Subversion Repositories Kolibri OS

(*

    BSD 2-Clause License

    Copyright (c) 2018-2019, Anton Krotov

    All rights reserved.

*)

MODULE PROG;

IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS;

CONST

    MAXARRDIM*    = 5;

    MAXSCOPE      = 16;

    MAXSYSVPARAM* = 26;

    idNONE*    =  0;  idGUARD   =  1;  idMODULE* =  2;  idCONST*   =  3;

    idTYPE*    =  4;  idSTFUNC* =  5;  idSTPROC* =  6;  idVAR*     =  7;

    idPROC*    =  8;  idVPAR*   =  9;  idPARAM*  = 10;  idSYSFUNC* = 11;

    idSYSPROC* = 12;  idIMP*    = 13;

    tINTEGER* =  1;  tBYTE*      =  2;  tCHAR*   =  3;  tSET*    =  4;

    tBOOLEAN* =  5;  tREAL*      =  6;  tARRAY*  =  7;  tRECORD* =  8;

    tPOINTER* =  9;  tPROCEDURE* = 10;  tSTRING* = 11;  tNIL*    = 12;

    tCARD32*  = 13;  tANYREC*    = 14;  tWCHAR*  = 15;

    BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD32, tWCHAR};

    stABS*  =  1;  stASR*  =  2;  stCHR*    =  3;  stFLOOR* =  4;

    stFLT*  =  5;  stLEN*  =  6;  stLSL*    =  7;  stODD*   =  8;

    stORD*  =  9;  stROR*  = 10;  stASSERT* = 11;  stDEC*   = 12;

    stEXCL* = 13;  stINC*  = 14;  stINCL*   = 15;  stNEW*   = 16;

    stPACK* = 17;  stUNPK* = 18;  sysADR*   = 19;  sysSIZE* = 20;

    sysGET* = 21;  sysPUT* = 22;

    stDISPOSE* = 23;  stLSR*     = 24;  stBITS*  = 25;  sysCODE*  = 26;

    sysMOVE*   = 27;  stLENGTH*  = 28;  stMIN*   = 29;  stMAX*    = 30;

    sysSADR*   = 31;  sysTYPEID* = 32;  sysCOPY* = 33;  sysINF*   = 34;

    sysPUT8*   = 35;  sysPUT16*  = 36;  stCOPY*  = 37;  stWCHR*   = 38;

    sysWSADR*  = 39;  sysPUT32*  = 40;  (*sysNOP*  = 41;  sysEINT*  = 42;

    sysDINT*   = 43;*)

    default32* =  2;

    stdcall*   =  4;  _stdcall*   = stdcall + 1;

    ccall*     =  6;  _ccall*     = ccall + 1;

    ccall16*   =  8;  _ccall16*   = ccall16 + 1;

    win64*     = 10;  _win64*     = win64 + 1;

    stdcall64* = 12;  _stdcall64* = stdcall64 + 1;

    default64* = 14;

    systemv*   = 16;  _systemv*   = systemv + 1;

    default16* = 18;

    code*      = 20;  _code*      = code + 1;

    noalign* = 22;

    callee_clean_up* = {default32, stdcall, _stdcall, default64, stdcall64, _stdcall64};

    sf_stdcall* = 0; sf_stdcall64* = 1; sf_ccall*   = 2; sf_ccall16* = 3;

    sf_win64*   = 4; sf_systemv*   = 5; sf_windows* = 6; sf_linux*   = 7;

    sf_code*    = 8;

    sf_noalign* = 9;

    proc_flags* = {sf_stdcall, sf_stdcall64, sf_ccall, sf_ccall16, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code};

    rec_flags*  = {sf_noalign};

    STACK_FRAME = 2;

