XenOn/kolibrios-fun
1
1
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Wiki Activity
e0e11ba32b
kolibrios-fun/programs/develop/oberon07/source/IL.ob07

1171 lines
26 KiB
Plaintext
Raw Normal View History

Oberon07: v1.53 git-svn-id: svn://kolibrios.org@9177 a494cfbc-eb01-0410-851d-a64ba20cac60
2021-09-03 19:21:37 +02:00
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE IL;
IMPORT LISTS, SCAN, STRINGS, CHL := CHUNKLISTS, C := COLLECTIONS, TARGETS, PATHS;
CONST
call_stack* = 0;
call_win64* = 1;
call_sysv* = 2;
begin_loop* = 1; end_loop* = 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; opONERR* = 19; opSUBL* = 20; opADDC* = 21; opSUBR* = 22;
opSAVE* = 23; opSAVEC* = 24; opSAVE8* = 25; opSAVE8C* = 26; opCHKBYTE* = 27; opDROP* = 28;
opNOT* = 29;
opEQ* = 30; opNE* = opEQ + 1; opLT* = opEQ + 2; opLE* = opEQ + 3; opGT* = opEQ + 4; opGE* = opEQ + 5 (* 35 *);
opEQC* = 36; opNEC* = opEQC + 1; opLTC* = opEQC + 2; opLEC* = opEQC + 3; opGTC* = opEQC + 4; opGEC* = opEQC + 5; (* 41 *)
opEQF* = 42; opNEF* = opEQF + 1; opLTF* = opEQF + 2; opLEF* = opEQF + 3; opGTF* = opEQF + 4; opGEF* = opEQF + 5; (* 47 *)
opEQS* = 48; opNES* = opEQS + 1; opLTS* = opEQS + 2; opLES* = opEQS + 3; opGTS* = opEQS + 4; opGES* = opEQS + 5; (* 53 *)
opEQSW* = 54; opNESW* = opEQSW + 1; opLTSW* = opEQSW + 2; opLESW* = opEQSW + 3; opGTSW* = opEQSW + 4; opGESW* = opEQSW + 5 (* 59 *);
opVLOAD32* = 60; opGLOAD32* = 61;
opJZ* = 62; opJNZ* = 63;
opSAVE32* = 64; opLLOAD8* = 65;
opCONSTF* = 66; opLOADF* = 67; opSAVEF* = 68; opMULF* = 69; opDIVF* = 70; opDIVFI* = 71;
opUMINF* = 72; opSAVEFI* = 73; opSUBFI* = 74; opADDF* = 75; opSUBF* = 76;
opJNZ1* = 77; opJG* = 78;
opINCCB* = 79; opDECCB* = 80; opINCB* = 81; opDECB* = 82;
opCASEL* = 83; opCASER* = 84; opCASELR* = 85;
opPOPSP* = 86;
opWIN64CALL* = 87; opWIN64CALLI* = 88; opWIN64CALLP* = 89; opAND* = 90; opOR* = 91;
opLOAD8* = 92; opLOAD16* = 93; opLOAD32* = 94; opPRECALL* = 95; opRES* = 96; opRESF* = 97;
opPUSHC* = 98; opSWITCH* = 99;
opSBOOL* = 100; opSBOOLC* = 101; opNOP* = 102;
opMULS* = 103; opMULSC* = 104; opDIVS* = 105; opDIVSC* = 106;
opADDS* = 107; opSUBS* = 108; opERR* = 109; opSUBSL* = 110; opADDSC* = 111; opSUBSR* = 112;
opUMINS* = 113; opIN* = 114; opINL* = 115; opINR* = 116;
opRSET* = 117; opRSETL* = 118; opRSETR* = 119; opRSET1* = 120; opLENGTH* = 121;
opLEAVEC* = 122; opCODE* = 123; opALIGN16* = 124;
opINCC* = 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;
opGETC* = 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; opLENGTHW* = 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; opSYSVALIGN16* = 192;
opEQB* = 193; opNEB* = 194; opINF* = 195; opWIN64ALIGN16* = 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; opHANDLER* = 215;
opSYSVCALL* = 216; opSYSVCALLI* = 217; opSYSVCALLP* = 218; opFNAME* = 219;
opSADR_PARAM* = -1; opLOAD64_PARAM* = -2; opLLOAD64_PARAM* = -3; opGLOAD64_PARAM* = -4;
opVADR_PARAM* = -5; opCONST_PARAM* = -6; opGLOAD32_PARAM* = -7; opLLOAD32_PARAM* = -8;
opLOAD32_PARAM* = -9;
opLADR_SAVEC* = -10; opGADR_SAVEC* = -11; opLADR_SAVE* = -12;
opLADR_INCC* = -13; opLADR_INCCB* = -14; opLADR_DECCB* = -15;
opLADR_INC* = -16; opLADR_DEC* = -17; opLADR_INCB* = -18; opLADR_DECB* = -19;
opLADR_INCL* = -20; opLADR_EXCL* = -21; opLADR_INCLC* = -22; opLADR_EXCLC* = -23;
opLADR_UNPK* = -24;
_init *= 0;
_move *= 1;
_strcmpw *= 2;
_exit *= 3;
_set *= 4;
_set1 *= 5;
_lengthw *= 6;
_strcpy *= 7;
_length *= 8;
_divmod *= 9;
_dllentry *= 10;
_sofinit *= 11;
_arrcpy *= 12;
_rot *= 13;
_new *= 14;
_dispose *= 15;
_strcmp *= 16;
_error *= 17;
_is *= 18;
_isrec *= 19;
_guard *= 20;
_guardrec *= 21;
_fmul *= 22;
_fdiv *= 23;
_fdivi *= 24;
_fadd *= 25;
_fsub *= 26;
_fsubi *= 27;
_fcmp *= 28;
_floor *= 29;
_flt *= 30;
_pack *= 31;
_unpk *= 32;
TYPE
COMMAND* = POINTER TO RECORD (LISTS.ITEM)
opcode*: INTEGER;
param1*: INTEGER;
param2*: INTEGER;
param3*: INTEGER;
float*: REAL
END;
FNAMECMD* = POINTER TO RECORD (COMMAND)
fname*: PATHS.PATH
END;
CMDSTACK = POINTER TO RECORD
data: ARRAY 1000 OF COMMAND;
top: INTEGER
END;
EXPORT_PROC* = POINTER TO RECORD (LISTS.ITEM)
label*: INTEGER;
name*: SCAN.IDSTR
END;
IMPORT_LIB* = POINTER TO RECORD (LISTS.ITEM)
name*: SCAN.TEXTSTR;
procs*: LISTS.LIST
END;
IMPORT_PROC* = POINTER TO RECORD (LISTS.ITEM)
label*: INTEGER;
lib*: IMPORT_LIB;
name*: SCAN.TEXTSTR;
count: INTEGER
END;
CODES = 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 33 OF INTEGER;
errlabels*: ARRAY 12 OF INTEGER;
charoffs: ARRAY 256 OF INTEGER;
wcharoffs: ARRAY 65536 OF INTEGER;
wstr: ARRAY 4*1024 OF WCHAR
END;
VAR
codes*: CODES;
CPU: INTEGER;
commands: C.COLLECTION;
PROCEDURE set_dmin* (value: INTEGER);
BEGIN
codes.dmin := value
END set_dmin;
PROCEDURE set_bss* (value: INTEGER);
BEGIN
codes.bss := value
END set_bss;
PROCEDURE set_rtl* (idx, label: INTEGER);
BEGIN
codes.rtl[idx] := label
END set_rtl;
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
RETURN cmd
END NewCmd;
PROCEDURE setlast* (cmd: COMMAND);
BEGIN
codes.last := cmd
END setlast;
PROCEDURE getlast* (): COMMAND;
RETURN codes.last
END getlast;
PROCEDURE PutByte (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(ORD(s[i]));
INC(i)
END;
PutByte(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(c);
PutByte(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(0);
INC(res)
END;
n := STRINGS.Utf8To16(s, codes.wstr);
i := 0;
WHILE i < n DO
IF TARGETS.LittleEndian THEN
PutByte(ORD(codes.wstr[i]) MOD 256);
PutByte(ORD(codes.wstr[i]) DIV 256)
ELSE
PutByte(ORD(codes.wstr[i]) DIV 256);
PutByte(ORD(codes.wstr[i]) MOD 256)
END;
INC(i)
END;
PutByte(0);
PutByte(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(0);
INC(res)
END;
IF TARGETS.LittleEndian THEN
PutByte(c MOD 256);
PutByte(c DIV 256)
ELSE
PutByte(c DIV 256);
PutByte(c MOD 256)
END;
PutByte(0);
PutByte(0);
codes.wcharoffs[c] := res
ELSE
res := codes.wcharoffs[c]
END
RETURN res
END putstrW1;
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
IF CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64, TARGETS.cpuMSP430} THEN
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
|opINC: cur.opcode := opLADR_INC
|opDEC: cur.opcode := opLADR_DEC
|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)
|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 := cur.param2 * param2
ELSIF (nov.opcode = opADDC) & (old_opcode = opADDC) THEN
INC(cur.param2, param2)
ELSE
old_opcode := -1
END
ELSIF CPU IN {TARGETS.cpuTHUMB, TARGETS.cpuRVM32I, TARGETS.cpuRVM64I} THEN
old_opcode := cur.opcode;
param2 := nov.param2;
IF (old_opcode = opLADR) & (nov.opcode = opSAVE) THEN
cur.opcode := opLADR_SAVE
ELSIF (old_opcode = opLADR) & (nov.opcode = opINCC) THEN
set(cur, opLADR_INCC, param2)
ELSIF (nov.opcode = opMULC) & (old_opcode = opMULC) THEN
cur.param2 := cur.param2 * param2
ELSIF (nov.opcode = opADDC) & (old_opcode = opADDC) THEN
INC(cur.param2, param2)
ELSE
old_opcode := -1
END
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 Const* (val: INTEGER);
BEGIN
AddCmd(opCONST, val)
END Const;
PROCEDURE StrAdr* (adr: INTEGER);
BEGIN
AddCmd(opSADR, adr)
END StrAdr;
PROCEDURE Param1*;
BEGIN
AddCmd(opPARAM, 1)
END Param1;
PROCEDURE NewLabel* (): INTEGER;
BEGIN
INC(codes.lcount)
RETURN codes.lcount - 1
END NewLabel;
PROCEDURE SetLabel* (label: INTEGER);
BEGIN
AddCmd2(opLABEL, label, 0)
END SetLabel;
PROCEDURE SetErrLabel* (errno: INTEGER);
BEGIN
codes.errlabels[errno] := NewLabel();
SetLabel(codes.errlabels[errno])
END SetErrLabel;
PROCEDURE AddCmd0* (opcode: INTEGER);
BEGIN
AddCmd(opcode, 0)
END AddCmd0;
PROCEDURE delete (cmd: COMMAND);
BEGIN
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 Jmp* (opcode: INTEGER; label: INTEGER);
VAR
prev: COMMAND;
not: BOOLEAN;
BEGIN
prev := codes.last;
not := prev.opcode = opNOT;
IF not THEN
IF opcode = opJNZ THEN
opcode := opJZ
ELSIF opcode = opJZ THEN
opcode := opJNZ
ELSE
not := FALSE
END
END;
AddCmd2(opcode, label, label);
IF not THEN
delete(prev)
END
END Jmp;
PROCEDURE AndOrOpt* (VAR label: INTEGER);
VAR
cur, prev: COMMAND;
i, op, l: INTEGER;
jz, not: BOOLEAN;
BEGIN
cur := codes.last;
not := cur.opcode = opNOT;
IF not THEN
cur := cur.prev(COMMAND)
END;
IF cur.opcode = opAND THEN
op := opAND
ELSIF cur.opcode = opOR THEN
op := opOR
ELSE
op := -1
END;
cur := codes.last;
IF op # -1 THEN
IF not THEN
IF op = opAND THEN
op := opOR
ELSE (* op = opOR *)
op := opAND
END;
prev := cur.prev(COMMAND);
delete(cur);
cur := prev
END;
FOR i := 1 TO 9 DO
IF i = 8 THEN
l := cur.param1
ELSIF i = 9 THEN
jz := cur.opcode = opJZ
END;
prev := cur.prev(COMMAND);
delete(cur);
cur := prev
END;
setlast(cur);
IF op = opAND THEN
label := l;
jz := ~jz
END;
IF jz THEN
Jmp(opJZ, label)
ELSE
Jmp(opJNZ, label)
END;
IF op = opOR THEN
SetLabel(l)
END
ELSE
Jmp(opJZ, label)
END;
setlast(codes.last)
END AndOrOpt;
PROCEDURE OnError* (line, error: INTEGER);
BEGIN
AddCmd2(opONERR, codes.errlabels[error], line)
END OnError;
PROCEDURE TypeGuard* (op, t: INTEGER; line, error: INTEGER);
VAR
label: INTEGER;
BEGIN
AddCmd(op, t);
label := NewLabel();
Jmp(opJNZ, 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 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 _ord*;
BEGIN
IF (codes.last.opcode # opAND) & (codes.last.opcode # opOR) THEN
AddCmd0(opORD)
END
END _ord;
PROCEDURE Enter* (label, params: INTEGER): COMMAND;
VAR
cmd: COMMAND;
BEGIN
cmd := NewCmd();
cmd.opcode := opENTER;
cmd.param1 := label;
cmd.param3 := params;
insert(codes.last, cmd)
RETURN codes.last
END Enter;
PROCEDURE Leave* (result, float: BOOLEAN; locsize, paramsize: INTEGER): COMMAND;
BEGIN
IF result THEN
IF float THEN
AddCmd2(opLEAVEF, locsize, paramsize)
ELSE
AddCmd2(opLEAVER, locsize, paramsize)
END
ELSE
AddCmd2(opLEAVE, locsize, paramsize)
END
RETURN codes.last
END Leave;
PROCEDURE EnterC* (label: INTEGER): COMMAND;
BEGIN
SetLabel(label)
RETURN codes.last
END EnterC;
PROCEDURE LeaveC* (): COMMAND;
BEGIN
AddCmd0(opLEAVEC)
RETURN codes.last
END LeaveC;
PROCEDURE Call* (proc, callconv, fparams: INTEGER);
BEGIN
CASE callconv OF
|call_stack: Jmp(opCALL, proc)
|call_win64: Jmp(opWIN64CALL, proc)
|call_sysv: Jmp(opSYSVCALL, proc)
END;
codes.last(COMMAND).param2 := fparams
END Call;
PROCEDURE CallImp* (proc: LISTS.ITEM; callconv, fparams: INTEGER);
BEGIN
CASE callconv OF
|call_stack: Jmp(opCALLI, proc(IMPORT_PROC).label)
|call_win64: Jmp(opWIN64CALLI, proc(IMPORT_PROC).label)
|call_sysv: Jmp(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
Jmp(opSAVEP, proc)
END AssignProc;
PROCEDURE AssignImpProc* (proc: LISTS.ITEM);
BEGIN
Jmp(opSAVEIP, proc(IMPORT_PROC).label)
END AssignImpProc;
PROCEDURE PushProc* (proc: INTEGER);
BEGIN
Jmp(opPUSHP, proc)
END PushProc;
PROCEDURE PushImpProc* (proc: LISTS.ITEM);
BEGIN
Jmp(opPUSHIP, proc(IMPORT_PROC).label)
END PushImpProc;
PROCEDURE ProcCmp* (proc: INTEGER; eq: BOOLEAN);
BEGIN
IF eq THEN
Jmp(opEQP, proc)
ELSE
Jmp(opNEP, proc)
END
END ProcCmp;
PROCEDURE ProcImpCmp* (proc: LISTS.ITEM; eq: BOOLEAN);
BEGIN
IF eq THEN
Jmp(opEQIP, proc(IMPORT_PROC).label)
ELSE
Jmp(opNEIP, proc(IMPORT_PROC).label)
END
END ProcImpCmp;
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* (inv: BOOLEAN);
BEGIN
IF inv THEN
AddCmd0(opSAVEFI)
ELSE
AddCmd0(opSAVEF)
END
END savef;
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 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; line, col: INTEGER);
VAR
cmd: COMMAND;
BEGIN
cmd := NewCmd();
cmd.opcode := opCONSTF;
cmd.float := r;
cmd.param1 := line;
cmd.param2 := col;
insert(codes.last, cmd)
END Float;
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 fname* (name: PATHS.PATH);
VAR
cmd: FNAMECMD;
BEGIN
NEW(cmd);
cmd.opcode := opFNAME;
cmd.fname := name;
insert(codes.last, cmd)
END fname;
PROCEDURE AddExp* (label: INTEGER; name: SCAN.IDSTR);
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.TEXTSTR): 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* (pCPU: INTEGER);
VAR
cmd: COMMAND;
i: INTEGER;
BEGIN
commands := C.create();
CPU := pCPU;
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;
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;
oberon07: update to the latest version from https://github.com/AntKrotov/oberon-07-compiler git-svn-id: svn://kolibrios.org@7983 a494cfbc-eb01-0410-851d-a64ba20cac60
2020-05-25 22:48:33 +02:00
END IL.
Copy Permalink