ruberon/lib/Windows/HOST.ob07

(*
    BSD 2-Clause License

    Copyright (c) 2018-2022, Anton Krotov
    All rights reserved.
*)

MODULE HOST;

IMPORT SYSTEM;


CONST

    slash* = "\";
    eol* = 0DX + 0AX;

    bit_depth* = (ORD(LSL(1, 31) > 0) + 1) * 32;
    maxint* = ROR(-2, 1);
    minint* = ROR(1, 1);

    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*, inf*: 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;
VAR
    res: INTEGER;

BEGIN
    a := 0;
    b := 0;
    SYSTEM.GET32(SYSTEM.ADR(x), a);
    SYSTEM.GET32(SYSTEM.ADR(x) + 4, b);
    SYSTEM.GET(SYSTEM.ADR(x), res)
    RETURN res
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
    inf := SYSTEM.INF();
    maxreal := 1.9;
    PACK(maxreal, 1023);
    hConsoleOutput := _GetStdHandle(-11);
    ParamParse
END HOST.