1,7 → 1,7 |
(* |
(* |
BSD 2-Clause License |
|
Copyright (c) 2018-2019, Anton Krotov |
Copyright (c) 2018-2020, Anton Krotov |
All rights reserved. |
*) |
|
16,36 → 16,16 |
maxint* = 7FFFFFFFH; |
minint* = 80000000H; |
|
DLL_PROCESS_ATTACH = 1; |
DLL_THREAD_ATTACH = 2; |
DLL_THREAD_DETACH = 3; |
DLL_PROCESS_DETACH = 0; |
|
WORD = bit_depth DIV 8; |
MAX_SET = bit_depth - 1; |
|
|
TYPE |
|
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER); |
PROC = PROCEDURE; |
|
|
VAR |
|
name: INTEGER; |
types: INTEGER; |
bits: ARRAY MAX_SET + 1 OF INTEGER; |
|
dll: RECORD |
process_detach, |
thread_detach, |
thread_attach: DLL_ENTRY |
END; |
|
fini: PROC; |
|
|
PROCEDURE [stdcall] _move* (bytes, dest, source: INTEGER); |
BEGIN |
SYSTEM.CODE( |
97,7 → 77,6 |
i, n, k: INTEGER; |
|
BEGIN |
|
k := LEN(A) - 1; |
n := A[0]; |
i := 0; |
106,7 → 85,6 |
INC(i) |
END; |
A[k] := n |
|
END _rot; |
|
|
128,14 → 106,16 |
END _set; |
|
|
PROCEDURE [stdcall] _set1* (a: INTEGER): INTEGER; |
PROCEDURE [stdcall] _set1* (a: INTEGER); (* {a} -> eax *) |
BEGIN |
IF ASR(a, 5) = 0 THEN |
SYSTEM.GET(SYSTEM.ADR(bits[0]) + a * WORD, a) |
ELSE |
a := 0 |
END |
RETURN a |
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; |
|
|
315,7 → 295,6 |
c: CHAR; |
|
BEGIN |
|
res := strncmp(str1, str2, MIN(len1, len2)); |
IF res = minint THEN |
IF len1 > len2 THEN |
349,7 → 328,6 |
c: WCHAR; |
|
BEGIN |
|
res := strncmpw(str1, str2, MIN(len1, len2)); |
IF res = minint THEN |
IF len1 > len2 THEN |
398,7 → 376,6 |
c: CHAR; |
|
BEGIN |
|
i := 0; |
REPEAT |
str[i] := CHR(x MOD 10 + ORD("0")); |
422,6 → 399,7 |
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR); |
VAR |
n1, n2, i, j: INTEGER; |
|
BEGIN |
n1 := LENGTH(s1); |
n2 := LENGTH(s2); |
437,7 → 415,6 |
END; |
|
s1[j] := 0X |
|
END append; |
|
|
446,20 → 423,18 |
s, temp: ARRAY 1024 OF CHAR; |
|
BEGIN |
|
s := ""; |
CASE err OF |
| 1: append(s, "assertion failure") |
| 2: append(s, "NIL dereference") |
| 3: append(s, "division by zero") |
| 4: append(s, "NIL procedure call") |
| 5: append(s, "type guard error") |
| 6: append(s, "index out of range") |
| 7: append(s, "invalid CASE") |
| 8: append(s, "array assignment error") |
| 9: append(s, "CHR out of range") |
|10: append(s, "WCHR out of range") |
|11: append(s, "BYTE out of range") |
| 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); |
513,36 → 488,16 |
|
|
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved) |
END _dllentry; |
|
|
PROCEDURE [stdcall] _sofinit*; |
BEGIN |
CASE fdwReason OF |
|DLL_PROCESS_ATTACH: |
res := 1 |
|DLL_THREAD_ATTACH: |
res := 0; |
IF dll.thread_attach # NIL THEN |
dll.thread_attach(hinstDLL, fdwReason, lpvReserved) |
END |
|DLL_THREAD_DETACH: |
res := 0; |
IF dll.thread_detach # NIL THEN |
dll.thread_detach(hinstDLL, fdwReason, lpvReserved) |
END |
|DLL_PROCESS_DETACH: |
res := 0; |
IF dll.process_detach # NIL THEN |
dll.process_detach(hinstDLL, fdwReason, lpvReserved) |
END |
ELSE |
res := 0 |
END |
API.sofinit |
END _sofinit; |
|
RETURN res |
END _dllentry; |
|
|
PROCEDURE [stdcall] _exit* (code: INTEGER); |
BEGIN |
API.exit(code) |
571,42 → 526,8 |
END |
END; |
|
j := 1; |
FOR i := 0 TO MAX_SET DO |
bits[i] := j; |
j := LSL(j, 1) |
END; |
|
name := modname; |
|
dll.process_detach := NIL; |
dll.thread_detach := NIL; |
dll.thread_attach := NIL; |
|
fini := NIL |
name := modname |
END _init; |
|
|
PROCEDURE [stdcall] _sofinit*; |
BEGIN |
IF fini # NIL THEN |
fini |
END |
END _sofinit; |
|
|
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY); |
BEGIN |
dll.process_detach := process_detach; |
dll.thread_detach := thread_detach; |
dll.thread_attach := thread_attach |
END SetDll; |
|
|
PROCEDURE SetFini* (ProcFini: PROC); |
BEGIN |
fini := ProcFini |
END SetFini; |
|
|
END RTL. |
END RTL. |