Subversion Repositories Kolibri OS

Rev

Rev 7107 | Go to most recent revision | Show entire file | Regard whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 7107 Rev 7597
Line 1... Line 1...
1 
(*
 1 
(*
2 
    Copyright 2016, 2017 Anton Krotov
 2 
    BSD 2-Clause License
Line 3... Line -...
3 
 
 - 
 
4 
    This program is free software: you can redistribute it and/or modify
 - 
 
5 
    it under the terms of the GNU Lesser General Public License as published by
 3 
 
6 
    the Free Software Foundation, either version 3 of the License, or
 4 
    Copyright (c) 2018, 2019, Anton Krotov
7 
    (at your option) any later version.
 - 
 
8 
 
 - 
 
9 
    This program is distributed in the hope that it will be useful,
 - 
 
10 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 - 
 
11 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 - 
 
12 
    GNU Lesser General Public License for more details.
 - 
 
13 
 
 - 
 
14 
    You should have received a copy of the GNU Lesser General Public License
 - 
 
15 
    along with this program.  If not, see .
 5 
    All rights reserved.
Line 16... Line 6...
16 
*)
 6 
*)
Line 17... Line 7...
17 
 
 7 
 
- 
 
 8 
MODULE RTL;
- 
 
 9 
 
- 
 
 10 
IMPORT SYSTEM, API;
- 
 
 11 
 
- 
 
 12 
 
- 
 
 13 
CONST
- 
 
 14 
 
- 
 
 15 
    bit_depth* = 32;
- 
 
 16 
    maxint* = 7FFFFFFFH;
- 
 
 17 
    minint* = 80000000H;
- 
 
 18 
 
- 
 
 19 
    DLL_PROCESS_ATTACH  = 1;
- 
 
 20 
    DLL_THREAD_ATTACH   = 2;
- 
 
 21 
    DLL_THREAD_DETACH   = 3;
- 
 
 22 
    DLL_PROCESS_DETACH  = 0;
Line 18... Line 23...
18 
MODULE RTL;
 23 
 
Line 19... Line 24...
19 
 
 24 
    SIZE_OF_DWORD = 4;
20 
IMPORT sys := SYSTEM, API;
 - 
 
21 
 
 - 
 
- 
 
 25 
 
Line 22... Line 26...
22 
TYPE
 26 
 
Line 23... Line 27...
23 
 
 27 
TYPE
24 
  IntArray = ARRAY 2048 OF INTEGER;
 28 
 
- 
 
 29 
    DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
- 
 
 30 
 
- 
 
 31 
 
- 
 
 32 
VAR
- 
 
 33 
 
- 
 
 34 
    name:  INTEGER;
- 
 
 35 
    types: INTEGER;
Line 25... Line 36...
25 
  STRING = ARRAY 2048 OF CHAR;
 36 
 
26 
  PROC = PROCEDURE;
 37 
    dll: RECORD
- 
 
 38 
        process_detach,
- 
 
 39 
        thread_detach,
- 
 
 40 
        thread_attach: DLL_ENTRY
- 
 
 41 
    END;
- 
 
 42 
 
- 
 
 43 
 
- 
 
 44 
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
- 
 
 45 
BEGIN
- 
 
 46 
    SYSTEM.CODE(
- 
 
 47 
 
- 
 
 48 
    08BH, 045H, 008H,    (*  mov eax, dword [ebp + 8]   *)
- 
 
 49 
    085H, 0C0H,          (*  test eax, eax              *)
- 
 
 50 
    07EH, 019H,          (*  jle L                      *)
- 
 
 51 
    0FCH,                (*  cld                        *)
- 
 
 52 
    057H,                (*  push edi                   *)
- 
 
 53 
    056H,                (*  push esi                   *)
- 
 
 54 
    08BH, 075H, 00CH,    (*  mov esi, dword [ebp + 12]  *)
- 
 
 55 
    08BH, 07DH, 010H,    (*  mov edi, dword [ebp + 16]  *)
- 
 
 56 
    089H, 0C1H,          (*  mov ecx, eax               *)
27 
 
 57 
    0C1H, 0E9H, 002H,    (*  shr ecx, 2                 *)
28 
VAR
 58 
    0F3H, 0A5H,          (*  rep movsd                  *)
- 
 
 59 
    089H, 0C1H,          (*  mov ecx, eax               *)
- 
 
 60 
    083H, 0E1H, 003H,    (*  and ecx, 3                 *)
- 
 
 61 
    0F3H, 0A4H,          (*  rep movsb                  *)
- 
 
 62 
    05EH,                (*  pop esi                    *)
- 
 
 63 
    05FH                 (*  pop edi                    *)
- 
 
 64 
                         (*  L:                         *)
- 
 
 65 
                )
