BlueGreycalmElegant

Català-Valencià – Catalan中文 – Chinese (Simplified)中文 – Chinese (Traditional)Česky – CzechDansk – DanishNederlands – DutchEnglish – EnglishSuomi – FinnishFrançais – FrenchDeutsch – Germanעברית – Hebrewहिंदी – HindiMagyar – HungarianBahasa Indonesia – IndonesianItaliano – Italian日本語 – Japanese한국어 – KoreanМакедонски – Macedonianमराठी – MarathiNorsk – NorwegianPolski – PolishPortuguês – PortuguesePortuguês – Portuguese (Brazil)Русский – RussianSlovenčina – SlovakSlovenščina – SlovenianEspañol – SpanishSvenska – SwedishTürkçe – TurkishУкраїнська – UkrainianOëzbekcha – Uzbek

Compare Revisions

• This comparison shows the changes necessary to convert path

  → /programs/develop/oberon07/source @ 8097

  → /programs/develop/oberon07/source @ 8859

  ↔ Reverse comparison

• Compare Path:	Rev

  With Path:	Rev

Regard whitespace Rev 8097 → Rev 8859

/programs/develop/oberon07/source/AMD64.ob07
0,0 → 1,2408
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE AMD64;
IMPORT IL, BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS, PATHS, PROG, TARGETS,
REG, UTILS, S := STRINGS, PE32, ELF, X86, ERRORS;
CONST
rax = REG.R0;
r10 = REG.R10;
r11 = REG.R11;
rcx = REG.R1;
rdx = REG.R2;
r8 = REG.R8;
r9 = REG.R9;
rsp = 4;
rbp = 5;
rsi = 6;
rdi = 7;
MAX_XMM = 5;
je = 84H; jne = 85H; jl = 8CH; jge = 8DH; jle = 8EH; jg = 8FH; jb = 82H;
sete = 94H; setne = 95H; setl = 9CH; setge = 9DH; setle = 9EH; setg = 9FH; setc = 92H; setnc = 93H;
shl = IL.opLSL2; shr = IL.opLSR2; sar = IL.opASR2; ror = IL.opROR2;
sCODE = BIN.PICCODE;
sDATA = BIN.PICDATA;
sBSS = BIN.PICBSS;
sIMP = BIN.PICIMP;
FPR_ERR = 41;
TYPE
COMMAND = IL.COMMAND;
Number = POINTER TO RECORD (LISTS.ITEM) value: INTEGER END;
OPRR = PROCEDURE (reg1, reg2: INTEGER);
VAR
R: REG.REGS;
Numbers: LISTS.LIST;
Numbers_Count: INTEGER;
Numbers_Offs: INTEGER;
prog: BIN.PROGRAM;
tcount: INTEGER;
dllret, sofinit: INTEGER;
Win64RegPar: ARRAY 4 OF INTEGER;
SystemVRegPar: ARRAY 6 OF INTEGER;
Xmm: ARRAY 1000 OF INTEGER;
fname: PATHS.PATH;
PROCEDURE OutByte (b: BYTE);
BEGIN
X86.OutByte(b)
END OutByte;
PROCEDURE OutByte2 (a, b: BYTE);
BEGIN
X86.OutByte(a);
X86.OutByte(b)
END OutByte2;
PROCEDURE OutByte3 (a, b, c: BYTE);
BEGIN
X86.OutByte(a);
X86.OutByte(b);
X86.OutByte(c)
END OutByte3;
PROCEDURE OutInt (n: INTEGER);
BEGIN
X86.OutByte(n MOD 256);
X86.OutByte(UTILS.Byte(n, 1));
X86.OutByte(UTILS.Byte(n, 2));
X86.OutByte(UTILS.Byte(n, 3))
END OutInt;
PROCEDURE short (n: INTEGER): INTEGER;
RETURN 2 * ORD(X86.isByte(n))
END short;
PROCEDURE long (n: INTEGER): INTEGER;
RETURN 40H * ORD(~X86.isByte(n))
END long;
PROCEDURE OutIntByte (n: INTEGER);
BEGIN
IF X86.isByte(n) THEN
OutByte(n MOD 256)
ELSE
OutInt(n)
END
END OutIntByte;
PROCEDURE isLong (n: INTEGER): BOOLEAN;
RETURN (n > UTILS.max32) OR (n < UTILS.min32)
END isLong;
PROCEDURE NewNumber (value: INTEGER);
VAR
number: Number;
BEGIN
NEW(number);
number.value := value;
LISTS.push(Numbers, number);
INC(Numbers_Count)
END NewNumber;
PROCEDURE NewLabel (): INTEGER;
BEGIN
BIN.NewLabel(prog)
RETURN IL.NewLabel()
END NewLabel;
PROCEDURE Rex (reg1, reg2: INTEGER);
BEGIN
OutByte(48H + reg1 DIV 8 + 4 * (reg2 DIV 8))
END Rex;
PROCEDURE lea (reg, offset, section: INTEGER);
BEGIN
Rex(0, reg);
OutByte2(8DH, 05H + 8 * (reg MOD 8)); (* lea reg, [rip + offset] *)
X86.Reloc(section, offset)
END lea;
PROCEDURE oprr (op: BYTE; reg1, reg2: INTEGER); (* op reg1, reg2 *)
BEGIN
Rex(reg1, reg2);
OutByte2(op, 0C0H + 8 * (reg2 MOD 8) + reg1 MOD 8)
END oprr;
PROCEDURE oprr2 (op1, op2: BYTE; reg1, reg2: INTEGER); (* op reg1, reg2 *)
BEGIN
Rex(reg1, reg2);
OutByte3(op1, op2, 0C0H + 8 * (reg2 MOD 8) + reg1 MOD 8)
END oprr2;
PROCEDURE mov (reg1, reg2: INTEGER); (* mov reg1, reg2 *)
BEGIN
oprr(89H, reg1, reg2)
END mov;
PROCEDURE xor (reg1, reg2: INTEGER); (* xor reg1, reg2 *)
BEGIN
oprr(31H, reg1, reg2)
END xor;
PROCEDURE and (reg1, reg2: INTEGER); (* and reg1, reg2 *)
BEGIN
oprr(21H, reg1, reg2)
END and;
PROCEDURE _or (reg1, reg2: INTEGER); (* or reg1, reg2 *)
BEGIN
oprr(09H, reg1, reg2)
END _or;
PROCEDURE add (reg1, reg2: INTEGER); (* add reg1, reg2 *)
BEGIN
oprr(01H, reg1, reg2)
END add;
PROCEDURE sub (reg1, reg2: INTEGER); (* sub reg1, reg2 *)
BEGIN
oprr(29H, reg1, reg2)
END sub;
PROCEDURE xchg (reg1, reg2: INTEGER); (* xchg reg1, reg2 *)
BEGIN
IF rax IN {reg1, reg2} THEN
Rex(reg1 + reg2, 0);
OutByte(90H + (reg1 + reg2) MOD 8)
ELSE
oprr(87H, reg1, reg2)
END
END xchg;
PROCEDURE cmprr (reg1, reg2: INTEGER); (* cmp reg1, reg2 *)
BEGIN
oprr(39H, reg1, reg2)
END cmprr;
PROCEDURE pop (reg: INTEGER); (* pop reg *)
BEGIN
IF reg >= 8 THEN
OutByte(41H)
END;
OutByte(58H + reg MOD 8)
END pop;
PROCEDURE push (reg: INTEGER); (* push reg *)
BEGIN
IF reg >= 8 THEN
OutByte(41H)
END;
OutByte(50H + reg MOD 8)
END push;
PROCEDURE decr (reg: INTEGER);
BEGIN
Rex(reg, 0);
OutByte2(0FFH, 0C8H + reg MOD 8) (* dec reg1 *)
END decr;
PROCEDURE incr (reg: INTEGER);
BEGIN
Rex(reg, 0);
OutByte2(0FFH, 0C0H + reg MOD 8) (* inc reg1 *)
END incr;
PROCEDURE drop;
BEGIN
REG.Drop(R)
END drop;
PROCEDURE GetAnyReg (): INTEGER;
RETURN REG.GetAnyReg(R)
END GetAnyReg;
PROCEDURE callimp (label: INTEGER);
BEGIN
OutByte2(0FFH, 15H); (* call qword[rip + label + IMP] *)
X86.Reloc(sIMP, label)
END callimp;
PROCEDURE pushDA (offs: INTEGER);
VAR
reg: INTEGER;
BEGIN
reg := GetAnyReg();
lea(reg, offs, sDATA);
push(reg);
drop
END pushDA;
PROCEDURE CallRTL (proc: INTEGER);
VAR
label: INTEGER;
BEGIN
label := IL.codes.rtl[proc];
IF label < 0 THEN
callimp(-label)
ELSE
X86.call(label)
END
END CallRTL;
PROCEDURE UnOp (VAR reg: INTEGER);
BEGIN
REG.UnOp(R, reg)
END UnOp;
PROCEDURE BinOp (VAR reg1, reg2: INTEGER);
BEGIN
REG.BinOp(R, reg1, reg2)
END BinOp;
PROCEDURE PushAll (NumberOfParameters: INTEGER);
BEGIN
REG.PushAll(R);
DEC(R.pushed, NumberOfParameters)
END PushAll;
PROCEDURE movabs (reg, n: INTEGER);
VAR
i: INTEGER;
BEGIN
Rex(reg, 0);
OutByte(0B8H + reg MOD 8); (* movabs reg, n *)
FOR i := 0 TO 7 DO
OutByte(UTILS.Byte(n, i))
END
END movabs;
PROCEDURE movrc (reg, n: INTEGER); (* mov reg, n *)
BEGIN
IF isLong(n) THEN
movabs(reg, n)
ELSIF n = 0 THEN
xor(reg, reg)
ELSE
Rex(reg, 0);
OutByte2(0C7H, 0C0H + reg MOD 8);
OutInt(n)
END
END movrc;
PROCEDURE test (reg: INTEGER); (* test reg, reg *)
BEGIN
oprr(85H, reg, reg)
END test;
PROCEDURE oprlongc (reg, n: INTEGER; oprr: OPRR);
VAR
reg2: INTEGER;
BEGIN
reg2 := GetAnyReg();
ASSERT(reg2 # reg);
movabs(reg2, n);
oprr(reg, reg2);
drop
END oprlongc;
PROCEDURE oprc (op, reg, n: INTEGER; oprr: OPRR);
BEGIN
IF isLong(n) THEN
oprlongc(reg, n, oprr)
ELSE
Rex(reg, 0);
X86.oprc(op, reg, n)
END
END oprc;
PROCEDURE cmprc (reg, n: INTEGER); (* cmp reg, n *)
BEGIN
IF n = 0 THEN
test(reg)
ELSE
oprc(0F8H, reg, n, cmprr)
END
END cmprc;
PROCEDURE addrc (reg, n: INTEGER); (* add reg, n *)
BEGIN
oprc(0C0H, reg, n, add)
END addrc;
PROCEDURE subrc (reg, n: INTEGER); (* sub reg, n *)
BEGIN
oprc(0E8H, reg, n, sub)
END subrc;
PROCEDURE andrc (reg, n: INTEGER); (* and reg, n *)
BEGIN
oprc(0E0H, reg, n, and)
END andrc;
PROCEDURE orrc (reg, n: INTEGER); (* or reg, n *)
BEGIN
oprc(0C8H, reg, n, _or)
END orrc;
PROCEDURE xorrc (reg, n: INTEGER); (* xor reg, n *)
BEGIN
oprc(0F0H, reg, n, xor)
END xorrc;
PROCEDURE pushc (n: INTEGER);
VAR
reg2: INTEGER;
BEGIN
IF isLong(n) THEN
reg2 := GetAnyReg();
movabs(reg2, n);
push(reg2);
drop
ELSE
X86.pushc(n)
END
END pushc;
PROCEDURE not (reg: INTEGER); (* not reg *)
BEGIN
Rex(reg, 0);
OutByte2(0F7H, 0D0H + reg MOD 8)
END not;
PROCEDURE neg (reg: INTEGER); (* neg reg *)
BEGIN
Rex(reg, 0);
OutByte2(0F7H, 0D8H + reg MOD 8)
END neg;
PROCEDURE movzx (reg1, reg2, offs: INTEGER; word: BOOLEAN); (* movzx reg1, byte/word[reg2 + offs] *)
BEGIN
Rex(reg2, reg1);
X86.movzx(reg1, reg2, offs, word)
END movzx;
PROCEDURE movmr32 (reg1, offs, reg2: INTEGER); (* mov dword[reg1+offs], reg2_32 *)
BEGIN
X86._movrm(reg2, reg1, offs, 32, TRUE)
END movmr32;
PROCEDURE movrm32 (reg1, reg2, offs: INTEGER); (* mov reg1_32, dword[reg2+offs] *)
BEGIN
X86._movrm(reg1, reg2, offs, 32, FALSE)
END movrm32;
PROCEDURE movmr (reg1, offs, reg2: INTEGER); (* mov qword[reg1+offs], reg2 *)
BEGIN
X86._movrm(reg2, reg1, offs, 64, TRUE)
END movmr;
PROCEDURE movrm (reg1, reg2, offs: INTEGER); (* mov reg1, qword[reg2+offs] *)
BEGIN
X86._movrm(reg1, reg2, offs, 64, FALSE)
END movrm;
PROCEDURE comisd (xmm1, xmm2: INTEGER); (* comisd xmm1, xmm2 *)
BEGIN
OutByte(66H);
IF (xmm1 >= 8) OR (xmm2 >= 8) THEN
OutByte(40H + (xmm1 DIV 8) * 4 + xmm2 DIV 8)
END;
OutByte3(0FH, 2FH, 0C0H + (xmm1 MOD 8) * 8 + xmm2 MOD 8)
END comisd;
PROCEDURE _movsdrm (xmm, reg, offs: INTEGER; mr: BOOLEAN);
VAR
b: BYTE;
BEGIN
OutByte(0F2H);
IF (xmm >= 8) OR (reg >= 8) THEN
OutByte(40H + (xmm DIV 8) * 4 + reg DIV 8)
END;
OutByte2(0FH, 10H + ORD(mr));
IF (offs = 0) & (reg # rbp) THEN
b := 0
ELSE
b := 40H + long(offs)
END;
OutByte(b + (xmm MOD 8) * 8 + reg MOD 8);
IF reg = rsp THEN
OutByte(24H)
END;
IF b # 0 THEN
OutIntByte(offs)
END
END _movsdrm;
PROCEDURE movsdrm (xmm, reg, offs: INTEGER); (* movsd xmm, qword[reg+offs] *)
BEGIN
_movsdrm(xmm, reg, offs, FALSE)
END movsdrm;
PROCEDURE movsdmr (reg, offs, xmm: INTEGER); (* movsd qword[reg+offs], xmm *)
BEGIN
_movsdrm(xmm, reg, offs, TRUE)
END movsdmr;
PROCEDURE opxx (op, xmm1, xmm2: INTEGER);
BEGIN
OutByte(0F2H);
IF (xmm1 >= 8) OR (xmm2 >= 8) THEN
OutByte(40H + (xmm1 DIV 8) * 4 + xmm2 DIV 8)
END;
OutByte3(0FH, op, 0C0H + (xmm1 MOD 8) * 8 + xmm2 MOD 8)
END opxx;
PROCEDURE jcc (cc, label: INTEGER); (* jcc label *)
BEGIN
X86.jcc(cc, label)
END jcc;
PROCEDURE shiftrc (op, reg, n: INTEGER);
BEGIN
Rex(reg, 0);
IF n = 1 THEN
OutByte(0D1H)
ELSE
OutByte(0C1H)
END;
X86.shift(op, reg MOD 8);
IF n # 1 THEN
OutByte(n)
END
END shiftrc;
PROCEDURE GetRegA;
BEGIN
ASSERT(REG.GetReg(R, rax))
END GetRegA;
PROCEDURE Win64Passing (params: INTEGER);
VAR
n, i: INTEGER;
BEGIN
n := params MOD 32;
params := params DIV 32;
FOR i := 0 TO n - 1 DO
IF i IN BITS(params) THEN
movsdrm(i, rsp, i * 8)
ELSE
movrm(Win64RegPar[i], rsp, i * 8)
END
END
END Win64Passing;
PROCEDURE SysVPassing (params: INTEGER);
VAR
n, i, s, p, ofs: INTEGER;
i_count, f_count: INTEGER;
reg: BOOLEAN;
BEGIN
ASSERT(r11 IN R.regs);
n := params MOD 32;
params := params DIV 32;
s := 0;
i_count := 0;
f_count := 0;
FOR i := 0 TO n - 1 DO
IF i IN BITS(params) THEN
INC(f_count)
ELSE
INC(i_count)
END
END;
s := MAX(0, f_count - 8) + MAX(0, i_count - 6);
p := 0;
subrc(rsp, s * 8);
i_count := 0;
f_count := 0;
FOR i := 0 TO n - 1 DO
ofs := (i + s) * 8;
IF i IN BITS(params) THEN
reg := f_count <= 7;
IF reg THEN
movsdrm(f_count, rsp, ofs);
INC(f_count)
END
ELSE
reg := i_count <= 5;
IF reg THEN
movrm(SystemVRegPar[i_count], rsp, ofs);
INC(i_count)
END
END;
IF ~reg THEN
movrm(r11, rsp, ofs);
movmr(rsp, p, r11);
INC(p, 8)
END
END
END SysVPassing;
PROCEDURE fcmp (op: INTEGER; xmm: INTEGER);
VAR
cc, reg: INTEGER;
BEGIN
reg := GetAnyReg();
xor(reg, reg);
CASE op OF
|IL.opEQF:
comisd(xmm - 1, xmm);
cc := sete
|IL.opNEF:
comisd(xmm - 1, xmm);
cc := setne
|IL.opLTF:
comisd(xmm - 1, xmm);
cc := setc
|IL.opGTF:
comisd(xmm, xmm - 1);
cc := setc
|IL.opLEF:
comisd(xmm, xmm - 1);
cc := setnc
|IL.opGEF:
comisd(xmm - 1, xmm);
cc := setnc
END;
OutByte2(7AH, 3 + reg DIV 8); (* jp L *)
X86.setcc(cc, reg)
(* L: *)
END fcmp;
PROCEDURE translate (commands: LISTS.LIST; stroffs: INTEGER);
VAR
cmd, next: COMMAND;
opcode, param1, param2, param3, a, b, c, n, label, L, i, cc: INTEGER;
reg1, reg2, xmm: INTEGER;
float: REAL;
BEGIN
xmm := -1;
cmd := commands.first(COMMAND);
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
opcode := cmd.opcode;
CASE opcode OF
|IL.opJMP:
X86.jmp(param1)
|IL.opCALL, IL.opWIN64CALL, IL.opSYSVCALL:
CASE opcode OF
|IL.opCALL:
|IL.opWIN64CALL: Win64Passing(param2)
|IL.opSYSVCALL: SysVPassing(param2)
END;
X86.call(param1)
|IL.opCALLP, IL.opWIN64CALLP, IL.opSYSVCALLP:
UnOp(reg1);
IF reg1 # rax THEN
mov(rax, reg1)
END;
drop;
CASE opcode OF
|IL.opCALLP:
|IL.opWIN64CALLP: Win64Passing(param2)
|IL.opSYSVCALLP: SysVPassing(param2)
END;
OutByte2(0FFH, 0D0H); (* call rax *)
ASSERT(R.top = -1)
|IL.opCALLI, IL.opWIN64CALLI, IL.opSYSVCALLI:
CASE opcode OF
|IL.opCALLI:
|IL.opWIN64CALLI: Win64Passing(param2)
|IL.opSYSVCALLI: SysVPassing(param2)
END;
callimp(param1)
|IL.opLABEL:
X86.SetLabel(param1)
|IL.opERR:
CallRTL(IL._error)
|IL.opONERR:
pushc(param2);
X86.jmp(param1)
|IL.opPUSHC:
pushc(param2)
|IL.opPRECALL:
PushAll(0);
IF (param2 # 0) & (xmm >= 0) THEN
subrc(rsp, 8)
END;
INC(Xmm[0]);
Xmm[Xmm[0]] := xmm + 1;
WHILE xmm >= 0 DO
subrc(rsp, 8);
movsdmr(rsp, 0, xmm);
DEC(xmm)
END;
ASSERT(xmm = -1)
|IL.opWIN64ALIGN16:
ASSERT(rax IN R.regs);
mov(rax, rsp);
andrc(rsp, -16);
push(rax);
subrc(rsp, (MAX(param2 - 4, 0) MOD 2 + MAX(4 - param2, 0) + 1) * 8)
|IL.opSYSVALIGN16:
ASSERT(rax IN R.regs);
mov(rax, rsp);
andrc(rsp, -16);
push(rax);
IF ~ODD(param2) THEN
push(rax)
END
|IL.opRESF, IL.opRES:
ASSERT(R.top = -1);
ASSERT(xmm = -1);
n := Xmm[Xmm[0]]; DEC(Xmm[0]);
IF opcode = IL.opRESF THEN
INC(xmm);
IF n > 0 THEN
movsdmr(rsp, n * 8, 0);
DEC(xmm);
INC(n)
END;
IF xmm + n > MAX_XMM THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END
ELSE
GetRegA
END;
WHILE n > 0 DO
INC(xmm);
movsdrm(xmm, rsp, 0);
addrc(rsp, 8);
DEC(n)
END
|IL.opENTER:
ASSERT(R.top = -1);
X86.SetLabel(param1);
param3 := cmd.param3;
IF param3 > 0 THEN
push(rbp);
mov(rbp, rsp);
n := param3 MOD 32;
param3 := param3 DIV 32;
FOR i := 0 TO n - 1 DO
IF i IN BITS(param3) THEN
movsdmr(rbp, i * 8 + 16, i)
ELSE
movmr(rbp, i * 8 + 16, Win64RegPar[i])
END
END
ELSIF param3 < 0 THEN
param3 := -param3;
n := (param3 MOD 32) * 8;
param3 := param3 DIV 32;
pop(r11);
subrc(rsp, n);
push(r11);
push(rbp);
mov(rbp, rsp);
a := 0;
b := 0;
c := 0;
INC(n, 16);
FOR i := 16 TO n - 8 BY 8 DO
IF ODD(param3) THEN
IF b <= 7 THEN
movsdmr(rbp, i, b);
INC(b)
ELSE
movrm(r11, rbp, n + c);
movmr(rbp, i, r11);
INC(c, 8)
END
ELSE
IF a <= 5 THEN
movmr(rbp, i, SystemVRegPar[a]);
INC(a)
ELSE
movrm(r11, rbp, n + c);
movmr(rbp, i, r11);
INC(c, 8)
END
END;
param3 := param3 DIV 2
END
ELSE
push(rbp);
mov(rbp, rsp)
END;
n := param2;
IF n > 4 THEN
movrc(rcx, n);
(* L: *)
pushc(0);
OutByte2(0E2H, 0FCH) (* loop L *)
ELSE
WHILE n > 0 DO
pushc(0);
DEC(n)
END
END
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF:
IF opcode = IL.opLEAVER THEN
UnOp(reg1);
IF reg1 # rax THEN
mov(rax, reg1)
END;
drop
END;
ASSERT(R.top = -1);
IF opcode = IL.opLEAVEF THEN
DEC(xmm)
END;
ASSERT(xmm = -1);
IF param1 > 0 THEN
mov(rsp, rbp)
END;
pop(rbp);
IF param2 > 0 THEN
OutByte3(0C2H, (param2 * 8) MOD 256, (param2 * 8) DIV 256) (* ret param2*8 *)
ELSE
X86.ret
END
|IL.opSAVES:
UnOp(reg1);
REG.PushAll_1(R);
pushDA(stroffs + param2);
push(reg1);
drop;
pushc(param1);
CallRTL(IL._move)
|IL.opSADR:
lea(GetAnyReg(), stroffs + param2, sDATA)
|IL.opLOAD8:
UnOp(reg1);
movzx(reg1, reg1, 0, FALSE)
|IL.opLOAD16:
UnOp(reg1);
movzx(reg1, reg1, 0, TRUE)
|IL.opLOAD32:
UnOp(reg1);
movrm32(reg1, reg1, 0);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32)
|IL.opLOAD64:
UnOp(reg1);
movrm(reg1, reg1, 0)
|IL.opLLOAD64:
reg1 := GetAnyReg();
movrm(reg1, rbp, param2 * 8)
|IL.opLLOAD8,
IL.opLLOAD16:
reg1 := GetAnyReg();
movzx(reg1, rbp, param2 * 8, opcode = IL.opLLOAD16)
|IL.opLLOAD32:
reg1 := GetAnyReg();
movrm32(reg1, rbp, param2 * 8);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32)
|IL.opGLOAD64:
reg1 := GetAnyReg();
Rex(0, reg1); (* mov reg1, qword[rip + param2 + BSS] *)
OutByte2(8BH, 05H + 8 * (reg1 MOD 8));
X86.Reloc(sBSS, param2)
|IL.opGLOAD8, IL.opGLOAD16:
reg1 := GetAnyReg();
Rex(0, reg1); (* movzx reg1, byte/word[rip + param2 + BSS] *)
OutByte3(0FH, 0B6H + ORD(opcode = IL.opGLOAD16), 05H + 8 * (reg1 MOD 8));
X86.Reloc(sBSS, param2)
|IL.opGLOAD32:
reg1 := GetAnyReg();
lea(reg1, param2, sBSS);
movrm32(reg1, reg1, 0);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32)
|IL.opVLOAD64:
reg1 := GetAnyReg();
movrm(reg1, rbp, param2 * 8);
movrm(reg1, reg1, 0)
|IL.opVLOAD8,
IL.opVLOAD16:
reg1 := GetAnyReg();
movrm(reg1, rbp, param2 * 8);
movzx(reg1, reg1, 0, opcode = IL.opVLOAD16)
|IL.opVLOAD32:
reg1 := GetAnyReg();
reg2 := GetAnyReg();
movrm(reg2, rbp, param2 * 8);
movrm32(reg1, reg2, 0);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32);
drop
|IL.opLADR:
n := param2 * 8;
next := cmd.next(COMMAND);
IF (next.opcode = IL.opSAVEF) OR (next.opcode = IL.opSAVEFI) THEN
ASSERT(xmm >= 0);
movsdmr(rbp, n, xmm);
DEC(xmm);
cmd := next
ELSIF next.opcode = IL.opLOADF THEN
INC(xmm);
IF xmm > MAX_XMM THEN
ERRORS.ErrorMsg(fname, next.param1, next.param2, FPR_ERR)
END;
movsdrm(xmm, rbp, n);
cmd := next
ELSE
IF (next.opcode = IL.opADDC) & ~isLong(n + next.param2) THEN
INC(n, next.param2);
cmd := next
END;
reg1 := GetAnyReg();
Rex(0, reg1);
OutByte2(8DH, 45H + long(n) + (reg1 MOD 8) * 8); (* lea reg1, qword[rbp+n] *)
OutIntByte(n)
END
|IL.opGADR:
next := cmd.next(COMMAND);
IF (next.opcode = IL.opADDC) & ~isLong(param2 + next.param2) THEN
INC(param2, next.param2);
cmd := next
END;
lea(GetAnyReg(), param2, sBSS)
|IL.opVADR:
movrm(GetAnyReg(), rbp, param2 * 8)
|IL.opSAVE8C:
UnOp(reg1);
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(0C6H, reg1 MOD 8, param2); (* mov byte[reg1], param2 *)
drop
|IL.opSAVE16C:
UnOp(reg1);
OutByte(66H);
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte2(0C7H, reg1 MOD 8);
OutByte2(param2 MOD 256, param2 DIV 256); (* mov word[reg1], param2 *)
drop
|IL.opSAVEC:
UnOp(reg1);
IF isLong(param2) THEN
reg2 := GetAnyReg();
movrc(reg2, param2);
movmr(reg1, 0, reg2);
drop
ELSE
Rex(reg1, 0);
OutByte2(0C7H, reg1 MOD 8); (* mov qword[reg1], param2 *)
OutInt(param2)
END;
drop
|IL.opRSET:
PushAll(2);
CallRTL(IL._set);
GetRegA
|IL.opRSETR:
PushAll(1);
pushc(param2);
CallRTL(IL._set);
GetRegA
|IL.opRSETL:
UnOp(reg1);
REG.PushAll_1(R);
pushc(param2);
push(reg1);
drop;
CallRTL(IL._set);
GetRegA
|IL.opRSET1:
PushAll(1);
CallRTL(IL._set1);
GetRegA
|IL.opINCL, IL.opEXCL:
BinOp(reg1, reg2);
cmprc(reg1, 64);
OutByte2(73H, 04H); (* jnb L *)
Rex(reg2, reg1);
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opEXCL), 8 * (reg1 MOD 8) + reg2 MOD 8); (* bts/btr qword[reg2], reg1 *)
(* L: *)
drop;
drop
|IL.opINCLC, IL.opEXCLC:
UnOp(reg1);
Rex(reg1, 0);
OutByte2(0FH, 0BAH); (* bts/btr qword[reg1], param2 *)
OutByte2(28H + 8 * ORD(opcode = IL.opEXCLC) + reg1 MOD 8, param2);
drop
|IL.opEQS .. IL.opGES:
PushAll(4);
pushc(opcode - IL.opEQS);
CallRTL(IL._strcmp);
GetRegA
|IL.opEQSW .. IL.opGESW:
PushAll(4);
pushc(opcode - IL.opEQSW);
CallRTL(IL._strcmpw);
GetRegA
|IL.opCONST:
movrc(GetAnyReg(), param2)
|IL.opEQ..IL.opGE,
IL.opEQC..IL.opGEC:
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN
BinOp(reg1, reg2);
cmprr(reg1, reg2);
drop
ELSE
UnOp(reg1);
cmprc(reg1, param2)
END;
drop;
cc := X86.cond(opcode);
next := cmd.next(COMMAND);
IF next.opcode = IL.opJNZ THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJZ THEN
jcc(X86.inv0(cc), next.param1);
cmd := next
ELSE
reg1 := GetAnyReg();
X86.setcc(cc + 16, reg1);
andrc(reg1, 1)
END
|IL.opCODE:
OutByte(param2)
|IL.opPUSHIP:
reg1 := GetAnyReg();
lea(reg1, param2, sIMP);
movrm(reg1, reg1, 0)
|IL.opPARAM:
n := param2;
IF n = 1 THEN
UnOp(reg1);
push(reg1);
drop
ELSE
ASSERT(R.top + 1 <= n);
PushAll(n)
END
|IL.opJNZ1:
UnOp(reg1);
test(reg1);
jcc(jne, param1)
|IL.opJG:
UnOp(reg1);
test(reg1);
jcc(jg, param1)
|IL.opJNZ:
UnOp(reg1);
test(reg1);
jcc(jne, param1);
drop
|IL.opJZ:
UnOp(reg1);
test(reg1);
jcc(je, param1);
drop
|IL.opIN, IL.opINR:
IF opcode = IL.opINR THEN
reg2 := GetAnyReg();
movrc(reg2, param2)
END;
label := NewLabel();
L := NewLabel();
BinOp(reg1, reg2);
cmprc(reg1, 64);
jcc(jb, L);
xor(reg1, reg1);
X86.jmp(label);
X86.SetLabel(L);
Rex(reg2, reg1);
OutByte3(0FH, 0A3H, 0C0H + 8 * (reg1 MOD 8) + reg2 MOD 8); (* bt reg2, reg1 *)
X86.setcc(setc, reg1);
andrc(reg1, 1);
X86.SetLabel(label);
drop
|IL.opINL:
UnOp(reg1);
Rex(reg1, 0);
OutByte2(0FH, 0BAH); (* bt reg1, param2 *)
OutByte2(0E0H + reg1 MOD 8, param2);
X86.setcc(setc, reg1);
andrc(reg1, 1)
|IL.opNOT:
UnOp(reg1);
test(reg1);
X86.setcc(sete, reg1);
andrc(reg1, 1)
|IL.opORD:
UnOp(reg1);
test(reg1);
X86.setcc(setne, reg1);
andrc(reg1, 1)
|IL.opABS:
UnOp(reg1);
test(reg1);
OutByte2(7DH, 03H); (* jge L *)
neg(reg1)
(* L: *)
|IL.opEQB, IL.opNEB:
BinOp(reg1, reg2);
drop;
test(reg1);
label := NewLabel();
jcc(je, label);
movrc(reg1, 1);
X86.SetLabel(label);
test(reg2);
label := NewLabel();
jcc(je, label);
movrc(reg2, 1);
X86.SetLabel(label);
cmprr(reg1, reg2);
IF opcode = IL.opEQB THEN
X86.setcc(sete, reg1)
ELSE
X86.setcc(setne, reg1)
END;
andrc(reg1, 1)
|IL.opMULSC:
UnOp(reg1);
andrc(reg1, param2)
|IL.opDIVSC:
UnOp(reg1);
xorrc(reg1, param2)
|IL.opADDSC:
UnOp(reg1);
orrc(reg1, param2)
|IL.opSUBSL:
UnOp(reg1);
not(reg1);
andrc(reg1, param2)
|IL.opSUBSR:
UnOp(reg1);
andrc(reg1, ORD(-BITS(param2)))
|IL.opMULS:
BinOp(reg1, reg2);
and(reg1, reg2);
drop
|IL.opDIVS:
BinOp(reg1, reg2);
xor(reg1, reg2);
drop
|IL.opUMINS:
UnOp(reg1);
not(reg1)
|IL.opCOPY:
PushAll(2);
pushc(param2);
CallRTL(IL._move)
|IL.opMOVE:
PushAll(3);
CallRTL(IL._move)
|IL.opCOPYA:
PushAll(4);
pushc(param2);
CallRTL(IL._arrcpy);
GetRegA
|IL.opCOPYS:
PushAll(4);
pushc(param2);
CallRTL(IL._strcpy)
|IL.opROT:
PushAll(0);
push(rsp);
pushc(param2);
CallRTL(IL._rot)
|IL.opNEW:
PushAll(1);
n := param2 + 8;
ASSERT(UTILS.Align(n, 8));
pushc(n);
pushc(param1);
CallRTL(IL._new)
|IL.opDISP:
PushAll(1);
CallRTL(IL._dispose)
|IL.opPUSHT:
UnOp(reg1);
movrm(GetAnyReg(), reg1, -8)
|IL.opISREC:
PushAll(2);
pushc(param2 * tcount);
CallRTL(IL._isrec);
GetRegA
|IL.opIS:
PushAll(1);
pushc(param2 * tcount);
CallRTL(IL._is);
GetRegA
|IL.opTYPEGR:
PushAll(1);
pushc(param2 * tcount);
CallRTL(IL._guardrec);
GetRegA
|IL.opTYPEGP:
UnOp(reg1);
PushAll(0);
push(reg1);
pushc(param2 * tcount);
CallRTL(IL._guard);
GetRegA
|IL.opTYPEGD:
UnOp(reg1);
PushAll(0);
X86.pushm(reg1, -8);
pushc(param2 * tcount);
CallRTL(IL._guardrec);
GetRegA
|IL.opCASET:
push(rcx);
push(rcx);
pushc(param2 * tcount);
CallRTL(IL._guardrec);
pop(rcx);
test(rax);
jcc(jne, param1)
|IL.opSAVEP:
UnOp(reg1);
reg2 := GetAnyReg();
lea(reg2, param2, sCODE);
movmr(reg1, 0, reg2);
drop;
drop
|IL.opPUSHP:
lea(GetAnyReg(), param2, sCODE)
|IL.opINC, IL.opDEC:
BinOp(reg1, reg2);
(* add/sub qword[reg2], reg1 *)
Rex(reg2, reg1);
OutByte2(01H + 28H * ORD(opcode = IL.opDEC), reg2 MOD 8 + (reg1 MOD 8) * 8);
drop;
drop
|IL.opINCC:
UnOp(reg1);
IF isLong(param2) THEN
reg2 := GetAnyReg();
movrc(reg2, param2);
(* add qword[reg1], reg2 *)
Rex(reg1, reg2);
OutByte2(01H, reg1 MOD 8 + (reg2 MOD 8) * 8);
drop
ELSIF ABS(param2) = 1 THEN
Rex(reg1, 0);
OutByte2(0FFH, reg1 MOD 8 + 8 * ORD(param2 = -1)) (* inc/dec qword[reg1] *)
ELSE
(* add qword[reg1], param2 *)
Rex(reg1, 0);
OutByte2(81H + short(param2), reg1 MOD 8);
OutIntByte(param2)
END;
drop
|IL.opDROP:
UnOp(reg1);
drop
|IL.opSAVE, IL.opSAVE64:
BinOp(reg2, reg1);
movmr(reg1, 0, reg2);
drop;
drop
|IL.opSAVE8:
BinOp(reg2, reg1);
X86.movmr8(reg1, 0, reg2);
drop;
drop
|IL.opSAVE16:
BinOp(reg2, reg1);
X86.movmr16(reg1, 0, reg2);
drop;
drop
|IL.opSAVE32:
BinOp(reg2, reg1);
movmr32(reg1, 0, reg2);
drop;
drop
|IL.opMAX, IL.opMIN:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(7DH + ORD(opcode = IL.opMIN), 3); (* jge/jle L *)
mov(reg1, reg2);
(* L: *)
drop
|IL.opMAXC, IL.opMINC:
UnOp(reg1);
cmprc(reg1, param2);
label := NewLabel();
IF opcode = IL.opMINC THEN
cc := jle
ELSE
cc := jge
END;
jcc(cc, label);
movrc(reg1, param2);
X86.SetLabel(label)
|IL.opSBOOL:
BinOp(reg2, reg1);
test(reg2);
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(0FH, 95H, reg1 MOD 8); (* setne byte[reg1] *)
drop;
drop
|IL.opSBOOLC:
UnOp(reg1);
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(0C6H, reg1 MOD 8, ORD(param2 # 0)); (* mov byte[reg1], 0/1 *)
drop
|IL.opUMINUS:
UnOp(reg1);
neg(reg1)
|IL.opADD:
BinOp(reg1, reg2);
add(reg1, reg2);
drop
|IL.opSUB:
BinOp(reg1, reg2);
sub(reg1, reg2);
drop
|IL.opSUBR, IL.opSUBL:
UnOp(reg1);
IF param2 = 1 THEN
decr(reg1)
ELSIF param2 = -1 THEN
incr(reg1)
ELSIF param2 # 0 THEN
subrc(reg1, param2)
END;
IF opcode = IL.opSUBL THEN
neg(reg1)
END
|IL.opADDC:
IF (param2 # 0) & ~isLong(param2) THEN
UnOp(reg1);
next := cmd.next(COMMAND);
CASE next.opcode OF
|IL.opLOAD64:
movrm(reg1, reg1, param2);
cmd := next
|IL.opLOAD32:
movrm32(reg1, reg1, param2);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32);
cmd := next
|IL.opLOAD16:
movzx(reg1, reg1, param2, TRUE);
cmd := next
|IL.opLOAD8:
movzx(reg1, reg1, param2, FALSE);
cmd := next
|IL.opLOAD64_PARAM:
X86.pushm(reg1, param2);
drop;
cmd := next
ELSE
IF param2 = 1 THEN
incr(reg1)
ELSIF param2 = -1 THEN
decr(reg1)
ELSE
addrc(reg1, param2)
END
END
ELSIF isLong(param2) THEN
UnOp(reg1);
addrc(reg1, param2)
END
|IL.opDIV:
PushAll(2);
CallRTL(IL._divmod);
GetRegA
|IL.opDIVR:
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(reg1);
shiftrc(sar, reg1, n)
ELSIF n < 0 THEN
PushAll(1);
pushc(param2);
CallRTL(IL._divmod);
GetRegA
END
|IL.opDIVL:
UnOp(reg1);
REG.PushAll_1(R);
pushc(param2);
push(reg1);
drop;
CallRTL(IL._divmod);
GetRegA
|IL.opMOD:
PushAll(2);
CallRTL(IL._divmod);
mov(rax, rdx);
GetRegA
|IL.opMODR:
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(reg1);
andrc(reg1, param2 - 1);
ELSIF n < 0 THEN
PushAll(1);
pushc(param2);
CallRTL(IL._divmod);
mov(rax, rdx);
GetRegA
ELSE
UnOp(reg1);
xor(reg1, reg1)
END
|IL.opMODL:
UnOp(reg1);
REG.PushAll_1(R);
pushc(param2);
push(reg1);
drop;
CallRTL(IL._divmod);
mov(rax, rdx);
GetRegA
|IL.opMUL:
BinOp(reg1, reg2);
oprr2(0FH, 0AFH, reg2, reg1); (* imul reg1, reg2 *)
drop
|IL.opMULC:
IF (cmd.next(COMMAND).opcode = IL.opADD) & ((param2 = 2) OR (param2 = 4) OR (param2 = 8)) THEN
BinOp(reg1, reg2);
OutByte2(48H + 5 * (reg1 DIV 8) + 2 * (reg2 DIV 8), 8DH); (* lea reg1, [reg1 + reg2 * param2] *)
reg1 := reg1 MOD 8;
reg2 := reg2 MOD 8;
OutByte2(04H + reg1 * 8, reg1 + reg2 * 8 + 40H * UTILS.Log2(param2));
drop;
cmd := cmd.next(COMMAND)
ELSE
UnOp(reg1);
a := param2;
IF a > 1 THEN
n := UTILS.Log2(a)
ELSIF a < -1 THEN
n := UTILS.Log2(-a)
ELSE
n := -1
END;
IF a = 1 THEN
ELSIF a = -1 THEN
neg(reg1)
ELSIF a = 0 THEN
xor(reg1, reg1)
ELSE
IF n > 0 THEN
IF a < 0 THEN
neg(reg1)
END;
shiftrc(shl, reg1, n)
ELSE
IF isLong(a) THEN
reg2 := GetAnyReg();
movabs(reg2, a);
ASSERT(reg1 # reg2);
oprr2(0FH, 0AFH, reg2, reg1); (* imul reg1, reg2 *)
drop
ELSE
(* imul reg1, a *)
Rex(reg1, reg1);
OutByte2(69H + short(a), 0C0H + (reg1 MOD 8) * 9);
OutIntByte(a)
END
END
END
END
|IL.opADDS:
BinOp(reg1, reg2);
_or(reg1, reg2);
drop
|IL.opSUBS:
BinOp(reg1, reg2);
not(reg2);
and(reg1, reg2);
drop
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opSWITCH:
UnOp(reg1);
IF param2 = 0 THEN
reg2 := rax
ELSE
reg2 := rcx
END;
IF reg1 # reg2 THEN
ASSERT(REG.GetReg(R, reg2));
ASSERT(REG.Exchange(R, reg1, reg2));
drop
END;
drop
|IL.opENDSW:
|IL.opCASEL:
GetRegA;
cmprc(rax, param1);
jcc(jl, param2);
drop
|IL.opCASER:
GetRegA;
cmprc(rax, param1);
jcc(jg, param2);
drop
|IL.opCASELR:
GetRegA;
cmprc(rax, param1);
IF param2 = cmd.param3 THEN
jcc(jne, param2)
ELSE
jcc(jl, param2);
jcc(jg, cmd.param3)
END;
drop
|IL.opASR, IL.opROR, IL.opLSL, IL.opLSR:
UnOp(reg1);
IF reg1 # rcx THEN
ASSERT(REG.GetReg(R, rcx));
ASSERT(REG.Exchange(R, reg1, rcx));
drop
END;
BinOp(reg1, reg2);
ASSERT(reg2 = rcx);
Rex(reg1, 0);
OutByte(0D3H);
X86.shift(opcode, reg1 MOD 8); (* shift reg1, cl *)
drop
|IL.opASR1, IL.opROR1, IL.opLSL1, IL.opLSR1:
UnOp(reg1);
IF reg1 # rcx THEN
ASSERT(REG.GetReg(R, rcx));
ASSERT(REG.Exchange(R, reg1, rcx));
drop
END;
reg1 := GetAnyReg();
movrc(reg1, param2);
BinOp(reg1, reg2);
ASSERT(reg1 = rcx);
Rex(reg2, 0);
OutByte(0D3H);
X86.shift(opcode, reg2 MOD 8); (* shift reg2, cl *)
drop;
drop;
ASSERT(REG.GetReg(R, reg2))
|IL.opASR2, IL.opROR2, IL.opLSL2, IL.opLSR2:
UnOp(reg1);
shiftrc(opcode, reg1, param2 MOD 64)
|IL.opGET, IL.opGETC:
IF opcode = IL.opGET THEN
BinOp(reg1, reg2)
ELSIF opcode = IL.opGETC THEN
UnOp(reg2);
reg1 := GetAnyReg();
movrc(reg1, param1)
END;
drop;
drop;
X86._movrm(reg1, reg1, 0, param2 * 8, FALSE);
X86._movrm(reg1, reg2, 0, param2 * 8, TRUE)
|IL.opCHKBYTE:
BinOp(reg1, reg2);
cmprc(reg1, 256);
jcc(jb, param1)
|IL.opCHKIDX:
UnOp(reg1);
cmprc(reg1, param2);
jcc(jb, param1)
|IL.opCHKIDX2:
BinOp(reg1, reg2);
IF param2 # -1 THEN
cmprr(reg2, reg1);
jcc(jb, param1);
END;
INCL(R.regs, reg1);
DEC(R.top);
R.stk[R.top] := reg2
|IL.opLENGTH:
PushAll(2);
CallRTL(IL._length);
GetRegA
|IL.opLENGTHW:
PushAll(2);
CallRTL(IL._lengthw);
GetRegA
|IL.opLEN:
n := param2;
UnOp(reg1);
drop;
EXCL(R.regs, reg1);
WHILE n > 0 DO
UnOp(reg2);
drop;
DEC(n)
END;
INCL(R.regs, reg1);
ASSERT(REG.GetReg(R, reg1))
|IL.opCHR:
UnOp(reg1);
andrc(reg1, 255)
|IL.opWCHR:
UnOp(reg1);
andrc(reg1, 65535)
|IL.opEQP, IL.opNEP, IL.opEQIP, IL.opNEIP:
UnOp(reg1);
reg2 := GetAnyReg();
CASE opcode OF
|IL.opEQP, IL.opNEP:
lea(reg2, param1, sCODE)
|IL.opEQIP, IL.opNEIP:
lea(reg2, param1, sIMP);
movrm(reg2, reg2, 0)
END;
cmprr(reg1, reg2);
drop;
drop;
reg1 := GetAnyReg();
CASE opcode OF
|IL.opEQP, IL.opEQIP: X86.setcc(sete, reg1)
|IL.opNEP, IL.opNEIP: X86.setcc(setne, reg1)
END;
andrc(reg1, 1)
|IL.opINCCB, IL.opDECCB:
UnOp(reg1);
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(80H, 28H * ORD(opcode = IL.opDECCB) + reg1 MOD 8, param2 MOD 256); (* add/sub byte[reg1], param2 MOD 256 *)
drop
|IL.opINCB, IL.opDECB:
BinOp(reg1, reg2);
IF (reg1 >= 8) OR (reg2 >= 8) THEN
OutByte(40H + reg2 DIV 8 + 4 * (reg1 DIV 8))
END;
OutByte2(28H * ORD(opcode = IL.opDECB), reg2 MOD 8 + 8 * (reg1 MOD 8)); (* add/sub byte[reg2], reg1_8 *)
drop;
drop
|IL.opSAVEIP:
UnOp(reg1);
reg2 := GetAnyReg();
lea(reg2, param2, sIMP);
movrm(reg2, reg2, 0);
push(reg2);
drop;
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte2(8FH, reg1 MOD 8); (* pop qword[reg1] *)
drop
|IL.opCLEANUP:
IF param2 # 0 THEN
addrc(rsp, param2 * 8)
END
|IL.opPOPSP:
pop(rsp)
|IL.opLOADF:
UnOp(reg1);
INC(xmm);
IF xmm > MAX_XMM THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
movsdrm(xmm, reg1, 0);
drop
|IL.opPUSHF:
ASSERT(xmm >= 0);
subrc(rsp, 8);
movsdmr(rsp, 0, xmm);
DEC(xmm)
|IL.opCONSTF:
float := cmd.float;
INC(xmm);
IF xmm > MAX_XMM THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
(* movsd xmm, qword ptr [rip + Numbers_Offs + Numbers_Count * 8 + DATA] *)
OutByte(0F2H);
IF xmm >= 8 THEN
OutByte(44H)
END;
OutByte3(0FH, 10H, 05H + 8 * (xmm MOD 8));
X86.Reloc(sDATA, Numbers_Offs + Numbers_Count * 8);
NewNumber(UTILS.splitf(float, a, b))
|IL.opSAVEF, IL.opSAVEFI:
ASSERT(xmm >= 0);
UnOp(reg1);
movsdmr(reg1, 0, xmm);
DEC(xmm);
drop
|IL.opADDF:
ASSERT(xmm >= 1);
opxx(58H, xmm - 1, xmm);
DEC(xmm)
|IL.opSUBF:
ASSERT(xmm >= 1);
opxx(5CH, xmm - 1, xmm);
DEC(xmm)
|IL.opSUBFI:
ASSERT(xmm >= 1);
opxx(5CH, xmm, xmm - 1);
opxx(10H, xmm - 1, xmm);
DEC(xmm)
|IL.opMULF:
ASSERT(xmm >= 1);
opxx(59H, xmm - 1, xmm);
DEC(xmm)
|IL.opDIVF:
ASSERT(xmm >= 1);
opxx(5EH, xmm - 1, xmm);
DEC(xmm)
|IL.opDIVFI:
ASSERT(xmm >= 1);
opxx(5EH, xmm, xmm - 1);
opxx(10H, xmm - 1, xmm);
DEC(xmm)
|IL.opFABS, IL.opUMINF: (* andpd/xorpd xmm, xmmword[rip + Numbers_Offs + (16) + DATA] *)
ASSERT(xmm >= 0);
OutByte(66H);
IF xmm >= 8 THEN
OutByte(44H)
END;
OutByte3(0FH, 54H + 3 * ORD(opcode = IL.opUMINF), 05H + (xmm MOD 8) * 8);
X86.Reloc(sDATA, Numbers_Offs + 16 * ORD(opcode = IL.opFABS))
|IL.opFLT:
UnOp(reg1);
INC(xmm);
IF xmm > MAX_XMM THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
OutByte(0F2H); Rex(reg1, xmm); OutByte(0FH); (* cvtsi2sd xmm, reg1 *)
OutByte2(2AH, 0C0H + (xmm MOD 8) * 8 + reg1 MOD 8);
drop
|IL.opFLOOR:
ASSERT(xmm >= 0);
reg1 := GetAnyReg();
subrc(rsp, 8);
OutByte3(00FH, 0AEH, 05CH); OutByte2(024H, 004H); (* stmxcsr dword[rsp+4]; *)
OutByte2(00FH, 0AEH); OutByte2(01CH, 024H); (* stmxcsr dword[rsp]; *)
OutByte3(081H, 024H, 024H); OutByte2(0FFH, 09FH); OutByte2(0FFH, 0FFH); (* and dword[rsp],11111111111111111001111111111111b; *)
OutByte3(081H, 00CH, 024H); OutByte2(000H, 020H); OutByte2(000H, 000H); (* or dword[rsp],00000000000000000010000000000000b; *)
OutByte2(00FH, 0AEH); OutByte2(014H, 024H); (* ldmxcsr dword[rsp]; *)
OutByte(0F2H); Rex(xmm, reg1); OutByte(0FH); (* cvtsd2si reg1, xmm *)
OutByte2(2DH, 0C0H + xmm MOD 8 + (reg1 MOD 8) * 8);
OutByte3(00FH, 0AEH, 054H); OutByte2(024H, 004H); (* ldmxcsr dword[rsp+4]; *)
addrc(rsp, 8);
DEC(xmm)
|IL.opEQF .. IL.opGEF:
ASSERT(xmm >= 1);
fcmp(opcode, xmm);
DEC(xmm, 2)
|IL.opINF:
INC(xmm);
IF xmm > MAX_XMM THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
(* movsd xmm, qword ptr [rip + Numbers_Offs + 32 + DATA] *)
OutByte(0F2H);
IF xmm >= 8 THEN
OutByte(44H)
END;
OutByte3(0FH, 10H, 05H + 8 * (xmm MOD 8));
X86.Reloc(sDATA, Numbers_Offs + 32)
|IL.opPACK, IL.opPACKC:
IF opcode = IL.opPACK THEN
BinOp(reg1, reg2)
ELSE
UnOp(reg1);
reg2 := GetAnyReg();
movrc(reg2, param2)
END;
push(reg1);
movrm(reg1, reg1, 0);
shiftrc(shl, reg1, 1);
shiftrc(shr, reg1, 53);
add(reg1, reg2);
andrc(reg1, ORD({0..10}));
shiftrc(shl, reg1, 52);
movrm(reg2, rsp, 0);
movrm(reg2, reg2, 0);
push(reg1);
lea(reg1, Numbers_Offs + 40, sDATA); (* {0..51, 63} *)
movrm(reg1, reg1, 0);
and(reg2, reg1);
pop(reg1);
_or(reg2, reg1);
pop(reg1);
movmr(reg1, 0, reg2);
drop;
drop
|IL.opUNPK, IL.opLADR_UNPK:
IF opcode = IL.opLADR_UNPK THEN
n := param2 * 8;
UnOp(reg1);
reg2 := GetAnyReg();
Rex(0, reg2);
OutByte2(8DH, 45H + long(n) + (reg2 MOD 8) * 8); (* lea reg2, qword[rbp+n] *)
OutIntByte(n)
ELSE
BinOp(reg1, reg2)
END;
push(reg1);
movrm(reg1, reg1, 0);
shiftrc(shl, reg1, 1);
shiftrc(shr, reg1, 53);
subrc(reg1, 1023);
movmr(reg2, 0, reg1);
pop(reg2);
movrm(reg1, reg2, 0);
push(reg2);
lea(reg2, Numbers_Offs + 48, sDATA); (* {52..61} *)
movrm(reg2, reg2, 0);
_or(reg1, reg2);
pop(reg2);
Rex(reg1, 0);
OutByte2(0FH, 0BAH);
OutByte2(0F0H + reg1 MOD 8, 3EH); (* btr reg1, 62 *)
movmr(reg2, 0, reg1);
drop;
drop
|IL.opSADR_PARAM:
pushDA(stroffs + param2)
|IL.opVADR_PARAM:
X86.pushm(rbp, param2 * 8)
|IL.opLOAD64_PARAM:
UnOp(reg1);
X86.pushm(reg1, 0);
drop
|IL.opLLOAD64_PARAM:
X86.pushm(rbp, param2 * 8)
|IL.opGLOAD64_PARAM:
OutByte2(0FFH, 35H); (* push qword[rip + param2 + BSS] *)
X86.Reloc(sBSS, param2)
|IL.opCONST_PARAM:
pushc(param2)
|IL.opGLOAD32_PARAM, IL.opLOAD32_PARAM:
IF opcode = IL.opGLOAD32_PARAM THEN
reg1 := GetAnyReg();
lea(reg1, param2, sBSS)
ELSE
UnOp(reg1)
END;
movrm32(reg1, reg1, 0);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32);
push(reg1);
drop
|IL.opLLOAD32_PARAM:
reg1 := GetAnyReg();
movrm32(reg1, rbp, param2 * 8);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32);
push(reg1);
drop
|IL.opLADR_SAVEC:
n := param1 * 8;
IF isLong(param2) THEN
reg2 := GetAnyReg();
movrc(reg2, param2);
movmr(rbp, n, reg2);
drop
ELSE
OutByte3(48H, 0C7H, 45H + long(n)); (* mov qword[rbp+n], param2 *)
OutIntByte(n);
OutInt(param2)
END
|IL.opGADR_SAVEC:
IF isLong(param2) THEN
reg1 := GetAnyReg();
movrc(reg1, param2);
reg2 := GetAnyReg();
lea(reg2, param1, sBSS);
movmr(reg2, 0, reg1);
drop;
drop
ELSE
(* mov qword[rip + param1 - 4 + BSS], param2 *)
OutByte3(48H, 0C7H, 05H);
X86.Reloc(sBSS, param1 - 4);
OutInt(param2)
END
|IL.opLADR_SAVE:
UnOp(reg1);
movmr(rbp, param2 * 8, reg1);
drop
|IL.opLADR_INCC:
IF isLong(param2) THEN
reg2 := GetAnyReg();
movrc(reg2, param2);
n := param1 * 8;
Rex(0, reg2);
OutByte2(01H, 45H + long(n) + (reg2 MOD 8) * 8);
OutIntByte(n); (* add qword[rbp+n], reg2 *)
drop
ELSIF ABS(param2) = 1 THEN
n := param1 * 8;
OutByte3(48H, 0FFH, 45H + 8 * ORD(param2 = -1) + long(n)); (* inc/dec qword[rbp+n] *)
OutIntByte(n)
ELSE
n := param1 * 8;
OutByte3(48H, 81H + short(param2), 45H + long(n));
OutIntByte(n);
OutIntByte(param2) (* add qword[rbp+n], param2 *)
END
|IL.opLADR_INCCB, IL.opLADR_DECCB:
param2 := param2 MOD 256;
n := param1 * 8;
OutByte2(80H, 45H + long(n) + 28H * ORD(opcode = IL.opLADR_DECCB));
OutIntByte(n);
OutByte(param2) (* add/sub byte[rbp+n], param2 *)
|IL.opLADR_INC, IL.opLADR_DEC:
UnOp(reg1);
n := param2 * 8;
Rex(0, reg1);
OutByte2(01H + 28H * ORD(opcode = IL.opLADR_DEC), 45H + long(n) + (reg1 MOD 8) * 8);
OutIntByte(n); (* add/sub qword[rbp+n], reg1 *)
drop
|IL.opLADR_INCB, IL.opLADR_DECB:
UnOp(reg1);
n := param2 * 8;
IF reg1 >= 8 THEN
OutByte(44H)
END;
OutByte2(28H * ORD(opcode = IL.opLADR_DECB), 45H + long(n) + 8 * (reg1 MOD 8));
OutIntByte(n); (* add/sub byte[rbp+n], reg1_8 *)
drop
|IL.opLADR_INCL, IL.opLADR_EXCL:
UnOp(reg1);
cmprc(reg1, 64);
n := param2 * 8;
OutByte2(73H, 5 + 3 * ORD(~X86.isByte(n))); (* jnb L *)
Rex(0, reg1);
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), 45H + long(n) + 8 * (reg1 MOD 8));
OutIntByte(n); (* bts/btr qword[rbp+n], reg1 *)
(* L: *)
drop
|IL.opLADR_INCLC, IL.opLADR_EXCLC:
n := param1 * 8;
OutByte3(48H, 0FH, 0BAH); (* bts/btr qword[rbp+n], param2 *)
OutByte(6DH + long(n) + 8 * ORD(opcode = IL.opLADR_EXCLC));
OutIntByte(n);
OutByte(param2)
|IL.opFNAME:
fname := cmd(IL.FNAMECMD).fname
END;
cmd := cmd.next(COMMAND)
END;
ASSERT(R.pushed = 0);
ASSERT(R.top = -1);
ASSERT(xmm = -1)
END translate;
PROCEDURE prolog (modname: ARRAY OF CHAR; target, stack_size: INTEGER);
VAR
ModName_Offs, entry, L: INTEGER;
BEGIN
ModName_Offs := tcount * 8 + CHL.Length(IL.codes.data);
Numbers_Offs := ModName_Offs + LENGTH(modname) + 1;
ASSERT(UTILS.Align(Numbers_Offs, 16));
entry := NewLabel();
X86.SetLabel(entry);
IF target = TARGETS.Win64DLL THEN
dllret := NewLabel();
push(r8);
push(rdx);
push(rcx);
CallRTL(IL._dllentry);
test(rax);
jcc(je, dllret);
pushc(0)
ELSIF target = TARGETS.Linux64 THEN
push(rsp)
ELSE
pushc(0)
END;
lea(rax, entry, sCODE);
push(rax);
pushDA(0); (* TYPES *)
pushc(tcount);
pushDA(ModName_Offs); (* MODNAME *)
CallRTL(IL._init);
IF target IN {TARGETS.Win64C, TARGETS.Win64GUI, TARGETS.Linux64} THEN
L := NewLabel();
pushc(0);
push(rsp);
pushc(1024 * 1024 * stack_size);
pushc(0);
CallRTL(IL._new);
pop(rax);
test(rax);
jcc(je, L);
GetRegA;
addrc(rax, 1024 * 1024 * stack_size - 8);
drop;
mov(rsp, rax);
X86.SetLabel(L)
END
END prolog;
PROCEDURE epilog (modname: ARRAY OF CHAR; target: INTEGER);
VAR
i, n: INTEGER;
number: Number;
exp: IL.EXPORT_PROC;
PROCEDURE _import (imp: LISTS.LIST);
VAR
lib: IL.IMPORT_LIB;
proc: IL.IMPORT_PROC;
BEGIN
lib := imp.first(IL.IMPORT_LIB);
WHILE lib # NIL DO
BIN.Import(prog, lib.name, 0);
proc := lib.procs.first(IL.IMPORT_PROC);
WHILE proc # NIL DO
BIN.Import(prog, proc.name, proc.label);
proc := proc.next(IL.IMPORT_PROC)
END;
lib := lib.next(IL.IMPORT_LIB)
END
END _import;
BEGIN
IF target = TARGETS.Win64DLL THEN
X86.SetLabel(dllret);
X86.ret
ELSIF target = TARGETS.Linux64SO THEN
sofinit := NewLabel();
X86.ret;
X86.SetLabel(sofinit);
CallRTL(IL._sofinit);
X86.ret
ELSE
pushc(0);
CallRTL(IL._exit)
END;
X86.fixup;
i := 0;
WHILE i < tcount DO
BIN.PutData64LE(prog, CHL.GetInt(IL.codes.types, i));
INC(i)
END;
i := 0;
WHILE i < CHL.Length(IL.codes.data) DO
BIN.PutData(prog, CHL.GetByte(IL.codes.data, i));
INC(i)
END;
BIN.PutDataStr(prog, modname);
BIN.PutData(prog, 0);
n := CHL.Length(prog.data);
ASSERT(UTILS.Align(n, 16));
i := n - CHL.Length(prog.data);
WHILE i > 0 DO
BIN.PutData(prog, 0);
DEC(i)
END;
number := Numbers.first(Number);
FOR i := 0 TO Numbers_Count - 1 DO
BIN.PutData64LE(prog, number.value);
number := number.next(Number)
END;
exp := IL.codes.export.first(IL.EXPORT_PROC);
WHILE exp # NIL DO
BIN.Export(prog, exp.name, exp.label);
exp := exp.next(IL.EXPORT_PROC)
END;
_import(IL.codes._import)
END epilog;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
VAR
path, modname, ext: PATHS.PATH;
BEGIN
Xmm[0] := 0;
tcount := CHL.Length(IL.codes.types);
Win64RegPar[0] := rcx;
Win64RegPar[1] := rdx;
Win64RegPar[2] := r8;
Win64RegPar[3] := r9;
SystemVRegPar[0] := rdi;
SystemVRegPar[1] := rsi;
SystemVRegPar[2] := rdx;
SystemVRegPar[3] := rcx;
SystemVRegPar[4] := r8;
SystemVRegPar[5] := r9;
PATHS.split(outname, path, modname, ext);
S.append(modname, ext);
REG.Init(R, push, pop, mov, xchg, {rax, rcx, rdx, r8, r9, r10, r11});
IL.set_bss(MAX(IL.codes.bss, MAX(IL.codes.dmin - CHL.Length(IL.codes.data), 8)));
Numbers := LISTS.create(NIL);
Numbers_Count := 0;
NewNumber(ROR(1, 1)); (* 8000000000000000H *)
NewNumber(0);
NewNumber(ROR(-2, 1)); (* 7FFFFFFFFFFFFFFFH *)
NewNumber(-1);
NewNumber(ROR(7FFH, 12)); (* +Infinity *)
NewNumber(ORD(-BITS(LSR(ASR(ROR(1, 1), 10), 1)))); (* {0..51, 63} *)
NewNumber(LSR(ASR(ROR(1, 1), 9), 2)); (* {52..61} *)
prog := BIN.create(IL.codes.lcount);
BIN.SetParams(prog, IL.codes.bss, 1, WCHR(1), WCHR(0));
X86.SetProgram(prog);
prolog(modname, target, options.stack);
translate(IL.codes.commands, tcount * 8);
epilog(modname, target);
BIN.fixup(prog);
IF TARGETS.OS = TARGETS.osWIN64 THEN
PE32.write(prog, outname, target = TARGETS.Win64C, target = TARGETS.Win64DLL, TRUE)
ELSIF TARGETS.OS = TARGETS.osLINUX64 THEN
ELF.write(prog, outname, sofinit, target = TARGETS.Linux64SO, TRUE)
END
END CodeGen;
END AMD64.

/programs/develop/oberon07/source/ARITH.ob07
0,0 → 1,806
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE ARITH;
IMPORT STRINGS, UTILS, LISTS;
CONST
tINTEGER* = 1; tREAL* = 2; tSET* = 3;
tBOOLEAN* = 4; tCHAR* = 5; tWCHAR* = 6;
tSTRING* = 7;
opEQ* = 0; opNE* = 1; opLT* = 2; opLE* = 3; opGT* = 4; opGE* = 5;
opIN* = 6; opIS* = 7;
TYPE
VALUE* = RECORD
typ*: INTEGER;
int: INTEGER;
float: REAL;
set: SET;
bool: BOOLEAN;
string*: LISTS.ITEM
END;
VAR
digit: ARRAY 256 OF INTEGER;
PROCEDURE Int* (v: VALUE): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE v.typ OF
|tINTEGER, tCHAR, tWCHAR:
res := v.int
|tSET:
res := UTILS.Long(ORD(v.set))
|tBOOLEAN:
res := ORD(v.bool)
END
RETURN res
END Int;
PROCEDURE getBool* (v: VALUE): BOOLEAN;
BEGIN
ASSERT(v.typ = tBOOLEAN);
RETURN v.bool
END getBool;
PROCEDURE Float* (v: VALUE): REAL;
BEGIN
ASSERT(v.typ = tREAL);
RETURN v.float
END Float;
PROCEDURE range* (i: VALUE; a, b: INTEGER): BOOLEAN;
RETURN (a <= i.int) & (i.int <= b)
END range;
PROCEDURE check* (v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
CASE v.typ OF
|tINTEGER: res := range(v, UTILS.target.minInt, UTILS.target.maxInt)
|tCHAR: res := range(v, 0, 255)
|tWCHAR: res := range(v, 0, 65535)
|tREAL: res := (-UTILS.target.maxReal <= v.float) & (v.float <= UTILS.target.maxReal)
END
RETURN res
END check;
PROCEDURE isZero* (v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
CASE v.typ OF
|tINTEGER: res := v.int = 0
|tREAL: res := v.float = 0.0
END
RETURN res
END isZero;
PROCEDURE iconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
value: INTEGER;
i: INTEGER;
d: INTEGER;
BEGIN
error := 0;
value := 0;
i := 0;
WHILE STRINGS.digit(s[i]) & (error = 0) DO
d := digit[ORD(s[i])];
IF value <= (UTILS.maxint - d) DIV 10 THEN
value := value * 10 + d;
INC(i)
ELSE
error := 1
END
END;
IF error = 0 THEN
v.int := value;
v.typ := tINTEGER;
IF ~check(v) THEN
error := 1
END
END
END iconv;
PROCEDURE hconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
value: INTEGER;
i: INTEGER;
n: INTEGER;
d: INTEGER;
BEGIN
ASSERT(STRINGS.digit(s[0]));
error := 0;
value := 0;
n := -1;
i := 0;
WHILE (s[i] # "H") & (s[i] # "X") & (s[i] # "h") & (s[i] # "x") & (error = 0) DO
d := digit[ORD(s[i])];
IF (n = -1) & (d # 0) THEN
n := i
END;
IF (n # -1) & (i - n + 1 > UTILS.target.maxHex) THEN
error := 2
ELSE
value := value * 16 + d;
INC(i)
END
END;
value := UTILS.Long(value);
IF ((s[i] = "X") OR (s[i] = "x")) & (n # -1) & (i - n > 4) THEN
error := 3
END;
IF error = 0 THEN
v.int := value;
IF (s[i] = "X") OR (s[i] = "x") THEN
v.typ := tCHAR;
IF ~check(v) THEN
v.typ := tWCHAR;
IF ~check(v) THEN
error := 3
END
END
ELSE
v.typ := tINTEGER;
IF ~check(v) THEN
error := 2
END
END
END
END hconv;
PROCEDURE opFloat2 (VAR a: REAL; b: REAL; op: CHAR): BOOLEAN;
BEGIN
CASE op OF
|"+": a := a + b
|"-": a := a - b
|"*": a := a * b
|"/": a := a / b
END
RETURN (-UTILS.maxreal <= a) & (a <= UTILS.maxreal) (* +inf > UTILS.maxreal *)
END opFloat2;
PROCEDURE fconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
value: REAL;
frac: REAL;
exp10: REAL;
i, n, d: INTEGER;
minus: BOOLEAN;
BEGIN
error := 0;
value := 0.0;
frac := 0.0;
exp10 := 1.0;
minus := FALSE;
n := 0;
i := 0;
WHILE (error = 0) & STRINGS.digit(s[i]) DO
IF opFloat2(value, 10.0, "*") & opFloat2(value, FLT(digit[ORD(s[i])]), "+") THEN
INC(i)
ELSE
error := 4
END
END;
INC(i);
WHILE (error = 0) & STRINGS.digit(s[i]) DO
IF opFloat2(frac, 10.0, "*") & opFloat2(frac, FLT(digit[ORD(s[i])]), "+") THEN
exp10 := exp10 * 10.0;
INC(i)
ELSE
error := 4
END
END;
IF ~opFloat2(value, frac / exp10, "+") THEN
error := 4
END;
IF (s[i] = "E") OR (s[i] = "e") THEN
INC(i)
END;
IF (s[i] = "-") OR (s[i] = "+") THEN
minus := s[i] = "-";
INC(i)
END;
WHILE (error = 0) & STRINGS.digit(s[i]) DO
d := digit[ORD(s[i])];
IF n <= (UTILS.maxint - d) DIV 10 THEN
n := n * 10 + d;
INC(i)
ELSE
error := 5
END
END;
exp10 := 1.0;
WHILE (error = 0) & (n > 0) DO
IF opFloat2(exp10, 10.0, "*") THEN
DEC(n)
ELSE
error := 4
END
END;
IF error = 0 THEN
IF minus THEN
IF ~opFloat2(value, exp10, "/") THEN
error := 4
END
ELSE
IF ~opFloat2(value, exp10, "*") THEN
error := 4
END
END
END;
IF error = 0 THEN
v.float := value;
v.typ := tREAL;
IF ~check(v) THEN
error := 4
END
END
END fconv;
PROCEDURE setChar* (VAR v: VALUE; ord: INTEGER);
BEGIN
v.typ := tCHAR;
v.int := ord
END setChar;
PROCEDURE setWChar* (VAR v: VALUE; ord: INTEGER);
BEGIN
v.typ := tWCHAR;
v.int := ord
END setWChar;
PROCEDURE addInt (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
error: BOOLEAN;
BEGIN
IF (a > 0) & (b > 0) THEN
error := a > UTILS.maxint - b
ELSIF (a < 0) & (b < 0) THEN
error := a < UTILS.minint - b
ELSE
error := FALSE
END;
IF ~error THEN
a := a + b
ELSE
a := 0
END
RETURN ~error
END addInt;
PROCEDURE subInt (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
error: BOOLEAN;
BEGIN
IF (a > 0) & (b < 0) THEN
error := a > UTILS.maxint + b
ELSIF (a < 0) & (b > 0) THEN
error := a < UTILS.minint + b
ELSIF (a = 0) & (b < 0) THEN
error := b = UTILS.minint
ELSE
error := FALSE
END;
IF ~error THEN
a := a - b
ELSE
a := 0
END
RETURN ~error
END subInt;
PROCEDURE lg2 (x: INTEGER): INTEGER;
VAR
n: INTEGER;
BEGIN
ASSERT(x > 0);
n := UTILS.Log2(x);
IF n = -1 THEN
n := 255
END
RETURN n
END lg2;
PROCEDURE mulInt* (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
error: BOOLEAN;
min, max: INTEGER;
BEGIN
min := UTILS.minint;
max := UTILS.maxint;
IF ((a > 1) & (b > 1)) OR ((a < 0) & (b < 0)) THEN
error := (a = min) OR (b = min) OR (ABS(a) > max DIV ABS(b))
ELSIF ((a > 1) & (b < 0)) OR ((a < 0) & (b > 1)) THEN
error := (a = min) OR (b = min);
IF ~error THEN
IF lg2(ABS(a)) + lg2(ABS(b)) >= UTILS.bit_depth THEN
error := ABS(a) > max DIV ABS(b)
END
END
ELSE
error := FALSE
END;
IF ~error THEN
a := a * b
ELSE
a := 0
END
RETURN ~error
END mulInt;
PROCEDURE _ASR (x, n: INTEGER): INTEGER;
RETURN ASR(UTILS.Long(x), n)
END _ASR;
PROCEDURE _LSR (x, n: INTEGER): INTEGER;
RETURN UTILS.Long(LSR(UTILS.Short(x), n))
END _LSR;
PROCEDURE _LSL (x, n: INTEGER): INTEGER;
RETURN UTILS.Long(LSL(x, n))
END _LSL;
PROCEDURE _ROR1_32 (x: INTEGER): INTEGER;
BEGIN
x := UTILS.Short(x);
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 31)))
RETURN UTILS.Long(x)
END _ROR1_32;
PROCEDURE _ROR1_16 (x: INTEGER): INTEGER;
BEGIN
x := x MOD 65536;
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 15)))
RETURN UTILS.Long(x)
END _ROR1_16;
PROCEDURE _ROR (x, n: INTEGER): INTEGER;
BEGIN
CASE UTILS.bit_diff OF
|0: x := ROR(x, n)
|16, 48:
n := n MOD 16;
WHILE n > 0 DO
x := _ROR1_16(x);
DEC(n)
END
|32:
n := n MOD 32;
WHILE n > 0 DO
x := _ROR1_32(x);
DEC(n)
END
END
RETURN x
END _ROR;
PROCEDURE opInt* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN;
VAR
success: BOOLEAN;
BEGIN
success := TRUE;
CASE op OF
|"+": success := addInt(a.int, b.int)
|"-": success := subInt(a.int, b.int)
|"*": success := mulInt(a.int, b.int)
|"/": success := FALSE
|"D": a.int := a.int DIV b.int
|"M": a.int := a.int MOD b.int
|"L": a.int := _LSL(a.int, b.int)
|"A": a.int := _ASR(a.int, b.int)
|"O": a.int := _ROR(a.int, b.int)
|"R": a.int := _LSR(a.int, b.int)
|"m": a.int := MIN(a.int, b.int)
|"x": a.int := MAX(a.int, b.int)
END;
a.typ := tINTEGER
RETURN success & check(a)
END opInt;
PROCEDURE charToStr* (c: VALUE; VAR s: ARRAY OF CHAR);
BEGIN
s[0] := CHR(c.int);
s[1] := 0X
END charToStr;
PROCEDURE opSet* (VAR a: VALUE; b: VALUE; op: CHAR);
BEGIN
CASE op OF
|"+": a.set := a.set + b.set
|"-": a.set := a.set - b.set
|"*": a.set := a.set * b.set
|"/": a.set := a.set / b.set
END;
a.typ := tSET
END opSet;
PROCEDURE opFloat* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN;
BEGIN
a.typ := tREAL
RETURN opFloat2(a.float, b.float, op) & check(a)
END opFloat;
PROCEDURE ord* (VAR v: VALUE);
BEGIN
CASE v.typ OF
|tCHAR, tWCHAR:
|tBOOLEAN: v.int := ORD(v.bool)
|tSET: v.int := UTILS.Long(ORD(v.set))
END;
v.typ := tINTEGER
END ord;
PROCEDURE odd* (VAR v: VALUE);
BEGIN
v.typ := tBOOLEAN;
v.bool := ODD(v.int)
END odd;
PROCEDURE bits* (VAR v: VALUE);
BEGIN
v.typ := tSET;
v.set := BITS(v.int)
END bits;
PROCEDURE abs* (VAR v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := FALSE;
CASE v.typ OF
|tREAL:
v.float := ABS(v.float);
res := TRUE
|tINTEGER:
IF v.int # UTILS.minint THEN
v.int := ABS(v.int);
res := TRUE
END
END
RETURN res
END abs;
PROCEDURE floor* (VAR v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
v.typ := tINTEGER;
res := (FLT(UTILS.minint) <= v.float) & (v.float <= FLT(UTILS.maxint));
IF res THEN
v.int := FLOOR(v.float)
END
RETURN res
END floor;
PROCEDURE flt* (VAR v: VALUE);
BEGIN
v.typ := tREAL;
v.float := FLT(v.int)
END flt;
PROCEDURE neg* (VAR v: VALUE): BOOLEAN;
VAR
z: VALUE;
res: BOOLEAN;
BEGIN
res := TRUE;
z.typ := tINTEGER;
z.int := 0;
CASE v.typ OF
|tREAL: v.float := -v.float
|tSET: v.set := -v.set
|tINTEGER: res := opInt(z, v, "-"); v := z
|tBOOLEAN: v.bool := ~v.bool
END
RETURN res
END neg;
PROCEDURE setbool* (VAR v: VALUE; b: BOOLEAN);
BEGIN
v.bool := b;
v.typ := tBOOLEAN
END setbool;
PROCEDURE opBoolean* (VAR a: VALUE; b: VALUE; op: CHAR);
BEGIN
CASE op OF
|"&": a.bool := a.bool & b.bool
|"|": a.bool := a.bool OR b.bool
END;
a.typ := tBOOLEAN
END opBoolean;
PROCEDURE less (v, v2: VALUE; VAR error: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := FALSE;
IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN
CASE v.typ OF
|tINTEGER,
tWCHAR,
tCHAR: res := v.int < v2.int
|tREAL: res := v.float < v2.float
|tBOOLEAN,
tSET: error := 1
END
ELSE
error := 1
END
RETURN res
END less;
PROCEDURE equal (v, v2: VALUE; VAR error: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := FALSE;
IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN
CASE v.typ OF
|tINTEGER,
tWCHAR,
tCHAR: res := v.int = v2.int
|tREAL: res := v.float = v2.float
|tBOOLEAN: res := v.bool = v2.bool
|tSET: res := v.set = v2.set
END
ELSE
error := 1
END
RETURN res
END equal;
PROCEDURE relation* (VAR v: VALUE; v2: VALUE; op: INTEGER; VAR error: INTEGER);
VAR
res: BOOLEAN;
BEGIN
error := 0;
res := FALSE;
CASE op OF
|opEQ:
res := equal(v, v2, error)
|opNE:
res := ~equal(v, v2, error)
|opLT:
res := less(v, v2, error)
|opLE:
res := less(v, v2, error);
IF error = 0 THEN
res := equal(v, v2, error) OR res
END
|opGE:
res := ~less(v, v2, error)
|opGT:
res := less(v, v2, error);
IF error = 0 THEN
res := equal(v, v2, error) OR res
END;
res := ~res
|opIN:
IF (v.typ = tINTEGER) & (v2.typ = tSET) THEN
IF range(v, 0, UTILS.target.maxSet) THEN
res := v.int IN v2.set
ELSE
error := 2
END
ELSE
error := 1
END
END;
IF error = 0 THEN
v.bool := res;
v.typ := tBOOLEAN
END
END relation;
PROCEDURE emptySet* (VAR v: VALUE);
BEGIN
v.typ := tSET;
v.set := {}
END emptySet;
PROCEDURE constrSet* (VAR v: VALUE; a, b: VALUE);
BEGIN
v.typ := tSET;
v.set := {a.int .. b.int}
END constrSet;
PROCEDURE getInt* (v: VALUE): INTEGER;
BEGIN
ASSERT(check(v))
RETURN v.int
END getInt;
PROCEDURE setInt* (VAR v: VALUE; i: INTEGER): BOOLEAN;
BEGIN
v.int := i;
v.typ := tINTEGER
RETURN check(v)
END setInt;
PROCEDURE concat* (VAR s: ARRAY OF CHAR; s1: ARRAY OF CHAR): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := LENGTH(s) + LENGTH(s1) < LEN(s);
IF res THEN
STRINGS.append(s, s1)
END
RETURN res
END concat;
PROCEDURE init;
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO LEN(digit) - 1 DO
digit[i] := -1
END;
FOR i := ORD("0") TO ORD("9") DO
digit[i] := i - ORD("0")
END;
FOR i := ORD("A") TO ORD("F") DO
digit[i] := i - ORD("A") + 10
END
END init;
BEGIN
init
END ARITH.

/programs/develop/oberon07/source/CHUNKLISTS.ob07
0,0 → 1,255
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE CHUNKLISTS;
IMPORT LISTS, WR := WRITER;
CONST
LENOFBYTECHUNK = 65536;
LENOFINTCHUNK = 16384;
TYPE
ANYLIST = POINTER TO RECORD (LISTS.LIST)
length: INTEGER
END;
BYTELIST* = POINTER TO RECORD (ANYLIST) END;
BYTECHUNK = POINTER TO RECORD (LISTS.ITEM)
data: ARRAY LENOFBYTECHUNK OF BYTE;
count: INTEGER
END;
INTLIST* = POINTER TO RECORD (ANYLIST) END;
INTCHUNK = POINTER TO RECORD (LISTS.ITEM)
data: ARRAY LENOFINTCHUNK OF INTEGER;
count: INTEGER
END;
PROCEDURE SetByte* (list: BYTELIST; idx: INTEGER; byte: BYTE);
VAR
chunk: BYTECHUNK;
item: LISTS.ITEM;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
item := LISTS.getidx(list, idx DIV LENOFBYTECHUNK);
ASSERT(item # NIL);
chunk := item(BYTECHUNK);
idx := idx MOD LENOFBYTECHUNK;
ASSERT(idx < chunk.count);
chunk.data[idx] := byte
END SetByte;
PROCEDURE GetByte* (list: BYTELIST; idx: INTEGER): BYTE;
VAR
chunk: BYTECHUNK;
item: LISTS.ITEM;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
item := LISTS.getidx(list, idx DIV LENOFBYTECHUNK);
ASSERT(item # NIL);
chunk := item(BYTECHUNK);
idx := idx MOD LENOFBYTECHUNK;
ASSERT(idx < chunk.count)
RETURN chunk.data[idx]
END GetByte;
PROCEDURE PushByte* (list: BYTELIST; byte: BYTE);
VAR
chunk: BYTECHUNK;
BEGIN
ASSERT(list # NIL);
chunk := list.last(BYTECHUNK);
IF chunk.count = LENOFBYTECHUNK THEN
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
END;
chunk.data[chunk.count] := byte;
INC(chunk.count);
INC(list.length)
END PushByte;
PROCEDURE PushStr* (list: BYTELIST; str: ARRAY OF CHAR): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := list.length;
i := 0;
REPEAT
PushByte(list, ORD(str[i]));
INC(i)
UNTIL str[i - 1] = 0X
RETURN res
END PushStr;
PROCEDURE GetStr* (list: BYTELIST; pos: INTEGER; VAR str: ARRAY OF CHAR): BOOLEAN;
VAR
i: INTEGER;
res: BOOLEAN;
BEGIN
res := FALSE;
i := 0;
WHILE (pos < list.length) & (i < LEN(str)) & ~res DO
str[i] := CHR(GetByte(list, pos));
res := str[i] = 0X;
INC(pos);
INC(i)
END
RETURN res
END GetStr;
PROCEDURE WriteToFile* (list: BYTELIST);
VAR
chunk: BYTECHUNK;
BEGIN
chunk := list.first(BYTECHUNK);
WHILE chunk # NIL DO
WR.Write(chunk.data, chunk.count);
chunk := chunk.next(BYTECHUNK)
END
END WriteToFile;
PROCEDURE CreateByteList* (): BYTELIST;
VAR
bytelist: BYTELIST;
list: LISTS.LIST;
chunk: BYTECHUNK;
BEGIN
NEW(bytelist);
list := LISTS.create(bytelist);
bytelist.length := 0;
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
RETURN list(BYTELIST)
END CreateByteList;
PROCEDURE SetInt* (list: INTLIST; idx: INTEGER; int: INTEGER);
VAR
chunk: INTCHUNK;
item: LISTS.ITEM;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
item := LISTS.getidx(list, idx DIV LENOFINTCHUNK);
ASSERT(item # NIL);
chunk := item(INTCHUNK);
idx := idx MOD LENOFINTCHUNK;
ASSERT(idx < chunk.count);
chunk.data[idx] := int
END SetInt;
PROCEDURE GetInt* (list: INTLIST; idx: INTEGER): INTEGER;
VAR
chunk: INTCHUNK;
item: LISTS.ITEM;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
item := LISTS.getidx(list, idx DIV LENOFINTCHUNK);
ASSERT(item # NIL);
chunk := item(INTCHUNK);
idx := idx MOD LENOFINTCHUNK;
ASSERT(idx < chunk.count)
RETURN chunk.data[idx]
END GetInt;
PROCEDURE PushInt* (list: INTLIST; int: INTEGER);
VAR
chunk: INTCHUNK;
BEGIN
ASSERT(list # NIL);
chunk := list.last(INTCHUNK);
IF chunk.count = LENOFINTCHUNK THEN
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
END;
chunk.data[chunk.count] := int;
INC(chunk.count);
INC(list.length)
END PushInt;
PROCEDURE CreateIntList* (): INTLIST;
VAR
intlist: INTLIST;
list: LISTS.LIST;
chunk: INTCHUNK;
BEGIN
NEW(intlist);
list := LISTS.create(intlist);
intlist.length := 0;
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
RETURN list(INTLIST)
END CreateIntList;
PROCEDURE Length* (list: ANYLIST): INTEGER;
RETURN list.length
END Length;
END CHUNKLISTS.

/programs/develop/oberon07/source/CONSOLE.ob07
0,0 → 1,78
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE CONSOLE;
IMPORT UTILS, STRINGS;
PROCEDURE String* (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
UTILS.OutChar(s[i]);
INC(i)
END
END String;
PROCEDURE Int* (x: INTEGER);
VAR
s: ARRAY 24 OF CHAR;
BEGIN
STRINGS.IntToStr(x, s);
String(s)
END Int;
PROCEDURE Int2* (x: INTEGER);
BEGIN
IF x < 10 THEN
String("0")
END;
Int(x)
END Int2;
PROCEDURE Ln*;
BEGIN
String(UTILS.eol)
END Ln;
PROCEDURE StringLn* (s: ARRAY OF CHAR);
BEGIN
String(s);
Ln
END StringLn;
PROCEDURE IntLn* (x: INTEGER);
BEGIN
Int(x);
Ln
END IntLn;
PROCEDURE Int2Ln* (x: INTEGER);
BEGIN
Int2(x);
Ln
END Int2Ln;
PROCEDURE Dashes*;
BEGIN
StringLn("------------------------------------------------")
END Dashes;
END CONSOLE.

/programs/develop/oberon07/source/Compiler.ob07
0,0 → 1,333
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE Compiler;
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, PROG, C := CONSOLE,
ERRORS, STRINGS, WRITER, MSP430, THUMB, TARGETS, SCAN;
CONST
DEF_WINDOWS = "WINDOWS";
DEF_LINUX = "LINUX";
DEF_KOLIBRIOS = "KOLIBRIOS";
DEF_CPU_X86 = "CPU_X86";
DEF_CPU_X8664 = "CPU_X8664";
PROCEDURE keys (VAR options: PROG.OPTIONS; VAR out: PARS.PATH);
VAR
param: PARS.PATH;
i, j: INTEGER;
_end: BOOLEAN;
value: INTEGER;
minor,
major: INTEGER;
checking: SET;
BEGIN
out := "";
checking := options.checking;
_end := FALSE;
i := 3;
REPEAT
UTILS.GetArg(i, param);
IF param = "-stk" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) & (1 <= value) & (value <= 32) THEN
options.stack := value
END;
IF param[0] = "-" THEN
DEC(i)
END
ELSIF param = "-out" THEN
INC(i);
UTILS.GetArg(i, param);
IF param[0] = "-" THEN
DEC(i)
ELSE
out := param
END
ELSIF param = "-ram" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) THEN
options.ram := value
END;
IF param[0] = "-" THEN
DEC(i)
END
ELSIF param = "-rom" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) THEN
options.rom := value
END;
IF param[0] = "-" THEN
DEC(i)
END
ELSIF param = "-nochk" THEN
INC(i);
UTILS.GetArg(i, param);
IF param[0] = "-" THEN
DEC(i)
ELSE
j := 0;
WHILE param[j] # 0X DO
IF param[j] = "p" THEN
EXCL(checking, ST.chkPTR)
ELSIF param[j] = "t" THEN
EXCL(checking, ST.chkGUARD)
ELSIF param[j] = "i" THEN
EXCL(checking, ST.chkIDX)
ELSIF param[j] = "b" THEN
EXCL(checking, ST.chkBYTE)
ELSIF param[j] = "c" THEN
EXCL(checking, ST.chkCHR)
ELSIF param[j] = "w" THEN
EXCL(checking, ST.chkWCHR)
ELSIF param[j] = "r" THEN
EXCL(checking, ST.chkCHR);
EXCL(checking, ST.chkWCHR);
EXCL(checking, ST.chkBYTE)
ELSIF param[j] = "s" THEN
EXCL(checking, ST.chkSTK)
ELSIF param[j] = "a" THEN
checking := {}
END;
INC(j)
END;
END
ELSIF param = "-ver" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToVer(param, major, minor) THEN
options.version := major * 65536 + minor
END;
IF param[0] = "-" THEN
DEC(i)
END
ELSIF param = "-lower" THEN
options.lower := TRUE
ELSIF param = "-pic" THEN
options.pic := TRUE
ELSIF param = "-def" THEN
INC(i);
UTILS.GetArg(i, param);
SCAN.NewDef(param)
ELSIF param = "" THEN
_end := TRUE
ELSE
ERRORS.BadParam(param)
END;
INC(i)
UNTIL _end;
options.checking := checking
END keys;
PROCEDURE OutTargetItem (target: INTEGER; text: ARRAY OF CHAR);
VAR
width: INTEGER;
BEGIN
width := 15;
width := width - LENGTH(TARGETS.Targets[target].ComLinePar) - 4;
C.String(" '"); C.String(TARGETS.Targets[target].ComLinePar); C.String("'");
WHILE width > 0 DO
C.String(20X);
DEC(width)
END;
C.StringLn(text)
END OutTargetItem;
PROCEDURE main;
VAR
path: PARS.PATH;
inname: PARS.PATH;
ext: PARS.PATH;
app_path: PARS.PATH;
lib_path: PARS.PATH;
modname: PARS.PATH;
outname: PARS.PATH;
param: PARS.PATH;
temp: PARS.PATH;
target: INTEGER;
time: INTEGER;
options: PROG.OPTIONS;
BEGIN
options.stack := 2;
options.version := 65536;
options.pic := FALSE;
options.lower := FALSE;
options.checking := ST.chkALL;
PATHS.GetCurrentDirectory(app_path);
UTILS.GetArg(0, temp);
PATHS.split(temp, path, modname, ext);
IF PATHS.isRelative(path) THEN
PATHS.RelPath(app_path, path, temp);
path := temp
END;
lib_path := path;
UTILS.GetArg(1, inname);
STRINGS.replace(inname, "\", UTILS.slash);
STRINGS.replace(inname, "/", UTILS.slash);
C.Ln;
C.String("Akron Oberon Compiler v"); C.Int(UTILS.vMajor); C.String("."); C.Int2(UTILS.vMinor);
C.String(" ("); C.Int(UTILS.bit_depth); C.StringLn("-bit) " + UTILS.Date);
C.StringLn("Copyright (c) 2018-2021, Anton Krotov");
IF inname = "" THEN
C.Ln;
C.StringLn("Usage: Compiler <main module> <target> [optional settings]"); C.Ln;
C.StringLn("target =");
IF UTILS.bit_depth = 64 THEN
OutTargetItem(TARGETS.Win64C, "Windows64 Console");
OutTargetItem(TARGETS.Win64GUI, "Windows64 GUI");
OutTargetItem(TARGETS.Win64DLL, "Windows64 DLL");
OutTargetItem(TARGETS.Linux64, "Linux64 Exec");
OutTargetItem(TARGETS.Linux64SO, "Linux64 SO")
END;
OutTargetItem(TARGETS.Win32C, "Windows32 Console");
OutTargetItem(TARGETS.Win32GUI, "Windows32 GUI");
OutTargetItem(TARGETS.Win32DLL, "Windows32 DLL");
OutTargetItem(TARGETS.Linux32, "Linux32 Exec");
OutTargetItem(TARGETS.Linux32SO, "Linux32 SO");
OutTargetItem(TARGETS.KolibriOS, "KolibriOS Exec");
OutTargetItem(TARGETS.KolibriOSDLL, "KolibriOS DLL");
OutTargetItem(TARGETS.MSP430, "MSP430x{1,2}xx microcontrollers");
OutTargetItem(TARGETS.STM32CM3, "STM32 Cortex-M3 microcontrollers");
C.Ln;
C.StringLn("optional settings:"); C.Ln;
C.StringLn(" -out <file name> output"); C.Ln;
C.StringLn(" -stk <size> set size of stack in Mbytes (Windows, Linux, KolibriOS)"); C.Ln;
C.StringLn(" -nochk <'ptibcwra'> disable runtime checking (pointers, types, indexes,");
C.StringLn(" BYTE, CHR, WCHR)"); C.Ln;
C.StringLn(" -lower allow lower case for keywords"); C.Ln;
C.StringLn(" -def <identifier> define conditional compilation symbol"); C.Ln;
C.StringLn(" -ver <major.minor> set version of program (KolibriOS DLL)"); C.Ln;
C.StringLn(" -ram <size> set size of RAM in bytes (MSP430) or Kbytes (STM32)"); C.Ln;
C.StringLn(" -rom <size> set size of ROM in bytes (MSP430) or Kbytes (STM32)"); C.Ln;
UTILS.Exit(0)
END;
C.Dashes;
PATHS.split(inname, path, modname, ext);
IF ext # UTILS.FILE_EXT THEN
ERRORS.Error(207)
END;
IF PATHS.isRelative(path) THEN
PATHS.RelPath(app_path, path, temp);
path := temp
END;
UTILS.GetArg(2, param);
IF param = "" THEN
ERRORS.Error(205)
END;
SCAN.NewDef(param);
IF TARGETS.Select(param) THEN
target := TARGETS.target
ELSE
ERRORS.Error(206)
END;
IF TARGETS.CPU = TARGETS.cpuMSP430 THEN
options.ram := MSP430.minRAM;
options.rom := MSP430.minROM
END;
IF (TARGETS.CPU = TARGETS.cpuTHUMB) & (TARGETS.OS = TARGETS.osNONE) THEN
options.ram := THUMB.minRAM;
options.rom := THUMB.minROM
END;
IF UTILS.bit_depth < TARGETS.BitDepth THEN
ERRORS.Error(206)
END;
STRINGS.append(lib_path, "lib");
STRINGS.append(lib_path, UTILS.slash);
STRINGS.append(lib_path, TARGETS.LibDir);
STRINGS.append(lib_path, UTILS.slash);
keys(options, outname);
IF outname = "" THEN
outname := path;
STRINGS.append(outname, modname);
STRINGS.append(outname, TARGETS.FileExt)
ELSE
IF PATHS.isRelative(outname) THEN
PATHS.RelPath(app_path, outname, temp);
outname := temp
END
END;
PARS.init(options);
CASE TARGETS.OS OF
|TARGETS.osNONE:
|TARGETS.osWIN32,
TARGETS.osWIN64: SCAN.NewDef(DEF_WINDOWS)
|TARGETS.osLINUX32,
TARGETS.osLINUX64: SCAN.NewDef(DEF_LINUX)
|TARGETS.osKOS: SCAN.NewDef(DEF_KOLIBRIOS)
END;
CASE TARGETS.CPU OF
|TARGETS.cpuX86: SCAN.NewDef(DEF_CPU_X86)
|TARGETS.cpuAMD64: SCAN.NewDef(DEF_CPU_X8664)
|TARGETS.cpuMSP430:
|TARGETS.cpuTHUMB:
|TARGETS.cpuRVM32I:
|TARGETS.cpuRVM64I:
END;
ST.compile(path, lib_path, modname, outname, target, options);
time := UTILS.GetTickCount() - UTILS.time;
C.Dashes;
C.Int(PARS.lines); C.String(" lines, ");
C.Int(time DIV 100); C.String("."); C.Int2(time MOD 100); C.String(" sec, ");
C.Int(WRITER.counter); C.StringLn(" bytes");
UTILS.Exit(0)
END main;
BEGIN
main
END Compiler.

/programs/develop/oberon07/source/ELF.ob07
0,0 → 1,592
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
All rights reserved.
*)
MODULE ELF;
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS, PE32, UTILS, STRINGS;
CONST
EI_NIDENT = 16;
ET_EXEC = 2;
ET_DYN = 3;
EM_386 = 3;
EM_8664 = 3EH;
ELFCLASS32 = 1;
ELFCLASS64 = 2;
ELFDATA2LSB = 1;
ELFDATA2MSB = 2;
PF_X = 1;
PF_W = 2;
PF_R = 4;
TYPE
Elf32_Ehdr = RECORD
e_ident: ARRAY EI_NIDENT OF BYTE;
e_type,
e_machine: WCHAR;
e_version,
e_entry,
e_phoff,
e_shoff,
e_flags: INTEGER;
e_ehsize,
e_phentsize,
e_phnum,
e_shentsize,
e_shnum,
e_shstrndx: WCHAR
END;
Elf32_Phdr = RECORD
p_type,
p_offset,
p_vaddr,
p_paddr,
p_filesz,
p_memsz,
p_flags,
p_align: INTEGER
END;
Elf32_Dyn = POINTER TO RECORD (LISTS.ITEM)
d_tag, d_val: INTEGER
END;
Elf32_Sym = POINTER TO RECORD (LISTS.ITEM)
name, value, size: INTEGER;
info, other: CHAR;
shndx: WCHAR
END;
VAR
dynamic: LISTS.LIST;
strtab: CHL.BYTELIST;
symtab: LISTS.LIST;
hashtab, bucket, chain: CHL.INTLIST;
PROCEDURE Write16 (w: WCHAR);
BEGIN
WR.Write16LE(ORD(w))
END Write16;
PROCEDURE WritePH (ph: Elf32_Phdr);
BEGIN
WR.Write32LE(ph.p_type);
WR.Write32LE(ph.p_offset);
WR.Write32LE(ph.p_vaddr);
WR.Write32LE(ph.p_paddr);
WR.Write32LE(ph.p_filesz);
WR.Write32LE(ph.p_memsz);
WR.Write32LE(ph.p_flags);
WR.Write32LE(ph.p_align)
END WritePH;
PROCEDURE WritePH64 (ph: Elf32_Phdr);
BEGIN
WR.Write32LE(ph.p_type);
WR.Write32LE(ph.p_flags);
WR.Write64LE(ph.p_offset);
WR.Write64LE(ph.p_vaddr);
WR.Write64LE(ph.p_paddr);
WR.Write64LE(ph.p_filesz);
WR.Write64LE(ph.p_memsz);
WR.Write64LE(ph.p_align)
END WritePH64;
PROCEDURE NewDyn (tag, val: INTEGER);
VAR
dyn: Elf32_Dyn;
BEGIN
NEW(dyn);
dyn.d_tag := tag;
dyn.d_val := val;
LISTS.push(dynamic, dyn)
END NewDyn;
PROCEDURE NewSym (name, value, size: INTEGER; info, other: CHAR; shndx: WCHAR);
VAR
sym: Elf32_Sym;
BEGIN
NEW(sym);
sym.name := name;
sym.value := value;
sym.size := size;
sym.info := info;
sym.other := other;
sym.shndx := shndx;
LISTS.push(symtab, sym)
END NewSym;
PROCEDURE MakeHash (bucket, chain: CHL.INTLIST; symCount: INTEGER);
VAR
symi, hi, k: INTEGER;
BEGIN
FOR symi := 0 TO symCount - 1 DO
CHL.SetInt(chain, symi, 0);
hi := CHL.GetInt(hashtab, symi) MOD symCount;
IF CHL.GetInt(bucket, hi) # 0 THEN
k := symi;
WHILE CHL.GetInt(chain, k) # 0 DO
k := CHL.GetInt(chain, k)
END;
CHL.SetInt(chain, k, CHL.GetInt(bucket, hi))
END;
CHL.SetInt(bucket, hi, symi)
END
END MakeHash;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; fini: INTEGER; so, amd64: BOOLEAN);
CONST
interp = 0;
dyn = 1;
header = 2;
text = 3;
data = 4;
bss = 5;
linuxInterpreter64 = "/lib64/ld-linux-x86-64.so.2";
linuxInterpreter32 = "/lib/ld-linux.so.2";
exeBaseAddress32 = 8048000H;
exeBaseAddress64 = 400000H;
dllBaseAddress = 0;
DT_NULL = 0;
DT_NEEDED = 1;
DT_HASH = 4;
DT_STRTAB = 5;
DT_SYMTAB = 6;
DT_RELA = 7;
DT_RELASZ = 8;
DT_RELAENT = 9;
DT_STRSZ = 10;
DT_SYMENT = 11;
DT_INIT = 12;
DT_FINI = 13;
DT_SONAME = 14;
DT_REL = 17;
DT_RELSZ = 18;
DT_RELENT = 19;
VAR
ehdr: Elf32_Ehdr;
phdr: ARRAY 16 OF Elf32_Phdr;
i, BaseAdr, DynAdr, offset, pad, VA, symCount: INTEGER;
SizeOf: RECORD header, code, data, bss: INTEGER END;
Offset: RECORD symtab, reltab, hash, strtab: INTEGER END;
Interpreter: ARRAY 40 OF CHAR; lenInterpreter: INTEGER;
item: LISTS.ITEM;
Name: ARRAY 2048 OF CHAR;
Address: PE32.VIRTUAL_ADDR;
BEGIN
dynamic := LISTS.create(NIL);
symtab := LISTS.create(NIL);
strtab := CHL.CreateByteList();
IF amd64 THEN
BaseAdr := exeBaseAddress64;
Interpreter := linuxInterpreter64
ELSE
BaseAdr := exeBaseAddress32;
Interpreter := linuxInterpreter32
END;
IF so THEN
BaseAdr := dllBaseAddress
END;
lenInterpreter := LENGTH(Interpreter) + 1;
SizeOf.code := CHL.Length(program.code);
SizeOf.data := CHL.Length(program.data);
SizeOf.bss := program.bss;
ehdr.e_ident[0] := 7FH;
ehdr.e_ident[1] := ORD("E");
ehdr.e_ident[2] := ORD("L");
ehdr.e_ident[3] := ORD("F");
IF amd64 THEN
ehdr.e_ident[4] := ELFCLASS64
ELSE
ehdr.e_ident[4] := ELFCLASS32
END;
ehdr.e_ident[5] := ELFDATA2LSB;
ehdr.e_ident[6] := 1;
ehdr.e_ident[7] := 3;
FOR i := 8 TO EI_NIDENT - 1 DO
ehdr.e_ident[i] := 0
END;
IF so THEN
ehdr.e_type := WCHR(ET_DYN)
ELSE
ehdr.e_type := WCHR(ET_EXEC)
END;
ehdr.e_version := 1;
ehdr.e_shoff := 0;
ehdr.e_flags := 0;
ehdr.e_shnum := WCHR(0);
ehdr.e_shstrndx := WCHR(0);
ehdr.e_phnum := WCHR(6);
IF amd64 THEN
ehdr.e_machine := WCHR(EM_8664);
ehdr.e_phoff := 40H;
ehdr.e_ehsize := WCHR(40H);
ehdr.e_phentsize := WCHR(38H);
ehdr.e_shentsize := WCHR(40H)
ELSE
ehdr.e_machine := WCHR(EM_386);
ehdr.e_phoff := 34H;
ehdr.e_ehsize := WCHR(34H);
ehdr.e_phentsize := WCHR(20H);
ehdr.e_shentsize := WCHR(28H)
END;
SizeOf.header := ORD(ehdr.e_ehsize) + ORD(ehdr.e_phentsize) * ORD(ehdr.e_phnum);
phdr[interp].p_type := 3;
phdr[interp].p_offset := SizeOf.header;
phdr[interp].p_vaddr := BaseAdr + phdr[interp].p_offset;
phdr[interp].p_paddr := phdr[interp].p_vaddr;
phdr[interp].p_filesz := lenInterpreter;
phdr[interp].p_memsz := lenInterpreter;
phdr[interp].p_flags := PF_R;
phdr[interp].p_align := 1;
phdr[dyn].p_type := 2;
phdr[dyn].p_offset := phdr[interp].p_offset + phdr[interp].p_filesz;
phdr[dyn].p_vaddr := BaseAdr + phdr[dyn].p_offset;
phdr[dyn].p_paddr := phdr[dyn].p_vaddr;
hashtab := CHL.CreateIntList();
CHL.PushInt(hashtab, STRINGS.HashStr(""));
NewSym(CHL.PushStr(strtab, ""), 0, 0, 0X, 0X, 0X);
CHL.PushInt(hashtab, STRINGS.HashStr("dlopen"));
NewSym(CHL.PushStr(strtab, "dlopen"), 0, 0, 12X, 0X, 0X);
CHL.PushInt(hashtab, STRINGS.HashStr("dlsym"));
NewSym(CHL.PushStr(strtab, "dlsym"), 0, 0, 12X, 0X, 0X);
IF so THEN
item := program.exp_list.first;
WHILE item # NIL DO
ASSERT(CHL.GetStr(program.export, item(BIN.EXPRT).nameoffs, Name));
CHL.PushInt(hashtab, STRINGS.HashStr(Name));
NewSym(CHL.PushStr(strtab, Name), item(BIN.EXPRT).label, 0, 12X, 0X, 0X);
item := item.next
END;
ASSERT(CHL.GetStr(program.data, program.modname, Name))
END;
symCount := LISTS.count(symtab);
bucket := CHL.CreateIntList();
chain := CHL.CreateIntList();
FOR i := 1 TO symCount DO
CHL.PushInt(bucket, 0);
CHL.PushInt(chain, 0)
END;
MakeHash(bucket, chain, symCount);
NewDyn(DT_NEEDED, CHL.PushStr(strtab, "libdl.so.2"));
NewDyn(DT_STRTAB, 0);
NewDyn(DT_STRSZ, CHL.Length(strtab));
NewDyn(DT_SYMTAB, 0);
IF amd64 THEN
NewDyn(DT_SYMENT, 24);
NewDyn(DT_RELA, 0);
NewDyn(DT_RELASZ, 48);
NewDyn(DT_RELAENT, 24)
ELSE
NewDyn(DT_SYMENT, 16);
NewDyn(DT_REL, 0);
NewDyn(DT_RELSZ, 16);
NewDyn(DT_RELENT, 8)
END;
NewDyn(DT_HASH, 0);
IF so THEN
NewDyn(DT_SONAME, CHL.PushStr(strtab, Name));
NewDyn(DT_INIT, 0);
NewDyn(DT_FINI, 0)
END;
NewDyn(DT_NULL, 0);
Offset.symtab := LISTS.count(dynamic) * (8 + 8 * ORD(amd64));
Offset.reltab := Offset.symtab + symCount * (16 + 8 * ORD(amd64));
Offset.hash := Offset.reltab + (8 + 16 * ORD(amd64)) * 2;
Offset.strtab := Offset.hash + (symCount * 2 + 2) * 4;
DynAdr := phdr[dyn].p_offset + BaseAdr;
item := LISTS.getidx(dynamic, 1); item(Elf32_Dyn).d_val := Offset.strtab + DynAdr;
item := LISTS.getidx(dynamic, 3); item(Elf32_Dyn).d_val := Offset.symtab + DynAdr;
item := LISTS.getidx(dynamic, 5); item(Elf32_Dyn).d_val := Offset.reltab + DynAdr;
item := LISTS.getidx(dynamic, 8); item(Elf32_Dyn).d_val := Offset.hash + DynAdr;
phdr[dyn].p_filesz := Offset.strtab + CHL.Length(strtab) + 8 + 8 * ORD(amd64);
phdr[dyn].p_memsz := phdr[dyn].p_filesz;
phdr[dyn].p_flags := PF_R;
phdr[dyn].p_align := 1;
offset := 0;
phdr[header].p_type := 1;
phdr[header].p_offset := offset;
phdr[header].p_vaddr := BaseAdr;
phdr[header].p_paddr := BaseAdr;
phdr[header].p_filesz := SizeOf.header + lenInterpreter + phdr[dyn].p_filesz;
phdr[header].p_memsz := phdr[header].p_filesz;
phdr[header].p_flags := PF_R + PF_W;
phdr[header].p_align := 1000H;
INC(offset, phdr[header].p_filesz);
VA := BaseAdr + offset + 1000H;
phdr[text].p_type := 1;
phdr[text].p_offset := offset;
phdr[text].p_vaddr := VA;
phdr[text].p_paddr := VA;
phdr[text].p_filesz := SizeOf.code;
phdr[text].p_memsz := SizeOf.code;
phdr[text].p_flags := PF_X + PF_R;
phdr[text].p_align := 1000H;
ehdr.e_entry := phdr[text].p_vaddr;
INC(offset, phdr[text].p_filesz);
VA := BaseAdr + offset + 2000H;
pad := (16 - VA MOD 16) MOD 16;
phdr[data].p_type := 1;
phdr[data].p_offset := offset;
phdr[data].p_vaddr := VA;
phdr[data].p_paddr := VA;
phdr[data].p_filesz := SizeOf.data + pad;
phdr[data].p_memsz := SizeOf.data + pad;
phdr[data].p_flags := PF_R + PF_W;
phdr[data].p_align := 1000H;
INC(offset, phdr[data].p_filesz);
VA := BaseAdr + offset + 3000H;
phdr[bss].p_type := 1;
phdr[bss].p_offset := offset;
phdr[bss].p_vaddr := VA;
phdr[bss].p_paddr := VA;
phdr[bss].p_filesz := 0;
phdr[bss].p_memsz := SizeOf.bss + 16;
phdr[bss].p_flags := PF_R + PF_W;
phdr[bss].p_align := 1000H;
Address.Code := ehdr.e_entry;
Address.Data := phdr[data].p_vaddr + pad;
Address.Bss := WR.align(phdr[bss].p_vaddr, 16);
Address.Import := 0;
PE32.fixup(program, Address, amd64);
item := symtab.first;
WHILE item # NIL DO
IF item(Elf32_Sym).value # 0 THEN
INC(item(Elf32_Sym).value, ehdr.e_entry)
END;
item := item.next
END;
IF so THEN
item := LISTS.getidx(dynamic, 10); item(Elf32_Dyn).d_val := ehdr.e_entry;
item := LISTS.getidx(dynamic, 11); item(Elf32_Dyn).d_val := BIN.GetLabel(program, fini) + ehdr.e_entry
END;
WR.Create(FileName);
FOR i := 0 TO EI_NIDENT - 1 DO
WR.WriteByte(ehdr.e_ident[i])
END;
Write16(ehdr.e_type);
Write16(ehdr.e_machine);
WR.Write32LE(ehdr.e_version);
IF amd64 THEN
WR.Write64LE(ehdr.e_entry);
WR.Write64LE(ehdr.e_phoff);
WR.Write64LE(ehdr.e_shoff)
ELSE
WR.Write32LE(ehdr.e_entry);
WR.Write32LE(ehdr.e_phoff);
WR.Write32LE(ehdr.e_shoff)
END;
WR.Write32LE(ehdr.e_flags);
Write16(ehdr.e_ehsize);
Write16(ehdr.e_phentsize);
Write16(ehdr.e_phnum);
Write16(ehdr.e_shentsize);
Write16(ehdr.e_shnum);
Write16(ehdr.e_shstrndx);
IF amd64 THEN
WritePH64(phdr[interp]);
WritePH64(phdr[dyn]);
WritePH64(phdr[header]);
WritePH64(phdr[text]);
WritePH64(phdr[data]);
WritePH64(phdr[bss])
ELSE
WritePH(phdr[interp]);
WritePH(phdr[dyn]);
WritePH(phdr[header]);
WritePH(phdr[text]);
WritePH(phdr[data]);
WritePH(phdr[bss])
END;
FOR i := 0 TO lenInterpreter - 1 DO
WR.WriteByte(ORD(Interpreter[i]))
END;
IF amd64 THEN
item := dynamic.first;
WHILE item # NIL DO
WR.Write64LE(item(Elf32_Dyn).d_tag);
WR.Write64LE(item(Elf32_Dyn).d_val);
item := item.next
END;
item := symtab.first;
WHILE item # NIL DO
WR.Write32LE(item(Elf32_Sym).name);
WR.WriteByte(ORD(item(Elf32_Sym).info));
WR.WriteByte(ORD(item(Elf32_Sym).other));
Write16(item(Elf32_Sym).shndx);
WR.Write64LE(item(Elf32_Sym).value);
WR.Write64LE(item(Elf32_Sym).size);
item := item.next
END;
WR.Write64LE(phdr[dyn].p_filesz + DynAdr - 16);
WR.Write32LE(1);
WR.Write32LE(1);
WR.Write64LE(0);
WR.Write64LE(phdr[dyn].p_filesz + DynAdr - 8);
WR.Write32LE(1);
WR.Write32LE(2);
WR.Write64LE(0)
ELSE
item := dynamic.first;
WHILE item # NIL DO
WR.Write32LE(item(Elf32_Dyn).d_tag);
WR.Write32LE(item(Elf32_Dyn).d_val);
item := item.next
END;
item := symtab.first;
WHILE item # NIL DO
WR.Write32LE(item(Elf32_Sym).name);
WR.Write32LE(item(Elf32_Sym).value);
WR.Write32LE(item(Elf32_Sym).size);
WR.WriteByte(ORD(item(Elf32_Sym).info));
WR.WriteByte(ORD(item(Elf32_Sym).other));
Write16(item(Elf32_Sym).shndx);
item := item.next
END;
WR.Write32LE(phdr[dyn].p_filesz + DynAdr - 8);
WR.Write32LE(00000101H);
WR.Write32LE(phdr[dyn].p_filesz + DynAdr - 4);
WR.Write32LE(00000201H)
END;
WR.Write32LE(symCount);
WR.Write32LE(symCount);
FOR i := 0 TO symCount - 1 DO
WR.Write32LE(CHL.GetInt(bucket, i))
END;
FOR i := 0 TO symCount - 1 DO
WR.Write32LE(CHL.GetInt(chain, i))
END;
CHL.WriteToFile(strtab);
IF amd64 THEN
WR.Write64LE(0);
WR.Write64LE(0)
ELSE
WR.Write32LE(0);
WR.Write32LE(0)
END;
CHL.WriteToFile(program.code);
WHILE pad > 0 DO
WR.WriteByte(0);
DEC(pad)
END;
CHL.WriteToFile(program.data);
WR.Close;
UTILS.chmod(FileName)
END write;
END ELF.

/programs/develop/oberon07/source/ERRORS.ob07
0,0 → 1,221
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE ERRORS;
IMPORT C := CONSOLE, UTILS;
PROCEDURE HintMsg* (name: ARRAY OF CHAR; line, col, hint: INTEGER);
BEGIN
IF hint = 0 THEN
C.String(" hint ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
C.String("variable '"); C.String(name); C.StringLn("' never used")
END
END HintMsg;
PROCEDURE WarningMsg* (line, col, warning: INTEGER);
BEGIN
C.String(" warning ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
CASE warning OF
|0: C.StringLn("passing a string value as a fixed array")
|1: C.StringLn("endless FOR loop")
|2: C.StringLn("identifier too long")
END
END WarningMsg;
PROCEDURE ErrorMsg* (fname: ARRAY OF CHAR; line, col, errno: INTEGER);
VAR
str: ARRAY 80 OF CHAR;
BEGIN
C.Ln;
C.String(" error ("); C.Int(errno); C.String(") ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
CASE errno OF
| 1: str := "missing 'H' or 'X'"
| 2: str := "missing scale"
| 3: str := "unclosed string"
| 4: str := "illegal character"
| 5: str := "string too long"
| 7: str := "number too long"
| 8..12: str := "number too large"
| 13: str := "real numbers not supported"
| 21: str := "'MODULE' expected"
| 22: str := "identifier expected"
| 23: str := "module name does not match file name"
| 24: str := "';' expected"
| 25: str := "identifier does not match module name"
| 26: str := "'.' expected"
| 27: str := "'END' expected"
| 28: str := "',', ';' or ':=' expected"
| 29: str := "module not found"
| 30: str := "multiply defined identifier"
| 31: str := "recursive import"
| 32: str := "'=' expected"
| 33: str := "')' expected"
| 34: str := "syntax error in expression"
| 35: str := "'}' expected"
| 36: str := "incompatible operand"
| 37: str := "incompatible operands"
| 38: str := "'RETURN' expected"
| 39: str := "integer overflow"
| 40: str := "floating point overflow"
| 41: str := "not enough floating point registers; simplify expression"
| 42: str := "out of range 0..255"
| 43: str := "expression is not an integer"
| 44: str := "out of range 0..MAXSET"
| 45: str := "division by zero"
| 46: str := "IV out of range"
| 47: str := "'OF' or ',' expected"
| 48: str := "undeclared identifier"
| 49: str := "type expected"
| 50: str := "recursive type definition"
| 51: str := "illegal value of constant"
| 52: str := "not a record type"
| 53: str := "':' expected"
| 54: str := "need to import SYSTEM"
| 55: str := "pointer type not defined"
| 56: str := "out of range 0..MAXSET"
| 57: str := "'TO' expected"
| 58: str := "not a record type"
| 59: str := "this expression cannot be a procedure"
| 60: str := "identifier does not match procedure name"
| 61: str := "illegally marked identifier"
| 62: str := "expression should be constant"
| 63: str := "not enough RAM"
| 64: str := "'(' expected"
| 65: str := "',' expected"
| 66: str := "incompatible parameter"
| 67: str := "'OF' expected"
| 68: str := "type expected"
| 69: str := "result type of procedure is not a basic type"
| 70: str := "import not supported"
| 71: str := "']' expected"
| 72: str := "expression is not BOOLEAN"
| 73: str := "not a record"
| 74: str := "undefined record field"
| 75: str := "not an array"
| 76: str := "expression is not an integer"
| 77: str := "not a pointer"
| 78: str := "type guard not allowed"
| 79: str := "not a type"
| 80: str := "not a record type"
| 81: str := "not a pointer type"
| 82: str := "type guard not allowed"
| 83: str := "index out of range"
| 84: str := "dimension too large"
| 85: str := "procedure must have level 0"
| 86: str := "not a procedure"
| 87: str := "incompatible expression (RETURN)"
| 88: str := "'THEN' expected"
| 89: str := "'DO' expected"
| 90: str := "'UNTIL' expected"
| 91: str := "incompatible assignment"
| 92: str := "procedure call of a function"
| 93: str := "not a variable"
| 94: str := "read only variable"
| 95: str := "invalid type of expression (CASE)"
| 96: str := "':=' expected"
| 97: str := "not INTEGER variable"
| 98: str := "illegal value of constant (0)"
| 99: str := "incompatible label"
|100: str := "multiply defined label"
|101: str := "too large parameter of WCHR"
|102: str := "label expected"
|103: str := "illegal value of constant"
|104: str := "type too large"
|105: str := "access to intermediate variables not allowed"
|106: str := "qualified identifier expected"
|107: str := "too large parameter of CHR"
|108: str := "a variable or a procedure expected"
|109: str := "expression should be constant"
|110: str := "out of range 0..65535"
|111: str := "record [noalign] cannot have a base type"
|112: str := "record [noalign] cannot be a base type"
|113: str := "result type of procedure should not be REAL"
|114: str := "identifiers 'lib_init' and 'version' are reserved"
|115: str := "recursive constant definition"
|116: str := "procedure too deep nested"
|117: str := "string expected"
|118: str := "'$END', '$ELSE' or '$ELSIF' without '$IF'"
|119: str := "'$IF', '$ELSIF', '$ELSE' or '$END' expected"
|120: str := "too many formal parameters"
|121: str := "multiply defined handler"
|122: str := "bad divisor"
|123: str := "illegal flag"
|124: str := "unknown flag"
|125: str := "flag not supported"
END;
C.StringLn(str);
C.String(" file: "); C.StringLn(fname);
UTILS.Exit(1)
END ErrorMsg;
PROCEDURE Error1 (s1: ARRAY OF CHAR);
BEGIN
C.Ln;
C.StringLn(s1);
UTILS.Exit(1)
END Error1;
PROCEDURE Error3 (s1, s2, s3: ARRAY OF CHAR);
BEGIN
C.Ln;
C.String(s1); C.String(s2); C.StringLn(s3);
UTILS.Exit(1)
END Error3;
PROCEDURE Error5 (s1, s2, s3, s4, s5: ARRAY OF CHAR);
BEGIN
C.Ln;
C.String(s1); C.String(s2); C.String(s3); C.String(s4); C.StringLn(s5);
UTILS.Exit(1)
END Error5;
PROCEDURE WrongRTL* (ProcName: ARRAY OF CHAR);
BEGIN
Error5("procedure ", UTILS.RTL_NAME, ".", ProcName, " not found")
END WrongRTL;
PROCEDURE BadParam* (param: ARRAY OF CHAR);
BEGIN
Error3("bad parameter: ", param, "")
END BadParam;
PROCEDURE FileNotFound* (Path, Name, Ext: ARRAY OF CHAR);
BEGIN
Error5("file ", Path, Name, Ext, " not found")
END FileNotFound;
PROCEDURE Error* (n: INTEGER);
BEGIN
CASE n OF
|201: Error1("writing file error")
|202: Error1("too many relocations")
|203: Error1("size of program is too large")
|204: Error1("size of variables is too large")
|205: Error1("not enough parameters")
|206: Error1("bad parameter <target>")
|207: Error3('inputfile name extension must be "', UTILS.FILE_EXT, '"')
|208: Error1("not enough RAM")
END
END Error;
END ERRORS.

/programs/develop/oberon07/source/FILES.ob07
0,0 → 1,200
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE FILES;
IMPORT UTILS, C := COLLECTIONS, CONSOLE;
TYPE
FILE* = POINTER TO RECORD (C.ITEM)
ptr: INTEGER;
buffer: ARRAY 64*1024 OF BYTE;
count: INTEGER
END;
VAR
files: C.COLLECTION;
PROCEDURE copy (src: ARRAY OF BYTE; src_idx: INTEGER; VAR dst: ARRAY OF BYTE; dst_idx: INTEGER; bytes: INTEGER);
BEGIN
WHILE bytes > 0 DO
dst[dst_idx] := src[src_idx];
INC(dst_idx);
INC(src_idx);
DEC(bytes)
END
END copy;
PROCEDURE flush (file: FILE): INTEGER;
VAR
res: INTEGER;
BEGIN
IF file # NIL THEN
res := UTILS.FileWrite(file.ptr, file.buffer, file.count);
IF res < 0 THEN
res := 0
END
ELSE
res := 0
END
RETURN res
END flush;
PROCEDURE NewFile (): FILE;
VAR
file: FILE;
citem: C.ITEM;
BEGIN
citem := C.pop(files);
IF citem = NIL THEN
NEW(file)
ELSE
file := citem(FILE)
END
RETURN file
END NewFile;
PROCEDURE create* (name: ARRAY OF CHAR): FILE;
VAR
file: FILE;
ptr: INTEGER;
BEGIN
ptr := UTILS.FileCreate(name);
IF ptr > 0 THEN
file := NewFile();
file.ptr := ptr;
file.count := 0
ELSE
file := NIL
END
RETURN file
END create;
PROCEDURE open* (name: ARRAY OF CHAR): FILE;
VAR
file: FILE;
ptr: INTEGER;
BEGIN
ptr := UTILS.FileOpen(name);
IF ptr > 0 THEN
file := NewFile();
file.ptr := ptr;
file.count := -1
ELSE
file := NIL
END
RETURN file
END open;
PROCEDURE close* (VAR file: FILE);
VAR
n: INTEGER;
BEGIN
IF file # NIL THEN
IF file.count > 0 THEN
n := flush(file)
END;
file.count := -1;
UTILS.FileClose(file.ptr);
file.ptr := 0;
C.push(files, file);
file := NIL
END
END close;
PROCEDURE read* (file: FILE; VAR chunk: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF file # NIL THEN
res := UTILS.FileRead(file.ptr, chunk, MAX(MIN(bytes, LEN(chunk)), 0));
IF res < 0 THEN
res := 0
END
ELSE
res := 0
END
RETURN res
END read;
PROCEDURE write* (file: FILE; chunk: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
free, n, idx: INTEGER;
BEGIN
idx := 0;
IF (file # NIL) & (file.count >= 0) THEN
free := LEN(file.buffer) - file.count;
WHILE bytes > 0 DO
n := MIN(free, bytes);
copy(chunk, idx, file.buffer, file.count, n);
DEC(free, n);
DEC(bytes, n);
INC(idx, n);
INC(file.count, n);
IF free = 0 THEN
IF flush(file) # LEN(file.buffer) THEN
bytes := 0;
DEC(idx, n)
ELSE
file.count := 0;
free := LEN(file.buffer)
END
END
END
END
RETURN idx
END write;
PROCEDURE WriteByte* (file: FILE; byte: BYTE): BOOLEAN;
VAR
arr: ARRAY 1 OF BYTE;
BEGIN
arr[0] := byte
RETURN write(file, arr, 1) = 1
END WriteByte;
BEGIN
files := C.create()
END FILES.

/programs/develop/oberon07/source/IL.ob07
0,0 → 1,1171
(*
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;
END IL.

/programs/develop/oberon07/source/LISTS.ob07
0,0 → 1,199
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE LISTS;
IMPORT C := COLLECTIONS;
TYPE
ITEM* = POINTER TO RECORD (C.ITEM)
prev*, next*: ITEM
END;
LIST* = POINTER TO RECORD
first*, last*: ITEM
END;
PROCEDURE push* (list: LIST; item: ITEM);
BEGIN
ASSERT(list # NIL);
ASSERT(item # NIL);
IF list.first = NIL THEN
list.first := item;
item.prev := NIL
ELSE
ASSERT(list.last # NIL);
item.prev := list.last;
list.last.next := item
END;
list.last := item;
item.next := NIL
END push;
PROCEDURE pop* (list: LIST): ITEM;
VAR
last: ITEM;
BEGIN
ASSERT(list # NIL);
last := list.last;
IF last # NIL THEN
IF last = list.first THEN
list.first := NIL;
list.last := NIL
ELSE
list.last := last.prev;
list.last.next := NIL
END;
last.next := NIL;
last.prev := NIL
END
RETURN last
END pop;
PROCEDURE insert* (list: LIST; cur, nov: ITEM);
VAR
next: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(nov # NIL);
ASSERT(cur # NIL);
next := cur.next;
IF next # NIL THEN
next.prev := nov;
nov.next := next;
cur.next := nov;
nov.prev := cur
ELSE
push(list, nov)
END
END insert;
PROCEDURE insertL* (list: LIST; cur, nov: ITEM);
VAR
prev: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(nov # NIL);
ASSERT(cur # NIL);
prev := cur.prev;
IF prev # NIL THEN
prev.next := nov;
nov.prev := prev
ELSE
nov.prev := NIL;
list.first := nov
END;
cur.prev := nov;
nov.next := cur
END insertL;
PROCEDURE delete* (list: LIST; item: ITEM);
VAR
prev, next: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(item # NIL);
prev := item.prev;
next := item.next;
IF next # NIL THEN
IF prev # NIL THEN
prev.next := next;
next.prev := prev
ELSE
next.prev := NIL;
list.first := next
END
ELSE
IF prev # NIL THEN
prev.next := NIL;
list.last := prev
ELSE
list.first := NIL;
list.last := NIL
END
END
END delete;
PROCEDURE count* (list: LIST): INTEGER;
VAR
item: ITEM;
res: INTEGER;
BEGIN
ASSERT(list # NIL);
res := 0;
item := list.first;
WHILE item # NIL DO
INC(res);
item := item.next
END
RETURN res
END count;
PROCEDURE getidx* (list: LIST; idx: INTEGER): ITEM;
VAR
item: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(idx >= 0);
item := list.first;
WHILE (item # NIL) & (idx > 0) DO
item := item.next;
DEC(idx)
END
RETURN item
END getidx;
PROCEDURE create* (list: LIST): LIST;
BEGIN
IF list = NIL THEN
NEW(list)
END;
list.first := NIL;
list.last := NIL
RETURN list
END create;
END LISTS.

/programs/develop/oberon07/source/MSP430.ob07
0,0 → 1,1780
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
All rights reserved.
*)
MODULE MSP430;
IMPORT IL, LISTS, REG, CHL := CHUNKLISTS, ERRORS, WR := WRITER, HEX,
UTILS, C := CONSOLE, PROG, RTL := MSP430RTL;
CONST
chkSTK* = 6;
minRAM* = 128; maxRAM* = 2048;
minROM* = 2048; maxROM* = 24576;
StkReserve = RTL.StkReserve;
IntVectorSize* = RTL.IntVectorSize;
PC = 0; SP = 1; SR = 2; CG = 3;
R4 = 4; R5 = 5; R6 = 6; R7 = 7;
HP = RTL.HP;
ACC = R4;
opRRC = 1000H; opSWPB = 1080H; opRRA = 1100H; opSXT = 1180H;
opPUSH = 1200H; opCALL = 1280H; opRETI = 1300H;
opMOV = 04000H; opADD = 05000H; opADDC = 06000H; opSUBC = 07000H;
opSUB = 08000H; opCMP = 09000H; opDADD = 0A000H; opBIT = 0B000H;
opBIC = 0C000H; opBIS = 0D000H; opXOR = 0E000H; opAND = 0F000H;
opJNE = 2000H; opJEQ = 2400H; opJNC = 2800H; opJC = 2C00H;
opJN = 3000H; opJGE = 3400H; opJL = 3800H; opJMP = 3C00H;
sREG = 0; sIDX = 16; sINDIR = 32; sINCR = 48; BW = 64; dIDX = 128;
NOWORD = 10000H;
RCODE = 0; RDATA = 1; RBSS = 2;
je = 0; jne = je + 1;
jge = 2; jl = jge + 1;
jle = 4; jg = jle + 1;
jb = 6;
TYPE
ANYCODE = POINTER TO RECORD (LISTS.ITEM)
offset: INTEGER
END;
WORD = POINTER TO RECORD (ANYCODE)
val: INTEGER
END;
LABEL = POINTER TO RECORD (ANYCODE)
num: INTEGER
END;
JMP = POINTER TO RECORD (ANYCODE)
cc, label: INTEGER;
short: BOOLEAN
END;
CALL = POINTER TO RECORD (ANYCODE)
label: INTEGER
END;
COMMAND = IL.COMMAND;
RELOC = POINTER TO RECORD (LISTS.ITEM)
section: INTEGER;
WordPtr: WORD
END;
VAR
R: REG.REGS;
CodeList: LISTS.LIST;
RelList: LISTS.LIST;
mem: ARRAY 65536 OF BYTE;
Labels: CHL.INTLIST;
IV: ARRAY RTL.LenIV OF INTEGER;
IdxWords: RECORD src, dst: INTEGER END;
StkCnt, MaxStkCnt: INTEGER;
PROCEDURE CheckProcDataSize* (VarSize, RamSize: INTEGER): BOOLEAN;
RETURN (VarSize + 1) * 2 + StkReserve + RTL.VarSize < RamSize
END CheckProcDataSize;
PROCEDURE EmitLabel (L: INTEGER);
VAR
label: LABEL;
BEGIN
NEW(label);
label.num := L;
LISTS.push(CodeList, label)
END EmitLabel;
PROCEDURE EmitWord (val: INTEGER);
VAR
word: WORD;
BEGIN
IF val < 0 THEN
ASSERT(val >= -32768);
val := val MOD 65536
ELSE
ASSERT(val <= 65535)
END;
NEW(word);
word.val := val;
LISTS.push(CodeList, word)
END EmitWord;
PROCEDURE EmitJmp (cc, label: INTEGER);
VAR
jmp: JMP;
BEGIN
NEW(jmp);
jmp.cc := cc;
jmp.label := label;
jmp.short := FALSE;
LISTS.push(CodeList, jmp)
END EmitJmp;
PROCEDURE EmitCall (label: INTEGER);
VAR
call: CALL;
BEGIN
NEW(call);
call.label := label;
LISTS.push(CodeList, call)
END EmitCall;
PROCEDURE IncStk;
BEGIN
INC(StkCnt);
MaxStkCnt := MAX(StkCnt, MaxStkCnt)
END IncStk;
PROCEDURE bw (b: BOOLEAN): INTEGER;
RETURN BW * ORD(b)
END bw;
PROCEDURE src_x (x, Rn: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF (x = 0) & ~(Rn IN {PC, SR, CG}) THEN
res := Rn * 256 + sINDIR
ELSE
IdxWords.src := x;
res := Rn * 256 + sIDX
END
RETURN res
END src_x;
PROCEDURE dst_x (x, Rn: INTEGER): INTEGER;
BEGIN
IdxWords.dst := x
RETURN Rn + dIDX
END dst_x;
PROCEDURE indir (Rn: INTEGER): INTEGER;
RETURN Rn * 256 + sINDIR
END indir;
PROCEDURE incr (Rn: INTEGER): INTEGER;
RETURN Rn * 256 + sINCR
END incr;
PROCEDURE imm (x: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE x OF
| 0: res := CG * 256
| 1: res := CG * 256 + sIDX
| 2: res := indir(CG)
| 4: res := indir(SR)
| 8: res := incr(SR)
|-1: res := incr(CG)
ELSE
res := incr(PC);
IdxWords.src := x
END
RETURN res
END imm;
PROCEDURE Op2 (op, src, dst: INTEGER);
BEGIN
ASSERT(BITS(op) - {6, 12..15} = {});
ASSERT(BITS(src) - {4, 5, 8..11} = {});
ASSERT(BITS(dst) - {0..3, 7} = {});
EmitWord(op + src + dst);
IF IdxWords.src # NOWORD THEN
EmitWord(IdxWords.src);
IdxWords.src := NOWORD
END;
IF IdxWords.dst # NOWORD THEN
EmitWord(IdxWords.dst);
IdxWords.dst := NOWORD
END
END Op2;
PROCEDURE Op1 (op, reg, As: INTEGER);
BEGIN
EmitWord(op + reg + As)
END Op1;
PROCEDURE MovRR (src, dst: INTEGER);
BEGIN
Op2(opMOV, src * 256, dst)
END MovRR;
PROCEDURE PushImm (imm: INTEGER);
BEGIN
imm := UTILS.Long(imm);
CASE imm OF
| 0: Op1(opPUSH, CG, sREG)
| 1: Op1(opPUSH, CG, sIDX)
| 2: Op1(opPUSH, CG, sINDIR)
|-1: Op1(opPUSH, CG, sINCR)
ELSE
Op1(opPUSH, PC, sINCR);
EmitWord(imm)
END;
IncStk
END PushImm;
PROCEDURE PutWord (word: INTEGER; VAR adr: INTEGER);
BEGIN
ASSERT(~ODD(adr));
ASSERT((0 <= word) & (word <= 65535));
mem[adr] := word MOD 256;
mem[adr + 1] := word DIV 256;
INC(adr, 2)
END PutWord;
PROCEDURE NewLabel (): INTEGER;
BEGIN
CHL.PushInt(Labels, 0)
RETURN IL.NewLabel()
END NewLabel;
PROCEDURE LabelOffs (n: INTEGER): INTEGER;
RETURN CHL.GetInt(Labels, n)
END LabelOffs;
PROCEDURE Fixup (CodeAdr, IntVectorSize: INTEGER): INTEGER;
VAR
cmd: ANYCODE;
adr: INTEGER;
offset: INTEGER;
diff: INTEGER;
cc: INTEGER;
shorted: BOOLEAN;
BEGIN
REPEAT
shorted := FALSE;
offset := CodeAdr DIV 2;
cmd := CodeList.first(ANYCODE);
WHILE cmd # NIL DO
cmd.offset := offset;
CASE cmd OF
|LABEL: CHL.SetInt(Labels, cmd.num, offset)
|JMP: INC(offset);
IF ~cmd.short THEN
INC(offset);
IF cmd.cc # opJMP THEN
INC(offset)
END
END
|CALL: INC(offset, 2)
|WORD: INC(offset)
END;
cmd := cmd.next(ANYCODE)
END;
cmd := CodeList.first(ANYCODE);
WHILE cmd # NIL DO
IF (cmd IS JMP) & ~cmd(JMP).short THEN
diff := LabelOffs(cmd(JMP).label) - cmd.offset - 1;
IF ABS(diff) <= 512 THEN
cmd(JMP).short := TRUE;
shorted := TRUE
END
END;
cmd := cmd.next(ANYCODE)
END
UNTIL ~shorted;
IF offset * 2 > 10000H - IntVectorSize THEN
ERRORS.Error(203)
END;
adr := CodeAdr;
cmd := CodeList.first(ANYCODE);
WHILE cmd # NIL DO
CASE cmd OF
|LABEL:
|JMP: IF ~cmd.short THEN
CASE cmd.cc OF
|opJNE: cc := opJEQ
|opJEQ: cc := opJNE
|opJNC: cc := opJC
|opJC: cc := opJNC
|opJGE: cc := opJL
|opJL: cc := opJGE
|opJMP: cc := opJMP
END;
IF cc # opJMP THEN
PutWord(cc + 2, adr) (* jcc L *)
END;
PutWord(4030H, adr); (* MOV @PC+, PC *)
PutWord(LabelOffs(cmd.label) * 2, adr)
(* L: *)
ELSE
diff := LabelOffs(cmd.label) - cmd.offset - 1;
ASSERT((-512 <= diff) & (diff <= 511));
PutWord(cmd.cc + diff MOD 1024, adr)
END
|CALL: PutWord(12B0H, adr); (* CALL @PC+ *)
PutWord(LabelOffs(cmd.label) * 2, adr)
|WORD: PutWord(cmd.val, adr)
END;
cmd := cmd.next(ANYCODE)
END
RETURN adr - CodeAdr
END Fixup;
PROCEDURE Push (reg: INTEGER);
BEGIN
Op1(opPUSH, reg, sREG);
IncStk
END Push;
PROCEDURE Pop (reg: INTEGER);
BEGIN
Op2(opMOV, incr(SP), reg);
DEC(StkCnt)
END Pop;
PROCEDURE Test (reg: INTEGER);
BEGIN
Op2(opCMP, imm(0), reg)
END Test;
PROCEDURE Clear (reg: INTEGER);
BEGIN
Op2(opMOV, imm(0), reg)
END Clear;
PROCEDURE mov (dst, src: INTEGER);
BEGIN
MovRR(src, dst)
END mov;
PROCEDURE xchg (reg1, reg2: INTEGER);
BEGIN
Push(reg1);
mov(reg1, reg2);
Pop(reg2)
END xchg;
PROCEDURE Reloc (section: INTEGER);
VAR
reloc: RELOC;
BEGIN
NEW(reloc);
reloc.section := section;
reloc.WordPtr := CodeList.last(WORD);
LISTS.push(RelList, reloc)
END Reloc;
PROCEDURE CallRTL (proc, params: INTEGER);
BEGIN
IncStk;
DEC(StkCnt);
EmitCall(RTL.rtl[proc].label);
RTL.Used(proc);
IF params > 0 THEN
Op2(opADD, imm(params * 2), SP);
DEC(StkCnt, params)
END
END CallRTL;
PROCEDURE UnOp (VAR reg: INTEGER);
BEGIN
REG.UnOp(R, reg)
END UnOp;
PROCEDURE BinOp (VAR reg1, reg2: INTEGER);
BEGIN
REG.BinOp(R, reg1, reg2)
END BinOp;
PROCEDURE GetRegA;
BEGIN
ASSERT(REG.GetReg(R, ACC))
END GetRegA;
PROCEDURE drop;
BEGIN
REG.Drop(R)
END drop;
PROCEDURE GetAnyReg (): INTEGER;
RETURN REG.GetAnyReg(R)
END GetAnyReg;
PROCEDURE PushAll (NumberOfParameters: INTEGER);
BEGIN
REG.PushAll(R);
DEC(R.pushed, NumberOfParameters)
END PushAll;
PROCEDURE PushAll_1;
BEGIN
REG.PushAll_1(R)
END PushAll_1;
PROCEDURE cond (op: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE op OF
|IL.opGT, IL.opGTC: res := jg
|IL.opGE, IL.opGEC: res := jge
|IL.opLT, IL.opLTC: res := jl
|IL.opLE, IL.opLEC: res := jle
|IL.opEQ, IL.opEQC: res := je
|IL.opNE, IL.opNEC: res := jne
END
RETURN res
END cond;
PROCEDURE jcc (cc, label: INTEGER);
VAR
L: INTEGER;
BEGIN
CASE cc OF
|jne:
EmitJmp(opJNE, label)
|je:
EmitJmp(opJEQ, label)
|jge:
EmitJmp(opJGE, label)
|jl:
EmitJmp(opJL, label)
|jle:
EmitJmp(opJL, label);
EmitJmp(opJEQ, label)
|jg:
L := NewLabel();
EmitJmp(opJEQ, L);
EmitJmp(opJGE, label);
EmitLabel(L)
|jb:
EmitJmp(opJNC, label)
END
END jcc;
PROCEDURE setcc (cc, reg: INTEGER);
VAR
L: INTEGER;
BEGIN
L := NewLabel();
Op2(opMOV, imm(1), reg);
jcc(cc, L);
Clear(reg);
EmitLabel(L)
END setcc;
PROCEDURE Shift2 (op, reg, n: INTEGER);
VAR
reg2: INTEGER;
BEGIN
IF n >= 8 THEN
CASE op OF
|IL.opASR2: Op1(opSWPB, reg, sREG); Op1(opSXT, reg, sREG)
|IL.opROR2: Op1(opSWPB, reg, sREG)
|IL.opLSL2: Op1(opSWPB, reg, sREG); Op2(opBIC, imm(255), reg)
|IL.opLSR2: Op2(opBIC, imm(255), reg); Op1(opSWPB, reg, sREG)
END;
DEC(n, 8)
END;
IF (op = IL.opROR2) & (n > 0) THEN
reg2 := GetAnyReg();
MovRR(reg, reg2)
ELSE
reg2 := -1
END;
WHILE n > 0 DO
CASE op OF
|IL.opASR2: Op1(opRRA, reg, sREG)
|IL.opROR2: Op1(opRRC, reg2, sREG); Op1(opRRC, reg, sREG)
|IL.opLSL2: Op2(opADD, reg * 256, reg)
|IL.opLSR2: Op2(opBIC, imm(1), SR); Op1(opRRC, reg, sREG)
END;
DEC(n)
END;
IF reg2 # -1 THEN
drop
END
END Shift2;
PROCEDURE Neg (reg: INTEGER);
BEGIN
Op2(opXOR, imm(-1), reg);
Op2(opADD, imm(1), reg)
END Neg;
PROCEDURE LocalOffset (offset: INTEGER): INTEGER;
RETURN (offset + StkCnt - ORD(offset > 0)) * 2
END LocalOffset;
PROCEDURE LocalDst (offset: INTEGER): INTEGER;
RETURN dst_x(LocalOffset(offset), SP)
END LocalDst;
PROCEDURE LocalSrc (offset: INTEGER): INTEGER;
RETURN src_x(LocalOffset(offset), SP)
END LocalSrc;
PROCEDURE translate (chk_stk: BOOLEAN);
VAR
cmd, next: COMMAND;
opcode, param1, param2, L, a, n, c1, c2: INTEGER;
reg1, reg2: INTEGER;
cc: INTEGER;
word: WORD;
BEGIN
cmd := IL.codes.commands.first(COMMAND);
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
opcode := cmd.opcode;
CASE opcode OF
|IL.opJMP:
EmitJmp(opJMP, param1)
|IL.opCALL:
IncStk;
DEC(StkCnt);
EmitCall(param1)
|IL.opCALLP:
IncStk;
DEC(StkCnt);
UnOp(reg1);
Op1(opCALL, reg1, sREG);
drop;
ASSERT(R.top = -1)
|IL.opPRECALL:
PushAll(0)
|IL.opLABEL:
EmitLabel(param1)
|IL.opSADR_PARAM:
Op1(opPUSH, PC, sINCR);
IncStk;
EmitWord(param2);
Reloc(RDATA)
|IL.opERR:
CallRTL(RTL._error, 2)
|IL.opPUSHC:
PushImm(param2)
|IL.opONERR:
DEC(StkCnt);
EmitWord(0C232H); (* BIC #8, SR; DINT *)
EmitWord(4303H); (* MOV R3, R3; NOP *)
PushImm(param2);
EmitJmp(opJMP, param1)
|IL.opLEAVEC:
Pop(PC)
|IL.opENTER:
ASSERT(R.top = -1);
EmitLabel(param1);
n := param2 MOD 65536;
param2 := param2 DIV 65536;
StkCnt := 0;
IF chk_stk THEN
L := NewLabel();
Op2(opMOV, SP * 256, R4);
Op2(opSUB, HP * 256, R4);
Op2(opCMP, imm(StkReserve), R4);
word := CodeList.last(WORD);
jcc(jge, L);
DEC(StkCnt);
EmitWord(0C232H); (* BIC #8, SR; DINT *)
EmitWord(4303H); (* MOV R3, R3; NOP *)
PushImm(n);
EmitJmp(opJMP, cmd.param3);
EmitLabel(L)
END;
IF param2 > 8 THEN
Op2(opMOV, imm(param2), R4);
L := NewLabel();
EmitLabel(L);
Push(CG);
Op2(opSUB, imm(1), R4);
jcc(jne, L)
ELSE
FOR n := 1 TO param2 DO
Push(CG)
END
END;
StkCnt := param2;
MaxStkCnt := StkCnt
|IL.opLEAVE, IL.opLEAVER:
ASSERT(param2 = 0);
IF opcode = IL.opLEAVER THEN
UnOp(reg1);
IF reg1 # ACC THEN
mov(ACC, reg1)
END;
drop
END;
ASSERT(R.top = -1);
ASSERT(StkCnt = param1);
IF chk_stk THEN
INC(word.val, MaxStkCnt * 2)
END;
IF param1 > 0 THEN
Op2(opADD, imm(param1 * 2), SP)
END;
Pop(PC)
|IL.opRES:
ASSERT(R.top = -1);
GetRegA
|IL.opCLEANUP:
IF param2 # 0 THEN
Op2(opADD, imm(param2 * 2), SP);
DEC(StkCnt, param2)
END
|IL.opCONST:
next := cmd.next(COMMAND);
IF next.opcode = IL.opCONST THEN
c1 := param2;
c2 := next.param2;
next := next.next(COMMAND);
IF (next.opcode = IL.opSAVE) OR (next.opcode = IL.opSAVE16) OR (next.opcode = IL.opSAVE8) THEN
Op2(opMOV + bw(next.opcode = IL.opSAVE8), imm(c1), dst_x(c2, SR));
cmd := next
ELSE
Op2(opMOV, imm(param2), GetAnyReg())
END
ELSIF (next.opcode = IL.opSAVE) OR (next.opcode = IL.opSAVE16) OR (next.opcode = IL.opSAVE8) THEN
UnOp(reg1);
Op2(opMOV + bw(next.opcode = IL.opSAVE8), reg1 * 256, dst_x(param2, SR));
drop;
cmd := next
ELSE
Op2(opMOV, imm(param2), GetAnyReg())
END
|IL.opSADR:
Op2(opMOV, incr(PC), GetAnyReg());
EmitWord(param2);
Reloc(RDATA)
|IL.opGADR:
Op2(opMOV, incr(PC), GetAnyReg());
EmitWord(param2);
Reloc(RBSS)
|IL.opLADR:
reg1 := GetAnyReg();
n := LocalOffset(param2);
Op2(opMOV, SP * 256, reg1);
IF n # 0 THEN
Op2(opADD, imm(n), reg1)
END
|IL.opLLOAD8:
Op2(opMOV + BW, LocalSrc(param2), GetAnyReg())
|IL.opLLOAD16, IL.opVADR:
Op2(opMOV, LocalSrc(param2), GetAnyReg())
|IL.opGLOAD8:
Op2(opMOV + BW, src_x(param2, SR), GetAnyReg());
Reloc(RBSS)
|IL.opGLOAD16:
Op2(opMOV, src_x(param2, SR), GetAnyReg());
Reloc(RBSS)
|IL.opLOAD8:
UnOp(reg1);
Op2(opMOV + BW, indir(reg1), reg1)
|IL.opLOAD16:
UnOp(reg1);
Op2(opMOV, indir(reg1), reg1)
|IL.opVLOAD8:
reg1 := GetAnyReg();
Op2(opMOV, LocalSrc(param2), reg1);
Op2(opMOV + BW, indir(reg1), reg1)
|IL.opVLOAD16:
reg1 := GetAnyReg();
Op2(opMOV, LocalSrc(param2), reg1);
Op2(opMOV, indir(reg1), reg1)
|IL.opSAVE, IL.opSAVE16:
BinOp(reg2, reg1);
Op2(opMOV, reg2 * 256, dst_x(0, reg1));
drop;
drop
|IL.opSAVE8:
BinOp(reg2, reg1);
Op2(opMOV + BW, reg2 * 256, dst_x(0, reg1));
drop;
drop
|IL.opSAVE8C:
UnOp(reg1);
Op2(opMOV + BW, imm(param2), dst_x(0, reg1));
drop
|IL.opSAVE16C, IL.opSAVEC:
UnOp(reg1);
Op2(opMOV, imm(param2), dst_x(0, reg1));
drop
|IL.opUMINUS:
UnOp(reg1);
Neg(reg1)
|IL.opADD:
BinOp(reg1, reg2);
Op2(opADD, reg2 * 256, reg1);
drop
|IL.opADDC:
IF param2 # 0 THEN
UnOp(reg1);
Op2(opADD, imm(param2), reg1)
END
|IL.opSUB:
BinOp(reg1, reg2);
Op2(opSUB, reg2 * 256, reg1);
drop
|IL.opSUBR, IL.opSUBL:
UnOp(reg1);
IF param2 # 0 THEN
Op2(opSUB, imm(param2), reg1)
END;
IF opcode = IL.opSUBL THEN
Neg(reg1)
END
|IL.opLADR_SAVEC:
Op2(opMOV, imm(param2), LocalDst(param1))
|IL.opLADR_SAVE:
UnOp(reg1);
Op2(opMOV, reg1 * 256, LocalDst(param2));
drop
|IL.opGADR_SAVEC:
Op2(opMOV, imm(param2), dst_x(param1, SR));
Reloc(RBSS)
|IL.opCONST_PARAM:
PushImm(param2)
|IL.opPARAM:
IF param2 = 1 THEN
UnOp(reg1);
Push(reg1);
drop
ELSE
ASSERT(R.top + 1 <= param2);
PushAll(param2)
END
|IL.opEQ..IL.opGE,
IL.opEQC..IL.opGEC:
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN
BinOp(reg1, reg2);
Op2(opCMP, reg2 * 256, reg1);
drop
ELSE
UnOp(reg1);
Op2(opCMP, imm(param2), reg1)
END;
drop;
cc := cond(opcode);
next := cmd.next(COMMAND);
IF next.opcode = IL.opJNZ THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJZ THEN
jcc(ORD(BITS(cc) / {0}), next.param1);
cmd := next
ELSE
setcc(cc, GetAnyReg())
END
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opCODE:
EmitWord(param2)
|IL.opDROP:
UnOp(reg1);
drop
|IL.opJNZ1:
UnOp(reg1);
Test(reg1);
jcc(jne, param1)
|IL.opJG:
UnOp(reg1);
Test(reg1);
jcc(jg, param1)
|IL.opJNZ:
UnOp(reg1);
Test(reg1);
jcc(jne, param1);
drop
|IL.opJZ:
UnOp(reg1);
Test(reg1);
jcc(je, param1);
drop
|IL.opNOT:
UnOp(reg1);
Test(reg1);
setcc(je, reg1)
|IL.opORD:
UnOp(reg1);
Test(reg1);
setcc(jne, reg1)
|IL.opGET:
BinOp(reg1, reg2);
drop;
drop;
Op2(opMOV + bw(param2 = 1), indir(reg1), dst_x(0, reg2))
|IL.opGETC:
UnOp(reg2);
drop;
Op2(opMOV + bw(param2 = 1), src_x(param1, SR), dst_x(0, reg2))
|IL.opCHKBYTE:
BinOp(reg1, reg2);
Op2(opCMP, imm(256), reg1);
jcc(jb, param1)
|IL.opCHKIDX:
UnOp(reg1);
Op2(opCMP, imm(param2), reg1);
jcc(jb, param1)
|IL.opCHKIDX2:
BinOp(reg1, reg2);
IF param2 # -1 THEN
Op2(opCMP, reg1 * 256, reg2);
jcc(jb, param1)
END;
INCL(R.regs, reg1);
DEC(R.top);
R.stk[R.top] := reg2
|IL.opINCC, IL.opINCCB:
UnOp(reg1);
Op2(opADD + bw(opcode = IL.opINCCB), imm(param2), dst_x(0, reg1));
drop
|IL.opDECCB:
UnOp(reg1);
Op2(opSUB + BW, imm(param2), dst_x(0, reg1));
drop
|IL.opINC, IL.opINCB:
BinOp(reg1, reg2);
Op2(opADD + bw(opcode = IL.opINCB), reg1 * 256, dst_x(0, reg2));
drop;
drop
|IL.opDEC, IL.opDECB:
BinOp(reg1, reg2);
Op2(opSUB + bw(opcode = IL.opDECB), reg1 * 256, dst_x(0, reg2));
drop;
drop
|IL.opLADR_INCC, IL.opLADR_INCCB:
Op2(opADD + bw(opcode = IL.opLADR_INCCB), imm(param2), LocalDst(param1))
|IL.opLADR_DECCB:
Op2(opSUB + BW, imm(param2), LocalDst(param1))
|IL.opLADR_INC, IL.opLADR_INCB:
UnOp(reg1);
Op2(opADD + bw(opcode = IL.opLADR_INCB), reg1 * 256, LocalDst(param2));
drop
|IL.opLADR_DEC, IL.opLADR_DECB:
UnOp(reg1);
Op2(opSUB + bw(opcode = IL.opLADR_DECB), reg1 * 256, LocalDst(param2));
drop
|IL.opPUSHT:
UnOp(reg1);
Op2(opMOV, src_x(-2, reg1), GetAnyReg())
|IL.opISREC:
PushAll(2);
PushImm(param2);
CallRTL(RTL._guardrec, 3);
GetRegA
|IL.opIS:
PushAll(1);
PushImm(param2);
CallRTL(RTL._is, 2);
GetRegA
|IL.opTYPEGR:
PushAll(1);
PushImm(param2);
CallRTL(RTL._guardrec, 2);
GetRegA
|IL.opTYPEGP:
UnOp(reg1);
PushAll(0);
Push(reg1);
PushImm(param2);
CallRTL(RTL._guard, 2);
GetRegA
|IL.opTYPEGD:
UnOp(reg1);
PushAll(0);
Op1(opPUSH, reg1, sIDX);
IncStk;
EmitWord(-2);
PushImm(param2);
CallRTL(RTL._guardrec, 2);
GetRegA
|IL.opMULS:
BinOp(reg1, reg2);
Op2(opAND, reg2 * 256, reg1);
drop
|IL.opMULSC:
UnOp(reg1);
Op2(opAND, imm(param2), reg1)
|IL.opDIVS:
BinOp(reg1, reg2);
Op2(opXOR, reg2 * 256, reg1);
drop
|IL.opDIVSC:
UnOp(reg1);
Op2(opXOR, imm(param2), reg1)
|IL.opADDS:
BinOp(reg1, reg2);
Op2(opBIS, reg2 * 256, reg1);
drop
|IL.opSUBS:
BinOp(reg1, reg2);
Op2(opBIC, reg2 * 256, reg1);
drop
|IL.opADDSC:
UnOp(reg1);
Op2(opBIS, imm(param2), reg1)
|IL.opSUBSL:
UnOp(reg1);
Op2(opXOR, imm(-1), reg1);
Op2(opAND, imm(param2), reg1)
|IL.opSUBSR:
UnOp(reg1);
Op2(opBIC, imm(param2), reg1)
|IL.opUMINS:
UnOp(reg1);
Op2(opXOR, imm(-1), reg1)
|IL.opLENGTH:
PushAll(2);
CallRTL(RTL._length, 2);
GetRegA
|IL.opMAX,IL.opMIN:
BinOp(reg1, reg2);
Op2(opCMP, reg2 * 256, reg1);
IF opcode = IL.opMIN THEN
cc := opJL + 1
ELSE
cc := opJGE + 1
END;
EmitWord(cc); (* jge/jl L *)
MovRR(reg2, reg1);
(* L: *)
drop
|IL.opMAXC, IL.opMINC:
UnOp(reg1);
Op2(opCMP, imm(param2), reg1);
L := NewLabel();
IF opcode = IL.opMINC THEN
cc := jl
ELSE
cc := jge
END;
jcc(cc, L);
Op2(opMOV, imm(param2), reg1);
EmitLabel(L)
|IL.opSWITCH:
UnOp(reg1);
IF param2 = 0 THEN
reg2 := ACC
ELSE
reg2 := R5
END;
IF reg1 # reg2 THEN
ASSERT(REG.GetReg(R, reg2));
ASSERT(REG.Exchange(R, reg1, reg2));
drop
END;
drop
|IL.opENDSW:
|IL.opCASEL:
Op2(opCMP, imm(param1), ACC);
jcc(jl, param2)
|IL.opCASER:
Op2(opCMP, imm(param1), ACC);
jcc(jg, param2)
|IL.opCASELR:
Op2(opCMP, imm(param1), ACC);
IF param2 = cmd.param3 THEN
jcc(jne, param2)
ELSE
jcc(jl, param2);
jcc(jg, cmd.param3)
END
|IL.opSBOOL:
BinOp(reg2, reg1);
Test(reg2);
setcc(jne, reg2);
Op2(opMOV + BW, reg2 * 256, dst_x(0, reg1));
drop;
drop
|IL.opSBOOLC:
UnOp(reg1);
Op2(opMOV + BW, imm(param2), dst_x(0, reg1));
drop
|IL.opEQS .. IL.opGES:
PushAll(4);
PushImm((opcode - IL.opEQS) * 12);
CallRTL(RTL._strcmp, 5);
GetRegA
|IL.opLEN:
UnOp(reg1);
drop;
EXCL(R.regs, reg1);
WHILE param2 > 0 DO
UnOp(reg2);
drop;
DEC(param2)
END;
INCL(R.regs, reg1);
ASSERT(REG.GetReg(R, reg1))
|IL.opLSL, IL.opASR, IL.opROR, IL.opLSR:
PushAll(2);
CASE opcode OF
|IL.opLSL: CallRTL(RTL._lsl, 2)
|IL.opASR: CallRTL(RTL._asr, 2)
|IL.opROR: CallRTL(RTL._ror, 2)
|IL.opLSR: CallRTL(RTL._lsr, 2)
END;
GetRegA
|IL.opLSL1, IL.opASR1, IL.opROR1, IL.opLSR1:
UnOp(reg1);
PushAll_1;
PushImm(param2);
Push(reg1);
drop;
CASE opcode OF
|IL.opLSL1: CallRTL(RTL._lsl, 2)
|IL.opASR1: CallRTL(RTL._asr, 2)
|IL.opROR1: CallRTL(RTL._ror, 2)
|IL.opLSR1: CallRTL(RTL._lsr, 2)
END;
GetRegA
|IL.opASR2, IL.opROR2, IL.opLSL2, IL.opLSR2:
param2 := param2 MOD 16;
IF param2 # 0 THEN
UnOp(reg1);
Shift2(opcode, reg1, param2)
END
|IL.opMUL:
PushAll(2);
CallRTL(RTL._mul, 2);
GetRegA
|IL.opMULC:
UnOp(reg1);
a := param2;
IF a > 1 THEN
n := UTILS.Log2(a)
ELSIF a < -1 THEN
n := UTILS.Log2(-a)
ELSE
n := -1
END;
IF a = 1 THEN
ELSIF a = -1 THEN
Neg(reg1)
ELSIF a = 0 THEN
Clear(reg1)
ELSE
IF n > 0 THEN
IF a < 0 THEN
Neg(reg1)
END;
Shift2(IL.opLSL2, reg1, n)
ELSE
PushAll(1);
PushImm(a);
CallRTL(RTL._mul, 2);
GetRegA
END
END
|IL.opDIV:
PushAll(2);
CallRTL(RTL._divmod, 2);
GetRegA
|IL.opDIVR:
ASSERT(param2 > 0);
IF param2 > 1 THEN
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(reg1);
Shift2(IL.opASR2, reg1, n)
ELSE
PushAll(1);
PushImm(param2);
CallRTL(RTL._divmod, 2);
GetRegA
END
END
|IL.opDIVL:
UnOp(reg1);
PushAll_1;
PushImm(param2);
Push(reg1);
drop;
CallRTL(RTL._divmod, 2);
GetRegA
|IL.opMOD:
PushAll(2);
CallRTL(RTL._divmod, 2);
ASSERT(REG.GetReg(R, R5))
|IL.opMODR:
ASSERT(param2 > 0);
IF param2 = 1 THEN
UnOp(reg1);
Clear(reg1)
ELSE
IF UTILS.Log2(param2) > 0 THEN
UnOp(reg1);
Op2(opAND, imm(param2 - 1), reg1)
ELSE
PushAll(1);
PushImm(param2);
CallRTL(RTL._divmod, 2);
ASSERT(REG.GetReg(R, R5))
END
END
|IL.opMODL:
UnOp(reg1);
PushAll_1;
PushImm(param2);
Push(reg1);
drop;
CallRTL(RTL._divmod, 2);
ASSERT(REG.GetReg(R, R5))
|IL.opCOPYS:
ASSERT(R.top = 3);
Push(R.stk[2]);
Push(R.stk[0]);
Op2(opCMP, R.stk[1] * 256, R.stk[3]);
EmitWord(3801H); (* JL L1 *)
MovRR(R.stk[1], R.stk[3]);
(* L1: *)
Push(R.stk[3]);
drop;
drop;
drop;
drop;
CallRTL(RTL._move, 3)
|IL.opCOPY:
PushAll(2);
PushImm(param2);
CallRTL(RTL._move, 3)
|IL.opMOVE:
PushAll(3);
CallRTL(RTL._move, 3)
|IL.opCOPYA:
PushAll(4);
PushImm(param2);
CallRTL(RTL._arrcpy, 5);
GetRegA
|IL.opROT:
PushAll(0);
MovRR(SP, ACC);
Push(ACC);
PushImm(param2);
CallRTL(RTL._rot, 2)
|IL.opSAVES:
UnOp(reg1);
PushAll_1;
Op1(opPUSH, PC, sINCR);
IncStk;
EmitWord(param2);
Reloc(RDATA);
Push(reg1);
drop;
PushImm(param1);
CallRTL(RTL._move, 3)
|IL.opCASET:
Push(R5);
Push(R5);
PushImm(param2);
CallRTL(RTL._guardrec, 2);
Pop(R5);
Test(ACC);
jcc(jne, param1)
|IL.opCHR:
UnOp(reg1);
Op2(opAND, imm(255), reg1)
|IL.opABS:
UnOp(reg1);
Test(reg1);
L := NewLabel();
jcc(jge, L);
Neg(reg1);
EmitLabel(L)
|IL.opEQB, IL.opNEB:
BinOp(reg1, reg2);
drop;
Test(reg1);
L := NewLabel();
jcc(je, L);
Op2(opMOV, imm(1), reg1);
EmitLabel(L);
Test(reg2);
L := NewLabel();
jcc(je, L);
Op2(opMOV, imm(1), reg2);
EmitLabel(L);
Op2(opCMP, reg2 * 256, reg1);
IF opcode = IL.opEQB THEN
setcc(je, reg1)
ELSE
setcc(jne, reg1)
END
|IL.opSAVEP:
UnOp(reg1);
Op2(opMOV, incr(PC), reg1 + dIDX);
EmitWord(param2);
Reloc(RCODE);
EmitWord(0);
drop
|IL.opPUSHP:
Op2(opMOV, incr(PC), GetAnyReg());
EmitWord(param2);
Reloc(RCODE)
|IL.opEQP, IL.opNEP:
UnOp(reg1);
Op2(opCMP, incr(PC), reg1);
EmitWord(param1);
Reloc(RCODE);
drop;
reg1 := GetAnyReg();
IF opcode = IL.opEQP THEN
setcc(je, reg1)
ELSIF opcode = IL.opNEP THEN
setcc(jne, reg1)
END
|IL.opVADR_PARAM:
reg1 := GetAnyReg();
Op2(opMOV, LocalSrc(param2), reg1);
Push(reg1);
drop
|IL.opNEW:
PushAll(1);
n := param2 + 2;
ASSERT(UTILS.Align(n, 2));
PushImm(n);
PushImm(param1);
CallRTL(RTL._new, 3)
|IL.opRSET:
PushAll(2);
CallRTL(RTL._set, 2);
GetRegA
|IL.opRSETR:
PushAll(1);
PushImm(param2);
CallRTL(RTL._set, 2);
GetRegA
|IL.opRSETL:
UnOp(reg1);
PushAll_1;
PushImm(param2);
Push(reg1);
drop;
CallRTL(RTL._set, 2);
GetRegA
|IL.opRSET1:
PushAll(1);
CallRTL(RTL._set1, 1);
GetRegA
|IL.opINCLC:
UnOp(reg1);
Op2(opBIS, imm(ORD({param2})), dst_x(0, reg1));
drop
|IL.opEXCLC:
UnOp(reg1);
Op2(opBIC, imm(ORD({param2})), dst_x(0, reg1));
drop
|IL.opIN:
PushAll(2);
CallRTL(RTL._in, 2);
GetRegA
|IL.opINR:
PushAll(1);
PushImm(param2);
CallRTL(RTL._in, 2);
GetRegA
|IL.opINL:
PushAll(1);
PushImm(param2);
CallRTL(RTL._in2, 2);
GetRegA
|IL.opINCL:
PushAll(2);
CallRTL(RTL._incl, 2)
|IL.opEXCL:
PushAll(2);
CallRTL(RTL._excl, 2)
|IL.opLADR_INCL, IL.opLADR_EXCL:
PushAll(1);
MovRR(SP, ACC);
n := LocalOffset(param2);
IF n # 0 THEN
Op2(opADD, imm(n), ACC)
END;
Push(ACC);
IF opcode = IL.opLADR_INCL THEN
CallRTL(RTL._incl, 2)
ELSIF opcode = IL.opLADR_EXCL THEN
CallRTL(RTL._excl, 2)
END
|IL.opLADR_INCLC:
Op2(opBIS, imm(ORD({param2})), LocalDst(param1))
|IL.opLADR_EXCLC:
Op2(opBIC, imm(ORD({param2})), LocalDst(param1))
END;
cmd := cmd.next(COMMAND)
END;
ASSERT(R.pushed = 0);
ASSERT(R.top = -1)
END translate;
PROCEDURE prolog;
VAR
i: INTEGER;
BEGIN
RTL.Init(EmitLabel, EmitWord, EmitCall);
FOR i := 0 TO LEN(RTL.rtl) - 1 DO
RTL.Set(i, NewLabel())
END;
IV[LEN(IV) - 1] := NewLabel();
EmitLabel(IV[LEN(IV) - 1]);
Op2(opMOV, incr(PC), SP);
EmitWord(0);
Op2(opMOV, incr(PC), HP);
EmitWord(0);
Op2(opMOV, imm(5A80H), dst_x(0120H, SR)); (* stop WDT *)
Op2(opMOV, imm(RTL.empty_proc), dst_x(0, SP));
Op2(opMOV, imm(RTL.empty_proc), dst_x(2, SP));
END prolog;
PROCEDURE epilog;
VAR
L1, i, n: INTEGER;
BEGIN
Op2(opBIS, imm(10H), SR); (* CPUOFF *)
L1 := NewLabel();
FOR i := 0 TO LEN(IV) - 2 DO
IV[i] := NewLabel();
EmitLabel(IV[i]);
PushImm(i);
IF i # LEN(IV) - 2 THEN
EmitJmp(opJMP, L1)
END
END;
EmitLabel(L1);
n := 0;
FOR i := 0 TO 15 DO
IF i IN R.regs THEN
Push(i);
INC(n)
END
END;
MovRR(SP, R4);
Op2(opADD, imm(n * 2), R4);
Push(R4);
Op1(opPUSH, R4, sINDIR);
Op1(opCALL, SR, sIDX); EmitWord(-RTL.VarSize); Reloc(RBSS); (* call int *)
Op2(opADD, imm(4), SP);
FOR i := 15 TO 0 BY -1 DO
IF i IN R.regs THEN
Pop(i)
END
END;
Op2(opADD, imm(2), SP);
Op1(opRETI, 0, 0);
RTL.Gen
END epilog;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
VAR
i, adr, heap, stack, TextSize, TypesSize, bits, n, val: INTEGER;
Code, Data, Bss: RECORD address, size: INTEGER END;
ram, rom: INTEGER;
reloc: RELOC;
BEGIN
IdxWords.src := NOWORD;
IdxWords.dst := NOWORD;
ram := options.ram;
rom := options.rom;
IF ODD(ram) THEN DEC(ram) END;
IF ODD(rom) THEN DEC(rom) END;
ram := MIN(MAX(ram, minRAM), maxRAM);
rom := MIN(MAX(rom, minROM), maxROM);
IF IL.codes.bss > ram - StkReserve - RTL.VarSize THEN
ERRORS.Error(204)
END;
Labels := CHL.CreateIntList();
FOR i := 1 TO IL.codes.lcount DO
CHL.PushInt(Labels, 0)
END;
CodeList := LISTS.create(NIL);
RelList := LISTS.create(NIL);
REG.Init(R, Push, Pop, mov, xchg, {R4, R5, R6, R7});
prolog;
translate(chkSTK IN options.checking);
epilog;
TypesSize := CHL.Length(IL.codes.types) * 2;
Data.size := CHL.Length(IL.codes.data);
IF ODD(Data.size) THEN
CHL.PushByte(IL.codes.data, 0);
INC(Data.size)
END;
Code.size := Fixup(0, IntVectorSize + TypesSize + Data.size);
Code.address := 10000H - (IntVectorSize + TypesSize + Data.size + Code.size);
IF Code.address < 10000H - rom THEN
ERRORS.Error(203)
END;
Code.size := Fixup(Code.address, IntVectorSize + TypesSize + Data.size);
Data.address := Code.address + Code.size;
TextSize := Code.size + Data.size;
IF Code.address + TextSize + MAX(IL.codes.dmin - Data.size, IntVectorSize + TypesSize) > 10000H THEN
ERRORS.Error(203)
END;
stack := RTL.ram + ram;
Bss.size := IL.codes.bss + IL.codes.bss MOD 2;
DEC(stack, Bss.size);
Bss.address := stack;
DEC(stack, RTL.VarSize);
heap := RTL.ram;
ASSERT(stack - heap >= StkReserve);
adr := Code.address + 2;
PutWord(stack, adr);
adr := Code.address + 6;
PutWord(heap, adr);
reloc := RelList.first(RELOC);
WHILE reloc # NIL DO
adr := reloc.WordPtr.offset * 2;
val := reloc.WordPtr.val;
CASE reloc.section OF
|RCODE: PutWord(LabelOffs(val) * 2, adr)
|RDATA: PutWord(val + Data.address, adr)
|RBSS: PutWord((val + Bss.address) MOD 65536, adr)
END;
reloc := reloc.next(RELOC)
END;
adr := Data.address;
FOR i := 0 TO Data.size - 1 DO
mem[adr] := CHL.GetByte(IL.codes.data, i);
INC(adr)
END;
FOR i := TypesSize DIV 2 - 1 TO 0 BY -1 DO
PutWord(CHL.GetInt(IL.codes.types, i), adr)
END;
FOR i := 0 TO 15 DO
PutWord((33 - i) * i, adr);
END;
FOR n := 0 TO 15 DO
bits := ORD({0 .. n});
FOR i := 0 TO 15 - n DO
PutWord(bits, adr);
bits := LSL(bits, 1)
END
END;
PutWord(4130H, adr); (* RET *)
PutWord(stack, adr);
PutWord(0001H, adr); (* bsl signature (adr 0FFBEH) *)
FOR i := 0 TO LEN(IV) - 1 DO
PutWord(LabelOffs(IV[i]) * 2, adr)
END;
INC(TextSize, IntVectorSize + TypesSize + Code.address MOD 16);
INC(Bss.size, StkReserve + RTL.VarSize);
WR.Create(outname);
HEX.Data(mem, Code.address - Code.address MOD 16, TextSize);
HEX.End;
WR.Close;
C.Dashes;
C.String(" rom: "); C.Int(TextSize); C.String(" of "); C.Int(rom); C.String(" ("); C.Int(TextSize * 100 DIV rom); C.StringLn("%)");
C.Ln;
C.String(" ram: "); C.Int(Bss.size); C.String(" of "); C.Int(ram); C.String(" ("); C.Int(Bss.size * 100 DIV ram); C.StringLn("%)")
END CodeGen;
END MSP430.

/programs/develop/oberon07/source/MSP430RTL.ob07
0,0 → 1,671
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
All rights reserved.
*)
MODULE MSP430RTL;
CONST
_mul* = 0;
_divmod* = 1;
_lsl* = 2;
_asr* = 3;
_ror* = 4;
_lsr* = 5;
_in* = 6;
_in2* = 7;
_set1* = 8;
_incl* = 9;
_excl* = 10;
_move* = 11;
_set* = 12;
_arrcpy* = 13;
_rot* = 14;
_strcmp* = 15;
_error* = 16;
_is* = 17;
_guard* = 18;
_guardrec* = 19;
_length* = 20;
_new* = 21;
HP* = 15;
LenIV* = 32;
iv = 10000H - LenIV * 2;
bsl = iv - 2;
sp = bsl - 2;
empty_proc* = sp - 2;
bits = empty_proc - 272;
bits_offs = bits - 32;
DataSize* = iv - bits_offs;
types = bits_offs - 2;
IntVectorSize* = LenIV * 2 + DataSize;
VarSize* = 4;
StkReserve* = 40;
trap = 2;
TYPE
EMITPROC = PROCEDURE (n: INTEGER);
VAR
ram*: INTEGER;
rtl*: ARRAY 22 OF
RECORD
label*: INTEGER;
used: BOOLEAN
END;
Label, Word, Call: EMITPROC;
PROCEDURE Gen*;
PROCEDURE Word1 (word: INTEGER);
BEGIN
Word(word)
END Word1;
PROCEDURE Word2 (word1, word2: INTEGER);
BEGIN
Word1(word1);
Word1(word2)
END Word2;
PROCEDURE Word3 (word1, word2, word3: INTEGER);
BEGIN
Word1(word1);
Word1(word2);
Word1(word3)
END Word3;
BEGIN
(* _lsl (n, x: INTEGER): INTEGER *)
IF rtl[_lsl].used THEN
Label(rtl[_lsl].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 3); (* JZ L1 *)
(* L2: *)
Word1(5404H); (* ADD R4, R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 3); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _asr (n, x: INTEGER): INTEGER *)
IF rtl[_asr].used THEN
Label(rtl[_asr].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 3); (* JZ L1 *)
(* L2: *)
Word1(1104H); (* RRA R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 3); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _ror (n, x: INTEGER): INTEGER *)
IF rtl[_ror].used THEN
Label(rtl[_ror].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 5); (* JZ L1 *)
Word1(4406H); (* MOV R4, R6 *)
(* L2: *)
Word1(1006H); (* RRC R6 *)
Word1(1004H); (* RRC R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 4); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _lsr (n, x: INTEGER): INTEGER *)
IF rtl[_lsr].used THEN
Label(rtl[_lsr].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 4); (* JZ L1 *)
(* L2: *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1004H); (* RRC R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 4); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _set (b, a: INTEGER): SET *)
IF rtl[_set].used THEN
Label(rtl[_set].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- b *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- a *)
Word1(9504H); (* CMP R5, R4 *)
Word1(3800H + 24); (* JL L1 *)
Word2(9035H, 16); (* CMP #16, R5 *)
Word1(3400H + 21); (* JGE L1 *)
Word1(9304H); (* CMP #0, R4 *)
Word1(3800H + 19); (* JL L1 *)
Word2(9034H, 16); (* CMP #16, R4 *)
Word1(3800H + 2); (* JL L2 *)
Word2(4034H, 15); (* MOV #15, R4 *)
(* L2: *)
Word1(9305H); (* CMP #0, R5 *)
Word1(3400H + 1); (* JGE L3 *)
Word1(4305H); (* MOV #0, R5 *)
(* L3: *)
Word1(8504H); (* SUB R5, R4 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits_offs); (* ADD bits_offs, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word1(5505H); (* ADD R5, R5 *)
Word1(5405H); (* ADD R4, R5 *)
Word2(5035H, bits); (* ADD bits, R5 *)
Word1(4524H); (* MOV @R5, R4 *)
Word1(4130H); (* RET *)
(* L1: *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H) (* RET *)
END;
(* _set1 (a: INTEGER): SET *)
IF rtl[_set1].used THEN
Label(rtl[_set1].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- a *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 5); (* JNZ L1 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word1(4130H); (* RET *)
(* L1: *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H) (* RET *)
END;
(* _in2 (i, s: INTEGER): BOOLEAN *)
IF rtl[_in2].used THEN
Label(rtl[_in2].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- i *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(0F114H, 4); (* AND 4(SP), R4 *)
Word1(2400H + 1); (* JZ L1 *)
Word1(4314H); (* MOV #1, R4 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _in (s, i: INTEGER): BOOLEAN *)
IF rtl[_in].used THEN
Label(rtl[_in].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 9); (* JNZ L2 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(0F114H, 2); (* AND 2(SP), R4 *)
Word1(2400H + 3); (* JZ L1 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4130H); (* RET *)
(* L2: *)
Word1(4304H); (* MOV #0, R4 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _incl (VAR s: SET; i: INTEGER) *)
IF rtl[_incl].used THEN
Label(rtl[_incl].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 8); (* JNZ L1 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- @s *)
Word2(0D485H, 0); (* BIS R4, 0(R5) *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _excl (VAR s: SET; i: INTEGER) *)
IF rtl[_excl].used THEN
Label(rtl[_excl].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 8); (* JNZ L1 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- @s *)
Word2(0C485H, 0); (* BIC R4, 0(R5) *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _rot (len, adr: INTEGER) *)
IF rtl[_rot].used THEN
Label(rtl[_rot].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- len *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- adr *)
Word1(8314H); (* SUB #1, R4 *)
Word1(5404H); (* ADD R4, R4 *)
Word1(1225H); (* PUSH @R5 *)
Word1(4406H); (* MOV R4, R6 *)
(* L1: *)
Word3(4595H, 2, 0); (* MOV 2(R5), 0(R5) *)
Word1(5325H); (* ADD #2, R5 *)
Word1(8326H); (* SUB #2, R6 *)
Word1(2000H + 400H - 6); (* JNZ L1 *)
Word2(41B5H, 0); (* MOV @SP+, 0(R5) *)
Word1(4130H) (* RET *)
END;
(* _divmod (b, a: INTEGER): INTEGER (* res -> R4, mod -> R5 *) *)
IF rtl[_divmod].used THEN
Label(rtl[_divmod].label);
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- a *)
Word1(4304H); (* MOV #0, R4 *)
(* L1: *)
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- b *)
Word1(9605H); (* CMP R6, R5 *)
Word1(3800H + 17); (* JL L3 *)
Word1(4327H); (* MOV #2, R7 *)
Word1(5606H); (* ADD R6, R6 *)
(* L4: *)
Word1(9306H); (* CMP #0, R6 *)
Word1(2400H + 6); (* JZ L2 *)
Word1(3800H + 5); (* JL L2 *)
Word1(9605H); (* CMP R6, R5 *)
Word1(3800H + 3); (* JL L2 *)
Word1(5606H); (* ADD R6, R6 *)
Word1(5707H); (* ADD R7, R7 *)
Word1(3C00H + 400H - 8); (* JMP L4 *)
(* L2: *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1006H); (* RRC R6 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1007H); (* RRC R7 *)
Word1(8605H); (* SUB R6, R5 *)
Word1(5704H); (* ADD R7, R4 *)
Word1(3C00H + 400H - 21); (* JMP L1 *)
(* L3: *)
(*----------- (a < 0) --------------*)
(* L1: *)
Word1(9305H); (* CMP #0, R5 *)
Word1(3400H + 23); (* JGE L3 *)
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- b *)
Word1(4327H); (* MOV #2, R7 *)
Word1(5606H); (* ADD R6, R6 *)
Word1(0E335H); (* XOR #-1, R5 *)
Word1(5315H); (* ADD #1, R5 *)
(* L4: *)
Word1(9306H); (* CMP #0, R6 *)
Word1(2400H + 6); (* JZ L2 *)
Word1(3800H + 5); (* JL L2 *)
Word1(9605H); (* CMP R6, R5 *)
Word1(3800H + 3); (* JL L2 *)
Word1(5606H); (* ADD R6, R6 *)
Word1(5707H); (* ADD R7, R7 *)
Word1(3C00H + 400H - 8); (* JMP L4 *)
(* L2: *)
Word1(0E335H); (* XOR #-1, R5 *)
Word1(5315H); (* ADD #1, R5 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1006H); (* RRC R6 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1007H); (* RRC R7 *)
Word1(5605H); (* ADD R6, R5 *)
Word1(8704H); (* SUB R7, R4 *)
Word1(3C00H + 400H - 25); (* JMP L1 *)
(* L3: *)
Word1(4130H) (* RET *)
END;
(* _mul (a, b: INTEGER): INTEGER *)
IF rtl[_mul].used THEN
Label(rtl[_mul].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- a *)
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- b *)
Word1(4304H); (* MOV #0, R4; res := 0 *)
Word1(9306H); (* CMP #0, R6 *)
Word1(2400H + 7); (* JZ L1 *)
(* L2: *)
Word1(0B316H); (* BIT #1, R6 *)
Word1(2400H + 1); (* JZ L3 *)
Word1(5504H); (* ADD R5, R4 *)
(* L3: *)
Word1(5505H); (* ADD R5, R5 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1006H); (* RRC R6 *)
Word1(2000H + 400H - 7); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _error (modNum, modName, err, line: INTEGER) *)
IF rtl[_error].used THEN
Label(rtl[_error].label);
Word1(5321H); (* ADD #2, SP *)
Word1(4134H); (* POP R4; R4 <- modNum *)
Word1(4135H); (* POP R5; R5 <- modName *)
Word1(4136H); (* POP R6; R6 <- err *)
Word1(4137H); (* POP R7; R7 <- line *)
Word2(4211H, sp); (* MOV sp(SR), SP *)
Word1(1207H); (* PUSH R7 *)
Word1(1206H); (* PUSH R6 *)
Word1(1205H); (* PUSH R5 *)
Word1(1204H); (* PUSH R4 *)
Word2(4214H, sp); (* MOV sp(SR), R4 *)
Word2(1294H, trap); (* CALL trap(R4) *)
Word2(04032H, 0F0H) (* MOV CPUOFF+OSCOFF+SCG0+SCG1, SR *)
END;
(* _new (t, size: INTEGER; VAR ptr: INTEGER) *)
IF rtl[_new].used THEN
Label(rtl[_new].label);
Word1(1202H); (* PUSH SR *)
Word1(4302H); (* MOV #0, SR *)
Word1(4303H); (* NOP *)
Word1(4104H); (* MOV SP, R4 *)
Word2(8034H, StkReserve); (* SUB #StkReserve, R4 *)
Word1(4005H + 100H * HP); (* MOV HP, R5 *)
Word2(5115H, 6); (* ADD 6(SP), R5 *)
Word1(9504H); (* CMP R5, R4 *)
Word2(4114H, 8); (* MOV 8(SP), R4 *)
Word1(3800H + 12); (* JL L1 *)
Word3(4190H + HP, 4, 0); (* MOV 4(SP), 0(HP) *)
Word1(5320H + HP); (* ADD #2, HP *)
Word2(4084H + 100H * HP, 0); (* MOV HP, 0(R4) *)
(* L3 *)
Word2(4380H + HP, 0); (* MOV #0, 0(HP) *)
Word1(5320H + HP); (* ADD #2, HP *)
Word1(9500H + HP); (* CMP R5, HP *)
Word1(3800H + 400H - 5); (* JL L3 *)
Word1(3C00H + 2); (* JMP L2 *)
(* L1 *)
Word2(4384H, 0); (* MOV #0, 0(R4) *)
(* L2 *)
Word1(1300H) (* RETI *)
END;
(* _guardrec (t0, t1: INTEGER): INTEGER *)
IF rtl[_guardrec].used THEN
Label(rtl[_guardrec].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- t0 *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- t1 *)
Word2(4036H, types); (* MOV #types, R6 *)
(* L3: *)
Word1(9305H); (* CMP #0, R5 *)
Word1(2400H + 8); (* JZ L1 *)
Word1(9405H); (* CMP R4, R5 *)
Word1(2400H + 10); (* JZ L2 *)
Word1(5505H); (* ADD R5, R5 *)
Word1(0E335H); (* XOR #-1, R5 *)
Word1(5315H); (* ADD #1, R5 *)
Word1(5605H); (* ADD R6, R5 *)
Word1(4525H); (* MOV @R5, R5 *)
Word1(3C00H + 400H - 10); (* JMP L3 *)
(* L1: *)
Word1(9405H); (* CMP R4, R5 *)
Word1(2400H + 2); (* JZ L2 *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H); (* RET *)
(* L2: *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4130H) (* RET *)
END;
(* _is (t, p: INTEGER): INTEGER *)
IF rtl[_is].used THEN
Label(rtl[_is].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- p *)
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- t *)
Word1(9304H); (* TST R4 *)
Word1(2400H + 2); (* JZ L *)
Word2(4414H, -2); (* MOV -2(R4), R4 *)
(* L: *)
Word1(1204H); (* PUSH R4 *)
Word1(1205H); (* PUSH R5 *)
Call(rtl[_guardrec].label); (* CALL _guardrec *)
Word1(5221H); (* ADD #4, SP *)
Word1(4130H) (* RET *)
END;
(* _guard (t, p: INTEGER): INTEGER *)
IF rtl[_guard].used THEN
Label(rtl[_guard].label);
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- p *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4525H); (* MOV @R5, R5 *)
Word1(9305H); (* TST R5 *)
Word1(2400H + 9); (* JZ L *)
Word2(4515H, -2); (* MOV -2(R5), R5 *)
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- t *)
Word1(1205H); (* PUSH R5 *)
Word1(1204H); (* PUSH R4 *)
Call(rtl[_guardrec].label); (* CALL _guardrec *)
Word1(5221H); (* ADD #4, SP *)
(* L: *)
Word1(4130H) (* RET *)
END;
(* _move (bytes, dest, source: INTEGER) *)
IF rtl[_move].used THEN
Label(rtl[_move].label);
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- bytes *)
Word2(4117H, 4); (* MOV 4(SP), R7; R7 <- dest *)
Word2(4115H, 6); (* MOV 6(SP), R5; R5 <- source *)
Word1(9306H); (* CMP #0, R6 *)
Word1(3800H + 6); (* JL L1 *)
Word1(2400H + 5); (* JZ L1 *)
(* L2: *)
Word2(45F7H, 0); (* MOV.B @R5+, 0(R7) *)
Word1(5317H); (* ADD #1, R7 *)
Word1(8316H); (* SUB #1, R6 *)
Word1(2000H + 400H - 5); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _arrcpy (base_size, len_dst, dst, len_src, src: INTEGER) *)
IF rtl[_arrcpy].used THEN
Label(rtl[_arrcpy].label);
Word3(9191H, 8, 4); (* CMP 8(SP), 4(SP) *)
Word1(3800H + 18); (* JL L1 *)
Word2(1211H, 12); (* PUSH 12(SP) *)
Word2(1211H, 10); (* PUSH 10(SP) *)
Word2(1211H, 14); (* PUSH 14(SP) *)
Word2(1211H, 10); (* PUSH 10(SP) *)
Call(rtl[_mul].label); (* CALL _mul *)
Word1(5221H); (* ADD #4, SP *)
Word1(1204H); (* PUSH R4 *)
Call(rtl[_move].label); (* CALL _move *)
Word2(5031H, 6); (* ADD #6, SP *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4130H); (* RET *)
(* L1 *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H) (* RET *)
END;
(* _length (len, str: INTEGER): INTEGER *)
IF rtl[_length].used THEN
Label(rtl[_length].label);
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- len *)
Word2(4117H, 4); (* MOV 4(SP), R7; R7 <- str *)
Word1(4304H); (* MOV #0, R4; res := 0 *)
(* L2: *)
Word1(4775H); (* MOV.B @R7+, R5 *)
Word1(9305H); (* CMP #0, R5 *)
Word1(2400H + 3); (* JZ L1 *)
Word1(5314H); (* ADD #1, R4 *)
Word1(8316H); (* SUB #1, R6 *)
Word1(2000H + 400H - 6); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _strcmp (op, len2, str2, len1, str1: INTEGER): BOOLEAN *)
IF rtl[_strcmp].used THEN
Label(rtl[_strcmp].label);
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- len2 *)
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- len1 *)
Word1(9607H); (* CMP R6, R7 *)
Word1(3400H + 1); (* JGE L5 *)
Word1(4706H); (* MOV R7, R6 *)
(* L5: *)
Word1(1206H); (* PUSH R6 *)
Word2(4116H, 12); (* MOV 12(SP), R6; R6 <- str1 *)
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- str2 *)
(* L3: *)
Word2(9381H, 0); (* CMP #0, 0(SP) *)
Word1(2400H + 11); (* JZ L1 *)
Word1(4674H); (* MOV.B @R6+, R4 *)
Word1(4775H); (* MOV.B @R7+, R5 *)
Word2(8391H, 0); (* SUB #1, 0(SP) *)
Word1(9405H); (* CMP R4, R5 *)
Word1(2400H + 2); (* JZ L2 *)
Word1(8504H); (* SUB R5, R4 *)
Word1(3C00H + 5); (* JMP L4 *)
(* L2: *)
Word1(9304H); (* CMP #0, R4 *)
Word1(2000H + 400H - 13); (* JNZ L3 *)
Word1(3C00H + 2); (* JMP L4 *)
(* L1: *)
Word2(4034H, 8000H); (* MOV #8000H, R4 *)
(* L4: *)
Word1(5321H); (* ADD #2, SP *)
Word2(9034H, 8000H); (* CMP #8000H, R4 *)
Word1(2000H + 18); (* JNZ L6 *)
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- len2 *)
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- len1 *)
Word1(9607H); (* CMP R6, R7 *)
Word1(2400H + 11); (* JZ L7 *)
Word1(3800H + 4); (* JL L8 *)
Word2(5116H, 10); (* ADD 10(SP), R6 *)
Word1(4664H); (* MOV.B @R6, R4 *)
Word1(3C00H + 7); (* JMP L6 *)
(* L8: *)
Word2(5117H, 6); (* ADD 6(SP), R7 *)
Word1(4764H); (* MOV.B @R7, R4 *)
Word1(0E334H); (* XOR #-1, R4 *)
Word1(5314H); (* ADD #1, R4 *)
Word1(3C00H + 1); (* JMP L6 *)
(* L7: *)
Word1(4304H); (* MOV #0, R4 *)
(* L6: *)
Word2(5110H, 2); (* ADD 2(SP), PC; PC <- PC + op *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(2400H + 1); (* JZ L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(4303H); (* NOP *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(2000H + 1); (* JNZ L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(4303H); (* NOP *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(3800H + 1); (* JL L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(4303H); (* NOP *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(3800H + 2); (* JL L *)
Word1(2400H + 1); (* JZ L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4304H); (* MOV #0, R4 *)
Word1(3800H + 2); (* JL L *)
Word1(2400H + 1); (* JZ L *)
Word1(4314H); (* MOV #1, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(3400H + 1); (* JGE L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H) (* RET *)
END
END Gen;
PROCEDURE Set* (idx, label: INTEGER);
BEGIN
rtl[idx].label := label;
rtl[idx].used := FALSE
END Set;
PROCEDURE Used* (idx: INTEGER);
BEGIN
rtl[idx].used := TRUE;
IF (idx = _guard) OR (idx = _is) THEN
rtl[_guardrec].used := TRUE
ELSIF idx = _arrcpy THEN
rtl[_move].used := TRUE;
rtl[_mul].used := TRUE
END
END Used;
PROCEDURE Init* (pLabel, pWord, pCall: EMITPROC);
BEGIN
Label := pLabel;
Word := pWord;
Call := pCall;
ram := 200H;
END Init;
END MSP430RTL.

/programs/develop/oberon07/source/PARS.ob07
0,0 → 1,1375
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE PARS;
IMPORT PROG, SCAN, ARITH, STRINGS, ERRORS, LISTS, IL, CONSOLE, PATHS, UTILS,
C := COLLECTIONS, TARGETS, THUMB, MSP430;
CONST
eCONST* = 1; eTYPE* = 2; eVAR* = 3; eEXPR* = 4;
eVREC* = 5; ePROC* = 6; eVPAR* = 7; ePARAM* = 8;
eSTPROC* = 9; eSTFUNC* = 10; eSYSFUNC* = 11; eSYSPROC* = 12;
eIMP* = 13;
TYPE
PATH* = PATHS.PATH;
PARSER* = POINTER TO rPARSER;
POSITION* = RECORD (SCAN.POSITION)
parser*: PARSER
END;
EXPR* = RECORD
obj*: INTEGER;
_type*: PROG._TYPE;
value*: ARITH.VALUE;
stproc*: INTEGER;
readOnly*: BOOLEAN;
ident*: PROG.IDENT
END;
STATPROC = PROCEDURE (parser: PARSER);
EXPRPROC = PROCEDURE (parser: PARSER; VAR e: EXPR);
RETPROC = PROCEDURE (parser: PARSER; e: EXPR; t: PROG._TYPE; pos: POSITION): BOOLEAN;
rPARSER = RECORD (C.ITEM)
fname*: PATH;
path: PATH;
lib_path: PATH;
ext: PATH;
modname: PATH;
scanner: SCAN.SCANNER;
lex*: SCAN.LEX;
sym*: INTEGER;
unit*: PROG.UNIT;
constexp*: BOOLEAN;
main*: BOOLEAN;
open*: PROCEDURE (parser: PARSER; modname, FileExt: ARRAY OF CHAR): BOOLEAN;
parse*: PROCEDURE (parser: PARSER);
StatSeq*: STATPROC;
expression*: EXPRPROC;
designator*: EXPRPROC;
chkreturn: RETPROC;
create*: PROCEDURE (path, lib_path: PATH; StatSeq: STATPROC; expression, designator: EXPRPROC; chkreturn: RETPROC): PARSER
END;
VAR
parsers: C.COLLECTION;
lines*, modules: INTEGER;
PROCEDURE destroy* (VAR parser: PARSER);
BEGIN
IF parser.scanner # NIL THEN
SCAN.close(parser.scanner)
END;
C.push(parsers, parser);
parser := NIL
END destroy;
PROCEDURE getpos (parser: PARSER; VAR pos: POSITION);
BEGIN
pos.line := parser.lex.pos.line;
pos.col := parser.lex.pos.col;
pos.parser := parser
END getpos;
PROCEDURE error* (pos: POSITION; errno: INTEGER);
BEGIN
ERRORS.ErrorMsg(pos.parser.fname, pos.line, pos.col, errno)
END error;
PROCEDURE check* (condition: BOOLEAN; pos: POSITION; errno: INTEGER);
BEGIN
IF ~condition THEN
error(pos, errno)
END
END check;
PROCEDURE check1* (condition: BOOLEAN; parser: PARSER; errno: INTEGER);
VAR
pos: POSITION;
BEGIN
IF ~condition THEN
getpos(parser, pos);
error(pos, errno)
END
END check1;
PROCEDURE Next* (parser: PARSER);
VAR
errno: INTEGER;
BEGIN
SCAN.Next(parser.scanner, parser.lex);
errno := parser.lex.error;
IF errno = 0 THEN
IF (TARGETS.RealSize = 0) & (parser.lex.sym = SCAN.lxFLOAT) THEN
errno := -SCAN.lxERROR13
ELSIF (TARGETS.BitDepth = 16) & (parser.lex.sym = SCAN.lxCHAR) & (parser.lex.value.typ = ARITH.tWCHAR) THEN
errno := -SCAN.lxERROR10
END
END;
IF errno # 0 THEN
check1(FALSE, parser, errno)
END;
parser.sym := parser.lex.sym
END Next;
PROCEDURE NextPos (parser: PARSER; VAR pos: POSITION);
BEGIN
Next(parser);
getpos(parser, pos)
END NextPos;
PROCEDURE checklex* (parser: PARSER; sym: INTEGER);
VAR
err: INTEGER;
BEGIN
IF parser.sym # sym THEN
CASE sym OF
|SCAN.lxCOMMA: err := 65
|SCAN.lxRROUND: err := 33
|SCAN.lxPOINT: err := 26
|SCAN.lxIDENT: err := 22
|SCAN.lxRSQUARE: err := 71
|SCAN.lxRCURLY: err := 35
|SCAN.lxUNDEF: err := 34
|SCAN.lxTHEN: err := 88
|SCAN.lxEND: err := 27
|SCAN.lxDO: err := 89
|SCAN.lxUNTIL: err := 90
|SCAN.lxCOLON: err := 53
|SCAN.lxOF: err := 67
|SCAN.lxASSIGN: err := 96
|SCAN.lxTO: err := 57
|SCAN.lxLROUND: err := 64
|SCAN.lxEQ: err := 32
|SCAN.lxSEMI: err := 24
|SCAN.lxRETURN: err := 38
|SCAN.lxMODULE: err := 21
END;
check1(FALSE, parser, err)
END
END checklex;
PROCEDURE ExpectSym* (parser: PARSER; sym: INTEGER);
BEGIN
Next(parser);
checklex(parser, sym)
END ExpectSym;
PROCEDURE ImportList (parser: PARSER);
VAR
fname, path, ext, _name: PATH;
name: SCAN.IDENT;
parser2: PARSER;
pos: POSITION;
alias, _in: BOOLEAN;
unit: PROG.UNIT;
ident: PROG.IDENT;
BEGIN
alias := FALSE;
REPEAT
ExpectSym(parser, SCAN.lxIDENT);
name := parser.lex.ident;
getpos(parser, pos);
IF ~alias THEN
ident := PROG.addIdent(parser.unit, name, PROG.idMODULE);
check(ident # NIL, pos, 30)
END;
Next(parser);
path := parser.path;
fname := "";
ext := UTILS.FILE_EXT;
COPY(name.s, _name);
_in := FALSE;
IF parser.sym = SCAN.lxIN THEN
_in := TRUE;
Next(parser);
IF parser.sym = SCAN.lxSTRING THEN
STRINGS.trim(parser.lex.string.s, fname)
ELSIF parser.sym = SCAN.lxCHAR THEN
fname[0] := CHR(ARITH.Int(parser.lex.value));
fname[1] := 0X
ELSE
check1(FALSE, parser, 117)
END;
STRINGS.replace(fname, "/", UTILS.slash);
STRINGS.replace(fname, "\", UTILS.slash);
PATHS.DelSlashes(fname);
PATHS.split(fname, path, _name, ext);
IF PATHS.isRelative(path) THEN
PATHS.RelPath(parser.path, path, fname);
STRINGS.append(fname, _name);
STRINGS.append(fname, ext);
PATHS.split(fname, path, _name, ext)
END;
Next(parser)
END;
IF (parser.sym = SCAN.lxCOMMA) OR (parser.sym = SCAN.lxSEMI) THEN
alias := FALSE;
IF (fname = "") & ((_name = "SYSTEM") OR PROG.LowerCase & (_name = "system")) THEN
unit := PROG.program.sysunit
ELSE
IF fname # "" THEN
unit := PROG.getUnit(fname)
ELSE
fname := path;
STRINGS.append(fname, _name);
STRINGS.append(fname, UTILS.FILE_EXT);
unit := PROG.getUnit(fname);
IF unit = NIL THEN
fname := parser.lib_path;
STRINGS.append(fname, _name);
STRINGS.append(fname, UTILS.FILE_EXT);
unit := PROG.getUnit(fname)
END
END
END;
IF unit # NIL THEN
check(unit.closed, pos, 31)
ELSE
parser2 := parser.create(path, parser.lib_path,
parser.StatSeq, parser.expression, parser.designator, parser.chkreturn);
IF ~parser2.open(parser2, _name, ext) THEN
IF (path # parser.lib_path) & ~_in THEN
destroy(parser2);
parser2 := parser.create(parser.lib_path, parser.lib_path,
parser.StatSeq, parser.expression, parser.designator, parser.chkreturn);
check(parser2.open(parser2, _name, ext), pos, 29)
ELSE
error(pos, 29)
END
END;
parser2.parse(parser2);
unit := parser2.unit;
unit.fname := parser2.fname;
destroy(parser2)
END;
IF unit = PROG.program.sysunit THEN
parser.unit.sysimport := TRUE
END;
ident.unit := unit
ELSIF parser.sym = SCAN.lxASSIGN THEN
alias := TRUE
ELSE
check1(FALSE, parser, 28)
END
UNTIL parser.sym = SCAN.lxSEMI;
Next(parser)
END ImportList;
PROCEDURE QIdent (parser: PARSER; forward: BOOLEAN): PROG.IDENT;
VAR
ident: PROG.IDENT;
unit: PROG.UNIT;
BEGIN
ASSERT(parser.sym = SCAN.lxIDENT);
ident := PROG.getIdent(parser.unit, parser.lex.ident, FALSE);
IF ~forward THEN
check1(ident # NIL, parser, 48)
END;
IF (ident # NIL) & (ident.typ = PROG.idMODULE) THEN
unit := ident.unit;
ExpectSym(parser, SCAN.lxPOINT);
ExpectSym(parser, SCAN.lxIDENT);
ident := PROG.getIdent(unit, parser.lex.ident, FALSE);
check1((ident # NIL) & ident.export, parser, 48)
END
RETURN ident
END QIdent;
PROCEDURE strcmp* (VAR v: ARITH.VALUE; v2: ARITH.VALUE; operator: INTEGER);
VAR
str: SCAN.TEXTSTR;
string1, string2: SCAN.STRING;
bool: BOOLEAN;
BEGIN
IF v.typ = ARITH.tCHAR THEN
ASSERT(v2.typ = ARITH.tSTRING);
ARITH.charToStr(v, str);
string1 := SCAN.enterStr(str);
string2 := v2.string(SCAN.STRING)
END;
IF v2.typ = ARITH.tCHAR THEN
ASSERT(v.typ = ARITH.tSTRING);
ARITH.charToStr(v2, str);
string2 := SCAN.enterStr(str);
string1 := v.string(SCAN.STRING)
END;
IF v.typ = v2.typ THEN
string1 := v.string(SCAN.STRING);
string2 := v2.string(SCAN.STRING)
END;
CASE operator OF
|SCAN.lxEQ: bool := string1.s = string2.s
|SCAN.lxNE: bool := string1.s # string2.s
|SCAN.lxLT: bool := string1.s < string2.s
|SCAN.lxGT: bool := string1.s > string2.s
|SCAN.lxLE: bool := string1.s <= string2.s
|SCAN.lxGE: bool := string1.s >= string2.s
END;
ARITH.setbool(v, bool)
END strcmp;
PROCEDURE ConstExpression* (parser: PARSER; VAR v: ARITH.VALUE);
VAR
e: EXPR;
pos: POSITION;
BEGIN
getpos(parser, pos);
parser.constexp := TRUE;
parser.expression(parser, e);
parser.constexp := FALSE;
check(e.obj = eCONST, pos, 62);
v := e.value
END ConstExpression;
PROCEDURE FieldList (parser: PARSER; rec: PROG._TYPE);
VAR
name: SCAN.IDENT;
export: BOOLEAN;
pos: POSITION;
BEGIN
ASSERT(parser.sym = SCAN.lxIDENT);
WHILE parser.sym = SCAN.lxIDENT DO
getpos(parser, pos);
name := parser.lex.ident;
Next(parser);
export := parser.sym = SCAN.lxMUL;
IF export THEN
check1(parser.unit.scopeLvl = 0, parser, 61);
Next(parser)
END;
check(PROG.addField(rec, name, export), pos, 30);
IF parser.sym = SCAN.lxCOMMA THEN
ExpectSym(parser, SCAN.lxIDENT)
ELSE
checklex(parser, SCAN.lxCOLON)
END
END
END FieldList;
PROCEDURE FormalParameters (parser: PARSER; _type: PROG._TYPE);
VAR
ident: PROG.IDENT;
PROCEDURE FPSection (parser: PARSER; _type: PROG._TYPE);
VAR
ident: PROG.IDENT;
exit: BOOLEAN;
vPar: BOOLEAN;
dim: INTEGER;
t0, t1: PROG._TYPE;
BEGIN
vPar := parser.sym = SCAN.lxVAR;
IF vPar THEN
Next(parser)
END;
checklex(parser, SCAN.lxIDENT);
exit := FALSE;
WHILE (parser.sym = SCAN.lxIDENT) & ~exit DO
check1(PROG.addParam(_type, parser.lex.ident, vPar), parser, 30);
Next(parser);
IF parser.sym = SCAN.lxCOMMA THEN
ExpectSym(parser, SCAN.lxIDENT)
ELSIF parser.sym = SCAN.lxCOLON THEN
Next(parser);
dim := 0;
WHILE parser.sym = SCAN.lxARRAY DO
INC(dim);
check1(dim <= PROG.MAXARRDIM, parser, 84);
ExpectSym(parser, SCAN.lxOF);
Next(parser)
END;
checklex(parser, SCAN.lxIDENT);
ident := QIdent(parser, FALSE);
check1(ident.typ = PROG.idTYPE, parser, 68);
t0 := ident._type;
t1 := t0;
WHILE dim > 0 DO
t1 := PROG.enterType(PROG.tARRAY, -1, 0, parser.unit);
t1.base := t0;
t0 := t1;
DEC(dim)
END;
PROG.setParams(_type, t1);
Next(parser);
exit := TRUE
ELSE
checklex(parser, SCAN.lxCOLON)
END
END
END FPSection;
BEGIN
IF parser.sym = SCAN.lxLROUND THEN
Next(parser);
IF (parser.sym = SCAN.lxVAR) OR (parser.sym = SCAN.lxIDENT) THEN
FPSection(parser, _type);
WHILE parser.sym = SCAN.lxSEMI DO
Next(parser);
FPSection(parser, _type)
END
END;
checklex(parser, SCAN.lxRROUND);
Next(parser);
IF parser.sym = SCAN.lxCOLON THEN
ExpectSym(parser, SCAN.lxIDENT);
ident := QIdent(parser, FALSE);
check1(ident.typ = PROG.idTYPE, parser, 68);
check1(~(ident._type.typ IN {PROG.tRECORD, PROG.tARRAY}), parser, 69);
check1( ~(ODD(_type.call) & (ident._type.typ = PROG.tREAL)), parser, 113);
_type.base := ident._type;
Next(parser)
ELSE
_type.base := NIL
END
END
END FormalParameters;
PROCEDURE sysflag (parser: PARSER; proc: BOOLEAN): INTEGER;
VAR
res, sf: INTEGER;
BEGIN
checklex(parser, SCAN.lxIDENT);
IF parser.lex.ident.s = "stdcall" THEN
sf := PROG.sf_stdcall
ELSIF parser.lex.ident.s = "cdecl" THEN
sf := PROG.sf_cdecl
ELSIF parser.lex.ident.s = "ccall" THEN
sf := PROG.sf_ccall
ELSIF parser.lex.ident.s = "win64" THEN
sf := PROG.sf_win64
ELSIF parser.lex.ident.s = "systemv" THEN
sf := PROG.sf_systemv
ELSIF parser.lex.ident.s = "windows" THEN
sf := PROG.sf_windows
ELSIF parser.lex.ident.s = "linux" THEN
sf := PROG.sf_linux
ELSIF parser.lex.ident.s = "code" THEN
sf := PROG.sf_code
ELSIF parser.lex.ident.s = "oberon" THEN
sf := PROG.sf_oberon
ELSIF parser.lex.ident.s = "noalign" THEN
sf := PROG.sf_noalign
ELSE
check1(FALSE, parser, 124)
END;
check1(sf IN PROG.program.sysflags, parser, 125);
IF proc THEN
check1(sf IN PROG.proc_flags, parser, 123)
ELSE
check1(sf IN PROG.rec_flags, parser, 123)
END;
CASE sf OF
|PROG.sf_stdcall:
res := PROG.stdcall
|PROG.sf_cdecl:
res := PROG.cdecl
|PROG.sf_ccall:
IF TARGETS.OS IN {TARGETS.osWIN32, TARGETS.osLINUX32, TARGETS.osKOS} THEN
res := PROG.ccall
ELSIF TARGETS.OS = TARGETS.osWIN64 THEN
res := PROG.win64
ELSIF TARGETS.OS = TARGETS.osLINUX64 THEN
res := PROG.systemv
END
|PROG.sf_win64:
res := PROG.win64
|PROG.sf_systemv:
res := PROG.systemv
|PROG.sf_code:
res := PROG.code
|PROG.sf_oberon:
IF TARGETS.OS IN {TARGETS.osWIN32, TARGETS.osLINUX32, TARGETS.osKOS} THEN
res := PROG.default32
ELSIF TARGETS.OS IN {TARGETS.osWIN64, TARGETS.osLINUX64} THEN
res := PROG.default64
END
|PROG.sf_windows:
IF TARGETS.OS = TARGETS.osWIN32 THEN
res := PROG.stdcall
ELSIF TARGETS.OS = TARGETS.osWIN64 THEN
res := PROG.win64
END
|PROG.sf_linux:
IF TARGETS.OS = TARGETS.osLINUX32 THEN
res := PROG.ccall
ELSIF TARGETS.OS = TARGETS.osLINUX64 THEN
res := PROG.systemv
END
|PROG.sf_noalign:
res := PROG.noalign
END
RETURN res
END sysflag;
PROCEDURE procflag (parser: PARSER; VAR _import: IL.IMPORT_PROC; isProc: BOOLEAN): INTEGER;
VAR
call: INTEGER;
dll, proc: SCAN.TEXTSTR;
pos: POSITION;
PROCEDURE getStr (parser: PARSER; VAR name: SCAN.TEXTSTR);
VAR
pos: POSITION;
str: ARITH.VALUE;
BEGIN
getpos(parser, pos);
ConstExpression(parser, str);
IF str.typ = ARITH.tSTRING THEN
name := str.string(SCAN.STRING).s
ELSIF str.typ = ARITH.tCHAR THEN
ARITH.charToStr(str, name)
ELSE
check(FALSE, pos, 117)
END
END getStr;
BEGIN
_import := NIL;
IF parser.sym = SCAN.lxLSQUARE THEN
getpos(parser, pos);
check1(parser.unit.sysimport, parser, 54);
Next(parser);
call := sysflag(parser, TRUE);
Next(parser);
IF parser.sym = SCAN.lxMINUS THEN
Next(parser);
INC(call)
END;
IF isProc & (parser.sym = SCAN.lxCOMMA) THEN
Next(parser);
getStr(parser, dll);
STRINGS.UpCase(dll);
checklex(parser, SCAN.lxCOMMA);
Next(parser);
getStr(parser, proc);
_import := IL.AddImp(dll, proc)
END;
checklex(parser, SCAN.lxRSQUARE);
Next(parser)
ELSE
CASE TARGETS.BitDepth OF
|16: call := PROG.default16
|32: IF TARGETS.CPU = TARGETS.cpuX86 THEN
call := PROG.default32
ELSE
call := PROG.cdecl
END
|64: IF TARGETS.CPU = TARGETS.cpuAMD64 THEN
call := PROG.default64
ELSE
call := PROG.cdecl
END
END
END;
IF _import # NIL THEN
check(TARGETS.Import, pos, 70)
END
RETURN call
END procflag;
PROCEDURE _type (parser: PARSER; VAR t: PROG._TYPE; flags: SET);
CONST
comma = 0;
closed = 1;
forward = 2;
VAR
arrLen: ARITH.VALUE;
typeSize: ARITH.VALUE;
ident: PROG.IDENT;
unit: PROG.UNIT;
pos, pos2: POSITION;
fieldType: PROG._TYPE;
baseIdent: SCAN.IDENT;
a, b: INTEGER;
RecFlag: INTEGER;
_import: IL.IMPORT_PROC;
BEGIN
unit := parser.unit;
t := NIL;
IF parser.sym = SCAN.lxIDENT THEN
ident := QIdent(parser, forward IN flags);
IF ident # NIL THEN
check1(ident.typ = PROG.idTYPE, parser, 49);
t := ident._type;
check1(t # NIL, parser, 50);
IF closed IN flags THEN
check1(t.closed, parser, 50)
END
END;
Next(parser)
ELSIF (parser.sym = SCAN.lxARRAY) OR ((parser.sym = SCAN.lxCOMMA) & (comma IN flags)) THEN
IF parser.sym = SCAN.lxARRAY THEN
getpos(parser, pos2)
END;
NextPos(parser, pos);
ConstExpression(parser, arrLen);
check(arrLen.typ = ARITH.tINTEGER, pos, 43);
check(ARITH.check(arrLen), pos, 39);
check(ARITH.getInt(arrLen) > 0, pos, 51);
t := PROG.enterType(PROG.tARRAY, -1, ARITH.getInt(arrLen), unit);
IF parser.sym = SCAN.lxCOMMA THEN
_type(parser, t.base, {comma, closed})
ELSIF parser.sym = SCAN.lxOF THEN
Next(parser);
_type(parser, t.base, {closed})
ELSE
check1(FALSE, parser, 47)
END;
t.align := t.base.align;
a := t.length;
b := t.base.size;
check(ARITH.mulInt(a, b), pos2, 104);
check(ARITH.setInt(typeSize, a), pos2, 104);
t.size := a;
t.closed := TRUE
ELSIF parser.sym = SCAN.lxRECORD THEN
getpos(parser, pos2);
Next(parser);
t := PROG.enterType(PROG.tRECORD, 0, 0, unit);
t.align := 1;
IF parser.sym = SCAN.lxLSQUARE THEN
check1(parser.unit.sysimport, parser, 54);
Next(parser);
RecFlag := sysflag(parser, FALSE);
t.noalign := RecFlag = PROG.noalign;
ExpectSym(parser, SCAN.lxRSQUARE);
Next(parser)
END;
IF parser.sym = SCAN.lxLROUND THEN
check1(~t.noalign, parser, 111);
ExpectSym(parser, SCAN.lxIDENT);
getpos(parser, pos);
_type(parser, t.base, {closed});
check(t.base.typ IN {PROG.tRECORD, PROG.tPOINTER}, pos, 52);
IF t.base.typ = PROG.tPOINTER THEN
t.base := t.base.base;
check(t.base # NIL, pos, 55)
END;
check(~t.base.noalign, pos, 112);
checklex(parser, SCAN.lxRROUND);
Next(parser);
t.size := t.base.size;
IF t.base.align > t.align THEN
t.align := t.base.align
END
ELSE
t.base := PROG.program.stTypes.tANYREC
END;
WHILE parser.sym = SCAN.lxIDENT DO
FieldList(parser, t);
ASSERT(parser.sym = SCAN.lxCOLON);
Next(parser);
_type(parser, fieldType, {closed});
check(PROG.setFields(t, fieldType), pos2, 104);
IF (fieldType.align > t.align) & ~t.noalign THEN
t.align := fieldType.align
END;
IF parser.sym = SCAN.lxSEMI THEN
ExpectSym(parser, SCAN.lxIDENT)
ELSE
checklex(parser, SCAN.lxEND)
END
END;
t.closed := TRUE;
IL.AddRec(t.base.num);
IF ~t.noalign THEN
check(UTILS.Align(t.size, t.align), pos2, 104);
check(ARITH.setInt(typeSize, t.size), pos2, 104)
END;
checklex(parser, SCAN.lxEND);
Next(parser)
ELSIF parser.sym = SCAN.lxPOINTER THEN
ExpectSym(parser, SCAN.lxTO);
Next(parser);
t := PROG.enterType(PROG.tPOINTER, TARGETS.AdrSize, 0, unit);
t.align := TARGETS.AdrSize;
getpos(parser, pos);
IF parser.sym = SCAN.lxIDENT THEN
baseIdent := parser.lex.ident
END;
_type(parser, t.base, {forward});
IF t.base # NIL THEN
check(t.base.typ = PROG.tRECORD, pos, 58)
ELSE
PROG.frwPtr(unit, t, baseIdent, pos)
END
ELSIF parser.sym = SCAN.lxPROCEDURE THEN
NextPos(parser, pos);
t := PROG.enterType(PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit);
t.align := TARGETS.AdrSize;
t.call := procflag(parser, _import, FALSE);
FormalParameters(parser, t)
ELSE
check1(FALSE, parser, 49)
END
END _type;
PROCEDURE IdentDef (parser: PARSER; typ: INTEGER; VAR name: SCAN.IDENT): PROG.IDENT;
VAR
ident: PROG.IDENT;
pos: POSITION;
BEGIN
ASSERT(parser.sym = SCAN.lxIDENT);
name := parser.lex.ident;
getpos(parser, pos);
ident := PROG.addIdent(parser.unit, name, typ);
check(ident # NIL, pos, 30);
ident.pos := pos;
Next(parser);
IF parser.sym = SCAN.lxMUL THEN
check1(ident.global, parser, 61);
ident.export := TRUE;
Next(parser)
END
RETURN ident
END IdentDef;
PROCEDURE ConstTypeDeclaration (parser: PARSER; _const: BOOLEAN);
VAR
ident: PROG.IDENT;
name: SCAN.IDENT;
pos: POSITION;
BEGIN
IF _const THEN
ident := IdentDef(parser, PROG.idNONE, name)
ELSE
ident := IdentDef(parser, PROG.idTYPE, name)
END;
checklex(parser, SCAN.lxEQ);
NextPos(parser, pos);
IF _const THEN
ConstExpression(parser, ident.value);
IF ident.value.typ = ARITH.tINTEGER THEN
check(ARITH.check(ident.value), pos, 39)
ELSIF ident.value.typ = ARITH.tREAL THEN
check(ARITH.check(ident.value), pos, 40)
END;
ident.typ := PROG.idCONST;
ident._type := PROG.getType(ident.value.typ)
ELSE
_type(parser, ident._type, {})
END;
checklex(parser, SCAN.lxSEMI);
Next(parser)
END ConstTypeDeclaration;
PROCEDURE VarDeclaration (parser: PARSER);
VAR
ident: PROG.IDENT;
name: SCAN.IDENT;
t: PROG._TYPE;
BEGIN
REPEAT
ident := IdentDef(parser, PROG.idVAR, name);
IF parser.sym = SCAN.lxCOMMA THEN
ExpectSym(parser, SCAN.lxIDENT)
ELSIF parser.sym = SCAN.lxCOLON THEN
Next(parser);
_type(parser, t, {});
PROG.setVarsType(parser.unit, t);
checklex(parser, SCAN.lxSEMI);
Next(parser)
ELSE
checklex(parser, SCAN.lxCOLON)
END
UNTIL parser.sym # SCAN.lxIDENT
END VarDeclaration;
PROCEDURE DeclarationSequence (parser: PARSER): BOOLEAN;
VAR
ptr: PROG.FRWPTR;
endmod: BOOLEAN;
pos: POSITION;
PROCEDURE ProcDeclaration (parser: PARSER): BOOLEAN;
VAR
proc: PROG.IDENT;
endname,
name: SCAN.IDENT;
param: PROG.PARAM;
unit: PROG.UNIT;
ident: PROG.IDENT;
e: EXPR;
pos, pos1,
pos2: POSITION;
label: INTEGER;
enter: IL.COMMAND;
call: INTEGER;
t: PROG._TYPE;
_import: IL.IMPORT_PROC;
endmod, b: BOOLEAN;
fparams: SET;
int, flt: INTEGER;
comma: BOOLEAN;
code, iv: ARITH.VALUE;
codeProc,
handler: BOOLEAN;
line: INTEGER;
BEGIN
endmod := FALSE;
handler := FALSE;
unit := parser.unit;
call := procflag(parser, _import, TRUE);
getpos(parser, pos);
pos1 := pos;
checklex(parser, SCAN.lxIDENT);
line := pos.line;
IF _import # NIL THEN
proc := IdentDef(parser, PROG.idIMP, name);
proc._import := _import;
IF _import.name = "" THEN
COPY(name.s, _import.name)
END;
PROG.program.procs.last(PROG.PROC)._import := _import
ELSE
proc := IdentDef(parser, PROG.idPROC, name)
END;
check(PROG.openScope(unit, proc.proc), pos, 116);
proc._type := PROG.enterType(PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit);
t := proc._type;
t.align := TARGETS.AdrSize;
t.call := call;
FormalParameters(parser, t);
IF parser.sym = SCAN.lxLSQUARE THEN
getpos(parser, pos2);
check((TARGETS.CPU = TARGETS.cpuTHUMB) & (TARGETS.OS = TARGETS.osNONE), pos2, 24);
Next(parser);
getpos(parser, pos2);
ConstExpression(parser, iv);
check(iv.typ = ARITH.tINTEGER, pos2, 43);
check((0 <= ARITH.Int(iv)) & (ARITH.Int(iv) <= THUMB.maxIVT), pos2, 46);
check(THUMB.SetIV(ARITH.Int(iv)), pos2, 121);
checklex(parser, SCAN.lxRSQUARE);
Next(parser);
handler := TRUE
END;
codeProc := call IN {PROG.code, PROG._code};
IF call IN {PROG.systemv, PROG._systemv} THEN
check(t.parSize <= PROG.MAXSYSVPARAM, pos, 120)
END;
param := t.params.first(PROG.PARAM);
WHILE param # NIL DO
ident := PROG.addIdent(unit, param.name, PROG.idPARAM);
ASSERT(ident # NIL);
ident._type := param._type;
ident.offset := param.offset;
IF param.vPar THEN
ident.typ := PROG.idVPAR
END;
param := param.next(PROG.PARAM)
END;
IF _import = NIL THEN
label := IL.NewLabel();
proc.proc.label := label;
proc.proc.used := handler;
IF handler THEN
IL.AddCmd2(IL.opHANDLER, label, ARITH.Int(iv))
END
END;
IF codeProc THEN
enter := IL.EnterC(label);
comma := FALSE;
WHILE (parser.sym # SCAN.lxSEMI) OR comma DO
getpos(parser, pos2);
ConstExpression(parser, code);
check(code.typ = ARITH.tINTEGER, pos2, 43);
IF TARGETS.WordSize > TARGETS.InstrSize THEN
CASE TARGETS.InstrSize OF
|1: check(ARITH.range(code, 0, 255), pos, 42)
|2: check(ARITH.range(code, 0, 65535), pos, 110)
END
END;
IL.AddCmd(IL.opCODE, ARITH.getInt(code));
comma := parser.sym = SCAN.lxCOMMA;
IF comma THEN
Next(parser)
ELSE
checklex(parser, SCAN.lxSEMI)
END
END
END;
checklex(parser, SCAN.lxSEMI);
Next(parser);
IF _import = NIL THEN
IF parser.main & proc.export & TARGETS.Dll THEN
IF TARGETS.target = TARGETS.KolibriOSDLL THEN
check((proc.name.s # "lib_init") & (proc.name.s # "version"), pos, 114)
END;
IL.AddExp(label, proc.name.s);
proc.proc.used := TRUE
END;
IF ~codeProc THEN
b := DeclarationSequence(parser)
END;
PROG.ResetLocSize;
IF call IN {PROG._win64, PROG.win64} THEN
fparams := PROG.getFloatParamsPos(proc._type, 3, int, flt);
enter := IL.Enter(label, LSL(ORD(fparams), 5) + MIN(proc._type.parSize, 4))
ELSIF call IN {PROG._systemv, PROG.systemv} THEN
fparams := PROG.getFloatParamsPos(proc._type, PROG.MAXSYSVPARAM - 1, int, flt);
enter := IL.Enter(label, -(LSL(ORD(fparams), 5) + proc._type.parSize))
ELSIF codeProc THEN
ELSE
enter := IL.Enter(label, 0)
END;
proc.proc.enter := enter;
IF ~codeProc & (parser.sym = SCAN.lxBEGIN) THEN
Next(parser);
parser.StatSeq(parser)
END;
IF ~codeProc & (t.base # NIL) THEN
checklex(parser, SCAN.lxRETURN);
NextPos(parser, pos);
parser.expression(parser, e);
check(parser.chkreturn(parser, e, t.base, pos), pos, 87)
END;
IF ~codeProc THEN
proc.proc.leave := IL.Leave(t.base # NIL, (t.base # NIL) & (t.base.typ = PROG.tREAL), PROG.program.locsize,
t.parSize * ORD((t.call IN PROG.callee_clean_up) OR (t.call IN {PROG.systemv, PROG._systemv})));
enter.param2 := PROG.program.locsize;
checklex(parser, SCAN.lxEND)
ELSE
proc.proc.leave := IL.LeaveC()
END;
IF (TARGETS.CPU = TARGETS.cpuMSP430) & ~codeProc THEN
check(MSP430.CheckProcDataSize(enter.param2 + proc._type.parSize, PROG.program.options.ram), pos1, 63);
enter.param2 := enter.param2 * 65536 + line;
enter.param3 := IL.codes.errlabels[10]
END
END;
IF parser.sym = SCAN.lxEND THEN
Next(parser);
IF parser.sym = SCAN.lxIDENT THEN
getpos(parser, pos);
endname := parser.lex.ident;
IF ~codeProc & (_import = NIL) THEN
check(PROG.IdEq(endname, name), pos, 60);
ExpectSym(parser, SCAN.lxSEMI);
Next(parser)
ELSE
IF PROG.IdEq(endname, parser.unit.name) THEN
ExpectSym(parser, SCAN.lxPOINT);
Next(parser);
endmod := TRUE
ELSIF PROG.IdEq(endname, name) THEN
ExpectSym(parser, SCAN.lxSEMI);
Next(parser)
ELSE
error(pos, 60)
END
END
ELSIF parser.sym = SCAN.lxSEMI THEN
Next(parser)
ELSE
checklex(parser, SCAN.lxIDENT)
END
END;
PROG.closeScope(unit);
RETURN endmod
END ProcDeclaration;
BEGIN
IF parser.sym = SCAN.lxCONST THEN
Next(parser);
WHILE parser.sym = SCAN.lxIDENT DO
ConstTypeDeclaration(parser, TRUE)
END
END;
IF parser.sym = SCAN.lxTYPE THEN
Next(parser);
WHILE parser.sym = SCAN.lxIDENT DO
ConstTypeDeclaration(parser, FALSE)
END
END;
ptr := PROG.linkPtr(parser.unit);
IF ptr # NIL THEN
pos.line := ptr.pos.line;
pos.col := ptr.pos.col;
pos.parser := parser;
IF ptr.notRecord THEN
error(pos, 58)
ELSE
error(pos, 48)
END
END;
IF parser.sym = SCAN.lxVAR THEN
Next(parser);
IF parser.sym = SCAN.lxIDENT THEN
VarDeclaration(parser)
END
END;
endmod := FALSE;
WHILE ~endmod & (parser.sym = SCAN.lxPROCEDURE) DO
Next(parser);
endmod := ProcDeclaration(parser)
END
RETURN endmod
END DeclarationSequence;
PROCEDURE parse (parser: PARSER);
VAR
unit: PROG.UNIT;
label: INTEGER;
name: INTEGER;
endmod: BOOLEAN;
errlabel: INTEGER;
errno: INTEGER;
BEGIN
ASSERT(parser # NIL);
ASSERT(parser.scanner # NIL);
ExpectSym(parser, SCAN.lxMODULE);
ExpectSym(parser, SCAN.lxIDENT);
IF ~parser.main THEN
check1(parser.lex.ident.s = parser.modname, parser, 23)
END;
unit := PROG.newUnit(parser.lex.ident);
unit.fname := parser.fname;
parser.unit := unit;
ExpectSym(parser, SCAN.lxSEMI);
Next(parser);
IF parser.sym = SCAN.lxIMPORT THEN
ImportList(parser)
END;
INC(modules);
CONSOLE.String("compiling ");
CONSOLE.String("("); CONSOLE.Int(modules); CONSOLE.String(") ");
CONSOLE.String(unit.name.s);
IF parser.unit.sysimport THEN
CONSOLE.String(" (SYSTEM)")
END;
CONSOLE.Ln;
IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
IL.fname(parser.fname)
END;
label := IL.NewLabel();
IL.Jmp(IL.opJMP, label);
name := IL.putstr(unit.name.s);
errlabel := IL.NewLabel();
IL.SetLabel(errlabel);
IL.StrAdr(name);
IL.Param1;
IL.AddCmd(IL.opPUSHC, modules);
IL.AddCmd0(IL.opERR);
FOR errno := 1 TO LEN(IL.codes.errlabels) - 1 DO
IL.SetErrLabel(errno);
IL.AddCmd(IL.opPUSHC, errno);
IL.Jmp(IL.opJMP, errlabel)
END;
endmod := DeclarationSequence(parser);
IL.SetLabel(label);
IF ~endmod THEN
IF parser.sym = SCAN.lxBEGIN THEN
Next(parser);
parser.StatSeq(parser)
END;
checklex(parser, SCAN.lxEND);
ExpectSym(parser, SCAN.lxIDENT);
check1(parser.lex.ident.s = unit.name.s, parser, 25);
ExpectSym(parser, SCAN.lxPOINT)
END;
INC(lines, parser.lex.pos.line);
PROG.closeUnit(unit)
END parse;
PROCEDURE open (parser: PARSER; modname, FileExt: ARRAY OF CHAR): BOOLEAN;
BEGIN
ASSERT(parser # NIL);
STRINGS.append(parser.fname, modname);
STRINGS.append(parser.fname, FileExt);
STRINGS.append(parser.modname, modname);
parser.scanner := SCAN.open(parser.fname)
RETURN parser.scanner # NIL
END open;
PROCEDURE NewParser (): PARSER;
VAR
pars: PARSER;
citem: C.ITEM;
BEGIN
citem := C.pop(parsers);
IF citem = NIL THEN
NEW(pars)
ELSE
pars := citem(PARSER)
END
RETURN pars
END NewParser;
PROCEDURE create* (path, lib_path: PATH; StatSeq: STATPROC; expression, designator: EXPRPROC; chkreturn: RETPROC): PARSER;
VAR
parser: PARSER;
BEGIN
parser := NewParser();
parser.path := path;
parser.lib_path := lib_path;
parser.ext := UTILS.FILE_EXT;
parser.fname := path;
parser.modname := "";
parser.scanner := NIL;
parser.unit := NIL;
parser.constexp := FALSE;
parser.main := FALSE;
parser.open := open;
parser.parse := parse;
parser.StatSeq := StatSeq;
parser.expression := expression;
parser.designator := designator;
parser.chkreturn := chkreturn;
parser.create := create
RETURN parser
END create;
PROCEDURE init* (options: PROG.OPTIONS);
BEGIN
PROG.create(options);
parsers := C.create();
lines := 0;
modules := 0
END init;
END PARS.

/programs/develop/oberon07/source/PATHS.ob07
0,0 → 1,151
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE PATHS;
IMPORT STRINGS, UTILS;
CONST
slash = UTILS.slash;
PATHLEN = 2048;
TYPE
PATH* = ARRAY PATHLEN OF CHAR;
PROCEDURE split* (fname: ARRAY OF CHAR; VAR path, name, ext: ARRAY OF CHAR);
VAR
pos1, pos2, len: INTEGER;
BEGIN
len := LENGTH(fname);
pos1 := len - 1;
pos2 := pos1;
STRINGS.search(fname, pos1, slash, FALSE);
STRINGS.search(fname, pos2, ".", FALSE);
path := fname;
path[pos1 + 1] := 0X;
IF (pos2 = -1) OR (pos2 < pos1) THEN
pos2 := len
END;
INC(pos1);
STRINGS.copy(fname, name, pos1, 0, pos2 - pos1);
name[pos2 - pos1] := 0X;
STRINGS.copy(fname, ext, pos2, 0, len - pos2);
ext[len - pos2] := 0X
END split;
PROCEDURE RelPath* (absolute, relative: ARRAY OF CHAR; VAR res: ARRAY OF CHAR);
VAR
i, j: INTEGER;
error: BOOLEAN;
BEGIN
COPY(absolute, res);
i := LENGTH(res) - 1;
WHILE (i >= 0) & (res[i] # slash) DO
DEC(i)
END;
INC(i);
res[i] := 0X;
error := FALSE;
j := 0;
WHILE (relative[j] = ".") & (relative[j + 1] = slash) DO
INC(j, 2)
ELSIF relative[j] = slash DO
INC(j)
END;
WHILE ~error & (relative[j] # 0X) DO
IF (relative[j] = ".") & (relative[j + 1] = ".") & (relative[j + 2] = slash) & (i > 0) & (res[i - 1] = slash) THEN
DEC(i, 2);
WHILE (i >= 0) & (res[i] # slash) DO
DEC(i)
END;
IF i < 0 THEN
error := TRUE
ELSE
INC(i);
INC(j, 3)
END
ELSE
res[i] := relative[j];
INC(i);
INC(j)
END
END;
IF error THEN
COPY(relative, res)
ELSE
res[i] := 0X
END
END RelPath;
PROCEDURE DelSlashes* (VAR path: ARRAY OF CHAR);
VAR
i, j, k: INTEGER;
c: CHAR;
BEGIN
i := 0;
j := 0;
k := 0;
REPEAT
c := path[j];
INC(j);
IF c = slash THEN
INC(k)
ELSE
k := 0
END;
IF k <= 1 THEN
path[i] := c;
INC(i)
END
UNTIL c = 0X;
i := 0;
j := 0;
REPEAT
c := path[j];
INC(j);
path[i] := c;
INC(i);
IF (c = slash) & (path[j] = ".") & (path[j + 1] = slash) THEN
INC(j, 2)
END
UNTIL c = 0X
END DelSlashes;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN UTILS.isRelative(path)
END isRelative;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
BEGIN
UTILS.GetCurrentDirectory(path)
END GetCurrentDirectory;
END PATHS.

/programs/develop/oberon07/source/PROG.ob07
0,0 → 1,1271
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE PROG;
IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS, STRINGS, PATHS;
CONST
MAXARRDIM* = 5;
MAXSCOPE = 16;
MAXSYSVPARAM* = 26;
idNONE* = 0; idGUARD = 1; idMODULE* = 2; idCONST* = 3;
idTYPE* = 4; idSTFUNC* = 5; idSTPROC* = 6; idVAR* = 7;
idPROC* = 8; idVPAR* = 9; idPARAM* = 10; idSYSFUNC* = 11;
idSYSPROC* = 12; idIMP* = 13;
tINTEGER* = 1; tBYTE* = 2; tCHAR* = 3; tSET* = 4;
tBOOLEAN* = 5; tREAL* = 6; tARRAY* = 7; tRECORD* = 8;
tPOINTER* = 9; tPROCEDURE* = 10; tSTRING* = 11; tNIL* = 12;
tCARD32* = 13; tANYREC* = 14; tWCHAR* = 15; tNONE* = 16;
BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD32, tWCHAR};
stABS* = 1; stASR* = 2; stCHR* = 3; stFLOOR* = 4;
stFLT* = 5; stLEN* = 6; stLSL* = 7; stODD* = 8;
stORD* = 9; stROR* = 10; stASSERT* = 11; stDEC* = 12;
stEXCL* = 13; stINC* = 14; stINCL* = 15; stNEW* = 16;
stPACK* = 17; stUNPK* = 18; sysADR* = 19; sysSIZE* = 20;
sysGET* = 21; sysPUT* = 22;
stDISPOSE* = 23; stLSR* = 24; stBITS* = 25; sysCODE* = 26;
sysMOVE* = 27; stLENGTH* = 28; stMIN* = 29; stMAX* = 30;
sysSADR* = 31; sysTYPEID* = 32; sysCOPY* = 33; sysINF* = 34;
sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38;
sysWSADR* = 39; sysPUT32* = 40; (*sysNOP* = 41; sysEINT* = 42;
sysDINT* = 43;*)sysGET8* = 44; sysGET16* = 45; sysGET32* = 46;
default32* = 2; _default32* = default32 + 1;
stdcall* = 4; _stdcall* = stdcall + 1;
cdecl* = 6; _cdecl* = cdecl + 1;
ccall* = 8; _ccall* = ccall + 1;
win64* = 10; _win64* = win64 + 1;
default64* = 12; _default64* = default64 + 1;
systemv* = 14; _systemv* = systemv + 1;
default16* = 16; _default16* = default16 + 1;
code* = 18; _code* = code + 1;
noalign* = 22;
callee_clean_up* = {default32, _default32, stdcall, _stdcall, default64, _default64};
sf_stdcall* = 0; sf_oberon* = 1; sf_cdecl* = 2; sf_ccall* = 3;
sf_win64* = 4; sf_systemv* = 5; sf_windows* = 6; sf_linux* = 7;
sf_code* = 8;
sf_noalign* = 9;
proc_flags* = {sf_stdcall, sf_cdecl, sf_ccall, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code, sf_oberon};
rec_flags* = {sf_noalign};
STACK_FRAME = 2;
TYPE
OPTIONS* = RECORD
version*, stack*, ram*, rom*: INTEGER;
pic*, lower*: BOOLEAN;
checking*: SET
END;
IDENT* = POINTER TO rIDENT;
UNIT* = POINTER TO rUNIT;
_TYPE* = POINTER TO rTYPE;
FRWPTR* = POINTER TO RECORD (LISTS.ITEM)
_type: _TYPE;
baseIdent: SCAN.IDENT;
linked: BOOLEAN;
pos*: SCAN.POSITION;
notRecord*: BOOLEAN
END;
PROC* = POINTER TO RECORD (LISTS.ITEM)
label*: INTEGER;
used*: BOOLEAN;
processed*: BOOLEAN;
_import*: LISTS.ITEM;
using*: LISTS.LIST;
enter*,
leave*: LISTS.ITEM
END;
USED_PROC = POINTER TO RECORD (LISTS.ITEM)
proc: PROC
END;
rUNIT = RECORD (LISTS.ITEM)
fname*: PATHS.PATH;
name*: SCAN.IDENT;
idents*: LISTS.LIST;
frwPointers: LISTS.LIST;
gscope: IDENT;
closed*: BOOLEAN;
scopeLvl*: INTEGER;
sysimport*: BOOLEAN;
scopes*: ARRAY MAXSCOPE OF PROC
END;
FIELD* = POINTER TO rFIELD;
PARAM* = POINTER TO rPARAM;
rTYPE = RECORD (LISTS.ITEM)
typ*: INTEGER;
size*: INTEGER;
parSize*: INTEGER;
length*: INTEGER;
align*: INTEGER;
base*: _TYPE;
fields*: LISTS.LIST;
params*: LISTS.LIST;
unit*: UNIT;
closed*: BOOLEAN;
num*: INTEGER;
call*: INTEGER;
_import*: BOOLEAN;
noalign*: BOOLEAN
END;
rFIELD = RECORD (LISTS.ITEM)
_type*: _TYPE;
name*: SCAN.IDENT;
export*: BOOLEAN;
offset*: INTEGER
END;
rPARAM = RECORD (LISTS.ITEM)
name*: SCAN.IDENT;
_type*: _TYPE;
vPar*: BOOLEAN;
offset*: INTEGER
END;
rIDENT = RECORD (LISTS.ITEM)
name*: SCAN.IDENT;
typ*: INTEGER;
export*: BOOLEAN;
_import*: LISTS.ITEM;
unit*: UNIT;
value*: ARITH.VALUE;
_type*: _TYPE;
stproc*: INTEGER;
global*: BOOLEAN;
scopeLvl*: INTEGER;
offset*: INTEGER;
proc*: PROC;
pos*: SCAN.POSITION
END;
PROGRAM = RECORD
recCount: INTEGER;
units*: LISTS.LIST;
types*: LISTS.LIST;
sysunit*: UNIT;
rtl*: UNIT;
bss*: INTEGER;
locsize*: INTEGER;
procs*: LISTS.LIST;
sysflags*: SET;
options*: OPTIONS;
stTypes*: RECORD
tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*,
tSTRING*, tNIL*, tCARD32*, tANYREC*, tNONE*: _TYPE
END
END;
DELIMPORT = PROCEDURE (_import: LISTS.ITEM);
VAR
LowerCase*: BOOLEAN;
idents: C.COLLECTION;
program*: PROGRAM;
PROCEDURE NewIdent (): IDENT;
VAR
ident: IDENT;
citem: C.ITEM;
BEGIN
citem := C.pop(idents);
IF citem = NIL THEN
NEW(ident)
ELSE
ident := citem(IDENT)
END
RETURN ident
END NewIdent;
PROCEDURE getOffset* (varIdent: IDENT): INTEGER;
VAR
size: INTEGER;
BEGIN
IF varIdent.offset = -1 THEN
size := varIdent._type.size;
IF varIdent.global THEN
IF UTILS.Align(program.bss, varIdent._type.align) THEN
IF UTILS.maxint - program.bss >= size THEN
varIdent.offset := program.bss;
INC(program.bss, size)
END
END
ELSE
IF UTILS.Align(size, TARGETS.WordSize) THEN
size := size DIV TARGETS.WordSize;
IF UTILS.maxint - program.locsize >= size THEN
INC(program.locsize, size);
varIdent.offset := program.locsize
END
END
END;
IF varIdent.offset = -1 THEN
ERRORS.Error(204)
END
END
RETURN varIdent.offset
END getOffset;
PROCEDURE closeUnit* (unit: UNIT);
VAR
ident, prev: IDENT;
offset: INTEGER;
BEGIN
ident := unit.idents.last(IDENT);
WHILE (ident # NIL) & (ident.typ # idGUARD) DO
IF (ident.typ = idVAR) & (ident.offset = -1) THEN
ERRORS.HintMsg(ident.name.s, ident.pos.line, ident.pos.col, 0);
IF ident.export THEN
offset := getOffset(ident)
END
END;
ident := ident.prev(IDENT)
END;
ident := unit.idents.last(IDENT);
WHILE ident # NIL DO
prev := ident.prev(IDENT);
IF ~ident.export THEN
LISTS.delete(unit.idents, ident);
C.push(idents, ident)
END;
ident := prev
END;
unit.closed := TRUE
END closeUnit;
PROCEDURE IdEq* (a, b: SCAN.IDENT): BOOLEAN;
RETURN (a.hash = b.hash) & (a.s = b.s)
END IdEq;
PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;
VAR
item: IDENT;
BEGIN
item := unit.idents.last(IDENT);
WHILE (item.typ # idGUARD) & ~IdEq(item.name, ident) DO
item := item.prev(IDENT)
END
RETURN item.typ = idGUARD
END unique;
PROCEDURE addIdent* (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
VAR
item: IDENT;
res: BOOLEAN;
proc: PROC;
BEGIN
ASSERT(unit # NIL);
res := unique(unit, ident);
IF res THEN
item := NewIdent();
item.name := ident;
item.typ := typ;
item.unit := NIL;
item.export := FALSE;
item._import := NIL;
item._type := NIL;
item.value.typ := 0;
item.stproc := 0;
item.global := unit.scopeLvl = 0;
item.scopeLvl := unit.scopeLvl;
item.offset := -1;
IF item.typ IN {idPROC, idIMP} THEN
NEW(proc);
proc._import := NIL;
proc.label := 0;
proc.used := FALSE;
proc.processed := FALSE;
proc.using := LISTS.create(NIL);
LISTS.push(program.procs, proc);
item.proc := proc
END;
LISTS.push(unit.idents, item)
ELSE
item := NIL
END
RETURN item
END addIdent;
PROCEDURE UseProc* (unit: UNIT; call_proc: PROC);
VAR
procs: LISTS.LIST;
cur: LISTS.ITEM;
proc: USED_PROC;
BEGIN
IF unit.scopeLvl = 0 THEN
call_proc.used := TRUE
ELSE
procs := unit.scopes[unit.scopeLvl].using;
cur := procs.first;
WHILE (cur # NIL) & (cur(USED_PROC).proc # call_proc) DO
cur := cur.next
END;
IF cur = NIL THEN
NEW(proc);
proc.proc := call_proc;
LISTS.push(procs, proc)
END
END
END UseProc;
PROCEDURE setVarsType* (unit: UNIT; _type: _TYPE);
VAR
item: IDENT;
BEGIN
ASSERT(_type # NIL);
item := unit.idents.last(IDENT);
WHILE (item # NIL) & (item.typ = idVAR) & (item._type = NIL) DO
item._type := _type;
item := item.prev(IDENT)
END
END setVarsType;
PROCEDURE getIdent* (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;
VAR
item: IDENT;
BEGIN
item := unit.idents.last(IDENT);
IF item # NIL THEN
IF currentScope THEN
WHILE (item.typ # idGUARD) & ~IdEq(item.name, ident) DO
item := item.prev(IDENT)
END;
IF item.typ = idGUARD THEN
item := NIL
END
ELSE
WHILE (item # NIL) & ~IdEq(item.name, ident) DO
item := item.prev(IDENT)
END
END
END
RETURN item
END getIdent;
PROCEDURE openScope* (unit: UNIT; proc: PROC): BOOLEAN;
VAR
item: IDENT;
res: BOOLEAN;
BEGIN
INC(unit.scopeLvl);
res := unit.scopeLvl < MAXSCOPE;
IF res THEN
unit.scopes[unit.scopeLvl] := proc;
NEW(item);
item := NewIdent();
item.name.s := "";
item.name.hash := 0;
item.typ := idGUARD;
LISTS.push(unit.idents, item)
END
RETURN res
END openScope;
PROCEDURE closeScope* (unit: UNIT);
VAR
item: IDENT;
del: IDENT;
BEGIN
item := unit.idents.last(IDENT);
WHILE (item # NIL) & (item.typ # idGUARD) DO
del := item;
item := item.prev(IDENT);
IF (del.typ = idVAR) & (del.offset = -1) THEN
ERRORS.HintMsg(del.name.s, del.pos.line, del.pos.col, 0)
END;
LISTS.delete(unit.idents, del);
C.push(idents, del)
END;
IF (item # NIL) & (item.typ = idGUARD) THEN
LISTS.delete(unit.idents, item);
C.push(idents, item)
END;
DEC(unit.scopeLvl)
END closeScope;
PROCEDURE frwPtr* (unit: UNIT; _type: _TYPE; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
VAR
newptr: FRWPTR;
BEGIN
ASSERT(unit # NIL);
ASSERT(_type # NIL);
NEW(newptr);
newptr._type := _type;
newptr.baseIdent := baseIdent;
newptr.pos := pos;
newptr.linked := FALSE;
newptr.notRecord := FALSE;
LISTS.push(unit.frwPointers, newptr)
END frwPtr;
PROCEDURE linkPtr* (unit: UNIT): FRWPTR;
VAR
item: FRWPTR;
ident: IDENT;
res: FRWPTR;
BEGIN
res := NIL;
item := unit.frwPointers.last(FRWPTR);
WHILE (item # NIL) & ~item.linked & (res = NIL) DO
ident := getIdent(unit, item.baseIdent, TRUE);
IF (ident # NIL) THEN
IF (ident.typ = idTYPE) & (ident._type.typ = tRECORD) THEN
item._type.base := ident._type;
item.linked := TRUE
ELSE
item.notRecord := TRUE;
res := item
END
ELSE
item.notRecord := FALSE;
res := item
END;
item := item.prev(FRWPTR)
END
RETURN res
END linkPtr;
PROCEDURE isTypeEq* (t1, t2: _TYPE): BOOLEAN;
VAR
res: BOOLEAN;
param1, param2: LISTS.ITEM;
BEGIN
IF t1 = t2 THEN
res := TRUE
ELSIF (t1 = NIL) OR (t2 = NIL) THEN
res := FALSE
ELSIF (t1.typ = tPROCEDURE) & (t2.typ = tPROCEDURE) THEN
param1 := t1.params.first;
param2 := t2.params.first;
res := ((t1.call = t2.call) OR (t1.call IN {code, _code}) OR (t2.call IN {code, _code})) & ((param1 # NIL) = (param2 # NIL));
WHILE res & (param1 # NIL) & (param2 # NIL) DO
res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM)._type, param2(PARAM)._type);
param1 := param1.next;
param2 := param2.next;
res := res & ((param1 # NIL) = (param2 # NIL))
END;
res := res & isTypeEq(t1.base, t2.base)
ELSIF (t1.typ = tARRAY) & (t2.typ = tARRAY) THEN
res := (t1.length = 0) & (t2.length = 0) & isTypeEq(t1.base, t2.base)
ELSE
res := FALSE
END
RETURN res
END isTypeEq;
PROCEDURE isBaseOf* (t0, t1: _TYPE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := (t0.typ = t1.typ) & (t0.typ IN {tPOINTER, tRECORD});
IF res & (t0.typ = tPOINTER) THEN
t0 := t0.base;
t1 := t1.base
END;
IF res THEN
WHILE (t1 # NIL) & (t1 # t0) DO
t1 := t1.base
END;
res := t1 # NIL
END
RETURN res
END isBaseOf;
PROCEDURE isOpenArray* (t: _TYPE): BOOLEAN;
RETURN (t.typ = tARRAY) & (t.length = 0)
END isOpenArray;
PROCEDURE arrcomp* (src, dst: _TYPE): BOOLEAN;
RETURN (dst.typ = tARRAY) & isOpenArray(src) &
~isOpenArray(src.base) & ~isOpenArray(dst.base) &
isTypeEq(src.base, dst.base)
END arrcomp;
PROCEDURE getUnit* (name: PATHS.PATH): UNIT;
VAR
item: UNIT;
BEGIN
item := program.units.first(UNIT);
WHILE (item # NIL) & (item.fname # name) DO
item := item.next(UNIT)
END;
IF (item = NIL) & ((name = "SYSTEM") OR LowerCase & (name = "system")) THEN
item := program.sysunit
END
RETURN item
END getUnit;
PROCEDURE enterStTypes (unit: UNIT);
PROCEDURE enter (unit: UNIT; nameStr: SCAN.IDSTR; _type: _TYPE);
VAR
ident: IDENT;
upper: SCAN.IDSTR;
name: SCAN.IDENT;
BEGIN
IF LowerCase THEN
SCAN.setIdent(name, nameStr);
ident := addIdent(unit, name, idTYPE);
ident._type := _type
END;
upper := nameStr;
STRINGS.UpCase(upper);
SCAN.setIdent(name, upper);
ident := addIdent(unit, name, idTYPE);
ident._type := _type
END enter;
BEGIN
enter(unit, "integer", program.stTypes.tINTEGER);
enter(unit, "byte", program.stTypes.tBYTE);
enter(unit, "char", program.stTypes.tCHAR);
enter(unit, "set", program.stTypes.tSET);
enter(unit, "boolean", program.stTypes.tBOOLEAN);
IF TARGETS.RealSize # 0 THEN
enter(unit, "real", program.stTypes.tREAL)
END;
IF TARGETS.BitDepth >= 32 THEN
enter(unit, "wchar", program.stTypes.tWCHAR)
END
END enterStTypes;
PROCEDURE enterStProcs (unit: UNIT);
PROCEDURE Enter (unit: UNIT; nameStr: SCAN.IDSTR; nfunc, tfunc: INTEGER);
VAR
ident: IDENT;
upper: SCAN.IDSTR;
name: SCAN.IDENT;
BEGIN
IF LowerCase THEN
SCAN.setIdent(name, nameStr);
ident := addIdent(unit, name, tfunc);
ident.stproc := nfunc;
ident._type := program.stTypes.tNONE
END;
upper := nameStr;
STRINGS.UpCase(upper);
SCAN.setIdent(name, upper);
ident := addIdent(unit, name, tfunc);
ident.stproc := nfunc;
ident._type := program.stTypes.tNONE
END Enter;
BEGIN
Enter(unit, "assert", stASSERT, idSTPROC);
Enter(unit, "dec", stDEC, idSTPROC);
Enter(unit, "excl", stEXCL, idSTPROC);
Enter(unit, "inc", stINC, idSTPROC);
Enter(unit, "incl", stINCL, idSTPROC);
Enter(unit, "new", stNEW, idSTPROC);
Enter(unit, "copy", stCOPY, idSTPROC);
Enter(unit, "abs", stABS, idSTFUNC);
Enter(unit, "asr", stASR, idSTFUNC);
Enter(unit, "chr", stCHR, idSTFUNC);
Enter(unit, "len", stLEN, idSTFUNC);
Enter(unit, "lsl", stLSL, idSTFUNC);
Enter(unit, "odd", stODD, idSTFUNC);
Enter(unit, "ord", stORD, idSTFUNC);
Enter(unit, "ror", stROR, idSTFUNC);
Enter(unit, "bits", stBITS, idSTFUNC);
Enter(unit, "lsr", stLSR, idSTFUNC);
Enter(unit, "length", stLENGTH, idSTFUNC);
Enter(unit, "min", stMIN, idSTFUNC);
Enter(unit, "max", stMAX, idSTFUNC);
IF TARGETS.RealSize # 0 THEN
Enter(unit, "pack", stPACK, idSTPROC);
Enter(unit, "unpk", stUNPK, idSTPROC);
Enter(unit, "floor", stFLOOR, idSTFUNC);
Enter(unit, "flt", stFLT, idSTFUNC)
END;
IF TARGETS.BitDepth >= 32 THEN
Enter(unit, "wchr", stWCHR, idSTFUNC)
END;
IF TARGETS.Dispose THEN
Enter(unit, "dispose", stDISPOSE, idSTPROC)
END
END enterStProcs;
PROCEDURE newUnit* (name: SCAN.IDENT): UNIT;
VAR
unit: UNIT;
BEGIN
NEW(unit);
unit.name := name;
unit.closed := FALSE;
unit.idents := LISTS.create(NIL);
unit.frwPointers := LISTS.create(NIL);
ASSERT(openScope(unit, NIL));
enterStTypes(unit);
enterStProcs(unit);
ASSERT(openScope(unit, NIL));
unit.gscope := unit.idents.last(IDENT);
LISTS.push(program.units, unit);
unit.scopeLvl := 0;
unit.scopes[0] := NIL;
unit.sysimport := FALSE;
IF unit.name.s = UTILS.RTL_NAME THEN
program.rtl := unit
END
RETURN unit
END newUnit;
PROCEDURE getField* (self: _TYPE; name: SCAN.IDENT; unit: UNIT): FIELD;
VAR
field: FIELD;
BEGIN
ASSERT(self # NIL);
ASSERT(unit # NIL);
field := NIL;
WHILE (self # NIL) & (field = NIL) DO
field := self.fields.first(FIELD);
WHILE (field # NIL) & ~IdEq(field.name, name) DO
field := field.next(FIELD)
END;
IF field = NIL THEN
self := self.base
END
END;
IF (field # NIL) & (self.unit # unit) & ~field.export THEN
field := NIL
END
RETURN field
END getField;
PROCEDURE addField* (self: _TYPE; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
VAR
field: FIELD;
res: BOOLEAN;
BEGIN
res := getField(self, name, self.unit) = NIL;
IF res THEN
NEW(field);
field.name := name;
field.export := export;
field._type := NIL;
field.offset := self.size;
LISTS.push(self.fields, field)
END
RETURN res
END addField;
PROCEDURE setFields* (self: _TYPE; _type: _TYPE): BOOLEAN;
VAR
item: FIELD;
res: BOOLEAN;
BEGIN
ASSERT(_type # NIL);
item := self.fields.first(FIELD);
WHILE (item # NIL) & (item._type # NIL) DO
item := item.next(FIELD)
END;
res := TRUE;
WHILE res & (item # NIL) & (item._type = NIL) DO
item._type := _type;
IF ~self.noalign THEN
res := UTILS.Align(self.size, _type.align)
ELSE
res := TRUE
END;
item.offset := self.size;
res := res & (UTILS.maxint - self.size >= _type.size);
IF res THEN
INC(self.size, _type.size)
END;
item := item.next(FIELD)
END
RETURN res
END setFields;
PROCEDURE getParam* (self: _TYPE; name: SCAN.IDENT): PARAM;
VAR
item: PARAM;
BEGIN
item := self.params.first(PARAM);
WHILE (item # NIL) & ~IdEq(item.name, name) DO
item := item.next(PARAM)
END
RETURN item
END getParam;
PROCEDURE addParam* (self: _TYPE; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
VAR
param: PARAM;
res: BOOLEAN;
BEGIN
res := getParam(self, name) = NIL;
IF res THEN
NEW(param);
param.name := name;
param._type := NIL;
param.vPar := vPar;
LISTS.push(self.params, param)
END
RETURN res
END addParam;
PROCEDURE Dim* (t: _TYPE): INTEGER;
VAR
res: INTEGER;
BEGIN
res := 0;
WHILE isOpenArray(t) DO
t := t.base;
INC(res)
END
RETURN res
END Dim;
PROCEDURE OpenBase* (t: _TYPE): _TYPE;
BEGIN
WHILE isOpenArray(t) DO t := t.base END
RETURN t
END OpenBase;
PROCEDURE getFloatParamsPos* (self: _TYPE; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
VAR
res: SET;
param: PARAM;
BEGIN
res := {};
int := 0;
flt := 0;
param := self.params.first(PARAM);
WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO
IF ~param.vPar & (param._type.typ = tREAL) THEN
INCL(res, param.offset - STACK_FRAME);
INC(flt)
END;
param := param.next(PARAM)
END;
int := self.parSize - flt
RETURN res
END getFloatParamsPos;
PROCEDURE setParams* (self: _TYPE; _type: _TYPE);
VAR
item: LISTS.ITEM;
param: PARAM;
word, size: INTEGER;
BEGIN
ASSERT(_type # NIL);
word := UTILS.target.bit_depth DIV 8;
item := self.params.first;
WHILE (item # NIL) & (item(PARAM)._type # NIL) DO
item := item.next
END;
WHILE (item # NIL) & (item(PARAM)._type = NIL) DO
param := item(PARAM);
param._type := _type;
IF param.vPar THEN
IF _type.typ = tRECORD THEN
size := 2
ELSIF isOpenArray(_type) THEN
size := Dim(_type) + 1
ELSE
size := 1
END;
param.offset := self.parSize + ORD(_type.typ = tRECORD) + Dim(_type) + STACK_FRAME;
INC(self.parSize, size)
ELSE
IF _type.typ IN {tRECORD, tARRAY} THEN
IF isOpenArray(_type) THEN
size := Dim(_type) + 1
ELSE
size := 1
END
ELSE
size := _type.size;
ASSERT(UTILS.Align(size, word));
size := size DIV word
END;
param.offset := self.parSize + Dim(_type) + STACK_FRAME;
INC(self.parSize, size)
END;
item := item.next
END
END setParams;
PROCEDURE enterType* (typ, size, length: INTEGER; unit: UNIT): _TYPE;
VAR
t: _TYPE;
BEGIN
NEW(t);
t.typ := typ;
t.size := size;
t.length := length;
t.align := 0;
t.base := NIL;
t.fields := LISTS.create(NIL);
t.params := LISTS.create(NIL);
t.unit := unit;
t.num := 0;
CASE TARGETS.BitDepth OF
|16: t.call := default16
|32: t.call := default32
|64: t.call := default64
END;
t._import := FALSE;
t.noalign := FALSE;
t.parSize := 0;
IF typ IN {tARRAY, tRECORD} THEN
t.closed := FALSE;
IF typ = tRECORD THEN
INC(program.recCount);
t.num := program.recCount
END
ELSE
t.closed := TRUE
END;
LISTS.push(program.types, t)
RETURN t
END enterType;
PROCEDURE getType* (typ: INTEGER): _TYPE;
VAR
res: _TYPE;
BEGIN
CASE typ OF
|ARITH.tINTEGER: res := program.stTypes.tINTEGER
|ARITH.tREAL: res := program.stTypes.tREAL
|ARITH.tSET: res := program.stTypes.tSET
|ARITH.tBOOLEAN: res := program.stTypes.tBOOLEAN
|ARITH.tCHAR: res := program.stTypes.tCHAR
|ARITH.tWCHAR: res := program.stTypes.tWCHAR
|ARITH.tSTRING: res := program.stTypes.tSTRING
END
RETURN res
END getType;
PROCEDURE createSysUnit;
VAR
ident: IDENT;
unit: UNIT;
name: SCAN.IDENT;
PROCEDURE EnterProc (sys: UNIT; nameStr: SCAN.IDSTR; idtyp, proc: INTEGER);
VAR
ident: IDENT;
upper: SCAN.IDSTR;
name: SCAN.IDENT;
BEGIN
IF LowerCase THEN
SCAN.setIdent(name, nameStr);
ident := addIdent(sys, name, idtyp);
ident.stproc := proc;
ident._type := program.stTypes.tNONE;
ident.export := TRUE
END;
upper := nameStr;
STRINGS.UpCase(upper);
SCAN.setIdent(name, upper);
ident := addIdent(sys, name, idtyp);
ident.stproc := proc;
ident._type := program.stTypes.tNONE;
ident.export := TRUE
END EnterProc;
BEGIN
SCAN.setIdent(name, "$SYSTEM");
unit := newUnit(name);
unit.fname := "SYSTEM";
EnterProc(unit, "adr", idSYSFUNC, sysADR);
EnterProc(unit, "size", idSYSFUNC, sysSIZE);
EnterProc(unit, "sadr", idSYSFUNC, sysSADR);
EnterProc(unit, "typeid", idSYSFUNC, sysTYPEID);
EnterProc(unit, "get", idSYSPROC, sysGET);
EnterProc(unit, "get8", idSYSPROC, sysGET8);
EnterProc(unit, "put", idSYSPROC, sysPUT);
EnterProc(unit, "put8", idSYSPROC, sysPUT8);
EnterProc(unit, "code", idSYSPROC, sysCODE);
EnterProc(unit, "move", idSYSPROC, sysMOVE);
(*
IF program.target.sys = mConst.Target_iMSP430 THEN
EnterProc(unit, "nop", idSYSPROC, sysNOP);
EnterProc(unit, "eint", idSYSPROC, sysEINT);
EnterProc(unit, "dint", idSYSPROC, sysDINT)
END;
*)
IF TARGETS.RealSize # 0 THEN
EnterProc(unit, "inf", idSYSFUNC, sysINF);
END;
IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
EnterProc(unit, "copy", idSYSPROC, sysCOPY)
END;
IF TARGETS.BitDepth >= 32 THEN
EnterProc(unit, "wsadr", idSYSFUNC, sysWSADR);
EnterProc(unit, "put16", idSYSPROC, sysPUT16);
EnterProc(unit, "put32", idSYSPROC, sysPUT32);
EnterProc(unit, "get16", idSYSPROC, sysGET16);
EnterProc(unit, "get32", idSYSPROC, sysGET32);
IF LowerCase THEN
SCAN.setIdent(name, "card32");
ident := addIdent(unit, name, idTYPE);
ident._type := program.stTypes.tCARD32;
ident.export := TRUE
END;
SCAN.setIdent(name, "CARD32");
ident := addIdent(unit, name, idTYPE);
ident._type := program.stTypes.tCARD32;
ident.export := TRUE;
END;
closeUnit(unit);
program.sysunit := unit
END createSysUnit;
PROCEDURE DelUnused* (DelImport: DELIMPORT);
VAR
proc: PROC;
flag: BOOLEAN;
PROCEDURE process (proc: PROC);
VAR
used_proc: LISTS.ITEM;
BEGIN
proc.processed := TRUE;
used_proc := proc.using.first;
WHILE used_proc # NIL DO
used_proc(USED_PROC).proc.used := TRUE;
used_proc := used_proc.next
END
END process;
BEGIN
REPEAT
flag := FALSE;
proc := program.procs.first(PROC);
WHILE proc # NIL DO
IF proc.used & ~proc.processed THEN
process(proc);
flag := TRUE
END;
proc := proc.next(PROC)
END
UNTIL ~flag;
proc := program.procs.first(PROC);
WHILE proc # NIL DO
IF ~proc.used THEN
IF proc._import = NIL THEN
IL.delete2(proc.enter, proc.leave)
ELSE
DelImport(proc._import)
END
END;
proc := proc.next(PROC)
END
END DelUnused;
PROCEDURE ResetLocSize*;
BEGIN
program.locsize := 0
END ResetLocSize;
PROCEDURE create* (options: OPTIONS);
BEGIN
LowerCase := options.lower;
SCAN.init(options.lower);
idents := C.create();
UTILS.SetBitDepth(TARGETS.BitDepth, TARGETS.RealSize = 8);
program.options := options;
CASE TARGETS.OS OF
|TARGETS.osWIN32: program.sysflags := {sf_oberon, sf_windows, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign}
|TARGETS.osLINUX32: program.sysflags := {sf_oberon, sf_linux, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign}
|TARGETS.osKOS: program.sysflags := {sf_oberon, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign}
|TARGETS.osWIN64: program.sysflags := {sf_oberon, sf_windows, sf_win64, sf_systemv, sf_ccall, sf_noalign}
|TARGETS.osLINUX64: program.sysflags := {sf_oberon, sf_linux, sf_win64, sf_systemv, sf_ccall, sf_noalign}
|TARGETS.osNONE: program.sysflags := {sf_code}
END;
program.recCount := -1;
program.bss := 0;
program.units := LISTS.create(NIL);
program.types := LISTS.create(NIL);
program.procs := LISTS.create(NIL);
program.stTypes.tINTEGER := enterType(tINTEGER, TARGETS.WordSize, 0, NIL);
program.stTypes.tBYTE := enterType(tBYTE, 1, 0, NIL);
program.stTypes.tCHAR := enterType(tCHAR, 1, 0, NIL);
program.stTypes.tSET := enterType(tSET, TARGETS.WordSize, 0, NIL);
program.stTypes.tBOOLEAN := enterType(tBOOLEAN, 1, 0, NIL);
program.stTypes.tINTEGER.align := TARGETS.WordSize;
program.stTypes.tBYTE.align := 1;
program.stTypes.tCHAR.align := 1;
program.stTypes.tSET.align := TARGETS.WordSize;
program.stTypes.tBOOLEAN.align := 1;
IF TARGETS.BitDepth >= 32 THEN
program.stTypes.tWCHAR := enterType(tWCHAR, 2, 0, NIL);
program.stTypes.tCARD32 := enterType(tCARD32, 4, 0, NIL);
program.stTypes.tWCHAR.align := 2;
program.stTypes.tCARD32.align := 4
END;
IF TARGETS.RealSize # 0 THEN
program.stTypes.tREAL := enterType(tREAL, TARGETS.RealSize, 0, NIL);
program.stTypes.tREAL.align := TARGETS.RealSize
END;
program.stTypes.tSTRING := enterType(tSTRING, TARGETS.WordSize, 0, NIL);
program.stTypes.tNIL := enterType(tNIL, TARGETS.WordSize, 0, NIL);
program.stTypes.tNONE := enterType(tNONE, 0, 0, NIL);
program.stTypes.tANYREC := enterType(tRECORD, 0, 0, NIL);
program.stTypes.tANYREC.closed := TRUE;
createSysUnit
END create;
END PROG.

/programs/develop/oberon07/source/REG.ob07
0,0 → 1,286
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE REG;
CONST
N = 16;
R0* = 0; R1* = 1; R2* = 2; R3* = 3;
R4* = 4; R5* = 5; R6* = 6; R7* = 7;
R8* = 8; R9* = 9; R10* = 10; R11* = 11;
R12* = 12; R13* = 13; R14* = 14; R15* = 15;
TYPE
OP1 = PROCEDURE (arg: INTEGER);
OP2 = PROCEDURE (arg1, arg2: INTEGER);
REGS* = RECORD
regs*: SET;
stk*: ARRAY N OF INTEGER;
top*: INTEGER;
pushed*: INTEGER;
push, pop: OP1;
mov, xch: OP2
END;
PROCEDURE push (VAR R: REGS);
VAR
i, reg: INTEGER;
BEGIN
reg := R.stk[0];
INCL(R.regs, reg);
R.push(reg);
FOR i := 0 TO R.top - 1 DO
R.stk[i] := R.stk[i + 1]
END;
DEC(R.top);
INC(R.pushed)
END push;
PROCEDURE pop (VAR R: REGS; reg: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := R.top + 1 TO 1 BY -1 DO
R.stk[i] := R.stk[i - 1]
END;
R.stk[0] := reg;
EXCL(R.regs, reg);
R.pop(reg);
INC(R.top);
DEC(R.pushed)
END pop;
PROCEDURE InStk (R: REGS; reg: INTEGER): INTEGER;
VAR
i: INTEGER;
BEGIN
i := R.top;
WHILE (i >= 0) & (R.stk[i] # reg) DO
DEC(i)
END
RETURN i
END InStk;
PROCEDURE GetFreeReg (R: REGS): INTEGER;
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < N) & ~(i IN R.regs) DO
INC(i)
END;
IF i = N THEN
i := -1
END
RETURN i
END GetFreeReg;
PROCEDURE Put (VAR R: REGS; reg: INTEGER);
BEGIN
EXCL(R.regs, reg);
INC(R.top);
R.stk[R.top] := reg
END Put;
PROCEDURE PopAnyReg (VAR R: REGS): INTEGER;
VAR
reg: INTEGER;
BEGIN
reg := GetFreeReg(R);
ASSERT(reg # -1);
ASSERT(R.top < LEN(R.stk) - 1);
ASSERT(R.pushed > 0);
pop(R, reg)
RETURN reg
END PopAnyReg;
PROCEDURE GetAnyReg* (VAR R: REGS): INTEGER;
VAR
reg: INTEGER;
BEGIN
reg := GetFreeReg(R);
IF reg = -1 THEN
ASSERT(R.top >= 0);
reg := R.stk[0];
push(R)
END;
Put(R, reg)
RETURN reg
END GetAnyReg;
PROCEDURE GetReg* (VAR R: REGS; reg: INTEGER): BOOLEAN;
VAR
free: INTEGER;
res: BOOLEAN;
PROCEDURE exch (VAR R: REGS; reg1, reg2: INTEGER);
VAR
n1, n2: INTEGER;
BEGIN
n1 := InStk(R, reg1);
n2 := InStk(R, reg2);
R.stk[n1] := reg2;
R.stk[n2] := reg1;
R.xch(reg1, reg2)
END exch;
BEGIN
IF reg IN R.regs THEN
Put(R, reg);
res := TRUE
ELSE
res := InStk(R, reg) # -1;
IF res THEN
free := GetFreeReg(R);
IF free # -1 THEN
Put(R, free);
exch(R, reg, free)
ELSE
push(R);
free := GetFreeReg(R);
ASSERT(free # -1);
Put(R, free);
IF free # reg THEN
exch(R, reg, free)
END
END
END
END
RETURN res
END GetReg;
PROCEDURE Exchange* (VAR R: REGS; reg1, reg2: INTEGER): BOOLEAN;
VAR
n1, n2: INTEGER;
res: BOOLEAN;
BEGIN
res := TRUE;
IF reg1 # reg2 THEN
n1 := InStk(R, reg1);
n2 := InStk(R, reg2);
IF (n1 # -1) & (n2 # -1) THEN
R.stk[n1] := reg2;
R.stk[n2] := reg1;
R.xch(reg2, reg1)
ELSIF (n1 # -1) & (reg2 IN R.regs) THEN
R.stk[n1] := reg2;
INCL(R.regs, reg1);
EXCL(R.regs, reg2);
R.mov(reg2, reg1)
ELSIF (n2 # -1) & (reg1 IN R.regs) THEN
R.stk[n2] := reg1;
EXCL(R.regs, reg1);
INCL(R.regs, reg2);
R.mov(reg1, reg2)
ELSE
res := FALSE
END
END
RETURN res
END Exchange;
PROCEDURE Drop* (VAR R: REGS);
BEGIN
INCL(R.regs, R.stk[R.top]);
DEC(R.top)
END Drop;
PROCEDURE BinOp* (VAR R: REGS; VAR reg1, reg2: INTEGER);
BEGIN
IF R.top > 0 THEN
reg1 := R.stk[R.top - 1];
reg2 := R.stk[R.top]
ELSIF R.top = 0 THEN
reg1 := PopAnyReg(R);
reg2 := R.stk[1]
ELSE (* R.top = -1 *)
reg2 := PopAnyReg(R);
reg1 := PopAnyReg(R)
END
END BinOp;
PROCEDURE UnOp* (VAR R: REGS; VAR reg: INTEGER);
BEGIN
IF R.top >= 0 THEN
reg := R.stk[R.top]
ELSE
reg := PopAnyReg(R)
END
END UnOp;
PROCEDURE PushAll* (VAR R: REGS);
BEGIN
WHILE R.top >= 0 DO
push(R)
END
END PushAll;
PROCEDURE PushAll_1* (VAR R: REGS);
BEGIN
WHILE R.top >= 1 DO
push(R)
END
END PushAll_1;
PROCEDURE Init* (VAR R: REGS; push, pop: OP1; mov, xch: OP2; regs: SET);
BEGIN
R.regs := regs;
R.pushed := 0;
R.top := -1;
R.push := push;
R.pop := pop;
R.mov := mov;
R.xch := xch;
END Init;
END REG.

/programs/develop/oberon07/source/RVMxI.ob07
0,0 → 1,1428
(*
BSD 2-Clause License
Copyright (c) 2020-2021, Anton Krotov
All rights reserved.
*)
MODULE RVMxI;
IMPORT
PROG, WR := WRITER, IL, CHL := CHUNKLISTS, REG, UTILS, STRINGS, ERRORS, TARGETS;
CONST
LTypes = 0;
LStrings = 1;
LGlobal = 2;
LHeap = 3;
LStack = 4;
numGPRs = 3;
R0 = 0; R1 = 1;
BP = 3; SP = 4;
ACC = R0;
GPRs = {0 .. 2} + {5 .. numGPRs + 1};
opSTOP = 0; opRET = 1; opENTER = 2; opNEG = 3; opNOT = 4; opNOP = 5;
opXCHG = 6; opLDB = 7; opLDH = 8; opLDW = 9; opPUSH = 10; opPUSHC = 11;
opPOP = 12; opLABEL = 13; opLEA = 14; opLLA = 15;
opLDD = 16; (* 17, 18 *)
opJMP = 19; opCALL = 20; opCALLI = 21;
opMOV = 22; opMUL = 24; opADD = 26; opSUB = 28; opDIV = 30; opMOD = 32;
opSTB = 34; opSTH = 36; opSTW = 38; opSTD = 40; (* 42, 44 *)
opAND = 46; opOR = 48; opXOR = 50; opASR = 52; opLSR = 54;
opLSL = 56; opROR = 58; (* 60, 62 *) opCMP = 64;
opMOVC = 23; opMULC = 25; opADDC = 27; opSUBC = 29; opDIVC = 31; opMODC = 33;
opSTBC = 35; opSTHC = 37; opSTWC = 39; opSTDC = 41; (* 43, 45 *)
opANDC = 47; opORC = 49; opXORC = 51; opASRC = 53; opLSRC = 55;
opLSLC = 57; opRORC = 59; (* 61, 63 *) opCMPC = 65;
opBIT = 66; opSYSCALL = 67; opJBT = 68; opADDRC = 69;
opJEQ = 70; opJNE = 71; opJLT = 72; opJGE = 73; opJGT = 74; opJLE = 75;
opSEQ = 76; opSNE = 77; opSLT = 78; opSGE = 79; opSGT = 80; opSLE = 81;
VAR
R: REG.REGS; count, szWord: INTEGER;
ldr, str: PROCEDURE (r1, r2: INTEGER);
PROCEDURE OutByte (n: BYTE);
BEGIN
WR.WriteByte(n);
INC(count)
END OutByte;
PROCEDURE OutInt (n: INTEGER);
BEGIN
IF szWord = 8 THEN
WR.Write64LE(n);
INC(count, 8)
ELSE (* szWord = 4 *)
WR.Write32LE(n);
INC(count, 4)
END
END OutInt;
PROCEDURE Emit (op, par1, par2: INTEGER);
BEGIN
OutInt(op);
OutInt(par1);
OutInt(par2)
END Emit;
PROCEDURE drop;
BEGIN
REG.Drop(R)
END drop;
PROCEDURE GetAnyReg (): INTEGER;
RETURN REG.GetAnyReg(R)
END GetAnyReg;
PROCEDURE GetAcc;
BEGIN
ASSERT(REG.GetReg(R, ACC))
END GetAcc;
PROCEDURE UnOp (VAR r: INTEGER);
BEGIN
REG.UnOp(R, r)
END UnOp;
PROCEDURE BinOp (VAR r1, r2: INTEGER);
BEGIN
REG.BinOp(R, r1, r2)
END BinOp;
PROCEDURE PushAll (NumberOfParameters: INTEGER);
BEGIN
REG.PushAll(R);
DEC(R.pushed, NumberOfParameters)
END PushAll;
PROCEDURE push (r: INTEGER);
BEGIN
Emit(opPUSH, r, 0)
END push;
PROCEDURE pop (r: INTEGER);
BEGIN
Emit(opPOP, r, 0)
END pop;
PROCEDURE mov (r1, r2: INTEGER);
BEGIN
Emit(opMOV, r1, r2)
END mov;
PROCEDURE xchg (r1, r2: INTEGER);
BEGIN
Emit(opXCHG, r1, r2)
END xchg;
PROCEDURE addrc (r, c: INTEGER);
BEGIN
Emit(opADDC, r, c)
END addrc;
PROCEDURE subrc (r, c: INTEGER);
BEGIN
Emit(opSUBC, r, c)
END subrc;
PROCEDURE movrc (r, c: INTEGER);
BEGIN
Emit(opMOVC, r, c)
END movrc;
PROCEDURE pushc (c: INTEGER);
BEGIN
Emit(opPUSHC, c, 0)
END pushc;
PROCEDURE add (r1, r2: INTEGER);
BEGIN
Emit(opADD, r1, r2)
END add;
PROCEDURE sub (r1, r2: INTEGER);
BEGIN
Emit(opSUB, r1, r2)
END sub;
PROCEDURE ldr64 (r1, r2: INTEGER);
BEGIN
Emit(opLDD, r2 * 256 + r1, 0)
END ldr64;
PROCEDURE ldr32 (r1, r2: INTEGER);
BEGIN
Emit(opLDW, r2 * 256 + r1, 0)
END ldr32;
PROCEDURE ldr16 (r1, r2: INTEGER);
BEGIN
Emit(opLDH, r2 * 256 + r1, 0)
END ldr16;
PROCEDURE ldr8 (r1, r2: INTEGER);
BEGIN
Emit(opLDB, r2 * 256 + r1, 0)
END ldr8;
PROCEDURE str64 (r1, r2: INTEGER);
BEGIN
Emit(opSTD, r1 * 256 + r2, 0)
END str64;
PROCEDURE str32 (r1, r2: INTEGER);
BEGIN
Emit(opSTW, r1 * 256 + r2, 0)
END str32;
PROCEDURE str16 (r1, r2: INTEGER);
BEGIN
Emit(opSTH, r1 * 256 + r2, 0)
END str16;
PROCEDURE str8 (r1, r2: INTEGER);
BEGIN
Emit(opSTB, r1 * 256 + r2, 0)
END str8;
PROCEDURE GlobalAdr (r, offset: INTEGER);
BEGIN
Emit(opLEA, r + 256 * LGlobal, offset)
END GlobalAdr;
PROCEDURE StrAdr (r, offset: INTEGER);
BEGIN
Emit(opLEA, r + 256 * LStrings, offset)
END StrAdr;
PROCEDURE ProcAdr (r, label: INTEGER);
BEGIN
Emit(opLLA, r, label)
END ProcAdr;
PROCEDURE jnz (r, label: INTEGER);
BEGIN
Emit(opCMPC, r, 0);
Emit(opJNE, label, 0)
END jnz;
PROCEDURE CallRTL (proc, par: INTEGER);
BEGIN
Emit(opCALL, IL.codes.rtl[proc], 0);
addrc(SP, par * szWord)
END CallRTL;
PROCEDURE jcc (cc: INTEGER): INTEGER;
BEGIN
CASE cc OF
|IL.opEQ, IL.opEQC: cc := opJEQ
|IL.opNE, IL.opNEC: cc := opJNE
|IL.opLT, IL.opLTC: cc := opJLT
|IL.opLE, IL.opLEC: cc := opJLE
|IL.opGT, IL.opGTC: cc := opJGT
|IL.opGE, IL.opGEC: cc := opJGE
END
RETURN cc
END jcc;
PROCEDURE shift1 (op, param: INTEGER);
VAR
r1, r2: INTEGER;
BEGIN
r2 := GetAnyReg();
Emit(opMOVC, r2, param);
BinOp(r1, r2);
Emit(op, r2, r1);
mov(r1, r2);
drop
END shift1;
PROCEDURE shift (op: INTEGER);
VAR
r1, r2: INTEGER;
BEGIN
BinOp(r1, r2);
Emit(op, r1, r2);
drop
END shift;
PROCEDURE translate (szWord: INTEGER);
VAR
cmd, next: IL.COMMAND;
opcode, param1, param2, r1, r2, r3,
a, b, label, opLD, opST, opSTC: INTEGER;
BEGIN
IF szWord = 8 THEN
opLD := opLDD;
opST := opSTD;
opSTC := opSTDC
ELSE
opLD := opLDW;
opST := opSTW;
opSTC := opSTWC
END;
cmd := IL.codes.commands.first(IL.COMMAND);
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
opcode := cmd.opcode;
CASE opcode OF
|IL.opJMP:
Emit(opJMP, param1, 0)
|IL.opLABEL:
Emit(opLABEL, param1, 0)
|IL.opCALL:
Emit(opCALL, param1, 0)
|IL.opCALLP:
UnOp(r1);
Emit(opCALLI, r1, 0);
drop;
ASSERT(R.top = -1)
|IL.opPUSHC:
pushc(param2)
|IL.opCLEANUP:
IF param2 # 0 THEN
addrc(SP, param2 * szWord)
END
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opSADR:
StrAdr(GetAnyReg(), param2)
|IL.opGADR:
GlobalAdr(GetAnyReg(), param2)
|IL.opLADR:
param2 := param2 * szWord;
next := cmd.next(IL.COMMAND);
IF ((next.opcode = IL.opSAVE) OR (next.opcode = IL.opSAVEF)) & (szWord = 8) OR (next.opcode = IL.opSAVE64) THEN
UnOp(r1);
Emit(opSTD, BP * 256 + r1, param2);
drop;
cmd := next
ELSIF ((next.opcode = IL.opSAVE) OR (next.opcode = IL.opSAVEF)) & (szWord = 4) OR (next.opcode = IL.opSAVE32) THEN
UnOp(r1);
Emit(opSTW, BP * 256 + r1, param2);
drop;
cmd := next
ELSIF next.opcode = IL.opSAVE16 THEN
UnOp(r1);
Emit(opSTH, BP * 256 + r1, param2);
drop;
cmd := next
ELSIF next.opcode = IL.opSAVE8 THEN
UnOp(r1);
Emit(opSTB, BP * 256 + r1, param2);
drop;
cmd := next
ELSE
Emit(opADDRC, BP * 256 + GetAnyReg(), param2)
END
|IL.opPARAM:
IF param2 = 1 THEN
UnOp(r1);
push(r1);
drop
ELSE
ASSERT(R.top + 1 <= param2);
PushAll(param2)
END
|IL.opONERR:
pushc(param2);
Emit(opJMP, param1, 0)
|IL.opPRECALL:
PushAll(0)
|IL.opRES, IL.opRESF:
ASSERT(R.top = -1);
GetAcc
|IL.opENTER:
ASSERT(R.top = -1);
Emit(opLABEL, param1, 0);
Emit(opENTER, param2, 0)
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF:
IF opcode # IL.opLEAVE THEN
UnOp(r1);
IF r1 # ACC THEN
mov(ACC, r1)
END;
drop
END;
ASSERT(R.top = -1);
IF param1 > 0 THEN
mov(SP, BP)
END;
pop(BP);
Emit(opRET, 0, 0)
|IL.opLEAVEC:
Emit(opRET, 0, 0)
|IL.opCONST:
next := cmd.next(IL.COMMAND);
IF (next.opcode = IL.opPARAM) & (next.param2 = 1) THEN
pushc(param2);
cmd := next
ELSE
movrc(GetAnyReg(), param2)
END
|IL.opDROP:
UnOp(r1);
drop
|IL.opSAVEC:
UnOp(r1);
Emit(opSTC, r1, param2);
drop
|IL.opSAVE8C:
UnOp(r1);
Emit(opSTBC, r1, param2 MOD 256);
drop
|IL.opSAVE16C:
UnOp(r1);
Emit(opSTHC, r1, param2 MOD 65536);
drop
|IL.opSAVE, IL.opSAVEF:
BinOp(r2, r1);
str(r1, r2);
drop;
drop
|IL.opSAVE32:
BinOp(r2, r1);
str32(r1, r2);
drop;
drop
|IL.opSAVE64:
BinOp(r2, r1);
str64(r1, r2);
drop;
drop
|IL.opSAVEFI:
BinOp(r2, r1);
str(r2, r1);
drop;
drop
|IL.opSAVE8:
BinOp(r2, r1);
str8(r1, r2);
drop;
drop
|IL.opSAVE16:
BinOp(r2, r1);
str16(r1, r2);
drop;
drop
|IL.opGLOAD32:
r1 := GetAnyReg();
GlobalAdr(r1, param2);
ldr32(r1, r1)
|IL.opGLOAD64:
r1 := GetAnyReg();
GlobalAdr(r1, param2);
ldr64(r1, r1)
|IL.opVADR:
Emit(opLD, BP * 256 + GetAnyReg(), param2 * szWord)
|IL.opLLOAD32:
Emit(opLDW, BP * 256 + GetAnyReg(), param2 * szWord)
|IL.opLLOAD64:
Emit(opLDD, BP * 256 + GetAnyReg(), param2 * szWord)
|IL.opVLOAD32:
r1 := GetAnyReg();
Emit(opLD, BP * 256 + r1, param2 * szWord);
ldr32(r1, r1)
|IL.opVLOAD64:
r1 := GetAnyReg();
Emit(opLDD, BP * 256 + r1, param2 * szWord);
ldr64(r1, r1)
|IL.opGLOAD16:
r1 := GetAnyReg();
GlobalAdr(r1, param2);
ldr16(r1, r1)
|IL.opLLOAD16:
Emit(opLDH, BP * 256 + GetAnyReg(), param2 * szWord)
|IL.opVLOAD16:
r1 := GetAnyReg();
Emit(opLD, BP * 256 + r1, param2 * szWord);
ldr16(r1, r1)
|IL.opGLOAD8:
r1 := GetAnyReg();
GlobalAdr(r1, param2);
ldr8(r1, r1)
|IL.opLLOAD8:
Emit(opLDB, BP * 256 + GetAnyReg(), param2 * szWord)
|IL.opVLOAD8:
r1 := GetAnyReg();
Emit(opLD, BP * 256 + r1, param2 * szWord);
ldr8(r1, r1)
|IL.opLOAD8:
UnOp(r1);
ldr8(r1, r1)
|IL.opLOAD16:
UnOp(r1);
ldr16(r1, r1)
|IL.opLOAD32:
UnOp(r1);
ldr32(r1, r1)
|IL.opLOAD64:
UnOp(r1);
ldr64(r1, r1)
|IL.opLOADF:
UnOp(r1);
ldr(r1, r1)
|IL.opUMINUS:
UnOp(r1);
Emit(opNEG, r1, 0)
|IL.opADD:
BinOp(r1, r2);
add(r1, r2);
drop
|IL.opSUB:
BinOp(r1, r2);
sub(r1, r2);
drop
|IL.opADDC:
UnOp(r1);
next := cmd.next(IL.COMMAND);
CASE next.opcode OF
|IL.opLOADF:
Emit(opLD, r1 * 256 + r1, param2);
cmd := next
|IL.opLOAD64:
Emit(opLDD, r1 * 256 + r1, param2);
cmd := next
|IL.opLOAD32:
Emit(opLDW, r1 * 256 + r1, param2);
cmd := next
|IL.opLOAD16:
Emit(opLDH, r1 * 256 + r1, param2);
cmd := next
|IL.opLOAD8:
Emit(opLDB, r1 * 256 + r1, param2);
cmd := next
ELSE
addrc(r1, param2)
END
|IL.opSUBR:
UnOp(r1);
subrc(r1, param2)
|IL.opSUBL:
UnOp(r1);
subrc(r1, param2);
Emit(opNEG, r1, 0)
|IL.opMULC:
UnOp(r1);
Emit(opMULC, r1, param2)
|IL.opMUL:
BinOp(r1, r2);
Emit(opMUL, r1, r2);
drop
|IL.opDIV:
BinOp(r1, r2);
Emit(opDIV, r1, r2);
drop
|IL.opMOD:
BinOp(r1, r2);
Emit(opMOD, r1, r2);
drop
|IL.opDIVR:
UnOp(r1);
Emit(opDIVC, r1, param2)
|IL.opMODR:
UnOp(r1);
Emit(opMODC, r1, param2)
|IL.opDIVL:
UnOp(r1);
r2 := GetAnyReg();
movrc(r2, param2);
Emit(opDIV, r2, r1);
mov(r1, r2);
drop
|IL.opMODL:
UnOp(r1);
r2 := GetAnyReg();
movrc(r2, param2);
Emit(opMOD, r2, r1);
mov(r1, r2);
drop
|IL.opEQ .. IL.opGE, IL.opEQC .. IL.opGEC:
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN
BinOp(r1, r2);
Emit(opCMP, r1, r2);
drop
ELSE
UnOp(r1);
Emit(opCMPC, r1, param2)
END;
next := cmd.next(IL.COMMAND);
IF next.opcode = IL.opJZ THEN
Emit(ORD(BITS(jcc(opcode)) / {0}), next.param1, 0);
cmd := next;
drop
ELSIF next.opcode = IL.opJNZ THEN
Emit(jcc(opcode), next.param1, 0);
cmd := next;
drop
ELSE
Emit(jcc(opcode) + 6, r1, 0)
END
|IL.opJNZ1:
UnOp(r1);
jnz(r1, param1)
|IL.opJG:
UnOp(r1);
Emit(opCMPC, r1, 0);
Emit(opJGT, param1, 0)
|IL.opJNZ:
UnOp(r1);
jnz(r1, param1);
drop
|IL.opJZ:
UnOp(r1);
Emit(opCMPC, r1, 0);
Emit(opJEQ, param1, 0);
drop
|IL.opMULS:
BinOp(r1, r2);
Emit(opAND, r1, r2);
drop
|IL.opMULSC:
UnOp(r1);
Emit(opANDC, r1, param2)
|IL.opDIVS:
BinOp(r1, r2);
Emit(opXOR, r1, r2);
drop
|IL.opDIVSC:
UnOp(r1);
Emit(opXORC, r1, param2)
|IL.opADDS:
BinOp(r1, r2);
Emit(opOR, r1, r2);
drop
|IL.opSUBS:
BinOp(r1, r2);
Emit(opNOT, r2, 0);
Emit(opAND, r1, r2);
drop
|IL.opADDSC:
UnOp(r1);
Emit(opORC, r1, param2)
|IL.opSUBSL:
UnOp(r1);
Emit(opNOT, r1, 0);
Emit(opANDC, r1, param2)
|IL.opSUBSR:
UnOp(r1);
Emit(opANDC, r1, ORD(-BITS(param2)))
|IL.opUMINS:
UnOp(r1);
Emit(opNOT, r1, 0)
|IL.opASR:
shift(opASR)
|IL.opLSL:
shift(opLSL)
|IL.opROR:
shift(opROR)
|IL.opLSR:
shift(opLSR)
|IL.opASR1:
shift1(opASR, param2)
|IL.opLSL1:
shift1(opLSL, param2)
|IL.opROR1:
shift1(opROR, param2)
|IL.opLSR1:
shift1(opLSR, param2)
|IL.opASR2:
UnOp(r1);
Emit(opASRC, r1, param2 MOD (szWord * 8))
|IL.opLSL2:
UnOp(r1);
Emit(opLSLC, r1, param2 MOD (szWord * 8))
|IL.opROR2:
UnOp(r1);
Emit(opRORC, r1, param2 MOD (szWord * 8))
|IL.opLSR2:
UnOp(r1);
Emit(opLSRC, r1, param2 MOD (szWord * 8))
|IL.opCHR:
UnOp(r1);
Emit(opANDC, r1, 255)
|IL.opWCHR:
UnOp(r1);
Emit(opANDC, r1, 65535)
|IL.opABS:
UnOp(r1);
Emit(opCMPC, r1, 0);
label := IL.NewLabel();
Emit(opJGE, label, 0);
Emit(opNEG, r1, 0);
Emit(opLABEL, label, 0)
|IL.opLEN:
UnOp(r1);
drop;
EXCL(R.regs, r1);
WHILE param2 > 0 DO
UnOp(r2);
drop;
DEC(param2)
END;
INCL(R.regs, r1);
ASSERT(REG.GetReg(R, r1))
|IL.opSWITCH:
UnOp(r1);
IF param2 = 0 THEN
r2 := ACC
ELSE
r2 := R1
END;
IF r1 # r2 THEN
ASSERT(REG.GetReg(R, r2));
ASSERT(REG.Exchange(R, r1, r2));
drop
END;
drop
|IL.opENDSW:
|IL.opCASEL:
Emit(opCMPC, ACC, param1);
Emit(opJLT, param2, 0)
|IL.opCASER:
Emit(opCMPC, ACC, param1);
Emit(opJGT, param2, 0)
|IL.opCASELR:
Emit(opCMPC, ACC, param1);
IF param2 = cmd.param3 THEN
Emit(opJNE, param2, 0)
ELSE
Emit(opJLT, param2, 0);
Emit(opJGT, cmd.param3, 0)
END
|IL.opSBOOL:
BinOp(r2, r1);
Emit(opCMPC, r2, 0);
Emit(opSNE, r2, 0);
str8(r1, r2);
drop;
drop
|IL.opSBOOLC:
UnOp(r1);
Emit(opSTBC, r1, ORD(param2 # 0));
drop
|IL.opINCC:
UnOp(r1);
r2 := GetAnyReg();
ldr(r2, r1);
addrc(r2, param2);
str(r1, r2);
drop;
drop
|IL.opINCCB, IL.opDECCB:
IF opcode = IL.opDECCB THEN
param2 := -param2
END;
UnOp(r1);
r2 := GetAnyReg();
ldr8(r2, r1);
addrc(r2, param2);
str8(r1, r2);
drop;
drop
|IL.opINCB, IL.opDECB:
BinOp(r2, r1);
r3 := GetAnyReg();
ldr8(r3, r1);
IF opcode = IL.opINCB THEN
add(r3, r2)
ELSE
sub(r3, r2)
END;
str8(r1, r3);
drop;
drop;
drop
|IL.opINC, IL.opDEC:
BinOp(r2, r1);
r3 := GetAnyReg();
ldr(r3, r1);
IF opcode = IL.opINC THEN
add(r3, r2)
ELSE
sub(r3, r2)
END;
str(r1, r3);
drop;
drop;
drop
|IL.opINCL, IL.opEXCL:
BinOp(r2, r1);
Emit(opBIT, r2, r2);
r3 := GetAnyReg();
ldr(r3, r1);
IF opcode = IL.opINCL THEN
Emit(opOR, r3, r2)
ELSE
Emit(opNOT, r2, 0);
Emit(opAND, r3, r2)
END;
str(r1, r3);
drop;
drop;
drop
|IL.opINCLC, IL.opEXCLC:
UnOp(r1);
r2 := GetAnyReg();
ldr(r2, r1);
IF opcode = IL.opINCLC THEN
Emit(opORC, r2, ORD({param2}))
ELSE
Emit(opANDC, r2, ORD(-{param2}))
END;
str(r1, r2);
drop;
drop
|IL.opEQB, IL.opNEB:
BinOp(r1, r2);
Emit(opCMPC, r1, 0);
Emit(opSNE, r1, 0);
Emit(opCMPC, r2, 0);
Emit(opSNE, r2, 0);
Emit(opCMP, r1, r2);
IF opcode = IL.opEQB THEN
Emit(opSEQ, r1, 0)
ELSE
Emit(opSNE, r1, 0)
END;
drop
|IL.opCHKBYTE:
BinOp(r1, r2);
Emit(opCMPC, r1, 256);
Emit(opJBT, param1, 0)
|IL.opCHKIDX:
UnOp(r1);
Emit(opCMPC, r1, param2);
Emit(opJBT, param1, 0)
|IL.opCHKIDX2:
BinOp(r1, r2);
IF param2 # -1 THEN
Emit(opCMP, r2, r1);
Emit(opJBT, param1, 0)
END;
INCL(R.regs, r1);
DEC(R.top);
R.stk[R.top] := r2
|IL.opEQP, IL.opNEP:
ProcAdr(GetAnyReg(), param1);
BinOp(r1, r2);
Emit(opCMP, r1, r2);
IF opcode = IL.opEQP THEN
Emit(opSEQ, r1, 0)
ELSE
Emit(opSNE, r1, 0)
END;
drop
|IL.opSAVEP:
UnOp(r1);
r2 := GetAnyReg();
ProcAdr(r2, param2);
str(r1, r2);
drop;
drop
|IL.opPUSHP:
ProcAdr(GetAnyReg(), param2)
|IL.opPUSHT:
UnOp(r1);
Emit(opLD, r1 * 256 + GetAnyReg(), -szWord)
|IL.opGET, IL.opGETC:
IF opcode = IL.opGET THEN
BinOp(r1, r2)
ELSIF opcode = IL.opGETC THEN
UnOp(r2);
r1 := GetAnyReg();
movrc(r1, param1)
END;
drop;
drop;
CASE param2 OF
|1: ldr8(r1, r1); str8(r2, r1)
|2: ldr16(r1, r1); str16(r2, r1)
|4: ldr32(r1, r1); str32(r2, r1)
|8: ldr64(r1, r1); str64(r2, r1)
END
|IL.opNOT:
UnOp(r1);
Emit(opCMPC, r1, 0);
Emit(opSEQ, r1, 0)
|IL.opORD:
UnOp(r1);
Emit(opCMPC, r1, 0);
Emit(opSNE, r1, 0)
|IL.opMIN, IL.opMAX:
BinOp(r1, r2);
Emit(opCMP, r1, r2);
label := IL.NewLabel();
IF opcode = IL.opMIN THEN
Emit(opJLE, label, 0)
ELSE
Emit(opJGE, label, 0)
END;
Emit(opMOV, r1, r2);
Emit(opLABEL, label, 0);
drop
|IL.opMINC, IL.opMAXC:
UnOp(r1);
Emit(opCMPC, r1, param2);
label := IL.NewLabel();
IF opcode = IL.opMINC THEN
Emit(opJLE, label, 0)
ELSE
Emit(opJGE, label, 0)
END;
Emit(opMOVC, r1, param2);
Emit(opLABEL, label, 0)
|IL.opIN:
BinOp(r1, r2);
Emit(opBIT, r1, r1);
Emit(opAND, r1, r2);
Emit(opCMPC, r1, 0);
Emit(opSNE, r1, 0);
drop
|IL.opINL:
UnOp(r1);
Emit(opANDC, r1, ORD({param2}));
Emit(opCMPC, r1, 0);
Emit(opSNE, r1, 0)
|IL.opINR:
UnOp(r1);
Emit(opBIT, r1, r1);
Emit(opANDC, r1, param2);
Emit(opCMPC, r1, 0);
Emit(opSNE, r1, 0)
|IL.opERR:
CallRTL(IL._error, 4)
|IL.opEQS .. IL.opGES:
PushAll(4);
pushc(opcode - IL.opEQS);
CallRTL(IL._strcmp, 5);
GetAcc
|IL.opEQSW .. IL.opGESW:
PushAll(4);
pushc(opcode - IL.opEQSW);
CallRTL(IL._strcmpw, 5);
GetAcc
|IL.opCOPY:
PushAll(2);
pushc(param2);
CallRTL(IL._move, 3)
|IL.opMOVE:
PushAll(3);
CallRTL(IL._move, 3)
|IL.opCOPYA:
PushAll(4);
pushc(param2);
CallRTL(IL._arrcpy, 5);
GetAcc
|IL.opCOPYS:
PushAll(4);
pushc(param2);
CallRTL(IL._strcpy, 5)
|IL.opROT:
PushAll(0);
mov(ACC, SP);
push(ACC);
pushc(param2);
CallRTL(IL._rot, 2)
|IL.opLENGTH:
PushAll(2);
CallRTL(IL._length, 2);
GetAcc
|IL.opLENGTHW:
PushAll(2);
CallRTL(IL._lengthw, 2);
GetAcc
|IL.opSAVES:
UnOp(r2);
REG.PushAll_1(R);
r1 := GetAnyReg();
StrAdr(r1, param2);
push(r1);
drop;
push(r2);
drop;
pushc(param1);
CallRTL(IL._move, 3)
|IL.opRSET:
PushAll(2);
CallRTL(IL._set, 2);
GetAcc
|IL.opRSETR:
PushAll(1);
pushc(param2);
CallRTL(IL._set, 2);
GetAcc
|IL.opRSETL:
UnOp(r1);
REG.PushAll_1(R);
pushc(param2);
push(r1);
drop;
CallRTL(IL._set, 2);
GetAcc
|IL.opRSET1:
PushAll(1);
CallRTL(IL._set1, 1);
GetAcc
|IL.opNEW:
PushAll(1);
INC(param2, szWord);
ASSERT(UTILS.Align(param2, szWord));
pushc(param2);
pushc(param1);
CallRTL(IL._new, 3)
|IL.opTYPEGP:
UnOp(r1);
PushAll(0);
push(r1);
pushc(param2);
CallRTL(IL._guard, 2);
GetAcc
|IL.opIS:
PushAll(1);
pushc(param2);
CallRTL(IL._is, 2);
GetAcc
|IL.opISREC:
PushAll(2);
pushc(param2);
CallRTL(IL._guardrec, 3);
GetAcc
|IL.opTYPEGR:
PushAll(1);
pushc(param2);
CallRTL(IL._guardrec, 2);
GetAcc
|IL.opTYPEGD:
UnOp(r1);
PushAll(0);
subrc(r1, szWord);
ldr(r1, r1);
push(r1);
pushc(param2);
CallRTL(IL._guardrec, 2);
GetAcc
|IL.opCASET:
push(R1);
push(R1);
pushc(param2);
CallRTL(IL._guardrec, 2);
pop(R1);
jnz(ACC, param1)
|IL.opCONSTF:
IF szWord = 8 THEN
movrc(GetAnyReg(), UTILS.splitf(cmd.float, a, b))
ELSE (* szWord = 4 *)
movrc(GetAnyReg(), UTILS.d2s(cmd.float))
END
|IL.opMULF:
PushAll(2);
CallRTL(IL._fmul, 2);
GetAcc
|IL.opDIVF:
PushAll(2);
CallRTL(IL._fdiv, 2);
GetAcc
|IL.opDIVFI:
PushAll(2);
CallRTL(IL._fdivi, 2);
GetAcc
|IL.opADDF:
PushAll(2);
CallRTL(IL._fadd, 2);
GetAcc
|IL.opSUBFI:
PushAll(2);
CallRTL(IL._fsubi, 2);
GetAcc
|IL.opSUBF:
PushAll(2);
CallRTL(IL._fsub, 2);
GetAcc
|IL.opEQF..IL.opGEF:
PushAll(2);
pushc(opcode - IL.opEQF);
CallRTL(IL._fcmp, 3);
GetAcc
|IL.opFLOOR:
PushAll(1);
CallRTL(IL._floor, 1);
GetAcc
|IL.opFLT:
PushAll(1);
CallRTL(IL._flt, 1);
GetAcc
|IL.opUMINF:
UnOp(r1);
Emit(opRORC, r1, -1);
Emit(opXORC, r1, 1);
Emit(opRORC, r1, 1)
|IL.opFABS:
UnOp(r1);
Emit(opLSLC, r1, 1);
Emit(opLSRC, r1, 1)
|IL.opINF:
r1 := GetAnyReg();
Emit(opMOVC, r1, 1);
Emit(opRORC, r1, 1);
Emit(opASRC, r1, 7 + 3 * ORD(szWord = 8));
Emit(opLSRC, r1, 1)
|IL.opPUSHF:
UnOp(r1);
push(r1);
drop
|IL.opPACK:
PushAll(2);
CallRTL(IL._pack, 2)
|IL.opPACKC:
PushAll(1);
pushc(param2);
CallRTL(IL._pack, 2)
|IL.opUNPK:
PushAll(2);
CallRTL(IL._unpk, 2)
|IL.opCODE:
OutInt(param2)
|IL.opLADR_SAVE:
UnOp(r1);
Emit(opST, BP * 256 + r1, param2 * szWord);
drop
|IL.opLADR_INCC:
r1 := GetAnyReg();
Emit(opLD, BP * 256 + r1, param1 * szWord);
Emit(opADDC, r1, param2);
Emit(opST, BP * 256 + r1, param1 * szWord);
drop
END;
cmd := cmd.next(IL.COMMAND)
END;
ASSERT(R.pushed = 0);
ASSERT(R.top = -1)
END translate;
PROCEDURE prolog;
BEGIN
Emit(opLEA, SP + LStack * 256, 0);
Emit(opLEA, ACC + LTypes * 256, 0);
push(ACC);
Emit(opLEA, ACC + LHeap * 256, 0);
push(ACC);
pushc(CHL.Length(IL.codes.types));
CallRTL(IL._init, 3)
END prolog;
PROCEDURE epilog (ram, szWord: INTEGER);
VAR
tcount, dcount, i, offTypes, offStrings,
szData, szGlobal, szHeapStack: INTEGER;
BEGIN
Emit(opSTOP, 0, 0);
offTypes := count;
tcount := CHL.Length(IL.codes.types);
FOR i := 0 TO tcount - 1 DO
OutInt(CHL.GetInt(IL.codes.types, i))
END;
offStrings := count;
dcount := CHL.Length(IL.codes.data);
FOR i := 0 TO dcount - 1 DO
OutByte(CHL.GetByte(IL.codes.data, i))
END;
IF dcount MOD szWord # 0 THEN
i := szWord - dcount MOD szWord;
WHILE i > 0 DO
OutByte(0);
DEC(i)
END
END;
szData := count - offTypes;
szGlobal := (IL.codes.bss DIV szWord + 1) * szWord;
szHeapStack := ram - szData - szGlobal;
OutInt(offTypes);
OutInt(offStrings);
OutInt(szGlobal DIV szWord);
OutInt(szHeapStack DIV szWord);
FOR i := 1 TO 8 DO
OutInt(0)
END
END epilog;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
CONST
minRAM = 32*1024;
maxRAM = 256*1024;
VAR
szData, szRAM: INTEGER;
BEGIN
szWord := TARGETS.WordSize;
IF szWord = 8 THEN
ldr := ldr64;
str := str64
ELSE
ldr := ldr32;
str := str32
END;
szData := (CHL.Length(IL.codes.types) + CHL.Length(IL.codes.data) DIV szWord + IL.codes.bss DIV szWord + 2) * szWord;
szRAM := MIN(MAX(options.ram, minRAM), maxRAM) * 1024;
IF szRAM - szData < 1024*1024 THEN
ERRORS.Error(208)
END;
count := 0;
WR.Create(outname);
REG.Init(R, push, pop, mov, xchg, GPRs);
prolog;
translate(szWord);
epilog(szRAM, szWord);
WR.Close
END CodeGen;
END RVMxI.

/programs/develop/oberon07/source/SCAN.ob07
0,0 → 1,783
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE SCAN;
IMPORT TXT := TEXTDRV, ARITH, S := STRINGS, ERRORS, LISTS;
CONST
NUMLEN = 256;
IDLEN = 256;
TEXTLEN = 512;
lxUNDEF* = 0; lxIDENT* = 1; lxINTEGER* = 2; lxHEX* = 3;
lxCHAR* = 4; lxFLOAT* = 5; lxSTRING* = 6; lxCOMMENT* = 7;
lxEOF* = 8;
lxPLUS* = 21; lxMINUS* = 22; lxMUL* = 23; lxSLASH* = 24;
lxNOT* = 25; lxAND* = 26; lxPOINT* = 27; lxCOMMA* = 28;
lxSEMI* = 29; lxBAR* = 30; lxLROUND* = 31; lxLSQUARE* = 32;
lxLCURLY* = 33; lxCARET* = 34; lxEQ* = 35; lxNE* = 36;
lxLT* = 37; lxGT* = 38; lxCOLON* = 39; lxRROUND* = 40;
lxRSQUARE* = 41; lxRCURLY* = 42; lxLE* = 43; lxGE* = 44;
lxASSIGN* = 45; lxRANGE* = 46;
lxKW = 51;
lxARRAY* = 51; lxBEGIN* = 52; lxBY* = 53; lxCASE* = 54;
lxCONST* = 55; lxDIV* = 56; lxDO* = 57; lxELSE* = 58;
lxELSIF* = 59; lxEND* = 60; lxFALSE* = 61; lxFOR* = 62;
lxIF* = 63; lxIMPORT* = 64; lxIN* = 65; lxIS* = 66;
lxMOD* = 67; lxMODULE* = 68; lxNIL* = 69; lxOF* = 70;
lxOR* = 71; lxPOINTER* = 72; lxPROCEDURE* = 73; lxRECORD* = 74;
lxREPEAT* = 75; lxRETURN* = 76; lxTHEN* = 77; lxTO* = 78;
lxTRUE* = 79; lxTYPE* = 80; lxUNTIL* = 81; lxVAR* = 82;
lxWHILE* = 83;
lxERROR01* = -1; lxERROR02* = -2; lxERROR03* = -3; lxERROR04* = -4;
lxERROR05* = -5; (*lxERROR06* = -6;*) lxERROR07* = -7; lxERROR08* = -8;
lxERROR09* = -9; lxERROR10* = -10; lxERROR11* = -11; lxERROR12* = -12;
lxERROR13* = -13;
TYPE
TEXTSTR* = ARRAY TEXTLEN OF CHAR;
IDSTR* = ARRAY IDLEN OF CHAR;
DEF = POINTER TO RECORD (LISTS.ITEM)
ident: IDSTR
END;
STRING* = POINTER TO RECORD (LISTS.ITEM)
s*: TEXTSTR;
offset*, offsetW*, hash: INTEGER
END;
IDENT* = RECORD
s*: IDSTR;
hash*: INTEGER
END;
POSITION* = RECORD
line*, col*: INTEGER
END;
LEX* = RECORD
sym*: INTEGER;
pos*: POSITION;
ident*: IDENT;
string*: STRING;
value*: ARITH.VALUE;
error*: INTEGER
END;
SCANNER* = TXT.TEXT;
KEYWORD = ARRAY 10 OF CHAR;
VAR
delimiters: ARRAY 256 OF BOOLEAN;
upto, LowerCase, _if: BOOLEAN;
strings, def: LISTS.LIST;
KW: ARRAY 33 OF RECORD upper, lower: KEYWORD; uhash, lhash: INTEGER END;
PROCEDURE enterKW (s: KEYWORD; idx: INTEGER);
BEGIN
KW[idx].lower := s;
KW[idx].upper := s;
S.UpCase(KW[idx].upper);
KW[idx].uhash := S.HashStr(KW[idx].upper);
KW[idx].lhash := S.HashStr(KW[idx].lower);
END enterKW;
PROCEDURE checkKW (ident: IDENT): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := lxIDENT;
i := 0;
WHILE i < LEN(KW) DO
IF (KW[i].uhash = ident.hash) & (KW[i].upper = ident.s)
OR LowerCase & (KW[i].lhash = ident.hash) & (KW[i].lower = ident.s) THEN
res := i + lxKW;
i := LEN(KW)
END;
INC(i)
END
RETURN res
END checkKW;
PROCEDURE enterStr* (s: TEXTSTR): STRING;
VAR
str, res: STRING;
hash: INTEGER;
BEGIN
hash := S.HashStr(s);
str := strings.first(STRING);
res := NIL;
WHILE str # NIL DO
IF (str.hash = hash) & (str.s = s) THEN
res := str;
str := NIL
ELSE
str := str.next(STRING)
END
END;
IF res = NIL THEN
NEW(res);
res.s := s;
res.offset := -1;
res.offsetW := -1;
res.hash := hash;
LISTS.push(strings, res)
END
RETURN res
END enterStr;
PROCEDURE nextc (text: TXT.TEXT): CHAR;
BEGIN
TXT.next(text)
RETURN text.peak
END nextc;
PROCEDURE setIdent* (VAR ident: IDENT; s: IDSTR);
BEGIN
ident.s := s;
ident.hash := S.HashStr(s)
END setIdent;
PROCEDURE ident (text: TXT.TEXT; VAR lex: LEX);
VAR
c: CHAR;
i: INTEGER;
BEGIN
c := text.peak;
ASSERT(S.letter(c));
i := 0;
WHILE (i < IDLEN - 1) & (S.letter(c) OR S.digit(c)) DO
lex.ident.s[i] := c;
INC(i);
c := nextc(text)
END;
lex.ident.s[i] := 0X;
lex.ident.hash := S.HashStr(lex.ident.s);
lex.sym := checkKW(lex.ident);
IF S.letter(c) OR S.digit(c) THEN
ERRORS.WarningMsg(lex.pos.line, lex.pos.col, 2);
WHILE S.letter(c) OR S.digit(c) DO
c := nextc(text)
END
END
END ident;
PROCEDURE number (text: TXT.TEXT; VAR lex: LEX);
TYPE
NUMSTR = ARRAY NUMLEN OF CHAR;
VAR
c: CHAR;
hex: BOOLEAN;
error, sym, i: INTEGER;
num: NUMSTR;
PROCEDURE push (VAR num: NUMSTR; VAR i: INTEGER; c: CHAR);
BEGIN
IF i < NUMLEN - 1 THEN
num[i] := c;
INC(i)
END
END push;
BEGIN
c := text.peak;
ASSERT(S.digit(c));
i := 0;
error := 0;
sym := lxINTEGER;
hex := FALSE;
WHILE S.digit(c) DO
push(num, i, c);
c := nextc(text)
END;
WHILE S.hexdigit(c) OR LowerCase & ("a" <= c) & (c <= "f") DO
S.cap(c);
push(num, i, c);
c := nextc(text);
hex := TRUE
END;
IF (c = "H") OR LowerCase & (c = "h") THEN
push(num, i, c);
TXT.next(text);
sym := lxHEX
ELSIF (c = "X") OR LowerCase & (c = "x") THEN
push(num, i, c);
TXT.next(text);
sym := lxCHAR
ELSIF c = "." THEN
IF hex THEN
sym := lxERROR01
ELSE
c := nextc(text);
IF c # "." THEN
push(num, i, ".");
sym := lxFLOAT
ELSE
sym := lxINTEGER;
text.peak := 7FX;
upto := TRUE
END;
WHILE S.digit(c) DO
push(num, i, c);
c := nextc(text)
END;
IF (c = "E") OR LowerCase & (c = "e") THEN
push(num, i, c);
c := nextc(text);
IF (c = "+") OR (c = "-") THEN
push(num, i, c);
c := nextc(text)
END;
IF S.digit(c) THEN
WHILE S.digit(c) DO
push(num, i, c);
c := nextc(text)
END
ELSE
sym := lxERROR02
END
END
END
ELSIF hex THEN
sym := lxERROR01
END;
IF (i = NUMLEN - 1) & (sym >= 0) THEN
sym := lxERROR07
END;
num[i] := 0X;
IF sym = lxINTEGER THEN
ARITH.iconv(num, lex.value, error)
ELSIF (sym = lxHEX) OR (sym = lxCHAR) THEN
ARITH.hconv(num, lex.value, error)
ELSIF sym = lxFLOAT THEN
ARITH.fconv(num, lex.value, error)
END;
CASE error OF
|0:
|1: sym := lxERROR08
|2: sym := lxERROR09
|3: sym := lxERROR10
|4: sym := lxERROR11
|5: sym := lxERROR12
END;
lex.sym := sym
END number;
PROCEDURE string (text: TXT.TEXT; VAR lex: LEX; quot: CHAR);
VAR
c: CHAR;
i: INTEGER;
str: TEXTSTR;
BEGIN
c := nextc(text);
i := 0;
WHILE (i < LEN(str) - 1) & (c # quot) & (c # 0X) & ~text.eol & ~text.eof DO
str[i] := c;
c := nextc(text);
INC(i)
END;
str[i] := 0X;
IF (i = LEN(str) - 1) & (c # quot) & (c # 0X) & ~text.eol & ~text.eof THEN
lex.sym := lxERROR05
END;
IF c = quot THEN
TXT.next(text);
IF i # 1 THEN
lex.sym := lxSTRING
ELSE
lex.sym := lxCHAR;
ARITH.setChar(lex.value, ORD(str[0]))
END
ELSIF lex.sym # lxERROR05 THEN
lex.sym := lxERROR03
END;
IF lex.sym = lxSTRING THEN
lex.string := enterStr(str);
lex.value.typ := ARITH.tSTRING;
lex.value.string := lex.string
END
END string;
PROCEDURE comment (text: TXT.TEXT);
VAR
c: CHAR;
cond, depth: INTEGER;
BEGIN
cond := 0;
depth := 1;
REPEAT
c := text.peak;
TXT.next(text);
IF c = "*" THEN
IF cond = 1 THEN
cond := 0;
INC(depth)
ELSE
cond := 2
END
ELSIF c = ")" THEN
IF cond = 2 THEN
DEC(depth)
END;
cond := 0
ELSIF c = "(" THEN
cond := 1
ELSE
cond := 0
END
UNTIL (depth = 0) OR text.eof
END comment;
PROCEDURE delimiter (text: TXT.TEXT; c: CHAR): INTEGER;
VAR
sym: INTEGER;
c0: CHAR;
BEGIN
c0 := c;
c := nextc(text);
CASE c0 OF
|"+":
sym := lxPLUS
|"-":
sym := lxMINUS
|"*":
sym := lxMUL
|"/":
sym := lxSLASH;
IF c = "/" THEN
sym := lxCOMMENT;
REPEAT
TXT.next(text)
UNTIL text.eol OR text.eof
END
|"~":
sym := lxNOT
|"&":
sym := lxAND
|".":
sym := lxPOINT;
IF c = "." THEN
sym := lxRANGE;
TXT.next(text)
END
|",":
sym := lxCOMMA
|";":
sym := lxSEMI
|"|":
sym := lxBAR
|"(":
sym := lxLROUND;
IF c = "*" THEN
sym := lxCOMMENT;
TXT.next(text);
comment(text)
END
|"[":
sym := lxLSQUARE
|"{":
sym := lxLCURLY
|"^":
sym := lxCARET
|"=":
sym := lxEQ
|"#":
sym := lxNE
|"<":
sym := lxLT;
IF c = "=" THEN
sym := lxLE;
TXT.next(text)
END
|">":
sym := lxGT;
IF c = "=" THEN
sym := lxGE;
TXT.next(text)
END
|":":
sym := lxCOLON;
IF c = "=" THEN
sym := lxASSIGN;
TXT.next(text)
END
|")":
sym := lxRROUND
|"]":
sym := lxRSQUARE
|"}":
sym := lxRCURLY
END
RETURN sym
END delimiter;
PROCEDURE Next* (text: SCANNER; VAR lex: LEX);
VAR
c: CHAR;
PROCEDURE check (cond: BOOLEAN; text: SCANNER; lex: LEX; errno: INTEGER);
BEGIN
IF ~cond THEN
ERRORS.ErrorMsg(text.fname, lex.pos.line, lex.pos.col, errno)
END
END check;
PROCEDURE IsDef (str: ARRAY OF CHAR): BOOLEAN;
VAR
cur: DEF;
BEGIN
cur := def.first(DEF);
WHILE (cur # NIL) & (cur.ident # str) DO
cur := cur.next(DEF)
END
RETURN cur # NIL
END IsDef;
PROCEDURE Skip (text: SCANNER);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i <= text.ifc) & ~text._skip[i] DO
INC(i)
END;
text.skip := i <= text.ifc
END Skip;
PROCEDURE prep_if (text: SCANNER; VAR lex: LEX);
VAR
skip: BOOLEAN;
BEGIN
INC(text.ifc);
text._elsif[text.ifc] := lex.sym = lxELSIF;
IF lex.sym = lxIF THEN
INC(text.elsec);
text._else[text.elsec] := FALSE
END;
_if := TRUE;
skip := TRUE;
text.skip := FALSE;
Next(text, lex);
check(lex.sym = lxLROUND, text, lex, 64);
Next(text, lex);
check(lex.sym = lxIDENT, text, lex, 22);
REPEAT
IF IsDef(lex.ident.s) THEN
skip := FALSE
END;
Next(text, lex);
IF lex.sym = lxBAR THEN
Next(text, lex);
check(lex.sym = lxIDENT, text, lex, 22)
ELSE
check(lex.sym = lxRROUND, text, lex, 33)
END
UNTIL lex.sym = lxRROUND;
_if := FALSE;
text._skip[text.ifc] := skip;
Skip(text);
Next(text, lex)
END prep_if;
PROCEDURE prep_end (text: SCANNER; VAR lex: LEX);
BEGIN
check(text.ifc > 0, text, lex, 118);
IF lex.sym = lxEND THEN
WHILE text._elsif[text.ifc] DO
DEC(text.ifc)
END;
DEC(text.ifc);
DEC(text.elsec)
ELSIF (lex.sym = lxELSE) OR (lex.sym = lxELSIF) THEN
check(~text._else[text.elsec], text, lex, 118);
text._skip[text.ifc] := ~text._skip[text.ifc];
text._else[text.elsec] := lex.sym = lxELSE
END;
Skip(text);
IF lex.sym = lxELSIF THEN
prep_if(text, lex)
ELSE
Next(text, lex)
END
END prep_end;
BEGIN
REPEAT
c := text.peak;
WHILE S.space(c) DO
c := nextc(text)
END;
lex.pos.line := text.line;
lex.pos.col := text.col;
IF S.letter(c) THEN
ident(text, lex)
ELSIF S.digit(c) THEN
number(text, lex)
ELSIF (c = '"') OR (c = "'") THEN
string(text, lex, c)
ELSIF delimiters[ORD(c)] THEN
lex.sym := delimiter(text, c)
ELSIF c = "$" THEN
IF S.letter(nextc(text)) THEN
ident(text, lex);
IF lex.sym = lxIF THEN
IF ~_if THEN
prep_if(text, lex)
END
ELSIF (lex.sym = lxEND) OR (lex.sym = lxELSE) OR (lex.sym = lxELSIF) THEN
IF ~_if THEN
prep_end(text, lex)
END
ELSE
check(FALSE, text, lex, 119)
END
ELSE
check(FALSE, text, lex, 119)
END
ELSIF c = 0X THEN
lex.sym := lxEOF;
text.skip := FALSE;
IF text.eof THEN
INC(lex.pos.col)
END
ELSIF (c = 7FX) & upto THEN
upto := FALSE;
lex.sym := lxRANGE;
DEC(lex.pos.col);
TXT.next(text)
ELSE
TXT.next(text);
lex.sym := lxERROR04
END;
IF lex.sym < 0 THEN
lex.error := -lex.sym
ELSE
lex.error := 0
END
UNTIL (lex.sym # lxCOMMENT) & ~text.skip
END Next;
PROCEDURE open* (name: ARRAY OF CHAR): SCANNER;
RETURN TXT.open(name)
END open;
PROCEDURE close* (VAR scanner: SCANNER);
BEGIN
TXT.close(scanner)
END close;
PROCEDURE init* (lower: BOOLEAN);
VAR
i: INTEGER;
delim: ARRAY 23 OF CHAR;
BEGIN
upto := FALSE;
LowerCase := lower;
FOR i := 0 TO 255 DO
delimiters[i] := FALSE
END;
delim := "+-*/~&.,;|([{^=#<>:)]}";
FOR i := 0 TO LEN(delim) - 2 DO
delimiters[ORD(delim[i])] := TRUE
END;
enterKW("array", 0);
enterKW("begin", 1);
enterKW("by", 2);
enterKW("case", 3);
enterKW("const", 4);
enterKW("div", 5);
enterKW("do", 6);
enterKW("else", 7);
enterKW("elsif", 8);
enterKW("end", 9);
enterKW("false", 10);
enterKW("for", 11);
enterKW("if", 12);
enterKW("import", 13);
enterKW("in", 14);
enterKW("is", 15);
enterKW("mod", 16);
enterKW("module", 17);
enterKW("nil", 18);
enterKW("of", 19);
enterKW("or", 20);
enterKW("pointer", 21);
enterKW("procedure", 22);
enterKW("record", 23);
enterKW("repeat", 24);
enterKW("return", 25);
enterKW("then", 26);
enterKW("to", 27);
enterKW("true", 28);
enterKW("type", 29);
enterKW("until", 30);
enterKW("var", 31);
enterKW("while", 32)
END init;
PROCEDURE NewDef* (str: ARRAY OF CHAR);
VAR
item: DEF;
BEGIN
NEW(item);
COPY(str, item.ident);
LISTS.push(def, item)
END NewDef;
BEGIN
def := LISTS.create(NIL);
strings := LISTS.create(NIL)
END SCAN.

/programs/develop/oberon07/source/STATEMENTS.ob07
0,0 → 1,3406
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE STATEMENTS;
IMPORT
PARS, PROG, SCAN, ARITH, STRINGS, LISTS, IL, X86, AMD64, MSP430, THUMB, RVMxI,
ERRORS, UTILS, AVL := AVLTREES, CONSOLE, C := COLLECTIONS, TARGETS;
CONST
eCONST = PARS.eCONST; eTYPE = PARS.eTYPE; eVAR = PARS.eVAR;
eEXPR = PARS.eEXPR; eVREC = PARS.eVREC; ePROC = PARS.ePROC;
eVPAR = PARS.eVPAR; ePARAM = PARS.ePARAM; eSTPROC = PARS.eSTPROC;
eSTFUNC = PARS.eSTFUNC; eSYSFUNC = PARS.eSYSFUNC; eSYSPROC = PARS.eSYSPROC;
eIMP = PARS.eIMP;
errASSERT = 1; errPTR = 2; errDIV = 3; errPROC = 4;
errGUARD = 5; errIDX = 6; errCASE = 7; errCOPY = 8;
errCHR = 9; errWCHR = 10; errBYTE = 11;
chkIDX* = 0; chkGUARD* = 1; chkPTR* = 2; chkCHR* = 3; chkWCHR* = 4; chkBYTE* = 5;
chkSTK* = MSP430.chkSTK; (* 6 *)
chkALL* = {chkIDX, chkGUARD, chkPTR, chkCHR, chkWCHR, chkBYTE, chkSTK};
TYPE
isXXX = PROCEDURE (e: PARS.EXPR): BOOLEAN;
RANGE = RECORD
a, b: INTEGER
END;
CASE_LABEL = POINTER TO rCASE_LABEL;
rCASE_LABEL = RECORD (AVL.DATA)
range: RANGE;
variant, self: INTEGER;
_type: PROG._TYPE;
prev: CASE_LABEL
END;
CASE_VARIANT = POINTER TO RECORD (LISTS.ITEM)
label: INTEGER;
cmd: IL.COMMAND;
processed: BOOLEAN
END;
VAR
Options: PROG.OPTIONS;
begcall, endcall: IL.COMMAND;
CaseLabels, CaseVar: C.COLLECTION;
CaseVariants: LISTS.LIST;
CPU: INTEGER;
tINTEGER, tBYTE, tCHAR, tWCHAR, tSET, tBOOLEAN, tREAL: PROG._TYPE;
PROCEDURE isExpr (e: PARS.EXPR): BOOLEAN;
RETURN e.obj IN {eCONST, eVAR, eEXPR, eVPAR, ePARAM, eVREC}
END isExpr;
PROCEDURE isVar (e: PARS.EXPR): BOOLEAN;
RETURN e.obj IN {eVAR, eVPAR, ePARAM, eVREC}
END isVar;
PROCEDURE isBoolean (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tBOOLEAN)
END isBoolean;
PROCEDURE isInteger (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tINTEGER)
END isInteger;
PROCEDURE isByte (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tBYTE)
END isByte;
PROCEDURE isInt (e: PARS.EXPR): BOOLEAN;
RETURN isByte(e) OR isInteger(e)
END isInt;
PROCEDURE isReal (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tREAL)
END isReal;
PROCEDURE isSet (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tSET)
END isSet;
PROCEDURE isString (e: PARS.EXPR): BOOLEAN;
RETURN (e.obj = eCONST) & (e._type.typ IN {PROG.tSTRING, PROG.tCHAR})
END isString;
PROCEDURE isStringW (e: PARS.EXPR): BOOLEAN;
RETURN (e.obj = eCONST) & (e._type.typ IN {PROG.tSTRING, PROG.tCHAR, PROG.tWCHAR})
END isStringW;
PROCEDURE isChar (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tCHAR)
END isChar;
PROCEDURE isCharW (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tWCHAR)
END isCharW;
PROCEDURE isPtr (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type.typ = PROG.tPOINTER)
END isPtr;
PROCEDURE isRec (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type.typ = PROG.tRECORD)
END isRec;
PROCEDURE isRecPtr (e: PARS.EXPR): BOOLEAN;
RETURN isRec(e) OR isPtr(e)
END isRecPtr;
PROCEDURE isArr (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type.typ = PROG.tARRAY)
END isArr;
PROCEDURE isProc (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type.typ = PROG.tPROCEDURE) OR (e.obj IN {ePROC, eIMP})
END isProc;
PROCEDURE isNil (e: PARS.EXPR): BOOLEAN;
RETURN e._type.typ = PROG.tNIL
END isNil;
PROCEDURE isCharArray (e: PARS.EXPR): BOOLEAN;
RETURN isArr(e) & (e._type.base = tCHAR)
END isCharArray;
PROCEDURE isCharArrayW (e: PARS.EXPR): BOOLEAN;
RETURN isArr(e) & (e._type.base = tWCHAR)
END isCharArrayW;
PROCEDURE isCharArrayX (e: PARS.EXPR): BOOLEAN;
RETURN isCharArray(e) OR isCharArrayW(e)
END isCharArrayX;
PROCEDURE getpos (parser: PARS.PARSER; VAR pos: PARS.POSITION);
BEGIN
pos.line := parser.lex.pos.line;
pos.col := parser.lex.pos.col;
pos.parser := parser
END getpos;
PROCEDURE NextPos (parser: PARS.PARSER; VAR pos: PARS.POSITION);
BEGIN
PARS.Next(parser);
getpos(parser, pos)
END NextPos;
PROCEDURE strlen (e: PARS.EXPR): INTEGER;
VAR
res: INTEGER;
BEGIN
ASSERT(isString(e));
IF e._type = tCHAR THEN
res := 1
ELSE
res := LENGTH(e.value.string(SCAN.STRING).s)
END
RETURN res
END strlen;
PROCEDURE _length (s: ARRAY OF CHAR): INTEGER;
VAR
i, res: INTEGER;
BEGIN
i := 0;
res := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
IF (s[i] <= CHR(127)) OR (s[i] >= CHR(192)) THEN
INC(res)
END;
INC(i)
END
RETURN res
END _length;
PROCEDURE utf8strlen (e: PARS.EXPR): INTEGER;
VAR
res: INTEGER;
BEGIN
ASSERT(isStringW(e));
IF e._type.typ IN {PROG.tCHAR, PROG.tWCHAR} THEN
res := 1
ELSE
res := _length(e.value.string(SCAN.STRING).s)
END
RETURN res
END utf8strlen;
PROCEDURE StrToWChar (s: ARRAY OF CHAR): INTEGER;
VAR
res: ARRAY 2 OF WCHAR;
BEGIN
ASSERT(STRINGS.Utf8To16(s, res) = 1)
RETURN ORD(res[0])
END StrToWChar;
PROCEDURE isStringW1 (e: PARS.EXPR): BOOLEAN;
RETURN isString(e) & (utf8strlen(e) = 1) & (strlen(e) > 1)
END isStringW1;
PROCEDURE assigncomp (e: PARS.EXPR; t: PROG._TYPE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN
IF t = e._type THEN
res := TRUE
ELSIF isInt(e) & (t.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN
IF (e.obj = eCONST) & (t = tBYTE) THEN
res := ARITH.range(e.value, 0, 255)
ELSE
res := TRUE
END
ELSIF
(e.obj = eCONST) & isChar(e) & (t = tWCHAR)
OR isStringW1(e) & (t = tWCHAR)
OR PROG.isBaseOf(t, e._type)
OR ~PROG.isOpenArray(t) & ~PROG.isOpenArray(e._type) & PROG.isTypeEq(t, e._type)
OR isNil(e) & (t.typ IN {PROG.tPOINTER, PROG.tPROCEDURE})
OR PROG.arrcomp(e._type, t)
OR isString(e) & (t.typ = PROG.tARRAY) & (t.base = tCHAR) & (t.length > strlen(e))
OR isStringW(e) & (t.typ = PROG.tARRAY) & (t.base = tWCHAR) & (t.length > utf8strlen(e))
THEN
res := TRUE
ELSE
res := FALSE
END
ELSE
res := FALSE
END
RETURN res
END assigncomp;
PROCEDURE String (e: PARS.EXPR): INTEGER;
VAR
offset: INTEGER;
string: SCAN.STRING;
BEGIN
IF strlen(e) # 1 THEN
string := e.value.string(SCAN.STRING);
IF string.offset = -1 THEN
string.offset := IL.putstr(string.s);
END;
offset := string.offset
ELSE
offset := IL.putstr1(ARITH.Int(e.value))
END
RETURN offset
END String;
PROCEDURE StringW (e: PARS.EXPR): INTEGER;
VAR
offset: INTEGER;
string: SCAN.STRING;
BEGIN
IF utf8strlen(e) # 1 THEN
string := e.value.string(SCAN.STRING);
IF string.offsetW = -1 THEN
string.offsetW := IL.putstrW(string.s);
END;
offset := string.offsetW
ELSE
IF e._type.typ IN {PROG.tWCHAR, PROG.tCHAR} THEN
offset := IL.putstrW1(ARITH.Int(e.value))
ELSE (* e._type.typ = PROG.tSTRING *)
string := e.value.string(SCAN.STRING);
IF string.offsetW = -1 THEN
string.offsetW := IL.putstrW(string.s);
END;
offset := string.offsetW
END
END
RETURN offset
END StringW;
PROCEDURE CheckRange (range, line, errno: INTEGER);
VAR
label: INTEGER;
BEGIN
label := IL.NewLabel();
IL.AddCmd2(IL.opCHKIDX, label, range);
IL.OnError(line, errno);
IL.SetLabel(label)
END CheckRange;
PROCEDURE Float (parser: PARS.PARSER; e: PARS.EXPR);
VAR
pos: PARS.POSITION;
BEGIN
getpos(parser, pos);
IL.Float(ARITH.Float(e.value), pos.line, pos.col)
END Float;
PROCEDURE assign (parser: PARS.PARSER; e: PARS.EXPR; VarType: PROG._TYPE; line: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
label: INTEGER;
BEGIN
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN
res := TRUE;
IF PROG.arrcomp(e._type, VarType) THEN
IF ~PROG.isOpenArray(VarType) THEN
IL.Const(VarType.length)
END;
IL.AddCmd(IL.opCOPYA, VarType.base.size);
label := IL.NewLabel();
IL.Jmp(IL.opJNZ, label);
IL.OnError(line, errCOPY);
IL.SetLabel(label)
ELSIF isInt(e) & (VarType.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN
IF VarType = tINTEGER THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVEC, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSAVE)
END
ELSE
IF e.obj = eCONST THEN
res := ARITH.range(e.value, 0, 255);
IF res THEN
IL.AddCmd(IL.opSAVE8C, ARITH.Int(e.value))
END
ELSE
IF chkBYTE IN Options.checking THEN
label := IL.NewLabel();
IL.AddCmd2(IL.opCHKBYTE, label, 0);
IL.OnError(line, errBYTE);
IL.SetLabel(label)
END;
IL.AddCmd0(IL.opSAVE8)
END
END
ELSIF isSet(e) & (VarType = tSET) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVEC, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSAVE)
END
ELSIF isBoolean(e) & (VarType = tBOOLEAN) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSBOOLC, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSBOOL)
END
ELSIF isReal(e) & (VarType = tREAL) THEN
IF e.obj = eCONST THEN
Float(parser, e)
END;
IL.savef(e.obj = eCONST)
ELSIF isChar(e) & (VarType = tCHAR) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVE8C, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSAVE8)
END
ELSIF (e.obj = eCONST) & isChar(e) & (VarType = tWCHAR) THEN
IL.AddCmd(IL.opSAVE16C, ARITH.Int(e.value))
ELSIF isStringW1(e) & (VarType = tWCHAR) THEN
IL.AddCmd(IL.opSAVE16C, StrToWChar(e.value.string(SCAN.STRING).s))
ELSIF isCharW(e) & (VarType = tWCHAR) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVE16C, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSAVE16)
END
ELSIF PROG.isBaseOf(VarType, e._type) THEN
IF VarType.typ = PROG.tPOINTER THEN
IL.AddCmd0(IL.opSAVE)
ELSE
IL.AddCmd(IL.opCOPY, VarType.size)
END
ELSIF (e._type.typ = PROG.tCARD32) & (VarType.typ = PROG.tCARD32) THEN
IL.AddCmd0(IL.opSAVE32)
ELSIF ~PROG.isOpenArray(VarType) & ~PROG.isOpenArray(e._type) & PROG.isTypeEq(VarType, e._type) THEN
IF e.obj = ePROC THEN
IL.AssignProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
IL.AssignImpProc(e.ident._import)
ELSE
IF VarType.typ = PROG.tPROCEDURE THEN
IL.AddCmd0(IL.opSAVE)
ELSE
IL.AddCmd(IL.opCOPY, VarType.size)
END
END
ELSIF isNil(e) & (VarType.typ IN {PROG.tPOINTER, PROG.tPROCEDURE}) THEN
IL.AddCmd(IL.opSAVEC, 0)
ELSIF isString(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base = tCHAR) & (VarType.length > strlen(e))) THEN
IL.saves(String(e), strlen(e) + 1)
ELSIF isStringW(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base = tWCHAR) & (VarType.length > utf8strlen(e))) THEN
IL.saves(StringW(e), (utf8strlen(e) + 1) * 2)
ELSE
res := FALSE
END
ELSE
res := FALSE
END
RETURN res
END assign;
PROCEDURE LoadConst (e: PARS.EXPR);
BEGIN
IL.Const(ARITH.Int(e.value))
END LoadConst;
PROCEDURE paramcomp (parser: PARS.PARSER; pos: PARS.POSITION; e: PARS.EXPR; p: PROG.PARAM);
VAR
stroffs: INTEGER;
PROCEDURE arrcomp (e: PARS.EXPR; p: PROG.PARAM): BOOLEAN;
VAR
t1, t2: PROG._TYPE;
BEGIN
t1 := p._type;
t2 := e._type;
WHILE (t2.typ = PROG.tARRAY) & PROG.isOpenArray(t1) DO
t1 := t1.base;
t2 := t2.base
END
RETURN PROG.isTypeEq(t1, t2)
END arrcomp;
PROCEDURE ArrLen (t: PROG._TYPE; n: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
REPEAT
res := t.length;
t := t.base;
DEC(n)
UNTIL (n < 0) OR (t.typ # PROG.tARRAY);
ASSERT(n < 0)
RETURN res
END ArrLen;
PROCEDURE OpenArray (t, t2: PROG._TYPE);
VAR
n, d1, d2: INTEGER;
BEGIN
IF t.length # 0 THEN
IL.Param1;
n := PROG.Dim(t2) - 1;
WHILE n >= 0 DO
IL.Const(ArrLen(t, n));
IL.Param1;
DEC(n)
END
ELSE
d1 := PROG.Dim(t);
d2 := PROG.Dim(t2);
IF d1 # d2 THEN
n := d2 - d1;
WHILE d2 > d1 DO
IL.Const(ArrLen(t, d2 - 1));
DEC(d2)
END;
d2 := PROG.Dim(t2);
WHILE n > 0 DO
IL.AddCmd(IL.opROT, d2);
DEC(n)
END
END;
IL.AddCmd(IL.opPARAM, PROG.Dim(t2) + 1)
END
END OpenArray;
BEGIN
IF p.vPar THEN
PARS.check(isVar(e), pos, 93);
IF p._type.typ = PROG.tRECORD THEN
PARS.check(PROG.isBaseOf(p._type, e._type), pos, 66);
IF e.obj = eVREC THEN
IF e.ident # NIL THEN
IL.AddCmd(IL.opVADR, e.ident.offset - 1)
ELSE
IL.AddCmd0(IL.opPUSHT)
END
ELSE
IL.Const(e._type.num)
END;
IL.AddCmd(IL.opPARAM, 2)
ELSIF PROG.isOpenArray(p._type) THEN
PARS.check(arrcomp(e, p), pos, 66);
OpenArray(e._type, p._type)
ELSE
PARS.check(PROG.isTypeEq(e._type, p._type), pos, 66);
IL.Param1
END;
PARS.check(~e.readOnly, pos, 94)
ELSE
PARS.check(isExpr(e) OR isProc(e), pos, 66);
IF PROG.isOpenArray(p._type) THEN
IF e._type.typ = PROG.tARRAY THEN
PARS.check(arrcomp(e, p), pos, 66);
OpenArray(e._type, p._type)
ELSIF isString(e) & (p._type.typ = PROG.tARRAY) & (p._type.base = tCHAR) THEN
IL.StrAdr(String(e));
IL.Param1;
IL.Const(strlen(e) + 1);
IL.Param1
ELSIF isStringW(e) & (p._type.typ = PROG.tARRAY) & (p._type.base = tWCHAR) THEN
IL.StrAdr(StringW(e));
IL.Param1;
IL.Const(utf8strlen(e) + 1);
IL.Param1
ELSE
PARS.error(pos, 66)
END
ELSE
PARS.check(~PROG.isOpenArray(e._type), pos, 66);
PARS.check(assigncomp(e, p._type), pos, 66);
IF e.obj = eCONST THEN
IF e._type = tREAL THEN
Float(parser, e);
IL.AddCmd0(IL.opPUSHF)
ELSIF e._type.typ = PROG.tNIL THEN
IL.Const(0);
IL.Param1
ELSIF isStringW1(e) & (p._type = tWCHAR) THEN
IL.Const(StrToWChar(e.value.string(SCAN.STRING).s));
IL.Param1
ELSIF (e._type.typ = PROG.tSTRING) OR
(e._type.typ IN {PROG.tCHAR, PROG.tWCHAR}) & (p._type.typ = PROG.tARRAY) & (p._type.base.typ IN {PROG.tCHAR, PROG.tWCHAR}) THEN
IF p._type.base = tCHAR THEN
stroffs := String(e);
IL.StrAdr(stroffs);
IF (CPU = TARGETS.cpuMSP430) & (p._type.size - strlen(e) - 1 > MSP430.IntVectorSize) THEN
ERRORS.WarningMsg(pos.line, pos.col, 0)
END
ELSE (* WCHAR *)
stroffs := StringW(e);
IL.StrAdr(stroffs)
END;
IL.set_dmin(stroffs + p._type.size);
IL.Param1
ELSE
LoadConst(e);
IL.Param1
END
ELSIF e.obj = ePROC THEN
PARS.check(e.ident.global, pos, 85);
IL.PushProc(e.ident.proc.label);
IL.Param1
ELSIF e.obj = eIMP THEN
IL.PushImpProc(e.ident._import);
IL.Param1
ELSIF isExpr(e) & (e._type = tREAL) THEN
IL.AddCmd0(IL.opPUSHF)
ELSE
IF (p._type = tBYTE) & (e._type = tINTEGER) & (chkBYTE IN Options.checking) THEN
CheckRange(256, pos.line, errBYTE)
END;
IL.Param1
END
END
END
END paramcomp;
PROCEDURE PExpression (parser: PARS.PARSER; VAR e: PARS.EXPR);
BEGIN
parser.expression(parser, e)
END PExpression;
PROCEDURE stProc (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
e1, e2: PARS.EXPR;
pos: PARS.POSITION;
proc,
label,
size,
n, i: INTEGER;
code: ARITH.VALUE;
wchar,
comma: BOOLEAN;
cmd1,
cmd2: IL.COMMAND;
PROCEDURE varparam (parser: PARS.PARSER; pos: PARS.POSITION; isfunc: isXXX; readOnly: BOOLEAN; VAR e: PARS.EXPR);
BEGIN
parser.designator(parser, e);
PARS.check(isVar(e), pos, 93);
PARS.check(isfunc(e), pos, 66);
IF readOnly THEN
PARS.check(~e.readOnly, pos, 94)
END
END varparam;
PROCEDURE shift_minmax (proc: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
CASE proc OF
|PROG.stASR: res := "A"
|PROG.stLSL: res := "L"
|PROG.stROR: res := "O"
|PROG.stLSR: res := "R"
|PROG.stMIN: res := "m"
|PROG.stMAX: res := "x"
END
RETURN res
END shift_minmax;
BEGIN
ASSERT(e.obj IN {eSTPROC, eSTFUNC, eSYSPROC, eSYSFUNC});
proc := e.stproc;
(* IF (proc # PROG.sysNOP) & (proc # PROG.sysEINT) & (proc # PROG.sysDINT) THEN *)
PARS.checklex(parser, SCAN.lxLROUND);
PARS.Next(parser);
(* END; *)
getpos(parser, pos);
IF e.obj IN {eSTPROC, eSYSPROC} THEN
CASE proc OF
|PROG.stASSERT:
PExpression(parser, e);
PARS.check(isBoolean(e), pos, 66);
IF e.obj = eCONST THEN
IF ~ARITH.getBool(e.value) THEN
IL.OnError(pos.line, errASSERT)
END
ELSE
label := IL.NewLabel();
IL.not;
IL.AndOrOpt(label);
IL.OnError(pos.line, errASSERT);
IL.SetLabel(label)
END
|PROG.stINC, PROG.stDEC:
IL.pushBegEnd(begcall, endcall);
varparam(parser, pos, isInt, TRUE, e);
IF e._type = tINTEGER THEN
IF parser.sym = SCAN.lxCOMMA THEN
NextPos(parser, pos);
IL.setlast(begcall);
PExpression(parser, e2);
IL.setlast(endcall.prev(IL.COMMAND));
PARS.check(isInt(e2), pos, 66);
IF e2.obj = eCONST THEN
IL.AddCmd(IL.opINCC, ARITH.Int(e2.value) * (ORD(proc = PROG.stINC) * 2 - 1))
ELSE
IL.AddCmd0(IL.opINC + ORD(proc = PROG.stDEC))
END
ELSE
IL.AddCmd(IL.opINCC, ORD(proc = PROG.stINC) * 2 - 1)
END
ELSE (* e._type = tBYTE *)
IF parser.sym = SCAN.lxCOMMA THEN
NextPos(parser, pos);
IL.setlast(begcall);
PExpression(parser, e2);
IL.setlast(endcall.prev(IL.COMMAND));
PARS.check(isInt(e2), pos, 66);
IF e2.obj = eCONST THEN
IL.AddCmd(IL.opINCCB + ORD(proc = PROG.stDEC), ARITH.Int(e2.value))
ELSE
IL.AddCmd0(IL.opINCB + ORD(proc = PROG.stDEC))
END
ELSE
IL.AddCmd(IL.opINCCB + ORD(proc = PROG.stDEC), 1)
END
END;
IL.popBegEnd(begcall, endcall)
|PROG.stINCL, PROG.stEXCL:
IL.pushBegEnd(begcall, endcall);
varparam(parser, pos, isSet, TRUE, e);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
IL.setlast(begcall);
PExpression(parser, e2);
IL.setlast(endcall.prev(IL.COMMAND));
PARS.check(isInt(e2), pos, 66);
IF e2.obj = eCONST THEN
PARS.check(ARITH.range(e2.value, 0, UTILS.target.maxSet), pos, 56);
IL.AddCmd(IL.opINCLC + ORD(proc = PROG.stEXCL), ARITH.Int(e2.value))
ELSE
IL.AddCmd0(IL.opINCL + ORD(proc = PROG.stEXCL))
END;
IL.popBegEnd(begcall, endcall)
|PROG.stNEW:
varparam(parser, pos, isPtr, TRUE, e);
IF CPU = TARGETS.cpuMSP430 THEN
PARS.check(e._type.base.size + 16 < Options.ram, pos, 63)
END;
IL.New(e._type.base.size, e._type.base.num)
|PROG.stDISPOSE:
varparam(parser, pos, isPtr, TRUE, e);
IL.AddCmd0(IL.opDISP)
|PROG.stPACK:
varparam(parser, pos, isReal, TRUE, e);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
PExpression(parser, e2);
PARS.check(isInt(e2), pos, 66);
IF e2.obj = eCONST THEN
IL.AddCmd(IL.opPACKC, ARITH.Int(e2.value))
ELSE
IL.AddCmd0(IL.opPACK)
END
|PROG.stUNPK:
varparam(parser, pos, isReal, TRUE, e);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
varparam(parser, pos, isInteger, TRUE, e2);
IL.AddCmd0(IL.opUNPK)
|PROG.stCOPY:
IL.pushBegEnd(begcall, endcall);
PExpression(parser, e);
IF isString(e) OR isCharArray(e) THEN
wchar := FALSE
ELSIF isStringW(e) OR isCharArrayW(e) THEN
wchar := TRUE
ELSE
PARS.error(pos, 66)
END;
IF isCharArrayX(e) & ~PROG.isOpenArray(e._type) THEN
IL.Const(e._type.length)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
IL.setlast(begcall);
IF wchar THEN
varparam(parser, pos, isCharArrayW, TRUE, e1)
ELSE
IF e.obj = eCONST THEN
varparam(parser, pos, isCharArrayX, TRUE, e1)
ELSE
varparam(parser, pos, isCharArray, TRUE, e1)
END;
wchar := e1._type.base = tWCHAR
END;
IF ~PROG.isOpenArray(e1._type) THEN
IL.Const(e1._type.length)
END;
IL.setlast(endcall.prev(IL.COMMAND));
IF e.obj = eCONST THEN
IF wchar THEN
IL.StrAdr(StringW(e));
IL.Const(utf8strlen(e) + 1)
ELSE
IL.StrAdr(String(e));
IL.Const(strlen(e) + 1)
END
END;
IL.AddCmd(IL.opCOPYS, e1._type.base.size);
IL.popBegEnd(begcall, endcall)
|PROG.sysGET, PROG.sysGET8, PROG.sysGET16, PROG.sysGET32:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
parser.designator(parser, e2);
PARS.check(isVar(e2), pos, 93);
IF proc = PROG.sysGET THEN
PARS.check(e2._type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66)
ELSE
PARS.check(e2._type.typ IN {PROG.tINTEGER, PROG.tBYTE, PROG.tCHAR, PROG.tSET, PROG.tWCHAR, PROG.tCARD32}, pos, 66)
END;
CASE proc OF
|PROG.sysGET: size := e2._type.size
|PROG.sysGET8: size := 1
|PROG.sysGET16: size := 2
|PROG.sysGET32: size := 4
END;
PARS.check(size <= e2._type.size, pos, 66);
IF e.obj = eCONST THEN
IL.AddCmd2(IL.opGETC, ARITH.Int(e.value), size)
ELSE
IL.AddCmd(IL.opGET, size)
END
|PROG.sysPUT, PROG.sysPUT8, PROG.sysPUT16, PROG.sysPUT32:
IL.pushBegEnd(begcall, endcall);
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
IL.setlast(begcall);
PExpression(parser, e2);
PARS.check(isExpr(e2), pos, 66);
IF proc = PROG.sysPUT THEN
PARS.check(e2._type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66);
IF e2.obj = eCONST THEN
IF e2._type = tREAL THEN
Float(parser, e2);
IL.setlast(endcall.prev(IL.COMMAND));
IL.savef(FALSE)
ELSE
LoadConst(e2);
IL.setlast(endcall.prev(IL.COMMAND));
IL.SysPut(e2._type.size)
END
ELSE
IL.setlast(endcall.prev(IL.COMMAND));
IF e2._type = tREAL THEN
IL.savef(FALSE)
ELSIF e2._type = tBYTE THEN
IL.SysPut(tINTEGER.size)
ELSE
IL.SysPut(e2._type.size)
END
END
ELSIF (proc = PROG.sysPUT8) OR (proc = PROG.sysPUT16) OR (proc = PROG.sysPUT32) THEN
PARS.check(e2._type.typ IN {PROG.tINTEGER, PROG.tBYTE, PROG.tCHAR, PROG.tSET, PROG.tWCHAR, PROG.tCARD32}, pos, 66);
IF e2.obj = eCONST THEN
LoadConst(e2)
END;
IL.setlast(endcall.prev(IL.COMMAND));
CASE proc OF
|PROG.sysPUT8: size := 1
|PROG.sysPUT16: size := 2
|PROG.sysPUT32: size := 4
END;
IL.SysPut(size)
END;
IL.popBegEnd(begcall, endcall)
|PROG.sysMOVE:
FOR i := 1 TO 2 DO
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos)
END;
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
IL.AddCmd0(IL.opMOVE)
|PROG.sysCOPY:
FOR i := 1 TO 2 DO
parser.designator(parser, e);
PARS.check(isVar(e), pos, 93);
n := PROG.Dim(e._type);
WHILE n > 0 DO
IL.drop;
DEC(n)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos)
END;
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
IL.AddCmd0(IL.opMOVE)
|PROG.sysCODE:
REPEAT
getpos(parser, pos);
PARS.ConstExpression(parser, code);
PARS.check(code.typ = ARITH.tINTEGER, pos, 43);
IF TARGETS.WordSize > TARGETS.InstrSize THEN
CASE TARGETS.InstrSize OF
|1: PARS.check(ARITH.range(code, 0, 255), pos, 42)
|2: PARS.check(ARITH.range(code, 0, 65535), pos, 110)
END
END;
IL.AddCmd(IL.opCODE, ARITH.getInt(code));
comma := parser.sym = SCAN.lxCOMMA;
IF comma THEN
PARS.Next(parser)
ELSE
PARS.checklex(parser, SCAN.lxRROUND)
END
UNTIL (parser.sym = SCAN.lxRROUND) & ~comma
(*
|PROG.sysNOP, PROG.sysDINT, PROG.sysEINT:
IF parser.sym = SCAN.lxLROUND THEN
PARS.Next(parser);
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser)
END;
ASSERT(CPU = cpuMSP430);
CASE proc OF
|PROG.sysNOP: IL.AddCmd(IL.opCODE, 4303H)
|PROG.sysDINT: IL.AddCmd(IL.opCODE, 0C232H); IL.AddCmd(IL.opCODE, 4303H)
|PROG.sysEINT: IL.AddCmd(IL.opCODE, 0D232H)
END
*)
END;
e.obj := eEXPR;
e._type := NIL
ELSIF e.obj IN {eSTFUNC, eSYSFUNC} THEN
CASE e.stproc OF
|PROG.stABS:
PExpression(parser, e);
PARS.check(isInt(e) OR isReal(e), pos, 66);
IF e.obj = eCONST THEN
PARS.check(ARITH.abs(e.value), pos, 39)
ELSE
IL.abs(isReal(e))
END
|PROG.stASR, PROG.stLSL, PROG.stROR, PROG.stLSR, PROG.stMIN, PROG.stMAX:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
PExpression(parser, e2);
PARS.check(isInt(e2), pos, 66);
e._type := tINTEGER;
IF (e.obj = eCONST) & (e2.obj = eCONST) THEN
ASSERT(ARITH.opInt(e.value, e2.value, shift_minmax(proc)))
ELSE
IF e.obj = eCONST THEN
IL.shift_minmax1(shift_minmax(proc), ARITH.Int(e.value))
ELSIF e2.obj = eCONST THEN
IL.shift_minmax2(shift_minmax(proc), ARITH.Int(e2.value))
ELSE
IL.shift_minmax(shift_minmax(proc))
END;
e.obj := eEXPR
END
|PROG.stCHR:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e._type := tCHAR;
IF e.obj = eCONST THEN
ARITH.setChar(e.value, ARITH.getInt(e.value));
PARS.check(ARITH.check(e.value), pos, 107)
ELSE
IF chkCHR IN Options.checking THEN
CheckRange(256, pos.line, errCHR)
ELSE
IL.AddCmd0(IL.opCHR)
END
END
|PROG.stWCHR:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e._type := tWCHAR;
IF e.obj = eCONST THEN
ARITH.setWChar(e.value, ARITH.getInt(e.value));
PARS.check(ARITH.check(e.value), pos, 101)
ELSE
IF chkWCHR IN Options.checking THEN
CheckRange(65536, pos.line, errWCHR)
ELSE
IL.AddCmd0(IL.opWCHR)
END
END
|PROG.stFLOOR:
PExpression(parser, e);
PARS.check(isReal(e), pos, 66);
e._type := tINTEGER;
IF e.obj = eCONST THEN
PARS.check(ARITH.floor(e.value), pos, 39)
ELSE
IL.AddCmd0(IL.opFLOOR)
END
|PROG.stFLT:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e._type := tREAL;
IF e.obj = eCONST THEN
ARITH.flt(e.value)
ELSE
IL.AddCmd2(IL.opFLT, pos.line, pos.col)
END
|PROG.stLEN:
cmd1 := IL.getlast();
varparam(parser, pos, isArr, FALSE, e);
IF e._type.length > 0 THEN
cmd2 := IL.getlast();
IL.delete2(cmd1.next, cmd2);
IL.setlast(cmd1);
ASSERT(ARITH.setInt(e.value, e._type.length));
e.obj := eCONST
ELSE
IL.len(PROG.Dim(e._type))
END;
e._type := tINTEGER
|PROG.stLENGTH:
PExpression(parser, e);
IF isCharArray(e) THEN
IF e._type.length > 0 THEN
IL.Const(e._type.length)
END;
IL.AddCmd0(IL.opLENGTH)
ELSIF isCharArrayW(e) THEN
IF e._type.length > 0 THEN
IL.Const(e._type.length)
END;
IL.AddCmd0(IL.opLENGTHW)
ELSE
PARS.error(pos, 66);
END;
e._type := tINTEGER
|PROG.stODD:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e._type := tBOOLEAN;
IF e.obj = eCONST THEN
ARITH.odd(e.value)
ELSE
IL.AddCmd(IL.opMODR, 2)
END
|PROG.stORD:
IL.AddCmd(IL.opPRECALL, 0);
PExpression(parser, e);
PARS.check(isChar(e) OR isBoolean(e) OR isSet(e) OR isCharW(e) OR isStringW1(e), pos, 66);
IF e.obj = eCONST THEN
IF isStringW1(e) THEN
ASSERT(ARITH.setInt(e.value, StrToWChar(e.value.string(SCAN.STRING).s)))
ELSE
ARITH.ord(e.value)
END
ELSE
IF isBoolean(e) THEN
IL._ord
END
END;
e._type := tINTEGER
|PROG.stBITS:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
IF e.obj = eCONST THEN
ARITH.bits(e.value)
END;
e._type := tSET
|PROG.sysADR:
parser.designator(parser, e);
IF isVar(e) THEN
n := PROG.Dim(e._type);
WHILE n > 0 DO
IL.drop;
DEC(n)
END
ELSIF e.obj = ePROC THEN
IL.PushProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
IL.PushImpProc(e.ident._import)
ELSE
PARS.error(pos, 108)
END;
e._type := tINTEGER
|PROG.sysSADR:
PExpression(parser, e);
PARS.check(isString(e), pos, 66);
IL.StrAdr(String(e));
e._type := tINTEGER;
e.obj := eEXPR
|PROG.sysWSADR:
PExpression(parser, e);
PARS.check(isStringW(e), pos, 66);
IL.StrAdr(StringW(e));
e._type := tINTEGER;
e.obj := eEXPR
|PROG.sysTYPEID:
PExpression(parser, e);
PARS.check(e.obj = eTYPE, pos, 68);
IF e._type.typ = PROG.tRECORD THEN
ASSERT(ARITH.setInt(e.value, e._type.num))
ELSIF e._type.typ = PROG.tPOINTER THEN
ASSERT(ARITH.setInt(e.value, e._type.base.num))
ELSE
PARS.error(pos, 52)
END;
e.obj := eCONST;
e._type := tINTEGER
|PROG.sysINF:
IL.AddCmd2(IL.opINF, pos.line, pos.col);
e.obj := eEXPR;
e._type := tREAL
|PROG.sysSIZE:
PExpression(parser, e);
PARS.check(e.obj = eTYPE, pos, 68);
ASSERT(ARITH.setInt(e.value, e._type.size));
e.obj := eCONST;
e._type := tINTEGER
END
END;
(* IF (proc # PROG.sysNOP) & (proc # PROG.sysEINT) & (proc # PROG.sysDINT) THEN *)
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser);
(* END; *)
IF e.obj # eCONST THEN
e.obj := eEXPR
END
END stProc;
PROCEDURE ActualParameters (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
proc: PROG._TYPE;
param: LISTS.ITEM;
e1: PARS.EXPR;
pos: PARS.POSITION;
BEGIN
ASSERT(parser.sym = SCAN.lxLROUND);
IF (e.obj IN {ePROC, eIMP}) OR isExpr(e) THEN
proc := e._type;
PARS.check1(proc.typ = PROG.tPROCEDURE, parser, 86);
PARS.Next(parser);
param := proc.params.first;
WHILE param # NIL DO
getpos(parser, pos);
IL.setlast(begcall);
IF param(PROG.PARAM).vPar THEN
parser.designator(parser, e1)
ELSE
PExpression(parser, e1)
END;
paramcomp(parser, pos, e1, param(PROG.PARAM));
param := param.next;
IF param # NIL THEN
PARS.checklex(parser, SCAN.lxCOMMA);
PARS.Next(parser)
END
END;
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser);
e.obj := eEXPR;
e._type := proc.base
ELSIF e.obj IN {eSTPROC, eSTFUNC, eSYSPROC, eSYSFUNC} THEN
stProc(parser, e)
ELSE
PARS.check1(FALSE, parser, 86)
END
END ActualParameters;
PROCEDURE qualident (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
ident: PROG.IDENT;
imp: BOOLEAN;
pos: PARS.POSITION;
BEGIN
PARS.checklex(parser, SCAN.lxIDENT);
getpos(parser, pos);
imp := FALSE;
ident := PROG.getIdent(parser.unit, parser.lex.ident, FALSE);
PARS.check1(ident # NIL, parser, 48);
IF ident.typ = PROG.idMODULE THEN
PARS.ExpectSym(parser, SCAN.lxPOINT);
PARS.ExpectSym(parser, SCAN.lxIDENT);
ident := PROG.getIdent(ident.unit, parser.lex.ident, FALSE);
PARS.check1((ident # NIL) & ident.export, parser, 48);
imp := TRUE
END;
PARS.Next(parser);
e.readOnly := FALSE;
e.ident := ident;
CASE ident.typ OF
|PROG.idCONST:
e.obj := eCONST;
e._type := ident._type;
e.value := ident.value
|PROG.idTYPE:
e.obj := eTYPE;
e._type := ident._type
|PROG.idVAR:
e.obj := eVAR;
e._type := ident._type;
e.readOnly := imp
|PROG.idPROC:
e.obj := ePROC;
e._type := ident._type
|PROG.idIMP:
e.obj := eIMP;
e._type := ident._type
|PROG.idVPAR:
e._type := ident._type;
IF e._type.typ = PROG.tRECORD THEN
e.obj := eVREC
ELSE
e.obj := eVPAR
END
|PROG.idPARAM:
e.obj := ePARAM;
e._type := ident._type;
e.readOnly := (e._type.typ IN {PROG.tRECORD, PROG.tARRAY})
|PROG.idSTPROC:
e.obj := eSTPROC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idSTFUNC:
e.obj := eSTFUNC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idSYSPROC:
e.obj := eSYSPROC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idSYSFUNC:
PARS.check(~parser.constexp, pos, 109);
e.obj := eSYSFUNC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idNONE:
PARS.error(pos, 115)
END;
IF isVar(e) THEN
PARS.check(e.ident.global OR (e.ident.scopeLvl = parser.unit.scopeLvl), pos, 105)
END
END qualident;
PROCEDURE deref (pos: PARS.POSITION; e: PARS.EXPR; load: BOOLEAN; error: INTEGER);
VAR
label: INTEGER;
BEGIN
IF load THEN
IL.load(e._type.size)
END;
IF chkPTR IN Options.checking THEN
label := IL.NewLabel();
IL.Jmp(IL.opJNZ1, label);
IL.OnError(pos.line, error);
IL.SetLabel(label)
END
END deref;
PROCEDURE designator (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
field: PROG.FIELD;
pos: PARS.POSITION;
t, idx: PARS.EXPR;
PROCEDURE LoadAdr (e: PARS.EXPR);
VAR
offset: INTEGER;
PROCEDURE OpenArray (e: PARS.EXPR);
VAR
offset, n: INTEGER;
BEGIN
offset := e.ident.offset;
n := PROG.Dim(e._type);
WHILE n >= 0 DO
IL.AddCmd(IL.opVADR, offset);
DEC(offset);
DEC(n)
END
END OpenArray;
BEGIN
IF e.obj = eVAR THEN
offset := PROG.getOffset(e.ident);
IF e.ident.global THEN
IL.AddCmd(IL.opGADR, offset)
ELSE
IL.AddCmd(IL.opLADR, -offset)
END
ELSIF e.obj = ePARAM THEN
IF (e._type.typ = PROG.tRECORD) OR ((e._type.typ = PROG.tARRAY) & (e._type.length > 0)) THEN
IL.AddCmd(IL.opVADR, e.ident.offset)
ELSIF PROG.isOpenArray(e._type) THEN
OpenArray(e)
ELSE
IL.AddCmd(IL.opLADR, e.ident.offset)
END
ELSIF e.obj IN {eVPAR, eVREC} THEN
IF PROG.isOpenArray(e._type) THEN
OpenArray(e)
ELSE
IL.AddCmd(IL.opVADR, e.ident.offset)
END
END
END LoadAdr;
PROCEDURE OpenIdx (parser: PARS.PARSER; pos: PARS.POSITION; e: PARS.EXPR);
VAR
label, offset, n, k: INTEGER;
_type: PROG._TYPE;
BEGIN
IF chkIDX IN Options.checking THEN
label := IL.NewLabel();
IL.AddCmd2(IL.opCHKIDX2, label, 0);
IL.OnError(pos.line, errIDX);
IL.SetLabel(label)
ELSE
IL.AddCmd(IL.opCHKIDX2, -1)
END;
_type := PROG.OpenBase(e._type);
IF _type.size # 1 THEN
IL.AddCmd(IL.opMULC, _type.size)
END;
n := PROG.Dim(e._type) - 1;
k := n;
WHILE n > 0 DO
IL.AddCmd0(IL.opMUL);
DEC(n)
END;
IL.AddCmd0(IL.opADD);
offset := e.ident.offset - 1;
n := k;
WHILE n > 0 DO
IL.AddCmd(IL.opVADR, offset);
DEC(offset);
DEC(n)
END
END OpenIdx;
BEGIN
qualident(parser, e);
IF e.obj IN {ePROC, eIMP} THEN
PROG.UseProc(parser.unit, e.ident.proc)
END;
IF isVar(e) THEN
LoadAdr(e)
END;
WHILE parser.sym = SCAN.lxPOINT DO
getpos(parser, pos);
PARS.check1(isExpr(e) & (e._type.typ IN {PROG.tRECORD, PROG.tPOINTER}), parser, 73);
IF e._type.typ = PROG.tPOINTER THEN
deref(pos, e, TRUE, errPTR)
END;
PARS.ExpectSym(parser, SCAN.lxIDENT);
IF e._type.typ = PROG.tPOINTER THEN
e._type := e._type.base;
e.readOnly := FALSE
END;
field := PROG.getField(e._type, parser.lex.ident, parser.unit);
PARS.check1(field # NIL, parser, 74);
e._type := field._type;
IF e.obj = eVREC THEN
e.obj := eVPAR
END;
IF field.offset # 0 THEN
IL.AddCmd(IL.opADDC, field.offset)
END;
PARS.Next(parser);
e.ident := NIL
ELSIF parser.sym = SCAN.lxLSQUARE DO
REPEAT
PARS.check1(isArr(e), parser, 75);
NextPos(parser, pos);
PExpression(parser, idx);
PARS.check(isInt(idx), pos, 76);
IF idx.obj = eCONST THEN
IF e._type.length > 0 THEN
PARS.check(ARITH.range(idx.value, 0, e._type.length - 1), pos, 83);
IF ARITH.Int(idx.value) > 0 THEN
IL.AddCmd(IL.opADDC, ARITH.Int(idx.value) * e._type.base.size)
END
ELSE
PARS.check(ARITH.range(idx.value, 0, UTILS.target.maxInt), pos, 83);
LoadConst(idx);
OpenIdx(parser, pos, e)
END
ELSE
IF e._type.length > 0 THEN
IF chkIDX IN Options.checking THEN
CheckRange(e._type.length, pos.line, errIDX)
END;
IF e._type.base.size # 1 THEN
IL.AddCmd(IL.opMULC, e._type.base.size)
END;
IL.AddCmd0(IL.opADD)
ELSE
OpenIdx(parser, pos, e)
END
END;
e._type := e._type.base
UNTIL parser.sym # SCAN.lxCOMMA;
PARS.checklex(parser, SCAN.lxRSQUARE);
PARS.Next(parser);
IF ~(isArr(e) & (e._type.length = 0) & (parser.sym = SCAN.lxLSQUARE)) THEN
e.ident := NIL
END
ELSIF parser.sym = SCAN.lxCARET DO
getpos(parser, pos);
PARS.check1(isPtr(e), parser, 77);
deref(pos, e, TRUE, errPTR);
e._type := e._type.base;
e.readOnly := FALSE;
PARS.Next(parser);
e.ident := NIL;
e.obj := eVREC
ELSIF (parser.sym = SCAN.lxLROUND) & isExpr(e) & (e._type.typ IN {PROG.tRECORD, PROG.tPOINTER}) DO
IF e._type.typ = PROG.tRECORD THEN
PARS.check1(e.obj = eVREC, parser, 78)
END;
NextPos(parser, pos);
qualident(parser, t);
PARS.check(t.obj = eTYPE, pos, 79);
IF e._type.typ = PROG.tRECORD THEN
PARS.check(t._type.typ = PROG.tRECORD, pos, 80);
IF chkGUARD IN Options.checking THEN
IF e.ident = NIL THEN
IL.TypeGuard(IL.opTYPEGD, t._type.num, pos.line, errGUARD)
ELSE
IL.AddCmd(IL.opVADR, e.ident.offset - 1);
IL.TypeGuard(IL.opTYPEGR, t._type.num, pos.line, errGUARD)
END
END;
ELSE
PARS.check(t._type.typ = PROG.tPOINTER, pos, 81);
IF chkGUARD IN Options.checking THEN
IL.TypeGuard(IL.opTYPEGP, t._type.base.num, pos.line, errGUARD)
END
END;
PARS.check(PROG.isBaseOf(e._type, t._type), pos, 82);
e._type := t._type;
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser)
END
END designator;
PROCEDURE ProcCall (e: PARS.EXPR; procType: PROG._TYPE; isfloat: BOOLEAN; parser: PARS.PARSER; pos: PARS.POSITION; CallStat: BOOLEAN);
VAR
cconv,
parSize,
callconv,
fparSize,
int, flt,
stk_par: INTEGER;
BEGIN
cconv := procType.call;
parSize := procType.parSize;
IF cconv IN {PROG._win64, PROG.win64} THEN
callconv := IL.call_win64;
fparSize := LSL(ORD(PROG.getFloatParamsPos(procType, 3, int, flt)), 5) + MIN(parSize, 4)
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN
callconv := IL.call_sysv;
fparSize := LSL(ORD(PROG.getFloatParamsPos(procType, PROG.MAXSYSVPARAM - 1, int, flt)), 5) + parSize;
stk_par := MAX(0, int - 6) + MAX(0, flt - 8)
ELSE
callconv := IL.call_stack;
fparSize := 0
END;
IL.setlast(begcall);
IL.AddCmd(IL.opPRECALL, ORD(isfloat));
IF cconv IN {PROG._ccall, PROG.ccall} THEN
IL.AddCmd(IL.opALIGN16, parSize)
ELSIF cconv IN {PROG._win64, PROG.win64} THEN
IL.AddCmd(IL.opWIN64ALIGN16, parSize)
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN
IL.AddCmd(IL.opSYSVALIGN16, parSize + stk_par)
END;
IL.setlast(endcall.prev(IL.COMMAND));
IF e.obj = eIMP THEN
IL.CallImp(e.ident._import, callconv, fparSize)
ELSIF e.obj = ePROC THEN
IL.Call(e.ident.proc.label, callconv, fparSize)
ELSIF isExpr(e) THEN
deref(pos, e, CallStat, errPROC);
IL.CallP(callconv, fparSize)
END;
IF cconv IN {PROG._ccall, PROG.ccall} THEN
IL.AddCmd(IL.opCLEANUP, parSize);
IL.AddCmd0(IL.opPOPSP)
ELSIF cconv IN {PROG._win64, PROG.win64} THEN
IL.AddCmd(IL.opCLEANUP, MAX(parSize + parSize MOD 2, 4) + 1);
IL.AddCmd0(IL.opPOPSP)
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN
IL.AddCmd(IL.opCLEANUP, parSize + stk_par);
IL.AddCmd0(IL.opPOPSP)
ELSIF cconv IN {PROG._cdecl, PROG.cdecl, PROG.default16, PROG.code, PROG._code} THEN
IL.AddCmd(IL.opCLEANUP, parSize)
END;
IF CallStat THEN
IL.AddCmd0(IL.opRES);
IL.drop
ELSE
IF isfloat THEN
IL.AddCmd2(IL.opRESF, pos.line, pos.col)
ELSE
IL.AddCmd0(IL.opRES)
END
END
END ProcCall;
PROCEDURE expression (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
pos, pos0, pos1: PARS.POSITION;
e1: PARS.EXPR;
op, cmp, error: INTEGER;
constant, eq: BOOLEAN;
PROCEDURE relation (sym: INTEGER): BOOLEAN;
RETURN (sym = SCAN.lxEQ) OR (sym = SCAN.lxNE) OR
(sym = SCAN.lxLT) OR (sym = SCAN.lxLE) OR
(sym = SCAN.lxGT) OR (sym = SCAN.lxGE) OR
(sym = SCAN.lxIN) OR (sym = SCAN.lxIS)
END relation;
PROCEDURE AddOperator (sym: INTEGER): BOOLEAN;
RETURN (sym = SCAN.lxPLUS) OR (sym = SCAN.lxMINUS) OR
(sym = SCAN.lxOR)
END AddOperator;
PROCEDURE MulOperator (sym: INTEGER): BOOLEAN;
RETURN (sym = SCAN.lxMUL) OR (sym = SCAN.lxSLASH) OR
(sym = SCAN.lxDIV) OR (sym = SCAN.lxMOD) OR
(sym = SCAN.lxAND)
END MulOperator;
PROCEDURE element (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
e1, e2: PARS.EXPR;
pos: PARS.POSITION;
range: BOOLEAN;
BEGIN
range := FALSE;
getpos(parser, pos);
expression(parser, e1);
PARS.check(isInt(e1), pos, 76);
IF e1.obj = eCONST THEN
PARS.check(ARITH.range(e1.value, 0, UTILS.target.maxSet), pos, 44)
END;
range := parser.sym = SCAN.lxRANGE;
IF range THEN
NextPos(parser, pos);
expression(parser, e2);
PARS.check(isInt(e2), pos, 76);
IF e2.obj = eCONST THEN
PARS.check(ARITH.range(e2.value, 0, UTILS.target.maxSet), pos, 44)
END
ELSE
IF e1.obj = eCONST THEN
e2 := e1
END
END;
e._type := tSET;
IF (e1.obj = eCONST) & (e2.obj = eCONST) THEN
ARITH.constrSet(e.value, e1.value, e2.value);
e.obj := eCONST
ELSE
IF range THEN
IF e1.obj = eCONST THEN
IL.AddCmd(IL.opRSETL, ARITH.Int(e1.value))
ELSIF e2.obj = eCONST THEN
IL.AddCmd(IL.opRSETR, ARITH.Int(e2.value))
ELSE
IL.AddCmd0(IL.opRSET)
END
ELSE
IL.AddCmd0(IL.opRSET1)
END;
e.obj := eEXPR
END
END element;
PROCEDURE set (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
e1: PARS.EXPR;
BEGIN
ASSERT(parser.sym = SCAN.lxLCURLY);
e.obj := eCONST;
e._type := tSET;
ARITH.emptySet(e.value);
PARS.Next(parser);
IF parser.sym # SCAN.lxRCURLY THEN
element(parser, e1);
IF e1.obj = eCONST THEN
ARITH.opSet(e.value, e1.value, "+")
ELSE
e.obj := eEXPR
END;
WHILE parser.sym = SCAN.lxCOMMA DO
PARS.Next(parser);
element(parser, e1);
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
ARITH.opSet(e.value, e1.value, "+")
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opADDSC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opADDSC, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opADDS)
END;
e.obj := eEXPR
END
END;
PARS.checklex(parser, SCAN.lxRCURLY)
END;
PARS.Next(parser);
END set;
PROCEDURE factor (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
sym: INTEGER;
pos: PARS.POSITION;
e1: PARS.EXPR;
isfloat: BOOLEAN;
PROCEDURE LoadVar (e: PARS.EXPR; parser: PARS.PARSER; pos: PARS.POSITION);
BEGIN
IF ~(e._type.typ IN {PROG.tRECORD, PROG.tARRAY}) THEN
IF e._type = tREAL THEN
IL.AddCmd2(IL.opLOADF, pos.line, pos.col)
ELSE
IL.load(e._type.size)
END
END
END LoadVar;
BEGIN
sym := parser.sym;
IF (sym = SCAN.lxINTEGER) OR (sym = SCAN.lxHEX) OR (sym = SCAN.lxFLOAT) OR (sym = SCAN.lxCHAR) OR (sym = SCAN.lxSTRING) THEN
e.obj := eCONST;
e.value := parser.lex.value;
e._type := PROG.getType(e.value.typ);
PARS.Next(parser)
ELSIF sym = SCAN.lxNIL THEN
e.obj := eCONST;
e._type := PROG.program.stTypes.tNIL;
PARS.Next(parser)
ELSIF (sym = SCAN.lxTRUE) OR (sym = SCAN.lxFALSE) THEN
e.obj := eCONST;
ARITH.setbool(e.value, sym = SCAN.lxTRUE);
e._type := tBOOLEAN;
PARS.Next(parser)
ELSIF sym = SCAN.lxLCURLY THEN
set(parser, e)
ELSIF sym = SCAN.lxIDENT THEN
getpos(parser, pos);
IL.pushBegEnd(begcall, endcall);
designator(parser, e);
IF isVar(e) THEN
LoadVar(e, parser, pos)
END;
IF parser.sym = SCAN.lxLROUND THEN
e1 := e;
ActualParameters(parser, e);
PARS.check(e._type # NIL, pos, 59);
isfloat := e._type = tREAL;
IF e1.obj IN {ePROC, eIMP} THEN
ProcCall(e1, e1.ident._type, isfloat, parser, pos, FALSE)
ELSIF isExpr(e1) THEN
ProcCall(e1, e1._type, isfloat, parser, pos, FALSE)
END
END;
IL.popBegEnd(begcall, endcall)
ELSIF sym = SCAN.lxLROUND THEN
PARS.Next(parser);
expression(parser, e);
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser);
IF isExpr(e) & (e.obj # eCONST) THEN
e.obj := eEXPR
END
ELSIF sym = SCAN.lxNOT THEN
NextPos(parser, pos);
factor(parser, e);
PARS.check(isBoolean(e), pos, 72);
IF e.obj # eCONST THEN
IL.not;
e.obj := eEXPR
ELSE
ASSERT(ARITH.neg(e.value))
END
ELSE
PARS.check1(FALSE, parser, 34)
END
END factor;
PROCEDURE term (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
pos: PARS.POSITION;
e1: PARS.EXPR;
op, label, label1: INTEGER;
BEGIN
factor(parser, e);
label := -1;
WHILE MulOperator(parser.sym) DO
op := parser.sym;
getpos(parser, pos);
PARS.Next(parser);
IF op = SCAN.lxAND THEN
IF ~parser.constexp THEN
IF label = -1 THEN
label := IL.NewLabel()
END;
IF (e.obj = eCONST) & isBoolean(e) THEN
IL.Const(ORD(ARITH.getBool(e.value)))
END;
IL.Jmp(IL.opJZ, label)
END
END;
factor(parser, e1);
CASE op OF
|SCAN.lxMUL:
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
CASE e.value.typ OF
|ARITH.tINTEGER: PARS.check(ARITH.opInt(e.value, e1.value, "*"), pos, 39)
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, "*"), pos, 40)
|ARITH.tSET: ARITH.opSet(e.value, e1.value, "*")
END
ELSE
IF isInt(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opMULC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opMULC, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opMUL)
END
ELSIF isReal(e) THEN
IF e.obj = eCONST THEN
Float(parser, e)
ELSIF e1.obj = eCONST THEN
Float(parser, e1)
END;
IL.AddCmd0(IL.opMULF)
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opMULSC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opMULSC, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opMULS)
END
END;
e.obj := eEXPR
END
|SCAN.lxSLASH:
PARS.check(isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), pos, 37);
IF (e1.obj = eCONST) & isReal(e1) THEN
PARS.check(~ARITH.isZero(e1.value), pos, 45)
END;
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
CASE e.value.typ OF
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, "/"), pos, 40)
|ARITH.tSET: ARITH.opSet(e.value, e1.value, "/")
END
ELSE
IF isReal(e) THEN
IF e.obj = eCONST THEN
Float(parser, e);
IL.AddCmd0(IL.opDIVFI)
ELSIF e1.obj = eCONST THEN
Float(parser, e1);
IL.AddCmd0(IL.opDIVF)
ELSE
IL.AddCmd0(IL.opDIVF)
END
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opDIVSC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opDIVSC, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opDIVS)
END
END;
e.obj := eEXPR
END
|SCAN.lxDIV, SCAN.lxMOD:
PARS.check(isInt(e) & isInt(e1), pos, 37);
IF e1.obj = eCONST THEN
PARS.check(ARITH.Int(e1.value) > 0, pos, 122)
END;
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
IF op = SCAN.lxDIV THEN
PARS.check(ARITH.opInt(e.value, e1.value, "D"), pos, 39)
ELSE
ASSERT(ARITH.opInt(e.value, e1.value, "M"))
END
ELSE
IF e1.obj # eCONST THEN
label1 := IL.NewLabel();
IL.Jmp(IL.opJG, label1)
END;
IF e.obj = eCONST THEN
IL.OnError(pos.line, errDIV);
IL.SetLabel(label1);
IL.AddCmd(IL.opDIVL + ORD(op = SCAN.lxMOD), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opDIVR + ORD(op = SCAN.lxMOD), ARITH.Int(e1.value))
ELSE
IL.OnError(pos.line, errDIV);
IL.SetLabel(label1);
IL.AddCmd0(IL.opDIV + ORD(op = SCAN.lxMOD))
END;
e.obj := eEXPR
END
|SCAN.lxAND:
PARS.check(isBoolean(e) & isBoolean(e1), pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) & parser.constexp THEN
ARITH.opBoolean(e.value, e1.value, "&")
ELSE
e.obj := eEXPR;
IF e1.obj = eCONST THEN
IL.Const(ORD(ARITH.getBool(e1.value)))
END
END
END
END;
IF label # -1 THEN
label1 := IL.NewLabel();
IL.Jmp(IL.opJNZ, label1);
IL.SetLabel(label);
IL.Const(0);
IL.drop;
label := IL.NewLabel();
IL.Jmp(IL.opJMP, label);
IL.SetLabel(label1);
IL.Const(1);
IL.SetLabel(label);
IL.AddCmd0(IL.opAND)
END
END term;
PROCEDURE SimpleExpression (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
pos: PARS.POSITION;
op: INTEGER;
e1: PARS.EXPR;
s, s1: SCAN.TEXTSTR;
plus, minus: BOOLEAN;
label, label1: INTEGER;
BEGIN
plus := parser.sym = SCAN.lxPLUS;
minus := parser.sym = SCAN.lxMINUS;
IF plus OR minus THEN
getpos(parser, pos);
PARS.Next(parser)
END;
term(parser, e);
IF plus OR minus THEN
PARS.check(isInt(e) OR isReal(e) OR isSet(e), pos, 36);
IF minus & (e.obj = eCONST) THEN
PARS.check(ARITH.neg(e.value), pos, 39)
END;
IF e.obj # eCONST THEN
IF minus THEN
IF isInt(e) THEN
IL.AddCmd0(IL.opUMINUS)
ELSIF isReal(e) THEN
IL.AddCmd0(IL.opUMINF)
ELSIF isSet(e) THEN
IL.AddCmd0(IL.opUMINS)
END
END;
e.obj := eEXPR
END
END;
label := -1;
WHILE AddOperator(parser.sym) DO
op := parser.sym;
getpos(parser, pos);
PARS.Next(parser);
IF op = SCAN.lxOR THEN
IF ~parser.constexp THEN
IF label = -1 THEN
label := IL.NewLabel()
END;
IF (e.obj = eCONST) & isBoolean(e) THEN
IL.Const(ORD(ARITH.getBool(e.value)))
END;
IL.Jmp(IL.opJNZ, label)
END
END;
term(parser, e1);
CASE op OF
|SCAN.lxPLUS, SCAN.lxMINUS:
minus := op = SCAN.lxMINUS;
IF minus THEN
op := ORD("-")
ELSE
op := ORD("+")
END;
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1) OR isString(e) & isString(e1) & ~minus, pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
CASE e.value.typ OF
|ARITH.tINTEGER:
PARS.check(ARITH.opInt(e.value, e1.value, CHR(op)), pos, 39)
|ARITH.tREAL:
PARS.check(ARITH.opFloat(e.value, e1.value, CHR(op)), pos, 40)
|ARITH.tSET:
ARITH.opSet(e.value, e1.value, CHR(op))
|ARITH.tCHAR, ARITH.tSTRING:
IF e.value.typ = ARITH.tCHAR THEN
ARITH.charToStr(e.value, s)
ELSE
s := e.value.string(SCAN.STRING).s
END;
IF e1.value.typ = ARITH.tCHAR THEN
ARITH.charToStr(e1.value, s1)
ELSE
s1 := e1.value.string(SCAN.STRING).s
END;
PARS.check(ARITH.concat(s, s1), pos, 5);
e.value.string := SCAN.enterStr(s);
e.value.typ := ARITH.tSTRING;
e._type := PROG.program.stTypes.tSTRING
END
ELSE
IF isInt(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opADDC - ORD(minus), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opADDC + ORD(minus), ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opADD + ORD(minus))
END
ELSIF isReal(e) THEN
IF e.obj = eCONST THEN
Float(parser, e);
IL.AddCmd0(IL.opADDF - ORD(minus))
ELSIF e1.obj = eCONST THEN
Float(parser, e1);
IL.AddCmd0(IL.opADDF + ORD(minus))
ELSE
IL.AddCmd0(IL.opADDF + ORD(minus))
END
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opADDSC - ORD(minus), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opADDSC + ORD(minus), ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opADDS + ORD(minus))
END
END;
e.obj := eEXPR
END
|SCAN.lxOR:
PARS.check(isBoolean(e) & isBoolean(e1), pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) & parser.constexp THEN
ARITH.opBoolean(e.value, e1.value, "|")
ELSE
e.obj := eEXPR;
IF e1.obj = eCONST THEN
IL.Const(ORD(ARITH.getBool(e1.value)))
END
END
END
END;
IF label # -1 THEN
label1 := IL.NewLabel();
IL.Jmp(IL.opJZ, label1);
IL.SetLabel(label);
IL.Const(1);
IL.drop;
label := IL.NewLabel();
IL.Jmp(IL.opJMP, label);
IL.SetLabel(label1);
IL.Const(0);
IL.SetLabel(label);
IL.AddCmd0(IL.opOR)
END
END SimpleExpression;
PROCEDURE cmpcode (op: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE op OF
|SCAN.lxEQ: res := ARITH.opEQ
|SCAN.lxNE: res := ARITH.opNE
|SCAN.lxLT: res := ARITH.opLT
|SCAN.lxLE: res := ARITH.opLE
|SCAN.lxGT: res := ARITH.opGT
|SCAN.lxGE: res := ARITH.opGE
|SCAN.lxIN: res := ARITH.opIN
|SCAN.lxIS: res := ARITH.opIS
END
RETURN res
END cmpcode;
PROCEDURE invcmpcode (op: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE op OF
|SCAN.lxEQ: res := ARITH.opEQ
|SCAN.lxNE: res := ARITH.opNE
|SCAN.lxLT: res := ARITH.opGT
|SCAN.lxLE: res := ARITH.opGE
|SCAN.lxGT: res := ARITH.opLT
|SCAN.lxGE: res := ARITH.opLE
|SCAN.lxIN: res := ARITH.opIN
|SCAN.lxIS: res := ARITH.opIS
END
RETURN res
END invcmpcode;
PROCEDURE BoolCmp (eq, val: BOOLEAN);
BEGIN
IF eq = val THEN
IL.AddCmd0(IL.opNEC)
ELSE
IL.AddCmd0(IL.opEQC)
END
END BoolCmp;
PROCEDURE strcmp (VAR e, e1: PARS.EXPR; op: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
cmp: INTEGER;
BEGIN
res := TRUE;
cmp := cmpcode(op);
IF isString(e) & isCharArray(e1) THEN
IL.StrAdr(String(e));
IL.Const(strlen(e) + 1);
IL.AddCmd0(IL.opEQS + invcmpcode(op))
ELSIF (isString(e) OR isStringW(e)) & isCharArrayW(e1) THEN
IL.StrAdr(StringW(e));
IL.Const(utf8strlen(e) + 1);
IL.AddCmd0(IL.opEQSW + invcmpcode(op))
ELSIF isCharArray(e) & isString(e1) THEN
IL.StrAdr(String(e1));
IL.Const(strlen(e1) + 1);
IL.AddCmd0(IL.opEQS + cmp)
ELSIF isCharArrayW(e) & (isString(e1) OR isStringW(e1)) THEN
IL.StrAdr(StringW(e1));
IL.Const(utf8strlen(e1) + 1);
IL.AddCmd0(IL.opEQSW + cmp)
ELSIF isCharArrayW(e) & isCharArrayW(e1) THEN
IL.AddCmd0(IL.opEQSW + cmp)
ELSIF isCharArray(e) & isCharArray(e1) THEN
IL.AddCmd0(IL.opEQS + cmp)
ELSIF isString(e) & isString(e1) THEN
PARS.strcmp(e.value, e1.value, op)
ELSE
res := FALSE
END
RETURN res
END strcmp;
BEGIN
getpos(parser, pos0);
SimpleExpression(parser, e);
IF relation(parser.sym) THEN
IF (isCharArray(e) OR isCharArrayW(e)) & (e._type.length # 0) THEN
IL.Const(e._type.length)
END;
op := parser.sym;
getpos(parser, pos);
PARS.Next(parser);
getpos(parser, pos1);
SimpleExpression(parser, e1);
IF (isCharArray(e1) OR isCharArrayW(e1)) & (e1._type.length # 0) THEN
IL.Const(e1._type.length)
END;
constant := (e.obj = eCONST) & (e1.obj = eCONST);
error := 0;
cmp := cmpcode(op);
CASE op OF
|SCAN.lxEQ, SCAN.lxNE:
eq := op = SCAN.lxEQ;
IF isInt(e) & isInt(e1) OR isSet(e) & isSet(e1) OR isChar(e) & isChar(e1) OR isCharW(e) & isCharW(e1) OR
isCharW(e) & isChar(e1) & (e1.obj = eCONST) OR isCharW(e1) & isChar(e) & (e.obj = eCONST) OR
isCharW(e1) & (e1.obj = eCONST) & isChar(e) & (e.obj = eCONST) OR
isCharW(e) & (e.obj = eCONST) & isChar(e1) & (e1.obj = eCONST) OR
isPtr(e) & isPtr(e1) & (PROG.isBaseOf(e._type, e1._type) OR PROG.isBaseOf(e1._type, e._type)) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opEQ + cmp)
END
END
ELSIF isStringW1(e) & isCharW(e1) THEN
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e.value.string(SCAN.STRING).s))
ELSIF isStringW1(e1) & isCharW(e) THEN
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e1.value.string(SCAN.STRING).s))
ELSIF isBoolean(e) & isBoolean(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
BoolCmp(eq, ARITH.Int(e.value) # 0)
ELSIF e1.obj = eCONST THEN
BoolCmp(eq, ARITH.Int(e1.value) # 0)
ELSE
IF eq THEN
IL.AddCmd0(IL.opEQB)
ELSE
IL.AddCmd0(IL.opNEB)
END
END
END
ELSIF isReal(e) & isReal(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
Float(parser, e)
ELSIF e1.obj = eCONST THEN
Float(parser, e1)
END;
IL.AddCmd0(IL.opEQF + cmp)
END
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN
IF ~strcmp(e, e1, op) THEN
PARS.error(pos, 37)
END
ELSIF isPtr(e) & isNil(e1) OR isNil(e) & isPtr(e1) THEN
IL.AddCmd0(IL.opEQC + cmp)
ELSIF isProc(e) & isNil(e1) THEN
IF e.obj IN {ePROC, eIMP} THEN
PARS.check(e.ident.global, pos0, 85);
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, ~eq)
ELSE
IL.AddCmd0(IL.opEQC + cmp)
END
ELSIF isNil(e) & isProc(e1) THEN
IF e1.obj IN {ePROC, eIMP} THEN
PARS.check(e1.ident.global, pos1, 85);
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, ~eq)
ELSE
IL.AddCmd0(IL.opEQC + cmp)
END
ELSIF isProc(e) & isProc(e1) & PROG.isTypeEq(e._type, e1._type) THEN
IF e.obj = ePROC THEN
PARS.check(e.ident.global, pos0, 85)
END;
IF e1.obj = ePROC THEN
PARS.check(e1.ident.global, pos1, 85)
END;
IF (e.obj IN {ePROC, eIMP}) & (e1.obj IN {ePROC, eIMP}) THEN
constant := TRUE;
e.obj := eCONST;
IF eq THEN
ARITH.setbool(e.value, e.ident = e1.ident)
ELSE
ARITH.setbool(e.value, e.ident # e1.ident)
END
ELSIF e.obj = ePROC THEN
IL.ProcCmp(e.ident.proc.label, eq)
ELSIF e1.obj = ePROC THEN
IL.ProcCmp(e1.ident.proc.label, eq)
ELSIF e.obj = eIMP THEN
IL.ProcImpCmp(e.ident._import, eq)
ELSIF e1.obj = eIMP THEN
IL.ProcImpCmp(e1.ident._import, eq)
ELSE
IL.AddCmd0(IL.opEQ + cmp)
END
ELSIF isNil(e) & isNil(e1) THEN
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, eq)
ELSE
PARS.error(pos, 37)
END
|SCAN.lxLT, SCAN.lxLE, SCAN.lxGT, SCAN.lxGE:
IF isInt(e) & isInt(e1) OR isChar(e) & isChar(e1) OR isCharW(e) & isCharW(e1) OR
isCharW(e) & isChar(e1) & (e1.obj = eCONST) OR isCharW(e1) & isChar(e) & (e.obj = eCONST) OR
isCharW(e1) & (e1.obj = eCONST) & isChar(e) & (e.obj = eCONST) OR
isCharW(e) & (e.obj = eCONST) & isChar(e1) & (e1.obj = eCONST) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opEQC + invcmpcode(op), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opEQ + cmp)
END
END
ELSIF isStringW1(e) & isCharW(e1) THEN
IL.AddCmd(IL.opEQC + invcmpcode(op), StrToWChar(e.value.string(SCAN.STRING).s))
ELSIF isStringW1(e1) & isCharW(e) THEN
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e1.value.string(SCAN.STRING).s))
ELSIF isReal(e) & isReal(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
Float(parser, e);
IL.AddCmd0(IL.opEQF + invcmpcode(op))
ELSIF e1.obj = eCONST THEN
Float(parser, e1);
IL.AddCmd0(IL.opEQF + cmp)
ELSE
IL.AddCmd0(IL.opEQF + cmp)
END
END
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN
IF ~strcmp(e, e1, op) THEN
PARS.error(pos, 37)
END
ELSE
PARS.error(pos, 37)
END
|SCAN.lxIN:
PARS.check(isInt(e) & isSet(e1), pos, 37);
IF e.obj = eCONST THEN
PARS.check(ARITH.range(e.value, 0, UTILS.target.maxSet), pos0, 56)
END;
IF constant THEN
ARITH.relation(e.value, e1.value, ARITH.opIN, error)
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opINL, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opINR, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opIN)
END
END
|SCAN.lxIS:
PARS.check(isRecPtr(e), pos, 73);
PARS.check(e1.obj = eTYPE, pos1, 79);
IF isRec(e) THEN
PARS.check(e.obj = eVREC, pos0, 78);
PARS.check(e1._type.typ = PROG.tRECORD, pos1, 80);
IF e.ident = NIL THEN
IL.TypeCheck(e1._type.num)
ELSE
IL.AddCmd(IL.opVADR, e.ident.offset - 1);
IL.TypeCheckRec(e1._type.num)
END
ELSE
PARS.check(e1._type.typ = PROG.tPOINTER, pos1, 81);
IL.TypeCheck(e1._type.base.num)
END;
PARS.check(PROG.isBaseOf(e._type, e1._type), pos1, 82)
END;
ASSERT(error = 0);
e._type := tBOOLEAN;
IF ~constant THEN
e.obj := eEXPR
END
END
END expression;
PROCEDURE ElementaryStatement (parser: PARS.PARSER);
VAR
e, e1: PARS.EXPR;
pos: PARS.POSITION;
line: INTEGER;
call: BOOLEAN;
BEGIN
getpos(parser, pos);
IL.pushBegEnd(begcall, endcall);
designator(parser, e);
IF parser.sym = SCAN.lxASSIGN THEN
line := parser.lex.pos.line;
PARS.check(isVar(e), pos, 93);
PARS.check(~e.readOnly, pos, 94);
IL.setlast(begcall);
NextPos(parser, pos);
expression(parser, e1);
IL.setlast(endcall.prev(IL.COMMAND));
PARS.check(assign(parser, e1, e._type, line), pos, 91);
IF e1.obj = ePROC THEN
PARS.check(e1.ident.global, pos, 85)
END;
call := FALSE
ELSIF parser.sym = SCAN.lxEQ THEN
PARS.check1(FALSE, parser, 96)
ELSIF parser.sym = SCAN.lxLROUND THEN
e1 := e;
ActualParameters(parser, e1);
PARS.check((e1._type = NIL) OR ODD(e._type.call), pos, 92);
call := TRUE
ELSE
IF e.obj IN {eSYSPROC, eSTPROC} THEN
stProc(parser, e);
call := FALSE
ELSE
PARS.check(isProc(e), pos, 86);
PARS.check((e._type.base = NIL) OR ODD(e._type.call), pos, 92);
PARS.check1(e._type.params.first = NIL, parser, 64);
call := TRUE
END
END;
IF call THEN
IF e.obj IN {ePROC, eIMP} THEN
ProcCall(e, e.ident._type, FALSE, parser, pos, TRUE)
ELSIF isExpr(e) THEN
ProcCall(e, e._type, FALSE, parser, pos, TRUE)
END
END;
IL.popBegEnd(begcall, endcall)
END ElementaryStatement;
PROCEDURE IfStatement (parser: PARS.PARSER; _if: BOOLEAN);
VAR
e: PARS.EXPR;
pos: PARS.POSITION;
label, L: INTEGER;
BEGIN
L := IL.NewLabel();
IF ~_if THEN
IL.AddCmd(IL.opNOP, IL.begin_loop);
IL.SetLabel(L)
END;
REPEAT
NextPos(parser, pos);
label := IL.NewLabel();
expression(parser, e);
PARS.check(isBoolean(e), pos, 72);
IF e.obj = eCONST THEN
IF ~ARITH.getBool(e.value) THEN
IL.Jmp(IL.opJMP, label)
END
ELSE
IL.AndOrOpt(label)
END;
IF _if THEN
PARS.checklex(parser, SCAN.lxTHEN)
ELSE
PARS.checklex(parser, SCAN.lxDO)
END;
PARS.Next(parser);
parser.StatSeq(parser);
IF ~_if OR (parser.sym # SCAN.lxEND) THEN
IL.Jmp(IL.opJMP, L)
END;
IL.SetLabel(label)
UNTIL parser.sym # SCAN.lxELSIF;
IF _if THEN
IF parser.sym = SCAN.lxELSE THEN
PARS.Next(parser);
parser.StatSeq(parser)
END;
IL.SetLabel(L)
ELSE
IL.AddCmd(IL.opNOP, IL.end_loop)
END;
PARS.checklex(parser, SCAN.lxEND);
PARS.Next(parser)
END IfStatement;
PROCEDURE RepeatStatement (parser: PARS.PARSER);
VAR
e: PARS.EXPR;
pos: PARS.POSITION;
label: INTEGER;
L: IL.COMMAND;
BEGIN
IL.AddCmd(IL.opNOP, IL.begin_loop);
label := IL.NewLabel();
IL.SetLabel(label);
L := IL.getlast();
PARS.Next(parser);
parser.StatSeq(parser);
PARS.checklex(parser, SCAN.lxUNTIL);
NextPos(parser, pos);
expression(parser, e);
PARS.check(isBoolean(e), pos, 72);
IF e.obj = eCONST THEN
IF ~ARITH.getBool(e.value) THEN
IL.Jmp(IL.opJMP, label)
END
ELSE
IL.AndOrOpt(label);
L.param1 := label
END;
IL.AddCmd(IL.opNOP, IL.end_loop)
END RepeatStatement;
PROCEDURE LabelCmp (a, b: AVL.DATA): INTEGER;
VAR
La, Ra, Lb, Rb, res: INTEGER;
BEGIN
La := a(CASE_LABEL).range.a;
Ra := a(CASE_LABEL).range.b;
Lb := b(CASE_LABEL).range.a;
Rb := b(CASE_LABEL).range.b;
IF (Ra < Lb) OR (La > Rb) THEN
res := ORD(La > Lb) - ORD(La < Lb)
ELSE
res := 0
END
RETURN res
END LabelCmp;
PROCEDURE DestroyLabel (VAR label: AVL.DATA);
BEGIN
C.push(CaseLabels, label);
label := NIL
END DestroyLabel;
PROCEDURE NewVariant (label: INTEGER; cmd: IL.COMMAND): CASE_VARIANT;
VAR
res: CASE_VARIANT;
citem: C.ITEM;
BEGIN
citem := C.pop(CaseVar);
IF citem = NIL THEN
NEW(res)
ELSE
res := citem(CASE_VARIANT)
END;
res.label := label;
res.cmd := cmd;
res.processed := FALSE
RETURN res
END NewVariant;
PROCEDURE CaseStatement (parser: PARS.PARSER);
VAR
e: PARS.EXPR;
pos: PARS.POSITION;
PROCEDURE Label (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR _type: PROG._TYPE): INTEGER;
VAR
a: INTEGER;
label: PARS.EXPR;
pos: PARS.POSITION;
value: ARITH.VALUE;
BEGIN
getpos(parser, pos);
_type := NIL;
IF isChar(caseExpr) THEN
PARS.ConstExpression(parser, value);
PARS.check(value.typ = ARITH.tCHAR, pos, 99);
a := ARITH.getInt(value)
ELSIF isCharW(caseExpr) THEN
PARS.ConstExpression(parser, value);
IF (value.typ = ARITH.tSTRING) & (_length(value.string(SCAN.STRING).s) = 1) & (LENGTH(value.string(SCAN.STRING).s) > 1) THEN
ASSERT(ARITH.setInt(value, StrToWChar(value.string(SCAN.STRING).s)))
ELSE
PARS.check(value.typ IN {ARITH.tWCHAR, ARITH.tCHAR}, pos, 99)
END;
a := ARITH.getInt(value)
ELSIF isInt(caseExpr) THEN
PARS.ConstExpression(parser, value);
PARS.check(value.typ = ARITH.tINTEGER, pos, 99);
a := ARITH.getInt(value)
ELSIF isRecPtr(caseExpr) THEN
qualident(parser, label);
PARS.check(label.obj = eTYPE, pos, 79);
PARS.check(PROG.isBaseOf(caseExpr._type, label._type), pos, 99);
IF isRec(caseExpr) THEN
a := label._type.num
ELSE
a := label._type.base.num
END;
_type := label._type
END
RETURN a
END Label;
PROCEDURE CheckType (node: AVL.NODE; _type: PROG._TYPE; parser: PARS.PARSER; pos: PARS.POSITION);
BEGIN
IF node # NIL THEN
PARS.check(~(PROG.isBaseOf(node.data(CASE_LABEL)._type, _type) OR PROG.isBaseOf(_type, node.data(CASE_LABEL)._type)), pos, 100);
CheckType(node.left, _type, parser, pos);
CheckType(node.right, _type, parser, pos)
END
END CheckType;
PROCEDURE LabelRange (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; variant: INTEGER): AVL.NODE;
VAR
label: CASE_LABEL;
citem: C.ITEM;
pos, pos1: PARS.POSITION;
node: AVL.NODE;
newnode: BOOLEAN;
range: RANGE;
BEGIN
citem := C.pop(CaseLabels);
IF citem = NIL THEN
NEW(label)
ELSE
label := citem(CASE_LABEL)
END;
label.variant := variant;
label.self := IL.NewLabel();
getpos(parser, pos1);
range.a := Label(parser, caseExpr, label._type);
IF parser.sym = SCAN.lxRANGE THEN
PARS.check1(~isRecPtr(caseExpr), parser, 53);
NextPos(parser, pos);
range.b := Label(parser, caseExpr, label._type);
PARS.check(range.a <= range.b, pos, 103)
ELSE
range.b := range.a
END;
label.range := range;
IF isRecPtr(caseExpr) THEN
CheckType(tree, label._type, parser, pos1)
END;
tree := AVL.insert(tree, label, LabelCmp, newnode, node);
PARS.check(newnode, pos1, 100)
RETURN node
END LabelRange;
PROCEDURE CaseLabelList (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; variant: INTEGER): AVL.NODE;
VAR
exit: BOOLEAN;
res: AVL.NODE;
BEGIN
exit := FALSE;
REPEAT
res := LabelRange(parser, caseExpr, tree, variant);
IF parser.sym = SCAN.lxCOMMA THEN
PARS.check1(~isRecPtr(caseExpr), parser, 53);
PARS.Next(parser)
ELSE
exit := TRUE
END
UNTIL exit
RETURN res
END CaseLabelList;
PROCEDURE _case (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; _end: INTEGER);
VAR
sym: INTEGER;
t: PROG._TYPE;
variant: INTEGER;
node: AVL.NODE;
last: IL.COMMAND;
BEGIN
sym := parser.sym;
IF sym # SCAN.lxBAR THEN
variant := IL.NewLabel();
node := CaseLabelList(parser, caseExpr, tree, variant);
PARS.checklex(parser, SCAN.lxCOLON);
PARS.Next(parser);
IF isRecPtr(caseExpr) THEN
t := caseExpr._type;
caseExpr.ident._type := node.data(CASE_LABEL)._type
END;
last := IL.getlast();
IL.SetLabel(variant);
IF ~isRecPtr(caseExpr) THEN
LISTS.push(CaseVariants, NewVariant(variant, last))
END;
parser.StatSeq(parser);
IL.Jmp(IL.opJMP, _end);
IF isRecPtr(caseExpr) THEN
caseExpr.ident._type := t
END
END
END _case;
PROCEDURE Table (node: AVL.NODE; _else: INTEGER);
VAR
L, R: INTEGER;
range: RANGE;
left, right: AVL.NODE;
last: IL.COMMAND;
v: CASE_VARIANT;
BEGIN
IF node # NIL THEN
range := node.data(CASE_LABEL).range;
left := node.left;
IF left # NIL THEN
L := left.data(CASE_LABEL).self
ELSE
L := _else
END;
right := node.right;
IF right # NIL THEN
R := right.data(CASE_LABEL).self
ELSE
R := _else
END;
last := IL.getlast();
v := CaseVariants.last(CASE_VARIANT);
WHILE (v # NIL) & (v.label # 0) & (v.label # node.data(CASE_LABEL).variant) DO
v := v.prev(CASE_VARIANT)
END;
ASSERT((v # NIL) & (v.label # 0));
IL.setlast(v.cmd);
IL.SetLabel(node.data(CASE_LABEL).self);
IL._case(range.a, range.b, L, R);
IF v.processed THEN
IL.Jmp(IL.opJMP, node.data(CASE_LABEL).variant)
END;
v.processed := TRUE;
IL.setlast(last);
Table(left, _else);
Table(right, _else)
END
END Table;
PROCEDURE TableT (node: AVL.NODE);
BEGIN
IF node # NIL THEN
IL.AddCmd2(IL.opCASET, node.data(CASE_LABEL).variant, node.data(CASE_LABEL).range.a);
TableT(node.left);
TableT(node.right)
END
END TableT;
PROCEDURE ParseCase (parser: PARS.PARSER; e: PARS.EXPR; pos: PARS.POSITION);
VAR
table, _end, _else: INTEGER;
tree: AVL.NODE;
item: LISTS.ITEM;
BEGIN
LISTS.push(CaseVariants, NewVariant(0, NIL));
_end := IL.NewLabel();
_else := IL.NewLabel();
table := IL.NewLabel();
IL.AddCmd(IL.opSWITCH, ORD(isRecPtr(e)));
IL.Jmp(IL.opJMP, table);
tree := NIL;
_case(parser, e, tree, _end);
WHILE parser.sym = SCAN.lxBAR DO
PARS.Next(parser);
_case(parser, e, tree, _end)
END;
IL.SetLabel(_else);
IF parser.sym = SCAN.lxELSE THEN
PARS.Next(parser);
parser.StatSeq(parser);
IL.Jmp(IL.opJMP, _end)
ELSE
IL.OnError(pos.line, errCASE)
END;
PARS.checklex(parser, SCAN.lxEND);
PARS.Next(parser);
IF isRecPtr(e) THEN
IL.SetLabel(table);
TableT(tree);
IL.Jmp(IL.opJMP, _else)
ELSE
tree.data(CASE_LABEL).self := table;
Table(tree, _else)
END;
AVL.destroy(tree, DestroyLabel);
IL.SetLabel(_end);
IL.AddCmd0(IL.opENDSW);
REPEAT
item := LISTS.pop(CaseVariants);
C.push(CaseVar, item)
UNTIL item(CASE_VARIANT).cmd = NIL
END ParseCase;
BEGIN
NextPos(parser, pos);
expression(parser, e);
PARS.check(isInt(e) OR isChar(e) OR isCharW(e) OR isPtr(e) OR isRec(e), pos, 95);
IF isRecPtr(e) THEN
PARS.check(isVar(e), pos, 93);
PARS.check(e.ident # NIL, pos, 106)
END;
IF isRec(e) THEN
PARS.check(e.obj = eVREC, pos, 78)
END;
IF e.obj = eCONST THEN
LoadConst(e)
ELSIF isRec(e) THEN
IL.drop;
IL.AddCmd(IL.opLADR, e.ident.offset - 1);
IL.load(TARGETS.WordSize)
ELSIF isPtr(e) THEN
deref(pos, e, FALSE, errPTR);
IL.AddCmd(IL.opSUBR, TARGETS.WordSize);
IL.load(TARGETS.WordSize)
END;
PARS.checklex(parser, SCAN.lxOF);
PARS.Next(parser);
ParseCase(parser, e, pos)
END CaseStatement;
PROCEDURE ForStatement (parser: PARS.PARSER);
VAR
e: PARS.EXPR;
pos, pos2: PARS.POSITION;
step: ARITH.VALUE;
st: INTEGER;
ident: PROG.IDENT;
offset: INTEGER;
L1, L2: INTEGER;
BEGIN
IL.AddCmd(IL.opNOP, IL.begin_loop);
L1 := IL.NewLabel();
L2 := IL.NewLabel();
PARS.ExpectSym(parser, SCAN.lxIDENT);
ident := PROG.getIdent(parser.unit, parser.lex.ident, TRUE);
PARS.check1(ident # NIL, parser, 48);
PARS.check1(ident.typ = PROG.idVAR, parser, 93);
PARS.check1(ident._type = tINTEGER, parser, 97);
PARS.ExpectSym(parser, SCAN.lxASSIGN);
NextPos(parser, pos);
expression(parser, e);
PARS.check(isInt(e), pos, 76);
offset := PROG.getOffset(ident);
IF ident.global THEN
IL.AddCmd(IL.opGADR, offset)
ELSE
IL.AddCmd(IL.opLADR, -offset)
END;
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVEC, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSAVE)
END;
IL.SetLabel(L1);
IF ident.global THEN
IL.AddCmd(IL.opGADR, offset)
ELSE
IL.AddCmd(IL.opLADR, -offset)
END;
IL.load(ident._type.size);
PARS.checklex(parser, SCAN.lxTO);
NextPos(parser, pos2);
expression(parser, e);
PARS.check(isInt(e), pos2, 76);
IF parser.sym = SCAN.lxBY THEN
NextPos(parser, pos);
PARS.ConstExpression(parser, step);
PARS.check(step.typ = ARITH.tINTEGER, pos, 76);
st := ARITH.getInt(step);
PARS.check(st # 0, pos, 98)
ELSE
st := 1
END;
IF e.obj = eCONST THEN
IF st > 0 THEN
IL.AddCmd(IL.opLEC, ARITH.Int(e.value));
IF ARITH.Int(e.value) = UTILS.target.maxInt THEN
ERRORS.WarningMsg(pos2.line, pos2.col, 1)
END
ELSE
IL.AddCmd(IL.opGEC, ARITH.Int(e.value));
IF ARITH.Int(e.value) = UTILS.target.minInt THEN
ERRORS.WarningMsg(pos2.line, pos2.col, 1)
END
END
ELSE
IF st > 0 THEN
IL.AddCmd0(IL.opLE)
ELSE
IL.AddCmd0(IL.opGE)
END
END;
IL.Jmp(IL.opJZ, L2);
PARS.checklex(parser, SCAN.lxDO);
PARS.Next(parser);
parser.StatSeq(parser);
IF ident.global THEN
IL.AddCmd(IL.opGADR, offset)
ELSE
IL.AddCmd(IL.opLADR, -offset)
END;
IL.AddCmd(IL.opINCC, st);
IL.Jmp(IL.opJMP, L1);
PARS.checklex(parser, SCAN.lxEND);
PARS.Next(parser);
IL.SetLabel(L2);
IL.AddCmd(IL.opNOP, IL.end_loop)
END ForStatement;
PROCEDURE statement (parser: PARS.PARSER);
VAR
sym: INTEGER;
BEGIN
sym := parser.sym;
IF sym = SCAN.lxIDENT THEN
ElementaryStatement(parser)
ELSIF sym = SCAN.lxIF THEN
IfStatement(parser, TRUE)
ELSIF sym = SCAN.lxWHILE THEN
IfStatement(parser, FALSE)
ELSIF sym = SCAN.lxREPEAT THEN
RepeatStatement(parser)
ELSIF sym = SCAN.lxCASE THEN
CaseStatement(parser)
ELSIF sym = SCAN.lxFOR THEN
ForStatement(parser)
END
END statement;
PROCEDURE StatSeq (parser: PARS.PARSER);
BEGIN
statement(parser);
WHILE parser.sym = SCAN.lxSEMI DO
PARS.Next(parser);
statement(parser)
END
END StatSeq;
PROCEDURE chkreturn (parser: PARS.PARSER; e: PARS.EXPR; t: PROG._TYPE; pos: PARS.POSITION): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := assigncomp(e, t);
IF res THEN
IF e.obj = eCONST THEN
IF e._type = tREAL THEN
Float(parser, e)
ELSIF e._type.typ = PROG.tNIL THEN
IL.Const(0)
ELSE
LoadConst(e)
END
ELSIF (e._type = tINTEGER) & (t = tBYTE) & (chkBYTE IN Options.checking) THEN
CheckRange(256, pos.line, errBYTE)
ELSIF e.obj = ePROC THEN
PARS.check(e.ident.global, pos, 85);
IL.PushProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
IL.PushImpProc(e.ident._import)
END
END
RETURN res
END chkreturn;
PROCEDURE setrtl;
VAR
rtl: PROG.UNIT;
PROCEDURE getproc (rtl: PROG.UNIT; name: SCAN.IDSTR; idx: INTEGER);
VAR
id: PROG.IDENT;
ident: SCAN.IDENT;
BEGIN
SCAN.setIdent(ident, name);
id := PROG.getIdent(rtl, ident, FALSE);
IF (id # NIL) & (id._import # NIL) THEN
IL.set_rtl(idx, -id._import(IL.IMPORT_PROC).label);
id.proc.used := TRUE
ELSIF (id # NIL) & (id.proc # NIL) THEN
IL.set_rtl(idx, id.proc.label);
id.proc.used := TRUE
ELSE
ERRORS.WrongRTL(name)
END
END getproc;
BEGIN
rtl := PROG.program.rtl;
ASSERT(rtl # NIL);
getproc(rtl, "_strcmp", IL._strcmp);
getproc(rtl, "_length", IL._length);
getproc(rtl, "_arrcpy", IL._arrcpy);
getproc(rtl, "_is", IL._is);
getproc(rtl, "_guard", IL._guard);
getproc(rtl, "_guardrec", IL._guardrec);
getproc(rtl, "_new", IL._new);
getproc(rtl, "_rot", IL._rot);
getproc(rtl, "_strcpy", IL._strcpy);
getproc(rtl, "_move", IL._move);
getproc(rtl, "_set", IL._set);
getproc(rtl, "_set1", IL._set1);
getproc(rtl, "_lengthw", IL._lengthw);
getproc(rtl, "_strcmpw", IL._strcmpw);
getproc(rtl, "_init", IL._init);
IF CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
getproc(rtl, "_error", IL._error);
getproc(rtl, "_divmod", IL._divmod);
getproc(rtl, "_exit", IL._exit);
getproc(rtl, "_dispose", IL._dispose);
getproc(rtl, "_isrec", IL._isrec);
getproc(rtl, "_dllentry", IL._dllentry);
getproc(rtl, "_sofinit", IL._sofinit)
ELSIF CPU IN {TARGETS.cpuTHUMB, TARGETS.cpuRVM32I, TARGETS.cpuRVM64I} THEN
getproc(rtl, "_fmul", IL._fmul);
getproc(rtl, "_fdiv", IL._fdiv);
getproc(rtl, "_fdivi", IL._fdivi);
getproc(rtl, "_fadd", IL._fadd);
getproc(rtl, "_fsub", IL._fsub);
getproc(rtl, "_fsubi", IL._fsubi);
getproc(rtl, "_fcmp", IL._fcmp);
getproc(rtl, "_floor", IL._floor);
getproc(rtl, "_flt", IL._flt);
getproc(rtl, "_pack", IL._pack);
getproc(rtl, "_unpk", IL._unpk);
IF CPU IN {TARGETS.cpuRVM32I, TARGETS.cpuRVM64I} THEN
getproc(rtl, "_error", IL._error)
END
END
END setrtl;
PROCEDURE compile* (path, lib_path, modname, outname: PARS.PATH; target: INTEGER; options: PROG.OPTIONS);
VAR
parser: PARS.PARSER;
ext: PARS.PATH;
BEGIN
tINTEGER := PROG.program.stTypes.tINTEGER;
tBYTE := PROG.program.stTypes.tBYTE;
tCHAR := PROG.program.stTypes.tCHAR;
tSET := PROG.program.stTypes.tSET;
tBOOLEAN := PROG.program.stTypes.tBOOLEAN;
tWCHAR := PROG.program.stTypes.tWCHAR;
tREAL := PROG.program.stTypes.tREAL;
Options := options;
CPU := TARGETS.CPU;
ext := UTILS.FILE_EXT;
CaseLabels := C.create();
CaseVar := C.create();
CaseVariants := LISTS.create(NIL);
LISTS.push(CaseVariants, NewVariant(0, NIL));
IL.init(CPU);
IF TARGETS.RTL THEN
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn);
IF parser.open(parser, UTILS.RTL_NAME, UTILS.FILE_EXT) THEN
parser.parse(parser);
PARS.destroy(parser)
ELSE
PARS.destroy(parser);
parser := PARS.create(lib_path, lib_path, StatSeq, expression, designator, chkreturn);
IF parser.open(parser, UTILS.RTL_NAME, UTILS.FILE_EXT) THEN
parser.parse(parser);
PARS.destroy(parser)
ELSE
ERRORS.FileNotFound(lib_path, UTILS.RTL_NAME, UTILS.FILE_EXT)
END
END
END;
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn);
parser.main := TRUE;
IF parser.open(parser, modname, UTILS.FILE_EXT) THEN
parser.parse(parser)
ELSE
ERRORS.FileNotFound(path, modname, UTILS.FILE_EXT)
END;
PARS.destroy(parser);
IF PROG.program.bss > UTILS.MAX_GLOBAL_SIZE THEN
ERRORS.Error(204)
END;
IF TARGETS.RTL THEN
setrtl
END;
PROG.DelUnused(IL.DelImport);
IL.set_bss(PROG.program.bss);
CASE CPU OF
|TARGETS.cpuAMD64: AMD64.CodeGen(outname, target, options)
|TARGETS.cpuX86: X86.CodeGen(outname, target, options)
|TARGETS.cpuMSP430: MSP430.CodeGen(outname, target, options)
|TARGETS.cpuTHUMB: THUMB.CodeGen(outname, target, options)
|TARGETS.cpuRVM32I,
TARGETS.cpuRVM64I: RVMxI.CodeGen(outname, target, options)
END
END compile;
END STATEMENTS.

/programs/develop/oberon07/source/STRINGS.ob07
0,0 → 1,342
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE STRINGS;
IMPORT UTILS;
PROCEDURE copy* (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR; spos, dpos, count: INTEGER);
BEGIN
WHILE count > 0 DO
dst[dpos] := src[spos];
INC(spos);
INC(dpos);
DEC(count)
END
END copy;
PROCEDURE append* (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
copy(s2, s1, 0, n1, n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE IntToStr* (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
BEGIN
IF x = UTILS.minint THEN
IF UTILS.bit_depth = 32 THEN
COPY("-2147483648", str)
ELSIF UTILS.bit_depth = 64 THEN
COPY("-9223372036854775808", str)
END
ELSE
i := 0;
IF x < 0 THEN
x := -x;
i := 1;
str[0] := "-"
END;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END
END IntToStr;
PROCEDURE search* (s: ARRAY OF CHAR; VAR pos: INTEGER; c: CHAR; forward: BOOLEAN);
VAR
length: INTEGER;
BEGIN
length := LENGTH(s);
IF (0 <= pos) & (pos < length) THEN
IF forward THEN
WHILE (pos < length) & (s[pos] # c) DO
INC(pos)
END;
IF pos = length THEN
pos := -1
END
ELSE
WHILE (pos >= 0) & (s[pos] # c) DO
DEC(pos)
END
END
ELSE
pos := -1
END
END search;
PROCEDURE replace* (VAR s: ARRAY OF CHAR; find, repl: CHAR);
VAR
i, strlen: INTEGER;
BEGIN
strlen := LENGTH(s) - 1;
FOR i := 0 TO strlen DO
IF s[i] = find THEN
s[i] := repl
END
END
END replace;
PROCEDURE trim* (source: ARRAY OF CHAR; VAR result: ARRAY OF CHAR);
VAR
LenS, start, _end, i, j: INTEGER;
BEGIN
LenS := LENGTH(source) - 1;
j := 0;
IF LenS >= 0 THEN
start := 0;
WHILE (start <= LenS) & (source[start] <= 20X) DO
INC(start)
END;
_end := LenS;
WHILE (_end >= 0) & (source[_end] <= 20X) DO
DEC(_end)
END;
FOR i := start TO _end DO
result[j] := source[i];
INC(j)
END
END;
result[j] := 0X
END trim;
PROCEDURE letter* (c: CHAR): BOOLEAN;
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z") OR (c = "_")
END letter;
PROCEDURE digit* (c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9")
END digit;
PROCEDURE hexdigit* (c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9") OR ("A" <= c) & (c <= "F")
END hexdigit;
PROCEDURE space* (c: CHAR): BOOLEAN;
RETURN (0X < c) & (c <= 20X)
END space;
PROCEDURE cap* (VAR c: CHAR);
BEGIN
IF ("a" <= c) & (c <= "z") THEN
c := CHR(ORD(c) - 32)
END
END cap;
PROCEDURE UpCase* (VAR str: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := LENGTH(str) - 1;
WHILE i >= 0 DO
cap(str[i]);
DEC(i)
END
END UpCase;
PROCEDURE StrToInt* (str: ARRAY OF CHAR; VAR x: INTEGER): BOOLEAN;
VAR
i, k: INTEGER;
res: BOOLEAN;
BEGIN
res := TRUE;
i := 0;
x := 0;
k := LENGTH(str);
WHILE i < k DO
IF digit(str[i]) THEN
x := x * 10 + ORD(str[i]) - ORD("0")
ELSE
i := k;
res := FALSE
END;
INC(i)
END
RETURN res
END StrToInt;
PROCEDURE CheckVer (str: ARRAY OF CHAR): BOOLEAN;
VAR
i, k: INTEGER;
res: BOOLEAN;
BEGIN
k := LENGTH(str);
res := k < LEN(str);
IF res & digit(str[0]) THEN
i := 0;
WHILE (i < k) & digit(str[i]) DO
INC(i)
END;
IF (i < k) & (str[i] = ".") THEN
INC(i);
IF i < k THEN
WHILE (i < k) & digit(str[i]) DO
INC(i)
END
ELSE
res := FALSE
END
ELSE
res := FALSE
END;
res := res & (i = k)
ELSE
res := FALSE
END
RETURN res
END CheckVer;
PROCEDURE StrToVer* (str: ARRAY OF CHAR; VAR major, minor: INTEGER): BOOLEAN;
VAR
i: INTEGER;
res: BOOLEAN;
BEGIN
res := CheckVer(str);
IF res THEN
i := 0;
minor := 0;
major := 0;
WHILE digit(str[i]) DO
major := major * 10 + ORD(str[i]) - ORD("0");
INC(i)
END;
INC(i);
WHILE digit(str[i]) DO
minor := minor * 10 + ORD(str[i]) - ORD("0");
INC(i)
END
END
RETURN res
END StrToVer;
PROCEDURE Utf8To16* (src: ARRAY OF CHAR; VAR dst: ARRAY OF WCHAR): INTEGER;
VAR
i, j, u, srclen, dstlen: INTEGER;
c: CHAR;
BEGIN
srclen := LEN(src);
dstlen := LEN(dst);
i := 0;
j := 0;
WHILE (i < srclen) & (j < dstlen) & (src[i] # 0X) DO
c := src[i];
CASE c OF
|00X..7FX:
u := ORD(c)
|0C1X..0DFX:
u := (ORD(c) - 0C0H) * 64;
IF i + 1 < srclen THEN
INC(i);
INC(u, ORD(src[i]) MOD 64)
END
|0E1X..0EFX:
u := (ORD(c) - 0E0H) * 4096;
IF i + 1 < srclen THEN
INC(i);
INC(u, (ORD(src[i]) MOD 64) * 64)
END;
IF i + 1 < srclen THEN
INC(i);
INC(u, ORD(src[i]) MOD 64)
END
(*
|0F1X..0F7X:
|0F9X..0FBX:
|0FDX:
*)
ELSE
END;
INC(i);
dst[j] := WCHR(u);
INC(j)
END;
IF j < dstlen THEN
dst[j] := WCHR(0)
END
RETURN j
END Utf8To16;
PROCEDURE HashStr* (name: ARRAY OF CHAR): INTEGER;
VAR
i, h: INTEGER;
g: SET;
BEGIN
h := 0;
i := 0;
WHILE name[i] # 0X DO
h := h * 16 + ORD(name[i]);
g := BITS(h) * {28..31};
h := ORD(BITS(h) / BITS(LSR(ORD(g), 24)) - g);
INC(i)
END
RETURN h
END HashStr;
END STRINGS.

/programs/develop/oberon07/source/TARGETS.ob07
0,0 → 1,153
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
All rights reserved.
*)
MODULE TARGETS;
IMPORT UTILS;
CONST
MSP430* = 0;
Win32C* = 1;
Win32GUI* = 2;
Win32DLL* = 3;
KolibriOS* = 4;
KolibriOSDLL* = 5;
Win64C* = 6;
Win64GUI* = 7;
Win64DLL* = 8;
Linux32* = 9;
Linux32SO* = 10;
Linux64* = 11;
Linux64SO* = 12;
STM32CM3* = 13;
RVM32I* = 14;
RVM64I* = 15;
cpuX86* = 0; cpuAMD64* = 1; cpuMSP430* = 2; cpuTHUMB* = 3;
cpuRVM32I* = 4; cpuRVM64I* = 5;
osNONE* = 0; osWIN32* = 1; osWIN64* = 2;
osLINUX32* = 3; osLINUX64* = 4; osKOS* = 5;
noDISPOSE = {MSP430, STM32CM3, RVM32I, RVM64I};
noRTL = {MSP430};
libRVM32I = "RVMxI" + UTILS.slash + "32";
libRVM64I = "RVMxI" + UTILS.slash + "64";
TYPE
STRING = ARRAY 32 OF CHAR;
TARGET = RECORD
target, CPU, OS, RealSize: INTEGER;
ComLinePar*, LibDir, FileExt: STRING
END;
VAR
Targets*: ARRAY 16 OF TARGET;
CPUs: ARRAY 6 OF
RECORD
BitDepth, InstrSize: INTEGER;
LittleEndian: BOOLEAN
END;
target*, CPU*, BitDepth*, OS*, RealSize*, WordSize*, AdrSize*, InstrSize*: INTEGER;
ComLinePar*, LibDir*, FileExt*: STRING;
Import*, Dispose*, RTL*, Dll*, LittleEndian*: BOOLEAN;
PROCEDURE Enter (idx, CPU, RealSize, OS: INTEGER; ComLinePar, LibDir, FileExt: STRING);
BEGIN
Targets[idx].target := idx;
Targets[idx].CPU := CPU;
Targets[idx].RealSize := RealSize;
Targets[idx].OS := OS;
Targets[idx].ComLinePar := ComLinePar;
Targets[idx].LibDir := LibDir;
Targets[idx].FileExt := FileExt;
END Enter;
PROCEDURE Select* (ComLineParam: ARRAY OF CHAR): BOOLEAN;
VAR
i: INTEGER;
res: BOOLEAN;
BEGIN
i := 0;
WHILE (i < LEN(Targets)) & (Targets[i].ComLinePar # ComLineParam) DO
INC(i)
END;
res := i < LEN(Targets);
IF res THEN
target := Targets[i].target;
CPU := Targets[i].CPU;
BitDepth := CPUs[CPU].BitDepth;
InstrSize := CPUs[CPU].InstrSize;
LittleEndian := CPUs[CPU].LittleEndian;
RealSize := Targets[i].RealSize;
OS := Targets[i].OS;
ComLinePar := Targets[i].ComLinePar;
LibDir := Targets[i].LibDir;
FileExt := Targets[i].FileExt;
Import := OS IN {osWIN32, osWIN64, osKOS};
Dispose := ~(target IN noDISPOSE);
RTL := ~(target IN noRTL);
Dll := target IN {Linux32SO, Linux64SO, Win32DLL, Win64DLL, KolibriOSDLL};
WordSize := BitDepth DIV 8;
AdrSize := WordSize
END
RETURN res
END Select;
PROCEDURE EnterCPU (cpu, BitDepth, InstrSize: INTEGER; LittleEndian: BOOLEAN);
BEGIN
CPUs[cpu].BitDepth := BitDepth;
CPUs[cpu].InstrSize := InstrSize;
CPUs[cpu].LittleEndian := LittleEndian
END EnterCPU;
BEGIN
EnterCPU(cpuX86, 32, 1, TRUE);
EnterCPU(cpuAMD64, 64, 1, TRUE);
EnterCPU(cpuMSP430, 16, 2, TRUE);
EnterCPU(cpuTHUMB, 32, 2, TRUE);
EnterCPU(cpuRVM32I, 32, 4, TRUE);
EnterCPU(cpuRVM64I, 64, 8, TRUE);
Enter( MSP430, cpuMSP430, 0, osNONE, "msp430", "MSP430", ".hex");
Enter( Win32C, cpuX86, 8, osWIN32, "win32con", "Windows", ".exe");
Enter( Win32GUI, cpuX86, 8, osWIN32, "win32gui", "Windows", ".exe");
Enter( Win32DLL, cpuX86, 8, osWIN32, "win32dll", "Windows", ".dll");
Enter( KolibriOS, cpuX86, 8, osKOS, "kosexe", "KolibriOS", "");
Enter( KolibriOSDLL, cpuX86, 8, osKOS, "kosdll", "KolibriOS", ".obj");
Enter( Win64C, cpuAMD64, 8, osWIN64, "win64con", "Windows", ".exe");
Enter( Win64GUI, cpuAMD64, 8, osWIN64, "win64gui", "Windows", ".exe");
Enter( Win64DLL, cpuAMD64, 8, osWIN64, "win64dll", "Windows", ".dll");
Enter( Linux32, cpuX86, 8, osLINUX32, "linux32exe", "Linux", "");
Enter( Linux32SO, cpuX86, 8, osLINUX32, "linux32so", "Linux", ".so");
Enter( Linux64, cpuAMD64, 8, osLINUX64, "linux64exe", "Linux", "");
Enter( Linux64SO, cpuAMD64, 8, osLINUX64, "linux64so", "Linux", ".so");
Enter( STM32CM3, cpuTHUMB, 4, osNONE, "stm32cm3", "STM32CM3", ".hex");
Enter( RVM32I, cpuRVM32I, 4, osNONE, "rvm32i", libRVM32I, ".bin");
Enter( RVM64I, cpuRVM64I, 8, osNONE, "rvm64i", libRVM64I, ".bin");
END TARGETS.

/programs/develop/oberon07/source/THUMB.ob07
0,0 → 1,2466
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
All rights reserved.
*)
MODULE THUMB;
IMPORT PROG, LISTS, CHL := CHUNKLISTS, BIN, REG, IL, C := CONSOLE,
UTILS, WR := WRITER, HEX, ERRORS, TARGETS;
CONST
R0 = 0; R1 = 1; R2 = 2; R3 = 3; R4 = 4;
SP = 13; LR = 14; PC = 15;
ACC = R0;
je = 0; jne = 1; jnb = 2; jb = 3; jge = 10; jl = 11; jg = 12; jle = 13;
inf = 7F800000H;
minROM* = 16; maxROM* = 65536;
minRAM* = 4; maxRAM* = 65536;
maxIVT* = 1023;
_THUMB2 = 0; _IT = 1; _SDIV = 2; _CBXZ = 3;
CortexM0 = {};
CortexM1 = {};
CortexM3 = {_THUMB2, _IT, _SDIV, _CBXZ};
CortexM23 = {_SDIV, _CBXZ};
TYPE
COMMAND = IL.COMMAND;
ANYCODE = POINTER TO RECORD (LISTS.ITEM)
offset: INTEGER
END;
CODE = POINTER TO RECORD (ANYCODE)
code: INTEGER
END;
LABEL = POINTER TO RECORD (ANYCODE)
label: INTEGER
END;
JUMP = POINTER TO RECORD (ANYCODE)
label, diff, len, cond: INTEGER;
short: BOOLEAN
END;
JMP = POINTER TO RECORD (JUMP)
END;
JCC = POINTER TO RECORD (JUMP)
END;
CBXZ = POINTER TO RECORD (JUMP)
reg: INTEGER
END;
CALL = POINTER TO RECORD (JUMP)
END;
RELOC = POINTER TO RECORD (ANYCODE)
reg, rel, value: INTEGER
END;
RELOCCODE = ARRAY 7 OF INTEGER;
VAR
R: REG.REGS;
tcount: INTEGER;
CodeList: LISTS.LIST;
program: BIN.PROGRAM;
StkCount: INTEGER;
Target: RECORD
FlashAdr,
SRAMAdr,
IVTLen,
MinStack,
Reserved: INTEGER;
InstrSet: SET;
isNXP: BOOLEAN
END;
IVT: ARRAY maxIVT + 1 OF INTEGER;
sdivProc, trap, genTrap, entry, emptyProc, int0, genInt: INTEGER;
PROCEDURE Code (code: INTEGER);
VAR
c: CODE;
BEGIN
NEW(c);
c.code := code;
LISTS.push(CodeList, c)
END Code;
PROCEDURE Label (label: INTEGER);
VAR
L: LABEL;
BEGIN
NEW(L);
L.label := label;
LISTS.push(CodeList, L)
END Label;
PROCEDURE jcc (cond, label: INTEGER);
VAR
j: JCC;
BEGIN
NEW(j);
j.label := label;
j.cond := cond;
j.short := FALSE;
j.len := 3;
LISTS.push(CodeList, j)
END jcc;
PROCEDURE cbxz (cond, reg, label: INTEGER);
VAR
j: CBXZ;
BEGIN
NEW(j);
j.label := label;
j.cond := cond;
j.reg := reg;
j.short := FALSE;
j.len := 4;
LISTS.push(CodeList, j)
END cbxz;
PROCEDURE jmp (label: INTEGER);
VAR
j: JMP;
BEGIN
NEW(j);
j.label := label;
j.short := FALSE;
j.len := 2;
LISTS.push(CodeList, j)
END jmp;
PROCEDURE call (label: INTEGER);
VAR
c: CALL;
BEGIN
NEW(c);
c.label := label;
c.short := FALSE;
c.len := 2;
LISTS.push(CodeList, c)
END call;
PROCEDURE reloc (reg, rel, value: INTEGER);
VAR
r: RELOC;
BEGIN
NEW(r);
r.reg := reg;
r.rel := rel;
r.value := value;
LISTS.push(CodeList, r)
END reloc;
PROCEDURE NewLabel (): INTEGER;
BEGIN
BIN.NewLabel(program)
RETURN IL.NewLabel()
END NewLabel;
PROCEDURE range (x, n: INTEGER): BOOLEAN;
RETURN (0 <= x) & (x < LSL(1, n))
END range;
PROCEDURE srange (x, n: INTEGER): BOOLEAN;
RETURN (-LSL(1, n - 1) <= x) & (x < LSL(1, n - 1))
END srange;
PROCEDURE gen1 (op, imm, rs, rd: INTEGER);
BEGIN
ASSERT(op IN {0..2});
ASSERT(range(imm, 5));
ASSERT(range(rs, 3));
ASSERT(range(rd, 3));
Code(LSL(op, 11) + LSL(imm, 6) + LSL(rs, 3) + rd)
END gen1;
PROCEDURE gen2 (i, op: BOOLEAN; imm, rs, rd: INTEGER);
BEGIN
ASSERT(range(imm, 3));
ASSERT(range(rs, 3));
ASSERT(range(rd, 3));
Code(1800H + LSL(ORD(i), 10) + LSL(ORD(op), 9) + LSL(imm, 6) + LSL(rs, 3) + rd)
END gen2;
PROCEDURE gen3 (op, rd, imm: INTEGER);
BEGIN
ASSERT(range(op, 2));
ASSERT(range(rd, 3));
ASSERT(range(imm, 8));
Code(2000H + LSL(op, 11) + LSL(rd, 8) + imm)
END gen3;
PROCEDURE gen4 (op, rs, rd: INTEGER);
BEGIN
ASSERT(range(op, 4));
ASSERT(range(rs, 3));
ASSERT(range(rd, 3));
Code(4000H + LSL(op, 6) + LSL(rs, 3) + rd)
END gen4;
PROCEDURE gen5 (op: INTEGER; h1, h2: BOOLEAN; rs, rd: INTEGER);
BEGIN
ASSERT(range(op, 2));
ASSERT(range(rs, 3));
ASSERT(range(rd, 3));
Code(4400H + LSL(op, 8) + LSL(ORD(h1), 7) + LSL(ORD(h2), 6) + LSL(rs, 3) + rd)
END gen5;
PROCEDURE gen7 (l, b: BOOLEAN; ro, rb, rd: INTEGER);
BEGIN
ASSERT(range(ro, 3));
ASSERT(range(rb, 3));
ASSERT(range(rd, 3));
Code(5000H + LSL(ORD(l), 11) + LSL(ORD(b), 10) + LSL(ro, 6) + LSL(rb, 3) + rd)
END gen7;
PROCEDURE gen8 (h, s: BOOLEAN; ro, rb, rd: INTEGER);
BEGIN
ASSERT(range(ro, 3));
ASSERT(range(rb, 3));
ASSERT(range(rd, 3));
Code(5200H + LSL(ORD(h), 11) + LSL(ORD(s), 10) + LSL(ro, 6) + LSL(rb, 3) + rd)
END gen8;
PROCEDURE gen9 (b, l: BOOLEAN; imm, rb, rd: INTEGER);
BEGIN
ASSERT(range(imm, 5));
ASSERT(range(rb, 3));
ASSERT(range(rd, 3));
Code(6000H + LSL(ORD(b), 12) + LSL(ORD(l), 11) + LSL(imm, 6) + LSL(rb, 3) + rd)
END gen9;
PROCEDURE gen10 (l: BOOLEAN; imm, rb, rd: INTEGER);
BEGIN
ASSERT(range(imm, 5));
ASSERT(range(rb, 3));
ASSERT(range(rd, 3));
Code(8000H + LSL(ORD(l), 11) + LSL(imm, 6) + LSL(rb, 3) + rd)
END gen10;
PROCEDURE gen11 (l: BOOLEAN; rd, imm: INTEGER);
BEGIN
ASSERT(range(rd, 3));
ASSERT(range(imm, 8));
Code(9000H + LSL(ORD(l), 11) + LSL(rd, 8) + imm)
END gen11;
PROCEDURE gen12 (sp: BOOLEAN; rd, imm: INTEGER);
BEGIN
ASSERT(range(rd, 3));
ASSERT(range(imm, 8));
Code(0A000H + LSL(ORD(sp), 11) + LSL(rd, 8) + imm)
END gen12;
PROCEDURE gen14 (l, r: BOOLEAN; rlist: SET);
VAR
i, n: INTEGER;
BEGIN
ASSERT(range(ORD(rlist), 8));
n := ORD(r);
FOR i := 0 TO 7 DO
IF i IN rlist THEN
INC(n)
END
END;
IF l THEN
n := -n
END;
INC(StkCount, n);
Code(0B400H + LSL(ORD(l), 11) + LSL(ORD(r), 8) + ORD(rlist))
END gen14;
PROCEDURE split16 (imm16: INTEGER; VAR imm4, imm1, imm3, imm8: INTEGER);
BEGIN
ASSERT(range(imm16, 16));
imm8 := imm16 MOD 256;
imm4 := LSR(imm16, 12);
imm3 := LSR(imm16, 8) MOD 8;
imm1 := LSR(imm16, 11) MOD 2;
END split16;
PROCEDURE LslImm (r, imm5: INTEGER);
BEGIN
gen1(0, imm5, r, r)
END LslImm;
PROCEDURE LsrImm (r, imm5: INTEGER);
BEGIN
gen1(1, imm5, r, r)
END LsrImm;
PROCEDURE AsrImm (r, imm5: INTEGER);
BEGIN
gen1(2, imm5, r, r)
END AsrImm;
PROCEDURE AddReg (rd, rs, rn: INTEGER);
BEGIN
gen2(FALSE, FALSE, rn, rs, rd)
END AddReg;
PROCEDURE SubReg (rd, rs, rn: INTEGER);
BEGIN
gen2(FALSE, TRUE, rn, rs, rd)
END SubReg;
PROCEDURE AddImm8 (rd, imm8: INTEGER);
BEGIN
IF imm8 # 0 THEN
gen3(2, rd, imm8)
END
END AddImm8;
PROCEDURE SubImm8 (rd, imm8: INTEGER);
BEGIN
IF imm8 # 0 THEN
gen3(3, rd, imm8)
END
END SubImm8;
PROCEDURE AddSubImm12 (r, imm12: INTEGER; sub: BOOLEAN);
VAR
imm4, imm1, imm3, imm8: INTEGER;
BEGIN
split16(imm12, imm4, imm1, imm3, imm8);
Code(0F200H + LSL(imm1, 10) + r + 0A0H * ORD(sub)); (* addw/subw r, r, imm12 *)
Code(LSL(imm3, 12) + LSL(r, 8) + imm8)
END AddSubImm12;
PROCEDURE MovImm8 (rd, imm8: INTEGER);
BEGIN
gen3(0, rd, imm8)
END MovImm8;
PROCEDURE CmpImm8 (rd, imm8: INTEGER);
BEGIN
gen3(1, rd, imm8)
END CmpImm8;
PROCEDURE Neg (r: INTEGER);
BEGIN
gen4(9, r, r)
END Neg;
PROCEDURE Mul (rd, rs: INTEGER);
BEGIN
gen4(13, rs, rd)
END Mul;
PROCEDURE Str32 (rs, rb: INTEGER);
BEGIN
gen9(FALSE, FALSE, 0, rb, rs)
END Str32;
PROCEDURE Ldr32 (rd, rb: INTEGER);
BEGIN
gen9(FALSE, TRUE, 0, rb, rd)
END Ldr32;
PROCEDURE Str16 (rs, rb: INTEGER);
BEGIN
gen10(FALSE, 0, rb, rs)
END Str16;
PROCEDURE Ldr16 (rd, rb: INTEGER);
BEGIN
gen10(TRUE, 0, rb, rd)
END Ldr16;
PROCEDURE Str8 (rs, rb: INTEGER);
BEGIN
gen9(TRUE, FALSE, 0, rb, rs)
END Str8;
PROCEDURE Ldr8 (rd, rb: INTEGER);
BEGIN
gen9(TRUE, TRUE, 0, rb, rd)
END Ldr8;
PROCEDURE Cmp (r1, r2: INTEGER);
BEGIN
gen4(10, r2, r1)
END Cmp;
PROCEDURE Tst (r: INTEGER);
BEGIN
gen3(1, r, 0) (* cmp r, 0 *)
END Tst;
PROCEDURE LdrSp (r, offset: INTEGER);
BEGIN
gen11(TRUE, r, offset)
END LdrSp;
PROCEDURE MovImm32 (r, imm32: INTEGER);
BEGIN
MovImm8(r, LSR(imm32, 24) MOD 256);
LslImm(r, 8);
AddImm8(r, LSR(imm32, 16) MOD 256);
LslImm(r, 8);
AddImm8(r, LSR(imm32, 8) MOD 256);
LslImm(r, 8);
AddImm8(r, imm32 MOD 256)
END MovImm32;
PROCEDURE low (x: INTEGER): INTEGER;
RETURN x MOD 65536
END low;
PROCEDURE high (x: INTEGER): INTEGER;
RETURN (x DIV 65536) MOD 65536
END high;
PROCEDURE movwt (r, imm16, t: INTEGER);
VAR
imm1, imm3, imm4, imm8: INTEGER;
BEGIN
ASSERT(range(r, 3));
ASSERT(range(imm16, 16));
ASSERT(range(t, 1));
split16(imm16, imm4, imm1, imm3, imm8);
Code(0F240H + imm1 * 1024 + t * 128 + imm4);
Code(imm3 * 4096 + r * 256 + imm8);
END movwt;
PROCEDURE inv0 (cond: INTEGER): INTEGER;
RETURN ORD(BITS(cond) / {0})
END inv0;
PROCEDURE fixup (CodeAdr, DataAdr, BssAdr: INTEGER);
VAR
code: ANYCODE;
count: INTEGER;
shorted: BOOLEAN;
jump: JUMP;
reloc, i, diff, len: INTEGER;
RelocCode: RELOCCODE;
PROCEDURE genjcc (cond, offset: INTEGER): INTEGER;
BEGIN
ASSERT(range(cond, 4));
ASSERT(srange(offset, 8))
RETURN 0D000H + cond * 256 + offset MOD 256
END genjcc;
PROCEDURE genjmp (offset: INTEGER): INTEGER;
BEGIN
ASSERT(srange(offset, 11))
RETURN 0E000H + offset MOD 2048
END genjmp;
PROCEDURE movwt (r, imm16, t: INTEGER; VAR code: RELOCCODE);
VAR
imm1, imm3, imm4, imm8: INTEGER;
BEGIN
split16(imm16, imm4, imm1, imm3, imm8);
code[t * 2] := 0F240H + imm1 * 1024 + t * 128 + imm4;
code[t * 2 + 1] := imm3 * 4096 + r * 256 + imm8
END movwt;
PROCEDURE genmovimm32 (r, value: INTEGER; VAR code: RELOCCODE);
BEGIN
IF _THUMB2 IN Target.InstrSet THEN
movwt(r, low(value), 0, code);
movwt(r, high(value), 1, code)
ELSE
code[0] := 2000H + r * 256 + UTILS.Byte(value, 3); (* movs r, imm8 *)
code[1] := 0200H + r * 9; (* lsls r, 8 *)
code[2] := 3000H + r * 256 + UTILS.Byte(value, 2); (* adds r, imm8 *)
code[3] := code[1]; (* lsls r, 8 *)
code[4] := 3000H + r * 256 + UTILS.Byte(value, 1); (* adds r, imm8 *)
code[5] := code[1]; (* lsls r, 8 *)
code[6] := 3000H + r * 256 + UTILS.Byte(value, 0) (* adds r, imm8 *)
END
END genmovimm32;
PROCEDURE PutCode (code: INTEGER);
BEGIN
BIN.PutCode16LE(program, code)
END PutCode;
PROCEDURE genlongjmp (offset: INTEGER);
BEGIN
ASSERT(srange(offset, 22));
PutCode(0F000H + ASR(offset, 11) MOD 2048);
PutCode(0F800H + offset MOD 2048)
END genlongjmp;
PROCEDURE genbc (code: JUMP);
BEGIN
CASE code.len OF
|1: PutCode(genjcc(code.cond, code.diff))
|2: PutCode(genjcc(inv0(code.cond), 0));
PutCode(genjmp(code.diff))
|3: PutCode(genjcc(inv0(code.cond), 1));
genlongjmp(code.diff)
END
END genbc;
PROCEDURE SetIV (idx, label, CodeAdr: INTEGER);
VAR
l, h: LISTS.ITEM;
BEGIN
l := CodeList.first;
h := l.next;
WHILE idx > 0 DO
l := h.next;
h := l.next;
DEC(idx)
END;
label := BIN.GetLabel(program, label) * 2 + CodeAdr + 1;
l(CODE).code := low(label);
h(CODE).code := high(label)
END SetIV;
BEGIN
REPEAT
shorted := FALSE;
count := 0;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
code.offset := count;
CASE code OF
|CODE: INC(count)
|LABEL: BIN.SetLabel(program, code.label, count)
|JUMP: INC(count, code.len); code.offset := count + ORD(code.short)
|RELOC: INC(count, 7 - ORD(_THUMB2 IN Target.InstrSet) * 3 + code.rel MOD 2)
END;
code := code.next(ANYCODE)
END;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
IF code IS JUMP THEN
jump := code(JUMP);
jump.diff := BIN.GetLabel(program, jump.label) - jump.offset;
len := jump.len;
diff := jump.diff;
CASE jump OF
|JMP:
IF (len = 2) & srange(diff, 11) THEN
len := 1
END
|JCC:
CASE len OF
|1:
|2: IF srange(diff, 8) THEN DEC(len) END
|3: IF srange(diff, 11) THEN DEC(len) END
END
|CBXZ:
CASE len OF
|1:
|2: IF range(diff, 6) THEN DEC(len) END
|3: IF srange(diff, 8) THEN DEC(len) END
|4: IF srange(diff, 11) THEN DEC(len) END
END
|CALL:
END;
IF len # jump.len THEN
jump.len := len;
jump.short := TRUE;
shorted := TRUE
END
END;
code := code.next(ANYCODE)
END
UNTIL ~shorted;
FOR i := 1 TO Target.IVTLen - 1 DO
SetIV(i, IVT[i], CodeAdr)
END;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
CASE code OF
|CODE: BIN.PutCode16LE(program, code.code)
|LABEL:
|JMP:
IF code.len = 1 THEN
PutCode(genjmp(code.diff))
ELSE
genlongjmp(code.diff)
END
|JCC: genbc(code)
|CBXZ:
IF code.len > 1 THEN
PutCode(2800H + code.reg * 256); (* cmp code.reg, 0 *)
DEC(code.len);
genbc(code)
ELSE
(* cb(n)z code.reg, L *)
PutCode(0B100H + 800H * ORD(code.cond = jne) + 200H * (code.diff DIV 32) + (code.diff MOD 32) * 8 + code.reg)
END
|CALL: genlongjmp(code.diff)
|RELOC:
CASE code.rel OF
|BIN.RCODE, BIN.PICCODE: reloc := BIN.GetLabel(program, code.value) * 2 + CodeAdr
|BIN.RDATA, BIN.PICDATA: reloc := code.value + DataAdr
|BIN.RBSS, BIN.PICBSS: reloc := code.value + BssAdr
END;
IF code.rel IN {BIN.PICCODE, BIN.PICDATA, BIN.PICBSS} THEN
DEC(reloc, CodeAdr + 2 * (code.offset - 3 * ORD(_THUMB2 IN Target.InstrSet) + 9))
END;
genmovimm32(code.reg, reloc, RelocCode);
FOR i := 0 TO 6 - 3 * ORD(_THUMB2 IN Target.InstrSet) DO
PutCode(RelocCode[i])
END;
IF code.rel IN {BIN.PICCODE, BIN.PICDATA, BIN.PICBSS} THEN
PutCode(4478H + code.reg) (* add code.reg, pc *)
END
END;
code := code.next(ANYCODE)
END
END fixup;
PROCEDURE push (r: INTEGER);
BEGIN
gen14(FALSE, FALSE, {r})
END push;
PROCEDURE pop (r: INTEGER);
BEGIN
gen14(TRUE, FALSE, {r})
END pop;
PROCEDURE mov (r1, r2: INTEGER);
BEGIN
IF (r1 < 8) & (r2 < 8) THEN
gen1(0, 0, r2, r1)
ELSE
gen5(2, r1 >= 8, r2 >= 8, r2 MOD 8, r1 MOD 8)
END
END mov;
PROCEDURE xchg (r1, r2: INTEGER);
BEGIN
push(r1);
mov(r1, r2);
pop(r2)
END xchg;
PROCEDURE drop;
BEGIN
REG.Drop(R)
END drop;
PROCEDURE GetAnyReg (): INTEGER;
RETURN REG.GetAnyReg(R)
END GetAnyReg;
PROCEDURE UnOp (VAR r: INTEGER);
BEGIN
REG.UnOp(R, r)
END UnOp;
PROCEDURE BinOp (VAR r1, r2: INTEGER);
BEGIN
REG.BinOp(R, r1, r2)
END BinOp;
PROCEDURE PushAll (NumberOfParameters: INTEGER);
BEGIN
REG.PushAll(R);
DEC(R.pushed, NumberOfParameters)
END PushAll;
PROCEDURE cond (op: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE op OF
|IL.opGT, IL.opGTC: res := jg
|IL.opGE, IL.opGEC: res := jge
|IL.opLT, IL.opLTC: res := jl
|IL.opLE, IL.opLEC: res := jle
|IL.opEQ, IL.opEQC: res := je
|IL.opNE, IL.opNEC: res := jne
END
RETURN res
END cond;
PROCEDURE GetRegA;
BEGIN
ASSERT(REG.GetReg(R, ACC))
END GetRegA;
PROCEDURE MovConst (r, c: INTEGER);
BEGIN
IF (0 <= c) & (c <= 255) THEN
MovImm8(r, c)
ELSIF (-255 <= c) & (c < 0) THEN
MovImm8(r, -c);
Neg(r)
ELSIF UTILS.Log2(c) >= 0 THEN
MovImm8(r, 1);
LslImm(r, UTILS.Log2(c))
ELSIF c = UTILS.min32 THEN
MovImm8(r, 1);
LslImm(r, 31)
ELSE
IF _THUMB2 IN Target.InstrSet THEN
movwt(r, low(c), 0);
IF (c < 0) OR (c > 65535) THEN
movwt(r, high(c), 1)
END
ELSE
MovImm32(r, c)
END
END
END MovConst;
PROCEDURE CmpConst (r, c: INTEGER);
VAR
r2: INTEGER;
BEGIN
IF (0 <= c) & (c <= 255) THEN
CmpImm8(r, c)
ELSE
r2 := GetAnyReg();
ASSERT(r2 # r);
MovConst(r2, c);
Cmp(r, r2);
drop
END
END CmpConst;
PROCEDURE LocalOffset (offset: INTEGER): INTEGER;
RETURN offset + StkCount - ORD(offset > 0)
END LocalOffset;
PROCEDURE SetCC (cc, r: INTEGER);
VAR
L1, L2: INTEGER;
BEGIN
IF _IT IN Target.InstrSet THEN
Code(0BF00H + cc * 16 + ((cc + 1) MOD 2) * 8 + 4); (* ite cc *)
MovConst(r, 1);
MovConst(r, 0)
ELSE
L1 := NewLabel();
L2 := NewLabel();
jcc(cc, L1);
MovConst(r, 0);
jmp(L2);
Label(L1);
MovConst(r, 1);
Label(L2)
END
END SetCC;
PROCEDURE PushConst (n: INTEGER);
VAR
r: INTEGER;
BEGIN
r := GetAnyReg();
MovConst(r, n);
push(r);
drop
END PushConst;
PROCEDURE AddConst (r, n: INTEGER);
VAR
r2: INTEGER;
BEGIN
IF n # 0 THEN
IF (-255 <= n) & (n <= 255) THEN
IF n > 0 THEN
AddImm8(r, n)
ELSE
SubImm8(r, -n)
END
ELSIF (_THUMB2 IN Target.InstrSet) & (-4095 <= n) & (n <= 4095) THEN
AddSubImm12(r, ABS(n), n < 0)
ELSE
r2 := GetAnyReg();
ASSERT(r2 # r);
IF n > 0 THEN
MovConst(r2, n);
AddReg(r, r, r2)
ELSE
MovConst(r2, -n);
SubReg(r, r, r2)
END;
drop
END
END
END AddConst;
PROCEDURE AddHH (r1, r2: INTEGER);
BEGIN
ASSERT((r1 >= 8) OR (r2 >= 8));
gen5(0, r1 >= 8, r2 >= 8, r2 MOD 8, r1 MOD 8)
END AddHH;
PROCEDURE AddSP (n: INTEGER);
BEGIN
IF n > 0 THEN
IF n < 127 THEN
Code(0B000H + n) (* add sp, n*4 *)
ELSE
ASSERT(R2 IN R.regs);
MovConst(R2, n * 4);
AddHH(SP, R2)
END;
DEC(StkCount, n)
END
END AddSP;
PROCEDURE cbxz2 (c, r, label: INTEGER);
BEGIN
IF _CBXZ IN Target.InstrSet THEN
cbxz(c, r, label)
ELSE
Tst(r);
jcc(c, label)
END
END cbxz2;
PROCEDURE cbz (r, label: INTEGER);
BEGIN
cbxz2(je, r, label)
END cbz;
PROCEDURE cbnz (r, label: INTEGER);
BEGIN
cbxz2(jne, r, label)
END cbnz;
PROCEDURE Shift (op, r1, r2: INTEGER);
VAR
L: INTEGER;
BEGIN
LslImm(r2, 27);
LsrImm(r2, 27);
L := NewLabel();
cbz(r2, L);
CASE op OF
|IL.opLSL, IL.opLSL1: gen4(2, r2, r1)
|IL.opLSR, IL.opLSR1: gen4(3, r2, r1)
|IL.opASR, IL.opASR1: gen4(4, r2, r1)
|IL.opROR, IL.opROR1: gen4(7, r2, r1)
END;
Label(L)
END Shift;
PROCEDURE LocAdr (offs: INTEGER);
VAR
r1, n: INTEGER;
BEGIN
r1 := GetAnyReg();
n := LocalOffset(offs);
IF n <= 255 THEN
gen12(TRUE, r1, n)
ELSE
MovConst(r1, n * 4);
AddHH(r1, SP)
END
END LocAdr;
PROCEDURE CallRTL (proc, par: INTEGER);
BEGIN
call(IL.codes.rtl[proc]);
AddSP(par)
END CallRTL;
PROCEDURE divmod;
BEGIN
call(sdivProc);
AddSP(2)
END divmod;
PROCEDURE cpsid_i;
BEGIN
Code(0B672H) (* cpsid i *)
END cpsid_i;
PROCEDURE cpsie_i;
BEGIN
Code(0B662H) (* cpsie i *)
END cpsie_i;
PROCEDURE translate (pic, stroffs: INTEGER);
VAR
cmd, next: COMMAND;
opcode, param1, param2: INTEGER;
r1, r2, r3: INTEGER;
a, n, cc, L, L2: INTEGER;
BEGIN
cmd := IL.codes.commands.first(COMMAND);
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
opcode := cmd.opcode;
CASE opcode OF
|IL.opJMP:
jmp(param1)
|IL.opLABEL:
Label(param1)
|IL.opHANDLER:
IF param2 = 0 THEN
int0 := param1
ELSIF param2 = 1 THEN
trap := param1
ELSE
IVT[param2] := param1
END
|IL.opCALL:
call(param1)
|IL.opCALLP:
UnOp(r1);
AddImm8(r1, 1); (* Thumb mode *)
gen5(3, TRUE, FALSE, r1, 0); (* blx r1 *)
drop;
ASSERT(R.top = -1)
|IL.opENTER:
ASSERT(R.top = -1);
Label(param1);
gen14(FALSE, TRUE, {}); (* push {lr} *)
n := param2;
IF n >= 5 THEN
MovConst(ACC, 0);
MovConst(R2, n);
L := NewLabel();
Label(L);
push(ACC);
SubImm8(R2, 1);
Tst(R2);
jcc(jne, L)
ELSIF n > 0 THEN
MovConst(ACC, 0);
WHILE n > 0 DO
push(ACC);
DEC(n)
END
END;
StkCount := param2
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF:
IF opcode # IL.opLEAVE THEN
UnOp(r1);
IF r1 # ACC THEN
mov(ACC, r1)
END;
drop
END;
ASSERT(R.top = -1);
ASSERT(StkCount = param1);
AddSP(param1);
gen14(TRUE, TRUE, {}) (* pop {pc} *)
|IL.opLEAVEC:
gen5(3, FALSE, TRUE, 6, 0) (* bx lr *)
|IL.opPRECALL:
PushAll(0)
|IL.opPARAM:
n := param2;
IF n = 1 THEN
UnOp(r1);
push(r1);
drop
ELSE
ASSERT(R.top + 1 <= n);
PushAll(n)
END
|IL.opCLEANUP:
AddSP(param2)
|IL.opRES, IL.opRESF:
ASSERT(R.top = -1);
GetRegA
|IL.opPUSHC:
PushConst(param2)
|IL.opONERR:
cpsid_i;
MovConst(R0, param2);
push(R0);
DEC(StkCount);
jmp(param1)
|IL.opERR:
call(genTrap)
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opSADR:
reloc(GetAnyReg(), BIN.RDATA + pic, stroffs + param2)
|IL.opGADR:
reloc(GetAnyReg(), BIN.RBSS + pic, param2)
|IL.opLADR:
LocAdr(param2)
|IL.opGLOAD32:
r1 := GetAnyReg();
reloc(r1, BIN.RBSS + pic, param2);
Ldr32(r1, r1)
|IL.opGLOAD16:
r1 := GetAnyReg();
reloc(r1, BIN.RBSS + pic, param2);
Ldr16(r1, r1)
|IL.opGLOAD8:
r1 := GetAnyReg();
reloc(r1, BIN.RBSS + pic, param2);
Ldr8(r1, r1)
|IL.opLADR_SAVE:
UnOp(r1);
n := LocalOffset(param2);
IF n <= 255 THEN
gen11(FALSE, r1, n) (* str r1, [sp, n*4] *)
ELSE
LocAdr(param2);
BinOp(r1, r2);
Str32(r1, r2);
drop
END;
drop
|IL.opLADR_INCC:
n := LocalOffset(param1);
IF n <= 255 THEN
r1 := GetAnyReg();
LdrSp(r1, n);
AddConst(r1, param2);
gen11(FALSE, r1, n) (* str r1, [sp, n*4] *)
ELSE
LocAdr(param1);
r1 := GetAnyReg();
BinOp(r2, r1);
Ldr32(r1, r2);
AddConst(r1, param2);
BinOp(r2, r1);
Str32(r1, r2);
drop
END;
drop
|IL.opLLOAD32, IL.opVADR, IL.opVLOAD32:
r1 := GetAnyReg();
n := LocalOffset(param2);
IF n <= 255 THEN
LdrSp(r1, n)
ELSE
drop;
LocAdr(param2);
UnOp(r1);
Ldr32(r1, r1)
END;
IF opcode = IL.opVLOAD32 THEN
Ldr32(r1, r1)
END
|IL.opLLOAD16:
LocAdr(param2);
UnOp(r1);
Ldr16(r1, r1)
|IL.opLLOAD8:
LocAdr(param2);
UnOp(r1);
Ldr8(r1, r1)
|IL.opLOAD32, IL.opLOADF:
UnOp(r1);
Ldr32(r1, r1)
|IL.opLOAD16:
UnOp(r1);
Ldr16(r1, r1)
|IL.opLOAD8:
UnOp(r1);
Ldr8(r1, r1)
|IL.opVLOAD16:
LocAdr(param2);
UnOp(r1);
Ldr32(r1, r1);
Ldr16(r1, r1)
|IL.opVLOAD8:
LocAdr(param2);
UnOp(r1);
Ldr32(r1, r1);
Ldr8(r1, r1)
|IL.opSBOOL:
BinOp(r2, r1);
Tst(r2);
SetCC(jne, r2);
Str8(r2, r1);
drop;
drop
|IL.opSBOOLC:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, ORD(param2 # 0));
Str8(r2, r1);
drop;
drop
|IL.opSAVEC:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, param2);
Str32(r2, r1);
drop;
drop
|IL.opSAVE16C:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, low(param2));
Str16(r2, r1);
drop;
drop
|IL.opSAVE8C:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, param2 MOD 256);
Str8(r2, r1);
drop;
drop
|IL.opSAVE, IL.opSAVE32, IL.opSAVEF:
BinOp(r2, r1);
Str32(r2, r1);
drop;
drop
|IL.opSAVEFI:
BinOp(r2, r1);
Str32(r1, r2);
drop;
drop
|IL.opSAVE16:
BinOp(r2, r1);
Str16(r2, r1);
drop;
drop
|IL.opSAVE8:
BinOp(r2, r1);
Str8(r2, r1);
drop;
drop
|IL.opSAVEP:
UnOp(r1);
r2 := GetAnyReg();
reloc(r2, BIN.RCODE + pic, param2);
Str32(r2, r1);
drop;
drop
|IL.opPUSHP:
reloc(GetAnyReg(), BIN.RCODE + pic, param2)
|IL.opEQB, IL.opNEB:
BinOp(r1, r2);
drop;
L := NewLabel();
cbz(r1, L);
MovConst(r1, 1);
Label(L);
L := NewLabel();
cbz(r2, L);
MovConst(r2, 1);
Label(L);
Cmp(r1, r2);
IF opcode = IL.opEQB THEN
SetCC(je, r1)
ELSE
SetCC(jne, r1)
END
|IL.opDROP:
UnOp(r1);
drop
|IL.opJNZ1:
UnOp(r1);
cbnz(r1, param1)
|IL.opJG:
UnOp(r1);
Tst(r1);
jcc(jg, param1)
|IL.opJNZ:
UnOp(r1);
cbnz(r1, param1);
drop
|IL.opJZ:
UnOp(r1);
cbz(r1, param1);
drop
|IL.opSWITCH:
UnOp(r1);
IF param2 = 0 THEN
r2 := ACC
ELSE
r2 := R2
END;
IF r1 # r2 THEN
ASSERT(REG.GetReg(R, r2));
ASSERT(REG.Exchange(R, r1, r2));
drop
END;
drop
|IL.opENDSW:
|IL.opCASEL:
GetRegA;
CmpConst(ACC, param1);
jcc(jl, param2);
drop
|IL.opCASER:
GetRegA;
CmpConst(ACC, param1);
jcc(jg, param2);
drop
|IL.opCASELR:
GetRegA;
CmpConst(ACC, param1);
IF param2 = cmd.param3 THEN
jcc(jne, param2)
ELSE
jcc(jl, param2);
jcc(jg, cmd.param3)
END;
drop
|IL.opCODE:
Code(param2)
|IL.opEQ..IL.opGE,
IL.opEQC..IL.opGEC:
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN
BinOp(r1, r2);
Cmp(r1, r2);
drop
ELSE
UnOp(r1);
CmpConst(r1, param2)
END;
drop;
cc := cond(opcode);
next := cmd.next(COMMAND);
IF next.opcode = IL.opJNZ THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJZ THEN
jcc(inv0(cc), next.param1);
cmd := next
ELSE
SetCC(cc, GetAnyReg())
END
|IL.opINCC:
UnOp(r1);
r2 := GetAnyReg();
Ldr32(r2, r1);
AddConst(r2, param2);
Str32(r2, r1);
drop;
drop
|IL.opINCCB, IL.opDECCB:
IF opcode = IL.opDECCB THEN
param2 := -param2
END;
UnOp(r1);
r2 := GetAnyReg();
Ldr8(r2, r1);
AddConst(r2, param2);
Str8(r2, r1);
drop;
drop
|IL.opUMINUS:
UnOp(r1);
Neg(r1)
|IL.opADD:
BinOp(r1, r2);
CASE cmd.next(COMMAND).opcode OF
|IL.opLOAD32, IL.opLOADF:
gen7(TRUE, FALSE, r2, r1, r1); (* ldr r1, [r1, r2] *)
cmd := cmd.next(COMMAND)
|IL.opLOAD8:
gen7(TRUE, TRUE, r2, r1, r1); (* ldrb r1, [r1, r2] *)
cmd := cmd.next(COMMAND)
|IL.opLOAD16:
gen8(TRUE, FALSE, r2, r1, r1); (* ldrh r1, [r1, r2] *)
cmd := cmd.next(COMMAND)
ELSE
AddReg(r1, r1, r2)
END;
drop
|IL.opADDC:
UnOp(r1);
AddConst(r1, param2)
|IL.opSUB:
BinOp(r1, r2);
SubReg(r1, r1, r2);
drop
|IL.opSUBL, IL.opSUBR:
UnOp(r1);
AddConst(r1, -param2);
IF opcode = IL.opSUBL THEN
Neg(r1)
END
|IL.opMUL:
BinOp(r1, r2);
Mul(r1, r2);
drop
|IL.opMULC:
UnOp(r1);
a := param2;
IF a > 1 THEN
n := UTILS.Log2(a)
ELSIF a < -1 THEN
n := UTILS.Log2(-a)
ELSE
n := -1
END;
IF a = 1 THEN
ELSIF a = -1 THEN
Neg(r1)
ELSIF a = 0 THEN
MovConst(r1, 0)
ELSE
IF n > 0 THEN
IF a < 0 THEN
Neg(r1)
END;
LslImm(r1, n)
ELSE
r2 := GetAnyReg();
MovConst(r2, a);
Mul(r1, r2);
drop
END
END
|IL.opABS:
UnOp(r1);
Tst(r1);
L := NewLabel();
jcc(jge, L);
Neg(r1);
Label(L)
|IL.opNOT:
UnOp(r1);
Tst(r1);
SetCC(je, r1)
|IL.opORD:
UnOp(r1);
Tst(r1);
SetCC(jne, r1)
|IL.opCHR:
UnOp(r1);
Code(0B2C0H + r1 * 9) (* uxtb r1, r1 *)
|IL.opWCHR:
UnOp(r1);
Code(0B280H + r1 * 9) (* uxth r1, r1 *)
|IL.opASR, IL.opROR, IL.opLSL, IL.opLSR:
BinOp(r1, r2);
Shift(opcode, r1, r2);
drop
|IL.opASR1, IL.opROR1, IL.opLSL1, IL.opLSR1:
MovConst(GetAnyReg(), param2);
BinOp(r2, r1);
Shift(opcode, r1, r2);
INCL(R.regs, r2);
DEC(R.top);
R.stk[R.top] := r1
|IL.opASR2, IL.opROR2, IL.opLSL2, IL.opLSR2:
n := param2 MOD 32;
IF n # 0 THEN
UnOp(r1);
CASE opcode OF
|IL.opASR2: AsrImm(r1, n)
|IL.opROR2: r2 := GetAnyReg(); MovConst(r2, n); Shift(IL.opROR, r1, r2); drop
|IL.opLSL2: LslImm(r1, n)
|IL.opLSR2: LsrImm(r1, n)
END
END
|IL.opCHKBYTE:
BinOp(r1, r2);
CmpConst(r1, 256);
jcc(jb, param1)
|IL.opCHKIDX:
UnOp(r1);
CmpConst(r1, param2);
jcc(jb, param1)
|IL.opCHKIDX2:
BinOp(r1, r2);
IF param2 # -1 THEN
Cmp(r2, r1);
jcc(jb, param1)
END;
INCL(R.regs, r1);
DEC(R.top);
R.stk[R.top] := r2
|IL.opLEN:
n := param2;
UnOp(r1);
drop;
EXCL(R.regs, r1);
WHILE n > 0 DO
UnOp(r2);
drop;
DEC(n)
END;
INCL(R.regs, r1);
ASSERT(REG.GetReg(R, r1))
|IL.opINF:
MovConst(GetAnyReg(), inf)
|IL.opPUSHF:
UnOp(r1);
push(r1);
drop
|IL.opCONST:
MovConst(GetAnyReg(), param2)
|IL.opEQP, IL.opNEP:
reloc(GetAnyReg(), BIN.RCODE + pic, param1);
BinOp(r1, r2);
Cmp(r1, r2);
drop;
IF opcode = IL.opEQP THEN
SetCC(je, r1)
ELSE
SetCC(jne, r1)
END
|IL.opPUSHT:
UnOp(r1);
r2 := GetAnyReg();
mov(r2, r1);
SubImm8(r2, 4);
Ldr32(r2, r2)
|IL.opGET, IL.opGETC:
IF opcode = IL.opGET THEN
BinOp(r1, r2)
ELSIF opcode = IL.opGETC THEN
UnOp(r2);
r1 := GetAnyReg();
MovConst(r1, param1)
END;
drop;
drop;
CASE param2 OF
|1: Ldr8(r1, r1); Str8(r1, r2)
|2: Ldr16(r1, r1); Str16(r1, r2)
|4: Ldr32(r1, r1); Str32(r1, r2)
END
|IL.opINC, IL.opDEC:
BinOp(r2, r1);
r3 := GetAnyReg();
Ldr32(r3, r1);
IF opcode = IL.opINC THEN
AddReg(r3, r3, r2)
ELSE
SubReg(r3, r3, r2)
END;
Str32(r3, r1);
drop;
drop;
drop
|IL.opINCB, IL.opDECB:
BinOp(r2, r1);
r3 := GetAnyReg();
Ldr8(r3, r1);
IF opcode = IL.opINCB THEN
AddReg(r3, r3, r2)
ELSE
SubReg(r3, r3, r2)
END;
Str8(r3, r1);
drop;
drop;
drop
|IL.opMIN, IL.opMAX:
BinOp(r1, r2);
Cmp(r1, r2);
L := NewLabel();
IF opcode = IL.opMIN THEN
cc := jle
ELSE
cc := jge
END;
jcc(cc, L);
mov(r1, r2);
Label(L);
drop
|IL.opMINC, IL.opMAXC:
UnOp(r1);
CmpConst(r1, param2);
L := NewLabel();
IF opcode = IL.opMINC THEN
cc := jle
ELSE
cc := jge
END;
jcc(cc, L);
MovConst(r1, param2);
Label(L)
|IL.opMULS:
BinOp(r1, r2);
gen4(0, r2, r1); (* ands r1, r2 *)
drop
|IL.opMULSC:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(0, r2, r1); (* ands r1, r2 *)
drop
|IL.opDIVS:
BinOp(r1, r2);
gen4(1, r2, r1); (* eors r1, r2 *)
drop
|IL.opDIVSC:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(1, r2, r1); (* eors r1, r2 *)
drop
|IL.opADDS:
BinOp(r1, r2);
gen4(12, r2, r1); (* orrs r1, r2 *)
drop
|IL.opSUBS:
BinOp(r1, r2);
gen4(14, r2, r1); (* bics r1, r2 *)
drop
|IL.opADDSC:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(12, r2, r1); (* orrs r1, r2 *)
drop
|IL.opSUBSL:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(14, r1, r2); (* bics r2, r1 *)
INCL(R.regs, r1);
DEC(R.top);
R.stk[R.top] := r2
|IL.opSUBSR:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(14, r2, r1); (* bics r1, r2 *)
drop
|IL.opUMINS:
UnOp(r1);
gen4(15, r1, r1) (* mvns r1, r1 *)
|IL.opINCL, IL.opEXCL:
BinOp(r1, r2);
r3 := GetAnyReg();
MovConst(r3, 1);
CmpConst(r1, 32);
L := NewLabel();
jcc(jnb, L);
gen4(2, r1, r3); (* lsls r3, r1 *)
Ldr32(r1, r2);
IF opcode = IL.opINCL THEN
gen4(12, r3, r1) (* orrs r1, r3 *)
ELSE
gen4(14, r3, r1) (* bics r1, r3 *)
END;
Str32(r1, r2);
Label(L);
drop;
drop;
drop
|IL.opINCLC, IL.opEXCLC:
UnOp(r2);
r1 := GetAnyReg();
r3 := GetAnyReg();
MovConst(r3, 1);
LslImm(r3, param2);
Ldr32(r1, r2);
IF opcode = IL.opINCLC THEN
gen4(12, r3, r1) (* orrs r1, r3 *)
ELSE
gen4(14, r3, r1) (* bics r1, r3 *)
END;
Str32(r1, r2);
drop;
drop;
drop
|IL.opLENGTH:
PushAll(2);
CallRTL(IL._length, 2);
GetRegA
|IL.opLENGTHW:
PushAll(2);
CallRTL(IL._lengthw, 2);
GetRegA
|IL.opSAVES:
UnOp(r2);
REG.PushAll_1(R);
r1 := GetAnyReg();
reloc(r1, BIN.RDATA + pic, stroffs + param2);
push(r1);
drop;
push(r2);
drop;
PushConst(param1);
CallRTL(IL._move, 3)
|IL.opEQS .. IL.opGES:
PushAll(4);
PushConst(opcode - IL.opEQS);
CallRTL(IL._strcmp, 5);
GetRegA
|IL.opEQSW .. IL.opGESW:
PushAll(4);
PushConst(opcode - IL.opEQSW);
CallRTL(IL._strcmpw, 5);
GetRegA
|IL.opCOPY:
PushAll(2);
PushConst(param2);
CallRTL(IL._move, 3)
|IL.opMOVE:
PushAll(3);
CallRTL(IL._move, 3)
|IL.opCOPYA:
PushAll(4);
PushConst(param2);
CallRTL(IL._arrcpy, 5);
GetRegA
|IL.opCOPYS:
PushAll(4);
PushConst(param2);
CallRTL(IL._strcpy, 5)
|IL.opDIV:
PushAll(2);
divmod;
GetRegA
|IL.opDIVL:
UnOp(r1);
REG.PushAll_1(R);
PushConst(param2);
push(r1);
drop;
divmod;
GetRegA
|IL.opDIVR:
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(r1);
AsrImm(r1, n)
ELSIF n < 0 THEN
PushAll(1);
PushConst(param2);
divmod;
GetRegA
END
|IL.opMOD:
PushAll(2);
divmod;
mov(R0, R1);
GetRegA
|IL.opMODR:
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(r1);
IF n = 8 THEN
Code(0B2C0H + r1 * 9) (* uxtb r1, r1 *)
ELSIF n = 16 THEN
Code(0B280H + r1 * 9) (* uxth r1, r1 *)
ELSE
LslImm(r1, 32 - n);
LsrImm(r1, 32 - n)
END
ELSIF n < 0 THEN
PushAll(1);
PushConst(param2);
divmod;
mov(R0, R1);
GetRegA
ELSE
UnOp(r1);
MovConst(r1, 0)
END
|IL.opMODL:
UnOp(r1);
REG.PushAll_1(R);
PushConst(param2);
push(r1);
drop;
divmod;
mov(R0, R1);
GetRegA
|IL.opIN, IL.opINR:
IF opcode = IL.opINR THEN
r2 := GetAnyReg();
MovConst(r2, param2)
END;
L := NewLabel();
L2 := NewLabel();
BinOp(r1, r2);
r3 := GetAnyReg();
CmpConst(r1, 32);
jcc(jb, L);
MovConst(r1, 0);
jmp(L2);
Label(L);
MovConst(r3, 1);
Shift(IL.opLSL, r3, r1);
gen4(0, r3, r2); (* ands r2, r3 *)
SetCC(jne, r1);
Label(L2);
drop;
drop
|IL.opINL:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, LSL(1, param2));
gen4(0, r2, r1); (* ands r1, r2 *)
SetCC(jne, r1);
drop
|IL.opRSET:
PushAll(2);
CallRTL(IL._set, 2);
GetRegA
|IL.opRSETR:
PushAll(1);
PushConst(param2);
CallRTL(IL._set, 2);
GetRegA
|IL.opRSETL:
UnOp(r1);
REG.PushAll_1(R);
PushConst(param2);
push(r1);
drop;
CallRTL(IL._set, 2);
GetRegA
|IL.opRSET1:
PushAll(1);
CallRTL(IL._set1, 1);
GetRegA
|IL.opCONSTF:
MovConst(GetAnyReg(), UTILS.d2s(cmd.float))
|IL.opMULF:
PushAll(2);
CallRTL(IL._fmul, 2);
GetRegA
|IL.opDIVF:
PushAll(2);
CallRTL(IL._fdiv, 2);
GetRegA
|IL.opDIVFI:
PushAll(2);
CallRTL(IL._fdivi, 2);
GetRegA
|IL.opADDF:
PushAll(2);
CallRTL(IL._fadd, 2);
GetRegA
|IL.opSUBFI:
PushAll(2);
CallRTL(IL._fsubi, 2);
GetRegA
|IL.opSUBF:
PushAll(2);
CallRTL(IL._fsub, 2);
GetRegA
|IL.opEQF..IL.opGEF:
PushAll(2);
PushConst(opcode - IL.opEQF);
CallRTL(IL._fcmp, 3);
GetRegA
|IL.opFLOOR:
PushAll(1);
CallRTL(IL._floor, 1);
GetRegA
|IL.opFLT:
PushAll(1);
CallRTL(IL._flt, 1);
GetRegA
|IL.opUMINF:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, 1);
LslImm(r2, 31);
gen4(1, r2, r1); (* eors r1, r2 *)
drop
|IL.opFABS:
UnOp(r1);
r2 := GetAnyReg();
MovConst(r2, 1);
LslImm(r2, 31);
gen4(14, r2, r1); (* bics r1, r2 *)
drop
|IL.opNEW:
cpsid_i;
PushAll(1);
n := param2 + 4;
ASSERT(UTILS.Align(n, 4));
PushConst(n);
PushConst(param1);
CallRTL(IL._new, 3);
cpsie_i
|IL.opTYPEGP:
UnOp(r1);
PushAll(0);
push(r1);
PushConst(param2);
CallRTL(IL._guard, 2);
GetRegA
|IL.opIS:
PushAll(1);
PushConst(param2);
CallRTL(IL._is, 2);
GetRegA
|IL.opISREC:
PushAll(2);
PushConst(param2);
CallRTL(IL._guardrec, 3);
GetRegA
|IL.opTYPEGR:
PushAll(1);
PushConst(param2);
CallRTL(IL._guardrec, 2);
GetRegA
|IL.opTYPEGD:
UnOp(r1);
PushAll(0);
SubImm8(r1, 4);
Ldr32(r1, r1);
push(r1);
PushConst(param2);
CallRTL(IL._guardrec, 2);
GetRegA
|IL.opCASET:
push(R2);
push(R2);
PushConst(param2);
CallRTL(IL._guardrec, 2);
pop(R2);
cbnz(ACC, param1)
|IL.opROT:
PushAll(0);
mov(R2, SP);
push(R2);
PushConst(param2);
CallRTL(IL._rot, 2)
|IL.opPACK:
PushAll(2);
CallRTL(IL._pack, 2)
|IL.opPACKC:
PushAll(1);
PushConst(param2);
CallRTL(IL._pack, 2)
|IL.opUNPK:
PushAll(2);
CallRTL(IL._unpk, 2)
END;
cmd := cmd.next(COMMAND)
END;
ASSERT(R.pushed = 0);
ASSERT(R.top = -1)
END translate;
PROCEDURE prolog (GlobSize, tcount, pic, sp, ivt_len: INTEGER);
VAR
r1, r2, i, dcount: INTEGER;
BEGIN
entry := NewLabel();
emptyProc := NewLabel();
genInt := NewLabel();
genTrap := NewLabel();
sdivProc := NewLabel();
trap := emptyProc;
int0 := emptyProc;
IVT[0] := sp;
IVT[1] := entry;
FOR i := 2 TO ivt_len - 1 DO
IVT[i] := genInt
END;
FOR i := 0 TO ivt_len - 1 DO
Code(low(IVT[i]));
Code(high(IVT[i]))
END;
Label(entry);
cpsie_i;
r1 := GetAnyReg();
r2 := GetAnyReg();
reloc(r1, BIN.RDATA + pic, 0);
FOR i := 0 TO tcount - 1 DO
MovConst(r2, CHL.GetInt(IL.codes.types, i));
Str32(r2, r1);
AddImm8(r1, 4)
END;
dcount := CHL.Length(IL.codes.data);
FOR i := 0 TO dcount - 1 BY 4 DO
MovConst(r2, BIN.get32le(IL.codes.data, i));
Str32(r2, r1);
AddImm8(r1, 4)
END;
drop;
drop;
r1 := GetAnyReg();
MovConst(r1, sp);
mov(SP, r1);
reloc(r1, BIN.RDATA + pic, 0);
push(r1);
reloc(r1, BIN.RBSS + pic, 0);
r2 := GetAnyReg();
MovConst(r2, GlobSize);
AddReg(r1, r1, r2);
drop;
push(r1);
drop;
PushConst(tcount);
CallRTL(IL._init, 3)
END prolog;
PROCEDURE epilog;
VAR
L1, L2, L3, L4: INTEGER;
BEGIN
(* L2: *)
Code(0E7FEH); (* b L2 *)
Label(genInt);
Code(0F3EFH); Code(08005H); (* mrs r0, ipsr *)
gen14(FALSE, TRUE, {R0}); (* push {lr, r0} *)
call(int0);
gen14(TRUE, TRUE, {R0}); (* pop {pc, r0} *)
Label(emptyProc);
Code(04770H); (* bx lr *)
Label(genTrap);
call(trap);
call(entry);
Label(sdivProc);
IF _SDIV IN Target.InstrSet THEN
Code(09800H); (* ldr r0, [sp] *)
Code(09901H); (* ldr r1, [sp, 4] *)
Code(0FB91H); (* sdiv r2, r1, r0 *)
Code(0F2F0H);
Code(00013H); (* movs r3, r2 *)
Code(04343H); (* muls r3, r0, r3 *)
Code(01AC9H); (* subs r1, r1, r3 *)
Code(0DA01H); (* bge L *)
Code(01809H); (* adds r1, r1, r0 *)
Code(03A01H); (* subs r2, 1 *)
(* L: *)
Code(00010H); (* movs r0, r2 *)
Code(04770H); (* bx lr *)
ELSE
(* a / b; a >= 0 *)
L1 := NewLabel();
L2 := NewLabel();
L3 := NewLabel();
L4 := NewLabel();
LdrSp(R1, 1);
LdrSp(R2, 0);
MovConst(R0, 0);
push(R4);
Label(L4);
Cmp(R1, R2);
jcc(jl, L1);
MovConst(R3, 2);
mov(R4, R2);
LslImm(R4, 1);
Label(L3);
Cmp(R1, R4);
jcc(jl, L2);
CmpConst(R4, 0);
jcc(jle, L2);
LslImm(R4, 1);
LslImm(R3, 1);
jmp(L3);
Label(L2);
LsrImm(R4, 1);
LsrImm(R3, 1);
SubReg(R1, R1, R4);
AddReg(R0, R0, R3);
jmp(L4);
Label(L1);
(* a / b; a < 0 *)
L1 := NewLabel();
L2 := NewLabel();
L3 := NewLabel();
L4 := NewLabel();
Label(L4);
CmpConst(R1, 0);
jcc(jge, L1);
MovConst(R3, 2);
mov(R4, R2);
LslImm(R4, 1);
Neg(R1);
Label(L3);
Cmp(R1, R4);
jcc(jl, L2);
CmpConst(R4, 0);
jcc(jle, L2);
LslImm(R4, 1);
LslImm(R3, 1);
jmp(L3);
Label(L2);
Neg(R1);
LsrImm(R4, 1);
LsrImm(R3, 1);
AddReg(R1, R1, R4);
SubReg(R0, R0, R3);
jmp(L4);
Label(L1);
pop(R4);
Code(04770H); (* bx lr *)
END
END epilog;
PROCEDURE SetTarget (FlashStart, SRAMStart: INTEGER; InstrSet: SET; isNXP: BOOLEAN);
BEGIN
Target.FlashAdr := FlashStart;
Target.SRAMAdr := SRAMStart;
Target.InstrSet := InstrSet;
Target.isNXP := isNXP;
Target.IVTLen := 256; (* >= 192 *)
Target.Reserved := 0;
Target.MinStack := 512;
END SetTarget;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
VAR
opt: PROG.OPTIONS;
ram, rom, i, j: INTEGER;
DataAdr, BssAdr, DataSize, BssSize, CodeSize: INTEGER;
BEGIN
ram := MIN(MAX(options.ram, minRAM), maxRAM) * 1024;
rom := MIN(MAX(options.rom, minROM), maxROM) * 1024;
IF target = TARGETS.STM32CM3 THEN
SetTarget(08000000H, 20000000H, CortexM3, FALSE)
END;
tcount := CHL.Length(IL.codes.types);
opt := options;
CodeList := LISTS.create(NIL);
program := BIN.create(IL.codes.lcount);
REG.Init(R, push, pop, mov, xchg, {R0, R1, R2, R3});
StkCount := 0;
DataAdr := Target.SRAMAdr + Target.Reserved;
DataSize := CHL.Length(IL.codes.data) + tcount * 4 + Target.Reserved;
WHILE DataSize MOD 4 # 0 DO
CHL.PushByte(IL.codes.data, 0);
INC(DataSize)
END;
BssAdr := DataAdr + DataSize - Target.Reserved;
IL.set_bss(MAX(IL.codes.bss, MAX(IL.codes.dmin - CHL.Length(IL.codes.data), 4)));
BssSize := IL.codes.bss;
ASSERT(UTILS.Align(BssSize, 4));
prolog(BssSize, tcount, ORD(opt.pic), Target.SRAMAdr + ram, Target.IVTLen);
translate(ORD(opt.pic), tcount * 4);
epilog;
fixup(Target.FlashAdr, DataAdr, BssAdr);
INC(DataSize, BssSize);
CodeSize := CHL.Length(program.code);
IF CodeSize > rom THEN
ERRORS.Error(203)
END;
IF DataSize > ram - Target.MinStack THEN
ERRORS.Error(204)
END;
IF Target.isNXP THEN
BIN.put32le(program.code, 2FCH, 0H); (* code read protection (CRP) *)
(* NXP checksum *)
j := 0;
FOR i := 0 TO 6 DO
INC(j, BIN.get32le(program.code, i * 4))
END;
BIN.put32le(program.code, 1CH, -j)
END;
WR.Create(outname);
HEX.Data2(program.code, 0, CodeSize, high(Target.FlashAdr));
HEX.End;
WR.Close;
C.Dashes;
C.String( " rom: "); C.Int(CodeSize); C.String(" of "); C.Int(rom); C.String(" ("); C.Int(CodeSize * 100 DIV rom); C.StringLn("%)");
C.Ln;
C.String( " ram: "); C.Int(DataSize); C.String(" of "); C.Int(ram); C.String(" ("); C.Int(DataSize * 100 DIV ram); C.StringLn("%)")
END CodeGen;
PROCEDURE SetIV* (idx: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := IVT[idx] = 0;
IVT[idx] := 1
RETURN res
END SetIV;
PROCEDURE init;
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO LEN(IVT) - 1 DO
IVT[i] := 0
END
END init;
BEGIN
init
END THUMB.

/programs/develop/oberon07/source/UTILS.ob07
0,0 → 1,216
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE UTILS;
IMPORT HOST;
CONST
slash* = HOST.slash;
eol* = HOST.eol;
bit_depth* = HOST.bit_depth;
maxint* = HOST.maxint;
minint* = HOST.minint;
min32* = -2147483647-1;
max32* = 2147483647;
vMajor* = 1;
vMinor* = 52;
Date* = "07-may-2021";
FILE_EXT* = ".ob07";
RTL_NAME* = "RTL";
MAX_GLOBAL_SIZE* = 1600000000;
VAR
time*: INTEGER;
maxreal*: REAL;
target*:
RECORD
bit_depth*,
maxInt*,
minInt*,
maxSet*,
maxHex*: INTEGER;
maxReal*: REAL
END;
bit_diff*: INTEGER;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
RETURN HOST.FileRead(F, Buffer, bytes)
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN HOST.FileWrite(F, Buffer, bytes)
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN HOST.FileCreate(FName)
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
HOST.FileClose(F)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN HOST.FileOpen(FName)
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
BEGIN
HOST.chmod(FName)
END chmod;
PROCEDURE GetArg* (i: INTEGER; VAR str: ARRAY OF CHAR);
BEGIN
HOST.GetArg(i, str)
END GetArg;
PROCEDURE Exit* (code: INTEGER);
BEGIN
HOST.ExitProcess(code)
END Exit;
PROCEDURE GetTickCount* (): INTEGER;
RETURN HOST.GetTickCount()
END GetTickCount;
PROCEDURE OutChar* (c: CHAR);
BEGIN
HOST.OutChar(c)
END OutChar;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
RETURN HOST.splitf(x, a, b)
END splitf;
PROCEDURE d2s* (x: REAL): INTEGER;
RETURN HOST.d2s(x)
END d2s;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN HOST.isRelative(path)
END isRelative;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
BEGIN
HOST.GetCurrentDirectory(path)
END GetCurrentDirectory;
PROCEDURE UnixTime* (): INTEGER;
RETURN HOST.UnixTime()
END UnixTime;
PROCEDURE SetBitDepth* (BitDepth: INTEGER; Double: BOOLEAN);
BEGIN
ASSERT((BitDepth = 16) OR (BitDepth = 32) OR (BitDepth = 64));
bit_diff := bit_depth - BitDepth;
ASSERT(bit_diff >= 0);
target.bit_depth := BitDepth;
target.maxSet := BitDepth - 1;
target.maxHex := BitDepth DIV 4;
target.minInt := ASR(minint, bit_diff);
target.maxInt := ASR(maxint, bit_diff);
IF Double THEN
target.maxReal := maxreal
ELSE
target.maxReal := 1.9;
PACK(target.maxReal, 127)
END
END SetBitDepth;
PROCEDURE Byte* (n: INTEGER; idx: INTEGER): BYTE;
RETURN ASR(n, 8 * idx) MOD 256
END Byte;
PROCEDURE Align* (VAR bytes: INTEGER; align: INTEGER): BOOLEAN;
BEGIN
INC(bytes, (-bytes) MOD align)
RETURN bytes >= 0
END Align;
PROCEDURE Long* (value: INTEGER): INTEGER;
RETURN ASR(LSL(value, bit_diff), bit_diff)
END Long;
PROCEDURE Short* (value: INTEGER): INTEGER;
RETURN LSR(LSL(value, bit_diff), bit_diff)
END Short;
PROCEDURE Log2* (x: INTEGER): INTEGER;
VAR
n: INTEGER;
BEGIN
n := 0;
WHILE ~ODD(x) DO
x := x DIV 2;
INC(n)
END;
IF x # 1 THEN
n := -1
END
RETURN n
END Log2;
PROCEDURE hexdgt* (n: BYTE): BYTE;
BEGIN
IF n < 10 THEN
INC(n, ORD("0"))
ELSE
INC(n, ORD("A") - 10)
END
RETURN n
END hexdgt;
BEGIN
time := HOST.GetTickCount();
maxreal := HOST.maxreal
END UTILS.

/programs/develop/oberon07/source/WRITER.ob07
0,0 → 1,104
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE WRITER;
IMPORT FILES, ERRORS, UTILS;
VAR
counter*: INTEGER;
file: FILES.FILE;
PROCEDURE align* (n, _align: INTEGER): INTEGER;
BEGIN
ASSERT(UTILS.Align(n, _align))
RETURN n
END align;
PROCEDURE WriteByte* (n: BYTE);
BEGIN
IF FILES.WriteByte(file, n) THEN
INC(counter)
ELSE
ERRORS.Error(201)
END
END WriteByte;
PROCEDURE Write* (chunk: ARRAY OF BYTE; bytes: INTEGER);
VAR
n: INTEGER;
BEGIN
n := FILES.write(file, chunk, bytes);
IF n # bytes THEN
ERRORS.Error(201)
END;
INC(counter, n)
END Write;
PROCEDURE Write64LE* (n: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 7 DO
WriteByte(UTILS.Byte(n, i))
END
END Write64LE;
PROCEDURE Write32LE* (n: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
WriteByte(UTILS.Byte(n, i))
END
END Write32LE;
PROCEDURE Write16LE* (n: INTEGER);
BEGIN
WriteByte(UTILS.Byte(n, 0));
WriteByte(UTILS.Byte(n, 1))
END Write16LE;
PROCEDURE Padding* (FileAlignment: INTEGER);
VAR
i: INTEGER;
BEGIN
i := align(counter, FileAlignment) - counter;
WHILE i > 0 DO
WriteByte(0);
DEC(i)
END
END Padding;
PROCEDURE Create* (FileName: ARRAY OF CHAR);
BEGIN
counter := 0;
file := FILES.create(FileName)
END Create;
PROCEDURE Close*;
BEGIN
FILES.close(file)
END Close;
END WRITER.

/programs/develop/oberon07/source/X86.ob07
0,0 → 1,2403
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE X86;
IMPORT IL, REG, UTILS, LISTS, BIN, PE32, KOS, MSCOFF, ELF, PROG,
CHL := CHUNKLISTS, PATHS, TARGETS, ERRORS;
CONST
eax = REG.R0; ecx = REG.R1; edx = REG.R2;
al = eax; cl = ecx; dl = edx; ah = 4;
ax = eax; cx = ecx; dx = edx;
esp = 4;
ebp = 5;
MAX_FR = 7;
sete = 94H; setne = 95H; setl = 9CH; setge = 9DH; setle = 9EH; setg = 9FH; setc = 92H; setnc = 93H;
je = 84H; jne = 85H; jl = 8CH; jge = 8DH; jle = 8EH; jg = 8FH; jb = 82H; jnb = 83H;
CODECHUNK = 8;
FPR_ERR = 41;
TYPE
COMMAND = IL.COMMAND;
ANYCODE = POINTER TO RECORD (LISTS.ITEM)
offset: INTEGER
END;
CODE = POINTER TO RECORD (ANYCODE)
code: ARRAY CODECHUNK OF BYTE;
length: INTEGER
END;
LABEL = POINTER TO RECORD (ANYCODE)
label: INTEGER
END;
JUMP = POINTER TO RECORD (ANYCODE)
label, diff: INTEGER;
short: BOOLEAN
END;
JMP = POINTER TO RECORD (JUMP)
END;
JCC = POINTER TO RECORD (JUMP)
jmp: INTEGER
END;
CALL = POINTER TO RECORD (JUMP)
END;
RELOC = POINTER TO RECORD (ANYCODE)
op, value: INTEGER
END;
VAR
R: REG.REGS;
program: BIN.PROGRAM;
CodeList: LISTS.LIST;
tcount: INTEGER;
FR: ARRAY 1000 OF INTEGER;
fname: PATHS.PATH;
PROCEDURE OutByte* (n: BYTE);
VAR
c: CODE;
last: ANYCODE;
BEGIN
last := CodeList.last(ANYCODE);
IF (last IS CODE) & (last(CODE).length < CODECHUNK) THEN
c := last(CODE);
c.code[c.length] := n;
INC(c.length)
ELSE
NEW(c);
c.code[0] := n;
c.length := 1;
LISTS.push(CodeList, c)
END
END OutByte;
PROCEDURE OutInt (n: INTEGER);
BEGIN
OutByte(n MOD 256);
OutByte(UTILS.Byte(n, 1));
OutByte(UTILS.Byte(n, 2));
OutByte(UTILS.Byte(n, 3))
END OutInt;
PROCEDURE OutByte2 (a, b: BYTE);
BEGIN
OutByte(a);
OutByte(b)
END OutByte2;
PROCEDURE OutByte3 (a, b, c: BYTE);
BEGIN
OutByte(a);
OutByte(b);
OutByte(c)
END OutByte3;
PROCEDURE OutWord (n: INTEGER);
BEGIN
ASSERT((0 <= n) & (n <= 65535));
OutByte2(n MOD 256, n DIV 256)
END OutWord;
PROCEDURE isByte* (n: INTEGER): BOOLEAN;
RETURN (-128 <= n) & (n <= 127)
END isByte;
PROCEDURE short (n: INTEGER): INTEGER;
RETURN 2 * ORD(isByte(n))
END short;
PROCEDURE long (n: INTEGER): INTEGER;
RETURN 40H * ORD(~isByte(n))
END long;
PROCEDURE OutIntByte (n: INTEGER);
BEGIN
IF isByte(n) THEN
OutByte(n MOD 256)
ELSE
OutInt(n)
END
END OutIntByte;
PROCEDURE shift* (op, reg: INTEGER);
BEGIN
CASE op OF
|IL.opASR, IL.opASR1, IL.opASR2: OutByte(0F8H + reg)
|IL.opROR, IL.opROR1, IL.opROR2: OutByte(0C8H + reg)
|IL.opLSL, IL.opLSL1, IL.opLSL2: OutByte(0E0H + reg)
|IL.opLSR, IL.opLSR1, IL.opLSR2: OutByte(0E8H + reg)
END
END shift;
PROCEDURE oprr (op: BYTE; reg1, reg2: INTEGER); (* op reg1, reg2 *)
BEGIN
OutByte2(op, 0C0H + 8 * reg2 + reg1)
END oprr;
PROCEDURE mov (reg1, reg2: INTEGER); (* mov reg1, reg2 *)
BEGIN
oprr(89H, reg1, reg2)
END mov;
PROCEDURE xchg (reg1, reg2: INTEGER); (* xchg reg1, reg2 *)
BEGIN
IF eax IN {reg1, reg2} THEN
OutByte(90H + reg1 + reg2)
ELSE
oprr(87H, reg1, reg2)
END
END xchg;
PROCEDURE pop (reg: INTEGER);
BEGIN
OutByte(58H + reg) (* pop reg *)
END pop;
PROCEDURE push (reg: INTEGER);
BEGIN
OutByte(50H + reg) (* push reg *)
END push;
PROCEDURE xor (reg1, reg2: INTEGER); (* xor reg1, reg2 *)
BEGIN
oprr(31H, reg1, reg2)
END xor;
PROCEDURE movrc (reg, n: INTEGER);
BEGIN
IF n = 0 THEN
xor(reg, reg)
ELSE
OutByte(0B8H + reg); (* mov reg, n *)
OutInt(n)
END
END movrc;
PROCEDURE pushc* (n: INTEGER);
BEGIN
OutByte(68H + short(n)); (* push n *)
OutIntByte(n)
END pushc;
PROCEDURE test (reg: INTEGER);
BEGIN
OutByte2(85H, 0C0H + reg * 9) (* test reg, reg *)
END test;
PROCEDURE neg (reg: INTEGER);
BEGIN
OutByte2(0F7H, 0D8H + reg) (* neg reg *)
END neg;
PROCEDURE not (reg: INTEGER);
BEGIN
OutByte2(0F7H, 0D0H + reg) (* not reg *)
END not;
PROCEDURE add (reg1, reg2: INTEGER); (* add reg1, reg2 *)
BEGIN
oprr(01H, reg1, reg2)
END add;
PROCEDURE oprc* (op, reg, n: INTEGER);
BEGIN
IF (reg = eax) & ~isByte(n) THEN
CASE op OF
|0C0H: op := 05H (* add *)
|0E8H: op := 2DH (* sub *)
|0F8H: op := 3DH (* cmp *)
|0E0H: op := 25H (* and *)
|0C8H: op := 0DH (* or *)
|0F0H: op := 35H (* xor *)
END;
OutByte(op);
OutInt(n)
ELSE
OutByte2(81H + short(n), op + reg MOD 8);
OutIntByte(n)
END
END oprc;
PROCEDURE andrc (reg, n: INTEGER); (* and reg, n *)
BEGIN
oprc(0E0H, reg, n)
END andrc;
PROCEDURE orrc (reg, n: INTEGER); (* or reg, n *)
BEGIN
oprc(0C8H, reg, n)
END orrc;
PROCEDURE xorrc (reg, n: INTEGER); (* xor reg, n *)
BEGIN
oprc(0F0H, reg, n)
END xorrc;
PROCEDURE addrc (reg, n: INTEGER); (* add reg, n *)
BEGIN
oprc(0C0H, reg, n)
END addrc;
PROCEDURE subrc (reg, n: INTEGER); (* sub reg, n *)
BEGIN
oprc(0E8H, reg, n)
END subrc;
PROCEDURE cmprc (reg, n: INTEGER); (* cmp reg, n *)
BEGIN
IF n = 0 THEN
test(reg)
ELSE
oprc(0F8H, reg, n)
END
END cmprc;
PROCEDURE cmprr (reg1, reg2: INTEGER); (* cmp reg1, reg2 *)
BEGIN
oprr(39H, reg1, reg2)
END cmprr;
PROCEDURE setcc* (cc, reg: INTEGER); (* setcc reg *)
BEGIN
IF reg >= 8 THEN
OutByte(41H)
END;
OutByte3(0FH, cc, 0C0H + reg MOD 8)
END setcc;
PROCEDURE ret*;
BEGIN
OutByte(0C3H)
END ret;
PROCEDURE drop;
BEGIN
REG.Drop(R)
END drop;
PROCEDURE GetAnyReg (): INTEGER;
RETURN REG.GetAnyReg(R)
END GetAnyReg;
PROCEDURE cond* (op: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE op OF
|IL.opGT, IL.opGTC: res := jg
|IL.opGE, IL.opGEC: res := jge
|IL.opLT, IL.opLTC: res := jl
|IL.opLE, IL.opLEC: res := jle
|IL.opEQ, IL.opEQC: res := je
|IL.opNE, IL.opNEC: res := jne
END
RETURN res
END cond;
PROCEDURE inv0* (op: INTEGER): INTEGER;
RETURN ORD(BITS(op) / {0})
END inv0;
PROCEDURE Reloc* (op, value: INTEGER);
VAR
reloc: RELOC;
BEGIN
NEW(reloc);
reloc.op := op;
reloc.value := value;
LISTS.push(CodeList, reloc)
END Reloc;
PROCEDURE jcc* (cc, label: INTEGER);
VAR
j: JCC;
BEGIN
NEW(j);
j.label := label;
j.jmp := cc;
j.short := FALSE;
LISTS.push(CodeList, j)
END jcc;
PROCEDURE jmp* (label: INTEGER);
VAR
j: JMP;
BEGIN
NEW(j);
j.label := label;
j.short := FALSE;
LISTS.push(CodeList, j)
END jmp;
PROCEDURE call* (label: INTEGER);
VAR
c: CALL;
BEGIN
NEW(c);
c.label := label;
c.short := TRUE;
LISTS.push(CodeList, c)
END call;
PROCEDURE Pic (reg, opcode, value: INTEGER);
BEGIN
OutByte(0E8H); OutInt(0); (* call L
L: *)
pop(reg);
OutByte2(081H, 0C0H + reg); (* add reg, ... *)
Reloc(opcode, value)
END Pic;
PROCEDURE CallRTL (pic: BOOLEAN; proc: INTEGER);
VAR
label: INTEGER;
reg1: INTEGER;
BEGIN
label := IL.codes.rtl[proc];
IF label < 0 THEN
label := -label;
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICIMP, label);
OutByte2(0FFH, 010H + reg1); (* call dword[reg1] *)
drop
ELSE
OutByte2(0FFH, 015H); (* call dword[label] *)
Reloc(BIN.RIMP, label)
END
ELSE
call(label)
END
END CallRTL;
PROCEDURE SetLabel* (label: INTEGER);
VAR
L: LABEL;
BEGIN
NEW(L);
L.label := label;
LISTS.push(CodeList, L)
END SetLabel;
PROCEDURE fixup*;
VAR
code: ANYCODE;
count, i: INTEGER;
shorted: BOOLEAN;
jump: JUMP;
BEGIN
REPEAT
shorted := FALSE;
count := 0;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
code.offset := count;
CASE code OF
|CODE: INC(count, code.length)
|LABEL: BIN.SetLabel(program, code.label, count)
|JMP: IF code.short THEN INC(count, 2) ELSE INC(count, 5) END; code.offset := count
|JCC: IF code.short THEN INC(count, 2) ELSE INC(count, 6) END; code.offset := count
|CALL: INC(count, 5); code.offset := count
|RELOC: INC(count, 4)
END;
code := code.next(ANYCODE)
END;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
IF code IS JUMP THEN
jump := code(JUMP);
jump.diff := BIN.GetLabel(program, jump.label) - code.offset;
IF ~jump.short & isByte(jump.diff) THEN
jump.short := TRUE;
shorted := TRUE
END
END;
code := code.next(ANYCODE)
END
UNTIL ~shorted;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
CASE code OF
|CODE:
FOR i := 0 TO code.length - 1 DO
BIN.PutCode(program, code.code[i])
END
|LABEL:
|JMP:
IF code.short THEN
BIN.PutCode(program, 0EBH);
BIN.PutCode(program, code.diff MOD 256)
ELSE
BIN.PutCode(program, 0E9H);
BIN.PutCode32LE(program, code.diff)
END
|JCC:
IF code.short THEN
BIN.PutCode(program, code.jmp - 16);
BIN.PutCode(program, code.diff MOD 256)
ELSE
BIN.PutCode(program, 0FH);
BIN.PutCode(program, code.jmp);
BIN.PutCode32LE(program, code.diff)
END
|CALL:
BIN.PutCode(program, 0E8H);
BIN.PutCode32LE(program, code.diff)
|RELOC:
BIN.PutReloc(program, code.op);
BIN.PutCode32LE(program, code.value)
END;
code := code.next(ANYCODE)
END
END fixup;
PROCEDURE UnOp (VAR reg: INTEGER);
BEGIN
REG.UnOp(R, reg)
END UnOp;
PROCEDURE BinOp (VAR reg1, reg2: INTEGER);
BEGIN
REG.BinOp(R, reg1, reg2)
END BinOp;
PROCEDURE PushAll (NumberOfParameters: INTEGER);
BEGIN
REG.PushAll(R);
DEC(R.pushed, NumberOfParameters)
END PushAll;
PROCEDURE NewLabel (): INTEGER;
BEGIN
BIN.NewLabel(program)
RETURN IL.NewLabel()
END NewLabel;
PROCEDURE GetRegA;
BEGIN
ASSERT(REG.GetReg(R, eax))
END GetRegA;
PROCEDURE fcmp;
BEGIN
GetRegA;
OutByte2(0DAH, 0E9H); (* fucompp *)
OutByte3(09BH, 0DFH, 0E0H); (* fstsw ax *)
OutByte(09EH); (* sahf *)
OutByte(0B8H); OutInt(0) (* mov eax, 0 *)
END fcmp;
PROCEDURE movzx* (reg1, reg2, offs: INTEGER; word: BOOLEAN); (* movzx reg1, byte/word[reg2 + offs] *)
VAR
b: BYTE;
BEGIN
OutByte2(0FH, 0B6H + ORD(word));
IF (offs = 0) & (reg2 # ebp) THEN
b := 0
ELSE
b := 40H + long(offs)
END;
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8);
IF reg2 = esp THEN
OutByte(24H)
END;
IF b # 0 THEN
OutIntByte(offs)
END
END movzx;
PROCEDURE _movrm* (reg1, reg2, offs, size: INTEGER; mr: BOOLEAN);
VAR
b: BYTE;
BEGIN
IF size = 16 THEN
OutByte(66H)
END;
IF (reg1 >= 8) OR (reg2 >= 8) OR (size = 64) THEN
OutByte(40H + reg2 DIV 8 + 4 * (reg1 DIV 8) + 8 * ORD(size = 64))
END;
OutByte(8BH - 2 * ORD(mr) - ORD(size = 8));
IF (offs = 0) & (reg2 # ebp) THEN
b := 0
ELSE
b := 40H + long(offs)
END;
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8);
IF reg2 = esp THEN
OutByte(24H)
END;
IF b # 0 THEN
OutIntByte(offs)
END
END _movrm;
PROCEDURE movmr (reg1, offs, reg2: INTEGER); (* mov dword[reg1+offs], reg2_8 *)
BEGIN
_movrm(reg2, reg1, offs, 32, TRUE)
END movmr;
PROCEDURE movrm (reg1, reg2, offs: INTEGER); (* mov reg1, dword[reg2 + offs] *)
BEGIN
_movrm(reg1, reg2, offs, 32, FALSE)
END movrm;
PROCEDURE movmr8* (reg1, offs, reg2: INTEGER); (* mov byte[reg1+offs], reg2_8 *)
BEGIN
_movrm(reg2, reg1, offs, 8, TRUE)
END movmr8;
PROCEDURE movrm8* (reg1, reg2, offs: INTEGER); (* mov reg1_8, byte[reg2+offs] *)
BEGIN
_movrm(reg1, reg2, offs, 8, FALSE)
END movrm8;
PROCEDURE movmr16* (reg1, offs, reg2: INTEGER); (* mov word[reg1+offs], reg2_16 *)
BEGIN
_movrm(reg2, reg1, offs, 16, TRUE)
END movmr16;
PROCEDURE movrm16* (reg1, reg2, offs: INTEGER); (* mov reg1_16, word[reg2+offs] *)
BEGIN
_movrm(reg1, reg2, offs, 16, FALSE)
END movrm16;
PROCEDURE pushm* (reg, offs: INTEGER); (* push qword[reg+offs] *)
VAR
b: BYTE;
BEGIN
IF reg >= 8 THEN
OutByte(41H)
END;
OutByte(0FFH);
IF (offs = 0) & (reg # ebp) THEN
b := 30H
ELSE
b := 70H + long(offs)
END;
OutByte(b + reg MOD 8);
IF reg = esp THEN
OutByte(24H)
END;
IF b # 30H THEN
OutIntByte(offs)
END
END pushm;
PROCEDURE translate (pic: BOOLEAN; stroffs: INTEGER);
VAR
cmd, next: COMMAND;
reg1, reg2, fr: INTEGER;
n, a, b, label, cc: INTEGER;
opcode, param1, param2: INTEGER;
float: REAL;
BEGIN
cmd := IL.codes.commands.first(COMMAND);
fr := -1;
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
opcode := cmd.opcode;
CASE opcode OF
|IL.opJMP:
jmp(param1)
|IL.opCALL:
call(param1)
|IL.opCALLI:
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICIMP, param1);
OutByte2(0FFH, 010H + reg1); (* call dword[reg1] *)
drop
ELSE
OutByte2(0FFH, 015H); (* call dword[L] *)
Reloc(BIN.RIMP, param1)
END
|IL.opCALLP:
UnOp(reg1);
OutByte2(0FFH, 0D0H + reg1); (* call reg1 *)
drop;
ASSERT(R.top = -1)
|IL.opPRECALL:
PushAll(0);
IF (param2 # 0) & (fr >= 0) THEN
subrc(esp, 8)
END;
INC(FR[0]);
FR[FR[0]] := fr + 1;
WHILE fr >= 0 DO
subrc(esp, 8);
OutByte3(0DDH, 01CH, 024H); (* fstp qword[esp] *)
DEC(fr)
END;
ASSERT(fr = -1)
|IL.opALIGN16:
ASSERT(eax IN R.regs);
mov(eax, esp);
andrc(esp, -16);
n := (3 - param2 MOD 4) * 4;
IF n > 0 THEN
subrc(esp, n)
END;
push(eax)
|IL.opRESF, IL.opRES:
ASSERT(R.top = -1);
ASSERT(fr = -1);
n := FR[FR[0]]; DEC(FR[0]);
IF opcode = IL.opRESF THEN
INC(fr);
IF n > 0 THEN
OutByte3(0DDH, 5CH + long(n * 8), 24H);
OutIntByte(n * 8); (* fstp qword[esp + n*8] *)
DEC(fr);
INC(n)
END;
IF fr + n > MAX_FR THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END
ELSE
GetRegA
END;
WHILE n > 0 DO
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *)
addrc(esp, 8);
INC(fr);
DEC(n)
END
|IL.opENTER:
ASSERT(R.top = -1);
SetLabel(param1);
push(ebp);
mov(ebp, esp);
n := param2;
IF n > 4 THEN
movrc(ecx, n);
pushc(0); (* L: push 0 *)
OutByte2(0E2H, 0FCH) (* loop L *)
ELSE
WHILE n > 0 DO
pushc(0);
DEC(n)
END
END
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF:
IF opcode = IL.opLEAVER THEN
UnOp(reg1);
IF reg1 # eax THEN
mov(eax, reg1)
END;
drop
END;
ASSERT(R.top = -1);
IF opcode = IL.opLEAVEF THEN
DEC(fr)
END;
ASSERT(fr = -1);
IF param1 > 0 THEN
mov(esp, ebp)
END;
pop(ebp);
IF param2 > 0 THEN
OutByte(0C2H); OutWord(param2 * 4 MOD 65536) (* ret param2*4 *)
ELSE
ret
END
|IL.opPUSHC:
pushc(param2)
|IL.opONERR:
pushc(param2);
jmp(param1)
|IL.opPARAM:
n := param2;
IF n = 1 THEN
UnOp(reg1);
push(reg1);
drop
ELSE
ASSERT(R.top + 1 <= n);
PushAll(n)
END
|IL.opCLEANUP:
IF param2 # 0 THEN
addrc(esp, param2 * 4)
END
|IL.opPOPSP:
pop(esp)
|IL.opCONST:
movrc(GetAnyReg(), param2)
|IL.opLABEL:
SetLabel(param1) (* L: *)
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opGADR:
next := cmd.next(COMMAND);
IF next.opcode = IL.opADDC THEN
INC(param2, next.param2);
cmd := next
END;
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICBSS, param2)
ELSE
OutByte(0B8H + reg1); (* mov reg1, _bss + param2 *)
Reloc(BIN.RBSS, param2)
END
|IL.opLADR:
next := cmd.next(COMMAND);
n := param2 * 4;
IF next.opcode = IL.opADDC THEN
INC(n, next.param2);
cmd := next
END;
OutByte2(8DH, 45H + GetAnyReg() * 8 + long(n)); (* lea reg1, dword[ebp + n] *)
OutIntByte(n)
|IL.opVADR, IL.opLLOAD32:
movrm(GetAnyReg(), ebp, param2 * 4)
|IL.opSADR:
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICDATA, stroffs + param2);
ELSE
OutByte(0B8H + reg1); (* mov reg1, _data + stroffs + param2 *)
Reloc(BIN.RDATA, stroffs + param2)
END
|IL.opSAVEC:
UnOp(reg1);
OutByte2(0C7H, reg1); OutInt(param2); (* mov dword[reg1], param2 *)
drop
|IL.opSAVE8C:
UnOp(reg1);
OutByte3(0C6H, reg1, param2 MOD 256); (* mov byte[reg1], param2 *)
drop
|IL.opSAVE16C:
UnOp(reg1);
OutByte3(66H, 0C7H, reg1); OutWord(param2 MOD 65536); (* mov word[reg1], param2 *)
drop
|IL.opVLOAD32:
reg1 := GetAnyReg();
movrm(reg1, ebp, param2 * 4);
movrm(reg1, reg1, 0)
|IL.opGLOAD32:
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
movrm(reg1, reg1, 0)
ELSE
OutByte2(08BH, 05H + reg1 * 8); (* mov reg1, dword[_bss + param2] *)
Reloc(BIN.RBSS, param2)
END
|IL.opLOAD32:
UnOp(reg1);
movrm(reg1, reg1, 0)
|IL.opVLOAD8:
reg1 := GetAnyReg();
movrm(reg1, ebp, param2 * 4);
movzx(reg1, reg1, 0, FALSE)
|IL.opGLOAD8:
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
movzx(reg1, reg1, 0, FALSE)
ELSE
OutByte3(00FH, 0B6H, 05H + reg1 * 8); (* movzx reg1, byte[_bss + param2] *)
Reloc(BIN.RBSS, param2)
END
|IL.opLLOAD8:
movzx(GetAnyReg(), ebp, param2 * 4, FALSE)
|IL.opLOAD8:
UnOp(reg1);
movzx(reg1, reg1, 0, FALSE)
|IL.opVLOAD16:
reg1 := GetAnyReg();
movrm(reg1, ebp, param2 * 4);
movzx(reg1, reg1, 0, TRUE)
|IL.opGLOAD16:
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
movzx(reg1, reg1, 0, TRUE)
ELSE
OutByte3(00FH, 0B7H, 05H + reg1 * 8); (* movzx reg1, word[_bss + param2] *)
Reloc(BIN.RBSS, param2)
END
|IL.opLLOAD16:
movzx(GetAnyReg(), ebp, param2 * 4, TRUE)
|IL.opLOAD16:
UnOp(reg1);
movzx(reg1, reg1, 0, TRUE)
|IL.opUMINUS:
UnOp(reg1);
neg(reg1)
|IL.opADD:
BinOp(reg1, reg2);
add(reg1, reg2);
drop
|IL.opADDC:
IF param2 # 0 THEN
UnOp(reg1);
next := cmd.next(COMMAND);
CASE next.opcode OF
|IL.opLOAD32:
movrm(reg1, reg1, param2);
cmd := next
|IL.opLOAD16:
movzx(reg1, reg1, param2, TRUE);
cmd := next
|IL.opLOAD8:
movzx(reg1, reg1, param2, FALSE);
cmd := next
|IL.opLOAD32_PARAM:
pushm(reg1, param2);
drop;
cmd := next
ELSE
IF param2 = 1 THEN
OutByte(40H + reg1) (* inc reg1 *)
ELSIF param2 = -1 THEN
OutByte(48H + reg1) (* dec reg1 *)
ELSE
addrc(reg1, param2)
END
END
END
|IL.opSUB:
BinOp(reg1, reg2);
oprr(29H, reg1, reg2); (* sub reg1, reg2 *)
drop
|IL.opSUBR, IL.opSUBL:
UnOp(reg1);
IF param2 = 1 THEN
OutByte(48H + reg1) (* dec reg1 *)
ELSIF param2 = -1 THEN
OutByte(40H + reg1) (* inc reg1 *)
ELSIF param2 # 0 THEN
subrc(reg1, param2)
END;
IF opcode = IL.opSUBL THEN
neg(reg1)
END
|IL.opMULC:
IF (cmd.next(COMMAND).opcode = IL.opADD) & ((param2 = 2) OR (param2 = 4) OR (param2 = 8)) THEN
BinOp(reg1, reg2);
OutByte3(8DH, 04H + reg1 * 8, reg1 + reg2 * 8 + 40H * UTILS.Log2(param2)); (* lea reg1, [reg1 + reg2 * param2] *)
drop;
cmd := cmd.next(COMMAND)
ELSE
UnOp(reg1);
a := param2;
IF a > 1 THEN
n := UTILS.Log2(a)
ELSIF a < -1 THEN
n := UTILS.Log2(-a)
ELSE
n := -1
END;
IF a = 1 THEN
ELSIF a = -1 THEN
neg(reg1)
ELSIF a = 0 THEN
xor(reg1, reg1)
ELSE
IF n > 0 THEN
IF a < 0 THEN
neg(reg1)
END;
IF n # 1 THEN
OutByte3(0C1H, 0E0H + reg1, n) (* shl reg1, n *)
ELSE
OutByte2(0D1H, 0E0H + reg1) (* shl reg1, 1 *)
END
ELSE
OutByte2(69H + short(a), 0C0H + reg1 * 9); (* imul reg1, a *)
OutIntByte(a)
END
END
END
|IL.opMUL:
BinOp(reg1, reg2);
OutByte3(0FH, 0AFH, 0C0H + reg1 * 8 + reg2); (* imul reg1, reg2 *)
drop
|IL.opSAVE, IL.opSAVE32:
BinOp(reg2, reg1);
movmr(reg1, 0, reg2);
drop;
drop
|IL.opSAVE8:
BinOp(reg2, reg1);
movmr8(reg1, 0, reg2);
drop;
drop
|IL.opSAVE16:
BinOp(reg2, reg1);
movmr16(reg1, 0, reg2);
drop;
drop
|IL.opSAVEP:
UnOp(reg1);
IF pic THEN
reg2 := GetAnyReg();
Pic(reg2, BIN.PICCODE, param2);
movmr(reg1, 0, reg2);
drop
ELSE
OutByte2(0C7H, reg1); (* mov dword[reg1], L *)
Reloc(BIN.RCODE, param2)
END;
drop
|IL.opSAVEIP:
UnOp(reg1);
IF pic THEN
reg2 := GetAnyReg();
Pic(reg2, BIN.PICIMP, param2);
pushm(reg2, 0);
OutByte2(08FH, reg1); (* pop dword[reg1] *)
drop
ELSE
OutByte2(0FFH, 035H); (* push dword[L] *)
Reloc(BIN.RIMP, param2);
OutByte2(08FH, reg1) (* pop dword[reg1] *)
END;
drop
|IL.opPUSHP:
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICCODE, param2)
ELSE
OutByte(0B8H + reg1); (* mov reg1, L *)
Reloc(BIN.RCODE, param2)
END
|IL.opPUSHIP:
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICIMP, param2);
movrm(reg1, reg1, 0)
ELSE
OutByte2(08BH, 05H + reg1 * 8); (* mov reg1, dword[L] *)
Reloc(BIN.RIMP, param2)
END
|IL.opNOT:
UnOp(reg1);
test(reg1);
setcc(sete, reg1);
andrc(reg1, 1)
|IL.opORD:
UnOp(reg1);
test(reg1);
setcc(setne, reg1);
andrc(reg1, 1)
|IL.opSBOOL:
BinOp(reg2, reg1);
test(reg2);
OutByte3(0FH, 95H, reg1); (* setne byte[reg1] *)
drop;
drop
|IL.opSBOOLC:
UnOp(reg1);
OutByte3(0C6H, reg1, ORD(param2 # 0)); (* mov byte[reg1], 0/1 *)
drop
|IL.opEQ..IL.opGE,
IL.opEQC..IL.opGEC:
IF (IL.opEQ <= opcode) & (opcode <= IL.opGE) THEN
BinOp(reg1, reg2);
cmprr(reg1, reg2);
drop
ELSE
UnOp(reg1);
cmprc(reg1, param2)
END;
drop;
cc := cond(opcode);
next := cmd.next(COMMAND);
IF next.opcode = IL.opJNZ THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJZ THEN
jcc(inv0(cc), next.param1);
cmd := next
ELSE
reg1 := GetAnyReg();
setcc(cc + 16, reg1);
andrc(reg1, 1)
END
|IL.opEQB, IL.opNEB:
BinOp(reg1, reg2);
drop;
test(reg1);
OutByte2(74H, 5); (* je @f *)
movrc(reg1, 1); (* mov reg1, 1
@@: *)
test(reg2);
OutByte2(74H, 5); (* je @f *)
movrc(reg2, 1); (* mov reg2, 1
@@: *)
cmprr(reg1, reg2);
IF opcode = IL.opEQB THEN
setcc(sete, reg1)
ELSE
setcc(setne, reg1)
END;
andrc(reg1, 1)
|IL.opDROP:
UnOp(reg1);
drop
|IL.opJNZ1:
UnOp(reg1);
test(reg1);
jcc(jne, param1)
|IL.opJG:
UnOp(reg1);
test(reg1);
jcc(jg, param1)
|IL.opJNZ:
UnOp(reg1);
test(reg1);
jcc(jne, param1);
drop
|IL.opJZ:
UnOp(reg1);
test(reg1);
jcc(je, param1);
drop
|IL.opSWITCH:
UnOp(reg1);
IF param2 = 0 THEN
reg2 := eax
ELSE
reg2 := ecx
END;
IF reg1 # reg2 THEN
ASSERT(REG.GetReg(R, reg2));
ASSERT(REG.Exchange(R, reg1, reg2));
drop
END;
drop
|IL.opENDSW:
|IL.opCASEL:
cmprc(eax, param1);
jcc(jl, param2)
|IL.opCASER:
cmprc(eax, param1);
jcc(jg, param2)
|IL.opCASELR:
cmprc(eax, param1);
IF param2 = cmd.param3 THEN
jcc(jne, param2)
ELSE
jcc(jl, param2);
jcc(jg, cmd.param3)
END
|IL.opCODE:
OutByte(param2)
|IL.opGET, IL.opGETC:
IF opcode = IL.opGET THEN
BinOp(reg1, reg2)
ELSIF opcode = IL.opGETC THEN
UnOp(reg2);
reg1 := GetAnyReg();
movrc(reg1, param1)
END;
drop;
drop;
IF param2 # 8 THEN
_movrm(reg1, reg1, 0, param2 * 8, FALSE);
_movrm(reg1, reg2, 0, param2 * 8, TRUE)
ELSE
PushAll(0);
push(reg1);
push(reg2);
pushc(8);
CallRTL(pic, IL._move)
END
|IL.opSAVES:
UnOp(reg2);
REG.PushAll_1(R);
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICDATA, stroffs + param2);
push(reg1);
drop
ELSE
OutByte(068H); (* push _data + stroffs + param2 *)
Reloc(BIN.RDATA, stroffs + param2);
END;
push(reg2);
drop;
pushc(param1);
CallRTL(pic, IL._move)
|IL.opCHKBYTE:
BinOp(reg1, reg2);
cmprc(reg1, 256);
jcc(jb, param1)
|IL.opCHKIDX:
UnOp(reg1);
cmprc(reg1, param2);
jcc(jb, param1)
|IL.opCHKIDX2:
BinOp(reg1, reg2);
IF param2 # -1 THEN
cmprr(reg2, reg1);
jcc(jb, param1)
END;
INCL(R.regs, reg1);
DEC(R.top);
R.stk[R.top] := reg2
|IL.opLEN:
n := param2;
UnOp(reg1);
drop;
EXCL(R.regs, reg1);
WHILE n > 0 DO
UnOp(reg2);
drop;
DEC(n)
END;
INCL(R.regs, reg1);
ASSERT(REG.GetReg(R, reg1))
|IL.opINCC:
UnOp(reg1);
IF param2 = 1 THEN
OutByte2(0FFH, reg1) (* inc dword[reg1] *)
ELSIF param2 = -1 THEN
OutByte2(0FFH, reg1 + 8) (* dec dword[reg1] *)
ELSE
OutByte2(81H + short(param2), reg1); OutIntByte(param2) (* add dword[reg1], param2 *)
END;
drop
|IL.opINC, IL.opDEC:
BinOp(reg1, reg2);
OutByte2(01H + 28H * ORD(opcode = IL.opDEC), reg1 * 8 + reg2); (* add/sub dword[reg2], reg1 *)
drop;
drop
|IL.opINCCB, IL.opDECCB:
UnOp(reg1);
OutByte3(80H, 28H * ORD(opcode = IL.opDECCB) + reg1, param2 MOD 256); (* add/sub byte[reg1], n *)
drop
|IL.opINCB, IL.opDECB:
BinOp(reg1, reg2);
OutByte2(28H * ORD(opcode = IL.opDECB), reg1 * 8 + reg2); (* add/sub byte[reg2], reg1 *)
drop;
drop
|IL.opMULS:
BinOp(reg1, reg2);
oprr(21H, reg1, reg2); (* and reg1, reg2 *)
drop
|IL.opMULSC:
UnOp(reg1);
andrc(reg1, param2)
|IL.opDIVS:
BinOp(reg1, reg2);
xor(reg1, reg2);
drop
|IL.opDIVSC:
UnOp(reg1);
xorrc(reg1, param2)
|IL.opADDS:
BinOp(reg1, reg2);
oprr(9H, reg1, reg2); (* or reg1, reg2 *)
drop
|IL.opSUBS:
BinOp(reg1, reg2);
not(reg2);
oprr(21H, reg1, reg2); (* and reg1, reg2 *)
drop
|IL.opADDSC:
UnOp(reg1);
orrc(reg1, param2)
|IL.opSUBSL:
UnOp(reg1);
not(reg1);
andrc(reg1, param2)
|IL.opSUBSR:
UnOp(reg1);
andrc(reg1, ORD(-BITS(param2)))
|IL.opUMINS:
UnOp(reg1);
not(reg1)
|IL.opLENGTH:
PushAll(2);
CallRTL(pic, IL._length);
GetRegA
|IL.opLENGTHW:
PushAll(2);
CallRTL(pic, IL._lengthw);
GetRegA
|IL.opCHR:
UnOp(reg1);
andrc(reg1, 255)
|IL.opWCHR:
UnOp(reg1);
andrc(reg1, 65535)
|IL.opASR, IL.opROR, IL.opLSL, IL.opLSR:
UnOp(reg1);
IF reg1 # ecx THEN
ASSERT(REG.GetReg(R, ecx));
ASSERT(REG.Exchange(R, reg1, ecx));
drop
END;
BinOp(reg1, reg2);
ASSERT(reg2 = ecx);
OutByte(0D3H);
shift(opcode, reg1); (* shift reg1, cl *)
drop
|IL.opASR1, IL.opROR1, IL.opLSL1, IL.opLSR1:
UnOp(reg1);
IF reg1 # ecx THEN
ASSERT(REG.GetReg(R, ecx));
ASSERT(REG.Exchange(R, reg1, ecx));
drop
END;
reg1 := GetAnyReg();
movrc(reg1, param2);
BinOp(reg1, reg2);
ASSERT(reg1 = ecx);
OutByte(0D3H);
shift(opcode, reg2); (* shift reg2, cl *)
drop;
drop;
ASSERT(REG.GetReg(R, reg2))
|IL.opASR2, IL.opROR2, IL.opLSL2, IL.opLSR2:
UnOp(reg1);
n := param2 MOD 32;
IF n # 1 THEN
OutByte(0C1H)
ELSE
OutByte(0D1H)
END;
shift(opcode, reg1); (* shift reg1, n *)
IF n # 1 THEN
OutByte(n)
END
|IL.opMAX, IL.opMIN:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(07DH + ORD(opcode = IL.opMIN), 2); (* jge/jle L *)
mov(reg1, reg2);
(* L: *)
drop
|IL.opMAXC, IL.opMINC:
UnOp(reg1);
cmprc(reg1, param2);
label := NewLabel();
IF opcode = IL.opMINC THEN
cc := jle
ELSE
cc := jge
END;
jcc(cc, label);
movrc(reg1, param2);
SetLabel(label)
|IL.opIN, IL.opINR:
IF opcode = IL.opINR THEN
reg2 := GetAnyReg();
movrc(reg2, param2)
END;
label := NewLabel();
BinOp(reg1, reg2);
cmprc(reg1, 32);
OutByte2(72H, 4); (* jb L *)
xor(reg1, reg1);
jmp(label);
(* L: *)
OutByte3(0FH, 0A3H, 0C0H + reg2 + 8 * reg1); (* bt reg2, reg1 *)
setcc(setc, reg1);
andrc(reg1, 1);
SetLabel(label);
drop
|IL.opINL:
UnOp(reg1);
OutByte3(0FH, 0BAH, 0E0H + reg1); OutByte(param2); (* bt reg1, param2 *)
setcc(setc, reg1);
andrc(reg1, 1)
|IL.opRSET:
PushAll(2);
CallRTL(pic, IL._set);
GetRegA
|IL.opRSETR:
PushAll(1);
pushc(param2);
CallRTL(pic, IL._set);
GetRegA
|IL.opRSETL:
UnOp(reg1);
REG.PushAll_1(R);
pushc(param2);
push(reg1);
drop;
CallRTL(pic, IL._set);
GetRegA
|IL.opRSET1:
PushAll(1);
CallRTL(pic, IL._set1);
GetRegA
|IL.opINCL, IL.opEXCL:
BinOp(reg1, reg2);
cmprc(reg1, 32);
OutByte2(73H, 03H); (* jnb L *)
OutByte(0FH);
IF opcode = IL.opINCL THEN
OutByte(0ABH) (* bts dword[reg2], reg1 *)
ELSE
OutByte(0B3H) (* btr dword[reg2], reg1 *)
END;
OutByte(reg2 + 8 * reg1);
(* L: *)
drop;
drop
|IL.opINCLC:
UnOp(reg1);
OutByte3(0FH, 0BAH, 28H + reg1); OutByte(param2); (* bts dword[reg1], param2 *)
drop
|IL.opEXCLC:
UnOp(reg1);
OutByte3(0FH, 0BAH, 30H + reg1); OutByte(param2); (* btr dword[reg1], param2 *)
drop
|IL.opDIV:
PushAll(2);
CallRTL(pic, IL._divmod);
GetRegA
|IL.opDIVR:
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(reg1);
IF n # 1 THEN
OutByte3(0C1H, 0F8H + reg1, n) (* sar reg1, n *)
ELSE
OutByte2(0D1H, 0F8H + reg1) (* sar reg1, 1 *)
END
ELSIF n < 0 THEN
PushAll(1);
pushc(param2);
CallRTL(pic, IL._divmod);
GetRegA
END
|IL.opDIVL:
UnOp(reg1);
REG.PushAll_1(R);
pushc(param2);
push(reg1);
drop;
CallRTL(pic, IL._divmod);
GetRegA
|IL.opMOD:
PushAll(2);
CallRTL(pic, IL._divmod);
mov(eax, edx);
GetRegA
|IL.opMODR:
n := UTILS.Log2(param2);
IF n > 0 THEN
UnOp(reg1);
andrc(reg1, param2 - 1);
ELSIF n < 0 THEN
PushAll(1);
pushc(param2);
CallRTL(pic, IL._divmod);
mov(eax, edx);
GetRegA
ELSE
UnOp(reg1);
xor(reg1, reg1)
END
|IL.opMODL:
UnOp(reg1);
REG.PushAll_1(R);
pushc(param2);
push(reg1);
drop;
CallRTL(pic, IL._divmod);
mov(eax, edx);
GetRegA
|IL.opERR:
CallRTL(pic, IL._error)
|IL.opABS:
UnOp(reg1);
test(reg1);
OutByte2(07DH, 002H); (* jge L *)
neg(reg1) (* neg reg1
L: *)
|IL.opCOPY:
PushAll(2);
pushc(param2);
CallRTL(pic, IL._move)
|IL.opMOVE:
PushAll(3);
CallRTL(pic, IL._move)
|IL.opCOPYA:
PushAll(4);
pushc(param2);
CallRTL(pic, IL._arrcpy);
GetRegA
|IL.opCOPYS:
PushAll(4);
pushc(param2);
CallRTL(pic, IL._strcpy)
|IL.opROT:
PushAll(0);
push(esp);
pushc(param2);
CallRTL(pic, IL._rot)
|IL.opNEW:
PushAll(1);
n := param2 + 8;
ASSERT(UTILS.Align(n, 32));
pushc(n);
pushc(param1);
CallRTL(pic, IL._new)
|IL.opDISP:
PushAll(1);
CallRTL(pic, IL._dispose)
|IL.opEQS .. IL.opGES:
PushAll(4);
pushc(opcode - IL.opEQS);
CallRTL(pic, IL._strcmp);
GetRegA
|IL.opEQSW .. IL.opGESW:
PushAll(4);
pushc(opcode - IL.opEQSW);
CallRTL(pic, IL._strcmpw);
GetRegA
|IL.opEQP, IL.opNEP, IL.opEQIP, IL.opNEIP:
UnOp(reg1);
CASE opcode OF
|IL.opEQP, IL.opNEP:
IF pic THEN
reg2 := GetAnyReg();
Pic(reg2, BIN.PICCODE, param1);
cmprr(reg1, reg2);
drop
ELSE
OutByte2(081H, 0F8H + reg1); (* cmp reg1, L *)
Reloc(BIN.RCODE, param1)
END
|IL.opEQIP, IL.opNEIP:
IF pic THEN
reg2 := GetAnyReg();
Pic(reg2, BIN.PICIMP, param1);
OutByte2(03BH, reg1 * 8 + reg2); (* cmp reg1, dword [reg2] *)
drop
ELSE
OutByte2(3BH, 05H + reg1 * 8); (* cmp reg1, dword[L] *)
Reloc(BIN.RIMP, param1)
END
END;
drop;
reg1 := GetAnyReg();
CASE opcode OF
|IL.opEQP, IL.opEQIP: setcc(sete, reg1)
|IL.opNEP, IL.opNEIP: setcc(setne, reg1)
END;
andrc(reg1, 1)
|IL.opPUSHT:
UnOp(reg1);
movrm(GetAnyReg(), reg1, -4)
|IL.opISREC:
PushAll(2);
pushc(param2 * tcount);
CallRTL(pic, IL._isrec);
GetRegA
|IL.opIS:
PushAll(1);
pushc(param2 * tcount);
CallRTL(pic, IL._is);
GetRegA
|IL.opTYPEGR:
PushAll(1);
pushc(param2 * tcount);
CallRTL(pic, IL._guardrec);
GetRegA
|IL.opTYPEGP:
UnOp(reg1);
PushAll(0);
push(reg1);
pushc(param2 * tcount);
CallRTL(pic, IL._guard);
GetRegA
|IL.opTYPEGD:
UnOp(reg1);
PushAll(0);
pushm(reg1, -4);
pushc(param2 * tcount);
CallRTL(pic, IL._guardrec);
GetRegA
|IL.opCASET:
push(ecx);
push(ecx);
pushc(param2 * tcount);
CallRTL(pic, IL._guardrec);
pop(ecx);
test(eax);
jcc(jne, param1)
|IL.opPACK:
BinOp(reg1, reg2);
push(reg2);
OutByte3(0DBH, 004H, 024H); (* fild dword[esp] *)
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
OutByte2(0D9H, 0FDH); (* fscale *)
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
OutByte3(0DBH, 01CH, 024H); (* fistp dword[esp] *)
pop(reg2);
drop;
drop
|IL.opPACKC:
UnOp(reg1);
pushc(param2);
OutByte3(0DBH, 004H, 024H); (* fild dword[esp] *)
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
OutByte2(0D9H, 0FDH); (* fscale *)
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
OutByte3(0DBH, 01CH, 024H); (* fistp dword[esp] *)
pop(reg1);
drop
|IL.opUNPK:
BinOp(reg1, reg2);
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
OutByte2(0D9H, 0F4H); (* fxtract *)
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
OutByte2(0DBH, 018H + reg2); (* fistp dword[reg2] *)
drop;
drop
|IL.opPUSHF:
ASSERT(fr >= 0);
DEC(fr);
subrc(esp, 8);
OutByte3(0DDH, 01CH, 024H) (* fstp qword[esp] *)
|IL.opLOADF:
INC(fr);
IF fr > MAX_FR THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
UnOp(reg1);
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
drop
|IL.opCONSTF:
INC(fr);
IF fr > MAX_FR THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
float := cmd.float;
IF float = 0.0 THEN
OutByte2(0D9H, 0EEH) (* fldz *)
ELSIF float = 1.0 THEN
OutByte2(0D9H, 0E8H) (* fld1 *)
ELSIF float = -1.0 THEN
OutByte2(0D9H, 0E8H); (* fld1 *)
OutByte2(0D9H, 0E0H) (* fchs *)
ELSE
n := UTILS.splitf(float, a, b);
pushc(b);
pushc(a);
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *)
addrc(esp, 8)
END
|IL.opSAVEF, IL.opSAVEFI:
ASSERT(fr >= 0);
DEC(fr);
UnOp(reg1);
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
drop
|IL.opADDF:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0C1H) (* faddp st1, st *)
|IL.opSUBF:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0E9H) (* fsubp st1, st *)
|IL.opSUBFI:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0E1H) (* fsubrp st1, st *)
|IL.opMULF:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0C9H) (* fmulp st1, st *)
|IL.opDIVF:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0F9H) (* fdivp st1, st *)
|IL.opDIVFI:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0F1H) (* fdivrp st1, st *)
|IL.opUMINF:
ASSERT(fr >= 0);
OutByte2(0D9H, 0E0H) (* fchs *)
|IL.opFABS:
ASSERT(fr >= 0);
OutByte2(0D9H, 0E1H) (* fabs *)
|IL.opFLT:
INC(fr);
IF fr > MAX_FR THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
UnOp(reg1);
push(reg1);
OutByte3(0DBH, 004H, 024H); (* fild dword[esp] *)
pop(reg1);
drop
|IL.opFLOOR:
ASSERT(fr >= 0);
DEC(fr);
subrc(esp, 8);
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 004H); (* fstcw word[esp+4] *)
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 006H); (* fstcw word[esp+6] *)
OutByte2(066H, 081H); OutByte3(064H, 024H, 004H); OutWord(0F3FFH); (* and word[esp+4], 1111001111111111b *)
OutByte2(066H, 081H); OutByte3(04CH, 024H, 004H); OutWord(00400H); (* or word[esp+4], 0000010000000000b *)
OutByte2(0D9H, 06CH); OutByte2(024H, 004H); (* fldcw word[esp+4] *)
OutByte2(0D9H, 0FCH); (* frndint *)
OutByte3(0DBH, 01CH, 024H); (* fistp dword[esp] *)
pop(GetAnyReg());
OutByte2(0D9H, 06CH); OutByte2(024H, 002H); (* fldcw word[esp+2] *)
addrc(esp, 4)
|IL.opEQF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 003H); (* jp L *)
setcc(sete, al)
(* L: *)
|IL.opNEF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 003H); (* jp L *)
setcc(setne, al)
(* L: *)
|IL.opLTF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 00EH); (* jp L *)
setcc(setc, al);
setcc(sete, ah);
test(eax);
setcc(sete, al);
andrc(eax, 1)
(* L: *)
|IL.opGTF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 00FH); (* jp L *)
setcc(setc, al);
setcc(sete, ah);
cmprc(eax, 1);
setcc(sete, al);
andrc(eax, 1)
(* L: *)
|IL.opLEF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 003H); (* jp L *)
setcc(setnc, al)
(* L: *)
|IL.opGEF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 010H); (* jp L *)
setcc(setc, al);
setcc(sete, ah);
OutByte2(000H, 0E0H); (* add al, ah *)
OutByte2(03CH, 001H); (* cmp al, 1 *)
setcc(sete, al);
andrc(eax, 1)
(* L: *)
|IL.opINF:
INC(fr);
IF fr > MAX_FR THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
pushc(7FF00000H);
pushc(0);
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *)
addrc(esp, 8)
|IL.opLADR_UNPK:
n := param2 * 4;
reg1 := GetAnyReg();
OutByte2(8DH, 45H + reg1 * 8 + long(n)); (* lea reg1, dword[ebp + n] *)
OutIntByte(n);
BinOp(reg1, reg2);
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
OutByte2(0D9H, 0F4H); (* fxtract *)
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
OutByte2(0DBH, 018H + reg2); (* fistp dword[reg2] *)
drop;
drop
|IL.opSADR_PARAM:
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICDATA, stroffs + param2);
push(reg1);
drop
ELSE
OutByte(068H); (* push _data + stroffs + param2 *)
Reloc(BIN.RDATA, stroffs + param2)
END
|IL.opVADR_PARAM, IL.opLLOAD32_PARAM:
pushm(ebp, param2 * 4)
|IL.opCONST_PARAM:
pushc(param2)
|IL.opGLOAD32_PARAM:
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICBSS, param2);
pushm(reg1, 0);
drop
ELSE
OutByte2(0FFH, 035H); (* push dword[_bss + param2] *)
Reloc(BIN.RBSS, param2)
END
|IL.opLOAD32_PARAM:
UnOp(reg1);
pushm(reg1, 0);
drop
|IL.opGADR_SAVEC:
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICBSS, param1);
OutByte2(0C7H, reg1); (* mov dword[reg1], param2 *)
OutInt(param2);
drop
ELSE
OutByte2(0C7H, 05H); (* mov dword[_bss + param1], param2 *)
Reloc(BIN.RBSS, param1);
OutInt(param2)
END
|IL.opLADR_SAVEC:
n := param1 * 4;
OutByte2(0C7H, 45H + long(n)); (* mov dword[ebp + n], param2 *)
OutIntByte(n);
OutInt(param2)
|IL.opLADR_SAVE:
UnOp(reg1);
movmr(ebp, param2 * 4, reg1);
drop
|IL.opLADR_INCC:
n := param1 * 4;
IF ABS(param2) = 1 THEN
OutByte2(0FFH, 45H + 8 * ORD(param2 = -1) + long(n)); (* inc/dec dword[ebp + n] *)
OutIntByte(n)
ELSE
OutByte2(81H + short(param2), 45H + long(n)); (* add dword[ebp + n], param2 *)
OutIntByte(n);
OutIntByte(param2)
END
|IL.opLADR_INCCB, IL.opLADR_DECCB:
n := param1 * 4;
IF param2 = 1 THEN
OutByte2(0FEH, 45H + 8 * ORD(opcode = IL.opLADR_DECCB) + long(n)); (* inc/dec byte[ebp + n] *)
OutIntByte(n)
ELSE
OutByte2(80H, 45H + 28H * ORD(opcode = IL.opLADR_DECCB) + long(n)); (* add/sub byte[ebp + n], param2 *)
OutIntByte(n);
OutByte(param2 MOD 256)
END
|IL.opLADR_INC, IL.opLADR_DEC:
n := param2 * 4;
UnOp(reg1);
OutByte2(01H + 28H * ORD(opcode = IL.opLADR_DEC), 45H + long(n) + reg1 * 8); (* add/sub dword[ebp + n], reg1 *)
OutIntByte(n);
drop
|IL.opLADR_INCB, IL.opLADR_DECB:
n := param2 * 4;
UnOp(reg1);
OutByte2(28H * ORD(opcode = IL.opLADR_DECB), 45H + long(n) + reg1 * 8); (* add/sub byte[ebp + n], reg1 *)
OutIntByte(n);
drop
|IL.opLADR_INCL, IL.opLADR_EXCL:
n := param2 * 4;
UnOp(reg1);
cmprc(reg1, 32);
label := NewLabel();
jcc(jnb, label);
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), 45H + long(n) + reg1 * 8); (* bts(r) dword[ebp + n], reg1 *)
OutIntByte(n);
SetLabel(label);
drop
|IL.opLADR_INCLC, IL.opLADR_EXCLC:
n := param1 * 4;
OutByte3(0FH, 0BAH, 6DH + long(n) + 8 * ORD(opcode = IL.opLADR_EXCLC)); (* bts(r) dword[ebp + n], param2 *)
OutIntByte(n);
OutByte(param2)
|IL.opFNAME:
fname := cmd(IL.FNAMECMD).fname
END;
cmd := cmd.next(COMMAND)
END;
ASSERT(R.pushed = 0);
ASSERT(R.top = -1);
ASSERT(fr = -1)
END translate;
PROCEDURE prolog (pic: BOOLEAN; target, stack, dllinit, dllret: INTEGER);
VAR
reg1, entry, L, dcount: INTEGER;
BEGIN
entry := NewLabel();
SetLabel(entry);
dcount := CHL.Length(IL.codes.data);
IF target = TARGETS.Win32DLL THEN
push(ebp);
mov(ebp, esp);
pushm(ebp, 16);
pushm(ebp, 12);
pushm(ebp, 8);
CallRTL(pic, IL._dllentry);
test(eax);
jcc(je, dllret);
pushc(0)
ELSIF target = TARGETS.KolibriOSDLL THEN
SetLabel(dllinit);
OutByte(68H); (* push IMPORT *)
Reloc(BIN.IMPTAB, 0)
ELSIF target = TARGETS.KolibriOS THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.IMPTAB, 0);
push(reg1); (* push IMPORT *)
drop
ELSIF target = TARGETS.Linux32 THEN
push(esp)
ELSE
pushc(0)
END;
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICCODE, entry);
push(reg1); (* push CODE *)
Pic(reg1, BIN.PICDATA, 0);
push(reg1); (* push _data *)
pushc(tcount);
Pic(reg1, BIN.PICDATA, tcount * 4 + dcount);
push(reg1); (* push _data + tcount * 4 + dcount *)
drop
ELSE
OutByte(68H); (* push CODE *)
Reloc(BIN.RCODE, entry);
OutByte(68H); (* push _data *)
Reloc(BIN.RDATA, 0);
pushc(tcount);
OutByte(68H); (* push _data + tcount * 4 + dcount *)
Reloc(BIN.RDATA, tcount * 4 + dcount)
END;
CallRTL(pic, IL._init);
IF target IN {TARGETS.Win32C, TARGETS.Win32GUI, TARGETS.Linux32} THEN
L := NewLabel();
pushc(0);
push(esp);
pushc(1024 * 1024 * stack);
pushc(0);
CallRTL(pic, IL._new);
pop(eax);
test(eax);
jcc(je, L);
addrc(eax, 1024 * 1024 * stack - 4);
mov(esp, eax);
SetLabel(L)
END
END prolog;
PROCEDURE epilog (pic: BOOLEAN; modname: ARRAY OF CHAR; target, stack, ver, dllinit, dllret, sofinit: INTEGER);
VAR
exp: IL.EXPORT_PROC;
path, name, ext: PATHS.PATH;
dcount, i: INTEGER;
PROCEDURE _import (imp: LISTS.LIST);
VAR
lib: IL.IMPORT_LIB;
proc: IL.IMPORT_PROC;
BEGIN
lib := imp.first(IL.IMPORT_LIB);
WHILE lib # NIL DO
BIN.Import(program, lib.name, 0);
proc := lib.procs.first(IL.IMPORT_PROC);
WHILE proc # NIL DO
BIN.Import(program, proc.name, proc.label);
proc := proc.next(IL.IMPORT_PROC)
END;
lib := lib.next(IL.IMPORT_LIB)
END
END _import;
BEGIN
IF target IN {TARGETS.Win32C, TARGETS.Win32GUI, TARGETS.KolibriOS, TARGETS.Linux32} THEN
pushc(0);
CallRTL(pic, IL._exit);
ELSIF target = TARGETS.Win32DLL THEN
SetLabel(dllret);
movrc(eax, 1);
OutByte(0C9H); (* leave *)
OutByte3(0C2H, 0CH, 0) (* ret 12 *)
ELSIF target = TARGETS.KolibriOSDLL THEN
movrc(eax, 1);
ret
ELSIF target = TARGETS.Linux32SO THEN
ret;
SetLabel(sofinit);
CallRTL(pic, IL._sofinit);
ret
END;
fixup;
dcount := CHL.Length(IL.codes.data);
FOR i := 0 TO tcount - 1 DO
BIN.PutData32LE(program, CHL.GetInt(IL.codes.types, i))
END;
FOR i := 0 TO dcount - 1 DO
BIN.PutData(program, CHL.GetByte(IL.codes.data, i))
END;
program.modname := CHL.Length(program.data);
PATHS.split(modname, path, name, ext);
BIN.PutDataStr(program, name);
BIN.PutDataStr(program, ext);
BIN.PutData(program, 0);
IF target = TARGETS.KolibriOSDLL THEN
BIN.Export(program, "lib_init", dllinit);
END;
exp := IL.codes.export.first(IL.EXPORT_PROC);
WHILE exp # NIL DO
BIN.Export(program, exp.name, exp.label);
exp := exp.next(IL.EXPORT_PROC)
END;
_import(IL.codes._import);
IL.set_bss(MAX(IL.codes.bss, MAX(IL.codes.dmin - CHL.Length(IL.codes.data), 4)));
BIN.SetParams(program, IL.codes.bss, stack * (1024 * 1024), WCHR(ver DIV 65536), WCHR(ver MOD 65536))
END epilog;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
VAR
dllret, dllinit, sofinit: INTEGER;
opt: PROG.OPTIONS;
BEGIN
FR[0] := 0;
tcount := CHL.Length(IL.codes.types);
opt := options;
CodeList := LISTS.create(NIL);
program := BIN.create(IL.codes.lcount);
dllinit := NewLabel();
dllret := NewLabel();
sofinit := NewLabel();
IF target = TARGETS.KolibriOSDLL THEN
opt.pic := FALSE
END;
IF TARGETS.OS IN {TARGETS.osWIN32, TARGETS.osLINUX32} THEN
opt.pic := TRUE
END;
REG.Init(R, push, pop, mov, xchg, {eax, ecx, edx});
prolog(opt.pic, target, opt.stack, dllinit, dllret);
translate(opt.pic, tcount * 4);
epilog(opt.pic, outname, target, opt.stack, opt.version, dllinit, dllret, sofinit);
BIN.fixup(program);
IF TARGETS.OS = TARGETS.osWIN32 THEN
PE32.write(program, outname, target = TARGETS.Win32C, target = TARGETS.Win32DLL, FALSE)
ELSIF target = TARGETS.KolibriOS THEN
KOS.write(program, outname)
ELSIF target = TARGETS.KolibriOSDLL THEN
MSCOFF.write(program, outname, opt.version)
ELSIF TARGETS.OS = TARGETS.osLINUX32 THEN
ELF.write(program, outname, sofinit, target = TARGETS.Linux32SO, FALSE)
END
END CodeGen;
PROCEDURE SetProgram* (prog: BIN.PROGRAM);
BEGIN
program := prog;
CodeList := LISTS.create(NIL)
END SetProgram;
END X86.

/programs/develop/oberon07/source/BIN.ob07
0,0 → 1,384
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE BIN;
IMPORT LISTS, CHL := CHUNKLISTS, ARITH, UTILS;
CONST
RCODE* = 0; PICCODE* = RCODE + 1;
RDATA* = 2; PICDATA* = RDATA + 1;
RBSS* = 4; PICBSS* = RBSS + 1;
RIMP* = 6; PICIMP* = RIMP + 1;
IMPTAB* = 8;
TYPE
RELOC* = POINTER TO RECORD (LISTS.ITEM)
opcode*: INTEGER;
offset*: INTEGER
END;
IMPRT* = POINTER TO RECORD (LISTS.ITEM)
nameoffs*: INTEGER;
label*: INTEGER;
OriginalFirstThunk*,
FirstThunk*: INTEGER
END;
EXPRT* = POINTER TO RECORD (LISTS.ITEM)
nameoffs*: INTEGER;
label*: INTEGER
END;
PROGRAM* = POINTER TO RECORD
code*: CHL.BYTELIST;
data*: CHL.BYTELIST;
labels: CHL.INTLIST;
bss*: INTEGER;
stack*: INTEGER;
vmajor*,
vminor*: WCHAR;
modname*: INTEGER;
_import*: CHL.BYTELIST;
export*: CHL.BYTELIST;
rel_list*: LISTS.LIST;
imp_list*: LISTS.LIST;
exp_list*: LISTS.LIST
END;
PROCEDURE create* (NumberOfLabels: INTEGER): PROGRAM;
VAR
program: PROGRAM;
i: INTEGER;
BEGIN
NEW(program);
program.bss := 0;
program.labels := CHL.CreateIntList();
FOR i := 0 TO NumberOfLabels - 1 DO
CHL.PushInt(program.labels, 0)
END;
program.rel_list := LISTS.create(NIL);
program.imp_list := LISTS.create(NIL);
program.exp_list := LISTS.create(NIL);
program.data := CHL.CreateByteList();
program.code := CHL.CreateByteList();
program._import := CHL.CreateByteList();
program.export := CHL.CreateByteList()
RETURN program
END create;
PROCEDURE SetParams* (program: PROGRAM; bss, stack: INTEGER; vmajor, vminor: WCHAR);
BEGIN
program.bss := bss;
program.stack := stack;
program.vmajor := vmajor;
program.vminor := vminor
END SetParams;
PROCEDURE PutReloc* (program: PROGRAM; opcode: INTEGER);
VAR
cmd: RELOC;
BEGIN
NEW(cmd);
cmd.opcode := opcode;
cmd.offset := CHL.Length(program.code);
LISTS.push(program.rel_list, cmd)
END PutReloc;
PROCEDURE PutData* (program: PROGRAM; b: BYTE);
BEGIN
CHL.PushByte(program.data, b)
END PutData;
PROCEDURE get32le* (_array: CHL.BYTELIST; idx: INTEGER): INTEGER;
VAR
i: INTEGER;
x: INTEGER;
BEGIN
x := 0;
FOR i := 3 TO 0 BY -1 DO
x := LSL(x, 8) + CHL.GetByte(_array, idx + i)
END;
IF UTILS.bit_depth = 64 THEN
x := LSL(x, 16);
x := LSL(x, 16);
x := ASR(x, 16);
x := ASR(x, 16)
END
RETURN x
END get32le;
PROCEDURE put32le* (_array: CHL.BYTELIST; idx: INTEGER; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
CHL.SetByte(_array, idx + i, UTILS.Byte(x, i))
END
END put32le;
PROCEDURE PutData32LE* (program: PROGRAM; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
CHL.PushByte(program.data, UTILS.Byte(x, i))
END
END PutData32LE;
PROCEDURE PutData64LE* (program: PROGRAM; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 7 DO
CHL.PushByte(program.data, UTILS.Byte(x, i))
END
END PutData64LE;
PROCEDURE PutDataStr* (program: PROGRAM; s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE s[i] # 0X DO
PutData(program, ORD(s[i]));
INC(i)
END
END PutDataStr;
PROCEDURE PutCode* (program: PROGRAM; b: BYTE);
BEGIN
CHL.PushByte(program.code, b)
END PutCode;
PROCEDURE PutCode32LE* (program: PROGRAM; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
CHL.PushByte(program.code, UTILS.Byte(x, i))
END
END PutCode32LE;
PROCEDURE PutCode16LE* (program: PROGRAM; x: INTEGER);
BEGIN
CHL.PushByte(program.code, UTILS.Byte(x, 0));
CHL.PushByte(program.code, UTILS.Byte(x, 1))
END PutCode16LE;
PROCEDURE SetLabel* (program: PROGRAM; label, offset: INTEGER);
BEGIN
CHL.SetInt(program.labels, label, offset)
END SetLabel;
PROCEDURE Import* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER);
VAR
imp: IMPRT;
BEGIN
CHL.PushByte(program._import, 0);
CHL.PushByte(program._import, 0);
IF ODD(CHL.Length(program._import)) THEN
CHL.PushByte(program._import, 0)
END;
NEW(imp);
imp.nameoffs := CHL.PushStr(program._import, name);
imp.label := label;
LISTS.push(program.imp_list, imp)
END Import;
PROCEDURE less (bytes: CHL.BYTELIST; a, b: EXPRT): BOOLEAN;
VAR
i, j: INTEGER;
BEGIN
i := a.nameoffs;
j := b.nameoffs;
WHILE (CHL.GetByte(bytes, i) # 0) & (CHL.GetByte(bytes, j) # 0) &
(CHL.GetByte(bytes, i) = CHL.GetByte(bytes, j)) DO
INC(i);
INC(j)
END
RETURN CHL.GetByte(bytes, i) < CHL.GetByte(bytes, j)
END less;
PROCEDURE Export* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER);
VAR
exp, cur: EXPRT;
BEGIN
NEW(exp);
exp.label := CHL.GetInt(program.labels, label);
exp.nameoffs := CHL.PushStr(program.export, name);
cur := program.exp_list.first(EXPRT);
WHILE (cur # NIL) & less(program.export, cur, exp) DO
cur := cur.next(EXPRT)
END;
IF cur # NIL THEN
IF cur.prev # NIL THEN
LISTS.insert(program.exp_list, cur.prev, exp)
ELSE
LISTS.insertL(program.exp_list, cur, exp)
END
ELSE
LISTS.push(program.exp_list, exp)
END
END Export;
PROCEDURE GetIProc* (program: PROGRAM; n: INTEGER): IMPRT;
VAR
_import, res: IMPRT;
BEGIN
_import := program.imp_list.first(IMPRT);
res := NIL;
WHILE (_import # NIL) & (n >= 0) DO
IF _import.label # 0 THEN
res := _import;
DEC(n)
END;
_import := _import.next(IMPRT)
END;
ASSERT(n = -1)
RETURN res
END GetIProc;
PROCEDURE GetLabel* (program: PROGRAM; label: INTEGER): INTEGER;
RETURN CHL.GetInt(program.labels, label)
END GetLabel;
PROCEDURE NewLabel* (program: PROGRAM);
BEGIN
CHL.PushInt(program.labels, 0)
END NewLabel;
PROCEDURE fixup* (program: PROGRAM);
VAR
rel: RELOC;
imp: IMPRT;
nproc: INTEGER;
L: INTEGER;
BEGIN
nproc := 0;
imp := program.imp_list.first(IMPRT);
WHILE imp # NIL DO
IF imp.label # 0 THEN
CHL.SetInt(program.labels, imp.label, nproc);
INC(nproc)
END;
imp := imp.next(IMPRT)
END;
rel := program.rel_list.first(RELOC);
WHILE rel # NIL DO
IF rel.opcode IN {RIMP, PICIMP} THEN
L := get32le(program.code, rel.offset);
put32le(program.code, rel.offset, GetLabel(program, L))
END;
rel := rel.next(RELOC)
END
END fixup;
PROCEDURE InitArray* (VAR _array: ARRAY OF BYTE; VAR idx: INTEGER; hex: ARRAY OF CHAR);
VAR
i, k: INTEGER;
PROCEDURE hexdgt (dgt: CHAR): INTEGER;
VAR
res: INTEGER;
BEGIN
IF dgt < "A" THEN
res := ORD(dgt) - ORD("0")
ELSE
res := ORD(dgt) - ORD("A") + 10
END
RETURN res
END hexdgt;
BEGIN
k := LENGTH(hex);
ASSERT(~ODD(k));
k := k DIV 2;
FOR i := 0 TO k - 1 DO
_array[i + idx] := hexdgt(hex[2 * i]) * 16 + hexdgt(hex[2 * i + 1])
END;
INC(idx, k)
END InitArray;
END BIN.

/programs/develop/oberon07/source/HEX.ob07
0,0 → 1,117
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE HEX;
IMPORT WRITER, CHL := CHUNKLISTS, UTILS;
VAR
chksum: INTEGER;
PROCEDURE Byte (byte: BYTE);
BEGIN
WRITER.WriteByte(UTILS.hexdgt(byte DIV 16));
WRITER.WriteByte(UTILS.hexdgt(byte MOD 16));
INC(chksum, byte)
END Byte;
PROCEDURE Byte4 (a, b, c, d: BYTE);
BEGIN
Byte(a);
Byte(b);
Byte(c);
Byte(d)
END Byte4;
PROCEDURE NewLine;
BEGIN
Byte((-chksum) MOD 256);
chksum := 0;
WRITER.WriteByte(0DH);
WRITER.WriteByte(0AH)
END NewLine;
PROCEDURE StartCode;
BEGIN
WRITER.WriteByte(ORD(":"));
chksum := 0
END StartCode;
PROCEDURE Data* (mem: ARRAY OF BYTE; idx, cnt: INTEGER);
VAR
i, len: INTEGER;
BEGIN
WHILE cnt > 0 DO
len := MIN(cnt, 16);
StartCode;
Byte4(len, idx DIV 256, idx MOD 256, 0);
FOR i := 1 TO len DO
Byte(mem[idx]);
INC(idx)
END;
DEC(cnt, len);
NewLine
END
END Data;
PROCEDURE ExtLA* (LA: INTEGER);
BEGIN
ASSERT((0 <= LA) & (LA <= 0FFFFH));
StartCode;
Byte4(2, 0, 0, 4);
Byte(LA DIV 256);
Byte(LA MOD 256);
NewLine
END ExtLA;
PROCEDURE Data2* (mem: CHL.BYTELIST; idx, cnt, LA: INTEGER);
VAR
i, len, offset: INTEGER;
BEGIN
ExtLA(LA);
offset := 0;
WHILE cnt > 0 DO
ASSERT(offset <= 65536);
IF offset = 65536 THEN
INC(LA);
ExtLA(LA);
offset := 0
END;
len := MIN(cnt, 16);
StartCode;
Byte4(len, offset DIV 256, offset MOD 256, 0);
FOR i := 1 TO len DO
Byte(CHL.GetByte(mem, idx));
INC(idx);
INC(offset)
END;
DEC(cnt, len);
NewLine
END
END Data2;
PROCEDURE End*;
BEGIN
StartCode;
Byte4(0, 0, 0, 1);
NewLine
END End;
END HEX.

/programs/develop/oberon07/source/KOS.ob07
0,0 → 1,206
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE KOS;
IMPORT BIN, WR := WRITER, LISTS, CHL := CHUNKLISTS;
CONST
HEADER_SIZE = 36;
SIZE_OF_DWORD = 4;
TYPE
HEADER = RECORD
menuet01: ARRAY 9 OF CHAR;
ver, start, size, mem, sp, param, path: INTEGER
END;
PROCEDURE Import* (program: BIN.PROGRAM; idata: INTEGER; VAR ImportTable: CHL.INTLIST; VAR len, libcount, size: INTEGER);
VAR
i: INTEGER;
imp: BIN.IMPRT;
BEGIN
libcount := 0;
imp := program.imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
INC(libcount)
END;
imp := imp.next(BIN.IMPRT)
END;
len := libcount * 2 + 2;
size := (LISTS.count(program.imp_list) + len + 1) * SIZE_OF_DWORD;
ImportTable := CHL.CreateIntList();
FOR i := 0 TO size DIV SIZE_OF_DWORD - 1 DO
CHL.PushInt(ImportTable, 0)
END;
i := 0;
imp := program.imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
CHL.SetInt(ImportTable, len, 0);
INC(len);
CHL.SetInt(ImportTable, i, idata + len * SIZE_OF_DWORD);
INC(i);
CHL.SetInt(ImportTable, i, imp.nameoffs + size + idata);
INC(i)
ELSE
CHL.SetInt(ImportTable, len, imp.nameoffs + size + idata);
imp.label := len * SIZE_OF_DWORD;
INC(len)
END;
imp := imp.next(BIN.IMPRT)
END;
CHL.SetInt(ImportTable, len, 0);
CHL.SetInt(ImportTable, i, 0);
CHL.SetInt(ImportTable, i + 1, 0);
INC(len);
INC(size, CHL.Length(program._import))
END Import;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR);
CONST
PARAM_SIZE = 2048;
FileAlignment = 16;
VAR
header: HEADER;
base, text, data, idata, bss, offset: INTEGER;
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
L: INTEGER;
delta: INTEGER;
i: INTEGER;
ImportTable: CHL.INTLIST;
ILen, libcount, isize: INTEGER;
icount, dcount, ccount: INTEGER;
code: CHL.BYTELIST;
BEGIN
base := 0;
icount := CHL.Length(program._import);
dcount := CHL.Length(program.data);
ccount := CHL.Length(program.code);
text := base + HEADER_SIZE;
data := WR.align(text + ccount, FileAlignment);
idata := WR.align(data + dcount, FileAlignment);
Import(program, idata, ImportTable, ILen, libcount, isize);
bss := WR.align(idata + isize, FileAlignment);
header.menuet01 := "MENUET01";
header.ver := 1;
header.start := text;
header.size := idata + isize - base;
header.mem := WR.align(header.size + program.stack + program.bss + PARAM_SIZE * 2 + 4096, FileAlignment);
header.sp := base + header.mem - PARAM_SIZE * 2;
header.param := header.sp;
header.path := header.param + PARAM_SIZE;
code := program.code;
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
offset := reloc.offset;
L := BIN.get32le(code, offset);
delta := 3 - offset - text;
CASE reloc.opcode OF
|BIN.RIMP:
iproc := BIN.GetIProc(program, L);
delta := idata + iproc.label
|BIN.RBSS:
delta := L + bss
|BIN.RDATA:
delta := L + data
|BIN.RCODE:
delta := BIN.GetLabel(program, L) + text
|BIN.PICDATA:
INC(delta, L + data)
|BIN.PICCODE:
INC(delta, BIN.GetLabel(program, L) + text)
|BIN.PICBSS:
INC(delta, L + bss)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
INC(delta, idata + iproc.label)
|BIN.IMPTAB:
INC(delta, idata)
END;
BIN.put32le(code, offset, delta);
reloc := reloc.next(BIN.RELOC)
END;
WR.Create(FileName);
FOR i := 0 TO 7 DO
WR.WriteByte(ORD(header.menuet01[i]))
END;
WR.Write32LE(header.ver);
WR.Write32LE(header.start);
WR.Write32LE(header.size);
WR.Write32LE(header.mem);
WR.Write32LE(header.sp);
WR.Write32LE(header.param);
WR.Write32LE(header.path);
CHL.WriteToFile(code);
WR.Padding(FileAlignment);
CHL.WriteToFile(program.data);
WR.Padding(FileAlignment);
FOR i := 0 TO ILen - 1 DO
WR.Write32LE(CHL.GetInt(ImportTable, i))
END;
CHL.WriteToFile(program._import);
WR.Close
END write;
END KOS.

/programs/develop/oberon07/source/MSCOFF.ob07
0,0 → 1,309
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE MSCOFF;
IMPORT BIN, PE32, KOS, WR := WRITER, UTILS, ERRORS, LISTS, CHL := CHUNKLISTS;
CONST
SIZE_OF_DWORD = 4;
(* SectionHeader.Characteristics *)
SHC_flat = 040500020H;
SHC_data = 0C0500040H;
SHC_bss = 0C03000C0H;
TYPE
FH = PE32.IMAGE_FILE_HEADER;
SH = PE32.IMAGE_SECTION_HEADER;
PROCEDURE WriteReloc (VirtualAddress, SymbolTableIndex, Type: INTEGER);
BEGIN
WR.Write32LE(VirtualAddress);
WR.Write32LE(SymbolTableIndex);
WR.Write16LE(Type)
END WriteReloc;
PROCEDURE Reloc (program: BIN.PROGRAM);
VAR
reloc: BIN.RELOC;
offset: INTEGER;
BEGIN
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
offset := reloc.offset;
CASE reloc.opcode OF
|BIN.RIMP,
BIN.IMPTAB: WriteReloc(offset, 4, 6)
|BIN.RBSS: WriteReloc(offset, 5, 6)
|BIN.RDATA: WriteReloc(offset, 2, 6)
|BIN.RCODE: WriteReloc(offset, 1, 6)
END;
reloc := reloc.next(BIN.RELOC)
END;
END Reloc;
PROCEDURE RelocCount (program: BIN.PROGRAM): INTEGER;
VAR
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
res, L: INTEGER;
offset: INTEGER;
code: CHL.BYTELIST;
BEGIN
res := 0;
code := program.code;
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
INC(res);
offset := reloc.offset;
IF reloc.opcode = BIN.RIMP THEN
L := BIN.get32le(code, offset);
iproc := BIN.GetIProc(program, L);
BIN.put32le(code, offset, iproc.label)
END;
IF reloc.opcode = BIN.RCODE THEN
L := BIN.get32le(code, offset);
BIN.put32le(code, offset, BIN.GetLabel(program, L))
END;
reloc := reloc.next(BIN.RELOC)
END
RETURN res
END RelocCount;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; ver: INTEGER);
VAR
exp: BIN.EXPRT;
n, i: INTEGER;
szversion: PE32.NAME;
ImportTable: CHL.INTLIST;
ILen, LibCount, isize: INTEGER;
ExpCount: INTEGER;
icount, ecount, dcount, ccount: INTEGER;
FileHeader: FH;
flat, data, edata, idata, bss: SH;
PROCEDURE ICount (ImportTable: CHL.INTLIST; ILen: INTEGER): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := 0;
FOR i := 0 TO ILen - 1 DO
IF CHL.GetInt(ImportTable, i) # 0 THEN
INC(res)
END
END
RETURN res
END ICount;
PROCEDURE SetNumberOfRelocations (VAR section: SH; NumberOfRelocations: INTEGER);
BEGIN
IF NumberOfRelocations >= 65536 THEN
ERRORS.Error(202)
END;
section.NumberOfRelocations := WCHR(NumberOfRelocations)
END SetNumberOfRelocations;
BEGIN
szversion := "version";
ASSERT(LENGTH(szversion) = 7);
KOS.Import(program, 0, ImportTable, ILen, LibCount, isize);
ExpCount := LISTS.count(program.exp_list);
icount := CHL.Length(program._import);
dcount := CHL.Length(program.data);
ccount := CHL.Length(program.code);
ecount := CHL.Length(program.export);
FileHeader.Machine := 014CX;
FileHeader.NumberOfSections := 5X;
FileHeader.TimeDateStamp := UTILS.UnixTime();
(* FileHeader.PointerToSymbolTable := 0; *)
FileHeader.NumberOfSymbols := 6;
FileHeader.SizeOfOptionalHeader := 0X;
FileHeader.Characteristics := 0184X;
flat.Name := ".flat";
flat.VirtualSize := 0;
flat.VirtualAddress := 0;
flat.SizeOfRawData := ccount;
flat.PointerToRawData := ORD(FileHeader.NumberOfSections) * PE32.SIZE_OF_IMAGE_SECTION_HEADER + PE32.SIZE_OF_IMAGE_FILE_HEADER;
(* flat.PointerToRelocations := 0; *)
flat.PointerToLinenumbers := 0;
SetNumberOfRelocations(flat, RelocCount(program));
flat.NumberOfLinenumbers := 0X;
flat.Characteristics := SHC_flat;
data.Name := ".data";
data.VirtualSize := 0;
data.VirtualAddress := 0;
data.SizeOfRawData := dcount;
data.PointerToRawData := flat.PointerToRawData + flat.SizeOfRawData;
data.PointerToRelocations := 0;
data.PointerToLinenumbers := 0;
data.NumberOfRelocations := 0X;
data.NumberOfLinenumbers := 0X;
data.Characteristics := SHC_data;
edata.Name := ".edata";
edata.VirtualSize := 0;
edata.VirtualAddress := 0;
edata.SizeOfRawData := ((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD + LENGTH(szversion) + 1 + ecount;
edata.PointerToRawData := data.PointerToRawData + data.SizeOfRawData;
(* edata.PointerToRelocations := 0; *)
edata.PointerToLinenumbers := 0;
SetNumberOfRelocations(edata, ExpCount * 2 + 1);
edata.NumberOfLinenumbers := 0X;
edata.Characteristics := SHC_data;
idata.Name := ".idata";
idata.VirtualSize := 0;
idata.VirtualAddress := 0;
idata.SizeOfRawData := isize;
idata.PointerToRawData := edata.PointerToRawData + edata.SizeOfRawData;
(* idata.PointerToRelocations := 0; *)
idata.PointerToLinenumbers := 0;
SetNumberOfRelocations(idata, ICount(ImportTable, ILen));
idata.NumberOfLinenumbers := 0X;
idata.Characteristics := SHC_data;
bss.Name := ".bss";
bss.VirtualSize := 0;
bss.VirtualAddress := 0;
bss.SizeOfRawData := program.bss;
bss.PointerToRawData := 0;
bss.PointerToRelocations := 0;
bss.PointerToLinenumbers := 0;
bss.NumberOfRelocations := 0X;
bss.NumberOfLinenumbers := 0X;
bss.Characteristics := SHC_bss;
flat.PointerToRelocations := idata.PointerToRawData + idata.SizeOfRawData;
edata.PointerToRelocations := flat.PointerToRelocations + ORD(flat.NumberOfRelocations) * 10;
idata.PointerToRelocations := edata.PointerToRelocations + ORD(edata.NumberOfRelocations) * 10;
FileHeader.PointerToSymbolTable := idata.PointerToRelocations + ORD(idata.NumberOfRelocations) * 10;
WR.Create(FileName);
PE32.WriteFileHeader(FileHeader);
PE32.WriteSectionHeader(flat);
PE32.WriteSectionHeader(data);
PE32.WriteSectionHeader(edata);
PE32.WriteSectionHeader(idata);
PE32.WriteSectionHeader(bss);
CHL.WriteToFile(program.code);
CHL.WriteToFile(program.data);
exp := program.exp_list.first(BIN.EXPRT);
WHILE exp # NIL DO
WR.Write32LE(exp.nameoffs + edata.SizeOfRawData - ecount);
WR.Write32LE(exp.label);
exp := exp.next(BIN.EXPRT)
END;
WR.Write32LE(((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD);
WR.Write32LE(ver);
WR.Write32LE(0);
PE32.WriteName(szversion);
CHL.WriteToFile(program.export);
FOR i := 0 TO ILen - 1 DO
WR.Write32LE(CHL.GetInt(ImportTable, i))
END;
CHL.WriteToFile(program._import);
Reloc(program);
n := 0;
exp := program.exp_list.first(BIN.EXPRT);
WHILE exp # NIL DO
WriteReloc(n, 3, 6);
INC(n, 4);
WriteReloc(n, 1, 6);
INC(n, 4);
exp := exp.next(BIN.EXPRT)
END;
WriteReloc(n, 3, 6);
FOR i := 0 TO LibCount * 2 - 1 DO
WriteReloc(i * SIZE_OF_DWORD, 4, 6)
END;
FOR i := LibCount * 2 TO ILen - 1 DO
IF CHL.GetInt(ImportTable, i) # 0 THEN
WriteReloc(i * SIZE_OF_DWORD, 4, 6)
END
END;
PE32.WriteName("EXPORTS");
WriteReloc(0, 3, 2);
PE32.WriteName(".flat");
WriteReloc(0, 1, 3);
PE32.WriteName(".data");
WriteReloc(0, 2, 3);
PE32.WriteName(".edata");
WriteReloc(0, 3, 3);
PE32.WriteName(".idata");
WriteReloc(0, 4, 3);
PE32.WriteName(".bss");
WriteReloc(0, 5, 3);
WR.Write32LE(4);
WR.Close
END write;
END MSCOFF.

/programs/develop/oberon07/source/PE32.ob07
0,0 → 1,695
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE PE32;
IMPORT BIN, LISTS, UTILS, WR := WRITER, CHL := CHUNKLISTS;
CONST
SIZE_OF_DWORD = 4;
SIZE_OF_WORD = 2;
SIZE_OF_IMAGE_EXPORT_DIRECTORY = 40;
IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16;
IMAGE_SIZEOF_SHORT_NAME = 8;
SIZE_OF_IMAGE_FILE_HEADER* = 20;
SIZE_OF_IMAGE_SECTION_HEADER* = 40;
(* SectionHeader.Characteristics *)
SHC_text = 060000020H;
SHC_data = 040000040H;
SHC_bss = 0C0000080H;
SectionAlignment = 1000H;
FileAlignment = 200H;
TYPE
WORD = WCHAR;
DWORD = INTEGER;
NAME* = ARRAY IMAGE_SIZEOF_SHORT_NAME OF CHAR;
IMAGE_DATA_DIRECTORY = RECORD
VirtualAddress: DWORD;
Size: DWORD
END;
IMAGE_OPTIONAL_HEADER = RECORD
Magic: WORD;
MajorLinkerVersion: BYTE;
MinorLinkerVersion: BYTE;
SizeOfCode: DWORD;
SizeOfInitializedData: DWORD;
SizeOfUninitializedData: DWORD;
AddressOfEntryPoint: DWORD;
BaseOfCode: DWORD;
BaseOfData: DWORD;
ImageBase: DWORD;
SectionAlignment: DWORD;
FileAlignment: DWORD;
MajorOperatingSystemVersion: WORD;
MinorOperatingSystemVersion: WORD;
MajorImageVersion: WORD;
MinorImageVersion: WORD;
MajorSubsystemVersion: WORD;
MinorSubsystemVersion: WORD;
Win32VersionValue: DWORD;
SizeOfImage: DWORD;
SizeOfHeaders: DWORD;
CheckSum: DWORD;
Subsystem: WORD;
DllCharacteristics: WORD;
SizeOfStackReserve: DWORD;
SizeOfStackCommit: DWORD;
SizeOfHeapReserve: DWORD;
SizeOfHeapCommit: DWORD;
LoaderFlags: DWORD;
NumberOfRvaAndSizes: DWORD;
DataDirectory: ARRAY IMAGE_NUMBEROF_DIRECTORY_ENTRIES OF IMAGE_DATA_DIRECTORY
END;
IMAGE_FILE_HEADER* = RECORD
Machine*: WORD;
NumberOfSections*: WORD;
TimeDateStamp*: DWORD;
PointerToSymbolTable*: DWORD;
NumberOfSymbols*: DWORD;
SizeOfOptionalHeader*: WORD;
Characteristics*: WORD
END;
IMAGE_SECTION_HEADER* = RECORD
Name*: NAME;
VirtualSize*,
VirtualAddress*,
SizeOfRawData*,
PointerToRawData*,
PointerToRelocations*,
PointerToLinenumbers*: DWORD;
NumberOfRelocations*,
NumberOfLinenumbers*: WORD;
Characteristics*: DWORD
END;
IMAGE_EXPORT_DIRECTORY = RECORD
Characteristics: DWORD;
TimeDateStamp: DWORD;
MajorVersion: WORD;
MinorVersion: WORD;
Name,
Base,
NumberOfFunctions,
NumberOfNames,
AddressOfFunctions,
AddressOfNames,
AddressOfNameOrdinals: DWORD
END;
VIRTUAL_ADDR* = RECORD
Code*, Data*, Bss*, Import*: INTEGER
END;
VAR
Signature: ARRAY 4 OF BYTE;
FileHeader: IMAGE_FILE_HEADER;
OptionalHeader: IMAGE_OPTIONAL_HEADER;
msdos: ARRAY 128 OF BYTE;
SectionHeaders: ARRAY 16 OF IMAGE_SECTION_HEADER;
libcnt: INTEGER;
SizeOfWord: INTEGER;
PROCEDURE Export (program: BIN.PROGRAM; name: INTEGER; VAR ExportDir: IMAGE_EXPORT_DIRECTORY): INTEGER;
BEGIN
ExportDir.Characteristics := 0;
ExportDir.TimeDateStamp := FileHeader.TimeDateStamp;
ExportDir.MajorVersion := 0X;
ExportDir.MinorVersion := 0X;
ExportDir.Name := name;
ExportDir.Base := 0;
ExportDir.NumberOfFunctions := LISTS.count(program.exp_list);
ExportDir.NumberOfNames := ExportDir.NumberOfFunctions;
ExportDir.AddressOfFunctions := SIZE_OF_IMAGE_EXPORT_DIRECTORY;
ExportDir.AddressOfNames := ExportDir.AddressOfFunctions + ExportDir.NumberOfFunctions * SIZE_OF_DWORD;
ExportDir.AddressOfNameOrdinals := ExportDir.AddressOfNames + ExportDir.NumberOfFunctions * SIZE_OF_DWORD
RETURN SIZE_OF_IMAGE_EXPORT_DIRECTORY + ExportDir.NumberOfFunctions * (2 * SIZE_OF_DWORD + SIZE_OF_WORD)
END Export;
PROCEDURE GetProcCount (lib: BIN.IMPRT): INTEGER;
VAR
imp: BIN.IMPRT;
res: INTEGER;
BEGIN
res := 0;
imp := lib.next(BIN.IMPRT);
WHILE (imp # NIL) & (imp.label # 0) DO
INC(res);
imp := imp.next(BIN.IMPRT)
END
RETURN res
END GetProcCount;
PROCEDURE GetImportSize (imp_list: LISTS.LIST): INTEGER;
VAR
imp: BIN.IMPRT;
proccnt: INTEGER;
procoffs: INTEGER;
OriginalCurrentThunk,
CurrentThunk: INTEGER;
BEGIN
libcnt := 0;
proccnt := 0;
imp := imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
INC(libcnt)
ELSE
INC(proccnt)
END;
imp := imp.next(BIN.IMPRT)
END;
procoffs := 0;
imp := imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
imp.OriginalFirstThunk := procoffs;
imp.FirstThunk := procoffs + (GetProcCount(imp) + 1);
OriginalCurrentThunk := imp.OriginalFirstThunk;
CurrentThunk := imp.FirstThunk;
INC(procoffs, (GetProcCount(imp) + 1) * 2)
ELSE
imp.OriginalFirstThunk := OriginalCurrentThunk;
imp.FirstThunk := CurrentThunk;
INC(OriginalCurrentThunk);
INC(CurrentThunk)
END;
imp := imp.next(BIN.IMPRT)
END
RETURN (libcnt + 1) * 5 * SIZE_OF_DWORD + (proccnt + libcnt) * 2 * SizeOfWord
END GetImportSize;
PROCEDURE fixup* (program: BIN.PROGRAM; Address: VIRTUAL_ADDR; amd64: BOOLEAN);
VAR
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
code: CHL.BYTELIST;
L, delta, delta0, AdrImp, offset: INTEGER;
BEGIN
AdrImp := Address.Import + (libcnt + 1) * 5 * SIZE_OF_DWORD;
code := program.code;
reloc := program.rel_list.first(BIN.RELOC);
delta0 := 3 - 7 * ORD(amd64) - Address.Code;
WHILE reloc # NIL DO
offset := reloc.offset;
L := BIN.get32le(code, offset);
delta := delta0 - offset;
CASE reloc.opcode OF
|BIN.PICDATA:
INC(delta, L + Address.Data)
|BIN.PICCODE:
INC(delta, BIN.GetLabel(program, L) + Address.Code)
|BIN.PICBSS:
INC(delta, L + Address.Bss)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
INC(delta, iproc.FirstThunk * SizeOfWord + AdrImp)
END;
BIN.put32le(code, offset, delta);
reloc := reloc.next(BIN.RELOC)
END
END fixup;
PROCEDURE WriteWord (w: WORD);
BEGIN
WR.Write16LE(ORD(w))
END WriteWord;
PROCEDURE WriteName* (name: NAME);
VAR
i, nameLen: INTEGER;
BEGIN
nameLen := LENGTH(name);
FOR i := 0 TO nameLen - 1 DO
WR.WriteByte(ORD(name[i]))
END;
i := LEN(name) - nameLen;
WHILE i > 0 DO
WR.WriteByte(0);
DEC(i)
END
END WriteName;
PROCEDURE WriteSectionHeader* (h: IMAGE_SECTION_HEADER);
VAR
i, nameLen: INTEGER;
BEGIN
nameLen := LENGTH(h.Name);
FOR i := 0 TO nameLen - 1 DO
WR.WriteByte(ORD(h.Name[i]))
END;
i := LEN(h.Name) - nameLen;
WHILE i > 0 DO
WR.WriteByte(0);
DEC(i)
END;
WR.Write32LE(h.VirtualSize);
WR.Write32LE(h.VirtualAddress);
WR.Write32LE(h.SizeOfRawData);
WR.Write32LE(h.PointerToRawData);
WR.Write32LE(h.PointerToRelocations);
WR.Write32LE(h.PointerToLinenumbers);
WriteWord(h.NumberOfRelocations);
WriteWord(h.NumberOfLinenumbers);
WR.Write32LE(h.Characteristics)
END WriteSectionHeader;
PROCEDURE WriteFileHeader* (h: IMAGE_FILE_HEADER);
BEGIN
WriteWord(h.Machine);
WriteWord(h.NumberOfSections);
WR.Write32LE(h.TimeDateStamp);
WR.Write32LE(h.PointerToSymbolTable);
WR.Write32LE(h.NumberOfSymbols);
WriteWord(h.SizeOfOptionalHeader);
WriteWord(h.Characteristics)
END WriteFileHeader;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; console, dll, amd64: BOOLEAN);
VAR
i, n, temp: INTEGER;
Size: RECORD
Code, Data, Bss, Import, Reloc, Export: INTEGER
END;
BaseAddress: INTEGER;
Address: VIRTUAL_ADDR;
_import: BIN.IMPRT;
ImportTable: CHL.INTLIST;
ExportDir: IMAGE_EXPORT_DIRECTORY;
export: BIN.EXPRT;
PROCEDURE WriteExportDir (e: IMAGE_EXPORT_DIRECTORY);
BEGIN
WR.Write32LE(e.Characteristics);
WR.Write32LE(e.TimeDateStamp);
WriteWord(e.MajorVersion);
WriteWord(e.MinorVersion);
WR.Write32LE(e.Name);
WR.Write32LE(e.Base);
WR.Write32LE(e.NumberOfFunctions);
WR.Write32LE(e.NumberOfNames);
WR.Write32LE(e.AddressOfFunctions);
WR.Write32LE(e.AddressOfNames);
WR.Write32LE(e.AddressOfNameOrdinals)
END WriteExportDir;
PROCEDURE WriteOptHeader (h: IMAGE_OPTIONAL_HEADER; amd64: BOOLEAN);
VAR
i: INTEGER;
BEGIN
WriteWord(h.Magic);
WR.WriteByte(h.MajorLinkerVersion);
WR.WriteByte(h.MinorLinkerVersion);
WR.Write32LE(h.SizeOfCode);
WR.Write32LE(h.SizeOfInitializedData);
WR.Write32LE(h.SizeOfUninitializedData);
WR.Write32LE(h.AddressOfEntryPoint);
WR.Write32LE(h.BaseOfCode);
IF amd64 THEN
WR.Write64LE(h.ImageBase)
ELSE
WR.Write32LE(h.BaseOfData);
WR.Write32LE(h.ImageBase)
END;
WR.Write32LE(h.SectionAlignment);
WR.Write32LE(h.FileAlignment);
WriteWord(h.MajorOperatingSystemVersion);
WriteWord(h.MinorOperatingSystemVersion);
WriteWord(h.MajorImageVersion);
WriteWord(h.MinorImageVersion);
WriteWord(h.MajorSubsystemVersion);
WriteWord(h.MinorSubsystemVersion);
WR.Write32LE(h.Win32VersionValue);
WR.Write32LE(h.SizeOfImage);
WR.Write32LE(h.SizeOfHeaders);
WR.Write32LE(h.CheckSum);
WriteWord(h.Subsystem);
WriteWord(h.DllCharacteristics);
IF amd64 THEN
WR.Write64LE(h.SizeOfStackReserve);
WR.Write64LE(h.SizeOfStackCommit);
WR.Write64LE(h.SizeOfHeapReserve);
WR.Write64LE(h.SizeOfHeapCommit)
ELSE
WR.Write32LE(h.SizeOfStackReserve);
WR.Write32LE(h.SizeOfStackCommit);
WR.Write32LE(h.SizeOfHeapReserve);
WR.Write32LE(h.SizeOfHeapCommit)
END;
WR.Write32LE(h.LoaderFlags);
WR.Write32LE(h.NumberOfRvaAndSizes);
FOR i := 0 TO LEN(h.DataDirectory) - 1 DO
WR.Write32LE(h.DataDirectory[i].VirtualAddress);
WR.Write32LE(h.DataDirectory[i].Size)
END
END WriteOptHeader;
PROCEDURE InitSection (VAR section: IMAGE_SECTION_HEADER; Name: NAME; VirtualSize: INTEGER; Characteristics: DWORD);
BEGIN
section.Name := Name;
section.VirtualSize := VirtualSize;
section.SizeOfRawData := WR.align(VirtualSize, FileAlignment);
section.PointerToRelocations := 0;
section.PointerToLinenumbers := 0;
section.NumberOfRelocations := 0X;
section.NumberOfLinenumbers := 0X;
section.Characteristics := Characteristics
END InitSection;
BEGIN
SizeOfWord := SIZE_OF_DWORD * (ORD(amd64) + 1);
Size.Code := CHL.Length(program.code);
Size.Data := CHL.Length(program.data);
Size.Bss := program.bss;
IF dll THEN
BaseAddress := 10000000H
ELSE
BaseAddress := 400000H
END;
Signature[0] := 50H;
Signature[1] := 45H;
Signature[2] := 0;
Signature[3] := 0;
IF amd64 THEN
FileHeader.Machine := 08664X
ELSE
FileHeader.Machine := 014CX
END;
FileHeader.NumberOfSections := WCHR(4 + ORD(dll));
FileHeader.TimeDateStamp := UTILS.UnixTime();
FileHeader.PointerToSymbolTable := 0H;
FileHeader.NumberOfSymbols := 0H;
FileHeader.SizeOfOptionalHeader := WCHR(0E0H + 10H * ORD(amd64));
FileHeader.Characteristics := WCHR(010EH + (20H - 100H) * ORD(amd64) + 2000H * ORD(dll));
OptionalHeader.Magic := WCHR(010BH + 100H * ORD(amd64));
OptionalHeader.MajorLinkerVersion := UTILS.vMajor;
OptionalHeader.MinorLinkerVersion := UTILS.vMinor;
OptionalHeader.SizeOfCode := WR.align(Size.Code, FileAlignment);
OptionalHeader.SizeOfInitializedData := 0;
OptionalHeader.SizeOfUninitializedData := 0;
OptionalHeader.AddressOfEntryPoint := SectionAlignment;
OptionalHeader.BaseOfCode := SectionAlignment;
OptionalHeader.BaseOfData := OptionalHeader.BaseOfCode + WR.align(Size.Code, SectionAlignment);
OptionalHeader.ImageBase := BaseAddress;
OptionalHeader.SectionAlignment := SectionAlignment;
OptionalHeader.FileAlignment := FileAlignment;
OptionalHeader.MajorOperatingSystemVersion := 1X;
OptionalHeader.MinorOperatingSystemVersion := 0X;
OptionalHeader.MajorImageVersion := 0X;
OptionalHeader.MinorImageVersion := 0X;
OptionalHeader.MajorSubsystemVersion := 4X;
OptionalHeader.MinorSubsystemVersion := 0X;
OptionalHeader.Win32VersionValue := 0H;
OptionalHeader.SizeOfImage := SectionAlignment;
OptionalHeader.SizeOfHeaders := 400H;
OptionalHeader.CheckSum := 0;
OptionalHeader.Subsystem := WCHR((2 + ORD(console)) * ORD(~dll));
OptionalHeader.DllCharacteristics := 0040X;
OptionalHeader.SizeOfStackReserve := 100000H;
OptionalHeader.SizeOfStackCommit := 10000H;
OptionalHeader.SizeOfHeapReserve := 100000H;
OptionalHeader.SizeOfHeapCommit := 10000H;
OptionalHeader.LoaderFlags := 0;
OptionalHeader.NumberOfRvaAndSizes := IMAGE_NUMBEROF_DIRECTORY_ENTRIES;
FOR i := 0 TO IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1 DO
OptionalHeader.DataDirectory[i].VirtualAddress := 0;
OptionalHeader.DataDirectory[i].Size := 0
END;
InitSection(SectionHeaders[0], ".text", Size.Code, SHC_text);
SectionHeaders[0].VirtualAddress := SectionAlignment;
SectionHeaders[0].PointerToRawData := OptionalHeader.SizeOfHeaders;
InitSection(SectionHeaders[1], ".data", Size.Data, SHC_data);
SectionHeaders[1].VirtualAddress := WR.align(SectionHeaders[0].VirtualAddress + SectionHeaders[0].VirtualSize, SectionAlignment);
SectionHeaders[1].PointerToRawData := SectionHeaders[0].PointerToRawData + SectionHeaders[0].SizeOfRawData;
InitSection(SectionHeaders[2], ".bss", Size.Bss, SHC_bss);
SectionHeaders[2].VirtualAddress := WR.align(SectionHeaders[1].VirtualAddress + SectionHeaders[1].VirtualSize, SectionAlignment);
SectionHeaders[2].PointerToRawData := SectionHeaders[1].PointerToRawData + SectionHeaders[1].SizeOfRawData;
SectionHeaders[2].SizeOfRawData := 0;
Size.Import := GetImportSize(program.imp_list);
InitSection(SectionHeaders[3], ".idata", Size.Import + CHL.Length(program._import), SHC_data);
SectionHeaders[3].VirtualAddress := WR.align(SectionHeaders[2].VirtualAddress + SectionHeaders[2].VirtualSize, SectionAlignment);
SectionHeaders[3].PointerToRawData := SectionHeaders[2].PointerToRawData + SectionHeaders[2].SizeOfRawData;
Address.Code := SectionHeaders[0].VirtualAddress + OptionalHeader.ImageBase;
Address.Data := SectionHeaders[1].VirtualAddress + OptionalHeader.ImageBase;
Address.Bss := SectionHeaders[2].VirtualAddress + OptionalHeader.ImageBase;
Address.Import := SectionHeaders[3].VirtualAddress + OptionalHeader.ImageBase;
fixup(program, Address, amd64);
IF dll THEN
Size.Export := Export(program, SectionHeaders[1].VirtualAddress + program.modname, ExportDir);
InitSection(SectionHeaders[4], ".edata", Size.Export + CHL.Length(program.export), SHC_data);
SectionHeaders[4].VirtualAddress := WR.align(SectionHeaders[3].VirtualAddress + SectionHeaders[3].VirtualSize, SectionAlignment);
SectionHeaders[4].PointerToRawData := SectionHeaders[3].PointerToRawData + SectionHeaders[3].SizeOfRawData;
OptionalHeader.DataDirectory[0].VirtualAddress := SectionHeaders[4].VirtualAddress;
OptionalHeader.DataDirectory[0].Size := SectionHeaders[4].VirtualSize
END;
OptionalHeader.DataDirectory[1].VirtualAddress := SectionHeaders[3].VirtualAddress;
OptionalHeader.DataDirectory[1].Size := SectionHeaders[3].VirtualSize;
FOR i := 1 TO ORD(FileHeader.NumberOfSections) - 1 DO
INC(OptionalHeader.SizeOfInitializedData, SectionHeaders[i].SizeOfRawData)
END;
OptionalHeader.SizeOfUninitializedData := WR.align(SectionHeaders[2].VirtualSize, FileAlignment);
FOR i := 0 TO ORD(FileHeader.NumberOfSections) - 1 DO
INC(OptionalHeader.SizeOfImage, WR.align(SectionHeaders[i].VirtualSize, SectionAlignment))
END;
n := 0;
BIN.InitArray(msdos, n, "4D5A80000100000004001000FFFF000040010000000000004000000000000000");
BIN.InitArray(msdos, n, "0000000000000000000000000000000000000000000000000000000080000000");
BIN.InitArray(msdos, n, "0E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F");
BIN.InitArray(msdos, n, "742062652072756E20696E20444F53206D6F64652E0D0A240000000000000000");
WR.Create(FileName);
WR.Write(msdos, LEN(msdos));
WR.Write(Signature, LEN(Signature));
WriteFileHeader(FileHeader);
WriteOptHeader(OptionalHeader, amd64);
FOR i := 0 TO ORD(FileHeader.NumberOfSections) - 1 DO
WriteSectionHeader(SectionHeaders[i])
END;
WR.Padding(FileAlignment);
CHL.WriteToFile(program.code);
WR.Padding(FileAlignment);
CHL.WriteToFile(program.data);
WR.Padding(FileAlignment);
n := (libcnt + 1) * 5;
ImportTable := CHL.CreateIntList();
FOR i := 0 TO (Size.Import - n * SIZE_OF_DWORD) DIV SizeOfWord + n - 1 DO
CHL.PushInt(ImportTable, 0)
END;
i := 0;
_import := program.imp_list.first(BIN.IMPRT);
WHILE _import # NIL DO
IF _import.label = 0 THEN
CHL.SetInt(ImportTable, i + 0, _import.OriginalFirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
CHL.SetInt(ImportTable, i + 1, 0);
CHL.SetInt(ImportTable, i + 2, 0);
CHL.SetInt(ImportTable, i + 3, _import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress);
CHL.SetInt(ImportTable, i + 4, _import.FirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
INC(i, 5)
END;
_import := _import.next(BIN.IMPRT)
END;
CHL.SetInt(ImportTable, i + 0, 0);
CHL.SetInt(ImportTable, i + 1, 0);
CHL.SetInt(ImportTable, i + 2, 0);
CHL.SetInt(ImportTable, i + 3, 0);
CHL.SetInt(ImportTable, i + 4, 0);
_import := program.imp_list.first(BIN.IMPRT);
WHILE _import # NIL DO
IF _import.label # 0 THEN
temp := _import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress - 2;
CHL.SetInt(ImportTable, _import.OriginalFirstThunk + n, temp);
CHL.SetInt(ImportTable, _import.FirstThunk + n, temp)
END;
_import := _import.next(BIN.IMPRT)
END;
FOR i := 0 TO n - 1 DO
WR.Write32LE(CHL.GetInt(ImportTable, i))
END;
FOR i := n TO CHL.Length(ImportTable) - 1 DO
IF amd64 THEN
WR.Write64LE(CHL.GetInt(ImportTable, i))
ELSE
WR.Write32LE(CHL.GetInt(ImportTable, i))
END
END;
CHL.WriteToFile(program._import);
WR.Padding(FileAlignment);
IF dll THEN
INC(ExportDir.AddressOfFunctions, SectionHeaders[4].VirtualAddress);
INC(ExportDir.AddressOfNames, SectionHeaders[4].VirtualAddress);
INC(ExportDir.AddressOfNameOrdinals, SectionHeaders[4].VirtualAddress);
WriteExportDir(ExportDir);
export := program.exp_list.first(BIN.EXPRT);
WHILE export # NIL DO
WR.Write32LE(export.label + SectionHeaders[0].VirtualAddress);
export := export.next(BIN.EXPRT)
END;
export := program.exp_list.first(BIN.EXPRT);
WHILE export # NIL DO
WR.Write32LE(export.nameoffs + Size.Export + SectionHeaders[4].VirtualAddress);
export := export.next(BIN.EXPRT)
END;
FOR i := 0 TO ExportDir.NumberOfFunctions - 1 DO
WriteWord(WCHR(i))
END;
CHL.WriteToFile(program.export);
WR.Padding(FileAlignment)
END;
WR.Close
END write;
END PE32.

/programs/develop/oberon07/source/RVM32I.ob07
0,0 → 1,1302
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE RVM32I;
IMPORT
PROG, WR := WRITER, IL, CHL := CHUNKLISTS, REG, UTILS, STRINGS, ERRORS;
CONST
LTypes = 0;
LStrings = 1;
LGlobal = 2;
LHeap = 3;
LStack = 4;
numGPRs = 3;
R0 = 0; R1 = 1;
BP = 3; SP = 4;
ACC = R0;
GPRs = {0 .. 2} + {5 .. numGPRs + 1};
opSTOP = 0; opRET = 1; opENTER = 2; opNEG = 3; opNOT = 4; opABS = 5;
opXCHG = 6; opLDR8 = 7; opLDR16 = 8; opLDR32 = 9; opPUSH = 10; opPUSHC = 11;
opPOP = 12; opJGZ = 13; opJZ = 14; opJNZ = 15; opLLA = 16; opJGA = 17;
opJLA = 18; opJMP = 19; opCALL = 20; opCALLI = 21;
opMOV = 22; opMUL = 24; opADD = 26; opSUB = 28; opDIV = 30; opMOD = 32;
opSTR8 = 34; opSTR16 = 36; opSTR32 = 38; opINCL = 40; opEXCL = 42;
opIN = 44; opAND = 46; opOR = 48; opXOR = 50; opASR = 52; opLSR = 54;
opLSL = 56; opROR = 58; opMIN = 60; opMAX = 62; opEQ = 64; opNE = 66;
opLT = 68; opLE = 70; opGT = 72; opGE = 74; opBT = 76;
opMOVC = 23; opMULC = 25; opADDC = 27; opSUBC = 29; opDIVC = 31; opMODC = 33;
opSTR8C = 35; opSTR16C = 37; opSTR32C = 39; opINCLC = 41; opEXCLC = 43;
opINC = 45; opANDC = 47; opORC = 49; opXORC = 51; opASRC = 53; opLSRC = 55;
opLSLC = 57; opRORC = 59; opMINC = 61; opMAXC = 63; opEQC = 65; opNEC = 67;
opLTC = 69; opLEC = 71; opGTC = 73; opGEC = 75; opBTC = 77;
opLEA = 78; opLABEL = 79;
inf = 7F800000H;
VAR
R: REG.REGS; count: INTEGER;
PROCEDURE OutByte (n: BYTE);
BEGIN
WR.WriteByte(n);
INC(count)
END OutByte;
PROCEDURE OutInt (n: INTEGER);
BEGIN
WR.Write32LE(n);
INC(count, 4)
END OutInt;
PROCEDURE Emit (op, par1, par2: INTEGER);
BEGIN
OutInt(op);
OutInt(par1);
OutInt(par2)
END Emit;
PROCEDURE drop;
BEGIN
REG.Drop(R)
END drop;
PROCEDURE GetAnyReg (): INTEGER;
RETURN REG.GetAnyReg(R)
END GetAnyReg;
PROCEDURE GetAcc;
BEGIN
ASSERT(REG.GetReg(R, ACC))
END GetAcc;
PROCEDURE UnOp (VAR r: INTEGER);
BEGIN
REG.UnOp(R, r)
END UnOp;
PROCEDURE BinOp (VAR r1, r2: INTEGER);
BEGIN
REG.BinOp(R, r1, r2)
END BinOp;
PROCEDURE PushAll (NumberOfParameters: INTEGER);
BEGIN
REG.PushAll(R);
DEC(R.pushed, NumberOfParameters)
END PushAll;
PROCEDURE push (r: INTEGER);
BEGIN
Emit(opPUSH, r, 0)
END push;
PROCEDURE pop (r: INTEGER);
BEGIN
Emit(opPOP, r, 0)
END pop;
PROCEDURE mov (r1, r2: INTEGER);
BEGIN
Emit(opMOV, r1, r2)
END mov;
PROCEDURE xchg (r1, r2: INTEGER);
BEGIN
Emit(opXCHG, r1, r2)
END xchg;
PROCEDURE addrc (r, c: INTEGER);
BEGIN
Emit(opADDC, r, c)
END addrc;
PROCEDURE subrc (r, c: INTEGER);
BEGIN
Emit(opSUBC, r, c)
END subrc;
PROCEDURE movrc (r, c: INTEGER);
BEGIN
Emit(opMOVC, r, c)
END movrc;
PROCEDURE pushc (c: INTEGER);
BEGIN
Emit(opPUSHC, c, 0)
END pushc;
PROCEDURE add (r1, r2: INTEGER);
BEGIN
Emit(opADD, r1, r2)
END add;
PROCEDURE sub (r1, r2: INTEGER);
BEGIN
Emit(opSUB, r1, r2)
END sub;
PROCEDURE ldr32 (r1, r2: INTEGER);
BEGIN
Emit(opLDR32, r1, r2)
END ldr32;
PROCEDURE ldr16 (r1, r2: INTEGER);
BEGIN
Emit(opLDR16, r1, r2)
END ldr16;
PROCEDURE ldr8 (r1, r2: INTEGER);
BEGIN
Emit(opLDR8, r1, r2)
END ldr8;
PROCEDURE str32 (r1, r2: INTEGER);
BEGIN
Emit(opSTR32, r1, r2)
END str32;
PROCEDURE str16 (r1, r2: INTEGER);
BEGIN
Emit(opSTR16, r1, r2)
END str16;
PROCEDURE str8 (r1, r2: INTEGER);
BEGIN
Emit(opSTR8, r1, r2)
END str8;
PROCEDURE GlobalAdr (r, offset: INTEGER);
BEGIN
Emit(opLEA, r + 256 * LGlobal, offset)
END GlobalAdr;
PROCEDURE StrAdr (r, offset: INTEGER);
BEGIN
Emit(opLEA, r + 256 * LStrings, offset)
END StrAdr;
PROCEDURE ProcAdr (r, label: INTEGER);
BEGIN
Emit(opLLA, r, label)
END ProcAdr;
PROCEDURE jnz (r, label: INTEGER);
BEGIN
Emit(opJNZ, r, label)
END jnz;
PROCEDURE CallRTL (proc, par: INTEGER);
BEGIN
Emit(opCALL, IL.codes.rtl[proc], 0);
addrc(SP, par * 4)
END CallRTL;
PROCEDURE translate;
VAR
cmd: IL.COMMAND;
opcode, param1, param2: INTEGER;
r1, r2, r3: INTEGER;
BEGIN
cmd := IL.codes.commands.first(IL.COMMAND);
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
opcode := cmd.opcode;
CASE opcode OF
|IL.opJMP:
Emit(opJMP, param1, 0)
|IL.opLABEL:
Emit(opLABEL, param1, 0)
|IL.opCALL:
Emit(opCALL, param1, 0)
|IL.opCALLP:
UnOp(r1);
Emit(opCALLI, r1, 0);
drop;
ASSERT(R.top = -1)
|IL.opPUSHC:
pushc(param2)
|IL.opCLEANUP:
IF param2 # 0 THEN
addrc(SP, param2 * 4)
END
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opSADR:
StrAdr(GetAnyReg(), param2)
|IL.opGADR:
GlobalAdr(GetAnyReg(), param2)
|IL.opLADR:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4)
|IL.opPARAM:
IF param2 = 1 THEN
UnOp(r1);
push(r1);
drop
ELSE
ASSERT(R.top + 1 <= param2);
PushAll(param2)
END
|IL.opONERR:
pushc(param2);
Emit(opJMP, param1, 0)
|IL.opPRECALL:
PushAll(0)
|IL.opRES, IL.opRESF:
ASSERT(R.top = -1);
GetAcc
|IL.opENTER:
ASSERT(R.top = -1);
Emit(opLABEL, param1, 0);
Emit(opENTER, param2, 0)
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF:
IF opcode # IL.opLEAVE THEN
UnOp(r1);
IF r1 # ACC THEN
GetAcc;
ASSERT(REG.Exchange(R, r1, ACC));
drop
END;
drop
END;
ASSERT(R.top = -1);
IF param1 > 0 THEN
mov(SP, BP)
END;
pop(BP);
Emit(opRET, 0, 0)
|IL.opLEAVEC:
Emit(opRET, 0, 0)
|IL.opCONST:
movrc(GetAnyReg(), param2)
|IL.opDROP:
UnOp(r1);
drop
|IL.opSAVEC:
UnOp(r1);
Emit(opSTR32C, r1, param2);
drop
|IL.opSAVE8C:
UnOp(r1);
Emit(opSTR8C, r1, param2 MOD 256);
drop
|IL.opSAVE16C:
UnOp(r1);
Emit(opSTR16C, r1, param2 MOD 65536);
drop
|IL.opSAVE, IL.opSAVE32, IL.opSAVEF:
BinOp(r2, r1);
str32(r1, r2);
drop;
drop
|IL.opSAVEFI:
BinOp(r2, r1);
str32(r2, r1);
drop;
drop
|IL.opSAVE8:
BinOp(r2, r1);
str8(r1, r2);
drop;
drop
|IL.opSAVE16:
BinOp(r2, r1);
str16(r1, r2);
drop;
drop
|IL.opGLOAD32:
r1 := GetAnyReg();
GlobalAdr(r1, param2);
ldr32(r1, r1)
|IL.opVADR, IL.opLLOAD32:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr32(r1, r1)
|IL.opVLOAD32:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr32(r1, r1);
ldr32(r1, r1)
|IL.opGLOAD16:
r1 := GetAnyReg();
GlobalAdr(r1, param2);
ldr16(r1, r1)
|IL.opLLOAD16:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr16(r1, r1)
|IL.opVLOAD16:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr32(r1, r1);
ldr16(r1, r1)
|IL.opGLOAD8:
r1 := GetAnyReg();
GlobalAdr(r1, param2);
ldr8(r1, r1)
|IL.opLLOAD8:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr8(r1, r1)
|IL.opVLOAD8:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr32(r1, r1);
ldr8(r1, r1)
|IL.opLOAD8:
UnOp(r1);
ldr8(r1, r1)
|IL.opLOAD16:
UnOp(r1);
ldr16(r1, r1)
|IL.opLOAD32, IL.opLOADF:
UnOp(r1);
ldr32(r1, r1)
|IL.opLOOP, IL.opENDLOOP:
|IL.opUMINUS:
UnOp(r1);
Emit(opNEG, r1, 0)
|IL.opADD:
BinOp(r1, r2);
add(r1, r2);
drop
|IL.opSUB:
BinOp(r1, r2);
sub(r1, r2);
drop
|IL.opADDC:
UnOp(r1);
addrc(r1, param2)
|IL.opSUBR:
UnOp(r1);
subrc(r1, param2)
|IL.opSUBL:
UnOp(r1);
subrc(r1, param2);
Emit(opNEG, r1, 0)
|IL.opMULC:
UnOp(r1);
Emit(opMULC, r1, param2)
|IL.opMUL:
BinOp(r1, r2);
Emit(opMUL, r1, r2);
drop
|IL.opDIV:
BinOp(r1, r2);
Emit(opDIV, r1, r2);
drop
|IL.opMOD:
BinOp(r1, r2);
Emit(opMOD, r1, r2);
drop
|IL.opDIVR:
UnOp(r1);
Emit(opDIVC, r1, param2)
|IL.opMODR:
UnOp(r1);
Emit(opMODC, r1, param2)
|IL.opDIVL:
UnOp(r1);
r2 := GetAnyReg();
movrc(r2, param2);
Emit(opDIV, r2, r1);
mov(r1, r2);
drop
|IL.opMODL:
UnOp(r1);
r2 := GetAnyReg();
movrc(r2, param2);
Emit(opMOD, r2, r1);
mov(r1, r2);
drop
|IL.opEQ:
BinOp(r1, r2);
Emit(opEQ, r1, r2);
drop
|IL.opNE:
BinOp(r1, r2);
Emit(opNE, r1, r2);
drop
|IL.opLT:
BinOp(r1, r2);
Emit(opLT, r1, r2);
drop
|IL.opLE:
BinOp(r1, r2);
Emit(opLE, r1, r2);
drop
|IL.opGT:
BinOp(r1, r2);
Emit(opGT, r1, r2);
drop
|IL.opGE:
BinOp(r1, r2);
Emit(opGE, r1, r2);
drop
|IL.opEQC:
UnOp(r1);
Emit(opEQC, r1, param2)
|IL.opNEC:
UnOp(r1);
Emit(opNEC, r1, param2)
|IL.opLTC:
UnOp(r1);
Emit(opLTC, r1, param2)
|IL.opLEC:
UnOp(r1);
Emit(opLEC, r1, param2)
|IL.opGTC:
UnOp(r1);
Emit(opGTC, r1, param2)
|IL.opGEC:
UnOp(r1);
Emit(opGEC, r1, param2)
|IL.opJNZ1:
UnOp(r1);
jnz(r1, param1)
|IL.opJG:
UnOp(r1);
Emit(opJGZ, r1, param1)
|IL.opJNZ:
UnOp(r1);
jnz(r1, param1);
drop
|IL.opJZ:
UnOp(r1);
Emit(opJZ, r1, param1);
drop
|IL.opMULS:
BinOp(r1, r2);
Emit(opAND, r1, r2);
drop
|IL.opMULSC:
UnOp(r1);
Emit(opANDC, r1, param2)
|IL.opDIVS:
BinOp(r1, r2);
Emit(opXOR, r1, r2);
drop
|IL.opDIVSC:
UnOp(r1);
Emit(opXORC, r1, param2)
|IL.opADDS:
BinOp(r1, r2);
Emit(opOR, r1, r2);
drop
|IL.opSUBS:
BinOp(r1, r2);
Emit(opNOT, r2, 0);
Emit(opAND, r1, r2);
drop
|IL.opADDSC:
UnOp(r1);
Emit(opORC, r1, param2)
|IL.opSUBSL:
UnOp(r1);
Emit(opNOT, r1, 0);
Emit(opANDC, r1, param2)
|IL.opSUBSR:
UnOp(r1);
Emit(opANDC, r1, ORD(-BITS(param2)))
|IL.opUMINS:
UnOp(r1);
Emit(opNOT, r1, 0)
|IL.opASR:
BinOp(r1, r2);
Emit(opASR, r1, r2);
drop
|IL.opLSL:
BinOp(r1, r2);
Emit(opLSL, r1, r2);
drop
|IL.opROR:
BinOp(r1, r2);
Emit(opROR, r1, r2);
drop
|IL.opLSR:
BinOp(r1, r2);
Emit(opLSR, r1, r2);
drop
|IL.opASR1:
r2 := GetAnyReg();
Emit(opMOVC, r2, param2);
BinOp(r1, r2);
Emit(opASR, r2, r1);
mov(r1, r2);
drop
|IL.opLSL1:
r2 := GetAnyReg();
Emit(opMOVC, r2, param2);
BinOp(r1, r2);
Emit(opLSL, r2, r1);
mov(r1, r2);
drop
|IL.opROR1:
r2 := GetAnyReg();
Emit(opMOVC, r2, param2);
BinOp(r1, r2);
Emit(opROR, r2, r1);
mov(r1, r2);
drop
|IL.opLSR1:
r2 := GetAnyReg();
Emit(opMOVC, r2, param2);
BinOp(r1, r2);
Emit(opLSR, r2, r1);
mov(r1, r2);
drop
|IL.opASR2:
UnOp(r1);
Emit(opASRC, r1, param2 MOD 32)
|IL.opLSL2:
UnOp(r1);
Emit(opLSLC, r1, param2 MOD 32)
|IL.opROR2:
UnOp(r1);
Emit(opRORC, r1, param2 MOD 32)
|IL.opLSR2:
UnOp(r1);
Emit(opLSRC, r1, param2 MOD 32)
|IL.opCHR:
UnOp(r1);
Emit(opANDC, r1, 255)
|IL.opWCHR:
UnOp(r1);
Emit(opANDC, r1, 65535)
|IL.opABS:
UnOp(r1);
Emit(opABS, r1, 0)
|IL.opLEN:
UnOp(r1);
drop;
EXCL(R.regs, r1);
WHILE param2 > 0 DO
UnOp(r2);
drop;
DEC(param2)
END;
INCL(R.regs, r1);
ASSERT(REG.GetReg(R, r1))
|IL.opSWITCH:
UnOp(r1);
IF param2 = 0 THEN
r2 := ACC
ELSE
r2 := R1
END;
IF r1 # r2 THEN
ASSERT(REG.GetReg(R, r2));
ASSERT(REG.Exchange(R, r1, r2));
drop
END;
drop
|IL.opENDSW:
|IL.opCASEL:
GetAcc;
Emit(opJLA, param1, param2);
drop
|IL.opCASER:
GetAcc;
Emit(opJGA, param1, param2);
drop
|IL.opCASELR:
GetAcc;
Emit(opJLA, param1, param2);
Emit(opJGA, param1, cmd.param3);
drop
|IL.opSBOOL:
BinOp(r2, r1);
Emit(opNEC, r2, 0);
str8(r1, r2);
drop;
drop
|IL.opSBOOLC:
UnOp(r1);
Emit(opSTR8C, r1, ORD(param2 # 0));
drop
|IL.opINCC:
UnOp(r1);
r2 := GetAnyReg();
ldr32(r2, r1);
addrc(r2, param2);
str32(r1, r2);
drop;
drop
|IL.opINCCB, IL.opDECCB:
IF opcode = IL.opDECCB THEN
param2 := -param2
END;
UnOp(r1);
r2 := GetAnyReg();
ldr8(r2, r1);
addrc(r2, param2);
str8(r1, r2);
drop;
drop
|IL.opINCB, IL.opDECB:
BinOp(r2, r1);
r3 := GetAnyReg();
ldr8(r3, r1);
IF opcode = IL.opINCB THEN
add(r3, r2)
ELSE
sub(r3, r2)
END;
str8(r1, r3);
drop;
drop;
drop
|IL.opINC, IL.opDEC:
BinOp(r2, r1);
r3 := GetAnyReg();
ldr32(r3, r1);
IF opcode = IL.opINC THEN
add(r3, r2)
ELSE
sub(r3, r2)
END;
str32(r1, r3);
drop;
drop;
drop
|IL.opINCL, IL.opEXCL:
BinOp(r2, r1);
IF opcode = IL.opINCL THEN
Emit(opINCL, r1, r2)
ELSE
Emit(opEXCL, r1, r2)
END;
drop;
drop
|IL.opINCLC, IL.opEXCLC:
UnOp(r1);
r2 := GetAnyReg();
ldr32(r2, r1);
IF opcode = IL.opINCLC THEN
Emit(opINCLC, r2, param2)
ELSE
Emit(opEXCLC, r2, param2)
END;
str32(r1, r2);
drop;
drop
|IL.opEQB, IL.opNEB:
BinOp(r1, r2);
Emit(opNEC, r1, 0);
Emit(opNEC, r2, 0);
IF opcode = IL.opEQB THEN
Emit(opEQ, r1, r2)
ELSE
Emit(opNE, r1, r2)
END;
drop
|IL.opCHKBYTE:
BinOp(r1, r2);
r3 := GetAnyReg();
mov(r3, r1);
Emit(opBTC, r3, 256);
jnz(r3, param1);
drop
|IL.opCHKIDX:
UnOp(r1);
r2 := GetAnyReg();
mov(r2, r1);
Emit(opBTC, r2, param2);
jnz(r2, param1);
drop
|IL.opCHKIDX2:
BinOp(r1, r2);
IF param2 # -1 THEN
r3 := GetAnyReg();
mov(r3, r2);
Emit(opBT, r3, r1);
jnz(r3, param1);
drop
END;
INCL(R.regs, r1);
DEC(R.top);
R.stk[R.top] := r2
|IL.opEQP, IL.opNEP:
ProcAdr(GetAnyReg(), param1);
BinOp(r1, r2);
IF opcode = IL.opEQP THEN
Emit(opEQ, r1, r2)
ELSE
Emit(opNE, r1, r2)
END;
drop
|IL.opSAVEP:
UnOp(r1);
r2 := GetAnyReg();
ProcAdr(r2, param2);
str32(r1, r2);
drop;
drop
|IL.opPUSHP:
ProcAdr(GetAnyReg(), param2)
|IL.opPUSHT:
UnOp(r1);
r2 := GetAnyReg();
mov(r2, r1);
subrc(r2, 4);
ldr32(r2, r2)
|IL.opGET, IL.opGETC:
IF opcode = IL.opGET THEN
BinOp(r1, r2)
ELSIF opcode = IL.opGETC THEN
UnOp(r2);
r1 := GetAnyReg();
movrc(r1, param1)
END;
drop;
drop;
CASE param2 OF
|1: ldr8(r1, r1); str8(r2, r1)
|2: ldr16(r1, r1); str16(r2, r1)
|4: ldr32(r1, r1); str32(r2, r1)
END
|IL.opNOT:
UnOp(r1);
Emit(opEQC, r1, 0)
|IL.opORD:
UnOp(r1);
Emit(opNEC, r1, 0)
|IL.opMIN:
BinOp(r1, r2);
Emit(opMIN, r1, r2);
drop
|IL.opMAX:
BinOp(r1, r2);
Emit(opMAX, r1, r2);
drop
|IL.opMINC:
UnOp(r1);
Emit(opMINC, r1, param2)
|IL.opMAXC:
UnOp(r1);
Emit(opMAXC, r1, param2)
|IL.opIN:
BinOp(r1, r2);
Emit(opIN, r1, r2);
drop
|IL.opINL:
r1 := GetAnyReg();
movrc(r1, param2);
BinOp(r2, r1);
Emit(opIN, r1, r2);
mov(r2, r1);
drop
|IL.opINR:
UnOp(r1);
Emit(opINC, r1, param2)
|IL.opERR:
CallRTL(IL._error, 4)
|IL.opEQS .. IL.opGES:
PushAll(4);
pushc(opcode - IL.opEQS);
CallRTL(IL._strcmp, 5);
GetAcc
|IL.opEQSW .. IL.opGESW:
PushAll(4);
pushc(opcode - IL.opEQSW);
CallRTL(IL._strcmpw, 5);
GetAcc
|IL.opCOPY:
PushAll(2);
pushc(param2);
CallRTL(IL._move, 3)
|IL.opMOVE:
PushAll(3);
CallRTL(IL._move, 3)
|IL.opCOPYA:
PushAll(4);
pushc(param2);
CallRTL(IL._arrcpy, 5);
GetAcc
|IL.opCOPYS:
PushAll(4);
pushc(param2);
CallRTL(IL._strcpy, 5)
|IL.opROT:
PushAll(0);
mov(ACC, SP);
push(ACC);
pushc(param2);
CallRTL(IL._rot, 2)
|IL.opLENGTH:
PushAll(2);
CallRTL(IL._length, 2);
GetAcc
|IL.opLENGTHW:
PushAll(2);
CallRTL(IL._lengthw, 2);
GetAcc
|IL.opSAVES:
UnOp(r2);
REG.PushAll_1(R);
r1 := GetAnyReg();
StrAdr(r1, param2);
push(r1);
drop;
push(r2);
drop;
pushc(param1);
CallRTL(IL._move, 3)
|IL.opRSET:
PushAll(2);
CallRTL(IL._set, 2);
GetAcc
|IL.opRSETR:
PushAll(1);
pushc(param2);
CallRTL(IL._set, 2);
GetAcc
|IL.opRSETL:
UnOp(r1);
REG.PushAll_1(R);
pushc(param2);
push(r1);
drop;
CallRTL(IL._set, 2);
GetAcc
|IL.opRSET1:
PushAll(1);
CallRTL(IL._set1, 1);
GetAcc
|IL.opNEW:
PushAll(1);
INC(param2, 8);
ASSERT(UTILS.Align(param2, 32));
pushc(param2);
pushc(param1);
CallRTL(IL._new, 3)
|IL.opTYPEGP:
UnOp(r1);
PushAll(0);
push(r1);
pushc(param2);
CallRTL(IL._guard, 2);
GetAcc
|IL.opIS:
PushAll(1);
pushc(param2);
CallRTL(IL._is, 2);
GetAcc
|IL.opISREC:
PushAll(2);
pushc(param2);
CallRTL(IL._guardrec, 3);
GetAcc
|IL.opTYPEGR:
PushAll(1);
pushc(param2);
CallRTL(IL._guardrec, 2);
GetAcc
|IL.opTYPEGD:
UnOp(r1);
PushAll(0);
subrc(r1, 4);
ldr32(r1, r1);
push(r1);
pushc(param2);
CallRTL(IL._guardrec, 2);
GetAcc
|IL.opCASET:
push(R1);
push(R1);
pushc(param2);
CallRTL(IL._guardrec, 2);
pop(R1);
jnz(ACC, param1)
|IL.opCONSTF:
movrc(GetAnyReg(), UTILS.d2s(cmd.float))
|IL.opMULF:
PushAll(2);
CallRTL(IL._fmul, 2);
GetAcc
|IL.opDIVF:
PushAll(2);
CallRTL(IL._fdiv, 2);
GetAcc
|IL.opDIVFI:
PushAll(2);
CallRTL(IL._fdivi, 2);
GetAcc
|IL.opADDF:
PushAll(2);
CallRTL(IL._fadd, 2);
GetAcc
|IL.opSUBFI:
PushAll(2);
CallRTL(IL._fsubi, 2);
GetAcc
|IL.opSUBF:
PushAll(2);
CallRTL(IL._fsub, 2);
GetAcc
|IL.opEQF..IL.opGEF:
PushAll(2);
pushc(opcode - IL.opEQF);
CallRTL(IL._fcmp, 3);
GetAcc
|IL.opFLOOR:
PushAll(1);
CallRTL(IL._floor, 1);
GetAcc
|IL.opFLT:
PushAll(1);
CallRTL(IL._flt, 1);
GetAcc
|IL.opUMINF:
UnOp(r1);
Emit(opXORC, r1, ORD({31}))
|IL.opFABS:
UnOp(r1);
Emit(opANDC, r1, ORD({0..30}))
|IL.opINF:
movrc(GetAnyReg(), inf)
|IL.opPUSHF:
UnOp(r1);
push(r1);
drop
|IL.opPACK:
PushAll(2);
CallRTL(IL._pack, 2)
|IL.opPACKC:
PushAll(1);
pushc(param2);
CallRTL(IL._pack, 2)
|IL.opUNPK:
PushAll(2);
CallRTL(IL._unpk, 2)
|IL.opCODE:
OutInt(param2)
END;
cmd := cmd.next(IL.COMMAND)
END;
ASSERT(R.pushed = 0);
ASSERT(R.top = -1)
END translate;
PROCEDURE prolog;
BEGIN
Emit(opLEA, SP + LStack * 256, 0);
Emit(opLEA, ACC + LTypes * 256, 0);
push(ACC);
Emit(opLEA, ACC + LHeap * 256, 0);
push(ACC);
pushc(CHL.Length(IL.codes.types));
CallRTL(IL._init, 3)
END prolog;
PROCEDURE epilog (ram: INTEGER);
VAR
tcount, dcount, i, offTypes, offStrings, szData, szGlobal, szHeapStack: INTEGER;
BEGIN
Emit(opSTOP, 0, 0);
offTypes := count;
tcount := CHL.Length(IL.codes.types);
FOR i := 0 TO tcount - 1 DO
OutInt(CHL.GetInt(IL.codes.types, i))
END;
offStrings := count;
dcount := CHL.Length(IL.codes.data);
FOR i := 0 TO dcount - 1 DO
OutByte(CHL.GetByte(IL.codes.data, i))
END;
IF dcount MOD 4 # 0 THEN
i := 4 - dcount MOD 4;
WHILE i > 0 DO
OutByte(0);
DEC(i)
END
END;
szData := count - offTypes;
szGlobal := (IL.codes.bss DIV 4 + 1) * 4;
szHeapStack := ram - szData - szGlobal;
OutInt(offTypes);
OutInt(offStrings);
OutInt(szGlobal DIV 4);
OutInt(szHeapStack DIV 4);
FOR i := 1 TO 8 DO
OutInt(0)
END
END epilog;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
CONST
minRAM = 32*1024;
maxRAM = 256*1024;
VAR
szData, szRAM: INTEGER;
BEGIN
szData := (CHL.Length(IL.codes.types) + CHL.Length(IL.codes.data) DIV 4 + IL.codes.bss DIV 4 + 2) * 4;
szRAM := MIN(MAX(options.ram, minRAM), maxRAM) * 1024;
IF szRAM - szData < 1024*1024 THEN
ERRORS.Error(208)
END;
count := 0;
WR.Create(outname);
REG.Init(R, push, pop, mov, xchg, NIL, NIL, GPRs, {});
prolog;
translate;
epilog(szRAM);
WR.Close
END CodeGen;
END RVM32I.

/programs/develop/oberon07/source/TEXTDRV.ob07
0,0 → 1,192
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE TEXTDRV;
IMPORT FILES, C := COLLECTIONS;
CONST
CR = 0DX; LF = 0AX;
CHUNK = 1024 * 256;
TYPE
TEXT* = POINTER TO RECORD (C.ITEM)
chunk: ARRAY CHUNK OF CHAR;
pos, size: INTEGER;
file: FILES.FILE;
utf8: BOOLEAN;
CR: BOOLEAN;
line*, col*: INTEGER;
ifc*: INTEGER;
elsec*: INTEGER;
eof*: BOOLEAN;
eol*: BOOLEAN;
skip*: BOOLEAN;
peak*: CHAR;
_skip*,
_elsif*,
_else*: ARRAY 100 OF BOOLEAN;
fname*: ARRAY 2048 OF CHAR
END;
VAR
texts: C.COLLECTION;
PROCEDURE load (text: TEXT);
BEGIN
IF ~text.eof THEN
text.size := FILES.read(text.file, text.chunk, LEN(text.chunk));
text.pos := 0;
IF text.size = 0 THEN
text.eof := TRUE;
text.chunk[0] := 0X
END;
text.peak := text.chunk[0]
END
END load;
PROCEDURE next* (text: TEXT);
VAR
c: CHAR;
BEGIN
IF text.pos < text.size - 1 THEN
INC(text.pos);
text.peak := text.chunk[text.pos]
ELSE
load(text)
END;
IF ~text.eof THEN
c := text.peak;
IF c = CR THEN
INC(text.line);
text.col := 0;
text.eol := TRUE;
text.CR := TRUE
ELSIF c = LF THEN
IF ~text.CR THEN
INC(text.line);
text.col := 0;
text.eol := TRUE
ELSE
text.eol := FALSE
END;
text.CR := FALSE
ELSE
text.eol := FALSE;
IF text.utf8 THEN
IF ORD(c) DIV 64 # 2 THEN
INC(text.col)
END
ELSE
INC(text.col)
END;
text.CR := FALSE
END
END
END next;
PROCEDURE init (text: TEXT);
BEGIN
IF (text.pos = 0) & (text.size >= 3) THEN
IF (text.chunk[0] = 0EFX) &
(text.chunk[1] = 0BBX) &
(text.chunk[2] = 0BFX) THEN
text.pos := 3;
text.utf8 := TRUE
END
END;
IF text.size = 0 THEN
text.chunk[0] := 0X;
text.size := 1;
text.eof := FALSE
END;
text.line := 1;
text.col := 1;
text.peak := text.chunk[text.pos]
END init;
PROCEDURE close* (VAR text: TEXT);
BEGIN
IF text # NIL THEN
IF text.file # NIL THEN
FILES.close(text.file)
END;
C.push(texts, text);
text := NIL
END
END close;
PROCEDURE open* (name: ARRAY OF CHAR): TEXT;
VAR
text: TEXT;
citem: C.ITEM;
BEGIN
citem := C.pop(texts);
IF citem = NIL THEN
NEW(text)
ELSE
text := citem(TEXT)
END;
IF text # NIL THEN
text.chunk[0] := 0X;
text.pos := 0;
text.size := 0;
text.utf8 := FALSE;
text.CR := FALSE;
text.line := 1;
text.col := 1;
text.eof := FALSE;
text.eol := FALSE;
text.skip := FALSE;
text.ifc := 0;
text.elsec := 0;
text._skip[0] := FALSE;
text.peak := 0X;
text.file := FILES.open(name);
COPY(name, text.fname);
IF text.file # NIL THEN
load(text);
init(text)
ELSE
close(text)
END
END
RETURN text
END open;
BEGIN
texts := C.create()
END TEXTDRV.

/programs/develop/oberon07/source/AVLTREES.ob07
0,0 → 1,197
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
All rights reserved.
*)
MODULE AVLTREES;
IMPORT C := COLLECTIONS;
TYPE
DATA* = POINTER TO RECORD (C.ITEM) END;
NODE* = POINTER TO RECORD (C.ITEM)
data*: DATA;
height: INTEGER;
left*, right*: NODE
END;
CMP* = PROCEDURE (a, b: DATA): INTEGER;
DESTRUCTOR* = PROCEDURE (VAR data: DATA);
VAR
nodes: C.COLLECTION;
PROCEDURE NewNode (data: DATA): NODE;
VAR
node: NODE;
citem: C.ITEM;
BEGIN
citem := C.pop(nodes);
IF citem = NIL THEN
NEW(node)
ELSE
node := citem(NODE)
END;
node.data := data;
node.left := NIL;
node.right := NIL;
node.height := 1
RETURN node
END NewNode;
PROCEDURE height (p: NODE): INTEGER;
VAR
res: INTEGER;
BEGIN
IF p = NIL THEN
res := 0
ELSE
res := p.height
END
RETURN res
END height;
PROCEDURE bfactor (p: NODE): INTEGER;
RETURN height(p.right) - height(p.left)
END bfactor;
PROCEDURE fixheight (p: NODE);
BEGIN
p.height := MAX(height(p.left), height(p.right)) + 1
END fixheight;
PROCEDURE rotateright (p: NODE): NODE;
VAR
q: NODE;
BEGIN
q := p.left;
p.left := q.right;
q.right := p;
fixheight(p);
fixheight(q)
RETURN q
END rotateright;
PROCEDURE rotateleft (q: NODE): NODE;
VAR
p: NODE;
BEGIN
p := q.right;
q.right := p.left;
p.left := q;
fixheight(q);
fixheight(p)
RETURN p
END rotateleft;
PROCEDURE balance (p: NODE): NODE;
VAR
res: NODE;
BEGIN
fixheight(p);
IF bfactor(p) = 2 THEN
IF bfactor(p.right) < 0 THEN
p.right := rotateright(p.right)
END;
res := rotateleft(p)
ELSIF bfactor(p) = -2 THEN
IF bfactor(p.left) > 0 THEN
p.left := rotateleft(p.left)
END;
res := rotateright(p)
ELSE
res := p
END
RETURN res
END balance;
PROCEDURE insert* (p: NODE; data: DATA; cmp: CMP; VAR newnode: BOOLEAN; VAR node: NODE): NODE;
VAR
res: NODE;
rescmp: INTEGER;
BEGIN
IF p = NIL THEN
res := NewNode(data);
node := res;
newnode := TRUE
ELSE
rescmp := cmp(data, p.data);
IF rescmp < 0 THEN
p.left := insert(p.left, data, cmp, newnode, node);
res := balance(p)
ELSIF rescmp > 0 THEN
p.right := insert(p.right, data, cmp, newnode, node);
res := balance(p)
ELSE
res := p;
node := res;
newnode := FALSE
END
END
RETURN res
END insert;
PROCEDURE destroy* (VAR node: NODE; destructor: DESTRUCTOR);
VAR
left, right: NODE;
BEGIN
IF node # NIL THEN
left := node.left;
right := node.right;
IF destructor # NIL THEN
destructor(node.data)
END;
C.push(nodes, node);
node := NIL;
destroy(left, destructor);
destroy(right, destructor)
END
END destroy;
BEGIN
nodes := C.create()
END AVLTREES.

/programs/develop/oberon07/source/COLLECTIONS.ob07
0,0 → 1,59
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
All rights reserved.
*)
MODULE COLLECTIONS;
TYPE
ITEM* = POINTER TO RECORD
link: ITEM
END;
COLLECTION* = POINTER TO RECORD
last: ITEM
END;
PROCEDURE push* (collection: COLLECTION; item: ITEM);
BEGIN
item.link := collection.last;
collection.last := item
END push;
PROCEDURE pop* (collection: COLLECTION): ITEM;
VAR
item: ITEM;
BEGIN
item := collection.last;
IF item # NIL THEN
collection.last := item.link
END
RETURN item
END pop;
PROCEDURE create* (): COLLECTION;
VAR
collection: COLLECTION;
BEGIN
NEW(collection);
collection.last := NIL
RETURN collection
END create;
END COLLECTIONS.