ruberon/lib/Linux/RTL.ob07

(*
    BSD 2-Clause License

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

(*---------------------x86_64---------------------*)

$IF (CPU_X8664)
MODULE RTL;

IMPORT SYSTEM, API;


CONST

    minint = ROR(1, 1);

    WORD = API.BIT_DEPTH DIV 8;


VAR

    name:  INTEGER;
    types: INTEGER;


PROCEDURE [oberon] _move* (bytes, dest, source: INTEGER);
BEGIN
    SYSTEM.CODE(
    048H, 08BH, 045H, 010H,    (*  mov     rax, qword [rbp + 16]  *)
    048H, 085H, 0C0H,          (*  test    rax, rax               *)
    07EH, 020H,                (*  jle     L                      *)
    0FCH,                      (*  cld                            *)
    057H,                      (*  push    rdi                    *)
    056H,                      (*  push    rsi                    *)
    048H, 08BH, 075H, 020H,    (*  mov     rsi, qword [rbp + 32]  *)
    048H, 08BH, 07DH, 018H,    (*  mov     rdi, qword [rbp + 24]  *)
    048H, 089H, 0C1H,          (*  mov     rcx, rax               *)
    048H, 0C1H, 0E9H, 003H,    (*  shr     rcx, 3                 *)
    0F3H, 048H, 0A5H,          (*  rep     movsd                  *)
    048H, 089H, 0C1H,          (*  mov     rcx, rax               *)
    048H, 083H, 0E1H, 007H,    (*  and     rcx, 7                 *)
    0F3H, 0A4H,                (*  rep     movsb                  *)
    05EH,                      (*  pop     rsi                    *)
    05FH                       (*  pop     rdi                    *)
                               (*  L:                             *)
                )
END _move;


PROCEDURE [oberon] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
    res: BOOLEAN;

BEGIN
    IF len_src > len_dst THEN
        res := FALSE
    ELSE
        _move(len_src * base_size, dst, src);
        res := TRUE
    END

    RETURN res
END _arrcpy;


PROCEDURE [oberon] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
    _move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;


PROCEDURE [oberon] _rot* (Len, Ptr: INTEGER);
BEGIN
    SYSTEM.CODE(
    048H, 08BH, 04DH, 010H,   (*  mov   rcx, qword [rbp + 16]  *)  (* rcx <- Len *)
    048H, 08BH, 045H, 018H,   (*  mov   rax, qword [rbp + 24]  *)  (* rax <- Ptr *)
    048H, 0FFH, 0C9H,         (*  dec   rcx                    *)
    04CH, 08BH, 010H,         (*  mov   r10, qword [rax]       *)
                              (*  L:                           *)
    048H, 08BH, 050H, 008H,   (*  mov   rdx, qword [rax + 8]   *)
    048H, 089H, 010H,         (*  mov   qword [rax], rdx       *)
    048H, 083H, 0C0H, 008H,   (*  add   rax, 8                 *)
    048H, 0FFH, 0C9H,         (*  dec   rcx                    *)
    075H, 0F0H,               (*  jnz   L                      *)
    04CH, 089H, 010H,         (*  mov   qword [rax], r10       *)
    05DH,                     (*  pop   rbp                    *)
    0C2H, 010H, 000H          (*  ret   16                     *)
    )
END _rot;


PROCEDURE [oberon] _set* (b, a: INTEGER); (* {a..b} -> rax *)
BEGIN
    SYSTEM.CODE(
    048H, 08BH, 04DH, 010H,    (*  mov   rcx, qword ptr [rbp + 16]  *)  (* rcx <- b *)
    048H, 08BH, 045H, 018H,    (*  mov   rax, qword ptr [rbp + 24]  *)  (* rax <- a *)
    048H, 039H, 0C8H,          (*  cmp   rax, rcx                   *)
    07FH, 047H,                (*  jg    L1                         *)
    048H, 083H, 0F8H, 03FH,    (*  cmp   rax, 63                    *)
    07FH, 041H,                (*  jg    L1                         *)
    048H, 085H, 0C9H,          (*  test  rcx, rcx                   *)
    07CH, 03CH,                (*  jl    L1                         *)
    048H, 083H, 0F9H, 03FH,    (*  cmp   rcx, 63                    *)
    07EH, 007H,                (*  jle   L3                         *)
    048H, 0C7H, 0C1H, 03FH,    (*  mov   rcx, 63                    *)
    000H, 000H, 000H,
                               (*  L3:                              *)
    048H, 085H, 0C0H,          (*  test  rax, rax                   *)
    07DH, 003H,                (*  jge   L2                         *)
    048H, 031H, 0C0H,          (*  xor   rax, rax                   *)
                               (*  L2:                              *)
    048H, 089H, 0CAH,          (*  mov   rdx, rcx                   *)
    048H, 029H, 0C2H,          (*  sub   rdx, rax                   *)
    048H, 0B8H, 000H, 000H,    (*  movabs   rax, minint             *)
    000H, 000H, 000H, 000H,
    000H, 080H,

    048H, 087H, 0CAH,          (*  xchg  rdx, rcx                   *)
    048H, 0D3H, 0F8H,          (*  sar   rax, cl                    *)
    048H, 087H, 0CAH,          (*  xchg  rdx, rcx                   *)
    048H, 083H, 0E9H, 03FH,    (*  sub   rcx, 63                    *)
    048H, 0F7H, 0D9H,          (*  neg   rcx                        *)
    048H, 0D3H, 0E8H,          (*  shr   rax, cl                    *)
    05DH,                      (*  pop   rbp                        *)
    0C2H, 010H, 000H,          (*  ret   16                         *)
                               (*  L1:                              *)
    048H, 031H, 0C0H,          (*  xor   rax, rax                   *)
    05DH,                      (*  pop   rbp                        *)
    0C2H, 010H, 000H           (*  ret   16                         *)
    )
END _set;


PROCEDURE [oberon] _set1* (a: INTEGER); (* {a} -> rax *)
BEGIN
    SYSTEM.CODE(
    048H, 031H, 0C0H,         (*  xor  rax, rax               *)
    048H, 08BH, 04DH, 010H,   (*  mov  rcx, qword [rbp + 16]  *)  (* rcx <- a *)
    048H, 083H, 0F9H, 03FH,   (*  cmp  rcx, 63                *)
    077H, 004H,               (*  ja   L                      *)
    048H, 00FH, 0ABH, 0C8H    (*  bts  rax, rcx               *)
                              (*  L:                          *)
    )
END _set1;


PROCEDURE [oberon] _divmod* (y, x: INTEGER); (* (x div y) -> rax; (x mod y) -> rdx *)
BEGIN
    SYSTEM.CODE(
    048H, 08BH, 045H, 018H,    (*  mov     rax, qword [rbp + 24]  *)  (* rax <- x *)
    048H, 031H, 0D2H,          (*  xor     rdx, rdx               *)
    048H, 085H, 0C0H,          (*  test    rax, rax               *)
    074H, 022H,                (*  je      L2                     *)
    07FH, 003H,                (*  jg      L1                     *)
    048H, 0F7H, 0D2H,          (*  not     rdx                    *)
                               (*  L1:                            *)
    049H, 089H, 0C0H,          (*  mov     r8, rax                *)
    048H, 08BH, 04DH, 010H,    (*  mov     rcx, qword [rbp + 16]  *)  (* rcx <- y *)
    048H, 0F7H, 0F9H,          (*  idiv    rcx                    *)
    048H, 085H, 0D2H,          (*  test    rdx, rdx               *)
    074H, 00EH,                (*  je      L2                     *)
    049H, 031H, 0C8H,          (*  xor     r8, rcx                *)
    04DH, 085H, 0C0H,          (*  test    r8, r8                 *)
    07DH, 006H,                (*  jge     L2                     *)
    048H, 0FFH, 0C8H,          (*  dec     rax                    *)
    048H, 001H, 0CAH           (*  add     rdx, rcx               *)
                               (*  L2:                            *)
               )
END _divmod;


PROCEDURE [oberon] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
    ptr := API._NEW(size);
    IF ptr # 0 THEN
        SYSTEM.PUT(ptr + 8, t);
        INC(ptr, 16)
    END
END _new;


PROCEDURE [oberon] _dispose* (VAR ptr: INTEGER);
BEGIN
    IF ptr # 0 THEN
        ptr := API._DISPOSE(ptr - 16)
    END
END _dispose;


PROCEDURE [oberon] _length* (len, str: INTEGER);
BEGIN
    SYSTEM.CODE(
    048H, 08BH, 045H, 018H,     (*  mov     rax, qword [rbp + 24]  *)
    048H, 08BH, 04DH, 010H,     (*  mov     rcx, qword [rbp + 16]  *)
    048H, 0FFH, 0C8H,           (*  dec     rax                    *)
                                (*  L1:                            *)
    048H, 0FFH, 0C0H,           (*  inc     rax                    *)
    080H, 038H, 000H,           (*  cmp     byte [rax], 0          *)
    074H, 005H,                 (*  jz      L2                     *)
    0E2H, 0F6H,                 (*  loop    L1                     *)
    048H, 0FFH, 0C0H,           (*  inc     rax                    *)
                                (*  L2:                            *)
    048H, 02BH, 045H, 018H      (*  sub     rax, qword [rbp + 24]  *)
               )
END _length;


PROCEDURE [oberon] _lengthw* (len, str: INTEGER);
BEGIN
    SYSTEM.CODE(
    048H, 08BH, 045H, 018H,     (*  mov     rax, qword [rbp + 24]  *)
    048H, 08BH, 04DH, 010H,     (*  mov     rcx, qword [rbp + 16]  *)
    048H, 083H, 0E8H, 002H,     (*  sub     rax, 2                 *)
                                (*  L1:                            *)
    048H, 083H, 0C0H, 002H,     (*  add     rax, 2                 *)
    066H, 083H, 038H, 000H,     (*  cmp     word [rax], 0          *)
    074H, 006H,                 (*  jz      L2                     *)
    0E2H, 0F4H,                 (*  loop    L1                     *)
    048H, 083H, 0C0H, 002H,     (*  add     rax, 2                 *)
                                (*  L2:                            *)
    048H, 02BH, 045H, 018H,     (*  sub     rax, qword [rbp + 24]  *)
    048H, 0D1H, 0E8H            (*  shr     rax, 1                 *)
               )
END _lengthw;


PROCEDURE [oberon] strncmp (a, b, n: INTEGER): INTEGER;
BEGIN
    SYSTEM.CODE(
    048H, 08BH, 04DH, 010H,   (*  mov     rcx, qword[rbp + 16]; rcx <- a *)
    048H, 08BH, 055H, 018H,   (*  mov     rdx, qword[rbp + 24]; rdx <- b *)
    04CH, 08BH, 045H, 020H,   (*  mov     r8,  qword[rbp + 32]; r8  <- n *)
    04DH, 031H, 0C9H,         (*  xor     r9, r9                         *)
    04DH, 031H, 0D2H,         (*  xor     r10, r10                       *)
    048H, 0B8H, 000H, 000H,   (*  movabs  rax, minint                    *)
    000H, 000H, 000H, 000H,
    000H, 080H,
                              (*  L1:                                    *)
    04DH, 085H, 0C0H,         (*  test    r8, r8                         *)
    07EH, 024H,               (*  jle     L3                             *)
    044H, 08AH, 009H,         (*  mov     r9b, byte[rcx]                 *)
    044H, 08AH, 012H,         (*  mov     r10b, byte[rdx]                *)
    048H, 0FFH, 0C1H,         (*  inc     rcx                            *)
    048H, 0FFH, 0C2H,         (*  inc     rdx                            *)
    049H, 0FFH, 0C8H,         (*  dec     r8                             *)
    04DH, 039H, 0D1H,         (*  cmp     r9, r10                        *)
    074H, 008H,               (*  je      L2                             *)
    04CH, 089H, 0C8H,         (*  mov     rax, r9                        *)
    04CH, 029H, 0D0H,         (*  sub     rax, r10                       *)
    0EBH, 008H,               (*  jmp     L3                             *)
                              (*  L2:                                    *)
    04DH, 085H, 0C9H,         (*  test    r9, r9                         *)
    075H, 0DAH,               (*  jne     L1                             *)
    048H, 031H, 0C0H,         (*  xor     rax, rax                       *)
                              (*  L3:                                    *)
    05DH,                     (*  pop     rbp                            *)
    0C2H, 018H, 000H          (*  ret     24                             *)
    )
    RETURN 0
END strncmp;


PROCEDURE [oberon] strncmpw (a, b, n: INTEGER): INTEGER;
BEGIN
    SYSTEM.CODE(
    048H, 08BH, 04DH, 010H,   (*  mov     rcx, qword[rbp + 16]; rcx <- a *)
    048H, 08BH, 055H, 018H,   (*  mov     rdx, qword[rbp + 24]; rdx <- b *)
    04CH, 08BH, 045H, 020H,   (*  mov     r8,  qword[rbp + 32]; r8  <- n *)
    04DH, 031H, 0C9H,         (*  xor     r9, r9                         *)
    04DH, 031H, 0D2H,         (*  xor     r10, r10                       *)
    048H, 0B8H, 000H, 000H,   (*  movabs  rax, minint                    *)
    000H, 000H, 000H, 000H,
    000H, 080H,
                              (*  L1:                                    *)
    04DH, 085H, 0C0H,         (*  test    r8, r8                         *)
    07EH, 028H,               (*  jle     L3                             *)
    066H, 044H, 08BH, 009H,   (*  mov     r9w, word[rcx]                 *)
    066H, 044H, 08BH, 012H,   (*  mov     r10w, word[rdx]                *)
    048H, 083H, 0C1H, 002H,   (*  add     rcx, 2                         *)
    048H, 083H, 0C2H, 002H,   (*  add     rdx, 2                         *)
    049H, 0FFH, 0C8H,         (*  dec     r8                             *)
    04DH, 039H, 0D1H,         (*  cmp     r9, r10                        *)
    074H, 008H,               (*  je      L2                             *)
    04CH, 089H, 0C8H,         (*  mov     rax, r9                        *)
    04CH, 029H, 0D0H,         (*  sub     rax, r10                       *)
    0EBH, 008H,               (*  jmp     L3                             *)
                              (*  L2:                                    *)
    04DH, 085H, 0C9H,         (*  test    r9, r9                         *)
    075H, 0D6H,               (*  jne     L1                             *)
    048H, 031H, 0C0H,         (*  xor     rax, rax                       *)
                              (*  L3:                                    *)
    05DH,                     (*  pop     rbp                            *)
    0C2H, 018H, 000H          (*  ret     24                             *)
    )
    RETURN 0
END strncmpw;


PROCEDURE [oberon] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
    res:  INTEGER;
    bRes: BOOLEAN;
    c:    CHAR;

BEGIN
    res := strncmp(str1, str2, MIN(len1, len2));
    IF res = minint THEN
        IF len1 > len2 THEN
            SYSTEM.GET(str1 + len2, c);
            res := ORD(c)
        ELSIF len1 < len2 THEN
            SYSTEM.GET(str2 + len1, c);
            res := -ORD(c)
        ELSE
            res := 0
        END
    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 _strcmp;


PROCEDURE [oberon] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
    res:  INTEGER;
    bRes: BOOLEAN;
    c:    WCHAR;

BEGIN
    res := strncmpw(str1, str2, MIN(len1, len2));
    IF res = minint THEN
        IF len1 > len2 THEN
            SYSTEM.GET(str1 + len2 * 2, c);
            res := ORD(c)
        ELSIF len1 < len2 THEN
            SYSTEM.GET(str2 + len1 * 2, c);
            res := -ORD(c)
        ELSE
            res := 0
        END
    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 PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
    c: CHAR;
    i: INTEGER;

BEGIN
    i := 0;
    REPEAT
        SYSTEM.GET(pchar, c);
        s[i] := c;
        INC(pchar);
        INC(i)
    UNTIL c = 0X
END PCharToStr;


PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
    i, a: INTEGER;

BEGIN
    i := 0;
    a := x;
    REPEAT
        INC(i);
        a := a DIV 10
    UNTIL a = 0;

    str[i] := 0X;

    REPEAT
        DEC(i);
        str[i] := CHR(x MOD 10 + ORD("0"));
        x := x DIV 10
    UNTIL x = 0
END IntToStr;


PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
    n1, n2: INTEGER;

BEGIN
    n1 := LENGTH(s1);
    n2 := LENGTH(s2);

    ASSERT(n1 + n2 < LEN(s1));

    SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
    s1[n1 + n2] := 0X
END append;


PROCEDURE [oberon] _error* (modnum, _module, err, line: INTEGER);
VAR
    s, temp: ARRAY 1024 OF CHAR;

BEGIN
    CASE err OF
    | 1: s := "assertion failure"
    | 2: s := "NIL dereference"
    | 3: s := "bad divisor"
    | 4: s := "NIL procedure call"
    | 5: s := "type guard error"
    | 6: s := "index out of range"
    | 7: s := "invalid CASE"
    | 8: s := "array assignment error"
    | 9: s := "CHR out of range"
    |10: s := "WCHR out of range"
    |11: s := "BYTE out of range"
    END;

    append(s, API.eol + "module: "); PCharToStr(_module, temp); append(s, temp);
    append(s, API.eol + "line: ");   IntToStr(line, temp);     append(s, temp);

    API.DebugMsg(SYSTEM.ADR(s[0]), name);

    API.exit_thread(0)
END _error;


PROCEDURE [oberon] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
    SYSTEM.GET(t0 + t1 + types, t0)
    RETURN t0 MOD 2
END _isrec;


PROCEDURE [oberon] _is* (t0, p: INTEGER): INTEGER;
BEGIN
    IF p # 0 THEN
        SYSTEM.GET(p - WORD, p);
        SYSTEM.GET(t0 + p + types, p)
    END

    RETURN p MOD 2
END _is;


PROCEDURE [oberon] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
    SYSTEM.GET(t0 + t1 + types, t0)
    RETURN t0 MOD 2
END _guardrec;


PROCEDURE [oberon] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
    SYSTEM.GET(p, p);
    IF p # 0 THEN
        SYSTEM.GET(p - WORD, p);
        SYSTEM.GET(t0 + p + types, p)
    ELSE
        p := 1
    END

    RETURN p MOD 2
END _guard;


PROCEDURE [oberon] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
    RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;


PROCEDURE [oberon] _sofinit*;
BEGIN
    API.sofinit
END _sofinit;


PROCEDURE [oberon] _exit* (code: INTEGER);
BEGIN
    API.exit(code)
END _exit;


PROCEDURE [oberon] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
    t0, t1, i, j: INTEGER;

BEGIN
    API.init(param, code);

    types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
    ASSERT(types # 0);
    FOR i := 0 TO tcount - 1 DO
        FOR j := 0 TO tcount - 1 DO
            t0 := i; t1 := j;

            WHILE (t1 # 0) & (t1 # t0) DO
                SYSTEM.GET(_types + t1 * WORD, t1)
            END;

            SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
        END
    END;

    name := modname
END _init;


END RTL.
$END

(*---------------------x86------------------------*)

$IF (CPU_X86)
MODULE RTL;

IMPORT SYSTEM, API;


CONST

    minint = ROR(1, 1);

    WORD = API.BIT_DEPTH DIV 8;


VAR

    name:  INTEGER;
    types: INTEGER;


PROCEDURE [stdcall] _move* (bytes, dest, source: INTEGER);
BEGIN
    SYSTEM.CODE(
    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 _move;


PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
    res: BOOLEAN;

BEGIN
    IF len_src > len_dst THEN
        res := FALSE
    ELSE
        _move(len_src * base_size, dst, src);
        res := TRUE
    END

    RETURN res
END _arrcpy;


PROCEDURE [stdcall] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
    _move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;


PROCEDURE [stdcall] _rot* (Len, Ptr: INTEGER);
BEGIN
    SYSTEM.CODE(
    08BH, 04DH, 008H,   (*  mov   ecx, dword [ebp +  8]  *)  (* ecx <- Len *)
    08BH, 045H, 00CH,   (*  mov   eax, dword [ebp + 12]  *)  (* eax <- Ptr *)
    049H,               (*  dec   ecx                    *)
    053H,               (*  push  ebx                    *)
    08BH, 018H,         (*  mov   ebx, dword [eax]       *)
                        (*  L:                           *)
    08BH, 050H, 004H,   (*  mov   edx, dword [eax + 4]   *)
    089H, 010H,         (*  mov   dword [eax], edx       *)
    083H, 0C0H, 004H,   (*  add   eax, 4                 *)
    049H,               (*  dec   ecx                    *)
    075H, 0F5H,         (*  jnz   L                      *)
    089H, 018H,         (*  mov   dword [eax], ebx       *)
    05BH,               (*  pop   ebx                    *)
    05DH,               (*  pop   ebp                    *)
    0C2H, 008H, 000H    (*  ret   8                      *)
    )
END _rot;


PROCEDURE [stdcall] _set* (b, a: INTEGER); (* {a..b} -> eax *)
BEGIN
    SYSTEM.CODE(
    08BH, 04DH, 008H,              (*  mov   ecx, dword [ebp +  8]  *)  (* ecx <- b *)
    08BH, 045H, 00CH,              (*  mov   eax, dword [ebp + 12]  *)  (* eax <- a *)
    039H, 0C8H,                    (*  cmp   eax, ecx               *)
    07FH, 033H,                    (*  jg    L1                     *)
    083H, 0F8H, 01FH,              (*  cmp   eax, 31                *)
    07FH, 02EH,                    (*  jg    L1                     *)
    085H, 0C9H,                    (*  test  ecx, ecx               *)
    07CH, 02AH,                    (*  jl    L1                     *)
    083H, 0F9H, 01FH,              (*  cmp   ecx, 31                *)
    07EH, 005H,                    (*  jle   L3                     *)
    0B9H, 01FH, 000H, 000H, 000H,  (*  mov   ecx, 31                *)
                                   (*  L3:                          *)
    085H, 0C0H,                    (*  test  eax, eax               *)
    07DH, 002H,                    (*  jge   L2                     *)
    031H, 0C0H,                    (*  xor   eax, eax               *)
                                   (*  L2:                          *)
    089H, 0CAH,                    (*  mov   edx, ecx               *)
    029H, 0C2H,                    (*  sub   edx, eax               *)
    0B8H, 000H, 000H, 000H, 080H,  (*  mov   eax, 0x80000000        *)
    087H, 0CAH,                    (*  xchg  edx, ecx               *)
    0D3H, 0F8H,                    (*  sar   eax, cl                *)
    087H, 0CAH,                    (*  xchg  edx, ecx               *)
    083H, 0E9H, 01FH,              (*  sub   ecx, 31                *)
    0F7H, 0D9H,                    (*  neg   ecx                    *)
    0D3H, 0E8H,                    (*  shr   eax, cl                *)
    05DH,                          (*  pop   ebp                    *)
    0C2H, 008H, 000H,              (*  ret   8                      *)
                                   (*  L1:                          *)
    031H, 0C0H,                    (*  xor   eax, eax               *)
    05DH,                          (*  pop   ebp                    *)
    0C2H, 008H, 000H               (*  ret   8                      *)
    )
END _set;


PROCEDURE [stdcall] _set1* (a: INTEGER); (* {a} -> eax *)
BEGIN
    SYSTEM.CODE(
    031H, 0C0H,         (*  xor  eax, eax              *)
    08BH, 04DH, 008H,   (*  mov  ecx, dword [ebp + 8]  *)  (* ecx <- a *)
    083H, 0F9H, 01FH,   (*  cmp  ecx, 31               *)
    077H, 003H,         (*  ja   L                     *)
    00FH, 0ABH, 0C8H    (*  bts  eax, ecx              *)
                        (*  L:                         *)
    )
END _set1;


PROCEDURE [stdcall] _divmod* (y, x: INTEGER); (* (x div y) -> eax; (x mod y) -> edx *)
BEGIN
    SYSTEM.CODE(
    053H,                (*  push    ebx                    *)
    08BH, 045H, 00CH,    (*  mov     eax, dword [ebp + 12]  *)  (* eax <- x *)
    031H, 0D2H,          (*  xor     edx, edx               *)
    085H, 0C0H,          (*  test    eax, eax               *)
    074H, 018H,          (*  je      L2                     *)
    07FH, 002H,          (*  jg      L1                     *)
    0F7H, 0D2H,          (*  not     edx                    *)
                         (*  L1:                            *)
    089H, 0C3H,          (*  mov     ebx, eax               *)
    08BH, 04DH, 008H,    (*  mov     ecx, dword [ebp + 8]   *)  (* ecx <- y *)
    0F7H, 0F9H,          (*  idiv    ecx                    *)
    085H, 0D2H,          (*  test    edx, edx               *)
    074H, 009H,          (*  je      L2                     *)
    031H, 0CBH,          (*  xor     ebx, ecx               *)
    085H, 0DBH,          (*  test    ebx, ebx               *)
    07DH, 003H,          (*  jge     L2                     *)
    048H,                (*  dec     eax                    *)
    001H, 0CAH,          (*  add     edx, ecx               *)
                         (*  L2:                            *)
    05BH                 (*  pop     ebx                    *)
               )
END _divmod;


PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
    ptr := API._NEW(size);
    IF ptr # 0 THEN
        SYSTEM.PUT(ptr + ORD(API.OS = "LINUX")*12, t);
        INC(ptr, 4 + ORD(API.OS = "LINUX")*12)
    END
END _new;


PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
BEGIN
    IF ptr # 0 THEN
        ptr := API._DISPOSE(ptr - (4 + ORD(API.OS = "LINUX")*12))
    END
END _dispose;


PROCEDURE [stdcall] _length* (len, str: 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]  *)
               )
END _length;


PROCEDURE [stdcall] _lengthw* (len, str: INTEGER);
BEGIN
    SYSTEM.CODE(
    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                  *)
               )
END _lengthw;


PROCEDURE [stdcall] strncmp (a, b, n: INTEGER): INTEGER;
BEGIN
    SYSTEM.CODE(
    056H,                    (*  push    esi                            *)
    057H,                    (*  push    edi                            *)
    053H,                    (*  push    ebx                            *)
    08BH, 075H, 008H,        (*  mov     esi, dword[ebp +  8]; esi <- a *)
    08BH, 07DH, 00CH,        (*  mov     edi, dword[ebp + 12]; edi <- b *)
    08BH, 05DH, 010H,        (*  mov     ebx, dword[ebp + 16]; ebx <- n *)
    031H, 0C9H,              (*  xor     ecx, ecx                       *)
    031H, 0D2H,              (*  xor     edx, edx                       *)
    0B8H,
    000H, 000H, 000H, 080H,  (*  mov     eax, minint                    *)
                             (*  L1:                                    *)
    085H, 0DBH,              (*  test    ebx, ebx                       *)
    07EH, 017H,              (*  jle     L3                             *)
    08AH, 00EH,              (*  mov     cl, byte[esi]                  *)
    08AH, 017H,              (*  mov     dl, byte[edi]                  *)
    046H,                    (*  inc     esi                            *)
    047H,                    (*  inc     edi                            *)
    04BH,                    (*  dec     ebx                            *)
    039H, 0D1H,              (*  cmp     ecx, edx                       *)
    074H, 006H,              (*  je      L2                             *)
    089H, 0C8H,              (*  mov     eax, ecx                       *)
    029H, 0D0H,              (*  sub     eax, edx                       *)
    0EBH, 006H,              (*  jmp     L3                             *)
                             (*  L2:                                    *)
    085H, 0C9H,              (*  test    ecx, ecx                       *)
    075H, 0E7H,              (*  jne     L1                             *)
    031H, 0C0H,              (*  xor     eax, eax                       *)
                             (*  L3:                                    *)
    05BH,                    (*  pop     ebx                            *)
    05FH,                    (*  pop     edi                            *)
    05EH,                    (*  pop     esi                            *)
    05DH,                    (*  pop     ebp                            *)
    0C2H, 00CH, 000H         (*  ret     12                             *)
    )
    RETURN 0
END strncmp;


PROCEDURE [stdcall] strncmpw (a, b, n: INTEGER): INTEGER;
BEGIN
    SYSTEM.CODE(
    056H,                    (*  push    esi                            *)
    057H,                    (*  push    edi                            *)
    053H,                    (*  push    ebx                            *)
    08BH, 075H, 008H,        (*  mov     esi, dword[ebp +  8]; esi <- a *)
    08BH, 07DH, 00CH,        (*  mov     edi, dword[ebp + 12]; edi <- b *)
    08BH, 05DH, 010H,        (*  mov     ebx, dword[ebp + 16]; ebx <- n *)
    031H, 0C9H,              (*  xor     ecx, ecx                       *)
    031H, 0D2H,              (*  xor     edx, edx                       *)
    0B8H,
    000H, 000H, 000H, 080H,  (*  mov     eax, minint                    *)
                             (*  L1:                                    *)
    085H, 0DBH,              (*  test    ebx, ebx                       *)
    07EH, 01BH,              (*  jle     L3                             *)
    066H, 08BH, 00EH,        (*  mov     cx, word[esi]                  *)
    066H, 08BH, 017H,        (*  mov     dx, word[edi]                  *)
    046H,                    (*  inc     esi                            *)
    046H,                    (*  inc     esi                            *)
    047H,                    (*  inc     edi                            *)
    047H,                    (*  inc     edi                            *)
    04BH,                    (*  dec     ebx                            *)
    039H, 0D1H,              (*  cmp     ecx, edx                       *)
    074H, 006H,              (*  je      L2                             *)
    089H, 0C8H,              (*  mov     eax, ecx                       *)
    029H, 0D0H,              (*  sub     eax, edx                       *)
    0EBH, 006H,              (*  jmp     L3                             *)
                             (*  L2:                                    *)
    085H, 0C9H,              (*  test    ecx, ecx                       *)
    075H, 0E3H,              (*  jne     L1                             *)
    031H, 0C0H,              (*  xor     eax, eax                       *)
                             (*  L3:                                    *)
    05BH,                    (*  pop     ebx                            *)
    05FH,                    (*  pop     edi                            *)
    05EH,                    (*  pop     esi                            *)
    05DH,                    (*  pop     ebp                            *)
    0C2H, 00CH, 000H         (*  ret     12                             *)
    )
    RETURN 0
END strncmpw;


PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
    res:  INTEGER;
    bRes: BOOLEAN;
    c:    CHAR;

BEGIN
    res := strncmp(str1, str2, MIN(len1, len2));
    IF res = minint THEN
        IF len1 > len2 THEN
            SYSTEM.GET(str1 + len2, c);
            res := ORD(c)
        ELSIF len1 < len2 THEN
            SYSTEM.GET(str2 + len1, c);
            res := -ORD(c)
        ELSE
            res := 0
        END
    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 _strcmp;


PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
    res:  INTEGER;
    bRes: BOOLEAN;
    c:    WCHAR;

BEGIN
    res := strncmpw(str1, str2, MIN(len1, len2));
    IF res = minint THEN
        IF len1 > len2 THEN
            SYSTEM.GET(str1 + len2 * 2, c);
            res := ORD(c)
        ELSIF len1 < len2 THEN
            SYSTEM.GET(str2 + len1 * 2, c);
            res := -ORD(c)
        ELSE
            res := 0
        END
    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 PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
    c: CHAR;
    i: INTEGER;

BEGIN
    i := 0;
    REPEAT
        SYSTEM.GET(pchar, c);
        s[i] := c;
        INC(pchar);
        INC(i)
    UNTIL c = 0X
END PCharToStr;


PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
    i, a: INTEGER;

BEGIN
    i := 0;
    a := x;
    REPEAT
        INC(i);
        a := a DIV 10
    UNTIL a = 0;

    str[i] := 0X;

    REPEAT
        DEC(i);
        str[i] := CHR(x MOD 10 + ORD("0"));
        x := x DIV 10
    UNTIL x = 0
END IntToStr;


PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
    n1, n2: INTEGER;

BEGIN
    n1 := LENGTH(s1);
    n2 := LENGTH(s2);

    ASSERT(n1 + n2 < LEN(s1));

    SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
    s1[n1 + n2] := 0X
END append;


PROCEDURE [stdcall] _error* (modnum, _module, err, line: INTEGER);
VAR
    s, temp: ARRAY 1024 OF CHAR;

BEGIN
    CASE err OF
    | 1: s := "assertion failure"
    | 2: s := "NIL dereference"
    | 3: s := "bad divisor"
    | 4: s := "NIL procedure call"
    | 5: s := "type guard error"
    | 6: s := "index out of range"
    | 7: s := "invalid CASE"
    | 8: s := "array assignment error"
    | 9: s := "CHR out of range"
    |10: s := "WCHR out of range"
    |11: s := "BYTE out of range"
    END;

    append(s, API.eol + "module: "); PCharToStr(_module, temp); append(s, temp);
    append(s, API.eol + "line: ");   IntToStr(line, temp);     append(s, temp);

    API.DebugMsg(SYSTEM.ADR(s[0]), name);

    API.exit_thread(0)
END _error;


PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
    SYSTEM.GET(t0 + t1 + types, t0)
    RETURN t0 MOD 2
END _isrec;


PROCEDURE [stdcall] _is* (t0, p: INTEGER): INTEGER;
BEGIN
    IF p # 0 THEN
        SYSTEM.GET(p - WORD, p);
        SYSTEM.GET(t0 + p + types, p)
    END

    RETURN p MOD 2
END _is;


PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
    SYSTEM.GET(t0 + t1 + types, t0)
    RETURN t0 MOD 2
END _guardrec;


PROCEDURE [stdcall] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
    SYSTEM.GET(p, p);
    IF p # 0 THEN
        SYSTEM.GET(p - WORD, p);
        SYSTEM.GET(t0 + p + types, p)
    ELSE
        p := 1
    END

    RETURN p MOD 2
END _guard;


PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
    RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;


PROCEDURE [stdcall] _sofinit*;
BEGIN
    API.sofinit
END _sofinit;


PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
    API.exit(code)
END _exit;


PROCEDURE [stdcall] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
    t0, t1, i, j: INTEGER;

BEGIN
    SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
    API.init(param, code);

    types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
    ASSERT(types # 0);
    FOR i := 0 TO tcount - 1 DO
        FOR j := 0 TO tcount - 1 DO
            t0 := i; t1 := j;

            WHILE (t1 # 0) & (t1 # t0) DO
                SYSTEM.GET(_types + t1 * WORD, t1)
            END;

            SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
        END
    END;

    name := modname
END _init;


END RTL.
$END