- 
 
 66 
END _move;
- 
 
 67 
 
- 
 
 68 
 
- 
 
 69 
PROCEDURE [stdcall] _move2* (bytes, dest, source: INTEGER);
- 
 
 70 
BEGIN
- 
 
 71 
    SYSTEM.CODE(
- 
 
 72 
 
- 
 
 73 
    08BH, 045H, 008H,    (*  mov eax, dword [ebp + 8]   *)
- 
 
 74 
    085H, 0C0H,          (*  test eax, eax              *)
- 
 
 75 
    07EH, 019H,          (*  jle L                      *)
- 
 
 76 
    0FCH,                (*  cld                        *)
- 
 
 77 
    057H,                (*  push edi                   *)
- 
 
 78 
    056H,                (*  push esi                   *)
- 
 
 79 
    08BH, 075H, 010H,    (*  mov esi, dword [ebp + 16]  *)
- 
 
 80 
    08BH, 07DH, 00CH,    (*  mov edi, dword [ebp + 12]  *)
- 
 
 81 
    089H, 0C1H,          (*  mov ecx, eax               *)
- 
 
 82 
    0C1H, 0E9H, 002H,    (*  shr ecx, 2                 *)
- 
 
 83 
    0F3H, 0A5H,          (*  rep movsd                  *)
- 
 
 84 
    089H, 0C1H,          (*  mov ecx, eax               *)
- 
 
 85 
    083H, 0E1H, 003H,    (*  and ecx, 3                 *)
- 
 
 86 
    0F3H, 0A4H,          (*  rep movsb                  *)
- 
 
 87 
    05EH,                (*  pop esi                    *)
- 
 
 88 
    05FH                 (*  pop edi                    *)
Line 29... Line -...
29 
 
 - 
 
30 
  SelfName, rtab: INTEGER; CloseProc: PROC;
 89 
                         (*  L:                         *)
31 
  init: BOOLEAN;
 90 
                )
32 
 
 91 
END _move2;
- 
 
 92 
 
33 
PROCEDURE [stdcall] _halt*(n: INTEGER);
 93 
 
34 
BEGIN
 94 
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
35 
  API.ExitProcess(n)
 95 
VAR
36 
END _halt;
 - 
 
Line -... Line 96...
- 
 
 96 
    res: BOOLEAN;
- 
 
 97 
 
- 
 
 98 
BEGIN
- 
 
 99 
    IF len_src > len_dst THEN
37 
 
 100 
        res := FALSE
38 
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
 101 
    ELSE
39 
BEGIN
 - 
 
40 
  ptr := API._NEW(size);
 102 
        _move(len_src * base_size, src, dst);
41 
  IF ptr # 0 THEN
 - 
 
42 
    sys.PUT(ptr, t);
 103 
        res := TRUE
- 
 
 104 
    END
Line 43... Line 105...
43 
    INC(ptr, 4)
 105 
 
44 
  END
 106 
    RETURN res
- 
 
 107 
END _arrcpy;
- 
 
 108 
 
- 
 
 109 
 
- 
 
 110 
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
45 
END _newrec;
 111 
BEGIN
- 
 
 112 
    _move(MIN(len_dst, len_src) * chr_size, src, dst)
- 
 
 113 
END _strcpy;
- 
 
 114 
 
- 
 
 115 
 
- 
 
 116 
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
- 
 
 117 
BEGIN
- 
 
 118 
    _move(MIN(len_dst, len_src) * chr_size, src, dst)
- 
 
 119 
END _strcpy2;
- 
 
 120 
 
- 
 
 121 
 
- 
 
 122 
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
- 
 
 123 
VAR
- 
 
 124 
    i, n, k: INTEGER;
- 
 
 125 
 
46 
 
 126 
BEGIN
- 
 
 127 
 
- 
 
 128 
    k := LEN(A) - 1;
- 
 
 129 
    n := A[0];
- 
 
 130 
    i := 0;
- 
 
 131 
    WHILE i < k DO
Line 47... Line -...
47 
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
 - 
 
48 
BEGIN
 132 
        A[i] := A[i + 1];
- 
 
 133 
        INC(i)
- 
 
 134 
    END;
- 
 
 135 
    A[k] := n
- 
 
 136 
 
- 
 
 137 
END _rot;
- 
 
 138 
 
- 
 
 139 
 
49 
  IF ptr # 0 THEN
 140 
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
- 
 
 141 
VAR
- 
 
 142 
    res: INTEGER;
- 
 
 143 
 
- 
 
 144 
BEGIN
- 
 
 145 
    IF (a <= b) & (a <= 31) & (b >= 0) THEN
