ruberon/source/PROG.ob07

MODULE PROG;

IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS IN "./utils/UTILS.ob07", 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*, PE32FileAlignment*: 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;


        PROCEDURE EnterProc (sys: UNIT; nameStr: SCAN.IDSTR; idtyp, proc: INTEGER);
        VAR
            ident: IDENT;
            upper: SCAN.IDSTR;
            name:  SCAN.IDENT;

        BEGIN
            IF LowerCase THEN
                SCAN.setIdent(name, nameStr);
                ident := addIdent(sys, name, idtyp);
                ident.stproc := proc;
                ident._type := program.stTypes.tNONE;
                ident.export := TRUE
            END;
            upper := nameStr;
            STRINGS.UpCase(upper);
            SCAN.setIdent(name, upper);
            ident := addIdent(sys, name, idtyp);
            ident.stproc := proc;
            ident._type := program.stTypes.tNONE;
            ident.export := TRUE
        END EnterProc;


    BEGIN
        SCAN.setIdent(name, "$SYSTEM");
        unit := newUnit(name);
        unit.fname := "SYSTEM";

        EnterProc(unit, "adr",    idSYSFUNC, sysADR);
        EnterProc(unit, "size",   idSYSFUNC, sysSIZE);
        EnterProc(unit, "sadr",   idSYSFUNC, sysSADR);
        EnterProc(unit, "typeid", idSYSFUNC, sysTYPEID);

        EnterProc(unit, "get",    idSYSPROC, sysGET);
        EnterProc(unit, "get8",   idSYSPROC, sysGET8);
        EnterProc(unit, "put",    idSYSPROC, sysPUT);
        EnterProc(unit, "put8",   idSYSPROC, sysPUT8);
        EnterProc(unit, "code",   idSYSPROC, sysCODE);
        EnterProc(unit, "move",   idSYSPROC, sysMOVE);
        EnterProc(unit, "val",    idSYSPROC, sysVAL);
            (*
        IF program.target.sys = mConst.Target_iMSP430 THEN
            EnterProc(unit, "nop",  idSYSPROC, sysNOP);
            EnterProc(unit, "eint", idSYSPROC, sysEINT);
            EnterProc(unit, "dint", idSYSPROC, sysDINT)
        END;
            *)
        IF TARGETS.RealSize # 0 THEN
            EnterProc(unit, "inf",    idSYSFUNC, sysINF);
        END;

        IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
            EnterProc(unit, "copy",   idSYSPROC, sysCOPY)
        END;

        IF TARGETS.BitDepth >= 32 THEN
            EnterProc(unit, "wsadr",  idSYSFUNC, sysWSADR);
            EnterProc(unit, "put16",  idSYSPROC, sysPUT16);
            EnterProc(unit, "put32",  idSYSPROC, sysPUT32);
            EnterProc(unit, "get16",  idSYSPROC, sysGET16);
            EnterProc(unit, "get32",  idSYSPROC, sysGET32);

            IF LowerCase THEN
                SCAN.setIdent(name, "card32");
                ident := addIdent(unit, name, idTYPE);
                ident._type := program.stTypes.tCARD32;
                ident.export := TRUE
            END;
            SCAN.setIdent(name, "CARD32");
            ident := addIdent(unit, name, idTYPE);
            ident._type := program.stTypes.tCARD32;
            ident.export := TRUE;
        END;

        closeUnit(unit);

        program.sysunit := unit
    END createSysUnit;


PROCEDURE DelUnused* (DelImport: DELIMPORT);
    VAR
        proc: PROC;
        flag: BOOLEAN;


        PROCEDURE process (proc: PROC);
        VAR
            used_proc: LISTS.ITEM;

        BEGIN
            proc.processed := TRUE;

            used_proc := proc.using.first;
            WHILE used_proc # NIL DO
                used_proc(USED_PROC).proc.used := TRUE;
                used_proc := used_proc.next
            END

        END process;


    BEGIN

        REPEAT
            flag := FALSE;
            proc := program.procs.first(PROC);

            WHILE proc # NIL DO
                IF proc.used & ~proc.processed THEN
                    process(proc);
                    flag := TRUE
                END;
                proc := proc.next(PROC)
            END

        UNTIL ~flag;

        proc := program.procs.first(PROC);

        WHILE proc # NIL DO
            IF ~proc.used THEN
                IF proc._import = NIL THEN
                    IL.delete2(proc.enter, proc.leave)
                ELSE
                    DelImport(proc._import)
                END
            END;
            proc := proc.next(PROC)
        END

    END DelUnused;


