Subversion Repositories Kolibri OS

Compare Revisions

Regard whitespace Rev 7107 → Rev 7597

/programs/develop/oberon07/Lib/Linux32/API.ob07
1,148 → 1,145
(*
Copyright 2016 Anton Krotov
BSD 2-Clause License
 
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/>.
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
 
MODULE API;
 
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
 
 
CONST
 
BASE_ADR = 08048000H;
 
 
TYPE
 
TP* = ARRAY 2 OF INTEGER;
 
 
VAR
 
Param*: INTEGER;
eol*: ARRAY 2 OF CHAR;
base*, MainParam*: INTEGER;
 
sec* : INTEGER;
dsec* : INTEGER;
stdin* : INTEGER;
stdout* : INTEGER;
libc*, librt*: INTEGER;
 
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): INTEGER;
 
stdout*,
stdin*,
stderr* : INTEGER;
dlopen* : PROCEDURE [cdecl] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [cdecl] (handle, symbol: INTEGER): INTEGER;
_malloc* : PROCEDURE [cdecl] (size: INTEGER): INTEGER;
free* : PROCEDURE [cdecl] (ptr: INTEGER);
fopen* : PROCEDURE [cdecl] (fname, fmode: INTEGER): INTEGER;
fclose*, ftell* : PROCEDURE [cdecl] (file: INTEGER): INTEGER;
fwrite*, fread* : PROCEDURE [cdecl] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fseek* : PROCEDURE [cdecl] (file, offset, origin: INTEGER): INTEGER;
exit* : PROCEDURE [cdecl] (code: INTEGER);
strncmp* : PROCEDURE [cdecl] (str1, str2, n: INTEGER): INTEGER;
strlen* : PROCEDURE [cdecl] (str: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [cdecl] (clock_id: INTEGER; VAR tp: TP): INTEGER;
 
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER);
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
_exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
 
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
 
 
PROCEDURE putc* (c: CHAR);
VAR
res: INTEGER;
 
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END putc;
 
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
 
PROCEDURE malloc* (Bytes: INTEGER): INTEGER;
VAR res: INTEGER;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
Bytes := Align(Bytes, 4);
res := _malloc(Bytes);
puts(lpCaption);
puts(lpText)
END DebugMsg;
 
 
PROCEDURE _NEW* (size: INTEGER): INTEGER;
VAR
res, ptr, words: INTEGER;
 
BEGIN
res := malloc(size);
IF res # 0 THEN
zeromem(ASR(Bytes, 2), res)
ptr := res;
words := size DIV SYSTEM.SIZE(INTEGER);
WHILE words > 0 DO
SYSTEM.PUT(ptr, 0);
INC(ptr, SYSTEM.SIZE(INTEGER));
DEC(words)
END
END
 
RETURN res
END malloc;
END _NEW;
 
PROCEDURE Free* (hMem: INTEGER): INTEGER;
 
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
free(hMem)
free(p)
RETURN 0
END Free;
 
PROCEDURE _NEW*(size: INTEGER): INTEGER;
RETURN malloc(size)
END _NEW;
 
PROCEDURE _DISPOSE*(p: INTEGER): INTEGER;
RETURN Free(p)
END _DISPOSE;
 