- 
 
 146 
        IF b > 31 THEN
- 
 
 147 
            b := 31
- 
 
 148 
        END;
- 
 
 149 
        IF a < 0 THEN
- 
 
 150 
            a := 0
50 
    ptr := API._DISPOSE(ptr - 4)
 151 
        END;
- 
 
 152 
        res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
- 
 
 153 
    ELSE
- 
 
 154 
        res := 0
- 
 
 155 
    END
- 
 
 156 
 
- 
 
 157 
    RETURN res
- 
 
 158 
END _set2;
- 
 
 159 
 
- 
 
 160 
 
- 
 
 161 
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
- 
 
 162 
    RETURN _set2(a, b)
- 
 
 163 
END _set;
- 
 
 164 
 
- 
 
 165 
 
- 
 
 166 
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
- 
 
 167 
BEGIN
- 
 
 168 
    SYSTEM.CODE(
- 
 
 169 
 
- 
 
 170 
    08BH, 045H, 008H,    (*  mov     eax, dword [ebp +  8]  *)
- 
 
 171 
    08BH, 04DH, 00CH,    (*  mov     ecx, dword [ebp + 12]  *)
- 
 
 172 
    031H, 0D2H,          (*  xor     edx, edx               *)
- 
 
 173 
    085H, 0C0H,          (*  test    eax, eax               *)
- 
 
 174 
    07DH, 002H,          (*  jge     L1                     *)
- 
 
 175 
    0F7H, 0D2H,          (*  not     edx                    *)
- 
 
 176 
                         (*  L1:                            *)
- 
 
 177 
    0F7H, 0F9H,          (*  idiv    ecx                    *)
- 
 
 178 
    08BH, 04DH, 010H,    (*  mov     ecx, dword [ebp + 16]  *)
Line 51... Line -...
51 
  END
 - 
 
52 
END _disprec;
 179 
    089H, 011H,          (*  mov     dword [ecx], edx       *)
53 
 
 180 
    0C9H,                (*  leave                          *)
54 
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
 181 
    0C2H, 00CH, 000H     (*  ret     12                     *)
- 
 
 182 
               )
- 
 
 183 
 
- 
 
 184 
    RETURN 0
- 
 
 185 
END divmod;
55 
BEGIN
 186 
 
- 
 
 187 
 
- 
 
 188 
PROCEDURE div_ (x, y: INTEGER): INTEGER;
- 
 
 189 
VAR
- 
 
 190 
    div, mod: INTEGER;
- 
 
 191 
 
Line 56... Line -...
56 
  sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
 - 
 
57 
END _rset;
 192 
BEGIN
- 
 
 193 
    div := divmod(x, y, mod);
58 
 
 194 
    IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
- 
 
 195 
        DEC(div)
- 
 
 196 
    END
- 
 
 197 
 
- 
 
 198 
    RETURN div
- 
 
 199 
END div_;
- 
 
 200 
 
- 
 
 201 
 
- 
 
 202 
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
- 
 
 203 
VAR
- 
 
 204 
    div, mod: INTEGER;
- 
 
 205 
 
- 
 
 206 
BEGIN
- 
 
 207 
    div := divmod(x, y, mod);
- 
 
 208 
    IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
59 
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
 209 
        INC(mod, y)
- 
 
 210 
    END
Line -... Line 211...
- 
 
 211 
 
- 
 
 212 
    RETURN mod
- 
 
 213 
END mod_;
- 
 
 214 
 
- 
 
 215 
 
60 
BEGIN
 216 
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
61 
  sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
 217 
    RETURN div_(a, b)
- 
 
 218 
END _div;
- 
 
 219 
 
- 
 
 220 
 
- 
 
 221 
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
62 
END _inset;
 222 
    RETURN div_(a, b)
63 
 
 223 
END _div2;
64 
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
 224 
 
- 
 
 225 
 
65 
BEGIN
 226 
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
66 
  table := rtab;
 227 
    RETURN mod_(a, b)
67 
  sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
 - 
 
68 
END _checktype;
 228 
END _mod;
- 
 
 229 
 
Line 69... Line 230...
69 
 
 230 
 
70 
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
 - 
 
71 
BEGIN
 231 
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
72 
  sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
 - 
 
73 
END _savearr;
 - 
 
74 
 
 232 
    RETURN mod_(a, b)
75 
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
 - 
 
76 
VAR res: BOOLEAN;
 233 
END _mod2;
77 
BEGIN
 - 
 
78 
  res := dyn = stat;
 - 
 
79 
  IF res THEN
 - 
 
80 
    _savearr(size, source, dest)
 234 
 
81 
  END
 235 
 
