Subversion Repositories Kolibri OS

Rev

Rev 7597 | 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, mConst := CONSTANTS, IL, UTILS;
  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.     tCARD16*  = 13;  tCARD32*    = 14;  tANYREC* = 15;  tWCHAR*  = 16;
  28.  
  29.     BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD16, 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*, base*, 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.         dll*:        BOOLEAN;
  203.         obj*:        BOOLEAN;
  204.  
  205.         stTypes*:    RECORD
  206.  
  207.             tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*,
  208.             tSTRING*, tNIL*, tCARD16*, tCARD32*, tANYREC*: TYPE_
  209.  
  210.         END;
  211.  
  212.         target*:     RECORD
  213.  
  214.             bit_depth*:  INTEGER;
  215.             word*:       INTEGER;
  216.             adr*:        INTEGER;
  217.             sys*:        INTEGER;
  218.             sysflags*:   SET;
  219.             options*:    OPTIONS
  220.  
  221.         END
  222.  
  223.     END;
  224.  
  225.     DELIMPORT = PROCEDURE (import: LISTS.ITEM);
  226.  
  227.  
  228. VAR
  229.  
  230.     idents: C.COLLECTION;
  231.  
  232.  
  233. PROCEDURE NewIdent (): IDENT;
  234. VAR
  235.     ident: IDENT;
  236.     citem: C.ITEM;
  237.  
  238. BEGIN
  239.     citem := C.pop(idents);
  240.     IF citem = NIL THEN
  241.         NEW(ident)
  242.     ELSE
  243.         ident := citem(IDENT)
  244.     END
  245.  
  246.     RETURN ident
  247. END NewIdent;
  248.  
  249.  
  250. PROCEDURE getOffset* (program: PROGRAM; varIdent: IDENT): INTEGER;
  251. VAR
  252.     word: INTEGER;
  253.     size: INTEGER;
  254.  
  255. BEGIN
  256.     IF varIdent.offset = -1 THEN
  257.         IF varIdent.global THEN
  258.             IF UTILS.Align(program.bss, varIdent.type.align) THEN
  259.                 IF UTILS.maxint - program.bss >= varIdent.type.size THEN
  260.                     varIdent.offset := program.bss;
  261.                     INC(program.bss, varIdent.type.size)
  262.                 END
  263.             END
  264.         ELSE
  265.             word := program.target.word;
  266.             size := varIdent.type.size;
  267.             IF UTILS.Align(size, word) THEN
  268.                 size := size DIV word;
  269.                 IF UTILS.maxint - program.locsize >= size THEN
  270.                     INC(program.locsize, size);
  271.                     varIdent.offset := program.locsize;
  272.                 END
  273.             END
  274.         END
  275.     END
  276.  
  277.     RETURN varIdent.offset
  278. END getOffset;
  279.  
  280.  
  281. PROCEDURE closeUnit* (unit: UNIT);
  282. VAR
  283.     ident, prev: IDENT;
  284.     offset: INTEGER;
  285.  
  286. BEGIN
  287.     ident := unit.idents.last(IDENT);
  288.     WHILE (ident # NIL) & (ident.typ # idGUARD) DO
  289.         IF (ident.typ = idVAR) & (ident.offset = -1) THEN
  290.             ERRORS.HintMsg(ident.name.s, ident.pos.line, ident.pos.col, 0);
  291.             IF ident.export THEN
  292.                 offset := getOffset(unit.program, ident)
  293.             END
  294.         END;
  295.         ident := ident.prev(IDENT)
  296.     END;
  297.  
  298.     ident := unit.idents.last(IDENT);
  299.     WHILE ident # NIL DO
  300.         prev := ident.prev(IDENT);
  301.         IF ~ident.export THEN
  302.             LISTS.delete(unit.idents, ident);
  303.             C.push(idents, ident)
  304.         END;
  305.         ident := prev
  306.     END;
  307.  
  308.     unit.closed := TRUE
  309. END closeUnit;
  310.  
  311.  
  312. PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;
  313. VAR
  314.     item: IDENT;
  315.  
  316. BEGIN
  317.     ASSERT(ident # NIL);
  318.  
  319.     item := unit.idents.last(IDENT);
  320.     WHILE (item.typ # idGUARD) & (item.name # ident) DO
  321.         item := item.prev(IDENT)
  322.     END
  323.  
  324.     RETURN item.typ = idGUARD
  325. END unique;
  326.  
  327.  
  328. PROCEDURE addIdent* (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
  329. VAR
  330.     item:  IDENT;
  331.     res:   BOOLEAN;
  332.     proc:  PROC;
  333.     procs: LISTS.LIST;
  334.  
  335. BEGIN
  336.     ASSERT(unit # NIL);
  337.     ASSERT(ident # NIL);
  338.  
  339.     res := unique(unit, ident);
  340.  
  341.     IF res THEN
  342.         item := NewIdent();
  343.  
  344.         item.name   := ident;
  345.         item.typ    := typ;
  346.         item.unit   := NIL;
  347.         item.export := FALSE;
  348.         item.import := NIL;
  349.         item.type   := NIL;
  350.         item.value.typ := 0;
  351.         item.stproc := 0;
  352.  
  353.         item.global := unit.scopeLvl = 0;
  354.         item.scopeLvl := unit.scopeLvl;
  355.         item.offset := -1;
  356.  
  357.         IF item.typ IN {idPROC, idIMP} THEN
  358.             NEW(proc);
  359.             proc.import := NIL;
  360.             proc.label := 0;
  361.             proc.used := FALSE;
  362.             proc.processed := FALSE;
  363.             proc.using := LISTS.create(NIL);
  364.             procs := unit.program.procs;
  365.             LISTS.push(procs, proc);
  366.             item.proc := proc
  367.         END;
  368.  
  369.         LISTS.push(unit.idents, item)
  370.     ELSE
  371.         item := NIL
  372.     END
  373.  
  374.     RETURN item
  375. END addIdent;
  376.  
  377.  
  378. PROCEDURE UseProc* (unit: UNIT; call_proc: PROC);
  379. VAR
  380.     procs: LISTS.LIST;
  381.     cur:   LISTS.ITEM;
  382.     proc:  USED_PROC;
  383.  
  384. BEGIN
  385.     IF unit.scopeLvl = 0 THEN
  386.         call_proc.used := TRUE
  387.     ELSE
  388.         procs := unit.scopes[unit.scopeLvl].using;
  389.  
  390.         cur := procs.first;
  391.         WHILE (cur # NIL) & (cur(USED_PROC).proc # call_proc) DO
  392.             cur := cur.next
  393.         END;
  394.  
  395.         IF cur = NIL THEN
  396.             NEW(proc);
  397.             proc.proc := call_proc;
  398.             LISTS.push(procs, proc)
  399.         END
  400.     END
  401. END UseProc;
  402.  
  403.  
  404. PROCEDURE setVarsType* (unit: UNIT; type: TYPE_);
  405. VAR
  406.     item: IDENT;
  407.  
  408. BEGIN
  409.     ASSERT(type # NIL);
  410.  
  411.     item := unit.idents.last(IDENT);
  412.     WHILE (item # NIL) & (item.typ = idVAR) & (item.type = NIL) DO
  413.         item.type := type;
  414.         item := item.prev(IDENT)
  415.     END
  416. END setVarsType;
  417.  
  418.  
  419. PROCEDURE getIdent* (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;
  420. VAR
  421.     item: IDENT;
  422.  
  423. BEGIN
  424.     ASSERT(ident # NIL);
  425.  
  426.     item := unit.idents.last(IDENT);
  427.  
  428.     IF item # NIL THEN
  429.  
  430.         IF currentScope THEN
  431.             WHILE (item.name # ident) & (item.typ # idGUARD) DO
  432.                 item := item.prev(IDENT)
  433.             END;
  434.             IF item.name # ident THEN
  435.                 item := NIL
  436.             END
  437.         ELSE
  438.             WHILE (item # NIL) & (item.name # ident) DO
  439.                 item := item.prev(IDENT)
  440.             END
  441.         END
  442.  
  443.     END
  444.  
  445.     RETURN item
  446. END getIdent;
  447.  
  448.  
  449. PROCEDURE openScope* (unit: UNIT; proc: PROC): BOOLEAN;
  450. VAR
  451.     item: IDENT;
  452.     res:  BOOLEAN;
  453.  
  454. BEGIN
  455.     INC(unit.scopeLvl);
  456.  
  457.     res := unit.scopeLvl < MAXSCOPE;
  458.  
  459.     IF res THEN
  460.  
  461.         unit.scopes[unit.scopeLvl] := proc;
  462.  
  463.         NEW(item);
  464.         item := NewIdent();
  465.  
  466.         item.name := NIL;
  467.         item.typ  := idGUARD;
  468.  
  469.         LISTS.push(unit.idents, item)
  470.     END
  471.  
  472.     RETURN res
  473. END openScope;
  474.  
  475.  
  476. PROCEDURE closeScope* (unit: UNIT; variables: LISTS.LIST);
  477. VAR
  478.     item: IDENT;
  479.     del:  IDENT;
  480.     lvar: IL.LOCALVAR;
  481.  
  482. BEGIN
  483.     item := unit.idents.last(IDENT);
  484.  
  485.     WHILE (item # NIL) & (item.typ # idGUARD) DO
  486.         del  := item;
  487.         item := item.prev(IDENT);
  488.         IF (del.typ = idVAR) & (del.offset = -1) THEN
  489.             ERRORS.HintMsg(del.name.s, del.pos.line, del.pos.col, 0)
  490.         END;
  491.         IF (variables # NIL) & (del.typ IN {idVAR, idPARAM}) & (del.offset # -1) THEN
  492.             IF del.type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN
  493.                 lvar := IL.NewVar();
  494.                 lvar.offset := del.offset;
  495.                 lvar.size   := del.type.size;
  496.                 IF del.typ = idVAR THEN
  497.                     lvar.offset := -lvar.offset
  498.                 END;
  499.                 LISTS.push(variables, lvar)
  500.             END
  501.         END;
  502.         LISTS.delete(unit.idents, del);
  503.         C.push(idents, del)
  504.     END;
  505.  
  506.     IF (item # NIL) & (item.typ = idGUARD) THEN
  507.         LISTS.delete(unit.idents, item);
  508.         C.push(idents, item)
  509.     END;
  510.  
  511.     DEC(unit.scopeLvl)
  512.  
  513. END closeScope;
  514.  
  515.  
  516. PROCEDURE frwPtr* (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
  517. VAR
  518.     newptr: FRWPTR;
  519.  
  520. BEGIN
  521.     ASSERT(unit # NIL);
  522.     ASSERT(type # NIL);
  523.     ASSERT(baseIdent # NIL);
  524.  
  525.     NEW(newptr);
  526.  
  527.     newptr.type      := type;
  528.     newptr.baseIdent := baseIdent;
  529.     newptr.pos       := pos;
  530.     newptr.linked    := FALSE;
  531.     newptr.notRecord := FALSE;
  532.  
  533.     LISTS.push(unit.frwPointers, newptr)
  534. END frwPtr;
  535.  
  536.  
  537. PROCEDURE linkPtr* (unit: UNIT): FRWPTR;
  538. VAR
  539.     item:  FRWPTR;
  540.     ident: IDENT;
  541.     res:   FRWPTR;
  542.  
  543. BEGIN
  544.     res  := NIL;
  545.     item := unit.frwPointers.last(FRWPTR);
  546.  
  547.     WHILE (item # NIL) & ~item.linked & (res = NIL) DO
  548.         ident := getIdent(unit, item.baseIdent, TRUE);
  549.  
  550.         IF (ident # NIL) THEN
  551.             IF (ident.typ = idTYPE) & (ident.type.typ = tRECORD) THEN
  552.                 item.type.base := ident.type;
  553.                 item.linked := TRUE
  554.             ELSE
  555.                 item.notRecord := TRUE;
  556.                 res := item
  557.             END
  558.         ELSE
  559.             item.notRecord := FALSE;
  560.             res := item
  561.         END;
  562.  
  563.         item := item.prev(FRWPTR)
  564.     END
  565.  
  566.     RETURN res
  567. END linkPtr;
  568.  
  569.  
  570. PROCEDURE isTypeEq* (t1, t2: TYPE_): BOOLEAN;
  571. VAR
  572.     res: BOOLEAN;
  573.     param1, param2: LISTS.ITEM;
  574.  
  575. BEGIN
  576.     IF t1 = t2 THEN
  577.         res := TRUE
  578.     ELSIF (t1 = NIL) OR (t2 = NIL) THEN
  579.         res := FALSE
  580.     ELSIF (t1.typ = tPROCEDURE) & (t2.typ = tPROCEDURE) THEN
  581.  
  582.         param1 := t1.params.first;
  583.         param2 := t2.params.first;
  584.  
  585.         res := ((t1.call = t2.call) OR (t1.call IN {code, _code}) OR (t2.call IN {code, _code})) & ((param1 # NIL) = (param2 # NIL));
  586.  
  587.         WHILE res & (param1 # NIL) & (param2 # NIL) DO
  588.             res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM).type, param2(PARAM).type);
  589.             param1 := param1.next;
  590.             param2 := param2.next;
  591.             res := res & ((param1 # NIL) = (param2 # NIL))
  592.         END;
  593.  
  594.         res := res & isTypeEq(t1.base, t2.base)
  595.  
  596.     ELSIF (t1.typ = tARRAY) & (t2.typ = tARRAY) THEN
  597.         res := (t1.length = 0) & (t2.length = 0) & isTypeEq(t1.base, t2.base)
  598.     ELSE
  599.         res := FALSE
  600.     END
  601.  
  602.     RETURN res
  603. END isTypeEq;
  604.  
  605.  
  606. PROCEDURE isBaseOf* (t0, t1: TYPE_): BOOLEAN;
  607. VAR
  608.     res: BOOLEAN;
  609.  
  610. BEGIN
  611.     res := (t0.typ = t1.typ) & (t0.typ IN {tPOINTER, tRECORD});
  612.  
  613.     IF res & (t0.typ = tPOINTER) THEN
  614.         t0 := t0.base;
  615.         t1 := t1.base
  616.     END;
  617.  
  618.     IF res THEN
  619.         WHILE (t1 # NIL) & (t1 # t0) DO
  620.             t1 := t1.base
  621.         END;
  622.         res := t1 # NIL
  623.     END
  624.  
  625.     RETURN res
  626. END isBaseOf;
  627.  
  628.  
  629. PROCEDURE isOpenArray* (t: TYPE_): BOOLEAN;
  630.     RETURN (t.typ = tARRAY) & (t.length = 0)
  631. END isOpenArray;
  632.  
  633.  
  634. PROCEDURE getUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;
  635. VAR
  636.     item: UNIT;
  637.  
  638. BEGIN
  639.     ASSERT(name # NIL);
  640.  
  641.     item := program.units.first(UNIT);
  642.  
  643.     WHILE (item # NIL) & (item.name # name) DO
  644.         item := item.next(UNIT)
  645.     END;
  646.  
  647.     IF (item = NIL) & (name.s = "SYSTEM") THEN
  648.         item := program.sysunit
  649.     END
  650.  
  651.     RETURN item
  652. END getUnit;
  653.  
  654.  
  655. PROCEDURE enterStTypes (unit: UNIT; program: PROGRAM);
  656. VAR
  657.     ident: IDENT;
  658.  
  659. BEGIN
  660.     ident      := addIdent(unit, SCAN.enterid("INTEGER"), idTYPE);
  661.     ident.type := program.stTypes.tINTEGER;
  662.  
  663.     ident      := addIdent(unit, SCAN.enterid("BYTE"), idTYPE);
  664.     ident.type := program.stTypes.tBYTE;
  665.  
  666.     ident      := addIdent(unit, SCAN.enterid("CHAR"), idTYPE);
  667.     ident.type := program.stTypes.tCHAR;
  668.  
  669.     ident      := addIdent(unit, SCAN.enterid("SET"), idTYPE);
  670.     ident.type := program.stTypes.tSET;
  671.  
  672.     ident      := addIdent(unit, SCAN.enterid("BOOLEAN"), idTYPE);
  673.     ident.type := program.stTypes.tBOOLEAN;
  674.  
  675.     IF program.target.sys # mConst.Target_iMSP430 THEN
  676.         ident      := addIdent(unit, SCAN.enterid("REAL"), idTYPE);
  677.         ident.type := program.stTypes.tREAL;
  678.  
  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 unit.program.target.sys # mConst.Target_iMSP430 THEN
  731.         EnterProc(unit, "PACK",    stPACK);
  732.         EnterProc(unit, "UNPK",    stUNPK);
  733.         EnterProc(unit, "DISPOSE", stDISPOSE);
  734.  
  735.         EnterFunc(unit, "WCHR",    stWCHR);
  736.         EnterFunc(unit, "FLOOR",   stFLOOR);
  737.         EnterFunc(unit, "FLT",     stFLT)
  738.     END
  739.  
  740. END enterStProcs;
  741.  
  742.  
  743. PROCEDURE newUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;
  744. VAR
  745.     unit: UNIT;
  746.  
  747. BEGIN
  748.     ASSERT(program # NIL);
  749.     ASSERT(name # NIL);
  750.  
  751.     NEW(unit);
  752.  
  753.     unit.program     := program;
  754.     unit.name        := name;
  755.     unit.closed      := FALSE;
  756.     unit.idents      := LISTS.create(NIL);
  757.     unit.frwPointers := LISTS.create(NIL);
  758.  
  759.     ASSERT(openScope(unit, NIL));
  760.  
  761.     enterStTypes(unit, program);
  762.     enterStProcs(unit);
  763.  
  764.     ASSERT(openScope(unit, NIL));
  765.  
  766.     unit.gscope := unit.idents.last(IDENT);
  767.  
  768.     LISTS.push(program.units, unit);
  769.  
  770.     unit.scopeLvl := 0;
  771.     unit.scopes[0] := NIL;
  772.  
  773.     unit.sysimport := FALSE;
  774.  
  775.     IF unit.name.s = mConst.RTL_NAME THEN
  776.         program.rtl := unit
  777.     END
  778.  
  779.     RETURN unit
  780. END newUnit;
  781.  
  782.  
  783. PROCEDURE getField* (self: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;
  784. VAR
  785.     field: FIELD;
  786.  
  787. BEGIN
  788.     ASSERT(self # NIL);
  789.     ASSERT(name # NIL);
  790.     ASSERT(unit # NIL);
  791.  
  792.     field := NIL;
  793.     WHILE (self # NIL) & (field = NIL) DO
  794.  
  795.         field := self.fields.first(FIELD);
  796.  
  797.         WHILE (field # NIL) & (field.name # name) DO
  798.             field := field.next(FIELD)
  799.         END;
  800.  
  801.         IF field = NIL THEN
  802.             self := self.base
  803.         END
  804.  
  805.     END;
  806.  
  807.     IF (field # NIL) & (self.unit # unit) & ~field.export THEN
  808.         field := NIL
  809.     END
  810.  
  811.     RETURN field
  812. END getField;
  813.  
  814.  
  815. PROCEDURE addField* (self: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
  816. VAR
  817.     field: FIELD;
  818.     res:   BOOLEAN;
  819.  
  820. BEGIN
  821.     ASSERT(name # NIL);
  822.  
  823.     res := getField(self, name, self.unit) = NIL;
  824.  
  825.     IF res THEN
  826.         NEW(field);
  827.  
  828.         field.name   := name;
  829.         field.export := export;
  830.         field.type   := NIL;
  831.         field.offset := self.size;
  832.  
  833.         LISTS.push(self.fields, field)
  834.     END
  835.  
  836.     RETURN res
  837. END addField;
  838.  
  839.  
  840. PROCEDURE setFields* (self: TYPE_; type: TYPE_): BOOLEAN;
  841. VAR
  842.     item: FIELD;
  843.     res:  BOOLEAN;
  844.  
  845. BEGIN
  846.     ASSERT(type # NIL);
  847.  
  848.     item := self.fields.first(FIELD);
  849.  
  850.     WHILE (item # NIL) & (item.type # NIL) DO
  851.         item := item.next(FIELD)
  852.     END;
  853.  
  854.     res := TRUE;
  855.  
  856.     WHILE res & (item # NIL) & (item.type = NIL) DO
  857.         item.type := type;
  858.         IF ~self.noalign THEN
  859.             res := UTILS.Align(self.size, type.align)
  860.         ELSE
  861.             res := TRUE
  862.         END;
  863.         item.offset := self.size;
  864.         res := res & (UTILS.maxint - self.size >= type.size);
  865.         IF res THEN
  866.             INC(self.size, type.size)
  867.         END;
  868.         item := item.next(FIELD)
  869.     END
  870.  
  871.     RETURN res
  872. END setFields;
  873.  
  874.  
  875. PROCEDURE getParam* (self: TYPE_; name: SCAN.IDENT): PARAM;
  876. VAR
  877.     item: PARAM;
  878.  
  879. BEGIN
  880.     ASSERT(name # NIL);
  881.  
  882.     item := self.params.first(PARAM);
  883.  
  884.     WHILE (item # NIL) & (item.name # name) DO
  885.         item := item.next(PARAM)
  886.     END
  887.  
  888.     RETURN item
  889. END getParam;
  890.  
  891.  
  892. PROCEDURE addParam* (self: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
  893. VAR
  894.     param: PARAM;
  895.     res:   BOOLEAN;
  896.  
  897. BEGIN
  898.     ASSERT(name # NIL);
  899.  
  900.     res := getParam(self, name) = NIL;
  901.  
  902.     IF res THEN
  903.         NEW(param);
  904.  
  905.         param.name := name;
  906.         param.type := NIL;
  907.         param.vPar := vPar;
  908.  
  909.         LISTS.push(self.params, param)
  910.     END
  911.  
  912.     RETURN res
  913. END addParam;
  914.  
  915.  
  916. PROCEDURE Dim* (t: TYPE_): INTEGER;
  917. VAR
  918.     res: INTEGER;
  919.  
  920. BEGIN
  921.     res := 0;
  922.     WHILE isOpenArray(t) DO
  923.         t := t.base;
  924.         INC(res)
  925.     END
  926.     RETURN res
  927. END Dim;
  928.  
  929.  
  930. PROCEDURE OpenBase* (t: TYPE_): TYPE_;
  931. BEGIN
  932.     WHILE isOpenArray(t) DO t := t.base END
  933.     RETURN t
  934. END OpenBase;
  935.  
  936.  
  937. PROCEDURE getFloatParamsPos* (self: TYPE_; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
  938. VAR
  939.     res: SET;
  940.     param: PARAM;
  941.  
  942. BEGIN
  943.     res := {};
  944.     int := 0;
  945.     flt := 0;
  946.     param := self.params.first(PARAM);
  947.     WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO
  948.         IF ~param.vPar & (param.type.typ = tREAL) THEN
  949.             INCL(res, param.offset - STACK_FRAME);
  950.             INC(flt)
  951.         END;
  952.         param := param.next(PARAM)
  953.     END;
  954.  
  955.     int := self.parSize - flt
  956.  
  957.     RETURN res
  958. END getFloatParamsPos;
  959.  
  960.  
  961. PROCEDURE setParams* (self: TYPE_; type: TYPE_);
  962. VAR
  963.     item: LISTS.ITEM;
  964.     param: PARAM;
  965.     word, size: INTEGER;
  966.  
  967. BEGIN
  968.     ASSERT(type # NIL);
  969.  
  970.     word := UTILS.target.bit_depth DIV 8;
  971.  
  972.     item := self.params.first;
  973.  
  974.     WHILE (item # NIL) & (item(PARAM).type # NIL) DO
  975.         item := item.next
  976.     END;
  977.  
  978.     WHILE (item # NIL) & (item(PARAM).type = NIL) DO
  979.         param := item(PARAM);
  980.         param.type := type;
  981.         IF param.vPar THEN
  982.             IF type.typ = tRECORD THEN
  983.                 size := 2
  984.             ELSIF isOpenArray(type) THEN
  985.                 size := Dim(type) + 1
  986.             ELSE
  987.                 size := 1
  988.             END;
  989.             param.offset := self.parSize + ORD(type.typ = tRECORD) + Dim(type) + STACK_FRAME;
  990.             INC(self.parSize, size)
  991.         ELSE
  992.             IF type.typ IN {tRECORD, tARRAY} THEN
  993.                 IF isOpenArray(type) THEN
  994.                     size := Dim(type) + 1
  995.                 ELSE
  996.                     size := 1
  997.                 END
  998.             ELSE
  999.                 size := type.size;
  1000.                 ASSERT(UTILS.Align(size, word));
  1001.                 size := size DIV word
  1002.             END;
  1003.             param.offset := self.parSize + Dim(type) + STACK_FRAME;
  1004.             INC(self.parSize, size)
  1005.         END;
  1006.  
  1007.         item := item.next
  1008.     END
  1009.  
  1010. END setParams;
  1011.  
  1012.  
  1013. PROCEDURE enterType* (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
  1014. VAR
  1015.     t: TYPE_;
  1016.  
  1017. BEGIN
  1018.     NEW(t);
  1019.  
  1020.     t.typ     := typ;
  1021.     t.size    := size;
  1022.     t.length  := length;
  1023.     t.align   := 0;
  1024.     t.base    := NIL;
  1025.     t.fields  := LISTS.create(NIL);
  1026.     t.params  := LISTS.create(NIL);
  1027.     t.unit    := unit;
  1028.     t.num     := 0;
  1029.  
  1030.     CASE program.target.bit_depth OF
  1031.     |16: t.call := default16
  1032.     |32: t.call := default32
  1033.     |64: t.call := default64
  1034.     END;
  1035.  
  1036.     t.import  := FALSE;
  1037.     t.noalign := FALSE;
  1038.     t.parSize := 0;
  1039.  
  1040.     IF typ IN {tARRAY, tRECORD} THEN
  1041.         t.closed := FALSE;
  1042.         IF typ = tRECORD THEN
  1043.             INC(program.recCount);
  1044.             t.num := program.recCount
  1045.         END
  1046.     ELSE
  1047.         t.closed := TRUE
  1048.     END;
  1049.  
  1050.     LISTS.push(program.types, t)
  1051.  
  1052.     RETURN t
  1053. END enterType;
  1054.  
  1055.  
  1056. PROCEDURE getType* (program: PROGRAM; typ: INTEGER): TYPE_;
  1057. VAR
  1058.     res: TYPE_;
  1059.  
  1060. BEGIN
  1061.  
  1062.     IF typ = ARITH.tINTEGER THEN
  1063.         res := program.stTypes.tINTEGER
  1064.     ELSIF typ = ARITH.tREAL THEN
  1065.         res := program.stTypes.tREAL
  1066.     ELSIF typ = ARITH.tSET THEN
  1067.         res := program.stTypes.tSET
  1068.     ELSIF typ = ARITH.tBOOLEAN THEN
  1069.         res := program.stTypes.tBOOLEAN
  1070.     ELSIF typ = ARITH.tCHAR THEN
  1071.         res := program.stTypes.tCHAR
  1072.     ELSIF typ = ARITH.tWCHAR THEN
  1073.         res := program.stTypes.tWCHAR
  1074.     ELSIF typ = ARITH.tSTRING THEN
  1075.         res := program.stTypes.tSTRING
  1076.     ELSE
  1077.         res := NIL
  1078.     END;
  1079.  
  1080.     ASSERT(res # NIL)
  1081.  
  1082.     RETURN res
  1083. END getType;
  1084.  
  1085.  
  1086. PROCEDURE createSysUnit (program: PROGRAM);
  1087. VAR
  1088.     ident: IDENT;
  1089.     unit:  UNIT;
  1090.  
  1091.  
  1092.     PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
  1093.     VAR
  1094.         ident: IDENT;
  1095.     BEGIN
  1096.         ident := addIdent(sys, SCAN.enterid(name), idtyp);
  1097.         ident.stproc := proc;
  1098.         ident.export := TRUE
  1099.     END EnterProc;
  1100.  
  1101.  
  1102. BEGIN
  1103.     unit := newUnit(program, SCAN.enterid("$SYSTEM"));
  1104.  
  1105.     EnterProc(unit, "ADR",    idSYSFUNC, sysADR);
  1106.     EnterProc(unit, "SIZE",   idSYSFUNC, sysSIZE);
  1107.     EnterProc(unit, "SADR",   idSYSFUNC, sysSADR);
  1108.     EnterProc(unit, "TYPEID", idSYSFUNC, sysTYPEID);
  1109.  
  1110.     EnterProc(unit, "GET",    idSYSPROC, sysGET);
  1111.     EnterProc(unit, "PUT8",   idSYSPROC, sysPUT8);
  1112.     EnterProc(unit, "PUT",    idSYSPROC, sysPUT);
  1113.     EnterProc(unit, "CODE",   idSYSPROC, sysCODE);
  1114.     EnterProc(unit, "MOVE",   idSYSPROC, sysMOVE);
  1115.            (*
  1116.     IF program.target.sys = mConst.Target_iMSP430 THEN
  1117.         EnterProc(unit, "NOP",  idSYSPROC, sysNOP);
  1118.         EnterProc(unit, "EINT", idSYSPROC, sysEINT);
  1119.         EnterProc(unit, "DINT", idSYSPROC, sysDINT)
  1120.     END;
  1121.          *)
  1122.     IF program.target.sys # mConst.Target_iMSP430 THEN
  1123.         EnterProc(unit, "WSADR",  idSYSFUNC, sysWSADR);
  1124.         EnterProc(unit, "INF",    idSYSFUNC, sysINF);
  1125.         EnterProc(unit, "PUT32",  idSYSPROC, sysPUT32);
  1126.         EnterProc(unit, "PUT16",  idSYSPROC, sysPUT16);
  1127.         EnterProc(unit, "COPY",   idSYSPROC, sysCOPY);
  1128.  
  1129.         ident := addIdent(unit, SCAN.enterid("CARD16"), idTYPE);
  1130.         ident.type := program.stTypes.tCARD16;
  1131.         ident.export := TRUE;
  1132.  
  1133.         ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
  1134.         ident.type := program.stTypes.tCARD32;
  1135.         ident.export := TRUE
  1136.     END;
  1137.  
  1138.     closeUnit(unit);
  1139.  
  1140.     program.sysunit := unit
  1141. END createSysUnit;
  1142.  
  1143.  
  1144. PROCEDURE DelUnused* (program: PROGRAM; DelImport: DELIMPORT);
  1145. VAR
  1146.     proc: PROC;
  1147.     flag: BOOLEAN;
  1148.  
  1149.  
  1150.     PROCEDURE process (proc: PROC);
  1151.     VAR
  1152.         used_proc: LISTS.ITEM;
  1153.  
  1154.     BEGIN
  1155.         proc.processed := TRUE;
  1156.  
  1157.         used_proc := proc.using.first;
  1158.         WHILE used_proc # NIL DO
  1159.             used_proc(USED_PROC).proc.used := TRUE;
  1160.             used_proc := used_proc.next
  1161.         END
  1162.  
  1163.     END process;
  1164.  
  1165.  
  1166. BEGIN
  1167.  
  1168.     REPEAT
  1169.         flag := FALSE;
  1170.         proc := program.procs.first(PROC);
  1171.  
  1172.         WHILE proc # NIL DO
  1173.             IF proc.used & ~proc.processed THEN
  1174.                 process(proc);
  1175.                 flag := TRUE
  1176.             END;
  1177.             proc := proc.next(PROC)
  1178.         END
  1179.  
  1180.     UNTIL ~flag;
  1181.  
  1182.     proc := program.procs.first(PROC);
  1183.  
  1184.     WHILE proc # NIL DO
  1185.         IF ~proc.used THEN
  1186.             IF proc.import = NIL THEN
  1187.                 IL.delete2(proc.enter, proc.leave)
  1188.             ELSE
  1189.                 DelImport(proc.import)
  1190.             END
  1191.         END;
  1192.         proc := proc.next(PROC)
  1193.     END
  1194.  
  1195. END DelUnused;
  1196.  
  1197.  
  1198. PROCEDURE create* (bit_depth, target: INTEGER; options: OPTIONS): PROGRAM;
  1199. VAR
  1200.     program: PROGRAM;
  1201.  
  1202. BEGIN
  1203.     idents := C.create();
  1204.  
  1205.     UTILS.SetBitDepth(bit_depth);
  1206.     NEW(program);
  1207.  
  1208.     program.target.bit_depth := bit_depth;
  1209.     program.target.word      := bit_depth DIV 8;
  1210.     program.target.adr       := bit_depth DIV 8;
  1211.     program.target.sys       := target;
  1212.     program.target.options   := options;
  1213.  
  1214.     CASE target OF
  1215.     |mConst.Target_iConsole,
  1216.      mConst.Target_iGUI,
  1217.      mConst.Target_iDLL:        program.target.sysflags := {sf_windows, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
  1218.  
  1219.     |mConst.Target_iELF32,
  1220.      mConst.Target_iELFSO32:    program.target.sysflags := {sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
  1221.  
  1222.     |mConst.Target_iKolibri,
  1223.      mConst.Target_iObject:     program.target.sysflags := {sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
  1224.  
  1225.     |mConst.Target_iConsole64,
  1226.      mConst.Target_iGUI64,
  1227.      mConst.Target_iDLL64:      program.target.sysflags := {sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
  1228.  
  1229.     |mConst.Target_iELF64,
  1230.      mConst.Target_iELFSO64:    program.target.sysflags := {sf_linux, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
  1231.  
  1232.     |mConst.Target_iMSP430:     program.target.sysflags := {sf_code}
  1233.     END;
  1234.  
  1235.     program.recCount := -1;
  1236.     program.bss := 0;
  1237.  
  1238.     program.units := LISTS.create(NIL);
  1239.     program.types := LISTS.create(NIL);
  1240.     program.procs := LISTS.create(NIL);
  1241.  
  1242.     program.stTypes.tINTEGER := enterType(program, tINTEGER,  program.target.word, 0, NIL);
  1243.     program.stTypes.tBYTE    := enterType(program, tBYTE,                       1, 0, NIL);
  1244.     program.stTypes.tCHAR    := enterType(program, tCHAR,                       1, 0, NIL);
  1245.     program.stTypes.tSET     := enterType(program, tSET,      program.target.word, 0, NIL);
  1246.     program.stTypes.tBOOLEAN := enterType(program, tBOOLEAN,                    1, 0, NIL);
  1247.  
  1248.     IF target # mConst.Target_iMSP430 THEN
  1249.         program.stTypes.tWCHAR   := enterType(program, tWCHAR,  2, 0, NIL);
  1250.         program.stTypes.tREAL    := enterType(program, tREAL,   8, 0, NIL);
  1251.         program.stTypes.tCARD16  := enterType(program, tCARD16, 2, 0, NIL);
  1252.         program.stTypes.tCARD32  := enterType(program, tCARD32, 4, 0, NIL)
  1253.     END;
  1254.  
  1255.     program.stTypes.tSTRING  := enterType(program, tSTRING, program.target.word, 0, NIL);
  1256.     program.stTypes.tNIL     := enterType(program, tNIL,    program.target.word, 0, NIL);
  1257.  
  1258.     program.stTypes.tANYREC  := enterType(program, tRECORD, 0, 0, NIL);
  1259.     program.stTypes.tANYREC.closed := TRUE;
  1260.  
  1261.     program.stTypes.tINTEGER.align := program.stTypes.tINTEGER.size;
  1262.     program.stTypes.tBYTE.align    := 1;
  1263.     program.stTypes.tCHAR.align    := program.stTypes.tCHAR.size;
  1264.     program.stTypes.tSET.align     := program.stTypes.tSET.size;
  1265.     program.stTypes.tBOOLEAN.align := program.stTypes.tBOOLEAN.size;
  1266.  
  1267.     IF target # mConst.Target_iMSP430 THEN
  1268.         program.stTypes.tWCHAR.align   := program.stTypes.tWCHAR.size;
  1269.         program.stTypes.tREAL.align    := program.stTypes.tREAL.size;
  1270.         program.stTypes.tCARD16.align  := program.stTypes.tCARD16.size;
  1271.         program.stTypes.tCARD32.align  := program.stTypes.tCARD32.size
  1272.     END;
  1273.  
  1274.     program.dll := FALSE;
  1275.     program.obj := FALSE;
  1276.  
  1277.     createSysUnit(program)
  1278.  
  1279.     RETURN program
  1280. END create;
  1281.  
  1282.  
  1283. END PROG.