BlueGreycalmElegant

Català-Valencià – Catalan中文 – Chinese (Simplified)中文 – Chinese (Traditional)Česky – CzechDansk – DanishNederlands – DutchEnglish – EnglishSuomi – FinnishFrançais – FrenchDeutsch – Germanעברית – Hebrewहिंदी – HindiMagyar – HungarianBahasa Indonesia – IndonesianItaliano – Italian日本語 – Japanese한국어 – KoreanМакедонски – Macedonianमराठी – MarathiNorsk – NorwegianPolski – PolishPortuguês – PortuguesePortuguês – Portuguese (Brazil)Русский – RussianSlovenčina – SlovakSlovenščina – SlovenianEspañol – SpanishSvenska – SwedishTürkçe – TurkishУкраїнська – UkrainianOëzbekcha – Uzbek

Compare Revisions

• This comparison shows the changes necessary to convert path

  → /programs/develop/oberon07/Lib/ @ 7596

  → /programs/develop/oberon07/Lib/ @ 7597

  ↔ Reverse comparison

• Compare Path:	Rev

  With Path:	Rev

Regard whitespace Rev 7596 → Rev 7597

/programs/develop/oberon07/Lib/KolibriOS/API.ob07
1,23 → 1,13
(*
Copyright 2016, 2017, 2018 Anton Krotov
(*
BSD 2-Clause License
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 <http://www.gnu.org/licenses/>.
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT sys := SYSTEM;
IMPORT SYSTEM, K := KOSAPI;
CONST
41,10 → 31,23
CriticalSection: CRITICAL_SECTION;
import*, multi: BOOLEAN;
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER);
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
PROCEDURE [stdcall] zeromem* (dwords: INTEGER; adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
SYSTEM.CODE(
0FCH, (* cld *)
031H, 0C0H, (* xor eax, eax *)
057H, (* push edi *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *)
0F3H, 0ABH, (* rep stosd *)
05FH (* pop edi *)
)
END zeromem;
53,128 → 56,31
tmp: INTEGER;
BEGIN
FOR tmp := adr TO adr + size - 1 BY 4096 DO
sys.PUT(tmp, 0)
SYSTEM.PUT(tmp, 0)
END
END mem_commit;
PROCEDURE strncmp* (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
Res: INTEGER;
BEGIN
Res := 0;
WHILE n > 0 DO
sys.GET(a, A); INC(a);
sys.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
Res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN Res
END strncmp;
PROCEDURE [stdcall] sysfunc1* (arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall] sysfunc2* (arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall] sysfunc3* (arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall] sysfunc4* (arg1, arg2, arg3, arg4: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21000"); (* ret 10h *)
RETURN 0
END sysfunc4;
PROCEDURE [stdcall] sysfunc5* (arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
RETURN 0
END sysfunc5;
PROCEDURE switch_task;
VAR
res: INTEGER;
BEGIN
res := sysfunc2(68, 1)
K.sysfunc2(68, 1)
END switch_task;
PROCEDURE futex_create (ptr: INTEGER): INTEGER;
RETURN sysfunc3(77, 0, ptr)
RETURN K.sysfunc3(77, 0, ptr)
END futex_create;
PROCEDURE futex_wait (futex, value, timeout: INTEGER);
VAR
res: INTEGER;
BEGIN
res := sysfunc5(77, 2, futex, value, timeout)
K.sysfunc5(77, 2, futex, value, timeout)
END futex_wait;
PROCEDURE futex_wake (futex, number: INTEGER);
VAR
res: INTEGER;
BEGIN
res := sysfunc4(77, 3, futex, number)
K.sysfunc4(77, 3, futex, number)
END futex_wake;
195,7 → 101,7
PROCEDURE InitializeCriticalSection* (VAR CriticalSection: CRITICAL_SECTION);
BEGIN
CriticalSection[0] := futex_create(sys.ADR(CriticalSection[1]));
CriticalSection[0] := futex_create(SYSTEM.ADR(CriticalSection[1]));
CriticalSection[1] := 0
END InitializeCriticalSection;
208,14 → 114,14
idx := ASR(size, 5);
res := pockets[idx];
IF res # 0 THEN
sys.GET(res, pockets[idx]);
sys.PUT(res, size);
SYSTEM.GET(res, pockets[idx]);
SYSTEM.PUT(res, size);
INC(res, 4)
ELSE
temp := 0;
IF heap + size >= endheap THEN
IF sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
temp := sysfunc3(68, 12, HEAP_SIZE)
IF K.sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
temp := K.sysfunc3(68, 12, HEAP_SIZE)
ELSE
temp := 0
END;
228,7 → 134,7
END
END;
IF (heap # 0) & (temp # -1) THEN
sys.PUT(heap, size);
SYSTEM.PUT(heap, size);
res := heap + 4;
heap := heap + size
ELSE
236,11 → 142,11
END
END
ELSE
IF sysfunc2(18, 16) > ASR(size, 10) THEN
res := sysfunc3(68, 12, size);
IF K.sysfunc2(18, 16) > ASR(size, 10) THEN
res := K.sysfunc3(68, 12, size);
IF res # 0 THEN
mem_commit(res, size);
sys.PUT(res, size);
SYSTEM.PUT(res, size);
INC(res, 4)
END
ELSE
259,13 → 165,13
size, idx: INTEGER;
BEGIN
DEC(ptr, 4);
sys.GET(ptr, size);
SYSTEM.GET(ptr, size);
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
sys.PUT(ptr, pockets[idx]);
SYSTEM.PUT(ptr, pockets[idx]);
pockets[idx] := ptr
ELSE
size := sysfunc3(68, 13, ptr)
size := K.sysfunc3(68, 13, ptr)
END
RETURN 0
END __DISPOSE;
274,8 → 180,11
PROCEDURE NEW_DISPOSE (func, arg: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
EnterCriticalSection(CriticalSection);
IF multi THEN
EnterCriticalSection(CriticalSection)
END;
IF func = _new THEN
res := __NEW(arg)
283,7 → 192,10
res := __DISPOSE(arg)
END;
IF multi THEN
LeaveCriticalSection(CriticalSection)
END
RETURN res
END NEW_DISPOSE;
298,63 → 210,110
END _DISPOSE;
PROCEDURE ExitProcess* (p1: INTEGER);
PROCEDURE exit* (p1: INTEGER);
BEGIN
p1 := sysfunc1(-1)
END ExitProcess;
K.sysfunc1(-1)
END exit;
PROCEDURE ExitThread* (p1: INTEGER);
PROCEDURE exit_thread* (p1: INTEGER);
BEGIN
p1 := sysfunc1(-1)
END ExitThread;
K.sysfunc1(-1)
END exit_thread;
PROCEDURE OutChar (c: CHAR);
VAR
res: INTEGER;
BEGIN
res := sysfunc3(63, 1, ORD(c))
K.sysfunc3(63, 1, ORD(c))
END OutChar;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
PROCEDURE OutLn;
BEGIN
OutChar(0DX);
OutChar(0AX)
END OutLn;
PROCEDURE OutStr (pchar: INTEGER);
VAR
c: CHAR;
BEGIN
IF lpCaption # 0 THEN
OutChar(0DX);
OutChar(0AX);
IF pchar # 0 THEN
REPEAT
sys.GET(lpCaption, c);
SYSTEM.GET(pchar, c);
IF c # 0X THEN
OutChar(c)
END;
INC(lpCaption)
UNTIL c = 0X;
INC(pchar)
UNTIL c = 0X
END
END OutStr;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
IF lpCaption # 0 THEN
OutLn;
OutStr(lpCaption);
OutChar(":");
OutChar(0DX);
OutChar(0AX)
OutLn
END;
REPEAT
sys.GET(lpText, c);
IF c # 0X THEN
OutChar(c)
END;
INC(lpText)
UNTIL c = 0X;
OutStr(lpText);
IF lpCaption # 0 THEN
OutChar(0DX);
OutChar(0AX)
OutLn
END
END DebugMsg;
PROCEDURE init* (p1: INTEGER);
PROCEDURE OutString (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
p1 := sysfunc2(68, 11);
InitializeCriticalSection(CriticalSection)
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
OutChar(s[i]);
INC(i)
END
END OutString;
PROCEDURE imp_error;
BEGIN
OutString("import error: ");
IF K.imp_error.error = 1 THEN
OutString("can't load "); OutString(K.imp_error.lib)
ELSIF K.imp_error.error = 2 THEN
OutString("not found "); OutString(K.imp_error.proc); OutString(" in "); OutString(K.imp_error.lib)
END;
OutLn
END imp_error;
PROCEDURE init* (_import, code: INTEGER);
BEGIN
multi := FALSE;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - 36;
K.sysfunc2(68, 11);
InitializeCriticalSection(CriticalSection);
K._init;
import := (K.dll_Load(_import) = 0) & (K.imp_error.error = 0);
IF ~import THEN
imp_error
END
END init;
PROCEDURE SetMultiThr* (value: BOOLEAN);
BEGIN
multi := value
END SetMultiThr;
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9) * 10
END GetTickCount;
END API.

/programs/develop/oberon07/Lib/KolibriOS/Args.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
38,7 → 38,7
PROCEDURE ParamParse;
VAR p, count, name: INTEGER; c: CHAR; cond: INTEGER;
PROCEDURE ChangeCond(A, B, C: INTEGER);
PROCEDURE ChangeCond(A, B, C: INTEGER; c: CHAR; VAR cond: INTEGER);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
64,11 → 64,11
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
END;
INC(p)

/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
65,7 → 65,7
res.color_type := 0;
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.ADR("/rd/1/colrdial");
res.start_path := sys.SADR("/rd/1/colrdial");
res.draw_window := draw_window;
res.status := 0;
res.X := 0;
86,7 → 86,7
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
96,8 → 96,8
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(sys.ADR(Dialog_init), "ColorDialog_init");
GetProc(sys.ADR(Dialog_start), "ColorDialog_start");
GetProc(Lib, sys.ADR(Dialog_init), "ColorDialog_init");
GetProc(Lib, sys.ADR(Dialog_start), "ColorDialog_start");
END Load;
BEGIN

/programs/develop/oberon07/Lib/KolibriOS/Console.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
17,8 → 17,9
MODULE Console;
IMPORT ConsoleLib;
IMPORT ConsoleLib, In, Out;
CONST
Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3;
26,23 → 27,29
DarkGray* = 8; LightBlue* = 9; LightGreen* = 10; LightCyan* = 11;
LightRed* = 12; LightMagenta* = 13; Yellow* = 14; White* = 15;
PROCEDURE SetCursor*(X, Y: INTEGER);
BEGIN
ConsoleLib.set_cursor_pos(X, Y)
END SetCursor;
PROCEDURE GetCursor*(VAR X, Y: INTEGER);
BEGIN
ConsoleLib.get_cursor_pos(X, Y)
END GetCursor;
PROCEDURE Cls*;
BEGIN
ConsoleLib.cls
END Cls;
PROCEDURE SetColor*(FColor, BColor: INTEGER);
VAR res: INTEGER;
VAR
res: INTEGER;
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
res := ConsoleLib.set_flags(LSL(BColor, 4) + FColor)
49,18 → 56,39
END
END SetColor;
PROCEDURE GetCursorX*(): INTEGER;
VAR x, y: INTEGER;
VAR
x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN x
END GetCursorX;
PROCEDURE GetCursorY*(): INTEGER;
VAR x, y: INTEGER;
VAR
x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN y
END GetCursorY;
PROCEDURE open*;
BEGIN
ConsoleLib.open(-1, -1, -1, -1, "");
In.Open;
Out.Open
END open;
PROCEDURE exit* (bCloseWindow: BOOLEAN);
BEGIN
ConsoleLib.exit(bCloseWindow)
END exit;
END Console.

/programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
66,7 → 66,7
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
77,25 → 77,25
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/Console.obj");
ASSERT(Lib # 0);
GetProc(sys.ADR(version), "version");
GetProc(sys.ADR(init), "con_init");
GetProc(sys.ADR(exit), "con_exit");
GetProc(sys.ADR(write_asciiz), "con_write_asciiz");
GetProc(sys.ADR(write_string), "con_write_string");
GetProc(sys.ADR(get_flags), "con_get_flags");
GetProc(sys.ADR(set_flags), "con_set_flags");
GetProc(sys.ADR(get_font_height), "con_get_font_height");
GetProc(sys.ADR(get_cursor_height), "con_get_cursor_height");
GetProc(sys.ADR(set_cursor_height), "con_set_cursor_height");
GetProc(sys.ADR(getch), "con_getch");
GetProc(sys.ADR(getch2), "con_getch2");
GetProc(sys.ADR(kbhit), "con_kbhit");
GetProc(sys.ADR(gets), "con_gets");
GetProc(sys.ADR(gets2), "con_gets2");
GetProc(sys.ADR(cls), "con_cls");
GetProc(sys.ADR(get_cursor_pos), "con_get_cursor_pos");
GetProc(sys.ADR(set_cursor_pos), "con_set_cursor_pos");
GetProc(sys.ADR(set_title), "con_set_title");
GetProc(Lib, sys.ADR(version), "version");
GetProc(Lib, sys.ADR(init), "con_init");
GetProc(Lib, sys.ADR(exit), "con_exit");
GetProc(Lib, sys.ADR(write_asciiz), "con_write_asciiz");
GetProc(Lib, sys.ADR(write_string), "con_write_string");
GetProc(Lib, sys.ADR(get_flags), "con_get_flags");
GetProc(Lib, sys.ADR(set_flags), "con_set_flags");
GetProc(Lib, sys.ADR(get_font_height), "con_get_font_height");
GetProc(Lib, sys.ADR(get_cursor_height), "con_get_cursor_height");
GetProc(Lib, sys.ADR(set_cursor_height), "con_set_cursor_height");
GetProc(Lib, sys.ADR(getch), "con_getch");
GetProc(Lib, sys.ADR(getch2), "con_getch2");
GetProc(Lib, sys.ADR(kbhit), "con_kbhit");
GetProc(Lib, sys.ADR(gets), "con_gets");
GetProc(Lib, sys.ADR(gets2), "con_gets2");
GetProc(Lib, sys.ADR(cls), "con_cls");
GetProc(Lib, sys.ADR(get_cursor_pos), "con_get_cursor_pos");
GetProc(Lib, sys.ADR(set_cursor_pos), "con_set_cursor_pos");
GetProc(Lib, sys.ADR(set_title), "con_set_title");
END main;
BEGIN

/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
19,10 → 19,10
IMPORT KOSAPI;
CONST ERR* = -7.0D5;
CONST ERR* = -7.0E5;
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL;
VAR d, i: INTEGER; M: ARRAY 13 OF CHAR; Res: LONGREAL;
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL;
VAR d, i: INTEGER; M: ARRAY 14 OF CHAR; Res: REAL;
BEGIN
Res := ERR;
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) &
38,16 → 38,16
FOR i := 1 TO Month - 1 DO
d := d + ORD(M[i]) - ORD("0") + 28
END;
Res := LONG(FLT(d)) + LONG(FLT(Hour * 3600000 + Min * 60000 + Sec * 1000)) / 86400000.0D0
Res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000) / 86400000.0
END
END
RETURN Res
END Encode;
PROCEDURE Decode*(Date: LONGREAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN;
VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 13 OF CHAR;
PROCEDURE Decode*(Date: REAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN;
VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 14 OF CHAR;
PROCEDURE MonthDay(n: INTEGER): BOOLEAN;
PROCEDURE MonthDay(n: INTEGER; VAR d, Month: INTEGER; M: ARRAY OF CHAR): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
Res := FALSE;
60,9 → 60,9
END MonthDay;
BEGIN
IF (Date >= -693593.0D0) & (Date < 2958466.0D0) THEN
IF (Date >= -693593.0) & (Date < 2958466.0) THEN
d := FLOOR(Date);
t := FLOOR((Date - LONG(FLT(d))) * 86400000.0D0);
t := FLOOR((Date - FLT(d)) * 86400000.0);
d := d + 693593;
Year := 1;
Month := 1;
82,7 → 82,7
i := 1;
flag := TRUE;
WHILE flag & (i <= 12) DO
flag := MonthDay(i);
flag := MonthDay(i, d, Month, M);
INC(i)
END;
Day := d;
98,7 → 98,7
RETURN Res
END Decode;
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec: INTEGER);
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec, Msec: INTEGER);
VAR date, time: INTEGER;
BEGIN
date := KOSAPI.sysfunc1(29);
134,7 → 134,8
Sec := (time MOD 16) * 10 + Sec;
time := time DIV 16;
Year := Year + 2000
Year := Year + 2000;
Msec := 0
END Now;
END DateTime.

/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
21,11 → 21,11
CONST
d = 1.0D0 - 5.0D-12;
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: LONGREAL; width: INTEGER);
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
VAR res: INTEGER;
72,7 → 72,7
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
80,8 → 80,8
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
97,15 → 97,15
END
END Int;
PROCEDURE OutInf(x: LONGREAL; width: INTEGER);
VAR s: ARRAY 4 OF CHAR; i: INTEGER;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0D0) THEN
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0D0) THEN
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
120,8 → 120,8
Char(0AX)
END Ln;
PROCEDURE _FixReal(x: LONGREAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN;
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
130,19 → 130,19
ELSE
len := 0;
minus := FALSE;
IF x < 0.0D0 THEN
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0D0 + d THEN
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
158,30 → 158,30
Char("-")
END;
y := x;
WHILE (y < 1.0D0) & (y # 0.0D0) DO
y := y * 10.0D0;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0D0
x := 0.0
ELSE
Char("0");
x := x * 10.0D0
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x > 9.0D0 THEN
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0D0
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
190,12 → 190,12
Char(".")
END;
WHILE p > 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0D0
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
202,7 → 202,7
END
END _FixReal;
PROCEDURE Real*(x: LONGREAL; width: INTEGER);
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
217,22 → 217,22
width := 9
END;
width := width - 5;
IF x < 0.0D0 THEN
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0D0) & (x # 0.0D0) DO
x := x * 10.0D0;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0D0 + d THEN
x := 1.0D0;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
260,7 → 260,7
END
END Real;
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER);
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
282,7 → 282,7
BEGIN
info.subfunc := 7;
info.flags := 0;
info.param := sys.ADR(" ");
info.param := sys.SADR(" ");
info.rsrvd1 := 0;
info.rsrvd2 := 0;
info.fname := "/rd/1/develop/board";

/programs/develop/oberon07/Lib/KolibriOS/File.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
19,10 → 19,12
IMPORT sys := SYSTEM, KOSAPI;
CONST
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
TYPE
FNAME* = ARRAY 520 OF CHAR;
47,29 → 49,36
name*: FNAME
END;
PROCEDURE [stdcall] f_68_27(file_name: INTEGER; VAR size: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("6A44"); (* push 68 *)
sys.CODE("58"); (* pop eax *)
sys.CODE("6A1B"); (* push 27 *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("8B4D08"); (* mov ecx, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D0C"); (* mov ecx, [ebp + 0Ch] *)
sys.CODE("8911"); (* mov [ecx], edx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
sys.CODE(
053H, (* push ebx *)
06AH, 044H, (* push 68 *)
058H, (* pop eax *)
06AH, 01BH, (* push 27 *)
05BH, (* pop ebx *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *)
0CDH, 040H, (* int 64 *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
089H, 011H, (* mov dword [ecx], edx *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 8 *)
)
RETURN 0
END f_68_27;
PROCEDURE Load*(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
RETURN f_68_27(sys.ADR(FName[0]), size)
END Load;
PROCEDURE GetFileInfo*(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR res2: INTEGER; fs: rFS;
VAR
res2: INTEGER; fs: rFS;
BEGIN
fs.subfunc := 5;
fs.pos := 0;
77,15 → 86,19
fs.bytes := 0;
fs.buffer := sys.ADR(Info);
COPY(FName, fs.name)
RETURN KOSAPI.sysfunc22(70, sys.ADR(fs), res2) = 0
END GetFileInfo;
PROCEDURE Exists*(FName: ARRAY OF CHAR): BOOLEAN;
VAR fd: rFD;
VAR
fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
END Exists;
PROCEDURE Close*(VAR F: FS);
BEGIN
IF F # NIL THEN
93,9 → 106,13
END
END Close;
PROCEDURE Open*(FName: ARRAY OF CHAR): FS;
VAR F: FS;
VAR
F: FS;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
109,12 → 126,18
ELSE
F := NIL
END
RETURN F
END Open;
PROCEDURE Delete*(FName: ARRAY OF CHAR): BOOLEAN;
VAR F: FS; res, res2: INTEGER;
VAR
F: FS;
res, res2: INTEGER;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
132,12 → 155,18
ELSE
res := -1
END
RETURN res = 0
END Delete;
PROCEDURE Seek*(F: FS; Offset, Origin: INTEGER): INTEGER;
VAR res: INTEGER; fd: rFD;
VAR
res: INTEGER;
fd: rFD;
BEGIN
IF (F # NIL) & GetFileInfo(F.name, fd) & (BITS(fd.attr) * {4} = {}) THEN
CASE Origin OF
|SEEK_BEG: F.pos := Offset
149,12 → 178,17
ELSE
res := -1
END
RETURN res
END Seek;
PROCEDURE Read*(F: FS; Buffer, Count: INTEGER): INTEGER;
VAR res, res2: INTEGER;
VAR
res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 0;
F.bytes := Count;
166,12 → 200,17
ELSE
res2 := 0
END
RETURN res2
END Read;
PROCEDURE Write*(F: FS; Buffer, Count: INTEGER): INTEGER;
VAR res, res2: INTEGER;
VAR
res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 3;
F.bytes := Count;
183,13 → 222,19
ELSE
res2 := 0
END
RETURN res2
END Write;
PROCEDURE Create*(FName: ARRAY OF CHAR): FS;
VAR F: FS; res2: INTEGER;
VAR
F: FS;
res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 2;
F.pos := 0;
201,19 → 246,27
DISPOSE(F)
END
END
RETURN F
END Create;
PROCEDURE DirExists*(FName: ARRAY OF CHAR): BOOLEAN;
VAR fd: rFD;
VAR
fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & (4 IN BITS(fd.attr))
END DirExists;
PROCEDURE CreateDir*(DirName: ARRAY OF CHAR): BOOLEAN;
VAR F: FS; res, res2: INTEGER;
VAR
F: FS;
res, res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 9;
F.pos := 0;
226,12 → 279,18
ELSE
res := -1
END
RETURN res = 0
END CreateDir;
PROCEDURE DeleteDir*(DirName: ARRAY OF CHAR): BOOLEAN;
VAR F: FS; res, res2: INTEGER;
VAR
F: FS;
res, res2: INTEGER;
BEGIN
IF DirExists(DirName) THEN
NEW(F);
IF F # NIL THEN
249,7 → 308,9
ELSE
res := -1
END
RETURN res = 0
END DeleteDir;
END File.

/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07
1,246 → 1,471
(*
Copyright 2016, 2017 Anton Krotov
(*
BSD 2-Clause License
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 <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, K := KOSAPI, API, RTL;
CONST
slash* = "/";
OS* = "KOS";
Slash* = "/";
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
MAX_PARAM = 1024;
TYPE
FILENAME = ARRAY 2048 OF CHAR;
FNAME = ARRAY 520 OF CHAR;
OFSTRUCT = RECORD
subfunc, pos, hpos, bytes, buf: INTEGER;
name: FILENAME
FS = POINTER TO rFS;
rFS = RECORD
subfunc, pos, hpos, bytes, buffer: INTEGER;
name: FNAME
END;
FD = POINTER TO rFD;
rFD = RECORD
attr: INTEGER;
ntyp: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create, date_create,
time_access, date_access,
time_modif, date_modif,
size, hsize: INTEGER;
name: FNAME
END;
VAR
con_init : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
con_exit : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
con_write_asciiz : PROCEDURE [stdcall] (string: INTEGER);
fsize, sec*, dsec*: INTEGER;
Console: BOOLEAN;
PROCEDURE [stdcall] sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
eol*: ARRAY 3 OF CHAR;
PROCEDURE [stdcall, "Console.obj", "con_init"] con_init (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
PROCEDURE [stdcall, "Console.obj", "con_exit"] con_exit (bCloseWindow: BOOLEAN);
PROCEDURE [stdcall, "Console.obj", "con_write_string"] con_write_string (string, length: INTEGER);
PROCEDURE ExitProcess* (p1: INTEGER);
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8919"); (* mov [ecx], ebx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc22;
IF Console THEN
con_exit(FALSE)
END;
K.sysfunc1(-1)
END ExitProcess;
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR cur, procname, adr: INTEGER;
PROCEDURE streq(str1, str2: INTEGER): BOOLEAN;
VAR c1, c2: CHAR;
PROCEDURE OutChar* (c: CHAR);
BEGIN
REPEAT
sys.GET(str1, c1);
sys.GET(str2, c2);
INC(str1);
INC(str2)
UNTIL (c1 # c2) OR (c1 = 0X)
RETURN c1 = c2
END streq;
IF Console THEN
con_write_string(SYSTEM.ADR(c), 1)
ELSE
K.sysfunc3(63, 1, ORD(c))
END
END OutChar;
PROCEDURE GetFileInfo (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR
res2: INTEGER;
fs: rFS;
BEGIN
adr := 0;
IF (lib # 0) & (name # "") THEN
cur := lib;
REPEAT
sys.GET(cur, procname);
INC(cur, 8)
UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0]));
IF procname # 0 THEN
sys.GET(cur - 4, adr)
fs.subfunc := 5;
fs.pos := 0;
fs.hpos := 0;
fs.bytes := 0;
fs.buffer := SYSTEM.ADR(Info);
COPY(FName, fs.name)
RETURN K.sysfunc22(70, SYSTEM.ADR(fs), res2) = 0
END GetFileInfo;
PROCEDURE Exists (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
END Exists;
PROCEDURE Close (VAR F: FS);
BEGIN
IF F # NIL THEN
DISPOSE(F)
END
END Close;
PROCEDURE Open (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 0;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name)
END
RETURN adr
END GetProcAdr;
ELSE
F := NIL
END
PROCEDURE Time*(VAR sec, dsec: INTEGER);
VAR t: INTEGER;
RETURN F
END Open;
PROCEDURE Read (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
BEGIN
t := API.sysfunc2(26, 9);
sec := t DIV 100;
dsec := t MOD 100
END Time;
IF F # NIL THEN
F.subfunc := 0;
F.bytes := Count;
F.buffer := Buffer;
res := K.sysfunc22(70, SYSTEM.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
PROCEDURE init*;
VAR Lib: INTEGER;
RETURN res2
END Read;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
PROCEDURE Write (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
BEGIN
a := GetProcAdr(name, Lib);
sys.PUT(v, a)
END GetProc;
IF F # NIL THEN
F.subfunc := 3;
F.bytes := Count;
F.buffer := Buffer;
res := K.sysfunc22(70, SYSTEM.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Write;
PROCEDURE Create (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
res2: INTEGER;
BEGIN
Time(sec, dsec);
Lib := API.sysfunc3(68, 19, sys.ADR("/rd/1/lib/console.obj"));
IF Lib # 0 THEN
GetProc(sys.ADR(con_init), "con_init");
GetProc(sys.ADR(con_exit), "con_exit");
GetProc(sys.ADR(con_write_asciiz), "con_write_asciiz");
IF con_init # NIL THEN
con_init(-1, -1, -1, -1, sys.ADR("Oberon-07/11 for KolibriOS"))
NEW(F);
IF F # NIL THEN
F.subfunc := 2;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
IF K.sysfunc22(70, SYSTEM.ADR(F^), res2) # 0 THEN
DISPOSE(F)
END
END
END init;
PROCEDURE ExitProcess* (n: INTEGER);
RETURN F
END Create;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
n: INTEGER;
fs: FS;
BEGIN
IF con_exit # NIL THEN
con_exit(FALSE)
END;
API.ExitProcess(0)
END ExitProcess;
SYSTEM.GET(SYSTEM.ADR(F), fs);
n := Read(fs, SYSTEM.ADR(Buffer[0]), bytes);
IF n = 0 THEN
n := -1
END
RETURN n
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
n: INTEGER;
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
n := Write(fs, SYSTEM.ADR(Buffer[0]), bytes);
IF n = 0 THEN
n := -1
END
RETURN n
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
VAR
fs: FS;
res: INTEGER;
BEGIN
fs := Create(FName);
SYSTEM.GET(SYSTEM.ADR(fs), res)
RETURN res
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
VAR
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
Close(fs)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
fs: FS;
res: INTEGER;
BEGIN
fs := Open(FName);
SYSTEM.GET(SYSTEM.ADR(fs), res)
RETURN res
END FileOpen;
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9)
END GetTickCount;
PROCEDURE AppAdr(): INTEGER;
VAR
buf: ARRAY 1024 OF CHAR;
a: INTEGER;
BEGIN
a := API.sysfunc3(9, sys.ADR(buf), -1);
sys.GET(sys.ADR(buf) + 22, a)
a := K.sysfunc3(9, SYSTEM.ADR(buf), -1);
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a)
RETURN a
END AppAdr;
PROCEDURE GetCommandLine*(): INTEGER;
VAR param: INTEGER;
PROCEDURE GetCommandLine (): INTEGER;
VAR
param: INTEGER;
BEGIN
sys.GET(28 + AppAdr(), param)
SYSTEM.GET(28 + AppAdr(), param)
RETURN param
END GetCommandLine;
PROCEDURE GetName*(): INTEGER;
VAR name: INTEGER;
PROCEDURE GetName (): INTEGER;
VAR
name: INTEGER;
BEGIN
sys.GET(32 + AppAdr(), name)
SYSTEM.GET(32 + AppAdr(), name)
RETURN name
END GetName;
PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN API.sysfunc3(68, 12, size)
END malloc;
PROCEDURE CloseFile*(hObject: INTEGER);
VAR pFS: POINTER TO OFSTRUCT;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
sys.PUT(sys.ADR(pFS), hObject);
DISPOSE(pFS)
END CloseFile;
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE _OCFile(FileName: ARRAY OF CHAR; VAR FS: OFSTRUCT; mode: INTEGER; VAR fsize: INTEGER): INTEGER;
VAR buf: ARRAY 40 OF CHAR; res: INTEGER;
PROCEDURE ParamParse;
VAR
p, count, name, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; c: CHAR; VAR cond: INTEGER);
BEGIN
FS.subfunc := mode;
FS.pos := 0;
FS.hpos := 0;
FS.bytes := 0;
FS.buf := sys.ADR(buf);
COPY(FileName, FS.name);
IF sysfunc22(70, sys.ADR(FS), res) = 0 THEN
res := sys.ADR(FS);
sys.GET(sys.ADR(buf) + 32, fsize)
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
res := 0
cond := C
END
RETURN res
END _OCFile;
END ChangeCond;
PROCEDURE IOFile(VAR FS: OFSTRUCT; Buffer, bytes, io: INTEGER): INTEGER;
VAR res1, res: INTEGER;
BEGIN
FS.subfunc := io;
FS.bytes := bytes;
FS.buf := Buffer;
res1 := sysfunc22(70, sys.ADR(FS), res);
IF res = -1 THEN
res := 0
p := GetCommandLine();
name := GetName();
Params[0, 0] := name;
WHILE GetChar(name) # 0X DO
INC(name)
END;
FS.pos := FS.pos + res
RETURN res
END IOFile;
Params[0, 1] := name - 1;
cond := 0;
count := 1;
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE OCFile(FName: ARRAY OF CHAR; mode: INTEGER): INTEGER;
VAR FS: OFSTRUCT; pFS: POINTER TO OFSTRUCT; res: INTEGER;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
BEGIN
IF _OCFile(FName, FS, mode, fsize) # 0 THEN
NEW(pFS);
IF pFS = NIL THEN
res := 0
ELSE
sys.GET(sys.ADR(pFS), res);
pFS^ := FS
END
ELSE
res := 0
END
RETURN res
END OCFile;
j := 0;
IF n < argc THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i);
END;
END;
s[j] := 0X
END GetArg;
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN OCFile(FName, 2)
END CreateFile;
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN OCFile(FName, 5)
END OpenFile;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
PROCEDURE FileSize* (F: INTEGER): INTEGER;
RETURN fsize
END FileSize;
BEGIN
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR pFS: POINTER TO OFSTRUCT; res: INTEGER;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
VAR
date, time: INTEGER;
BEGIN
IF hFile # 0 THEN
sys.PUT(sys.ADR(pFS), hFile);
res := IOFile(pFS^, Buffer, nNumberOfBytes, 3 * ORD(write))
ELSE
res := 0
END
RETURN res
END FileRW;
date := K.sysfunc1(29);
time := K.sysfunc1(3);
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR n: INTEGER;
year := date MOD 16;
date := date DIV 16;
year := (date MOD 16) * 10 + year;
date := date DIV 16;
month := date MOD 16;
date := date DIV 16;
month := (date MOD 16) * 10 + month;
date := date DIV 16;
day := date MOD 16;
date := date DIV 16;
day := (date MOD 16) * 10 + day;
date := date DIV 16;
hour := time MOD 16;
time := time DIV 16;
hour := (time MOD 16) * 10 + hour;
time := time DIV 16;
min := time MOD 16;
time := time DIV 16;
min := (time MOD 16) * 10 + min;
time := time DIV 16;
sec := time MOD 16;
time := time DIV 16;
sec := (time MOD 16) * 10 + sec;
time := time DIV 16;
year := year + 2000
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN 0
END UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
n := ORD(str[0] = 3X);
IF con_write_asciiz # NIL THEN
con_write_asciiz(sys.ADR(str[n]))
ELSE
API.DebugMsg(sys.ADR(str[n]), 0)
END
END OutString;
SYSTEM.GET(SYSTEM.ADR(x), a);
SYSTEM.GET(SYSTEM.ADR(x) + 4, b)
RETURN a
END splitf;
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
Console := API.import;
IF Console THEN
con_init(-1, -1, -1, -1, SYSTEM.SADR("Oberon-07 for KolibriOS"))
END;
ParamParse
END HOST.

/programs/develop/oberon07/Lib/KolibriOS/In.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
134,23 → 134,23
RETURN Res & (s[i] <= 20X)
END CheckReal;
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): LONGREAL;
CONST maxDBL = 1.69D308; maxINT = 7FFFFFFFH;
VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, neg: BOOLEAN;
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): REAL;
CONST maxDBL = 1.69E308; maxINT = 7FFFFFFFH;
VAR i, scale: INTEGER; res, m, d: REAL; minus, neg: BOOLEAN;
PROCEDURE part1(): BOOLEAN;
PROCEDURE part1 (str: STRING; VAR res, d: REAL; VAR i: INTEGER): BOOLEAN;
BEGIN
res := 0.0D0;
d := 1.0D0;
res := 0.0;
d := 1.0;
WHILE digit(str[i]) DO
res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0")));
res := res * 10.0 + FLT(ORD(str[i]) - ORD("0"));
INC(i)
END;
IF str[i] = "." THEN
INC(i);
WHILE digit(str[i]) DO
d := d / 10.0D0;
res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d;
d := d / 10.0;
res := res + FLT(ORD(str[i]) - ORD("0")) * d;
INC(i)
END
END
157,10 → 157,10
RETURN str[i] # 0X
END part1;
PROCEDURE part2(): BOOLEAN;
PROCEDURE part2 (str: STRING; VAR i, scale: INTEGER; VAR minus, err: BOOLEAN; VAR m, res: REAL): BOOLEAN;
BEGIN
INC(i);
m := 10.0D0;
m := 10.0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
167,7 → 167,7
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1D0
m := 0.1
END;
scale := 0;
err := FALSE;
174,12 → 174,12
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0D0
res := 0.0
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0D0
res := 0.0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
189,19 → 189,19
RETURN ~err
END part2;
PROCEDURE part3;
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR res, m: REAL; VAR scale: INTEGER);
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0D0
res := 0.0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0D0
res := 0.0
ELSE
res := res * m;
INC(i)
211,14 → 211,14
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1() & part2() THEN
part3
IF part1(str, res, d, i) & part2(str, i, scale, minus, err, m, res) THEN
part3(err, minus, res, m, scale)
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0D0;
res := 0.0;
err := TRUE
END
RETURN res
251,7 → 251,7
Done := TRUE
END Ln;
PROCEDURE LongReal*(VAR x: LONGREAL);
PROCEDURE Real* (VAR x: REAL);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
260,23 → 260,9
UNTIL ~Space(str);
x := StrToFloat(str, err);
Done := ~err
END LongReal;
PROCEDURE Real*(VAR x: REAL);
CONST maxREAL = 3.39E38;
VAR y: LONGREAL;
BEGIN
LongReal(y);
IF Done THEN
IF ABS(y) > LONG(maxREAL) THEN
x := 0.0;
Done := FALSE
ELSE
x := SHORT(y)
END
END
END Real;
PROCEDURE Int*(VAR x: INTEGER);
VAR str: STRING; err: BOOLEAN;
BEGIN

/programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07
1,162 → 1,195
(*
Copyright 2016, 2018 Anton Krotov
(*
BSD 2-Clause License
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 <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE KOSAPI;
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
TYPE STRING = ARRAY 1024 OF CHAR;
VAR DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER);
TYPE
PROCEDURE [stdcall] sysfunc1*(arg1: INTEGER): INTEGER;
STRING = ARRAY 1024 OF CHAR;
VAR
DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER);
imp_error*: RECORD
proc*, lib*: STRING;
error*: INTEGER
END;
PROCEDURE [stdcall-] sysfunc1* (arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
0CDH, 040H, (* int 64 *)
0C9H, (* leave *)
0C2H, 004H, 000H (* ret 4 *)
)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall] sysfunc2*(arg1, arg2: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc2* (arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 8 *)
)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall] sysfunc3*(arg1, arg2, arg3: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc3* (arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall] sysfunc4*(arg1, arg2, arg3, arg4: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc4* (arg1, arg2, arg3, arg4: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21000"); (* ret 10h *)
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 16 *)
)
RETURN 0
END sysfunc4;
PROCEDURE [stdcall] sysfunc5*(arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc5* (arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
0CDH, 040H, (* int 64 *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 014H, 000H (* ret 20 *)
)
RETURN 0
END sysfunc5;
PROCEDURE [stdcall] sysfunc6*(arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc6* (arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("57"); (* push edi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5F"); (* pop edi *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21800"); (* ret 18h *)
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
0CDH, 040H, (* int 64 *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END sysfunc6;
PROCEDURE [stdcall] sysfunc7*(arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc7* (arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("57"); (* push edi *)
sys.CODE("55"); (* push ebp *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *)
sys.CODE("8B6D20"); (* mov ebp, [ebp + 20h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5D"); (* pop ebp *)
sys.CODE("5F"); (* pop edi *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21C00"); (* ret 1Ch *)
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
055H, (* push ebp *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
08BH, 06DH, 020H, (* mov ebp, dword [ebp + 32] *)
0CDH, 040H, (* int 64 *)
05DH, (* pop ebp *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 01CH, 000H (* ret 28 *)
)
RETURN 0
END sysfunc7;
PROCEDURE [stdcall] sysfunc22*(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc22* (arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8919"); (* mov [ecx], ebx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
0CDH, 040H, (* int 64 *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 019H, (* mov dword [ecx], ebx *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END sysfunc22;
PROCEDURE mem_commit(adr, size: INTEGER);
VAR tmp: INTEGER;
VAR
tmp: INTEGER;
BEGIN
FOR tmp := adr TO adr + size - 1 BY 4096 DO
sys.PUT(tmp, 0)
SYSTEM.PUT(tmp, 0)
END
END mem_commit;
PROCEDURE [stdcall] malloc*(size: INTEGER): INTEGER;
VAR ptr: INTEGER;
VAR
ptr: INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
SYSTEM.CODE(060H); (* pusha *)
IF sysfunc2(18, 16) > ASR(size, 10) THEN
ptr := sysfunc3(68, 12, size);
IF ptr # 0 THEN
165,98 → 198,122
ELSE
ptr := 0
END;
sys.CODE("61") (* popa *)
SYSTEM.CODE(061H) (* popa *)
RETURN ptr
END malloc;
PROCEDURE [stdcall] free*(ptr: INTEGER): INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
SYSTEM.CODE(060H); (* pusha *)
IF ptr # 0 THEN
ptr := sysfunc3(68, 13, ptr)
END;
sys.CODE("61") (* popa *)
SYSTEM.CODE(061H) (* popa *)
RETURN 0
END free;
PROCEDURE [stdcall] realloc*(ptr, size: INTEGER): INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
SYSTEM.CODE(060H); (* pusha *)
ptr := sysfunc4(68, 20, size, ptr);
sys.CODE("61") (* popa *)
SYSTEM.CODE(061H) (* popa *)
RETURN ptr
END realloc;
PROCEDURE AppAdr(): INTEGER;
VAR
buf: ARRAY 1024 OF CHAR;
a: INTEGER;
BEGIN
a := sysfunc3(9, sys.ADR(buf), -1);
sys.GET(sys.ADR(buf) + 22, a)
a := sysfunc3(9, SYSTEM.ADR(buf), -1);
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a)
RETURN a
END AppAdr;
PROCEDURE GetCommandLine*(): INTEGER;
VAR param: INTEGER;
VAR
param: INTEGER;
BEGIN
sys.GET(28 + AppAdr(), param)
SYSTEM.GET(28 + AppAdr(), param)
RETURN param
END GetCommandLine;
PROCEDURE GetName*(): INTEGER;
VAR name: INTEGER;
VAR
name: INTEGER;
BEGIN
sys.GET(32 + AppAdr(), name)
SYSTEM.GET(32 + AppAdr(), name)
RETURN name
END GetName;
PROCEDURE [stdcall] dll_init2(arg1, arg2, arg3, arg4, arg5: INTEGER);
BEGIN
sys.CODE("60"); (* pusha *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("FFD6"); (* call esi *)
sys.CODE("61"); (* popa *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
SYSTEM.CODE(
060H, (* pusha *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
0FFH, 0D6H, (* call esi *)
061H, (* popa *)
0C9H, (* leave *)
0C2H, 014H, 000H (* ret 20 *)
)
END dll_init2;
PROCEDURE GetProcAdr*(name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR cur, procname, adr: INTEGER;
VAR
cur, procname, adr: INTEGER;
PROCEDURE streq(str1, str2: INTEGER): BOOLEAN;
VAR c1, c2: CHAR;
VAR
c1, c2: CHAR;
BEGIN
REPEAT
sys.GET(str1, c1);
sys.GET(str2, c2);
SYSTEM.GET(str1, c1);
SYSTEM.GET(str2, c2);
INC(str1);
INC(str2)
UNTIL (c1 # c2) OR (c1 = 0X)
RETURN c1 = c2
END streq;
BEGIN
adr := 0;
IF (lib # 0) & (name # "") THEN
cur := lib;
REPEAT
sys.GET(cur, procname);
SYSTEM.GET(cur, procname);
INC(cur, 8)
UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0]));
UNTIL (procname = 0) OR streq(procname, SYSTEM.ADR(name[0]));
IF procname # 0 THEN
sys.GET(cur - 4, adr)
SYSTEM.GET(cur - 4, adr)
END
END
RETURN adr
END GetProcAdr;
PROCEDURE init(dll: INTEGER);
VAR lib_init: INTEGER;
VAR
lib_init: INTEGER;
BEGIN
lib_init := GetProcAdr("lib_init", dll);
IF lib_init # 0 THEN
265,51 → 322,62
lib_init := GetProcAdr("START", dll);
IF lib_init # 0 THEN
DLL_INIT(lib_init)
END;
END
END init;
PROCEDURE [stdcall] dll_Load(import_table: INTEGER): INTEGER;
VAR imp, lib, exp, proc, res: INTEGER;
fail, done: BOOLEAN;
procname, libname: STRING;
PROCEDURE GetStr(adr, i: INTEGER; VAR str: STRING);
VAR c: CHAR;
VAR
c: CHAR;
BEGIN
REPEAT
sys.GET(adr, c); INC(adr);
SYSTEM.GET(adr, c); INC(adr);
str[i] := c; INC(i)
UNTIL c = 0X
END GetStr;
PROCEDURE [stdcall] dll_Load* (import_table: INTEGER): INTEGER;
VAR
imp, lib, exp, proc, res: INTEGER;
fail, done: BOOLEAN;
procname, libname: STRING;
BEGIN
sys.CODE("60"); (* pusha *)
SYSTEM.CODE(060H); (* pusha *)
fail := FALSE;
done := FALSE;
res := 0;
libname := "/rd/1/lib/";
REPEAT
sys.GET(import_table, imp);
SYSTEM.GET(import_table, imp);
IF imp # 0 THEN
sys.GET(import_table + 4, lib);
SYSTEM.GET(import_table + 4, lib);
GetStr(lib, 10, libname);
exp := sysfunc3(68, 19, sys.ADR(libname[0]));
exp := sysfunc3(68, 19, SYSTEM.ADR(libname[0]));
fail := exp = 0;
ELSE
done := TRUE
END;
IF fail THEN
done := TRUE
done := TRUE;
imp_error.proc := "";
imp_error.lib := libname;
imp_error.error := 1
END;
IF (imp # 0) & ~fail THEN
REPEAT
sys.GET(imp, proc);
SYSTEM.GET(imp, proc);
IF proc # 0 THEN
GetStr(proc, 0, procname);
proc := GetProcAdr(procname, exp);
IF proc # 0 THEN
sys.PUT(imp, proc);
INC(imp, 4);
SYSTEM.PUT(imp, proc);
INC(imp, 4)
ELSE
imp_error.proc := procname;
imp_error.lib := libname;
imp_error.error := 2
END
END
UNTIL proc = 0;
321,24 → 389,28
res := 1
END;
import_table := res;
sys.CODE("61") (* popa *)
SYSTEM.CODE(061H) (* popa *)
RETURN import_table
END dll_Load;
PROCEDURE [stdcall] dll_Init(entry: INTEGER);
BEGIN
sys.CODE("60"); (* pusha *)
SYSTEM.CODE(060H); (* pusha *)
IF entry # 0 THEN
dll_init2(sys.ADR(malloc), sys.ADR(free), sys.ADR(realloc), sys.ADR(dll_Load), entry)
dll_init2(SYSTEM.ADR(malloc), SYSTEM.ADR(free), SYSTEM.ADR(realloc), SYSTEM.ADR(dll_Load), entry)
END;
sys.CODE("61"); (* popa *)
SYSTEM.CODE(061H); (* popa *)
END dll_Init;
PROCEDURE LoadLib*(name: ARRAY OF CHAR): INTEGER;
VAR Lib: INTEGER;
VAR
Lib: INTEGER;
BEGIN
DLL_INIT := dll_Init;
Lib := sysfunc3(68, 19, sys.ADR(name[0]));
Lib := sysfunc3(68, 19, SYSTEM.ADR(name[0]));
IF Lib # 0 THEN
init(Lib)
END
345,4 → 417,14
RETURN Lib
END LoadLib;
PROCEDURE _init*;
BEGIN
DLL_INIT := dll_Init;
imp_error.lib := "";
imp_error.proc := "";
imp_error.error := 0
END _init;
END KOSAPI.

/programs/develop/oberon07/Lib/KolibriOS/Math.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2013, 2014, 2018 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
17,238 → 17,365
MODULE Math;
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
CONST pi* = 3.141592653589793D+00;
e* = 2.718281828459045D+00;
VAR Inf*, nInf*: LONGREAL;
CONST
PROCEDURE IsNan*(x: LONGREAL): BOOLEAN;
VAR h, l: SET;
pi* = 3.141592653589793;
e* = 2.718281828459045;
PROCEDURE IsNan* (x: REAL): BOOLEAN;
VAR
h, l: SET;
BEGIN
sys.GET(sys.ADR(x), l);
sys.GET(sys.ADR(x) + 4, h);
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf*(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
PROCEDURE IsInf* (x: REAL): BOOLEAN;
RETURN ABS(x) = SYSTEM.INF()
END IsInf;
PROCEDURE Max(A, B: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE Max (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF A > B THEN
Res := A
IF a > b THEN
res := a
ELSE
Res := B
res := b
END
RETURN Res
RETURN res
END Max;
PROCEDURE Min(A, B: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE Min (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF A < B THEN
Res := A
IF a < b THEN
res := a
ELSE
Res := B
res := b
END
RETURN Res
RETURN res
END Min;
PROCEDURE SameValue(A, B: LONGREAL): BOOLEAN;
VAR Epsilon: LONGREAL; Res: BOOLEAN;
PROCEDURE SameValue (a, b: REAL): BOOLEAN;
VAR
eps: REAL;
res: BOOLEAN;
BEGIN
Epsilon := Max(Min(ABS(A), ABS(B)) * 1.0D-12, 1.0D-12);
IF A > B THEN
Res := (A - B) <= Epsilon
eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);
IF a > b THEN
res := (a - b) <= eps
ELSE
Res := (B - A) <= Epsilon
res := (b - a) <= eps
END
RETURN Res
RETURN res
END SameValue;
PROCEDURE IsZero(x: LONGREAL): BOOLEAN;
RETURN ABS(x) <= 1.0D-12
PROCEDURE IsZero (x: REAL): BOOLEAN;
RETURN ABS(x) <= 1.0E-12
END IsZero;
PROCEDURE [stdcall] sqrt*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D9FAC9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FAH, (* fsqrt *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sqrt;
PROCEDURE [stdcall] sin*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] sin* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D9FEC9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FEH, (* fsin *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sin;
PROCEDURE [stdcall] cos*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] cos* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D9FFC9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FFH, (* fcos *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END cos;
PROCEDURE [stdcall] tan*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] tan* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D9F2DEC9C9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FBH, (* fsincos *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END tan;
PROCEDURE [stdcall] arctan2*(y, x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
BEGIN
sys.CODE("DD4508DD4510D9F3C9C21000")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F3H, (* fpatan *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END arctan2;
PROCEDURE [stdcall] ln*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] ln* (x: REAL): REAL;
BEGIN
sys.CODE("D9EDDD4508D9F1C9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0D9H, 0EDH, (* fldln2 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END ln;
PROCEDURE [stdcall] log*(base, x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] log* (base, x: REAL): REAL;
BEGIN
sys.CODE("D9E8DD4510D9F1D9E8DD4508D9F1DEF9C9C21000")
RETURN 0.0D0
SYSTEM.CODE(
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F1H, (* fyl2x *)
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END log;
PROCEDURE [stdcall] exp*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] exp* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D9EADEC9D9C0D9FCDCE9D9C9D9F0D9E8DEC1D9FDDDD9C9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0EAH, (* fldl2e *)
0DEH, 0C9H, 0D9H, 0C0H,
0D9H, 0FCH, 0DCH, 0E9H,
0D9H, 0C9H, 0D9H, 0F0H,
0D9H, 0E8H, 0DEH, 0C1H,
0D9H, 0FDH, 0DDH, 0D9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END exp;
PROCEDURE [stdcall] round*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] round* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D97DF4D97DF666814DF60003D96DF6D9FCD96DF4C9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 07DH, 0F4H, 0D9H,
07DH, 0F6H, 066H, 081H,
04DH, 0F6H, 000H, 003H,
0D9H, 06DH, 0F6H, 0D9H,
0FCH, 0D9H, 06DH, 0F4H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END round;
PROCEDURE [stdcall] frac*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] frac* (x: REAL): REAL;
BEGIN
sys.CODE("50DD4508D9C0D93C24D97C240266814C2402000FD96C2402D9FCD92C24DEE9C9C20800")
RETURN 0.0D0
SYSTEM.CODE(
050H,
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0C0H, 0D9H, 03CH,
024H, 0D9H, 07CH, 024H,
002H, 066H, 081H, 04CH,
024H, 002H, 000H, 00FH,
0D9H, 06CH, 024H, 002H,
0D9H, 0FCH, 0D9H, 02CH,
024H, 0DEH, 0E9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END frac;
PROCEDURE arcsin*(x: LONGREAL): LONGREAL;
RETURN arctan2(x, sqrt(1.0D0 - x * x))
PROCEDURE arcsin* (x: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
PROCEDURE arccos*(x: LONGREAL): LONGREAL;
RETURN arctan2(sqrt(1.0D0 - x * x), x)
PROCEDURE arccos* (x: REAL): REAL;
RETURN arctan2(sqrt(1.0 - x * x), x)
END arccos;
PROCEDURE arctan*(x: LONGREAL): LONGREAL;
RETURN arctan2(x, 1.0D0)
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, 1.0)
END arctan;
PROCEDURE sinh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE sinh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF IsZero(x) THEN
Res := 0.0D0
res := 0.0
ELSE
Res := (exp(x) - exp(-x)) / 2.0D0
res := (exp(x) - exp(-x)) / 2.0
END
RETURN Res
RETURN res
END sinh;
PROCEDURE cosh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE cosh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF IsZero(x) THEN
Res := 1.0D0
res := 1.0
ELSE
Res := (exp(x) + exp(-x)) / 2.0D0
res := (exp(x) + exp(-x)) / 2.0
END
RETURN Res
RETURN res
END cosh;
PROCEDURE tanh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE tanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF IsZero(x) THEN
Res := 0.0D0
res := 0.0
ELSE
Res := sinh(x) / cosh(x)
res := sinh(x) / cosh(x)
END
RETURN Res
RETURN res
END tanh;
PROCEDURE arcsinh*(x: LONGREAL): LONGREAL;
RETURN ln(x + sqrt((x * x) + 1.0D0))
PROCEDURE arcsinh* (x: REAL): REAL;
RETURN ln(x + sqrt((x * x) + 1.0))
END arcsinh;
PROCEDURE arccosh*(x: LONGREAL): LONGREAL;
RETURN ln(x + sqrt((x - 1.0D0) / (x + 1.0D0)) * (x + 1.0D0))
PROCEDURE arccosh* (x: REAL): REAL;
RETURN ln(x + sqrt((x - 1.0) / (x + 1.0)) * (x + 1.0))
END arccosh;
PROCEDURE arctanh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE arctanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF SameValue(x, 1.0D0) THEN
Res := Inf
ELSIF SameValue(x, -1.0D0) THEN
Res := nInf
IF SameValue(x, 1.0) THEN
res := SYSTEM.INF()
ELSIF SameValue(x, -1.0) THEN
res := -SYSTEM.INF()
ELSE
Res := 0.5D0 * ln((1.0D0 + x) / (1.0D0 - x))
res := 0.5 * ln((1.0 + x) / (1.0 - x))
END
RETURN Res
RETURN res
END arctanh;
PROCEDURE floor*(x: LONGREAL): LONGREAL;
VAR f: LONGREAL;
PROCEDURE floor* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0D0 THEN
x := x - 1.0D0
IF f < 0.0 THEN
x := x - 1.0
END
RETURN x
END floor;
PROCEDURE ceil*(x: LONGREAL): LONGREAL;
VAR f: LONGREAL;
PROCEDURE ceil* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0D0 THEN
x := x + 1.0D0
IF f > 0.0 THEN
x := x + 1.0
END
RETURN x
END ceil;
PROCEDURE power*(base, exponent: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE power* (base, exponent: REAL): REAL;
VAR
res: REAL;
BEGIN
IF exponent = 0.0D0 THEN
Res := 1.0D0
ELSIF (base = 0.0D0) & (exponent > 0.0D0) THEN
Res := 0.0D0
IF exponent = 0.0 THEN
res := 1.0
ELSIF (base = 0.0) & (exponent > 0.0) THEN
res := 0.0
ELSE
Res := exp(exponent * ln(base))
res := exp(exponent * ln(base))
END
RETURN Res
RETURN res
END power;
PROCEDURE sgn*(x: LONGREAL): INTEGER;
VAR Res: INTEGER;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0D0 THEN
Res := 1
ELSIF x < 0.0D0 THEN
Res := -1
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
Res := 0
res := 0
END
RETURN Res
RETURN res
END sgn;
BEGIN
Inf := sys.INF(LONGREAL);
nInf := -sys.INF(LONGREAL)
END Math.

/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
108,7 → 108,7
res.filter_area.size := LENGTH(res.filter_area.filter);
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.ADR("/rd/1/File managers/opendial");
res.start_path := sys.SADR("/rd/1/File managers/opendial");
res.opendir_path := sys.ADR(res.s_opendir_path[0]);
res.dir_default_path := sys.ADR(res.s_dir_default_path[0]);
res.openfile_path := sys.ADR(res.FilePath[0]);
134,7 → 134,7
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
144,8 → 144,8
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(sys.ADR(Dialog_init), "OpenDialog_init");
GetProc(sys.ADR(Dialog_start), "OpenDialog_start");
GetProc(Lib, sys.ADR(Dialog_init), "OpenDialog_init");
GetProc(Lib, sys.ADR(Dialog_start), "OpenDialog_start");
END Load;
BEGIN

/programs/develop/oberon07/Lib/KolibriOS/Out.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
21,11 → 21,11
CONST
d = 1.0D0 - 5.0D-12;
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: LONGREAL; width: INTEGER);
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
BEGIN
67,7 → 67,7
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
75,8 → 75,8
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
92,15 → 92,15
END
END Int;
PROCEDURE OutInf(x: LONGREAL; width: INTEGER);
VAR s: ARRAY 4 OF CHAR; i: INTEGER;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0D0) THEN
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0D0) THEN
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
115,8 → 115,8
Char(0AX)
END Ln;
PROCEDURE _FixReal(x: LONGREAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN;
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
125,19 → 125,19
ELSE
len := 0;
minus := FALSE;
IF x < 0.0D0 THEN
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0D0 + d THEN
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
153,30 → 153,30
Char("-")
END;
y := x;
WHILE (y < 1.0D0) & (y # 0.0D0) DO
y := y * 10.0D0;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0D0
x := 0.0
ELSE
Char("0");
x := x * 10.0D0
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x > 9.0D0 THEN
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0D0
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
185,12 → 185,12
Char(".")
END;
WHILE p > 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0D0
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
197,7 → 197,7
END
END _FixReal;
PROCEDURE Real*(x: LONGREAL; width: INTEGER);
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
212,22 → 212,22
width := 9
END;
width := width - 5;
IF x < 0.0D0 THEN
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0D0) & (x # 0.0D0) DO
x := x * 10.0D0;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0D0 + d THEN
x := 1.0D0;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
255,7 → 255,7
END
END Real;
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER);
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)

/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07
1,193 → 1,441
(*
Copyright 2016, 2017 Anton Krotov
(*
BSD 2-Clause License
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 <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, API;
CONST
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
SIZE_OF_DWORD = 4;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
name: INTEGER;
types: INTEGER;
PROCEDURE [stdcall] _halt*(n: INTEGER);
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
BEGIN
API.ExitProcess(n)
END _halt;
SYSTEM.CODE(
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
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, 00CH, (* mov esi, dword [ebp + 12] *)
08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
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] _move2* (bytes, dest, source: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
SYSTEM.CODE(
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
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 _move2;
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, src, dst);
res := TRUE
END
END _disprec;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
END _rot;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
END;
IF a < 0 THEN
a := 0
END;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
ELSE
res := 0
END
RETURN res
END _saverec;
END _set2;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: INTEGER;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
END _set;
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): 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
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
0F7H, 0F9H, (* idiv ecx *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 011H, (* mov dword [ecx], edx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END divmod;
PROCEDURE div_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
DEC(div)
END
END _arrayidx;
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
RETURN div
END div_;
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
INC(mod, y)
END
END _arrayidx1;
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: INTEGER;
RETURN mod
END mod_;
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(a, b)
END _div;
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
RETURN div_(a, b)
END _div2;
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod;
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: 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
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, SIZE_OF_DWORD)
END
END _arrayrot;
END _new;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
PROCEDURE [stdcall] _dispose* (VAR ptr: 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
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
END
END _dispose;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a);
SYSTEM.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a, 2);
SYSTEM.GET(b, B); INC(b, 2);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _length* (len, str: INTEGER): 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] *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0
END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
BEGIN
_savearr(MIN(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
SYSTEM.CODE(
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
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 *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0
END _lengthw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: 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)
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
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
|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 Res
RETURN bRes
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmp(op, len2, str2, len1, str1)
END _strcmp2;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
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;
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
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 [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmpw(op, len2, str2, len1, str1)
END _strcmpw2;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
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;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
197,80 → 445,186
DEC(b)
END;
str[i] := 0X
END Int;
END IntToStr;
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;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n := LEN(s);
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE [stdcall] _error* (module, err: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err MOD 16 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")
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
BEGIN
(* r IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END StrAppend;
RETURN t1 = t0
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
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")
(* p IS t0 *)
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
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;
API.DebugMsg(sys.ADR(msg), SelfName);
API.ExitThread(0)
END _assrt;
t1 := -1
END
PROCEDURE [stdcall] _close*;
RETURN t1 = t0
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
BEGIN
IF CloseProc # NIL THEN
CloseProc
(* r:t1 IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
RETURN t1 = t0
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
BEGIN
IF ~init THEN
API.zeromem(gsize, gadr);
init := TRUE;
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL
(* p IS t0 *)
SYSTEM.GET(p, p);
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END _init;
ELSE
t1 := t0
END
PROCEDURE SetClose*(proc: PROC);
RETURN t1 = t0
END _guard;
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CloseProc := proc
END SetClose;
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
RETURN res
END _dllentry;
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 [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := _types;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
END _init;
END RTL.

/programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07
1,5 → 1,5
(*
Copyright 2016 KolibriOS team
(*
Copyright 2016, 2018 KolibriOS team
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
101,7 → 101,7
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
112,10 → 112,10
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/RasterWorks.obj");
ASSERT(Lib # 0);
GetProc(sys.ADR(drawText), "drawText");
GetProc(sys.ADR(cntUTF_8), "cntUTF-8");
GetProc(sys.ADR(charsFit), "charsFit");
GetProc(sys.ADR(strWidth), "strWidth");
GetProc(Lib, sys.ADR(drawText), "drawText");
GetProc(Lib, sys.ADR(cntUTF_8), "cntUTF-8");
GetProc(Lib, sys.ADR(charsFit), "charsFit");
GetProc(Lib, sys.ADR(strWidth), "strWidth");
END main;

/programs/develop/oberon07/Lib/KolibriOS/Read.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
31,10 → 31,6
RETURN File.Read(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL)
END Real;
PROCEDURE LongReal*(F: File.FS; VAR x: LONGREAL): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL)
END LongReal;
PROCEDURE Boolean*(F: File.FS; VAR x: BOOLEAN): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN)
END Boolean;

/programs/develop/oberon07/Lib/KolibriOS/Write.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
31,10 → 31,6
RETURN File.Write(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL)
END Real;
PROCEDURE LongReal*(F: File.FS; x: LONGREAL): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL)
END LongReal;
PROCEDURE Boolean*(F: File.FS; x: BOOLEAN): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN)
END Boolean;

/programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07
1,5 → 1,5
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 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
51,7 → 51,7
PROCEDURE [stdcall] zeromem(size, adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
sys.CODE(057H, 08BH, 07DH, 00CH, 08BH, 04DH, 008H, 033H, 0C0H, 09CH, 0FCH, 0F3H, 0ABH, 09DH, 05FH)
END zeromem;
PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN);
97,7 → 97,6
END rgb;
PROCEDURE create_glyph(VAR Font: TFont_desc; VAR glyph: Glyph; xsize, ysize: INTEGER);
VAR res: INTEGER;
BEGIN
glyph.base := Font.mempos;
glyph.xsize := xsize;

/programs/develop/oberon07/Lib/KolibriOS/libimg.ob07
1,5 → 1,5
(*
Copyright 2016 KolibriOS team
(*
Copyright 2016, 2018 KolibriOS team
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
398,7 → 398,7
PROCEDURE main;
VAR Lib, formats_table_ptr: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
409,23 → 409,23
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/libimg.obj");
ASSERT(Lib # 0);
GetProc(sys.ADR(img_is_img) , "img_is_img");
GetProc(sys.ADR(img_to_rgb) , "img_to_rgb");
GetProc(sys.ADR(img_to_rgb2) , "img_to_rgb2");
GetProc(sys.ADR(img_decode) , "img_decode");
GetProc(sys.ADR(img_encode) , "img_encode");
GetProc(sys.ADR(img_create) , "img_create");
GetProc(sys.ADR(img_destroy) , "img_destroy");
GetProc(sys.ADR(img_destroy_layer) , "img_destroy_layer");
GetProc(sys.ADR(img_count) , "img_count");
GetProc(sys.ADR(img_flip) , "img_flip");
GetProc(sys.ADR(img_flip_layer) , "img_flip_layer");
GetProc(sys.ADR(img_rotate) , "img_rotate");
GetProc(sys.ADR(img_rotate_layer) , "img_rotate_layer");
GetProc(sys.ADR(img_draw) , "img_draw");
GetProc(sys.ADR(img_scale) , "img_scale");
GetProc(sys.ADR(img_convert) , "img_convert");
GetProc(sys.ADR(formats_table_ptr) , "img_formats_table");
GetProc(Lib, sys.ADR(img_is_img) , "img_is_img");
GetProc(Lib, sys.ADR(img_to_rgb) , "img_to_rgb");
GetProc(Lib, sys.ADR(img_to_rgb2) , "img_to_rgb2");
GetProc(Lib, sys.ADR(img_decode) , "img_decode");
GetProc(Lib, sys.ADR(img_encode) , "img_encode");
GetProc(Lib, sys.ADR(img_create) , "img_create");
GetProc(Lib, sys.ADR(img_destroy) , "img_destroy");
GetProc(Lib, sys.ADR(img_destroy_layer) , "img_destroy_layer");
GetProc(Lib, sys.ADR(img_count) , "img_count");
GetProc(Lib, sys.ADR(img_flip) , "img_flip");
GetProc(Lib, sys.ADR(img_flip_layer) , "img_flip_layer");
GetProc(Lib, sys.ADR(img_rotate) , "img_rotate");
GetProc(Lib, sys.ADR(img_rotate_layer) , "img_rotate_layer");
GetProc(Lib, sys.ADR(img_draw) , "img_draw");
GetProc(Lib, sys.ADR(img_scale) , "img_scale");
GetProc(Lib, sys.ADR(img_convert) , "img_convert");
GetProc(Lib, sys.ADR(formats_table_ptr) , "img_formats_table");
GetFormatsTable(formats_table_ptr)
END main;

/programs/develop/oberon07/Lib/Linux32/API.ob07
1,148 → 1,145
(*
Copyright 2016 Anton Krotov
BSD 2-Clause License
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 <http://www.gnu.org/licenses/>.
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
CONST
BASE_ADR = 08048000H;
TYPE
TP* = ARRAY 2 OF INTEGER;
VAR
Param*: INTEGER;
eol*: ARRAY 2 OF CHAR;
base*, MainParam*: INTEGER;
sec* : INTEGER;
dsec* : INTEGER;
stdin* : INTEGER;
stdout* : INTEGER;
libc*, librt*: INTEGER;
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): INTEGER;
stdout*,
stdin*,
stderr* : INTEGER;
dlopen* : PROCEDURE [cdecl] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [cdecl] (handle, symbol: INTEGER): INTEGER;
_malloc* : PROCEDURE [cdecl] (size: INTEGER): INTEGER;
free* : PROCEDURE [cdecl] (ptr: INTEGER);
fopen* : PROCEDURE [cdecl] (fname, fmode: INTEGER): INTEGER;
fclose*, ftell* : PROCEDURE [cdecl] (file: INTEGER): INTEGER;
fwrite*, fread* : PROCEDURE [cdecl] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fseek* : PROCEDURE [cdecl] (file, offset, origin: INTEGER): INTEGER;
exit* : PROCEDURE [cdecl] (code: INTEGER);
strncmp* : PROCEDURE [cdecl] (str1, str2, n: INTEGER): INTEGER;
strlen* : PROCEDURE [cdecl] (str: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [cdecl] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER);
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
_exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
PROCEDURE putc* (c: CHAR);
VAR
res: INTEGER;
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END putc;
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
PROCEDURE malloc* (Bytes: INTEGER): INTEGER;
VAR res: INTEGER;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
Bytes := Align(Bytes, 4);
res := _malloc(Bytes);
puts(lpCaption);
puts(lpText)
END DebugMsg;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
VAR
res, ptr, words: INTEGER;
BEGIN
res := malloc(size);
IF res # 0 THEN
zeromem(ASR(Bytes, 2), res)
ptr := res;
words := size DIV SYSTEM.SIZE(INTEGER);
WHILE words > 0 DO
SYSTEM.PUT(ptr, 0);
INC(ptr, SYSTEM.SIZE(INTEGER));
DEC(words)
END
END
RETURN res
END malloc;
END _NEW;
PROCEDURE Free* (hMem: INTEGER): INTEGER;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
free(hMem)
free(p)
RETURN 0
END Free;
PROCEDURE _NEW*(size: INTEGER): INTEGER;
RETURN malloc(size)
END _NEW;
PROCEDURE _DISPOSE*(p: INTEGER): INTEGER;
RETURN Free(p)
END _DISPOSE;
PROCEDURE ConOut(str, length: INTEGER);
BEGIN
length := fwrite(str, length, 1, stdout)
END ConOut;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
VAR eol: ARRAY 3 OF CHAR;
PROCEDURE GetProcAdr (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
eol[0] := 0DX;
eol[1] := 0AX;
eol[2] := 00X;
ConOut(sys.ADR(eol), 2);
ConOut(lpCaption, strlen(lpCaption));
ConOut(sys.ADR(":"), 1);
ConOut(sys.ADR(eol), 2);
ConOut(lpText, strlen(lpText));
ConOut(sys.ADR(eol), 2);
END DebugMsg;
sym := dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetProcAdr;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
exit(code)
END ExitProcess;
PROCEDURE ExitThread* (code: INTEGER);
PROCEDURE init* (sp, code: INTEGER);
BEGIN
exit(code)
END ExitThread;
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
base := BASE_ADR;
eol := 0AX;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
VAR H: INTEGER;
libc := dlopen(SYSTEM.SADR("libc.so.6"), 1);
GetProcAdr(libc, "malloc", SYSTEM.ADR(malloc));
GetProcAdr(libc, "free", SYSTEM.ADR(free));
GetProcAdr(libc, "exit", SYSTEM.ADR(_exit));
GetProcAdr(libc, "stdout", SYSTEM.ADR(stdout));
GetProcAdr(libc, "stdin", SYSTEM.ADR(stdin));
GetProcAdr(libc, "stderr", SYSTEM.ADR(stderr));
SYSTEM.GET(stdout - SYSTEM.SIZE(INTEGER), stdout);
SYSTEM.GET(stdin - SYSTEM.SIZE(INTEGER), stdin);
SYSTEM.GET(stderr - SYSTEM.SIZE(INTEGER), stderr);
GetProcAdr(libc, "puts", SYSTEM.ADR(puts));
GetProcAdr(libc, "fwrite", SYSTEM.ADR(fwrite));
GetProcAdr(libc, "fread", SYSTEM.ADR(fread));
GetProcAdr(libc, "fopen", SYSTEM.ADR(fopen));
GetProcAdr(libc, "fclose", SYSTEM.ADR(fclose));
GetProcAdr(libc, "time", SYSTEM.ADR(time));
librt := dlopen(SYSTEM.SADR("librt.so.1"), 1);
GetProcAdr(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END init;
PROCEDURE exit* (code: INTEGER);
BEGIN
H := dlsym(hMOD, sys.ADR(name[0]));
ASSERT(H # 0);
sys.PUT(adr, H);
END GetProc;
_exit(code)
END exit;
PROCEDURE init* (esp: INTEGER);
VAR lib, proc: INTEGER;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
Param := esp;
sys.MOVE(Param + 12, sys.ADR(dlopen), 4);
sys.MOVE(Param + 16, sys.ADR(dlsym), 4);
sys.MOVE(Param + 20, sys.ADR(exit), 4);
sys.MOVE(Param + 24, sys.ADR(stdin), 4);
sys.MOVE(Param + 28, sys.ADR(stdout), 4);
sys.MOVE(Param + 32, sys.ADR(stderr), 4);
sys.MOVE(Param + 36, sys.ADR(_malloc), 4);
sys.MOVE(Param + 40, sys.ADR(free), 4);
sys.MOVE(Param + 44, sys.ADR(fopen), 4);
sys.MOVE(Param + 48, sys.ADR(fclose), 4);
sys.MOVE(Param + 52, sys.ADR(fwrite), 4);
sys.MOVE(Param + 56, sys.ADR(fread), 4);
sys.MOVE(Param + 60, sys.ADR(fseek), 4);
sys.MOVE(Param + 64, sys.ADR(ftell), 4);
_exit(code)
END exit_thread;
lib := dlopen(sys.ADR("libc.so.6"), 1);
ASSERT(lib # 0);
GetProc("strncmp", lib, sys.ADR(strncmp));
GetProc("strlen", lib, sys.ADR(strlen));
lib := dlopen(sys.ADR("librt.so.1"), 1);
ASSERT(lib # 0);
GetProc("clock_gettime", lib, sys.ADR(clock_gettime));
END init;
END API.

/programs/develop/oberon07/Lib/Linux32/HOST.ob07
1,121 → 1,178
(*
Copyright 2016 Anton Krotov
(*
BSD 2-Clause License
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 <http://www.gnu.org/licenses/>.
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, API, RTL;
CONST
OS* = "LNX";
Slash* = "/";
slash* = "/";
OS* = "LINUX";
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
VAR
fsize : INTEGER;
argc: INTEGER;
sec* : INTEGER;
dsec* : INTEGER;
eol*: ARRAY 2 OF CHAR;
PROCEDURE GetCommandLine* (): INTEGER;
RETURN API.Param
END GetCommandLine;
PROCEDURE CloseFile* (File: INTEGER);
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
File := API.fclose(File)
END CloseFile;
API.exit(code)
END ExitProcess;
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR res: INTEGER;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
IF write THEN
res := API.fwrite(Buffer, nNumberOfBytes, 1, hFile) * nNumberOfBytes
ELSE
res := API.fread(Buffer, nNumberOfBytes, 1, hFile) * nNumberOfBytes
END
RETURN res
END FileRW;
i := 0;
len := LEN(s) - 1;
IF (n < argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR res: INTEGER;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
res := FileRW(API.stdout, sys.ADR(str), LENGTH(str), TRUE)
END OutString;
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(sys.ADR(FName), sys.ADR("wb"))
END CreateFile;
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
VAR F, res: INTEGER;
PROCEDURE ReadFile (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN API.fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F)
END ReadFile;
PROCEDURE WriteFile (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN API.fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F)
END WriteFile;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
F := API.fopen(sys.ADR(FName), sys.ADR("rb"));
IF F # 0 THEN
res := API.fseek(F, 0, 2);
fsize := API.ftell(F);
res := API.fseek(F, 0, 0)
res := ReadFile(F, Buffer, bytes);
IF res <= 0 THEN
res := -1
END
RETURN F
END OpenFile;
PROCEDURE FileSize* (F: INTEGER): INTEGER;
RETURN fsize
END FileSize;
RETURN res
END FileRead;
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
PROCEDURE malloc* (Bytes: INTEGER): INTEGER;
VAR res: INTEGER;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
Bytes := Align(Bytes, 4);
res := API.malloc(Bytes);
IF res # 0 THEN
API.zeromem(ASR(Bytes, 2), res)
res := WriteFile(F, Buffer, bytes);
IF res <= 0 THEN
res := -1
END
RETURN res
END malloc;
END FileWrite;
PROCEDURE ExitProcess* (code: INTEGER);
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
END FileCreate;
PROCEDURE FileClose* (File: INTEGER);
BEGIN
API.exit(code)
END ExitProcess;
File := API.fclose(File)
END FileClose;
PROCEDURE Time* (VAR sec, dsec: INTEGER);
VAR tp: API.TP;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
END FileOpen;
PROCEDURE OutChar* (c: CHAR);
BEGIN
API.putc(c)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
VAR
tp: API.TP;
res: INTEGER;
BEGIN
IF API.clock_gettime(0, tp) = 0 THEN
sec := tp[0];
dsec := tp[1] DIV 10000000
res := tp[0] * 100 + tp[1] DIV 10000000
ELSE
sec := 0;
dsec := 0
res := 0
END
END Time;
PROCEDURE init*;
RETURN res
END GetTickCount;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN API.time(0)
END UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
Time(sec, dsec)
END init;
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
PROCEDURE GetName*(): INTEGER;
RETURN 0
END GetName;
BEGIN
eol := 0AX;
SYSTEM.GET(API.MainParam, argc)
END HOST.

/programs/develop/oberon07/Lib/Linux32/LINAPI.ob07
0,0 → 1,141
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE LINAPI;
IMPORT SYSTEM, API;
TYPE
TP* = API.TP;
VAR
argc*, envc*: INTEGER;
libc*, librt*: INTEGER;
stdout*,
stdin*,
stderr* : INTEGER;
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE dlopen* (filename: ARRAY OF CHAR): INTEGER;
RETURN API.dlopen(SYSTEM.ADR(filename[0]), 1)
END dlopen;
PROCEDURE dlsym* (handle: INTEGER; symbol: ARRAY OF CHAR): INTEGER;
RETURN API.dlsym(handle, SYSTEM.ADR(symbol[0]))
END dlsym;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (0 <= n) & (n <= argc + envc) & (n # argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetEnv* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
IF (0 <= n) & (n < envc) THEN
GetArg(n + argc + 1, s)
ELSE
s[0] := 0X
END
END GetEnv;
PROCEDURE init;
VAR
ptr: INTEGER;
BEGIN
envc := -1;
SYSTEM.GET(API.MainParam, argc);
REPEAT
SYSTEM.GET(API.MainParam + (envc + argc + 3) * SYSTEM.SIZE(INTEGER), ptr);
INC(envc)
UNTIL ptr = 0;
libc := API.libc;
stdout := API.stdout;
stdin := API.stdin;
stderr := API.stderr;
malloc := API.malloc;
free := API.free;
exit := API._exit;
puts := API.puts;
fwrite := API.fwrite;
fread := API.fread;
fopen := API.fopen;
fclose := API.fclose;
time := API.time;
librt := API.librt;
clock_gettime := API.clock_gettime
END init;
PROCEDURE [stdcall-] syscall* (eax, ebx, ecx, edx, esi, edi: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
0CDH, 080H, (* int 128 *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END syscall;
BEGIN
init
END LINAPI.

/programs/develop/oberon07/Lib/Linux32/RTL.ob07
1,193 → 1,441
(*
Copyright 2016, 2017 Anton Krotov
BSD 2-Clause License
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 <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, API;
CONST
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
SIZE_OF_DWORD = 4;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
name: INTEGER;
types: INTEGER;
PROCEDURE [stdcall] _halt*(n: INTEGER);
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
BEGIN
API.ExitProcess(n)
END _halt;
SYSTEM.CODE(
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
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, 00CH, (* mov esi, dword [ebp + 12] *)
08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
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] _move2* (bytes, dest, source: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
SYSTEM.CODE(
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
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 _move2;
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, src, dst);
res := TRUE
END
END _disprec;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
END _rot;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
END;
IF a < 0 THEN
a := 0
END;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
ELSE
res := 0
END
RETURN res
END _saverec;
END _set2;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: INTEGER;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
END _set;
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): 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
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
0F7H, 0F9H, (* idiv ecx *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 011H, (* mov dword [ecx], edx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END divmod;
PROCEDURE div_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
DEC(div)
END
END _arrayidx;
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
RETURN div
END div_;
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
INC(mod, y)
END
END _arrayidx1;
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: INTEGER;
RETURN mod
END mod_;
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(a, b)
END _div;
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
RETURN div_(a, b)
END _div2;
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod;
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: 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
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, SIZE_OF_DWORD)
END
END _arrayrot;
END _new;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
PROCEDURE [stdcall] _dispose* (VAR ptr: 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
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
END
END _dispose;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a);
SYSTEM.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a, 2);
SYSTEM.GET(b, B); INC(b, 2);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _length* (len, str: INTEGER): 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] *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0
END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
BEGIN
_savearr(MIN(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
SYSTEM.CODE(
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
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 *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0
END _lengthw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: 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)
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
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
|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 Res
RETURN bRes
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmp(op, len2, str2, len1, str1)
END _strcmp2;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
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;
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
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 [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmpw(op, len2, str2, len1, str1)
END _strcmpw2;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
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;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
197,80 → 445,186
DEC(b)
END;
str[i] := 0X
END Int;
END IntToStr;
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;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n := LEN(s);
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE [stdcall] _error* (module, err: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err MOD 16 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")
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
BEGIN
(* r IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END StrAppend;
RETURN t1 = t0
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
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")
(* p IS t0 *)
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
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;
API.DebugMsg(sys.ADR(msg), SelfName);
API.ExitThread(0)
END _assrt;
t1 := -1
END
PROCEDURE [stdcall] _close*;
RETURN t1 = t0
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
BEGIN
IF CloseProc # NIL THEN
CloseProc
(* r:t1 IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
RETURN t1 = t0
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
BEGIN
IF ~init THEN
API.zeromem(gsize, gadr);
init := TRUE;
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL
(* p IS t0 *)
SYSTEM.GET(p, p);
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END _init;
ELSE
t1 := t0
END
PROCEDURE SetClose*(proc: PROC);
RETURN t1 = t0
END _guard;
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CloseProc := proc
END SetClose;
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
RETURN res
END _dllentry;
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 [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := _types;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
END _init;
END RTL.

/programs/develop/oberon07/Lib/Windows32/API.ob07
1,79 → 1,61
(*
Copyright 2016, 2017 Anton Krotov
BSD 2-Clause License
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 <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
VAR
Alloc*: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER;
Free*: PROCEDURE [winapi] (hMem: INTEGER): INTEGER;
MessageBoxA*: PROCEDURE [winapi] (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
ExitThread*: PROCEDURE [winapi] (code: INTEGER);
GetCurrentThreadId*: PROCEDURE [winapi] (): INTEGER;
strncmp*: PROCEDURE [cdecl] (a, b, n: INTEGER): INTEGER;
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER;
LoadLibraryA*: PROCEDURE [winapi] (name: INTEGER): INTEGER;
PROCEDURE zeromem*(size, adr: INTEGER);
END zeromem;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GlobalAlloc"] Alloc (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalFree"] Free (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, "user32.dll", "MessageBoxA"] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE DebugMsg*(lpText, lpCaption: INTEGER);
BEGIN
MessageBoxA(0, lpText, lpCaption, 16)
END DebugMsg;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
VAR H: INTEGER;
BEGIN
H := GetProcAddress(hMOD, sys.ADR(name[0]));
ASSERT(H # 0);
sys.PUT(adr, H);
END GetProc;
PROCEDURE _NEW*(size: INTEGER): INTEGER;
RETURN Alloc(64, size)
END _NEW;
PROCEDURE _DISPOSE*(p: INTEGER): INTEGER;
RETURN Free(p)
END _DISPOSE;
PROCEDURE init* (esp: INTEGER);
VAR lib: INTEGER;
PROCEDURE init* (reserved, code: INTEGER);
BEGIN
sys.GET(esp, GetProcAddress);
sys.GET(esp + 4, LoadLibraryA);
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - 4096
END init;
lib := LoadLibraryA(sys.ADR("kernel32.dll"));
GetProc("ExitProcess", lib, sys.ADR(ExitProcess));
GetProc("ExitThread", lib, sys.ADR(ExitThread));
GetProc("GetCurrentThreadId", lib, sys.ADR(GetCurrentThreadId));
GetProc("GlobalAlloc", lib, sys.ADR(Alloc));
GetProc("GlobalFree", lib, sys.ADR(Free));
lib := LoadLibraryA(sys.ADR("msvcrt.dll"));
GetProc("strncmp", lib, sys.ADR(strncmp));
PROCEDURE exit* (code: INTEGER);
BEGIN
ExitProcess(code)
END exit;
lib := LoadLibraryA(sys.ADR("user32.dll"));
GetProc("MessageBoxA", lib, sys.ADR(MessageBoxA));
END init;
END API.
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
ExitThread(code)
END exit_thread;
END API.

/programs/develop/oberon07/Lib/Windows32/HOST.ob07
1,139 → 1,331
(*
Copyright 2016, 2017 Anton Krotov
BSD 2-Clause License
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 <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, RTL;
CONST
OS* = "WIN";
Slash* = "\";
slash* = "\";
OS* = "WINDOWS";
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
MAX_PARAM = 1024;
OFS_MAXPATHNAME = 128;
TYPE
POverlapped = POINTER TO OVERLAPPED;
OVERLAPPED = RECORD
Internal: INTEGER;
InternalHigh: INTEGER;
Offset: INTEGER;
OffsetHigh: INTEGER;
hEvent: INTEGER
END;
OFSTRUCT = RECORD
cBytes: CHAR;
fFixedDisk: CHAR;
nErrCode: sys.CARD16;
Reserved1: sys.CARD16;
Reserved2: sys.CARD16;
nErrCode: SYSTEM.CARD16;
Reserved1: SYSTEM.CARD16;
Reserved2: SYSTEM.CARD16;
szPathName: ARRAY OFS_MAXPATHNAME OF CHAR
END;
PSecurityAttributes = POINTER TO TSecurityAttributes;
TSecurityAttributes = RECORD
nLength: INTEGER;
lpSecurityDescriptor: INTEGER;
bInheritHandle: INTEGER
END;
TSystemTime = RECORD
Year,
Month,
DayOfWeek,
Day,
Hour,
Min,
Sec,
MSec: WCHAR
END;
VAR
sec*, dsec*, hConsoleOutput: INTEGER;
hConsoleOutput: INTEGER;
GetStdHandle: PROCEDURE [winapi] (nStdHandle: INTEGER): INTEGER;
CloseFile*: PROCEDURE [winapi] (hObject: INTEGER): INTEGER;
_CreateFile*: PROCEDURE [winapi] (lpFileName, dwDesiredAccess, dwShareMode, lpSecurityAttributes,
dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: INTEGER): INTEGER;
_OpenFile*: PROCEDURE [winapi] (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
ReadFile, WriteFile: PROCEDURE [winapi] (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, lpOverlapped: INTEGER): INTEGER;
GetCommandLine*: PROCEDURE [winapi] (): INTEGER;
GetTickCount: PROCEDURE [winapi] (): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
SetFilePointer: PROCEDURE [winapi] (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc: INTEGER;
PROCEDURE FileRW*(hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR res: INTEGER;
eol*: ARRAY 3 OF CHAR;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
_GetTickCount (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
_GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
_GetCommandLine (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
_ReadFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
_WriteFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
_CloseHandle (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CreateFileA"]
_CreateFile (
lpFileName, dwDesiredAccess, dwShareMode: INTEGER;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition, dwFlagsAndAttributes,
hTemplateFile: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
_OpenFile (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCurrentDirectoryA"]
_GetCurrentDirectory (nBufferLength, lpBuffer: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetSystemTime"]
_GetSystemTime (T: TSystemTime);
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
_ExitProcess (code: INTEGER);
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
IF write THEN
WriteFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0)
_ExitProcess(code)
END ExitProcess;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
n := _GetCurrentDirectory(LEN(path), SYSTEM.ADR(path[0]));
path[n] := slash;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR
p, count, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; VAR cond: INTEGER; c: CHAR);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
ReadFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0)
cond := C
END
RETURN res
END FileRW;
END ChangeCond;
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR res: INTEGER;
BEGIN
res := FileRW(hConsoleOutput, sys.ADR(str[0]), LENGTH(str), TRUE)
END OutString;
p := _GetCommandLine();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, cond, c); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, cond, c); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, cond, c); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
VAR res: INTEGER;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
BEGIN
res := _CreateFile(sys.ADR(FName[0]), 0C0000000H, 0, 0, 2, 80H, 0);
IF res = -1 THEN
res := 0
j := 0;
IF n < argc THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i)
END
RETURN res
END CreateFile;
END;
s[j] := 0X
END GetArg;
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
VAR res: INTEGER; ofstr: OFSTRUCT;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
BEGIN
res := _OpenFile(sys.ADR(FName[0]), ofstr, 0);
IF res = -1 THEN
res := 0
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END OpenFile;
END FileRead;
PROCEDURE FileSize*(F: INTEGER): INTEGER;
VAR res: INTEGER;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
BEGIN
res := SetFilePointer(F, 0, 0, 2);
SetFilePointer(F, 0, 0, 0)
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END FileSize;
END FileWrite;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN _CreateFile(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
sys.PUT(adr, API.GetProcAddress(hMOD, sys.ADR(name[0])))
END GetProc;
_CloseHandle(F)
END FileClose;
PROCEDURE Time*(VAR sec, dsec: INTEGER);
VAR t: INTEGER;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
ofstr: OFSTRUCT;
res: INTEGER;
BEGIN
t := GetTickCount() DIV 10;
sec := t DIV 100;
dsec := t MOD 100
END Time;
res := _OpenFile(SYSTEM.ADR(FName[0]), ofstr, 0);
IF res = 0FFFFFFFFH THEN
res := -1
END
PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN API.Alloc(64, size)
END malloc;
RETURN res
END FileOpen;
PROCEDURE init*;
VAR lib: INTEGER;
PROCEDURE OutChar* (c: CHAR);
VAR
count: INTEGER;
BEGIN
lib := API.LoadLibraryA(sys.ADR("kernel32.dll"));
GetProc("GetTickCount", lib, sys.ADR(GetTickCount));
Time(sec, dsec);
GetProc("GetStdHandle", lib, sys.ADR(GetStdHandle));
GetProc("CreateFileA", lib, sys.ADR(_CreateFile));
GetProc("CloseHandle", lib, sys.ADR(CloseFile));
GetProc("OpenFile", lib, sys.ADR(_OpenFile));
GetProc("ReadFile", lib, sys.ADR(ReadFile));
GetProc("WriteFile", lib, sys.ADR(WriteFile));
GetProc("GetCommandLineA", lib, sys.ADR(GetCommandLine));
GetProc("SetFilePointer", lib, sys.ADR(SetFilePointer));
ExitProcess := API.ExitProcess;
hConsoleOutput := GetStdHandle(-11)
END init;
_WriteFile(hConsoleOutput, SYSTEM.ADR(c), 1, count, NIL)
END OutChar;
PROCEDURE GetName*(): INTEGER;
PROCEDURE GetTickCount* (): INTEGER;
RETURN _GetTickCount() DIV 10
END GetTickCount;
PROCEDURE letter (c: CHAR): BOOLEAN;
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z")
END letter;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN ~(letter(path[0]) & (path[1] = ":"))
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
VAR
T: TSystemTime;
BEGIN
_GetSystemTime(T);
year := ORD(T.Year);
month := ORD(T.Month);
day := ORD(T.Day);
hour := ORD(T.Hour);
min := ORD(T.Min);
sec := ORD(T.Sec)
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN 0
END GetName;
END UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
hConsoleOutput := _GetStdHandle(-11);
ParamParse
END HOST.

/programs/develop/oberon07/Lib/Windows32/RTL.ob07
1,194 → 1,441
(*
Copyright 2016, 2017 Anton Krotov
(*
BSD 2-Clause License
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 <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, API;
CONST
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
SIZE_OF_DWORD = 4;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
main_thread_id: INTEGER;
name: INTEGER;
types: INTEGER;
PROCEDURE [stdcall] _halt*(n: INTEGER);
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
BEGIN
API.ExitProcess(n)
END _halt;
SYSTEM.CODE(
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
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, 00CH, (* mov esi, dword [ebp + 12] *)
08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
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] _move2* (bytes, dest, source: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
SYSTEM.CODE(
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
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 _move2;
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, src, dst);
res := TRUE
END
END _disprec;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
END _rot;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
END;
IF a < 0 THEN
a := 0
END;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
ELSE
res := 0
END
RETURN res
END _saverec;
END _set2;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: INTEGER;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
END _set;
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): 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
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
0F7H, 0F9H, (* idiv ecx *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 011H, (* mov dword [ecx], edx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END divmod;
PROCEDURE div_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
DEC(div)
END
END _arrayidx;
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
RETURN div
END div_;
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
INC(mod, y)
END
END _arrayidx1;
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: INTEGER;
RETURN mod
END mod_;
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(a, b)
END _div;
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
RETURN div_(a, b)
END _div2;
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod;
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: 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
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, SIZE_OF_DWORD)
END
END _arrayrot;
END _new;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
PROCEDURE [stdcall] _dispose* (VAR ptr: 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
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
END
END _dispose;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a);
SYSTEM.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a, 2);
SYSTEM.GET(b, B); INC(b, 2);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _length* (len, str: INTEGER): 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] *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0
END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
BEGIN
_savearr(MIN(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
SYSTEM.CODE(
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
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 *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0
END _lengthw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: 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)
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
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
|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 Res
RETURN bRes
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmp(op, len2, str2, len1, str1)
END _strcmp2;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
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;
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
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 [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmpw(op, len2, str2, len1, str1)
END _strcmpw2;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
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;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
198,85 → 445,186
DEC(b)
END;
str[i] := 0X
END Int;
END IntToStr;
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;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n := LEN(s);
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE [stdcall] _error* (module, err: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err MOD 16 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")
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
BEGIN
(* r IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END StrAppend;
RETURN t1 = t0
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
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")
(* p IS t0 *)
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
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;
API.DebugMsg(sys.ADR(msg), SelfName);
IF API.GetCurrentThreadId() = main_thread_id THEN
API.ExitProcess(0)
ELSE
API.ExitThread(0)
t1 := -1
END
END _assrt;
PROCEDURE [stdcall] _close*;
RETURN t1 = t0
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
BEGIN
IF CloseProc # NIL THEN
CloseProc
(* r:t1 IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
RETURN t1 = t0
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: 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
(* p IS t0 *)
SYSTEM.GET(p, p);
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
END _init;
ELSE
t1 := t0
END
PROCEDURE SetClose*(proc: PROC);
RETURN t1 = t0
END _guard;
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CloseProc := proc
END SetClose;
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
RETURN res
END _dllentry;
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 [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := _types;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
END _init;
END RTL.