Subversion Repositories Kolibri OS

Rev

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