| 0,0 → 1,1181 |
|---|
| (* |
| 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. |