TYPE

    OPTIONS* = RECORD

        version*, stack*, ram*, rom*: INTEGER;

        pic*: BOOLEAN;

        checking*: SET

    END;

    IDENT* = POINTER TO rIDENT;

    UNIT* = POINTER TO rUNIT;

    PROGRAM* = POINTER TO rPROGRAM;

    TYPE_* = POINTER TO rTYPE_;

    FRWPTR* = POINTER TO RECORD (LISTS.ITEM)

        type:        TYPE_;

        baseIdent:   SCAN.IDENT;

        linked:      BOOLEAN;

        pos*:        SCAN.POSITION;

        notRecord*:  BOOLEAN

    END;

    PROC* = POINTER TO RECORD (LISTS.ITEM)

        label*:      INTEGER;

        used*:       BOOLEAN;

        processed*:  BOOLEAN;

        import*:     LISTS.ITEM;

        using*:      LISTS.LIST;

        enter*,

        leave*:      LISTS.ITEM

    END;

    USED_PROC = POINTER TO RECORD (LISTS.ITEM)

        proc: PROC

    END;

    rUNIT = RECORD (LISTS.ITEM)

        program*:    PROGRAM;

        name*:       SCAN.IDENT;

        idents*:     LISTS.LIST;

        frwPointers: LISTS.LIST;

        gscope:      IDENT;

        closed*:     BOOLEAN;

        scopeLvl*:   INTEGER;

        sysimport*:  BOOLEAN;

        scopes*:     ARRAY MAXSCOPE OF PROC

    END;

    FIELD* = POINTER TO rFIELD;

    PARAM* = POINTER TO rPARAM;

    rTYPE_ = RECORD (LISTS.ITEM)

        typ*:        INTEGER;

        size*:       INTEGER;

        parSize*:    INTEGER;

        length*:     INTEGER;

        align*:      INTEGER;

        base*:       TYPE_;

        fields*:     LISTS.LIST;

        params*:     LISTS.LIST;

        unit*:       UNIT;

        closed*:     BOOLEAN;

        num*:        INTEGER;

        call*:       INTEGER;

        import*:     BOOLEAN;

        noalign*:    BOOLEAN

    END;

    rFIELD = RECORD (LISTS.ITEM)

        type*:       TYPE_;

        name*:       SCAN.IDENT;

        export*:     BOOLEAN;

        offset*:     INTEGER

    END;

    rPARAM = RECORD (LISTS.ITEM)

        name*:       SCAN.IDENT;

        type*:       TYPE_;

        vPar*:       BOOLEAN;

        offset*:     INTEGER

    END;

    rIDENT = RECORD (LISTS.ITEM)

        name*:       SCAN.IDENT;

        typ*:        INTEGER;

        export*:     BOOLEAN;

        import*:     LISTS.ITEM;

        unit*:       UNIT;

        value*:      ARITH.VALUE;

        type*:       TYPE_;

        stproc*:     INTEGER;

        global*:     BOOLEAN;

        scopeLvl*:   INTEGER;

        offset*:     INTEGER;

        proc*:       PROC;

        pos*:        SCAN.POSITION

    END;

    rPROGRAM = RECORD

        recCount:    INTEGER;

        units*:      LISTS.LIST;

        types*:      LISTS.LIST;

        sysunit*:    UNIT;

        rtl*:        UNIT;

        bss*:        INTEGER;

        locsize*:    INTEGER;

        procs*:      LISTS.LIST;

        sysflags*:   SET;

        options*:    OPTIONS;

        stTypes*:    RECORD

            tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*,

            tSTRING*, tNIL*, tCARD32*, tANYREC*: TYPE_

        END

    END;

    DELIMPORT = PROCEDURE (import: LISTS.ITEM);

VAR

    idents: C.COLLECTION;

PROCEDURE NewIdent (): IDENT;

VAR

    ident: IDENT;

    citem: C.ITEM;

BEGIN

    citem := C.pop(idents);

    IF citem = NIL THEN

        NEW(ident)

    ELSE

        ident := citem(IDENT)

    END

    RETURN ident

END NewIdent;

PROCEDURE getOffset* (program: PROGRAM; varIdent: IDENT): INTEGER;

VAR

    size: INTEGER;

BEGIN

    IF varIdent.offset = -1 THEN

        size := varIdent.type.size;

        IF varIdent.global THEN

            IF UTILS.Align(program.bss, varIdent.type.align) THEN

                IF UTILS.maxint - program.bss >= size THEN

                    varIdent.offset := program.bss;

                    INC(program.bss, size)

                END

            END

        ELSE

            IF UTILS.Align(size, TARGETS.WordSize) THEN

                size := size DIV TARGETS.WordSize;

                IF UTILS.maxint - program.locsize >= size THEN

                    INC(program.locsize, size);

                    varIdent.offset := program.locsize

                END

            END

        END;

        IF varIdent.offset = -1 THEN

            ERRORS.Error(204)

        END

    END

    RETURN varIdent.offset