- 
 
 236 
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
- 
 
 237 
BEGIN
- 
 
 238 
    ptr := API._NEW(size);
- 
 
 239 
    IF ptr # 0 THEN
- 
 
 240 
        SYSTEM.PUT(ptr, t);
- 
 
 241 
        INC(ptr, SIZE_OF_DWORD)
Line 82... Line -...
82 
  RETURN res
 - 
 
83 
END _saverec;
 242 
    END
- 
 
 243 
END _new;
- 
 
 244 
 
- 
 
 245 
 
- 
 
 246 
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
- 
 
 247 
BEGIN
84 
 
 248 
    IF ptr # 0 THEN
85 
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
 249 
        ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
- 
 
 250 
    END
86 
VAR i, m: INTEGER;
 251 
END _dispose;
87 
BEGIN
 252 
 
88 
  m := bsize * idx;
 253 
 
- 
 
 254 
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
- 
 
 255 
VAR
89 
  FOR i := 4 TO Dim + 2 DO
 256 
    A, B: CHAR;
- 
 
 257 
    res:  INTEGER;
- 
 
 258 
 
- 
 
 259 
BEGIN
- 
 
 260 
    res := 0;
- 
 
 261 
    WHILE n > 0 DO
- 
 
 262 
        SYSTEM.GET(a, A); INC(a);
Line 90... Line -...
90 
    m := m * Arr[i]
 - 
 
91 
  END;
 - 
 
92 
  IF (Arr[3] > idx) & (idx >= 0) THEN
 263 
        SYSTEM.GET(b, B); INC(b);
- 
 
 264 
        DEC(n);
93 
    Arr[3] := c + m
 265 
        IF A # B THEN
- 
 
 266 
            res := ORD(A) - ORD(B);
- 
 
 267 
            n := 0
94 
  ELSE
 268 
        ELSIF A = 0X THEN
95 
    Arr[3] := 0
 269 
            n := 0
96 
  END
 270 
        END
97 
END _arrayidx;
 271 
    END
- 
 
 272 
    RETURN res
98 
 
 273 
END strncmp;
99 
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
 274 
 
- 
 
 275 
 
- 
 
 276 
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
100 
BEGIN
 277 
VAR
- 
 
 278 
    A, B: WCHAR;
Line 101... Line 279...
101 
  IF (Arr[3] > idx) & (idx >= 0) THEN
 279 
    res:  INTEGER;
102 
    Arr[3] := bsize * idx + c
 280 
 
- 
 
 281 
BEGIN
- 
 
 282 
    res := 0;
103 
  ELSE
 283 
    WHILE n > 0 DO
104 
    Arr[3] := 0
 284 
        SYSTEM.GET(a, A); INC(a, 2);
105 
  END
 285 
        SYSTEM.GET(b, B); INC(b, 2);
106 
END _arrayidx1;
 286 
        DEC(n);
107 
 
 287 
        IF A # B THEN
108 
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
 288 
            res := ORD(A) - ORD(B);
109 
VAR i, j, t: INTEGER;
 289 
            n := 0
110 
BEGIN
 290 
        ELSIF A = 0X THEN
111 
  FOR i := 1 TO n DO
 291 
            n := 0
112 
    t := Arr[0];
 292 
        END
113 
    FOR j := 0 TO m + n - 1 DO
 293 
    END
114 
      Arr[j] := Arr[j + 1]
 294 
    RETURN res
115 
    END;
 295 
END strncmpw;
- 
 
 296 
 
- 
 
 297 
 
116 
    Arr[m + n] := t
 298 
PROCEDURE [stdcall] _length* (len, str: INTEGER): INTEGER;
117 
  END
 299 
BEGIN
Line -... Line 300...
- 
 
 300 
    SYSTEM.CODE(
118 
END _arrayrot;
 301 
 
119 
 
 302 
    08BH, 045H, 00CH,    (*  mov     eax, dword [ebp + 0Ch]  *)
- 
 
 303 
    08BH, 04DH, 008H,    (*  mov     ecx, dword [ebp + 08h]  *)
- 
 
 304 
    048H,                (*  dec     eax                     *)
- 
 
 305 
                         (*  L1:                             *)
- 
 
 306 
    040H,                (*  inc     eax                     *)
- 
 
 307 
    080H, 038H, 000H,    (*  cmp     byte [eax], 0           *)
- 
 
 308 
    074H, 003H,          (*  jz      L2                      *)
- 
 
 309 
    0E2H, 0F8H,          (*  loop    L1                      *)
- 
 
 310 
    040H,                (*  inc     eax                     *)
- 
 
 311 
                         (*  L2:                             *)
- 
 
 312 
    02BH, 045H, 00CH,    (*  sub     eax, dword [ebp + 0Ch]  *)
- 
 
 313 
    0C9H,                (*  leave                           *)
- 
 
 314 
    0C2H, 008H, 000H     (*  ret     08h                     *)
- 
 
 315 
               )
