Subversion Repositories Kolibri OS

Rev

Rev 8097 | Rev 9177 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed

  1. (*
  2.     BSD 2-Clause License
  3.  
  4.     Copyright (c) 2018-2021, Anton Krotov
  5.     All rights reserved.
  6. *)
  7.  
  8. MODULE PROG;
  9.  
  10. IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS, STRINGS, PATHS;
  11.  
  12.  
  13. CONST
  14.  
  15.     MAXARRDIM*    = 5;
  16.     MAXSCOPE      = 16;
  17.     MAXSYSVPARAM* = 26;
  18.  
  19.     idNONE*    =  0;  idGUARD   =  1;  idMODULE* =  2;  idCONST*   =  3;
  20.     idTYPE*    =  4;  idSTFUNC* =  5;  idSTPROC* =  6;  idVAR*     =  7;
  21.     idPROC*    =  8;  idVPAR*   =  9;  idPARAM*  = 10;  idSYSFUNC* = 11;
  22.     idSYSPROC* = 12;  idIMP*    = 13;
  23.  
  24.     tINTEGER* =  1;  tBYTE*      =  2;  tCHAR*   =  3;  tSET*    =  4;
  25.     tBOOLEAN* =  5;  tREAL*      =  6;  tARRAY*  =  7;  tRECORD* =  8;
  26.     tPOINTER* =  9;  tPROCEDURE* = 10;  tSTRING* = 11;  tNIL*    = 12;
  27.     tCARD32*  = 13;  tANYREC*    = 14;  tWCHAR*  = 15;  tNONE*   = 16;
  28.  
  29.     BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD32, tWCHAR};
  30.  
  31.     stABS*  =  1;  stASR*  =  2;  stCHR*    =  3;  stFLOOR* =  4;
  32.     stFLT*  =  5;  stLEN*  =  6;  stLSL*    =  7;  stODD*   =  8;
  33.     stORD*  =  9;  stROR*  = 10;  stASSERT* = 11;  stDEC*   = 12;
  34.     stEXCL* = 13;  stINC*  = 14;  stINCL*   = 15;  stNEW*   = 16;
  35.     stPACK* = 17;  stUNPK* = 18;  sysADR*   = 19;  sysSIZE* = 20;
  36.     sysGET* = 21;  sysPUT* = 22;
  37.  
  38.     stDISPOSE* = 23;  stLSR*     = 24;  stBITS*   = 25;  sysCODE*  = 26;
  39.     sysMOVE*   = 27;  stLENGTH*  = 28;  stMIN*    = 29;  stMAX*    = 30;
  40.     sysSADR*   = 31;  sysTYPEID* = 32;  sysCOPY*  = 33;  sysINF*   = 34;
  41.     sysPUT8*   = 35;  sysPUT16*  = 36;  stCOPY*   = 37;  stWCHR*   = 38;
  42.     sysWSADR*  = 39;  sysPUT32*  = 40;  (*sysNOP*   = 41;  sysEINT*  = 42;
  43.     sysDINT*   = 43;*)sysGET8*   = 44;  sysGET16* = 45;  sysGET32* = 46;
  44.  
  45.     default32* =  2;  _default32* = default32 + 1;
  46.     stdcall*   =  4;  _stdcall*   = stdcall + 1;
  47.     cdecl*     =  6;  _cdecl*     = cdecl + 1;
  48.     ccall*     =  8;  _ccall*     = ccall + 1;
  49.     win64*     = 10;  _win64*     = win64 + 1;
  50.     default64* = 12;  _default64* = default64 + 1;
  51.     systemv*   = 14;  _systemv*   = systemv + 1;
  52.     default16* = 16;  _default16* = default16 + 1;
  53.     code*      = 18;  _code*      = code + 1;
  54.  
  55.     noalign* = 22;
  56.  
  57.     callee_clean_up* = {default32, _default32, stdcall, _stdcall, default64, _default64};
  58.  
  59.     sf_stdcall* =  0; sf_oberon*    = 1; sf_cdecl*   = 2; sf_ccall*  = 3;
  60.     sf_win64*   =  4; sf_systemv*   = 5; sf_windows* = 6; sf_linux*  = 7;
  61.     sf_code*    =  8;
  62.     sf_noalign* =  9;
  63.  
  64.     proc_flags* = {sf_stdcall, sf_cdecl, sf_ccall, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code, sf_oberon};
  65.     rec_flags*  = {sf_noalign};
  66.  
  67.     STACK_FRAME = 2;
  68.  
  69.  
  70. TYPE
  71.  
  72.     OPTIONS* = RECORD
  73.  
  74.         version*, stack*, ram*, rom*: INTEGER;
  75.         pic*, lower*: BOOLEAN;
  76.         checking*: SET
  77.  
  78.     END;
  79.  
  80.     IDENT* = POINTER TO rIDENT;
  81.  
  82.     UNIT* = POINTER TO rUNIT;
  83.  
  84.     _TYPE* = POINTER TO rTYPE;
  85.  
  86.     FRWPTR* = POINTER TO RECORD (LISTS.ITEM)
  87.  
  88.         _type:       _TYPE;
  89.         baseIdent:   SCAN.IDENT;
  90.         linked:      BOOLEAN;
  91.  
  92.         pos*:        SCAN.POSITION;
  93.         notRecord*:  BOOLEAN
  94.  
  95.     END;
  96.  
  97.     PROC* = POINTER TO RECORD (LISTS.ITEM)
  98.  
  99.         label*:      INTEGER;
  100.         used*:       BOOLEAN;
  101.         processed*:  BOOLEAN;
  102.         _import*:    LISTS.ITEM;
  103.         using*:      LISTS.LIST;
  104.         enter*,
  105.         leave*:      LISTS.ITEM
  106.  
  107.     END;
  108.  
  109.     USED_PROC = POINTER TO RECORD (LISTS.ITEM)
  110.  
  111.         proc: PROC
  112.  
  113.     END;
  114.  
  115.     rUNIT = RECORD (LISTS.ITEM)
  116.  
  117.         fname*:      PATHS.PATH;
  118.         name*:       SCAN.IDENT;
  119.         idents*:     LISTS.LIST;
  120.         frwPointers: LISTS.LIST;
  121.         gscope:      IDENT;
  122.         closed*:     BOOLEAN;
  123.         scopeLvl*:   INTEGER;
  124.         sysimport*:  BOOLEAN;
  125.         scopes*:     ARRAY MAXSCOPE OF PROC
  126.  
  127.     END;
  128.  
  129.     FIELD* = POINTER TO rFIELD;
  130.  
  131.     PARAM* = POINTER TO rPARAM;
  132.  
  133.     rTYPE = RECORD (LISTS.ITEM)
  134.  
  135.         typ*:        INTEGER;
  136.         size*:       INTEGER;
  137.         parSize*:    INTEGER;
  138.         length*:     INTEGER;
  139.         align*:      INTEGER;
  140.         base*:       _TYPE;
  141.         fields*:     LISTS.LIST;
  142.         params*:     LISTS.LIST;
  143.         unit*:       UNIT;
  144.         closed*:     BOOLEAN;
  145.         num*:        INTEGER;
  146.         call*:       INTEGER;
  147.         _import*:    BOOLEAN;
  148.         noalign*:    BOOLEAN
  149.  
  150.     END;
  151.  
  152.     rFIELD = RECORD (LISTS.ITEM)
  153.  
  154.         _type*:      _TYPE;
  155.         name*:       SCAN.IDENT;
  156.         export*:     BOOLEAN;
  157.         offset*:     INTEGER
  158.  
  159.     END;
  160.  
  161.     rPARAM = RECORD (LISTS.ITEM)
  162.  
  163.         name*:       SCAN.IDENT;
  164.         _type*:      _TYPE;
  165.         vPar*:       BOOLEAN;
  166.         offset*:     INTEGER
  167.  
  168.     END;
  169.  
  170.     rIDENT = RECORD (LISTS.ITEM)
  171.  
  172.         name*:       SCAN.IDENT;
  173.         typ*:        INTEGER;
  174.         export*:     BOOLEAN;
  175.         _import*:    LISTS.ITEM;
  176.         unit*:       UNIT;
  177.         value*:      ARITH.VALUE;
  178.         _type*:      _TYPE;
  179.         stproc*:     INTEGER;
  180.         global*:     BOOLEAN;
  181.         scopeLvl*:   INTEGER;
  182.         offset*:     INTEGER;
  183.         proc*:       PROC;
  184.         pos*:        SCAN.POSITION
  185.  
  186.     END;
  187.  
  188.     PROGRAM = RECORD
  189.  
  190.         recCount:    INTEGER;
  191.         units*:      LISTS.LIST;
  192.         types*:      LISTS.LIST;
  193.         sysunit*:    UNIT;
  194.         rtl*:        UNIT;
  195.         bss*:        INTEGER;
  196.         locsize*:    INTEGER;
  197.  
  198.         procs*:      LISTS.LIST;
  199.  
  200.         sysflags*:   SET;
  201.         options*:    OPTIONS;
  202.  
  203.         stTypes*:    RECORD
  204.  
  205.             tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*,
  206.             tSTRING*, tNIL*, tCARD32*, tANYREC*, tNONE*: _TYPE
  207.  
  208.         END
  209.  
  210.     END;
  211.  
  212.     DELIMPORT = PROCEDURE (_import: LISTS.ITEM);
  213.  
  214.  
  215. VAR
  216.  
  217.     LowerCase*: BOOLEAN;
  218.     idents: C.COLLECTION;
  219.     program*: PROGRAM;
  220.  
  221.  
  222. PROCEDURE NewIdent (): IDENT;
  223. VAR
  224.     ident: IDENT;
  225.     citem: C.ITEM;
  226.  
  227. BEGIN
  228.     citem := C.pop(idents);
  229.     IF citem = NIL THEN
  230.         NEW(ident)
  231.     ELSE
  232.         ident := citem(IDENT)
  233.     END
  234.  
  235.     RETURN ident
  236. END NewIdent;
  237.  
  238.  
  239. PROCEDURE getOffset* (varIdent: IDENT): INTEGER;
  240. VAR
  241.     size: INTEGER;
  242.  
  243. BEGIN
  244.     IF varIdent.offset = -1 THEN
  245.         size := varIdent._type.size;
  246.         IF varIdent.global THEN
  247.             IF UTILS.Align(program.bss, varIdent._type.align) THEN
  248.                 IF UTILS.maxint - program.bss >= size THEN
  249.                     varIdent.offset := program.bss;
  250.                     INC(program.bss, size)
  251.                 END
  252.             END
  253.         ELSE
  254.             IF UTILS.Align(size, TARGETS.WordSize) THEN
  255.                 size := size DIV TARGETS.WordSize;
  256.                 IF UTILS.maxint - program.locsize >= size THEN
  257.                     INC(program.locsize, size);
  258.                     varIdent.offset := program.locsize
  259.                 END
  260.             END
  261.         END;
  262.  
  263.         IF varIdent.offset = -1 THEN
  264.             ERRORS.Error(204)
  265.         END
  266.     END
  267.  
  268.     RETURN varIdent.offset
  269. END getOffset;
  270.  
  271.  
  272. PROCEDURE closeUnit* (unit: UNIT);
  273. VAR
  274.     ident, prev: IDENT;
  275.     offset: INTEGER;
  276.  
  277. BEGIN
  278.     ident := unit.idents.last(IDENT);
  279.     WHILE (ident # NIL) & (ident.typ # idGUARD) DO
  280.         IF (ident.typ = idVAR) & (ident.offset = -1) THEN
  281.             ERRORS.HintMsg(ident.name.s, ident.pos.line, ident.pos.col, 0);
  282.             IF ident.export THEN
  283.                 offset := getOffset(ident)
  284.             END
  285.         END;
  286.         ident := ident.prev(IDENT)
  287.     END;
  288.  
  289.     ident := unit.idents.last(IDENT);
  290.     WHILE ident # NIL DO
  291.         prev := ident.prev(IDENT);
  292.         IF ~ident.export THEN
  293.             LISTS.delete(unit.idents, ident);
  294.             C.push(idents, ident)
  295.         END;
  296.         ident := prev
  297.     END;
  298.  
  299.     unit.closed := TRUE
  300. END closeUnit;
  301.  
  302.  
  303. PROCEDURE IdEq* (a, b: SCAN.IDENT): BOOLEAN;
  304.     RETURN (a.hash = b.hash) & (a.s = b.s)
  305. END IdEq;
  306.  
  307.  
  308. PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;
  309. VAR
  310.     item: IDENT;
  311.  
  312. BEGIN
  313.     item := unit.idents.last(IDENT);
  314.     WHILE (item.typ # idGUARD) & ~IdEq(item.name, ident) DO
  315.         item := item.prev(IDENT)
  316.     END
  317.  
  318.     RETURN item.typ = idGUARD
  319. END unique;
  320.  
  321.  
  322. PROCEDURE addIdent* (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
  323. VAR
  324.     item:  IDENT;
  325.     res:   BOOLEAN;
  326.     proc:  PROC;
  327.  
  328. BEGIN
  329.     ASSERT(unit # NIL);
  330.  
  331.     res := unique(unit, ident);
  332.  
  333.     IF res THEN
  334.         item := NewIdent();
  335.  
  336.         item.name    := ident;
  337.         item.typ     := typ;
  338.         item.unit    := NIL;
  339.         item.export  := FALSE;
  340.         item._import := NIL;
  341.         item._type   := NIL;
  342.         item.value.typ := 0;
  343.         item.stproc := 0;
  344.  
  345.         item.global := unit.scopeLvl = 0;
  346.         item.scopeLvl := unit.scopeLvl;
  347.         item.offset := -1;
  348.  
  349.         IF item.typ IN {idPROC, idIMP} THEN
  350.             NEW(proc);
  351.             proc._import := NIL;
  352.             proc.label := 0;
  353.             proc.used := FALSE;
  354.             proc.processed := FALSE;
  355.             proc.using := LISTS.create(NIL);
  356.             LISTS.push(program.procs, proc);
  357.             item.proc := proc
  358.         END;
  359.  
  360.         LISTS.push(unit.idents, item)
  361.     ELSE
  362.         item := NIL
  363.     END
  364.  
  365.     RETURN item
  366. END addIdent;
  367.  
  368.  
  369. PROCEDURE UseProc* (unit: UNIT; call_proc: PROC);
  370. VAR
  371.     procs: LISTS.LIST;
  372.     cur:   LISTS.ITEM;
  373.     proc:  USED_PROC;
  374.  
  375. BEGIN
  376.     IF unit.scopeLvl = 0 THEN
  377.         call_proc.used := TRUE
  378.     ELSE
  379.         procs := unit.scopes[unit.scopeLvl].using;
  380.  
  381.         cur := procs.first;
  382.         WHILE (cur # NIL) & (cur(USED_PROC).proc # call_proc) DO
  383.             cur := cur.next
  384.         END;
  385.  
  386.         IF cur = NIL THEN
  387.             NEW(proc);
  388.             proc.proc := call_proc;
  389.             LISTS.push(procs, proc)
  390.         END
  391.     END
  392. END UseProc;
  393.  
  394.  
  395. PROCEDURE setVarsType* (unit: UNIT; _type: _TYPE);
  396. VAR
  397.     item: IDENT;
  398.  
  399. BEGIN
  400.     ASSERT(_type # NIL);
  401.  
  402.     item := unit.idents.last(IDENT);
  403.     WHILE (item # NIL) & (item.typ = idVAR) & (item._type = NIL) DO
  404.         item._type := _type;
  405.         item := item.prev(IDENT)
  406.     END
  407. END setVarsType;
  408.  
  409.  
  410. PROCEDURE getIdent* (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;
  411. VAR
  412.     item: IDENT;
  413.  
  414. BEGIN
  415.     item := unit.idents.last(IDENT);
  416.  
  417.     IF item # NIL THEN
  418.  
  419.         IF currentScope THEN
  420.             WHILE (item.typ # idGUARD) & ~IdEq(item.name, ident) DO
  421.                 item := item.prev(IDENT)
  422.             END;
  423.             IF item.typ = idGUARD THEN
  424.                 item := NIL
  425.             END
  426.         ELSE
  427.             WHILE (item # NIL) & ~IdEq(item.name, ident) DO
  428.                 item := item.prev(IDENT)
  429.             END
  430.         END
  431.  
  432.     END
  433.  
  434.     RETURN item
  435. END getIdent;
  436.  
  437.  
  438. PROCEDURE openScope* (unit: UNIT; proc: PROC): BOOLEAN;
  439. VAR
  440.     item: IDENT;
  441.     res:  BOOLEAN;
  442.  
  443. BEGIN
  444.     INC(unit.scopeLvl);
  445.  
  446.     res := unit.scopeLvl < MAXSCOPE;
  447.  
  448.     IF res THEN
  449.  
  450.         unit.scopes[unit.scopeLvl] := proc;
  451.  
  452.         NEW(item);
  453.         item := NewIdent();
  454.  
  455.         item.name.s := "";
  456.         item.name.hash := 0;
  457.         item.typ  := idGUARD;
  458.  
  459.         LISTS.push(unit.idents, item)
  460.     END
  461.  
  462.     RETURN res
  463. END openScope;
  464.  
  465.  
  466. PROCEDURE closeScope* (unit: UNIT);
  467. VAR
  468.     item: IDENT;
  469.     del:  IDENT;
  470.  
  471. BEGIN
  472.     item := unit.idents.last(IDENT);
  473.  
  474.     WHILE (item # NIL) & (item.typ # idGUARD) DO
  475.         del  := item;
  476.         item := item.prev(IDENT);
  477.         IF (del.typ = idVAR) & (del.offset = -1) THEN
  478.             ERRORS.HintMsg(del.name.s, del.pos.line, del.pos.col, 0)
  479.         END;
  480.         LISTS.delete(unit.idents, del);
  481.         C.push(idents, del)
  482.     END;
  483.  
  484.     IF (item # NIL) & (item.typ = idGUARD) THEN
  485.         LISTS.delete(unit.idents, item);
  486.         C.push(idents, item)
  487.     END;
  488.  
  489.     DEC(unit.scopeLvl)
  490. END closeScope;
  491.  
  492.  
  493. PROCEDURE frwPtr* (unit: UNIT; _type: _TYPE; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
  494. VAR
  495.     newptr: FRWPTR;
  496.  
  497. BEGIN
  498.     ASSERT(unit # NIL);
  499.     ASSERT(_type # NIL);
  500.  
  501.     NEW(newptr);
  502.  
  503.     newptr._type      := _type;
  504.     newptr.baseIdent := baseIdent;
  505.     newptr.pos       := pos;
  506.     newptr.linked    := FALSE;
  507.     newptr.notRecord := FALSE;
  508.  
  509.     LISTS.push(unit.frwPointers, newptr)
  510. END frwPtr;
  511.  
  512.  
  513. PROCEDURE linkPtr* (unit: UNIT): FRWPTR;
  514. VAR
  515.     item:  FRWPTR;
  516.     ident: IDENT;
  517.     res:   FRWPTR;
  518.  
  519. BEGIN
  520.     res  := NIL;
  521.     item := unit.frwPointers.last(FRWPTR);
  522.  
  523.     WHILE (item # NIL) & ~item.linked & (res = NIL) DO
  524.         ident := getIdent(unit, item.baseIdent, TRUE);
  525.  
  526.         IF (ident # NIL) THEN
  527.             IF (ident.typ = idTYPE) & (ident._type.typ = tRECORD) THEN
  528.                 item._type.base := ident._type;
  529.                 item.linked := TRUE
  530.             ELSE
  531.                 item.notRecord := TRUE;
  532.                 res := item
  533.             END
  534.         ELSE
  535.             item.notRecord := FALSE;
  536.             res := item
  537.         END;
  538.  
  539.         item := item.prev(FRWPTR)
  540.     END
  541.  
  542.     RETURN res
  543. END linkPtr;
  544.  
  545.  
  546. PROCEDURE isTypeEq* (t1, t2: _TYPE): BOOLEAN;
  547. VAR
  548.     res: BOOLEAN;
  549.     param1, param2: LISTS.ITEM;
  550.  
  551. BEGIN
  552.     IF t1 = t2 THEN
  553.         res := TRUE
  554.     ELSIF (t1 = NIL) OR (t2 = NIL) THEN
  555.         res := FALSE
  556.     ELSIF (t1.typ = tPROCEDURE) & (t2.typ = tPROCEDURE) THEN
  557.  
  558.         param1 := t1.params.first;
  559.         param2 := t2.params.first;
  560.  
  561.         res := ((t1.call = t2.call) OR (t1.call IN {code, _code}) OR (t2.call IN {code, _code})) & ((param1 # NIL) = (param2 # NIL));
  562.  
  563.         WHILE res & (param1 # NIL) & (param2 # NIL) DO
  564.             res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM)._type, param2(PARAM)._type);
  565.             param1 := param1.next;
  566.             param2 := param2.next;
  567.             res := res & ((param1 # NIL) = (param2 # NIL))
  568.         END;
  569.  
  570.         res := res & isTypeEq(t1.base, t2.base)
  571.  
  572.     ELSIF (t1.typ = tARRAY) & (t2.typ = tARRAY) THEN
  573.         res := (t1.length = 0) & (t2.length = 0) & isTypeEq(t1.base, t2.base)
  574.     ELSE
  575.         res := FALSE
  576.     END
  577.  
  578.     RETURN res
  579. END isTypeEq;
  580.  
  581.  
  582. PROCEDURE isBaseOf* (t0, t1: _TYPE): BOOLEAN;
  583. VAR
  584.     res: BOOLEAN;
  585.  
  586. BEGIN
  587.     res := (t0.typ = t1.typ) & (t0.typ IN {tPOINTER, tRECORD});
  588.  
  589.     IF res & (t0.typ = tPOINTER) THEN
  590.         t0 := t0.base;
  591.         t1 := t1.base
  592.     END;
  593.  
  594.     IF res THEN
  595.         WHILE (t1 # NIL) & (t1 # t0) DO
  596.             t1 := t1.base
  597.         END;
  598.         res := t1 # NIL
  599.     END
  600.  
  601.     RETURN res
  602. END isBaseOf;
  603.  
  604.  
  605. PROCEDURE isOpenArray* (t: _TYPE): BOOLEAN;
  606.     RETURN (t.typ = tARRAY) & (t.length = 0)
  607. END isOpenArray;
  608.  
  609.  
  610. PROCEDURE arrcomp* (src, dst: _TYPE): BOOLEAN;
  611.     RETURN (dst.typ = tARRAY) & isOpenArray(src) &
  612.             ~isOpenArray(src.base) & ~isOpenArray(dst.base) &
  613.             isTypeEq(src.base, dst.base)
  614. END arrcomp;
  615.  
  616.  
  617. PROCEDURE getUnit* (name: PATHS.PATH): UNIT;
  618. VAR
  619.     item: UNIT;
  620.  
  621. BEGIN
  622.     item := program.units.first(UNIT);
  623.  
  624.     WHILE (item # NIL) & (item.fname # name) DO
  625.         item := item.next(UNIT)
  626.     END;
  627.  
  628.     IF (item = NIL) & ((name = "SYSTEM") OR LowerCase & (name = "system")) THEN
  629.         item := program.sysunit
  630.     END
  631.  
  632.     RETURN item
  633. END getUnit;
  634.  
  635.  
  636. PROCEDURE enterStTypes (unit: UNIT);
  637.  
  638.  
  639.     PROCEDURE enter (unit: UNIT; nameStr: SCAN.IDSTR; _type: _TYPE);
  640.     VAR
  641.         ident: IDENT;
  642.         upper: SCAN.IDSTR;
  643.         name:  SCAN.IDENT;
  644.  
  645.     BEGIN
  646.         IF LowerCase THEN
  647.             SCAN.setIdent(name, nameStr);
  648.             ident := addIdent(unit, name, idTYPE);
  649.             ident._type := _type
  650.         END;
  651.         upper := nameStr;
  652.         STRINGS.UpCase(upper);
  653.         SCAN.setIdent(name, upper);
  654.         ident := addIdent(unit, name, idTYPE);
  655.         ident._type := _type
  656.     END enter;
  657.  
  658.  
  659. BEGIN
  660.     enter(unit, "integer", program.stTypes.tINTEGER);
  661.     enter(unit, "byte",    program.stTypes.tBYTE);
  662.     enter(unit, "char",    program.stTypes.tCHAR);
  663.     enter(unit, "set",     program.stTypes.tSET);
  664.     enter(unit, "boolean", program.stTypes.tBOOLEAN);
  665.  
  666.     IF TARGETS.RealSize # 0 THEN
  667.         enter(unit, "real", program.stTypes.tREAL)
  668.     END;
  669.  
  670.     IF TARGETS.BitDepth >= 32 THEN
  671.         enter(unit, "wchar", program.stTypes.tWCHAR)
  672.     END
  673. END enterStTypes;
  674.  
  675.  
  676. PROCEDURE enterStProcs (unit: UNIT);
  677.  
  678.  
  679.     PROCEDURE Enter (unit: UNIT; nameStr: SCAN.IDSTR; nfunc, tfunc: INTEGER);
  680.     VAR
  681.         ident: IDENT;
  682.         upper: SCAN.IDSTR;
  683.         name:  SCAN.IDENT;
  684.  
  685.     BEGIN
  686.         IF LowerCase THEN
  687.             SCAN.setIdent(name, nameStr);
  688.             ident := addIdent(unit, name, tfunc);
  689.             ident.stproc := nfunc;
  690.             ident._type := program.stTypes.tNONE
  691.         END;
  692.         upper := nameStr;
  693.         STRINGS.UpCase(upper);
  694.         SCAN.setIdent(name, upper);
  695.         ident := addIdent(unit, name, tfunc);
  696.         ident.stproc := nfunc;
  697.         ident._type := program.stTypes.tNONE
  698.     END Enter;
  699.  
  700.  
  701. BEGIN
  702.     Enter(unit, "assert", stASSERT, idSTPROC);
  703.     Enter(unit, "dec",    stDEC,    idSTPROC);
  704.     Enter(unit, "excl",   stEXCL,   idSTPROC);
  705.     Enter(unit, "inc",    stINC,    idSTPROC);
  706.     Enter(unit, "incl",   stINCL,   idSTPROC);
  707.     Enter(unit, "new",    stNEW,    idSTPROC);
  708.     Enter(unit, "copy",   stCOPY,   idSTPROC);
  709.  
  710.     Enter(unit, "abs",    stABS,    idSTFUNC);
  711.     Enter(unit, "asr",    stASR,    idSTFUNC);
  712.     Enter(unit, "chr",    stCHR,    idSTFUNC);
  713.     Enter(unit, "len",    stLEN,    idSTFUNC);
  714.     Enter(unit, "lsl",    stLSL,    idSTFUNC);
  715.     Enter(unit, "odd",    stODD,    idSTFUNC);
  716.     Enter(unit, "ord",    stORD,    idSTFUNC);
  717.     Enter(unit, "ror",    stROR,    idSTFUNC);
  718.     Enter(unit, "bits",   stBITS,   idSTFUNC);
  719.     Enter(unit, "lsr",    stLSR,    idSTFUNC);
  720.     Enter(unit, "length", stLENGTH, idSTFUNC);
  721.     Enter(unit, "min",    stMIN,    idSTFUNC);
  722.     Enter(unit, "max",    stMAX,    idSTFUNC);
  723.  
  724.     IF TARGETS.RealSize # 0 THEN
  725.         Enter(unit, "pack",  stPACK,  idSTPROC);
  726.         Enter(unit, "unpk",  stUNPK,  idSTPROC);
  727.         Enter(unit, "floor", stFLOOR, idSTFUNC);
  728.         Enter(unit, "flt",   stFLT,   idSTFUNC)
  729.     END;
  730.  
  731.     IF TARGETS.BitDepth >= 32 THEN
  732.         Enter(unit, "wchr", stWCHR, idSTFUNC)
  733.     END;
  734.  
  735.     IF TARGETS.Dispose THEN
  736.         Enter(unit, "dispose", stDISPOSE, idSTPROC)
  737.     END
  738.  
  739. END enterStProcs;
  740.  
  741.  
  742. PROCEDURE newUnit* (name: SCAN.IDENT): UNIT;
  743. VAR
  744.     unit: UNIT;
  745.  
  746. BEGIN
  747.     NEW(unit);
  748.  
  749.     unit.name        := name;
  750.     unit.closed      := FALSE;
  751.     unit.idents      := LISTS.create(NIL);
  752.     unit.frwPointers := LISTS.create(NIL);
  753.  
  754.     ASSERT(openScope(unit, NIL));
  755.  
  756.     enterStTypes(unit);
  757.     enterStProcs(unit);
  758.  
  759.     ASSERT(openScope(unit, NIL));
  760.  
  761.     unit.gscope := unit.idents.last(IDENT);
  762.  
  763.     LISTS.push(program.units, unit);
  764.  
  765.     unit.scopeLvl := 0;
  766.     unit.scopes[0] := NIL;
  767.  
  768.     unit.sysimport := FALSE;
  769.  
  770.     IF unit.name.s = UTILS.RTL_NAME THEN
  771.         program.rtl := unit
  772.     END
  773.  
  774.     RETURN unit
  775. END newUnit;
  776.  
  777.  
  778. PROCEDURE getField* (self: _TYPE; name: SCAN.IDENT; unit: UNIT): FIELD;
  779. VAR
  780.     field: FIELD;
  781.  
  782. BEGIN
  783.     ASSERT(self # NIL);
  784.     ASSERT(unit # NIL);
  785.  
  786.     field := NIL;
  787.     WHILE (self # NIL) & (field = NIL) DO
  788.  
  789.         field := self.fields.first(FIELD);
  790.  
  791.         WHILE (field # NIL) & ~IdEq(field.name, name) DO
  792.             field := field.next(FIELD)
  793.         END;
  794.  
  795.         IF field = NIL THEN
  796.             self := self.base
  797.         END
  798.  
  799.     END;
  800.  
  801.     IF (field # NIL) & (self.unit # unit) & ~field.export THEN
  802.         field := NIL
  803.     END
  804.  
  805.     RETURN field
  806. END getField;
  807.  
  808.  
  809. PROCEDURE addField* (self: _TYPE; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
  810. VAR
  811.     field: FIELD;
  812.     res:   BOOLEAN;
  813.  
  814. BEGIN
  815.     res := getField(self, name, self.unit) = NIL;
  816.  
  817.     IF res THEN
  818.         NEW(field);
  819.  
  820.         field.name   := name;
  821.         field.export := export;
  822.         field._type  := NIL;
  823.         field.offset := self.size;
  824.  
  825.         LISTS.push(self.fields, field)
  826.     END
  827.  
  828.     RETURN res
  829. END addField;
  830.  
  831.  
  832. PROCEDURE setFields* (self: _TYPE; _type: _TYPE): BOOLEAN;
  833. VAR
  834.     item: FIELD;
  835.     res:  BOOLEAN;
  836.  
  837. BEGIN
  838.     ASSERT(_type # NIL);
  839.  
  840.     item := self.fields.first(FIELD);
  841.  
  842.     WHILE (item # NIL) & (item._type # NIL) DO
  843.         item := item.next(FIELD)
  844.     END;
  845.  
  846.     res := TRUE;
  847.  
  848.     WHILE res & (item # NIL) & (item._type = NIL) DO
  849.         item._type := _type;
  850.         IF ~self.noalign THEN
  851.             res := UTILS.Align(self.size, _type.align)
  852.         ELSE
  853.             res := TRUE
  854.         END;
  855.         item.offset := self.size;
  856.         res := res & (UTILS.maxint - self.size >= _type.size);
  857.         IF res THEN
  858.             INC(self.size, _type.size)
  859.         END;
  860.         item := item.next(FIELD)
  861.     END
  862.  
  863.     RETURN res
  864. END setFields;
  865.  
  866.  
  867. PROCEDURE getParam* (self: _TYPE; name: SCAN.IDENT): PARAM;
  868. VAR
  869.     item: PARAM;
  870.  
  871. BEGIN
  872.     item := self.params.first(PARAM);
  873.  
  874.     WHILE (item # NIL) & ~IdEq(item.name, name) DO
  875.         item := item.next(PARAM)
  876.     END
  877.  
  878.     RETURN item
  879. END getParam;
  880.  
  881.  
  882. PROCEDURE addParam* (self: _TYPE; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
  883. VAR
  884.     param: PARAM;
  885.     res:   BOOLEAN;
  886.  
  887. BEGIN
  888.     res := getParam(self, name) = NIL;
  889.  
  890.     IF res THEN
  891.         NEW(param);
  892.  
  893.         param.name  := name;
  894.         param._type := NIL;
  895.         param.vPar  := vPar;
  896.  
  897.         LISTS.push(self.params, param)
  898.     END
  899.  
  900.     RETURN res
  901. END addParam;
  902.  
  903.  
  904. PROCEDURE Dim* (t: _TYPE): INTEGER;
  905. VAR
  906.     res: INTEGER;
  907.  
  908. BEGIN
  909.     res := 0;
  910.     WHILE isOpenArray(t) DO
  911.         t := t.base;
  912.         INC(res)
  913.     END
  914.     RETURN res
  915. END Dim;
  916.  
  917.  
  918. PROCEDURE OpenBase* (t: _TYPE): _TYPE;
  919. BEGIN
  920.     WHILE isOpenArray(t) DO t := t.base END
  921.     RETURN t
  922. END OpenBase;
  923.  
  924.  
  925. PROCEDURE getFloatParamsPos* (self: _TYPE; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
  926. VAR
  927.     res: SET;
  928.     param: PARAM;
  929.  
  930. BEGIN
  931.     res := {};
  932.     int := 0;
  933.     flt := 0;
  934.     param := self.params.first(PARAM);
  935.     WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO
  936.         IF ~param.vPar & (param._type.typ = tREAL) THEN
  937.             INCL(res, param.offset - STACK_FRAME);
  938.             INC(flt)
  939.         END;
  940.         param := param.next(PARAM)
  941.     END;
  942.  
  943.     int := self.parSize - flt
  944.  
  945.     RETURN res
  946. END getFloatParamsPos;
  947.  
  948.  
  949. PROCEDURE setParams* (self: _TYPE; _type: _TYPE);
  950. VAR
  951.     item: LISTS.ITEM;
  952.     param: PARAM;
  953.     word, size: INTEGER;
  954.  
  955. BEGIN
  956.     ASSERT(_type # NIL);
  957.  
  958.     word := UTILS.target.bit_depth DIV 8;
  959.  
  960.     item := self.params.first;
  961.  
  962.     WHILE (item # NIL) & (item(PARAM)._type # NIL) DO
  963.         item := item.next
  964.     END;
  965.  
  966.     WHILE (item # NIL) & (item(PARAM)._type = NIL) DO
  967.         param := item(PARAM);
  968.         param._type := _type;
  969.         IF param.vPar THEN
  970.             IF _type.typ = tRECORD THEN
  971.                 size := 2
  972.             ELSIF isOpenArray(_type) THEN
  973.                 size := Dim(_type) + 1
  974.             ELSE
  975.                 size := 1
  976.             END;
  977.             param.offset := self.parSize + ORD(_type.typ = tRECORD) + Dim(_type) + STACK_FRAME;
  978.             INC(self.parSize, size)
  979.         ELSE
  980.             IF _type.typ IN {tRECORD, tARRAY} THEN
  981.                 IF isOpenArray(_type) THEN
  982.                     size := Dim(_type) + 1
  983.                 ELSE
  984.                     size := 1
  985.                 END
  986.             ELSE
  987.                 size := _type.size;
  988.                 ASSERT(UTILS.Align(size, word));
  989.                 size := size DIV word
  990.             END;
  991.             param.offset := self.parSize + Dim(_type) + STACK_FRAME;
  992.             INC(self.parSize, size)
  993.         END;
  994.  
  995.         item := item.next
  996.     END
  997.  
  998. END setParams;
  999.  
  1000.  
  1001. PROCEDURE enterType* (typ, size, length: INTEGER; unit: UNIT): _TYPE;
  1002. VAR
  1003.     t: _TYPE;
  1004.  
  1005. BEGIN
  1006.     NEW(t);
  1007.  
  1008.     t.typ     := typ;
  1009.     t.size    := size;
  1010.     t.length  := length;
  1011.     t.align   := 0;
  1012.     t.base    := NIL;
  1013.     t.fields  := LISTS.create(NIL);
  1014.     t.params  := LISTS.create(NIL);
  1015.     t.unit    := unit;
  1016.     t.num     := 0;
  1017.  
  1018.     CASE TARGETS.BitDepth OF
  1019.     |16: t.call := default16
  1020.     |32: t.call := default32
  1021.     |64: t.call := default64
  1022.     END;
  1023.  
  1024.     t._import := FALSE;
  1025.     t.noalign := FALSE;
  1026.     t.parSize := 0;
  1027.  
  1028.     IF typ IN {tARRAY, tRECORD} THEN
  1029.         t.closed := FALSE;
  1030.         IF typ = tRECORD THEN
  1031.             INC(program.recCount);
  1032.             t.num := program.recCount
  1033.         END
  1034.     ELSE
  1035.         t.closed := TRUE
  1036.     END;
  1037.  
  1038.     LISTS.push(program.types, t)
  1039.  
  1040.     RETURN t
  1041. END enterType;
  1042.  
  1043.  
  1044. PROCEDURE getType* (typ: INTEGER): _TYPE;
  1045. VAR
  1046.     res: _TYPE;
  1047.  
  1048. BEGIN
  1049.  
  1050.     CASE typ OF
  1051.     |ARITH.tINTEGER: res := program.stTypes.tINTEGER
  1052.     |ARITH.tREAL:    res := program.stTypes.tREAL
  1053.     |ARITH.tSET:     res := program.stTypes.tSET
  1054.     |ARITH.tBOOLEAN: res := program.stTypes.tBOOLEAN
  1055.     |ARITH.tCHAR:    res := program.stTypes.tCHAR
  1056.     |ARITH.tWCHAR:   res := program.stTypes.tWCHAR
  1057.     |ARITH.tSTRING:  res := program.stTypes.tSTRING
  1058.     END
  1059.  
  1060.     RETURN res
  1061. END getType;
  1062.  
  1063.  
  1064. PROCEDURE createSysUnit;
  1065. VAR
  1066.     ident: IDENT;
  1067.     unit:  UNIT;
  1068.     name:  SCAN.IDENT;
  1069.  
  1070.  
  1071.     PROCEDURE EnterProc (sys: UNIT; nameStr: SCAN.IDSTR; idtyp, proc: INTEGER);
  1072.     VAR
  1073.         ident: IDENT;
  1074.         upper: SCAN.IDSTR;
  1075.         name:  SCAN.IDENT;
  1076.  
  1077.     BEGIN
  1078.         IF LowerCase THEN
  1079.             SCAN.setIdent(name, nameStr);
  1080.             ident := addIdent(sys, name, idtyp);
  1081.             ident.stproc := proc;
  1082.             ident._type := program.stTypes.tNONE;
  1083.             ident.export := TRUE
  1084.         END;
  1085.         upper := nameStr;
  1086.         STRINGS.UpCase(upper);
  1087.         SCAN.setIdent(name, upper);
  1088.         ident := addIdent(sys, name, idtyp);
  1089.         ident.stproc := proc;
  1090.         ident._type := program.stTypes.tNONE;
  1091.         ident.export := TRUE
  1092.     END EnterProc;
  1093.  
  1094.  
  1095. BEGIN
  1096.     SCAN.setIdent(name, "$SYSTEM");
  1097.     unit := newUnit(name);
  1098.     unit.fname := "SYSTEM";
  1099.  
  1100.     EnterProc(unit, "adr",    idSYSFUNC, sysADR);
  1101.     EnterProc(unit, "size",   idSYSFUNC, sysSIZE);
  1102.     EnterProc(unit, "sadr",   idSYSFUNC, sysSADR);
  1103.     EnterProc(unit, "typeid", idSYSFUNC, sysTYPEID);
  1104.  
  1105.     EnterProc(unit, "get",    idSYSPROC, sysGET);
  1106.     EnterProc(unit, "get8",   idSYSPROC, sysGET8);
  1107.     EnterProc(unit, "put",    idSYSPROC, sysPUT);
  1108.     EnterProc(unit, "put8",   idSYSPROC, sysPUT8);
  1109.     EnterProc(unit, "code",   idSYSPROC, sysCODE);
  1110.     EnterProc(unit, "move",   idSYSPROC, sysMOVE);
  1111.            (*
  1112.     IF program.target.sys = mConst.Target_iMSP430 THEN
  1113.         EnterProc(unit, "nop",  idSYSPROC, sysNOP);
  1114.         EnterProc(unit, "eint", idSYSPROC, sysEINT);
  1115.         EnterProc(unit, "dint", idSYSPROC, sysDINT)
  1116.     END;
  1117.          *)
  1118.     IF TARGETS.RealSize # 0 THEN
  1119.         EnterProc(unit, "inf",    idSYSFUNC, sysINF);
  1120.     END;
  1121.  
  1122.     IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
  1123.         EnterProc(unit, "copy",   idSYSPROC, sysCOPY)
  1124.     END;
  1125.  
  1126.     IF TARGETS.BitDepth >= 32 THEN
  1127.         EnterProc(unit, "wsadr",  idSYSFUNC, sysWSADR);
  1128.         EnterProc(unit, "put16",  idSYSPROC, sysPUT16);
  1129.         EnterProc(unit, "put32",  idSYSPROC, sysPUT32);
  1130.         EnterProc(unit, "get16",  idSYSPROC, sysGET16);
  1131.         EnterProc(unit, "get32",  idSYSPROC, sysGET32);
  1132.  
  1133.         IF LowerCase THEN
  1134.             SCAN.setIdent(name, "card32");
  1135.             ident := addIdent(unit, name, idTYPE);
  1136.             ident._type := program.stTypes.tCARD32;
  1137.             ident.export := TRUE
  1138.         END;
  1139.         SCAN.setIdent(name, "CARD32");
  1140.         ident := addIdent(unit, name, idTYPE);
  1141.         ident._type := program.stTypes.tCARD32;
  1142.         ident.export := TRUE;
  1143.     END;
  1144.  
  1145.     closeUnit(unit);
  1146.  
  1147.     program.sysunit := unit
  1148. END createSysUnit;
  1149.  
  1150.  
  1151. PROCEDURE DelUnused* (DelImport: DELIMPORT);
  1152. VAR
  1153.     proc: PROC;
  1154.     flag: BOOLEAN;
  1155.  
  1156.  
  1157.     PROCEDURE process (proc: PROC);
  1158.     VAR
  1159.         used_proc: LISTS.ITEM;
  1160.  
  1161.     BEGIN
  1162.         proc.processed := TRUE;
  1163.  
  1164.         used_proc := proc.using.first;
  1165.         WHILE used_proc # NIL DO
  1166.             used_proc(USED_PROC).proc.used := TRUE;
  1167.             used_proc := used_proc.next
  1168.         END
  1169.  
  1170.     END process;
  1171.  
  1172.  
  1173. BEGIN
  1174.  
  1175.     REPEAT
  1176.         flag := FALSE;
  1177.         proc := program.procs.first(PROC);
  1178.  
  1179.         WHILE proc # NIL DO
  1180.             IF proc.used & ~proc.processed THEN
  1181.                 process(proc);
  1182.                 flag := TRUE
  1183.             END;
  1184.             proc := proc.next(PROC)
  1185.         END
  1186.  
  1187.     UNTIL ~flag;
  1188.  
  1189.     proc := program.procs.first(PROC);
  1190.  
  1191.     WHILE proc # NIL DO
  1192.         IF ~proc.used THEN
  1193.             IF proc._import = NIL THEN
  1194.                 IL.delete2(proc.enter, proc.leave)
  1195.             ELSE
  1196.                 DelImport(proc._import)
  1197.             END
  1198.         END;
  1199.         proc := proc.next(PROC)
  1200.     END
  1201.  
  1202. END DelUnused;
  1203.  
  1204.  
  1205. PROCEDURE ResetLocSize*;
  1206. BEGIN
  1207.     program.locsize := 0
  1208. END ResetLocSize;
  1209.  
  1210.  
  1211. PROCEDURE create* (options: OPTIONS);
  1212. BEGIN
  1213.     LowerCase := options.lower;
  1214.     SCAN.init(options.lower);
  1215.     idents := C.create();
  1216.  
  1217.     UTILS.SetBitDepth(TARGETS.BitDepth, TARGETS.RealSize = 8);
  1218.  
  1219.     program.options := options;
  1220.  
  1221.     CASE TARGETS.OS OF
  1222.     |TARGETS.osWIN32:    program.sysflags := {sf_oberon, sf_windows, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign}
  1223.     |TARGETS.osLINUX32:  program.sysflags := {sf_oberon, sf_linux, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign}
  1224.     |TARGETS.osKOS:      program.sysflags := {sf_oberon, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign}
  1225.     |TARGETS.osWIN64:    program.sysflags := {sf_oberon, sf_windows, sf_win64, sf_systemv, sf_ccall, sf_noalign}
  1226.     |TARGETS.osLINUX64:  program.sysflags := {sf_oberon, sf_linux, sf_win64, sf_systemv, sf_ccall, sf_noalign}
  1227.     |TARGETS.osNONE:     program.sysflags := {sf_code}
  1228.     END;
  1229.  
  1230.     program.recCount := -1;
  1231.     program.bss := 0;
  1232.  
  1233.     program.units := LISTS.create(NIL);
  1234.     program.types := LISTS.create(NIL);
  1235.     program.procs := LISTS.create(NIL);
  1236.  
  1237.     program.stTypes.tINTEGER := enterType(tINTEGER, TARGETS.WordSize, 0, NIL);
  1238.     program.stTypes.tBYTE    := enterType(tBYTE,                   1, 0, NIL);
  1239.     program.stTypes.tCHAR    := enterType(tCHAR,                   1, 0, NIL);
  1240.     program.stTypes.tSET     := enterType(tSET,     TARGETS.WordSize, 0, NIL);
  1241.     program.stTypes.tBOOLEAN := enterType(tBOOLEAN,                1, 0, NIL);
  1242.  
  1243.     program.stTypes.tINTEGER.align := TARGETS.WordSize;
  1244.     program.stTypes.tBYTE.align    := 1;
  1245.     program.stTypes.tCHAR.align    := 1;
  1246.     program.stTypes.tSET.align     := TARGETS.WordSize;
  1247.     program.stTypes.tBOOLEAN.align := 1;
  1248.  
  1249.     IF TARGETS.BitDepth >= 32 THEN
  1250.         program.stTypes.tWCHAR  := enterType(tWCHAR,  2, 0, NIL);
  1251.         program.stTypes.tCARD32 := enterType(tCARD32, 4, 0, NIL);
  1252.         program.stTypes.tWCHAR.align  := 2;
  1253.         program.stTypes.tCARD32.align := 4
  1254.     END;
  1255.  
  1256.     IF TARGETS.RealSize # 0 THEN
  1257.         program.stTypes.tREAL := enterType(tREAL, TARGETS.RealSize, 0, NIL);
  1258.         program.stTypes.tREAL.align := TARGETS.RealSize
  1259.     END;
  1260.  
  1261.     program.stTypes.tSTRING := enterType(tSTRING, TARGETS.WordSize, 0, NIL);
  1262.     program.stTypes.tNIL    := enterType(tNIL,    TARGETS.WordSize, 0, NIL);
  1263.     program.stTypes.tNONE   := enterType(tNONE,   0, 0, NIL);
  1264.     program.stTypes.tANYREC := enterType(tRECORD, 0, 0, NIL);
  1265.     program.stTypes.tANYREC.closed := TRUE;
  1266.  
  1267.     createSysUnit
  1268. END create;
  1269.  
  1270.  
  1271. END PROG.