PROCEDURE ResetLocSize*;
    BEGIN
        program.locsize := 0
    END ResetLocSize;


PROCEDURE create* (options: OPTIONS);
    BEGIN
        LowerCase := options.lower;
        SCAN.init(options.lower);
        idents := C.create();

        UTILS.SetBitDepth(TARGETS.BitDepth, TARGETS.RealSize = 8);

        program.options := options;

        CASE TARGETS.OS OF
        |TARGETS.osWIN32:    program.sysflags := {sf_oberon, sf_windows, sf_stdcall, sf_cdecl, sf_ccall, sf_fastcall, sf_noalign}
        |TARGETS.osLINUX32:  program.sysflags := {sf_oberon, sf_linux, sf_stdcall, sf_cdecl, sf_ccall, sf_fastcall, sf_noalign}
        |TARGETS.osKOS:      program.sysflags := {sf_oberon, sf_stdcall, sf_cdecl, sf_ccall, sf_fastcall, sf_noalign}
        |TARGETS.osWIN64:    program.sysflags := {sf_oberon, sf_windows, sf_win64, sf_systemv, sf_ccall, sf_noalign}
        |TARGETS.osLINUX64:  program.sysflags := {sf_oberon, sf_linux, sf_win64, sf_systemv, sf_ccall, sf_noalign}
        |TARGETS.osNONE:     program.sysflags := {sf_code}
        END;

        program.recCount := -1;
        program.bss := 0;

        program.units := LISTS.create(NIL);
        program.types := LISTS.create(NIL);
        program.procs := LISTS.create(NIL);

        program.stTypes.tINTEGER := enterType(tINTEGER, TARGETS.WordSize, 0, NIL);
        program.stTypes.tBYTE    := enterType(tBYTE,                   1, 0, NIL);
        program.stTypes.tCHAR    := enterType(tCHAR,                   1, 0, NIL);
        program.stTypes.tSET     := enterType(tSET,     TARGETS.WordSize, 0, NIL);
        program.stTypes.tBOOLEAN := enterType(tBOOLEAN,                1, 0, NIL);

        program.stTypes.tINTEGER.align := TARGETS.WordSize;
        program.stTypes.tBYTE.align    := 1;
        program.stTypes.tCHAR.align    := 1;
        program.stTypes.tSET.align     := TARGETS.WordSize;
        program.stTypes.tBOOLEAN.align := 1;

        IF TARGETS.BitDepth >= 32 THEN
            program.stTypes.tWCHAR  := enterType(tWCHAR,  2, 0, NIL);
            program.stTypes.tCARD32 := enterType(tCARD32, 4, 0, NIL);
            program.stTypes.tWCHAR.align  := 2;
            program.stTypes.tCARD32.align := 4
        END;

        IF TARGETS.RealSize # 0 THEN
            program.stTypes.tREAL := enterType(tREAL, TARGETS.RealSize, 0, NIL);
            IF TARGETS.OS = TARGETS.osLINUX32 THEN
                program.stTypes.tREAL.align := 4
            ELSE
                program.stTypes.tREAL.align := TARGETS.RealSize
            END
        END;

        program.stTypes.tSTRING := enterType(tSTRING, TARGETS.WordSize, 0, NIL);
        program.stTypes.tNIL    := enterType(tNIL,    TARGETS.WordSize, 0, NIL);
        program.stTypes.tNONE   := enterType(tNONE,   0, 0, NIL);
        program.stTypes.tANYREC := enterType(tRECORD, 0, 0, NIL);
        program.stTypes.tANYREC.closed := TRUE;

        createSysUnit
    END create;


END PROG.