- 
 
 316 
 
- 
 
 317 
    RETURN 0
120 
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
 318 
END _length;
- 
 
 319 
 
121 
BEGIN
 320 
 
- 
 
 321 
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
122 
  sys.CODE("8B4508");     //  mov     eax, [ebp + 08h]
 322 
BEGIN
- 
 
 323 
    SYSTEM.CODE(
123 
  sys.CODE("8B4D0C");     //  mov     ecx, [ebp + 0Ch]
 324 
 
124 
  sys.CODE("48");         //  dec     eax
 325 
    08BH, 045H, 00CH,         (*  mov     eax, dword [ebp + 0Ch]  *)
- 
 
 326 
    08BH, 04DH, 008H,         (*  mov     ecx, dword [ebp + 08h]  *)
- 
 
 327 
    048H,                     (*  dec     eax                     *)
- 
 
 328 
    048H,                     (*  dec     eax                     *)
- 
 
 329 
                              (*  L1:                             *)
- 
 
 330 
    040H,                     (*  inc     eax                     *)
- 
 
 331 
    040H,                     (*  inc     eax                     *)
Line 125... Line -...
125 
                          //  L1:
 - 
 
126 
  sys.CODE("40");         //  inc     eax
 - 
 
127 
  sys.CODE("803800");     //  cmp     byte ptr [eax], 0
 332 
    066H, 083H, 038H, 000H,   (*  cmp     word [eax], 0           *)
- 
 
 333 
    074H, 004H,               (*  jz      L2                      *)
128 
  sys.CODE("7403");       //  jz      L2
 334 
    0E2H, 0F6H,               (*  loop    L1                      *)
129 
  sys.CODE("E2F8");       //  loop    L1
 335 
    040H,                     (*  inc     eax                     *)
130 
  sys.CODE("40");         //  inc     eax
 336 
    040H,                     (*  inc     eax                     *)
131 
                          //  L2:
 337 
                              (*  L2:                             *)
- 
 
 338 
    02BH, 045H, 00CH,         (*  sub     eax, dword [ebp + 0Ch]  *)
132 
  sys.CODE("2B4508");     //  sub     eax, [ebp + 08h]
 339 
    0D1H, 0E8H,               (*  shr     eax, 1                  *)
133 
  sys.CODE("C9");         //  leave
 340 
    0C9H,                     (*  leave                           *)
134 
  sys.CODE("C20800");     //  ret     08h
 341 
    0C2H, 008H, 000H          (*  ret     08h                     *)
135 
  RETURN 0
 342 
               )
136 
END _length;
 343 
 
137 
 
 344 
    RETURN 0
138 
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
 345 
END _lengthw;
139 
BEGIN
 - 
 
140 
  _savearr(MIN(alen, blen), a, b);
 346 
 
- 
 
 347 
 
141 
  IF blen > alen THEN
 348 
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
142 
    sys.PUT(b + alen, 0X)
 349 
VAR
Line -... Line 350...
- 
 
 350 
    res:  INTEGER;
- 
 
 351 
    bRes: BOOLEAN;
- 
 
 352 
 
- 
 
 353 
BEGIN
- 
 
 354 
 
- 
 
 355 
    res := strncmp(str1, str2, MIN(len1, len2));
143 
  END
 356 
    IF res = 0 THEN
- 
 
 357 
        res := _length(len1, str1) - _length(len2, str2)
- 
 
 358 
    END;
144 
END _strcopy;
 359 
 
- 
 
 360 
    CASE op OF
145 
 
 361 
    |0: bRes := res =  0
146 
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
 - 
 
147 
VAR i: INTEGER; Res: BOOLEAN;
 - 
 
148 
BEGIN
 - 
 
149 
  i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b)));
 - 
 
150 
  IF i = 0 THEN
 - 
 
151 
    i := _length(a) - _length(b)
 - 
 
152 
  END;
 - 
 
153 
  CASE op OF
 - 
 
154 
  |0: Res := i = 0
 - 
 
155 
  |1: Res := i # 0
 - 
 
156 
  |2: Res := i < 0
 - 
 
157 
  |3: Res := i > 0
 - 
 
Line -... Line 362...
- 
 
 362 
    |1: bRes := res #  0
- 
 
 363 
    |2: bRes := res <  0
- 
 
 364 
    |3: bRes := res <= 0
- 
 
 365 
    |4: bRes := res >  0
