Subversion Repositories Kolibri OS

Rev

Rev 7597 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

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