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 @ 7209

  → /programs/develop/oberon07/Source @ 7597

  ↔ Reverse comparison

• Compare Path:	Rev

  With Path:	Rev

Regard whitespace Rev 7209 → Rev 7597

/programs/develop/oberon07/Source/DECL.ob07
File deleted
\ No newline at end of file

/programs/develop/oberon07/Source/AMD64.ob07
0,0 → 1,2782
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE AMD64;
IMPORT CODE, BIN, WR := WRITER, CHL := CHUNKLISTS, MACHINE, LISTS, PATHS,
REG, C := CONSOLE, UTILS, mConst := CONSTANTS, S := STRINGS, PE32, ELF, X86;
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;
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 = CODE.opLSL2; shr = CODE.opLSR2; sar = CODE.opASR2; ror = CODE.opROR2;
sCODE = BIN.PICCODE;
sDATA = BIN.PICDATA;
sBSS = BIN.PICBSS;
sIMP = BIN.PICIMP;
TYPE
COMMAND = CODE.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;
dllret: INTEGER;
Win64RegPar: ARRAY 4 OF INTEGER;
SystemVRegPar: ARRAY 6 OF INTEGER;
PROCEDURE OutByte (b: BYTE);
BEGIN
X86.OutByte(b)
END OutByte;
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 OutInt (n: INTEGER);
BEGIN
OutByte(MACHINE.Byte(n, 0));
OutByte(MACHINE.Byte(n, 1));
OutByte(MACHINE.Byte(n, 2));
OutByte(MACHINE.Byte(n, 3))
END OutInt;
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(MACHINE.Byte(n, 0))
ELSE
OutInt(n)
END
END OutIntByte;
PROCEDURE isLong (n: INTEGER): BOOLEAN;
RETURN (n > MACHINE.max32) OR (n < MACHINE.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 CODE.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); // and 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
oprr(87H, reg1, reg2)
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 callimp (label: INTEGER);
VAR
reg: INTEGER;
BEGIN
reg := REG.GetAnyReg(R);
lea(reg, label, sIMP);
IF reg >= 8 THEN // call qword[reg]
OutByte(41H)
END;
OutByte2(0FFH, 10H + reg MOD 8);
drop
END callimp;
PROCEDURE pushDA (offs: INTEGER);
VAR
reg: INTEGER;
BEGIN
reg := REG.GetAnyReg(R);
lea(reg, offs, sDATA);
push(reg);
drop
END pushDA;
PROCEDURE CallRTL (proc: INTEGER);
VAR
label: INTEGER;
BEGIN
REG.Store(R);
label := CODE.codes.rtl[proc];
IF label < 0 THEN
callimp(-label)
ELSE
X86.call(label)
END;
REG.Restore(R)
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);
R.pushed := 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(MACHINE.Byte(n, i))
END
END movabs;
PROCEDURE movrc (reg, n: INTEGER); // mov reg, n
BEGIN
IF isLong(n) THEN
movabs(reg, n)
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 := REG.GetAnyReg(R);
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);
OutByte2(81H + short(n), op + reg MOD 8);
OutIntByte(n)
END
END oprc;
PROCEDURE cmprc (reg, n: INTEGER); // cmp reg, n
BEGIN
oprc(0F8H, reg, n, cmprr)
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 pushc (n: INTEGER);
VAR
reg2: INTEGER;
BEGIN
IF isLong(n) THEN
reg2 := REG.GetAnyReg(R);
movabs(reg2, n);
push(reg2);
drop
ELSE
OutByte(68H + short(n)); OutIntByte(n) // push 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]
VAR
b: BYTE;
BEGIN
Rex(reg2, reg1);
OutByte2(0FH, 0B6H + ORD(word));
IF (offs = 0) & (reg2 # rbp) THEN
b := 0
ELSE
b := 40H + long(offs)
END;
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8);
IF reg2 = rsp 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 # rbp) THEN
b := 0
ELSE
b := 40H + long(offs)
END;
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8);
IF reg2 = rsp THEN
OutByte(24H)
END;
IF b # 0 THEN
OutIntByte(offs)
END
END _movrm;
PROCEDURE movmr32 (reg1, offs, reg2: INTEGER); // mov dword[reg1+offs], reg2_32
BEGIN
_movrm(reg2, reg1, offs, 32, TRUE)
END movmr32;
PROCEDURE movrm32 (reg1, reg2, offs: INTEGER); // mov reg1_32, dword[reg2+offs]
BEGIN
_movrm(reg1, reg2, offs, 32, FALSE)
END movrm32;
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 movmr (reg1, offs, reg2: INTEGER); // mov qword[reg1+offs], reg2
BEGIN
_movrm(reg2, reg1, offs, 64, TRUE)
END movmr;
PROCEDURE movrm (reg1, reg2, offs: INTEGER); // mov reg1, qword[reg2+offs]
BEGIN
_movrm(reg1, reg2, offs, 64, FALSE)
END movrm;
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 # rbp) THEN
b := 30H
ELSE
b := 70H + long(offs)
END;
OutByte(b + reg MOD 8);
IF reg = rsp THEN
OutByte(24H)
END;
IF b # 30H THEN
OutIntByte(offs)
END
END pushm;
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 jmp (label: INTEGER); // jmp label
BEGIN
X86.jmp(label)
END jmp;
PROCEDURE setcc (cc, reg: INTEGER); //setcc reg8
BEGIN
IF reg >= 8 THEN
OutByte(41H)
END;
OutByte3(0FH, cc, 0C0H + reg MOD 8)
END setcc;
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 getVar (variables: LISTS.LIST; offset: INTEGER): CODE.LOCALVAR;
VAR
cur: CODE.LOCALVAR;
BEGIN
cur := variables.first(CODE.LOCALVAR);
WHILE (cur # NIL) & (cur.offset # offset) DO
cur := cur.next(CODE.LOCALVAR)
END
RETURN cur
END getVar;
PROCEDURE allocReg (cmd: COMMAND);
VAR
leave: BOOLEAN;
leaf: BOOLEAN;
cur: COMMAND;
variables: LISTS.LIST;
lvar, rvar: CODE.LOCALVAR;
reg: INTEGER;
max: INTEGER;
loop: INTEGER;
BEGIN
loop := 1;
variables := cmd.variables;
leave := FALSE;
leaf := TRUE;
cur := cmd.next(COMMAND);
REPEAT
CASE cur.opcode OF
|CODE.opLLOAD64,
CODE.opLLOAD8,
CODE.opLLOAD16,
CODE.opLLOAD32,
CODE.opLLOAD64_PARAM,
CODE.opLLOAD32_PARAM,
CODE.opLADR_SAVE,
CODE.opLADR_INC1,
CODE.opLADR_DEC1,
CODE.opLADR_INC,
CODE.opLADR_DEC,
CODE.opLADR_INC1B,
CODE.opLADR_DEC1B,
CODE.opLADR_INCB,
CODE.opLADR_DECB,
CODE.opLADR_INCL,
CODE.opLADR_EXCL,
CODE.opLADR_UNPK:
lvar := getVar(variables, cur.param2);
IF (lvar # NIL) & (lvar.count # -1) THEN
INC(lvar.count, loop)
END
|CODE.opLADR_SAVEC,
CODE.opLADR_INCC,
CODE.opLADR_DECC,
CODE.opLADR_INCCB,
CODE.opLADR_DECCB,
CODE.opLADR_INCLC,
CODE.opLADR_EXCLC:
lvar := getVar(variables, cur.param1);
IF (lvar # NIL) & (lvar.count # -1) THEN
INC(lvar.count, loop)
END
|CODE.opLADR:
lvar := getVar(variables, cur.param2);
IF (lvar # NIL) & (lvar.count # -1) THEN
lvar.count := -1
END
|CODE.opLOOP:
INC(loop, 10)
|CODE.opENDLOOP:
DEC(loop, 10)
|CODE.opLEAVE,
CODE.opLEAVER,
CODE.opLEAVEF:
leave := TRUE
|CODE.opCALL, CODE.opCALLP, CODE.opCALLI,
CODE.opWIN64CALL, CODE.opWIN64CALLP, CODE.opWIN64CALLI,
CODE.opSYSVCALL, CODE.opSYSVCALLP, CODE.opSYSVCALLI:
leaf := FALSE
ELSE
END;
cur := cur.next(COMMAND)
UNTIL leave OR ~leaf;
IF leaf THEN
REPEAT
reg := -1;
max := -1;
rvar := NIL;
lvar := variables.first(CODE.LOCALVAR);
WHILE lvar # NIL DO
IF lvar.count > max THEN
max := lvar.count;
rvar := lvar
END;
lvar := lvar.next(CODE.LOCALVAR)
END;
IF rvar # NIL THEN
reg := REG.GetAnyVarReg(R);
IF reg # -1 THEN
REG.Lock(R, reg, rvar.offset, rvar.size);
REG.Load(R, reg);
rvar.count := -1
END
END
UNTIL (rvar = NIL) OR (reg = -1)
END
END allocReg;
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(r10 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(r10, rsp, ofs);
movmr(rsp, p, r10);
INC(p, 8)
END
END
END SysVPassing;
PROCEDURE fcmp (op: INTEGER; xmm: INTEGER);
VAR
cc, reg: INTEGER;
BEGIN
reg := REG.GetAnyReg(R);
xor(reg, reg);
CASE op OF
|CODE.opEQF, CODE.opEQFI:
comisd(xmm - 1, xmm);
cc := sete
|CODE.opNEF, CODE.opNEFI:
comisd(xmm - 1, xmm);
cc := setne
|CODE.opLTF, CODE.opGTFI:
comisd(xmm - 1, xmm);
cc := setc
|CODE.opGTF, CODE.opLTFI:
comisd(xmm, xmm - 1);
cc := setc
|CODE.opLEF, CODE.opGEFI:
comisd(xmm, xmm - 1);
cc := setnc
|CODE.opGEF, CODE.opLEFI:
comisd(xmm - 1, xmm);
cc := setnc
END;
OutByte2(7AH, 3 + reg DIV 8); // jp L
setcc(cc, reg);
//L:
END fcmp;
PROCEDURE translate (commands: LISTS.LIST; stroffs: INTEGER);
VAR
cmd, next: COMMAND;
param1, param2, param3, a, b, c, n, label, L, i, cc: INTEGER;
reg1, reg2, xmm: INTEGER;
float: REAL;
regVar: BOOLEAN;
BEGIN
xmm := -1;
cmd := commands.first(COMMAND);
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
CASE cmd.opcode OF
|CODE.opJMP:
jmp(param1)
|CODE.opCALL, CODE.opWIN64CALL, CODE.opSYSVCALL:
REG.Store(R);
CASE cmd.opcode OF
|CODE.opCALL:
|CODE.opWIN64CALL: Win64Passing(param2)
|CODE.opSYSVCALL: SysVPassing(param2)
END;
X86.call(param1);
REG.Restore(R)
|CODE.opCALLP, CODE.opWIN64CALLP, CODE.opSYSVCALLP:
UnOp(reg1);
IF reg1 # rax THEN
GetRegA;
ASSERT(REG.Exchange(R, reg1, rax));
drop
END;
drop;
REG.Store(R);
CASE cmd.opcode OF
|CODE.opCALLP:
|CODE.opWIN64CALLP: Win64Passing(param2)
|CODE.opSYSVCALLP: SysVPassing(param2)
END;
OutByte2(0FFH, 0D0H); // call rax
REG.Restore(R);
ASSERT(R.top = -1)
|CODE.opCALLI, CODE.opWIN64CALLI, CODE.opSYSVCALLI:
REG.Store(R);
CASE cmd.opcode OF
|CODE.opCALLI:
|CODE.opWIN64CALLI: Win64Passing(param2)
|CODE.opSYSVCALLI: SysVPassing(param2)
END;
callimp(param1);
REG.Restore(R)
|CODE.opLABEL:
X86.SetLabel(param2)
|CODE.opERR:
CallRTL(CODE._error)
|CODE.opERRC:
pushc(param2)
|CODE.opPRECALL:
n := param2;
IF (param1 # 0) & (n # 0) THEN
subrc(rsp, 8)
END;
WHILE n > 0 DO
subrc(rsp, 8);
movsdmr(rsp, 0, xmm);
DEC(xmm);
DEC(n)
END;
ASSERT(xmm = -1);
PushAll(0)
|CODE.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)
|CODE.opSYSVALIGN16:
ASSERT(rax IN R.regs);
mov(rax, rsp);
andrc(rsp, -16);
push(rax);
IF ~ODD(param2) THEN
push(rax)
END
|CODE.opRESF:
ASSERT(xmm = -1);
INC(xmm);
n := param2;
IF n > 0 THEN
movsdmr(rsp, n * 8, xmm);
DEC(xmm);
INC(n)
END;
WHILE n > 0 DO
INC(xmm);
movsdrm(xmm, rsp, 0);
addrc(rsp, 8);
DEC(n)
END
|CODE.opRES:
ASSERT(R.top = -1);
GetRegA;
n := param2;
WHILE n > 0 DO
INC(xmm);
movsdrm(xmm, rsp, 0);
addrc(rsp, 8);
DEC(n)
END
|CODE.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(r10);
subrc(rsp, n);
push(r10);
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(r10, rbp, n + c);
movmr(rbp, i, r10);
INC(c, 8)
END
ELSE
IF a <= 5 THEN
movmr(rbp, i, SystemVRegPar[a]);
INC(a)
ELSE
movrm(r10, rbp, n + c);
movmr(rbp, i, r10);
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;
IF cmd.allocReg THEN
allocReg(cmd)
END
|CODE.opLEAVE, CODE.opLEAVER, CODE.opLEAVEF:
IF cmd.opcode = CODE.opLEAVER THEN
UnOp(reg1);
IF reg1 # rax THEN
GetRegA;
ASSERT(REG.Exchange(R, reg1, rax));
drop
END;
drop
END;
ASSERT(R.top = -1);
IF cmd.opcode = CODE.opLEAVEF THEN
DEC(xmm)
END;
ASSERT(xmm = -1);
mov(rsp, rbp);
pop(rbp);
IF param2 > 0 THEN
OutByte3(0C2H, (param2 * 8) MOD 256, (param2 * 8) DIV 256) // ret param2
ELSE
OutByte(0C3H) // ret
END;
REG.Reset(R)
|CODE.opSAVES:
UnOp(reg1);
drop;
PushAll(0);
push(reg1);
pushDA(stroffs + param2);
pushc(param1);
CallRTL(CODE._move)
|CODE.opSADR:
reg1 := REG.GetAnyReg(R);
lea(reg1, stroffs + param2, sDATA)
|CODE.opLOAD8:
UnOp(reg1);
movzx(reg1, reg1, 0, FALSE)
|CODE.opLOAD16:
UnOp(reg1);
movzx(reg1, reg1, 0, TRUE)
|CODE.opLOAD32:
UnOp(reg1);
movrm32(reg1, reg1, 0);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32)
|CODE.opLOAD64:
UnOp(reg1);
movrm(reg1, reg1, 0)
|CODE.opLLOAD64:
reg1 := REG.GetAnyReg(R);
reg2 := REG.GetVarReg(R, param2);
IF reg2 # -1 THEN
mov(reg1, reg2)
ELSE
movrm(reg1, rbp, param2 * 8)
END
|CODE.opLLOAD8,
CODE.opLLOAD16:
reg1 := REG.GetAnyReg(R);
reg2 := REG.GetVarReg(R, param2);
IF reg2 # -1 THEN
mov(reg1, reg2)
ELSE
movzx(reg1, rbp, param2 * 8, cmd.opcode = CODE.opLLOAD16)
END
|CODE.opLLOAD32:
reg1 := REG.GetAnyReg(R);
reg2 := REG.GetVarReg(R, param2);
IF reg2 # -1 THEN
mov(reg1, reg2)
ELSE
n := param2 * 8;
xor(reg1, reg1);
movrm32(reg1, rbp, n)
END
|CODE.opGLOAD64:
reg1 := REG.GetAnyReg(R);
lea(reg1, param2, sBSS);
movrm(reg1, reg1, 0)
|CODE.opGLOAD8:
reg1 := REG.GetAnyReg(R);
lea(reg1, param2, sBSS);
movzx(reg1, reg1, 0, FALSE)
|CODE.opGLOAD16:
reg1 := REG.GetAnyReg(R);
lea(reg1, param2, sBSS);
movzx(reg1, reg1, 0, TRUE)
|CODE.opGLOAD32:
reg1 := REG.GetAnyReg(R);
xor(reg1, reg1);
lea(reg1, param2, sBSS);
movrm32(reg1, reg1, 0)
|CODE.opVLOAD64:
reg1 := REG.GetAnyReg(R);
movrm(reg1, rbp, param2 * 8);
movrm(reg1, reg1, 0)
|CODE.opVLOAD8,
CODE.opVLOAD16:
reg1 := REG.GetAnyReg(R);
movrm(reg1, rbp, param2 * 8);
movzx(reg1, reg1, 0, cmd.opcode = CODE.opVLOAD16)
|CODE.opVLOAD32:
reg1 := REG.GetAnyReg(R);
reg2 := REG.GetAnyReg(R);
xor(reg1, reg1);
movrm(reg2, rbp, param2 * 8);
movrm32(reg1, reg2, 0);
drop
|CODE.opLADR:
n := param2 * 8;
next := cmd.next(COMMAND);
IF next.opcode = CODE.opSAVEF THEN
movsdmr(rbp, n, xmm);
DEC(xmm);
cmd := next
ELSIF next.opcode = CODE.opLOADF THEN
INC(xmm);
movsdrm(xmm, rbp, n);
cmd := next
ELSE
reg1 := REG.GetAnyReg(R);
Rex(0, reg1);
OutByte2(8DH, 45H + long(n) + (reg1 MOD 8) * 8); // lea reg1, qword[rbp+n]
OutIntByte(n)
END
|CODE.opGADR:
reg1 := REG.GetAnyReg(R);
lea(reg1, param2, sBSS)
|CODE.opVADR:
reg1 := REG.GetAnyReg(R);
movrm(reg1, rbp, param2 * 8)
|CODE.opSAVE8C:
UnOp(reg1);
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(0C6H, reg1 MOD 8, param2); // mov byte[reg1], param2
drop
|CODE.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
|CODE.opSAVEC:
UnOp(reg1);
IF isLong(param2) THEN
reg2 := REG.GetAnyReg(R);
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
|CODE.opRSET:
PushAll(2);
CallRTL(CODE._set);
GetRegA
|CODE.opRSETR:
PushAll(1);
pushc(param2);
CallRTL(CODE._set);
GetRegA
|CODE.opRSETL:
PushAll(1);
pushc(param2);
CallRTL(CODE._set2);
GetRegA
|CODE.opRSET1:
UnOp(reg1);
PushAll(1);
push(reg1);
CallRTL(CODE._set);
GetRegA
|CODE.opINCL, CODE.opEXCL:
BinOp(reg1, reg2);
cmprc(reg1, 64);
OutByte2(73H, 04H); // jnb L
Rex(reg2, reg1);
OutByte3(0FH, 0ABH + 8 * ORD(cmd.opcode = CODE.opEXCL), 8 * (reg1 MOD 8) + reg2 MOD 8); // bts/btr qword[reg2], reg1
// L:
drop;
drop
|CODE.opINCLC, CODE.opEXCLC:
UnOp(reg1);
Rex(reg1, 0);
OutByte2(0FH, 0BAH); // bts/btr qword[reg1], param2
OutByte2(28H + 8 * ORD(cmd.opcode = CODE.opEXCLC) + reg1 MOD 8, param2);
drop
|CODE.opEQS .. CODE.opGES:
PushAll(4);
pushc(cmd.opcode - CODE.opEQS);
CallRTL(CODE._strcmp);
GetRegA
|CODE.opEQS2 .. CODE.opGES2:
PushAll(4);
pushc(cmd.opcode - CODE.opEQS2);
CallRTL(CODE._strcmp2);
GetRegA
|CODE.opEQSW .. CODE.opGESW:
PushAll(4);
pushc(cmd.opcode - CODE.opEQSW);
CallRTL(CODE._strcmpw);
GetRegA
|CODE.opEQSW2 .. CODE.opGESW2:
PushAll(4);
pushc(cmd.opcode - CODE.opEQSW2);
CallRTL(CODE._strcmpw2);
GetRegA
|CODE.opINC1, CODE.opDEC1:
UnOp(reg1);
Rex(reg1, 0);
OutByte2(0FFH, reg1 MOD 8 + 8 * ORD(cmd.opcode = CODE.opDEC1));
drop
|CODE.opCONST:
reg1 := REG.GetAnyReg(R);
movrc(reg1, param2)
|CODE.opGT, CODE.opGE, CODE.opLT,
CODE.opLE, CODE.opEQ, CODE.opNE:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
drop;
drop;
cc := X86.cond(cmd.opcode);
IF cmd.next(COMMAND).opcode = CODE.opJE THEN
label := cmd.next(COMMAND).param1;
jcc(cc, label);
cmd := cmd.next(COMMAND)
ELSIF cmd.next(COMMAND).opcode = CODE.opJNE THEN
label := cmd.next(COMMAND).param1;
jcc(X86.inv1(cc), label);
cmd := cmd.next(COMMAND)
ELSE
reg1 := REG.GetAnyReg(R);
setcc(cc + 16, reg1);
andrc(reg1, 1)
END
|CODE.opGTR, CODE.opLTL, CODE.opGER, CODE.opLEL,
CODE.opLER, CODE.opGEL, CODE.opLTR, CODE.opGTL,
CODE.opEQR, CODE.opEQL, CODE.opNER, CODE.opNEL:
UnOp(reg1);
IF param2 = 0 THEN
test(reg1)
ELSE
cmprc(reg1, param2)
END;
drop;
cc := X86.cond(cmd.opcode);
IF cmd.next(COMMAND).opcode = CODE.opJE THEN
label := cmd.next(COMMAND).param1;
jcc(cc, label);
cmd := cmd.next(COMMAND)
ELSIF cmd.next(COMMAND).opcode = CODE.opJNE THEN
label := cmd.next(COMMAND).param1;
jcc(X86.inv1(cc), label);
cmd := cmd.next(COMMAND)
ELSE
reg1 := REG.GetAnyReg(R);
setcc(cc + 16, reg1);
andrc(reg1, 1)
END
|CODE.opCODE:
OutByte(param2)
|CODE.opPUSHIP:
reg1 := REG.GetAnyReg(R);
lea(reg1, param2, sIMP);
movrm(reg1, reg1, 0)
|CODE.opPARAM:
n := param2;
IF n = 1 THEN
UnOp(reg1);
push(reg1);
drop
ELSE
ASSERT(R.top + 1 <= n);
PushAll(n)
END
|CODE.opJNZ:
UnOp(reg1);
test(reg1);
jcc(jne, param1)
|CODE.opJZ:
UnOp(reg1);
test(reg1);
jcc(je, param1)
|CODE.opJE:
UnOp(reg1);
test(reg1);
jcc(jne, param1);
drop
|CODE.opJNE:
UnOp(reg1);
test(reg1);
jcc(je, param1);
drop
|CODE.opIN:
label := NewLabel();
L := NewLabel();
BinOp(reg1, reg2);
cmprc(reg1, 64);
jcc(jb, L);
xor(reg1, reg1);
jmp(label);
X86.SetLabel(L);
Rex(reg2, reg1);
OutByte3(0FH, 0A3H, 0C0H + 8 * (reg1 MOD 8) + reg2 MOD 8); // bt reg2, reg1
setcc(setc, reg1);
andrc(reg1, 1);
X86.SetLabel(label);
drop
|CODE.opINR:
label := NewLabel();
L := NewLabel();
UnOp(reg1);
reg2 := REG.GetAnyReg(R);
cmprc(reg1, 64);
jcc(jb, L);
xor(reg1, reg1);
jmp(label);
X86.SetLabel(L);
movrc(reg2, param2);
Rex(reg2, reg1);
OutByte3(0FH, 0A3H, 0C0H + 8 * (reg1 MOD 8) + reg2 MOD 8); // bt reg2, reg1
setcc(setc, reg1);
andrc(reg1, 1);
X86.SetLabel(label);
drop
|CODE.opINL:
UnOp(reg1);
Rex(reg1, 0);
OutByte2(0FH, 0BAH); // bt reg1, param2
OutByte2(0E0H + reg1 MOD 8, param2);
setcc(setc, reg1);
andrc(reg1, 1)
|CODE.opNOT:
UnOp(reg1);
test(reg1);
setcc(sete, reg1);
andrc(reg1, 1)
|CODE.opORD:
UnOp(reg1);
test(reg1);
setcc(setne, reg1);
andrc(reg1, 1)
|CODE.opABS:
UnOp(reg1);
test(reg1);
OutByte2(7DH, 03H); // jge L
neg(reg1)
// L:
|CODE.opEQB, CODE.opNEB:
BinOp(reg1, reg2);
drop;
drop;
test(reg1);
OutByte2(74H, 07H); // je L1
movrc(reg1, 1);
// L1:
test(reg2);
OutByte2(74H, 07H); // je L2
movrc(reg2, 1);
// L2:
cmprr(reg1, reg2);
reg1 := REG.GetAnyReg(R);
IF cmd.opcode = CODE.opEQB THEN
setcc(sete, reg1)
ELSE
setcc(setne, reg1)
END;
andrc(reg1, 1)
|CODE.opMULSC:
UnOp(reg1);
andrc(reg1, param2)
|CODE.opDIVSC, CODE.opADDSL, CODE.opADDSR:
UnOp(reg1);
Rex(reg1, 0);
OutByte2(81H + short(param2), 0C8H + 28H * ORD(cmd.opcode = CODE.opDIVSC) + reg1 MOD 8); // or/xor reg1, param2
OutIntByte(param2)
|CODE.opSUBSL:
UnOp(reg1);
not(reg1);
andrc(reg1, param2)
|CODE.opSUBSR:
UnOp(reg1);
andrc(reg1, ORD(-BITS(param2)))
|CODE.opMULS:
BinOp(reg1, reg2);
and(reg1, reg2);
drop
|CODE.opDIVS:
BinOp(reg1, reg2);
xor(reg1, reg2);
drop
|CODE.opUMINS:
UnOp(reg1);
not(reg1)
|CODE.opCOPY:
PushAll(2);
pushc(param2);
CallRTL(CODE._move2)
|CODE.opMOVE:
PushAll(3);
CallRTL(CODE._move2)
|CODE.opCOPYA:
PushAll(4);
pushc(param2);
CallRTL(CODE._arrcpy);
GetRegA
|CODE.opCOPYS:
PushAll(4);
pushc(param2);
CallRTL(CODE._strcpy)
|CODE.opCOPYS2:
PushAll(4);
pushc(param2);
CallRTL(CODE._strcpy2)
|CODE.opROT:
PushAll(0);
push(rsp);
pushc(param2);
CallRTL(CODE._rot)
|CODE.opNEW:
PushAll(1);
n := param2 + 16;
ASSERT(MACHINE.Align(n, 64));
pushc(n);
pushc(param1);
CallRTL(CODE._new)
|CODE.opDISP:
PushAll(1);
CallRTL(CODE._dispose)
|CODE.opPUSHT:
UnOp(reg1);
reg2 := REG.GetAnyReg(R);
movrm(reg2, reg1, -8)
|CODE.opISREC:
PushAll(2);
pushc(param2);
CallRTL(CODE._isrec);
GetRegA
|CODE.opIS:
PushAll(1);
pushc(param2);
CallRTL(CODE._is);
GetRegA
|CODE.opTYPEGR:
PushAll(1);
pushc(param2);
CallRTL(CODE._guardrec);
GetRegA
|CODE.opTYPEGP:
UnOp(reg1);
PushAll(0);
push(reg1);
pushc(param2);
CallRTL(CODE._guard);
GetRegA
|CODE.opTYPEGD:
UnOp(reg1);
PushAll(0);
pushm(reg1, -8);
pushc(param2);
CallRTL(CODE._guardrec);
GetRegA
|CODE.opCASET:
push(r10);
push(r10);
pushc(param2);
CallRTL(CODE._guardrec);
pop(r10);
test(rax);
jcc(jne, param1)
|CODE.opSAVEP:
UnOp(reg1);
reg2 := REG.GetAnyReg(R);
lea(reg2, param2, sCODE);
movmr(reg1, 0, reg2);
drop;
drop
|CODE.opPUSHP:
reg1 := REG.GetAnyReg(R);
lea(reg1, param2, sCODE)
|CODE.opINC, CODE.opDEC:
BinOp(reg1, reg2);
// add/sub qword[reg2], reg1
Rex(reg2, reg1);
OutByte2(01H + 28H * ORD(cmd.opcode = CODE.opDEC), reg2 MOD 8 + (reg1 MOD 8) * 8);
drop;
drop
|CODE.opINCC, CODE.opDECC:
UnOp(reg1);
IF isLong(param2) THEN
reg2 := REG.GetAnyReg(R);
movrc(reg2, param2);
// add/sub qword[reg1], reg2
Rex(reg1, reg2);
OutByte2(01H + 28H * ORD(cmd.opcode = CODE.opDECC), reg1 MOD 8 + (reg2 MOD 8) * 8);
drop
ELSE
// add/sub qword[reg1], param2
Rex(reg1, 0);
OutByte2(81H + short(param2), 28H * ORD(cmd.opcode = CODE.opDECC) + reg1 MOD 8);
OutIntByte(param2)
END;
drop
|CODE.opDROP:
UnOp(reg1);
drop
|CODE.opSAVE, CODE.opSAVE64:
BinOp(reg2, reg1);
movmr(reg1, 0, reg2);
drop;
drop
|CODE.opSAVE8:
BinOp(reg2, reg1);
movmr8(reg1, 0, reg2);
drop;
drop
|CODE.opSAVE16:
BinOp(reg2, reg1);
movmr16(reg1, 0, reg2);
drop;
drop
|CODE.opSAVE32:
BinOp(reg2, reg1);
movmr32(reg1, 0, reg2);
drop;
drop
|CODE.opMIN:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(7EH, 3); // jle L
mov(reg1, reg2);
// L:
drop
|CODE.opMAX:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(7DH, 3); // jge L
mov(reg1, reg2);
// L:
drop
|CODE.opMINC:
UnOp(reg1);
cmprc(reg1, param2);
label := NewLabel();
jcc(jle, label);
movrc(reg1, param2);
X86.SetLabel(label)
|CODE.opMAXC:
UnOp(reg1);
cmprc(reg1, param2);
label := NewLabel();
jcc(jge, label);
movrc(reg1, param2);
X86.SetLabel(label)
|CODE.opSBOOL:
BinOp(reg2, reg1);
test(reg2);
setcc(setne, reg2);
movmr8(reg1, 0, reg2);
drop;
drop
|CODE.opSBOOLC:
UnOp(reg1);
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(0C6H, reg1 MOD 8, ORD(param2 # 0));
drop
|CODE.opODD:
UnOp(reg1);
andrc(reg1, 1)
|CODE.opUMINUS:
UnOp(reg1);
neg(reg1)
|CODE.opADD:
BinOp(reg1, reg2);
add(reg1, reg2);
drop
|CODE.opSUB:
BinOp(reg1, reg2);
sub(reg1, reg2);
drop
|CODE.opSUBR, CODE.opSUBL:
UnOp(reg1);
n := param2;
IF n = 1 THEN
decr(reg1)
ELSIF n = -1 THEN
incr(reg1)
ELSIF n # 0 THEN
subrc(reg1, n)
END;
IF cmd.opcode = CODE.opSUBL THEN
neg(reg1)
END
|CODE.opADDL, CODE.opADDR:
IF param2 # 0 THEN
UnOp(reg1);
IF param2 = 1 THEN
incr(reg1)
ELSIF param2 = -1 THEN
decr(reg1)
ELSE
addrc(reg1, param2)
END
END
|CODE.opDIV:
PushAll(2);
CallRTL(CODE._div);
GetRegA
|CODE.opDIVR:
a := param2;
IF a > 1 THEN
n := X86.log2(a)
ELSIF a < -1 THEN
n := X86.log2(-a)
ELSE
n := -1
END;
IF a = 1 THEN
ELSIF a = -1 THEN
UnOp(reg1);
neg(reg1)
ELSE
IF n > 0 THEN
UnOp(reg1);
IF a < 0 THEN
reg2 := REG.GetAnyReg(R);
mov(reg2, reg1);
shiftrc(sar, reg1, n);
sub(reg1, reg2);
drop
ELSE
shiftrc(sar, reg1, n)
END
ELSE
PushAll(1);
pushc(param2);
CallRTL(CODE._div);
GetRegA
END
END
|CODE.opDIVL:
PushAll(1);
pushc(param2);
CallRTL(CODE._div2);
GetRegA
|CODE.opMOD:
PushAll(2);
CallRTL(CODE._mod);
GetRegA
|CODE.opMODR:
a := param2;
IF a > 1 THEN
n := X86.log2(a)
ELSIF a < -1 THEN
n := X86.log2(-a)
ELSE
n := -1
END;
IF ABS(a) = 1 THEN
UnOp(reg1);
xor(reg1, reg1)
ELSE
IF n > 0 THEN
UnOp(reg1);
andrc(reg1, ABS(a) - 1);
IF a < 0 THEN
test(reg1);
label := NewLabel();
jcc(je, label);
addrc(reg1, a);
X86.SetLabel(label)
END
ELSE
PushAll(1);
pushc(param2);
CallRTL(CODE._mod);
GetRegA
END
END
|CODE.opMODL:
PushAll(1);
pushc(param2);
CallRTL(CODE._mod2);
GetRegA
|CODE.opMUL:
BinOp(reg1, reg2);
oprr2(0FH, 0AFH, reg2, reg1); // imul reg1, reg2
drop
|CODE.opMULC:
UnOp(reg1);
a := param2;
IF a > 1 THEN
n := X86.log2(a)
ELSIF a < -1 THEN
n := X86.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
// imul reg1, a
Rex(reg1, reg1);
OutByte2(69H + short(a), 0C0H + (reg1 MOD 8) * 9);
OutIntByte(a)
END
END
|CODE.opADDS:
BinOp(reg1, reg2);
or(reg1, reg2);
drop
|CODE.opSUBS:
BinOp(reg1, reg2);
not(reg2);
and(reg1, reg2);
drop
|CODE.opNOP:
|CODE.opSWITCH:
UnOp(reg1);
IF param2 = 0 THEN
reg2 := rax
ELSE
reg2 := r10
END;
IF reg1 # reg2 THEN
ASSERT(REG.GetReg(R, reg2));
ASSERT(REG.Exchange(R, reg1, reg2));
drop
END;
drop
|CODE.opENDSW:
|CODE.opCASEL:
cmprc(rax, param1);
jcc(jl, param2)
|CODE.opCASER:
cmprc(rax, param1);
jcc(jg, param2)
|CODE.opCASELR:
cmprc(rax, param1);
jcc(jl, param2);
jcc(jg, cmd.param3)
|CODE.opASR, CODE.opROR, CODE.opLSL, CODE.opLSR:
BinOp(reg1, reg2);
xchg(reg2, rcx);
Rex(reg1, 0);
OutByte(0D3H);
X86.shift(cmd.opcode, reg1 MOD 8); // shift reg1, cl
xchg(reg2, rcx);
drop
|CODE.opASR1, CODE.opROR1, CODE.opLSL1, CODE.opLSR1:
reg1 := REG.GetAnyReg(R);
movrc(reg1, param2);
BinOp(reg1, reg2);
xchg(reg1, rcx);
Rex(reg2, 0);
OutByte(0D3H);
X86.shift(cmd.opcode, reg2 MOD 8); // shift reg2, cl
xchg(reg1, rcx);
drop;
drop;
ASSERT(REG.GetReg(R, reg2))
|CODE.opASR2, CODE.opROR2, CODE.opLSL2, CODE.opLSR2:
UnOp(reg1);
shiftrc(cmd.opcode, reg1, ORD(BITS(param2) * {0..5}))
|CODE.opGET:
BinOp(reg1, reg2);
drop;
drop;
_movrm(reg1, reg1, 0, param2 * 8, FALSE);
_movrm(reg1, reg2, 0, param2 * 8, TRUE)
|CODE.opCHKBYTE:
BinOp(reg1, reg2);
cmprc(reg1, 256);
jcc(jb, param1)
|CODE.opCHKIDX:
UnOp(reg1);
cmprc(reg1, param2);
jcc(jb, param1)
|CODE.opCHKIDX2:
BinOp(reg1, reg2);
IF param2 # -1 THEN
cmprr(reg2, reg1);
mov(reg1, reg2);
drop;
jcc(jb, param1)
ELSE
INCL(R.regs, reg1);
DEC(R.top);
R.stk[R.top] := reg2
END
|CODE.opLENGTH:
PushAll(2);
CallRTL(CODE._length);
GetRegA
|CODE.opLENGTHW:
PushAll(2);
CallRTL(CODE._lengthw);
GetRegA
|CODE.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))
|CODE.opCHR:
UnOp(reg1);
andrc(reg1, 255)
|CODE.opWCHR:
UnOp(reg1);
andrc(reg1, 65535)
|CODE.opEQP, CODE.opNEP, CODE.opEQIP, CODE.opNEIP:
UnOp(reg1);
reg2 := REG.GetAnyReg(R);
CASE cmd.opcode OF
|CODE.opEQP, CODE.opNEP:
lea(reg2, param1, sCODE)
|CODE.opEQIP, CODE.opNEIP:
lea(reg2, param1, sIMP);
movrm(reg2, reg2, 0)
END;
cmprr(reg1, reg2);
drop;
drop;
reg1 := REG.GetAnyReg(R);
CASE cmd.opcode OF
|CODE.opEQP, CODE.opEQIP: setcc(sete, reg1)
|CODE.opNEP, CODE.opNEIP: setcc(setne, reg1)
END;
andrc(reg1, 1)
|CODE.opINC1B, CODE.opDEC1B:
UnOp(reg1);
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte2(0FEH, 8 * ORD(cmd.opcode = CODE.opDEC1B) + reg1 MOD 8); // inc/dec byte[reg1]
drop
|CODE.opINCCB, CODE.opDECCB:
UnOp(reg1);
IF reg1 >= 8 THEN
OutByte(41H)
END;
OutByte3(80H, 28H * ORD(cmd.opcode = CODE.opDECCB) + reg1 MOD 8, param2 MOD 256); // add/sub byte[reg1], param2 MOD 256
drop
|CODE.opINCB, CODE.opDECB:
BinOp(reg1, reg2);
IF (reg1 >= 8) OR (reg2 >= 8) THEN
OutByte(40H + reg2 DIV 8 + 4 * (reg1 DIV 8))
END;
OutByte2(28H * ORD(cmd.opcode = CODE.opDECB), reg2 MOD 8 + 8 * (reg1 MOD 8)); // add/sub byte[reg2], reg1_8
drop;
drop
|CODE.opSAVEIP:
UnOp(reg1);
reg2 := REG.GetAnyReg(R);
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
|CODE.opCLEANUP:
n := param2 * 8;
IF n # 0 THEN
addrc(rsp, n)
END
|CODE.opPOPSP:
pop(rsp)
|CODE.opLOADF:
UnOp(reg1);
INC(xmm);
movsdrm(xmm, reg1, 0);
drop
|CODE.opPUSHF:
subrc(rsp, 8);
movsdmr(rsp, 0, xmm);
DEC(xmm)
|CODE.opCONSTF:
float := cmd.float;
INC(xmm);
reg1 := REG.GetAnyReg(R);
lea(reg1, Numbers_Offs + Numbers_Count * 8, sDATA);
movsdrm(xmm, reg1, 0);
drop;
NewNumber(UTILS.splitf(float, a, b))
|CODE.opSAVEF:
UnOp(reg1);
movsdmr(reg1, 0, xmm);
DEC(xmm);
drop
|CODE.opADDF, CODE.opADDFI:
opxx(58H, xmm - 1, xmm);
DEC(xmm)
|CODE.opSUBF:
opxx(5CH, xmm - 1, xmm);
DEC(xmm)
|CODE.opSUBFI:
opxx(5CH, xmm, xmm - 1);
opxx(10H, xmm - 1, xmm);
DEC(xmm)
|CODE.opMULF:
opxx(59H, xmm - 1, xmm);
DEC(xmm)
|CODE.opDIVF:
opxx(5EH, xmm - 1, xmm);
DEC(xmm)
|CODE.opDIVFI:
opxx(5EH, xmm, xmm - 1);
opxx(10H, xmm - 1, xmm);
DEC(xmm)
|CODE.opUMINF:
reg1 := REG.GetAnyReg(R);
lea(reg1, Numbers_Offs, sDATA);
OutByte3(66H, 40H + reg1 DIV 8 + (xmm DIV 8) * 4, 0FH); // xorpd xmm, xmmword[reg1]
OutByte2(57H, reg1 MOD 8 + (xmm MOD 8) * 8);
drop
|CODE.opFABS:
reg1 := REG.GetAnyReg(R);
lea(reg1, Numbers_Offs + 16, sDATA);
OutByte3(66H, 40H + reg1 DIV 8 + (xmm DIV 8) * 4, 0FH); // andpd xmm, xmmword[reg1]
OutByte2(54H, reg1 MOD 8 + (xmm MOD 8) * 8);
drop
|CODE.opFLT:
UnOp(reg1);
INC(xmm);
OutByte(0F2H); Rex(reg1, xmm); OutByte(0FH); // cvtsi2sd xmm, reg1
OutByte2(2AH, 0C0H + (xmm MOD 8) * 8 + reg1 MOD 8);
drop
|CODE.opFLOOR:
reg1 := REG.GetAnyReg(R);
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)
|CODE.opEQF .. CODE.opGEFI:
fcmp(cmd.opcode, xmm);
DEC(xmm, 2)
|CODE.opINF:
INC(xmm);
reg1 := REG.GetAnyReg(R);
lea(reg1, Numbers_Offs + 32, sDATA);
movsdrm(xmm, reg1, 0);
drop
|CODE.opPACK, CODE.opPACKC:
IF cmd.opcode = CODE.opPACK THEN
BinOp(reg1, reg2)
ELSE
UnOp(reg1);
reg2 := REG.GetAnyReg(R);
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
|CODE.opUNPK, CODE.opLADR_UNPK:
IF cmd.opcode = CODE.opLADR_UNPK THEN
n := param2 * 8;
UnOp(reg1);
reg2 := REG.GetVarReg(R, param2);
regVar := reg2 # -1;
IF ~regVar THEN
reg2 := REG.GetAnyReg(R);
Rex(0, reg2);
OutByte2(8DH, 45H + long(n) + (reg2 MOD 8) * 8); // lea reg2, qword[rbp+n]
OutIntByte(n)
END
ELSE
BinOp(reg1, reg2);
regVar := FALSE
END;
push(reg1);
movrm(reg1, reg1, 0);
shiftrc(shl, reg1, 1);
shiftrc(shr, reg1, 53);
subrc(reg1, 1023);
IF regVar THEN
mov(reg2, reg1);
reg2 := REG.GetAnyReg(R)
ELSE
movmr(reg2, 0, reg1)
END;
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
|CODE.opSADR_PARAM:
pushDA(stroffs + param2)
|CODE.opVADR_PARAM:
pushm(rbp, param2 * 8)
|CODE.opLOAD64_PARAM:
UnOp(reg1);
pushm(reg1, 0);
drop
|CODE.opLLOAD64_PARAM:
reg1 := REG.GetVarReg(R, param2);
IF reg1 # -1 THEN
push(reg1)
ELSE
pushm(rbp, param2 * 8)
END
|CODE.opGLOAD64_PARAM:
reg2 := REG.GetAnyReg(R);
lea(reg2, param2, sBSS);
movrm(reg2, reg2, 0);
push(reg2);
drop
|CODE.opCONST_PARAM:
pushc(param2)
|CODE.opGLOAD32_PARAM:
reg1 := REG.GetAnyReg(R);
xor(reg1, reg1);
lea(reg1, param2, sBSS);
movrm32(reg1, reg1, 0);
push(reg1);
drop
|CODE.opLOAD32_PARAM:
UnOp(reg1);
movrm32(reg1, reg1, 0);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32);
push(reg1);
drop
|CODE.opLLOAD32_PARAM:
reg1 := REG.GetAnyReg(R);
xor(reg1, reg1);
reg2 := REG.GetVarReg(R, param2);
IF reg2 # -1 THEN
mov(reg1, reg2)
ELSE
movrm32(reg1, rbp, param2 * 8)
END;
push(reg1);
drop
|CODE.opLADR_SAVEC:
n := param1 * 8;
reg1 := REG.GetVarReg(R, param1);
IF reg1 # -1 THEN
movrc(reg1, param2)
ELSE
IF isLong(param2) THEN
reg2 := REG.GetAnyReg(R);
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
END
|CODE.opGADR_SAVEC:
IF isLong(param2) THEN
reg1 := REG.GetAnyReg(R);
movrc(reg1, param2);
reg2 := REG.GetAnyReg(R);
lea(reg2, param1, sBSS);
movmr(reg2, 0, reg1);
drop;
drop
ELSE
reg2 := REG.GetAnyReg(R);
lea(reg2, param1, sBSS);
Rex(reg2, 0);
OutByte2(0C7H, reg2 MOD 8); // mov qword[reg2], param2
OutInt(param2);
drop
END
|CODE.opLADR_SAVE:
UnOp(reg1);
reg2 := REG.GetVarReg(R, param2);
IF reg2 # -1 THEN
mov(reg2, reg1)
ELSE
movmr(rbp, param2 * 8, reg1)
END;
drop
|CODE.opLADR_INC1:
reg1 := REG.GetVarReg(R, param2);
IF reg1 # -1 THEN
incr(reg1)
ELSE
n := param2 * 8;
OutByte3(48H, 0FFH, 45H + long(n)); // inc qword[rbp+n]
OutIntByte(n)
END
|CODE.opLADR_DEC1:
reg1 := REG.GetVarReg(R, param2);
IF reg1 # -1 THEN
decr(reg1)
ELSE
n := param2 * 8;
OutByte3(48H, 0FFH, 4DH + long(n)); // dec qword[rbp+n]
OutIntByte(n)
END
|CODE.opLADR_INCC, CODE.opLADR_DECC:
reg1 := REG.GetVarReg(R, param1);
IF isLong(param2) THEN
reg2 := REG.GetAnyReg(R);
movrc(reg2, param2);
IF reg1 # -1 THEN
IF cmd.opcode = CODE.opLADR_DECC THEN
sub(reg1, reg2)
ELSE
add(reg1, reg2)
END
ELSE
n := param1 * 8;
Rex(0, reg2);
OutByte2(01H + 28H * ORD(cmd.opcode = CODE.opLADR_DECC), 45H + long(n) + (reg2 MOD 8) * 8);
OutIntByte(n) // add/sub qword[rbp+n],reg2
END;
drop
ELSE
IF reg1 # -1 THEN
IF cmd.opcode = CODE.opLADR_DECC THEN
subrc(reg1, param2)
ELSE
addrc(reg1, param2)
END
ELSE
n := param1 * 8;
OutByte3(48H, 81H + short(param2), 45H + long(n) + 28H * ORD(cmd.opcode = CODE.opLADR_DECC));
OutIntByte(n);
OutIntByte(param2) // add/sub qword[rbp+n],param2
END
END
|CODE.opLADR_INC1B, CODE.opLADR_DEC1B:
reg1 := REG.GetVarReg(R, param2);
IF reg1 # -1 THEN
IF cmd.opcode = CODE.opLADR_DEC1B THEN
decr(reg1)
ELSE
incr(reg1)
END;
andrc(reg1, 255)
ELSE
n := param2 * 8;
OutByte2(0FEH, 45H + long(n) + 8 * ORD(cmd.opcode = CODE.opLADR_DEC1B));
OutIntByte(n) // inc/dec byte[rbp+n]
END
|CODE.opLADR_INCCB, CODE.opLADR_DECCB:
reg1 := REG.GetVarReg(R, param1);
param2 := param2 MOD 256;
IF reg1 # -1 THEN
IF cmd.opcode = CODE.opLADR_DECCB THEN
subrc(reg1, param2)
ELSE
addrc(reg1, param2)
END;
andrc(reg1, 255)
ELSE
n := param1 * 8;
OutByte2(80H, 45H + long(n) + 28H * ORD(cmd.opcode = CODE.opLADR_DECCB));
OutIntByte(n);
OutByte(param2) // add/sub byte[rbp+n],param2
END
|CODE.opLADR_INC, CODE.opLADR_DEC:
UnOp(reg1);
reg2 := REG.GetVarReg(R, param2);
IF reg2 # -1 THEN
IF cmd.opcode = CODE.opLADR_DEC THEN
sub(reg2, reg1)
ELSE
add(reg2, reg1)
END
ELSE
n := param2 * 8;
Rex(0, reg1);
OutByte2(01H + 28H * ORD(cmd.opcode = CODE.opLADR_DEC), 45H + long(n) + (reg1 MOD 8) * 8);
OutIntByte(n) // add/sub qword[rbp+n],reg1
END;
drop
|CODE.opLADR_INCB, CODE.opLADR_DECB:
UnOp(reg1);
reg2 := REG.GetVarReg(R, param2);
IF reg2 # -1 THEN
IF cmd.opcode = CODE.opLADR_DECB THEN
sub(reg2, reg1)
ELSE
add(reg2, reg1)
END;
andrc(reg2, 255)
ELSE
n := param2 * 8;
IF reg1 >= 8 THEN
OutByte(44H)
END;
OutByte2(28H * ORD(cmd.opcode = CODE.opLADR_DECB), 45H + long(n) + 8 * (reg1 MOD 8));
OutIntByte(n) // add/sub byte[rbp+n], reg1_8
END;
drop
|CODE.opLADR_INCL, CODE.opLADR_EXCL:
UnOp(reg1);
cmprc(reg1, 64);
reg2 := REG.GetVarReg(R, param2);
IF reg2 # -1 THEN
OutByte2(73H, 4); // jnb L
oprr2(0FH, 0ABH + 8 * ORD(cmd.opcode = CODE.opLADR_EXCL), reg2, reg1) // bts/btr reg2, reg1
ELSE
n := param2 * 8;
OutByte2(73H, 5 + 3 * ORD(~isByte(n))); // jnb L
Rex(0, reg1);
OutByte3(0FH, 0ABH + 8 * ORD(cmd.opcode = CODE.opLADR_EXCL), 45H + long(n) + 8 * (reg1 MOD 8));
OutIntByte(n) // bts/btr qword[rbp+n], reg1
END;
// L:
drop
|CODE.opLADR_INCLC, CODE.opLADR_EXCLC:
reg1 := REG.GetVarReg(R, param1);
IF reg1 # -1 THEN
Rex(reg1, 0);
OutByte3(0FH, 0BAH, 0E8H); // bts/btr reg1, param2
OutByte2(reg1 MOD 8 + 8 * ORD(cmd.opcode = CODE.opLADR_EXCLC), param2)
ELSE
n := param1 * 8;
OutByte3(48H, 0FH, 0BAH); // bts/btr qword[rbp+n], param2
OutByte(6DH + long(n) + 8 * ORD(cmd.opcode = CODE.opLADR_EXCLC));
OutIntByte(n);
OutByte(param2)
END
|CODE.opLOOP, CODE.opENDLOOP:
END;
cmd := cmd.next(COMMAND)
END;
ASSERT(R.pushed = 0);
ASSERT(R.top = -1);
ASSERT(xmm = -1)
END translate;
PROCEDURE prolog (code: CODE.CODES; modname: ARRAY OF CHAR; target, stack_size: INTEGER);
VAR
ModName_Offs, entry: INTEGER;
BEGIN
ModName_Offs := CHL.Length(code.types) * 8 + CHL.Length(code.data);
Numbers_Offs := ModName_Offs + LENGTH(modname) + 1;
ASSERT(MACHINE.Align(Numbers_Offs, 16));
entry := NewLabel();
X86.SetLabel(entry);
IF target = mConst.Target_iDLL64 THEN
dllret := NewLabel();
push(r8);
push(rdx);
push(rcx);
CallRTL(CODE._dllentry);
test(rax);
jcc(je, dllret)
END;
push(rsp);
lea(rax, entry, sCODE);
push(rax);
pushDA(0); //TYPES
pushc(CHL.Length(code.types));
pushDA(ModName_Offs); //MODNAME
CallRTL(CODE._init)
END prolog;
PROCEDURE epilog (code: CODE.CODES; modname: ARRAY OF CHAR; target: INTEGER);
VAR
i, n: INTEGER;
number: Number;
exp: CODE.EXPORT_PROC;
PROCEDURE import (imp: LISTS.LIST);
VAR
lib: CODE.IMPORT_LIB;
proc: CODE.IMPORT_PROC;
BEGIN
lib := imp.first(CODE.IMPORT_LIB);
WHILE lib # NIL DO
BIN.Import(prog, lib.name, 0);
proc := lib.procs.first(CODE.IMPORT_PROC);
WHILE proc # NIL DO
BIN.Import(prog, proc.name, proc.label);
proc := proc.next(CODE.IMPORT_PROC)
END;
lib := lib.next(CODE.IMPORT_LIB)
END
END import;
BEGIN
IF target = mConst.Target_iDLL64 THEN
X86.SetLabel(dllret);
OutByte(0C3H) // ret
ELSE
pushc(0);
CallRTL(CODE._exit)
END;
X86.fixup;
i := 0;
WHILE i < CHL.Length(code.types) DO
BIN.PutData64LE(prog, CHL.GetInt(code.types, i));
INC(i)
END;
i := 0;
WHILE i < CHL.Length(code.data) DO
BIN.PutData(prog, CHL.GetByte(code.data, i));
INC(i)
END;
BIN.PutDataStr(prog, modname);
BIN.PutData(prog, 0);
n := CHL.Length(prog.data);
ASSERT(MACHINE.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 := code.export.first(CODE.EXPORT_PROC);
WHILE exp # NIL DO
BIN.Export(prog, exp.name, exp.label);
exp := exp.next(CODE.EXPORT_PROC)
END;
import(code.import)
END epilog;
PROCEDURE rload (reg, offs, size: INTEGER);
BEGIN
offs := offs * 8;
CASE size OF
|1: movzx(reg, rbp, offs, FALSE)
|2: movzx(reg, rbp, offs, TRUE)
|4: xor(reg, reg); movrm32(reg, rbp, offs)
|8: movrm(reg, rbp, offs)
END
END rload;
PROCEDURE rsave (reg, offs, size: INTEGER);
BEGIN
offs := offs * 8;
CASE size OF
|1: movmr8(rbp, offs, reg)
|2: movmr16(rbp, offs, reg)
|4: movmr32(rbp, offs, reg)
|8: movmr(rbp, offs, reg)
END
END rsave;
PROCEDURE CodeGen* (code: CODE.CODES; outname: ARRAY OF CHAR; target, stack, base: INTEGER);
VAR
path, modname, ext: PATHS.PATH;
n: INTEGER;
BEGIN
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);
R := REG.Create(push, pop, mov, xchg, rload, rsave, {rax, r10, r11}, {rcx, rdx, r8, r9});
n := code.dmin - CHL.Length(code.data);
IF n > 0 THEN
INC(code.bss, n)
END;
code.bss := MAX(code.bss, 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(code.lcount);
BIN.SetParams(prog, code.bss, stack, WCHR(1), WCHR(0));
X86.SetProgram(prog);
prolog(code, modname, target, stack);
translate(code.commands, CHL.Length(code.types) * 8);
epilog(code, modname, target);
BIN.fixup(prog);
IF target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN
PE32.write(prog, outname, base, target = mConst.Target_iConsole64, target = mConst.Target_iDLL64, TRUE)
ELSIF target = mConst.Target_iELF64 THEN
ELF.write(prog, outname, TRUE)
END
END CodeGen;
END AMD64.

/programs/develop/oberon07/Source/ARITH.ob07
0,0 → 1,861
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE ARITH;
IMPORT AVLTREES, STRINGS, MACHINE, UTILS;
CONST
tINTEGER* = 1; tREAL* = 2; tSET* = 3;
tBOOLEAN* = 4; tCHAR* = 5; tWCHAR* = 6;
tSTRING* = 7;
TYPE
RELATION* = ARRAY 3 OF CHAR;
VALUE* = RECORD
typ*: INTEGER;
int: INTEGER;
float: REAL;
set: SET;
bool: BOOLEAN;
string*: AVLTREES.DATA
END;
VAR
digit: ARRAY 256 OF INTEGER;
PROCEDURE Int* (v: VALUE): INTEGER;
VAR
res: INTEGER;
BEGIN
IF v.typ = tINTEGER THEN
res := v.int
ELSIF v.typ = tCHAR THEN
res := v.int
ELSIF v.typ = tWCHAR THEN
res := v.int
ELSIF v.typ = tSET THEN
res := ORD(v.set);
IF MACHINE._64to32 THEN
res := MACHINE.Int32To64(res)
END
ELSIF v.typ = tBOOLEAN THEN
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 check* (v: VALUE): BOOLEAN;
VAR
error: BOOLEAN;
BEGIN
error := FALSE;
IF (v.typ = tINTEGER) & ((v.int < MACHINE.target.minInt) OR (v.int > MACHINE.target.maxInt)) THEN
error := TRUE
ELSIF (v.typ = tCHAR) & ((v.int < 0) OR (v.int > 255)) THEN
error := TRUE
ELSIF (v.typ = tWCHAR) & ((v.int < 0) OR (v.int > 65535)) THEN
error := TRUE
ELSIF (v.typ = tREAL) & ((v.float < -MACHINE.target.maxReal) OR (v.float > MACHINE.target.maxReal)) THEN
error := TRUE
END
RETURN ~error
END check;
PROCEDURE isZero* (v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
ASSERT(v.typ IN {tINTEGER, tREAL});
IF v.typ = tINTEGER THEN
res := v.int = 0
ELSIF v.typ = tREAL THEN
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") & (error = 0) DO
d := digit[ORD(s[i])];
IF (n = -1) & (d # 0) THEN
n := i
END;
IF (n # -1) & (i - n + 1 > MACHINE.target.maxHex) THEN
error := 2
ELSE
value := value * 16 + d;
INC(i)
END
END;
IF MACHINE._64to32 THEN
value := MACHINE.Int32To64(value);
END;
IF (s[i] = "X") & (n # -1) & (i - n > 4) THEN
error := 3
END;
IF error = 0 THEN
v.int := value;
IF 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;
VAR
max: REAL;
res: BOOLEAN;
BEGIN
max := UTILS.maxreal;
CASE op OF
|"+":
IF (a < 0.0) & (b < 0.0) THEN
res := a > -max - b
ELSIF (a > 0.0) & (b > 0.0) THEN
res := a < max - b
ELSE
res := TRUE
END;
IF res THEN
a := a + b
END
|"-":
IF (a < 0.0) & (b > 0.0) THEN
res := a > b - max
ELSIF (a > 0.0) & (b < 0.0) THEN
res := a < b + max
ELSE
res := TRUE
END;
IF res THEN
a := a - b
END
|"*":
IF (ABS(a) > 1.0) & (ABS(b) > 1.0) THEN
res := ABS(a) < max / ABS(b)
ELSE
res := TRUE
END;
IF res THEN
a := a * b
END
|"/":
IF ABS(b) < 1.0 THEN
res := ABS(a) < max * ABS(b)
ELSE
res := TRUE
END;
IF res THEN
a := a / b
END
END
RETURN res
END opFloat2;
PROCEDURE fconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
value: REAL;
exp10: REAL;
i, n, d: INTEGER;
minus: BOOLEAN;
BEGIN
error := 0;
value := 0.0;
exp10 := 10.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(value, FLT(digit[ORD(s[i])]) / exp10, "+") & opFloat2(exp10, 10.0, "*") THEN
INC(i)
ELSE
error := 4
END
END;
IF 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 := 0;
WHILE ~ODD(x) DO
x := x DIV 2;
INC(n)
END;
IF x # 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;
BEGIN
IF MACHINE._64to32 THEN
x := MACHINE.Int32To64(x)
END
RETURN ASR(x, n)
END _ASR;
PROCEDURE _LSR (x, n: INTEGER): INTEGER;
BEGIN
IF MACHINE._64to32 THEN
x := MACHINE.Int64To32(x);
x := LSR(x, n);
x := MACHINE.Int32To64(x)
ELSE
x := LSR(x, n)
END
RETURN x
END _LSR;
PROCEDURE _LSL (x, n: INTEGER): INTEGER;
BEGIN
x := LSL(x, n);
IF MACHINE._64to32 THEN
x := MACHINE.Int32To64(x)
END
RETURN x
END _LSL;
PROCEDURE _ROR1_32 (x: INTEGER): INTEGER;
BEGIN
x := MACHINE.Int64To32(x);
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 31)))
RETURN MACHINE.Int32To64(x)
END _ROR1_32;
PROCEDURE _ROR (x, n: INTEGER): INTEGER;
BEGIN
IF MACHINE._64to32 THEN
n := n MOD 32;
WHILE n > 0 DO
x := _ROR1_32(x);
DEC(n)
END
ELSE
x := ROR(x, n)
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": IF (b.int # -1) OR (a.int # UTILS.minint) THEN a.int := a.int DIV b.int ELSE success := FALSE END
|"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 := ORD(v.set);
IF MACHINE._64to32 THEN
v.int := MACHINE.Int32To64(v.int)
END
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 range* (i: VALUE; a, b: INTEGER): BOOLEAN;
RETURN (a <= i.int) & (i.int <= b)
END range;
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; operator: RELATION; VAR error: INTEGER);
VAR
res: BOOLEAN;
BEGIN
error := 0;
res := FALSE;
CASE operator[0] OF
|"=":
res := equal(v, v2, error)
|"#":
res := ~equal(v, v2, error)
|"<":
IF operator[1] = "=" THEN
res := less(v, v2, error);
IF error = 0 THEN
res := equal(v, v2, error) OR res
END
ELSE
res := less(v, v2, error)
END
|">":
IF operator[1] = "=" THEN
res := ~less(v, v2, error)
ELSE
res := less(v, v2, error);
IF error = 0 THEN
res := equal(v, v2, error) OR res
END;
res := ~res
END
|"I":
IF (v.typ = tINTEGER) & (v2.typ = tSET) THEN
IF range(v, 0, MACHINE.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 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/AVLTREES.ob07
0,0 → 1,197
(*
BSD 2-Clause License
Copyright (c) 2018, 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/BIN.ob07
0,0 → 1,396
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE BIN;
IMPORT LISTS, MACHINE, CHL := CHUNKLISTS, ARITH, UTILS;
CONST
RCODE* = 1;
RDATA* = 2;
RBSS* = 3;
RIMP* = 4;
PICCODE* = 5;
PICDATA* = 6;
PICBSS* = 7;
PICIMP* = 8;
IMPTAB* = 9;
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 := MACHINE.Int32To64(x)
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, MACHINE.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, MACHINE.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, MACHINE.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, MACHINE.Byte(x, i))
END
END PutCode32LE;
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;
i: INTEGER;
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.Length(program.import);
imp.label := label;
LISTS.push(program.imp_list, imp);
i := 0;
WHILE name[i] # 0X DO
CHL.PushByte(program.import, ORD(name[i]));
INC(i)
END;
CHL.PushByte(program.import, 0)
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;
i: INTEGER;
BEGIN
NEW(exp);
exp.nameoffs := CHL.Length(program.export);
exp.label := CHL.GetInt(program.labels, label);
i := 0;
WHILE name[i] # 0X DO
CHL.PushByte(program.export, ORD(name[i]));
INC(i)
END;
CHL.PushByte(program.export, 0);
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: IMPRT;
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;
idx := idx + k
END InitArray;
END BIN.

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

/programs/develop/oberon07/Source/COLLECTIONS.ob07
0,0 → 1,59
(*
BSD 2-Clause License
Copyright (c) 2018, 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.

/programs/develop/oberon07/Source/CONSOLE.ob07
0,0 → 1,72
(*
BSD 2-Clause License
Copyright (c) 2018, 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* (n: INTEGER);
VAR
s: ARRAY 32 OF CHAR;
BEGIN
STRINGS.IntToStr(n, s);
String(s)
END Int;
PROCEDURE Int2* (n: INTEGER);
BEGIN
IF n < 10 THEN
String("0")
END;
Int(n)
END Int2;
PROCEDURE Ln*;
BEGIN
String(UTILS.eol)
END Ln;
PROCEDURE StringLn* (s: ARRAY OF CHAR);
BEGIN
String(s);
Ln
END StringLn;
PROCEDURE IntLn* (n: INTEGER);
BEGIN
Int(n);
Ln
END IntLn;
PROCEDURE Int2Ln* (n: INTEGER);
BEGIN
Int2(n);
Ln
END Int2Ln;
END CONSOLE.

/programs/develop/oberon07/Source/CONSTANTS.ob07
0,0 → 1,43
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE CONSTANTS;
CONST
vMajor* = 0;
vMinor* = 98;
FILE_EXT* = ".ob07";
RTL_NAME* = "RTL";
MAX_GLOBAL_SIZE* = 1600000000;
Target_iConsole* = 1;
Target_iGUI* = 2;
Target_iDLL* = 3;
Target_iKolibri* = 4;
Target_iObject* = 5;
Target_iConsole64* = 6;
Target_iGUI64* = 7;
Target_iDLL64* = 8;
Target_iELF32* = 9;
Target_iELF64* = 10;
Target_sConsole* = "console";
Target_sGUI* = "gui";
Target_sDLL* = "dll";
Target_sKolibri* = "kos";
Target_sObject* = "obj";
Target_sConsole64* = "console64";
Target_sGUI64* = "gui64";
Target_sDLL64* = "dll64";
Target_sELF32* = "elfexe";
Target_sELF64* = "elfexe64";
END CONSTANTS.

/programs/develop/oberon07/Source/Compiler.ob07
1,1958 → 1,280
(*
Copyright 2016, 2017, 2018 Anton Krotov
(*
BSD 2-Clause License
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE Compiler;
IMPORT DECL, SCAN, UTILS, X86, SYSTEM;
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, C := CONSOLE, ERRORS, STRINGS, mConst := CONSTANTS, WRITER;
CONST
Slash = UTILS.Slash;
lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7;
lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8;
lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16;
lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23;
lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30;
lxUNTIL = 31; lxVAR = 32; lxWHILE = 33;
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58;
lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65;
lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7;
TNIL = 8; TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14;
TNUM = {TINTEGER, TREAL, TLONGREAL};
TFLOAT = {TREAL, TLONGREAL};
TOBJECT = {TRECORD, TPOINTER};
TSTRUCT = {TARRAY, TRECORD};
eVAR = 1; eCONST = 2; eEXP = 3; ePROC = 4; eSTPROC = 5; eSYSPROC = 6;
IDMOD = 1; IDCONST = 2; IDTYPE = 3; IDVAR = 4; IDPROC = 5; IDSTPROC = 6; IDGUARD = 7; IDPARAM = 8; IDSYSPROC = 9;
stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8;
stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15;
stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22;
stBITS = 23; stLSR = 24; stLENGTH = 25; stMIN = 26; stMAX = 27;
sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; sysCOPY = 109;
TYPE
LABEL = POINTER TO RECORD (UTILS.rITEM)
a, b: INTEGER
END;
PROCEDURE Target (s: ARRAY OF CHAR): INTEGER;
VAR
res: INTEGER;
pExpr, pFactor: PROCEDURE (VAR e: DECL.EXPRESSION);
pOpSeq: PROCEDURE;
sttypes: DECL.stTYPES;
voidtype, inttype, booltype, strtype, settype, realtype, longrealtype, chartype, niltype: DECL.pTYPE;
PROCEDURE Load(e: DECL.EXPRESSION);
BEGIN
IF e.eType = eVAR THEN
X86.Load(e.T.tType)
IF s = mConst.Target_sConsole THEN
res := mConst.Target_iConsole
ELSIF s = mConst.Target_sGUI THEN
res := mConst.Target_iGUI
ELSIF s = mConst.Target_sDLL THEN
res := mConst.Target_iDLL
ELSIF s = mConst.Target_sKolibri THEN
res := mConst.Target_iKolibri
ELSIF s = mConst.Target_sObject THEN
res := mConst.Target_iObject
ELSIF s = mConst.Target_sConsole64 THEN
res := mConst.Target_iConsole64
ELSIF s = mConst.Target_sGUI64 THEN
res := mConst.Target_iGUI64
ELSIF s = mConst.Target_sDLL64 THEN
res := mConst.Target_iDLL64
ELSIF s = mConst.Target_sELF32 THEN
res := mConst.Target_iELF32
ELSIF s = mConst.Target_sELF64 THEN
res := mConst.Target_iELF64
ELSE
res := 0
END
END Load;
PROCEDURE LenString(adr: LONGREAL): INTEGER;
VAR s: UTILS.STRCONST;
BEGIN
s := DECL.GetString(adr)
RETURN s.Len
END LenString;
RETURN res
END Target;
PROCEDURE Assert(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER);
BEGIN
IF ~cond THEN
DECL.Assert(FALSE, coord, code)
END
END Assert;
PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER);
BEGIN
IF ~cond THEN
DECL.Assert(FALSE, SCAN.coord, code)
END
END Assert2;
PROCEDURE keys (VAR StackSize, BaseAddress, Version: INTEGER; VAR pic: BOOLEAN; VAR checking: SET);
VAR
param: PARS.PATH;
i, j: INTEGER;
end: BOOLEAN;
value: INTEGER;
minor,
major: INTEGER;
PROCEDURE IntType(T: DECL.pTYPE; coord: SCAN.TCoord);
BEGIN
Assert(T.tType = TINTEGER, coord, 52)
END IntType;
end := FALSE;
i := 4;
REPEAT
UTILS.GetArg(i, param);
PROCEDURE Next;
BEGIN
DECL.Next
END Next;
IF param = "-stk" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) & (1 <= value) & (value <= 32) THEN
StackSize := value
END;
IF param[0] = "-" THEN
DEC(i)
END
PROCEDURE Coord(VAR coord: SCAN.TCoord);
BEGIN
coord := SCAN.coord
END Coord;
PROCEDURE NextCoord(VAR coord: SCAN.TCoord);
BEGIN
DECL.Next;
coord := SCAN.coord
END NextCoord;
PROCEDURE Check(key: INTEGER);
BEGIN
DECL.Check(key)
END Check;
PROCEDURE NextCheck(key: INTEGER);
BEGIN
DECL.Next;
DECL.Check(key)
END NextCheck;
PROCEDURE BaseOf(T0, T1: DECL.pTYPE): BOOLEAN;
BEGIN
IF (T0.tType = T1.tType) & (T0.tType IN TOBJECT) THEN
IF T0.tType = TPOINTER THEN
T0 := T0.Base;
T1 := T1.Base
ELSIF param = "-base" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) THEN
BaseAddress := ((value DIV 64) * 64) * 1024
END;
WHILE (T1 # NIL) & (T1 # T0) DO
T1 := T1.Base
IF param[0] = "-" THEN
DEC(i)
END
END
RETURN T0 = T1
END BaseOf;
PROCEDURE Designator(VAR e: DECL.EXPRESSION);
VAR id, id2: DECL.IDENT; name: SCAN.NODE; e1: DECL.EXPRESSION;
coord: SCAN.TCoord; i, n, bases, glob, loc, idx: INTEGER;
imp, break, guard: BOOLEAN; f: DECL.FIELD;
T, BaseT: DECL.pTYPE; s: UTILS.STRCONST;
ELSIF param = "-nochk" THEN
INC(i);
UTILS.GetArg(i, param);
PROCEDURE LoadVar;
BEGIN
IF glob # -1 THEN
X86.GlobalAdr(glob);
glob := -1
ELSIF loc # -1 THEN
X86.LocalAdr(loc, bases);
loc := -1
END
END LoadVar;
BEGIN
glob := -1;
loc := -1;
Coord(coord);
Check(lxIDENT);
name := SCAN.id;
id := DECL.GetIdent(name);
IF (id # NIL) & (id.iType = IDMOD) THEN
NextCheck(lxDot);
NextCheck(lxIDENT);
Coord(coord);
name := SCAN.id;
imp := id.Unit # DECL.unit;
id := DECL.GetQIdent(id.Unit, name)
END;
Assert(id # NIL, coord, 42);
e.vparam := FALSE;
e.deref := FALSE;
e.id := id;
Next;
CASE id.iType OF
|IDVAR:
e.eType := eVAR;
e.T := id.T;
IF id.VarKind = 0 THEN
e.Read := imp
IF param[0] = "-" THEN
DEC(i)
ELSE
e.Read := (id.VarKind = DECL.param) & (id.T.tType IN TSTRUCT);
e.vparam := id.VarKind = DECL.paramvar
END;
bases := DECL.unit.Level - id.Level;
IF id.Level = 3 THEN
glob := id.Offset
ELSIF (id.VarKind = 0) OR (id.VarKind = DECL.param) & ~(id.T.tType IN TSTRUCT) THEN
loc := id.Offset
ELSIF (id.VarKind = DECL.paramvar) OR (id.T.tType IN TSTRUCT) THEN
IF DECL.Dim(e.T) > 0 THEN
n := DECL.Dim(e.T);
FOR i := n TO 1 BY -1 DO
X86.LocalAdr(id.Offset + i * 4, bases);
X86.Load(TINTEGER)
END
END;
X86.LocalAdr(id.Offset, bases);
X86.Load(TINTEGER)
END
|IDCONST:
Assert(id.T # NIL, coord, 75);
e.eType := eCONST;
e.T := id.T;
e.Value := id.Value;
IF id.T.tType IN {TINTEGER, TSET, TBOOLEAN} THEN
X86.PushConst(FLOOR(e.Value))
ELSIF id.T.tType IN TFLOAT THEN
X86.PushFlt(e.Value)
ELSIF id.T.tType = TSTRING THEN
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
END
|IDPROC:
e.eType := ePROC;
NEW(id2);
UTILS.MemErr(id2 = NIL);
id2^ := id^;
UTILS.Push(DECL.curproc.Procs, id2);
e.T := voidtype
|IDTYPE:
Assert(FALSE, coord, 101)
|IDSTPROC:
e.eType := eSTPROC;
e.T := voidtype
|IDSYSPROC:
e.eType := eSYSPROC;
e.T := voidtype
ELSE
END;
break := FALSE;
guard := FALSE;
REPEAT
CASE SCAN.tLex OF
|lxDot:
e.deref := FALSE;
Assert2(e.T.tType IN TOBJECT, 105);
IF e.T.tType = TPOINTER THEN
e.Read := FALSE;
LoadVar;
e.T := e.T.Base;
X86.Load(TINTEGER);
IF ~guard THEN
X86.CheckNIL
END
END;
NextCheck(lxIDENT);
Coord(coord);
name := SCAN.id;
T := e.T;
REPEAT
f := DECL.GetField(T, name);
T := T.Base
UNTIL (f # NIL) OR (T = NIL);
Assert(f # NIL, coord, 99);
IF f.Unit # DECL.unit THEN
Assert(f.Export, coord, 99)
END;
IF glob # -1 THEN
glob := glob + f.Offset
ELSIF loc # -1 THEN
loc := loc + f.Offset
ELSE
X86.Field(f.Offset)
END;
e.T := f.T;
e.vparam := FALSE;
guard := FALSE;
Next
|lxLSquare:
LoadVar;
REPEAT
Assert2(e.T.tType = TARRAY, 102);
NextCoord(coord);
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e.T.Len = 0 THEN
IF e1.eType = eCONST THEN
idx := FLOOR(e1.Value);
Assert(idx >= 0, coord, 159)
END;
BaseT := DECL.OpenBase(e.T);
X86.PushConst(BaseT.Size);
X86.OpenIdx(DECL.Dim(e.T))
ELSE
IF e1.eType = eCONST THEN
idx := FLOOR(e1.Value);
Assert((idx >= 0) & (idx < e.T.Len), coord, 159);
IF e.T.Base.Size # 1 THEN
X86.Drop;
X86.PushConst(e.T.Base.Size * idx)
END;
X86.Idx
ELSE
X86.FixIdx(e.T.Len, e.T.Base.Size)
END
END;
e.T := e.T.Base
UNTIL SCAN.tLex # lxComma;
Check(lxRSquare);
e.vparam := FALSE;
guard := FALSE;
Next
|lxCaret:
LoadVar;
Assert2(e.T.tType = TPOINTER, 104);
e.Read := FALSE;
X86.Load(TINTEGER);
IF ~guard THEN
X86.CheckNIL
END;
e.T := e.T.Base;
e.vparam := FALSE;
e.deref := TRUE;
guard := FALSE;
Next
|lxLRound:
LoadVar;
IF e.T.tType IN TOBJECT THEN
IF e.T.tType = TRECORD THEN
Assert2(e.vparam, 108)
END;
NextCheck(lxIDENT);
Coord(coord);
T := DECL.IdType(coord);
Assert(T # NIL, coord, 42);
IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord, 106)
ELSE
Assert(T.tType = TPOINTER, coord, 107)
END;
Assert(BaseOf(e.T, T), coord, 108);
e.T := T;
Check(lxRRound);
Next;
IF e.T.tType = TPOINTER THEN
IF (SCAN.tLex = lxDot) OR (SCAN.tLex = lxCaret) THEN
X86.DupLoadCheck
ELSE
X86.DupLoad
END;
guard := TRUE;
T := T.Base
ELSE
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END;
X86.Guard(T.Number, FALSE)
ELSE
break := TRUE
END
ELSE
break := TRUE
END
UNTIL break;
LoadVar
END Designator;
j := 0;
WHILE param[j] # 0X DO
PROCEDURE Set(VAR e: DECL.EXPRESSION);
VAR a, b: DECL.EXPRESSION; coord: SCAN.TCoord; fpu: INTEGER; s: SET; flag: BOOLEAN;
beg: X86.ASMLINE;
BEGIN
Next;
e.eType := eEXP;
e.T := settype;
e.Value := 0.0D0;
e.vparam := FALSE;
s := {};
flag := TRUE;
fpu := X86.fpu;
beg := X86.current;
X86.PushConst(0);
WHILE SCAN.tLex # lxRCurly DO
Coord(coord);
pExpr(a);
IntType(a.T, coord);
IF a.eType = eCONST THEN
Assert(ASR(FLOOR(a.Value), 5) = 0, coord, 53)
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] = "a" THEN
checking := {}
END;
Load(a);
b := a;
IF SCAN.tLex = lxDbl THEN
NextCoord(coord);
pExpr(b);
IntType(b.T, coord);
IF b.eType = eCONST THEN
Assert(ASR(FLOOR(b.Value), 5) = 0, coord, 53);
IF a.eType = eCONST THEN
Assert(a.Value <= b.Value, coord, 54)
END
END;
Load(b)
ELSE
X86.Dup
END;
X86.rset;
X86.Set(lxPlus);
flag := (a.eType = eCONST) & (b.eType = eCONST) & flag;
IF flag THEN
s := s + {FLOOR(a.Value) .. FLOOR(b.Value)}
END;
IF SCAN.tLex = lxComma THEN
Next;
Assert2(SCAN.tLex # lxRCurly, 36)
ELSE
Check(lxRCurly)
END
END;
IF flag THEN
e.Value := LONG(FLT(ORD(s)));
e.eType := eCONST;
X86.Del(beg);
X86.Setfpu(fpu);
IF ~DECL.Const THEN
X86.PushConst(ORD(s))
END
END;
Next
END Set;
PROCEDURE IsString(a: DECL.EXPRESSION): BOOLEAN;
RETURN (a.T.tType = TSTRING) OR (a.T.tType = TARRAY) & (a.T.Base.tType = TCHAR)
END IsString;
PROCEDURE Str(e: DECL.EXPRESSION);
VAR A: X86.TIDX;
BEGIN
IF (e.T.tType = TARRAY) & (e.T.Base.tType = TCHAR) & (e.T.Len # 0) THEN
A[0] := e.T.Len;
X86.OpenArray(A, 1)
ELSIF e.T.tType = TSTRING THEN
A[0] := LenString(e.Value) + 1;
IF A[0] # 2 THEN
X86.OpenArray(A, 1)
INC(j)
END
END
END Str;
PROCEDURE StFunc(VAR e: DECL.EXPRESSION; func: INTEGER);
VAR coord, coord2: SCAN.TCoord; a, b, p: INTEGER; e1, e2: DECL.EXPRESSION;
T: DECL.pTYPE; str, str2: UTILS.STRCONST;
BEGIN
e.vparam := FALSE;
e.eType := eEXP;
Coord(coord2);
Check(lxLRound);
NextCoord(coord);
CASE func OF
|stABS:
pExpr(e1);
Assert(e1.T.tType IN TNUM, coord, 57);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := ABS(e1.Value);
e.eType := eCONST;
Assert(~((e1.T.tType = TINTEGER) & (e1.Value = LONG(FLT(SCAN.minINT)))), coord, DECL.IOVER)
ELSIF param = "-ver" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToVer(param, major, minor) THEN
Version := major * 65536 + minor
END;
IF e1.T.tType = TINTEGER THEN
X86.StFunc(X86.stABS)
ELSE
X86.StFunc(X86.stFABS)
END;
e.T := e1.T
|stODD:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := LONG(FLT(ORD(ODD(FLOOR(e1.Value)))));
e.eType := eCONST
END;
X86.StFunc(X86.stODD);
e.T := booltype
|stLEN:
Designator(e1);
Assert((e1.eType = eVAR) & (e1.T.tType = TARRAY), coord, 102);
IF e1.T.Len > 0 THEN
X86.Len(-e1.T.Len)
ELSE
X86.Len(DECL.Dim(e1.T))
END;
e.T := inttype
|stLSL, stASR, stROR, stLSR:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
NextCoord(coord);
pExpr(e2);
IntType(e2.T, coord);
Load(e2);
IF (e1.eType = eCONST) & (e2.eType = eCONST) THEN
a := FLOOR(e1.Value);
b := FLOOR(e2.Value);
CASE func OF
|stLSL: a := LSL(a, b)
|stASR: a := ASR(a, b)
|stROR: a := ROR(a, b)
|stLSR: a := LSR(a, b)
ELSE
END;
e.Value := LONG(FLT(a));
e.eType := eCONST
END;
CASE func OF
|stLSL: X86.StFunc(X86.stLSL)
|stASR: X86.StFunc(X86.stASR)
|stROR: X86.StFunc(X86.stROR)
|stLSR: X86.StFunc(X86.stLSR)
ELSE
END;
e.T := inttype
|stFLOOR:
pExpr(e1);
Assert(e1.T.tType IN TFLOAT, coord, 66);
Load(e1);
IF e1.eType = eCONST THEN
Assert((e1.Value - 1.0D0 < LONG(FLT(SCAN.maxINT))) & (e1.Value >= LONG(FLT(SCAN.minINT))), coord, 74);
e.Value := LONG(FLT(FLOOR(e1.Value)));
e.eType := eCONST
END;
X86.StFunc(X86.stFLOOR);
e.T := inttype
|stFLT:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
X86.StFunc(X86.stFLT);
e.T := realtype
|stORD:
pExpr(e1);
Assert(e1.T.tType IN {TCHAR, TBOOLEAN, TSET, TSTRING}, coord, 68);
IF e1.T.tType = TSTRING THEN
Assert(LenString(e1.Value) = 1, coord, 94)
END;
Load(e1);
IF e1.eType = eCONST THEN
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
e.Value := LONG(FLT(ORD(str.Str[0])))
ELSE
e.Value := e1.Value
END;
e.eType := eCONST
END;
IF e1.T.tType = TBOOLEAN THEN
X86.StFunc(X86.stORD)
END;
e.T := inttype
|stBITS:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
e.T := settype
|stCHR:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
e.T := chartype;
IF e1.eType = eCONST THEN
Assert(ASR(FLOOR(e1.Value), 8) = 0, coord, 76);
str2 := DECL.AddMono(CHR(FLOOR(e1.Value)));
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
e.T := strtype;
e.eType := eCONST
IF param[0] = "-" THEN
DEC(i)
END
|stLONG:
pExpr(e1);
Assert(e1.T.tType = TREAL, coord, 71);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
Load(e1);
e.T := longrealtype
|stSHORT:
pExpr(e1);
Assert(e1.T.tType = TLONGREAL, coord, 70);
IF e1.eType = eCONST THEN
Assert(ABS(e1.Value) <= LONG(SCAN.maxREAL), coord, DECL.FOVER);
Assert(ABS(e1.Value) >= LONG(SCAN.minREAL), coord, DECL.UNDER);
e.Value := e1.Value;
e.eType := eCONST
END;
Load(e1);
e.T := realtype
|stLENGTH:
pExpr(e1);
Assert(IsString(e1), coord, 141);
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Mono(str.Number);
X86.StrMono
END;
e.Value := LONG(FLT(LENGTH(str.Str)));
e.eType := eCONST
END;
Str(e1);
e.T := inttype;
X86.StFunc(X86.stLENGTH)
|stMIN, stMAX:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
NextCoord(coord);
pExpr(e2);
IntType(e2.T, coord);
Load(e2);
IF (e1.eType = eCONST) & (e2.eType = eCONST) THEN
a := FLOOR(e1.Value);
b := FLOOR(e2.Value);
CASE func OF
|stMIN: a := MIN(a, b)
|stMAX: a := MAX(a, b)
ELSE
END;
e.Value := LONG(FLT(a));
e.eType := eCONST
END;
IF func = stMIN THEN
X86.StFunc(X86.stMIN)
ELSE
X86.StFunc(X86.stMAX)
END;
e.T := inttype
|sysADR:
Assert((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxSTRING) OR (SCAN.tLex = lxCHX), coord, 43);
IF SCAN.tLex = lxIDENT THEN
Designator(e1);
Assert((e1.eType = eVAR) OR (e1.eType = ePROC) OR (e1.T = strtype), coord, 43);
IF e1.eType = ePROC THEN
X86.PushInt(e1.id.Number)
END
ELSE
pFactor(e1)
END;
IF e1.T = strtype THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Drop;
X86.PushInt(str.Number)
END
END;
e.T := inttype;
X86.ADR(DECL.Dim(e1.T))
|sysSIZE, sysTYPEID, sysINF:
DECL.SetSizeFunc;
Check(lxIDENT);
T := DECL.IdType(coord);
Assert(T # NIL, coord, 42);
e.eType := eCONST;
IF func = sysTYPEID THEN
e.T := inttype;
Assert(T.tType IN TOBJECT, coord, 47);
IF T.tType = TPOINTER THEN
T := T.Base
END;
e.Value := LONG(FLT(T.Number));
X86.PushConst(T.Number)
ELSIF func = sysSIZE THEN
e.T := inttype;
e.Value := LONG(FLT(T.Size));
X86.PushConst(T.Size)
ELSIF func = sysINF THEN
Assert(T.tType IN TFLOAT, coord, 91);
e.T := T;
e.Value := SYSTEM.INF(LONGREAL);
X86.PushFlt(e.Value)
END
ELSE
Assert(FALSE, coord2, 73)
END;
Check(lxRRound);
Next
END StFunc;
PROCEDURE ProcTypeComp(T1, T2: DECL.pTYPE): BOOLEAN;
VAR sp: INTEGER; stk: ARRAY 100, 2 OF DECL.pTYPE;
ELSIF param = "-pic" THEN
pic := TRUE
PROCEDURE ProcTypeComp1(T1, T2: DECL.pTYPE): BOOLEAN;
VAR fp, ft: DECL.FIELD; Res: BOOLEAN;
ELSIF param = "" THEN
end := TRUE
PROCEDURE TypeComp(T1, T2: DECL.pTYPE): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF (T1.tType = TARRAY) & (T2.tType = TARRAY) & (T1.Len = 0) & (T2.Len = 0) THEN
Res := TypeComp(T1.Base, T2.Base)
ELSE
Res := ProcTypeComp1(T1, T2)
END
RETURN Res
END TypeComp;
ERRORS.error3("bad parameter: ", param, "")
END;
PROCEDURE Check(): BOOLEAN;
VAR i: INTEGER; res: BOOLEAN;
BEGIN
i := 0;
res := FALSE;
WHILE (i < sp) & ~res DO
res := ((stk[i][0] = T1) & (stk[i][1] = T2)) OR ((stk[i][0] = T2) & (stk[i][1] = T1));
INC(i)
END
RETURN res
END Check;
UNTIL end
BEGIN
INC(sp);
stk[sp][0] := T1;
stk[sp][1] := T2;
IF Check() THEN
Res := TRUE
ELSE
IF (T1.tType = TPROC) & (T2.tType = TPROC) & (T1 # T2) THEN
Res := (T1.Call = T2.Call) & (T1.Fields.Count = T2.Fields.Count) & ProcTypeComp1(T1.Base, T2.Base);
fp := T1.Fields.First(DECL.FIELD);
ft := T2.Fields.First(DECL.FIELD);
WHILE Res & (fp # NIL) DO
Res := (fp.ByRef = ft.ByRef) & TypeComp(fp.T, ft.T);
fp := fp.Next(DECL.FIELD);
ft := ft.Next(DECL.FIELD)
END
ELSE
Res := T1 = T2
END
END;
DEC(sp)
RETURN Res
END ProcTypeComp1;
END keys;
BEGIN
sp := -1
RETURN ProcTypeComp1(T1, T2)
END ProcTypeComp;
PROCEDURE ArrComp(Ta, Tf: DECL.pTYPE): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF (Tf.tType = TARRAY) & (Tf.Len = 0) & (Ta.tType = TARRAY) THEN
Res := ArrComp(Ta.Base, Tf.Base)
ELSE
Res := ProcTypeComp(Ta, Tf)
END
RETURN Res
END ArrComp;
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;
PROCEDURE AssComp(e: DECL.EXPRESSION; T: DECL.pTYPE; param: BOOLEAN): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
CASE T.tType OF
|TINTEGER, TREAL, TLONGREAL, TSET, TBOOLEAN, TCARD16:
Res := e.T = T
|TCHAR:
IF e.T.tType = TSTRING THEN
Res := LenString(e.Value) = 1
ELSE
Res := e.T.tType = TCHAR
END
|TARRAY:
IF param THEN
IF T.Len = 0 THEN
IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := TRUE
ELSE
Res := ArrComp(e.T, T)
END
ELSE
IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := LenString(e.Value) <= T.Len
ELSE
Res := e.T = T
END
END
ELSE
IF T.Len = 0 THEN
Res := FALSE
ELSIF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := LenString(e.Value) <= T.Len
ELSE
Res := e.T = T
END
END
|TRECORD: Res := BaseOf(T, e.T)
|TPOINTER: Res := BaseOf(T, e.T) OR (e.T.tType = TNIL)
|TPROC: Res := (e.T.tType = TNIL) OR (e.eType = ePROC) & ProcTypeComp(e.id.T, T) OR
(e.eType # ePROC) & ProcTypeComp(e.T, T)
ELSE
Res := FALSE
END
RETURN Res
END AssComp;
target: INTEGER;
PROCEDURE ParamComp(e: DECL.EXPRESSION; T: DECL.pTYPE; ByRef: BOOLEAN): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF ByRef THEN
IF e.eType = eVAR THEN
CASE T.tType OF
|TINTEGER, TREAL, TLONGREAL, TCHAR,
TSET, TBOOLEAN, TPOINTER, TCARD16:
Res := e.T = T
|TARRAY:
IF T.Len > 0 THEN
Res := e.T = T
ELSE
Res := ArrComp(e.T, T)
END
|TRECORD:
Res := BaseOf(T, e.T)
|TPROC:
Res := ProcTypeComp(e.T, T)
ELSE
END
ELSE
Res := FALSE
END
ELSE
Res := AssComp(e, T, TRUE)
END
RETURN Res
END ParamComp;
time: INTEGER;
PROCEDURE Call(param: DECL.FIELD);
VAR coord: SCAN.TCoord; i, n: INTEGER; e1: DECL.EXPRESSION; s: UTILS.STRCONST; A: X86.TIDX; TA: DECL.pTYPE;
BEGIN
WHILE param # NIL DO
Coord(coord);
X86.Param;
pExpr(e1);
Assert(ParamComp(e1, param.T, param.ByRef), coord, 114);
Assert(~(param.ByRef & e1.Read), coord, 115);
Assert(~((e1.eType = ePROC) & (e1.id.Level > 3)), coord, 116);
IF (e1.eType = eVAR) & ~param.ByRef THEN
X86.Load(e1.T.tType)
END;
IF param.ByRef & (e1.T.tType = TRECORD) THEN
IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER)
ELSIF e1.deref THEN
X86.DerefType(0)
ELSE
X86.PushConst(e1.T.Number)
END
END;
IF ~param.ByRef & (param.T.tType IN TFLOAT) THEN
X86.DropFpu(param.T.tType = TLONGREAL)
END;
IF (e1.T.tType = TSTRING) & (param.T.tType = TARRAY) THEN
IF param.T.Len > X86.maxstrlen THEN
X86.set_maxstrlen(param.T.Len)
END;
s := DECL.GetString(e1.Value);
IF s.Len = 1 THEN
X86.Mono(s.Number)
END;
IF param.T.Len = 0 THEN
A[0] := s.Len + 1;
X86.OpenArray(A, 1)
END
END;
IF (e1.T.tType = TARRAY) & (DECL.Dim(param.T) > DECL.Dim(e1.T)) THEN
n := DECL.Dim(param.T) - DECL.Dim(e1.T);
TA := DECL.OpenBase(e1.T);
FOR i := 0 TO n - 1 DO
A[i] := TA.Len;
TA := TA.Base
END;
IF DECL.Dim(e1.T) = 0 THEN
X86.OpenArray(A, n)
ELSE
X86.ExtArray(A, n, DECL.Dim(e1.T))
END
END;
param := param.Next(DECL.FIELD);
IF param # NIL THEN
Check(lxComma);
Next
END
END;
Check(lxRRound);
Next
END Call;
StackSize,
Version,
BaseAdr: INTEGER;
pic: BOOLEAN;
checking: SET;
PROCEDURE Factor(VAR e: DECL.EXPRESSION);
VAR coord: SCAN.TCoord; ccall, p: INTEGER; begcall: X86.ASMLINE; s, str2: UTILS.STRCONST;
BEGIN
e.eType := eCONST;
e.vparam := FALSE;
CASE SCAN.tLex OF
|lxIDENT:
begcall := X86.current;
Designator(e);
IF e.eType = ePROC THEN
IF SCAN.tLex = lxLRound THEN
Assert2(e.id.T.Base.tType # TVOID, 73);
Next;
X86.PushCall(begcall);
Call(e.id.T.Fields.First(DECL.FIELD));
X86.EndCall;
e.eType := eEXP;
e.T := e.id.T.Base;
IF e.id.Level = 3 THEN
ccall := 0
ELSIF e.id.Level > DECL.curBlock.Level THEN
ccall := 1
ELSE
ccall := 2
END;
X86.Call(e.id.Number, TRUE, e.T.tType IN TFLOAT, e.id.T.Call, ccall, e.id.Level - 3,
DECL.curBlock.Level - 3, e.id.ParamSize, DECL.curBlock.LocalSize)
ELSE
X86.PushInt(e.id.Number)
END
ELSIF (e.eType = eVAR) & (e.T.tType = TPROC) & (SCAN.tLex = lxLRound) THEN
Assert2(e.T.Base.tType # TVOID, 73);
Next;
X86.PushCall(begcall);
Call(e.T.Fields.First(DECL.FIELD));
X86.EndCall;
e.eType := eEXP;
X86.CallVar(TRUE, e.T.Base.tType IN TFLOAT, e.T.Call, e.T.Len, DECL.curBlock.LocalSize);
e.T := e.T.Base;
ELSIF e.eType IN {eSTPROC, eSYSPROC} THEN
StFunc(e, e.id.StProc)
END
|lxNIL:
e.T := niltype;
e.Value := 0.0D0;
X86.PushConst(0);
Next
|lxTRUE:
e.T := booltype;
e.Value := 1.0D0;
X86.PushConst(1);
Next
|lxFALSE:
e.T := booltype;
e.Value := 0.0D0;
X86.PushConst(0);
Next
|lxCHX, lxSTRING:
IF SCAN.tLex = lxSTRING THEN
str2 := DECL.AddString(SCAN.Lex);
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
ELSE
str2 := DECL.AddMono(SCAN.vCHX);
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
X86.PushConst(ORD(SCAN.vCHX))
END;
e.T := strtype;
Next
|lxREAL:
e.T := realtype;
e.Value := SCAN.vFLT;
X86.PushFlt(SCAN.vFLT);
Next
|lxLONGREAL:
e.T := longrealtype;
e.Value := SCAN.vFLT;
X86.PushFlt(SCAN.vFLT);
Next
|lxINT, lxHEX:
e.T := inttype;
e.Value := LONG(FLT(SCAN.vINT));
X86.PushConst(SCAN.vINT);
Next
|lxLRound:
Next;
pExpr(e);
Check(lxRRound);
Next
|lxNot:
NextCoord(coord);
Factor(e);
Assert(e.T.tType = TBOOLEAN, coord, 37);
Load(e);
IF e.eType = eCONST THEN
e.Value := LONG(FLT(ORD(e.Value = 0.0D0)))
ELSE
e.eType := eEXP
END;
X86.Not;
e.vparam := FALSE
|lxLCurly:
Set(e)
ELSE
Assert2(FALSE, 36)
END
END Factor;
bits64: BOOLEAN;
PROCEDURE IsChr(a: DECL.EXPRESSION): BOOLEAN;
RETURN (a.T.tType = TSTRING) & (LenString(a.Value) = 1) OR (a.T.tType = TCHAR)
END IsChr;
PROCEDURE StrRel(a, b: DECL.EXPRESSION; Op: INTEGER);
BEGIN
IF ~(IsChr(a) OR IsChr(b)) THEN
X86.strcmp(Op, 0)
ELSIF IsChr(a) & IsChr(b) THEN
X86.CmpInt(Op)
ELSIF IsChr(a) THEN
X86.strcmp(Op, 1)
ELSE
X86.strcmp(Op, -1)
END
END StrRel;
StackSize := 2;
Version := 65536;
pic := FALSE;
checking := ST.chkALL;
PROCEDURE log2(n: INTEGER): INTEGER;
VAR x, i: INTEGER;
BEGIN
x := 1;
i := 0;
WHILE (x # n) & (i < 31) DO
x := LSL(x, 1);
INC(i)
END;
IF x # n THEN
i := -1
END
RETURN i
END log2;
PATHS.GetCurrentDirectory(app_path);
lib_path := app_path;
PROCEDURE Operation(VAR a, b: DECL.EXPRESSION; Op: INTEGER; coord: SCAN.TCoord);
VAR n, m: INTEGER;
BEGIN
CASE Op OF
|lxPlus, lxMinus, lxMult, lxSlash:
Assert((a.T.tType IN (TNUM + {TSET})) & (a.T.tType = b.T.tType), coord, 37);
Assert(~((Op = lxSlash) & (a.T.tType = TINTEGER)), coord, 37);
CASE a.T.tType OF
|TINTEGER: X86.Int(Op)
|TSET: X86.Set(Op)
|TREAL, TLONGREAL: X86.farith(Op)
ELSE
END
|lxDIV, lxMOD:
Assert((a.T.tType = TINTEGER) & (b.T.tType = TINTEGER), coord, 37);
IF b.eType = eCONST THEN
m := FLOOR(b.Value);
Assert(m # 0, coord, 48);
n := log2(m);
IF n = -1 THEN
X86.idivmod(Op = lxMOD)
ELSE
X86.Drop;
IF Op = lxMOD THEN
n := ORD(-BITS(LSL(-1, n)));
X86.PushConst(n);
X86.Set(lxMult)
ELSE
X86.PushConst(n);
X86.StFunc(X86.stASR)
END
END
ELSE
X86.idivmod(Op = lxMOD)
END
|lxAnd, lxOR:
Assert((a.T.tType = TBOOLEAN) & (b.T.tType = TBOOLEAN), coord, 37)
|lxIN:
Assert((a.T.tType = TINTEGER) & (b.T.tType = TSET), coord, 37);
X86.inset
|lxLT, lxLE, lxGT, lxGE:
Assert(((a.T.tType IN TNUM) & (a.T.tType = b.T.tType)) OR
(IsChr(a) OR IsString(a)) & (IsChr(b) OR IsString(b)) OR
(a.T.tType = TSET) & (b.T.tType = TSET) & ((Op = lxLE) OR (Op = lxGE)), coord, 37);
IF a.T.tType IN TFLOAT THEN
X86.fcmp(Op)
ELSIF a.T.tType = TSET THEN
X86.Inclusion(Op)
ELSIF IsString(a) OR IsString(b) THEN
StrRel(a, b, Op)
ELSE
X86.CmpInt(Op)
END
|lxEQ, lxNE:
Assert(((a.T.tType IN (TNUM + {TSET, TBOOLEAN})) & (a.T.tType = b.T.tType)) OR
(IsChr(a) OR IsString(a)) & (IsChr(b) OR IsString(b)) OR
(a.T.tType IN {TPOINTER, TPROC, TNIL}) & (b.T.tType = TNIL) OR
(b.T.tType IN {TPOINTER, TPROC, TNIL}) & (a.T.tType = TNIL) OR
(a.T.tType = TPOINTER) & (b.T.tType = TPOINTER) & (BaseOf(a.T, b.T) OR BaseOf(b.T, a.T)) OR
(a.T.tType = TPROC) & ProcTypeComp(b.T, a.T) OR (a.eType = ePROC) & ProcTypeComp(b.T, a.id.T) OR
(b.eType = ePROC) & ProcTypeComp(a.T, b.id.T), coord, 37);
IF a.T.tType IN TFLOAT THEN
X86.fcmp(Op)
ELSIF IsString(a) OR IsString(b) THEN
StrRel(a, b, Op)
ELSE
X86.CmpInt(Op)
END
ELSE
END;
IF (a.eType # eCONST) OR (b.eType # eCONST) THEN
a.eType := eEXP;
IF DECL.Relation(Op) THEN
a.T := booltype
END
ELSE
DECL.Calc(a.Value, b.Value, a.T, b.T, Op, coord, a.Value, a.T)
END;
a.vparam := FALSE
END Operation;
UTILS.GetArg(1, inname);
PROCEDURE Term(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; Op, L: INTEGER; coord: SCAN.TCoord;
BEGIN
Factor(e);
WHILE (SCAN.tLex = lxMult) OR (SCAN.tLex = lxSlash) OR
(SCAN.tLex = lxDIV) OR (SCAN.tLex = lxMOD) OR
(SCAN.tLex = lxAnd) DO
Load(e);
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxAnd THEN
L := X86.NewLabel();
X86.IfWhile(L, FALSE)
IF inname = "" THEN
C.String("Akron Oberon-07/16 Compiler v"); C.Int(mConst.vMajor); C.String("."); C.Int2(mConst.vMinor);
C.String(" ("); C.Int(UTILS.bit_depth); C.StringLn("-bit)"); C.Ln;
C.StringLn("Usage: Compiler <main module> <output> <target> [optional settings]"); C.Ln;
IF UTILS.bit_depth = 64 THEN
C.StringLn('target = console | gui | dll | console64 | gui64 | dll64 | kos | obj | elfexe | elfexe64'); C.Ln;
ELSIF UTILS.bit_depth = 32 THEN
C.StringLn('target = console | gui | dll | kos | obj | elfexe'); C.Ln;
END;
Factor(a);
Load(a);
IF Op = lxAnd THEN
X86.Label(L)
C.StringLn("optional settings:"); C.Ln;
C.StringLn(" -stk <size> set size of stack in megabytes"); C.Ln;
C.StringLn(" -base <address> set base address of image in kilobytes"); C.Ln;
C.StringLn(' -ver <major.minor> set version of program'); C.Ln;
C.StringLn(' -nochk <"ptibcwra"> disable runtime checking (pointers, types, indexes,');
C.StringLn(' BYTE, CHR, WCHR)'); C.Ln;
UTILS.Exit(0)
END;
Operation(e, a, Op, coord)
END
END Term;
PROCEDURE Simple(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; Op, uOp, L: INTEGER; coord, ucoord: SCAN.TCoord;
BEGIN
uOp := 0;
IF (SCAN.tLex = lxPlus) OR (SCAN.tLex = lxMinus) THEN
Coord(ucoord);
uOp := SCAN.tLex;
Next
END;
Term(e);
IF uOp # 0 THEN
Assert(e.T.tType IN (TNUM + {TSET}), ucoord, 37);
Load(e);
IF uOp = lxMinus THEN
CASE e.T.tType OF
|TINTEGER: X86.NegInt
|TSET: X86.NegSet
|TREAL, TLONGREAL: X86.fneg
ELSE
END
END;
IF (uOp = lxMinus) & (e.eType = eCONST) THEN
CASE e.T.tType OF
|TINTEGER:
Assert(e.Value # LONG(FLT(SCAN.minINT)), ucoord, DECL.IOVER)
|TSET:
e.Value := -LONG(FLT(ORD(-BITS(FLOOR(e.Value)))))
ELSE
END;
e.Value := -e.Value
END;
IF e.eType # eCONST THEN
e.eType := eEXP
END;
e.vparam := FALSE
END;
WHILE (SCAN.tLex = lxPlus) OR (SCAN.tLex = lxMinus) OR (SCAN.tLex = lxOR) DO
Load(e);
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxOR THEN
L := X86.NewLabel();
X86.IfWhile(L, TRUE)
END;
Term(a);
Load(a);
IF Op = lxOR THEN
X86.Label(L)
END;
Operation(e, a, Op, coord)
END
END Simple;
PATHS.split(inname, path, modname, ext);
PROCEDURE Expr(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; coord, coord2: SCAN.TCoord; Op, fpu: INTEGER; T: DECL.pTYPE; beg: X86.ASMLINE; s: UTILS.STRCONST;
BEGIN
fpu := X86.fpu;
beg := X86.current;
Simple(e);
IF DECL.Relation(SCAN.tLex) THEN
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxIS THEN
Assert(e.T.tType IN TOBJECT, coord, 37);
IF e.T.tType = TRECORD THEN
Assert(e.vparam, coord, 37)
IF ext # mConst.FILE_EXT THEN
ERRORS.error3('inputfile name extension must be "', mConst.FILE_EXT, '"')
END;
Check(lxIDENT);
Coord(coord2);
T := DECL.IdType(coord2);
Assert(T # NIL, coord2, 42);
IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord2, 106)
ELSE
Assert(T.tType = TPOINTER, coord2, 107)
IF PATHS.isRelative(path) THEN
PATHS.RelPath(app_path, path, temp);
path := temp
END;
Assert(BaseOf(e.T, T), coord, 37);
IF e.T.tType = TRECORD THEN
X86.Drop;
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END;
Load(e);
IF e.T.tType = TPOINTER THEN
T := T.Base
END;
X86.Guard(T.Number, TRUE);
e.T := booltype;
e.eType := eEXP;
e.vparam := FALSE
ELSE
Load(e);
Str(e);
Simple(a);
Load(a);
Str(a);
Operation(e, a, Op, coord)
END
END;
IF e.eType = eCONST THEN
X86.Del(beg);
X86.Setfpu(fpu);
IF ~DECL.Const THEN
CASE e.T.tType OF
|TREAL, TLONGREAL:
X86.PushFlt(e.Value)
|TINTEGER, TSET, TBOOLEAN, TNIL:
X86.PushConst(FLOOR(e.Value))
|TSTRING:
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
ELSE
END
END
END
END Expr;
PROCEDURE IfWhileOper(wh: BOOLEAN);
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L, L3: INTEGER;
BEGIN
L := X86.NewLabel();
IF wh THEN
X86.Label(L)
UTILS.GetArg(2, outname);
IF outname = "" THEN
ERRORS.error1("not enough parameters")
END;
REPEAT
NextCoord(coord);
Expr(e);
Assert(e.T.tType = TBOOLEAN, coord, 117);
Load(e);
IF wh THEN
Check(lxDO)
ELSE
Check(lxTHEN)
IF PATHS.isRelative(outname) THEN
PATHS.RelPath(app_path, outname, temp);
outname := temp
END;
L3 := X86.NewLabel();
X86.ifwh(L3);
Next;
pOpSeq;
X86.jmp(X86.JMP, L);
X86.Label(L3)
UNTIL SCAN.tLex # lxELSIF;
IF ~wh & (SCAN.tLex = lxELSE) THEN
Next;
pOpSeq
END;
Check(lxEND);
IF ~wh THEN
X86.Label(L)
END;
Next
END IfWhileOper;
PROCEDURE RepeatOper;
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L: INTEGER;
BEGIN
Next;
L := X86.NewLabel();
X86.Label(L);
pOpSeq;
Check(lxUNTIL);
NextCoord(coord);
Expr(e);
Assert(e.T.tType = TBOOLEAN, coord, 117);
Load(e);
X86.ifwh(L)
END RepeatOper;
PROCEDURE ForOper;
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; LBeg, LEnd, iValue: INTEGER; Value: LONGREAL;
T: DECL.pTYPE; name: SCAN.NODE; id: DECL.IDENT;
BEGIN
NextCheck(lxIDENT);
name := SCAN.id;
id := DECL.GetIdent(name);
Assert2(id # NIL, 42);
Assert2(id.iType = IDVAR, 126);
Assert2(id.VarKind = 0, 127);
Assert2(id.T.tType = TINTEGER, 128);
Assert2(id.Level = DECL.unit.Level, 129);
NextCheck(lxAssign);
NextCoord(coord);
IF id.Level = 3 THEN
X86.GlobalAdr(id.Offset)
ELSE
X86.LocalAdr(id.Offset, 0)
UTILS.GetArg(3, param);
IF param = "" THEN
ERRORS.error1("not enough parameters")
END;
X86.Dup;
Expr(e);
IntType(e.T, coord);
Load(e);
X86.Save(TINTEGER);
Check(lxTO);
NextCoord(coord);
Expr(e);
IntType(e.T, coord);
Load(e);
iValue := 1;
IF SCAN.tLex = lxBY THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(iValue # 0, coord, 122)
END;
Check(lxDO);
Next;
X86.For(iValue > 0, LBeg, LEnd);
pOpSeq;
X86.NextFor(iValue, LBeg, LEnd);
Check(lxEND);
Next
END ForOper;
PROCEDURE CheckLabel(a, b: INTEGER; Labels: UTILS.LIST): BOOLEAN;
VAR cur: LABEL;
BEGIN
cur := Labels.First(LABEL);
WHILE (cur # NIL) & ((b < cur.a) OR (a > cur.b)) DO
cur := cur.Next(LABEL)
END
RETURN cur = NIL
END CheckLabel;
target := Target(param);
PROCEDURE LabelVal(VAR a: INTEGER; int: BOOLEAN);
VAR Value: LONGREAL; T: DECL.pTYPE; s: UTILS.STRCONST; coord: SCAN.TCoord;
BEGIN
Coord(coord);
DECL.ConstExpr(Value, T);
IF int THEN
Assert(T.tType = TINTEGER, coord, 161);
a := FLOOR(Value)
ELSE
Assert(T.tType = TSTRING, coord, 55);
s := DECL.GetString(Value);
Assert(s.Len = 1, coord, 94);
a := ORD(s.Str[0])
END
END LabelVal;
PROCEDURE Label(int: BOOLEAN; Labels: UTILS.LIST; LBeg: INTEGER);
VAR a, b: INTEGER; label: LABEL; coord: SCAN.TCoord;
BEGIN
Coord(coord);
LabelVal(a, int);
b := a;
IF SCAN.tLex = lxDbl THEN
Next;
LabelVal(b, int)
IF target = 0 THEN
ERRORS.error1("bad parameter <target>")
END;
Assert(a <= b, coord, 54);
Assert(CheckLabel(a, b, Labels), coord, 100);
NEW(label);
DECL.MemErr(label = NIL);
label.a := a;
label.b := b;
UTILS.Push(Labels, label);
X86.CaseLabel(a, b, LBeg)
END Label;
PROCEDURE Variant(int: BOOLEAN; Labels: UTILS.LIST; EndCase: INTEGER);
VAR LBeg, LEnd: INTEGER;
BEGIN
LBeg := X86.NewLabel();
LEnd := X86.NewLabel();
IF ~((SCAN.tLex = lxStick) OR (SCAN.tLex = lxEND)) THEN
Label(int, Labels, LBeg);
WHILE SCAN.tLex = lxComma DO
Next;
Label(int, Labels, LBeg)
END;
Check(lxColon);
Next;
X86.jmp(X86.JMP, LEnd);
X86.Label(LBeg);
pOpSeq;
X86.jmp(X86.JMP, EndCase);
X86.Label(LEnd)
END
END Variant;
bits64 := target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64, mConst.Target_iELF64};
PROCEDURE CaseOper;
VAR e: DECL.EXPRESSION; int: BOOLEAN; coord: SCAN.TCoord; EndCase: INTEGER; Labels: UTILS.LIST;
BEGIN
NextCoord(coord);
Expr(e);
Assert(e.T.tType IN {TCHAR, TSTRING, TINTEGER}, coord, 156);
Assert(~((e.T.tType = TSTRING) & (LenString(e.Value) # 1)), coord, 94);
int := e.T.tType = TINTEGER;
Check(lxOF);
Load(e);
X86.Drop;
Labels := UTILS.CreateList();
Next;
EndCase := X86.NewLabel();
Variant(int, Labels, EndCase);
WHILE SCAN.tLex = lxStick DO
Next;
Variant(int, Labels, EndCase)
IF bits64 THEN
IF UTILS.bit_depth = 32 THEN
ERRORS.error1("bad parameter <target>")
END;
IF SCAN.tLex = lxELSE THEN
Next;
pOpSeq
PARS.init(64, target)
ELSE
UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line);
X86.OnError(7)
PARS.init(32, target)
END;
Check(lxEND);
X86.Label(EndCase);
Next;
UTILS.Clear(Labels)
END CaseOper;
PROCEDURE CheckCode(Code: UTILS.STRING; Len: INTEGER; coord: SCAN.TCoord);
VAR i: INTEGER;
BEGIN
Assert(~ODD(Len), coord, 34);
FOR i := 0 TO Len - 1 DO
Assert(SCAN.HexDigit(Code[i]), coord, 34)
END
END CheckCode;
PARS.program.dll := target IN {mConst.Target_iDLL, mConst.Target_iObject, mConst.Target_iDLL64};
PARS.program.obj := target = mConst.Target_iObject;
PROCEDURE StProc(proc: INTEGER);
VAR coord, coord2: SCAN.TCoord; iValue: INTEGER; e1, e2: DECL.EXPRESSION; Value: LONGREAL;
T: DECL.pTYPE; str: UTILS.STRCONST; begcall: X86.ASMLINE;
BEGIN
Coord(coord2);
Check(lxLRound);
NextCoord(coord);
CASE proc OF
|stINC, stDEC:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TINTEGER, coord, 128);
IF SCAN.tLex = lxComma THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(iValue # 0, coord, 122);
IF iValue < 0 THEN
IF proc = stINC THEN
proc := stDEC
ELSE
proc := stINC
END;
iValue := -iValue
END;
IF iValue # 1 THEN
X86.PushConst(iValue);
IF proc = stDEC THEN
X86.StProc(X86.stDEC)
ELSE
X86.StProc(X86.stINC)
END
ELSE
IF proc = stDEC THEN
X86.StProc(X86.stDEC1)
ELSE
X86.StProc(X86.stINC1)
END
END
ELSE
IF proc = stDEC THEN
X86.StProc(X86.stDEC1)
ELSE
X86.StProc(X86.stINC1)
END
END
|stINCL, stEXCL:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TSET, coord, 138);
Check(lxComma);
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(ASR(iValue, 5) = 0, coord, 53);
IF proc = stINCL THEN
X86.PushConst(ORD({iValue}));
X86.StProc(X86.stINCL)
ELSE
X86.PushConst(ORD(-{iValue}));
X86.StProc(X86.stEXCL)
END
|stCOPY:
Expr(e1);
Assert(IsString(e1), coord, 141);
Check(lxComma);
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Mono(str.Number);
X86.StrMono
END
END;
Str(e1);
NextCoord(coord);
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(IsString(e2), coord, 143);
Assert(~e2.Read, coord, 115);
Str(e2);
X86.StProc(X86.stCOPY)
|stNEW, stDISPOSE:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TPOINTER, coord, 145);
IF proc = stNEW THEN
X86.PushConst(e1.T.Base.Number);
X86.PushConst(X86.Align(e1.T.Base.Size + 8, 32));
X86.newrec
ELSE
X86.disprec
END
|stASSERT:
Expr(e1);
Assert(e1.T.tType = TBOOLEAN, coord, 117);
Load(e1);
IF SCAN.tLex = lxComma THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
Assert((Value >= 0.0D0) & (Value <= 127.0D0), coord, 95);
X86.Assert(X86.stASSERT, FLOOR(Value))
ELSE
X86.Assert(X86.stASSERT1, 0)
END
|stPACK, stUNPK:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(e1.T.tType IN TFLOAT, coord, 149);
Assert(~e1.Read, coord, 115);
Check(lxComma);
NextCoord(coord);
IF proc = stUNPK THEN
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(e2.T.tType = TINTEGER, coord, 128);
Assert(~e2.Read, coord, 115);
IF e1.T.tType = TLONGREAL THEN
X86.StProc(X86.stUNPK)
ELSE
X86.StProc(X86.stUNPK1)
END
ELSE
Expr(e2);
IntType(e2.T, coord);
Load(e2);
IF e1.T.tType = TLONGREAL THEN
X86.StProc(X86.stPACK)
ELSE
X86.StProc(X86.stPACK1)
END
END
|sysPUT, sysGET:
begcall := X86.current;
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
NextCoord(coord);
IF proc = sysGET THEN
X86.PushCall(begcall);
X86.Param;
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(~(e2.T.tType IN TSTRUCT), coord, 90);
Assert(~e2.Read, coord, 115);
X86.EndCall;
X86.Load(e2.T.tType);
X86.Save(e2.T.tType)
ELSE
Expr(e2);
Assert(~(e2.T.tType IN TSTRUCT), coord, 90);
IF e2.T.tType = TSTRING THEN
Assert(LenString(e2.Value) = 1, coord, 94)
ELSIF e2.T.tType = TVOID THEN
e2.T := inttype
END;
Load(e2);
X86.Save(e2.T.tType)
END
|sysCODE:
Assert(SCAN.tLex = lxSTRING, coord, 150);
CheckCode(SCAN.Lex, SCAN.count - 1, coord);
X86.Asm(SCAN.Lex);
Next
|sysMOVE:
begcall := X86.current;
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
X86.PushCall(begcall);
X86.Param;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
X86.EndCall;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
Load(e1);
|sysCOPY:
begcall := X86.current;
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Check(lxComma);
X86.PushCall(begcall);
X86.Param;
NextCoord(coord);
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Check(lxComma);
X86.EndCall;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
Load(e1);
ELSE
Assert(FALSE, coord2, 132)
END;
Check(lxRRound);
Next;
IF (proc = sysMOVE) OR (proc = sysCOPY) THEN
X86.StProc(X86.sysMOVE)
END
END StProc;
STRINGS.append(lib_path, "lib");
STRINGS.append(lib_path, UTILS.slash);
PROCEDURE IdentOper;
VAR e1, e2: DECL.EXPRESSION; coord: SCAN.TCoord; ccall: INTEGER; begcall: X86.ASMLINE; s: UTILS.STRCONST;
BEGIN
Coord(coord);
begcall := X86.current;
Designator(e1);
Assert(e1.eType # eCONST, coord, 130);
IF (e1.eType = eVAR) & (e1.T.tType # TPROC) THEN
Check(lxAssign);
Assert(~e1.Read, coord, 115);
NextCoord(coord);
Expr(e2);
Assert(AssComp(e2, e1.T, FALSE), coord, 131);
Load(e2);
IF e1.T.tType = TRECORD THEN
X86.PushConst(e1.T.Size);
X86.PushConst(e1.T.Number);
IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER)
ELSIF e1.deref THEN
X86.DerefType(12)
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN
IF target = mConst.Target_iDLL THEN
BaseAdr := 10000000H
ELSE
X86.PushConst(e1.T.Number)
END
ELSIF e2.T.tType = TARRAY THEN
X86.PushConst(e2.T.Size)
ELSIF (e2.T.tType = TSTRING) & (e1.T.tType = TARRAY) THEN
s := DECL.GetString(e2.Value);
IF s.Len = 1 THEN
X86.Mono(s.Number)
BaseAdr := 400000H
END;
X86.PushConst(MIN(s.Len + 1, e1.T.Len))
END;
X86.Save(e1.T.tType)
ELSIF e1.eType = ePROC THEN
Assert((e1.id.T.Base.tType = TVOID) OR (e1.id.T.Call = DECL.winapi), coord, 132);
IF e1.id.ParamCount > 0 THEN
Check(lxLRound);
Next;
X86.PushCall(begcall);
Call(e1.id.T.Fields.First(DECL.FIELD));
X86.EndCall
ELSIF SCAN.tLex = lxLRound THEN
NextCheck(lxRRound);
Next
END;
IF e1.id.Level = 3 THEN
ccall := 0
ELSIF e1.id.Level > DECL.curBlock.Level THEN
ccall := 1
ELSE
ccall := 2
END;
X86.Call(e1.id.Number, FALSE, FALSE, e1.id.T.Call, ccall, e1.id.Level - 3, DECL.curBlock.Level - 3, e1.id.ParamSize, DECL.curBlock.LocalSize)
ELSIF e1.eType IN {eSTPROC, eSYSPROC} THEN
StProc(e1.id.StProc)
ELSIF (e1.eType = eVAR) & (e1.T.tType = TPROC) THEN
IF SCAN.tLex = lxLRound THEN
Next;
Assert((e1.T.Base.tType = TVOID) OR (e1.T.Call = DECL.winapi), coord, 132);
X86.PushCall(begcall);
Call(e1.T.Fields.First(DECL.FIELD));
X86.EndCall;
X86.CallVar(FALSE, FALSE, e1.T.Call, e1.T.Len, DECL.curBlock.LocalSize)
ELSIF SCAN.tLex = lxAssign THEN
Assert(~e1.Read, coord, 115);
NextCoord(coord);
Expr(e2);
Assert(AssComp(e2, e1.T, FALSE), coord, 131);
Assert(~((e2.eType = ePROC) & (e2.id.Level > 3)), coord, 116);
IF e2.eType = eVAR THEN
X86.Load(TPROC)
END;
X86.Save(TPROC)
ELSE
Assert2(e1.T.Fields.Count = 0, 155);
Assert((e1.T.Base.tType = TVOID) OR (e1.T.Call = DECL.winapi), coord, 132);
X86.CallVar(FALSE, FALSE, e1.T.Call, e1.T.Len, DECL.curBlock.LocalSize)
END
END
END IdentOper;
STRINGS.append(lib_path, "Windows32")
PROCEDURE Operator;
BEGIN
UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line);
CASE SCAN.tLex OF
|lxIDENT: IdentOper
|lxIF, lxWHILE: IfWhileOper(SCAN.tLex = lxWHILE)
|lxREPEAT: RepeatOper
|lxFOR: ForOper
|lxCASE: CaseOper
ELSE
END
END Operator;
ELSIF target IN {mConst.Target_iKolibri, mConst.Target_iObject} THEN
STRINGS.append(lib_path, "KolibriOS")
PROCEDURE OpSeq;
BEGIN
Operator;
WHILE SCAN.tLex = lxSemi DO
Next;
Operator
END
END OpSeq;
ELSIF target = mConst.Target_iELF32 THEN
STRINGS.append(lib_path, "Linux32")
PROCEDURE Start;
VAR SelfName, SelfPath, CName, CExt, FName, Path, StdPath,
Name, Ext, temp, system, stk: UTILS.STRING;
platform, stksize: INTEGER;
ELSIF target = mConst.Target_iELF64 THEN
STRINGS.append(lib_path, "Linux64")
PROCEDURE getstksize(): INTEGER;
VAR res, i: INTEGER;
BEGIN
res := 0;
i := 0;
WHILE SCAN.Digit(stk[i]) DO
INC(i)
ELSIF target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN
STRINGS.append(lib_path, "Windows64")
END;
IF stk[i] <= 20X THEN
stk[i] := 0X;
res := SCAN.StrToInt(stk)
END;
IF res = 0 THEN
res := 1
END
RETURN res
END getstksize;
PROCEDURE getver(): INTEGER;
VAR res, i: INTEGER; err: BOOLEAN;
STRINGS.append(lib_path, UTILS.slash);
PROCEDURE hexdgt(c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9") OR
("A" <= c) & (c <= "F") OR
("a" <= c) & (c <= "f")
END hexdgt;
keys(StackSize, BaseAdr, Version, pic, checking);
PROCEDURE hex(c: CHAR): INTEGER;
VAR res: INTEGER;
BEGIN
IF ("0" <= c) & (c <= "9") THEN
res := ORD(c) - ORD("0")
ELSIF ("A" <= c) & (c <= "F") THEN
res := ORD(c) - ORD("A") + 10
ELSIF ("a" <= c) & (c <= "f") THEN
res := ORD(c) - ORD("a") + 10
END
RETURN res
END hex;
ST.compile(path, lib_path, modname, outname, target, Version, StackSize, BaseAdr, pic, checking);
BEGIN
res := 0;
i := 0;
err := stk[i] # "0"; INC(i);
err := err OR (stk[i] # "x"); INC(i);
WHILE ~err & hexdgt(stk[i]) DO
INC(i)
END;
err := err OR (i = 2);
IF stk[i] <= 20X THEN
stk[i] := 0X
ELSE
err := TRUE
END;
i := 2;
WHILE ~err & (stk[i] # 0X) DO
res := LSL(res, 4) + hex(stk[i]);
INC(i)
END;
IF res = 0 THEN
res := 65536
END
RETURN res
END getver;
time := UTILS.GetTickCount() - UTILS.time;
BEGIN
IF UTILS.ParamCount < 2 THEN
UTILS.ErrMsg(59);
UTILS.HALT(1)
END;
UTILS.ParamStr(SelfName, 0);
UTILS.ParamStr(FName, 1);
UTILS.ParamStr(system, 2);
UTILS.ParamStr(stk, 3);
pExpr := Expr;
pFactor := Factor;
pOpSeq := OpSeq;
UTILS.Split(FName, Path, Name, Ext);
IF Ext # UTILS.Ext THEN
UTILS.ErrMsg(121);
UTILS.HALT(1)
END;
UTILS.Split(SelfName, SelfPath, CName, CExt);
temp := Name;
IF UTILS.streq(system, "kem") THEN
X86.setkem;
platform := 4;
UTILS.concat(temp, ".kex")
ELSIF UTILS.streq(system, "obj") THEN
platform := 6;
UTILS.concat(temp, ".obj")
ELSIF UTILS.streq(system, "elf") THEN
platform := 5
ELSIF UTILS.streq(system, "kos") THEN
platform := 4;
UTILS.concat(temp, ".kex")
ELSIF UTILS.streq(system, "con") THEN
platform := 3;
UTILS.concat(temp, ".exe")
ELSIF UTILS.streq(system, "gui") THEN
platform := 2;
UTILS.concat(temp, ".exe")
ELSIF UTILS.streq(system, "dll") THEN
platform := 1;
UTILS.concat(temp, ".dll")
ELSE
UTILS.ErrMsg(60);
UTILS.HALT(1)
END;
IF platform IN {1, 2, 3, 4} THEN
stksize := getstksize()
ELSE
stksize := 1
END;
IF platform = 6 THEN
stksize := getver()
END;
UTILS.concat(SelfPath, "Lib");
UTILS.concat(SelfPath, UTILS.Slash);
IF platform = 5 THEN
UTILS.concat(SelfPath, "Linux32")
ELSIF platform IN {4, 6} THEN
UTILS.concat(SelfPath, "KolibriOS")
ELSIF platform IN {1, 2, 3} THEN
UTILS.concat(SelfPath, "Windows32")
END;
UTILS.concat(SelfPath, UTILS.Slash);
X86.set_maxstrlen(0);
X86.Init(platform);
X86.Prolog(temp);
DECL.Program(SelfPath, Path, Name, Ext, platform IN {1, 2, 3}, OpSeq, Expr, AssComp, sttypes);
voidtype := sttypes[TVOID];
inttype := sttypes[TINTEGER];
booltype := sttypes[TBOOLEAN];
strtype := sttypes[TSTRING];
settype := sttypes[TSET];
realtype := sttypes[TREAL];
longrealtype := sttypes[TLONGREAL];
chartype := sttypes[TCHAR];
niltype := sttypes[TNIL];
DECL.Compile(platform, stksize);
UTILS.OutString("success"); UTILS.Ln;
UTILS.HALT(0)
END Start;
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
Start
main
END Compiler.

/programs/develop/oberon07/Source/ELF.ob07
1,295 → 1,382
(*
Copyright 2016 Anton Krotov
(*
BSD 2-Clause License
This file is part of Compiler.
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
MODULE ELF;
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS;
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE ELF;
CONST
IMPORT SYSTEM;
EI_NIDENT = 16;
ET_EXEC = 2;
ET_DYN = 3;
CONST size* = 8346;
EM_386 = 3;
EM_8664 = 3EH;
PROCEDURE [stdcall] data;
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;
FILE = WR.FILE;
PROCEDURE align (n, _align: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE("7F454C4601010100000000000000000002000300010000004086040834000000");
SYSTEM.CODE("A41120000000000034002000080028001D001A00060000003400000034800408");
SYSTEM.CODE("3480040800010000000100000500000004000000030000003401000034810408");
SYSTEM.CODE("3481040813000000130000000400000001000000010000000000000000800408");
SYSTEM.CODE("00800408240C1000240C10000500000000100000010000000C0F10000C9F1408");
SYSTEM.CODE("0C9F1408540110009401900C060000000010000002000000200F1000209F1408");
SYSTEM.CODE("209F1408D0000000D00000000600000004000000040000004801000048810408");
SYSTEM.CODE("488104084400000044000000040000000400000051E574640000000000000000");
SYSTEM.CODE("000000000000000000000000060000000400000052E574640C0F10000C9F1408");
SYSTEM.CODE("0C9F1408F4000000F400000004000000010000002F6C69622F6C642D6C696E75");
SYSTEM.CODE("782E736F2E320000040000001000000001000000474E55000000000002000000");
SYSTEM.CODE("060000000F000000040000001400000003000000474E55006D648AA1A4FF8A62");
SYSTEM.CODE("6855372198B3905D7B4527570300000005000000040000000700000092005000");
SYSTEM.CODE("126388F68400000080044030050000000800000013000000AEC44D0F281D8C1C");
SYSTEM.CODE("4701750FAC4BE3C086F0967C328E750F20CF09FD38F28B1C7C8B730F060204F9");
SYSTEM.CODE("16EA76FE3CAD390D665561103F7E967C7D1B760F000000000000000000000000");
SYSTEM.CODE("000000000C0000000000000000000000200000001B0000000000000000000000");
SYSTEM.CODE("20000000A20000000000000000000000120000006C0000000000000000000000");
SYSTEM.CODE("12000000360000008C85040800000000120000007900000080A0240804000000");
SYSTEM.CODE("110018009C0000001C8604080000000012000000460000000C8C140804000000");
SYSTEM.CODE("11000F00B40000007C8504080000000012000000730000009C85040800000000");
SYSTEM.CODE("1200000080000000AC85040800000000120000008E00000060A0240804000000");
SYSTEM.CODE("110018005A000000BC85040800000000120000002F000000CC85040800000000");
SYSTEM.CODE("1200000095000000FC8504080000000012000000870000000C86040800000000");
SYSTEM.CODE("120000006600000064A024080400000011001800550000002C86040800000000");
SYSTEM.CODE("1200000060000000DC8504080000000012000000006C6962646C2E736F2E3200");
SYSTEM.CODE("5F5F676D6F6E5F73746172745F5F005F4A765F5265676973746572436C617373");
SYSTEM.CODE("657300646C6F70656E00646C73796D006C6962632E736F2E36005F494F5F7374");
SYSTEM.CODE("64696E5F75736564006578697400666F70656E006674656C6C00737464696E00");
SYSTEM.CODE("7072696E746600667365656B007374646F75740066636C6F7365006D616C6C6F");
SYSTEM.CODE("630073746465727200667772697465006672656164005F5F6C6962635F737461");
SYSTEM.CODE("72745F6D61696E006672656500474C4942435F322E3100474C4942435F322E30");
SYSTEM.CODE("0000000000000000020002000300020002000100020002000400020004000500");
SYSTEM.CODE("020002000200020002000000010002000100000010000000300000001169690D");
SYSTEM.CODE("00000500B9000000100000001069690D00000300C30000000000000001000200");
SYSTEM.CODE("3C00000010000000000000001169690D00000400B9000000100000001069690D");
SYSTEM.CODE("00000200C300000000000000F09F14080601000060A02408050C000064A02408");
SYSTEM.CODE("0511000080A024080506000000A014080701000004A014080703000008A01408");
SYSTEM.CODE("070900000CA014080705000010A01408070A000014A01408070B000018A01408");
SYSTEM.CODE("070D00001CA01408070E000020A014080713000024A014080704000028A01408");
SYSTEM.CODE("070F00002CA014080710000030A014080707000034A01408071200005589E553");
SYSTEM.CODE("83EC04E8000000005B81C3CC1A10008B93FCFFFFFF85D27405E81E000000E88D");
SYSTEM.CODE("010000E878061000585BC9C3FF35F89F1408FF25FC9F140800000000FF2500A0");
SYSTEM.CODE("14086800000000E9E0FFFFFFFF2504A014086808000000E9D0FFFFFFFF2508A0");
SYSTEM.CODE("14086810000000E9C0FFFFFFFF250CA014086818000000E9B0FFFFFFFF2510A0");
SYSTEM.CODE("14086820000000E9A0FFFFFFFF2514A014086828000000E990FFFFFFFF2518A0");
SYSTEM.CODE("14086830000000E980FFFFFFFF251CA014086838000000E970FFFFFFFF2520A0");
SYSTEM.CODE("14086840000000E960FFFFFFFF2524A014086848000000E950FFFFFFFF2528A0");
SYSTEM.CODE("14086850000000E940FFFFFFFF252CA014086858000000E930FFFFFFFF2530A0");
SYSTEM.CODE("14086860000000E920FFFFFFFF2534A014086868000000E910FFFFFF00000000");
SYSTEM.CODE("31ED5E89E183E4F050545268B08B140868508B1408515668F4860408E80BFFFF");
SYSTEM.CODE("FFF490909090909090909090909090905589E55383EC04803D84A0240800753F");
SYSTEM.CODE("A188A02408BB189F140881EB149F1408C1FB0283EB0139D8731E8DB600000000");
SYSTEM.CODE("83C001A388A02408FF1485149F1408A188A0240839D872E8C60584A024080183");
SYSTEM.CODE("C4045B5DC38D7426008DBC27000000005589E583EC18A11C9F140885C07412B8");
SYSTEM.CODE("0000000085C07409C704241C9F1408FFD0C9C3905589E583E4F0565383EC38C7");
SYSTEM.CODE("44242CA0A024088B55088B44242C89108344242C048B550C8B44242C89108344");
SYSTEM.CODE("242C048B55108B44242C89108344242C04BACC8504088B44242C89108344242C");
SYSTEM.CODE("04BA8C8504088B44242C89108344242C04BA2C8604088B44242C89108344242C");
SYSTEM.CODE("04A164A0240889C28B44242C89108344242C04A180A0240889C28B44242C8910");
SYSTEM.CODE("8344242C04A160A0240889C28B44242C89108344242C04BA0C8604088B44242C");
SYSTEM.CODE("89108344242C04BA7C8504088B44242C89108344242C04BABC8504088B44242C");
SYSTEM.CODE("89108344242C04BAAC8504088B44242C89108344242C04BAFC8504088B44242C");
SYSTEM.CODE("89108344242C04BA1C8604088B44242C89108344242C04BA9C8504088B44242C");
SYSTEM.CODE("89108344242C04BADC8504088B44242C89108344242C048B35B8A02408BBF486");
SYSTEM.CODE("0408B9A0A02408BA60A01408B8108C140889742410895C240C894C2408895424");
SYSTEM.CODE("04890424E8B9FAEFFFB80000000083C4385B5E89EC5DC3909090909090909090");
SYSTEM.CODE("9090909090905589E5575653E85A00000081C39914000083EC1CE8B3F9EFFF8D");
SYSTEM.CODE("BB18FFFFFF8D8318FFFFFF29C7C1FF0285FF742431F68B4510894424088B450C");
SYSTEM.CODE("894424048B4508890424FF94B318FFFFFF83C60139FE72DE83C41C5B5E5F5DC3");
SYSTEM.CODE("8DB6000000005589E55DC38B1C24C3909090909090905589E55383EC04A10C9F");
SYSTEM.CODE("140883F8FF7413BB0C9F1408669083EB04FFD08B0383F8FF75F483C4045B5DC3");
SYSTEM.CODE("90905589E55383EC04E8000000005B81C3FC130000E86CFAEFFF595BC9C30300");
SYSTEM.CODE("00000100020025750A25750A25750A25750A0000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000FFFFFFFF00000000FFFFFFFF000000000000000001000000010000000100");
SYSTEM.CODE("00003C0000000C0000001C8504080D000000EC8B1408F5FEFF6F8C8104080500");
SYSTEM.CODE("00003483040806000000F48104080A000000CD0000000B000000100000001500");
SYSTEM.CODE("00000000000003000000F49F1408020000007000000014000000110000001700");
SYSTEM.CODE("0000AC840408110000008C84040812000000200000001300000008000000FEFF");
SYSTEM.CODE("FF6F2C840408FFFFFF6F02000000F0FFFF6F0284040800000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("00000000000000000000209F1408000000000000000062850408728504088285");
SYSTEM.CODE("040892850408A2850408B2850408C2850408D2850408E2850408F28504080286");
SYSTEM.CODE("0408128604082286040832860408000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000004743433A20285562756E74");
SYSTEM.CODE("752F4C696E61726F20342E352E322D387562756E7475342920342E352E320047");
SYSTEM.CODE("43433A20285562756E74752F4C696E61726F20342E352E322D387562756E7475");
SYSTEM.CODE("332920342E352E3200002E73796D746162002E737472746162002E7368737472");
SYSTEM.CODE("746162002E696E74657270002E6E6F74652E4142492D746167002E6E6F74652E");
SYSTEM.CODE("676E752E6275696C642D6964002E676E752E68617368002E64796E73796D002E");
SYSTEM.CODE("64796E737472002E676E752E76657273696F6E002E676E752E76657273696F6E");
SYSTEM.CODE("5F72002E72656C2E64796E002E72656C2E706C74002E696E6974002E74657874");
SYSTEM.CODE("002E66696E69002E726F64617461002E65685F6672616D65002E63746F727300");
SYSTEM.CODE("2E64746F7273002E6A6372002E64796E616D6963002E676F74002E676F742E70");
SYSTEM.CODE("6C74002E64617461002E627373002E636F6D6D656E7400000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("001B000000010000000200000034810408340100001300000000000000000000");
SYSTEM.CODE("0001000000000000002300000007000000020000004881040848010000200000");
SYSTEM.CODE("0000000000000000000400000000000000310000000700000002000000688104");
SYSTEM.CODE("0868010000240000000000000000000000040000000000000044000000F6FFFF");
SYSTEM.CODE("6F020000008C8104088C01000068000000050000000000000004000000040000");
SYSTEM.CODE("004E0000000B00000002000000F4810408F40100004001000006000000010000");
SYSTEM.CODE("0004000000100000005600000003000000020000003483040834030000CD0000");
SYSTEM.CODE("00000000000000000001000000000000005E000000FFFFFF6F02000000028404");
SYSTEM.CODE("080204000028000000050000000000000002000000020000006B000000FEFFFF");
SYSTEM.CODE("6F020000002C8404082C04000060000000060000000200000004000000000000");
SYSTEM.CODE("007A00000009000000020000008C8404088C0400002000000005000000000000");
SYSTEM.CODE("000400000008000000830000000900000002000000AC840408AC040000700000");
SYSTEM.CODE("00050000000C00000004000000080000008C00000001000000060000001C8504");
SYSTEM.CODE("081C050000300000000000000000000000040000000000000087000000010000");
SYSTEM.CODE("00060000004C8504084C050000F0000000000000000000000004000000040000");
SYSTEM.CODE("009200000001000000060000004086040840060000AC05100000000000000000");
SYSTEM.CODE("001000000000000000980000000100000006000000EC8B1408EC0B10001C0000");
SYSTEM.CODE("00000000000000000004000000000000009E0000000100000002000000088C14");
SYSTEM.CODE("08080C10001500000000000000000000000400000000000000A6000000010000");
SYSTEM.CODE("0002000000208C1408200C100004000000000000000000000004000000000000");
SYSTEM.CODE("00B000000001000000030000000C9F14080C0F10000800000000000000000000");
SYSTEM.CODE("000400000000000000B70000000100000003000000149F1408140F1000080000");
SYSTEM.CODE("0000000000000000000400000000000000BE00000001000000030000001C9F14");
SYSTEM.CODE("081C0F10000400000000000000000000000400000000000000C3000000060000");
SYSTEM.CODE("0003000000209F1408200F1000D0000000060000000000000004000000080000");
SYSTEM.CODE("00CC0000000100000003000000F09F1408F00F10000400000000000000000000");
SYSTEM.CODE("000400000004000000D10000000100000003000000F49F1408F40F1000440000");
SYSTEM.CODE("0000000000000000000400000004000000DA000000010000000300000040A014");
SYSTEM.CODE("08401010002000100000000000000000002000000000000000E0000000080000");
SYSTEM.CODE("000300000060A02408601020004000800C000000000000000020000000000000");
SYSTEM.CODE("00E5000000010000003000000000000000601020005400000000000000000000");
SYSTEM.CODE("00010000000100000011000000030000000000000000000000B4102000EE0000");
SYSTEM.CODE("0000000000000000000100000000000000010000000200000000000000000000");
SYSTEM.CODE("002C162000000500001C0000002C000000040000001000000009000000030000");
SYSTEM.CODE("0000000000000000002C1B2000F9020000000000000000000001000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000003481040800000000030001");
SYSTEM.CODE("0000000000488104080000000003000200000000006881040800000000030003");
SYSTEM.CODE("00000000008C810408000000000300040000000000F481040800000000030005");
SYSTEM.CODE("0000000000348304080000000003000600000000000284040800000000030007");
SYSTEM.CODE("00000000002C8404080000000003000800000000008C84040800000000030009");
SYSTEM.CODE("0000000000AC8404080000000003000A00000000001C8504080000000003000B");
SYSTEM.CODE("00000000004C8504080000000003000C0000000000408604080000000003000D");
SYSTEM.CODE("0000000000EC8B14080000000003000E0000000000088C14080000000003000F");
SYSTEM.CODE("0000000000208C14080000000003001000000000000C9F140800000000030011");
SYSTEM.CODE("0000000000149F14080000000003001200000000001C9F140800000000030013");
SYSTEM.CODE("0000000000209F1408000000000300140000000000F09F140800000000030015");
SYSTEM.CODE("0000000000F49F140800000000030016000000000040A0140800000000030017");
SYSTEM.CODE("000000000060A024080000000003001800000000000000000000000000030019");
SYSTEM.CODE("000100000000000000000000000400F1FF0C0000000C9F140800000000010011");
SYSTEM.CODE("001A000000149F14080000000001001200280000001C9F140800000000010013");
SYSTEM.CODE("0035000000708604080000000002000D004B00000084A0240801000000010018");
SYSTEM.CODE("005A00000088A02408040000000100180068000000D08604080000000002000D");
SYSTEM.CODE("000100000000000000000000000400F1FF74000000109F140800000000010011");
SYSTEM.CODE("0081000000208C140800000000010010008F0000001C9F140800000000010013");
SYSTEM.CODE("009B000000C08B14080000000002000D00B100000000000000000000000400F1");
SYSTEM.CODE("FFB8000000F49F14080000000001001600CE0000000C9F140800000000000011");
SYSTEM.CODE("00DF0000000C9F14080000000000001100F2000000209F140800000000010014");
SYSTEM.CODE("00FB00000040A01408000000002000170006010000B08B14080500000012000D");
SYSTEM.CODE("0016010000408604080000000012000D001D0100000000000000000000200000");
SYSTEM.CODE("002C01000000000000000000002000000040010000088C14080400000011000F");
SYSTEM.CODE("0047010000EC8B14080000000012000E004D0100000000000000000000120000");
SYSTEM.CODE("006A0100000C8C14080400000011000F00790100007C85040800000000120000");
SYSTEM.CODE("0089010000A0A024080000800C110018008E01000040A0140800000000100017");
SYSTEM.CODE("009B0100008C8504080000000012000000AC0100009C85040800000000120000");
SYSTEM.CODE("00BD010000AC8504080000000012000000CF01000060A0240804000000110018");
SYSTEM.CODE("00E1010000BC8504080000000012000000F201000044A0140800000000110217");
SYSTEM.CODE("00FF010000CC850408000000001200000011020000DC85040800000000120000");
SYSTEM.CODE("0022020000189F140800000000110212002F020000508B14085A00000012000D");
SYSTEM.CODE("003F02000000000000000000001200000051020000FC85040800000000120000");
SYSTEM.CODE("006302000060A02408000000001000F1FF6F0200000C86040800000000120000");
SYSTEM.CODE("008102000060A0140800001000110017008702000064A0240804000000110018");
SYSTEM.CODE("0098020000A0A0A414000000001000F1FF9D02000080A0240804000000110018");
SYSTEM.CODE("00AF0200001C8604080000000012000000C002000060A02408000000001000F1");
SYSTEM.CODE("FFC70200002C8604080000000012000000D7020000B58B14080000000012020D");
SYSTEM.CODE("00EE020000F48604084D04100012000D00F30200001C8504080000000012000B");
SYSTEM.CODE("000063727473747566662E63005F5F43544F525F4C4953545F5F005F5F44544F");
SYSTEM.CODE("525F4C4953545F5F005F5F4A43525F4C4953545F5F005F5F646F5F676C6F6261");
SYSTEM.CODE("6C5F64746F72735F61757800636F6D706C657465642E363135350064746F725F");
SYSTEM.CODE("6964782E36313537006672616D655F64756D6D79005F5F43544F525F454E445F");
SYSTEM.CODE("5F005F5F4652414D455F454E445F5F005F5F4A43525F454E445F5F005F5F646F");
SYSTEM.CODE("5F676C6F62616C5F63746F72735F6175780070726F672E63005F474C4F42414C");
SYSTEM.CODE("5F4F46465345545F5441424C455F005F5F696E69745F61727261795F656E6400");
SYSTEM.CODE("5F5F696E69745F61727261795F7374617274005F44594E414D49430064617461");
SYSTEM.CODE("5F7374617274005F5F6C6962635F6373755F66696E69005F7374617274005F5F");
SYSTEM.CODE("676D6F6E5F73746172745F5F005F4A765F5265676973746572436C6173736573");
SYSTEM.CODE("005F66705F6877005F66696E69005F5F6C6962635F73746172745F6D61696E40");
SYSTEM.CODE("40474C4942435F322E30005F494F5F737464696E5F7573656400667265654040");
SYSTEM.CODE("474C4942435F322E300064617461005F5F646174615F737461727400646C7379");
SYSTEM.CODE("6D4040474C4942435F322E3000667365656B4040474C4942435F322E30006663");
SYSTEM.CODE("6C6F73654040474C4942435F322E31007374646572724040474C4942435F322E");
SYSTEM.CODE("3000666F70656E4040474C4942435F322E31005F5F64736F5F68616E646C6500");
SYSTEM.CODE("646C6F70656E4040474C4942435F322E31006674656C6C4040474C4942435F32");
SYSTEM.CODE("2E30005F5F44544F525F454E445F5F005F5F6C6962635F6373755F696E697400");
SYSTEM.CODE("7072696E74664040474C4942435F322E30006677726974654040474C4942435F");
SYSTEM.CODE("322E30005F5F6273735F7374617274006D616C6C6F634040474C4942435F322E");
SYSTEM.CODE("3000696461746100737464696E4040474C4942435F322E30005F656E64007374");
SYSTEM.CODE("646F75744040474C4942435F322E300066726561644040474C4942435F322E30");
SYSTEM.CODE("005F656461746100657869744040474C4942435F322E30005F5F693638362E67");
SYSTEM.CODE("65745F70635F7468756E6B2E6278006D61696E005F696E697400");
END data;
IF n MOD _align # 0 THEN
n := n + _align - (n MOD _align)
END
PROCEDURE get*(): INTEGER;
RETURN SYSTEM.ADR(data) + 3
END get;
RETURN n
END align;
PROCEDURE Write16 (file: FILE; w: WCHAR);
BEGIN
WR.Write16LE(file, ORD(w))
END Write16;
PROCEDURE WritePH (file: FILE; ph: Elf32_Phdr);
BEGIN
WR.Write32LE(file, ph.p_type);
WR.Write32LE(file, ph.p_offset);
WR.Write32LE(file, ph.p_vaddr);
WR.Write32LE(file, ph.p_paddr);
WR.Write32LE(file, ph.p_filesz);
WR.Write32LE(file, ph.p_memsz);
WR.Write32LE(file, ph.p_flags);
WR.Write32LE(file, ph.p_align)
END WritePH;
PROCEDURE WritePH64 (file: FILE; ph: Elf32_Phdr);
BEGIN
WR.Write32LE(file, ph.p_type);
WR.Write32LE(file, ph.p_flags);
WR.Write64LE(file, ph.p_offset);
WR.Write64LE(file, ph.p_vaddr);
WR.Write64LE(file, ph.p_paddr);
WR.Write64LE(file, ph.p_filesz);
WR.Write64LE(file, ph.p_memsz);
WR.Write64LE(file, ph.p_align)
END WritePH64;
PROCEDURE fixup (program: BIN.PROGRAM; text, data, bss: INTEGER; amd64: BOOLEAN);
VAR
reloc: BIN.RELOC;
L, delta: INTEGER;
BEGIN
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
L := BIN.get32le(program.code, reloc.offset);
delta := 3 - reloc.offset - text - 7 * ORD(amd64);
CASE reloc.opcode OF
|BIN.PICDATA: BIN.put32le(program.code, reloc.offset, L + data + delta)
|BIN.PICCODE: BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + text + delta)
|BIN.PICBSS: BIN.put32le(program.code, reloc.offset, L + bss + delta)
END;
reloc := reloc.next(BIN.RELOC)
END;
END fixup;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; amd64: BOOLEAN);
CONST
interp = 0;
dyn = 1;
header = 2;
text = 3;
data = 4;
bss = 5;
VAR
ehdr: Elf32_Ehdr;
phdr: ARRAY 16 OF Elf32_Phdr;
i, LoadAdr, offset, pad, VA: INTEGER;
SizeOf: RECORD header, code, data, bss: INTEGER END;
File: FILE;
str: ARRAY 40 OF CHAR; lstr: INTEGER;
Dyn: ARRAY 350 OF BYTE;
BEGIN
IF amd64 THEN
str := "/lib64/ld-linux-x86-64.so.2"
ELSE
str := "/lib/ld-linux.so.2"
END;
lstr := LENGTH(str);
IF amd64 THEN
LoadAdr := 400000H
ELSE
LoadAdr := 08048000H
END;
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;
ehdr.e_type := WCHR(ET_EXEC);
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 := LoadAdr + phdr[interp].p_offset;
phdr[interp].p_paddr := LoadAdr + phdr[interp].p_offset;
phdr[interp].p_filesz := lstr + 1;
phdr[interp].p_memsz := lstr + 1;
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 := LoadAdr + phdr[dyn].p_offset;
phdr[dyn].p_paddr := LoadAdr + phdr[dyn].p_offset;
IF amd64 THEN
phdr[dyn].p_filesz := 0A0H;
phdr[dyn].p_memsz := 0A0H
ELSE
phdr[dyn].p_filesz := 50H;
phdr[dyn].p_memsz := 50H
END;
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 := LoadAdr;
phdr[header].p_paddr := LoadAdr;
IF amd64 THEN
phdr[header].p_filesz := 305H;
phdr[header].p_memsz := 305H
ELSE
phdr[header].p_filesz := 1D0H;
phdr[header].p_memsz := 1D0H
END;
phdr[header].p_flags := PF_R + PF_W;
phdr[header].p_align := 1000H;
offset := offset + phdr[header].p_filesz;
VA := LoadAdr + 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;
offset := offset + phdr[text].p_filesz;
VA := LoadAdr + 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;
offset := offset + phdr[data].p_filesz;
VA := LoadAdr + 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;
fixup(program, phdr[text].p_vaddr, phdr[data].p_vaddr + pad, align(phdr[bss].p_vaddr, 16), amd64);
File := WR.Create(FileName);
FOR i := 0 TO EI_NIDENT - 1 DO
WR.WriteByte(File, ehdr.e_ident[i])
END;
Write16(File, ehdr.e_type);
Write16(File, ehdr.e_machine);
WR.Write32LE(File, ehdr.e_version);
IF amd64 THEN
WR.Write64LE(File, ehdr.e_entry);
WR.Write64LE(File, ehdr.e_phoff);
WR.Write64LE(File, ehdr.e_shoff)
ELSE
WR.Write32LE(File, ehdr.e_entry);
WR.Write32LE(File, ehdr.e_phoff);
WR.Write32LE(File, ehdr.e_shoff)
END;
WR.Write32LE(File, ehdr.e_flags);
Write16(File, ehdr.e_ehsize);
Write16(File, ehdr.e_phentsize);
Write16(File, ehdr.e_phnum);
Write16(File, ehdr.e_shentsize);
Write16(File, ehdr.e_shnum);
Write16(File, ehdr.e_shstrndx);
IF amd64 THEN
WritePH64(File, phdr[interp]);
WritePH64(File, phdr[dyn]);
WritePH64(File, phdr[header]);
WritePH64(File, phdr[text]);
WritePH64(File, phdr[data]);
WritePH64(File, phdr[bss])
ELSE
WritePH(File, phdr[interp]);
WritePH(File, phdr[dyn]);
WritePH(File, phdr[header]);
WritePH(File, phdr[text]);
WritePH(File, phdr[data]);
WritePH(File, phdr[bss])
END;
FOR i := 0 TO lstr DO
WR.WriteByte(File, ORD(str[i]))
END;
i := 0;
IF amd64 THEN
BIN.InitArray(Dyn, i, "01000000000000000E000000000000000500000000000000DC02400000000000");
BIN.InitArray(Dyn, i, "0A00000000000000190000000000000006000000000000004C02400000000000");
BIN.InitArray(Dyn, i, "0B00000000000000180000000000000007000000000000009402400000000000");
BIN.InitArray(Dyn, i, "0800000000000000300000000000000009000000000000001800000000000000");
BIN.InitArray(Dyn, i, "0400000000000000C40240000000000000000000000000000000000000000000");
BIN.InitArray(Dyn, i, "0000000000000000000000000000000000000000000000000100000012000000");
BIN.InitArray(Dyn, i, "0000000000000000000000000000000008000000120000000000000000000000");
BIN.InitArray(Dyn, i, "0000000000000000F50240000000000001000000010000000000000000000000");
BIN.InitArray(Dyn, i, "FD02400000000000010000000200000000000000000000000100000003000000");
BIN.InitArray(Dyn, i, "0000000001000000020000000000000000646C6F70656E00646C73796D006C69");
BIN.InitArray(Dyn, i, "62646C2E736F2E320000000000000000000000000000000000")
ELSE
BIN.InitArray(Dyn, i, "010000000E00000005000000AF8104080A000000190000000600000057810408");
BIN.InitArray(Dyn, i, "0B00000010000000110000008781040812000000100000001300000008000000");
BIN.InitArray(Dyn, i, "0400000097810408000000000000000000000000000000000000000000000000");
BIN.InitArray(Dyn, i, "0100000000000000000000001200000008000000000000000000000012000000");
BIN.InitArray(Dyn, i, "C881040801010000CC8104080102000001000000030000000000000001000000");
BIN.InitArray(Dyn, i, "020000000000000000646C6F70656E00646C73796D006C6962646C2E736F2E32");
BIN.InitArray(Dyn, i, "000000000000000000")
END;
WR.Write(File, Dyn, i);
CHL.WriteToFile(File, program.code);
WHILE pad > 0 DO
WR.WriteByte(File, 0);
DEC(pad)
END;
CHL.WriteToFile(File, program.data);
WR.Close(File)
END write;
END ELF.

/programs/develop/oberon07/Source/ERRORS.ob07
1,285 → 1,171
(*
Copyright 2016, 2017 Anton Krotov
(*
BSD 2-Clause License
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE ERRORS;
IMPORT H := HOST;
IMPORT C := CONSOLE, UTILS;
TYPE
STRING = ARRAY 1024 OF CHAR;
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;
CP = ARRAY 256 OF INTEGER;
PROCEDURE errormsg* (fname: ARRAY OF CHAR; line, col, errno: INTEGER);
VAR
str: ARRAY 80 OF CHAR;
cp: CP;
PROCEDURE utf8(code: INTEGER; VAR uchar: STRING);
BEGIN
uchar[0] := 0X;
IF code < 80H THEN
uchar[0] := CHR(code);
uchar[1] := 0X
ELSIF code < 800H THEN
uchar[1] := CHR(ROR(LSL(code, 26), 26) + 80H);
uchar[0] := CHR(ASR(code, 6) + 0C0H);
uchar[2] := 0X
ELSIF code < 10000H THEN
uchar[2] := CHR(ROR(LSL(code, 26), 26) + 80H);
code := ASR(code, 6);
uchar[1] := CHR(ROR(LSL(code, 26), 26) + 80H);
uchar[0] := CHR(ASR(code, 6) + 0E0H);
uchar[3] := 0X
(*
ELSIF code < 200000H THEN
ELSIF code < 4000000H THEN
ELSE *)
END
END utf8;
C.Ln;
C.String(" error ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
PROCEDURE InitCP(VAR cp: CP);
VAR i: INTEGER;
BEGIN
FOR i := 0H TO 7FH DO
cp[i] := i
END
END InitCP;
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"
| 6: str := "identifier too long"
| 7: str := "number too long"
| 8..12: str := "number too large"
PROCEDURE Init8(VAR cp: CP; VAR n: INTEGER; a, b, c, d, e, f, g, h: INTEGER);
BEGIN
cp[n] := a; INC(n);
cp[n] := b; INC(n);
cp[n] := c; INC(n);
cp[n] := d; INC(n);
cp[n] := e; INC(n);
cp[n] := f; INC(n);
cp[n] := g; INC(n);
cp[n] := h; INC(n);
END Init8;
PROCEDURE InitCP866(VAR cp: CP);
VAR n, i: INTEGER;
BEGIN
FOR i := 0410H TO 043FH DO
cp[i - 0410H + 80H] := i
| 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 := "integer division by zero"
| 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 := "'stdcall', 'ccall', 'ccall16', 'windows' or 'linux' expected"
| 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 := "'noalign' expected"
|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 := "'stdcall64', 'win64', 'systemv', 'windows' or 'linux' expected"
|118: str := "this flag for Windows only"
|119: str := "this flag for Linux only"
|120: str := "too many formal parameters"
END;
FOR i := 0440H TO 044FH DO
cp[i - 0440H + 0E0H] := i
END;
C.StringLn(str);
C.String(" file: "); C.StringLn(fname);
UTILS.Exit(1)
END errormsg;
n := 0B0H;
Init8(cp, n, 2591H, 2592H, 2593H, 2502H, 2524H, 2561H, 2562H, 2556H);
Init8(cp, n, 2555H, 2563H, 2551H, 2557H, 255DH, 255CH, 255BH, 2510H);
Init8(cp, n, 2514H, 2534H, 252CH, 251CH, 2500H, 253CH, 255EH, 255FH);
Init8(cp, n, 255AH, 2554H, 2569H, 2566H, 2560H, 2550H, 256CH, 2567H);
Init8(cp, n, 2568H, 2564H, 2565H, 2559H, 2558H, 2552H, 2553H, 256BH);
Init8(cp, n, 256AH, 2518H, 250CH, 2588H, 2584H, 258CH, 2590H, 2580H);
n := 0F0H;
Init8(cp, n, 0401H, 0451H, 0404H, 0454H, 0407H, 0457H, 040EH, 045EH);
Init8(cp, n, 00B0H, 2219H, 00B7H, 221AH, 2116H, 00A4H, 25A0H, 00A0H);
PROCEDURE error1* (s1: ARRAY OF CHAR);
BEGIN
C.Ln;
C.StringLn(s1);
UTILS.Exit(1)
END error1;
InitCP(cp)
END InitCP866;
PROCEDURE concat(VAR L: STRING; R: STRING);
VAR i, n, pos: INTEGER;
PROCEDURE error3* (s1, s2, s3: ARRAY OF CHAR);
BEGIN
n := LENGTH(R);
i := 0;
pos := LENGTH(L);
WHILE (i <= n) & (pos < LEN(L)) DO
L[pos] := R[i];
INC(pos);
INC(i)
END
END concat;
C.Ln;
C.String(s1); C.String(s2); C.StringLn(s3);
UTILS.Exit(1)
END error3;
PROCEDURE Utf8(VAR str: STRING);
VAR i: INTEGER; in, out, u: STRING;
BEGIN
in := str;
out := "";
FOR i := 0 TO LENGTH(in) - 1 DO
utf8(cp[ORD(in[i])], u);
concat(out, u)
END;
str := out
END Utf8;
PROCEDURE ErrorMsg*(code: INTEGER; VAR msg: ARRAY OF CHAR);
VAR str: STRING;
PROCEDURE error5* (s1, s2, s3, s4, s5: ARRAY OF CHAR);
BEGIN
CASE code OF
| 1: str := "®¦¨¤ « áì 'H' ¨«¨ 'X'"
| 2: str := "®¦¨¤ « áì æ¨äà "
| 3: str := "áâப  ­¥ ᮤ¥à¦¨â § ªà뢠î饩 ª ¢ë窨"
| 4: str := "­¥¤®¯ãáâ¨¬ë© á¨¬¢®«"
| 5: str := "楫®ç¨á«¥­­®¥ ¯¥à¥¯®«­¥­¨¥"
| 6: str := "᫨誮¬ ¡®«ì讥 §­ ç¥­¨¥ ᨬ¢®«ì­®© ª®­áâ ­âë"
| 7: str := "¢¥é¥á⢥­­®¥ ¯¥à¥¯®«­¥­¨¥"
| 8: str := "¯¥à¥¯®«­¥­¨¥ ¯®à浪  ¢¥é¥á⢥­­®£® ç¨á« "
| 9: str := "¢¥é¥á⢥­­®¥  ­â¨¯¥à¥¯®«­¥­¨¥"
| 10: str := "᫨誮¬ ¤«¨­­ë© ¨¤¥­â¨ä¨ª â®à"
| 11: str := "᫨誮¬ ¤«¨­­ ï áâப®¢ ï ª®­áâ ­â "
C.Ln;
C.String(s1); C.String(s2); C.String(s3); C.String(s4); C.StringLn(s5);
UTILS.Exit(1)
END error5;
| 21: str := "®¦¨¤ «®áì 'MODULE'"
| 22: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à"
| 23: str := "®¦¨¤ « áì ';'"
| 24: str := "®¦¨¤ «®áì 'END'"
| 25: str := "®¦¨¤ « áì '.'"
| 26: str := "¨¤¥­â¨ä¨ª â®à ­¥ ᮢ¯ ¤ ¥â á ¨¬¥­¥¬ ¬®¤ã«ï"
| 27: str := "­¥®¦¨¤ ­­ë© ª®­¥æ ä ©« "
| 28: str := "®¦¨¤ « áì ',', ';' ¨«¨ ':='"
| 29: str := "®¦¨¤ « áì ',' ¨«¨ ';'"
| 30: str := "¨¤¥­â¨ä¨ª â®à ¯¥à¥®¯à¥¤¥«¥­"
| 31: str := "横«¨ç¥áª¨© ¨¬¯®àâ"
| 32: str := "¬®¤ã«ì ­¥ ­ ©¤¥­ ¨«¨ ®è¨¡ª  ¤®áâ㯠"
| 33: str := "¨¬ï ¬®¤ã«ï ­¥ ᮢ¯ ¤ ¥â á ¨¬¥­¥¬ ä ©«  ¬®¤ã«ï"
| 34: str := "­¥¯à ¢¨«ì­ë© ä®à¬ â áâப¨ ¬ è¨­­ëå ª®¤®¢"
| 35: str := "®¦¨¤ «®áì '='"
| 36: str := "ᨭ⠪á¨ç¥áª ï ®è¨¡ª  ¢ ¢ëà ¦¥­¨¨"
| 37: str := "®¯¥à æ¨ï ­¥ ¯à¨¬¥­¨¬ "
| 38: str := "®¦¨¤ « áì ')'"
| 39: str := "®¦¨¤ «oáì 'ARRAY', 'RECORD', 'POINTER' ¨«¨ 'PROCEDURE'"
| 40: str := "®¦¨¤ «oáì 'TO'"
| 41: str := "®¦¨¤ «oáì 'OF'"
| 42: str := "­¥®¯à¥¤¥«¥­­ë© ¨¤¥­â¨ä¨ª â®à"
| 43: str := "âॡã¥âáï ¯¥à¥¬¥­­ ï, ¯à®æ¥¤ãà  ¨«¨ áâப®¢ ï ª®­áâ ­â "
| 44: str := "®¦¨¤ «oáì 'cdecl', 'stdcall' ¨«¨ 'winapi'"
| 45: str := "ä« £ ¢ë§®¢  ­¥¤®¯ã᪠¥âáï ¤«ï «®ª «ì­ëå ¯à®æ¥¤ãà"
| 46: str := "¤¥«¥­¨¥ ­  ­ã«ì"
| 47: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨ ¨«¨ ⨯ -㪠§ â¥«ï"
| 48: str := "楫®ç¨á«¥­­®¥ ¤¥«¥­¨¥ ­  ­ã«ì"
| 49: str := "§­ ç¥­¨¥ «¥¢®£® ®¯¥à ­¤  ¢­¥ ¤¨ ¯ §®­  0..31"
| 50: str := "ä« £ [winapi] ¤®áâ㯥­ ⮫쪮 ¤«ï ¯« âä®à¬ë Windows"
| 51: str := "®¦¨¤ « áì '}'"
| 52: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  INTEGER"
| 53: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¢­¥ ¤¨ ¯ §®­  0..31"
| 54: str := "«¥¢ ï £à ­¨æ  ¤¨ ¯ §®­  ¡®«ìè¥ ¯à ¢®©"
| 55: str := "âॡã¥âáï ª®­áâ ­â  â¨¯  CHAR"
| 56: str := "®¦¨¤ « áì '('"
| 57: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ç¨á«®¢®£® ⨯ "
| 59: str := "­¥¤®áâ â®ç­® ¯ à ¬¥â஢"
| 60: str := "­¥¤®¯ãáâ¨¬ë© ¯ à ¬¥âà"
| 61: str := "®¦¨¤ « áì ','"
| 62: str := "âॡã¥âáï ª®­áâ ­â­®¥ ¢ëà ¦¥­¨¥"
| 63: str := "âॡã¥âáï ¯¥à¥¬¥­­ ï"
| 64: str := "ä ©« ­¥ ­ ©¤¥­ ¨«¨ ®è¨¡ª  ¤®áâ㯠"
| 65: str := "¬®¤ã«ì RTL ­¥ ­ ©¤¥­"
| 66: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  REAL ¨«¨ LONGREAL"
| 67: str := "­¥¢®§¬®¦­® ᮧ¤ âì ä ©«, ¢®§¬®¦­® ä ©« ®âªàëâ ¨«¨ ¤¨áª § é¨é¥­ ®â § ¯¨á¨"
| 68: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  CHAR, SET ¨«¨ BOOLEAN"
| 69: str := "­¥¢®§¬®¦­® § ¯¨á âì ä ©«"
| 70: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  LONGREAL"
| 71: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  REAL"
| 72: str := "­¥¤®áâ â®ç­® ¯ ¬ï⨠¤«ï § ¢¥à襭¨ï ª®¬¯¨«ï樨"
| 73: str := "¯à®æ¥¤ãà  ­¥ ¢®§¢à é îé ï १ã«ìâ â ­¥¤®¯ãá⨬  ¢ ¢ëà ¦¥­¨ïå"
| 74: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¢­¥ 楫®ç¨á«¥­­®£® ¤¨ ¯ §®­ "
| 75: str := "४ãàᨢ­®¥ ®¯à¥¤¥«¥­¨¥ ª®­áâ ­âë"
| 76: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¢­¥ ¤¨ ¯ §®­  0..255"
| 77: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ⨯ "
| 78: str := "¤«¨­  ⨯ -¬ áᨢ  ¤®«¦­  ¡ëâì ¡®«ìè¥ ­ã«ï"
| 79: str := "®¦¨¤ «®áì 'OF' ¨«¨ ','"
| 80: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨ ¨«¨ ⨯ -㪠§ â¥«ï"
| 81: str := "¡ §®¢ë© ⨯ ⨯ -㪠§ â¥«ï ¤®«¦¥­ ¡ëâì § ¯¨áìî"
| 82: str := "⨯ १ã«ìâ â  ¯à®æ¥¤ãàë ­¥ ¬®¦¥â ¡ëâì § ¯¨áìî ¨«¨ ¬ áᨢ®¬"
| 83: str := "à §¬¥à ⨯  ᫨誮¬ ¢¥«¨ª"
| 84: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ¨«¨ 'VAR'"
| 85: str := "®¦¨¤ « áì ',' ¨«¨ ':'"
| 86: str := "®¦¨¤ «®áì 'END' ¨«¨ ';'"
| 87: str := "¨¤¥­â¨ä¨ª â®à ­¥ ᮢ¯ ¤ ¥â á ¨¬¥­¥¬ ¯à®æ¥¤ãàë"
| 89: str := "íªá¯®àâ «®ª «ì­®£® ¨¤¥­â¨ä¨ª â®à  ­¥¤®¯ãá⨬"
| 90: str := "⨯ ARRAY ¨«¨ RECORD ­¥¤®¯ãá⨬"
| 91: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ¢¥é¥á⢥­­®£® ⨯ "
| 93: str := "à §¬¥à ¤ ­­ëå ᫨誮¬ ¢¥«¨ª"
| 94: str := "áâப  ¤«¨­ë, ®â«¨ç­®© ®â 1 ­¥¤®¯ãá⨬ "
| 95: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¤®«¦­® ¡ëâì ¢ ¤¨ ¯ §®­¥ 0..127"
| 96: str := "­¥¤®¯ãá⨬®¥ ४ãàᨢ­®¥ ®¯à¥¤¥«¥­¨¥ ⨯ "
| 97: str := "­¥¤®áâ â®ç­® ¢¥é¥á⢥­­ëå ॣ¨áâ஢, ã¯à®áâ¨â¥ ¢ëà ¦¥­¨¥"
| 98: str := "®¦¨¤ «®áì 'THEN'"
| 99: str := "¯®«¥ § ¯¨á¨ ­¥ ­ ©¤¥­®"
|100: str := "¬¥âª  ¤ã¡«¨à®¢ ­ "
|101: str := "¨¤¥­â¨ä¨ª â®à ⨯  ­¥¤®¯ãá⨬ ¢ ¢ëà ¦¥­¨ïå"
|102: str := "âॡã¥âáï ¬ áᨢ"
|103: str := "®¦¨¤ «oáì 'union' ¨«¨ 'noalign'"
|104: str := "âॡã¥âáï 㪠§ â¥«ì"
|105: str := "âॡã¥âáï § ¯¨áì"
|106: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨"
|107: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ⨯ -㪠§ â¥«ï"
|108: str := "­¥¤®¯ãá⨬ ï ®åà ­  ⨯ "
|109: str := "®¦¨¤ « áì ']'"
|110: str := "à §¬¥à­®áâì ®âªàë⮣® ¬ áᨢ  ᫨誮¬ ¢¥«¨ª "
|111: str := "á¨á⥬­ë¥ ä« £¨ âॡãîâ ¨¬¯®àâ  ¬®¤ã«ï SYSTEM"
|112: str := "à áè¨à¥­¨¥ § ¯¨á¨ ­¥ ¬®¦¥â ¡ëâì [noalign] ¨«¨ [union]"
|113: str := "¡ §®¢ë© ⨯ § ¯¨á¨ ­¥ ¬®¦¥â ¡ëâì [noalign] ¨«¨ [union]"
|114: str := "­¥á®¢¬¥áâ¨¬ë© ¯ à ¬¥âà"
|115: str := "¯¥à¥¬¥­­ ï ¤®áâ㯭  ⮫쪮 ¤«ï ç⥭¨ï"
|116: str := "­¥«ì§ï ¨á¯®«ì§®¢ âì «®ª «ì­ãî ¯à®æ¥¤ãàã"
|117: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  BOOLEAN"
|118: str := "®¦¨¤ «®áì 'DO'"
|119: str := "®¦¨¤ «®áì 'UNTIL'"
|120: str := "®¦¨¤ «®áì ':='"
|121: str := "à áè¨à¥­¨¥ ¨¬¥­¨ ä ©«  £« ¢­®£® ¬®¤ã«ï ¤®«¦­® ¡ëâì 'ob07'"
|122: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ­¥ ¬®¦¥â ¡ëâì à ¢­ë¬ ­ã«î"
|123: str := "'RETURN' ­¥¤®¯ãá⨬ ¢ ¯à®æ¥¤ãà¥, ­¥ ¢®§¢à é î饩 १ã«ìâ â"
|124: str := "®¦¨¤ «®áì 'RETURN'"
|125: str := "⨯ ¢ëà ¦¥­¨ï ­¥ ᮮ⢥âáâ¢ã¥â ⨯ã १ã«ìâ â  ¯à®æ¥¤ãàë"
|126: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ¯¥à¥¬¥­­®©"
|127: str := "áç¥â稪 横«  FOR ­¥ ¤®«¦¥­ ¡ëâì ¯ à ¬¥â஬"
|128: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì INTEGER"
|129: str := "¯¥à¥¬¥­­ ï ¤®«¦­  ¡ëâì «®ª «ì­®©"
|130: str := "­¥«ì§ï ¨á¯®«ì§®¢ âì ª®­áâ ­âã"
|131: str := "­¥á®¢¬¥á⨬®áâì ¯® ¯à¨á¢ ¨¢ ­¨î"
|132: str := "¢ë§®¢ ¯à®æ¥¤ãàë-ä㭪樨 ¤®¯ã᪠¥âáï ⮫쪮 ¢ á®áâ ¢¥ ¢ëà ¦¥­¨ï"
|133: str := "¨¤¥­â¨ä¨ª â®àë 'lib_init' ¨ 'version' § à¥§¥à¢¨à®¢ ­ë"
|138: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì SET"
|141: str := "âॡã¥âáï áâப  ¨«¨ ᨬ¢®«ì­ë© ¬ áᨢ"
|143: str := "âॡã¥âáï ᨬ¢®«ì­ë© ¬ áᨢ"
|145: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì POINTER"
|149: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì REAL ¨«¨ LONGREAL"
|150: str := "âॡã¥âáï áâப®¢ ï ª®­áâ ­â "
|155: str := "®¦¨¤ « áì '(' ¨«¨ ':='"
|156: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  INTEGER ¨«¨ CHAR"
|157: str := "®¦¨¤ « áì ':'"
|158: str := "­¥ ­ ©¤¥­  ¯à®æ¥¤ãà  ¢ ¬®¤ã«¥ RTL"
|159: str := "­ àã襭¨¥ £à ­¨æ ¬ áᨢ "
|160: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ª®­áâ ­âë"
|161: str := "âॡã¥âáï ª®­áâ ­â  â¨¯  INTEGER"
END;
IF H.OS = "LNX" THEN
Utf8(str)
END;
COPY(str, msg)
END ErrorMsg;
BEGIN
InitCP866(cp)
END ERRORS.

/programs/develop/oberon07/Source/FILES.ob07
0,0 → 1,219
(*
BSD 2-Clause License
Copyright (c) 2018, 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 BYTE; 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, k, res, idx: INTEGER;
BEGIN
idx := 0;
res := 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);
INC(res, n);
DEC(free, n);
DEC(bytes, n);
INC(idx, n);
INC(file.count, n);
IF free = 0 THEN
k := flush(file);
IF k # LEN(file.buffer) THEN
bytes := 0;
DEC(res, n)
ELSE
file.count := 0;
free := LEN(file.buffer)
END
END
END
END
RETURN res
END write;
PROCEDURE WriteByte* (file: FILE; byte: BYTE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := TRUE;
IF (file # NIL) & (file.count >= 0) THEN
IF file.count = LEN(file.buffer) THEN
IF flush(file) # LEN(file.buffer) THEN
res := FALSE
ELSE
file.buffer[0] := byte;
file.count := 1
END
ELSE
file.buffer[file.count] := byte;
INC(file.count)
END
ELSE
res := FALSE
END
RETURN res
END WriteByte;
BEGIN
files := C.create()
END FILES.

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

/programs/develop/oberon07/Source/LISTS.ob07
0,0 → 1,184
(*
BSD 2-Clause License
Copyright (c) 2018, 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;
list.last := item;
item.prev := NIL;
item.next := NIL
ELSE
ASSERT(list.last # NIL);
item.prev := list.last;
list.last.next := item;
item.next := NIL;
list.last := item
END
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;
cur.prev := nov;
nov.next := cur
ELSE
nov.prev := NIL;
cur.prev := nov;
nov.next := cur;
list.first := nov
END
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) & (prev # NIL) THEN
prev.next := next;
next.prev := prev
ELSIF (next = NIL) & (prev = NIL) THEN
list.first := NIL;
list.last := NIL
ELSIF (next = NIL) & (prev # NIL) THEN
prev.next := NIL;
list.last := prev
ELSIF (next # NIL) & (prev = NIL) THEN
next.prev := NIL;
list.first := next
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 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/MACHINE.ob07
0,0 → 1,110
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE MACHINE;
IMPORT UTILS;
CONST
min32* = -2147483647-1;
max32* = 2147483647;
VAR
target*:
RECORD
bit_depth*,
maxInt*,
minInt*,
maxSet*,
maxHex*: INTEGER;
maxReal*: REAL
END;
_64to32*: BOOLEAN;
PROCEDURE SetBitDepth* (pBitDepth: INTEGER);
BEGIN
ASSERT(pBitDepth <= UTILS.bit_depth);
ASSERT((pBitDepth = 32) OR (pBitDepth = 64));
_64to32 := (UTILS.bit_depth = 64) & (pBitDepth = 32);
target.bit_depth := pBitDepth;
target.maxSet := pBitDepth - 1;
target.maxHex := pBitDepth DIV 4;
target.minInt := ASR(UTILS.minint, UTILS.bit_depth - pBitDepth);
target.maxInt := ASR(UTILS.maxint, UTILS.bit_depth - pBitDepth);
target.maxReal := 1.9;
PACK(target.maxReal, 1023);
END SetBitDepth;
PROCEDURE Byte* (n: INTEGER; idx: INTEGER): BYTE;
BEGIN
WHILE idx > 0 DO
n := ASR(n, 8);
DEC(idx)
END
RETURN ORD(BITS(n) * {0..7})
END Byte;
PROCEDURE Align* (VAR bytes: INTEGER; align: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF bytes MOD align # 0 THEN
res := UTILS.maxint - bytes >= align - (bytes MOD align);
IF res THEN
bytes := bytes + align - (bytes MOD align)
END
ELSE
res := TRUE
END
RETURN res
END Align;
PROCEDURE Int32To64* (value: INTEGER): INTEGER;
BEGIN
IF UTILS.bit_depth = 64 THEN
value := LSL(value, 16);
value := LSL(value, 16);
value := ASR(value, 16);
value := ASR(value, 16)
END
RETURN value
END Int32To64;
PROCEDURE Int64To32* (value: INTEGER): INTEGER;
BEGIN
IF UTILS.bit_depth = 64 THEN
value := LSL(value, 16);
value := LSL(value, 16);
value := LSR(value, 16);
value := LSR(value, 16)
END
RETURN value
END Int64To32;
END MACHINE.

/programs/develop/oberon07/Source/MSCOFF.ob07
0,0 → 1,316
(*
BSD 2-Clause License
Copyright (c) 2018, 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 (File: WR.FILE; VirtualAddress, SymbolTableIndex, Type: INTEGER);
BEGIN
WR.Write32LE(File, VirtualAddress);
WR.Write32LE(File, SymbolTableIndex);
WR.Write16LE(File, Type)
END WriteReloc;
PROCEDURE Reloc (program: BIN.PROGRAM; File: WR.FILE);
VAR
reloc: BIN.RELOC;
BEGIN
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
CASE reloc.opcode OF
|BIN.RIMP, BIN.IMPTAB:
WriteReloc(File, reloc.offset, 4, 6)
|BIN.RBSS:
WriteReloc(File, reloc.offset, 5, 6)
|BIN.RDATA:
WriteReloc(File, reloc.offset, 2, 6)
|BIN.RCODE:
WriteReloc(File, reloc.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;
BEGIN
res := 0;
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
INC(res);
IF reloc.opcode = BIN.RIMP THEN
L := BIN.get32le(program.code, reloc.offset);
iproc := BIN.GetIProc(program, L);
BIN.put32le(program.code, reloc.offset, iproc.label)
END;
IF reloc.opcode = BIN.RCODE THEN
L := BIN.get32le(program.code, reloc.offset);
BIN.put32le(program.code, reloc.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
File: WR.FILE;
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.error1("too many relocations")
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;
File := WR.Create(FileName);
PE32.WriteFileHeader(File, FileHeader);
PE32.WriteSectionHeader(File, flat);
PE32.WriteSectionHeader(File, data);
PE32.WriteSectionHeader(File, edata);
PE32.WriteSectionHeader(File, idata);
PE32.WriteSectionHeader(File, bss);
CHL.WriteToFile(File, program.code);
CHL.WriteToFile(File, program.data);
exp := program.exp_list.first(BIN.EXPRT);
WHILE exp # NIL DO
WR.Write32LE(File, exp.nameoffs + edata.SizeOfRawData - ecount);
WR.Write32LE(File, exp.label);
exp := exp.next(BIN.EXPRT)
END;
WR.Write32LE(File, ((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD);
WR.Write32LE(File, ver);
WR.Write32LE(File, 0);
PE32.WriteName(File, szversion);
CHL.WriteToFile(File, program.export);
FOR i := 0 TO ILen - 1 DO
WR.Write32LE(File, CHL.GetInt(ImportTable, i))
END;
CHL.WriteToFile(File, program.import);
Reloc(program, File);
n := 0;
exp := program.exp_list.first(BIN.EXPRT);
WHILE exp # NIL DO
WriteReloc(File, n, 3, 6);
INC(n, 4);
WriteReloc(File, n, 1, 6);
INC(n, 4);
exp := exp.next(BIN.EXPRT)
END;
WriteReloc(File, n, 3, 6);
i := 0;
WHILE i < LibCount * 2 DO
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6);
INC(i);
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6);
INC(i)
END;
FOR i := LibCount * 2 TO ILen - 1 DO
IF CHL.GetInt(ImportTable, i) # 0 THEN
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6)
END
END;
PE32.WriteName(File, "EXPORTS");
WriteReloc(File, 0, 3, 2);
PE32.WriteName(File, ".flat");
WriteReloc(File, 0, 1, 3);
PE32.WriteName(File, ".data");
WriteReloc(File, 0, 2, 3);
PE32.WriteName(File, ".edata");
WriteReloc(File, 0, 3, 3);
PE32.WriteName(File, ".idata");
WriteReloc(File, 0, 4, 3);
PE32.WriteName(File, ".bss");
WriteReloc(File, 0, 5, 3);
WR.Write32LE(File, 4);
WR.Close(File)
END write;
END MSCOFF.

/programs/develop/oberon07/Source/PARS.ob07
0,0 → 1,1166
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE PARS;
IMPORT PROG, SCAN, ARITH, STRINGS, ERRORS, LISTS, CODE, CONSOLE, PATHS, MACHINE, C := COLLECTIONS, mConst := CONSTANTS;
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;
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: SCAN.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: 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
program*: PROG.PROGRAM;
parsers: C.COLLECTION;
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 error* (parser: PARSER; pos: SCAN.POSITION; errno: INTEGER);
BEGIN
ERRORS.errormsg(parser.fname, pos.line, pos.col, errno)
END error;
PROCEDURE check* (condition: BOOLEAN; parser: PARSER; pos: SCAN.POSITION; errno: INTEGER);
BEGIN
IF ~condition THEN
error(parser, pos, errno)
END
END check;
PROCEDURE check1* (condition: BOOLEAN; parser: PARSER; errno: INTEGER);
BEGIN
IF ~condition THEN
error(parser, parser.lex.pos, errno)
END
END check1;
PROCEDURE getpos (parser: PARSER; VAR pos: SCAN.POSITION);
BEGIN
pos := parser.lex.pos
END getpos;
PROCEDURE Next* (parser: PARSER);
VAR
errno: INTEGER;
BEGIN
SCAN.Next(parser.scanner, parser.lex);
errno := parser.lex.error;
IF errno # 0 THEN
check1(FALSE, parser, errno)
END;
parser.sym := parser.lex.sym
END Next;
PROCEDURE NextPos* (parser: PARSER; VAR pos: SCAN.POSITION);
BEGIN
Next(parser);
pos := parser.lex.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
|SCAN.lxSTRING: err := 66
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
name: SCAN.IDENT;
parser2: PARSER;
pos: SCAN.POSITION;
alias: BOOLEAN;
unit: PROG.UNIT;
ident: PROG.IDENT;
units: PROG.UNITS;
BEGIN
units := program.units;
alias := FALSE;
REPEAT
ExpectSym(parser, SCAN.lxIDENT);
name := parser.lex.ident;
getpos(parser, pos);
IF ~alias THEN
ident := parser.unit.idents.add(parser.unit, name, PROG.idMODULE);
check(ident # NIL, parser, pos, 30)
END;
Next(parser);
IF (parser.sym = SCAN.lxCOMMA) OR (parser.sym = SCAN.lxSEMI) THEN
alias := FALSE;
unit := units.get(units, name);
IF unit # NIL THEN
check(unit.closed, parser, pos, 31)
ELSE
parser2 := parser.create(parser.path, parser.lib_path,
parser.StatSeq, parser.expression, parser.designator, parser.chkreturn);
IF ~parser2.open(parser2, name.s) THEN
IF parser.path # parser.lib_path 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.s), parser, pos, 29)
ELSE
check(FALSE, parser, pos, 29)
END
END;
parser2.parse(parser2);
unit := parser2.unit;
destroy(parser2)
END;
IF unit = 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 := parser.unit.idents.get(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 := unit.idents.get(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.LEXSTR;
string1, string2: SCAN.IDENT;
bool: BOOLEAN;
BEGIN
IF v.typ = ARITH.tCHAR THEN
ASSERT(v2.typ = ARITH.tSTRING);
ARITH.charToStr(v, str);
string1 := SCAN.enterid(str);
string2 := v2.string(SCAN.IDENT)
END;
IF v2.typ = ARITH.tCHAR THEN
ASSERT(v.typ = ARITH.tSTRING);
ARITH.charToStr(v2, str);
string2 := SCAN.enterid(str);
string1 := v.string(SCAN.IDENT)
END;
IF v.typ = v2.typ THEN
string1 := v.string(SCAN.IDENT);
string2 := v2.string(SCAN.IDENT)
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: SCAN.POSITION;
BEGIN
getpos(parser, pos);
parser.constexp := TRUE;
parser.expression(parser, e);
parser.constexp := FALSE;
check(e.obj = eCONST, parser, pos, 62);
v := e.value
END ConstExpression;
PROCEDURE FieldList (parser: PARSER; rec: PROG.TYPE_);
VAR
name: SCAN.IDENT;
export: BOOLEAN;
pos: SCAN.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(rec.fields.add(rec, name, export), parser, 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(type.params.add(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 := program.enterType(program, PROG.tARRAY, -1, 0, parser.unit);
t1.base := t0;
t0 := t1;
DEC(dim)
END;
type.params.set(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 # PROG.tRECORD) & (ident.type.typ # 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): INTEGER;
VAR
res: INTEGER;
BEGIN
IF parser.lex.s = "stdcall" THEN
res := PROG.stdcall
ELSIF parser.lex.s = "stdcall64" THEN
res := PROG.stdcall64
ELSIF parser.lex.s = "ccall" THEN
res := PROG.ccall
ELSIF parser.lex.s = "ccall16" THEN
res := PROG.ccall16
ELSIF parser.lex.s = "win64" THEN
res := PROG.win64
ELSIF parser.lex.s = "systemv" THEN
res := PROG.systemv
ELSIF parser.lex.s = "windows" THEN
IF program.target.sys IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN
res := PROG.stdcall
ELSIF program.target.sys IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN
res := PROG.win64
ELSE
check1(FALSE, parser, 118)
END
ELSIF parser.lex.s = "linux" THEN
IF program.target.sys = mConst.Target_iELF32 THEN
res := PROG.ccall16
ELSIF program.target.sys = mConst.Target_iELF64 THEN
res := PROG.systemv
ELSE
check1(FALSE, parser, 119)
END
ELSIF parser.lex.s = "noalign" THEN
res := PROG.noalign
ELSE
res := 0
END
RETURN res
END sysflag;
PROCEDURE procflag (parser: PARSER; VAR import: CODE.IMPORT_PROC; isProc: BOOLEAN): INTEGER;
VAR
call: INTEGER;
dll, proc: SCAN.LEXSTR;
pos: SCAN.POSITION;
BEGIN
import := NIL;
IF parser.sym = SCAN.lxLSQUARE THEN
getpos(parser, pos);
check1(parser.unit.sysimport, parser, 54);
Next(parser);
call := sysflag(parser);
IF program.target.bit_depth = 64 THEN
check1(call IN PROG.callconv64, parser, 117)
ELSIF program.target.bit_depth = 32 THEN
check1(call IN PROG.callconv32, parser, 63)
END;
Next(parser);
IF parser.sym = SCAN.lxMINUS THEN
Next(parser);
INC(call)
END;
IF ~isProc THEN
checklex(parser, SCAN.lxRSQUARE)
END;
IF parser.sym = SCAN.lxCOMMA THEN
ExpectSym(parser, SCAN.lxSTRING);
dll := parser.lex.s;
ExpectSym(parser, SCAN.lxCOMMA);
ExpectSym(parser, SCAN.lxSTRING);
proc := parser.lex.s;
Next(parser);
import := CODE.AddImp(dll, proc)
END;
checklex(parser, SCAN.lxRSQUARE);
Next(parser)
ELSE
IF program.target.bit_depth = 32 THEN
call := PROG.default
ELSIF program.target.bit_depth = 64 THEN
call := PROG.default64
END
END;
IF import # NIL THEN
check(~(program.target.sys IN {mConst.Target_iELF32, mConst.Target_iELF64}), parser, 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: SCAN.POSITION;
fieldType: PROG.TYPE_;
baseIdent: SCAN.IDENT;
a, b: INTEGER;
RecFlag: INTEGER;
import: CODE.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, parser, pos, 43);
check(ARITH.check(arrLen), parser, pos, 39);
check(ARITH.getInt(arrLen) > 0, parser, pos, 51);
t := program.enterType(program, 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), parser, pos2, 104);
check(ARITH.setInt(typeSize, a), parser, pos2, 104);
t.size := a;
t.closed := TRUE
ELSIF parser.sym = SCAN.lxRECORD THEN
getpos(parser, pos2);
Next(parser);
t := program.enterType(program, 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);
IF RecFlag = PROG.noalign THEN
t.noalign := TRUE
ELSE
check1(FALSE, parser, 110)
END;
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}, parser, pos, 52);
IF t.base.typ = PROG.tPOINTER THEN
t.base := t.base.base;
check(t.base # NIL, parser, pos, 55)
END;
check(~t.base.noalign, parser, 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 := 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(t.fields.set(t, fieldType), parser, 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;
CODE.AddRec(t.base.num);
IF ~t.noalign THEN
check(MACHINE.Align(t.size, t.align), parser, pos2, 104);
check(ARITH.setInt(typeSize, t.size), parser, pos2, 104)
END;
checklex(parser, SCAN.lxEND);
Next(parser)
ELSIF parser.sym = SCAN.lxPOINTER THEN
ExpectSym(parser, SCAN.lxTO);
Next(parser);
t := program.enterType(program, PROG.tPOINTER, program.target.adr, 0, unit);
t.align := program.target.adr;
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, parser, pos, 58)
ELSE
unit.pointers.add(unit, t, baseIdent, pos)
END
ELSIF parser.sym = SCAN.lxPROCEDURE THEN
NextPos(parser, pos);
t := program.enterType(program, PROG.tPROCEDURE, program.target.adr, 0, unit);
t.align := program.target.adr;
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: SCAN.POSITION;
BEGIN
ASSERT(parser.sym = SCAN.lxIDENT);
name := parser.lex.ident;
getpos(parser, pos);
ident := parser.unit.idents.add(parser.unit, name, typ);
check(ident # NIL, parser, 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: SCAN.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), parser, pos, 39)
ELSIF ident.value.typ = ARITH.tREAL THEN
check(ARITH.check(ident.value), parser, pos, 40)
END;
ident.typ := PROG.idCONST;
ident.type := program.getType(program, 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, {});
parser.unit.setvars(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;
PROCEDURE ProcDeclaration (parser: PARSER): BOOLEAN;
VAR
proc: PROG.IDENT;
endname,
name: SCAN.IDENT;
param: LISTS.ITEM;
unit: PROG.UNIT;
ident: PROG.IDENT;
e: EXPR;
pos: SCAN.POSITION;
label: INTEGER;
enter: CODE.COMMAND;
call: INTEGER;
t: PROG.TYPE_;
import: CODE.IMPORT_PROC;
endmod, b: BOOLEAN;
fparams: SET;
variables: LISTS.LIST;
int, flt: INTEGER;
BEGIN
endmod := FALSE;
unit := parser.unit;
call := procflag(parser, import, TRUE);
getpos(parser, pos);
checklex(parser, SCAN.lxIDENT);
IF import # NIL THEN
proc := IdentDef(parser, PROG.idIMP, name);
proc.import := import;
program.procs.last(PROG.PROC).import := import
ELSE
proc := IdentDef(parser, PROG.idPROC, name)
END;
check(unit.scope.open(unit, proc.proc), parser, pos, 116);
proc.type := program.enterType(program, PROG.tPROCEDURE, program.target.adr, 0, unit);
t := proc.type;
t.align := program.target.adr;
t.call := call;
FormalParameters(parser, t);
IF call IN {PROG.systemv, PROG._systemv} THEN
check(t.params.size <= PROG.MAXSYSVPARAM, parser, pos, 120)
END;
param := t.params.first;
WHILE param # NIL DO
ident := unit.idents.add(unit, param(PROG.PARAM).name, PROG.idPARAM);
ASSERT(ident # NIL);
ident.type := param(PROG.PARAM).type;
ident.offset := param(PROG.PARAM).offset;
IF param(PROG.PARAM).vPar THEN
ident.typ := PROG.idVPAR
END;
param := param.next
END;
checklex(parser, SCAN.lxSEMI);
Next(parser);
IF import = NIL THEN
label := CODE.NewLabel();
proc.proc.label := label;
IF parser.main & proc.export & program.dll THEN
IF program.obj THEN
check((proc.name.s # "lib_init") & (proc.name.s # "version"), parser, pos, 114)
END;
CODE.AddExp(label, proc.name.s);
proc.proc.used := TRUE
END;
b := DeclarationSequence(parser);
program.locsize := 0;
IF call IN {PROG._win64, PROG.win64} THEN
fparams := proc.type.params.getfparams(proc.type, 3, int, flt);
enter := CODE.Enter(label, LSL(ORD(fparams), 5) + MIN(proc.type.params.size, 4))
ELSIF call IN {PROG._systemv, PROG.systemv} THEN
fparams := proc.type.params.getfparams(proc.type, PROG.MAXSYSVPARAM - 1, int, flt);
enter := CODE.Enter(label, -(LSL(ORD(fparams), 5) + proc.type.params.size))
ELSE
enter := CODE.Enter(label, 0)
END;
proc.proc.enter := enter;
IF parser.sym = SCAN.lxBEGIN THEN
Next(parser);
parser.StatSeq(parser)
END;
IF t.base # NIL THEN
checklex(parser, SCAN.lxRETURN);
NextPos(parser, pos);
parser.expression(parser, e);
check(parser.chkreturn(parser, e, t.base, pos), parser, pos, 87)
END;
proc.proc.leave := CODE.Leave(t.base # NIL, (t.base # NIL) & (t.base.typ = PROG.tREAL),
t.params.size * ORD((t.call IN PROG.callee_clean_up) OR (t.call IN {PROG.systemv, PROG._systemv})));
enter.param2 := program.locsize;
checklex(parser, SCAN.lxEND)
END;
IF parser.sym = SCAN.lxEND THEN
ExpectSym(parser, SCAN.lxIDENT);
getpos(parser, pos);
endname := parser.lex.ident;
IF import = NIL THEN
check(endname = name, parser, pos, 60);
ExpectSym(parser, SCAN.lxSEMI);
Next(parser)
ELSE
IF endname = parser.unit.name THEN
ExpectSym(parser, SCAN.lxPOINT);
Next(parser);
endmod := TRUE
ELSIF endname = name THEN
ExpectSym(parser, SCAN.lxSEMI);
Next(parser)
ELSE
check(FALSE, parser, pos, 60)
END
END
END;
IF import = NIL THEN
variables := LISTS.create(NIL);
ELSE
variables := NIL
END;
unit.scope.close(unit, variables);
IF import = NIL THEN
enter.variables := variables
END
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 := parser.unit.pointers.link(parser.unit);
IF ptr # NIL THEN
IF ptr.notRecord THEN
error(parser, ptr.pos, 58)
ELSE
error(parser, ptr.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;
BEGIN
ASSERT(parser # NIL);
ASSERT(parser.scanner # NIL);
ExpectSym(parser, SCAN.lxMODULE);
ExpectSym(parser, SCAN.lxIDENT);
IF ~parser.main THEN
check1(parser.lex.s = parser.modname, parser, 23)
END;
unit := program.units.create(program.units, parser.lex.ident);
parser.unit := unit;
ExpectSym(parser, SCAN.lxSEMI);
Next(parser);
IF parser.sym = SCAN.lxIMPORT THEN
ImportList(parser)
END;
CONSOLE.String("compiling "); CONSOLE.String(unit.name.s);
IF parser.unit.sysimport THEN
CONSOLE.String(" (SYSTEM)")
END;
CONSOLE.Ln;
label := CODE.NewLabel();
CODE.AddJmpCmd(CODE.opJMP, label);
name := CODE.putstr(unit.name.s);
CODE.SetErrLabel;
CODE.AddCmd(CODE.opSADR, name);
CODE.AddCmd(CODE.opPARAM, 1);
CODE.AddCmd0(CODE.opERR);
endmod := DeclarationSequence(parser);
CODE.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.s = unit.name.s, parser, 25);
ExpectSym(parser, SCAN.lxPOINT)
END;
unit.close(unit)
END parse;
PROCEDURE open (parser: PARSER; modname: ARRAY OF CHAR): BOOLEAN;
BEGIN
ASSERT(parser # NIL);
STRINGS.append(parser.fname, modname);
STRINGS.append(parser.fname, parser.ext);
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 := mConst.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* (bit_depth, sys: INTEGER);
BEGIN
program := PROG.create(bit_depth, sys);
parsers := C.create()
END init;
END PARS.

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

/programs/develop/oberon07/Source/PROG.ob07
0,0 → 1,1311
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE PROG;
IMPORT SCAN, LISTS, ARITH, ERRORS, MACHINE, C := COLLECTIONS, mConst := CONSTANTS, CODE, UTILS;
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;
tCARD16* = 13; tCARD32* = 14; tANYREC* = 15; tWCHAR* = 16;
BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD16, 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;
default* = 2;
stdcall* = 4; _stdcall* = stdcall + 1;
ccall* = 6; _ccall* = ccall + 1;
ccall16* = 8; _ccall16* = ccall16 + 1;
win64* = 10; _win64* = win64 + 1;
stdcall64* = 12; _stdcall64* = stdcall64 + 1;
default64* = 14;
systemv* = 16; _systemv* = systemv + 1;
noalign* = 20;
callee_clean_up* = {default, stdcall, _stdcall, default64, stdcall64, _stdcall64};
caller_clean_up* = {ccall, ccall16, win64, systemv, _ccall, _ccall16, _win64, _systemv};
callconv32* = {default, stdcall, ccall, ccall16, _stdcall, _ccall, _ccall16};
callconv64* = {default64, win64, stdcall64, systemv, _win64, _stdcall64, _systemv};
STACK_FRAME = 2;
TYPE
IDENT* = POINTER TO rIDENT;
UNIT* = POINTER TO rUNIT;
PROGRAM* = POINTER TO rPROGRAM;
TYPE_* = POINTER TO rTYPE_;
FRWPTR* = POINTER TO RECORD (LISTS.ITEM)
type: TYPE_;
baseIdent: SCAN.IDENT;
linked: BOOLEAN;
pos*: SCAN.POSITION;
notRecord*: BOOLEAN
END;
IDENTS = POINTER TO RECORD (LISTS.LIST)
add*: PROCEDURE (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
get*: PROCEDURE (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT
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)
program*: PROGRAM;
name*: SCAN.IDENT;
idents*: IDENTS;
frwPointers: LISTS.LIST;
gscope: IDENT;
closed*: BOOLEAN;
scopeLvl*: INTEGER;
sysimport*: BOOLEAN;
scopes*: ARRAY MAXSCOPE OF PROC;
scope*: RECORD
open*: PROCEDURE (unit: UNIT; proc: PROC): BOOLEAN;
close*: PROCEDURE (unit: UNIT; variables: LISTS.LIST)
END;
close*: PROCEDURE (unit: UNIT);
setvars*: PROCEDURE (unit: UNIT; type: TYPE_);
pointers*: RECORD
add*: PROCEDURE (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
link*: PROCEDURE (unit: UNIT): FRWPTR
END
END;
FIELD* = POINTER TO rFIELD;
PARAM* = POINTER TO rPARAM;
FIELDS = POINTER TO RECORD (LISTS.LIST)
add*: PROCEDURE (rec: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
get*: PROCEDURE (rec: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;
set*: PROCEDURE (rec: TYPE_; type: TYPE_): BOOLEAN
END;
PARAMS = POINTER TO RECORD (LISTS.LIST)
size*: INTEGER;
add*: PROCEDURE (proc: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
get*: PROCEDURE (proc: TYPE_; name: SCAN.IDENT): PARAM;
set*: PROCEDURE (proc: TYPE_; type: TYPE_);
getfparams*: PROCEDURE (proc: TYPE_; maxparam: INTEGER; VAR int, flt: INTEGER): SET
END;
rTYPE_ = RECORD (LISTS.ITEM)
typ*: INTEGER;
size*: INTEGER;
length*: INTEGER;
align*: INTEGER;
base*: TYPE_;
fields*: FIELDS;
params*: PARAMS;
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;
UNITS* = POINTER TO RECORD (LISTS.LIST)
program: PROGRAM;
create*: PROCEDURE (units: UNITS; name: SCAN.IDENT): UNIT;
get*: PROCEDURE (units: UNITS; name: SCAN.IDENT): UNIT
END;
rPROGRAM = RECORD
recCount: INTEGER;
units*: UNITS;
types*: LISTS.LIST;
sysunit*: UNIT;
rtl*: UNIT;
bss*: INTEGER;
locsize*: INTEGER;
procs*: LISTS.LIST;
dll*: BOOLEAN;
obj*: BOOLEAN;
stTypes*: RECORD
tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*, tSTRING*, tNIL*,
tCARD16*, tCARD32*, tANYREC*: TYPE_
END;
target*: RECORD
bit_depth*: INTEGER;
word*: INTEGER;
adr*: INTEGER;
sys*: INTEGER
END;
enterType*: PROCEDURE (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
getType*: PROCEDURE (program: PROGRAM; typ: INTEGER): TYPE_
END;
DELIMPORT = PROCEDURE (import: LISTS.ITEM);
VAR
idents: C.COLLECTION;
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* (program: PROGRAM; varIdent: IDENT): INTEGER;
VAR
word: INTEGER;
size: INTEGER;
BEGIN
IF varIdent.offset = -1 THEN
IF varIdent.global THEN
IF MACHINE.Align(program.bss, varIdent.type.align) THEN
IF UTILS.maxint - program.bss >= varIdent.type.size THEN
varIdent.offset := program.bss;
INC(program.bss, varIdent.type.size)
END
END
ELSE
word := program.target.word;
size := varIdent.type.size;
IF MACHINE.Align(size, word) THEN
size := size DIV word;
IF UTILS.maxint - program.locsize >= size THEN
INC(program.locsize, size);
varIdent.offset := program.locsize;
END
END
END
END
RETURN varIdent.offset
END getOffset;
PROCEDURE close (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(unit.program, 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 close;
PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;
VAR
item: IDENT;
BEGIN
ASSERT(ident # NIL);
item := unit.idents.last(IDENT);
WHILE (item.typ # idGUARD) & (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;
procs: LISTS.LIST;
BEGIN
ASSERT(unit # NIL);
ASSERT(ident # 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);
procs := unit.program.procs;
LISTS.push(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 setvars (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 setvars;
PROCEDURE getIdent (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;
VAR
item: IDENT;
BEGIN
ASSERT(ident # NIL);
item := unit.idents.last(IDENT);
ASSERT(item # NIL);
IF currentScope THEN
WHILE (item.name # ident) & (item.typ # idGUARD) DO
item := item.prev(IDENT)
END;
IF item.name # ident THEN
item := NIL
END
ELSE
WHILE (item # NIL) & (item.name # ident) DO
item := item.prev(IDENT)
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 := NIL;
item.typ := idGUARD;
LISTS.push(unit.idents, item)
END
RETURN res
END openScope;
PROCEDURE closeScope (unit: UNIT; variables: LISTS.LIST);
VAR
item: IDENT;
del: IDENT;
lvar: CODE.LOCALVAR;
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;
IF (variables # NIL) & (del.typ IN {idVAR, idPARAM}) & (del.offset # -1) THEN
IF del.type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN
lvar := CODE.NewVar();
lvar.offset := del.offset;
lvar.size := del.type.size;
IF del.typ = idVAR THEN
lvar.offset := -lvar.offset
END;
LISTS.push(variables, lvar)
END
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);
ASSERT(baseIdent # 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 := unit.idents.get(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) & ((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 = tPOINTER) & (t1.typ = tPOINTER)) OR ((t0.typ = tRECORD) & (t1.typ = tRECORD));
IF (t0.typ = tPOINTER) & (t1.typ = tPOINTER) THEN
t0 := t0.base;
t1 := t1.base
END;
WHILE res & (t1 # NIL) & (t1 # t0) DO
t1 := t1.base
END
RETURN res & (t1 = t0)
END isBaseOf;
PROCEDURE isOpenArray* (t: TYPE_): BOOLEAN;
RETURN (t.typ = tARRAY) & (t.length = 0)
END isOpenArray;
PROCEDURE getunit (units: UNITS; name: SCAN.IDENT): UNIT;
VAR
item: UNIT;
BEGIN
ASSERT(name # NIL);
item := units.first(UNIT);
WHILE (item # NIL) & (item.name # name) DO
item := item.next(UNIT)
END;
IF (item = NIL) & (name.s = "SYSTEM") THEN
item := units.program.sysunit
END
RETURN item
END getunit;
PROCEDURE enterStTypes (unit: UNIT; program: PROGRAM);
VAR
ident: IDENT;
stName: SCAN.IDENT;
BEGIN
stName := SCAN.enterid("INTEGER");
ident := addIdent(unit, stName, idTYPE);
ident.type := program.stTypes.tINTEGER;
stName := SCAN.enterid("BYTE");
ident := addIdent(unit, stName, idTYPE);
ident.type := program.stTypes.tBYTE;
stName := SCAN.enterid("CHAR");
ident := addIdent(unit, stName, idTYPE);
ident.type := program.stTypes.tCHAR;
stName := SCAN.enterid("WCHAR");
ident := addIdent(unit, stName, idTYPE);
ident.type := program.stTypes.tWCHAR;
stName := SCAN.enterid("SET");
ident := addIdent(unit, stName, idTYPE);
ident.type := program.stTypes.tSET;
stName := SCAN.enterid("BOOLEAN");
ident := addIdent(unit, stName, idTYPE);
ident.type := program.stTypes.tBOOLEAN;
stName := SCAN.enterid("REAL");
ident := addIdent(unit, stName, idTYPE);
ident.type := program.stTypes.tREAL;
END enterStTypes;
PROCEDURE enterStProcs (unit: UNIT);
PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
VAR
ident: IDENT;
BEGIN
ident := addIdent(unit, SCAN.enterid(name), idtyp);
ident.stproc := proc
END EnterProc;
BEGIN
EnterProc(unit, "ASSERT", idSTPROC, stASSERT);
EnterProc(unit, "DEC", idSTPROC, stDEC);
EnterProc(unit, "EXCL", idSTPROC, stEXCL);
EnterProc(unit, "INC", idSTPROC, stINC);
EnterProc(unit, "INCL", idSTPROC, stINCL);
EnterProc(unit, "NEW", idSTPROC, stNEW);
EnterProc(unit, "PACK", idSTPROC, stPACK);
EnterProc(unit, "UNPK", idSTPROC, stUNPK);
EnterProc(unit, "DISPOSE", idSTPROC, stDISPOSE);
EnterProc(unit, "COPY", idSTPROC, stCOPY);
EnterProc(unit, "ABS", idSTFUNC, stABS);
EnterProc(unit, "ASR", idSTFUNC, stASR);
EnterProc(unit, "CHR", idSTFUNC, stCHR);
EnterProc(unit, "WCHR", idSTFUNC, stWCHR);
EnterProc(unit, "FLOOR", idSTFUNC, stFLOOR);
EnterProc(unit, "FLT", idSTFUNC, stFLT);
EnterProc(unit, "LEN", idSTFUNC, stLEN);
EnterProc(unit, "LSL", idSTFUNC, stLSL);
EnterProc(unit, "ODD", idSTFUNC, stODD);
EnterProc(unit, "ORD", idSTFUNC, stORD);
EnterProc(unit, "ROR", idSTFUNC, stROR);
EnterProc(unit, "BITS", idSTFUNC, stBITS);
EnterProc(unit, "LSR", idSTFUNC, stLSR);
EnterProc(unit, "LENGTH", idSTFUNC, stLENGTH);
EnterProc(unit, "MIN", idSTFUNC, stMIN);
EnterProc(unit, "MAX", idSTFUNC, stMAX);
END enterStProcs;
PROCEDURE newunit (units: UNITS; name: SCAN.IDENT): UNIT;
VAR
unit: UNIT;
idents: IDENTS;
BEGIN
ASSERT(units # NIL);
ASSERT(name # NIL);
NEW(unit);
NEW(idents);
ASSERT(LISTS.create(idents) = idents);
idents.add := addIdent;
idents.get := getIdent;
unit.program := units.program;
unit.name := name;
unit.closed := FALSE;
unit.idents := idents;
unit.frwPointers := LISTS.create(NIL);
unit.scope.open := openScope;
unit.scope.close := closeScope;
unit.close := close;
unit.setvars := setvars;
unit.pointers.add := frwptr;
unit.pointers.link := linkptr;
ASSERT(unit.scope.open(unit, NIL));
enterStTypes(unit, units.program);
enterStProcs(unit);
ASSERT(unit.scope.open(unit, NIL));
unit.gscope := unit.idents.last(IDENT);
LISTS.push(units, unit);
unit.scopeLvl := 0;
unit.scopes[0] := NIL;
unit.sysimport := FALSE;
IF unit.name.s = mConst.RTL_NAME THEN
unit.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(name # NIL);
ASSERT(unit # NIL);
field := NIL;
WHILE (self # NIL) & (field = NIL) DO
field := self.fields.first(FIELD);
WHILE (field # NIL) & (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
ASSERT(name # NIL);
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 := MACHINE.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
ASSERT(name # NIL);
item := self.params.first(PARAM);
WHILE (item # NIL) & (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
ASSERT(name # NIL);
res := self.params.get(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.params.size - 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 := MACHINE.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.params.size + ORD(type.typ = tRECORD) + Dim(type) + STACK_FRAME;
INC(self.params.size, 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(MACHINE.Align(size, word));
size := size DIV word
END;
param.offset := self.params.size + Dim(type) + STACK_FRAME;
INC(self.params.size, size)
END;
item := item.next
END
END setParams;
PROCEDURE enterType (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
VAR
t: TYPE_;
fields: FIELDS;
params: PARAMS;
BEGIN
NEW(t);
NEW(fields);
ASSERT(LISTS.create(fields) = fields);
NEW(params);
ASSERT(LISTS.create(params) = params);
t.typ := typ;
t.size := size;
t.length := length;
t.align := 0;
t.base := NIL;
t.fields := fields;
t.params := params;
t.unit := unit;
t.num := 0;
IF program.target.bit_depth = 32 THEN
t.call := default
ELSIF program.target.bit_depth = 64 THEN
t.call := default64
END;
t.import := FALSE;
t.noalign := FALSE;
t.fields.add := addField;
t.fields.get := getField;
t.fields.set := setFields;
t.params.add := addParam;
t.params.get := getParam;
t.params.getfparams := getFloatParamsPos;
t.params.set := setParams;
t.params.size := 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 (program: PROGRAM; typ: INTEGER): TYPE_;
VAR
res: TYPE_;
BEGIN
IF typ = ARITH.tINTEGER THEN
res := program.stTypes.tINTEGER
ELSIF typ = ARITH.tREAL THEN
res := program.stTypes.tREAL
ELSIF typ = ARITH.tSET THEN
res := program.stTypes.tSET
ELSIF typ = ARITH.tBOOLEAN THEN
res := program.stTypes.tBOOLEAN
ELSIF typ = ARITH.tCHAR THEN
res := program.stTypes.tCHAR
ELSIF typ = ARITH.tWCHAR THEN
res := program.stTypes.tWCHAR
ELSIF typ = ARITH.tSTRING THEN
res := program.stTypes.tSTRING
ELSE
res := NIL
END;
ASSERT(res # NIL)
RETURN res
END getType;
PROCEDURE createSysUnit (program: PROGRAM);
VAR
ident: IDENT;
unit: UNIT;
PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
VAR
ident: IDENT;
BEGIN
ident := addIdent(sys, SCAN.enterid(name), idtyp);
ident.stproc := proc;
ident.export := TRUE
END EnterProc;
BEGIN
unit := program.units.create(program.units, SCAN.enterid("$SYSTEM"));
EnterProc(unit, "ADR", idSYSFUNC, sysADR);
EnterProc(unit, "SIZE", idSYSFUNC, sysSIZE);
EnterProc(unit, "SADR", idSYSFUNC, sysSADR);
EnterProc(unit, "WSADR", idSYSFUNC, sysWSADR);
EnterProc(unit, "TYPEID", idSYSFUNC, sysTYPEID);
EnterProc(unit, "INF", idSYSFUNC, sysINF);
EnterProc(unit, "GET", idSYSPROC, sysGET);
EnterProc(unit, "PUT", idSYSPROC, sysPUT);
EnterProc(unit, "PUT8", idSYSPROC, sysPUT8);
EnterProc(unit, "PUT16", idSYSPROC, sysPUT16);
EnterProc(unit, "PUT32", idSYSPROC, sysPUT32);
EnterProc(unit, "CODE", idSYSPROC, sysCODE);
EnterProc(unit, "MOVE", idSYSPROC, sysMOVE);
EnterProc(unit, "COPY", idSYSPROC, sysCOPY);
ident := addIdent(unit, SCAN.enterid("CARD16"), idTYPE);
ident.type := program.stTypes.tCARD16;
ident.export := TRUE;
ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
ident.type := program.stTypes.tCARD32;
ident.export := TRUE;
unit.close(unit);
program.sysunit := unit
END createSysUnit;
PROCEDURE DelUnused* (program: PROGRAM; 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
CODE.delete2(proc.enter, proc.leave)
ELSE
DelImport(proc.import)
END
END;
proc := proc.next(PROC)
END
END DelUnused;
PROCEDURE create* (bit_depth, sys: INTEGER): PROGRAM;
VAR
program: PROGRAM;
units: UNITS;
BEGIN
idents := C.create();
MACHINE.SetBitDepth(bit_depth);
NEW(program);
NEW(units);
ASSERT(LISTS.create(units) = units);
program.target.bit_depth := bit_depth;
program.target.word := bit_depth DIV 8;
program.target.adr := bit_depth DIV 8;
program.target.sys := sys;
program.recCount := -1;
program.bss := 0;
program.units := units;
program.types := LISTS.create(NIL);
program.procs := LISTS.create(NIL);
program.enterType := enterType;
program.getType := getType;
program.stTypes.tINTEGER := enterType(program, tINTEGER, program.target.word, 0, NIL);
program.stTypes.tBYTE := enterType(program, tBYTE, 1, 0, NIL);
program.stTypes.tCHAR := enterType(program, tCHAR, 1, 0, NIL);
program.stTypes.tWCHAR := enterType(program, tWCHAR, 2, 0, NIL);
program.stTypes.tSET := enterType(program, tSET, program.target.word, 0, NIL);
program.stTypes.tBOOLEAN := enterType(program, tBOOLEAN, 1, 0, NIL);
program.stTypes.tREAL := enterType(program, tREAL, 8, 0, NIL);
program.stTypes.tSTRING := enterType(program, tSTRING, program.target.word, 0, NIL);
program.stTypes.tNIL := enterType(program, tNIL, program.target.word, 0, NIL);
program.stTypes.tCARD16 := enterType(program, tCARD16, 2, 0, NIL);
program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL);
program.stTypes.tANYREC := enterType(program, tRECORD, 0, 0, NIL);
program.stTypes.tANYREC.closed := TRUE;
program.stTypes.tINTEGER.align := program.stTypes.tINTEGER.size;
program.stTypes.tBYTE.align := 1;
program.stTypes.tCHAR.align := program.stTypes.tCHAR.size;
program.stTypes.tWCHAR.align := program.stTypes.tWCHAR.size;
program.stTypes.tSET.align := program.stTypes.tSET.size;
program.stTypes.tBOOLEAN.align := program.stTypes.tBOOLEAN.size;
program.stTypes.tREAL.align := program.stTypes.tREAL.size;
program.stTypes.tCARD16.align := program.stTypes.tCARD16.size;
program.stTypes.tCARD32.align := program.stTypes.tCARD32.size;
units.program := program;
units.create := newunit;
units.get := getunit;
program.dll := FALSE;
program.obj := FALSE;
createSysUnit(program)
RETURN program
END create;
END PROG.

/programs/develop/oberon07/Source/REG.ob07
0,0 → 1,434
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE REG;
CONST
N = 16;
R0* = 0; R1* = 1; R2* = 2;
R8* = 8; R9* = 9; R10* = 10; R11* = 11;
NVR = 32;
TYPE
OP1 = PROCEDURE (arg: INTEGER);
OP2 = PROCEDURE (arg1, arg2: INTEGER);
OP3 = PROCEDURE (arg1, arg2, arg3: INTEGER);
REGS* = POINTER TO RECORD
regs*: SET;
stk*: ARRAY N OF INTEGER;
top*: INTEGER;
pushed*: INTEGER;
vregs*: SET;
offs: ARRAY NVR OF INTEGER;
size: ARRAY NVR OF INTEGER;
push, pop: OP1;
mov, xch: OP2;
load, save: OP3
END;
PROCEDURE push (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 (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, n: INTEGER;
BEGIN
i := 0;
n := R.top;
WHILE (i <= n) & (R.stk[i] # reg) DO
INC(i)
END;
IF i > n THEN
i := -1
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 (R: REGS; reg: INTEGER);
BEGIN
EXCL(R.regs, reg);
INC(R.top);
R.stk[R.top] := reg
END Put;
PROCEDURE PopAnyReg (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* (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* (R: REGS; reg: INTEGER): BOOLEAN;
VAR
free, n: INTEGER;
res: BOOLEAN;
PROCEDURE exch (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
n := InStk(R, reg);
IF n # -1 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;
res := TRUE
ELSE
res := FALSE
END
END
RETURN res
END GetReg;
PROCEDURE Exchange* (R: REGS; reg1, reg2: INTEGER): BOOLEAN;
VAR
n1, n2: INTEGER;
res: BOOLEAN;
BEGIN
res := FALSE;
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);
res := TRUE
ELSIF (n1 # -1) & (reg2 IN R.regs) THEN
R.stk[n1] := reg2;
INCL(R.regs, reg1);
EXCL(R.regs, reg2);
R.mov(reg2, reg1);
res := TRUE
ELSIF (n2 # -1) & (reg1 IN R.regs) THEN
R.stk[n2] := reg1;
EXCL(R.regs, reg1);
INCL(R.regs, reg2);
R.mov(reg1, reg2);
res := TRUE
END
ELSE
res := TRUE
END
RETURN res
END Exchange;
PROCEDURE Drop* (R: REGS);
BEGIN
INCL(R.regs, R.stk[R.top]);
DEC(R.top)
END Drop;
PROCEDURE BinOp* (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[R.top]
ELSIF R.top < 0 THEN
reg2 := PopAnyReg(R);
reg1 := PopAnyReg(R)
END
END BinOp;
PROCEDURE UnOp* (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* (R: REGS);
BEGIN
WHILE R.top >= 0 DO
push(R)
END
END PushAll;
PROCEDURE Lock* (R: REGS; reg, offs, size: INTEGER);
BEGIN
ASSERT(reg IN R.vregs);
ASSERT(offs # 0);
R.offs[reg] := offs;
IF size = 0 THEN
size := 8
END;
R.size[reg] := size
END Lock;
PROCEDURE Release* (R: REGS; reg: INTEGER);
BEGIN
ASSERT(reg IN R.vregs);
R.offs[reg] := 0
END Release;
PROCEDURE Load* (R: REGS; reg: INTEGER);
VAR
offs: INTEGER;
BEGIN
ASSERT(reg IN R.vregs);
offs := R.offs[reg];
IF offs # 0 THEN
R.load(reg, offs, R.size[reg])
END
END Load;
PROCEDURE Save* (R: REGS; reg: INTEGER);
VAR
offs: INTEGER;
BEGIN
ASSERT(reg IN R.vregs);
offs := R.offs[reg];
IF offs # 0 THEN
R.save(reg, offs, R.size[reg])
END
END Save;
PROCEDURE Store* (R: REGS);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO NVR - 1 DO
IF i IN R.vregs THEN
Save(R, i)
END
END
END Store;
PROCEDURE Restore* (R: REGS);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO NVR - 1 DO
IF i IN R.vregs THEN
Load(R, i)
END
END
END Restore;
PROCEDURE Reset* (R: REGS);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO NVR - 1 DO
IF i IN R.vregs THEN
R.offs[i] := 0
END
END
END Reset;
PROCEDURE GetVarReg* (R: REGS; offs: INTEGER): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := -1;
i := 0;
WHILE i < NVR DO
IF (i IN R.vregs) & (R.offs[i] = offs) THEN
res := i;
i := NVR
END;
INC(i)
END
RETURN res
END GetVarReg;
PROCEDURE GetAnyVarReg* (R: REGS): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := -1;
i := 0;
WHILE i < NVR DO
IF (i IN R.vregs) & (R.offs[i] = 0) THEN
res := i;
i := NVR
END;
INC(i)
END
RETURN res
END GetAnyVarReg;
PROCEDURE Create* (push, pop: OP1; mov, xch: OP2; load, save: OP3; regs, vregs: SET): REGS;
VAR
R: REGS;
i: INTEGER;
BEGIN
NEW(R);
R.regs := regs;
R.pushed := 0;
R.top := -1;
R.push := push;
R.pop := pop;
R.mov := mov;
R.xch := xch;
R.load := load;
R.save := save;
R.vregs := vregs;
FOR i := 0 TO NVR - 1 DO
R.offs[i] := 0;
R.size[i] := 0
END
RETURN R
END Create;
END REG.

/programs/develop/oberon07/Source/SCAN.ob07
1,699 → 1,723
(*
Copyright 2016 Anton Krotov
(*
BSD 2-Clause License
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE SCAN;
IMPORT UTILS, sys := SYSTEM;
IMPORT TEXTDRV, AVL := AVLTREES, ARITH, S := STRINGS, C := COLLECTIONS;
CONST
Tab = 8;
maxINT* = 7FFFFFFFH;
minINT* = 80000000H;
maxREAL* = 3.39E38;
maxDBL* = 1.69D308;
minREAL* = 1.41E-45;
IDLENGTH = 255;
STRLENGTH* = 256;
LEXLEN = 1024;
lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7;
lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8;
lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16;
lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23;
lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30;
lxUNTIL = 31; lxVAR = 32; lxWHILE = 33;
lxUNDEF* = 0; lxIDENT* = 1; lxINTEGER* = 2; lxHEX* = 3;
lxCHAR* = 4; lxFLOAT* = 5; lxSTRING* = 6; lxCOMMENT* = 7;
lxEOF* = 8;
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58;
lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65;
lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
lxKW = 101;
lxERR0 = 100; lxERR1 = 101; lxERR2 = 102; lxERR3 = 103; lxERR4 = 104; lxERR5 = 105; lxERR6 = 106;
lxERR7 = 107; lxERR8 = 108; lxERR9 = 109; lxERR10 = 110; lxERR11 = 111; lxERR20 = 120;
lxARRAY* = 101; lxBEGIN* = 102; lxBY* = 103; lxCASE* = 104;
lxCONST* = 105; lxDIV* = 106; lxDO* = 107; lxELSE* = 108;
lxELSIF* = 109; lxEND* = 110; lxFALSE* = 111; lxFOR* = 112;
lxIF* = 113; lxIMPORT* = 114; lxIN* = 115; lxIS* = 116;
lxMOD* = 117; lxMODULE* = 118; lxNIL* = 119; lxOF* = 120;
lxOR* = 121; lxPOINTER* = 122; lxPROCEDURE* = 123; lxRECORD* = 124;
lxREPEAT* = 125; lxRETURN* = 126; lxTHEN* = 127; lxTO* = 128;
lxTRUE* = 129; lxTYPE* = 130; lxUNTIL* = 131; lxVAR* = 132;
lxWHILE* = 133;
lxPLUS* = 201; lxMINUS* = 202; lxMUL* = 203; lxSLASH* = 204;
lxNOT* = 205; lxAND* = 206; lxPOINT* = 207; lxCOMMA* = 208;
lxSEMI* = 209; lxBAR* = 210; lxLROUND* = 211; lxLSQUARE* = 212;
lxLCURLY* = 213; lxCARET* = 214; lxEQ* = 215; lxNE* = 216;
lxLT* = 217; lxGT* = 218; lxCOLON* = 219; lxRROUND* = 220;
lxRSQUARE* = 221; lxRCURLY* = 222; lxLE* = 223; lxGE* = 224;
lxASSIGN* = 225; lxRANGE* = 226;
lxERROR01 = -1; lxERROR02 = -2; lxERROR03 = -3; lxERROR04 = -4;
lxERROR05 = -5; lxERROR06 = -6; lxERROR07 = -7; lxERROR08 = -8;
lxERROR09 = -9; lxERROR10 = -10; lxERROR11 = -11; lxERROR12 = -12;
TYPE
TCoord* = RECORD line*, col*: INTEGER END;
LEXSTR* = ARRAY LEXLEN OF CHAR;
NODE* = POINTER TO RECORD
Left, Right: NODE;
tLex: INTEGER;
Name*: UTILS.STRING
IDENT* = POINTER TO RECORD (AVL.DATA)
s*: LEXSTR;
offset*, offsetW*: INTEGER
END;
SCANNER* = POINTER TO RECORD
File, ccol, cline, count, tLex, vINT: INTEGER;
coord: TCoord;
ch, vCHX: CHAR;
Lex: UTILS.STRING;
vFLT: LONGREAL;
id: NODE;
buf, bufpos: INTEGER;
CR, UTF8: BOOLEAN
POSITION* = RECORD
line*, col*: INTEGER
END;
LEX* = RECORD
s*: LEXSTR;
length*: INTEGER;
sym*: INTEGER;
pos*: POSITION;
ident*: IDENT;
string*: IDENT;
value*: ARITH.VALUE;
error*: INTEGER;
over: BOOLEAN
END;
SCANNER* = POINTER TO RECORD (C.ITEM)
text: TEXTDRV.TEXT;
range: BOOLEAN
END;
KEYWORD = ARRAY 10 OF CHAR;
VAR
Lex*: UTILS.STRING; File, ccol, cline, count*, tLex*, vINT*: INTEGER;
coord*: TCoord;
vFLT*: LONGREAL; id*: NODE; ch, vCHX*: CHAR;
buf, bufpos: INTEGER; CR, UTF8: BOOLEAN;
Nodes: ARRAY 256 OF NODE;
_START*, _version*: NODE;
vocabulary: RECORD
PROCEDURE AddNode*(Name: UTILS.STRING): NODE;
VAR cur, res: NODE;
KW: ARRAY 33 OF KEYWORD;
PROCEDURE NewNode(Right: BOOLEAN);
delimiters: ARRAY 256 OF BOOLEAN;
idents: AVL.NODE;
ident: IDENT
END;
scanners: C.COLLECTION;
PROCEDURE nodecmp (a, b: AVL.DATA): INTEGER;
RETURN ORD(a(IDENT).s > b(IDENT).s) - ORD(a(IDENT).s < b(IDENT).s)
END nodecmp;
PROCEDURE key (VAR lex: LEX);
VAR
L, R, M: INTEGER;
BEGIN
NEW(res);
UTILS.MemErr(res = NIL);
res.Name := Name;
res.tLex := lxIDENT;
res.Left := NIL;
res.Right := NIL;
IF Right THEN
cur.Right := res
L := 0;
R := LEN(vocabulary.KW) - 1;
M := (L + R) DIV 2;
WHILE L # M DO
IF lex.s > vocabulary.KW[M] THEN
L := M;
M := (L + R) DIV 2
ELSIF lex.s < vocabulary.KW[M] THEN
R := M;
M := (L + R) DIV 2
ELSE
cur.Left := res
lex.sym := lxKW + M;
L := M;
R := M
END
END NewNode;
END;
BEGIN
res := NIL;
cur := Nodes[ORD(Name[0])];
REPEAT
IF Name > cur.Name THEN
IF cur.Right # NIL THEN
cur := cur.Right
ELSE
NewNode(TRUE)
IF L # R THEN
IF lex.s = vocabulary.KW[L] THEN
lex.sym := lxKW + L
END;
IF lex.s = vocabulary.KW[R] THEN
lex.sym := lxKW + R
END
ELSIF Name < cur.Name THEN
IF cur.Left # NIL THEN
cur := cur.Left
ELSE
NewNode(FALSE)
END
ELSE
res := cur
END
UNTIL res # NIL
RETURN res
END AddNode;
PROCEDURE Backup*(scanner: SCANNER);
BEGIN
scanner.File := File;
scanner.ccol := ccol;
scanner.cline := cline;
scanner.ch := ch;
scanner.Lex := Lex;
scanner.count := count;
scanner.coord := coord;
scanner.tLex := tLex;
scanner.vINT := vINT;
scanner.vFLT := vFLT;
scanner.vCHX := vCHX;
scanner.buf := buf;
scanner.bufpos := bufpos;
scanner.CR := CR;
scanner.UTF8 := UTF8
END Backup;
END key;
PROCEDURE Recover*(scanner: SCANNER);
PROCEDURE enterid* (s: LEXSTR): IDENT;
VAR
newnode: BOOLEAN;
node: AVL.NODE;
BEGIN
File := scanner.File;
ccol := scanner.ccol;
cline := scanner.cline;
ch := scanner.ch;
Lex := scanner.Lex;
count := scanner.count;
coord := scanner.coord;
tLex := scanner.tLex;
vINT := scanner.vINT;
vFLT := scanner.vFLT;
vCHX := scanner.vCHX;
buf := scanner.buf;
bufpos := scanner.bufpos;
CR := scanner.CR;
UTF8 := scanner.UTF8
END Recover;
vocabulary.ident.s := s;
vocabulary.idents := AVL.insert(vocabulary.idents, vocabulary.ident, nodecmp, newnode, node);
PROCEDURE Next;
VAR cr: BOOLEAN;
IF newnode THEN
NEW(vocabulary.ident);
vocabulary.ident.offset := -1;
vocabulary.ident.offsetW := -1
END
RETURN node.data(IDENT)
END enterid;
PROCEDURE putchar (VAR lex: LEX; c: CHAR);
BEGIN
cr := FALSE;
sys.GET(bufpos, ch);
INC(ccol);
CASE ch OF
|0AX: IF ~CR THEN INC(cline) END; ccol := 0
|0DX: INC(cline); ccol := 0; cr := TRUE
|09X: DEC(ccol); ccol := (ccol DIV Tab) * Tab + Tab
|80X..0BFX: IF UTF8 THEN DEC(ccol) END
IF lex.length < LEXLEN - 1 THEN
lex.s[lex.length] := c;
INC(lex.length);
lex.s[lex.length] := 0X
ELSE
END;
CR := cr;
INC(bufpos)
END Next;
lex.over := TRUE
END
END putchar;
PROCEDURE Open*(FName: ARRAY OF CHAR; VAR FHandle: INTEGER): BOOLEAN;
VAR n, size: INTEGER; c: CHAR;
PROCEDURE ident (text: TEXTDRV.TEXT; VAR lex: LEX);
VAR
c: CHAR;
BEGIN
File := UTILS.OpenF(FName);
FHandle := File;
IF File # 0 THEN
CR := FALSE;
UTF8 := FALSE;
ccol := 0;
cline := 1;
ch := 0X;
size := UTILS.FileSize(File);
buf := UTILS.GetMem(size + 1024);
UTILS.MemErr(buf = 0);
sys.PUT(buf + size, 0X);
n := UTILS.Read(File, buf, size);
UTILS.CloseF(File);
bufpos := buf;
sys.GET(buf, c);
IF c = 0EFX THEN
sys.GET(buf + 1, c);
IF c = 0BBX THEN
sys.GET(buf + 2, c);
IF c = 0BFX THEN
INC(bufpos, 3);
UTF8 := TRUE
END
END
c := text.peak(text);
ASSERT(S.letter(c));
WHILE S.letter(c) OR S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
END;
Next
END
RETURN (File # 0) & (n = size)
END Open;
PROCEDURE Space(ch: CHAR): BOOLEAN;
RETURN (ch <= 20X) & (ch > 0X)
END Space;
IF lex.over THEN
lex.sym := lxERROR06
ELSE
lex.sym := lxIDENT;
key(lex)
END;
PROCEDURE Letter(ch: CHAR): BOOLEAN;
RETURN (ch >= "A") & (ch <= "Z") OR (ch >= "a") & (ch <= "z") OR (ch = "_")
END Letter;
IF lex.sym = lxIDENT THEN
lex.ident := enterid(lex.s)
END
PROCEDURE Digit*(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END Digit;
END ident;
PROCEDURE HexDigit*(ch: CHAR): BOOLEAN;
RETURN (ch >= "A") & (ch <= "F") OR (ch >= "0") & (ch <= "9")
END HexDigit;
PROCEDURE PutChar(ch: CHAR);
BEGIN
Lex[count] := ch;
IF ch # 0X THEN
INC(count)
END
END PutChar;
PROCEDURE number (text: TEXTDRV.TEXT; VAR lex: LEX; VAR range: BOOLEAN);
VAR
c: CHAR;
hex: BOOLEAN;
error: INTEGER;
PROCEDURE PutNext(ch: CHAR);
BEGIN
PutChar(ch);
Next
END PutNext;
c := text.peak(text);
ASSERT(S.digit(c));
PROCEDURE Ident;
BEGIN
tLex := lxIDENT;
WHILE Letter(ch) OR Digit(ch) DO
PutNext(ch)
error := 0;
range := FALSE;
lex.sym := lxINTEGER;
hex := FALSE;
WHILE S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
END;
PutChar(0X);
IF count > IDLENGTH THEN
tLex := lxERR10
END
END Ident;
PROCEDURE hex*(ch: CHAR): INTEGER;
VAR Res: INTEGER;
BEGIN
Res := ORD(ch);
CASE ch OF
|"0".."9": DEC(Res, ORD("0"))
|"A".."F": DEC(Res, ORD("A") - 10)
WHILE S.hexdigit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text);
hex := TRUE
END;
IF c = "H" THEN
putchar(lex, c);
text.nextc(text);
lex.sym := lxHEX
ELSIF c = "X" THEN
putchar(lex, c);
text.nextc(text);
lex.sym := lxCHAR
ELSIF c = "." THEN
IF hex THEN
lex.sym := lxERROR01
ELSE
END
RETURN Res
END hex;
PROCEDURE StrToInt16(str: UTILS.STRING): INTEGER;
VAR i, res, n: INTEGER; flag: BOOLEAN;
BEGIN
res := 0;
i := 0;
n := 0;
WHILE str[i] = "0" DO
INC(i)
text.nextc(text);
c := text.peak(text);
IF c # "." THEN
putchar(lex, ".");
lex.sym := lxFLOAT
ELSE
lex.sym := lxINTEGER;
range := TRUE
END;
flag := TRUE;
WHILE flag & (str[i] # "X") & (str[i] # "H") DO
INC(n);
IF n > 8 THEN
tLex := lxERR5;
flag := FALSE
WHILE S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
END;
IF c = "E" THEN
putchar(lex, c);
text.nextc(text);
c := text.peak(text);
IF (c = "+") OR (c = "-") THEN
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
END;
IF S.digit(c) THEN
WHILE S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
END
ELSE
res := LSL(res, 4) + hex(str[i]);
INC(i)
lex.sym := lxERROR02
END
END
RETURN res
END StrToInt16;
PROCEDURE StrToChx(str: UTILS.STRING): CHAR;
VAR res: INTEGER;
BEGIN
res := StrToInt16(str);
IF (res < 0) OR (res > 0FFH) THEN
tLex := lxERR6;
res := 0
END
RETURN CHR(res)
END StrToChx;
PROCEDURE StrToInt*(str: UTILS.STRING): INTEGER;
VAR i, res: INTEGER; flag: BOOLEAN;
BEGIN
res := 0;
i := 0;
flag := TRUE;
WHILE flag & (str[i] # 0X) DO
IF res > maxINT DIV 10 THEN
tLex := lxERR5;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
tLex := lxERR5;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
IF hex THEN
lex.sym := lxERROR01
END
END
END
RETURN res
END StrToInt;
PROCEDURE StrToFloat(str: UTILS.STRING): LONGREAL;
VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, nez: BOOLEAN;
END;
PROCEDURE Error(e: INTEGER; VAR cont: BOOLEAN);
BEGIN
tLex := e;
res := 0.0D0;
cont := FALSE
END Error;
IF lex.over & (lex.sym >= 0) THEN
lex.sym := lxERROR07
END;
PROCEDURE Inf(VAR cont: BOOLEAN; VAR i: INTEGER);
BEGIN
IF UTILS.IsInf(res) THEN
Error(lxERR7, cont)
IF lex.sym = lxINTEGER THEN
ARITH.iconv(lex.s, lex.value, error)
ELSIF (lex.sym = lxHEX) OR (lex.sym = lxCHAR) THEN
ARITH.hconv(lex.s, lex.value, error)
ELSIF lex.sym = lxFLOAT THEN
ARITH.fconv(lex.s, lex.value, error)
END;
INC(i)
END Inf;
PROCEDURE part1(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
res := 0.0D0;
i := 0;
d := 1.0D0;
nez := FALSE;
cont := TRUE;
WHILE cont & Digit(str[i]) DO
nez := nez OR (str[i] # "0");
res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0")));
Inf(cont, i)
CASE error OF
|0:
|1: lex.sym := lxERROR08
|2: lex.sym := lxERROR09
|3: lex.sym := lxERROR10
|4: lex.sym := lxERROR11
|5: lex.sym := lxERROR12
END
RETURN cont
END part1;
PROCEDURE part2(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
INC(i);
cont := TRUE;
WHILE cont & Digit(str[i]) DO
nez := nez OR (str[i] # "0");
d := d / 10.0D0;
res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d;
Inf(cont, i)
END
RETURN cont
END part2;
END number;
PROCEDURE part3(): BOOLEAN;
VAR cont: BOOLEAN;
PROCEDURE string (text: TEXTDRV.TEXT; VAR lex: LEX);
VAR
c, c1: CHAR;
n: INTEGER;
quot: CHAR;
BEGIN
cont := TRUE;
IF str[i] = 0X THEN
IF res > LONG(maxREAL) THEN
Error(lxERR7, cont)
ELSIF nez & ((res = 0.0D0) OR (res < LONG(minREAL)) & (tLex = lxREAL)) THEN
Error(lxERR9, cont)
END
END
RETURN cont
END part3;
quot := text.peak(text);
PROCEDURE part4(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
IF str[i] = "D" THEN
tLex := lxLONGREAL
ASSERT((quot = '"') OR (quot = "'"));
text.nextc(text);
c := text.peak(text);
c1 := c;
n := 0;
WHILE (c # quot) & (c # 0X) & ~text.eol & ~text.eof DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text);
INC(n)
END;
INC(i);
m := 10.0D0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1D0
END;
scale := 0;
cont := TRUE;
WHILE cont & Digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
Error(lxERR8, cont)
IF c = quot THEN
text.nextc(text);
IF lex.over THEN
lex.sym := lxERROR05
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
Error(lxERR8, cont)
IF n # 1 THEN
lex.sym := lxSTRING
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
lex.sym := lxCHAR;
ARITH.setChar(lex.value, ORD(c1))
END
END
ELSE
lex.sym := lxERROR03
END;
IF lex.sym = lxSTRING THEN
lex.string := enterid(lex.s);
lex.value.typ := ARITH.tSTRING;
lex.value.string := lex.string
END
RETURN cont
END part4;
PROCEDURE part5(): BOOLEAN;
VAR cont: BOOLEAN; i: INTEGER;
END string;
PROCEDURE comment (text: TEXTDRV.TEXT);
VAR
c: CHAR;
cond, depth: INTEGER;
BEGIN
cont := TRUE;
IF scale = maxINT THEN
Error(lxERR8, cont)
cond := 0;
depth := 1;
REPEAT
c := text.peak(text);
text.nextc(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;
i := 1;
WHILE cont & (i <= scale) DO
res := res * m;
Inf(cont, i)
END;
IF cont & (nez & (res = 0.0D0) OR (res > 0.0D0) & (res < LONG(minREAL)) & (tLex = lxREAL)) THEN
Error(lxERR9, cont)
ELSIF cont & (tLex = lxREAL) & (res > LONG(maxREAL)) THEN
Error(lxERR7, cont)
cond := 0
ELSIF c = "(" THEN
cond := 1
ELSE
cond := 0
END
RETURN cont
END part5;
UNTIL (depth = 0) OR text.eof
END comment;
PROCEDURE delimiter (text: TEXTDRV.TEXT; VAR lex: LEX; VAR range: BOOLEAN);
VAR
c: CHAR;
BEGIN
IF part1() & part2() & part3() & part4() & part5() THEN END
RETURN res
END StrToFloat;
c := text.peak(text);
PROCEDURE Number;
VAR nextchr: CHAR;
BEGIN
tLex := lxINT;
WHILE Digit(ch) DO
PutNext(ch)
IF range THEN
ASSERT(c = ".")
END;
IF ch = "H" THEN
tLex := lxHEX
ELSIF ch = "X" THEN
tLex := lxCHX
END;
IF tLex # lxINT THEN
PutNext(ch)
ELSE
WHILE HexDigit(ch) DO
tLex := lxHEX;
PutNext(ch)
END;
IF tLex = lxHEX THEN
IF ch = "H" THEN
PutNext(ch)
ELSIF ch = "X" THEN
tLex := lxCHX;
PutNext(ch)
ELSE
tLex := lxERR1
putchar(lex, c);
text.nextc(text);
CASE c OF
|"+":
lex.sym := lxPLUS
|"-":
lex.sym := lxMINUS
|"*":
lex.sym := lxMUL
|"/":
lex.sym := lxSLASH;
IF text.peak(text) = "/" THEN
lex.sym := lxCOMMENT;
REPEAT
text.nextc(text)
UNTIL text.eol OR text.eof
END
ELSIF ch = "." THEN
sys.GET(bufpos, nextchr);
IF nextchr # "." THEN
tLex := lxREAL;
PutNext(ch);
WHILE Digit(ch) DO
PutNext(ch)
END;
IF (ch = "E") OR (ch = "D") THEN
PutNext(ch);
IF (ch = "+") OR (ch = "-") THEN
PutNext(ch)
END;
IF ~Digit(ch) THEN
tLex := lxERR2
|"~":
lex.sym := lxNOT
|"&":
lex.sym := lxAND
|".":
IF range THEN
putchar(lex, ".");
lex.sym := lxRANGE;
range := FALSE;
DEC(lex.pos.col)
ELSE
WHILE Digit(ch) DO
PutNext(ch)
lex.sym := lxPOINT;
c := text.peak(text);
IF c = "." THEN
lex.sym := lxRANGE;
putchar(lex, c);
text.nextc(text)
END
END
|",":
lex.sym := lxCOMMA
|";":
lex.sym := lxSEMI
|"|":
lex.sym := lxBAR
|"(":
lex.sym := lxLROUND;
c := text.peak(text);
IF c = "*" THEN
lex.sym := lxCOMMENT;
putchar(lex, c);
text.nextc(text);
comment(text)
END
|"[":
lex.sym := lxLSQUARE
|"{":
lex.sym := lxLCURLY
|"^":
lex.sym := lxCARET
|"=":
lex.sym := lxEQ
|"#":
lex.sym := lxNE
|"<":
lex.sym := lxLT;
c := text.peak(text);
IF c = "=" THEN
lex.sym := lxLE;
putchar(lex, c);
text.nextc(text)
END
|">":
lex.sym := lxGT;
c := text.peak(text);
IF c = "=" THEN
lex.sym := lxGE;
putchar(lex, c);
text.nextc(text)
END
END;
PutChar(0X)
END Number;
PROCEDURE Delim(ch: CHAR): INTEGER;
VAR Res: INTEGER;
BEGIN
CASE ch OF
|"+": Res := lxPlus
|"-": Res := lxMinus
|"*": Res := lxMult
|"/": Res := lxSlash
|"~": Res := lxNot
|"&": Res := lxAnd
|",": Res := lxComma
|";": Res := lxSemi
|"|": Res := lxStick
|"[": Res := lxLSquare
|"{": Res := lxLCurly
|"^": Res := lxCaret
|"=": Res := lxEQ
|"#": Res := lxNE
|")": Res := lxRRound
|"]": Res := lxRSquare
|"}": Res := lxRCurly
|">": Res := lxGT
|"<": Res := lxLT
|":": Res := lxColon
ELSE
|":":
lex.sym := lxCOLON;
c := text.peak(text);
IF c = "=" THEN
lex.sym := lxASSIGN;
putchar(lex, c);
text.nextc(text)
END
RETURN Res
END Delim;
PROCEDURE Comment;
VAR c, level: INTEGER; cont: BOOLEAN;
|")":
lex.sym := lxRROUND
|"]":
lex.sym := lxRSQUARE
|"}":
lex.sym := lxRCURLY
END
END delimiter;
PROCEDURE Next* (scanner: SCANNER; VAR lex: LEX);
VAR
c: CHAR;
text: TEXTDRV.TEXT;
BEGIN
c := 1;
level := 1;
cont := TRUE;
WHILE cont & (level > 0) DO
Next;
CASE ch OF
|"(": c := 2
|")": IF c = 3 THEN DEC(level) END; c := 1
|"*": IF c = 2 THEN INC(level); c := 1 ELSE c := 3 END
|0X : cont := FALSE
text := scanner.text;
REPEAT
c := text.peak(text);
WHILE S.space(c) DO
text.nextc(text);
c := text.peak(text)
END;
lex.s[0] := 0X;
lex.length := 0;
lex.sym := lxUNDEF;
lex.pos.line := text.line;
lex.pos.col := text.col;
lex.ident := NIL;
lex.over := FALSE;
IF S.letter(c) THEN
ident(text, lex)
ELSIF S.digit(c) THEN
number(text, lex, scanner.range)
ELSIF (c = '"') OR (c = "'") THEN
string(text, lex)
ELSIF vocabulary.delimiters[ORD(c)] THEN
delimiter(text, lex, scanner.range)
ELSIF c = 0X THEN
lex.sym := lxEOF;
IF text.eof THEN
INC(lex.pos.col)
END
ELSE
c := 1
putchar(lex, c);
text.nextc(text);
lex.sym := lxERROR04
END;
END;
IF cont THEN
Next
IF lex.sym < 0 THEN
lex.error := -lex.sym
ELSE
lex.error := 0
END
END Comment;
PROCEDURE GetLex*;
UNTIL lex.sym # lxCOMMENT
END Next;
PROCEDURE NewScanner (): SCANNER;
VAR
scan: SCANNER;
citem: C.ITEM;
BEGIN
WHILE Space(ch) DO
Next
END;
coord.col := ccol;
coord.line := cline;
count := 0;
CASE ch OF
|"A".."Z", "a".."z", "_":
Ident;
id := AddNode(Lex);
tLex := id.tLex;
|"0".."9":
Number;
CASE tLex OF
|lxINT: vINT := StrToInt(Lex)
|lxHEX: vINT := StrToInt16(Lex)
|lxCHX: vCHX := StrToChx(Lex)
|lxREAL: vFLT := StrToFloat(Lex)
citem := C.pop(scanners);
IF citem = NIL THEN
NEW(scan)
ELSE
scan := citem(SCANNER)
END
|22X:
tLex := lxSTRING;
Next;
WHILE (ch # 22X) & (ch >= 20X) DO
PutNext(ch)
END;
IF ch = 22X THEN
Next
RETURN scan
END NewScanner;
PROCEDURE open* (name: ARRAY OF CHAR): SCANNER;
VAR
scanner: SCANNER;
text: TEXTDRV.TEXT;
BEGIN
text := TEXTDRV.create();
IF text.open(text, name) THEN
scanner := NewScanner();
scanner.text := text;
scanner.range := FALSE
ELSE
tLex := lxERR3
END;
PutChar(0X);
INC(count);
IF count > STRLENGTH THEN
tLex := lxERR11
scanner := NIL;
TEXTDRV.destroy(text)
END
|"/":
tLex := Delim(ch);
PutNext(ch);
IF ch = "/" THEN
WHILE (ch >= 20X) OR (ch = 9X) DO
PutNext(ch)
RETURN scanner
END open;
PROCEDURE close* (VAR scanner: SCANNER);
BEGIN
IF scanner # NIL THEN
IF scanner.text # NIL THEN
TEXTDRV.destroy(scanner.text)
END;
GetLex
END;
PutChar(0X)
|">", "<", ":":
tLex := Delim(ch);
PutNext(ch);
IF ch = "=" THEN
CASE tLex OF
|lxLT: tLex := lxLE
|lxGT: tLex := lxGE
|lxColon: tLex := lxAssign
ELSE
END;
PutNext(ch)
END;
PutChar(0X)
|".":
tLex := lxDot;
PutNext(ch);
IF ch = "." THEN
tLex := lxDbl;
PutNext(ch)
END;
PutChar(0X)
|"(":
tLex := lxLRound;
PutNext(ch);
IF ch = "*" THEN
Comment;
GetLex
END;
PutChar(0X)
|"+", "-", "*", "~", "&", ",", ";", "|",
"[", "{", "^", "=", "#", ")", "]", "}":
tLex := Delim(ch);
PutChar(ch);
PutNext(0X)
|0X:
tLex := lxEOF;
PutChar(0X)
ELSE
tLex := lxERR4
C.push(scanners, scanner);
scanner := NIL
END
END GetLex;
END close;
PROCEDURE AddNodeKey(Name: UTILS.STRING; key: INTEGER);
VAR node: NODE;
PROCEDURE init;
VAR
i: INTEGER;
delim: ARRAY 23 OF CHAR;
PROCEDURE enterkw (VAR i: INTEGER; kw: KEYWORD);
BEGIN
node := AddNode(Name);
node.tLex := key
END AddNodeKey;
vocabulary.KW[i] := kw;
INC(i)
END enterkw;
PROCEDURE Init;
VAR i: INTEGER; node: NODE;
BEGIN
FOR i := 0 TO LEN(Nodes) - 1 DO
NEW(node);
UTILS.MemErr(node = NIL);
sys.PUT(sys.ADR(node.Name), i);
node.Left := NIL;
node.Right := NIL;
node.tLex := lxIDENT;
Nodes[i] := node
scanners := C.create();
FOR i := 0 TO 255 DO
vocabulary.delimiters[i] := FALSE
END;
_START := AddNode("lib_init");
_version := AddNode("version");
AddNodeKey("MOD", lxMOD);
AddNodeKey("ELSE", lxELSE);
AddNodeKey("RETURN", lxRETURN);
AddNodeKey("CASE", lxCASE);
AddNodeKey("IF", lxIF);
AddNodeKey("POINTER", lxPOINTER);
AddNodeKey("TYPE", lxTYPE);
AddNodeKey("BEGIN", lxBEGIN);
AddNodeKey("DIV", lxDIV);
AddNodeKey("FALSE", lxFALSE);
AddNodeKey("IN", lxIN);
AddNodeKey("NIL", lxNIL);
AddNodeKey("RECORD", lxRECORD);
AddNodeKey("TO", lxTO);
AddNodeKey("VAR", lxVAR);
AddNodeKey("ARRAY", lxARRAY);
AddNodeKey("DO", lxDO);
AddNodeKey("END", lxEND);
AddNodeKey("IS", lxIS);
AddNodeKey("OF", lxOF);
AddNodeKey("PROCEDURE", lxPROCEDURE);
AddNodeKey("THEN", lxTHEN);
AddNodeKey("WHILE", lxWHILE);
AddNodeKey("BY", lxBY);
AddNodeKey("CONST", lxCONST);
AddNodeKey("ELSIF", lxELSIF);
AddNodeKey("IMPORT", lxIMPORT);
AddNodeKey("MODULE", lxMODULE);
AddNodeKey("OR", lxOR);
AddNodeKey("REPEAT", lxREPEAT);
AddNodeKey("TRUE", lxTRUE);
AddNodeKey("UNTIL", lxUNTIL);
AddNodeKey("FOR", lxFOR)
END Init;
delim := "+-*/~&.,;|([{^=#<>:)]}";
FOR i := 0 TO LEN(delim) - 2 DO
vocabulary.delimiters[ORD(delim[i])] := TRUE
END;
i := 0;
enterkw(i, "ARRAY");
enterkw(i, "BEGIN");
enterkw(i, "BY");
enterkw(i, "CASE");
enterkw(i, "CONST");
enterkw(i, "DIV");
enterkw(i, "DO");
enterkw(i, "ELSE");
enterkw(i, "ELSIF");
enterkw(i, "END");
enterkw(i, "FALSE");
enterkw(i, "FOR");
enterkw(i, "IF");
enterkw(i, "IMPORT");
enterkw(i, "IN");
enterkw(i, "IS");
enterkw(i, "MOD");
enterkw(i, "MODULE");
enterkw(i, "NIL");
enterkw(i, "OF");
enterkw(i, "OR");
enterkw(i, "POINTER");
enterkw(i, "PROCEDURE");
enterkw(i, "RECORD");
enterkw(i, "REPEAT");
enterkw(i, "RETURN");
enterkw(i, "THEN");
enterkw(i, "TO");
enterkw(i, "TRUE");
enterkw(i, "TYPE");
enterkw(i, "UNTIL");
enterkw(i, "VAR");
enterkw(i, "WHILE");
NEW(vocabulary.ident);
vocabulary.ident.s := "";
vocabulary.ident.offset := -1;
vocabulary.ident.offsetW := -1;
vocabulary.idents := NIL
END init;
BEGIN
Init
init
END SCAN.

/programs/develop/oberon07/Source/STATEMENTS.ob07
0,0 → 1,3297
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE STATEMENTS;
IMPORT
PARS, PROG, SCAN, ARITH, STRINGS, LISTS, CODE, X86, AMD64,
ERRORS, MACHINE, AVL := AVLTREES, CONSOLE, C := COLLECTIONS, mConst := CONSTANTS;
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;
chkALL* = {chkIDX, chkGUARD, chkPTR, chkCHR, chkWCHR, chkBYTE};
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: CODE.COMMAND;
processed: BOOLEAN
END;
VAR
begcall, endcall: CODE.COMMAND;
checking: SET;
CaseLabels, CaseVar: C.COLLECTION;
CaseVariants: LISTS.LIST;
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.typ = PROG.tBOOLEAN)
END isBoolean;
PROCEDURE isInteger (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.tINTEGER)
END isInteger;
PROCEDURE isByte (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.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.typ = PROG.tREAL)
END isReal;
PROCEDURE isSet (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.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.typ = PROG.tCHAR)
END isChar;
PROCEDURE isCharArray (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.tARRAY) & (e.type.base.typ = PROG.tCHAR)
END isCharArray;
PROCEDURE isCharW (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.tWCHAR)
END isCharW;
PROCEDURE isCharArrayW (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.tARRAY) & (e.type.base.typ = PROG.tWCHAR)
END isCharArrayW;
PROCEDURE isCharArrayX (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.tARRAY) & (e.type.base.typ IN {PROG.tCHAR, PROG.tWCHAR})
END isCharArrayX;
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 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 getpos (parser: PARS.PARSER; VAR pos: SCAN.POSITION);
BEGIN
pos := parser.lex.pos
END getpos;
PROCEDURE NextPos (parser: PARS.PARSER; VAR pos: SCAN.POSITION);
BEGIN
PARS.NextPos(parser, pos)
END NextPos;
PROCEDURE strlen (e: PARS.EXPR): INTEGER;
VAR
res: INTEGER;
BEGIN
ASSERT(isString(e));
IF e.type.typ = PROG.tCHAR THEN
res := 1
ELSE
res := LENGTH(e.value.string(SCAN.IDENT).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.IDENT).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 (e.obj = eCONST) & isString(e) & (utf8strlen(e) = 1) & (strlen(e) > 1)
END isStringW1;
PROCEDURE assigncomp (e: PARS.EXPR; t: PROG.TYPE_): BOOLEAN;
VAR
res: BOOLEAN;
PROCEDURE arrcomp (src, dst: PROG.TYPE_): BOOLEAN;
RETURN (dst.typ = PROG.tARRAY) & PROG.isOpenArray(src) &
~PROG.isOpenArray(src.base) & ~PROG.isOpenArray(dst.base) &
PROG.isTypeEq(src.base, dst.base)
END arrcomp;
BEGIN
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN
IF arrcomp(e.type, t) THEN
res := TRUE
ELSIF isInt(e) & (t.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN
IF (e.obj = eCONST) & (t.typ = PROG.tBYTE) THEN
res := ARITH.range(e.value, 0, 255)
ELSE
res := TRUE
END
ELSIF isSet(e) & (t.typ = PROG.tSET) THEN
res := TRUE
ELSIF isBoolean(e) & (t.typ = PROG.tBOOLEAN) THEN
res := TRUE
ELSIF isReal(e) & (t.typ = PROG.tREAL) THEN
res := TRUE
ELSIF isChar(e) & (t.typ = PROG.tCHAR) THEN
res := TRUE
ELSIF (e.obj = eCONST) & isChar(e) & (t.typ = PROG.tWCHAR) THEN
res := TRUE
ELSIF isStringW1(e) & (t.typ = PROG.tWCHAR) THEN
res := TRUE
ELSIF isCharW(e) & (t.typ = PROG.tWCHAR) THEN
res := TRUE
ELSIF PROG.isBaseOf(t, e.type) THEN
res := TRUE
ELSIF ~PROG.isOpenArray(t) & ~PROG.isOpenArray(e.type) & PROG.isTypeEq(t, e.type) THEN
res := TRUE
ELSIF isNil(e) & (t.typ IN {PROG.tPOINTER, PROG.tPROCEDURE}) THEN
res := TRUE
ELSIF isString(e) & ((t.typ = PROG.tARRAY) & (t.base.typ = PROG.tCHAR) & (t.length > strlen(e))) THEN
res := TRUE
ELSIF isStringW(e) & ((t.typ = PROG.tARRAY) & (t.base.typ = PROG.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.IDENT;
BEGIN
IF strlen(e) # 1 THEN
string := e.value.string(SCAN.IDENT);
IF string.offset = -1 THEN
string.offset := CODE.putstr(string.s);
END;
offset := string.offset
ELSE
offset := CODE.putstr1(ARITH.Int(e.value))
END
RETURN offset
END String;
PROCEDURE StringW (e: PARS.EXPR): INTEGER;
VAR
offset: INTEGER;
string: SCAN.IDENT;
BEGIN
IF utf8strlen(e) # 1 THEN
string := e.value.string(SCAN.IDENT);
IF string.offsetW = -1 THEN
string.offsetW := CODE.putstrW(string.s);
END;
offset := string.offsetW
ELSE
IF e.type.typ IN {PROG.tWCHAR, PROG.tCHAR} THEN
offset := CODE.putstrW1(ARITH.Int(e.value))
ELSE (* e.type.typ = PROG.tSTRING *)
string := e.value.string(SCAN.IDENT);
IF string.offsetW = -1 THEN
string.offsetW := CODE.putstrW(string.s);
END;
offset := string.offsetW
END
END
RETURN offset
END StringW;
PROCEDURE CheckRange (range, line, errno: INTEGER);
VAR
label: INTEGER;
BEGIN
label := CODE.NewLabel();
CODE.AddCmd2(CODE.opCHKIDX, label, range);
CODE.OnError(line, errno);
CODE.SetLabel(label)
END CheckRange;
PROCEDURE assign (e: PARS.EXPR; VarType: PROG.TYPE_; line: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
label: INTEGER;
PROCEDURE arrcomp (src, dst: PROG.TYPE_): BOOLEAN;
RETURN (dst.typ = PROG.tARRAY) & PROG.isOpenArray(src) &
~PROG.isOpenArray(src.base) & ~PROG.isOpenArray(dst.base) &
PROG.isTypeEq(src.base, dst.base)
END arrcomp;
BEGIN
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN
res := TRUE;
IF arrcomp(e.type, VarType) THEN
IF ~PROG.isOpenArray(VarType) THEN
CODE.AddCmd(CODE.opCONST, VarType.length)
END;
CODE.AddCmd(CODE.opCOPYA, VarType.base.size);
label := CODE.NewLabel();
CODE.AddJmpCmd(CODE.opJE, label);
CODE.OnError(line, errCOPY);
CODE.SetLabel(label)
ELSIF isInt(e) & (VarType.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN
IF VarType.typ = PROG.tINTEGER THEN
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opSAVEC, ARITH.Int(e.value))
ELSE
CODE.AddCmd0(CODE.opSAVE)
END
ELSE
IF e.obj = eCONST THEN
res := ARITH.range(e.value, 0, 255);
IF res THEN
CODE.AddCmd(CODE.opSAVE8C, ARITH.Int(e.value))
END
ELSE
IF chkBYTE IN checking THEN
label := CODE.NewLabel();
CODE.AddCmd2(CODE.opCHKBYTE, label, 0);
CODE.OnError(line, errBYTE);
CODE.SetLabel(label)
END;
CODE.AddCmd0(CODE.opSAVE8)
END
END
ELSIF isSet(e) & (VarType.typ = PROG.tSET) THEN
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opSAVEC, ARITH.Int(e.value))
ELSE
CODE.AddCmd0(CODE.opSAVE)
END
ELSIF isBoolean(e) & (VarType.typ = PROG.tBOOLEAN) THEN
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opSBOOLC, ARITH.Int(e.value))
ELSE
CODE.AddCmd0(CODE.opSBOOL)
END
ELSIF isReal(e) & (VarType.typ = PROG.tREAL) THEN
IF e.obj = eCONST THEN
CODE.Float(ARITH.Float(e.value))
END;
CODE.savef
ELSIF isChar(e) & (VarType.typ = PROG.tCHAR) THEN
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opSAVE8C, ARITH.Int(e.value))
ELSE
CODE.AddCmd0(CODE.opSAVE8)
END
ELSIF (e.obj = eCONST) & isChar(e) & (VarType.typ = PROG.tWCHAR) THEN
CODE.AddCmd(CODE.opSAVE16C, ARITH.Int(e.value))
ELSIF isStringW1(e) & (VarType.typ = PROG.tWCHAR) THEN
CODE.AddCmd(CODE.opSAVE16C, StrToWChar(e.value.string(SCAN.IDENT).s))
ELSIF isCharW(e) & (VarType.typ = PROG.tWCHAR) THEN
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opSAVE16C, ARITH.Int(e.value))
ELSE
CODE.AddCmd0(CODE.opSAVE16)
END
ELSIF PROG.isBaseOf(VarType, e.type) THEN
IF VarType.typ = PROG.tPOINTER THEN
CODE.AddCmd0(CODE.opSAVE)
ELSE
CODE.AddCmd(CODE.opCOPY, VarType.size)
END
ELSIF (e.type.typ = PROG.tCARD32) & (VarType.typ = PROG.tCARD32) THEN
CODE.AddCmd0(CODE.opSAVE32)
ELSIF (e.type.typ = PROG.tCARD16) & (VarType.typ = PROG.tCARD16) THEN
CODE.AddCmd0(CODE.opSAVE16)
ELSIF ~PROG.isOpenArray(VarType) & ~PROG.isOpenArray(e.type) & PROG.isTypeEq(VarType, e.type) THEN
IF e.obj = ePROC THEN
CODE.AssignProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
CODE.AssignImpProc(e.ident.import)
ELSE
IF VarType.typ = PROG.tPROCEDURE THEN
CODE.AddCmd0(CODE.opSAVE)
ELSE
CODE.AddCmd(CODE.opCOPY, VarType.size)
END
END
ELSIF isNil(e) & (VarType.typ IN {PROG.tPOINTER, PROG.tPROCEDURE}) THEN
CODE.AddCmd(CODE.opSAVEC, 0)
ELSIF isString(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base.typ = PROG.tCHAR) & (VarType.length > strlen(e))) THEN
CODE.saves(String(e), strlen(e) + 1)
ELSIF isStringW(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base.typ = PROG.tWCHAR) & (VarType.length > utf8strlen(e))) THEN
CODE.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
CODE.AddCmd(CODE.opCONST, ARITH.Int(e.value))
END LoadConst;
PROCEDURE paramcomp (parser: PARS.PARSER; pos: SCAN.POSITION; e: PARS.EXPR; p: PROG.PARAM);
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: INTEGER;
d1, d2: INTEGER;
BEGIN
IF t.length # 0 THEN
CODE.AddCmd(CODE.opPARAM, 1);
n := PROG.Dim(t2) - 1;
WHILE n >= 0 DO
CODE.AddCmd(CODE.opCONST, ArrLen(t, n));
CODE.AddCmd(CODE.opPARAM, 1);
DEC(n)
END
ELSE
d1 := PROG.Dim(t);
d2 := PROG.Dim(t2);
IF d1 # d2 THEN
n := d2 - d1;
WHILE d2 > d1 DO
CODE.AddCmd(CODE.opCONST, ArrLen(t, d2 - 1));
DEC(d2)
END;
d2 := PROG.Dim(t2);
WHILE n > 0 DO
CODE.AddCmd(CODE.opROT, d2);
DEC(n)
END
END;
CODE.AddCmd(CODE.opPARAM, PROG.Dim(t2) + 1)
END
END OpenArray;
BEGIN
IF p.vPar THEN
PARS.check(isVar(e), parser, pos, 93);
IF p.type.typ = PROG.tRECORD THEN
PARS.check(PROG.isBaseOf(p.type, e.type), parser, pos, 66);
IF e.obj = eVREC THEN
IF e.ident # NIL THEN
CODE.AddCmd(CODE.opVADR, e.ident.offset - 1)
ELSE
CODE.AddCmd0(CODE.opPUSHT)
END
ELSE
CODE.AddCmd(CODE.opCONST, e.type.num)
END;
CODE.AddCmd(CODE.opPARAM, 2)
ELSIF PROG.isOpenArray(p.type) THEN
PARS.check(arrcomp(e, p), parser, pos, 66);
OpenArray(e.type, p.type)
ELSE
PARS.check(PROG.isTypeEq(e.type, p.type), parser, pos, 66);
CODE.AddCmd(CODE.opPARAM, 1)
END;
PARS.check(~e.readOnly, parser, pos, 94)
ELSE
PARS.check(isExpr(e) OR isProc(e), parser, pos, 66);
IF PROG.isOpenArray(p.type) THEN
IF e.type.typ = PROG.tARRAY THEN
PARS.check(arrcomp(e, p), parser, pos, 66);
OpenArray(e.type, p.type)
ELSIF isString(e) & (p.type.typ = PROG.tARRAY) & (p.type.base.typ = PROG.tCHAR) THEN
CODE.AddCmd(CODE.opSADR, String(e));
CODE.AddCmd(CODE.opPARAM, 1);
CODE.AddCmd(CODE.opCONST, strlen(e) + 1);
CODE.AddCmd(CODE.opPARAM, 1)
ELSIF isStringW(e) & (p.type.typ = PROG.tARRAY) & (p.type.base.typ = PROG.tWCHAR) THEN
CODE.AddCmd(CODE.opSADR, StringW(e));
CODE.AddCmd(CODE.opPARAM, 1);
CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1);
CODE.AddCmd(CODE.opPARAM, 1)
ELSE
PARS.error(parser, pos, 66)
END
ELSE
PARS.check(~PROG.isOpenArray(e.type), parser, pos, 66);
PARS.check(assigncomp(e, p.type), parser, pos, 66);
IF e.obj = eCONST THEN
IF e.type.typ = PROG.tREAL THEN
CODE.Float(ARITH.Float(e.value));
CODE.pushf
ELSIF e.type.typ = PROG.tNIL THEN
CODE.AddCmd(CODE.opCONST, 0);
CODE.AddCmd(CODE.opPARAM, 1)
ELSIF isStringW1(e) & (p.type.typ = PROG.tWCHAR) THEN
CODE.AddCmd(CODE.opCONST, StrToWChar(e.value.string(SCAN.IDENT).s));
CODE.AddCmd(CODE.opPARAM, 1)
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
CODE.SetMinDataSize(p.type.size);
IF p.type.base.typ = PROG.tCHAR THEN
CODE.AddCmd(CODE.opSADR, String(e))
ELSE (* WCHAR *)
CODE.AddCmd(CODE.opSADR, StringW(e))
END;
CODE.AddCmd(CODE.opPARAM, 1)
ELSE
LoadConst(e);
CODE.AddCmd(CODE.opPARAM, 1)
END
ELSIF e.obj = ePROC THEN
PARS.check(e.ident.global, parser, pos, 85);
CODE.PushProc(e.ident.proc.label);
CODE.AddCmd(CODE.opPARAM, 1)
ELSIF e.obj = eIMP THEN
CODE.PushImpProc(e.ident.import);
CODE.AddCmd(CODE.opPARAM, 1)
ELSIF isExpr(e) & (e.type.typ = PROG.tREAL) THEN
CODE.pushf
ELSE
IF (p.type.typ = PROG.tBYTE) & (e.type.typ = PROG.tINTEGER) & (chkBYTE IN checking) THEN
CheckRange(256, pos.line, errBYTE)
END;
CODE.AddCmd(CODE.opPARAM, 1)
END
END
END
END paramcomp;
PROCEDURE stProc (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
e2: PARS.EXPR;
pos: SCAN.POSITION;
proc: INTEGER;
label: INTEGER;
n, i: INTEGER;
code: ARITH.VALUE;
e1: PARS.EXPR;
wchar: BOOLEAN;
cmd1,
cmd2: CODE.COMMAND;
PROCEDURE varparam (parser: PARS.PARSER; pos: SCAN.POSITION; isfunc: isXXX; readOnly: BOOLEAN; VAR e: PARS.EXPR);
BEGIN
parser.designator(parser, e);
PARS.check(isVar(e), parser, pos, 93);
PARS.check(isfunc(e), parser, pos, 66);
IF readOnly THEN
PARS.check(~e.readOnly, parser, 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});
getpos(parser, pos);
proc := e.stproc;
IF e.obj IN {eSYSPROC, eSYSFUNC} THEN
IF parser.unit.scopeLvl > 0 THEN
parser.unit.scopes[parser.unit.scopeLvl].enter(CODE.COMMAND).allocReg := FALSE
END
END;
IF e.obj IN {eSTPROC, eSYSPROC} THEN
CASE proc OF
|PROG.stASSERT:
parser.expression(parser, e);
PARS.check(isBoolean(e), parser, pos, 66);
IF e.obj = eCONST THEN
IF ~ARITH.getBool(e.value) THEN
CODE.OnError(pos.line, errASSERT)
END
ELSE
label := CODE.NewLabel();
CODE.AddJmpCmd(CODE.opJE, label);
CODE.OnError(pos.line, errASSERT);
CODE.SetLabel(label)
END
|PROG.stINC, PROG.stDEC:
CODE.pushBegEnd(begcall, endcall);
varparam(parser, pos, isInt, TRUE, e);
IF e.type.typ = PROG.tINTEGER THEN
IF parser.sym = SCAN.lxCOMMA THEN
NextPos(parser, pos);
CODE.setlast(begcall);
parser.expression(parser, e2);
CODE.setlast(endcall.prev(CODE.COMMAND));
PARS.check(isInt(e2), parser, pos, 66);
IF e2.obj = eCONST THEN
CODE.AddCmd(CODE.opINCC + ORD(proc = PROG.stDEC), ARITH.Int(e2.value))
ELSE
CODE.AddCmd0(CODE.opINC + ORD(proc = PROG.stDEC))
END
ELSE
CODE.AddCmd0(CODE.opINC1 + ORD(proc = PROG.stDEC))
END
ELSE (* e.type.typ = PROG.tBYTE *)
IF parser.sym = SCAN.lxCOMMA THEN
NextPos(parser, pos);
CODE.setlast(begcall);
parser.expression(parser, e2);
CODE.setlast(endcall.prev(CODE.COMMAND));
PARS.check(isInt(e2), parser, pos, 66);
IF e2.obj = eCONST THEN
CODE.AddCmd(CODE.opINCCB + ORD(proc = PROG.stDEC), ARITH.Int(e2.value))
ELSE
CODE.AddCmd0(CODE.opINCB + ORD(proc = PROG.stDEC))
END
ELSE
CODE.AddCmd0(CODE.opINC1B + ORD(proc = PROG.stDEC))
END
END;
CODE.popBegEnd(begcall, endcall)
|PROG.stINCL, PROG.stEXCL:
CODE.pushBegEnd(begcall, endcall);
varparam(parser, pos, isSet, TRUE, e);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
CODE.setlast(begcall);
parser.expression(parser, e2);
CODE.setlast(endcall.prev(CODE.COMMAND));
PARS.check(isInt(e2), parser, pos, 66);
IF e2.obj = eCONST THEN
PARS.check(ARITH.range(e2.value, 0, MACHINE.target.maxSet), parser, pos, 56);
CODE.AddCmd(CODE.opINCLC + ORD(proc = PROG.stEXCL), ARITH.Int(e2.value))
ELSE
CODE.AddCmd0(CODE.opINCL + ORD(proc = PROG.stEXCL))
END;
CODE.popBegEnd(begcall, endcall)
|PROG.stNEW:
varparam(parser, pos, isPtr, TRUE, e);
CODE.New(e.type.base.size, e.type.base.num)
|PROG.stDISPOSE:
varparam(parser, pos, isPtr, TRUE, e);
CODE.AddCmd0(CODE.opDISP)
|PROG.stPACK:
varparam(parser, pos, isReal, TRUE, e);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
parser.expression(parser, e2);
PARS.check(isInt(e2), parser, pos, 66);
IF e2.obj = eCONST THEN
CODE.AddCmd(CODE.opPACKC, ARITH.Int(e2.value))
ELSE
CODE.AddCmd0(CODE.opPACK)
END
|PROG.stUNPK:
varparam(parser, pos, isReal, TRUE, e);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
varparam(parser, pos, isInteger, TRUE, e2);
CODE.AddCmd0(CODE.opUNPK)
|PROG.stCOPY:
parser.expression(parser, e);
IF isString(e) OR isCharArray(e) THEN
wchar := FALSE
ELSIF isStringW(e) OR isCharArrayW(e) THEN
wchar := TRUE
ELSE
PARS.check(FALSE, parser, pos, 66)
END;
IF isCharArrayX(e) & ~PROG.isOpenArray(e.type) THEN
CODE.AddCmd(CODE.opCONST, e.type.length)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
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.typ = PROG.tWCHAR
END;
IF ~PROG.isOpenArray(e1.type) THEN
CODE.AddCmd(CODE.opCONST, e1.type.length)
END;
IF e.obj = eCONST THEN
IF wchar THEN
CODE.AddCmd(CODE.opSADR, StringW(e));
CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1)
ELSE
CODE.AddCmd(CODE.opSADR, String(e));
CODE.AddCmd(CODE.opCONST, strlen(e) + 1)
END;
CODE.AddCmd(CODE.opCOPYS2, e1.type.base.size)
ELSE
CODE.AddCmd(CODE.opCOPYS, e1.type.base.size)
END
|PROG.sysGET:
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
parser.designator(parser, e2);
PARS.check(isVar(e2), parser, pos, 93);
PARS.check((e2.type.typ IN PROG.BASICTYPES) OR (e2.type.typ = PROG.tPOINTER) OR (e2.type.typ = PROG.tPROCEDURE), parser, pos, 66);
CODE.SysGet(e2.type.size)
|PROG.sysPUT, PROG.sysPUT8, PROG.sysPUT16, PROG.sysPUT32:
CODE.pushBegEnd(begcall, endcall);
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
CODE.setlast(begcall);
parser.expression(parser, e2);
PARS.check(isExpr(e2), parser, pos, 66);
IF proc = PROG.sysPUT THEN
PARS.check((e2.type.typ IN PROG.BASICTYPES) OR (e2.type.typ = PROG.tPOINTER) OR (e2.type.typ = PROG.tPROCEDURE), parser, pos, 66);
IF e2.obj = eCONST THEN
IF e2.type.typ = PROG.tREAL THEN
CODE.setlast(endcall.prev(CODE.COMMAND));
CODE.Float(ARITH.Float(e2.value));
CODE.savef
ELSE
LoadConst(e2);
CODE.setlast(endcall.prev(CODE.COMMAND));
CODE.SysPut(e2.type.size)
END
ELSE
CODE.setlast(endcall.prev(CODE.COMMAND));
IF e2.type.typ = PROG.tREAL THEN
CODE.savef
ELSIF e2.type.typ = PROG.tBYTE THEN
CODE.SysPut(PARS.program.stTypes.tINTEGER.size)
ELSE
CODE.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.tWCHAR, PROG.tCARD16, PROG.tCARD32}, parser, pos, 66);
IF e2.obj = eCONST THEN
LoadConst(e2)
END;
CODE.setlast(endcall.prev(CODE.COMMAND));
IF proc = PROG.sysPUT8 THEN
CODE.SysPut(1)
ELSIF proc = PROG.sysPUT16 THEN
CODE.SysPut(2)
ELSIF proc = PROG.sysPUT32 THEN
CODE.SysPut(4)
END
END;
CODE.popBegEnd(begcall, endcall)
|PROG.sysMOVE:
FOR i := 1 TO 2 DO
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos)
END;
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
CODE.AddCmd0(CODE.opMOVE)
|PROG.sysCOPY:
FOR i := 1 TO 2 DO
parser.designator(parser, e);
PARS.check(isVar(e), parser, pos, 93);
n := PROG.Dim(e.type);
WHILE n > 0 DO
CODE.drop;
DEC(n)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos)
END;
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
CODE.AddCmd0(CODE.opMOVE)
|PROG.sysCODE:
REPEAT
getpos(parser, pos);
PARS.ConstExpression(parser, code);
PARS.check(code.typ = ARITH.tINTEGER, parser, pos, 43);
PARS.check(ARITH.range(code, 0, 255), parser, pos, 42);
IF parser.sym = SCAN.lxCOMMA THEN
PARS.Next(parser)
ELSE
PARS.checklex(parser, SCAN.lxRROUND)
END;
CODE.AddCmd(CODE.opCODE, ARITH.getInt(code))
UNTIL parser.sym = SCAN.lxRROUND
END;
e.obj := eEXPR;
e.type := NIL
ELSIF e.obj IN {eSTFUNC, eSYSFUNC} THEN
CASE e.stproc OF
|PROG.stABS:
parser.expression(parser, e);
PARS.check(isInt(e) OR isReal(e), parser, pos, 66);
IF e.obj = eCONST THEN
PARS.check(ARITH.abs(e.value), parser, pos, 39)
ELSE
CODE.abs(isReal(e))
END
|PROG.stASR, PROG.stLSL, PROG.stROR, PROG.stLSR, PROG.stMIN, PROG.stMAX:
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
parser.expression(parser, e2);
PARS.check(isInt(e2), parser, pos, 66);
e.type := PARS.program.stTypes.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
CODE.shift_minmax1(shift_minmax(proc), ARITH.Int(e.value))
ELSIF e2.obj = eCONST THEN
CODE.shift_minmax2(shift_minmax(proc), ARITH.Int(e2.value))
ELSE
CODE.shift_minmax(shift_minmax(proc))
END;
e.obj := eEXPR
END
|PROG.stCHR:
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
e.type := PARS.program.stTypes.tCHAR;
IF e.obj = eCONST THEN
ARITH.setChar(e.value, ARITH.getInt(e.value));
PARS.check(ARITH.check(e.value), parser, pos, 107)
ELSE
IF chkCHR IN checking THEN
CheckRange(256, pos.line, errCHR)
ELSE
CODE.AddCmd0(CODE.opCHR)
END
END
|PROG.stWCHR:
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
e.type := PARS.program.stTypes.tWCHAR;
IF e.obj = eCONST THEN
ARITH.setWChar(e.value, ARITH.getInt(e.value));
PARS.check(ARITH.check(e.value), parser, pos, 101)
ELSE
IF chkWCHR IN checking THEN
CheckRange(65536, pos.line, errWCHR)
ELSE
CODE.AddCmd0(CODE.opWCHR)
END
END
|PROG.stFLOOR:
parser.expression(parser, e);
PARS.check(isReal(e), parser, pos, 66);
e.type := PARS.program.stTypes.tINTEGER;
IF e.obj = eCONST THEN
PARS.check(ARITH.floor(e.value), parser, pos, 39)
ELSE
CODE.floor
END
|PROG.stFLT:
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
e.type := PARS.program.stTypes.tREAL;
IF e.obj = eCONST THEN
ARITH.flt(e.value)
ELSE
PARS.check(CODE.flt(), parser, pos, 41)
END
|PROG.stLEN:
cmd1 := CODE.getlast();
varparam(parser, pos, isArr, FALSE, e);
IF e.type.length > 0 THEN
cmd2 := CODE.getlast();
CODE.delete2(cmd1.next, cmd2);
CODE.setlast(cmd1);
ASSERT(ARITH.setInt(e.value, e.type.length));
e.obj := eCONST
ELSE
CODE.len(PROG.Dim(e.type))
END;
e.type := PARS.program.stTypes.tINTEGER
|PROG.stLENGTH:
parser.expression(parser, e);
IF isCharArray(e) THEN
IF e.type.length > 0 THEN
CODE.AddCmd(CODE.opCONST, e.type.length)
END;
CODE.AddCmd0(CODE.opLENGTH)
ELSIF isCharArrayW(e) THEN
IF e.type.length > 0 THEN
CODE.AddCmd(CODE.opCONST, e.type.length)
END;
CODE.AddCmd0(CODE.opLENGTHW)
ELSE
PARS.check(FALSE, parser, pos, 66);
END;
e.type := PARS.program.stTypes.tINTEGER
|PROG.stODD:
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
e.type := PARS.program.stTypes.tBOOLEAN;
IF e.obj = eCONST THEN
ARITH.odd(e.value)
ELSE
CODE.odd
END
|PROG.stORD:
parser.expression(parser, e);
PARS.check(isChar(e) OR isBoolean(e) OR isSet(e) OR isCharW(e) OR isStringW1(e), parser, pos, 66);
IF e.obj = eCONST THEN
IF isStringW1(e) THEN
ASSERT(ARITH.setInt(e.value, StrToWChar(e.value.string(SCAN.IDENT).s)))
ELSE
ARITH.ord(e.value)
END
ELSE
IF isBoolean(e) THEN
CODE.ord
END
END;
e.type := PARS.program.stTypes.tINTEGER
|PROG.stBITS:
parser.expression(parser, e);
PARS.check(isInt(e), parser, pos, 66);
IF e.obj = eCONST THEN
ARITH.bits(e.value)
END;
e.type := PARS.program.stTypes.tSET
|PROG.sysADR:
parser.designator(parser, e);
IF isVar(e) THEN
n := PROG.Dim(e.type);
WHILE n > 0 DO
CODE.drop;
DEC(n)
END
ELSIF e.obj = ePROC THEN
CODE.PushProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
CODE.PushImpProc(e.ident.import)
ELSE
PARS.check(FALSE, parser, pos, 108)
END;
e.type := PARS.program.stTypes.tINTEGER
|PROG.sysSADR:
parser.expression(parser, e);
PARS.check(isString(e), parser, pos, 66);
CODE.AddCmd(CODE.opSADR, String(e));
e.type := PARS.program.stTypes.tINTEGER;
e.obj := eEXPR
|PROG.sysWSADR:
parser.expression(parser, e);
PARS.check(isStringW(e), parser, pos, 66);
CODE.AddCmd(CODE.opSADR, StringW(e));
e.type := PARS.program.stTypes.tINTEGER;
e.obj := eEXPR
|PROG.sysTYPEID:
parser.expression(parser, e);
PARS.check(e.obj = eTYPE, parser, 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.check(FALSE, parser, pos, 52)
END;
e.obj := eCONST;
e.type := PARS.program.stTypes.tINTEGER
|PROG.sysINF:
PARS.check(CODE.inf(), parser, pos, 41);
e.obj := eEXPR;
e.type := PARS.program.stTypes.tREAL
|PROG.sysSIZE:
parser.expression(parser, e);
PARS.check(e.obj = eTYPE, parser, pos, 68);
ASSERT(ARITH.setInt(e.value, e.type.size));
e.obj := eCONST;
e.type := PARS.program.stTypes.tINTEGER
END
END;
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser);
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: SCAN.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);
CODE.setlast(begcall);
IF param(PROG.PARAM).vPar THEN
parser.designator(parser, e1)
ELSE
parser.expression(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
PARS.Next(parser);
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;
import: BOOLEAN;
pos: SCAN.POSITION;
BEGIN
PARS.checklex(parser, SCAN.lxIDENT);
getpos(parser, pos);
import := FALSE;
ident := parser.unit.idents.get(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 := ident.unit.idents.get(ident.unit, parser.lex.ident, FALSE);
PARS.check1((ident # NIL) & ident.export, parser, 48);
import := 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 := import
|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.stproc := ident.stproc
|PROG.idSTFUNC:
e.obj := eSTFUNC;
e.stproc := ident.stproc
|PROG.idSYSPROC:
e.obj := eSYSPROC;
e.stproc := ident.stproc
|PROG.idSYSFUNC:
PARS.check(~parser.constexp, parser, pos, 109);
e.obj := eSYSFUNC;
e.stproc := ident.stproc
|PROG.idNONE:
PARS.check(FALSE, parser, pos, 115)
END;
IF isVar(e) THEN
PARS.check(e.ident.global OR (e.ident.scopeLvl = parser.unit.scopeLvl), parser, pos, 105)
END
END qualident;
PROCEDURE deref (pos: SCAN.POSITION; e: PARS.EXPR; load: BOOLEAN; error: INTEGER);
VAR
label: INTEGER;
BEGIN
IF load THEN
CODE.load(e.type.size)
END;
IF chkPTR IN checking THEN
label := CODE.NewLabel();
CODE.AddJmpCmd(CODE.opJNZ, label);
CODE.OnError(pos.line, error);
CODE.SetLabel(label)
END
END deref;
PROCEDURE designator (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
field: PROG.FIELD;
pos: SCAN.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
CODE.AddCmd(CODE.opVADR, offset);
DEC(offset);
DEC(n)
END
END OpenArray;
BEGIN
IF e.obj = eVAR THEN
offset := PROG.getOffset(PARS.program, e.ident);
IF e.ident.global THEN
CODE.AddCmd(CODE.opGADR, offset)
ELSE
CODE.AddCmd(CODE.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
CODE.AddCmd(CODE.opVADR, e.ident.offset)
ELSIF PROG.isOpenArray(e.type) THEN
OpenArray(e)
ELSE
CODE.AddCmd(CODE.opLADR, e.ident.offset)
END
ELSIF e.obj IN {eVPAR, eVREC} THEN
IF PROG.isOpenArray(e.type) THEN
OpenArray(e)
ELSE
CODE.AddCmd(CODE.opVADR, e.ident.offset)
END
END
END LoadAdr;
PROCEDURE OpenIdx (parser: PARS.PARSER; pos: SCAN.POSITION; e: PARS.EXPR);
VAR
label: INTEGER;
type: PROG.TYPE_;
n, offset, k: INTEGER;
BEGIN
IF chkIDX IN checking THEN
label := CODE.NewLabel();
CODE.AddCmd2(CODE.opCHKIDX2, label, 0);
CODE.OnError(pos.line, errIDX);
CODE.SetLabel(label)
ELSE
CODE.AddCmd(CODE.opCHKIDX2, -1)
END;
type := PROG.OpenBase(e.type);
IF type.size # 1 THEN
CODE.AddCmd(CODE.opMULC, type.size)
END;
n := PROG.Dim(e.type) - 1;
k := n;
WHILE n > 0 DO
CODE.AddCmd0(CODE.opMUL);
DEC(n)
END;
CODE.AddCmd0(CODE.opADD);
offset := e.ident.offset - 1;
n := k;
WHILE n > 0 DO
CODE.AddCmd(CODE.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 := e.type.fields.get(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
CODE.AddCmd(CODE.opADDR, 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);
parser.expression(parser, idx);
PARS.check(isInt(idx), parser, pos, 76);
IF idx.obj = eCONST THEN
IF e.type.length > 0 THEN
PARS.check(ARITH.range(idx.value, 0, e.type.length - 1), parser, pos, 83);
IF ARITH.Int(idx.value) > 0 THEN
CODE.AddCmd(CODE.opADDR, ARITH.Int(idx.value) * e.type.base.size)
END
ELSE
PARS.check(ARITH.range(idx.value, 0, MACHINE.target.maxInt), parser, pos, 83);
LoadConst(idx);
OpenIdx(parser, pos, e)
END
ELSE
IF e.type.length > 0 THEN
IF chkIDX IN checking THEN
CheckRange(e.type.length, pos.line, errIDX)
END;
IF e.type.base.size # 1 THEN
CODE.AddCmd(CODE.opMULC, e.type.base.size)
END;
CODE.AddCmd0(CODE.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);
e.ident := NIL
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, parser, pos, 79);
IF e.type.typ = PROG.tRECORD THEN
PARS.check(t.type.typ = PROG.tRECORD, parser, pos, 80);
IF chkGUARD IN checking THEN
IF e.ident = NIL THEN
CODE.TypeGuard(CODE.opTYPEGD, t.type.num, pos.line, errGUARD)
ELSE
CODE.AddCmd(CODE.opVADR, e.ident.offset - 1);
CODE.TypeGuard(CODE.opTYPEGR, t.type.num, pos.line, errGUARD)
END
END;
ELSE
PARS.check(t.type.typ = PROG.tPOINTER, parser, pos, 81);
IF chkGUARD IN checking THEN
CODE.TypeGuard(CODE.opTYPEGP, t.type.base.num, pos.line, errGUARD)
END
END;
PARS.check(PROG.isBaseOf(e.type, t.type), parser, 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; VAR fregs: INTEGER; parser: PARS.PARSER; pos: SCAN.POSITION; CallStat: BOOLEAN);
VAR
cconv: INTEGER;
params: INTEGER;
callconv: INTEGER;
fparams: INTEGER;
int, flt: INTEGER;
stk_par: INTEGER;
BEGIN
cconv := procType.call;
params := procType.params.size;
IF cconv IN {PROG._win64, PROG.win64} THEN
callconv := CODE.call_win64;
fparams := LSL(ORD(procType.params.getfparams(procType, 3, int, flt)), 5) + MIN(params, 4)
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN
callconv := CODE.call_sysv;
fparams := LSL(ORD(procType.params.getfparams(procType, PROG.MAXSYSVPARAM - 1, int, flt)), 5) + params;
stk_par := MAX(0, int - 6) + MAX(0, flt - 8)
ELSE
callconv := CODE.call_stack;
fparams := 0
END;
CODE.setlast(begcall);
fregs := CODE.precall(isfloat);
IF cconv IN {PROG._ccall16, PROG.ccall16} THEN
CODE.AddCmd(CODE.opALIGN16, params)
ELSIF cconv IN {PROG._win64, PROG.win64} THEN
CODE.AddCmd(CODE.opWIN64ALIGN16, params)
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN
CODE.AddCmd(CODE.opSYSVALIGN16, params + stk_par)
END;
CODE.setlast(endcall.prev(CODE.COMMAND));
IF e.obj = eIMP THEN
CODE.CallImp(e.ident.import, callconv, fparams)
ELSIF e.obj = ePROC THEN
CODE.Call(e.ident.proc.label, callconv, fparams)
ELSIF isExpr(e) THEN
deref(pos, e, CallStat, errPROC);
CODE.CallP(callconv, fparams)
END;
IF cconv IN {PROG._ccall16, PROG.ccall16} THEN
CODE.AddCmd(CODE.opCLEANUP, params);
CODE.AddCmd0(CODE.opPOPSP)
ELSIF cconv IN {PROG._win64, PROG.win64} THEN
CODE.AddCmd(CODE.opCLEANUP, MAX(params + params MOD 2, 4) + 1);
CODE.AddCmd0(CODE.opPOPSP)
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN
CODE.AddCmd(CODE.opCLEANUP, params + stk_par);
CODE.AddCmd0(CODE.opPOPSP)
ELSIF cconv IN {PROG._ccall, PROG.ccall} THEN
CODE.AddCmd(CODE.opCLEANUP, params)
END;
IF ~CallStat THEN
IF isfloat THEN
PARS.check(CODE.resf(fregs), parser, pos, 41)
ELSE
CODE.res(fregs)
END
END
END ProcCall;
PROCEDURE expression (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
pos, pos0, pos1: SCAN.POSITION;
op: INTEGER;
e1: PARS.EXPR;
constant: BOOLEAN;
operator: ARITH.RELATION;
error: INTEGER;
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: SCAN.POSITION;
range: BOOLEAN;
BEGIN
range := FALSE;
getpos(parser, pos);
expression(parser, e1);
PARS.check(isInt(e1), parser, pos, 76);
IF e1.obj = eCONST THEN
PARS.check(ARITH.range(e1.value, 0, MACHINE.target.maxSet), parser, pos, 44)
END;
range := parser.sym = SCAN.lxRANGE;
IF range THEN
NextPos(parser, pos);
expression(parser, e2);
PARS.check(isInt(e2), parser, pos, 76);
IF e2.obj = eCONST THEN
PARS.check(ARITH.range(e2.value, 0, MACHINE.target.maxSet), parser, pos, 44)
END
ELSE
IF e1.obj = eCONST THEN
e2 := e1
END
END;
e.type := PARS.program.stTypes.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
CODE.AddCmd(CODE.opRSETL, ARITH.Int(e1.value))
ELSIF e2.obj = eCONST THEN
CODE.AddCmd(CODE.opRSETR, ARITH.Int(e2.value))
ELSE
CODE.AddCmd0(CODE.opRSET)
END
ELSE
CODE.AddCmd0(CODE.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 := PARS.program.stTypes.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
CODE.AddCmd(CODE.opADDSL, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opADDSR, ARITH.Int(e1.value))
ELSE
CODE.AddCmd0(CODE.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: SCAN.POSITION;
e1: PARS.EXPR;
isfloat: BOOLEAN;
fregs: INTEGER;
PROCEDURE LoadVar (e: PARS.EXPR; parser: PARS.PARSER; pos: SCAN.POSITION);
BEGIN
IF ~(e.type.typ IN {PROG.tRECORD, PROG.tARRAY}) THEN
IF e.type.typ = PROG.tREAL THEN
PARS.check(CODE.loadf(), parser, pos, 41)
ELSE
CODE.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 := PARS.program.getType(PARS.program, e.value.typ);
PARS.Next(parser)
ELSIF sym = SCAN.lxNIL THEN
e.obj := eCONST;
e.type := PARS.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 := PARS.program.stTypes.tBOOLEAN;
PARS.Next(parser)
ELSIF sym = SCAN.lxLCURLY THEN
set(parser, e)
ELSIF sym = SCAN.lxIDENT THEN
getpos(parser, pos);
CODE.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, parser, pos, 59);
isfloat := e.type.typ = PROG.tREAL;
IF e1.obj IN {ePROC, eIMP} THEN
ProcCall(e1, e1.ident.type, isfloat, fregs, parser, pos, FALSE)
ELSIF isExpr(e1) THEN
ProcCall(e1, e1.type, isfloat, fregs, parser, pos, FALSE)
END
END;
CODE.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), parser, pos, 72);
IF e.obj # eCONST THEN
CODE.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: SCAN.POSITION;
op: INTEGER;
e1: PARS.EXPR;
label: INTEGER;
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 := CODE.NewLabel()
END;
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e.value)))
END;
CODE.AddJmpCmd(CODE.opJZ, label);
CODE.drop
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), parser, 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, "*"), parser, pos, 39)
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, "*"), parser, pos, 40)
|ARITH.tSET: ARITH.opSet(e.value, e1.value, "*")
END
ELSE
IF isInt(e) THEN
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opMULC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opMULC, ARITH.Int(e1.value))
ELSE
CODE.AddCmd0(CODE.opMUL)
END
ELSIF isReal(e) THEN
IF e.obj = eCONST THEN
CODE.Float(ARITH.Float(e.value))
ELSIF e1.obj = eCONST THEN
CODE.Float(ARITH.Float(e1.value))
END;
CODE.fbinop(CODE.opMULF)
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opMULSC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opMULSC, ARITH.Int(e1.value))
ELSE
CODE.AddCmd0(CODE.opMULS)
END
END;
e.obj := eEXPR
END
|SCAN.lxSLASH:
PARS.check(isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), parser, pos, 37);
IF (e1.obj = eCONST) & isReal(e1) THEN
PARS.check(~ARITH.isZero(e1.value), parser, 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, "/"), parser, pos, 40)
|ARITH.tSET: ARITH.opSet(e.value, e1.value, "/")
END
ELSE
IF isReal(e) THEN
IF e.obj = eCONST THEN
CODE.Float(ARITH.Float(e.value));
CODE.fbinop(CODE.opDIVFI)
ELSIF e1.obj = eCONST THEN
CODE.Float(ARITH.Float(e1.value));
CODE.fbinop(CODE.opDIVF)
ELSE
CODE.fbinop(CODE.opDIVF)
END
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opDIVSC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opDIVSC, ARITH.Int(e1.value))
ELSE
CODE.AddCmd0(CODE.opDIVS)
END
END;
e.obj := eEXPR
END
|SCAN.lxDIV, SCAN.lxMOD:
PARS.check(isInt(e) & isInt(e1), parser, pos, 37);
IF e1.obj = eCONST THEN
PARS.check(~ARITH.isZero(e1.value), parser, pos, 46)
END;
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
IF op = SCAN.lxDIV THEN
PARS.check(ARITH.opInt(e.value, e1.value, "D"), parser, pos, 39)
ELSE
ASSERT(ARITH.opInt(e.value, e1.value, "M"))
END
ELSE
IF e1.obj # eCONST THEN
label1 := CODE.NewLabel();
CODE.AddJmpCmd(CODE.opJNZ, label1)
END;
IF e.obj = eCONST THEN
CODE.OnError(pos.line, errDIV);
CODE.SetLabel(label1);
CODE.AddCmd(CODE.opDIVL + ORD(op = SCAN.lxMOD), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opDIVR + ORD(op = SCAN.lxMOD), ARITH.Int(e1.value))
ELSE
CODE.OnError(pos.line, errDIV);
CODE.SetLabel(label1);
CODE.AddCmd0(CODE.opDIV + ORD(op = SCAN.lxMOD))
END;
e.obj := eEXPR
END
|SCAN.lxAND:
PARS.check(isBoolean(e) & isBoolean(e1), parser, pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
ARITH.opBoolean(e.value, e1.value, "&")
ELSE
e.obj := eEXPR;
IF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e1.value)))
END
END
END
END;
IF label # -1 THEN
CODE.SetLabel(label)
END
END term;
PROCEDURE SimpleExpression (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
pos: SCAN.POSITION;
op: INTEGER;
e1: PARS.EXPR;
plus, minus: BOOLEAN;
label: 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), parser, pos, 36);
IF minus & (e.obj = eCONST) THEN
PARS.check(ARITH.neg(e.value), parser, pos, 39)
END;
IF e.obj # eCONST THEN
IF minus THEN
IF isInt(e) THEN
CODE.AddCmd0(CODE.opUMINUS)
ELSIF isReal(e) THEN
CODE.AddCmd0(CODE.opUMINF)
ELSIF isSet(e) THEN
CODE.AddCmd0(CODE.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 := CODE.NewLabel()
END;
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e.value)))
END;
CODE.AddJmpCmd(CODE.opJNZ, label);
CODE.drop
END
END;
term(parser, e1);
CASE op OF
|SCAN.lxPLUS, SCAN.lxMINUS:
IF op = SCAN.lxPLUS THEN
op := ORD("+")
ELSE
op := ORD("-")
END;
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), parser, 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)), parser, pos, 39)
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, CHR(op)), parser, pos, 40)
|ARITH.tSET: ARITH.opSet(e.value, e1.value, CHR(op))
END
ELSE
IF isInt(e) THEN
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opADDL + ORD(op = ORD("-")), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opADDR + ORD(op = ORD("-")), ARITH.Int(e1.value))
ELSE
CODE.AddCmd0(CODE.opADD + ORD(op = ORD("-")))
END
ELSIF isReal(e) THEN
IF e.obj = eCONST THEN
CODE.Float(ARITH.Float(e.value));
CODE.fbinop(CODE.opADDFI + ORD(op = ORD("-")))
ELSIF e1.obj = eCONST THEN
CODE.Float(ARITH.Float(e1.value));
CODE.fbinop(CODE.opADDF + ORD(op = ORD("-")))
ELSE
CODE.fbinop(CODE.opADDF + ORD(op = ORD("-")))
END
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opADDSL + ORD(op = ORD("-")), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opADDSR + ORD(op = ORD("-")), ARITH.Int(e1.value))
ELSE
CODE.AddCmd0(CODE.opADDS + ORD(op = ORD("-")))
END
END;
e.obj := eEXPR
END
|SCAN.lxOR:
PARS.check(isBoolean(e) & isBoolean(e1), parser, pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
ARITH.opBoolean(e.value, e1.value, "|")
ELSE
e.obj := eEXPR;
IF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e1.value)))
END
END
END
END;
IF label # -1 THEN
CODE.SetLabel(label)
END
END SimpleExpression;
PROCEDURE cmpcode (op: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE op OF
|SCAN.lxEQ: res := 0
|SCAN.lxNE: res := 1
|SCAN.lxLT: res := 2
|SCAN.lxLE: res := 3
|SCAN.lxGT: res := 4
|SCAN.lxGE: res := 5
END
RETURN res
END cmpcode;
PROCEDURE BoolCmp (eq, val: BOOLEAN);
BEGIN
IF eq = val THEN
CODE.AddCmd0(CODE.opNER)
ELSE
CODE.AddCmd0(CODE.opEQR)
END
END BoolCmp;
PROCEDURE strcmp (VAR e, e1: PARS.EXPR; op: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := TRUE;
IF isString(e) & isCharArray(e1) THEN
CODE.AddCmd(CODE.opSADR, String(e));
CODE.AddCmd(CODE.opCONST, strlen(e) + 1);
CODE.AddCmd0(CODE.opEQS2 + cmpcode(op))
ELSIF isString(e) & isCharArrayW(e1) THEN
CODE.AddCmd(CODE.opSADR, StringW(e));
CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1);
CODE.AddCmd0(CODE.opEQSW2 + cmpcode(op))
ELSIF isStringW(e) & isCharArrayW(e1) THEN
CODE.AddCmd(CODE.opSADR, StringW(e));
CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1);
CODE.AddCmd0(CODE.opEQSW2 + cmpcode(op))
ELSIF isCharArray(e) & isString(e1) THEN
CODE.AddCmd(CODE.opSADR, String(e1));
CODE.AddCmd(CODE.opCONST, strlen(e1) + 1);
CODE.AddCmd0(CODE.opEQS + cmpcode(op))
ELSIF isCharArrayW(e) & isString(e1) THEN
CODE.AddCmd(CODE.opSADR, StringW(e1));
CODE.AddCmd(CODE.opCONST, utf8strlen(e1) + 1);
CODE.AddCmd0(CODE.opEQSW + cmpcode(op))
ELSIF isCharArrayW(e) & isStringW(e1) THEN
CODE.AddCmd(CODE.opSADR, StringW(e1));
CODE.AddCmd(CODE.opCONST, utf8strlen(e1) + 1);
CODE.AddCmd0(CODE.opEQSW + cmpcode(op))
ELSIF isCharArrayW(e) & isCharArrayW(e1) THEN
CODE.AddCmd0(CODE.opEQSW + cmpcode(op))
ELSIF isCharArray(e) & isCharArray(e1) THEN
CODE.AddCmd0(CODE.opEQS + cmpcode(op))
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
CODE.AddCmd(CODE.opCONST, e.type.length)
END;
op := parser.sym;
getpos(parser, pos);
PARS.Next(parser);
pos1 := parser.lex.pos;
SimpleExpression(parser, e1);
IF (isCharArray(e1) OR isCharArrayW(e1)) & (e1.type.length # 0) THEN
CODE.AddCmd(CODE.opCONST, e1.type.length)
END;
constant := (e.obj = eCONST) & (e1.obj = eCONST);
CASE op OF
|SCAN.lxEQ: operator := "="
|SCAN.lxNE: operator := "#"
|SCAN.lxLT: operator := "<"
|SCAN.lxLE: operator := "<="
|SCAN.lxGT: operator := ">"
|SCAN.lxGE: operator := ">="
|SCAN.lxIN: operator := "IN"
|SCAN.lxIS: operator := ""
END;
error := 0;
CASE op OF
|SCAN.lxEQ, SCAN.lxNE:
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, operator, error)
ELSE
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, ARITH.Int(e1.value))
ELSE
CODE.AddCmd0(CODE.opEQ + cmpcode(op))
END
END
ELSIF isStringW1(e) & isCharW(e1) THEN
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, StrToWChar(e.value.string(SCAN.IDENT).s))
ELSIF isStringW1(e1) & isCharW(e) THEN
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, StrToWChar(e1.value.string(SCAN.IDENT).s))
ELSIF isBoolean(e) & isBoolean(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, operator, error)
ELSE
IF e.obj = eCONST THEN
BoolCmp(op = SCAN.lxEQ, ARITH.Int(e.value) # 0)
ELSIF e1.obj = eCONST THEN
BoolCmp(op = SCAN.lxEQ, ARITH.Int(e1.value) # 0)
ELSE
IF op = SCAN.lxEQ THEN
CODE.AddCmd0(CODE.opEQB)
ELSE
CODE.AddCmd0(CODE.opNEB)
END
END
END
ELSIF isReal(e) & isReal(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, operator, error)
ELSE
IF e.obj = eCONST THEN
CODE.Float(ARITH.Float(e.value));
CODE.fcmp(CODE.opEQF + cmpcode(op) + 6)
ELSIF e1.obj = eCONST THEN
CODE.Float(ARITH.Float(e1.value));
CODE.fcmp(CODE.opEQF + cmpcode(op))
ELSE
CODE.fcmp(CODE.opEQF + cmpcode(op))
END
END
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN
IF ~strcmp(e, e1, op) THEN
PARS.error(parser, pos, 37)
END
ELSIF isPtr(e) & isNil(e1) OR isNil(e) & isPtr(e1) THEN
CODE.AddCmd0(CODE.opEQ + cmpcode(op) + 6)
ELSIF isProc(e) & isNil(e1) THEN
IF e.obj IN {ePROC, eIMP} THEN
PARS.check(e.ident.global, parser, pos0, 85);
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, op = SCAN.lxNE)
ELSE
CODE.AddCmd0(CODE.opEQ + cmpcode(op) + 6)
END
ELSIF isNil(e) & isProc(e1) THEN
IF e1.obj IN {ePROC, eIMP} THEN
PARS.check(e1.ident.global, parser, pos1, 85);
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, op = SCAN.lxNE)
ELSE
CODE.AddCmd0(CODE.opEQ + cmpcode(op) + 6)
END
ELSIF isProc(e) & isProc(e1) & PROG.isTypeEq(e.type, e1.type) THEN
IF e.obj = ePROC THEN
PARS.check(e.ident.global, parser, pos0, 85)
END;
IF e1.obj = ePROC THEN
PARS.check(e1.ident.global, parser, pos1, 85)
END;
IF (e.obj IN {ePROC, eIMP}) & (e1.obj IN {ePROC, eIMP}) THEN
constant := TRUE;
e.obj := eCONST;
IF op = SCAN.lxEQ THEN
ARITH.setbool(e.value, e.ident = e1.ident)
ELSE
ARITH.setbool(e.value, e.ident # e1.ident)
END
ELSIF e.obj = ePROC THEN
CODE.ProcCmp(e.ident.proc.label, cmpcode(op) = 0)
ELSIF e1.obj = ePROC THEN
CODE.ProcCmp(e1.ident.proc.label, cmpcode(op) = 0)
ELSIF e.obj = eIMP THEN
CODE.ProcImpCmp(e.ident.import, cmpcode(op) = 0)
ELSIF e1.obj = eIMP THEN
CODE.ProcImpCmp(e1.ident.import, cmpcode(op) = 0)
ELSE
CODE.AddCmd0(CODE.opEQ + cmpcode(op))
END
ELSIF isNil(e) & isNil(e1) THEN
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, op = SCAN.lxEQ)
ELSE
PARS.error(parser, 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, operator, error)
ELSE
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, ARITH.Int(e1.value))
ELSE
CODE.AddCmd0(CODE.opEQ + cmpcode(op))
END
END
ELSIF isStringW1(e) & isCharW(e1) THEN
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, StrToWChar(e.value.string(SCAN.IDENT).s))
ELSIF isStringW1(e1) & isCharW(e) THEN
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, StrToWChar(e1.value.string(SCAN.IDENT).s))
ELSIF isReal(e) & isReal(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, operator, error)
ELSE
IF e.obj = eCONST THEN
CODE.Float(ARITH.Float(e.value));
CODE.fcmp(CODE.opEQF + cmpcode(op) + 6)
ELSIF e1.obj = eCONST THEN
CODE.Float(ARITH.Float(e1.value));
CODE.fcmp(CODE.opEQF + cmpcode(op))
ELSE
CODE.fcmp(CODE.opEQF + cmpcode(op))
END
END
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN
IF ~strcmp(e, e1, op) THEN
PARS.error(parser, pos, 37)
END
ELSE
PARS.error(parser, pos, 37)
END
|SCAN.lxIN:
PARS.check(isInt(e) & isSet(e1), parser, pos, 37);
IF e.obj = eCONST THEN
PARS.check(ARITH.range(e.value, 0, MACHINE.target.maxSet), parser, pos0, 56)
END;
IF constant THEN
ARITH.relation(e.value, e1.value, operator, error)
ELSE
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opINL, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
CODE.AddCmd(CODE.opINR, ARITH.Int(e1.value))
ELSE
CODE.AddCmd0(CODE.opIN)
END
END
|SCAN.lxIS:
PARS.check(isExpr(e) & (e.type.typ IN {PROG.tRECORD, PROG.tPOINTER}), parser, pos, 73);
IF e.type.typ = PROG.tRECORD THEN
PARS.check(e.obj = eVREC, parser, pos0, 78)
END;
PARS.check(e1.obj = eTYPE, parser, pos1, 79);
IF e.type.typ = PROG.tRECORD THEN
PARS.check(e1.type.typ = PROG.tRECORD, parser, pos1, 80);
IF e.ident = NIL THEN
CODE.TypeCheck(e1.type.num)
ELSE
CODE.AddCmd(CODE.opVADR, e.ident.offset - 1);
CODE.TypeCheckRec(e1.type.num)
END
ELSE
PARS.check(e1.type.typ = PROG.tPOINTER, parser, pos1, 81);
CODE.TypeCheck(e1.type.base.num)
END;
PARS.check(PROG.isBaseOf(e.type, e1.type), parser, pos1, 82)
END;
ASSERT(error = 0);
e.type := PARS.program.stTypes.tBOOLEAN;
IF ~constant THEN
e.obj := eEXPR
END
END
END expression;
PROCEDURE ElementaryStatement (parser: PARS.PARSER);
VAR
e, e1: PARS.EXPR;
pos: SCAN.POSITION;
line: INTEGER;
call: BOOLEAN;
fregs: INTEGER;
BEGIN
getpos(parser, pos);
CODE.pushBegEnd(begcall, endcall);
designator(parser, e);
IF parser.sym = SCAN.lxASSIGN THEN
line := parser.lex.pos.line;
PARS.check(isVar(e), parser, pos, 93);
PARS.check(~e.readOnly, parser, pos, 94);
CODE.setlast(begcall);
NextPos(parser, pos);
expression(parser, e1);
CODE.setlast(endcall.prev(CODE.COMMAND));
PARS.check(assign(e1, e.type, line), parser, pos, 91);
IF e1.obj = ePROC THEN
PARS.check(e1.ident.global, parser, 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), parser, pos, 92);
call := TRUE
ELSE
PARS.check(isProc(e), parser, pos, 86);
PARS.check((e.type.base = NIL) OR ODD(e.type.call), parser, pos, 92);
PARS.check1(e.type.params.first = NIL, parser, 64);
call := TRUE
END;
IF call THEN
IF e.obj IN {ePROC, eIMP} THEN
ProcCall(e, e.ident.type, FALSE, fregs, parser, pos, TRUE)
ELSIF isExpr(e) THEN
ProcCall(e, e.type, FALSE, fregs, parser, pos, TRUE)
END
END;
CODE.popBegEnd(begcall, endcall)
END ElementaryStatement;
PROCEDURE IfStatement (parser: PARS.PARSER; if: BOOLEAN);
VAR
e: PARS.EXPR;
pos: SCAN.POSITION;
label, L: INTEGER;
BEGIN
L := CODE.NewLabel();
IF ~if THEN
CODE.AddCmd0(CODE.opLOOP);
CODE.SetLabel(L)
END;
REPEAT
NextPos(parser, pos);
label := CODE.NewLabel();
expression(parser, e);
PARS.check(isBoolean(e), parser, pos, 72);
IF e.obj = eCONST THEN
IF ~ARITH.getBool(e.value) THEN
CODE.AddJmpCmd(CODE.opJMP, label)
END
ELSE
CODE.AddJmpCmd(CODE.opJNE, label)
END;
IF if THEN
PARS.checklex(parser, SCAN.lxTHEN)
ELSE
PARS.checklex(parser, SCAN.lxDO)
END;
PARS.Next(parser);
parser.StatSeq(parser);
CODE.AddJmpCmd(CODE.opJMP, L);
CODE.SetLabel(label)
UNTIL parser.sym # SCAN.lxELSIF;
IF if THEN
IF parser.sym = SCAN.lxELSE THEN
PARS.Next(parser);
parser.StatSeq(parser)
END;
CODE.SetLabel(L)
END;
PARS.checklex(parser, SCAN.lxEND);
IF ~if THEN
CODE.AddCmd0(CODE.opENDLOOP)
END;
PARS.Next(parser)
END IfStatement;
PROCEDURE RepeatStatement (parser: PARS.PARSER);
VAR
e: PARS.EXPR;
pos: SCAN.POSITION;
label: INTEGER;
BEGIN
CODE.AddCmd0(CODE.opLOOP);
label := CODE.NewLabel();
CODE.SetLabel(label);
PARS.Next(parser);
parser.StatSeq(parser);
PARS.checklex(parser, SCAN.lxUNTIL);
NextPos(parser, pos);
expression(parser, e);
PARS.check(isBoolean(e), parser, pos, 72);
IF e.obj = eCONST THEN
IF ~ARITH.getBool(e.value) THEN
CODE.AddJmpCmd(CODE.opJMP, label)
END
ELSE
CODE.AddJmpCmd(CODE.opJNE, label)
END;
CODE.AddCmd0(CODE.opENDLOOP)
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: CODE.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: SCAN.POSITION;
PROCEDURE isRecPtr (caseExpr: PARS.EXPR): BOOLEAN;
RETURN isRec(caseExpr) OR isPtr(caseExpr)
END isRecPtr;
PROCEDURE Label (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR type: PROG.TYPE_): INTEGER;
VAR
a: INTEGER;
label: PARS.EXPR;
pos: SCAN.POSITION;
value: ARITH.VALUE;
BEGIN
getpos(parser, pos);
type := NIL;
IF isChar(caseExpr) THEN
PARS.ConstExpression(parser, value);
PARS.check(value.typ = ARITH.tCHAR, parser, pos, 99);
a := ARITH.getInt(value)
ELSIF isCharW(caseExpr) THEN
PARS.ConstExpression(parser, value);
IF (value.typ = ARITH.tSTRING) & (_length(value.string(SCAN.IDENT).s) = 1) & (LENGTH(value.string(SCAN.IDENT).s) > 1) THEN
ASSERT(ARITH.setInt(value, StrToWChar(value.string(SCAN.IDENT).s)))
ELSE
PARS.check(value.typ IN {ARITH.tWCHAR, ARITH.tCHAR}, parser, pos, 99)
END;
a := ARITH.getInt(value)
ELSIF isInt(caseExpr) THEN
PARS.ConstExpression(parser, value);
PARS.check(value.typ = ARITH.tINTEGER, parser, pos, 99);
a := ARITH.getInt(value)
ELSIF isRecPtr(caseExpr) THEN
qualident(parser, label);
PARS.check(label.obj = eTYPE, parser, pos, 79);
PARS.check(PROG.isBaseOf(caseExpr.type, label.type), parser, 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: SCAN.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)), parser, 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: SCAN.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 := CODE.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, parser, 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, parser, 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: CODE.COMMAND;
BEGIN
sym := parser.sym;
IF sym # SCAN.lxBAR THEN
variant := CODE.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 := CODE.getlast();
CODE.SetLabel(variant);
IF ~isRecPtr(caseExpr) THEN
LISTS.push(CaseVariants, NewVariant(variant, last))
END;
parser.StatSeq(parser);
CODE.AddJmpCmd(CODE.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: CODE.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 := CODE.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));
CODE.setlast(v.cmd);
CODE.SetLabel(node.data(CASE_LABEL).self);
CODE.case(range.a, range.b, L, R);
IF v.processed THEN
CODE.AddJmpCmd(CODE.opJMP, node.data(CASE_LABEL).variant)
END;
v.processed := TRUE;
CODE.setlast(last);
Table(left, else);
Table(right, else)
END
END Table;
PROCEDURE TableT (node: AVL.NODE);
BEGIN
IF node # NIL THEN
CODE.caset(node.data(CASE_LABEL).range.a, node.data(CASE_LABEL).variant);
TableT(node.left);
TableT(node.right)
END
END TableT;
PROCEDURE ParseCase (parser: PARS.PARSER; e: PARS.EXPR; pos: SCAN.POSITION);
VAR
table, end, else: INTEGER;
tree: AVL.NODE;
item: LISTS.ITEM;
BEGIN
LISTS.push(CaseVariants, NewVariant(0, NIL));
end := CODE.NewLabel();
else := CODE.NewLabel();
table := CODE.NewLabel();
CODE.AddCmd(CODE.opSWITCH, ORD(isRecPtr(e)));
CODE.AddJmpCmd(CODE.opJMP, table);
tree := NIL;
case(parser, e, tree, end);
WHILE parser.sym = SCAN.lxBAR DO
PARS.Next(parser);
case(parser, e, tree, end)
END;
CODE.SetLabel(else);
IF parser.sym = SCAN.lxELSE THEN
PARS.Next(parser);
parser.StatSeq(parser);
CODE.AddJmpCmd(CODE.opJMP, end)
ELSE
CODE.OnError(pos.line, errCASE)
END;
PARS.checklex(parser, SCAN.lxEND);
PARS.Next(parser);
IF isRecPtr(e) THEN
CODE.SetLabel(table);
TableT(tree);
CODE.AddJmpCmd(CODE.opJMP, else)
ELSE
tree.data(CASE_LABEL).self := table;
Table(tree, else)
END;
AVL.destroy(tree, DestroyLabel);
CODE.SetLabel(end);
CODE.AddCmd0(CODE.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), parser, pos, 95);
IF isRecPtr(e) THEN
PARS.check(isVar(e), parser, pos, 93);
PARS.check(e.ident # NIL, parser, pos, 106)
END;
IF isRec(e) THEN
PARS.check(e.obj = eVREC, parser, pos, 78)
END;
IF e.obj = eCONST THEN
LoadConst(e)
ELSIF isRec(e) THEN
CODE.drop;
CODE.AddCmd(CODE.opLADR, e.ident.offset - 1);
CODE.load(PARS.program.target.word)
ELSIF isPtr(e) THEN
deref(pos, e, FALSE, errPTR);
CODE.AddCmd(CODE.opSUBR, PARS.program.target.word);
CODE.load(PARS.program.target.word)
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: SCAN.POSITION;
step: ARITH.VALUE;
st: INTEGER;
ident: PROG.IDENT;
offset: INTEGER;
L1, L2: INTEGER;
BEGIN
CODE.AddCmd0(CODE.opLOOP);
L1 := CODE.NewLabel();
L2 := CODE.NewLabel();
PARS.ExpectSym(parser, SCAN.lxIDENT);
ident := parser.unit.idents.get(parser.unit, parser.lex.ident, TRUE);
PARS.check1(ident # NIL, parser, 48);
PARS.check1(ident.typ = PROG.idVAR, parser, 93);
PARS.check1(ident.type.typ = PROG.tINTEGER, parser, 97);
PARS.ExpectSym(parser, SCAN.lxASSIGN);
NextPos(parser, pos);
expression(parser, e);
PARS.check(isInt(e), parser, pos, 76);
offset := PROG.getOffset(PARS.program, ident);
IF ident.global THEN
CODE.AddCmd(CODE.opGADR, offset)
ELSE
CODE.AddCmd(CODE.opLADR, -offset)
END;
IF e.obj = eCONST THEN
CODE.AddCmd(CODE.opSAVEC, ARITH.Int(e.value))
ELSE
CODE.AddCmd0(CODE.opSAVE)
END;
CODE.SetLabel(L1);
IF ident.global THEN
CODE.AddCmd(CODE.opGADR, offset)
ELSE
CODE.AddCmd(CODE.opLADR, -offset)
END;
CODE.load(ident.type.size);
PARS.checklex(parser, SCAN.lxTO);
NextPos(parser, pos);
expression(parser, e);
PARS.check(isInt(e), parser, pos, 76);
IF parser.sym = SCAN.lxBY THEN
NextPos(parser, pos);
PARS.ConstExpression(parser, step);
PARS.check(step.typ = ARITH.tINTEGER, parser, pos, 76);
st := ARITH.getInt(step);
PARS.check(st # 0, parser, pos, 98)
ELSE
st := 1
END;
IF e.obj = eCONST THEN
IF st > 0 THEN
CODE.AddCmd(CODE.opLER, ARITH.Int(e.value))
ELSE
CODE.AddCmd(CODE.opGER, ARITH.Int(e.value))
END
ELSE
IF st > 0 THEN
CODE.AddCmd0(CODE.opLE)
ELSE
CODE.AddCmd0(CODE.opGE)
END
END;
CODE.AddJmpCmd(CODE.opJNE, L2);
PARS.checklex(parser, SCAN.lxDO);
PARS.Next(parser);
parser.StatSeq(parser);
IF ident.global THEN
CODE.AddCmd(CODE.opGADR, offset)
ELSE
CODE.AddCmd(CODE.opLADR, -offset)
END;
IF st = 1 THEN
CODE.AddCmd0(CODE.opINC1)
ELSIF st = -1 THEN
CODE.AddCmd0(CODE.opDEC1)
ELSE
IF st > 0 THEN
CODE.AddCmd(CODE.opINCC, st)
ELSE
CODE.AddCmd(CODE.opDECC, -st)
END
END;
CODE.AddJmpCmd(CODE.opJMP, L1);
PARS.checklex(parser, SCAN.lxEND);
PARS.Next(parser);
CODE.SetLabel(L2);
CODE.AddCmd0(CODE.opENDLOOP)
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: SCAN.POSITION): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := assigncomp(e, t);
IF res THEN
IF e.obj = eCONST THEN
IF e.type.typ = PROG.tREAL THEN
CODE.Float(ARITH.Float(e.value))
ELSIF e.type.typ = PROG.tNIL THEN
CODE.AddCmd(CODE.opCONST, 0)
ELSE
LoadConst(e)
END
ELSIF (e.type.typ = PROG.tINTEGER) & (t.typ = PROG.tBYTE) & (chkBYTE IN checking) THEN
CheckRange(256, pos.line, errBYTE)
ELSIF e.obj = ePROC THEN
PARS.check(e.ident.global, parser, pos, 85);
CODE.PushProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
CODE.PushImpProc(e.ident.import)
END;
IF e.type.typ = PROG.tREAL THEN
CODE.retf
END
END
RETURN res
END chkreturn;
PROCEDURE setrtl;
VAR
rtl: PROG.UNIT;
PROCEDURE getproc (rtl: PROG.UNIT; name: SCAN.LEXSTR; idx: INTEGER);
VAR
id: PROG.IDENT;
BEGIN
id := rtl.idents.get(rtl, SCAN.enterid(name), FALSE);
IF (id # NIL) & (id.import # NIL) THEN
CODE.codes.rtl[idx] := -id.import(CODE.IMPORT_PROC).label;
id.proc.used := TRUE
ELSIF (id # NIL) & (id.proc # NIL) THEN
CODE.codes.rtl[idx] := id.proc.label;
id.proc.used := TRUE
ELSE
ERRORS.error5("procedure ", mConst.RTL_NAME, ".", name, " not found")
END
END getproc;
BEGIN
rtl := PARS.program.rtl;
ASSERT(rtl # NIL);
getproc(rtl, "_move", CODE._move);
getproc(rtl, "_move2", CODE._move2);
getproc(rtl, "_set", CODE._set);
getproc(rtl, "_set2", CODE._set2);
getproc(rtl, "_div", CODE._div);
getproc(rtl, "_mod", CODE._mod);
getproc(rtl, "_div2", CODE._div2);
getproc(rtl, "_mod2", CODE._mod2);
getproc(rtl, "_arrcpy", CODE._arrcpy);
getproc(rtl, "_rot", CODE._rot);
getproc(rtl, "_new", CODE._new);
getproc(rtl, "_dispose", CODE._dispose);
getproc(rtl, "_strcmp", CODE._strcmp);
getproc(rtl, "_error", CODE._error);
getproc(rtl, "_is", CODE._is);
getproc(rtl, "_isrec", CODE._isrec);
getproc(rtl, "_guard", CODE._guard);
getproc(rtl, "_guardrec", CODE._guardrec);
getproc(rtl, "_length", CODE._length);
getproc(rtl, "_init", CODE._init);
getproc(rtl, "_dllentry", CODE._dllentry);
getproc(rtl, "_strcpy", CODE._strcpy);
getproc(rtl, "_exit", CODE._exit);
getproc(rtl, "_strcpy2", CODE._strcpy2);
getproc(rtl, "_lengthw", CODE._lengthw);
getproc(rtl, "_strcmp2", CODE._strcmp2);
getproc(rtl, "_strcmpw", CODE._strcmpw);
getproc(rtl, "_strcmpw2", CODE._strcmpw2);
END setrtl;
PROCEDURE compile* (path, lib_path, modname, outname: PARS.PATH; target, version, stack, base: INTEGER; pic: BOOLEAN; chk: SET);
VAR
parser: PARS.PARSER;
ext: PARS.PATH;
amd64: BOOLEAN;
BEGIN
amd64 := target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64, mConst.Target_iELF64};
ext := mConst.FILE_EXT;
CaseLabels := C.create();
CaseVar := C.create();
CaseVariants := LISTS.create(NIL);
LISTS.push(CaseVariants, NewVariant(0, NIL));
checking := chk;
IF amd64 THEN
CODE.init(6, CODE.little_endian)
ELSE
CODE.init(8, CODE.little_endian)
END;
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn);
IF parser.open(parser, mConst.RTL_NAME) 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, mConst.RTL_NAME) THEN
parser.parse(parser);
PARS.destroy(parser)
ELSE
ERRORS.error5("file ", lib_path, mConst.RTL_NAME, mConst.FILE_EXT, " not found")
END
END;
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn);
parser.main := TRUE;
IF parser.open(parser, modname) THEN
parser.parse(parser)
ELSE
ERRORS.error5("file ", path, modname, mConst.FILE_EXT, " not found")
END;
PARS.destroy(parser);
IF PARS.program.bss > mConst.MAX_GLOBAL_SIZE THEN
ERRORS.error1("size of global variables is too large")
END;
setrtl;
PROG.DelUnused(PARS.program, CODE.DelImport);
CODE.codes.bss := PARS.program.bss;
IF amd64 THEN
AMD64.CodeGen(CODE.codes, outname, target, stack, base)
ELSE
X86.CodeGen(CODE.codes, outname, target, stack, base, version, pic)
END
END compile;
END STATEMENTS.

/programs/develop/oberon07/Source/STRINGS.ob07
0,0 → 1,291
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE STRINGS;
IMPORT UTILS;
PROCEDURE append* (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE reverse* (VAR s: ARRAY OF CHAR);
VAR
i, j: INTEGER;
a, b: CHAR;
BEGIN
i := 0;
j := LENGTH(s) - 1;
WHILE i < j DO
a := s[i];
b := s[j];
s[i] := b;
s[j] := a;
INC(i);
DEC(j)
END
END reverse;
PROCEDURE IntToStr* (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
minus: BOOLEAN;
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
minus := x < 0;
IF minus THEN
x := -x
END;
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
IF minus THEN
str[i] := "-";
INC(i)
END;
str[i] := 0X;
reverse(str)
END
END IntToStr;
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 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 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 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 := LSL(ORD(c) - 0C0H, 6);
IF i + 1 < srclen THEN
u := u + ROR(LSL(ORD(src[i + 1]), 26), 26);
INC(i)
END
|0E1X..0EFX:
u := LSL(ORD(c) - 0E0H, 12);
IF i + 1 < srclen THEN
u := u + ROR(LSL(ORD(src[i + 1]), 26), 20);
INC(i)
END;
IF i + 1 < srclen THEN
u := u + ROR(LSL(ORD(src[i + 1]), 26), 26);
INC(i)
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;
END STRINGS.

/programs/develop/oberon07/Source/TEXTDRV.ob07
0,0 → 1,209
(*
BSD 2-Clause License
Copyright (c) 2018, 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 BYTE;
pos, size: INTEGER;
file: FILES.FILE;
utf8: BOOLEAN;
CR: BOOLEAN;
line*, col*: INTEGER;
eof*: BOOLEAN;
eol*: BOOLEAN;
open*: PROCEDURE (text: TEXT; name: ARRAY OF CHAR): BOOLEAN;
peak*: PROCEDURE (text: TEXT): CHAR;
nextc*: PROCEDURE (text: TEXT)
END;
VAR
texts: C.COLLECTION;
PROCEDURE reset (text: TEXT);
BEGIN
text.chunk[0] := 0;
text.pos := 0;
text.size := 0;
text.file := NIL;
text.utf8 := FALSE;
text.CR := FALSE;
text.line := 1;
text.col := 1;
text.eof := FALSE;
text.eol := FALSE
END reset;
PROCEDURE peak (text: TEXT): CHAR;
RETURN CHR(text.chunk[text.pos])
END peak;
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] := 0
END
END
END load;
PROCEDURE next (text: TEXT);
VAR
c: CHAR;
BEGIN
IF text.pos < text.size - 1 THEN
INC(text.pos)
ELSE
load(text)
END;
IF ~text.eof THEN
c := peak(text);
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 (c < 80X) OR (c > 0BFX) 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] = 0EFH) &
(text.chunk[1] = 0BBH) &
(text.chunk[2] = 0BFH) THEN
text.pos := 3;
text.utf8 := TRUE
END
END;
IF text.size = 0 THEN
text.chunk[0] := 0;
text.size := 1;
text.eof := FALSE
END;
text.line := 1;
text.col := 1
END init;
PROCEDURE open (text: TEXT; name: ARRAY OF CHAR): BOOLEAN;
BEGIN
ASSERT(text # NIL);
reset(text);
text.file := FILES.open(name);
IF text.file # NIL THEN
load(text);
init(text)
END
RETURN text.file # NIL
END open;
PROCEDURE NewText (): TEXT;
VAR
text: TEXT;
citem: C.ITEM;
BEGIN
citem := C.pop(texts);
IF citem = NIL THEN
NEW(text)
ELSE
text := citem(TEXT)
END
RETURN text
END NewText;
PROCEDURE create* (): TEXT;
VAR
text: TEXT;
BEGIN
text := NewText();
reset(text);
text.open := open;
text.peak := peak;
text.nextc := next
RETURN text
END create;
PROCEDURE destroy* (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 destroy;
BEGIN
texts := C.create()
END TEXTDRV.

/programs/develop/oberon07/Source/UNIXTIME.ob07
0,0 → 1,69
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE UNIXTIME;
VAR
days: ARRAY 12, 31, 2 OF INTEGER;
PROCEDURE init;
VAR
i, j, k, n0, n1: INTEGER;
BEGIN
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
days[i, j, 0] := 0;
days[i, j, 1] := 0;
END
END;
days[ 1, 28, 0] := -1;
FOR k := 0 TO 1 DO
days[ 1, 29, k] := -1;
days[ 1, 30, k] := -1;
days[ 3, 30, k] := -1;
days[ 5, 30, k] := -1;
days[ 8, 30, k] := -1;
days[10, 30, k] := -1;
END;
n0 := 0;
n1 := 0;
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
IF days[i, j, 0] = 0 THEN
days[i, j, 0] := n0;
INC(n0)
END;
IF days[i, j, 1] = 0 THEN
days[i, j, 1] := n1;
INC(n1)
END
END
END
END init;
PROCEDURE time* (year, month, day, hour, min, sec: INTEGER): INTEGER;
VAR
d, s: INTEGER;
BEGIN
d := (year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4;
s := d * 86400 + hour * 3600 + min * 60 + sec
RETURN s
END time;
BEGIN
init
END UNIXTIME.

/programs/develop/oberon07/Source/UTILS.ob07
1,418 → 1,120
(*
Copyright 2016, 2017 Anton Krotov
(*
BSD 2-Clause License
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE UTILS;
IMPORT sys := SYSTEM, H := HOST, ERRORS;
IMPORT HOST, UNIXTIME;
CONST
OS* = H.OS;
Slash* = H.Slash;
Ext* = ".ob07";
MAX_PATH = 1024;
MAX_PARAM = 1024;
Date* = 1509580800; (* 2017-11-02 *)
slash* = HOST.slash;
TYPE
bit_depth* = HOST.bit_depth;
maxint* = HOST.maxint;
minint* = HOST.minint;
STRING* = ARRAY MAX_PATH OF CHAR;
OS = HOST.OS;
ITEM* = POINTER TO rITEM;
rITEM* = RECORD
Next*, Prev*: ITEM
END;
VAR
LIST* = POINTER TO RECORD
First*, Last*: ITEM;
Count*: INTEGER
END;
time*: INTEGER;
STRCONST* = POINTER TO RECORD (rITEM)
Str*: STRING;
Len*, Number*: INTEGER
END;
eol*: ARRAY 3 OF CHAR;
VAR
maxreal*: REAL;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
ParamCount*, Line*, Unit*: INTEGER;
FileName: STRING;
PROCEDURE SetFile*(F: STRING);
BEGIN
FileName := F
END SetFile;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN HOST.FileRead(F, Buffer, bytes)
END FileRead;
PROCEDURE IsInf*(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
PROCEDURE GetChar(adr: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN HOST.FileWrite(F, Buffer, bytes)
END FileWrite;
PROCEDURE ParamParse(count: INTEGER);
VAR c: CHAR; cond, p: INTEGER;
PROCEDURE ChangeCond(A, B, C: INTEGER);
BEGIN
cond := C;
CASE c OF
|0X: cond := 6
|1X..20X: cond := A
|22X: cond := B
ELSE
END
END ChangeCond;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN HOST.FileCreate(FName)
END FileCreate;
BEGIN
p := H.GetCommandLine();
cond := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END
|4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3, 5: ChangeCond(cond, 1, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
END;
INC(p)
END;
ParamCount := count - 1
END ParamParse;
PROCEDURE ParamStr*(VAR str: ARRAY OF CHAR; n: INTEGER);
VAR i, j, len: INTEGER; c: CHAR;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
j := 0;
IF n <= ParamCount THEN
len := LEN(str) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
str[j] := c;
INC(j)
END;
INC(i)
END
END;
str[j] := 0X
END ParamStr;
HOST.FileClose(F)
END FileClose;
PROCEDURE GetMem*(n: INTEGER): INTEGER;
RETURN H.malloc(n)
END GetMem;
PROCEDURE CloseF*(F: INTEGER);
BEGIN
H.CloseFile(F)
END CloseF;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN HOST.FileOpen(FName)
END FileOpen;
PROCEDURE Read*(F, Buffer, Count: INTEGER): INTEGER;
RETURN H.FileRW(F, Buffer, Count, FALSE)
END Read;
PROCEDURE Write*(F, Buffer, Count: INTEGER): INTEGER;
RETURN H.FileRW(F, Buffer, Count, TRUE)
END Write;
PROCEDURE FileSize*(F: INTEGER): INTEGER;
RETURN H.FileSize(F)
END FileSize;
PROCEDURE CharC*(x: CHAR);
VAR str: ARRAY 2 OF CHAR;
PROCEDURE GetArg* (i: INTEGER; VAR str: ARRAY OF CHAR);
BEGIN
str[0] := x;
str[1] := 0X;
H.OutString(str)
END CharC;
HOST.GetArg(i, str)
END GetArg;
PROCEDURE Int*(x: INTEGER);
VAR i: INTEGER; buf: ARRAY 11 OF INTEGER;
BEGIN
i := 0;
REPEAT
buf[i] := x MOD 10;
x := x DIV 10;
INC(i)
UNTIL x = 0;
REPEAT
DEC(i);
CharC(CHR(buf[i] + ORD("0")))
UNTIL i = 0
END Int;
PROCEDURE Ln*;
PROCEDURE Exit* (code: INTEGER);
BEGIN
CharC(0DX);
CharC(0AX)
END Ln;
HOST.ExitProcess(code)
END Exit;
PROCEDURE OutString*(str: ARRAY OF CHAR);
BEGIN
H.OutString(str)
END OutString;
PROCEDURE ErrMsg*(code: INTEGER);
VAR str: ARRAY 1024 OF CHAR;
BEGIN
ERRORS.ErrorMsg(code, str);
OutString("error: ("); Int(code); OutString(") "); OutString(str); Ln
END ErrMsg;
PROCEDURE GetTickCount* (): INTEGER;
RETURN HOST.GetTickCount()
END GetTickCount;
PROCEDURE ErrMsgPos*(line, col, code: INTEGER);
VAR s: STRING;
BEGIN
ErrMsg(code);
OutString("file: "); OutString(FileName); Ln;
OutString("line: "); Int(line); Ln;
OutString("pos: "); Int(col); Ln;
END ErrMsgPos;
PROCEDURE UnitLine*(newUnit, newLine: INTEGER);
PROCEDURE OutChar* (c: CHAR);
BEGIN
Unit := newUnit;
Line := newLine
END UnitLine;
HOST.OutChar(c)
END OutChar;
PROCEDURE Align*(n: INTEGER): INTEGER;
RETURN (4 - n MOD 4) MOD 4
END Align;
PROCEDURE CAP(x: CHAR): CHAR;
BEGIN
IF (x >= "a") & (x <= "z") THEN
x := CHR(ORD(x) - 32)
END
RETURN x
END CAP;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
RETURN HOST.splitf(x, a, b)
END splitf;
PROCEDURE streq*(a, b: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := -1;
REPEAT
INC(i)
UNTIL (CAP(a[i]) # CAP(b[i])) OR (a[i] = 0X) OR (b[i] = 0X)
RETURN a[i] = b[i]
END streq;
PROCEDURE concat*(VAR L: STRING; R: STRING);
VAR i, n, pos: INTEGER;
BEGIN
n := LENGTH(R);
i := 0;
pos := LENGTH(L);
WHILE (i <= n) & (pos < LEN(L)) DO
L[pos] := R[i];
INC(pos);
INC(i)
END
END concat;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN HOST.isRelative(path)
END isRelative;
PROCEDURE GetStr*(this: LIST; str: STRING): STRCONST;
VAR res: STRCONST;
BEGIN
res := this.First(STRCONST);
WHILE (res # NIL) & (res.Str # str) DO
res := res.Next(STRCONST)
END
RETURN res
END GetStr;
PROCEDURE Push*(this: LIST; item: ITEM);
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
BEGIN
IF this.Count = 0 THEN
this.First := item;
item.Prev := NIL
ELSE
this.Last.Next := item;
item.Prev := this.Last
END;
INC(this.Count);
this.Last := item;
item.Next := NIL
END Push;
HOST.GetCurrentDirectory(path)
END GetCurrentDirectory;
PROCEDURE Insert*(this: LIST; item, prev: ITEM);
BEGIN
IF prev # this.Last THEN
item.Next := prev.Next;
item.Prev := prev;
prev.Next := item;
item.Next.Prev := item;
INC(this.Count)
ELSE
Push(this, item)
END
END Insert;
PROCEDURE Clear*(this: LIST);
BEGIN
this.First := NIL;
this.Last := NIL;
this.Count := 0
END Clear;
PROCEDURE UnixTime* (): INTEGER;
VAR
year, month, day, hour, min, sec: INTEGER;
res: INTEGER;
PROCEDURE Revers(VAR str: STRING);
VAR a, b: INTEGER; c: CHAR;
BEGIN
a := 0;
b := LENGTH(str) - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END
END Revers;
PROCEDURE Split*(FName: STRING; VAR Path, Name, Ext: STRING);
VAR i, j, k: INTEGER;
BEGIN
i := LENGTH(FName) - 1;
j := 0;
WHILE (i >= 0) & (FName[i] # Slash) DO
Name[j] := FName[i];
DEC(i);
INC(j)
END;
Name[j] := 0X;
Revers(Name);
j := 0;
k := LENGTH(Name) - 1;
WHILE (k >= 0) & (Name[k] # ".") DO
Ext[j] := Name[k];
DEC(k);
INC(j)
END;
IF k >= 0 THEN
Name[k] := 0X;
Ext[j] := ".";
INC(j)
IF OS = "LINUX" THEN
res := HOST.UnixTime()
ELSE
j := 0
END;
Ext[j] := 0X;
Revers(Ext);
FOR j := 0 TO i DO
Path[j] := FName[j]
END;
Path[i + 1] := 0X
END Split;
PROCEDURE LinuxParam;
VAR p, i, str: INTEGER; c: CHAR;
BEGIN
p := H.GetCommandLine();
sys.GET(p, ParamCount);
sys.GET(p + 4, p);
FOR i := 0 TO ParamCount - 1 DO
sys.GET(p + i * 4, str);
Params[i, 0] := str;
REPEAT
sys.GET(str, c);
INC(str)
UNTIL c = 0X;
Params[i, 1] := str - 1
END;
DEC(ParamCount)
END LinuxParam;
PROCEDURE Time*;
VAR sec, dsec: INTEGER;
BEGIN
OutString("elapsed time ");
H.Time(sec, dsec);
sec := sec - H.sec;
dsec := dsec - H.dsec;
dsec := dsec + sec * 100;
Int(dsec DIV 100); CharC(".");
dsec := dsec MOD 100;
IF dsec < 10 THEN
Int(0)
END;
Int(dsec); OutString(" sec"); Ln
END Time;
PROCEDURE HALT*(n: INTEGER);
BEGIN
Time;
H.ExitProcess(n)
END HALT;
PROCEDURE MemErr*(err: BOOLEAN);
BEGIN
IF err THEN
ErrMsg(72);
HALT(1)
HOST.now(year, month, day, hour, min, sec);
res := UNIXTIME.time(year, month, day, hour, min, sec)
END
END MemErr;
PROCEDURE CreateList*(): LIST;
VAR nov: LIST;
BEGIN
NEW(nov);
MemErr(nov = NIL)
RETURN nov
END CreateList;
RETURN res
END UnixTime;
PROCEDURE CreateF*(FName: ARRAY OF CHAR): INTEGER;
RETURN H.CreateFile(FName)
END CreateF;
PROCEDURE OpenF*(FName: ARRAY OF CHAR(*; Mode: INTEGER*)): INTEGER;
RETURN H.OpenFile(FName)
END OpenF;
PROCEDURE Init;
VAR p: INTEGER;
PROCEDURE last(VAR p: INTEGER);
BEGIN
WHILE GetChar(p) # 0X DO INC(p) END;
DEC(p)
END last;
BEGIN
H.init;
IF OS = "WIN" THEN
ParamParse(0)
ELSIF OS = "KOS" THEN
ParamParse(1);
Params[0, 0] := H.GetName();
Params[0, 1] := Params[0, 0];
last(Params[0, 1])
ELSIF OS = "LNX" THEN
LinuxParam
END
END Init;
BEGIN
Init
time := GetTickCount();
COPY(HOST.eol, eol);
maxreal := 1.9;
PACK(maxreal, 1023)
END UTILS.

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

/programs/develop/oberon07/Source/X86.ob07
1,2004 → 1,2406
(*
Copyright 2016, 2017, 2018 Anton Krotov
(*
BSD 2-Clause License
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE X86;
IMPORT UTILS, sys := SYSTEM, SCAN, ELF;
IMPORT CODE, REG, UTILS, LISTS, BIN, PE32, KOS, MSCOFF, ELF, mConst := CONSTANTS, MACHINE, CHL := CHUNKLISTS, PATHS;
CONST
ADIM* = 5;
eax = REG.R0; ecx = REG.R1; edx = REG.R2;
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
al = eax; cl = ecx; dl = edx; ah = 4;
TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7;
TNIL = 8; TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14;
ax = eax; cx = ecx; dx = edx;
stABS* = 1; stODD* = 2; stLEN* = 3; stLSL* = 4; stASR* = 5; stROR* = 6; stFLOOR* = 7;
stFLT* = 8; stORD* = 9; stCHR* = 10; stLONG* = 11; stSHORT* = 12; stINC* = 13;
stDEC* = 14; stINCL* = 15; stEXCL* = 16; stCOPY* = 17; stNEW* = 18; stASSERT* = 19;
stPACK* = 20; stUNPK* = 21; stDISPOSE* = 22; stFABS* = 23; stINC1* = 24;
stDEC1* = 25; stASSERT1* = 26; stUNPK1* = 27; stPACK1* = 28; stLSR* = 29;
stLENGTH* = 30; stMIN* = 31; stMAX* = 32;
esp = 4;
ebp = 5;
sysMOVE* = 108;
sete = 94H; setne = 95H; setl = 9CH; setge = 9DH; setle = 9EH; setg = 9FH; setc = 92H; setnc = 93H;
JMP* = 0E9X; CALL = 0E8X;
JE = 84X; JNE = 85X; JLE = 8EX; JGE = 8DX; JG = 8FX; JL = 8CX;
je = 84H; jne = 85H; jl = 8CH; jge = 8DH; jle = 8EH; jg = 8FH; jb = 82H; jnb = 83H;
JCMD = 1; LCMD = 2; GCMD = 3; OCMD = 4; ECMD = 5;
PUSHEAX = 6; PUSHECX = 7; PUSHEDX = 8; POPEAX = 9; POPECX = 10; POPEDX = 11;
ICMP1 = 13; ICMP2 = 14;
defcall = 0; stdcall = 1; cdecl = 2; winapi = 3;
CODECHUNK = 8;
_rset* = 0; _inset* = 1; _saverec* = 2; _length* = 3; _checktype* = 4; _strcmp* = 5;
_lstrcmp* = 6; _rstrcmp* = 7; _savearr* = 8; _newrec* = 9; _disprec* = 10; _arrayidx* = 11;
_arrayrot* = 12; _assrt* = 13; _strcopy* = 14; _arrayidx1* = 15; _init* = 16; _close* = 17; _halt* = 18;
ASSRT = 19; hInstance = 20; SELFNAME = 21; RTABLE = 22;LoadLibrary = 23; GetProcAddress = 24;
Exports = 25; szSTART = 26; START = 27; szversion = 28; _floor = 29; HALT = 30;
FREGS = 8;
TYPE
ASMLINE* = POINTER TO RECORD (UTILS.rITEM)
cmd, clen, varadr, adr, tcmd, codeadr: INTEGER; short: BOOLEAN
COMMAND = CODE.COMMAND;
ANYCODE = POINTER TO RECORD (LISTS.ITEM)
offset: INTEGER
END;
TFLT = ARRAY 2 OF INTEGER;
TCODE = POINTER TO RECORD (ANYCODE)
TIDX* = ARRAY ADIM OF INTEGER;
code: ARRAY CODECHUNK OF BYTE;
length: INTEGER
SECTIONNAME = ARRAY 8 OF CHAR;
END;
SECTION = RECORD
name: SECTIONNAME;
size, adr, sizealign, OAPfile, reserved6, reserved7, reserved8, attrflags: INTEGER
LABEL = POINTER TO RECORD (ANYCODE)
label: INTEGER
END;
HEADER = RECORD
msdos: ARRAY 180 OF CHAR;
typecomp, seccount: sys.CARD16;
time, reserved1, reserved2: INTEGER;
PEoptsize, infflags, PEfile, compver: sys.CARD16;
codesize, datasize, initdatasize, startadr,
codeadr, rdataadr, loadadr, secalign, filealign,
oldestver, version, oldestverNT, reserved3,
filesize, headersize, dllcrc: INTEGER;
UI, reserved4: sys.CARD16;
stksize, stkalloc, heapsize, heapalloc, reserved5, structcount: INTEGER;
structs: ARRAY 16 OF RECORD adr, size: INTEGER END;
sections: ARRAY 3 OF SECTION
JUMP = POINTER TO RECORD (ANYCODE)
label, diff: INTEGER;
short: BOOLEAN
END;
COFFHEADER = RECORD
Machine: sys.CARD16;
NumberOfSections: sys.CARD16;
TimeDateStamp,
PointerToSymbolTable,
NumberOfSymbols: INTEGER;
SizeOfOptionalHeader,
Characteristics: sys.CARD16;
text, data, bss: SECTION
JMP = POINTER TO RECORD (JUMP)
END;
KOSHEADER = RECORD
menuet01: ARRAY 8 OF CHAR;
ver, start, size, mem, sp, param, path: INTEGER
JCC = POINTER TO RECORD (JUMP)
jmp: INTEGER
END;
ETABLE = RECORD
reserved1, time, reserved2, dllnameoffset, firstnum, adrcount,
namecount, arradroffset, arrnameptroffset, arrnumoffset: INTEGER;
arradr, arrnameptr: ARRAY 10000H OF INTEGER;
arrnum: ARRAY 10000H OF sys.CARD16;
text: ARRAY 1000000 OF CHAR;
textlen, size: INTEGER
CALL = POINTER TO RECORD (JUMP)
END;
RELOC = RECORD
Page, Size: INTEGER;
reloc: ARRAY 1024 OF sys.CARD16
RELOC = POINTER TO RECORD (ANYCODE)
op, value: INTEGER
END;
VAR asmlist: UTILS.LIST; start: ASMLINE; dll, con, gui, kos, elf, obj, kem: BOOLEAN;
Lcount, reccount, topstk: INTEGER; recarray: ARRAY 2048 OF INTEGER; current*: ASMLINE;
callstk: ARRAY 1024, 2 OF ASMLINE; OutFile: UTILS.STRING;
Code: ARRAY 4000000 OF CHAR; ccount: INTEGER; Data: ARRAY 1000000 OF CHAR; dcount: INTEGER;
Labels: ARRAY 200000 OF INTEGER; rdata: ARRAY 400H OF INTEGER; Header: HEADER; etable: ETABLE;
ExecName: UTILS.STRING; LoadAdr: INTEGER; Reloc: ARRAY 200000 OF CHAR; rcount: INTEGER;
RtlProc: ARRAY 20 OF INTEGER; OutFilePos: INTEGER; RelocSection: SECTION;
fpu*: INTEGER; isfpu: BOOLEAN; maxfpu: INTEGER; fpucmd: ASMLINE;
kosexp: ARRAY 65536 OF RECORD Name: SCAN.NODE; Adr, NameLabel: INTEGER END; kosexpcount: INTEGER;
maxstrlen*: INTEGER;
PROCEDURE set_maxstrlen* (value: INTEGER);
BEGIN
maxstrlen := value
END set_maxstrlen;
VAR
PROCEDURE AddRtlProc*(idx, proc: INTEGER);
BEGIN
RtlProc[idx] := proc
END AddRtlProc;
R: REG.REGS;
PROCEDURE IntToCard16(i: INTEGER): sys.CARD16;
VAR w: sys.CARD16;
BEGIN
sys.GET(sys.ADR(i), w)
RETURN w
END IntToCard16;
program: BIN.PROGRAM;
PROCEDURE CopyStr(VAR Dest: ARRAY OF CHAR; Source: ARRAY OF CHAR; VAR di: INTEGER; si: INTEGER);
BEGIN
DEC(di);
REPEAT
INC(di);
Dest[di] := Source[si];
INC(si)
UNTIL Dest[di] = 0X
END CopyStr;
CodeList: LISTS.LIST;
PROCEDURE exch(VAR a, b: INTEGER);
VAR c: INTEGER;
BEGIN
c := a;
a := b;
b := c
END exch;
PROCEDURE Sort(VAR NamePtr, Adr: ARRAY OF INTEGER; Text: ARRAY OF CHAR; LB, RB: INTEGER);
VAR L, R: INTEGER;
PROCEDURE Byte (n: INTEGER): BYTE;
RETURN MACHINE.Byte(n, 0)
END Byte;
PROCEDURE strle(s1, s2: INTEGER): BOOLEAN;
VAR S1, S2: ARRAY 256 OF CHAR; i: INTEGER;
PROCEDURE Word (n: INTEGER): INTEGER;
RETURN MACHINE.Byte(n, 0) + MACHINE.Byte(n, 1) * 256
END Word;
PROCEDURE OutByte* (n: BYTE);
VAR
c: TCODE;
last: ANYCODE;
BEGIN
i := 0;
CopyStr(S1, Text, i, s1);
i := 0;
CopyStr(S2, Text, i, s2)
RETURN S1 <= S2
END strle;
last := CodeList.last(ANYCODE);
BEGIN
IF LB < RB THEN
L := LB;
R := RB;
REPEAT
WHILE (L < RB) & strle(NamePtr[L], NamePtr[LB]) DO
INC(L)
END;
WHILE (R > LB) & strle(NamePtr[LB], NamePtr[R]) DO
DEC(R)
END;
IF L < R THEN
exch(NamePtr[L], NamePtr[R]);
exch(Adr[L], Adr[R])
IF (last IS TCODE) & (last(TCODE).length < CODECHUNK) THEN
c := last(TCODE);
c.code[c.length] := n;
INC(c.length)
ELSE
NEW(c);
c.code[0] := n;
c.length := 1;
LISTS.push(CodeList, c)
END
UNTIL L >= R;
IF R > LB THEN
exch(NamePtr[LB], NamePtr[R]);
exch(Adr[LB], Adr[R]);
Sort(NamePtr, Adr, Text, LB, R - 1)
END;
Sort(NamePtr, Adr, Text, R + 1, RB)
END
END Sort;
PROCEDURE PackExport(Name: ARRAY OF CHAR);
VAR i: INTEGER;
END OutByte;
PROCEDURE OutInt (n: INTEGER);
BEGIN
Sort(etable.arrnameptr, etable.arradr, etable.text, 0, etable.namecount - 1);
FOR i := 0 TO etable.namecount - 1 DO
etable.arrnum[i] := IntToCard16(i)
END;
etable.size := 40 + etable.adrcount * 4 + etable.namecount * 6;
etable.arradroffset := 40;
etable.arrnameptroffset := 40 + etable.adrcount * 4;
etable.arrnumoffset := etable.arrnameptroffset + etable.namecount * 4;
etable.dllnameoffset := etable.size + etable.textlen;
CopyStr(etable.text, Name, etable.textlen, 0);
INC(etable.textlen);
FOR i := 0 TO etable.namecount - 1 DO
etable.arrnameptr[i] := etable.arrnameptr[i] + etable.size
END;
etable.size := etable.size + etable.textlen
END PackExport;
OutByte(MACHINE.Byte(n, 0));
OutByte(MACHINE.Byte(n, 1));
OutByte(MACHINE.Byte(n, 2));
OutByte(MACHINE.Byte(n, 3))
END OutInt;
PROCEDURE ProcExport*(Number: INTEGER; Name: SCAN.NODE; NameLabel: INTEGER);
PROCEDURE OutByte2 (a, b: BYTE);
BEGIN
IF dll THEN
etable.arradr[etable.adrcount] := Number;
INC(etable.adrcount);
etable.arrnameptr[etable.namecount] := etable.textlen;
INC(etable.namecount);
CopyStr(etable.text, Name.Name, etable.textlen, 0);
INC(etable.textlen)
ELSIF obj THEN
kosexp[kosexpcount].Name := Name;
kosexp[kosexpcount].Adr := Number;
kosexp[kosexpcount].NameLabel := NameLabel;
INC(kosexpcount)
END
END ProcExport;
OutByte(a);
OutByte(b)
END OutByte2;
PROCEDURE Err(code: INTEGER);
PROCEDURE OutByte3 (a, b, c: BYTE);
BEGIN
CASE code OF
|1: UTILS.ErrMsg(67); UTILS.OutString(OutFile)
|2: UTILS.ErrMsg(69); UTILS.OutString(OutFile)
ELSE
END;
UTILS.Ln;
UTILS.HALT(1)
END Err;
OutByte(a);
OutByte(b);
OutByte(c)
END OutByte3;
PROCEDURE Align*(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
PROCEDURE PutReloc(R: RELOC);
VAR i: INTEGER;
PROCEDURE OutWord (n: INTEGER);
BEGIN
sys.PUT(sys.ADR(Reloc[rcount]), R.Page);
INC(rcount, 4);
sys.PUT(sys.ADR(Reloc[rcount]), R.Size);
INC(rcount, 4);
FOR i := 0 TO ASR(R.Size - 8, 1) - 1 DO
sys.PUT(sys.ADR(Reloc[rcount]), R.reloc[i]);
INC(rcount, 2)
END
END PutReloc;
ASSERT((0 <= n) & (n <= 65535));
OutByte2(n MOD 256, n DIV 256)
END OutWord;
PROCEDURE InitArray(VAR adr: INTEGER; chars: UTILS.STRING);
VAR i, x, n: INTEGER;
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
n := LEN(chars) - 1;
i := 0;
WHILE (i < n) & (chars[i] # 0X) DO
x := SCAN.hex(chars[i]) * 16 + SCAN.hex(chars[i + 1]);
sys.PUT(adr, CHR(x));
INC(adr);
INC(i, 2)
IF isByte(n) THEN
OutByte(Byte(n))
ELSE
OutInt(n)
END
END InitArray;
END OutIntByte;
PROCEDURE WriteF(F, A, N: INTEGER);
PROCEDURE shift* (op, reg: INTEGER);
BEGIN
IF UTILS.Write(F, A, N) # N THEN
Err(2)
CASE op OF
|CODE.opASR, CODE.opASR1, CODE.opASR2: OutByte(0F8H + reg)
|CODE.opROR, CODE.opROR1, CODE.opROR2: OutByte(0C8H + reg)
|CODE.opLSL, CODE.opLSL1, CODE.opLSL2: OutByte(0E0H + reg)
|CODE.opLSR, CODE.opLSR1, CODE.opLSR2: OutByte(0E8H + reg)
END
END WriteF;
END shift;
PROCEDURE Write(A, N: INTEGER);
PROCEDURE mov (reg1, reg2: INTEGER);
BEGIN
sys.MOVE(A, OutFilePos, N);
OutFilePos := OutFilePos + N
END Write;
OutByte2(89H, 0C0H + reg2 * 8 + reg1) // mov reg1, reg2
END mov;
PROCEDURE Fill(n: INTEGER; c: CHAR);
VAR i: INTEGER;
PROCEDURE xchg (reg1, reg2: INTEGER);
VAR
regs: SET;
BEGIN
FOR i := 1 TO n DO
Write(sys.ADR(c), 1)
regs := {reg1, reg2};
IF regs = {eax, ecx} THEN
OutByte(91H) // xchg eax, ecx
ELSIF regs = {eax, edx} THEN
OutByte(92H) // xchg eax, edx
ELSIF regs = {ecx, edx} THEN
OutByte2(87H, 0D1H) // xchg ecx, edx
END
END Fill;
END xchg;
PROCEDURE SetSection(VAR Section: SECTION; name: SECTIONNAME; size, adr, sizealign, OAPfile, attrflags: INTEGER);
PROCEDURE pop (reg: INTEGER);
BEGIN
Section.name := name;
Section.size := size;
Section.adr := adr;
Section.sizealign := sizealign;
Section.OAPfile := OAPfile;
Section.attrflags := attrflags;
END SetSection;
OutByte(58H + reg) // pop reg
END pop;
PROCEDURE WritePE(FName: ARRAY OF CHAR; stksize, codesize, datasize, rdatasize, gsize: INTEGER);
CONST textattr = 60000020H; rdataattr = 40000040H; dataattr = 0C0000040H; relocattr = 42000040H;
VAR i, F, adr, acodesize, compver, version, stkalloc, heapsize, heapalloc, filesize, filebuf: INTEGER;
cur: ASMLINE;
PROCEDURE push (reg: INTEGER);
BEGIN
OutByte(50H + reg) // push reg
END push;
compver := 0;
version := 0;
stkalloc := stksize;
heapsize := 100000H;
heapalloc := 100000H;
acodesize := Align(codesize, 1000H) + 1000H;
adr := sys.ADR(rdata);
filesize := acodesize + Align(rdatasize, 1000H) + Align(datasize, 1000H) + Align(rcount, 1000H);
InitArray(adr, "5000000040000000000000003400000000000000000000006200000000000000");
InitArray(adr, "0000000000000000000000000000000000000000500000004000000000000000");
InitArray(adr, "A4014C6F61644C6962726172794100001F0147657450726F6341646472657373");
InitArray(adr, "00006B65726E656C33322E646C6C0000");
PROCEDURE movrc (reg, n: INTEGER);
BEGIN
OutByte(0B8H + reg); // mov reg, n
OutInt(n)
END movrc;
rdata[ 0] := acodesize + 50H;
rdata[ 1] := acodesize + 40H;
rdata[ 3] := acodesize + 34H;
rdata[ 6] := acodesize + 62H;
rdata[ 7] := acodesize;
rdata[13] := acodesize + 50H;
rdata[14] := acodesize + 40H;
adr := sys.ADR(Header.msdos);
InitArray(adr, "4D5A90000300000004000000FFFF0000B8000000000000004000000000000000");
InitArray(adr, "00000000000000000000000000000000000000000000000000000000B0000000");
InitArray(adr, "0E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F");
InitArray(adr, "742062652072756E20696E20444F53206D6F64652E0D0D0A2400000000000000");
InitArray(adr, "5DCF9F8719AEF1D419AEF1D419AEF1D497B1E2D413AEF1D4E58EE3D418AEF1D4");
InitArray(adr, "5269636819AEF1D4000000000000000050450000");
Header.typecomp := IntToCard16(014CH);
IF dll THEN
Header.seccount := IntToCard16(0004H);
Header.infflags := IntToCard16(210EH)
ELSE
Header.seccount := IntToCard16(0003H);
Header.infflags := IntToCard16(010FH)
END;
Header.time := UTILS.Date;
Header.PEoptsize := IntToCard16(00E0H);
Header.PEfile := IntToCard16(010BH);
Header.compver := IntToCard16(compver);
Header.codesize := Align(codesize, 200H);
Header.datasize := Align(datasize + gsize, 200H) + Align(rdatasize, 200H) + Align(rcount, 200H);
Header.startadr := 1000H;
Header.codeadr := 1000H;
Header.rdataadr := Header.codeadr + Align(codesize, 1000H);
Header.loadadr := LoadAdr;
Header.secalign := 1000H;
Header.filealign := 0200H;
Header.oldestver := 0004H;
Header.version := version;
Header.oldestverNT := 0004H;
Header.filesize := Align(codesize, 1000H) + Align(datasize + gsize, 1000H) + Align(rdatasize, 1000H) + Align(rcount, 1000H) + 1000H;
Header.headersize := 0400H;
Header.UI := IntToCard16(ORD(con) + 2);
Header.stksize := stksize;
Header.stkalloc := stkalloc;
Header.heapsize := heapsize;
Header.heapalloc := heapalloc;
Header.structcount := 10H;
IF dll THEN
Header.structs[0].adr := Header.rdataadr + 0DAH;
Header.structs[0].size := etable.size
END;
PROCEDURE pushc (n: INTEGER);
BEGIN
OutByte(68H + short(n)); // push n
OutIntByte(n)
END pushc;
Header.structs[1].adr := Header.rdataadr + 0CH;
Header.structs[1].size := 28H;
Header.structs[12].adr := Header.rdataadr;
Header.structs[12].size := 0CH;
SetSection(Header.sections[0], ".text", codesize, 1000H, Align(codesize, 200H), 400H, textattr);
SetSection(Header.sections[1], ".rdata", rdatasize, Align(codesize, 1000H) + 1000H, Align(rdatasize, 200H),
Align(codesize, 200H) + 400H, rdataattr);
SetSection(Header.sections[2], ".data", datasize + gsize, Align(codesize, 1000H) + Align(rdatasize, 1000H) + 1000H,
Align(datasize, 200H), Align(codesize, 200H) + Align(rdatasize, 200H) + 400H, dataattr);
PROCEDURE test (reg: INTEGER);
BEGIN
OutByte2(85H, 0C0H + reg * 9) // test reg, reg
END test;
IF dll THEN
SetSection(RelocSection, ".reloc", rcount, Header.sections[2].adr + Align(datasize + gsize, 1000H), Align(rcount, 200H),
Header.sections[2].OAPfile + Align(datasize, 200H), relocattr);
Header.structs[5].adr := RelocSection.adr;
Header.structs[5].size := rcount
END;
F := UTILS.CreateF(FName);
IF F = 0 THEN
Err(1)
END;
OutFilePos := UTILS.GetMem(filesize);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
PROCEDURE neg (reg: INTEGER);
BEGIN
OutByte2(0F7H, 0D8H + reg) // neg reg
END neg;
Write(sys.ADR(Header), sys.SIZE(HEADER));
IF dll THEN
Write(sys.ADR(RelocSection), sys.SIZE(SECTION));
Fill(Align(sys.SIZE(HEADER) + sys.SIZE(SECTION), 200H) - (sys.SIZE(HEADER) + sys.SIZE(SECTION)), 0X)
ELSE
Fill(Align(sys.SIZE(HEADER), 200H) - sys.SIZE(HEADER), 0X)
END;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
Fill(Align(codesize, 200H) - codesize, 0X);
Write(sys.ADR(rdata), 0DAH);
IF dll THEN
etable.time := Header.time;
Write(sys.ADR(etable), 40);
Write(sys.ADR(etable.arradr), etable.adrcount * 4);
Write(sys.ADR(etable.arrnameptr), etable.namecount * 4);
Write(sys.ADR(etable.arrnum), etable.namecount * 2);
Write(sys.ADR(etable.text), etable.textlen)
END;
Fill(Align(rdatasize, 200H) - rdatasize, 0X);
Write(sys.ADR(Data), datasize);
Fill(Align(datasize, 200H) - datasize, 0X);
IF dll THEN
Write(sys.ADR(Reloc), rcount);
Fill(Align(rcount, 200H) - rcount, 0X)
END;
WriteF(F, filebuf, OutFilePos - filebuf);
UTILS.CloseF(F)
END WritePE;
PROCEDURE New;
VAR nov: ASMLINE;
PROCEDURE not (reg: INTEGER);
BEGIN
NEW(nov);
UTILS.MemErr(nov = NIL);
nov.cmd := ccount;
UTILS.Insert(asmlist, nov, current);
current := current.Next(ASMLINE)
END New;
OutByte2(0F7H, 0D0H + reg) // not reg
END not;
PROCEDURE Empty(varadr: INTEGER);
PROCEDURE add (reg1, reg2: INTEGER);
BEGIN
New;
current.clen := 0;
current.tcmd := ECMD;
current.varadr := varadr
END Empty;
OutByte2(01H, 0C0H + reg2 * 8 + reg1) // add reg1, reg2
END add;
PROCEDURE OutByte(byte: INTEGER);
PROCEDURE andrc (reg, n: INTEGER);
BEGIN
New;
current.clen := 1;
Code[ccount] := CHR(byte);
INC(ccount)
END OutByte;
OutByte2(81H + short(n), 0E0H + reg); // and reg, n
OutIntByte(n)
END andrc;
PROCEDURE OutInt(int: INTEGER);
PROCEDURE orrc (reg, n: INTEGER);
BEGIN
New;
current.clen := 4;
sys.PUT(sys.ADR(Code[ccount]), int);
INC(ccount, 4)
END OutInt;
OutByte2(81H + short(n), 0C8H + reg); // or reg, n
OutIntByte(n)
END orrc;
PROCEDURE PushEAX;
PROCEDURE addrc (reg, n: INTEGER);
BEGIN
OutByte(50H);
current.tcmd := PUSHEAX
END PushEAX;
OutByte2(81H + short(n), 0C0H + reg); // add reg, n
OutIntByte(n)
END addrc;
PROCEDURE PushECX;
PROCEDURE subrc (reg, n: INTEGER);
BEGIN
OutByte(51H);
current.tcmd := PUSHECX
END PushECX;
OutByte2(81H + short(n), 0E8H + reg); // sub reg, n
OutIntByte(n)
END subrc;
PROCEDURE PushEDX;
PROCEDURE cmprr (reg1, reg2: INTEGER);
BEGIN
OutByte(52H);
current.tcmd := PUSHEDX
END PushEDX;
OutByte2(39H, 0C0H + reg2 * 8 + reg1) // cmp reg1, reg2
END cmprr;
PROCEDURE PopEAX;
PROCEDURE cmprc (reg, n: INTEGER);
BEGIN
OutByte(58H);
current.tcmd := POPEAX
END PopEAX;
OutByte2(81H + short(n), 0F8H + reg); // cmp reg, n
OutIntByte(n)
END cmprc;
PROCEDURE PopECX;
PROCEDURE setcc (cond, reg: INTEGER);
BEGIN
OutByte(59H);
current.tcmd := POPECX
END PopECX;
OutByte3(0FH, cond, 0C0H + reg) // setcc reg
END setcc;
PROCEDURE PopEDX;
PROCEDURE drop;
BEGIN
OutByte(5AH);
current.tcmd := POPEDX
END PopEDX;
REG.Drop(R)
END drop;
PROCEDURE OutCode(cmd: UTILS.STRING);
VAR a, b: INTEGER;
PROCEDURE log2* (x: INTEGER): INTEGER;
VAR
n: INTEGER;
BEGIN
New;
a := sys.ADR(Code[ccount]);
b := a;
InitArray(a, cmd);
ccount := a - b + ccount;
current.clen := a - b
END OutCode;
ASSERT(x > 0);
PROCEDURE Del*(last: ASMLINE);
BEGIN
last.Next := current.Next;
IF current = asmlist.Last THEN
asmlist.Last := last
n := 0;
WHILE ~ODD(x) DO
x := x DIV 2;
INC(n)
END;
current := last
END Del;
PROCEDURE NewLabel*(): INTEGER;
BEGIN
INC(Lcount)
RETURN Lcount
END NewLabel;
IF x # 1 THEN
n := -1
END
PROCEDURE PushCall*(asmline: ASMLINE);
BEGIN
New;
callstk[topstk][0] := asmline;
callstk[topstk][1] := current;
INC(topstk)
END PushCall;
RETURN n
END log2;
PROCEDURE Param*;
BEGIN
current := callstk[topstk - 1][0]
END Param;
PROCEDURE EndCall*;
PROCEDURE cond* (op: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
current := callstk[topstk - 1][1];
DEC(topstk)
END EndCall;
CASE op OF
|CODE.opGT, CODE.opGTR, CODE.opLTL: res := jg
|CODE.opGE, CODE.opGER, CODE.opLEL: res := jge
|CODE.opLT, CODE.opLTR, CODE.opGTL: res := jl
|CODE.opLE, CODE.opLER, CODE.opGEL: res := jle
|CODE.opEQ, CODE.opEQR, CODE.opEQL: res := je
|CODE.opNE, CODE.opNER, CODE.opNEL: res := jne
END
PROCEDURE Init*(UI: INTEGER);
VAR nov: ASMLINE;
RETURN res
END cond;
PROCEDURE inv1* (op: INTEGER): INTEGER;
BEGIN
dcount := 4;
dll := UI = 1;
gui := UI = 2;
con := UI = 3;
kos := UI = 4;
elf := UI = 5;
obj := UI = 6;
Lcount := HALT;
asmlist := UTILS.CreateList();
NEW(nov);
UTILS.MemErr(nov = NIL);
UTILS.Push(asmlist, nov);
current := nov
END Init;
IF ODD(op) THEN
DEC(op)
ELSE
INC(op)
END
PROCEDURE datastr(str: UTILS.STRING);
VAR i, n: INTEGER;
RETURN op
END inv1;
PROCEDURE Reloc* (op, value: INTEGER);
VAR
reloc: RELOC;
BEGIN
i := 0;
n := LEN(str);
WHILE (i < n) & (str[i] # 0X) DO
Data[dcount] := str[i];
INC(dcount);
INC(i)
END;
Data[dcount] := 0X;
INC(dcount)
END datastr;
NEW(reloc);
reloc.op := op;
reloc.value := value;
LISTS.push(CodeList, reloc)
END Reloc;
PROCEDURE dataint(n: INTEGER);
PROCEDURE jcc* (cc, label: INTEGER);
VAR
j: JCC;
BEGIN
sys.PUT(sys.ADR(Data[dcount]), n);
INC(dcount, 4)
END dataint;
NEW(j);
j.label := label;
j.jmp := cc;
j.short := FALSE;
LISTS.push(CodeList, j)
END jcc;
PROCEDURE jmp*(jamp: CHAR; label: INTEGER);
VAR n: INTEGER;
PROCEDURE jmp* (label: INTEGER);
VAR
j: JMP;
BEGIN
New;
CASE jamp OF
|JMP, CALL:
n := 5
|JE, JLE, JGE, JG, JL, JNE:
Code[ccount] := 0FX;
INC(ccount);
n := 6
ELSE
END;
current.clen := n;
Code[ccount] := jamp;
INC(ccount);
current.codeadr := sys.ADR(Code[ccount]);
current.varadr := sys.ADR(Labels[label]);
current.tcmd := JCMD;
current.short := TRUE;
INC(ccount, 4)
NEW(j);
j.label := label;
j.short := FALSE;
LISTS.push(CodeList, j)
END jmp;
PROCEDURE jmplong(jamp: CHAR; label: INTEGER);
PROCEDURE call* (label: INTEGER);
VAR
c: CALL;
BEGIN
jmp(jamp, label);
current.short := FALSE
END jmplong;
NEW(c);
c.label := label;
c.short := TRUE;
LISTS.push(CodeList, c)
END call;
PROCEDURE Label*(label: INTEGER);
PROCEDURE Pic (reg, opcode, value: INTEGER);
BEGIN
New;
current.varadr := sys.ADR(Labels[label]);
current.tcmd := LCMD
END Label;
OutByte(0E8H); OutInt(0); // call L
// L:
pop(reg);
OutByte2(081H, 0C0H + reg); // add reg, ...
Reloc(opcode, value)
END Pic;
PROCEDURE CmdN(Number: INTEGER);
PROCEDURE CallRTL (pic: BOOLEAN; proc: INTEGER);
VAR
label: INTEGER;
reg1: INTEGER;
BEGIN
New;
current.clen := 4;
current.codeadr := sys.ADR(Code[ccount]);
current.varadr := sys.ADR(Labels[Number]);
current.tcmd := OCMD;
INC(ccount, 4)
END CmdN;
label := CODE.codes.rtl[proc];
PROCEDURE IntByte(bytecode, intcode: UTILS.STRING; n: INTEGER);
BEGIN
IF (n <= 127) & (n >= -128) THEN
OutCode(bytecode);
OutByte(n)
IF label < 0 THEN
label := -label;
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICIMP, label);
OutByte2(0FFH, 010H + reg1); // call dword[reg1]
drop
ELSE
OutCode(intcode);
OutInt(n)
OutByte2(0FFH, 015H); // call dword[label]
Reloc(BIN.RIMP, label)
END
END IntByte;
ELSE
call(label)
END
END CallRTL;
PROCEDURE DropFpu*(long: BOOLEAN);
PROCEDURE SetLabel* (label: INTEGER);
VAR
L: LABEL;
BEGIN
IF long THEN
OutCode("83EC08DD1C24")
ELSE
OutCode("83EC04D91C24")
END;
DEC(fpu)
END DropFpu;
NEW(L);
L.label := label;
LISTS.push(CodeList, L)
END SetLabel;
PROCEDURE AfterRet(func, float: BOOLEAN; callconv, parsize: INTEGER);
PROCEDURE fixup*;
VAR
code: ANYCODE;
count, i: INTEGER;
shorted: BOOLEAN;
jump: JUMP;
BEGIN
IF callconv = cdecl THEN
OutCode("81C4");
OutInt(parsize)
REPEAT
shorted := FALSE;
count := 0;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
code.offset := count;
CASE code OF
|TCODE: 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;
IF func THEN
IF float THEN
OutCode("83EC08DD1C24")
ELSE
PushEAX
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
END AfterRet;
PROCEDURE FpuSave(local: INTEGER);
VAR i: INTEGER;
BEGIN
IF fpu > maxfpu THEN
maxfpu := fpu
END;
FOR i := 1 TO fpu DO
IntByte("DD5D", "DD9D", -local - i * 8)
UNTIL ~shorted;
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
CASE code OF
|TCODE:
FOR i := 0 TO code.length - 1 DO
BIN.PutCode(program, code.code[i])
END
END FpuSave;
PROCEDURE Incfpu;
BEGIN
IF fpu >= FREGS THEN
UTILS.ErrMsgPos(SCAN.coord.line, SCAN.coord.col, 97);
UTILS.HALT(1)
END;
INC(fpu);
isfpu := TRUE
END Incfpu;
|LABEL:
BIN.SetLabel(program, code.label, code.offset)
PROCEDURE FpuLoad(local: INTEGER; float: BOOLEAN);
VAR i: INTEGER;
BEGIN
FOR i := fpu TO 1 BY -1 DO
IntByte("DD45", "DD85", -local - i * 8)
END;
IF float THEN
Incfpu;
OutCode("DD042483C408")
|JMP:
IF code.short THEN
BIN.PutCode(program, 0EBH);
BIN.PutCode(program, Byte(code.diff))
ELSE
BIN.PutCode(program, 0E9H);
BIN.PutCode32LE(program, code.diff)
END
END FpuLoad;
PROCEDURE Call*(proc: INTEGER; func, float: BOOLEAN; callconv, ccall, bases, level, parsize, local: INTEGER);
VAR i: INTEGER;
BEGIN
IF ccall # 0 THEN
FOR i := level TO level - bases + ORD(ccall = 1) + 1 BY -1 DO
IntByte("FF75", "FFB5", 4 * i + 4)
END;
IF ccall = 1 THEN
OutByte(55H)
|JCC:
IF code.short THEN
BIN.PutCode(program, code.jmp - 16);
BIN.PutCode(program, Byte(code.diff))
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;
FpuSave(local);
jmplong(CALL, proc);
AfterRet(func, float, callconv, parsize);
FpuLoad(local, func & float)
END Call;
PROCEDURE CallRTL(Proc: INTEGER);
code := code.next(ANYCODE)
END
END fixup;
PROCEDURE UnOp (VAR reg: INTEGER);
BEGIN
New;
current.clen := 5;
Code[ccount] := CALL;
INC(ccount);
current.codeadr := sys.ADR(Code[ccount]);
current.varadr := sys.ADR(RtlProc[Proc]);
current.tcmd := JCMD;
INC(ccount, 4)
END CallRTL;
REG.UnOp(R, reg)
END UnOp;
PROCEDURE PushInt*(n: INTEGER);
PROCEDURE BinOp (VAR reg1, reg2: INTEGER);
BEGIN
OutByte(68H);
CmdN(n)
END PushInt;
REG.BinOp(R, reg1, reg2)
END BinOp;
PROCEDURE Prolog*(exename: UTILS.STRING);
PROCEDURE PushAll (NumberOfParameters: INTEGER);
BEGIN
ExecName := exename;
Labels[hInstance] := -dcount;
dataint(0);
Labels[SELFNAME] := -dcount;
datastr(exename);
Label(START);
IF dll THEN
OutCode("558BEC837D0C007507");
CallRTL(_close);
OutCode("EB06837D0C017409B801000000C9C20C00")
ELSIF obj THEN
OutCode("558BEC")
END;
start := asmlist.Last(ASMLINE)
END Prolog;
REG.PushAll(R);
R.pushed := R.pushed - NumberOfParameters
END PushAll;
PROCEDURE AddRec*(base: INTEGER);
PROCEDURE NewLabel (): INTEGER;
BEGIN
INC(reccount);
recarray[reccount] := base
END AddRec;
BIN.NewLabel(program)
RETURN CODE.NewLabel()
END NewLabel;
PROCEDURE CmpOpt(inv: BOOLEAN): INTEGER;
VAR cur: ASMLINE; c: INTEGER;
PROCEDURE GetRegA;
BEGIN
c := ORD(Code[current.Prev.Prev(ASMLINE).cmd]);
IF inv THEN
IF ODD(c) THEN
DEC(c)
ELSE
INC(c)
END
END;
cur := current;
REPEAT
cur.tcmd := 0;
cur.clen := 0;
cur := cur.Prev(ASMLINE)
UNTIL cur.tcmd = ICMP1;
cur.tcmd := 0;
cur.clen := 0
RETURN c - 16
END CmpOpt;
ASSERT(REG.GetReg(R, eax))
END GetRegA;
PROCEDURE ifwh*(L: INTEGER);
VAR c: INTEGER;
PROCEDURE translate (code: CODE.CODES; pic: BOOLEAN; stroffs: INTEGER);
VAR
cmd: COMMAND;
reg1, reg2: INTEGER;
n, a, b, label, cc: INTEGER;
param1, param2: INTEGER;
float: REAL;
BEGIN
IF current.Prev(ASMLINE).tcmd = ICMP2 THEN
c := CmpOpt(TRUE);
OutCode("5A583BC2");
jmp(CHR(c), L)
cmd := code.commands.first(COMMAND);
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
CASE cmd.opcode OF
|CODE.opJMP:
jmp(param1)
|CODE.opCALL:
call(param1)
|CODE.opCALLI:
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICIMP, param1);
OutByte2(0FFH, 010H + reg1); // call dword[reg1]
drop
ELSE
PopECX;
OutCode("85C9");
jmp(JE, L)
OutByte2(0FFH, 015H); // call dword[L]
Reloc(BIN.RIMP, param1)
END
END ifwh;
PROCEDURE PushConst*(Number: INTEGER);
BEGIN
IntByte("6A", "68", Number);
current.Prev(ASMLINE).varadr := Number
END PushConst;
|CODE.opCALLP:
UnOp(reg1);
OutByte2(0FFH, 0D0H + reg1); // call reg1
drop;
ASSERT(R.top = -1)
PROCEDURE IfWhile*(L: INTEGER; orop: BOOLEAN);
VAR c, L1: INTEGER;
BEGIN
L1 := NewLabel();
IF current.Prev(ASMLINE).tcmd = ICMP2 THEN
c := CmpOpt(orop);
OutCode("5A583BC2");
jmp(CHR(c), L1);
PushConst(ORD(orop))
ELSE
PopECX;
OutCode("85C9");
IF orop THEN
jmp(JE, L1)
ELSE
jmp(JNE, L1)
|CODE.opPRECALL:
n := param2;
IF (param1 # 0) & (n # 0) THEN
subrc(esp, 8)
END;
PushECX
WHILE n > 0 DO
subrc(esp, 8);
OutByte3(0DDH, 01CH, 024H); // fstp qword[esp]
DEC(n)
END;
jmp(JMP, L);
Label(L1)
END IfWhile;
PushAll(0)
PROCEDURE newrec*;
BEGIN
CallRTL(_newrec)
END newrec;
|CODE.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)
PROCEDURE disprec*;
BEGIN
CallRTL(_disprec)
END disprec;
PROCEDURE String*(Number, Len: INTEGER; str: UTILS.STRING);
BEGIN
Labels[Number] := -dcount;
IF Len > 1 THEN
datastr(str)
ELSIF Len = 1 THEN
dataint(ORD(str[0]))
ELSE
dataint(0)
|CODE.opRES:
ASSERT(R.top = -1);
GetRegA;
n := param2;
WHILE n > 0 DO
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
addrc(esp, 8);
DEC(n)
END
END String;
PROCEDURE InsertFpuInit;
VAR t: ASMLINE;
BEGIN
IF isfpu THEN
t := current;
current := fpucmd;
IF maxfpu > 0 THEN
OutCode("83EC");
OutByte(maxfpu * 8)
|CODE.opRESF:
n := param2;
IF n > 0 THEN
OutByte3(0DDH, 5CH + long(n * 8), 24H);
OutIntByte(n * 8); // fstp qword[esp + n*8]
INC(n)
END;
OutCode("DBE3");
current := t
WHILE n > 0 DO
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
addrc(esp, 8);
DEC(n)
END
END InsertFpuInit;
PROCEDURE ProcBeg*(Number, Local: INTEGER; Module: BOOLEAN);
VAR i: INTEGER;
BEGIN
IF Module THEN
OutCode("EB0C");
Label(Number + 3);
PushInt(Number + 2);
jmplong(JMP, HALT);
Label(Number + 1)
|CODE.opENTER:
ASSERT(R.top = -1);
SetLabel(param1);
push(ebp);
mov(ebp, esp);
n := param2;
IF n > 4 THEN
movrc(ecx, n);
pushc(0); // @@: push 0
OutByte2(0E2H, 0FCH) // loop @b
ELSE
Label(Number)
END;
OutCode("558BEC");
IF Local > 12 THEN
IntByte("83EC", "81EC", Local);
OutCode("8BD733C08BFCB9");
OutInt(ASR(Local, 2));
OutCode("9CFCF3AB8BFA9D")
ELSE
FOR i := 4 TO Local BY 4 DO
OutCode("6A00")
WHILE n > 0 DO
pushc(0);
DEC(n)
END
END
|CODE.opLEAVE, CODE.opLEAVER, CODE.opLEAVEF:
IF cmd.opcode = CODE.opLEAVER THEN
UnOp(reg1);
IF reg1 # eax THEN
GetRegA;
ASSERT(REG.Exchange(R, reg1, eax));
drop
END;
fpucmd := current;
fpu := 0;
maxfpu := 0;
isfpu := FALSE
END ProcBeg;
drop
END;
PROCEDURE Leave*;
BEGIN
OutByte(0C9H);
InsertFpuInit
END Leave;
ASSERT(R.top = -1);
PROCEDURE ProcEnd*(Number, Param: INTEGER; func, float: BOOLEAN);
BEGIN
IF func & ~float THEN
PopEAX
END;
OutByte(0C9H);
IF Param = 0 THEN
OutByte(0C3H)
mov(esp, ebp);
pop(ebp);
n := param2;
IF n > 0 THEN
n := n * 4;
OutByte(0C2H); OutWord(Word(n)) // ret n
ELSE
OutByte(0C2H);
OutByte(Param MOD 256);
OutByte(ASR(Param, 8))
END;
InsertFpuInit
END ProcEnd;
OutByte(0C3H) // ret
END
PROCEDURE Module*(Name: UTILS.STRING; Number: INTEGER);
BEGIN
String(Number + 2, LENGTH(Name), Name);
jmplong(JMP, Number + 1)
END Module;
|CODE.opERRC:
pushc(param2)
PROCEDURE Asm*(s: UTILS.STRING);
BEGIN
OutCode(s)
END Asm;
|CODE.opPARAM:
n := param2;
IF n = 1 THEN
UnOp(reg1);
push(reg1);
drop
ELSE
ASSERT(R.top + 1 <= n);
PushAll(n)
END
PROCEDURE GlobalAdr*(offset: INTEGER);
BEGIN
OutByte(0BAH);
OutInt(offset);
current.codeadr := sys.ADR(Code[ccount - 4]);
current.tcmd := GCMD;
PushEDX
END GlobalAdr;
|CODE.opCLEANUP:
n := param2 * 4;
IF n # 0 THEN
addrc(esp, n)
END
PROCEDURE Mono*(Number: INTEGER);
BEGIN
PopEDX;
PushInt(Number)
END Mono;
|CODE.opPOPSP:
pop(esp)
PROCEDURE StrMono*;
BEGIN
PopEDX;
OutCode("6A02");
PushEDX
END StrMono;
|CODE.opCONST:
reg1 := REG.GetAnyReg(R);
movrc(reg1, param2)
PROCEDURE Not*;
BEGIN
PopECX;
OutCode("85C90F94C1");
PushECX
END Not;
|CODE.opLABEL:
SetLabel(param2) // L:
PROCEDURE NegSet*;
BEGIN
OutCode("F71424")
END NegSet;
|CODE.opNOP:
PROCEDURE Int*(Op: INTEGER);
BEGIN
PopEDX;
CASE Op OF
|lxPlus: OutCode("011424")
|lxMinus: OutCode("291424")
|lxMult: OutCode("58F7EA"); PushEAX
|CODE.opGADR:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICBSS, param2)
ELSE
OutByte(0B8H + reg1); // mov reg1, _bss + param2
Reloc(BIN.RBSS, param2)
END
END Int;
PROCEDURE Set*(Op: INTEGER);
BEGIN
PopEDX;
OutByte(58H);
CASE Op OF
|lxPlus: OutByte(0BH)
|lxMinus: OutCode("F7D223")
|lxMult: OutByte(23H)
|lxSlash: OutByte(33H)
ELSE
END;
OutByte(0C2H);
PushEAX
END Set;
|CODE.opLADR:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8DH, 45H + reg1 * 8 + long(n)); // lea reg1, dword[ebp + n]
OutIntByte(n)
PROCEDURE Setfpu*(newfpu: INTEGER);
BEGIN
fpu := newfpu
END Setfpu;
|CODE.opVADR:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n)
PROCEDURE PushFlt*(x: LONGREAL);
VAR f: TFLT; L: INTEGER;
BEGIN
sys.PUT(sys.ADR(f), x);
Incfpu;
IF x = 0.0D0 THEN
OutCode("D9EE")
ELSIF x = 1.0D0 THEN
OutCode("D9E8")
|CODE.opSADR:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICDATA, stroffs + param2);
ELSE
L := NewLabel();
Labels[L] := -dcount;
dataint(f[0]);
dataint(f[1]);
OutByte(0BAH);
CmdN(L);
OutCode("DD02")
OutByte(0B8H + reg1); // mov reg1, _data + stroffs + param2
Reloc(BIN.RDATA, stroffs + param2)
END
END PushFlt;
PROCEDURE farith*(op: INTEGER);
VAR n: INTEGER;
BEGIN
OutByte(0DEH);
CASE op OF
|lxPlus: n := 0C1H
|lxMinus: n := 0E9H
|lxMult: n := 0C9H
|lxSlash: n := 0F9H
|CODE.opSAVEC:
UnOp(reg1);
OutByte2(0C7H, reg1); OutInt(param2); // mov dword[reg1], param2
drop
|CODE.opSAVE8C:
UnOp(reg1);
OutByte3(0C6H, reg1, Byte(param2)); // mov byte[reg1], param2
drop
|CODE.opSAVE16C:
UnOp(reg1);
OutByte3(66H, 0C7H, reg1); OutWord(Word(param2)); // mov word[reg1], param2
drop
|CODE.opVLOAD32:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n);
OutByte2(8BH, reg1 * 9) // mov reg1, dword[reg1]
|CODE.opGLOAD32:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
OutByte2(8BH, reg1 * 9) // mov reg1, dword[reg1]
ELSE
END;
OutByte(n);
DEC(fpu)
END farith;
OutByte2(08BH, 05H + reg1 * 8); // mov reg1, dword[_bss + param2]
Reloc(BIN.RBSS, param2)
END
PROCEDURE fcmp*(Op: INTEGER);
VAR n: INTEGER;
BEGIN
OutCode("33C9DED9DFE09E0F");
CASE Op OF
|lxEQ: n := 94H
|lxNE: n := 95H
|lxLT: n := 97H
|lxGT: n := 92H
|lxLE: n := 93H
|lxGE: n := 96H
|CODE.opLLOAD32:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n)
|CODE.opLOAD32:
UnOp(reg1);
OutByte2(8BH, reg1 * 9) // mov reg1, dword[reg1]
|CODE.opVLOAD8:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n);
OutByte3(0FH, 0B6H, reg1 * 9) // movzx reg1, byte[reg1]
|CODE.opGLOAD8:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
OutByte3(0FH, 0B6H, reg1 * 9) // movzx reg1, byte[reg1]
ELSE
END;
DEC(fpu, 2);
OutByte(n);
OutByte(0C1H);
PushECX
END fcmp;
OutByte3(00FH, 0B6H, 05H + reg1 * 8); // movzx reg1, byte[_bss + param2]
Reloc(BIN.RBSS, param2)
END
PROCEDURE fneg*;
BEGIN
OutCode("D9E0")
END fneg;
|CODE.opLLOAD8:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte3(0FH, 0B6H, 45H + reg1 * 8 + long(n)); // movzx reg1, byte[ebp + n]
OutIntByte(n)
PROCEDURE OnError*(n: INTEGER);
BEGIN
OutByte(68H);
OutInt(LSL(UTILS.Line, 4) + n);
jmplong(JMP, UTILS.Unit + 3)
END OnError;
|CODE.opLOAD8:
UnOp(reg1);
OutByte3(0FH, 0B6H, reg1 * 9) // movzx reg1, byte[reg1]
PROCEDURE idivmod*(opmod: BOOLEAN);
BEGIN
PopECX;
IF opmod THEN
OutCode("58E32E538BD833D9C1FB1F8BD0C1FA1F83F9FF750C3D0000008075055B6A00EB1AF7F985DB740685D2740203D15B52EB0A")
|CODE.opVLOAD16:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n);
OutByte3(0FH, 0B7H, reg1 * 9) // movzx reg1, word[reg1]
|CODE.opGLOAD16:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
OutByte3(0FH, 0B7H, reg1 * 9) // movzx reg1, word[reg1]
ELSE
OutCode("58E32C538BD833D9C1FB1F8BD0C1FA1F83F9FF750B3D0000008075045B50EB19F7F985DB740585D27401485B50EB0A")
END;
OnError(8)
END idivmod;
OutByte3(00FH, 0B7H, 05H + reg1 * 8); // movzx reg1, word[_bss + param2]
Reloc(BIN.RBSS, param2)
END
PROCEDURE rset*;
BEGIN
CallRTL(_rset);
PushEAX
END rset;
|CODE.opLLOAD16:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte3(0FH, 0B7H, 45H + reg1 * 8 + long(n)); // movzx reg1, word[ebp + n]
OutIntByte(n)
PROCEDURE inset*;
BEGIN
CallRTL(_inset);
PushEAX
END inset;
|CODE.opLOAD16:
UnOp(reg1);
OutByte3(0FH, 0B7H, reg1 * 9) // movzx reg1, word[reg1]
PROCEDURE Dup*;
BEGIN
PopEDX;
PushEDX;
PushEDX
END Dup;
|CODE.opUMINUS:
UnOp(reg1);
neg(reg1)
PROCEDURE Inclusion*(Op: INTEGER);
BEGIN
PopEDX;
PopEAX;
IF Op = lxLE THEN
PushEDX
|CODE.opADD:
BinOp(reg1, reg2);
add(reg1, reg2);
drop
|CODE.opADDL, CODE.opADDR:
IF param2 # 0 THEN
UnOp(reg1);
IF param2 = 1 THEN
OutByte(40H + reg1) // inc reg1
ELSIF param2 = -1 THEN
OutByte(48H + reg1) // dec reg1
ELSE
PushEAX
addrc(reg1, param2)
END
END
|CODE.opSUB:
BinOp(reg1, reg2);
OutByte2(29H, 0C0H + reg2 * 8 + reg1); // sub reg1, reg2
drop
|CODE.opSUBR, CODE.opSUBL:
UnOp(reg1);
n := param2;
IF n = 1 THEN
OutByte(48H + reg1) // dec reg1
ELSIF n = -1 THEN
OutByte(40H + reg1) // inc reg1
ELSIF n # 0 THEN
subrc(reg1, n)
END;
OutCode("0BC25933C8E3046A00EB026A01")
END Inclusion;
IF cmd.opcode = CODE.opSUBL THEN
neg(reg1)
END
PROCEDURE NegInt*;
BEGIN
OutCode("F71C24")
END NegInt;
|CODE.opMULC:
UnOp(reg1);
PROCEDURE CmpInt*(Op: INTEGER);
VAR n: INTEGER;
BEGIN
OutCode("33C95A583BC20F"); current.tcmd := ICMP1;
CASE Op OF
|lxEQ: n := 94H
|lxNE: n := 95H
|lxLT: n := 9CH
|lxGT: n := 9FH
|lxLE: n := 9EH
|lxGE: n := 9DH
a := param2;
IF a > 1 THEN
n := log2(a)
ELSIF a < -1 THEN
n := log2(-a)
ELSE
n := -1
END;
OutByte(n);
OutByte(0C1H); current.tcmd := ICMP2;
PushECX;
END CmpInt;
PROCEDURE CallVar*(func, float: BOOLEAN; callconv, parsize, local: INTEGER);
BEGIN
PopEDX;
OutCode("8B1285D2750A");
OnError(2);
FpuSave(local);
OutCode("FFD2");
AfterRet(func, float, callconv, parsize);
FpuLoad(local, func & float)
END CallVar;
IF a = 1 THEN
PROCEDURE LocalAdr*(offset, bases: INTEGER);
BEGIN
IF bases = 0 THEN
Empty(offset);
OutCode("8BD5")
ELSIF a = -1 THEN
neg(reg1)
ELSIF a = 0 THEN
OutByte2(31H, 0C0H + reg1 * 9) // xor reg1, reg1
ELSE
IntByte("8B55", "8B95", 4 * bases + 4)
IF n > 0 THEN
IF a < 0 THEN
neg(reg1)
END;
IntByte("83C2", "81C2", offset);
PushEDX;
IF bases = 0 THEN
Empty(offset)
END
END LocalAdr;
PROCEDURE Field*(offset: INTEGER);
BEGIN
IF offset # 0 THEN
IntByte("830424", "810424", offset)
IF n # 1 THEN
OutByte3(0C1H, 0E0H + reg1, n) // shl reg1, n
ELSE
OutByte2(0D1H, 0E0H + reg1) // shl reg1, 1
END
END Field;
ELSE
OutByte2(69H + short(a), 0C0H + reg1 * 9); // imul reg1, a
OutIntByte(a)
END
END
PROCEDURE DerefType*(n: INTEGER);
BEGIN
IntByte("8B5424", "8B9424", n);
OutCode("FF72FC")
END DerefType;
|CODE.opMUL:
BinOp(reg1, reg2);
OutByte3(0FH, 0AFH, 0C0H + reg1 * 8 + reg2); // imul reg1, reg2
drop
PROCEDURE Guard*(T: INTEGER; Check: BOOLEAN);
BEGIN
IF Check THEN
PopEAX;
OutCode("85C074");
IF T <= 127 THEN
OutByte(9)
|CODE.opSAVE, CODE.opSAVE32:
BinOp(reg2, reg1);
OutByte2(89H, reg2 * 8 + reg1); // mov dword[reg1], reg2
drop;
drop
|CODE.opSAVE8:
BinOp(reg2, reg1);
OutByte2(88H, reg2 * 8 + reg1); // mov byte[reg1], reg2
drop;
drop
|CODE.opSAVE16:
BinOp(reg2, reg1);
OutByte3(66H, 89H, reg2 * 8 + reg1); // mov word[reg1], reg2
drop;
drop
|CODE.opSAVEP:
UnOp(reg1);
IF pic THEN
reg2 := REG.GetAnyReg(R);
Pic(reg2, BIN.PICCODE, param2);
OutByte2(089H, reg2 * 8 + reg1); // mov dword[reg1], reg2
drop
ELSE
OutByte(12)
OutByte2(0C7H, reg1); // mov dword[reg1], L
Reloc(BIN.RCODE, param2)
END;
PushEAX
drop
|CODE.opSAVEIP:
UnOp(reg1);
IF pic THEN
reg2 := REG.GetAnyReg(R);
Pic(reg2, BIN.PICIMP, param2);
OutByte2(0FFH, 30H + reg2); // push dword[reg2]
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;
PushConst(T);
PushEAX;
CallRTL(_checktype);
IF Check THEN
PushEAX
drop
|CODE.opPUSHP:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICCODE, param2)
ELSE
OutCode("85C0750A");
OnError(3)
OutByte(0B8H + reg1); // mov reg1, L
Reloc(BIN.RCODE, param2)
END
END Guard;
PROCEDURE StProc*(proc: INTEGER);
BEGIN
CASE proc OF
|stINC: PopEDX; OutCode("590111")
|stDEC: PopEDX; OutCode("592911")
|stINC1: PopEDX; OutCode("FF02")
|stDEC1: PopEDX; OutCode("FF0A")
|stINCL: PopEDX; OutCode("580910")
|stEXCL: PopEDX; OutCode("582110")
|stPACK: OutCode("DB04245A5ADD02D9FDDD1A"); isfpu := TRUE
|stPACK1: OutCode("DB04245A5AD902D9FDD91A"); isfpu := TRUE
|stUNPK: PopEDX; OutCode("59DD01D9F4DD19DB1A"); isfpu := TRUE
|stUNPK1: PopEDX; OutCode("59D901D9F4D919DB1A"); isfpu := TRUE
|stCOPY: CallRTL(_strcopy)
|sysMOVE: CallRTL(_savearr)
|CODE.opPUSHIP:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICIMP, param2);
OutByte2(08BH, reg1 * 9) // mov reg1, dword[reg1]
ELSE
OutByte2(08BH, 05H + reg1 * 8); // mov reg1, dword[L]
Reloc(BIN.RIMP, param2)
END
END StProc;
PROCEDURE Assert*(proc, assrt: INTEGER);
BEGIN
PopEDX;
OutCode("85D2751368");
OutInt(UTILS.Line * 16 + 1);
PushInt(UTILS.Unit + 2);
IF proc = stASSERT THEN
OutCode("6A026A")
|CODE.opNOT:
UnOp(reg1);
test(reg1);
setcc(sete, reg1);
andrc(reg1, 1)
|CODE.opORD:
UnOp(reg1);
test(reg1);
setcc(setne, reg1);
andrc(reg1, 1)
|CODE.opSBOOL:
BinOp(reg2, reg1);
test(reg2);
setcc(setne, reg2);
OutByte2(88H, reg2 * 8 + reg1); // mov byte[reg1], reg2
drop;
drop
|CODE.opSBOOLC:
UnOp(reg1);
OutByte3(0C6H, reg1, ORD(param2 # 0)); // mov byte[reg1], 0/1
drop
|CODE.opODD:
UnOp(reg1);
andrc(reg1, 1)
|CODE.opGTR, CODE.opLTL, CODE.opGER, CODE.opLEL,
CODE.opLER, CODE.opGEL, CODE.opLTR, CODE.opGTL,
CODE.opEQR, CODE.opEQL, CODE.opNER, CODE.opNEL:
UnOp(reg1);
IF param2 = 0 THEN
test(reg1)
ELSE
OutCode("6A016A")
cmprc(reg1, param2)
END;
OutByte(assrt);
jmplong(JMP, ASSRT)
END Assert;
drop;
cc := cond(cmd.opcode);
PROCEDURE StFunc*(func: INTEGER);
BEGIN
CASE func OF
|stABS: PopEDX; OutCode("85D27D02F7DA"); PushEDX
|stFABS: OutCode("D9E1")
|stFLT: OutCode("DB0424"); PopEAX; Incfpu;
|stFLOOR: jmplong(CALL, _floor); PushEAX; DEC(fpu)
|stODD: OutCode("83242401")
|stROR: PopECX; OutCode("58D3C8"); PushEAX
|stASR: PopECX; OutCode("58D3F8"); PushEAX
|stLSL: PopECX; OutCode("58D3E0"); PushEAX
|stLSR: PopECX; OutCode("58D3E8"); PushEAX
|stORD: PopEDX; OutCode("85D274036A015A"); PushEDX;
|stMIN: PopEDX; OutCode("3914247E025852");
|stMAX: PopEDX; OutCode("3B14247E025852");
|stLENGTH: CallRTL(_length); PushEAX
ELSE
END
END StFunc;
IF cmd.next(COMMAND).opcode = CODE.opJE THEN
label := cmd.next(COMMAND).param1;
jcc(cc, label);
cmd := cmd.next(COMMAND)
PROCEDURE Load*(T: INTEGER);
VAR lastcmd: ASMLINE; offset: INTEGER;
ELSIF cmd.next(COMMAND).opcode = CODE.opJNE THEN
label := cmd.next(COMMAND).param1;
jcc(inv1(cc), label);
cmd := cmd.next(COMMAND)
PROCEDURE del;
BEGIN
lastcmd.tcmd := 0;
offset := lastcmd.varadr;
lastcmd := lastcmd.Prev(ASMLINE);
WHILE lastcmd.tcmd # ECMD DO
lastcmd.clen := 0;
lastcmd.tcmd := 0;
lastcmd := lastcmd.Prev(ASMLINE)
ELSE
reg1 := REG.GetAnyReg(R);
setcc(cc + 16, reg1);
andrc(reg1, 1)
END;
lastcmd.tcmd := 0
END del;
BEGIN
lastcmd := current;
CASE T OF
|TINTEGER, TSET, TPOINTER, TPROC:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("8B55", "8B95", offset);
PushEDX
|CODE.opGT, CODE.opGE, CODE.opLT,
CODE.opLE, CODE.opEQ, CODE.opNE:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
drop;
drop;
cc := cond(cmd.opcode);
IF cmd.next(COMMAND).opcode = CODE.opJE THEN
label := cmd.next(COMMAND).param1;
jcc(cc, label);
cmd := cmd.next(COMMAND)
ELSIF cmd.next(COMMAND).opcode = CODE.opJNE THEN
label := cmd.next(COMMAND).param1;
jcc(inv1(cc), label);
cmd := cmd.next(COMMAND)
ELSE
PopEDX;
OutCode("FF32")
reg1 := REG.GetAnyReg(R);
setcc(cc + 16, reg1);
andrc(reg1, 1)
END
|TCHAR, TBOOLEAN:
IF lastcmd.tcmd = ECMD THEN
del;
OutCode("0FB6");
IntByte("55", "95", offset);
PushEDX
|CODE.opEQB, CODE.opNEB:
BinOp(reg1, reg2);
drop;
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);
reg1 := REG.GetAnyReg(R);
IF cmd.opcode = CODE.opEQB THEN
setcc(sete, reg1)
ELSE
PopEDX;
OutCode("0FB60A");
PushECX
END
|TLONGREAL:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("DD45", "DD85", offset)
ELSE
PopEDX;
OutCode("DD02")
setcc(setne, reg1)
END;
Incfpu
|TREAL:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("D945", "D985", offset)
andrc(reg1, 1)
|CODE.opDROP:
UnOp(reg1);
drop
|CODE.opJNZ:
UnOp(reg1);
test(reg1);
jcc(jne, param1)
|CODE.opJZ:
UnOp(reg1);
test(reg1);
jcc(je, param1)
|CODE.opJE:
UnOp(reg1);
test(reg1);
jcc(jne, param1);
drop;
|CODE.opJNE:
UnOp(reg1);
test(reg1);
jcc(je, param1);
drop;
|CODE.opSWITCH:
UnOp(reg1);
IF param2 = 0 THEN
reg2 := eax
ELSE
PopEDX;
OutCode("D902")
reg2 := ecx
END;
Incfpu
|TCARD16:
IF lastcmd.tcmd = ECMD THEN
del;
OutCode("33D2668B");
IntByte("55", "95", offset);
PushEDX
ELSE
PopEDX;
OutCode("33C9668B0A");
PushECX
IF reg1 # reg2 THEN
ASSERT(REG.GetReg(R, reg2));
ASSERT(REG.Exchange(R, reg1, reg2));
drop
END;
drop
|CODE.opENDSW:
|CODE.opCASEL:
cmprc(eax, param1);
jcc(jl, param2)
|CODE.opCASER:
cmprc(eax, param1);
jcc(jg, param2)
|CODE.opCASELR:
cmprc(eax, param1);
jcc(jl, param2);
jcc(jg, cmd.param3)
|CODE.opCODE:
OutByte(param2)
|CODE.opGET:
BinOp(reg1, reg2);
drop;
drop;
CASE param2 OF
|1:
OutByte2(8AH, reg1 * 9); // mov reg1, byte[reg1]
OutByte2(88H, reg1 * 8 + reg2) // mov byte[reg2], reg1
|2:
OutByte3(66H, 8BH, reg1 * 9); // mov reg1, word[reg1]
OutByte3(66H, 89H, reg1 * 8 + reg2) // mov word[reg2], reg1
|4:
OutByte2(8BH, reg1 * 9); // mov reg1, dword[reg1]
OutByte2(89H, reg1 * 8 + reg2) // mov dword[reg2], reg1
|8:
PushAll(0);
push(reg2);
push(reg1);
pushc(8);
CallRTL(pic, CODE._move)
END
|CODE.opSAVES:
UnOp(reg1);
drop;
PushAll(0);
push(reg1);
IF pic THEN
Pic(reg1, BIN.PICDATA, stroffs + param2);
push(reg1)
ELSE
END
END Load;
OutByte(068H); // push _data + stroffs + param2
Reloc(BIN.RDATA, stroffs + param2);
END;
PROCEDURE Save*(T: INTEGER);
BEGIN
CASE T OF
|TINTEGER, TSET, TPOINTER, TPROC:
PopEDX;
OutCode("588910")
|TCHAR, TSTRING, TBOOLEAN:
PopEDX;
OutCode("588810")
|TCARD16:
PopEDX;
OutCode("58668910")
|TLONGREAL:
PopEDX;
OutCode("DD1A");
DEC(fpu)
|TREAL:
PopEDX;
OutCode("D91A");
DEC(fpu)
|TRECORD:
CallRTL(_saverec);
OutCode("85C0750A");
OnError(4)
|TARRAY:
CallRTL(_savearr)
pushc(param1);
CallRTL(pic, CODE._move)
|CODE.opCHKBYTE:
BinOp(reg1, reg2);
cmprc(reg1, 256);
jcc(jb, param1)
|CODE.opCHKIDX:
UnOp(reg1);
cmprc(reg1, param2);
jcc(jb, param1)
|CODE.opCHKIDX2:
BinOp(reg1, reg2);
IF param2 # -1 THEN
cmprr(reg2, reg1);
mov(reg1, reg2);
drop;
jcc(jb, param1)
ELSE
INCL(R.regs, reg1);
DEC(R.top);
R.stk[R.top] := reg2
END
END Save;
PROCEDURE OpenArray*(A: TIDX; n: INTEGER);
VAR i: INTEGER;
BEGIN
PopEDX;
FOR i := n - 1 TO 0 BY -1 DO
PushConst(A[i])
|CODE.opLEN:
n := param2;
UnOp(reg1);
drop;
EXCL(R.regs, reg1);
WHILE n > 0 DO
UnOp(reg2);
drop;
DEC(n)
END;
PushEDX
END OpenArray;
PROCEDURE OpenIdx*(n: INTEGER);
BEGIN
OutByte(54H);
IF n > 1 THEN
PushConst(n);
CallRTL(_arrayidx)
INCL(R.regs, reg1);
ASSERT(REG.GetReg(R, reg1))
|CODE.opINC1:
UnOp(reg1);
OutByte2(0FFH, reg1); // inc dword[reg1]
drop
|CODE.opDEC1:
UnOp(reg1);
OutByte2(0FFH, 8 + reg1); // dec dword[reg1]
drop
|CODE.opINCC:
UnOp(reg1);
n := param2;
OutByte2(81H + short(n), reg1); OutIntByte(n); // add dword[reg1], n
drop
|CODE.opDECC:
UnOp(reg1);
n := param2;
OutByte2(81H + short(n), 28H + reg1); OutIntByte(n); // sub dword[reg1], n
drop
|CODE.opINC:
BinOp(reg1, reg2);
OutByte2(01H, reg1 * 8 + reg2); // add dword[reg2], reg1
drop;
drop
|CODE.opDEC:
BinOp(reg1, reg2);
OutByte2(29H, reg1 * 8 + reg2); // sub dword[reg2], reg1
drop;
drop
|CODE.opINC1B:
UnOp(reg1);
OutByte2(0FEH, reg1); // inc byte[reg1]
drop
|CODE.opDEC1B:
UnOp(reg1);
OutByte2(0FEH, 08H + reg1); // dec byte[reg1]
drop
|CODE.opINCCB:
UnOp(reg1);
OutByte3(80H, reg1, Byte(param2)); // add byte[reg1], n
drop
|CODE.opDECCB:
UnOp(reg1);
OutByte3(80H, 28H + reg1, Byte(param2)); // sub byte[reg1], n
drop
|CODE.opINCB, CODE.opDECB:
BinOp(reg1, reg2);
IF cmd.opcode = CODE.opINCB THEN
OutByte2(00H, reg1 * 8 + reg2) // add byte[reg2], reg1
ELSE
CallRTL(_arrayidx1)
OutByte2(28H, reg1 * 8 + reg2) // sub byte[reg2], reg1
END;
PopEDX;
OutCode("85D2750A");
OnError(5);
PushEDX;
END OpenIdx;
drop;
drop
PROCEDURE FixIdx*(len, size: INTEGER);
BEGIN
PopEDX;
IntByte("5983FA", "5981FA", len);
OutCode("720A");
OnError(5);
IF size > 1 THEN
IntByte("6BD2", "69D2", size)
END;
OutCode("03D1");
PushEDX
END FixIdx;
|CODE.opMULS:
BinOp(reg1, reg2);
OutByte2(21H, 0C0H + reg2 * 8 + reg1); // and reg1, reg2
drop
PROCEDURE Idx*;
BEGIN
PopEDX;
PopECX;
OutCode("03D1");
PushEDX
END Idx;
|CODE.opMULSC:
UnOp(reg1);
andrc(reg1, param2)
PROCEDURE DupLoadCheck*;
BEGIN
PopEDX;
OutCode("528B125285D2750A");
OnError(6)
END DupLoadCheck;
|CODE.opDIVS:
BinOp(reg1, reg2);
OutByte2(31H, 0C0H + reg2 * 8 + reg1); // xor reg1, reg2
drop
PROCEDURE DupLoad*;
BEGIN
PopEDX;
OutCode("528B12");
PushEDX;
END DupLoad;
|CODE.opDIVSC:
UnOp(reg1);
OutByte2(81H + short(param2), 0F0H + reg1); // xor reg1, n
OutIntByte(param2)
PROCEDURE CheckNIL*;
BEGIN
PopEDX;
OutCode("85D2750A");
OnError(6);
PushEDX;
END CheckNIL;
|CODE.opADDS:
BinOp(reg1, reg2);
OutByte2(9H, 0C0H + reg2 * 8 + reg1); // or reg1, reg2
drop
PROCEDURE ExtArray*(A: TIDX; n, m: INTEGER);
VAR i: INTEGER;
BEGIN
FOR i := n - 1 TO 0 BY -1 DO
PushConst(A[i])
|CODE.opSUBS:
BinOp(reg1, reg2);
not(reg2);
OutByte2(21H, 0C0H + reg2 * 8 + reg1); // and reg1, reg2
drop
|CODE.opADDSL, CODE.opADDSR:
UnOp(reg1);
orrc(reg1, param2)
|CODE.opSUBSL:
UnOp(reg1);
not(reg1);
andrc(reg1, param2)
|CODE.opSUBSR:
UnOp(reg1);
andrc(reg1, ORD(-BITS(param2)));
|CODE.opUMINS:
UnOp(reg1);
not(reg1)
|CODE.opLENGTH:
PushAll(2);
CallRTL(pic, CODE._length);
GetRegA
|CODE.opLENGTHW:
PushAll(2);
CallRTL(pic, CODE._lengthw);
GetRegA
|CODE.opCHR:
UnOp(reg1);
andrc(reg1, 255)
|CODE.opWCHR:
UnOp(reg1);
andrc(reg1, 65535)
|CODE.opASR, CODE.opROR, CODE.opLSL, CODE.opLSR:
UnOp(reg1);
IF reg1 # ecx THEN
ASSERT(REG.GetReg(R, ecx));
ASSERT(REG.Exchange(R, reg1, ecx));
drop
END;
OutByte(54H);
PushConst(n);
PushConst(m);
CallRTL(_arrayrot)
END ExtArray;
PROCEDURE ADR*(dim: INTEGER);
BEGIN
IF dim > 0 THEN
PopEDX;
OutCode("83C4");
OutByte(dim * 4);
PushEDX
END
END ADR;
BinOp(reg1, reg2);
ASSERT(reg2 = ecx);
OutByte(0D3H);
shift(cmd.opcode, reg1); // shift reg1, cl
drop
PROCEDURE Len*(dim: INTEGER);
BEGIN
PopEDX;
IF dim < 0 THEN
PushConst(-dim)
ELSIF dim > 1 THEN
PopEDX;
OutCode("83C4");
OutByte((dim - 1) * 4);
PushEDX
END
END Len;
|CODE.opASR1, CODE.opROR1, CODE.opLSL1, CODE.opLSR1:
UnOp(reg1);
IF reg1 # ecx THEN
ASSERT(REG.GetReg(R, ecx));
ASSERT(REG.Exchange(R, reg1, ecx));
drop
END;
PROCEDURE For*(inc: BOOLEAN; VAR LBeg, LEnd: INTEGER);
BEGIN
LEnd := NewLabel();
LBeg := NewLabel();
Label(LBeg);
OutCode("8B14248B4424043910");
IF inc THEN
jmp(JG, LEnd)
reg1 := REG.GetAnyReg(R);
movrc(reg1, param2);
BinOp(reg1, reg2);
ASSERT(reg1 = ecx);
OutByte(0D3H);
shift(cmd.opcode, reg2); // shift reg2, cl
drop;
drop;
ASSERT(REG.GetReg(R, reg2))
|CODE.opASR2, CODE.opROR2, CODE.opLSL2, CODE.opLSR2:
UnOp(reg1);
n := ORD(BITS(param2) * {0..4});
IF n # 1 THEN
OutByte(0C1H)
ELSE
jmp(JL, LEnd)
OutByte(0D1H)
END;
shift(cmd.opcode, reg1); // shift reg1, n
IF n # 1 THEN
OutByte(n)
END
END For;
PROCEDURE NextFor*(step, LBeg, LEnd: INTEGER);
BEGIN
OutCode("8B542404");
IF step = 1 THEN
OutCode("FF02")
ELSIF step = -1 THEN
OutCode("FF0A")
|CODE.opMIN:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(07EH, 002H); // jle @f
mov(reg1, reg2); // mov reg1, reg2
// @@:
drop
|CODE.opMAX:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(07DH, 002H); // jge @f
mov(reg1, reg2); // mov reg1, reg2
// @@:
drop
|CODE.opMINC:
UnOp(reg1);
cmprc(reg1, param2);
OutByte2(07EH, 005H); // jle @f
movrc(reg1, param2); // mov reg1, param2
// @@:
|CODE.opMAXC:
UnOp(reg1);
cmprc(reg1, param2);
OutByte2(07DH, 005H); // jge @f
movrc(reg1, param2); // mov reg1, param2
// @@:
|CODE.opIN:
label := NewLabel();
BinOp(reg1, reg2);
cmprc(reg1, 32);
OutByte2(72H, 4); // jb L
OutByte2(31H, 0C0H + reg1 * 9); // 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
|CODE.opINR:
label := NewLabel();
UnOp(reg1);
reg2 := REG.GetAnyReg(R);
cmprc(reg1, 32);
OutByte2(72H, 4); // jb L
OutByte2(31H, 0C0H + reg1 * 9); // xor reg1, reg1
jmp(label);
//L:
movrc(reg2, param2);
OutByte3(0FH, 0A3H, 0C0H + reg2 + 8 * reg1); // bt reg2, reg1
setcc(setc, reg1);
andrc(reg1, 1);
SetLabel(label);
drop
|CODE.opINL:
UnOp(reg1);
OutByte3(0FH, 0BAH, 0E0H + reg1); OutByte(param2); // bt reg1, param2
setcc(setc, reg1);
andrc(reg1, 1)
|CODE.opRSET:
PushAll(2);
CallRTL(pic, CODE._set);
GetRegA
|CODE.opRSETR:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._set);
GetRegA
|CODE.opRSETL:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._set2);
GetRegA
|CODE.opRSET1:
UnOp(reg1);
PushAll(1);
push(reg1);
CallRTL(pic, CODE._set);
GetRegA
|CODE.opINCL, CODE.opEXCL:
BinOp(reg1, reg2);
cmprc(reg1, 32);
OutByte2(73H, 03H); // jnb L
OutByte(0FH);
IF cmd.opcode = CODE.opINCL THEN
OutByte(0ABH) // bts dword[reg2], reg1
ELSE
IntByte("8302", "8102", step)
OutByte(0B3H) // btr dword[reg2], reg1
END;
jmp(JMP, LBeg);
Label(LEnd);
OutCode("83C408")
END NextFor;
OutByte(reg2 + 8 * reg1);
//L:
drop;
drop
PROCEDURE CaseLabel*(a, b, LBeg: INTEGER);
VAR L: INTEGER;
BEGIN
L := NewLabel();
IntByte("83FA", "81FA", a);
IF a = b THEN
jmp(JNE, L)
|CODE.opINCLC:
UnOp(reg1);
OutByte3(0FH, 0BAH, 28H + reg1); OutByte(param2); //bts dword[reg1],param2
drop
|CODE.opEXCLC:
UnOp(reg1);
OutByte3(0FH, 0BAH, 30H + reg1); OutByte(param2); //btr dword[reg1],param2
drop
|CODE.opDIV:
PushAll(2);
CallRTL(pic, CODE._div);
GetRegA
|CODE.opDIVR:
a := param2;
IF a > 1 THEN
n := log2(a)
ELSIF a < -1 THEN
n := log2(-a)
ELSE
jmp(JL, L);
IntByte("83FA", "81FA", b);
jmp(JG, L)
n := -1
END;
jmp(JMP, LBeg);
Label(L)
END CaseLabel;
PROCEDURE Drop*;
BEGIN
PopEDX
END Drop;
IF a = 1 THEN
PROCEDURE strcmp*(Op, LR: INTEGER);
BEGIN
CASE Op OF
|lxEQ: PushConst(0)
|lxNE: PushConst(1)
|lxLT: PushConst(2)
|lxGT: PushConst(3)
|lxLE: PushConst(4)
|lxGE: PushConst(5)
ELSIF a = -1 THEN
UnOp(reg1);
neg(reg1)
ELSE
IF n > 0 THEN
UnOp(reg1);
IF a < 0 THEN
reg2 := REG.GetAnyReg(R);
mov(reg2, reg1);
IF n # 1 THEN
OutByte3(0C1H, 0F8H + reg1, n) // sar reg1, n
ELSE
OutByte2(0D1H, 0F8H + reg1) // sar reg1, 1
END;
CASE LR OF
|-1: CallRTL(_lstrcmp)
| 0: CallRTL(_strcmp)
| 1: CallRTL(_rstrcmp)
OutByte2(29H, 0C0H + reg2 * 8 + reg1); // sub reg1, reg2
drop
ELSE
END;
PushEAX
END strcmp;
IF n # 1 THEN
OutByte3(0C1H, 0F8H + reg1, n) // sar reg1, n
ELSE
OutByte2(0D1H, 0F8H + reg1) // sar reg1, 1
END
END
PROCEDURE Optimization;
VAR cur: ASMLINE; flag: BOOLEAN;
BEGIN
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
flag := FALSE;
CASE cur.tcmd OF
|PUSHEAX:
flag := cur.Next(ASMLINE).tcmd = POPEAX
|PUSHECX:
flag := cur.Next(ASMLINE).tcmd = POPECX
|PUSHEDX:
flag := cur.Next(ASMLINE).tcmd = POPEDX
ELSE
END;
IF flag THEN
cur.clen := 0;
cur.tcmd := 0;
cur := cur.Next(ASMLINE);
cur.clen := 0;
cur.tcmd := 0
END;
cur := cur.Next(ASMLINE)
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._div);
GetRegA
END
END Optimization;
END
PROCEDURE WriteKOS(FName: ARRAY OF CHAR; stk, size, datasize, gsize: INTEGER; obj: BOOLEAN);
CONST strsize = 2048;
VAR Header: KOSHEADER; F, i, filesize, filebuf, a, sec, adr, size2: INTEGER; cur: ASMLINE;
Coff: COFFHEADER; sym: ARRAY 18 * 4 OF CHAR; FileName: UTILS.STRING;
BEGIN
F := UTILS.CreateF(FName);
IF F <= 0 THEN
Err(1)
|CODE.opDIVL:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._div2);
GetRegA
|CODE.opMOD:
PushAll(2);
CallRTL(pic, CODE._mod);
GetRegA
|CODE.opMODR:
a := param2;
IF a > 1 THEN
n := log2(a)
ELSIF a < -1 THEN
n := log2(-a)
ELSE
n := -1
END;
OutFilePos := UTILS.GetMem(Align(size, 4) + datasize + 1000H);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
IF ~obj THEN
Header.menuet01 := "MENUET01";
Header.ver := 1;
Header.start := sys.SIZE(KOSHEADER) + ORD(kem) * 65536;
Header.size := Align(size, 4) + datasize;
Header.mem := Header.size + stk + gsize + strsize * 2 + 1000H;
Header.sp := Header.size + gsize + stk;// + ORD(kem) * 65536;
Header.param := Header.sp;
Header.path := Header.param + strsize;
IF ABS(a) = 1 THEN
UnOp(reg1);
OutByte2(31H, 0C0H + reg1 * 9) // xor reg1, reg1
ELSE
IF n > 0 THEN
UnOp(reg1);
andrc(reg1, ABS(a) - 1);
Write(sys.ADR(Header), sys.SIZE(KOSHEADER));
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
IF a < 0 THEN
test(reg1);
OutByte(74H); // je @f
IF isByte(a) THEN
OutByte(3)
ELSE
OutByte(6)
END;
Fill(Align(size, 4) - size, 0X);
Write(sys.ADR(Data), datasize);
WriteF(F, filebuf, OutFilePos - filebuf)
addrc(reg1, a)
// @@:
END
ELSE
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._mod);
GetRegA
END
END
size2 := size;
size := Align(size, 4) - sys.SIZE(KOSHEADER);
Coff.Machine := IntToCard16(014CH);
Coff.NumberOfSections := IntToCard16(3);
Coff.TimeDateStamp := UTILS.Date;
Coff.SizeOfOptionalHeader := IntToCard16(0);
Coff.Characteristics := IntToCard16(0184H);
|CODE.opMODL:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._mod2);
GetRegA
Coff.text.name := ".flat";
Coff.text.size := 0;
Coff.text.adr := 0;
Coff.text.sizealign := size;
Coff.text.OAPfile := 8CH;
Coff.text.reserved6 := size + datasize + 8CH;
Coff.text.reserved7 := 0;
Coff.text.attrflags := 40300020H;
|CODE.opERR:
CallRTL(pic, CODE._error)
Coff.data.name := ".data";
Coff.data.size := 0;
Coff.data.adr := 0;
Coff.data.sizealign := datasize;
Coff.data.OAPfile := size + 8CH;
Coff.data.reserved6 := 0;
Coff.data.reserved7 := 0;
Coff.data.reserved8 := 0;
Coff.data.attrflags := 0C0300040H;
|CODE.opABS:
UnOp(reg1);
test(reg1);
OutByte2(07DH, 002H); // jge @f
neg(reg1); // neg reg1
// @@:
Coff.bss.name := ".bss";
Coff.bss.size := 0;
Coff.bss.adr := 0;
Coff.bss.sizealign := gsize;
Coff.bss.OAPfile := 0;
Coff.bss.reserved6 := 0;
Coff.bss.reserved7 := 0;
Coff.bss.reserved8 := 0;
Coff.bss.attrflags := 0C03000C0H;
|CODE.opCOPY:
PushAll(2);
pushc(param2);
CallRTL(pic, CODE._move2)
size := Align(size2, 4);
rcount := 0;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
IF cur.tcmd IN {OCMD, GCMD} THEN
sys.GET(sys.ADR(Code[cur.cmd]), a);
IF a < size THEN
a := a - sys.SIZE(KOSHEADER);
sec := 1
ELSIF a < size + datasize THEN
a := a - size;
sec := 2
|CODE.opMOVE:
PushAll(3);
CallRTL(pic, CODE._move2)
|CODE.opCOPYA:
PushAll(4);
pushc(param2);
CallRTL(pic, CODE._arrcpy);
GetRegA
|CODE.opCOPYS:
PushAll(4);
pushc(param2);
CallRTL(pic, CODE._strcpy)
|CODE.opCOPYS2:
PushAll(4);
pushc(param2);
CallRTL(pic, CODE._strcpy2)
|CODE.opROT:
PushAll(0);
push(esp);
pushc(param2);
CallRTL(pic, CODE._rot)
|CODE.opNEW:
PushAll(1);
n := param2 + 8;
ASSERT(MACHINE.Align(n, 32));
pushc(n);
pushc(param1);
CallRTL(pic, CODE._new)
|CODE.opDISP:
PushAll(1);
CallRTL(pic, CODE._dispose)
|CODE.opEQS .. CODE.opGES:
PushAll(4);
pushc(cmd.opcode - CODE.opEQS);
CallRTL(pic, CODE._strcmp);
GetRegA
|CODE.opEQS2 .. CODE.opGES2:
PushAll(4);
pushc(cmd.opcode - CODE.opEQS2);
CallRTL(pic, CODE._strcmp2);
GetRegA
|CODE.opEQSW .. CODE.opGESW:
PushAll(4);
pushc(cmd.opcode - CODE.opEQSW);
CallRTL(pic, CODE._strcmpw);
GetRegA
|CODE.opEQSW2 .. CODE.opGESW2:
PushAll(4);
pushc(cmd.opcode - CODE.opEQSW2);
CallRTL(pic, CODE._strcmpw2);
GetRegA
|CODE.opEQP, CODE.opNEP, CODE.opEQIP, CODE.opNEIP:
UnOp(reg1);
CASE cmd.opcode OF
|CODE.opEQP, CODE.opNEP:
IF pic THEN
reg2 := REG.GetAnyReg(R);
Pic(reg2, BIN.PICCODE, param1);
cmprr(reg1, reg2);
drop
ELSE
a := a - size - datasize;
sec := 3
OutByte2(081H, 0F8H + reg1); // cmp reg1, L
Reloc(BIN.RCODE, param1)
END
|CODE.opEQIP, CODE.opNEIP:
IF pic THEN
reg2 := REG.GetAnyReg(R);
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;
sys.PUT(sys.ADR(Code[cur.cmd]), a);
sys.PUT(sys.ADR(Reloc[rcount]), cur.adr - sys.SIZE(KOSHEADER));
INC(rcount, 4);
sys.PUT(sys.ADR(Reloc[rcount]), sec);
INC(rcount, 4);
sys.PUT(sys.ADR(Reloc[rcount]), 06X); INC(rcount);
sys.PUT(sys.ADR(Reloc[rcount]), 00X); INC(rcount);
drop;
reg1 := REG.GetAnyReg(R);
CASE cmd.opcode OF
|CODE.opEQP, CODE.opEQIP: setcc(sete, reg1)
|CODE.opNEP, CODE.opNEIP: setcc(setne, reg1)
END;
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
size := size2;
Fill(Align(size, 4) - size2, 0X);
Write(sys.ADR(Data), datasize);
Coff.text.reserved8 := rcount DIV 10;
Coff.PointerToSymbolTable := Coff.text.reserved6 + rcount;
Coff.NumberOfSymbols := 4;
WriteF(F, sys.ADR(Coff), sys.SIZE(COFFHEADER));
WriteF(F, filebuf, OutFilePos - filebuf);
WriteF(F, sys.ADR(Reloc), rcount);
andrc(reg1, 1)
adr := sys.ADR(sym);
InitArray(adr, "4558504F52545300000000000100000002002E666C617400000000000000010000000300");
InitArray(adr, "2E64617461000000000000000200000003002E6273730000000000000000030000000300");
sys.PUT(sys.ADR(sym) + 8, Labels[Exports] - sys.SIZE(KOSHEADER));
|CODE.opPUSHT:
UnOp(reg1);
reg2 := REG.GetAnyReg(R);
OutByte3(8BH, 40H + reg2 * 8 + reg1, 0FCH) // mov reg2, dword[reg1 - 4]
WriteF(F, sys.ADR(sym), LEN(sym));
i := 4;
WriteF(F, sys.ADR(i), 4)
END;
UTILS.CloseF(F)
END WriteKOS;
|CODE.opISREC:
PushAll(2);
pushc(param2);
CallRTL(pic, CODE._isrec);
GetRegA
PROCEDURE WriteELF(FName: ARRAY OF CHAR; code, data, glob: INTEGER);
VAR F, delta, filebuf: INTEGER; cur: ASMLINE; bytes: ARRAY 817H + 55FH + 4900 OF CHAR;
|CODE.opIS:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._is);
GetRegA
PROCEDURE Add(offset: INTEGER);
VAR m: INTEGER;
BEGIN
sys.GET(sys.ADR(bytes[offset]), m);
sys.PUT(sys.ADR(bytes[offset]), m + delta)
END Add;
|CODE.opTYPEGR:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._guardrec);
GetRegA
PROCEDURE Sub(offset: INTEGER);
VAR m: INTEGER;
BEGIN
sys.GET(sys.ADR(bytes[offset]), m);
sys.PUT(sys.ADR(bytes[offset]), m - delta)
END Sub;
|CODE.opTYPEGP:
UnOp(reg1);
PushAll(0);
push(reg1);
pushc(param2);
CallRTL(pic, CODE._guard);
GetRegA
PROCEDURE Add8(a1, a2, a3, a4, a5, a6, a7, a8: INTEGER);
BEGIN
Add(a1); Add(a2); Add(a3); Add(a4);
Add(a5); Add(a6); Add(a7); Add(a8)
END Add8;
|CODE.opTYPEGD:
UnOp(reg1);
PushAll(0);
OutByte3(0FFH, 070H + reg1, 0FCH); // push dword[reg1 - 4]
pushc(param2);
CallRTL(pic, CODE._guardrec);
GetRegA
BEGIN
sys.MOVE(ELF.get(), sys.ADR(bytes[0]), ELF.size);
|CODE.opCASET:
push(ecx);
push(ecx);
pushc(param2);
CallRTL(pic, CODE._guardrec);
pop(ecx);
test(eax);
jcc(jne, param1)
DEC(code, 13);
|CODE.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
delta := Align(data, 1000H) - 100000H;
Add8(0020H, 00A4H, 00A8H, 0258H, 02B8H, 0308H, 0494H, 049CH);
Add8(04A4H, 0679H, 0681H, 06A4H, 06B0H, 06BAH, 0703H, 0762H);
Add8(0774H, 0786H, 0819H, 0823H, 17C5H, 17E5H, 17E9H, 1811H);
Add8(1839H, 1861H, 1889H, 1A25H, 1A95H, 1AA5H, 1C05H, 1C55H);
Add(1CE5H); Add(1D09H); Add(1D15H); Add(1D25H); Add(1D35H); Add(1D55H);
|CODE.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
delta := Align(glob, 1000H) - 3200000H;
Add(00A8H); Add(17EDH); Add(1C09H); Add(1D25H);
|CODE.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
delta := Align(code, 1000H) - 100000H;
Add8(0020H, 0084H, 0088H, 0098H, 009CH, 00A0H, 00B8H, 00BCH);
Add8(00C0H, 0118H, 011CH, 0120H, 0258H, 0278H, 02B8H, 0308H);
Add8(048CH, 0494H, 049CH, 04A4H, 04ACH, 04B4H, 04BCH, 04C4H);
Add8(04CCH, 04D4H, 04DCH, 04E4H, 04ECH, 04F4H, 04FCH, 0504H);
Add8(050CH, 0514H, 052BH, 0544H, 054EH, 0554H, 055EH, 056EH);
Add8(057EH, 058EH, 059EH, 05AEH, 05BEH, 05CEH, 05DEH, 05EEH);
Add8(05FEH, 060EH, 061EH, 062EH, 064CH, 0651H, 0679H, 0681H);
Add8(0686H, 068CH, 06A4H, 06ABH, 06B0H, 06BAH, 06D7H, 06EBH);
Add8(0703H, 0762H, 0774H, 0786H, 0819H, 0823H, 0828H, 082DH);
Add8(1635H, 1655H, 1659H, 167DH, 1681H, 16A5H, 16A9H, 16CDH);
Add8(16D1H, 16F5H, 16F9H, 171DH, 1721H, 1745H, 1749H, 176DH);
Add8(1771H, 1795H, 1799H, 17BDH, 17C1H, 17E5H, 17E9H, 1811H);
Add8(1839H, 1861H, 1889H, 1985H, 1995H, 19A5H, 19B5H, 19C5H);
Add8(19D5H, 19E5H, 19F5H, 1A05H, 1A15H, 1A25H, 1A55H, 1A65H);
Add8(1A75H, 1A95H, 1AA5H, 1AD5H, 1AE5H, 1AF5H, 1B05H, 1B25H);
Add8(1B35H, 1B45H, 1B55H, 1B65H, 1B75H, 1BB5H, 1BC5H, 1BE5H);
Add8(1C05H, 1C15H, 1C55H, 1C75H, 1CA5H, 1CB5H, 1CE5H, 1D05H);
Add8(1D15H, 1D25H, 1D35H, 1D55H, 1D75H, 1D89H, 08DEH, 08E8H);
Sub(0845H); Sub(087BH); Sub(0916H); Add(0C52H); Add(0C8AH); Add(0D0AH);
|CODE.opPUSHF:
subrc(esp, 8);
OutByte3(0DDH, 01CH, 024H) // fstp qword[esp]
OutFilePos := UTILS.GetMem(code + data + 8000H);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
|CODE.opLOADF:
UnOp(reg1);
OutByte2(0DDH, reg1); // fld qword[reg1]
drop
Write(sys.ADR(bytes), 817H);
Fill(2DDH, 90X);
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
Fill(Align(code, 1000H) - code, 90X);
Write(sys.ADR(bytes[817H]), 55FH);
Write(sys.ADR(Data), data);
Fill(Align(data, 1000H) - data, 0X);
Write(sys.ADR(bytes[817H + 55FH + 55FH]), 0DC5H);
|CODE.opCONSTF:
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
F := UTILS.CreateF(FName);
IF F <= 0 THEN
Err(1)
END;
WriteF(F, filebuf, OutFilePos - filebuf);
UTILS.CloseF(F)
END WriteELF;
|CODE.opSAVEF:
UnOp(reg1);
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
drop
PROCEDURE DelProc*(beg, end: ASMLINE);
BEGIN
WHILE beg # end DO
beg.clen := 0;
beg.tcmd := 0;
beg := beg.Next(ASMLINE)
END;
beg.clen := 0;
beg.tcmd := 0
END DelProc;
|CODE.opADDF, CODE.opADDFI:
OutByte2(0DEH, 0C1H) // faddp st1, st
PROCEDURE FixLabels*(FName: ARRAY OF CHAR; stk, gsize, glob: INTEGER);
VAR size, asize, i, rdatasize, RCount, n, temp, temp2, temp3: INTEGER; cur: ASMLINE; R: RELOC; c: CHAR;
BEGIN
dcount := Align(dcount, 4);
IF dll THEN
LoadAdr := 10000000H;
PackExport(ExecName)
ELSIF con OR gui THEN
LoadAdr := 400000H
ELSIF kos OR obj THEN
LoadAdr := sys.SIZE(KOSHEADER) + ORD(kem & kos) * 65536
ELSIF elf THEN
LoadAdr := 134514420 + 1024;
INC(gsize, 1024)
END;
|CODE.opSUBF:
OutByte2(0DEH, 0E9H) // fsubp st1, st
IF dll OR con OR gui THEN
rdatasize := 0DAH + etable.size;
size := 1000H + LoadAdr;
ELSIF kos OR elf OR obj THEN
rdatasize := 0;
size := LoadAdr
END;
|CODE.opSUBFI:
OutByte2(0DEH, 0E1H) // fsubrp st1, st
Optimization;
temp2 := size;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
cur.adr := size;
IF cur.tcmd = LCMD THEN
sys.PUT(cur.varadr, size)
END;
size := size + cur.clen;
cur := cur.Next(ASMLINE)
END;
|CODE.opMULF:
OutByte2(0DEH, 0C9H) // fmulp st1, st
size := temp2;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
cur.adr := size;
IF cur.tcmd = LCMD THEN
sys.PUT(cur.varadr, size)
ELSIF (cur.tcmd = JCMD) & cur.short THEN
sys.GET(cur.varadr, i);
temp3 := i - cur.Next(ASMLINE).adr;
IF (-131 <= temp3) & (temp3 <= 123) THEN
sys.GET(cur(ASMLINE).codeadr - 1, c);
IF c = JMP THEN
sys.PUT(cur(ASMLINE).codeadr - 1, 0EBX)
ELSE (*JE, JNE, JLE, JGE, JG, JL*)
sys.PUT(cur(ASMLINE).codeadr - 2, ORD(c) - 16);
sys.PUT(cur(ASMLINE).codeadr - 1, temp3);
DEC(cur(ASMLINE).codeadr)
END;
cur.clen := 2
|CODE.opDIVF:
OutByte2(0DEH, 0F9H) // fdivp st1, st
|CODE.opDIVFI:
OutByte2(0DEH, 0F1H) // fdivrp st1, st
|CODE.opUMINF:
OutByte2(0D9H, 0E0H) // fchs
|CODE.opFABS:
OutByte2(0D9H, 0E1H) // fabs
|CODE.opFLT:
UnOp(reg1);
push(reg1);
OutByte3(0DBH, 004H, 024H); // fild dword[esp]
pop(reg1);
drop
|CODE.opFLOOR:
reg1 := REG.GetAnyReg(R);
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(reg1);
OutByte2(0D9H, 06CH); OutByte2(024H, 002H); // fldcw word[esp+2]
addrc(esp, 4)
|CODE.opEQF, CODE.opEQFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 003H); // jp L
setcc(sete, al)
// L:
|CODE.opNEF, CODE.opNEFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 003H); // jp L
setcc(setne, al)
// L:
|CODE.opLTF, CODE.opGTFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 00EH); // jp L
setcc(setc, al);
setcc(sete, ah);
test(eax);
setcc(sete, al);
andrc(eax, 1)
// L:
|CODE.opGTF, CODE.opLTFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 00FH); // jp L
setcc(setc, al);
setcc(sete, ah);
cmprc(eax, 1);
setcc(sete, al);
andrc(eax, 1)
// L:
|CODE.opLEF, CODE.opGEFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 003H); // jp L
setcc(setnc, al)
// L:
|CODE.opGEF, CODE.opLEFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
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:
|CODE.opINF:
pushc(7FF00000H);
pushc(0);
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
addrc(esp, 8)
|CODE.opLADR_UNPK:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
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
|CODE.opSADR_PARAM:
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICDATA, stroffs + param2);
push(reg1);
drop
ELSE
OutByte(068H); // push _data + stroffs + param2
Reloc(BIN.RDATA, stroffs + param2)
END
END;
size := size + cur.clen;
cur := cur.Next(ASMLINE)
END;
IF dll OR con OR gui THEN
asize := Align(size, 1000H)
ELSIF kos OR obj THEN
asize := Align(size, 4)
ELSIF elf THEN
asize := 134514420 + 6508 + Align(size - 13 - LoadAdr, 1000H)
END;
|CODE.opVADR_PARAM:
n := param2 * 4;
OutByte2(0FFH, 75H + long(n)); // push dword[ebp + n]
OutIntByte(n)
FOR i := 0 TO Lcount DO
IF Labels[i] < 0 THEN
Labels[i] := -Labels[i] + asize + Align(rdatasize, 1000H)
|CODE.opCONST_PARAM:
pushc(param2)
|CODE.opGLOAD32_PARAM:
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICBSS, param2);
OutByte2(0FFH, 30H + reg1); // push dword[reg1]
drop
ELSE
OutByte2(0FFH, 035H); // push dword[_bss + param2]
Reloc(BIN.RBSS, param2)
END
|CODE.opLLOAD32_PARAM:
n := param2 * 4;
OutByte2(0FFH, 75H + long(n)); // push dword[ebp + n]
OutIntByte(n)
|CODE.opLOAD32_PARAM:
UnOp(reg1);
OutByte2(0FFH, 30H + reg1); // push dword[reg1]
drop
|CODE.opGADR_SAVEC:
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICBSS, param1);
OutByte2(0C7H, reg1); // mov dword[reg1], param2
OutInt(param2);
drop
ELSE
OutByte2(0C7H, 05H); // mov dword[_bss + param2], param2
Reloc(BIN.RBSS, param1);
OutInt(param2)
END
|CODE.opLADR_SAVEC:
n := param1 * 4;
OutByte2(0C7H, 45H + long(n)); // mov dword[ebp + n], param2
OutIntByte(n);
OutInt(param2)
|CODE.opLADR_SAVE:
n := param2 * 4;
UnOp(reg1);
OutByte2(89H, 45H + reg1 * 8 + long(n)); // mov dword[ebp + n], reg1
OutIntByte(n);
drop
|CODE.opLADR_INC1:
n := param2 * 4;
OutByte2(0FFH, 45H + long(n)); // inc dword[ebp + n]
OutIntByte(n)
|CODE.opLADR_DEC1:
n := param2 * 4;
OutByte2(0FFH, 4DH + long(n)); // dec dword[ebp + n]
OutIntByte(n)
|CODE.opLADR_INCC:
n := param1 * 4;
OutByte2(81H + short(param2), 45H + long(n)); // add dword[ebp + n], param2
OutIntByte(n);
OutIntByte(param2)
|CODE.opLADR_DECC:
n := param1 * 4;
OutByte2(81H + short(param2), 6DH + long(n)); // sub dword[ebp + n], param2
OutIntByte(n);
OutIntByte(param2)
|CODE.opLADR_INC1B:
n := param2 * 4;
OutByte2(0FEH, 45H + long(n)); // inc byte[ebp + n]
OutIntByte(n)
|CODE.opLADR_DEC1B:
n := param2 * 4;
OutByte2(0FEH, 4DH + long(n)); // dec byte[ebp + n]
OutIntByte(n)
|CODE.opLADR_INCCB:
n := param1 * 4;
OutByte2(80H, 45H + long(n)); // add byte[ebp + n], param2
OutIntByte(n);
OutByte(param2 MOD 256)
|CODE.opLADR_DECCB:
n := param1 * 4;
OutByte2(80H, 6DH + long(n)); // sub byte[ebp + n], param2
OutIntByte(n);
OutByte(param2 MOD 256)
|CODE.opLADR_INC:
n := param2 * 4;
UnOp(reg1);
OutByte2(01H, 45H + long(n) + reg1 * 8); // add dword[ebp + n], reg1
OutIntByte(n);
drop
|CODE.opLADR_DEC:
n := param2 * 4;
UnOp(reg1);
OutByte2(29H, 45H + long(n) + reg1 * 8); // sub dword[ebp + n], reg1
OutIntByte(n);
drop
|CODE.opLADR_INCB:
n := param2 * 4;
UnOp(reg1);
OutByte2(00H, 45H + long(n) + reg1 * 8); // add byte[ebp + n], reg1
OutIntByte(n);
drop
|CODE.opLADR_DECB:
n := param2 * 4;
UnOp(reg1);
OutByte2(28H, 45H + long(n) + reg1 * 8); // sub byte[ebp + n], reg1
OutIntByte(n);
drop
|CODE.opLADR_INCL, CODE.opLADR_EXCL:
n := param2 * 4;
UnOp(reg1);
cmprc(reg1, 32);
label := NewLabel();
jcc(jnb, label);
OutByte3(0FH, 0ABH + 8 * ORD(cmd.opcode = CODE.opLADR_EXCL), 45H + long(n) + reg1 * 8); // bts(r) dword[ebp + n], reg1
OutIntByte(n);
SetLabel(label);
drop
|CODE.opLADR_INCLC, CODE.opLADR_EXCLC:
n := param1 * 4;
OutByte3(0FH, 0BAH, 6DH + long(n) + 8 * ORD(cmd.opcode = CODE.opLADR_EXCLC)); // bts(r) dword[ebp + n], param2
OutIntByte(n);
OutByte(param2)
|CODE.opLOOP, CODE.opENDLOOP:
END;
temp := dcount;
IF elf THEN
asize := asize + Align(dcount, 1000H) + 64 + 1024;
sys.PUT(sys.ADR(Code[glob + 1]), asize - 1024);
dcount := 0
cmd := cmd.next(COMMAND)
END;
IF dll THEN
asize := asize - LoadAdr + 0DAH;
FOR i := 0 TO etable.namecount - 1 DO
etable.arradr[i] := Labels[etable.arradr[i]] - LoadAdr;
etable.arrnameptr[i] := etable.arrnameptr[i] + asize
ASSERT(R.pushed = 0);
ASSERT(R.top = -1)
END translate;
PROCEDURE prolog (code: CODE.CODES; pic: BOOLEAN; target, stack, dllinit, dllret: INTEGER);
VAR
reg1, entry, tcount, dcount: INTEGER;
BEGIN
entry := NewLabel();
SetLabel(entry);
IF target = mConst.Target_iDLL THEN
push(ebp);
mov(ebp, esp);
OutByte3(0FFH, 75H, 16); // push dword[ebp+16]
OutByte3(0FFH, 75H, 12); // push dword[ebp+12]
OutByte3(0FFH, 75H, 8); // push dword[ebp+8]
CallRTL(pic, CODE._dllentry);
test(eax);
jcc(je, dllret)
ELSIF target = mConst.Target_iObject THEN
SetLabel(dllinit)
END;
etable.arradroffset := etable.arradroffset + asize;
etable.arrnameptroffset := etable.arrnameptroffset + asize;
etable.arrnumoffset := etable.arrnumoffset + asize;
etable.dllnameoffset := etable.dllnameoffset + asize;
asize := asize + LoadAdr - 0DAH
IF target = mConst.Target_iKolibri THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.IMPTAB, 0);
push(reg1); // push IMPORT
drop
ELSIF target = mConst.Target_iObject THEN
OutByte(68H); // push IMPORT
Reloc(BIN.IMPTAB, 0)
ELSIF target = mConst.Target_iELF32 THEN
push(esp)
ELSE
pushc(0)
END;
IF dll OR con OR gui THEN
Labels[LoadLibrary] := asize + 4;
Labels[GetProcAddress] := asize;
R.Page := 0;
R.Size := 0;
RCount := 0;
END;
cur := asmlist.First(ASMLINE);
FOR i := 0 TO LEN(RtlProc) - 1 DO
RtlProc[i] := Labels[RtlProc[i]]
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICCODE, entry);
push(reg1); // push CODE
drop
ELSE
OutByte(68H); // push CODE
Reloc(BIN.RCODE, entry)
END;
temp3 := asize + Align(rdatasize, 1000H) + dcount;
WHILE cur # NIL DO
CASE cur.tcmd OF
|JCMD:
sys.GET(cur.varadr, i);
sys.PUT(cur.codeadr, i - cur.Next(ASMLINE).adr)
|GCMD:
sys.GET(cur.codeadr, i);
sys.PUT(cur.codeadr, i + temp3)
|OCMD:
sys.MOVE(cur.varadr, cur.codeadr, 4)
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICDATA, 0);
push(reg1); // push _data
drop
ELSE
OutByte(68H); // push _data
Reloc(BIN.RDATA, 0)
END;
IF dll & (cur.tcmd IN {GCMD, OCMD}) THEN
n := cur.adr - LoadAdr;
IF ASR(n, 12) = ASR(R.Page, 12) THEN
R.reloc[RCount] := IntToCard16(n MOD 1000H + 3000H);
INC(RCount);
INC(R.Size, 2)
tcount := CHL.Length(code.types);
dcount := CHL.Length(code.data);
pushc(tcount);
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICDATA, tcount * 4 + dcount);
push(reg1); // push _data + tcount * 4 + dcount
drop
ELSE
IF R.Size # 0 THEN
PutReloc(R)
OutByte(68H); // push _data
Reloc(BIN.RDATA, tcount * 4 + dcount)
END;
R.Page := ASR(n, 12) * 1000H;
R.Size := 10;
R.reloc[0] := IntToCard16(n MOD 1000H + 3000H);
RCount := 1
END
CallRTL(pic, CODE._init)
END prolog;
PROCEDURE epilog (code: CODE.CODES; pic: BOOLEAN; modname: ARRAY OF CHAR; target, stack, ver, dllinit, dllret: INTEGER);
VAR
i, n: INTEGER;
exp: CODE.EXPORT_PROC;
path, name, ext: PATHS.PATH;
tcount, dcount: INTEGER;
PROCEDURE import (imp: LISTS.LIST);
VAR
lib: CODE.IMPORT_LIB;
proc: CODE.IMPORT_PROC;
BEGIN
lib := imp.first(CODE.IMPORT_LIB);
WHILE lib # NIL DO
BIN.Import(program, lib.name, 0);
proc := lib.procs.first(CODE.IMPORT_PROC);
WHILE proc # NIL DO
BIN.Import(program, proc.name, proc.label);
proc := proc.next(CODE.IMPORT_PROC)
END;
cur := cur.Next(ASMLINE)
END;
IF R.Size # 0 THEN
PutReloc(R)
END;
IF dll OR con OR gui THEN
WritePE(FName, stk, size - 1000H - LoadAdr, dcount, rdatasize, gsize)
ELSIF kos OR obj THEN
WriteKOS(FName, Align(stk, 4), size, dcount, gsize, obj)
ELSIF elf THEN
WriteELF(FName, size - LoadAdr, temp, gsize)
lib := lib.next(CODE.IMPORT_LIB)
END
END FixLabels;
PROCEDURE OutStringZ(str: ARRAY OF CHAR);
VAR i: INTEGER;
END import;
BEGIN
New;
current.clen := LENGTH(str);
FOR i := 0 TO current.clen - 1 DO
Code[ccount] := str[i];
INC(ccount)
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iKolibri, mConst.Target_iELF32} THEN
pushc(0);
CallRTL(pic, CODE._exit);
ELSIF target = mConst.Target_iDLL THEN
SetLabel(dllret);
movrc(eax, 1);
OutByte(0C9H); // leave
OutByte3(0C2H, 0CH, 0) // ret 12
ELSIF target = mConst.Target_iObject THEN
movrc(eax, 1);
OutByte(0C3H) // ret
END;
Code[ccount] := 0X;
INC(ccount);
INC(current.clen)
END OutStringZ;
PROCEDURE Epilog*(gsize: INTEGER; FName: ARRAY OF CHAR; stk: INTEGER);
VAR i, glob: INTEGER;
BEGIN
glob := 0;
IF gsize < maxstrlen THEN
gsize := maxstrlen
fixup;
tcount := CHL.Length(code.types);
dcount := CHL.Length(code.data);
FOR i := 0 TO tcount - 1 DO
BIN.PutData32LE(program, CHL.GetInt(code.types, i))
END;
gsize := Align(gsize, 4) + 4;
COPY(FName, OutFile);
Labels[RTABLE] := -dcount;
dataint(recarray[0]);
FOR i := 1 TO reccount DO
dataint(recarray[i])
FOR i := 0 TO dcount - 1 DO
BIN.PutData(program, CHL.GetByte(code.data, i))
END;
current := start;
IF con OR gui OR dll THEN
PushInt(LoadLibrary);
PushInt(GetProcAddress);
OutCode("5859FF31FF3054")
ELSIF elf THEN
OutCode("6800000000");
glob := current.cmd;
ELSIF kos OR obj THEN
OutByte(54H)
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 = mConst.Target_iObject THEN
BIN.Export(program, "lib_init", dllinit);
END;
GlobalAdr(0);
PushConst(ASR(gsize, 2));
PushInt(RTABLE);
PushInt(SELFNAME);
CallRTL(_init);
current := asmlist.Last(ASMLINE);
IF dll THEN
OutCode("B801000000C9C20C00")
exp := code.export.first(CODE.EXPORT_PROC);
WHILE exp # NIL DO
BIN.Export(program, exp.name, exp.label);
exp := exp.next(CODE.EXPORT_PROC)
END;
IF obj THEN
OutCode("B801000000C9C20000")
import(code.import);
n := code.dmin - CHL.Length(code.data);
IF n > 0 THEN
INC(code.bss, n)
END;
OutCode("EB05");
Label(ASSRT);
CallRTL(_assrt);
OutCode("EB09");
Label(HALT);
OutCode("6A006A00");
CallRTL(_assrt);
OutCode("6A00");
CallRTL(_halt);
Label(_floor);
OutCode("83EC06D93C2466812424FFF366810C24FFF7D92C2483C402D9FCDB1C2458C3");
IF obj THEN
Label(Exports);
CmdN(szSTART); CmdN(START);
CmdN(szversion); OutInt(stk);
FOR i := 0 TO kosexpcount - 1 DO
CmdN(kosexp[i].NameLabel); CmdN(kosexp[i].Adr)
BIN.SetParams(program, MAX(code.bss, 4), stack * (1024 * 1024), WCHR(ver DIV 65536), WCHR(ver MOD 65536));
END epilog;
PROCEDURE CodeGen* (code: CODE.CODES; outname: ARRAY OF CHAR; target, stack, base, ver: INTEGER; pic: BOOLEAN);
VAR
dllret, dllinit: INTEGER;
BEGIN
CodeList := LISTS.create(NIL);
program := BIN.create(code.lcount);
dllinit := NewLabel();
dllret := NewLabel();
IF target = mConst.Target_iObject THEN
pic := FALSE
END;
OutInt(0);
Label(szSTART); OutStringZ("lib_init");
Label(szversion); OutStringZ("version");
FOR i := 0 TO kosexpcount - 1 DO
Label(kosexp[i].NameLabel);
OutStringZ(kosexp[i].Name.Name)
END
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL, mConst.Target_iELF32} THEN
pic := TRUE
END;
FixLabels(FName, stk, gsize, glob)
END Epilog;
PROCEDURE setkem*;
R := REG.Create(push, pop, mov, xchg, NIL, NIL, {eax, ecx, edx}, {});
prolog(code, pic, target, stack, dllinit, dllret);
translate(code, pic, CHL.Length(code.types) * 4);
epilog(code, pic, outname, target, stack, ver, dllinit, dllret);
BIN.fixup(program);
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN
PE32.write(program, outname, base, target = mConst.Target_iConsole, target = mConst.Target_iDLL, FALSE)
ELSIF target = mConst.Target_iKolibri THEN
KOS.write(program, outname)
ELSIF target = mConst.Target_iObject THEN
MSCOFF.write(program, outname, ver)
ELSIF target = mConst.Target_iELF32 THEN
ELF.write(program, outname, FALSE)
END
END CodeGen;
PROCEDURE SetProgram* (prog: BIN.PROGRAM);
BEGIN
kem := TRUE
END setkem;
program := prog;
CodeList := LISTS.create(NIL)
END SetProgram;
BEGIN
kem := FALSE
END X86.