- 
 
 366 
    |5: bRes := res >= 0
- 
 
 367 
    END
- 
 
 368 
 
- 
 
 369 
    RETURN bRes
- 
 
 370 
END _strcmp;
- 
 
 371 
 
- 
 
 372 
 
- 
 
 373 
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
- 
 
 374 
    RETURN _strcmp(op, len2, str2, len1, str1)
- 
 
 375 
END _strcmp2;
- 
 
 376 
 
- 
 
 377 
 
- 
 
 378 
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
- 
 
 379 
VAR
- 
 
 380 
    res:  INTEGER;
- 
 
 381 
    bRes: BOOLEAN;
- 
 
 382 
 
- 
 
 383 
BEGIN
- 
 
 384 
 
158 
  |4: Res := i <= 0
 385 
    res := strncmpw(str1, str2, MIN(len1, len2));
- 
 
 386 
    IF res = 0 THEN
- 
 
 387 
        res := _lengthw(len1, str1) - _lengthw(len2, str2)
159 
  |5: Res := i >= 0
 388 
    END;
- 
 
 389 
 
160 
  ELSE
 390 
    CASE op OF
161 
  END
 391 
    |0: bRes := res =  0
- 
 
 392 
    |1: bRes := res #  0
- 
 
 393 
    |2: bRes := res <  0
- 
 
 394 
    |3: bRes := res <= 0
- 
 
 395 
    |4: bRes := res >  0
- 
 
 396 
    |5: bRes := res >= 0
- 
 
 397 
    END
- 
 
 398 
 
- 
 
 399 
    RETURN bRes
- 
 
 400 
END _strcmpw;
- 
 
 401 
 
- 
 
 402 
 
- 
 
 403 
PROCEDURE [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
- 
 
 404 
    RETURN _strcmpw(op, len2, str2, len1, str1)
- 
 
 405 
END _strcmpw2;
- 
 
 406 
 
- 
 
 407 
 
162 
  RETURN Res
 408 
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
163 
END _strcmp;
 409 
VAR
164 
 
 410 
    c: CHAR;
165 
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
 411 
    i: INTEGER;
166 
VAR s: ARRAY 2 OF CHAR;
 412 
 
167 
BEGIN
 413 
BEGIN
- 
 
 414 
    i := 0;
- 
 
 415 
    REPEAT
168 
  s[0] := b;
 416 
        SYSTEM.GET(pchar, c);
169 
  s[1] := 0X;
 417 
        s[i] := c;
170 
  RETURN _strcmp(op, s, a)
 418 
        INC(pchar);
171 
END _lstrcmp;
 419 
        INC(i)
172 
 
 420 
    UNTIL c = 0X
173 
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
 421 
END PCharToStr;
174 
VAR s: ARRAY 2 OF CHAR;
 422 
 
175 
BEGIN
 423 
 
176 
  s[0] := a;
 424 
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
177 
  s[1] := 0X;
 425 
VAR
Line 178... Line -...
178 
  RETURN _strcmp(op, b, s)
 - 
 
179 
END _rstrcmp;
 - 
 
Line 180... Line 426...
180 
 
 426 
    i, a, b: INTEGER;
- 
 
 427 
    c: CHAR;
181 
PROCEDURE Int(x: INTEGER; VAR str: STRING);
 428 
 
182 
VAR i, a, b: INTEGER; c: CHAR;
 429 
BEGIN
- 
 
 430 
 
183 
BEGIN
 431 
    i := 0;
- 
 
 432 
    REPEAT
- 
 
 433 
        str[i] := CHR(x MOD 10 + ORD("0"));
- 
 
 434 
        x := x DIV 10;
184 
  i := 0;
 435 
        INC(i)
- 
 
 436 
    UNTIL x = 0;
185 
  a := 0;
 437 
 
186 
  REPEAT
 438 
    a := 0;
187 
    str[i] := CHR(x MOD 10 + ORD("0"));
 439 
    b := i - 1;
188 
    x := x DIV 10;
 440 
    WHILE a < b DO
- 
 
 441 
        c := str[a];
- 
 
 442 
        str[a] := str[b];
- 
 
 443 
        str[b] := c;
- 
 
 444 
        INC(a);
- 
 
 445 
        DEC(b)
- 
 
 446 
    END;
- 
 
 447 
    str[i] := 0X
- 
 
 448 
END IntToStr;
- 
 
 449 
 
- 
 
 450 
 
- 
 
 451 
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
- 
 
 452 
VAR
- 
 
 453 
    n1, n2, i, j: INTEGER;
- 
 
 454 
BEGIN
- 
 
 455 
    n1 := LENGTH(s1);
- 
 
 456 
    n2 := LENGTH(s2);
- 
 
 457 
 
- 
 
 458 
    ASSERT(n1 + n2 < LEN(s1));
- 
 
 459 
 
- 
 
 460 
    i := 0;
- 
 
 461 
    j := n1;
- 
 
 462 
    WHILE i < n2 DO
- 
 
 463 
        s1[j] := s2[i];
- 
 
 464 
        INC(i);
- 
 
 465 
        INC(j)
- 
 
 466 
    END;
- 
 
 467 
 
- 
 
 468 
    s1[j] := 0X
- 
 
 469 
 
- 
 
 470 
END append;
- 
 
 471 
 
- 
 
 472 
 
- 
 
 473 
PROCEDURE [stdcall] _error* (module, err: INTEGER);
- 
 
 474 
VAR
- 
 
 475 
    s, temp: ARRAY 1024 OF CHAR;
- 
 
 476 
 
- 
 
 477 
BEGIN
- 
 
 478 
 
- 
 
 479 
    s := "";
- 
 
 480 
    CASE err MOD 16 OF
- 
 
 481 
    | 1: append(s, "assertion failure")
- 
 
 482 
    | 2: append(s, "NIL dereference")
- 
 
 483 
    | 3: append(s, "division by zero")
- 
 
 484 
    | 4: append(s, "NIL procedure call")
- 
 
 485 
    | 5: append(s, "type guard error")
189 
    INC(i)
 486 
    | 6: append(s, "index out of range")
- 
 
 487 
    | 7: append(s, "invalid CASE")
- 
 
 488 
    | 8: append(s, "array assignment error")
190 
  UNTIL x = 0;
 489 
    | 9: append(s, "CHR out of range")
- 
 
 490 
    |10: append(s, "WCHR out of range")
- 
 
 491 
    |11: append(s, "BYTE out of range")
- 
 
 492 
    END;
- 
 
 493 
 
- 
 
 494 
    append(s, API.eol);
Line 191... Line 495...
191 
  b := i - 1;
 495 
 
192 
  WHILE a < b DO
 496 
    append(s, "module: ");   PCharToStr(module, temp);     append(s, temp); append(s, API.eol);
- 
 
 497 
    append(s, "line: ");     IntToStr(LSR(err, 4), temp);  append(s, temp);
193 
    c := str[a];
 498 
 
194 
    str[a] := str[b];
 499 
    API.DebugMsg(SYSTEM.ADR(s[0]), name);
195 
    str[b] := c;
 - 
 
196 
    INC(a);
 - 
 
197 
    DEC(b)
 - 
 
198 
  END;
 500 
 
199 
  str[i] := 0X
 - 
 
200 
END Int;
 501 
    API.exit_thread(0)
201 
 
 - 
 
202 
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER);
 502 
