Subversion Repositories Kolibri OS

(*

    BSD 2-Clause License

    Copyright (c) 2018-2023, Anton Krotov

    All rights reserved.

*)

MODULE PROG;

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

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;  tNONE*   = 16;

    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;*)sysGET8*   = 44;  sysGET16* = 45;  sysGET32* = 46;

    sysVAL* = 47;

    default32* =  2;  _default32* = default32 + 1;

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

    cdecl*     =  6;  _cdecl*     = cdecl + 1;

    ccall*     =  8;  _ccall*     = ccall + 1;

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

    default64* = 12;  _default64* = default64 + 1;

    systemv*   = 14;  _systemv*   = systemv + 1;

    default16* = 16;  _default16* = default16 + 1;

    code*      = 18;  _code*      = code + 1;

    fastcall*  = 20;  _fastcall*  = fastcall + 1;

    noalign* = 22;

    callee_clean_up* = {default32, _default32, stdcall, _stdcall, default64, _default64, fastcall, _fastcall};

    sf_stdcall* =  0; sf_oberon*    = 1; sf_cdecl*   = 2; sf_ccall*  = 3;

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

    sf_code*    =  8; sf_fastcall*  = 9;

    sf_noalign* = 10;

    proc_flags* = {sf_stdcall, sf_cdecl, sf_ccall, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code, sf_oberon, sf_fastcall};

    rec_flags*  = {sf_noalign};

    STACK_FRAME = 2;

TYPE

    OPTIONS* = RECORD

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

        pic*, lower*, uses*: BOOLEAN;

        checking*: SET

    END;

    IDENT* = POINTER TO rIDENT;

    UNIT* = POINTER TO rUNIT;

    _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)

        fname*:      PATHS.PATH;

        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;

    PROGRAM = 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*, tNONE*: _TYPE

        END

    END;

    DELIMPORT = PROCEDURE (_import: LISTS.ITEM);

VAR

    LowerCase*: BOOLEAN;

    idents: C.COLLECTION;

    program*: PROGRAM;

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* (varIdent: IDENT): INTEGER;

VAR

    size, glob_align: INTEGER;

