(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, RTL;
CONST
slash* = "\";
eol* = 0DX + 0AX;
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
MAX_PARAM = 1024;
OFS_MAXPATHNAME = 128;
TYPE
POverlapped = POINTER TO OVERLAPPED;
OVERLAPPED = RECORD
Internal: INTEGER;
InternalHigh: INTEGER;
Offset: INTEGER;
OffsetHigh: INTEGER;
hEvent: INTEGER
END;
OFSTRUCT = RECORD
cBytes: CHAR;
fFixedDisk: CHAR;
nErrCode: WCHAR;
Reserved1: WCHAR;
Reserved2: WCHAR;
szPathName: ARRAY OFS_MAXPATHNAME OF CHAR
END;
PSecurityAttributes = POINTER TO TSecurityAttributes;
TSecurityAttributes = RECORD
nLength: INTEGER;
lpSecurityDescriptor: INTEGER;
bInheritHandle: INTEGER
END;
VAR
hConsoleOutput: INTEGER;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc: INTEGER;
maxreal*: REAL;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
_GetTickCount (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
_GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
_GetCommandLine (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
_ReadFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
_WriteFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
_CloseHandle (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CreateFileA"]
_CreateFile (
lpFileName, dwDesiredAccess, dwShareMode: INTEGER;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition, dwFlagsAndAttributes,
hTemplateFile: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
_OpenFile (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCurrentDirectoryA"]
_GetCurrentDirectory (nBufferLength, lpBuffer: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
_ExitProcess (code: INTEGER);
PROCEDURE [ccall, "msvcrt.dll", "time"]
_time (ptr: INTEGER): INTEGER;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
_ExitProcess(code)
END ExitProcess;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
n := _GetCurrentDirectory(LEN(path), SYSTEM.ADR(path[0]));
path[n] := slash;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR
p, count, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; VAR cond: INTEGER; c: CHAR);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
cond := C
END
END ChangeCond;
BEGIN
p := _GetCommandLine();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, cond, c); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, cond, c); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, cond, c); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
BEGIN
j := 0;
IF n < argc THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i)
END
END;
s[j] := 0X
END GetArg;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, res, NIL) = 0 THEN
res := -1
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, res, NIL) = 0 THEN
res := -1
END
RETURN res
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN _CreateFile(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
_CloseHandle(F)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
ofstr: OFSTRUCT;
res: INTEGER;
BEGIN
res := _OpenFile(SYSTEM.ADR(FName[0]), ofstr, 0);
IF res = 0FFFFFFFFH THEN
res := -1
END
RETURN res
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
END chmod;
PROCEDURE OutChar* (c: CHAR);
VAR
count: INTEGER;
BEGIN
_WriteFile(hConsoleOutput, SYSTEM.ADR(c), 1, count, NIL)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
RETURN _GetTickCount() DIV 10
END GetTickCount;
PROCEDURE letter (c: CHAR): BOOLEAN;
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z")
END letter;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN ~(letter(path[0]) & (path[1] = ":"))
END isRelative;
PROCEDURE UnixTime* (): INTEGER;
RETURN _time(0)
END UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
SYSTEM.GET32(SYSTEM.ADR(x), a);
SYSTEM.GET32(SYSTEM.ADR(x) + 4, b)
RETURN a
END splitf;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
BEGIN
maxreal := 1.9;
PACK(maxreal, 1023);
hConsoleOutput := _GetStdHandle(-11);
ParamParse
END HOST.