diff --git a/programs/develop/oberon07/Source/CODE.ob07 b/programs/develop/oberon07/Source/CODE.ob07 deleted file mode 100644 index e42b630338..0000000000 --- a/programs/develop/oberon07/Source/CODE.ob07 +++ /dev/null @@ -1,1181 +0,0 @@ -(* - 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. \ No newline at end of file diff --git a/programs/develop/oberon07/Source/MACHINE.ob07 b/programs/develop/oberon07/Source/MACHINE.ob07 deleted file mode 100644 index 2e60460f94..0000000000 --- a/programs/develop/oberon07/Source/MACHINE.ob07 +++ /dev/null @@ -1,110 +0,0 @@ -(* - BSD 2-Clause License - - Copyright (c) 2018, 2019, Anton Krotov - All rights reserved. -*) - -MODULE MACHINE; - -IMPORT UTILS; - - -CONST - - min32* = -2147483647-1; - max32* = 2147483647; - - -VAR - - target*: - - RECORD - - bit_depth*, - maxInt*, - minInt*, - maxSet*, - maxHex*: INTEGER; - - maxReal*: REAL - - END; - - _64to32*: BOOLEAN; - - -PROCEDURE SetBitDepth* (pBitDepth: INTEGER); -BEGIN - ASSERT(pBitDepth <= UTILS.bit_depth); - ASSERT((pBitDepth = 32) OR (pBitDepth = 64)); - - _64to32 := (UTILS.bit_depth = 64) & (pBitDepth = 32); - - target.bit_depth := pBitDepth; - target.maxSet := pBitDepth - 1; - target.maxHex := pBitDepth DIV 4; - target.minInt := ASR(UTILS.minint, UTILS.bit_depth - pBitDepth); - target.maxInt := ASR(UTILS.maxint, UTILS.bit_depth - pBitDepth); - target.maxReal := 1.9; - PACK(target.maxReal, 1023); -END SetBitDepth; - - -PROCEDURE Byte* (n: INTEGER; idx: INTEGER): BYTE; -BEGIN - WHILE idx > 0 DO - n := ASR(n, 8); - DEC(idx) - END - - RETURN ORD(BITS(n) * {0..7}) -END Byte; - - -PROCEDURE Align* (VAR bytes: INTEGER; align: INTEGER): BOOLEAN; -VAR - res: BOOLEAN; - -BEGIN - IF bytes MOD align # 0 THEN - res := UTILS.maxint - bytes >= align - (bytes MOD align); - IF res THEN - bytes := bytes + align - (bytes MOD align) - END - ELSE - res := TRUE - END - - RETURN res -END Align; - - -PROCEDURE Int32To64* (value: INTEGER): INTEGER; -BEGIN - IF UTILS.bit_depth = 64 THEN - value := LSL(value, 16); - value := LSL(value, 16); - value := ASR(value, 16); - value := ASR(value, 16) - END - - RETURN value -END Int32To64; - - -PROCEDURE Int64To32* (value: INTEGER): INTEGER; -BEGIN - IF UTILS.bit_depth = 64 THEN - value := LSL(value, 16); - value := LSL(value, 16); - value := LSR(value, 16); - value := LSR(value, 16) - END - - RETURN value -END Int64To32; - - -END MACHINE. \ No newline at end of file