BEGIN

    IF varIdent.offset = -1 THEN

        size := varIdent._type.size;

        IF varIdent.global THEN

            IF TARGETS.WinLin THEN

                glob_align := 16

            ELSE

                glob_align := varIdent._type.align

            END;

            IF UTILS.Align(program.bss, glob_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(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 IdEq* (a, b: SCAN.IDENT): BOOLEAN;

    RETURN (a.hash = b.hash) & (a.s = b.s)

END IdEq;

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

VAR

    item: IDENT;

BEGIN

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

    WHILE (item.typ # idGUARD) & ~IdEq(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;

BEGIN

    ASSERT(unit # 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);

            LISTS.push(program.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

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

    IF item # NIL THEN

        IF currentScope THEN

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

                item := item.prev(IDENT)

            END;

            IF item.typ = idGUARD THEN

                item := NIL

            END

        ELSE

            WHILE (item # NIL) & ~IdEq(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.s := "";

        item.name.hash := 0;

        item.typ  := idGUARD;

        LISTS.push(unit.idents, item)

    END

    RETURN res

END openScope;

PROCEDURE closeScope* (unit: UNIT);

VAR

    item: IDENT;

    del:  IDENT;

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;

        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);

    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* (name: PATHS.PATH): UNIT;

VAR

    item: UNIT;

BEGIN

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

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

        item := item.next(UNIT)

    END;

    IF (item = NIL) & ((name = "SYSTEM") OR LowerCase & (name = "system")) THEN

        item := program.sysunit

    END

    RETURN item

END getUnit;

PROCEDURE enterStTypes (unit: UNIT);

    PROCEDURE enter (unit: UNIT; nameStr: SCAN.IDSTR; _type: _TYPE);

    VAR

        ident: IDENT;

        upper: SCAN.IDSTR;

        name:  SCAN.IDENT;

    BEGIN

        IF LowerCase THEN

            SCAN.setIdent(name, nameStr);

            ident := addIdent(unit, name, idTYPE);

            ident._type := _type

        END;

        upper := nameStr;

        STRINGS.UpCase(upper);

        SCAN.setIdent(name, upper);

        ident := addIdent(unit, name, idTYPE);

        ident._type := _type

    END enter;

BEGIN

    enter(unit, "integer", program.stTypes.tINTEGER);

    enter(unit, "byte",    program.stTypes.tBYTE);

    enter(unit, "char",    program.stTypes.tCHAR);

    enter(unit, "set",     program.stTypes.tSET);

    enter(unit, "boolean", program.stTypes.tBOOLEAN);

    IF TARGETS.RealSize # 0 THEN

        enter(unit, "real", program.stTypes.tREAL)

    END;

    IF TARGETS.BitDepth >= 32 THEN

        enter(unit, "wchar", program.stTypes.tWCHAR)

    END

END enterStTypes;

PROCEDURE enterStProcs (unit: UNIT);

    PROCEDURE Enter (unit: UNIT; nameStr: SCAN.IDSTR; nfunc, tfunc: INTEGER);

    VAR

        ident: IDENT;

        upper: SCAN.IDSTR;

        name:  SCAN.IDENT;

    BEGIN

        IF LowerCase THEN

            SCAN.setIdent(name, nameStr);

            ident := addIdent(unit, name, tfunc);

            ident.stproc := nfunc;

            ident._type := program.stTypes.tNONE

        END;

        upper := nameStr;

        STRINGS.UpCase(upper);

        SCAN.setIdent(name, upper);

        ident := addIdent(unit, name, tfunc);

        ident.stproc := nfunc;

        ident._type := program.stTypes.tNONE

    END Enter;

BEGIN

    Enter(unit, "assert", stASSERT, idSTPROC);

    Enter(unit, "dec",    stDEC,    idSTPROC);

    Enter(unit, "excl",   stEXCL,   idSTPROC);

    Enter(unit, "inc",    stINC,    idSTPROC);

    Enter(unit, "incl",   stINCL,   idSTPROC);

    Enter(unit, "new",    stNEW,    idSTPROC);

    Enter(unit, "copy",   stCOPY,   idSTPROC);

    Enter(unit, "abs",    stABS,    idSTFUNC);

    Enter(unit, "asr",    stASR,    idSTFUNC);

    Enter(unit, "chr",    stCHR,    idSTFUNC);

    Enter(unit, "len",    stLEN,    idSTFUNC);

    Enter(unit, "lsl",    stLSL,    idSTFUNC);

    Enter(unit, "odd",    stODD,    idSTFUNC);

    Enter(unit, "ord",    stORD,    idSTFUNC);

    Enter(unit, "ror",    stROR,    idSTFUNC);

    Enter(unit, "bits",   stBITS,   idSTFUNC);

    Enter(unit, "lsr",    stLSR,    idSTFUNC);

    Enter(unit, "length", stLENGTH, idSTFUNC);

    Enter(unit, "min",    stMIN,    idSTFUNC);

    Enter(unit, "max",    stMAX,    idSTFUNC);

    IF TARGETS.RealSize # 0 THEN

        Enter(unit, "pack",  stPACK,  idSTPROC);

        Enter(unit, "unpk",  stUNPK,  idSTPROC);

        Enter(unit, "floor", stFLOOR, idSTFUNC);

        Enter(unit, "flt",   stFLT,   idSTFUNC)

    END;

    IF TARGETS.BitDepth >= 32 THEN

        Enter(unit, "wchr", stWCHR, idSTFUNC)

    END;

    IF TARGETS.Dispose THEN

        Enter(unit, "dispose", stDISPOSE, idSTPROC)

    END

END enterStProcs;

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

VAR

    unit: UNIT;

BEGIN

    NEW(unit);

    unit.name        := name;

    unit.closed      := FALSE;

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

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

    ASSERT(openScope(unit, NIL));

    enterStTypes(unit);

    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(unit # NIL);

    field := NIL;

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

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

        WHILE (field # NIL) & ~IdEq(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

    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

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

    WHILE (item # NIL) & ~IdEq(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

    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* (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* (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;

VAR

    ident: IDENT;

    unit:  UNIT;

    name:  SCAN.IDENT;