mirror of
https://github.com/AntKrotov/oberon-07-compiler.git
synced 2026-10-05 09:45:47 +00:00
поддержка Linux-x86_64
This commit is contained in:
AntKrotov authored and 
GitHub committed
1 parent
e3bfdbe15f
commit
c658de2e05
4 files changed
+1232
No files matched your search
@@ -0,0 +1,167 @@
|
||||
(*
|
||||
BSD 2-Clause License
|
||||
|
||||
Copyright (c) 2019, Anton Krotov
|
||||
All rights reserved.
|
||||
*)
|
||||
|
||||
MODULE API;
|
||||
|
||||
IMPORT SYSTEM;
|
||||
|
||||
|
||||
CONST
|
||||
|
||||
SIZE_OF_QWORD = 8;
|
||||
|
||||
|
||||
TYPE
|
||||
|
||||
TP* = ARRAY 2 OF INTEGER;
|
||||
|
||||
|
||||
VAR
|
||||
|
||||
eol*: ARRAY 3 OF CHAR;
|
||||
base*: INTEGER;
|
||||
MainParam*: INTEGER;
|
||||
|
||||
libc*, librt*: INTEGER;
|
||||
|
||||
stdout*,
|
||||
stdin*,
|
||||
stderr* : INTEGER;
|
||||
|
||||
dlopen*,
|
||||
dlsym*,
|
||||
malloc*,
|
||||
free*,
|
||||
puts*,
|
||||
_exit*,
|
||||
fwrite*,
|
||||
fread*,
|
||||
fopen*,
|
||||
fclose*,
|
||||
clock_gettime*,
|
||||
time*: INTEGER;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] SysVCall* (rax, rdi, rsi, rdx, rcx, r8, r9: INTEGER): INTEGER;
|
||||
BEGIN
|
||||
SYSTEM.CODE(
|
||||
048H, 08BH, 045H, 010H, // mov rax, qword[rbp + 16]
|
||||
048H, 08BH, 07DH, 018H, // mov rdi, qword[rbp + 24]
|
||||
048H, 08BH, 075H, 020H, // mov rsi, qword[rbp + 32]
|
||||
048H, 08BH, 055H, 028H, // mov rdx, qword[rbp + 40]
|
||||
048H, 08BH, 04DH, 030H, // mov rcx, qword[rbp + 48]
|
||||
04CH, 08BH, 045H, 038H, // mov r8, qword[rbp + 56]
|
||||
04CH, 08BH, 04DH, 040H, // mov r9, qword[rbp + 64]
|
||||
048H, 081H, 0ECH, 080H, 000H, 000H, 000H, // sub rsp, 128
|
||||
048H, 083H, 0E4H, 0F0H, // and rsp, -16
|
||||
0FFH, 0D0H, // call rax
|
||||
0C9H, // leave
|
||||
0C2H, 038H, 000H // ret 56
|
||||
)
|
||||
RETURN 0
|
||||
END SysVCall;
|
||||
|
||||
|
||||
PROCEDURE putc* (c: CHAR);
|
||||
VAR
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
res := SysVCall(fwrite, SYSTEM.ADR(c), 1, 1, stdout, 0,0)
|
||||
END putc;
|
||||
|
||||
|
||||
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
|
||||
VAR
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
res := SysVCall(puts, lpCaption, 0,0,0,0,0);
|
||||
res := SysVCall(puts, lpText, 0,0,0,0,0);
|
||||
END DebugMsg;
|
||||
|
||||
|
||||
PROCEDURE _NEW* (size: INTEGER): INTEGER;
|
||||
VAR
|
||||
res, ptr, qwords: INTEGER;
|
||||
|
||||
BEGIN
|
||||
res := SysVCall(malloc, size, 0,0,0,0,0);
|
||||
IF res # 0 THEN
|
||||
ptr := res;
|
||||
qwords := size DIV SIZE_OF_QWORD;
|
||||
WHILE qwords > 0 DO
|
||||
SYSTEM.PUT(ptr, 0);
|
||||
INC(ptr, SIZE_OF_QWORD);
|
||||
DEC(qwords)
|
||||
END
|
||||
END
|
||||
|
||||
RETURN res
|
||||
END _NEW;
|
||||
|
||||
|
||||
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
|
||||
BEGIN
|
||||
p := SysVCall(free, p, 0,0,0,0,0)
|
||||
RETURN 0
|
||||
END _DISPOSE;
|
||||
|
||||
|
||||
PROCEDURE GetProcAdr (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
|
||||
VAR
|
||||
sym: INTEGER;
|
||||
BEGIN
|
||||
sym := SysVCall(dlsym, lib, SYSTEM.ADR(name[0]), 0,0,0,0);
|
||||
ASSERT(sym # 0);
|
||||
SYSTEM.PUT(VarAdr, sym)
|
||||
END GetProcAdr;
|
||||
|
||||
|
||||
PROCEDURE init* (rsp, code: INTEGER);
|
||||
BEGIN
|
||||
MainParam := rsp;
|
||||
base := 400000H;
|
||||
SYSTEM.GET(base + 305H - 16, dlopen);
|
||||
SYSTEM.GET(base + 305H - 8, dlsym);
|
||||
libc := SysVCall(dlopen, SYSTEM.SADR("libc.so.6"), 1, 0,0,0,0);
|
||||
ASSERT(libc # 0);
|
||||
GetProcAdr(libc, "malloc", SYSTEM.ADR(malloc));
|
||||
GetProcAdr(libc, "free", SYSTEM.ADR(free));
|
||||
GetProcAdr(libc, "exit", SYSTEM.ADR(_exit));
|
||||
GetProcAdr(libc, "stdout", SYSTEM.ADR(stdout));
|
||||
GetProcAdr(libc, "stdin", SYSTEM.ADR(stdin));
|
||||
GetProcAdr(libc, "stderr", SYSTEM.ADR(stderr));
|
||||
SYSTEM.GET(stdout - 8, stdout);
|
||||
SYSTEM.GET(stdin - 8, stdin);
|
||||
SYSTEM.GET(stderr - 8, stderr);
|
||||
GetProcAdr(libc, "puts", SYSTEM.ADR(puts));
|
||||
GetProcAdr(libc, "fwrite", SYSTEM.ADR(fwrite));
|
||||
GetProcAdr(libc, "fread", SYSTEM.ADR(fread));
|
||||
GetProcAdr(libc, "fopen", SYSTEM.ADR(fopen));
|
||||
GetProcAdr(libc, "fclose", SYSTEM.ADR(fclose));
|
||||
GetProcAdr(libc, "time", SYSTEM.ADR(time));
|
||||
librt := SysVCall(dlopen, SYSTEM.SADR("librt.so.1"), 1, 0,0,0,0);
|
||||
ASSERT(librt # 0);
|
||||
GetProcAdr(librt, "clock_gettime", SYSTEM.ADR(clock_gettime));
|
||||
eol := 0AX
|
||||
END init;
|
||||
|
||||
|
||||
PROCEDURE exit* (code: INTEGER);
|
||||
BEGIN
|
||||
code := SysVCall(_exit, code, 0,0,0,0,0)
|
||||
END exit;
|
||||
|
||||
|
||||
PROCEDURE exit_thread* (code: INTEGER);
|
||||
BEGIN
|
||||
exit(code)
|
||||
END exit_thread;
|
||||
|
||||
|
||||
END API.
|
||||
@@ -0,0 +1,180 @@
|
||||
(*
|
||||
BSD 2-Clause License
|
||||
|
||||
Copyright (c) 2019, Anton Krotov
|
||||
All rights reserved.
|
||||
*)
|
||||
|
||||
MODULE HOST;
|
||||
|
||||
IMPORT SYSTEM, API;
|
||||
|
||||
|
||||
CONST
|
||||
|
||||
slash* = "/";
|
||||
OS* = "LINUX64";
|
||||
|
||||
bit_depth* = 64;
|
||||
maxint* = 7FFFFFFFFFFFFFFFH;
|
||||
minint* = 8000000000000000H;
|
||||
|
||||
SIZE_OF_QWORD = 8;
|
||||
|
||||
|
||||
VAR
|
||||
|
||||
argc: INTEGER;
|
||||
|
||||
eol*: ARRAY 2 OF CHAR;
|
||||
|
||||
|
||||
PROCEDURE ExitProcess* (code: INTEGER);
|
||||
BEGIN
|
||||
API.exit(code)
|
||||
END ExitProcess;
|
||||
|
||||
|
||||
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
|
||||
VAR
|
||||
i, len, ptr: INTEGER;
|
||||
c: CHAR;
|
||||
|
||||
BEGIN
|
||||
i := 0;
|
||||
len := LEN(s) - 1;
|
||||
IF (n < argc) & (len > 0) THEN
|
||||
SYSTEM.GET(API.MainParam + (n + 1) * SIZE_OF_QWORD, ptr);
|
||||
REPEAT
|
||||
SYSTEM.GET(ptr, c);
|
||||
s[i] := c;
|
||||
INC(i);
|
||||
INC(ptr)
|
||||
UNTIL (c = 0X) OR (i = len)
|
||||
END;
|
||||
s[i] := 0X
|
||||
END GetArg;
|
||||
|
||||
|
||||
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
|
||||
VAR
|
||||
n: INTEGER;
|
||||
|
||||
BEGIN
|
||||
GetArg(0, path);
|
||||
n := LENGTH(path) - 1;
|
||||
WHILE path[n] # slash DO
|
||||
DEC(n)
|
||||
END;
|
||||
path[n + 1] := 0X
|
||||
END GetCurrentDirectory;
|
||||
|
||||
|
||||
PROCEDURE ReadFile (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
|
||||
RETURN API.SysVCall(API.fread, SYSTEM.ADR(Buffer[0]), 1, bytes, F, 0,0)
|
||||
END ReadFile;
|
||||
|
||||
|
||||
PROCEDURE WriteFile (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
|
||||
RETURN API.SysVCall(API.fwrite, SYSTEM.ADR(Buffer[0]), 1, bytes, F, 0,0)
|
||||
END WriteFile;
|
||||
|
||||
|
||||
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
|
||||
VAR
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
res := ReadFile(F, Buffer, bytes);
|
||||
IF res <= 0 THEN
|
||||
res := -1
|
||||
END
|
||||
|
||||
RETURN res
|
||||
END FileRead;
|
||||
|
||||
|
||||
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
|
||||
VAR
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
res := WriteFile(F, Buffer, bytes);
|
||||
IF res <= 0 THEN
|
||||
res := -1
|
||||
END
|
||||
|
||||
RETURN res
|
||||
END FileWrite;
|
||||
|
||||
|
||||
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
|
||||
RETURN API.SysVCall(API.fopen, SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"), 0,0,0,0)
|
||||
END FileCreate;
|
||||
|
||||
|
||||
PROCEDURE FileClose* (File: INTEGER);
|
||||
BEGIN
|
||||
File := API.SysVCall(API.fclose, File, 0,0,0,0,0)
|
||||
END FileClose;
|
||||
|
||||
|
||||
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
|
||||
RETURN API.SysVCall(API.fopen, SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"), 0,0,0,0)
|
||||
END FileOpen;
|
||||
|
||||
|
||||
PROCEDURE OutChar* (c: CHAR);
|
||||
BEGIN
|
||||
API.putc(c)
|
||||
END OutChar;
|
||||
|
||||
|
||||
PROCEDURE GetTickCount* (): INTEGER;
|
||||
VAR
|
||||
tp: API.TP;
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
IF API.SysVCall(API.clock_gettime, 0, SYSTEM.ADR(tp), 0,0,0,0) = 0 THEN
|
||||
res := tp[0] * 100 + tp[1] DIV 10000000
|
||||
ELSE
|
||||
res := 0
|
||||
END
|
||||
|
||||
RETURN res
|
||||
END GetTickCount;
|
||||
|
||||
|
||||
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
|
||||
RETURN path[0] # slash
|
||||
END isRelative;
|
||||
|
||||
|
||||
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
|
||||
END now;
|
||||
|
||||
|
||||
PROCEDURE UnixTime* (): INTEGER;
|
||||
RETURN API.SysVCall(API.time, 0, 0,0,0,0,0)
|
||||
END UnixTime;
|
||||
|
||||
|
||||
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
|
||||
VAR
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
a := 0;
|
||||
b := 0;
|
||||
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
|
||||
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
|
||||
SYSTEM.GET(SYSTEM.ADR(x), res)
|
||||
RETURN res
|
||||
END splitf;
|
||||
|
||||
|
||||
BEGIN
|
||||
eol := 0AX;
|
||||
SYSTEM.GET(API.MainParam, argc)
|
||||
END HOST.
|
||||
@@ -0,0 +1,277 @@
|
||||
(*
|
||||
Copyright 2013, 2014, 2017, 2018, 2019 Anton Krotov
|
||||
|
||||
This program is free software: you can redistribute it and/or modify
|
||||
it under the terms of the GNU Lesser General Public License as published by
|
||||
the Free Software Foundation, either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program 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 Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
*)
|
||||
|
||||
MODULE Out;
|
||||
|
||||
IMPORT sys := SYSTEM, API;
|
||||
|
||||
CONST
|
||||
|
||||
d = 1.0 - 5.0E-12;
|
||||
|
||||
VAR
|
||||
|
||||
Realp: PROCEDURE (x: REAL; width: INTEGER);
|
||||
|
||||
|
||||
PROCEDURE Char*(x: CHAR);
|
||||
BEGIN
|
||||
API.putc(x)
|
||||
END Char;
|
||||
|
||||
|
||||
PROCEDURE String*(s: ARRAY OF CHAR);
|
||||
VAR
|
||||
i: INTEGER;
|
||||
|
||||
BEGIN
|
||||
i := 0;
|
||||
WHILE (i < LEN(s)) & (s[i] # 0X) DO
|
||||
Char(s[i]);
|
||||
INC(i)
|
||||
END
|
||||
END String;
|
||||
|
||||
|
||||
PROCEDURE WriteInt(x, n: INTEGER);
|
||||
VAR i: INTEGER; a: ARRAY 24 OF CHAR; neg: BOOLEAN;
|
||||
BEGIN
|
||||
i := 0;
|
||||
IF n < 1 THEN
|
||||
n := 1
|
||||
END;
|
||||
IF x < 0 THEN
|
||||
x := -x;
|
||||
DEC(n);
|
||||
neg := TRUE
|
||||
END;
|
||||
REPEAT
|
||||
a[i] := CHR(x MOD 10 + ORD("0"));
|
||||
x := x DIV 10;
|
||||
INC(i)
|
||||
UNTIL x = 0;
|
||||
WHILE n > i DO
|
||||
Char(" ");
|
||||
DEC(n)
|
||||
END;
|
||||
IF neg THEN
|
||||
Char("-")
|
||||
END;
|
||||
REPEAT
|
||||
DEC(i);
|
||||
Char(a[i])
|
||||
UNTIL i = 0
|
||||
END WriteInt;
|
||||
|
||||
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
|
||||
VAR h, l: SET;
|
||||
BEGIN
|
||||
sys.GET(sys.ADR(AValue), l);
|
||||
sys.GET(sys.ADR(AValue) + 4, h)
|
||||
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
|
||||
END IsNan;
|
||||
|
||||
PROCEDURE IsInf(x: REAL): BOOLEAN;
|
||||
RETURN ABS(x) = sys.INF()
|
||||
END IsInf;
|
||||
|
||||
PROCEDURE Int*(x, width: INTEGER);
|
||||
VAR i: INTEGER;
|
||||
BEGIN
|
||||
IF x # 80000000H THEN
|
||||
WriteInt(x, width)
|
||||
ELSE
|
||||
FOR i := 12 TO width DO
|
||||
Char(20X)
|
||||
END;
|
||||
String("-2147483648")
|
||||
END
|
||||
END Int;
|
||||
|
||||
PROCEDURE OutInf(x: REAL; width: INTEGER);
|
||||
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
|
||||
BEGIN
|
||||
IF IsNan(x) THEN
|
||||
s := "Nan";
|
||||
INC(width)
|
||||
ELSIF IsInf(x) & (x > 0.0) THEN
|
||||
s := "+Inf"
|
||||
ELSIF IsInf(x) & (x < 0.0) THEN
|
||||
s := "-Inf"
|
||||
END;
|
||||
FOR i := 1 TO width - 4 DO
|
||||
Char(" ")
|
||||
END;
|
||||
String(s)
|
||||
END OutInf;
|
||||
|
||||
PROCEDURE Ln*;
|
||||
BEGIN
|
||||
Char(0AX)
|
||||
END Ln;
|
||||
|
||||
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
|
||||
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
|
||||
BEGIN
|
||||
IF IsNan(x) OR IsInf(x) THEN
|
||||
OutInf(x, width)
|
||||
ELSIF p < 0 THEN
|
||||
Realp(x, width)
|
||||
ELSE
|
||||
len := 0;
|
||||
minus := FALSE;
|
||||
IF x < 0.0 THEN
|
||||
minus := TRUE;
|
||||
INC(len);
|
||||
x := ABS(x)
|
||||
END;
|
||||
e := 0;
|
||||
WHILE x >= 10.0 DO
|
||||
x := x / 10.0;
|
||||
INC(e)
|
||||
END;
|
||||
|
||||
IF e >= 0 THEN
|
||||
len := len + e + p + 1;
|
||||
IF x > 9.0 + d THEN
|
||||
INC(len)
|
||||
END;
|
||||
IF p > 0 THEN
|
||||
INC(len)
|
||||
END;
|
||||
ELSE
|
||||
len := len + p + 2
|
||||
END;
|
||||
FOR i := 1 TO width - len DO
|
||||
Char(" ")
|
||||
END;
|
||||
IF minus THEN
|
||||
Char("-")
|
||||
END;
|
||||
y := x;
|
||||
WHILE (y < 1.0) & (y # 0.0) DO
|
||||
y := y * 10.0;
|
||||
DEC(e)
|
||||
END;
|
||||
IF e < 0 THEN
|
||||
IF x - FLT(FLOOR(x)) > d THEN
|
||||
Char("1");
|
||||
x := 0.0
|
||||
ELSE
|
||||
Char("0");
|
||||
x := x * 10.0
|
||||
END
|
||||
ELSE
|
||||
WHILE e >= 0 DO
|
||||
IF x - FLT(FLOOR(x)) > d THEN
|
||||
IF x > 9.0 THEN
|
||||
String("10")
|
||||
ELSE
|
||||
Char(CHR(FLOOR(x) + ORD("0") + 1))
|
||||
END;
|
||||
x := 0.0
|
||||
ELSE
|
||||
Char(CHR(FLOOR(x) + ORD("0")));
|
||||
x := (x - FLT(FLOOR(x))) * 10.0
|
||||
END;
|
||||
DEC(e)
|
||||
END
|
||||
END;
|
||||
IF p > 0 THEN
|
||||
Char(".")
|
||||
END;
|
||||
WHILE p > 0 DO
|
||||
IF x - FLT(FLOOR(x)) > d THEN
|
||||
Char(CHR(FLOOR(x) + ORD("0") + 1));
|
||||
x := 0.0
|
||||
ELSE
|
||||
Char(CHR(FLOOR(x) + ORD("0")));
|
||||
x := (x - FLT(FLOOR(x))) * 10.0
|
||||
END;
|
||||
DEC(p)
|
||||
END
|
||||
END
|
||||
END _FixReal;
|
||||
|
||||
PROCEDURE Real*(x: REAL; width: INTEGER);
|
||||
VAR e, n, i: INTEGER; minus: BOOLEAN;
|
||||
BEGIN
|
||||
Realp := Real;
|
||||
IF IsNan(x) OR IsInf(x) THEN
|
||||
OutInf(x, width)
|
||||
ELSE
|
||||
e := 0;
|
||||
n := 0;
|
||||
IF width > 23 THEN
|
||||
n := width - 23;
|
||||
width := 23
|
||||
ELSIF width < 9 THEN
|
||||
width := 9
|
||||
END;
|
||||
width := width - 5;
|
||||
IF x < 0.0 THEN
|
||||
x := -x;
|
||||
minus := TRUE
|
||||
ELSE
|
||||
minus := FALSE
|
||||
END;
|
||||
WHILE x >= 10.0 DO
|
||||
x := x / 10.0;
|
||||
INC(e)
|
||||
END;
|
||||
WHILE (x < 1.0) & (x # 0.0) DO
|
||||
x := x * 10.0;
|
||||
DEC(e)
|
||||
END;
|
||||
IF x > 9.0 + d THEN
|
||||
x := 1.0;
|
||||
INC(e)
|
||||
END;
|
||||
FOR i := 1 TO n DO
|
||||
Char(" ")
|
||||
END;
|
||||
IF minus THEN
|
||||
x := -x
|
||||
END;
|
||||
_FixReal(x, width, width - 3);
|
||||
Char("E");
|
||||
IF e >= 0 THEN
|
||||
Char("+")
|
||||
ELSE
|
||||
Char("-");
|
||||
e := ABS(e)
|
||||
END;
|
||||
IF e < 100 THEN
|
||||
Char("0")
|
||||
END;
|
||||
IF e < 10 THEN
|
||||
Char("0")
|
||||
END;
|
||||
Int(e, 0)
|
||||
END
|
||||
END Real;
|
||||
|
||||
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
|
||||
BEGIN
|
||||
Realp := Real;
|
||||
_FixReal(x, width, p)
|
||||
END FixReal;
|
||||
|
||||
PROCEDURE Open*;
|
||||
END Open;
|
||||
|
||||
END Out.
|
||||
@@ -0,0 +1,608 @@
|
||||
(*
|
||||
BSD 2-Clause License
|
||||
|
||||
Copyright (c) 2018, 2019, Anton Krotov
|
||||
All rights reserved.
|
||||
*)
|
||||
|
||||
MODULE RTL;
|
||||
|
||||
IMPORT SYSTEM, API;
|
||||
|
||||
|
||||
CONST
|
||||
|
||||
DLL_PROCESS_ATTACH = 1;
|
||||
DLL_THREAD_ATTACH = 2;
|
||||
DLL_THREAD_DETACH = 3;
|
||||
DLL_PROCESS_DETACH = 0;
|
||||
|
||||
SIZE_OF_QWORD = 8;
|
||||
|
||||
|
||||
TYPE
|
||||
|
||||
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
|
||||
|
||||
|
||||
VAR
|
||||
|
||||
name: INTEGER;
|
||||
types: INTEGER;
|
||||
|
||||
dll: RECORD
|
||||
process_detach,
|
||||
thread_detach,
|
||||
thread_attach: DLL_ENTRY
|
||||
END;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
|
||||
VAR
|
||||
qwords: INTEGER;
|
||||
qword: INTEGER;
|
||||
byte: BYTE;
|
||||
|
||||
BEGIN
|
||||
qwords := bytes DIV 8;
|
||||
bytes := bytes MOD 8;
|
||||
|
||||
WHILE qwords > 0 DO
|
||||
SYSTEM.GET(source, qword);
|
||||
SYSTEM.PUT(dest, qword);
|
||||
INC(source, 8);
|
||||
INC(dest, 8);
|
||||
DEC(qwords)
|
||||
END;
|
||||
|
||||
WHILE bytes > 0 DO
|
||||
SYSTEM.GET(source, byte);
|
||||
SYSTEM.PUT8(dest, byte);
|
||||
INC(source);
|
||||
INC(dest);
|
||||
DEC(bytes)
|
||||
END
|
||||
END _move;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _move2* (bytes, dest, source: INTEGER);
|
||||
BEGIN
|
||||
_move(bytes, source, dest)
|
||||
END _move2;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
|
||||
VAR
|
||||
res: BOOLEAN;
|
||||
|
||||
BEGIN
|
||||
IF len_src > len_dst THEN
|
||||
res := FALSE
|
||||
ELSE
|
||||
_move(len_src * base_size, src, dst);
|
||||
res := TRUE
|
||||
END
|
||||
|
||||
RETURN res
|
||||
END _arrcpy;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
|
||||
BEGIN
|
||||
_move(MIN(len_dst, len_src) * chr_size, src, dst)
|
||||
END _strcpy;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
|
||||
BEGIN
|
||||
_move(MIN(len_dst, len_src) * chr_size, src, dst)
|
||||
END _strcpy2;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
|
||||
VAR
|
||||
i, n, k: INTEGER;
|
||||
|
||||
BEGIN
|
||||
|
||||
k := LEN(A) - 1;
|
||||
n := A[0];
|
||||
i := 0;
|
||||
WHILE i < k DO
|
||||
A[i] := A[i + 1];
|
||||
INC(i)
|
||||
END;
|
||||
A[k] := n
|
||||
|
||||
END _rot;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
|
||||
VAR
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
IF (a <= b) & (a <= 63) & (b >= 0) THEN
|
||||
IF b > 63 THEN
|
||||
b := 63
|
||||
END;
|
||||
IF a < 0 THEN
|
||||
a := 0
|
||||
END;
|
||||
res := LSR(ASR(ROR(1, 1), b - a), 63 - b)
|
||||
ELSE
|
||||
res := 0
|
||||
END
|
||||
|
||||
RETURN res
|
||||
END _set2;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
|
||||
RETURN _set2(a, b)
|
||||
END _set;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
|
||||
BEGIN
|
||||
SYSTEM.CODE(
|
||||
|
||||
049H, 087H, 0CAH, (* xchg r10, rcx *)
|
||||
049H, 087H, 0D3H, (* xchg r11, rdx *)
|
||||
|
||||
048H, 08BH, 045H, 010H, (* mov rax, qword [rbp + 16] *)
|
||||
048H, 08BH, 04DH, 018H, (* mov rcx, qword [rbp + 24] *)
|
||||
048H, 031H, 0D2H, (* xor rdx, rdx *)
|
||||
048H, 085H, 0C0H, (* test rax, rax *)
|
||||
07DH, 003H, (* jge L1 *)
|
||||
048H, 0F7H, 0D2H, (* not rdx *)
|
||||
(* L1: *)
|
||||
048H, 0F7H, 0F9H, (* idiv rcx *)
|
||||
048H, 08BH, 04DH, 020H, (* mov rcx, qword [rbp + 32] *)
|
||||
048H, 089H, 011H, (* mov qword [rcx], rdx *)
|
||||
048H, 089H, 0ECH, (* mov rsp, rbp *)
|
||||
05DH, (* pop rbp *)
|
||||
|
||||
049H, 087H, 0CAH, (* xchg r10, rcx *)
|
||||
049H, 087H, 0D3H, (* xchg r11, rdx *)
|
||||
|
||||
0C2H, 018H, 000H (* ret 24 *)
|
||||
)
|
||||
RETURN 0
|
||||
END divmod;
|
||||
|
||||
|
||||
PROCEDURE div_ (x, y: INTEGER): INTEGER;
|
||||
VAR
|
||||
div, mod: INTEGER;
|
||||
|
||||
BEGIN
|
||||
div := divmod(x, y, mod);
|
||||
IF ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) & (mod # 0) THEN
|
||||
DEC(div)
|
||||
END
|
||||
|
||||
RETURN div
|
||||
END div_;
|
||||
|
||||
|
||||
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
|
||||
VAR
|
||||
div, mod: INTEGER;
|
||||
|
||||
BEGIN
|
||||
div := divmod(x, y, mod);
|
||||
IF ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) & (mod # 0) THEN
|
||||
INC(mod, y)
|
||||
END
|
||||
|
||||
RETURN mod
|
||||
END mod_;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
|
||||
RETURN div_(a, b)
|
||||
END _div;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
|
||||
RETURN div_(a, b)
|
||||
END _div2;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
|
||||
RETURN mod_(a, b)
|
||||
END _mod;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
|
||||
RETURN mod_(a, b)
|
||||
END _mod2;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
|
||||
BEGIN
|
||||
ptr := API._NEW(size);
|
||||
IF ptr # 0 THEN
|
||||
SYSTEM.PUT(ptr, t);
|
||||
INC(ptr, SIZE_OF_QWORD)
|
||||
END
|
||||
END _new;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
|
||||
BEGIN
|
||||
IF ptr # 0 THEN
|
||||
ptr := API._DISPOSE(ptr - SIZE_OF_QWORD)
|
||||
END
|
||||
END _dispose;
|
||||
|
||||
|
||||
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
|
||||
VAR
|
||||
A, B: CHAR;
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
res := 0;
|
||||
WHILE n > 0 DO
|
||||
SYSTEM.GET(a, A); INC(a);
|
||||
SYSTEM.GET(b, B); INC(b);
|
||||
DEC(n);
|
||||
IF A # B THEN
|
||||
res := ORD(A) - ORD(B);
|
||||
n := 0
|
||||
ELSIF A = 0X THEN
|
||||
n := 0
|
||||
END
|
||||
END
|
||||
RETURN res
|
||||
END strncmp;
|
||||
|
||||
|
||||
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
|
||||
VAR
|
||||
A, B: WCHAR;
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
res := 0;
|
||||
WHILE n > 0 DO
|
||||
SYSTEM.GET(a, A); INC(a, 2);
|
||||
SYSTEM.GET(b, B); INC(b, 2);
|
||||
DEC(n);
|
||||
IF A # B THEN
|
||||
res := ORD(A) - ORD(B);
|
||||
n := 0
|
||||
ELSIF A = 0X THEN
|
||||
n := 0
|
||||
END
|
||||
END
|
||||
RETURN res
|
||||
END strncmpw;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _length* (len, str: INTEGER): INTEGER;
|
||||
VAR
|
||||
c: CHAR;
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
res := 0;
|
||||
REPEAT
|
||||
SYSTEM.GET(str, c); INC(str);
|
||||
DEC(len);
|
||||
INC(res)
|
||||
UNTIL (c = 0X) OR (len = 0);
|
||||
|
||||
IF c = 0X THEN
|
||||
DEC(res)
|
||||
END
|
||||
|
||||
RETURN res
|
||||
END _length;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
|
||||
VAR
|
||||
c: WCHAR;
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
res := 0;
|
||||
REPEAT
|
||||
SYSTEM.GET(str, c); INC(str, 2);
|
||||
DEC(len);
|
||||
INC(res)
|
||||
UNTIL (c = 0X) OR (len = 0);
|
||||
|
||||
IF c = 0X THEN
|
||||
DEC(res)
|
||||
END
|
||||
|
||||
RETURN res
|
||||
END _lengthw;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
|
||||
VAR
|
||||
res: INTEGER;
|
||||
bRes: BOOLEAN;
|
||||
|
||||
BEGIN
|
||||
|
||||
res := strncmp(str1, str2, MIN(len1, len2));
|
||||
IF res = 0 THEN
|
||||
res := _length(len1, str1) - _length(len2, str2)
|
||||
END;
|
||||
|
||||
CASE op OF
|
||||
|0: bRes := res = 0
|
||||
|1: bRes := res # 0
|
||||
|2: bRes := res < 0
|
||||
|3: bRes := res <= 0
|
||||
|4: bRes := res > 0
|
||||
|5: bRes := res >= 0
|
||||
END
|
||||
|
||||
RETURN bRes
|
||||
END _strcmp;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
|
||||
RETURN _strcmp(op, len2, str2, len1, str1)
|
||||
END _strcmp2;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
|
||||
VAR
|
||||
res: INTEGER;
|
||||
bRes: BOOLEAN;
|
||||
|
||||
BEGIN
|
||||
|
||||
res := strncmpw(str1, str2, MIN(len1, len2));
|
||||
IF res = 0 THEN
|
||||
res := _lengthw(len1, str1) - _lengthw(len2, str2)
|
||||
END;
|
||||
|
||||
CASE op OF
|
||||
|0: bRes := res = 0
|
||||
|1: bRes := res # 0
|
||||
|2: bRes := res < 0
|
||||
|3: bRes := res <= 0
|
||||
|4: bRes := res > 0
|
||||
|5: bRes := res >= 0
|
||||
END
|
||||
|
||||
RETURN bRes
|
||||
END _strcmpw;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
|
||||
RETURN _strcmpw(op, len2, str2, len1, str1)
|
||||
END _strcmpw2;
|
||||
|
||||
|
||||
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
|
||||
VAR
|
||||
c: CHAR;
|
||||
i: INTEGER;
|
||||
|
||||
BEGIN
|
||||
i := 0;
|
||||
REPEAT
|
||||
SYSTEM.GET(pchar, c);
|
||||
s[i] := c;
|
||||
INC(pchar);
|
||||
INC(i)
|
||||
UNTIL c = 0X
|
||||
END PCharToStr;
|
||||
|
||||
|
||||
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
|
||||
VAR
|
||||
i, a, b: INTEGER;
|
||||
c: CHAR;
|
||||
|
||||
BEGIN
|
||||
|
||||
i := 0;
|
||||
REPEAT
|
||||
str[i] := CHR(x MOD 10 + ORD("0"));
|
||||
x := x DIV 10;
|
||||
INC(i)
|
||||
UNTIL x = 0;
|
||||
|
||||
a := 0;
|
||||
b := i - 1;
|
||||
WHILE a < b DO
|
||||
c := str[a];
|
||||
str[a] := str[b];
|
||||
str[b] := c;
|
||||
INC(a);
|
||||
DEC(b)
|
||||
END;
|
||||
str[i] := 0X
|
||||
END IntToStr;
|
||||
|
||||
|
||||
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 [stdcall] _error* (module, err: INTEGER);
|
||||
VAR
|
||||
s, temp: ARRAY 1024 OF CHAR;
|
||||
|
||||
BEGIN
|
||||
|
||||
s := "";
|
||||
CASE err MOD 16 OF
|
||||
| 1: append(s, "assertion failure")
|
||||
| 2: append(s, "NIL dereference")
|
||||
| 3: append(s, "division by zero")
|
||||
| 4: append(s, "NIL procedure call")
|
||||
| 5: append(s, "type guard error")
|
||||
| 6: append(s, "index out of range")
|
||||
| 7: append(s, "invalid CASE")
|
||||
| 8: append(s, "array assignment error")
|
||||
| 9: append(s, "CHR out of range")
|
||||
|10: append(s, "WCHR out of range")
|
||||
|11: append(s, "BYTE out of range")
|
||||
END;
|
||||
|
||||
append(s, API.eol);
|
||||
|
||||
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
|
||||
append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
|
||||
|
||||
API.DebugMsg(SYSTEM.ADR(s[0]), name);
|
||||
|
||||
API.exit_thread(0)
|
||||
END _error;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
|
||||
BEGIN
|
||||
(* r IS t0 *)
|
||||
|
||||
WHILE (t1 # 0) & (t1 # t0) DO
|
||||
SYSTEM.GET(types + t1 * SIZE_OF_QWORD, t1)
|
||||
END
|
||||
|
||||
RETURN t1 = t0
|
||||
END _isrec;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
|
||||
VAR
|
||||
t1: INTEGER;
|
||||
|
||||
BEGIN
|
||||
(* p IS t0 *)
|
||||
|
||||
IF p # 0 THEN
|
||||
DEC(p, SIZE_OF_QWORD);
|
||||
SYSTEM.GET(p, t1);
|
||||
WHILE (t1 # 0) & (t1 # t0) DO
|
||||
SYSTEM.GET(types + t1 * SIZE_OF_QWORD, t1)
|
||||
END
|
||||
ELSE
|
||||
t1 := -1
|
||||
END
|
||||
|
||||
RETURN t1 = t0
|
||||
END _is;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
|
||||
BEGIN
|
||||
(* r:t1 IS t0 *)
|
||||
|
||||
WHILE (t1 # 0) & (t1 # t0) DO
|
||||
SYSTEM.GET(types + t1 * SIZE_OF_QWORD, t1)
|
||||
END
|
||||
|
||||
RETURN t1 = t0
|
||||
END _guardrec;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
|
||||
VAR
|
||||
t1: INTEGER;
|
||||
|
||||
BEGIN
|
||||
(* p IS t0 *)
|
||||
SYSTEM.GET(p, p);
|
||||
IF p # 0 THEN
|
||||
DEC(p, SIZE_OF_QWORD);
|
||||
SYSTEM.GET(p, t1);
|
||||
WHILE (t1 # t0) & (t1 # 0) DO
|
||||
SYSTEM.GET(types + t1 * SIZE_OF_QWORD, t1)
|
||||
END
|
||||
ELSE
|
||||
t1 := t0
|
||||
END
|
||||
|
||||
RETURN t1 = t0
|
||||
END _guard;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
|
||||
VAR
|
||||
res: INTEGER;
|
||||
|
||||
BEGIN
|
||||
CASE fdwReason OF
|
||||
|DLL_PROCESS_ATTACH:
|
||||
res := 1
|
||||
|DLL_THREAD_ATTACH:
|
||||
res := 0;
|
||||
IF dll.thread_attach # NIL THEN
|
||||
dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
|
||||
END
|
||||
|DLL_THREAD_DETACH:
|
||||
res := 0;
|
||||
IF dll.thread_detach # NIL THEN
|
||||
dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
|
||||
END
|
||||
|DLL_PROCESS_DETACH:
|
||||
res := 0;
|
||||
IF dll.process_detach # NIL THEN
|
||||
dll.process_detach(hinstDLL, fdwReason, lpvReserved)
|
||||
END
|
||||
ELSE
|
||||
res := 0
|
||||
END
|
||||
|
||||
RETURN res
|
||||
END _dllentry;
|
||||
|
||||
|
||||
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
|
||||
BEGIN
|
||||
dll.process_detach := process_detach;
|
||||
dll.thread_detach := thread_detach;
|
||||
dll.thread_attach := thread_attach
|
||||
END SetDll;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _exit* (code: INTEGER);
|
||||
BEGIN
|
||||
API.exit(code)
|
||||
END _exit;
|
||||
|
||||
|
||||
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
|
||||
BEGIN
|
||||
API.init(param, code);
|
||||
|
||||
types := _types;
|
||||
name := modname;
|
||||
|
||||
dll.process_detach := NIL;
|
||||
dll.thread_detach := NIL;
|
||||
dll.thread_attach := NIL;
|
||||
END _init;
|
||||
|
||||
|
||||
END RTL.
|
||||
Reference in new issue
Block a user