(*
    Copyright 2016 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 RTL;

IMPORT sys := SYSTEM, API;

TYPE

  IntArray = ARRAY 2048 OF INTEGER;
  STRING = ARRAY 2048 OF CHAR;
  PROC = PROCEDURE;

VAR

  SelfName, rtab: INTEGER; CloseProc: PROC;

PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN
  API.ExitProcess(n)
END _halt;

PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
BEGIN
  ptr := API._NEW(size);
  IF ptr # 0 THEN
    sys.PUT(ptr, t);
    INC(ptr, 4)
  END
END _newrec;

PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
BEGIN
  IF ptr # 0 THEN
    ptr := API._DISPOSE(ptr - 4)
  END
END _disprec;

PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
  sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;

PROCEDURE [stdcall] _inset*(y, x: INTEGER);
BEGIN
  sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;

PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
BEGIN
  table := rtab;
  sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;

PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
BEGIN
  sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;

PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
  res := dyn = stat;
  IF res THEN
    _savearr(size, source, dest)
  END
  RETURN res
END _saverec;

PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: 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
  END
END _arrayidx;

PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
BEGIN
  IF (Arr[3] > idx) & (idx >= 0) THEN
    Arr[3] := bsize * idx + c
  ELSE
    Arr[3] := 0
  END
END _arrayidx1;

PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: 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
  END
END _arrayrot;

PROCEDURE Min(a, b: INTEGER): INTEGER;
BEGIN
  IF a > b THEN
    a := b
  END
  RETURN a
END Min;

PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): 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
  RETURN 0
END _length;

PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN
  _savearr(Min(alen, blen), a, b);
  IF blen > alen THEN
    sys.PUT(b + alen, 0X)
  END
END _strcopy;

PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: 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)
  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
  END
  RETURN Res
END _strcmp;

PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
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;
BEGIN
  s[0] := a;
  s[1] := 0X;
  RETURN _strcmp(op, b, s)
END _rstrcmp;

PROCEDURE Int(x: INTEGER; VAR str: STRING);
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;
  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 Int;

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;
  BEGIN
    n := LEN(s);
    i := 0;
    WHILE (i < n) & (s[i] # 0X) DO
      msg[pos] := s[i];
      INC(pos);
      INC(i)
    END
  END StrAppend;

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")
  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)
END _assrt;

PROCEDURE [stdcall] _close*;
BEGIN
  IF CloseProc # NIL THEN
    CloseProc
  END
END _close;

PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
BEGIN
  API.zeromem(gsize, gadr);
  API.init(esp);
  SelfName := self;
  rtab := rec;
  CloseProc := NIL
END _init;

PROCEDURE SetClose*(proc: PROC);
BEGIN
  CloseProc := proc
END SetClose;

END RTL.