kolibrios-fun/programs/develop/oberon07/Source/PROG.ob07

(*
    BSD 2-Clause License

    Copyright (c) 2018-2020, Anton Krotov
    All rights reserved.
*)

MODULE PROG;

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


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;

    default32* =  2;  _default32* = default32 + 1;
    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;  _default64* = default64 + 1;
    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_oberon*    = 9;
    sf_noalign* = 10;

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

    STACK_FRAME = 2;


TYPE

    OPTIONS* = RECORD

        version*, stack*, ram*, rom*: INTEGER;
        pic*, lower*: 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)

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

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);
            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
    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* (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") OR LowerCase & (name.s = "system")) THEN
        item := program.sysunit
    END

    RETURN item
END getUnit;


PROCEDURE enterStTypes (unit: UNIT);


    PROCEDURE enter (unit: UNIT; name: SCAN.LEXSTR; _type: _TYPE);
    VAR
        ident: IDENT;
        upper: SCAN.LEXSTR;

    BEGIN
        IF LowerCase THEN
            ident := addIdent(unit, SCAN.enterid(name), idTYPE);
            ident._type := _type
        END;
        upper := name;
        STRINGS.UpCase(upper);
        ident := addIdent(unit, SCAN.enterid(upper), 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 EnterProc (unit: UNIT; name: SCAN.LEXSTR; proc: INTEGER);
    VAR
        ident: IDENT;
        upper: SCAN.LEXSTR;

    BEGIN
        IF LowerCase THEN
            ident := addIdent(unit, SCAN.enterid(name), idSTPROC);
            ident.stproc := proc;
            ident._type := program.stTypes.tNONE
        END;
        upper := name;
        STRINGS.UpCase(upper);
        ident := addIdent(unit, SCAN.enterid(upper), idSTPROC);
        ident.stproc := proc;
        ident._type := program.stTypes.tNONE
    END EnterProc;


    PROCEDURE EnterFunc (unit: UNIT; name: SCAN.LEXSTR; func: INTEGER);
    VAR
        ident: IDENT;
        upper: SCAN.LEXSTR;

    BEGIN
        IF LowerCase THEN
            ident := addIdent(unit, SCAN.enterid(name), idSTFUNC);
            ident.stproc := func;
            ident._type := program.stTypes.tNONE
        END;
        upper := name;
        STRINGS.UpCase(upper);
        ident := addIdent(unit, SCAN.enterid(upper), idSTFUNC);
        ident.stproc := func;
        ident._type := program.stTypes.tNONE
    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* (name: SCAN.IDENT): UNIT;
VAR
    unit: UNIT;

BEGIN
    ASSERT(name # NIL);

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


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

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


BEGIN
    unit := newUnit(SCAN.enterid("$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);
           (*
    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
            ident := addIdent(unit, SCAN.enterid("card32"), idTYPE);
            ident._type := program.stTypes.tCARD32;
            ident.export := TRUE
        END;
        ident := addIdent(unit, SCAN.enterid("CARD32"), 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_ccall, sf_ccall16, sf_noalign}
    |TARGETS.osLINUX32:  program.sysflags := {sf_oberon, sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
    |TARGETS.osKOS:      program.sysflags := {sf_oberon, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
    |TARGETS.osWIN64:    program.sysflags := {sf_oberon, sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
    |TARGETS.osLINUX64:  program.sysflags := {sf_oberon, sf_linux, sf_stdcall64, sf_win64, sf_systemv, 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);
        program.stTypes.tREAL.align := TARGETS.RealSize
    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.