END getOffset;

PROCEDURE closeUnit* (unit: UNIT);

VAR

    ident, prev: IDENT;

    offset: INTEGER;

BEGIN

    ident := unit.idents.last(IDENT);

    WHILE (ident # NIL) & (ident.typ # idGUARD) DO

        IF (ident.typ = idVAR) & (ident.offset = -1) THEN

            ERRORS.HintMsg(ident.name.s, ident.pos.line, ident.pos.col, 0);

            IF ident.export THEN

                offset := getOffset(unit.program, ident)

            END

        END;

        ident := ident.prev(IDENT)

    END;

    ident := unit.idents.last(IDENT);

    WHILE ident # NIL DO

        prev := ident.prev(IDENT);

        IF ~ident.export THEN

            LISTS.delete(unit.idents, ident);

            C.push(idents, ident)

        END;

        ident := prev

    END;

    unit.closed := TRUE

END closeUnit;

PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;

VAR

    item: IDENT;

BEGIN

    ASSERT(ident # NIL);

    item := unit.idents.last(IDENT);

    WHILE (item.typ # idGUARD) & (item.name # ident) DO

        item := item.prev(IDENT)

    END

    RETURN item.typ = idGUARD

END unique;

PROCEDURE addIdent* (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;

VAR

    item:  IDENT;

    res:   BOOLEAN;

    proc:  PROC;

    procs: LISTS.LIST;

BEGIN

    ASSERT(unit # NIL);

    ASSERT(ident # NIL);

    res := unique(unit, ident);

    IF res THEN

        item := NewIdent();

        item.name   := ident;

        item.typ    := typ;

        item.unit   := NIL;

        item.export := FALSE;

        item.import := NIL;

        item.type   := NIL;

        item.value.typ := 0;

        item.stproc := 0;

        item.global := unit.scopeLvl = 0;

        item.scopeLvl := unit.scopeLvl;

        item.offset := -1;

        IF item.typ IN {idPROC, idIMP} THEN

            NEW(proc);

            proc.import := NIL;

            proc.label := 0;

            proc.used := FALSE;

            proc.processed := FALSE;

            proc.using := LISTS.create(NIL);

            procs := unit.program.procs;

            LISTS.push(procs, proc);

            item.proc := proc

        END;

        LISTS.push(unit.idents, item)

    ELSE

        item := NIL

    END

    RETURN item

END addIdent;

PROCEDURE UseProc* (unit: UNIT; call_proc: PROC);

VAR

    procs: LISTS.LIST;

    cur:   LISTS.ITEM;

    proc:  USED_PROC;

BEGIN

    IF unit.scopeLvl = 0 THEN

        call_proc.used := TRUE

    ELSE

        procs := unit.scopes[unit.scopeLvl].using;

        cur := procs.first;

        WHILE (cur # NIL) & (cur(USED_PROC).proc # call_proc) DO

            cur := cur.next

        END;

        IF cur = NIL THEN

            NEW(proc);

            proc.proc := call_proc;

            LISTS.push(procs, proc)

        END

    END

END UseProc;

PROCEDURE setVarsType* (unit: UNIT; type: TYPE_);

VAR

    item: IDENT;

BEGIN

    ASSERT(type # NIL);

    item := unit.idents.last(IDENT);

    WHILE (item # NIL) & (item.typ = idVAR) & (item.type = NIL) DO

        item.type := type;

        item := item.prev(IDENT)

    END

END setVarsType;

PROCEDURE getIdent* (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;

VAR

    item: IDENT;

BEGIN

    ASSERT(ident # NIL);

    item := unit.idents.last(IDENT);

    IF item # NIL THEN

        IF currentScope THEN

            WHILE (item.name # ident) & (item.typ # idGUARD) DO

                item := item.prev(IDENT)

            END;

            IF item.name # ident THEN

                item := NIL

            END

        ELSE

            WHILE (item # NIL) & (item.name # ident) DO

                item := item.prev(IDENT)

            END

        END

    END

    RETURN item

END getIdent;

PROCEDURE openScope* (unit: UNIT; proc: PROC): BOOLEAN;

VAR

    item: IDENT;

    res:  BOOLEAN;

BEGIN

    INC(unit.scopeLvl);

    res := unit.scopeLvl < MAXSCOPE;

    IF res THEN

        unit.scopes[unit.scopeLvl] := proc;

        NEW(item);

        item := NewIdent();

        item.name := NIL;

        item.typ  := idGUARD;

        LISTS.push(unit.idents, item)

    END

    RETURN res

END openScope;

PROCEDURE closeScope* (unit: UNIT; variables: LISTS.LIST);

VAR

    item: IDENT;

    del:  IDENT;

    lvar: IL.LOCALVAR;

BEGIN

    item := unit.idents.last(IDENT);

    WHILE (item # NIL) & (item.typ # idGUARD) DO

        del  := item;

        item := item.prev(IDENT);

        IF (del.typ = idVAR) & (del.offset = -1) THEN

            ERRORS.HintMsg(del.name.s, del.pos.line, del.pos.col, 0)

        END;

        IF (variables # NIL) & (del.typ IN {idVAR, idPARAM}) & (del.offset # -1) THEN

            IF del.type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN

                lvar := IL.NewVar();

                lvar.offset := del.offset;

                lvar.size   := del.type.size;

                IF del.typ = idVAR THEN

                    lvar.offset := -lvar.offset

                END;

                LISTS.push(variables, lvar)

            END

        END;

        LISTS.delete(unit.idents, del);

        C.push(idents, del)

    END;

    IF (item # NIL) & (item.typ = idGUARD) THEN

        LISTS.delete(unit.idents, item);

        C.push(idents, item)

    END;

    DEC(unit.scopeLvl)

END closeScope;

PROCEDURE frwPtr* (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);

VAR

    newptr: FRWPTR;

BEGIN

    ASSERT(unit # NIL);

    ASSERT(type # NIL);

    ASSERT(baseIdent # NIL);

    NEW(newptr);

    newptr.type      := type;

    newptr.baseIdent := baseIdent;

    newptr.pos       := pos;

    newptr.linked    := FALSE;

    newptr.notRecord := FALSE;

    LISTS.push(unit.frwPointers, newptr)

END frwPtr;

PROCEDURE linkPtr* (unit: UNIT): FRWPTR;

VAR

    item:  FRWPTR;

    ident: IDENT;

    res:   FRWPTR;

BEGIN

    res  := NIL;

    item := unit.frwPointers.last(FRWPTR);

    WHILE (item # NIL) & ~item.linked & (res = NIL) DO

        ident := getIdent(unit, item.baseIdent, TRUE);

        IF (ident # NIL) THEN

            IF (ident.typ = idTYPE) & (ident.type.typ = tRECORD) THEN

                item.type.base := ident.type;

                item.linked := TRUE

            ELSE

                item.notRecord := TRUE;

                res := item

            END

        ELSE

            item.notRecord := FALSE;

            res := item

        END;

        item := item.prev(FRWPTR)

    END

    RETURN res

END linkPtr;

PROCEDURE isTypeEq* (t1, t2: TYPE_): BOOLEAN;

VAR

    res: BOOLEAN;

    param1, param2: LISTS.ITEM;

BEGIN

    IF t1 = t2 THEN

        res := TRUE

    ELSIF (t1 = NIL) OR (t2 = NIL) THEN

        res := FALSE

    ELSIF (t1.typ = tPROCEDURE) & (t2.typ = tPROCEDURE) THEN

        param1 := t1.params.first;

        param2 := t2.params.first;

        res := ((t1.call = t2.call) OR (t1.call IN {code, _code}) OR (t2.call IN {code, _code})) & ((param1 # NIL) = (param2 # NIL));

        WHILE res & (param1 # NIL) & (param2 # NIL) DO

            res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM).type, param2(PARAM).type);

            param1 := param1.next;

            param2 := param2.next;

            res := res & ((param1 # NIL) = (param2 # NIL))

        END;

        res := res & isTypeEq(t1.base, t2.base)

    ELSIF (t1.typ = tARRAY) & (t2.typ = tARRAY) THEN

        res := (t1.length = 0) & (t2.length = 0) & isTypeEq(t1.base, t2.base)

    ELSE

        res := FALSE

    END

    RETURN res

END isTypeEq;

PROCEDURE isBaseOf* (t0, t1: TYPE_): BOOLEAN;

VAR

    res: BOOLEAN;

BEGIN

    res := (t0.typ = t1.typ) & (t0.typ IN {tPOINTER, tRECORD});

    IF res & (t0.typ = tPOINTER) THEN

        t0 := t0.base;

        t1 := t1.base

    END;

    IF res THEN

        WHILE (t1 # NIL) & (t1 # t0) DO

            t1 := t1.base

        END;

        res := t1 # NIL

    END

    RETURN res

END isBaseOf;

PROCEDURE isOpenArray* (t: TYPE_): BOOLEAN;

    RETURN (t.typ = tARRAY) & (t.length = 0)

END isOpenArray;

PROCEDURE arrcomp* (src, dst: TYPE_): BOOLEAN;

    RETURN (dst.typ = tARRAY) & isOpenArray(src) &

            ~isOpenArray(src.base) & ~isOpenArray(dst.base) &

            isTypeEq(src.base, dst.base)

END arrcomp;

PROCEDURE getUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;

VAR

    item: UNIT;

BEGIN

    ASSERT(name # NIL);

    item := program.units.first(UNIT);

    WHILE (item # NIL) & (item.name # name) DO

        item := item.next(UNIT)

    END;

    IF (item = NIL) & (name.s = "SYSTEM") THEN

        item := program.sysunit

    END

    RETURN item

END getUnit;

PROCEDURE enterStTypes (unit: UNIT; program: PROGRAM);

VAR

    ident: IDENT;

BEGIN

    ident      := addIdent(unit, SCAN.enterid("INTEGER"), idTYPE);

    ident.type := program.stTypes.tINTEGER;

    ident      := addIdent(unit, SCAN.enterid("BYTE"), idTYPE);

    ident.type := program.stTypes.tBYTE;

    ident      := addIdent(unit, SCAN.enterid("CHAR"), idTYPE);

    ident.type := program.stTypes.tCHAR;

    ident      := addIdent(unit, SCAN.enterid("SET"), idTYPE);

    ident.type := program.stTypes.tSET;

    ident      := addIdent(unit, SCAN.enterid("BOOLEAN"), idTYPE);

    ident.type := program.stTypes.tBOOLEAN;

    IF TARGETS.RealSize # 0 THEN

        ident      := addIdent(unit, SCAN.enterid("REAL"), idTYPE);

        ident.type := program.stTypes.tREAL

    END;

    IF TARGETS.BitDepth >= 32 THEN

        ident      := addIdent(unit, SCAN.enterid("WCHAR"), idTYPE);

        ident.type := program.stTypes.tWCHAR

    END

END enterStTypes;

PROCEDURE enterStProcs (unit: UNIT);

    PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; proc: INTEGER);

    VAR

        ident: IDENT;

    BEGIN

        ident := addIdent(unit, SCAN.enterid(name), idSTPROC);

        ident.stproc := proc

    END EnterProc;

    PROCEDURE EnterFunc (unit: UNIT; name: SCAN.LEXSTR; func: INTEGER);

    VAR

        ident: IDENT;

    BEGIN

        ident := addIdent(unit, SCAN.enterid(name), idSTFUNC);

        ident.stproc := func

    END EnterFunc;

BEGIN

    EnterProc(unit, "ASSERT", stASSERT);

    EnterProc(unit, "DEC",    stDEC);

    EnterProc(unit, "EXCL",   stEXCL);

    EnterProc(unit, "INC",    stINC);

    EnterProc(unit, "INCL",   stINCL);

    EnterProc(unit, "NEW",    stNEW);

    EnterProc(unit, "COPY",   stCOPY);

    EnterFunc(unit, "ABS",    stABS);

    EnterFunc(unit, "ASR",    stASR);

    EnterFunc(unit, "CHR",    stCHR);

    EnterFunc(unit, "LEN",    stLEN);

    EnterFunc(unit, "LSL",    stLSL);

    EnterFunc(unit, "ODD",    stODD);

    EnterFunc(unit, "ORD",    stORD);

    EnterFunc(unit, "ROR",    stROR);

    EnterFunc(unit, "BITS",   stBITS);

    EnterFunc(unit, "LSR",    stLSR);

    EnterFunc(unit, "LENGTH", stLENGTH);

    EnterFunc(unit, "MIN",    stMIN);

    EnterFunc(unit, "MAX",    stMAX);

    IF TARGETS.RealSize # 0 THEN

        EnterProc(unit, "PACK",  stPACK);

        EnterProc(unit, "UNPK",  stUNPK);

        EnterFunc(unit, "FLOOR", stFLOOR);

        EnterFunc(unit, "FLT",   stFLT)

    END;

    IF TARGETS.BitDepth >= 32 THEN

        EnterFunc(unit, "WCHR", stWCHR)

    END;

    IF TARGETS.Dispose THEN

        EnterProc(unit, "DISPOSE", stDISPOSE)

    END

END enterStProcs;

PROCEDURE newUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;

VAR

    unit: UNIT;

BEGIN

    ASSERT(program # NIL);

    ASSERT(name # NIL);

    NEW(unit);

    unit.program     := program;

    unit.name        := name;

    unit.closed      := FALSE;

    unit.idents      := LISTS.create(NIL);

    unit.frwPointers := LISTS.create(NIL);

    ASSERT(openScope(unit, NIL));

    enterStTypes(unit, program);

    enterStProcs(unit);

    ASSERT(openScope(unit, NIL));

    unit.gscope := unit.idents.last(IDENT);

    LISTS.push(program.units, unit);

    unit.scopeLvl := 0;

    unit.scopes[0] := NIL;

    unit.sysimport := FALSE;

    IF unit.name.s = UTILS.RTL_NAME THEN

        program.rtl := unit

    END

    RETURN unit

END newUnit;

PROCEDURE getField* (self: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;

VAR

    field: FIELD;

BEGIN

    ASSERT(self # NIL);

    ASSERT(name # NIL);

    ASSERT(unit # NIL);

    field := NIL;

    WHILE (self # NIL) & (field = NIL) DO

        field := self.fields.first(FIELD);

        WHILE (field # NIL) & (field.name # name) DO

            field := field.next(FIELD)

        END;

        IF field = NIL THEN

            self := self.base

        END

    END;

    IF (field # NIL) & (self.unit # unit) & ~field.export THEN

        field := NIL

    END

    RETURN field

END getField;

PROCEDURE addField* (self: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;

VAR

    field: FIELD;

    res:   BOOLEAN;

BEGIN

    ASSERT(name # NIL);

    res := getField(self, name, self.unit) = NIL;

    IF res THEN

        NEW(field);

        field.name   := name;

        field.export := export;

        field.type   := NIL;

        field.offset := self.size;

        LISTS.push(self.fields, field)

    END

    RETURN res

END addField;

PROCEDURE setFields* (self: TYPE_; type: TYPE_): BOOLEAN;

VAR

    item: FIELD;

    res:  BOOLEAN;

BEGIN

    ASSERT(type # NIL);

    item := self.fields.first(FIELD);

    WHILE (item # NIL) & (item.type # NIL) DO

        item := item.next(FIELD)

    END;

    res := TRUE;

    WHILE res & (item # NIL) & (item.type = NIL) DO

        item.type := type;

        IF ~self.noalign THEN

            res := UTILS.Align(self.size, type.align)

        ELSE

            res := TRUE

        END;

        item.offset := self.size;

        res := res & (UTILS.maxint - self.size >= type.size);

        IF res THEN

            INC(self.size, type.size)

        END;

        item := item.next(FIELD)

    END

    RETURN res

END setFields;

PROCEDURE getParam* (self: TYPE_; name: SCAN.IDENT): PARAM;

VAR

    item: PARAM;

BEGIN

    ASSERT(name # NIL);

    item := self.params.first(PARAM);

    WHILE (item # NIL) & (item.name # name) DO

        item := item.next(PARAM)

    END

    RETURN item

END getParam;

PROCEDURE addParam* (self: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;

VAR

    param: PARAM;

    res:   BOOLEAN;

BEGIN

    ASSERT(name # NIL);

    res := getParam(self, name) = NIL;

    IF res THEN

        NEW(param);

        param.name := name;

        param.type := NIL;

        param.vPar := vPar;

        LISTS.push(self.params, param)

    END

    RETURN res

END addParam;

PROCEDURE Dim* (t: TYPE_): INTEGER;

VAR

    res: INTEGER;

BEGIN

    res := 0;

    WHILE isOpenArray(t) DO

        t := t.base;

        INC(res)

    END

    RETURN res

END Dim;

PROCEDURE OpenBase* (t: TYPE_): TYPE_;

BEGIN

    WHILE isOpenArray(t) DO t := t.base END

    RETURN t

END OpenBase;

PROCEDURE getFloatParamsPos* (self: TYPE_; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;

VAR

    res: SET;

    param: PARAM;

BEGIN

    res := {};

    int := 0;

    flt := 0;

    param := self.params.first(PARAM);

    WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO

        IF ~param.vPar & (param.type.typ = tREAL) THEN

            INCL(res, param.offset - STACK_FRAME);

            INC(flt)

        END;

        param := param.next(PARAM)

    END;

    int := self.parSize - flt

    RETURN res

END getFloatParamsPos;

PROCEDURE setParams* (self: TYPE_; type: TYPE_);

VAR

    item: LISTS.ITEM;

    param: PARAM;

    word, size: INTEGER;

BEGIN

    ASSERT(type # NIL);

    word := UTILS.target.bit_depth DIV 8;

    item := self.params.first;

    WHILE (item # NIL) & (item(PARAM).type # NIL) DO

        item := item.next

    END;

    WHILE (item # NIL) & (item(PARAM).type = NIL) DO

        param := item(PARAM);

        param.type := type;

        IF param.vPar THEN

            IF type.typ = tRECORD THEN

                size := 2

            ELSIF isOpenArray(type) THEN

                size := Dim(type) + 1

            ELSE

                size := 1

            END;

            param.offset := self.parSize + ORD(type.typ = tRECORD) + Dim(type) + STACK_FRAME;

            INC(self.parSize, size)

        ELSE

            IF type.typ IN {tRECORD, tARRAY} THEN

                IF isOpenArray(type) THEN

                    size := Dim(type) + 1

                ELSE

                    size := 1

                END

            ELSE

                size := type.size;

                ASSERT(UTILS.Align(size, word));

                size := size DIV word

            END;

            param.offset := self.parSize + Dim(type) + STACK_FRAME;

            INC(self.parSize, size)

        END;

        item := item.next

    END

END setParams;

PROCEDURE enterType* (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;

VAR

    t: TYPE_;

BEGIN

    NEW(t);

    t.typ     := typ;

    t.size    := size;

    t.length  := length;

    t.align   := 0;

    t.base    := NIL;

    t.fields  := LISTS.create(NIL);

    t.params  := LISTS.create(NIL);

    t.unit    := unit;

    t.num     := 0;

    CASE TARGETS.BitDepth OF

    |16: t.call := default16

    |32: t.call := default32

    |64: t.call := default64

    END;

    t.import  := FALSE;

    t.noalign := FALSE;

    t.parSize := 0;

    IF typ IN {tARRAY, tRECORD} THEN

        t.closed := FALSE;

        IF typ = tRECORD THEN

            INC(program.recCount);

            t.num := program.recCount

        END

    ELSE

        t.closed := TRUE

    END;

    LISTS.push(program.types, t)

    RETURN t

END enterType;

PROCEDURE getType* (program: PROGRAM; typ: INTEGER): TYPE_;

VAR

    res: TYPE_;

BEGIN

    CASE typ OF

    |ARITH.tINTEGER: res := program.stTypes.tINTEGER

    |ARITH.tREAL:    res := program.stTypes.tREAL

    |ARITH.tSET:     res := program.stTypes.tSET

    |ARITH.tBOOLEAN: res := program.stTypes.tBOOLEAN

    |ARITH.tCHAR:    res := program.stTypes.tCHAR

    |ARITH.tWCHAR:   res := program.stTypes.tWCHAR

    |ARITH.tSTRING:  res := program.stTypes.tSTRING

    END

    RETURN res

END getType;

PROCEDURE createSysUnit (program: PROGRAM);

VAR

    ident: IDENT;

    unit:  UNIT;

    PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);

    VAR

        ident: IDENT;

    BEGIN

        ident := addIdent(sys, SCAN.enterid(name), idtyp);

        ident.stproc := proc;

        ident.export := TRUE

    END EnterProc;