Subversion Repositories Kolibri OS

Rev

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 CODE;
  9.  
  10. IMPORT LISTS, SCAN, STRINGS, CHL := CHUNKLISTS, C := COLLECTIONS;
  11.  
  12.  
  13. CONST
  14.  
  15.     little_endian* = 0;
  16.     big_endian* = 1;
  17.  
  18.     call_stack* = 0;
  19.     call_win64* = 1;
  20.     call_sysv*  = 2;
  21.  
  22.     opJMP* = 0; opLABEL* = 1; opCOPYS* = 2; opGADR* = 3; opCONST* = 4; opLLOAD32* = 5;
  23.     opCOPYA* = 6; opCASET* = 7; opMULC* = 8; opMUL* = 9;
  24.     opDIV* = 10; opMOD* = 11; opDIVL* = 12; opMODL* = 13; opDIVR* = 14; opMODR* = 15;
  25.     opUMINUS* = 16;
  26.     opADD* = 17; opSUB* = 18; opADDL* = 19; opSUBL* = 20; opADDR* = 21; opSUBR* = 22;
  27.     opSAVE* = 23; opSAVEC* = 24; opSAVE8* = 25; opSAVE8C* = 26; opCHKBYTE* = 27; opDROP* = 28;
  28.     opNOT* = 29;
  29.  
  30.     opEQ*  = 30; opNE*  = 31; opLT*  = 32; opLE*  = 33; opGT*  = 34; opGE*  = 35;
  31.     opEQL* = 36; opNEL* = 37; opLTL* = 38; opLEL* = 39; opGTL* = 40; opGEL* = 41;
  32.     opEQR* = 42; opNER* = 43; opLTR* = 44; opLER* = 45; opGTR* = 46; opGER* = 47;
  33.  
  34.     opVLOAD32* = 48; opGLOAD32* = 49;
  35.  
  36.     opJNE* = 50; opJE* = 51;
  37.  
  38.     opEQS* = 52; opNES* = opEQS + 1; opLTS* = opEQS + 2; opLES* = opEQS + 3; opGTS* = opEQS + 4; opGES* = opEQS + 5 (* 58 *);
  39.  
  40.     opSAVE32* = 58; opLLOAD8* = 59;
  41.  
  42.     opCONSTF* = 60; opLOADF* = 61; opSAVEF* = 62; opMULF* = 63; opDIVF* = 64; opDIVFI* = 65;
  43.     opUMINF* = 66; opADDFI* = 67; opSUBFI* = 68; opADDF* = 69; opSUBF* = 70;
  44.  
  45.     opINC1B* = 71; opDEC1B* = 72; opINCCB* = 73; opDECCB* = 74; opINCB* = 75; opDECB* = 76;
  46.  
  47.     opCASEL* = 77; opCASER* = 78; opCASELR* = 79;
  48.  
  49.     opEQF*  = 80; opNEF*  = opEQF + 1; opLTF*  = opEQF + 2; opLEF*  = opEQF + 3; opGTF*  = opEQF + 4; opGEF*  = opEQF + 5;
  50.     opEQFI* = opEQF + 6; opNEFI* = opEQF + 7; opLTFI* = opEQF + 8; opLEFI* = opEQF + 9; opGTFI* = opEQF + 10; opGEFI* = opEQF + 11; (* 91 *)
  51.  
  52.     opLOAD8* = 92; opLOAD16* = 93; opLOAD32* = 94; opPRECALL* = 95; opRES* = 96; opRESF* = 97;
  53.     opERRC* = 98; opSWITCH* = 99;
  54.  
  55.     opSBOOL* = 100; opSBOOLC* = 101; opNOP* = 102;
  56.  
  57.     opMULS* = 103; opMULSC* = 104; opDIVS* = 105; opDIVSC* = 106;
  58.     opADDS* = 107; opSUBS* = 108; opADDSL* = 109; opSUBSL* = 110; opADDSR* = 111; opSUBSR* = 112;
  59.     opUMINS* = 113; opIN* = 114; opINL* = 115; opINR* = 116;
  60.     opRSET* = 117; opRSETL* = 118; opRSETR* = 119; opRSET1* = 120; opLENGTH* = 121;
  61.  
  62.     opINC1* = 122; opDEC1* = 123; opINCC* = 124; opDECC* = 125; opINC* = 126; opDEC* = 127;
  63.     opINCL* = 128; opEXCL* = 129; opINCLC* = 130; opEXCLC* = 131; opNEW* = 132; opDISP* = 133;
  64.     opPACK* = 134; opPACKC* = 135; opUNPK* = 136; opCOPY* = 137; opENTER* = 138; opLEAVE* = 139;
  65.     opCALL* = 140; opSAVEP* = 141; opCALLP* = 142; opEQP* = 143; opNEP* = 144; opLEAVER* = 145;
  66.     opGET* = 146; opSAVE16* = 147; opABS* = 148; opFABS* = 149; opFLOOR* = 150; opFLT* = 151;
  67.     opODD* = 152; opORD* = 153; opASR* = 154; opLSL* = 155; opROR* = 156;
  68.     opASR1* = 157; opLSL1* = 158; opROR1* = 159; opASR2* = 160; opLSL2* = 161; opROR2* = 162;
  69.     opPUSHP* = 163; opLADR* = 164; opTYPEGP* = 165; opIS* = 166; opPUSHF* = 167; opVADR* = 168;
  70.     opPUSHT* = 169; opTYPEGR* = 170; opISREC* = 171; opCHKIDX* = 172; opPARAM* = 173;
  71.     opCHKIDX2* = 174; opLEN* = 175; opROT* = 176; opSAVES* = 177; opSADR* = 178; opERR* = 179;
  72.  
  73.     opCHR* = 180; opENDSW* = 181; opLEAVEF* = 182; opCLEANUP* = 183; opMOVE* = 184;
  74.     opLSR* = 185; opLSR1* = 186; opLSR2* = 187;
  75.     opMIN* = 188; opMINC* = 189; opMAX* = 190; opMAXC* = 191; opJNZ* = 192;
  76.     opEQB* = 193; opNEB* = 194; opINF* = 195; opJZ* = 196; opVLOAD8* = 197; opGLOAD8* = 198;
  77.     opLLOAD16* = 199; opVLOAD16* = 200; opGLOAD16* = 201;
  78.     opLOAD64* = 202; opLLOAD64* = 203; opVLOAD64* = 204; opGLOAD64* = 205; opSAVE64* = 206;
  79.  
  80.     opTYPEGD* = 207; opCALLI* = 208; opPUSHIP* = 209; opSAVEIP* = 210; opEQIP* = 211; opNEIP* = 212;
  81.     opSAVE16C* = 213; opWCHR* = 214; opCOPYS2* = 215; opLENGTHW* = 216;
  82.  
  83.     opEQS2*  = 217; opNES2* = opEQS2 + 1; opLTS2* = opEQS2 + 2; opLES2* = opEQS2 + 3; opGTS2* = opEQS2 + 4; opGES2* = opEQS2 + 5 (* 222 *);
  84.     opEQSW*  = 223; opNESW* = opEQSW + 1; opLTSW* = opEQSW + 2; opLESW* = opEQSW + 3; opGTSW* = opEQSW + 4; opGESW* = opEQSW + 5 (* 228 *);
  85.     opEQSW2*  = 229; opNESW2* = opEQSW2 + 1; opLTSW2* = opEQSW2 + 2; opLESW2* = opEQSW2 + 3; opGTSW2* = opEQSW2 + 4; opGESW2* = opEQSW2 + 5 (* 234 *);
  86.  
  87.     opCODE* = 235;
  88.  
  89.     opALIGN16* = 236; opPOPSP* = 237;
  90.     opWIN64CALL* = 238; opWIN64CALLI* = 239; opWIN64CALLP* = 240; opLOOP* = 241; opENDLOOP* = 242;
  91.     opSYSVCALL* = 243; opSYSVCALLI* = 244; opSYSVCALLP* = 245; opSYSVALIGN16* = 246; opWIN64ALIGN16* = 247;
  92.  
  93.  
  94.     opSADR_PARAM* = 1000; opLOAD64_PARAM* = 1001; opLLOAD64_PARAM* = 1002; opGLOAD64_PARAM* = 1003;
  95.     opVADR_PARAM* = 1004; opCONST_PARAM* = 1005; opGLOAD32_PARAM* = 1006; opLLOAD32_PARAM* = 1007;
  96.     opLOAD32_PARAM* = 1008;
  97.  
  98.     opLADR_SAVEC* = 1009; opGADR_SAVEC* = 1010; opLADR_SAVE* = 1011;
  99.  
  100.     opLADR_INC1* = 1012; opLADR_DEC1* = 1013; opLADR_INCC* = 1014; opLADR_DECC* = 1015;
  101.     opLADR_INC1B* = 1016; opLADR_DEC1B* = 1017; opLADR_INCCB* = 1018; opLADR_DECCB* = 1019;
  102.     opLADR_INC* = 1020; opLADR_DEC* = 1021; opLADR_INCB* = 1022; opLADR_DECB* = 1023;
  103.     opLADR_INCL* = 1024; opLADR_EXCL* = 1025; opLADR_INCLC* = 1026; opLADR_EXCLC* = 1027;
  104.     opLADR_UNPK* = 1028;
  105.  
  106.  
  107.     _move      *=   0;
  108.     _move2     *=   1;
  109.     _strcmpw   *=   2;
  110.     _strcmpw2  *=   3;
  111.     _set       *=   4;
  112.     _set2      *=   5;
  113.     _lengthw   *=   6;
  114.     _strcmp2   *=   7;
  115.     _div       *=   8;
  116.     _mod       *=   9;
  117.     _div2      *=  10;
  118.     _mod2      *=  11;
  119.     _arrcpy    *=  12;
  120.     _rot       *=  13;
  121.     _new       *=  14;
  122.     _dispose   *=  15;
  123.     _strcmp    *=  16;
  124.     _error     *=  17;
  125.     _is        *=  18;
  126.     _isrec     *=  19;
  127.     _guard     *=  20;
  128.     _guardrec  *=  21;
  129.     _length    *=  22;
  130.     _init      *=  23;
  131.     _dllentry  *=  24;
  132.     _strcpy    *=  25;
  133.     _exit      *=  26;
  134.     _strcpy2   *=  27;
  135.  
  136.  
  137. TYPE
  138.  
  139.     LOCALVAR* = POINTER TO RECORD (LISTS.ITEM)
  140.  
  141.         offset*, size*, count*: INTEGER
  142.  
  143.     END;
  144.  
  145.     COMMAND* = POINTER TO RECORD (LISTS.ITEM)
  146.  
  147.         opcode*:    INTEGER;
  148.         param1*:    INTEGER;
  149.         param2*:    INTEGER;
  150.         param3*:    INTEGER;
  151.         float*:     REAL;
  152.         variables*: LISTS.LIST;
  153.         allocReg*:  BOOLEAN
  154.  
  155.     END;
  156.  
  157.     CMDSTACK = POINTER TO RECORD
  158.  
  159.         data: ARRAY 1000 OF COMMAND;
  160.         top:  INTEGER
  161.  
  162.     END;
  163.  
  164.     EXPORT_PROC* = POINTER TO RECORD (LISTS.ITEM)
  165.  
  166.         label*: INTEGER;
  167.         name*:  SCAN.LEXSTR
  168.  
  169.     END;
  170.  
  171.     IMPORT_LIB* = POINTER TO RECORD (LISTS.ITEM)
  172.  
  173.         name*:   SCAN.LEXSTR;
  174.         procs*:  LISTS.LIST
  175.  
  176.     END;
  177.  
  178.     IMPORT_PROC* = POINTER TO RECORD (LISTS.ITEM)
  179.  
  180.         label*: INTEGER;
  181.         lib*:   IMPORT_LIB;
  182.         name*:  SCAN.LEXSTR;
  183.         count:  INTEGER
  184.  
  185.     END;
  186.  
  187.  
  188.     CODES* = POINTER TO RECORD
  189.  
  190.         last:       COMMAND;
  191.         begcall:    CMDSTACK;
  192.         endcall:    CMDSTACK;
  193.         commands*:  LISTS.LIST;
  194.         export*:    LISTS.LIST;
  195.         import*:    LISTS.LIST;
  196.         types*:     CHL.INTLIST;
  197.         data*:      CHL.BYTELIST;
  198.         dmin*:      INTEGER;
  199.         lcount*:    INTEGER;
  200.         bss*:       INTEGER;
  201.         rtl*:       ARRAY 28 OF INTEGER;
  202.  
  203.         charoffs:   ARRAY 256 OF INTEGER;
  204.         wcharoffs:  ARRAY 65536 OF INTEGER;
  205.  
  206.         fregs:      INTEGER;
  207.         wstr:       ARRAY 4*1024 OF WCHAR;
  208.  
  209.         errlabel*:  INTEGER
  210.  
  211.     END;
  212.  
  213.  
  214. VAR
  215.  
  216.     codes*: CODES;
  217.     endianness: INTEGER;
  218.     numRegsFloat: INTEGER;
  219.  
  220.     commands, variables: C.COLLECTION;
  221.  
  222.  
  223. PROCEDURE NewCmd (): COMMAND;
  224. VAR
  225.     cmd:   COMMAND;
  226.     citem: C.ITEM;
  227.  
  228. BEGIN
  229.     citem := C.pop(commands);
  230.     IF citem = NIL THEN
  231.         NEW(cmd)
  232.     ELSE
  233.         cmd := citem(COMMAND)
  234.     END;
  235.  
  236.     cmd.allocReg := FALSE
  237.  
  238.     RETURN cmd
  239. END NewCmd;
  240.  
  241.  
  242. PROCEDURE NewVar* (): LOCALVAR;
  243. VAR
  244.     lvar:  LOCALVAR;
  245.     citem: C.ITEM;
  246.  
  247. BEGIN
  248.     citem := C.pop(variables);
  249.     IF citem = NIL THEN
  250.         NEW(lvar)
  251.     ELSE
  252.         lvar := citem(LOCALVAR)
  253.     END;
  254.  
  255.     lvar.count := 0
  256.  
  257.     RETURN lvar
  258. END NewVar;
  259.  
  260.  
  261. PROCEDURE setlast* (cmd: COMMAND);
  262. BEGIN
  263.     codes.last := cmd
  264. END setlast;
  265.  
  266.  
  267. PROCEDURE getlast* (): COMMAND;
  268.     RETURN codes.last
  269. END getlast;
  270.  
  271.  
  272. PROCEDURE PutByte (codes: CODES; b: BYTE);
  273. BEGIN
  274.     CHL.PushByte(codes.data, b)
  275. END PutByte;
  276.  
  277.  
  278. PROCEDURE putstr* (s: ARRAY OF CHAR): INTEGER;
  279. VAR
  280.     i, n, res: INTEGER;
  281. BEGIN
  282.     res := CHL.Length(codes.data);
  283.  
  284.     i := 0;
  285.     n := LENGTH(s);
  286.     WHILE i < n DO
  287.         PutByte(codes, ORD(s[i]));
  288.         INC(i)
  289.     END;
  290.  
  291.     PutByte(codes, 0)
  292.  
  293.     RETURN res
  294. END putstr;
  295.  
  296.  
  297. PROCEDURE putstr1* (c: INTEGER): INTEGER;
  298. VAR
  299.     res: INTEGER;
  300.  
  301. BEGIN
  302.     IF codes.charoffs[c] = -1 THEN
  303.         res := CHL.Length(codes.data);
  304.         PutByte(codes, c);
  305.         PutByte(codes, 0);
  306.         codes.charoffs[c] := res
  307.     ELSE
  308.         res := codes.charoffs[c]
  309.     END
  310.  
  311.     RETURN res
  312. END putstr1;
  313.  
  314.  
  315. PROCEDURE putstrW* (s: ARRAY OF CHAR): INTEGER;
  316. VAR
  317.     i, n, res: INTEGER;
  318.  
  319. BEGIN
  320.     res := CHL.Length(codes.data);
  321.  
  322.     IF ODD(res) THEN
  323.         PutByte(codes, 0);
  324.         INC(res)
  325.     END;
  326.  
  327.     n := STRINGS.Utf8To16(s, codes.wstr);
  328.  
  329.     i := 0;
  330.     WHILE i < n DO
  331.         IF endianness = little_endian THEN
  332.             PutByte(codes, ORD(codes.wstr[i]) MOD 256);
  333.             PutByte(codes, ORD(codes.wstr[i]) DIV 256)
  334.         ELSIF endianness = big_endian THEN
  335.             PutByte(codes, ORD(codes.wstr[i]) DIV 256);
  336.             PutByte(codes, ORD(codes.wstr[i]) MOD 256)
  337.         END;
  338.         INC(i)
  339.     END;
  340.  
  341.     PutByte(codes, 0);
  342.     PutByte(codes, 0)
  343.  
  344.     RETURN res
  345. END putstrW;
  346.  
  347.  
  348. PROCEDURE putstrW1* (c: INTEGER): INTEGER;
  349. VAR
  350.     res: INTEGER;
  351.  
  352. BEGIN
  353.     IF codes.wcharoffs[c] = -1 THEN
  354.         res := CHL.Length(codes.data);
  355.  
  356.         IF ODD(res) THEN
  357.             PutByte(codes, 0);
  358.             INC(res)
  359.         END;
  360.  
  361.         IF endianness = little_endian THEN
  362.             PutByte(codes, c MOD 256);
  363.             PutByte(codes, c DIV 256)
  364.         ELSIF endianness = big_endian THEN
  365.             PutByte(codes, c DIV 256);
  366.             PutByte(codes, c MOD 256)
  367.         END;
  368.  
  369.         PutByte(codes, 0);
  370.         PutByte(codes, 0);
  371.  
  372.         codes.wcharoffs[c] := res
  373.     ELSE
  374.         res := codes.wcharoffs[c]
  375.     END
  376.  
  377.     RETURN res
  378. END putstrW1;
  379.  
  380.  
  381. PROCEDURE SetMinDataSize* (size: INTEGER);
  382. BEGIN
  383.     codes.dmin := CHL.Length(codes.data) + size
  384. END SetMinDataSize;
  385.  
  386.  
  387. PROCEDURE push (stk: CMDSTACK; cmd: COMMAND);
  388. BEGIN
  389.     INC(stk.top);
  390.     stk.data[stk.top] := cmd
  391. END push;
  392.  
  393.  
  394. PROCEDURE pop (stk: CMDSTACK): COMMAND;
  395. VAR
  396.     res: COMMAND;
  397. BEGIN
  398.     res := stk.data[stk.top];
  399.     DEC(stk.top)
  400.     RETURN res
  401. END pop;
  402.  
  403.  
  404. PROCEDURE pushBegEnd* (VAR beg, end: COMMAND);
  405. BEGIN
  406.     push(codes.begcall, beg);
  407.     push(codes.endcall, end);
  408.     beg := codes.last;
  409.     end := beg.next(COMMAND)
  410. END pushBegEnd;
  411.  
  412.  
  413. PROCEDURE popBegEnd* (VAR beg, end: COMMAND);
  414. BEGIN
  415.     beg := pop(codes.begcall);
  416.     end := pop(codes.endcall)
  417. END popBegEnd;
  418.  
  419.  
  420. PROCEDURE AddRec* (base: INTEGER);
  421. BEGIN
  422.     CHL.PushInt(codes.types, base)
  423. END AddRec;
  424.  
  425.  
  426. PROCEDURE insert (cur, nov: COMMAND);
  427. VAR
  428.     old_opcode, param2: INTEGER;
  429.  
  430.  
  431.     PROCEDURE set (cur: COMMAND; opcode, param2: INTEGER);
  432.     BEGIN
  433.         cur.opcode := opcode;
  434.         cur.param1 := cur.param2;
  435.         cur.param2 := param2
  436.     END set;
  437.  
  438.  
  439. BEGIN
  440.     old_opcode := cur.opcode;
  441.     param2 := nov.param2;
  442.  
  443.     IF (nov.opcode = opPARAM) & (param2 = 1) THEN
  444.  
  445.         CASE old_opcode OF
  446.         |opGLOAD64: cur.opcode := opGLOAD64_PARAM
  447.         |opLLOAD64: cur.opcode := opLLOAD64_PARAM
  448.         |opLOAD64:  cur.opcode := opLOAD64_PARAM
  449.         |opGLOAD32: cur.opcode := opGLOAD32_PARAM
  450.         |opLLOAD32: cur.opcode := opLLOAD32_PARAM
  451.         |opLOAD32:  cur.opcode := opLOAD32_PARAM
  452.         |opSADR:    cur.opcode := opSADR_PARAM
  453.         |opVADR:    cur.opcode := opVADR_PARAM
  454.         |opCONST:   cur.opcode := opCONST_PARAM
  455.         ELSE
  456.             old_opcode := -1
  457.         END
  458.  
  459.     ELSIF old_opcode = opLADR THEN
  460.  
  461.         CASE nov.opcode OF
  462.         |opSAVEC: set(cur, opLADR_SAVEC, param2)
  463.         |opSAVE:  cur.opcode := opLADR_SAVE
  464.         |opINC1:  cur.opcode := opLADR_INC1
  465.         |opDEC1:  cur.opcode := opLADR_DEC1
  466.         |opINC:   cur.opcode := opLADR_INC
  467.         |opDEC:   cur.opcode := opLADR_DEC
  468.         |opINC1B: cur.opcode := opLADR_INC1B
  469.         |opDEC1B: cur.opcode := opLADR_DEC1B
  470.         |opINCB:  cur.opcode := opLADR_INCB
  471.         |opDECB:  cur.opcode := opLADR_DECB
  472.         |opINCL:  cur.opcode := opLADR_INCL
  473.         |opEXCL:  cur.opcode := opLADR_EXCL
  474.         |opUNPK:  cur.opcode := opLADR_UNPK
  475.         |opINCC:  set(cur, opLADR_INCC, param2)
  476.         |opDECC:  set(cur, opLADR_DECC, param2)
  477.         |opINCCB: set(cur, opLADR_INCCB, param2)
  478.         |opDECCB: set(cur, opLADR_DECCB, param2)
  479.         |opINCLC: set(cur, opLADR_INCLC, param2)
  480.         |opEXCLC: set(cur, opLADR_EXCLC, param2)
  481.         ELSE
  482.             old_opcode := -1
  483.         END
  484.  
  485.     ELSIF (nov.opcode = opSAVEC) & (old_opcode = opGADR) THEN
  486.         set(cur, opGADR_SAVEC, param2)
  487.  
  488.     ELSIF (nov.opcode = opMULC) & (old_opcode = opMULC) THEN
  489.         cur.param2 := param2 * cur.param2
  490.  
  491.     ELSE
  492.         old_opcode := -1
  493.     END;
  494.  
  495.     IF old_opcode = -1 THEN
  496.         LISTS.insert(codes.commands, cur, nov);
  497.         codes.last := nov
  498.     ELSE
  499.         C.push(commands, nov);
  500.         codes.last := cur
  501.     END
  502. END insert;
  503.  
  504.  
  505. PROCEDURE AddCmd* (opcode: INTEGER; param: INTEGER);
  506. VAR
  507.     cmd: COMMAND;
  508. BEGIN
  509.     cmd := NewCmd();
  510.     cmd.opcode := opcode;
  511.     cmd.param1 := 0;
  512.     cmd.param2 := param;
  513.     insert(codes.last, cmd)
  514. END AddCmd;
  515.  
  516.  
  517. PROCEDURE AddCmd2* (opcode: INTEGER; param1, param2: INTEGER);
  518. VAR
  519.     cmd: COMMAND;
  520. BEGIN
  521.     cmd := NewCmd();
  522.     cmd.opcode := opcode;
  523.     cmd.param1 := param1;
  524.     cmd.param2 := param2;
  525.     insert(codes.last, cmd)
  526. END AddCmd2;
  527.  
  528.  
  529. PROCEDURE NewLabel* (): INTEGER;
  530. BEGIN
  531.     INC(codes.lcount)
  532.     RETURN codes.lcount - 1
  533. END NewLabel;
  534.  
  535.  
  536. PROCEDURE SetLabel* (label: INTEGER);
  537. BEGIN
  538.     AddCmd(opLABEL, label)
  539. END SetLabel;
  540.  
  541.  
  542. PROCEDURE SetErrLabel*;
  543. BEGIN
  544.     codes.errlabel := NewLabel();
  545.     SetLabel(codes.errlabel)
  546. END SetErrLabel;
  547.  
  548.  
  549. PROCEDURE AddCmd0* (opcode: INTEGER);
  550. BEGIN
  551.     AddCmd(opcode, 0)
  552. END AddCmd0;
  553.  
  554.  
  555. PROCEDURE deleteVarList (list: LISTS.LIST);
  556. VAR
  557.     last: LISTS.ITEM;
  558.  
  559. BEGIN
  560.     WHILE list.last # NIL DO
  561.         last := LISTS.pop(list);
  562.         C.push(variables, last)
  563.     END
  564. END deleteVarList;
  565.  
  566.  
  567. PROCEDURE delete (cmd: COMMAND);
  568. BEGIN
  569.     IF cmd.variables # NIL THEN
  570.         deleteVarList(cmd.variables)
  571.     END;
  572.     LISTS.delete(codes.commands, cmd);
  573.     C.push(commands, cmd)
  574. END delete;
  575.  
  576.  
  577. PROCEDURE delete2* (first, last: LISTS.ITEM);
  578. VAR
  579.     cur, next: LISTS.ITEM;
  580.  
  581. BEGIN
  582.     cur := first;
  583.  
  584.     IF first # last THEN
  585.         REPEAT
  586.             next := cur.next;
  587.             LISTS.delete(codes.commands, cur);
  588.             C.push(commands, cur);
  589.             cur := next
  590.         UNTIL cur = last
  591.     END;
  592.  
  593.     LISTS.delete(codes.commands, cur);
  594.     C.push(commands, cur)
  595. END delete2;
  596.  
  597.  
  598. PROCEDURE AddJmpCmd* (opcode: INTEGER; label: INTEGER);
  599. VAR
  600.     prev: COMMAND;
  601.     not:  BOOLEAN;
  602.  
  603. BEGIN
  604.     prev := codes.last;
  605.     not := prev.opcode = opNOT;
  606.     IF not THEN
  607.         IF opcode = opJE THEN
  608.             opcode := opJNE
  609.         ELSIF opcode = opJNE THEN
  610.             opcode := opJE
  611.         ELSE
  612.             not := FALSE
  613.         END
  614.     END;
  615.  
  616.     AddCmd2(opcode, label, label);
  617.  
  618.     IF not THEN
  619.         delete(prev)
  620.     END
  621.  
  622. END AddJmpCmd;
  623.  
  624.  
  625. PROCEDURE OnError* (line, error: INTEGER);
  626. BEGIN
  627.     AddCmd(opERRC, LSL(line, 4) + error);
  628.     AddJmpCmd(opJMP, codes.errlabel)
  629. END OnError;
  630.  
  631.  
  632. PROCEDURE TypeGuard* (op, t: INTEGER; line, error: INTEGER);
  633. VAR
  634.     label: INTEGER;
  635. BEGIN
  636.     AddCmd(op, t);
  637.     label := NewLabel();
  638.     AddJmpCmd(opJE, label);
  639.     OnError(line, error);
  640.     SetLabel(label)
  641. END TypeGuard;
  642.  
  643.  
  644. PROCEDURE TypeCheck* (t: INTEGER);
  645. BEGIN
  646.     AddCmd(opIS, t)
  647. END TypeCheck;
  648.  
  649.  
  650. PROCEDURE TypeCheckRec* (t: INTEGER);
  651. BEGIN
  652.     AddCmd(opISREC, t)
  653. END TypeCheckRec;
  654.  
  655.  
  656. PROCEDURE New* (size, typenum: INTEGER);
  657. BEGIN
  658.     AddCmd2(opNEW, typenum, size)
  659. END New;
  660.  
  661.  
  662. PROCEDURE fcmp* (opcode: INTEGER);
  663. BEGIN
  664.     AddCmd(opcode, 0);
  665.     DEC(codes.fregs, 2);
  666.     ASSERT(codes.fregs >= 0)
  667. END fcmp;
  668.  
  669.  
  670. PROCEDURE not*;
  671. VAR
  672.     prev: COMMAND;
  673. BEGIN
  674.     prev := codes.last;
  675.     IF prev.opcode = opNOT THEN
  676.         codes.last := prev.prev(COMMAND);
  677.         delete(prev)
  678.     ELSE
  679.         AddCmd0(opNOT)
  680.     END
  681. END not;
  682.  
  683.  
  684. PROCEDURE Enter* (label, params: INTEGER): COMMAND;
  685. VAR
  686.     cmd: COMMAND;
  687.  
  688. BEGIN
  689.     cmd := NewCmd();
  690.     cmd.opcode := opENTER;
  691.     cmd.param1 := label;
  692.     cmd.param3 := params;
  693.     cmd.allocReg := TRUE;
  694.     insert(codes.last, cmd)
  695.  
  696.     RETURN codes.last
  697. END Enter;
  698.  
  699.  
  700. PROCEDURE Leave* (result, float: BOOLEAN; paramsize: INTEGER): COMMAND;
  701. BEGIN
  702.     IF result THEN
  703.         IF float THEN
  704.             AddCmd(opLEAVEF, paramsize)
  705.         ELSE
  706.             AddCmd(opLEAVER, paramsize)
  707.         END
  708.     ELSE
  709.         AddCmd(opLEAVE, paramsize)
  710.     END
  711.  
  712.     RETURN codes.last
  713. END Leave;
  714.  
  715.  
  716. PROCEDURE Call* (proc, callconv, fparams: INTEGER);
  717. BEGIN
  718.     CASE callconv OF
  719.     |call_stack: AddJmpCmd(opCALL, proc)
  720.     |call_win64: AddJmpCmd(opWIN64CALL, proc)
  721.     |call_sysv:  AddJmpCmd(opSYSVCALL, proc)
  722.     END;
  723.     codes.last(COMMAND).param2 := fparams
  724. END Call;
  725.  
  726.  
  727. PROCEDURE CallImp* (proc: LISTS.ITEM; callconv, fparams: INTEGER);
  728. BEGIN
  729.     CASE callconv OF
  730.     |call_stack: AddJmpCmd(opCALLI, proc(IMPORT_PROC).label)
  731.     |call_win64: AddJmpCmd(opWIN64CALLI, proc(IMPORT_PROC).label)
  732.     |call_sysv:  AddJmpCmd(opSYSVCALLI, proc(IMPORT_PROC).label)
  733.     END;
  734.     codes.last(COMMAND).param2 := fparams
  735. END CallImp;
  736.  
  737.  
  738. PROCEDURE CallP* (callconv, fparams: INTEGER);
  739. BEGIN
  740.     CASE callconv OF
  741.     |call_stack: AddCmd0(opCALLP)
  742.     |call_win64: AddCmd(opWIN64CALLP, fparams)
  743.     |call_sysv:  AddCmd(opSYSVCALLP, fparams)
  744.     END
  745. END CallP;
  746.  
  747.  
  748. PROCEDURE AssignProc* (proc: INTEGER);
  749. BEGIN
  750.     AddJmpCmd(opSAVEP, proc)
  751. END AssignProc;
  752.  
  753.  
  754. PROCEDURE AssignImpProc* (proc: LISTS.ITEM);
  755. BEGIN
  756.     AddJmpCmd(opSAVEIP, proc(IMPORT_PROC).label)
  757. END AssignImpProc;
  758.  
  759.  
  760. PROCEDURE PushProc* (proc: INTEGER);
  761. BEGIN
  762.     AddJmpCmd(opPUSHP, proc)
  763. END PushProc;
  764.  
  765.  
  766. PROCEDURE PushImpProc* (proc: LISTS.ITEM);
  767. BEGIN
  768.     AddJmpCmd(opPUSHIP, proc(IMPORT_PROC).label)
  769. END PushImpProc;
  770.  
  771.  
  772. PROCEDURE ProcCmp* (proc: INTEGER; eq: BOOLEAN);
  773. BEGIN
  774.     IF eq THEN
  775.         AddJmpCmd(opEQP, proc)
  776.     ELSE
  777.         AddJmpCmd(opNEP, proc)
  778.     END
  779. END ProcCmp;
  780.  
  781.  
  782. PROCEDURE ProcImpCmp* (proc: LISTS.ITEM; eq: BOOLEAN);
  783. BEGIN
  784.     IF eq THEN
  785.         AddJmpCmd(opEQIP, proc(IMPORT_PROC).label)
  786.     ELSE
  787.         AddJmpCmd(opNEIP, proc(IMPORT_PROC).label)
  788.     END
  789. END ProcImpCmp;
  790.  
  791.  
  792. PROCEDURE SysGet* (size: INTEGER);
  793. BEGIN
  794.     AddCmd(opGET, size)
  795. END SysGet;
  796.  
  797.  
  798. PROCEDURE load* (size: INTEGER);
  799. VAR
  800.     last: COMMAND;
  801.  
  802. BEGIN
  803.     last := codes.last;
  804.     CASE size OF
  805.     |1:
  806.         IF last.opcode = opLADR THEN
  807.             last.opcode := opLLOAD8
  808.         ELSIF last.opcode = opVADR THEN
  809.             last.opcode := opVLOAD8
  810.         ELSIF last.opcode = opGADR THEN
  811.             last.opcode := opGLOAD8
  812.         ELSE
  813.             AddCmd0(opLOAD8)
  814.         END
  815.  
  816.     |2:
  817.         IF last.opcode = opLADR THEN
  818.             last.opcode := opLLOAD16
  819.         ELSIF last.opcode = opVADR THEN
  820.             last.opcode := opVLOAD16
  821.         ELSIF last.opcode = opGADR THEN
  822.             last.opcode := opGLOAD16
  823.         ELSE
  824.             AddCmd0(opLOAD16)
  825.         END
  826.  
  827.     |4:
  828.         IF last.opcode = opLADR THEN
  829.             last.opcode := opLLOAD32
  830.         ELSIF last.opcode = opVADR THEN
  831.             last.opcode := opVLOAD32
  832.         ELSIF last.opcode = opGADR THEN
  833.             last.opcode := opGLOAD32
  834.         ELSE
  835.             AddCmd0(opLOAD32)
  836.         END
  837.  
  838.     |8:
  839.         IF last.opcode = opLADR THEN
  840.             last.opcode := opLLOAD64
  841.         ELSIF last.opcode = opVADR THEN
  842.             last.opcode := opVLOAD64
  843.         ELSIF last.opcode = opGADR THEN
  844.             last.opcode := opGLOAD64
  845.         ELSE
  846.             AddCmd0(opLOAD64)
  847.         END
  848.     END
  849. END load;
  850.  
  851.  
  852. PROCEDURE SysPut* (size: INTEGER);
  853. BEGIN
  854.     CASE size OF
  855.     |1: AddCmd0(opSAVE8)
  856.     |2: AddCmd0(opSAVE16)
  857.     |4: AddCmd0(opSAVE32)
  858.     |8: AddCmd0(opSAVE64)
  859.     END
  860. END SysPut;
  861.  
  862.  
  863. PROCEDURE savef*;
  864. BEGIN
  865.     AddCmd0(opSAVEF);
  866.     DEC(codes.fregs);
  867.     ASSERT(codes.fregs >= 0)
  868. END savef;
  869.  
  870.  
  871. PROCEDURE pushf*;
  872. BEGIN
  873.     AddCmd0(opPUSHF);
  874.     DEC(codes.fregs);
  875.     ASSERT(codes.fregs >= 0)
  876. END pushf;
  877.  
  878.  
  879. PROCEDURE loadf* (): BOOLEAN;
  880. BEGIN
  881.     AddCmd0(opLOADF);
  882.     INC(codes.fregs)
  883.     RETURN codes.fregs < numRegsFloat
  884. END loadf;
  885.  
  886.  
  887. PROCEDURE inf* (): BOOLEAN;
  888. BEGIN
  889.     AddCmd0(opINF);
  890.     INC(codes.fregs)
  891.     RETURN codes.fregs < numRegsFloat
  892. END inf;
  893.  
  894.  
  895. PROCEDURE fbinop* (opcode: INTEGER);
  896. BEGIN
  897.     AddCmd0(opcode);
  898.     DEC(codes.fregs);
  899.     ASSERT(codes.fregs > 0)
  900. END fbinop;
  901.  
  902.  
  903. PROCEDURE saves* (offset, length: INTEGER);
  904. BEGIN
  905.     AddCmd2(opSAVES, length, offset)
  906. END saves;
  907.  
  908.  
  909. PROCEDURE abs* (real: BOOLEAN);
  910. BEGIN
  911.     IF real THEN
  912.         AddCmd0(opFABS)
  913.     ELSE
  914.         AddCmd0(opABS)
  915.     END
  916. END abs;
  917.  
  918.  
  919. PROCEDURE floor*;
  920. BEGIN
  921.     AddCmd0(opFLOOR);
  922.     DEC(codes.fregs);
  923.     ASSERT(codes.fregs >= 0)
  924. END floor;
  925.  
  926.  
  927. PROCEDURE flt* (): BOOLEAN;
  928. BEGIN
  929.     AddCmd0(opFLT);
  930.     INC(codes.fregs)
  931.     RETURN codes.fregs < numRegsFloat
  932. END flt;
  933.  
  934.  
  935. PROCEDURE odd*;
  936. BEGIN
  937.     AddCmd0(opODD)
  938. END odd;
  939.  
  940.  
  941. PROCEDURE ord*;
  942. BEGIN
  943.     AddCmd0(opORD)
  944. END ord;
  945.  
  946.  
  947. PROCEDURE shift_minmax* (op: CHAR);
  948. BEGIN
  949.     CASE op OF
  950.     |"A": AddCmd0(opASR)
  951.     |"L": AddCmd0(opLSL)
  952.     |"O": AddCmd0(opROR)
  953.     |"R": AddCmd0(opLSR)
  954.     |"m": AddCmd0(opMIN)
  955.     |"x": AddCmd0(opMAX)
  956.     END
  957. END shift_minmax;
  958.  
  959.  
  960. PROCEDURE shift_minmax1* (op: CHAR; x: INTEGER);
  961. BEGIN
  962.     CASE op OF
  963.     |"A": AddCmd(opASR1, x)
  964.     |"L": AddCmd(opLSL1, x)
  965.     |"O": AddCmd(opROR1, x)
  966.     |"R": AddCmd(opLSR1, x)
  967.     |"m": AddCmd(opMINC, x)
  968.     |"x": AddCmd(opMAXC, x)
  969.     END
  970. END shift_minmax1;
  971.  
  972.  
  973. PROCEDURE shift_minmax2* (op: CHAR; x: INTEGER);
  974. BEGIN
  975.     CASE op OF
  976.     |"A": AddCmd(opASR2, x)
  977.     |"L": AddCmd(opLSL2, x)
  978.     |"O": AddCmd(opROR2, x)
  979.     |"R": AddCmd(opLSR2, x)
  980.     |"m": AddCmd(opMINC, x)
  981.     |"x": AddCmd(opMAXC, x)
  982.     END
  983. END shift_minmax2;
  984.  
  985.  
  986. PROCEDURE len* (dim: INTEGER);
  987. BEGIN
  988.     AddCmd(opLEN, dim)
  989. END len;
  990.  
  991.  
  992. PROCEDURE Float* (r: REAL);
  993. VAR
  994.     cmd: COMMAND;
  995.  
  996. BEGIN
  997.     cmd := NewCmd();
  998.     cmd.opcode := opCONSTF;
  999.     cmd.float := r;
  1000.     insert(codes.last, cmd);
  1001.     INC(codes.fregs);
  1002.     ASSERT(codes.fregs <= numRegsFloat)
  1003. END Float;
  1004.  
  1005.  
  1006. PROCEDURE precall* (flt: BOOLEAN): INTEGER;
  1007. VAR
  1008.     res: INTEGER;
  1009. BEGIN
  1010.     res := codes.fregs;
  1011.     AddCmd2(opPRECALL, ORD(flt), res);
  1012.     codes.fregs := 0
  1013.     RETURN res
  1014. END precall;
  1015.  
  1016.  
  1017. PROCEDURE resf* (fregs: INTEGER): BOOLEAN;
  1018. BEGIN
  1019.     AddCmd(opRESF, fregs);
  1020.     codes.fregs := fregs + 1
  1021.     RETURN codes.fregs < numRegsFloat
  1022. END resf;
  1023.  
  1024.  
  1025. PROCEDURE res* (fregs: INTEGER);
  1026. BEGIN
  1027.     AddCmd(opRES, fregs);
  1028.     codes.fregs := fregs
  1029. END res;
  1030.  
  1031.  
  1032. PROCEDURE retf*;
  1033. BEGIN
  1034.     DEC(codes.fregs);
  1035.     ASSERT(codes.fregs = 0)
  1036. END retf;
  1037.  
  1038.  
  1039. PROCEDURE drop*;
  1040. BEGIN
  1041.     AddCmd0(opDROP)
  1042. END drop;
  1043.  
  1044.  
  1045. PROCEDURE case* (a, b, L, R: INTEGER);
  1046. VAR
  1047.     cmd: COMMAND;
  1048.  
  1049. BEGIN
  1050.     IF a = b THEN
  1051.         cmd := NewCmd();
  1052.         cmd.opcode := opCASELR;
  1053.         cmd.param1 := a;
  1054.         cmd.param2 := L;
  1055.         cmd.param3 := R;
  1056.         insert(codes.last, cmd)
  1057.     ELSE
  1058.         AddCmd2(opCASEL, a, L);
  1059.         AddCmd2(opCASER, b, R)
  1060.     END
  1061. END case;
  1062.  
  1063.  
  1064. PROCEDURE caset* (a, label: INTEGER);
  1065. BEGIN
  1066.     AddCmd2(opCASET, label, a)
  1067. END caset;
  1068.  
  1069.  
  1070. PROCEDURE AddExp* (label: INTEGER; name: SCAN.LEXSTR);
  1071. VAR
  1072.     exp: EXPORT_PROC;
  1073.  
  1074. BEGIN
  1075.     NEW(exp);
  1076.     exp.label := label;
  1077.     exp.name  := name;
  1078.     LISTS.push(codes.export, exp)
  1079. END AddExp;
  1080.  
  1081.  
  1082. PROCEDURE AddImp* (dll, proc: SCAN.LEXSTR): IMPORT_PROC;
  1083. VAR
  1084.     lib: IMPORT_LIB;
  1085.     p:   IMPORT_PROC;
  1086.  
  1087. BEGIN
  1088.     lib := codes.import.first(IMPORT_LIB);
  1089.     WHILE (lib # NIL) & (lib.name # dll) DO
  1090.         lib := lib.next(IMPORT_LIB)
  1091.     END;
  1092.  
  1093.     IF lib = NIL THEN
  1094.         NEW(lib);
  1095.         lib.name := dll;
  1096.         lib.procs := LISTS.create(NIL);
  1097.         LISTS.push(codes.import, lib)
  1098.     END;
  1099.  
  1100.     p := lib.procs.first(IMPORT_PROC);
  1101.     WHILE (p # NIL) & (p.name # proc) DO
  1102.         p := p.next(IMPORT_PROC)
  1103.     END;
  1104.  
  1105.     IF p = NIL THEN
  1106.         NEW(p);
  1107.         p.name  := proc;
  1108.         p.label := NewLabel();
  1109.         p.lib   := lib;
  1110.         p.count := 1;
  1111.         LISTS.push(lib.procs, p)
  1112.     ELSE
  1113.         INC(p.count)
  1114.     END
  1115.  
  1116.     RETURN p
  1117. END AddImp;
  1118.  
  1119.  
  1120. PROCEDURE DelImport* (imp: LISTS.ITEM);
  1121. VAR
  1122.     lib: IMPORT_LIB;
  1123.  
  1124. BEGIN
  1125.     DEC(imp(IMPORT_PROC).count);
  1126.     IF imp(IMPORT_PROC).count = 0 THEN
  1127.         lib := imp(IMPORT_PROC).lib;
  1128.         LISTS.delete(lib.procs, imp);
  1129.         IF lib.procs.first = NIL THEN
  1130.             LISTS.delete(codes.import, lib)
  1131.         END
  1132.     END
  1133. END DelImport;
  1134.  
  1135.  
  1136. PROCEDURE init* (pNumRegsFloat, pEndianness: INTEGER);
  1137. VAR
  1138.     cmd:    COMMAND;
  1139.     i:      INTEGER;
  1140.  
  1141. BEGIN
  1142.     commands := C.create();
  1143.     variables := C.create();
  1144.     numRegsFloat := pNumRegsFloat;
  1145.     endianness := pEndianness;
  1146.  
  1147.     NEW(codes);
  1148.     NEW(codes.begcall);
  1149.     codes.begcall.top := -1;
  1150.     NEW(codes.endcall);
  1151.     codes.endcall.top := -1;
  1152.     codes.commands := LISTS.create(NIL);
  1153.     codes.export   := LISTS.create(NIL);
  1154.     codes.import   := LISTS.create(NIL);
  1155.     codes.types    := CHL.CreateIntList();
  1156.     codes.data     := CHL.CreateByteList();
  1157.  
  1158.     NEW(cmd); cmd.opcode := opNOP; LISTS.push(codes.commands, cmd);
  1159.     codes.last := cmd;
  1160.     NEW(cmd); cmd.opcode := opNOP; LISTS.push(codes.commands, cmd);
  1161.  
  1162.     AddRec(0);
  1163.  
  1164.     codes.lcount := 0;
  1165.  
  1166.     codes.fregs := 0;
  1167.  
  1168.     FOR i := 0 TO LEN(codes.charoffs) - 1 DO
  1169.         codes.charoffs[i] := -1
  1170.     END;
  1171.  
  1172.     FOR i := 0 TO LEN(codes.wcharoffs) - 1 DO
  1173.         codes.wcharoffs[i] := -1
  1174.     END
  1175.  
  1176. END init;
  1177.  
  1178.  
  1179. END CODE.