Subversion Repositories Kolibri OS

(*

    Copyright 2016, 2017 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 .

*)

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;

  init: BOOLEAN;

  main_thread_id: INTEGER;

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 [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;

  IF API.GetCurrentThreadId() = main_thread_id THEN

    API.ExitProcess(0)

  ELSE

    API.ExitThread(0)

  END

END _assrt;

PROCEDURE [stdcall] _close*;

BEGIN

  IF CloseProc # NIL THEN

    CloseProc

  END

END _close;

PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);

BEGIN

  IF ~init THEN

    API.zeromem(gsize, gadr);

    init := TRUE;

    API.init(esp);

    main_thread_id := API.GetCurrentThreadId();

    SelfName := self;

    rtab := rec;

    CloseProc := NIL

  END

END _init;

PROCEDURE SetClose*(proc: PROC);

BEGIN

  CloseProc := proc

END SetClose;

END RTL.