PROCEDURE ConOut(str, length: INTEGER);
BEGIN
length := fwrite(str, length, 1, stdout)
END ConOut;
 
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
VAR eol: ARRAY 3 OF CHAR;
PROCEDURE GetProcAdr (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
eol[0] := 0DX;
eol[1] := 0AX;
eol[2] := 00X;
ConOut(sys.ADR(eol), 2);
ConOut(lpCaption, strlen(lpCaption));
ConOut(sys.ADR(":"), 1);
ConOut(sys.ADR(eol), 2);
ConOut(lpText, strlen(lpText));
ConOut(sys.ADR(eol), 2);
END DebugMsg;
sym := dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetProcAdr;
 
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
exit(code)
END ExitProcess;
 
PROCEDURE ExitThread* (code: INTEGER);
PROCEDURE init* (sp, code: INTEGER);
BEGIN
exit(code)
END ExitThread;
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
base := BASE_ADR;
eol := 0AX;
 
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
VAR H: INTEGER;
libc := dlopen(SYSTEM.SADR("libc.so.6"), 1);
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 - SYSTEM.SIZE(INTEGER), stdout);
SYSTEM.GET(stdin - SYSTEM.SIZE(INTEGER), stdin);
SYSTEM.GET(stderr - SYSTEM.SIZE(INTEGER), 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 := dlopen(SYSTEM.SADR("librt.so.1"), 1);
GetProcAdr(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END init;
 
 
PROCEDURE exit* (code: INTEGER);
BEGIN
H := dlsym(hMOD, sys.ADR(name[0]));
ASSERT(H # 0);
sys.PUT(adr, H);
END GetProc;
_exit(code)
END exit;
 
PROCEDURE init* (esp: INTEGER);
VAR lib, proc: INTEGER;
 
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
Param := esp;
sys.MOVE(Param + 12, sys.ADR(dlopen), 4);
sys.MOVE(Param + 16, sys.ADR(dlsym), 4);
sys.MOVE(Param + 20, sys.ADR(exit), 4);
sys.MOVE(Param + 24, sys.ADR(stdin), 4);
sys.MOVE(Param + 28, sys.ADR(stdout), 4);
sys.MOVE(Param + 32, sys.ADR(stderr), 4);
sys.MOVE(Param + 36, sys.ADR(_malloc), 4);
sys.MOVE(Param + 40, sys.ADR(free), 4);
sys.MOVE(Param + 44, sys.ADR(fopen), 4);
sys.MOVE(Param + 48, sys.ADR(fclose), 4);
sys.MOVE(Param + 52, sys.ADR(fwrite), 4);
sys.MOVE(Param + 56, sys.ADR(fread), 4);
sys.MOVE(Param + 60, sys.ADR(fseek), 4);
sys.MOVE(Param + 64, sys.ADR(ftell), 4);
_exit(code)
END exit_thread;
 
lib := dlopen(sys.ADR("libc.so.6"), 1);
ASSERT(lib # 0);
GetProc("strncmp", lib, sys.ADR(strncmp));
GetProc("strlen", lib, sys.ADR(strlen));
 
lib := dlopen(sys.ADR("librt.so.1"), 1);
ASSERT(lib # 0);
GetProc("clock_gettime", lib, sys.ADR(clock_gettime));
END init;
 
END API.
/programs/develop/oberon07/Lib/Linux32/HOST.ob07
1,121 → 1,178
(*
Copyright 2016 Anton Krotov
(*
BSD 2-Clause License
 
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/>.
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
 
MODULE HOST;
 
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, API, RTL;
 
 
CONST
 
OS* = "LNX";
Slash* = "/";
slash* = "/";
OS* = "LINUX";
 
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
 
 
VAR
 
fsize : INTEGER;
argc: INTEGER;
 
sec* : INTEGER;
dsec* : INTEGER;
eol*: ARRAY 2 OF CHAR;
 
PROCEDURE GetCommandLine* (): INTEGER;
RETURN API.Param
END GetCommandLine;
 
PROCEDURE CloseFile* (File: INTEGER);
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
File := API.fclose(File)
END CloseFile;
API.exit(code)
END ExitProcess;
 
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR res: INTEGER;
 
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
 
BEGIN
IF write THEN
res := API.fwrite(Buffer, nNumberOfBytes, 1, hFile) * nNumberOfBytes
ELSE
res := API.fread(Buffer, nNumberOfBytes, 1, hFile) * nNumberOfBytes
END
RETURN res
END FileRW;
i := 0;
len := LEN(s) - 1;
IF (n < argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), 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 OutString* (str: ARRAY OF CHAR);
VAR res: INTEGER;
 
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
 
BEGIN
res := FileRW(API.stdout, sys.ADR(str), LENGTH(str), TRUE)
END OutString;
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
 
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(sys.ADR(FName), sys.ADR("wb"))
END CreateFile;
 
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
VAR F, res: INTEGER;
PROCEDURE ReadFile (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN API.fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F)
END ReadFile;
 
 
PROCEDURE WriteFile (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN API.fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F)
END WriteFile;
 
 
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
 
BEGIN
F := API.fopen(sys.ADR(FName), sys.ADR("rb"));
IF F # 0 THEN
res := API.fseek(F, 0, 2);
fsize := API.ftell(F);
res := API.fseek(F, 0, 0)
res := ReadFile(F, Buffer, bytes);
IF res <= 0 THEN
res := -1
END
RETURN F
END OpenFile;
 
PROCEDURE FileSize* (F: INTEGER): INTEGER;
RETURN fsize
END FileSize;
RETURN res
END FileRead;
 
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
 
PROCEDURE malloc* (Bytes: INTEGER): INTEGER;
VAR res: INTEGER;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
 
BEGIN
Bytes := Align(Bytes, 4);
res := API.malloc(Bytes);
IF res # 0 THEN
API.zeromem(ASR(Bytes, 2), res)
res := WriteFile(F, Buffer, bytes);
IF res <= 0 THEN
res := -1
END
 
RETURN res
END malloc;
END FileWrite;
 
PROCEDURE ExitProcess* (code: INTEGER);
 
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
END FileCreate;
 
 
PROCEDURE FileClose* (File: INTEGER);
BEGIN
API.exit(code)
END ExitProcess;
File := API.fclose(File)
END FileClose;
 
PROCEDURE Time* (VAR sec, dsec: INTEGER);
VAR tp: API.TP;
 
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
END FileOpen;
 
 
PROCEDURE OutChar* (c: CHAR);
BEGIN
API.putc(c)
END OutChar;
 
 
PROCEDURE GetTickCount* (): INTEGER;
VAR
tp: API.TP;
res: INTEGER;
 
BEGIN
IF API.clock_gettime(0, tp) = 0 THEN
sec := tp[0];
dsec := tp[1] DIV 10000000
res := tp[0] * 100 + tp[1] DIV 10000000
ELSE
sec := 0;
dsec := 0
res := 0
END
END Time;
 
PROCEDURE init*;
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.time(0)
END UnixTime;
 
 
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
 
BEGIN
Time(sec, dsec)
END init;
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;
 
PROCEDURE GetName*(): INTEGER;
RETURN 0
END GetName;
 
BEGIN
eol := 0AX;
SYSTEM.GET(API.MainParam, argc)
END HOST.
/programs/develop/oberon07/Lib/Linux32/LINAPI.ob07
0,0 → 1,141
(*
BSD 2-Clause License
 
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
 
MODULE LINAPI;
 
IMPORT SYSTEM, API;
 
 
TYPE
 
TP* = API.TP;
 
 
VAR
 
argc*, envc*: INTEGER;
 
libc*, librt*: INTEGER;
 
stdout*,
stdin*,
stderr* : INTEGER;
 
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
 
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
 
 
PROCEDURE dlopen* (filename: ARRAY OF CHAR): INTEGER;
RETURN API.dlopen(SYSTEM.ADR(filename[0]), 1)
END dlopen;
 
 
PROCEDURE dlsym* (handle: INTEGER; symbol: ARRAY OF CHAR): INTEGER;
RETURN API.dlsym(handle, SYSTEM.ADR(symbol[0]))
END dlsym;
 
 
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
 
BEGIN
i := 0;
len := LEN(s) - 1;
IF (0 <= n) & (n <= argc + envc) & (n # argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), 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 GetEnv* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
IF (0 <= n) & (n < envc) THEN
GetArg(n + argc + 1, s)
ELSE
s[0] := 0X
END
END GetEnv;
 
 
PROCEDURE init;
VAR
ptr: INTEGER;
 
BEGIN
envc := -1;
SYSTEM.GET(API.MainParam, argc);
REPEAT
SYSTEM.GET(API.MainParam + (envc + argc + 3) * SYSTEM.SIZE(INTEGER), ptr);
INC(envc)
UNTIL ptr = 0;
 
libc := API.libc;
 
stdout := API.stdout;
stdin := API.stdin;
stderr := API.stderr;
 
malloc := API.malloc;
free := API.free;
exit := API._exit;
puts := API.puts;
fwrite := API.fwrite;
fread := API.fread;
fopen := API.fopen;
fclose := API.fclose;
time := API.time;
 
librt := API.librt;
 
clock_gettime := API.clock_gettime
END init;
 
 
PROCEDURE [stdcall-] syscall* (eax, ebx, ecx, edx, esi, edi: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
0CDH, 080H, (* int 128 *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END syscall;
 
 
BEGIN
init
END LINAPI.
/programs/develop/oberon07/Lib/Linux32/RTL.ob07
1,193 → 1,441
(*
Copyright 2016, 2017 Anton Krotov
BSD 2-Clause License
 
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/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
 
MODULE RTL;
 
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, API;
 
 
CONST
 
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
 
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
 
SIZE_OF_DWORD = 4;
 
 
TYPE
 
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
 
 
VAR
 
SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
name: INTEGER;
types: INTEGER;
 
PROCEDURE [stdcall] _halt*(n: INTEGER);
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
 
 
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
BEGIN
API.ExitProcess(n)
END _halt;
SYSTEM.CODE(
 
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 00CH, (* mov esi, dword [ebp + 12] *)
08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
 
 
PROCEDURE [stdcall] _move2* (bytes, dest, source: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
SYSTEM.CODE(
 
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move2;
 
 
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
 
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, src, dst);
res := TRUE
END
END _disprec;
 
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
RETURN res
END _arrcpy;
 
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
 
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
 
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
 
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
 
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
 
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
 
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
 
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
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
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
END;
IF a < 0 THEN
a := 0
END;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
ELSE
res := 0
END
 
RETURN res
END _saverec;
END _set2;
 
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: INTEGER;
 
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
END _set;
 
 
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
BEGIN
m := bsize * idx;
FOR i := 4 TO Dim + 2 DO
m := m * Arr[i]
END;
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := c + m
ELSE
Arr[3] := 0
SYSTEM.CODE(
 
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
0F7H, 0F9H, (* idiv ecx *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 011H, (* mov dword [ecx], edx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
 
RETURN 0
END divmod;
 
 
PROCEDURE div_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
 
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
DEC(div)
END
END _arrayidx;
 
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
RETURN div
END div_;
 
 
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
 
BEGIN
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
INC(mod, y)
END
END _arrayidx1;
 
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: INTEGER;
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
FOR i := 1 TO n DO
t := Arr[0];
FOR j := 0 TO m + n - 1 DO
Arr[j] := Arr[j + 1]
END;
Arr[m + n] := t
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, SIZE_OF_DWORD)
END
END _arrayrot;
END _new;
 
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
 
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
BEGIN
sys.CODE("8B4508"); // mov eax, [ebp + 08h]
sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch]
sys.CODE("48"); // dec eax
// L1:
sys.CODE("40"); // inc eax
sys.CODE("803800"); // cmp byte ptr [eax], 0
sys.CODE("7403"); // jz L2
sys.CODE("E2F8"); // loop L1
sys.CODE("40"); // inc eax
// L2:
sys.CODE("2B4508"); // sub eax, [ebp + 08h]
sys.CODE("C9"); // leave
sys.CODE("C20800"); // ret 08h
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
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;
BEGIN
SYSTEM.CODE(
 
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
 
RETURN 0
END _length;
 
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
 
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
BEGIN
_savearr(MIN(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
SYSTEM.CODE(
 
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H, (* shr eax, 1 *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
 
RETURN 0
END _lengthw;
 
 
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
 
BEGIN
i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b)));
IF i = 0 THEN
i := _length(a) - _length(b)
 
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
END;
 
CASE op OF
|0: Res := i = 0
|1: Res := i # 0
|2: Res := i < 0
|3: Res := i > 0
|4: Res := i <= 0
|5: Res := i >= 0
ELSE
|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 Res
 
RETURN bRes
END _strcmp;
 
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
 
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
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
 
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
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
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
 
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
 
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
 
BEGIN
 
i := 0;
a := 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];
197,80 → 445,186
DEC(b)
END;
str[i] := 0X
END Int;
END IntToStr;
 
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER);
VAR msg, int: STRING; pos, n: INTEGER;
 
PROCEDURE StrAppend(s: STRING);
VAR i, n: INTEGER;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n := LEN(s);
n1 := LENGTH(s1);
n2 := LENGTH(s2);
 
ASSERT(n1 + n2 < LEN(s1));
 
i := 0;
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
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_DWORD, t1)
END
END StrAppend;
 
RETURN t1 = t0
END _isrec;
 
 
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
 
BEGIN
pos := 0;
n := line MOD 16;
line := line DIV 16;
CASE n OF
|1: StrAppend("assertion failure")
|2: StrAppend("variable of a procedure type has NIL as value")
|3: StrAppend("typeguard error")
|4: StrAppend("inadmissible dynamic type")
|5: StrAppend("index check error")
|6: StrAppend("NIL pointer dereference")
|7: StrAppend("invalid value in case statement")
|8: StrAppend("division by zero")
(* p IS t0 *)
 
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
ELSE
END;
StrAppend(0DX);
StrAppend(0AX);
StrAppend("module ");
StrAppend(modname);
StrAppend(0DX);
StrAppend(0AX);
StrAppend("line ");
Int(line, int);
StrAppend(int);
IF m = 2 THEN
StrAppend(0DX);
StrAppend(0AX);
StrAppend("code ");
Int(code, int);
StrAppend(int)
END;
API.DebugMsg(sys.ADR(msg), SelfName);
API.ExitThread(0)
END _assrt;
t1 := -1
END
 
PROCEDURE [stdcall] _close*;
RETURN t1 = t0
END _is;
 
 
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
BEGIN
IF CloseProc # NIL THEN
CloseProc
(* r:t1 IS t0 *)
 
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END _close;
 
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
RETURN t1 = t0
END _guardrec;
 
 
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
 
BEGIN
IF ~init THEN
API.zeromem(gsize, gadr);
init := TRUE;
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL
(* p IS t0 *)
SYSTEM.GET(p, p);
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END _init;
ELSE
t1 := t0
END
 
PROCEDURE SetClose*(proc: PROC);
RETURN t1 = t0
END _guard;
 
 
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
 
BEGIN
CloseProc := proc
END SetClose;
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
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
 
types := _types;
name := modname;
 
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
END _init;
 
 
END RTL.