END _error;
203 
VAR msg, int: STRING; pos, n: INTEGER;
 503 
 
204 
 
 504 
 
205 
  PROCEDURE StrAppend(s: STRING);
 - 
 
206 
  VAR i, n: INTEGER;
 - 
 
207 
  BEGIN
 - 
 
208 
    n := LEN(s);
 - 
 
209 
    i := 0;
 - 
 
210 
    WHILE (i < n) & (s[i] # 0X) DO
 - 
 
211 
      msg[pos] := s[i];
 - 
 
212 
      INC(pos);
 - 
 
213 
      INC(i)
 - 
 
214 
    END
 - 
 
215 
  END StrAppend;
 - 
 
216 
 
 - 
 
217 
BEGIN
 - 
 
218 
  pos := 0;
 - 
 
219 
  n := line MOD 16;
 - 
 
220 
  line := line DIV 16;
 - 
 
221 
  CASE n OF
 - 
 
222 
  |1: StrAppend("assertion failure")
 - 
 
223 
  |2: StrAppend("variable of a procedure type has NIL as value")
 - 
 
224 
  |3: StrAppend("typeguard error")
 - 
 
225 
  |4: StrAppend("inadmissible dynamic type")
 - 
 
226 
  |5: StrAppend("index check error")
 - 
 
227 
  |6: StrAppend("NIL pointer dereference")
 - 
 
228 
  |7: StrAppend("invalid value in case statement")
 - 
 
229 
  |8: StrAppend("division by zero")
 - 
 
230 
  ELSE
 - 
 
231 
  END;
 - 
 
232 
  StrAppend(0DX);
 - 
 
233 
  StrAppend(0AX);
 - 
 
234 
  StrAppend("module ");
 - 
 
235 
  StrAppend(modname);
 - 
 
236 
  StrAppend(0DX);
 - 
 
237 
  StrAppend(0AX);
 505 
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
238 
  StrAppend("line ");
 - 
 
239 
  Int(line, int);
 - 
 
240 
  StrAppend(int);
 - 
 
241 
  IF m = 2 THEN
 - 
 
242 
    StrAppend(0DX);
 506 
BEGIN
243 
    StrAppend(0AX);
 - 
 
Line -... Line 507...
- 
 
 507 
    (* r IS t0 *)
- 
 
 508 
 
- 
 
 509 
    WHILE (t1 # 0) & (t1 # t0) DO
- 
 
 510 
        SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
- 
 
 511 
    END
- 
 
 512 
 
- 
 
 513 
    RETURN t1 = t0
- 
 
 514 
END _isrec;
- 
 
 515 
 
- 
 
 516 
 
- 
 
 517 
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
- 
 
 518 
VAR
- 
 
 519 
    t1: INTEGER;
- 
 
 520 
 
- 
 
 521 
BEGIN
- 
 
 522 
    (* p IS t0 *)
244 
    StrAppend("code ");
 523 
 
- 
 
 524 
    IF p # 0 THEN
- 
 
 525 
        DEC(p, SIZE_OF_DWORD);
- 
 
 526 
        SYSTEM.GET(p, t1);
245 
    Int(code, int);
 527 
        WHILE (t1 # 0) & (t1 # t0) DO
- 
 
 528 
            SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
- 
 
 529 
        END
- 
 
 530 
    ELSE
- 
 
 531 
        t1 := -1
- 
 
 532 
    END
- 
 
 533 
 
- 
 
 534 
    RETURN t1 = t0
- 
 
 535 
END _is;
- 
 
 536 
 
- 
 
 537 
 
- 
 
 538 
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
- 
 
 539 
BEGIN
- 
 
 540 
    (* r:t1 IS t0 *)
- 
 
 541 
 
- 
 
 542 
    WHILE (t1 # 0) & (t1 # t0) DO
- 
 
 543 
        SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
- 
 
 544 
    END
- 
 
 545 
 
- 
 
 546 
    RETURN t1 = t0
- 
 
 547 
END _guardrec;
- 
 
 548 
 
- 
 
 549 
 
- 
 
 550 
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
- 
 
 551 
VAR
- 
 
 552 
    t1:  INTEGER;
- 
 
 553 
 
- 
 
 554 
BEGIN
- 
 
 555 
    (* p IS t0 *)
- 
 
 556 
    SYSTEM.GET(p, p);
- 
 
 557 
    IF p # 0 THEN
- 
 
 558 
        DEC(p, SIZE_OF_DWORD);
- 
 
 559 
        SYSTEM.GET(p, t1);
- 
 
 560 
        WHILE (t1 # t0) & (t1 # 0) DO
- 
 
 561 
            SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
- 
 
 562 
        END
246 
    StrAppend(int)
 563 
    ELSE
- 
 
 564 
        t1 := t0
- 
 
 565 
    END
- 
 
 566 
 
- 
 
 567 
    RETURN t1 = t0
- 
 
 568 
END _guard;
- 
 
 569 
 
- 
 
 570 
 
- 
 
 571 
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
- 
 
 572 
VAR
- 
 
 573 
    res: INTEGER;
- 
 
 574 
 
- 
 
 575 
BEGIN
- 
 
 576 
    CASE fdwReason OF
- 
 
 577 
    |DLL_PROCESS_ATTACH:
- 
 
 578 
        res := 1
- 
 
 579 
    |DLL_THREAD_ATTACH:
247 
  END;
 580 
        res := 0;
- 
 
 581 
        IF dll.thread_attach # NIL THEN
- 
 
 582 
            dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
- 
 
 583 
        END
- 
 
 584 
    |DLL_THREAD_DETACH:
- 
 
 585 
        res := 0;
- 
 
 586 
        IF dll.thread_detach # NIL THEN
- 
 
 587 
            dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
- 
 
 588 
        END
- 
 
 589 
    |DLL_PROCESS_DETACH:
- 
 
 590 
        res := 0;
- 
 
 591 
        IF dll.process_detach # NIL THEN
- 
 
 592 
            dll.process_detach(hinstDLL, fdwReason, lpvReserved)
- 
 
 593 
        END
- 
 
 594 
    ELSE
- 
 
 595 
        res := 0
- 
 
 596 
    END
- 
 
 597 
 
- 
 
 598 
    RETURN res
- 
 
 599 
END _dllentry;
- 
 
 600 
 
- 
 
 601 
 
Line 248... Line 602...
248 
  API.DebugMsg(sys.ADR(msg), SelfName);
 602 
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
249 
  API.ExitThread(0)
 603 
BEGIN