Subversion Repositories Kolibri OS

Rev

Rev 7696 | Go to most recent revision | Blame | Last modification | View Log | Download | RSS feed

  1. (*
  2.     BSD 2-Clause License
  3.  
  4.     Copyright (c) 2018-2019, Anton Krotov
  5.     All rights reserved.
  6. *)
  7.  
  8. MODULE PROG;
  9.  
  10. IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS;
  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;
  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;*)
  44.  
  45.     default32* =  2;
  46.     stdcall*   =  4;  _stdcall*   = stdcall + 1;
  47.     ccall*     =  6;  _ccall*     = ccall + 1;
  48.     ccall16*   =  8;  _ccall16*   = ccall16 + 1;
  49.     win64*     = 10;  _win64*     = win64 + 1;
  50.     stdcall64* = 12;  _stdcall64* = stdcall64 + 1;
  51.     default64* = 14;
  52.     systemv*   = 16;  _systemv*   = systemv + 1;
  53.     default16* = 18;
  54.     code*      = 20;  _code*      = code + 1;
  55.  
  56.     noalign* = 22;
  57.  
  58.     callee_clean_up* = {default32, stdcall, _stdcall, default64, stdcall64, _stdcall64};
  59.  
  60.     sf_stdcall* = 0; sf_stdcall64* = 1; sf_ccall*   = 2; sf_ccall16* = 3;
  61.     sf_win64*   = 4; sf_systemv*   = 5; sf_windows* = 6; sf_linux*   = 7;
  62.     sf_code*    = 8;
  63.     sf_noalign* = 9;
  64.  
  65.     proc_flags* = {sf_stdcall, sf_stdcall64, sf_ccall, sf_ccall16, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code};
  66.     rec_flags*  = {sf_noalign};
  67.  
  68.     STACK_FRAME = 2;
  69.  
  70.  
  71. TYPE
  72.  
  73.     OPTIONS* = RECORD
  74.  
  75.         version*, stack*, ram*, rom*: INTEGER;
  76.         pic*: BOOLEAN;
  77.         checking*: SET
  78.  
  79.     END;
  80.  
  81.     IDENT* = POINTER TO rIDENT;
  82.  
  83.     UNIT* = POINTER TO rUNIT;
  84.  
  85.     PROGRAM* = POINTER TO rPROGRAM;
  86.  
  87.     TYPE_* = POINTER TO rTYPE_;
  88.  
  89.     FRWPTR* = POINTER TO RECORD (LISTS.ITEM)
  90.  
  91.         type:        TYPE_;
  92.         baseIdent:   SCAN.IDENT;
  93.         linked:      BOOLEAN;
  94.  
  95.         pos*:        SCAN.POSITION;
  96.         notRecord*:  BOOLEAN
  97.  
  98.     END;
  99.  
  100.     PROC* = POINTER TO RECORD (LISTS.ITEM)
  101.  
  102.         label*:      INTEGER;
  103.         used*:       BOOLEAN;
  104.         processed*:  BOOLEAN;
  105.         import*:     LISTS.ITEM;
  106.         using*:      LISTS.LIST;
  107.         enter*,
  108.         leave*:      LISTS.ITEM
  109.  
  110.     END;
  111.  
  112.     USED_PROC = POINTER TO RECORD (LISTS.ITEM)
  113.  
  114.         proc: PROC
  115.  
  116.     END;
  117.  
  118.     rUNIT = RECORD (LISTS.ITEM)
  119.  
  120.         program*:    PROGRAM;
  121.         name*:       SCAN.IDENT;
  122.         idents*:     LISTS.LIST;
  123.         frwPointers: LISTS.LIST;
  124.         gscope:      IDENT;
  125.         closed*:     BOOLEAN;
  126.         scopeLvl*:   INTEGER;
  127.         sysimport*:  BOOLEAN;
  128.         scopes*:     ARRAY MAXSCOPE OF PROC
  129.  
  130.     END;
  131.  
  132.     FIELD* = POINTER TO rFIELD;
  133.  
  134.     PARAM* = POINTER TO rPARAM;
  135.  
  136.     rTYPE_ = RECORD (LISTS.ITEM)
  137.  
  138.         typ*:        INTEGER;
  139.         size*:       INTEGER;
  140.         parSize*:    INTEGER;
  141.         length*:     INTEGER;
  142.         align*:      INTEGER;
  143.         base*:       TYPE_;
  144.         fields*:     LISTS.LIST;
  145.         params*:     LISTS.LIST;
  146.         unit*:       UNIT;
  147.         closed*:     BOOLEAN;
  148.         num*:        INTEGER;
  149.         call*:       INTEGER;
  150.         import*:     BOOLEAN;
  151.         noalign*:    BOOLEAN
  152.  
  153.     END;
  154.  
  155.     rFIELD = RECORD (LISTS.ITEM)
  156.  
  157.         type*:       TYPE_;
  158.         name*:       SCAN.IDENT;
  159.         export*:     BOOLEAN;
  160.         offset*:     INTEGER
  161.  
  162.     END;
  163.  
  164.     rPARAM = RECORD (LISTS.ITEM)
  165.  
  166.         name*:       SCAN.IDENT;
  167.         type*:       TYPE_;
  168.         vPar*:       BOOLEAN;
  169.         offset*:     INTEGER
  170.  
  171.     END;
  172.  
  173.     rIDENT = RECORD (LISTS.ITEM)
  174.  
  175.         name*:       SCAN.IDENT;
  176.         typ*:        INTEGER;
  177.         export*:     BOOLEAN;
  178.         import*:     LISTS.ITEM;
  179.         unit*:       UNIT;
  180.         value*:      ARITH.VALUE;
  181.         type*:       TYPE_;
  182.         stproc*:     INTEGER;
  183.         global*:     BOOLEAN;
  184.         scopeLvl*:   INTEGER;
  185.         offset*:     INTEGER;
  186.         proc*:       PROC;
  187.         pos*:        SCAN.POSITION
  188.  
  189.     END;
  190.  
  191.     rPROGRAM = RECORD
  192.  
  193.         recCount:    INTEGER;
  194.         units*:      LISTS.LIST;
  195.         types*:      LISTS.LIST;
  196.         sysunit*:    UNIT;
  197.         rtl*:        UNIT;
  198.         bss*:        INTEGER;
  199.         locsize*:    INTEGER;
  200.  
  201.         procs*:      LISTS.LIST;
  202.  
  203.         sysflags*:   SET;
  204.         options*:    OPTIONS;
  205.  
  206.         stTypes*:    RECORD
  207.  
  208.             tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*,
  209.             tSTRING*, tNIL*, tCARD32*, tANYREC*: TYPE_
  210.  
  211.         END
  212.  
  213.     END;
  214.  
  215.     DELIMPORT = PROCEDURE (import: LISTS.ITEM);
  216.  
  217.  
  218. VAR
  219.  
  220.     idents: C.COLLECTION;
  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* (program: PROGRAM; 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(unit.program, 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 unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;
  305. VAR
  306.     item: IDENT;
  307.  
  308. BEGIN
  309.     ASSERT(ident # NIL);
  310.  
  311.     item := unit.idents.last(IDENT);
  312.     WHILE (item.typ # idGUARD) & (item.name # ident) DO
  313.         item := item.prev(IDENT)
  314.     END
  315.  
  316.     RETURN item.typ = idGUARD
  317. END unique;
  318.  
  319.  
  320. PROCEDURE addIdent* (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
  321. VAR
  322.     item:  IDENT;
  323.     res:   BOOLEAN;
  324.     proc:  PROC;
  325.     procs: LISTS.LIST;
  326.  
  327. BEGIN
  328.     ASSERT(unit # NIL);
  329.     ASSERT(ident # 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.             procs := unit.program.procs;
  357.             LISTS.push(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.     ASSERT(ident # NIL);
  417.  
  418.     item := unit.idents.last(IDENT);
  419.  
  420.     IF item # NIL THEN
  421.  
  422.         IF currentScope THEN
  423.             WHILE (item.name # ident) & (item.typ # idGUARD) DO
  424.                 item := item.prev(IDENT)
  425.             END;
  426.             IF item.name # ident THEN
  427.                 item := NIL
  428.             END
  429.         ELSE
  430.             WHILE (item # NIL) & (item.name # ident) DO
  431.                 item := item.prev(IDENT)
  432.             END
  433.         END
  434.  
  435.     END
  436.  
  437.     RETURN item
  438. END getIdent;
  439.  
  440.  
  441. PROCEDURE openScope* (unit: UNIT; proc: PROC): BOOLEAN;
  442. VAR
  443.     item: IDENT;
  444.     res:  BOOLEAN;
  445.  
  446. BEGIN
  447.     INC(unit.scopeLvl);
  448.  
  449.     res := unit.scopeLvl < MAXSCOPE;
  450.  
  451.     IF res THEN
  452.  
  453.         unit.scopes[unit.scopeLvl] := proc;
  454.  
  455.         NEW(item);
  456.         item := NewIdent();
  457.  
  458.         item.name := NIL;
  459.         item.typ  := idGUARD;
  460.  
  461.         LISTS.push(unit.idents, item)
  462.     END
  463.  
  464.     RETURN res
  465. END openScope;
  466.  
  467.  
  468. PROCEDURE closeScope* (unit: UNIT; variables: LISTS.LIST);
  469. VAR
  470.     item: IDENT;
  471.     del:  IDENT;
  472.     lvar: IL.LOCALVAR;
  473.  
  474. BEGIN
  475.     item := unit.idents.last(IDENT);
  476.  
  477.     WHILE (item # NIL) & (item.typ # idGUARD) DO
  478.         del  := item;
  479.         item := item.prev(IDENT);
  480.         IF (del.typ = idVAR) & (del.offset = -1) THEN
  481.             ERRORS.HintMsg(del.name.s, del.pos.line, del.pos.col, 0)
  482.         END;
  483.         IF (variables # NIL) & (del.typ IN {idVAR, idPARAM}) & (del.offset # -1) THEN
  484.             IF del.type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN
  485.                 lvar := IL.NewVar();
  486.                 lvar.offset := del.offset;
  487.                 lvar.size   := del.type.size;
  488.                 IF del.typ = idVAR THEN
  489.                     lvar.offset := -lvar.offset
  490.                 END;
  491.                 LISTS.push(variables, lvar)
  492.             END
  493.         END;
  494.         LISTS.delete(unit.idents, del);
  495.         C.push(idents, del)
  496.     END;
  497.  
  498.     IF (item # NIL) & (item.typ = idGUARD) THEN
  499.         LISTS.delete(unit.idents, item);
  500.         C.push(idents, item)
  501.     END;
  502.  
  503.     DEC(unit.scopeLvl)
  504. END closeScope;
  505.  
  506.  
  507. PROCEDURE frwPtr* (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
  508. VAR
  509.     newptr: FRWPTR;
  510.  
  511. BEGIN
  512.     ASSERT(unit # NIL);
  513.     ASSERT(type # NIL);
  514.     ASSERT(baseIdent # NIL);
  515.  
  516.     NEW(newptr);
  517.  
  518.     newptr.type      := type;
  519.     newptr.baseIdent := baseIdent;
  520.     newptr.pos       := pos;
  521.     newptr.linked    := FALSE;
  522.     newptr.notRecord := FALSE;
  523.  
  524.     LISTS.push(unit.frwPointers, newptr)
  525. END frwPtr;
  526.  
  527.  
  528. PROCEDURE linkPtr* (unit: UNIT): FRWPTR;
  529. VAR
  530.     item:  FRWPTR;
  531.     ident: IDENT;
  532.     res:   FRWPTR;
  533.  
  534. BEGIN
  535.     res  := NIL;
  536.     item := unit.frwPointers.last(FRWPTR);
  537.  
  538.     WHILE (item # NIL) & ~item.linked & (res = NIL) DO
  539.         ident := getIdent(unit, item.baseIdent, TRUE);
  540.  
  541.         IF (ident # NIL) THEN
  542.             IF (ident.typ = idTYPE) & (ident.type.typ = tRECORD) THEN
  543.                 item.type.base := ident.type;
  544.                 item.linked := TRUE
  545.             ELSE
  546.                 item.notRecord := TRUE;
  547.                 res := item
  548.             END
  549.         ELSE
  550.             item.notRecord := FALSE;
  551.             res := item
  552.         END;
  553.  
  554.         item := item.prev(FRWPTR)
  555.     END
  556.  
  557.     RETURN res
  558. END linkPtr;
  559.  
  560.  
  561. PROCEDURE isTypeEq* (t1, t2: TYPE_): BOOLEAN;
  562. VAR
  563.     res: BOOLEAN;
  564.     param1, param2: LISTS.ITEM;
  565.  
  566. BEGIN
  567.     IF t1 = t2 THEN
  568.         res := TRUE
  569.     ELSIF (t1 = NIL) OR (t2 = NIL) THEN
  570.         res := FALSE
  571.     ELSIF (t1.typ = tPROCEDURE) & (t2.typ = tPROCEDURE) THEN
  572.  
  573.         param1 := t1.params.first;
  574.         param2 := t2.params.first;
  575.  
  576.         res := ((t1.call = t2.call) OR (t1.call IN {code, _code}) OR (t2.call IN {code, _code})) & ((param1 # NIL) = (param2 # NIL));
  577.  
  578.         WHILE res & (param1 # NIL) & (param2 # NIL) DO
  579.             res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM).type, param2(PARAM).type);
  580.             param1 := param1.next;
  581.             param2 := param2.next;
  582.             res := res & ((param1 # NIL) = (param2 # NIL))
  583.         END;
  584.  
  585.         res := res & isTypeEq(t1.base, t2.base)
  586.  
  587.     ELSIF (t1.typ = tARRAY) & (t2.typ = tARRAY) THEN
  588.         res := (t1.length = 0) & (t2.length = 0) & isTypeEq(t1.base, t2.base)
  589.     ELSE
  590.         res := FALSE
  591.     END
  592.  
  593.     RETURN res
  594. END isTypeEq;
  595.  
  596.  
  597. PROCEDURE isBaseOf* (t0, t1: TYPE_): BOOLEAN;
  598. VAR
  599.     res: BOOLEAN;
  600.  
  601. BEGIN
  602.     res := (t0.typ = t1.typ) & (t0.typ IN {tPOINTER, tRECORD});
  603.  
  604.     IF res & (t0.typ = tPOINTER) THEN
  605.         t0 := t0.base;
  606.         t1 := t1.base
  607.     END;
  608.  
  609.     IF res THEN
  610.         WHILE (t1 # NIL) & (t1 # t0) DO
  611.             t1 := t1.base
  612.         END;
  613.         res := t1 # NIL
  614.     END
  615.  
  616.     RETURN res
  617. END isBaseOf;
  618.  
  619.  
  620. PROCEDURE isOpenArray* (t: TYPE_): BOOLEAN;
  621.     RETURN (t.typ = tARRAY) & (t.length = 0)
  622. END isOpenArray;
  623.  
  624.  
  625. PROCEDURE arrcomp* (src, dst: TYPE_): BOOLEAN;
  626.     RETURN (dst.typ = tARRAY) & isOpenArray(src) &
  627.             ~isOpenArray(src.base) & ~isOpenArray(dst.base) &
  628.             isTypeEq(src.base, dst.base)
  629. END arrcomp;
  630.  
  631.  
  632. PROCEDURE getUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;
  633. VAR
  634.     item: UNIT;
  635.  
  636. BEGIN
  637.     ASSERT(name # NIL);
  638.  
  639.     item := program.units.first(UNIT);
  640.  
  641.     WHILE (item # NIL) & (item.name # name) DO
  642.         item := item.next(UNIT)
  643.     END;
  644.  
  645.     IF (item = NIL) & (name.s = "SYSTEM") THEN
  646.         item := program.sysunit
  647.     END
  648.  
  649.     RETURN item
  650. END getUnit;
  651.  
  652.  
  653. PROCEDURE enterStTypes (unit: UNIT; program: PROGRAM);
  654. VAR
  655.     ident: IDENT;
  656.  
  657. BEGIN
  658.     ident      := addIdent(unit, SCAN.enterid("INTEGER"), idTYPE);
  659.     ident.type := program.stTypes.tINTEGER;
  660.  
  661.     ident      := addIdent(unit, SCAN.enterid("BYTE"), idTYPE);
  662.     ident.type := program.stTypes.tBYTE;
  663.  
  664.     ident      := addIdent(unit, SCAN.enterid("CHAR"), idTYPE);
  665.     ident.type := program.stTypes.tCHAR;
  666.  
  667.     ident      := addIdent(unit, SCAN.enterid("SET"), idTYPE);
  668.     ident.type := program.stTypes.tSET;
  669.  
  670.     ident      := addIdent(unit, SCAN.enterid("BOOLEAN"), idTYPE);
  671.     ident.type := program.stTypes.tBOOLEAN;
  672.  
  673.     IF TARGETS.RealSize # 0 THEN
  674.         ident      := addIdent(unit, SCAN.enterid("REAL"), idTYPE);
  675.         ident.type := program.stTypes.tREAL
  676.     END;
  677.  
  678.     IF TARGETS.BitDepth >= 32 THEN
  679.         ident      := addIdent(unit, SCAN.enterid("WCHAR"), idTYPE);
  680.         ident.type := program.stTypes.tWCHAR
  681.     END
  682.  
  683. END enterStTypes;
  684.  
  685.  
  686. PROCEDURE enterStProcs (unit: UNIT);
  687.  
  688.  
  689.     PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; proc: INTEGER);
  690.     VAR
  691.         ident: IDENT;
  692.     BEGIN
  693.         ident := addIdent(unit, SCAN.enterid(name), idSTPROC);
  694.         ident.stproc := proc
  695.     END EnterProc;
  696.  
  697.  
  698.     PROCEDURE EnterFunc (unit: UNIT; name: SCAN.LEXSTR; func: INTEGER);
  699.     VAR
  700.         ident: IDENT;
  701.     BEGIN
  702.         ident := addIdent(unit, SCAN.enterid(name), idSTFUNC);
  703.         ident.stproc := func
  704.     END EnterFunc;
  705.  
  706.  
  707. BEGIN
  708.     EnterProc(unit, "ASSERT", stASSERT);
  709.     EnterProc(unit, "DEC",    stDEC);
  710.     EnterProc(unit, "EXCL",   stEXCL);
  711.     EnterProc(unit, "INC",    stINC);
  712.     EnterProc(unit, "INCL",   stINCL);
  713.     EnterProc(unit, "NEW",    stNEW);
  714.     EnterProc(unit, "COPY",   stCOPY);
  715.  
  716.     EnterFunc(unit, "ABS",    stABS);
  717.     EnterFunc(unit, "ASR",    stASR);
  718.     EnterFunc(unit, "CHR",    stCHR);
  719.     EnterFunc(unit, "LEN",    stLEN);
  720.     EnterFunc(unit, "LSL",    stLSL);
  721.     EnterFunc(unit, "ODD",    stODD);
  722.     EnterFunc(unit, "ORD",    stORD);
  723.     EnterFunc(unit, "ROR",    stROR);
  724.     EnterFunc(unit, "BITS",   stBITS);
  725.     EnterFunc(unit, "LSR",    stLSR);
  726.     EnterFunc(unit, "LENGTH", stLENGTH);
  727.     EnterFunc(unit, "MIN",    stMIN);
  728.     EnterFunc(unit, "MAX",    stMAX);
  729.  
  730.     IF TARGETS.RealSize # 0 THEN
  731.         EnterProc(unit, "PACK",  stPACK);
  732.         EnterProc(unit, "UNPK",  stUNPK);
  733.         EnterFunc(unit, "FLOOR", stFLOOR);
  734.         EnterFunc(unit, "FLT",   stFLT)
  735.     END;
  736.  
  737.     IF TARGETS.BitDepth >= 32 THEN
  738.         EnterFunc(unit, "WCHR", stWCHR)
  739.     END;
  740.  
  741.     IF TARGETS.Dispose THEN
  742.         EnterProc(unit, "DISPOSE", stDISPOSE)
  743.     END
  744.  
  745. END enterStProcs;
  746.  
  747.  
  748. PROCEDURE newUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;
  749. VAR
  750.     unit: UNIT;
  751.  
  752. BEGIN
  753.     ASSERT(program # NIL);
  754.     ASSERT(name # NIL);
  755.  
  756.     NEW(unit);
  757.  
  758.     unit.program     := program;
  759.     unit.name        := name;
  760.     unit.closed      := FALSE;
  761.     unit.idents      := LISTS.create(NIL);
  762.     unit.frwPointers := LISTS.create(NIL);
  763.  
  764.     ASSERT(openScope(unit, NIL));
  765.  
  766.     enterStTypes(unit, program);
  767.     enterStProcs(unit);
  768.  
  769.     ASSERT(openScope(unit, NIL));
  770.  
  771.     unit.gscope := unit.idents.last(IDENT);
  772.  
  773.     LISTS.push(program.units, unit);
  774.  
  775.     unit.scopeLvl := 0;
  776.     unit.scopes[0] := NIL;
  777.  
  778.     unit.sysimport := FALSE;
  779.  
  780.     IF unit.name.s = UTILS.RTL_NAME THEN
  781.         program.rtl := unit
  782.     END
  783.  
  784.     RETURN unit
  785. END newUnit;
  786.  
  787.  
  788. PROCEDURE getField* (self: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;
  789. VAR
  790.     field: FIELD;
  791.  
  792. BEGIN
  793.     ASSERT(self # NIL);
  794.     ASSERT(name # NIL);
  795.     ASSERT(unit # NIL);
  796.  
  797.     field := NIL;
  798.     WHILE (self # NIL) & (field = NIL) DO
  799.  
  800.         field := self.fields.first(FIELD);
  801.  
  802.         WHILE (field # NIL) & (field.name # name) DO
  803.             field := field.next(FIELD)
  804.         END;
  805.  
  806.         IF field = NIL THEN
  807.             self := self.base
  808.         END
  809.  
  810.     END;
  811.  
  812.     IF (field # NIL) & (self.unit # unit) & ~field.export THEN
  813.         field := NIL
  814.     END
  815.  
  816.     RETURN field
  817. END getField;
  818.  
  819.  
  820. PROCEDURE addField* (self: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
  821. VAR
  822.     field: FIELD;
  823.     res:   BOOLEAN;
  824.  
  825. BEGIN
  826.     ASSERT(name # NIL);
  827.  
  828.     res := getField(self, name, self.unit) = NIL;
  829.  
  830.     IF res THEN
  831.         NEW(field);
  832.  
  833.         field.name   := name;
  834.         field.export := export;
  835.         field.type   := NIL;
  836.         field.offset := self.size;
  837.  
  838.         LISTS.push(self.fields, field)
  839.     END
  840.  
  841.     RETURN res
  842. END addField;
  843.  
  844.  
  845. PROCEDURE setFields* (self: TYPE_; type: TYPE_): BOOLEAN;
  846. VAR
  847.     item: FIELD;
  848.     res:  BOOLEAN;
  849.  
  850. BEGIN
  851.     ASSERT(type # NIL);
  852.  
  853.     item := self.fields.first(FIELD);
  854.  
  855.     WHILE (item # NIL) & (item.type # NIL) DO
  856.         item := item.next(FIELD)
  857.     END;
  858.  
  859.     res := TRUE;
  860.  
  861.     WHILE res & (item # NIL) & (item.type = NIL) DO
  862.         item.type := type;
  863.         IF ~self.noalign THEN
  864.             res := UTILS.Align(self.size, type.align)
  865.         ELSE
  866.             res := TRUE
  867.         END;
  868.         item.offset := self.size;
  869.         res := res & (UTILS.maxint - self.size >= type.size);
  870.         IF res THEN
  871.             INC(self.size, type.size)
  872.         END;
  873.         item := item.next(FIELD)
  874.     END
  875.  
  876.     RETURN res
  877. END setFields;
  878.  
  879.  
  880. PROCEDURE getParam* (self: TYPE_; name: SCAN.IDENT): PARAM;
  881. VAR
  882.     item: PARAM;
  883.  
  884. BEGIN
  885.     ASSERT(name # NIL);
  886.  
  887.     item := self.params.first(PARAM);
  888.  
  889.     WHILE (item # NIL) & (item.name # name) DO
  890.         item := item.next(PARAM)
  891.     END
  892.  
  893.     RETURN item
  894. END getParam;
  895.  
  896.  
  897. PROCEDURE addParam* (self: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
  898. VAR
  899.     param: PARAM;
  900.     res:   BOOLEAN;
  901.  
  902. BEGIN
  903.     ASSERT(name # NIL);
  904.  
  905.     res := getParam(self, name) = NIL;
  906.  
  907.     IF res THEN
  908.         NEW(param);
  909.  
  910.         param.name := name;
  911.         param.type := NIL;
  912.         param.vPar := vPar;
  913.  
  914.         LISTS.push(self.params, param)
  915.     END
  916.  
  917.     RETURN res
  918. END addParam;
  919.  
  920.  
  921. PROCEDURE Dim* (t: TYPE_): INTEGER;
  922. VAR
  923.     res: INTEGER;
  924.  
  925. BEGIN
  926.     res := 0;
  927.     WHILE isOpenArray(t) DO
  928.         t := t.base;
  929.         INC(res)
  930.     END
  931.     RETURN res
  932. END Dim;
  933.  
  934.  
  935. PROCEDURE OpenBase* (t: TYPE_): TYPE_;
  936. BEGIN
  937.     WHILE isOpenArray(t) DO t := t.base END
  938.     RETURN t
  939. END OpenBase;
  940.  
  941.  
  942. PROCEDURE getFloatParamsPos* (self: TYPE_; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
  943. VAR
  944.     res: SET;
  945.     param: PARAM;
  946.  
  947. BEGIN
  948.     res := {};
  949.     int := 0;
  950.     flt := 0;
  951.     param := self.params.first(PARAM);
  952.     WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO
  953.         IF ~param.vPar & (param.type.typ = tREAL) THEN
  954.             INCL(res, param.offset - STACK_FRAME);
  955.             INC(flt)
  956.         END;
  957.         param := param.next(PARAM)
  958.     END;
  959.  
  960.     int := self.parSize - flt
  961.  
  962.     RETURN res
  963. END getFloatParamsPos;
  964.  
  965.  
  966. PROCEDURE setParams* (self: TYPE_; type: TYPE_);
  967. VAR
  968.     item: LISTS.ITEM;
  969.     param: PARAM;
  970.     word, size: INTEGER;
  971.  
  972. BEGIN
  973.     ASSERT(type # NIL);
  974.  
  975.     word := UTILS.target.bit_depth DIV 8;
  976.  
  977.     item := self.params.first;
  978.  
  979.     WHILE (item # NIL) & (item(PARAM).type # NIL) DO
  980.         item := item.next
  981.     END;
  982.  
  983.     WHILE (item # NIL) & (item(PARAM).type = NIL) DO
  984.         param := item(PARAM);
  985.         param.type := type;
  986.         IF param.vPar THEN
  987.             IF type.typ = tRECORD THEN
  988.                 size := 2
  989.             ELSIF isOpenArray(type) THEN
  990.                 size := Dim(type) + 1
  991.             ELSE
  992.                 size := 1
  993.             END;
  994.             param.offset := self.parSize + ORD(type.typ = tRECORD) + Dim(type) + STACK_FRAME;
  995.             INC(self.parSize, size)
  996.         ELSE
  997.             IF type.typ IN {tRECORD, tARRAY} THEN
  998.                 IF isOpenArray(type) THEN
  999.                     size := Dim(type) + 1
  1000.                 ELSE
  1001.                     size := 1
  1002.                 END
  1003.             ELSE
  1004.                 size := type.size;
  1005.                 ASSERT(UTILS.Align(size, word));
  1006.                 size := size DIV word
  1007.             END;
  1008.             param.offset := self.parSize + Dim(type) + STACK_FRAME;
  1009.             INC(self.parSize, size)
  1010.         END;
  1011.  
  1012.         item := item.next
  1013.     END
  1014.  
  1015. END setParams;
  1016.  
  1017.  
  1018. PROCEDURE enterType* (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
  1019. VAR
  1020.     t: TYPE_;
  1021.  
  1022. BEGIN
  1023.     NEW(t);
  1024.  
  1025.     t.typ     := typ;
  1026.     t.size    := size;
  1027.     t.length  := length;
  1028.     t.align   := 0;
  1029.     t.base    := NIL;
  1030.     t.fields  := LISTS.create(NIL);
  1031.     t.params  := LISTS.create(NIL);
  1032.     t.unit    := unit;
  1033.     t.num     := 0;
  1034.  
  1035.     CASE TARGETS.BitDepth OF
  1036.     |16: t.call := default16
  1037.     |32: t.call := default32
  1038.     |64: t.call := default64
  1039.     END;
  1040.  
  1041.     t.import  := FALSE;
  1042.     t.noalign := FALSE;
  1043.     t.parSize := 0;
  1044.  
  1045.     IF typ IN {tARRAY, tRECORD} THEN
  1046.         t.closed := FALSE;
  1047.         IF typ = tRECORD THEN
  1048.             INC(program.recCount);
  1049.             t.num := program.recCount
  1050.         END
  1051.     ELSE
  1052.         t.closed := TRUE
  1053.     END;
  1054.  
  1055.     LISTS.push(program.types, t)
  1056.  
  1057.     RETURN t
  1058. END enterType;
  1059.  
  1060.  
  1061. PROCEDURE getType* (program: PROGRAM; typ: INTEGER): TYPE_;
  1062. VAR
  1063.     res: TYPE_;
  1064.  
  1065. BEGIN
  1066.  
  1067.     CASE typ OF
  1068.     |ARITH.tINTEGER: res := program.stTypes.tINTEGER
  1069.     |ARITH.tREAL:    res := program.stTypes.tREAL
  1070.     |ARITH.tSET:     res := program.stTypes.tSET
  1071.     |ARITH.tBOOLEAN: res := program.stTypes.tBOOLEAN
  1072.     |ARITH.tCHAR:    res := program.stTypes.tCHAR
  1073.     |ARITH.tWCHAR:   res := program.stTypes.tWCHAR
  1074.     |ARITH.tSTRING:  res := program.stTypes.tSTRING
  1075.     END
  1076.  
  1077.     RETURN res
  1078. END getType;
  1079.  
  1080.  
  1081. PROCEDURE createSysUnit (program: PROGRAM);
  1082. VAR
  1083.     ident: IDENT;
  1084.     unit:  UNIT;
  1085.  
  1086.  
  1087.     PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
  1088.     VAR
  1089.         ident: IDENT;
  1090.     BEGIN
  1091.         ident := addIdent(sys, SCAN.enterid(name), idtyp);
  1092.         ident.stproc := proc;
  1093.         ident.export := TRUE
  1094.     END EnterProc;
  1095.  
  1096.  
  1097. BEGIN
  1098.     unit := newUnit(program, SCAN.enterid("$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, "PUT8",   idSYSPROC, sysPUT8);
  1107.     EnterProc(unit, "PUT",    idSYSPROC, sysPUT);
  1108.     EnterProc(unit, "CODE",   idSYSPROC, sysCODE);
  1109.     EnterProc(unit, "MOVE",   idSYSPROC, sysMOVE);
  1110.            (*
  1111.     IF program.target.sys = mConst.Target_iMSP430 THEN
  1112.         EnterProc(unit, "NOP",  idSYSPROC, sysNOP);
  1113.         EnterProc(unit, "EINT", idSYSPROC, sysEINT);
  1114.         EnterProc(unit, "DINT", idSYSPROC, sysDINT)
  1115.     END;
  1116.          *)
  1117.     IF TARGETS.RealSize # 0 THEN
  1118.         EnterProc(unit, "INF",    idSYSFUNC, sysINF);
  1119.     END;
  1120.  
  1121.     IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
  1122.         EnterProc(unit, "COPY",   idSYSPROC, sysCOPY)
  1123.     END;
  1124.  
  1125.     IF TARGETS.BitDepth >= 32 THEN
  1126.         EnterProc(unit, "WSADR",  idSYSFUNC, sysWSADR);
  1127.         EnterProc(unit, "PUT32",  idSYSPROC, sysPUT32);
  1128.         EnterProc(unit, "PUT16",  idSYSPROC, sysPUT16);
  1129.  
  1130.         ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
  1131.         ident.type := program.stTypes.tCARD32;
  1132.         ident.export := TRUE
  1133.     END;
  1134.  
  1135.     closeUnit(unit);
  1136.  
  1137.     program.sysunit := unit
  1138. END createSysUnit;
  1139.  
  1140.  
  1141. PROCEDURE DelUnused* (program: PROGRAM; DelImport: DELIMPORT);
  1142. VAR
  1143.     proc: PROC;
  1144.     flag: BOOLEAN;
  1145.  
  1146.  
  1147.     PROCEDURE process (proc: PROC);
  1148.     VAR
  1149.         used_proc: LISTS.ITEM;
  1150.  
  1151.     BEGIN
  1152.         proc.processed := TRUE;
  1153.  
  1154.         used_proc := proc.using.first;
  1155.         WHILE used_proc # NIL DO
  1156.             used_proc(USED_PROC).proc.used := TRUE;
  1157.             used_proc := used_proc.next
  1158.         END
  1159.  
  1160.     END process;
  1161.  
  1162.  
  1163. BEGIN
  1164.  
  1165.     REPEAT
  1166.         flag := FALSE;
  1167.         proc := program.procs.first(PROC);
  1168.  
  1169.         WHILE proc # NIL DO
  1170.             IF proc.used & ~proc.processed THEN
  1171.                 process(proc);
  1172.                 flag := TRUE
  1173.             END;
  1174.             proc := proc.next(PROC)
  1175.         END
  1176.  
  1177.     UNTIL ~flag;
  1178.  
  1179.     proc := program.procs.first(PROC);
  1180.  
  1181.     WHILE proc # NIL DO
  1182.         IF ~proc.used THEN
  1183.             IF proc.import = NIL THEN
  1184.                 IL.delete2(proc.enter, proc.leave)
  1185.             ELSE
  1186.                 DelImport(proc.import)
  1187.             END
  1188.         END;
  1189.         proc := proc.next(PROC)
  1190.     END
  1191.  
  1192. END DelUnused;
  1193.  
  1194.  
  1195. PROCEDURE create* (options: OPTIONS): PROGRAM;
  1196. VAR
  1197.     program: PROGRAM;
  1198.  
  1199. BEGIN
  1200.     idents := C.create();
  1201.  
  1202.     UTILS.SetBitDepth(TARGETS.BitDepth, TARGETS.RealSize = 8);
  1203.     NEW(program);
  1204.  
  1205.     program.options := options;
  1206.  
  1207.     CASE TARGETS.OS OF
  1208.     |TARGETS.osWIN32:    program.sysflags := {sf_windows, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
  1209.     |TARGETS.osLINUX32:  program.sysflags := {sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
  1210.     |TARGETS.osKOS:      program.sysflags := {sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
  1211.     |TARGETS.osWIN64:    program.sysflags := {sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
  1212.     |TARGETS.osLINUX64:  program.sysflags := {sf_linux, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
  1213.     |TARGETS.osNONE:     program.sysflags := {sf_code}
  1214.     END;
  1215.  
  1216.     program.recCount := -1;
  1217.     program.bss := 0;
  1218.  
  1219.     program.units := LISTS.create(NIL);
  1220.     program.types := LISTS.create(NIL);
  1221.     program.procs := LISTS.create(NIL);
  1222.  
  1223.     program.stTypes.tINTEGER := enterType(program, tINTEGER, TARGETS.WordSize, 0, NIL);
  1224.     program.stTypes.tBYTE    := enterType(program, tBYTE,                   1, 0, NIL);
  1225.     program.stTypes.tCHAR    := enterType(program, tCHAR,                   1, 0, NIL);
  1226.     program.stTypes.tSET     := enterType(program, tSET,     TARGETS.WordSize, 0, NIL);
  1227.     program.stTypes.tBOOLEAN := enterType(program, tBOOLEAN,                1, 0, NIL);
  1228.  
  1229.     program.stTypes.tINTEGER.align := TARGETS.WordSize;
  1230.     program.stTypes.tBYTE.align    := 1;
  1231.     program.stTypes.tCHAR.align    := 1;
  1232.     program.stTypes.tSET.align     := TARGETS.WordSize;
  1233.     program.stTypes.tBOOLEAN.align := 1;
  1234.  
  1235.     IF TARGETS.BitDepth >= 32 THEN
  1236.         program.stTypes.tWCHAR  := enterType(program, tWCHAR,  2, 0, NIL);
  1237.         program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL);
  1238.         program.stTypes.tWCHAR.align  := 2;
  1239.         program.stTypes.tCARD32.align := 4
  1240.     END;
  1241.  
  1242.     IF TARGETS.RealSize # 0 THEN
  1243.         program.stTypes.tREAL := enterType(program, tREAL, TARGETS.RealSize, 0, NIL);
  1244.         program.stTypes.tREAL.align := TARGETS.RealSize
  1245.     END;
  1246.  
  1247.     program.stTypes.tSTRING := enterType(program, tSTRING, TARGETS.WordSize, 0, NIL);
  1248.     program.stTypes.tNIL    := enterType(program, tNIL,    TARGETS.WordSize, 0, NIL);
  1249.  
  1250.     program.stTypes.tANYREC := enterType(program, tRECORD, 0, 0, NIL);
  1251.     program.stTypes.tANYREC.closed := TRUE;
  1252.  
  1253.     createSysUnit(program)
  1254.  
  1255.     RETURN program
  1256. END create;
  1257.  
  1258.  
  1259. END PROG.