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