forked from KolibriOS/kolibrios
1181 lines
26 KiB
Plaintext
1181 lines
26 KiB
Plaintext
(*
|
|
BSD 2-Clause License
|
|
|
|
Copyright (c) 2018, 2019, Anton Krotov
|
|
All rights reserved.
|
|
*)
|
|
|
|
MODULE CODE;
|
|
|
|
IMPORT LISTS, SCAN, STRINGS, CHL := CHUNKLISTS, C := COLLECTIONS;
|
|
|
|
|
|
CONST
|
|
|
|
little_endian* = 0;
|
|
big_endian* = 1;
|
|
|
|
call_stack* = 0;
|
|
call_win64* = 1;
|
|
call_sysv* = 2;
|
|
|
|
opJMP* = 0; opLABEL* = 1; opCOPYS* = 2; opGADR* = 3; opCONST* = 4; opLLOAD32* = 5;
|
|
opCOPYA* = 6; opCASET* = 7; opMULC* = 8; opMUL* = 9;
|
|
opDIV* = 10; opMOD* = 11; opDIVL* = 12; opMODL* = 13; opDIVR* = 14; opMODR* = 15;
|
|
opUMINUS* = 16;
|
|
opADD* = 17; opSUB* = 18; opADDL* = 19; opSUBL* = 20; opADDR* = 21; opSUBR* = 22;
|
|
opSAVE* = 23; opSAVEC* = 24; opSAVE8* = 25; opSAVE8C* = 26; opCHKBYTE* = 27; opDROP* = 28;
|
|
opNOT* = 29;
|
|
|
|
opEQ* = 30; opNE* = 31; opLT* = 32; opLE* = 33; opGT* = 34; opGE* = 35;
|
|
opEQL* = 36; opNEL* = 37; opLTL* = 38; opLEL* = 39; opGTL* = 40; opGEL* = 41;
|
|
opEQR* = 42; opNER* = 43; opLTR* = 44; opLER* = 45; opGTR* = 46; opGER* = 47;
|
|
|
|
opVLOAD32* = 48; opGLOAD32* = 49;
|
|
|
|
opJNE* = 50; opJE* = 51;
|
|
|
|
opEQS* = 52; opNES* = opEQS + 1; opLTS* = opEQS + 2; opLES* = opEQS + 3; opGTS* = opEQS + 4; opGES* = opEQS + 5 (* 58 *);
|
|
|
|
opSAVE32* = 58; opLLOAD8* = 59;
|
|
|
|
opCONSTF* = 60; opLOADF* = 61; opSAVEF* = 62; opMULF* = 63; opDIVF* = 64; opDIVFI* = 65;
|
|
opUMINF* = 66; opADDFI* = 67; opSUBFI* = 68; opADDF* = 69; opSUBF* = 70;
|
|
|
|
opINC1B* = 71; opDEC1B* = 72; opINCCB* = 73; opDECCB* = 74; opINCB* = 75; opDECB* = 76;
|
|
|
|
opCASEL* = 77; opCASER* = 78; opCASELR* = 79;
|
|
|
|
opEQF* = 80; opNEF* = opEQF + 1; opLTF* = opEQF + 2; opLEF* = opEQF + 3; opGTF* = opEQF + 4; opGEF* = opEQF + 5;
|
|
opEQFI* = opEQF + 6; opNEFI* = opEQF + 7; opLTFI* = opEQF + 8; opLEFI* = opEQF + 9; opGTFI* = opEQF + 10; opGEFI* = opEQF + 11; (* 91 *)
|
|
|
|
opLOAD8* = 92; opLOAD16* = 93; opLOAD32* = 94; opPRECALL* = 95; opRES* = 96; opRESF* = 97;
|
|
opERRC* = 98; opSWITCH* = 99;
|
|
|
|
opSBOOL* = 100; opSBOOLC* = 101; opNOP* = 102;
|
|
|
|
opMULS* = 103; opMULSC* = 104; opDIVS* = 105; opDIVSC* = 106;
|
|
opADDS* = 107; opSUBS* = 108; opADDSL* = 109; opSUBSL* = 110; opADDSR* = 111; opSUBSR* = 112;
|
|
opUMINS* = 113; opIN* = 114; opINL* = 115; opINR* = 116;
|
|
opRSET* = 117; opRSETL* = 118; opRSETR* = 119; opRSET1* = 120; opLENGTH* = 121;
|
|
|
|
opINC1* = 122; opDEC1* = 123; opINCC* = 124; opDECC* = 125; opINC* = 126; opDEC* = 127;
|
|
opINCL* = 128; opEXCL* = 129; opINCLC* = 130; opEXCLC* = 131; opNEW* = 132; opDISP* = 133;
|
|
opPACK* = 134; opPACKC* = 135; opUNPK* = 136; opCOPY* = 137; opENTER* = 138; opLEAVE* = 139;
|
|
opCALL* = 140; opSAVEP* = 141; opCALLP* = 142; opEQP* = 143; opNEP* = 144; opLEAVER* = 145;
|
|
opGET* = 146; opSAVE16* = 147; opABS* = 148; opFABS* = 149; opFLOOR* = 150; opFLT* = 151;
|
|
opODD* = 152; opORD* = 153; opASR* = 154; opLSL* = 155; opROR* = 156;
|
|
opASR1* = 157; opLSL1* = 158; opROR1* = 159; opASR2* = 160; opLSL2* = 161; opROR2* = 162;
|
|
opPUSHP* = 163; opLADR* = 164; opTYPEGP* = 165; opIS* = 166; opPUSHF* = 167; opVADR* = 168;
|
|
opPUSHT* = 169; opTYPEGR* = 170; opISREC* = 171; opCHKIDX* = 172; opPARAM* = 173;
|
|
opCHKIDX2* = 174; opLEN* = 175; opROT* = 176; opSAVES* = 177; opSADR* = 178; opERR* = 179;
|
|
|
|
opCHR* = 180; opENDSW* = 181; opLEAVEF* = 182; opCLEANUP* = 183; opMOVE* = 184;
|
|
opLSR* = 185; opLSR1* = 186; opLSR2* = 187;
|
|
opMIN* = 188; opMINC* = 189; opMAX* = 190; opMAXC* = 191; opJNZ* = 192;
|
|
opEQB* = 193; opNEB* = 194; opINF* = 195; opJZ* = 196; opVLOAD8* = 197; opGLOAD8* = 198;
|
|
opLLOAD16* = 199; opVLOAD16* = 200; opGLOAD16* = 201;
|
|
opLOAD64* = 202; opLLOAD64* = 203; opVLOAD64* = 204; opGLOAD64* = 205; opSAVE64* = 206;
|
|
|
|
opTYPEGD* = 207; opCALLI* = 208; opPUSHIP* = 209; opSAVEIP* = 210; opEQIP* = 211; opNEIP* = 212;
|
|
opSAVE16C* = 213; opWCHR* = 214; opCOPYS2* = 215; opLENGTHW* = 216;
|
|
|
|
opEQS2* = 217; opNES2* = opEQS2 + 1; opLTS2* = opEQS2 + 2; opLES2* = opEQS2 + 3; opGTS2* = opEQS2 + 4; opGES2* = opEQS2 + 5 (* 222 *);
|
|
opEQSW* = 223; opNESW* = opEQSW + 1; opLTSW* = opEQSW + 2; opLESW* = opEQSW + 3; opGTSW* = opEQSW + 4; opGESW* = opEQSW + 5 (* 228 *);
|
|
opEQSW2* = 229; opNESW2* = opEQSW2 + 1; opLTSW2* = opEQSW2 + 2; opLESW2* = opEQSW2 + 3; opGTSW2* = opEQSW2 + 4; opGESW2* = opEQSW2 + 5 (* 234 *);
|
|
|
|
opCODE* = 235;
|
|
|
|
opALIGN16* = 236; opPOPSP* = 237;
|
|
opWIN64CALL* = 238; opWIN64CALLI* = 239; opWIN64CALLP* = 240; opLOOP* = 241; opENDLOOP* = 242;
|
|
opSYSVCALL* = 243; opSYSVCALLI* = 244; opSYSVCALLP* = 245; opSYSVALIGN16* = 246; opWIN64ALIGN16* = 247;
|
|
|
|
opACC* = 248;
|
|
|
|
|
|
opSADR_PARAM* = 1000; opLOAD64_PARAM* = 1001; opLLOAD64_PARAM* = 1002; opGLOAD64_PARAM* = 1003;
|
|
opVADR_PARAM* = 1004; opCONST_PARAM* = 1005; opGLOAD32_PARAM* = 1006; opLLOAD32_PARAM* = 1007;
|
|
opLOAD32_PARAM* = 1008;
|
|
|
|
opLADR_SAVEC* = 1009; opGADR_SAVEC* = 1010; opLADR_SAVE* = 1011;
|
|
|
|
opLADR_INC1* = 1012; opLADR_DEC1* = 1013; opLADR_INCC* = 1014; opLADR_DECC* = 1015;
|
|
opLADR_INC1B* = 1016; opLADR_DEC1B* = 1017; opLADR_INCCB* = 1018; opLADR_DECCB* = 1019;
|
|
opLADR_INC* = 1020; opLADR_DEC* = 1021; opLADR_INCB* = 1022; opLADR_DECB* = 1023;
|
|
opLADR_INCL* = 1024; opLADR_EXCL* = 1025; opLADR_INCLC* = 1026; opLADR_EXCLC* = 1027;
|
|
opLADR_UNPK* = 1028;
|
|
|
|
|
|
_move *= 0;
|
|
_move2 *= 1;
|
|
_strcmpw *= 2;
|
|
_strcmpw2 *= 3;
|
|
_set *= 4;
|
|
_set2 *= 5;
|
|
_lengthw *= 6;
|
|
_strcmp2 *= 7;
|
|
_div *= 8;
|
|
_mod *= 9;
|
|
_div2 *= 10;
|
|
_mod2 *= 11;
|
|
_arrcpy *= 12;
|
|
_rot *= 13;
|
|
_new *= 14;
|
|
_dispose *= 15;
|
|
_strcmp *= 16;
|
|
_error *= 17;
|
|
_is *= 18;
|
|
_isrec *= 19;
|
|
_guard *= 20;
|
|
_guardrec *= 21;
|
|
_length *= 22;
|
|
_init *= 23;
|
|
_dllentry *= 24;
|
|
_strcpy *= 25;
|
|
_exit *= 26;
|
|
_strcpy2 *= 27;
|
|
|
|
|
|
TYPE
|
|
|
|
LOCALVAR* = POINTER TO RECORD (LISTS.ITEM)
|
|
|
|
offset*, size*, count*: INTEGER
|
|
|
|
END;
|
|
|
|
COMMAND* = POINTER TO RECORD (LISTS.ITEM)
|
|
|
|
opcode*: INTEGER;
|
|
param1*: INTEGER;
|
|
param2*: INTEGER;
|
|
param3*: INTEGER;
|
|
float*: REAL;
|
|
variables*: LISTS.LIST;
|
|
allocReg*: BOOLEAN
|
|
|
|
END;
|
|
|
|
CMDSTACK = POINTER TO RECORD
|
|
|
|
data: ARRAY 1000 OF COMMAND;
|
|
top: INTEGER
|
|
|
|
END;
|
|
|
|
EXPORT_PROC* = POINTER TO RECORD (LISTS.ITEM)
|
|
|
|
label*: INTEGER;
|
|
name*: SCAN.LEXSTR
|
|
|
|
END;
|
|
|
|
IMPORT_LIB* = POINTER TO RECORD (LISTS.ITEM)
|
|
|
|
name*: SCAN.LEXSTR;
|
|
procs*: LISTS.LIST
|
|
|
|
END;
|
|
|
|
IMPORT_PROC* = POINTER TO RECORD (LISTS.ITEM)
|
|
|
|
label*: INTEGER;
|
|
lib*: IMPORT_LIB;
|
|
name*: SCAN.LEXSTR;
|
|
count: INTEGER
|
|
|
|
END;
|
|
|
|
|
|
CODES* = POINTER TO RECORD
|
|
|
|
last: COMMAND;
|
|
begcall: CMDSTACK;
|
|
endcall: CMDSTACK;
|
|
commands*: LISTS.LIST;
|
|
export*: LISTS.LIST;
|
|
import*: LISTS.LIST;
|
|
types*: CHL.INTLIST;
|
|
data*: CHL.BYTELIST;
|
|
dmin*: INTEGER;
|
|
lcount*: INTEGER;
|
|
bss*: INTEGER;
|
|
rtl*: ARRAY 28 OF INTEGER;
|
|
|
|
charoffs: ARRAY 256 OF INTEGER;
|
|
wcharoffs: ARRAY 65536 OF INTEGER;
|
|
|
|
fregs: INTEGER;
|
|
wstr: ARRAY 4*1024 OF WCHAR;
|
|
|
|
errlabel*: INTEGER
|
|
|
|
END;
|
|
|
|
|
|
VAR
|
|
|
|
codes*: CODES;
|
|
endianness: INTEGER;
|
|
numRegsFloat: INTEGER;
|
|
|
|
commands, variables: C.COLLECTION;
|
|
|
|
|
|
PROCEDURE NewCmd (): COMMAND;
|
|
VAR
|
|
cmd: COMMAND;
|
|
citem: C.ITEM;
|
|
|
|
BEGIN
|
|
citem := C.pop(commands);
|
|
IF citem = NIL THEN
|
|
NEW(cmd)
|
|
ELSE
|
|
cmd := citem(COMMAND)
|
|
END;
|
|
|
|
cmd.allocReg := FALSE
|
|
|
|
RETURN cmd
|
|
END NewCmd;
|
|
|
|
|
|
PROCEDURE NewVar* (): LOCALVAR;
|
|
VAR
|
|
lvar: LOCALVAR;
|
|
citem: C.ITEM;
|
|
|
|
BEGIN
|
|
citem := C.pop(variables);
|
|
IF citem = NIL THEN
|
|
NEW(lvar)
|
|
ELSE
|
|
lvar := citem(LOCALVAR)
|
|
END;
|
|
|
|
lvar.count := 0
|
|
|
|
RETURN lvar
|
|
END NewVar;
|
|
|
|
|
|
PROCEDURE setlast* (cmd: COMMAND);
|
|
BEGIN
|
|
codes.last := cmd
|
|
END setlast;
|
|
|
|
|
|
PROCEDURE getlast* (): COMMAND;
|
|
RETURN codes.last
|
|
END getlast;
|
|
|
|
|
|
PROCEDURE PutByte (codes: CODES; b: BYTE);
|
|
BEGIN
|
|
CHL.PushByte(codes.data, b)
|
|
END PutByte;
|
|
|
|
|
|
PROCEDURE putstr* (s: ARRAY OF CHAR): INTEGER;
|
|
VAR
|
|
i, n, res: INTEGER;
|
|
BEGIN
|
|
res := CHL.Length(codes.data);
|
|
|
|
i := 0;
|
|
n := LENGTH(s);
|
|
WHILE i < n DO
|
|
PutByte(codes, ORD(s[i]));
|
|
INC(i)
|
|
END;
|
|
|
|
PutByte(codes, 0)
|
|
|
|
RETURN res
|
|
END putstr;
|
|
|
|
|
|
PROCEDURE putstr1* (c: INTEGER): INTEGER;
|
|
VAR
|
|
res: INTEGER;
|
|
|
|
BEGIN
|
|
IF codes.charoffs[c] = -1 THEN
|
|
res := CHL.Length(codes.data);
|
|
PutByte(codes, c);
|
|
PutByte(codes, 0);
|
|
codes.charoffs[c] := res
|
|
ELSE
|
|
res := codes.charoffs[c]
|
|
END
|
|
|
|
RETURN res
|
|
END putstr1;
|
|
|
|
|
|
PROCEDURE putstrW* (s: ARRAY OF CHAR): INTEGER;
|
|
VAR
|
|
i, n, res: INTEGER;
|
|
|
|
BEGIN
|
|
res := CHL.Length(codes.data);
|
|
|
|
IF ODD(res) THEN
|
|
PutByte(codes, 0);
|
|
INC(res)
|
|
END;
|
|
|
|
n := STRINGS.Utf8To16(s, codes.wstr);
|
|
|
|
i := 0;
|
|
WHILE i < n DO
|
|
IF endianness = little_endian THEN
|
|
PutByte(codes, ORD(codes.wstr[i]) MOD 256);
|
|
PutByte(codes, ORD(codes.wstr[i]) DIV 256)
|
|
ELSIF endianness = big_endian THEN
|
|
PutByte(codes, ORD(codes.wstr[i]) DIV 256);
|
|
PutByte(codes, ORD(codes.wstr[i]) MOD 256)
|
|
END;
|
|
INC(i)
|
|
END;
|
|
|
|
PutByte(codes, 0);
|
|
PutByte(codes, 0)
|
|
|
|
RETURN res
|
|
END putstrW;
|
|
|
|
|
|
PROCEDURE putstrW1* (c: INTEGER): INTEGER;
|
|
VAR
|
|
res: INTEGER;
|
|
|
|
BEGIN
|
|
IF codes.wcharoffs[c] = -1 THEN
|
|
res := CHL.Length(codes.data);
|
|
|
|
IF ODD(res) THEN
|
|
PutByte(codes, 0);
|
|
INC(res)
|
|
END;
|
|
|
|
IF endianness = little_endian THEN
|
|
PutByte(codes, c MOD 256);
|
|
PutByte(codes, c DIV 256)
|
|
ELSIF endianness = big_endian THEN
|
|
PutByte(codes, c DIV 256);
|
|
PutByte(codes, c MOD 256)
|
|
END;
|
|
|
|
PutByte(codes, 0);
|
|
PutByte(codes, 0);
|
|
|
|
codes.wcharoffs[c] := res
|
|
ELSE
|
|
res := codes.wcharoffs[c]
|
|
END
|
|
|
|
RETURN res
|
|
END putstrW1;
|
|
|
|
|
|
PROCEDURE SetMinDataSize* (size: INTEGER);
|
|
BEGIN
|
|
codes.dmin := CHL.Length(codes.data) + size
|
|
END SetMinDataSize;
|
|
|
|
|
|
PROCEDURE push (stk: CMDSTACK; cmd: COMMAND);
|
|
BEGIN
|
|
INC(stk.top);
|
|
stk.data[stk.top] := cmd
|
|
END push;
|
|
|
|
|
|
PROCEDURE pop (stk: CMDSTACK): COMMAND;
|
|
VAR
|
|
res: COMMAND;
|
|
BEGIN
|
|
res := stk.data[stk.top];
|
|
DEC(stk.top)
|
|
RETURN res
|
|
END pop;
|
|
|
|
|
|
PROCEDURE pushBegEnd* (VAR beg, end: COMMAND);
|
|
BEGIN
|
|
push(codes.begcall, beg);
|
|
push(codes.endcall, end);
|
|
beg := codes.last;
|
|
end := beg.next(COMMAND)
|
|
END pushBegEnd;
|
|
|
|
|
|
PROCEDURE popBegEnd* (VAR beg, end: COMMAND);
|
|
BEGIN
|
|
beg := pop(codes.begcall);
|
|
end := pop(codes.endcall)
|
|
END popBegEnd;
|
|
|
|
|
|
PROCEDURE AddRec* (base: INTEGER);
|
|
BEGIN
|
|
CHL.PushInt(codes.types, base)
|
|
END AddRec;
|
|
|
|
|
|
PROCEDURE insert (cur, nov: COMMAND);
|
|
VAR
|
|
old_opcode, param2: INTEGER;
|
|
|
|
|
|
PROCEDURE set (cur: COMMAND; opcode, param2: INTEGER);
|
|
BEGIN
|
|
cur.opcode := opcode;
|
|
cur.param1 := cur.param2;
|
|
cur.param2 := param2
|
|
END set;
|
|
|
|
|
|
BEGIN
|
|
old_opcode := cur.opcode;
|
|
param2 := nov.param2;
|
|
|
|
IF (nov.opcode = opPARAM) & (param2 = 1) THEN
|
|
|
|
CASE old_opcode OF
|
|
|opGLOAD64: cur.opcode := opGLOAD64_PARAM
|
|
|opLLOAD64: cur.opcode := opLLOAD64_PARAM
|
|
|opLOAD64: cur.opcode := opLOAD64_PARAM
|
|
|opGLOAD32: cur.opcode := opGLOAD32_PARAM
|
|
|opLLOAD32: cur.opcode := opLLOAD32_PARAM
|
|
|opLOAD32: cur.opcode := opLOAD32_PARAM
|
|
|opSADR: cur.opcode := opSADR_PARAM
|
|
|opVADR: cur.opcode := opVADR_PARAM
|
|
|opCONST: cur.opcode := opCONST_PARAM
|
|
ELSE
|
|
old_opcode := -1
|
|
END
|
|
|
|
ELSIF old_opcode = opLADR THEN
|
|
|
|
CASE nov.opcode OF
|
|
|opSAVEC: set(cur, opLADR_SAVEC, param2)
|
|
|opSAVE: cur.opcode := opLADR_SAVE
|
|
|opINC1: cur.opcode := opLADR_INC1
|
|
|opDEC1: cur.opcode := opLADR_DEC1
|
|
|opINC: cur.opcode := opLADR_INC
|
|
|opDEC: cur.opcode := opLADR_DEC
|
|
|opINC1B: cur.opcode := opLADR_INC1B
|
|
|opDEC1B: cur.opcode := opLADR_DEC1B
|
|
|opINCB: cur.opcode := opLADR_INCB
|
|
|opDECB: cur.opcode := opLADR_DECB
|
|
|opINCL: cur.opcode := opLADR_INCL
|
|
|opEXCL: cur.opcode := opLADR_EXCL
|
|
|opUNPK: cur.opcode := opLADR_UNPK
|
|
|opINCC: set(cur, opLADR_INCC, param2)
|
|
|opDECC: set(cur, opLADR_DECC, param2)
|
|
|opINCCB: set(cur, opLADR_INCCB, param2)
|
|
|opDECCB: set(cur, opLADR_DECCB, param2)
|
|
|opINCLC: set(cur, opLADR_INCLC, param2)
|
|
|opEXCLC: set(cur, opLADR_EXCLC, param2)
|
|
ELSE
|
|
old_opcode := -1
|
|
END
|
|
|
|
ELSIF (nov.opcode = opSAVEC) & (old_opcode = opGADR) THEN
|
|
set(cur, opGADR_SAVEC, param2)
|
|
|
|
ELSIF (nov.opcode = opMULC) & (old_opcode = opMULC) THEN
|
|
cur.param2 := param2 * cur.param2
|
|
|
|
ELSE
|
|
old_opcode := -1
|
|
END;
|
|
|
|
IF old_opcode = -1 THEN
|
|
LISTS.insert(codes.commands, cur, nov);
|
|
codes.last := nov
|
|
ELSE
|
|
C.push(commands, nov);
|
|
codes.last := cur
|
|
END
|
|
END insert;
|
|
|
|
|
|
PROCEDURE AddCmd* (opcode: INTEGER; param: INTEGER);
|
|
VAR
|
|
cmd: COMMAND;
|
|
BEGIN
|
|
cmd := NewCmd();
|
|
cmd.opcode := opcode;
|
|
cmd.param1 := 0;
|
|
cmd.param2 := param;
|
|
insert(codes.last, cmd)
|
|
END AddCmd;
|
|
|
|
|
|
PROCEDURE AddCmd2* (opcode: INTEGER; param1, param2: INTEGER);
|
|
VAR
|
|
cmd: COMMAND;
|
|
BEGIN
|
|
cmd := NewCmd();
|
|
cmd.opcode := opcode;
|
|
cmd.param1 := param1;
|
|
cmd.param2 := param2;
|
|
insert(codes.last, cmd)
|
|
END AddCmd2;
|
|
|
|
|
|
PROCEDURE NewLabel* (): INTEGER;
|
|
BEGIN
|
|
INC(codes.lcount)
|
|
RETURN codes.lcount - 1
|
|
END NewLabel;
|
|
|
|
|
|
PROCEDURE SetLabel* (label: INTEGER);
|
|
BEGIN
|
|
AddCmd(opLABEL, label)
|
|
END SetLabel;
|
|
|
|
|
|
PROCEDURE SetErrLabel*;
|
|
BEGIN
|
|
codes.errlabel := NewLabel();
|
|
SetLabel(codes.errlabel)
|
|
END SetErrLabel;
|
|
|
|
|
|
PROCEDURE AddCmd0* (opcode: INTEGER);
|
|
BEGIN
|
|
AddCmd(opcode, 0)
|
|
END AddCmd0;
|
|
|
|
|
|
PROCEDURE deleteVarList (list: LISTS.LIST);
|
|
VAR
|
|
last: LISTS.ITEM;
|
|
|
|
BEGIN
|
|
WHILE list.last # NIL DO
|
|
last := LISTS.pop(list);
|
|
C.push(variables, last)
|
|
END
|
|
END deleteVarList;
|
|
|
|
|
|
PROCEDURE delete (cmd: COMMAND);
|
|
BEGIN
|
|
IF cmd.variables # NIL THEN
|
|
deleteVarList(cmd.variables)
|
|
END;
|
|
LISTS.delete(codes.commands, cmd);
|
|
C.push(commands, cmd)
|
|
END delete;
|
|
|
|
|
|
PROCEDURE delete2* (first, last: LISTS.ITEM);
|
|
VAR
|
|
cur, next: LISTS.ITEM;
|
|
|
|
BEGIN
|
|
cur := first;
|
|
|
|
IF first # last THEN
|
|
REPEAT
|
|
next := cur.next;
|
|
LISTS.delete(codes.commands, cur);
|
|
C.push(commands, cur);
|
|
cur := next
|
|
UNTIL cur = last
|
|
END;
|
|
|
|
LISTS.delete(codes.commands, cur);
|
|
C.push(commands, cur)
|
|
END delete2;
|
|
|
|
|
|
PROCEDURE AddJmpCmd* (opcode: INTEGER; label: INTEGER);
|
|
VAR
|
|
prev: COMMAND;
|
|
not: BOOLEAN;
|
|
|
|
BEGIN
|
|
prev := codes.last;
|
|
not := prev.opcode = opNOT;
|
|
IF not THEN
|
|
IF opcode = opJE THEN
|
|
opcode := opJNE
|
|
ELSIF opcode = opJNE THEN
|
|
opcode := opJE
|
|
ELSE
|
|
not := FALSE
|
|
END
|
|
END;
|
|
|
|
AddCmd2(opcode, label, label);
|
|
|
|
IF not THEN
|
|
delete(prev)
|
|
END
|
|
|
|
END AddJmpCmd;
|
|
|
|
|
|
PROCEDURE OnError* (line, error: INTEGER);
|
|
BEGIN
|
|
AddCmd(opERRC, LSL(line, 4) + error);
|
|
AddJmpCmd(opJMP, codes.errlabel)
|
|
END OnError;
|
|
|
|
|
|
PROCEDURE TypeGuard* (op, t: INTEGER; line, error: INTEGER);
|
|
VAR
|
|
label: INTEGER;
|
|
BEGIN
|
|
AddCmd(op, t);
|
|
label := NewLabel();
|
|
AddJmpCmd(opJE, label);
|
|
OnError(line, error);
|
|
SetLabel(label)
|
|
END TypeGuard;
|
|
|
|
|
|
PROCEDURE TypeCheck* (t: INTEGER);
|
|
BEGIN
|
|
AddCmd(opIS, t)
|
|
END TypeCheck;
|
|
|
|
|
|
PROCEDURE TypeCheckRec* (t: INTEGER);
|
|
BEGIN
|
|
AddCmd(opISREC, t)
|
|
END TypeCheckRec;
|
|
|
|
|
|
PROCEDURE New* (size, typenum: INTEGER);
|
|
BEGIN
|
|
AddCmd2(opNEW, typenum, size)
|
|
END New;
|
|
|
|
|
|
PROCEDURE fcmp* (opcode: INTEGER);
|
|
BEGIN
|
|
AddCmd(opcode, 0);
|
|
DEC(codes.fregs, 2);
|
|
ASSERT(codes.fregs >= 0)
|
|
END fcmp;
|
|
|
|
|
|
PROCEDURE not*;
|
|
VAR
|
|
prev: COMMAND;
|
|
BEGIN
|
|
prev := codes.last;
|
|
IF prev.opcode = opNOT THEN
|
|
codes.last := prev.prev(COMMAND);
|
|
delete(prev)
|
|
ELSE
|
|
AddCmd0(opNOT)
|
|
END
|
|
END not;
|
|
|
|
|
|
PROCEDURE Enter* (label, params: INTEGER): COMMAND;
|
|
VAR
|
|
cmd: COMMAND;
|
|
|
|
BEGIN
|
|
cmd := NewCmd();
|
|
cmd.opcode := opENTER;
|
|
cmd.param1 := label;
|
|
cmd.param3 := params;
|
|
cmd.allocReg := TRUE;
|
|
insert(codes.last, cmd)
|
|
|
|
RETURN codes.last
|
|
END Enter;
|
|
|
|
|
|
PROCEDURE Leave* (result, float: BOOLEAN; paramsize: INTEGER): COMMAND;
|
|
BEGIN
|
|
IF result THEN
|
|
IF float THEN
|
|
AddCmd(opLEAVEF, paramsize)
|
|
ELSE
|
|
AddCmd(opLEAVER, paramsize)
|
|
END
|
|
ELSE
|
|
AddCmd(opLEAVE, paramsize)
|
|
END
|
|
|
|
RETURN codes.last
|
|
END Leave;
|
|
|
|
|
|
PROCEDURE Call* (proc, callconv, fparams: INTEGER);
|
|
BEGIN
|
|
CASE callconv OF
|
|
|call_stack: AddJmpCmd(opCALL, proc)
|
|
|call_win64: AddJmpCmd(opWIN64CALL, proc)
|
|
|call_sysv: AddJmpCmd(opSYSVCALL, proc)
|
|
END;
|
|
codes.last(COMMAND).param2 := fparams
|
|
END Call;
|
|
|
|
|
|
PROCEDURE CallImp* (proc: LISTS.ITEM; callconv, fparams: INTEGER);
|
|
BEGIN
|
|
CASE callconv OF
|
|
|call_stack: AddJmpCmd(opCALLI, proc(IMPORT_PROC).label)
|
|
|call_win64: AddJmpCmd(opWIN64CALLI, proc(IMPORT_PROC).label)
|
|
|call_sysv: AddJmpCmd(opSYSVCALLI, proc(IMPORT_PROC).label)
|
|
END;
|
|
codes.last(COMMAND).param2 := fparams
|
|
END CallImp;
|
|
|
|
|
|
PROCEDURE CallP* (callconv, fparams: INTEGER);
|
|
BEGIN
|
|
CASE callconv OF
|
|
|call_stack: AddCmd0(opCALLP)
|
|
|call_win64: AddCmd(opWIN64CALLP, fparams)
|
|
|call_sysv: AddCmd(opSYSVCALLP, fparams)
|
|
END
|
|
END CallP;
|
|
|
|
|
|
PROCEDURE AssignProc* (proc: INTEGER);
|
|
BEGIN
|
|
AddJmpCmd(opSAVEP, proc)
|
|
END AssignProc;
|
|
|
|
|
|
PROCEDURE AssignImpProc* (proc: LISTS.ITEM);
|
|
BEGIN
|
|
AddJmpCmd(opSAVEIP, proc(IMPORT_PROC).label)
|
|
END AssignImpProc;
|
|
|
|
|
|
PROCEDURE PushProc* (proc: INTEGER);
|
|
BEGIN
|
|
AddJmpCmd(opPUSHP, proc)
|
|
END PushProc;
|
|
|
|
|
|
PROCEDURE PushImpProc* (proc: LISTS.ITEM);
|
|
BEGIN
|
|
AddJmpCmd(opPUSHIP, proc(IMPORT_PROC).label)
|
|
END PushImpProc;
|
|
|
|
|
|
PROCEDURE ProcCmp* (proc: INTEGER; eq: BOOLEAN);
|
|
BEGIN
|
|
IF eq THEN
|
|
AddJmpCmd(opEQP, proc)
|
|
ELSE
|
|
AddJmpCmd(opNEP, proc)
|
|
END
|
|
END ProcCmp;
|
|
|
|
|
|
PROCEDURE ProcImpCmp* (proc: LISTS.ITEM; eq: BOOLEAN);
|
|
BEGIN
|
|
IF eq THEN
|
|
AddJmpCmd(opEQIP, proc(IMPORT_PROC).label)
|
|
ELSE
|
|
AddJmpCmd(opNEIP, proc(IMPORT_PROC).label)
|
|
END
|
|
END ProcImpCmp;
|
|
|
|
|
|
PROCEDURE SysGet* (size: INTEGER);
|
|
BEGIN
|
|
AddCmd(opGET, size)
|
|
END SysGet;
|
|
|
|
|
|
PROCEDURE load* (size: INTEGER);
|
|
VAR
|
|
last: COMMAND;
|
|
|
|
BEGIN
|
|
last := codes.last;
|
|
CASE size OF
|
|
|1:
|
|
IF last.opcode = opLADR THEN
|
|
last.opcode := opLLOAD8
|
|
ELSIF last.opcode = opVADR THEN
|
|
last.opcode := opVLOAD8
|
|
ELSIF last.opcode = opGADR THEN
|
|
last.opcode := opGLOAD8
|
|
ELSE
|
|
AddCmd0(opLOAD8)
|
|
END
|
|
|
|
|2:
|
|
IF last.opcode = opLADR THEN
|
|
last.opcode := opLLOAD16
|
|
ELSIF last.opcode = opVADR THEN
|
|
last.opcode := opVLOAD16
|
|
ELSIF last.opcode = opGADR THEN
|
|
last.opcode := opGLOAD16
|
|
ELSE
|
|
AddCmd0(opLOAD16)
|
|
END
|
|
|
|
|4:
|
|
IF last.opcode = opLADR THEN
|
|
last.opcode := opLLOAD32
|
|
ELSIF last.opcode = opVADR THEN
|
|
last.opcode := opVLOAD32
|
|
ELSIF last.opcode = opGADR THEN
|
|
last.opcode := opGLOAD32
|
|
ELSE
|
|
AddCmd0(opLOAD32)
|
|
END
|
|
|
|
|8:
|
|
IF last.opcode = opLADR THEN
|
|
last.opcode := opLLOAD64
|
|
ELSIF last.opcode = opVADR THEN
|
|
last.opcode := opVLOAD64
|
|
ELSIF last.opcode = opGADR THEN
|
|
last.opcode := opGLOAD64
|
|
ELSE
|
|
AddCmd0(opLOAD64)
|
|
END
|
|
END
|
|
END load;
|
|
|
|
|
|
PROCEDURE SysPut* (size: INTEGER);
|
|
BEGIN
|
|
CASE size OF
|
|
|1: AddCmd0(opSAVE8)
|
|
|2: AddCmd0(opSAVE16)
|
|
|4: AddCmd0(opSAVE32)
|
|
|8: AddCmd0(opSAVE64)
|
|
END
|
|
END SysPut;
|
|
|
|
|
|
PROCEDURE savef*;
|
|
BEGIN
|
|
AddCmd0(opSAVEF);
|
|
DEC(codes.fregs);
|
|
ASSERT(codes.fregs >= 0)
|
|
END savef;
|
|
|
|
|
|
PROCEDURE pushf*;
|
|
BEGIN
|
|
AddCmd0(opPUSHF);
|
|
DEC(codes.fregs);
|
|
ASSERT(codes.fregs >= 0)
|
|
END pushf;
|
|
|
|
|
|
PROCEDURE loadf* (): BOOLEAN;
|
|
BEGIN
|
|
AddCmd0(opLOADF);
|
|
INC(codes.fregs)
|
|
RETURN codes.fregs < numRegsFloat
|
|
END loadf;
|
|
|
|
|
|
PROCEDURE inf* (): BOOLEAN;
|
|
BEGIN
|
|
AddCmd0(opINF);
|
|
INC(codes.fregs)
|
|
RETURN codes.fregs < numRegsFloat
|
|
END inf;
|
|
|
|
|
|
PROCEDURE fbinop* (opcode: INTEGER);
|
|
BEGIN
|
|
AddCmd0(opcode);
|
|
DEC(codes.fregs);
|
|
ASSERT(codes.fregs > 0)
|
|
END fbinop;
|
|
|
|
|
|
PROCEDURE saves* (offset, length: INTEGER);
|
|
BEGIN
|
|
AddCmd2(opSAVES, length, offset)
|
|
END saves;
|
|
|
|
|
|
PROCEDURE abs* (real: BOOLEAN);
|
|
BEGIN
|
|
IF real THEN
|
|
AddCmd0(opFABS)
|
|
ELSE
|
|
AddCmd0(opABS)
|
|
END
|
|
END abs;
|
|
|
|
|
|
PROCEDURE floor*;
|
|
BEGIN
|
|
AddCmd0(opFLOOR);
|
|
DEC(codes.fregs);
|
|
ASSERT(codes.fregs >= 0)
|
|
END floor;
|
|
|
|
|
|
PROCEDURE flt* (): BOOLEAN;
|
|
BEGIN
|
|
AddCmd0(opFLT);
|
|
INC(codes.fregs)
|
|
RETURN codes.fregs < numRegsFloat
|
|
END flt;
|
|
|
|
|
|
PROCEDURE odd*;
|
|
BEGIN
|
|
AddCmd0(opODD)
|
|
END odd;
|
|
|
|
|
|
PROCEDURE ord*;
|
|
BEGIN
|
|
AddCmd0(opORD)
|
|
END ord;
|
|
|
|
|
|
PROCEDURE shift_minmax* (op: CHAR);
|
|
BEGIN
|
|
CASE op OF
|
|
|"A": AddCmd0(opASR)
|
|
|"L": AddCmd0(opLSL)
|
|
|"O": AddCmd0(opROR)
|
|
|"R": AddCmd0(opLSR)
|
|
|"m": AddCmd0(opMIN)
|
|
|"x": AddCmd0(opMAX)
|
|
END
|
|
END shift_minmax;
|
|
|
|
|
|
PROCEDURE shift_minmax1* (op: CHAR; x: INTEGER);
|
|
BEGIN
|
|
CASE op OF
|
|
|"A": AddCmd(opASR1, x)
|
|
|"L": AddCmd(opLSL1, x)
|
|
|"O": AddCmd(opROR1, x)
|
|
|"R": AddCmd(opLSR1, x)
|
|
|"m": AddCmd(opMINC, x)
|
|
|"x": AddCmd(opMAXC, x)
|
|
END
|
|
END shift_minmax1;
|
|
|
|
|
|
PROCEDURE shift_minmax2* (op: CHAR; x: INTEGER);
|
|
BEGIN
|
|
CASE op OF
|
|
|"A": AddCmd(opASR2, x)
|
|
|"L": AddCmd(opLSL2, x)
|
|
|"O": AddCmd(opROR2, x)
|
|
|"R": AddCmd(opLSR2, x)
|
|
|"m": AddCmd(opMINC, x)
|
|
|"x": AddCmd(opMAXC, x)
|
|
END
|
|
END shift_minmax2;
|
|
|
|
|
|
PROCEDURE len* (dim: INTEGER);
|
|
BEGIN
|
|
AddCmd(opLEN, dim)
|
|
END len;
|
|
|
|
|
|
PROCEDURE Float* (r: REAL);
|
|
VAR
|
|
cmd: COMMAND;
|
|
|
|
BEGIN
|
|
cmd := NewCmd();
|
|
cmd.opcode := opCONSTF;
|
|
cmd.float := r;
|
|
insert(codes.last, cmd);
|
|
INC(codes.fregs);
|
|
ASSERT(codes.fregs <= numRegsFloat)
|
|
END Float;
|
|
|
|
|
|
PROCEDURE precall* (flt: BOOLEAN): INTEGER;
|
|
VAR
|
|
res: INTEGER;
|
|
BEGIN
|
|
res := codes.fregs;
|
|
AddCmd2(opPRECALL, ORD(flt), res);
|
|
codes.fregs := 0
|
|
RETURN res
|
|
END precall;
|
|
|
|
|
|
PROCEDURE resf* (fregs: INTEGER): BOOLEAN;
|
|
BEGIN
|
|
AddCmd(opRESF, fregs);
|
|
codes.fregs := fregs + 1
|
|
RETURN codes.fregs < numRegsFloat
|
|
END resf;
|
|
|
|
|
|
PROCEDURE res* (fregs: INTEGER);
|
|
BEGIN
|
|
AddCmd(opRES, fregs);
|
|
codes.fregs := fregs
|
|
END res;
|
|
|
|
|
|
PROCEDURE retf*;
|
|
BEGIN
|
|
DEC(codes.fregs);
|
|
ASSERT(codes.fregs = 0)
|
|
END retf;
|
|
|
|
|
|
PROCEDURE drop*;
|
|
BEGIN
|
|
AddCmd0(opDROP)
|
|
END drop;
|
|
|
|
|
|
PROCEDURE case* (a, b, L, R: INTEGER);
|
|
VAR
|
|
cmd: COMMAND;
|
|
|
|
BEGIN
|
|
IF a = b THEN
|
|
cmd := NewCmd();
|
|
cmd.opcode := opCASELR;
|
|
cmd.param1 := a;
|
|
cmd.param2 := L;
|
|
cmd.param3 := R;
|
|
insert(codes.last, cmd)
|
|
ELSE
|
|
AddCmd2(opCASEL, a, L);
|
|
AddCmd2(opCASER, b, R)
|
|
END
|
|
END case;
|
|
|
|
|
|
PROCEDURE caset* (a, label: INTEGER);
|
|
BEGIN
|
|
AddCmd2(opCASET, label, a)
|
|
END caset;
|
|
|
|
|
|
PROCEDURE AddExp* (label: INTEGER; name: SCAN.LEXSTR);
|
|
VAR
|
|
exp: EXPORT_PROC;
|
|
|
|
BEGIN
|
|
NEW(exp);
|
|
exp.label := label;
|
|
exp.name := name;
|
|
LISTS.push(codes.export, exp)
|
|
END AddExp;
|
|
|
|
|
|
PROCEDURE AddImp* (dll, proc: SCAN.LEXSTR): IMPORT_PROC;
|
|
VAR
|
|
lib: IMPORT_LIB;
|
|
p: IMPORT_PROC;
|
|
|
|
BEGIN
|
|
lib := codes.import.first(IMPORT_LIB);
|
|
WHILE (lib # NIL) & (lib.name # dll) DO
|
|
lib := lib.next(IMPORT_LIB)
|
|
END;
|
|
|
|
IF lib = NIL THEN
|
|
NEW(lib);
|
|
lib.name := dll;
|
|
lib.procs := LISTS.create(NIL);
|
|
LISTS.push(codes.import, lib)
|
|
END;
|
|
|
|
p := lib.procs.first(IMPORT_PROC);
|
|
WHILE (p # NIL) & (p.name # proc) DO
|
|
p := p.next(IMPORT_PROC)
|
|
END;
|
|
|
|
IF p = NIL THEN
|
|
NEW(p);
|
|
p.name := proc;
|
|
p.label := NewLabel();
|
|
p.lib := lib;
|
|
p.count := 1;
|
|
LISTS.push(lib.procs, p)
|
|
ELSE
|
|
INC(p.count)
|
|
END
|
|
|
|
RETURN p
|
|
END AddImp;
|
|
|
|
|
|
PROCEDURE DelImport* (imp: LISTS.ITEM);
|
|
VAR
|
|
lib: IMPORT_LIB;
|
|
|
|
BEGIN
|
|
DEC(imp(IMPORT_PROC).count);
|
|
IF imp(IMPORT_PROC).count = 0 THEN
|
|
lib := imp(IMPORT_PROC).lib;
|
|
LISTS.delete(lib.procs, imp);
|
|
IF lib.procs.first = NIL THEN
|
|
LISTS.delete(codes.import, lib)
|
|
END
|
|
END
|
|
END DelImport;
|
|
|
|
|
|
PROCEDURE init* (pNumRegsFloat, pEndianness: INTEGER);
|
|
VAR
|
|
cmd: COMMAND;
|
|
i: INTEGER;
|
|
|
|
BEGIN
|
|
commands := C.create();
|
|
variables := C.create();
|
|
numRegsFloat := pNumRegsFloat;
|
|
endianness := pEndianness;
|
|
|
|
NEW(codes);
|
|
NEW(codes.begcall);
|
|
codes.begcall.top := -1;
|
|
NEW(codes.endcall);
|
|
codes.endcall.top := -1;
|
|
codes.commands := LISTS.create(NIL);
|
|
codes.export := LISTS.create(NIL);
|
|
codes.import := LISTS.create(NIL);
|
|
codes.types := CHL.CreateIntList();
|
|
codes.data := CHL.CreateByteList();
|
|
|
|
NEW(cmd); cmd.opcode := opNOP; LISTS.push(codes.commands, cmd);
|
|
codes.last := cmd;
|
|
NEW(cmd); cmd.opcode := opNOP; LISTS.push(codes.commands, cmd);
|
|
|
|
AddRec(0);
|
|
|
|
codes.lcount := 0;
|
|
|
|
codes.fregs := 0;
|
|
|
|
FOR i := 0 TO LEN(codes.charoffs) - 1 DO
|
|
codes.charoffs[i] := -1
|
|
END;
|
|
|
|
FOR i := 0 TO LEN(codes.wcharoffs) - 1 DO
|
|
codes.wcharoffs[i] := -1
|
|
END
|
|
|
|
END init;
|
|
|
|
|
|
END CODE. |