Subversion Repositories Kolibri OS

Rev

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