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/ @ 7982

  → /programs/develop/oberon07/Lib/ @ 7983

  ↔ Reverse comparison

• Compare Path:	Rev

  With Path:	Rev

Regard whitespace Rev 7982 → Rev 7983

/programs/develop/oberon07/Lib/KolibriOS/API.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2020, Anton Krotov
All rights reserved.
*)
318,4 → 318,13
END GetTickCount;
END API.
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
END sofinit;
END API.

/programs/develop/oberon07/Lib/KolibriOS/Args.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/Console.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/File.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
57,7 → 57,9
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
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);
453,6 → 455,42
END UnixTime;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (l # 0) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), a);
463,9 → 501,11
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
maxreal := 1.9;
PACK(maxreal, 1023);
Console := API.import;
IF Console THEN
con_init(-1, -1, -1, -1, SYSTEM.SADR("Oberon-07 for KolibriOS"))
END;
ParamParse
END HOST.
END HOST.

/programs/develop/oberon07/Lib/KolibriOS/In.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Lib/KolibriOS/Math.ob07
1,4 → 1,4
(*
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/NetDevices.ob07
1,4 → 1,4
(*
(*
Copyright 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/Out.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

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

/programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 KolibriOS team
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/Read.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/UnixTime.ob07
1,4 → 1,4
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov

/programs/develop/oberon07/Lib/KolibriOS/Vector.ob07
1,4 → 1,4
(*
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/Write.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/KolibriOS/libimg.ob07
1,4 → 1,4
(*
(*
Copyright 2016, 2018 KolibriOS team
This program is free software: you can redistribute it and/or modify

/programs/develop/oberon07/Lib/Linux32/API.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
13,11 → 13,13
CONST
RTLD_LAZY* = 1;
BIT_DEPTH* = 32;
TYPE
TP* = ARRAY 2 OF INTEGER;
SOFINI* = PROCEDURE;
VAR
46,7 → 48,9
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
fini: SOFINI;
PROCEDURE putc* (c: CHAR);
VAR
res: INTEGER;
103,6 → 107,7
PROCEDURE init* (sp, code: INTEGER);
BEGIN
fini := NIL;
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
142,4 → 147,23
END exit_thread;
END API.
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END sofinit;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
fini := ProcFini
END SetFini;
END API.

/programs/develop/oberon07/Lib/Linux32/HOST.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
26,7 → 26,9
eol*: ARRAY 2 OF CHAR;
maxreal*: REAL;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
API.exit(code)
148,6 → 150,42
END UnixTime;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (l # 0) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
164,5 → 202,7
BEGIN
eol := 0AX;
maxreal := 1.9;
PACK(maxreal, 1023);
SYSTEM.GET(API.MainParam, argc)
END HOST.
END HOST.

/programs/develop/oberon07/Lib/Linux32/LINAPI.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
13,6 → 13,7
TYPE
TP* = API.TP;
SOFINI* = API.SOFINI;
VAR
69,12 → 70,17
END GetEnv;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
API.SetFini(ProcFini)
END SetFini;
PROCEDURE init;
VAR
ptr: INTEGER;
BEGIN
IF API.MainParam # 0 THEN
envc := -1;
SYSTEM.GET(API.MainParam, argc);

/programs/develop/oberon07/Lib/Linux32/Libdl.ob07
0,0 → 1,65
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Libdl;
IMPORT SYSTEM, API;
CONST
LAZY* = 1;
NOW* = 2;
BINDING_MASK* = 3;
NOLOAD* = 4;
LOCAL* = 0;
GLOBAL* = 256;
NODELETE* = 4096;
VAR
_close: PROCEDURE [linux] (handle: INTEGER): INTEGER;
_error: PROCEDURE [linux] (): INTEGER;
PROCEDURE open* (file: ARRAY OF CHAR; mode: INTEGER): INTEGER;
RETURN API.dlopen(SYSTEM.ADR(file[0]), mode)
END open;
PROCEDURE sym* (handle: INTEGER; name: ARRAY OF CHAR): INTEGER;
RETURN API.dlsym(handle, SYSTEM.ADR(name[0]))
END sym;
PROCEDURE close* (handle: INTEGER): INTEGER;
RETURN _close(handle)
END close;
PROCEDURE error* (): INTEGER;
RETURN _error()
END error;
PROCEDURE init;
VAR
lib: INTEGER;
BEGIN
lib := open("libdl.so.2", LAZY);
SYSTEM.PUT(SYSTEM.ADR(_close), sym(lib, "dlclose"));
ASSERT(_close # NIL);
SYSTEM.PUT(SYSTEM.ADR(_error), sym(lib, "dlerror"));
ASSERT(_error # NIL)
END init;
BEGIN
init
END Libdl.

/programs/develop/oberon07/Lib/Linux32/Math.ob07
0,0 → 1,384
(*
Copyright 2013, 2014, 2018, 2019 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
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/>.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
pi* = 3.141592653589793;
e* = 2.718281828459045;
PROCEDURE IsNan* (x: REAL): BOOLEAN;
VAR
h, l: SET;
BEGIN
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: REAL): BOOLEAN;
RETURN ABS(x) = SYSTEM.INF()
END IsInf;
PROCEDURE Max (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a > b THEN
res := a
ELSE
res := b
END
RETURN res
END Max;
PROCEDURE Min (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a < b THEN
res := a
ELSE
res := b
END
RETURN res
END Min;
PROCEDURE SameValue (a, b: REAL): BOOLEAN;
VAR
eps: REAL;
res: BOOLEAN;
BEGIN
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) <= eps
END
RETURN res
END SameValue;
PROCEDURE IsZero (x: REAL): BOOLEAN;
RETURN ABS(x) <= 1.0E-12
END IsZero;
PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
RETURN arctan2(sqrt(1.0 - x * x), x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, 1.0)
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF SameValue(x, 1.0) THEN
res := SYSTEM.INF()
ELSIF SameValue(x, -1.0) THEN
res := -SYSTEM.INF()
ELSE
res := 0.5 * ln((1.0 + x) / (1.0 - x))
END
RETURN res
END artanh;
PROCEDURE floor* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0 THEN
x := x - 1.0
END
RETURN x
END floor;
PROCEDURE ceil* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0 THEN
x := x + 1.0
END
RETURN x
END ceil;
PROCEDURE power* (base, exponent: REAL): REAL;
VAR
res: REAL;
BEGIN
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))
END
RETURN res
END power;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
END Math.

/programs/develop/oberon07/Lib/Linux32/Out.ob07
0,0 → 1,277
(*
Copyright 2013, 2014, 2017, 2018, 2019 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
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/>.
*)
MODULE Out;
IMPORT sys := SYSTEM, API;
CONST
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(x: CHAR);
BEGIN
API.putc(x)
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
Char(s[i]);
INC(i)
END
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
sys.GET(sys.ADR(AValue) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
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.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0AX)
END Ln;
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)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END;
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
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.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
END FixReal;
PROCEDURE Open*;
END Open;
END Out.

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

/programs/develop/oberon07/Lib/Linux64/API.ob07
0,0 → 1,169
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT SYSTEM;
CONST
RTLD_LAZY* = 1;
BIT_DEPTH* = 64;
TYPE
TP* = ARRAY 2 OF INTEGER;
SOFINI* = PROCEDURE;
VAR
eol*: ARRAY 2 OF CHAR;
MainParam*: INTEGER;
libc*, librt*: INTEGER;
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): 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;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
fini: SOFINI;
PROCEDURE putc* (c: CHAR);
VAR
res: INTEGER;
BEGIN
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END putc;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
puts(lpCaption);
puts(lpText)
END DebugMsg;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
VAR
res, ptr, words: INTEGER;
BEGIN
res := malloc(size);
IF res # 0 THEN
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 _NEW;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
free(p)
RETURN 0
END _DISPOSE;
PROCEDURE GetProcAdr (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
sym := dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetProcAdr;
PROCEDURE init* (sp, code: INTEGER);
BEGIN
fini := NIL;
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
eol := 0AX;
libc := dlopen(SYSTEM.SADR("libc.so.6"), RTLD_LAZY);
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"), RTLD_LAZY);
GetProcAdr(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END init;
PROCEDURE exit* (code: INTEGER);
BEGIN
_exit(code)
END exit;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
_exit(code)
END exit_thread;
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END sofinit;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
fini := ProcFini
END SetFini;
END API.

/programs/develop/oberon07/Lib/Linux64/HOST.ob07
0,0 → 1,208
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, API, RTL;
CONST
slash* = "/";
OS* = "LINUX";
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
VAR
argc: INTEGER;
eol*: ARRAY 2 OF CHAR;
maxreal*: REAL;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
API.exit(code)
END ExitProcess;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
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 GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := API.fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := API.fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
RETURN res
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
END FileCreate;
PROCEDURE FileClose* (File: INTEGER);
BEGIN
File := API.fclose(File)
END FileClose;
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
res := tp[0] * 100 + tp[1] DIV 10000000
ELSE
res := 0
END
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 d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
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 := 0AX;
maxreal := 1.9;
PACK(maxreal, 1023);
SYSTEM.GET(API.MainParam, argc)
END HOST.

/programs/develop/oberon07/Lib/Linux64/LINAPI.ob07
0,0 → 1,138
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE LINAPI;
IMPORT SYSTEM, API;
TYPE
TP* = API.TP;
SOFINI* = API.SOFINI;
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 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 SetFini* (ProcFini: SOFINI);
BEGIN
API.SetFini(ProcFini)
END SetFini;
PROCEDURE init;
VAR
ptr: INTEGER;
BEGIN
IF API.MainParam # 0 THEN
envc := -1;
SYSTEM.GET(API.MainParam, argc);
REPEAT
SYSTEM.GET(API.MainParam + (envc + argc + 3) * SYSTEM.SIZE(INTEGER), ptr);
INC(envc)
UNTIL ptr = 0
ELSE
envc := 0;
argc := 0
END;
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 [stdcall64-] syscall* (rax, rdi, rsi, rdx, r10, r8, r9: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 010H, (* mov rax, qword [rbp + 16] *)
048H, 08BH, 07DH, 018H, (* mov rdi, qword [rbp + 24] *)
048H, 08BH, 075H, 020H, (* mov rsi, qword [rbp + 32] *)
048H, 08BH, 055H, 028H, (* mov rdx, qword [rbp + 40] *)
04CH, 08BH, 055H, 030H, (* mov r10, qword [rbp + 48] *)
04CH, 08BH, 045H, 038H, (* mov r8, qword [rbp + 56] *)
04CH, 08BH, 04DH, 040H, (* mov r9, qword [rbp + 64] *)
00FH, 005H, (* syscall *)
0C9H, (* leave *)
0C2H, 038H, 000H (* ret 56 *)
)
RETURN 0
END syscall;
BEGIN
init
END LINAPI.

/programs/develop/oberon07/Lib/Linux64/Libdl.ob07
0,0 → 1,65
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Libdl;
IMPORT SYSTEM, API;
CONST
LAZY* = 1;
NOW* = 2;
BINDING_MASK* = 3;
NOLOAD* = 4;
LOCAL* = 0;
GLOBAL* = 256;
NODELETE* = 4096;
VAR
_close: PROCEDURE [linux] (handle: INTEGER): INTEGER;
_error: PROCEDURE [linux] (): INTEGER;
PROCEDURE open* (file: ARRAY OF CHAR; mode: INTEGER): INTEGER;
RETURN API.dlopen(SYSTEM.ADR(file[0]), mode)
END open;
PROCEDURE sym* (handle: INTEGER; name: ARRAY OF CHAR): INTEGER;
RETURN API.dlsym(handle, SYSTEM.ADR(name[0]))
END sym;
PROCEDURE close* (handle: INTEGER): INTEGER;
RETURN _close(handle)
END close;
PROCEDURE error* (): INTEGER;
RETURN _error()
END error;
PROCEDURE init;
VAR
lib: INTEGER;
BEGIN
lib := open("libdl.so.2", LAZY);
SYSTEM.PUT(SYSTEM.ADR(_close), sym(lib, "dlclose"));
ASSERT(_close # NIL);
SYSTEM.PUT(SYSTEM.ADR(_error), sym(lib, "dlerror"));
ASSERT(_error # NIL)
END init;
BEGIN
init
END Libdl.

/programs/develop/oberon07/Lib/Linux64/Math.ob07
0,0 → 1,311
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
e *= 2.71828182845904523;
pi *= 3.14159265358979324;
ln2 *= 0.693147180559945309;
eps = 1.0E-16;
MaxCosArg = 1000000.0 * pi;
VAR
Exp: ARRAY 710 OF REAL;
PROCEDURE [stdcall64] sqrt* (x: REAL): REAL;
BEGIN
ASSERT(x >= 0.0);
SYSTEM.CODE(
0F2H, 0FH, 51H, 45H, 10H, (* sqrtsd xmm0, qword[rbp + 10h] *)
05DH, (* pop rbp *)
0C2H, 08H, 00H (* ret 8 *)
)
RETURN 0.0
END sqrt;
PROCEDURE exp* (x: REAL): REAL;
CONST
e25 = 1.284025416687741484; (* exp(0.25) *)
VAR
a, s, res: REAL;
neg: BOOLEAN;
n: INTEGER;
BEGIN
neg := x < 0.0;
IF neg THEN
x := -x
END;
IF x < FLT(LEN(Exp)) THEN
res := Exp[FLOOR(x)];
x := x - FLT(FLOOR(x));
WHILE x >= 0.25 DO
res := res * e25;
x := x - 0.25
END
ELSE
res := SYSTEM.INF();
x := 0.0
END;
n := 0;
a := 1.0;
s := 1.0;
REPEAT
INC(n);
a := a * x / FLT(n);
s := s + a
UNTIL a < eps;
IF neg THEN
res := 1.0 / (res * s)
ELSE
res := res * s
END
RETURN res
END exp;
PROCEDURE ln* (x: REAL): REAL;
VAR
a, x2, res: REAL;
n: INTEGER;
BEGIN
ASSERT(x > 0.0);
UNPK(x, n);
x := (x - 1.0) / (x + 1.0);
x2 := x * x;
res := x + FLT(n) * (ln2 * 0.5);
n := 1;
REPEAT
INC(n, 2);
x := x * x2;
a := x / FLT(n);
res := res + a
UNTIL a < eps
RETURN res * 2.0
END ln;
PROCEDURE power* (base, exponent: REAL): REAL;
BEGIN
ASSERT(base > 0.0)
RETURN exp(exponent * ln(base))
END power;
PROCEDURE log* (base, x: REAL): REAL;
BEGIN
ASSERT(base > 0.0);
ASSERT(x > 0.0)
RETURN ln(x) / ln(base)
END log;
PROCEDURE cos* (x: REAL): REAL;
VAR
a, res: REAL;
n: INTEGER;
BEGIN
x := ABS(x);
ASSERT(x <= MaxCosArg);
x := x - FLT( FLOOR(x / (2.0 * pi)) ) * (2.0 * pi);
x := x * x;
res := 0.0;
a := 1.0;
n := -1;
REPEAT
INC(n, 2);
res := res + a;
a := -a * x / FLT(n*n + n)
UNTIL ABS(a) < eps
RETURN res
END cos;
PROCEDURE sin* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x)
END sin;
PROCEDURE tan* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x) / x
END tan;
PROCEDURE arcsin* (x: REAL): REAL;
PROCEDURE arctan (x: REAL): REAL;
VAR
z, p, k: REAL;
BEGIN
p := x / (x * x + 1.0);
z := p * x;
x := 0.0;
k := 0.0;
REPEAT
k := k + 2.0;
x := x + p;
p := p * k * z / (k + 1.0)
UNTIL p < eps
RETURN x
END arctan;
BEGIN
ASSERT(ABS(x) <= 1.0);
IF ABS(x) >= 0.707 THEN
x := 0.5 * pi - arctan(sqrt(1.0 - x * x) / x)
ELSE
x := arctan(x / sqrt(1.0 - x * x))
END
RETURN x
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= 1.0)
RETURN 0.5 * pi - arcsin(x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arcsin(x / sqrt(1.0 + x * x))
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
BEGIN
ASSERT(x >= 1.0)
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) < 1.0)
RETURN 0.5 * ln((1.0 + x) / (1.0 - x))
END artanh;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
PROCEDURE init;
VAR
i: INTEGER;
BEGIN
Exp[0] := 1.0;
FOR i := 1 TO LEN(Exp) - 1 DO
Exp[i] := Exp[i - 1] * e
END
END init;
BEGIN
init
END Math.

/programs/develop/oberon07/Lib/Linux64/Out.ob07
0,0 → 1,276
(*
Copyright 2013, 2014, 2017, 2018, 2019 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
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/>.
*)
MODULE Out;
IMPORT sys := SYSTEM, API;
CONST
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(x: CHAR);
BEGIN
API.putc(x)
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
Char(s[i]);
INC(i)
END
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 24 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR s: SET;
BEGIN
sys.GET(sys.ADR(AValue), s)
RETURN (s * {52..62} = {52..62}) & ((s * {32..51} # {}) OR (s * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
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.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0AX)
END Ln;
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)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END;
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
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.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
END FixReal;
PROCEDURE Open*;
END Open;
END Out.

/programs/develop/oberon07/Lib/Linux64/RTL.ob07
0,0 → 1,516
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, API;
CONST
bit_depth* = 64;
maxint* = 7FFFFFFFFFFFFFFFH;
minint* = 8000000000000000H;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
VAR
name: INTEGER;
types: INTEGER;
sets: ARRAY (MAX_SET + 1) * (MAX_SET + 1) OF INTEGER;
PROCEDURE [stdcall64] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 010H, (* mov rax, qword [rbp + 16] *)
048H, 085H, 0C0H, (* test rax, rax *)
07EH, 020H, (* jle L *)
0FCH, (* cld *)
057H, (* push rdi *)
056H, (* push rsi *)
048H, 08BH, 075H, 020H, (* mov rsi, qword [rbp + 32] *)
048H, 08BH, 07DH, 018H, (* mov rdi, qword [rbp + 24] *)
048H, 089H, 0C1H, (* mov rcx, rax *)
048H, 0C1H, 0E9H, 003H, (* shr rcx, 3 *)
0F3H, 048H, 0A5H, (* rep movsd *)
048H, 089H, 0C1H, (* mov rcx, rax *)
048H, 083H, 0E1H, 007H, (* and rcx, 7 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop rsi *)
05FH (* pop rdi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall64] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, dst, src);
res := TRUE
END
RETURN res
END _arrcpy;
PROCEDURE [stdcall64] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE [stdcall64] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
BEGIN
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 [stdcall64] _set* (b, a: INTEGER): INTEGER;
BEGIN
IF (a <= b) & (a <= MAX_SET) & (b >= 0) THEN
SYSTEM.GET((MIN(b, MAX_SET) * (MAX_SET + 1) + MAX(a, 0)) * WORD + SYSTEM.ADR(sets[0]), a)
ELSE
a := 0
END
RETURN a
END _set;
PROCEDURE [stdcall64] _set1* (a: INTEGER); (* {a} -> rax *)
BEGIN
SYSTEM.CODE(
048H, 031H, 0C0H, (* xor rax, rax *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *) (* rcx <- a *)
048H, 083H, 0F9H, 03FH, (* cmp rcx, 63 *)
077H, 004H, (* ja L *)
048H, 00FH, 0ABH, 0C8H (* bts rax, rcx *)
(* L: *)
)
END _set1;
PROCEDURE [stdcall64] _divmod* (y, x: INTEGER); (* (x div y) -> rax; (x mod y) -> rdx *)
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *) (* rax <- x *)
048H, 031H, 0D2H, (* xor rdx, rdx *)
048H, 085H, 0C0H, (* test rax, rax *)
074H, 022H, (* je L2 *)
07FH, 003H, (* jg L1 *)
048H, 0F7H, 0D2H, (* not rdx *)
(* L1: *)
049H, 089H, 0C0H, (* mov r8, rax *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *) (* rcx <- y *)
048H, 0F7H, 0F9H, (* idiv rcx *)
048H, 085H, 0D2H, (* test rdx, rdx *)
074H, 00EH, (* je L2 *)
049H, 031H, 0C8H, (* xor r8, rcx *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07DH, 006H, (* jge L2 *)
048H, 0FFH, 0C8H, (* dec rax *)
048H, 001H, 0CAH (* add rdx, rcx *)
(* L2: *)
)
END _divmod;
PROCEDURE [stdcall64] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, WORD)
END
END _new;
PROCEDURE [stdcall64] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - WORD)
END
END _dispose;
PROCEDURE [stdcall64] _length* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *)
048H, 0FFH, 0C8H, (* dec rax *)
(* L1: *)
048H, 0FFH, 0C0H, (* inc rax *)
080H, 038H, 000H, (* cmp byte [rax], 0 *)
074H, 005H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
048H, 0FFH, 0C0H, (* inc rax *)
(* L2: *)
048H, 02BH, 045H, 018H (* sub rax, qword [rbp + 24] *)
)
END _length;
PROCEDURE [stdcall64] _lengthw* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *)
048H, 083H, 0E8H, 002H, (* sub rax, 2 *)
(* L1: *)
048H, 083H, 0C0H, 002H, (* add rax, 2 *)
066H, 083H, 038H, 000H, (* cmp word [rax], 0 *)
074H, 006H, (* jz L2 *)
0E2H, 0F4H, (* loop L1 *)
048H, 083H, 0C0H, 002H, (* add rax, 2 *)
(* L2: *)
048H, 02BH, 045H, 018H, (* sub rax, qword [rbp + 24] *)
048H, 0D1H, 0E8H (* shr rax, 1 *)
)
END _lengthw;
PROCEDURE [stdcall64] strncmp (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 04DH, 010H, (* mov rcx, qword[rbp + 16]; rcx <- a *)
048H, 08BH, 055H, 018H, (* mov rdx, qword[rbp + 24]; rdx <- b *)
04CH, 08BH, 045H, 020H, (* mov r8, qword[rbp + 32]; r8 <- n *)
04DH, 031H, 0C9H, (* xor r9, r9 *)
04DH, 031H, 0D2H, (* xor r10, r10 *)
048H, 0B8H, 000H, 000H,
000H, 000H, 000H, 000H,
000H, 080H, (* movabs rax, minint *)
(* L1: *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07EH, 024H, (* jle L3 *)
044H, 08AH, 009H, (* mov r9b, byte[rcx] *)
044H, 08AH, 012H, (* mov r10b, byte[rdx] *)
048H, 0FFH, 0C1H, (* inc rcx *)
048H, 0FFH, 0C2H, (* inc rdx *)
049H, 0FFH, 0C8H, (* dec r8 *)
04DH, 039H, 0D1H, (* cmp r9, r10 *)
074H, 008H, (* je L2 *)
04CH, 089H, 0C8H, (* mov rax, r9 *)
04CH, 029H, 0D0H, (* sub rax, r10 *)
0EBH, 008H, (* jmp L3 *)
(* L2: *)
04DH, 085H, 0C9H, (* test r9, r9 *)
075H, 0DAH, (* jne L1 *)
048H, 031H, 0C0H, (* xor rax, rax *)
(* L3: *)
05DH, (* pop rbp *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END strncmp;
PROCEDURE [stdcall64] strncmpw (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 04DH, 010H, (* mov rcx, qword[rbp + 16]; rcx <- a *)
048H, 08BH, 055H, 018H, (* mov rdx, qword[rbp + 24]; rdx <- b *)
04CH, 08BH, 045H, 020H, (* mov r8, qword[rbp + 32]; r8 <- n *)
04DH, 031H, 0C9H, (* xor r9, r9 *)
04DH, 031H, 0D2H, (* xor r10, r10 *)
048H, 0B8H, 000H, 000H,
000H, 000H, 000H, 000H,
000H, 080H, (* movabs rax, minint *)
(* L1: *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07EH, 028H, (* jle L3 *)
066H, 044H, 08BH, 009H, (* mov r9w, word[rcx] *)
066H, 044H, 08BH, 012H, (* mov r10w, word[rdx] *)
048H, 083H, 0C1H, 002H, (* add rcx, 2 *)
048H, 083H, 0C2H, 002H, (* add rdx, 2 *)
049H, 0FFH, 0C8H, (* dec r8 *)
04DH, 039H, 0D1H, (* cmp r9, r10 *)
074H, 008H, (* je L2 *)
04CH, 089H, 0C8H, (* mov rax, r9 *)
04CH, 029H, 0D0H, (* sub rax, r10 *)
0EBH, 008H, (* jmp L3 *)
(* L2: *)
04DH, 085H, 0C9H, (* test r9, r9 *)
075H, 0D6H, (* jne L1 *)
048H, 031H, 0C0H, (* xor rax, rax *)
(* L3: *)
05DH, (* pop rbp *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END strncmpw;
PROCEDURE [stdcall64] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmp;
PROCEDURE [stdcall64] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2 * 2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1 * 2, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmpw;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
BEGIN
i := 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];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE [stdcall64] _error* (module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
CASE err OF
| 1: s := "assertion failure"
| 2: s := "NIL dereference"
| 3: s := "bad divisor"
| 4: s := "NIL procedure call"
| 5: s := "type guard error"
| 6: s := "index out of range"
| 7: s := "invalid CASE"
| 8: s := "array assignment error"
| 9: s := "CHR out of range"
|10: s := "WCHR out of range"
|11: s := "BYTE out of range"
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall64] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall64] _is* (t0, p: INTEGER): INTEGER;
BEGIN
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
END
RETURN p MOD 2
END _is;
PROCEDURE [stdcall64] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall64] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(p, p);
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
ELSE
p := 1
END
RETURN p MOD 2
END _guard;
PROCEDURE [stdcall64] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall64] _sofinit*;
BEGIN
API.sofinit
END _sofinit;
PROCEDURE [stdcall64] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall64] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
API.init(param, code);
types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
ASSERT(types # 0);
FOR i := 0 TO tcount - 1 DO
FOR j := 0 TO tcount - 1 DO
t0 := i; t1 := j;
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(_types + t1 * WORD, t1)
END;
SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
END
END;
FOR i := 0 TO MAX_SET DO
FOR j := 0 TO i DO
sets[i * (MAX_SET + 1) + j] := LSR(ASR(minint, i - j), MAX_SET - i)
END
END;
name := modname
END _init;
END RTL.

/programs/develop/oberon07/Lib/Windows32/API.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
14,7 → 14,17
SectionAlignment = 1000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
eol*: ARRAY 3 OF CHAR;
21,7 → 31,11
base*: INTEGER;
heap: INTEGER;
process_detach,
thread_detach,
thread_attach: DLL_ENTRY;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetProcessHeap"] GetProcessHeap (): INTEGER;
51,6 → 65,9
PROCEDURE init* (reserved, code: INTEGER);
BEGIN
process_detach := NIL;
thread_detach := NIL;
thread_attach := NIL;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - SectionAlignment;
heap := GetProcessHeap()
69,4 → 86,45
END exit_thread;
END API.
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := 0;
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
IF thread_attach # NIL THEN
thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
IF thread_detach # NIL THEN
thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
IF process_detach # NIL THEN
process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
END
RETURN res
END dllentry;
PROCEDURE sofinit*;
END sofinit;
PROCEDURE SetDll* (_process_detach, _thread_detach, _thread_attach: DLL_ENTRY);
BEGIN
process_detach := _process_detach;
thread_detach := _thread_detach;
thread_attach := _thread_attach
END SetDll;
END API.

/programs/develop/oberon07/Lib/Windows32/Args.ob07
0,0 → 1,101
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Args;
IMPORT SYSTEM, WINAPI;
CONST
MAX_PARAM = 1024;
VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
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): INTEGER;
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
cond := C
END
RETURN cond
END ChangeCond;
BEGIN
p := WINAPI.GetCommandLine();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: IF ChangeCond(0, 4, 1, cond, c) = 1 THEN Params[count, 0] := p END
|1: IF ChangeCond(0, 3, 1, cond, c) IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: IF ChangeCond(3, 1, 3, cond, c) = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: IF ChangeCond(5, 0, 5, cond, c) = 5 THEN Params[count, 0] := p END
|5: IF ChangeCond(5, 1, 5, cond, c) = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
BEGIN
j := 0;
IF n < argc THEN
i := Params[n, 0];
len := LEN(s) - 1;
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # '"' THEN
s[j] := c;
INC(j)
END;
INC(i)
END
END;
s[j] := 0X
END GetArg;
BEGIN
ParamParse
END Args.

/programs/develop/oberon07/Lib/Windows32/Console.ob07
0,0 → 1,100
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Console;
IMPORT SYSTEM, WINAPI, In, Out;
CONST
Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3;
Red* = 4; Magenta* = 5; Brown* = 6; LightGray* = 7;
DarkGray* = 8; LightBlue* = 9; LightGreen* = 10; LightCyan* = 11;
LightRed* = 12; LightMagenta* = 13; Yellow* = 14; White* = 15;
VAR
hConsoleOutput: INTEGER;
PROCEDURE SetCursor* (X, Y: INTEGER);
BEGIN
WINAPI.SetConsoleCursorPosition(hConsoleOutput, X + Y * 65536)
END SetCursor;
PROCEDURE GetCursor* (VAR X, Y: INTEGER);
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
X := ORD(ScrBufInfo.dwCursorPosition.X);
Y := ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursor;
PROCEDURE Cls*;
VAR
fill: INTEGER;
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
fill := ORD(ScrBufInfo.dwSize.X) * ORD(ScrBufInfo.dwSize.Y);
WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputAttribute(hConsoleOutput, ORD(ScrBufInfo.wAttributes), fill, 0, SYSTEM.ADR(fill));
SetCursor(0, 0)
END Cls;
PROCEDURE SetColor* (FColor, BColor: INTEGER);
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
WINAPI.SetConsoleTextAttribute(hConsoleOutput, LSL(BColor, 4) + FColor)
END
END SetColor;
PROCEDURE GetCursorX* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.X)
END GetCursorX;
PROCEDURE GetCursorY* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursorY;
PROCEDURE open*;
BEGIN
WINAPI.AllocConsole;
hConsoleOutput := WINAPI.GetStdHandle(-11);
In.Open;
Out.Open
END open;
PROCEDURE exit* (b: BOOLEAN);
BEGIN
WINAPI.FreeConsole
END exit;
END Console.

/programs/develop/oberon07/Lib/Windows32/DateTime.ob07
0,0 → 1,174
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE DateTime;
IMPORT WINAPI;
CONST
ERR* = -7.0E5;
VAR
DateTable: ARRAY 120000, 3 OF INTEGER;
MonthsTable: ARRAY 13, 4 OF INTEGER;
PROCEDURE Encode* (Year, Month, Day, Hour, Min, Sec, MSec: INTEGER): REAL;
VAR
d, bis: INTEGER;
res: REAL;
BEGIN
res := ERR;
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) &
(Day >= 1) & (Day <= 31) & (Hour >= 0) & (Hour <= 23) &
(Min >= 0) & (Min <= 59) & (Sec >= 0) & (Sec <= 59) &
(MSec >= 0) & (MSec <= 999) THEN
bis := ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0));
IF Day <= MonthsTable[Month][2 + bis] THEN
DEC(Year);
d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) +
MonthsTable[Month][bis] + Day - 693594;
res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000 + MSec) / 86400000.0
END
END
RETURN res
END Encode;
PROCEDURE Decode* (Date: REAL; VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
d, t: INTEGER;
L, R, M: INTEGER;
BEGIN
res := (Date >= -693593.0) & (Date < 2958466.0);
IF res THEN
d := FLOOR(Date);
t := FLOOR((Date - FLT(d)) * 86400000.0);
INC(d, 693593);
L := 0;
R := LEN(DateTable) - 1;
M := (L + R) DIV 2;
WHILE R - L > 1 DO
IF d > DateTable[M][0] THEN
L := M;
M := (L + R) DIV 2
ELSIF d < DateTable[M][0] THEN
R := M;
M := (L + R) DIV 2
ELSE
L := M;
R := M
END
END;
Year := DateTable[L][1];
Month := DateTable[L][2];
Day := d - DateTable[L][0] + 1;
Hour := t DIV 3600000; t := t MOD 3600000;
Min := t DIV 60000; t := t MOD 60000;
Sec := t DIV 1000;
MSec := t MOD 1000
END
RETURN res
END Decode;
PROCEDURE Now* (VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER);
VAR
T: WINAPI.TSystemTime;
BEGIN
WINAPI.GetLocalTime(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);
MSec := ORD(T.MSec)
END Now;
PROCEDURE NowEncode* (): REAL;
VAR
Year, Month, Day, Hour, Min, Sec, MSec: INTEGER;
BEGIN
Now(Year, Month, Day, Hour, Min, Sec, MSec)
RETURN Encode(Year, Month, Day, Hour, Min, Sec, MSec)
END NowEncode;
PROCEDURE init;
VAR
day, year, month, i: INTEGER;
Months: ARRAY 13 OF INTEGER;
BEGIN
Months[1] := 31; Months[2] := 28; Months[3] := 31; Months[4] := 30;
Months[5] := 31; Months[6] := 30; Months[7] := 31; Months[8] := 31;
Months[9] := 30; Months[10] := 31; Months[11] := 30; Months[12] := 31;
day := 0;
year := 1;
month := 1;
i := 0;
WHILE year <= 10000 DO
DateTable[i][0] := day;
DateTable[i][1] := year;
DateTable[i][2] := month;
INC(day, Months[month]);
IF (month = 2) & ((year MOD 4 = 0) & (year MOD 100 # 0) OR (year MOD 400 = 0)) THEN
INC(day)
END;
INC(month);
IF month > 12 THEN
month := 1;
INC(year)
END;
INC(i)
END;
MonthsTable[1][0] := 0;
FOR i := 2 TO 12 DO
MonthsTable[i][0] := MonthsTable[i - 1][0] + Months[i - 1]
END;
FOR i := 1 TO 12 DO
MonthsTable[i][2] := Months[i]
END;
Months[2] := 29;
MonthsTable[1][1] := 0;
FOR i := 2 TO 12 DO
MonthsTable[i][1] := MonthsTable[i - 1][1] + Months[i - 1]
END;
FOR i := 1 TO 12 DO
MonthsTable[i][3] := Months[i]
END
END init;
BEGIN
init
END DateTime.

/programs/develop/oberon07/Lib/Windows32/File.ob07
0,0 → 1,142
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE File;
IMPORT SYSTEM, WINAPI;
CONST
OPEN_R* = 0; OPEN_W* = 1; OPEN_RW* = 2;
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
PROCEDURE Exists* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
FindData: WINAPI.TWin32FindData;
Handle: INTEGER;
BEGIN
Handle := WINAPI.FindFirstFile(SYSTEM.ADR(FName[0]), FindData);
IF Handle # -1 THEN
WINAPI.FindClose(Handle);
IF 4 IN FindData.dwFileAttributes THEN
Handle := -1
END
END
RETURN Handle # -1
END Exists;
PROCEDURE Delete* (FName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.DeleteFile(SYSTEM.ADR(FName[0])) # 0
END Delete;
PROCEDURE Create* (FName: ARRAY OF CHAR): INTEGER;
RETURN WINAPI.CreateFile(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END Create;
PROCEDURE Close* (F: INTEGER);
BEGIN
WINAPI.CloseHandle(F)
END Close;
PROCEDURE Open* (FName: ARRAY OF CHAR; Mode: INTEGER): INTEGER;
VAR
ofstr: WINAPI.OFSTRUCT;
BEGIN
RETURN WINAPI.OpenFile(SYSTEM.ADR(FName[0]), ofstr, Mode)
END Open;
PROCEDURE Seek* (F, Offset, Origin: INTEGER): INTEGER;
RETURN WINAPI.SetFilePointer(F, Offset, 0, Origin)
END Seek;
PROCEDURE Read* (F, Buffer, Count: INTEGER): INTEGER;
VAR
res, n: INTEGER;
BEGIN
IF WINAPI.ReadFile(F, Buffer, Count, SYSTEM.ADR(n), NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END Read;
PROCEDURE Write* (F, Buffer, Count: INTEGER): INTEGER;
VAR
res, n: INTEGER;
BEGIN
IF WINAPI.WriteFile(F, Buffer, Count, SYSTEM.ADR(n), NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END Write;
PROCEDURE Load* (FName: ARRAY OF CHAR; VAR Size: INTEGER): INTEGER;
VAR
res, n, F: INTEGER;
BEGIN
res := 0;
F := Open(FName, OPEN_R);
IF F # -1 THEN
Size := Seek(F, 0, SEEK_END);
n := Seek(F, 0, SEEK_BEG);
res := WINAPI.GlobalAlloc(64, Size);
IF (res = 0) OR (Read(F, res, Size) # Size) THEN
IF res # 0 THEN
WINAPI.GlobalFree(Size);
res := 0;
Size := 0
END
END;
Close(F)
END
RETURN res
END Load;
PROCEDURE RemoveDir* (DirName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.RemoveDirectory(SYSTEM.ADR(DirName[0])) # 0
END RemoveDir;
PROCEDURE ExistsDir* (DirName: ARRAY OF CHAR): BOOLEAN;
VAR
Code: SET;
BEGIN
Code := WINAPI.GetFileAttributes(SYSTEM.ADR(DirName[0]))
RETURN (Code # {0..31}) & (4 IN Code)
END ExistsDir;
PROCEDURE CreateDir* (DirName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.CreateDirectory(SYSTEM.ADR(DirName[0]), NIL) # 0
END CreateDir;
END File.

/programs/develop/oberon07/Lib/Windows32/HOST.ob07
1,7 → 1,7
(*
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
82,7 → 82,9
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
_GetTickCount (): INTEGER;
310,6 → 312,42
END UnixTime;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (l # 0) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
326,6 → 364,8
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
maxreal := 1.9;
PACK(maxreal, 1023);
hConsoleOutput := _GetStdHandle(-11);
ParamParse
END HOST.
END HOST.

/programs/develop/oberon07/Lib/Windows32/In.ob07
0,0 → 1,289
(*
Copyright 2013, 2017, 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
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/>.
*)
MODULE In;
IMPORT sys := SYSTEM, WINAPI;
TYPE
STRING = ARRAY 260 OF CHAR;
VAR
Done*: BOOLEAN;
hConsoleInput: INTEGER;
PROCEDURE digit(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END digit;
PROCEDURE CheckInt(s: STRING; VAR first, last: INTEGER; VAR neg: BOOLEAN; Point: BOOLEAN): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
neg := FALSE;
WHILE (s[i] <= 20X) & (s[i] # 0X) DO
INC(i)
END;
IF s[i] = "-" THEN
neg := TRUE;
INC(i)
ELSIF s[i] = "+" THEN
INC(i)
END;
first := i;
WHILE digit(s[i]) DO
INC(i)
END;
last := i
RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first])
END CheckInt;
PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN;
VAR i: INTEGER; min: STRING;
BEGIN
i := 0;
min := "2147483648";
WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO
INC(i)
END
RETURN i = 10
END IsMinInt;
PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER;
CONST maxINT = 7FFFFFFFH;
VAR i, n, res: INTEGER; flag, neg: BOOLEAN;
BEGIN
res := 0;
flag := CheckInt(str, i, n, neg, FALSE);
err := ~flag;
IF flag & neg & IsMinInt(str, i) THEN
flag := FALSE;
neg := FALSE;
res := 80000000H
END;
WHILE flag & digit(str[i]) DO
IF res > maxINT DIV 10 THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END;
IF neg THEN
res := -res
END
RETURN res
END StrToInt;
PROCEDURE Space(s: STRING): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) & (s[i] <= 20X) DO
INC(i)
END
RETURN s[i] = 0X
END Space;
PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
Res := CheckInt(s, n, i, neg, TRUE);
IF Res THEN
IF s[i] = "." THEN
INC(i);
WHILE digit(s[i]) DO
INC(i)
END;
IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN
INC(i);
IF (s[i] = "+") OR (s[i] = "-") THEN
INC(i)
END;
Res := digit(s[i]);
WHILE digit(s[i]) DO
INC(i)
END
END
END
END
RETURN Res & (s[i] <= 20X)
END CheckReal;
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(VAR res, d: REAL; VAR i: INTEGER; str: STRING): BOOLEAN;
BEGIN
res := 0.0;
d := 1.0;
WHILE digit(str[i]) DO
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.0;
res := res + FLT(ORD(str[i]) - ORD("0")) * d;
INC(i)
END
END
RETURN str[i] # 0X
END part1;
PROCEDURE part2(VAR i, scale: INTEGER; VAR m, res: REAL; VAR minus, err: BOOLEAN; str: STRING): BOOLEAN;
BEGIN
INC(i);
m := 10.0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1
END;
scale := 0;
err := FALSE;
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN ~err
END part2;
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR scale: INTEGER; VAR res, m: REAL);
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0
ELSE
res := res * m;
INC(i)
END
END
END part3;
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1(res, d, i, str) & part2(i, scale, m, res, minus, err, str) THEN
part3(err, minus, scale, res, m)
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0;
err := TRUE
END
RETURN res
END StrToFloat;
PROCEDURE String*(VAR s: ARRAY OF CHAR);
VAR count, i: INTEGER; str: STRING;
BEGIN
WINAPI.ReadConsole(hConsoleInput, sys.ADR(str[0]), 256, sys.ADR(count), 0);
IF (str[count - 1] = 0AX) & (str[count - 2] = 0DX) THEN
DEC(count, 2)
END;
str[256] := 0X;
str[count] := 0X;
i := 0;
WHILE (i < LEN(s) - 1) & (i < LEN(str)) & (str[i] # 0X) DO
s[i] := str[i];
INC(i)
END;
s[i] := 0X;
Done := TRUE
END String;
PROCEDURE Char*(VAR x: CHAR);
VAR str: STRING;
BEGIN
String(str);
x := str[0];
Done := TRUE
END Char;
PROCEDURE Ln*;
VAR str: STRING;
BEGIN
String(str);
Done := TRUE
END Ln;
PROCEDURE Real*(VAR x: REAL);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToFloat(str, err);
Done := ~err
END Real;
PROCEDURE Int*(VAR x: INTEGER);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToInt(str, err);
Done := ~err
END Int;
PROCEDURE Open*;
BEGIN
hConsoleInput := WINAPI.GetStdHandle(-10);
Done := TRUE
END Open;
END In.

/programs/develop/oberon07/Lib/Windows32/Math.ob07
0,0 → 1,384
(*
Copyright 2013, 2014, 2018, 2019 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
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/>.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
pi* = 3.141592653589793;
e* = 2.718281828459045;
PROCEDURE IsNan* (x: REAL): BOOLEAN;
VAR
h, l: SET;
BEGIN
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: REAL): BOOLEAN;
RETURN ABS(x) = SYSTEM.INF()
END IsInf;
PROCEDURE Max (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a > b THEN
res := a
ELSE
res := b
END
RETURN res
END Max;
PROCEDURE Min (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a < b THEN
res := a
ELSE
res := b
END
RETURN res
END Min;
PROCEDURE SameValue (a, b: REAL): BOOLEAN;
VAR
eps: REAL;
res: BOOLEAN;
BEGIN
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) <= eps
END
RETURN res
END SameValue;
PROCEDURE IsZero (x: REAL): BOOLEAN;
RETURN ABS(x) <= 1.0E-12
END IsZero;
PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
BEGIN
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: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
RETURN arctan2(sqrt(1.0 - x * x), x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, 1.0)
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF SameValue(x, 1.0) THEN
res := SYSTEM.INF()
ELSIF SameValue(x, -1.0) THEN
res := -SYSTEM.INF()
ELSE
res := 0.5 * ln((1.0 + x) / (1.0 - x))
END
RETURN res
END artanh;
PROCEDURE floor* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0 THEN
x := x - 1.0
END
RETURN x
END floor;
PROCEDURE ceil* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0 THEN
x := x + 1.0
END
RETURN x
END ceil;
PROCEDURE power* (base, exponent: REAL): REAL;
VAR
res: REAL;
BEGIN
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))
END
RETURN res
END power;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
END Math.

/programs/develop/oberon07/Lib/Windows32/Out.ob07
0,0 → 1,280
(*
Copyright 2013, 2014, 2017, 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
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/>.
*)
MODULE Out;
IMPORT sys := SYSTEM, WINAPI;
CONST
d = 1.0 - 5.0E-12;
VAR
hConsoleOutput: INTEGER;
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE String*(s: ARRAY OF CHAR);
VAR count: INTEGER;
BEGIN
WINAPI.WriteFile(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), NIL)
END String;
PROCEDURE StringW*(s: ARRAY OF WCHAR);
VAR count: INTEGER;
BEGIN
WINAPI.WriteConsoleW(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), 0)
END StringW;
PROCEDURE Char*(x: CHAR);
VAR count: INTEGER;
BEGIN
WINAPI.WriteFile(hConsoleOutput, sys.ADR(x), 1, sys.ADR(count), NIL)
END Char;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
sys.GET(sys.ADR(AValue) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
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.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
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)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END;
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
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.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
END FixReal;
PROCEDURE Open*;
BEGIN
hConsoleOutput := WINAPI.GetStdHandle(-11)
END Open;
END Out.

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

/programs/develop/oberon07/Lib/Windows32/UnixTime.ob07
0,0 → 1,64
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
All rights reserved.
*)
MODULE UnixTime;
VAR
days: ARRAY 12, 31, 2 OF INTEGER;
PROCEDURE init;
VAR
i, j, k, n0, n1: INTEGER;
BEGIN
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
days[i, j, 0] := 0;
days[i, j, 1] := 0;
END
END;
days[ 1, 28, 0] := -1;
FOR k := 0 TO 1 DO
days[ 1, 29, k] := -1;
days[ 1, 30, k] := -1;
days[ 3, 30, k] := -1;
days[ 5, 30, k] := -1;
days[ 8, 30, k] := -1;
days[10, 30, k] := -1;
END;
n0 := 0;
n1 := 0;
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
IF days[i, j, 0] = 0 THEN
days[i, j, 0] := n0;
INC(n0)
END;
IF days[i, j, 1] = 0 THEN
days[i, j, 1] := n1;
INC(n1)
END
END
END
END init;
PROCEDURE time* (year, month, day, hour, min, sec: INTEGER): INTEGER;
RETURN ((year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4) * 86400 + hour * 3600 + min * 60 + sec
END time;
BEGIN
init
END UnixTime.

/programs/develop/oberon07/Lib/Windows32/Utils.ob07
0,0 → 1,76
(*
Copyright 2013, 2017, 2018, 2020 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
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/>.
*)
MODULE Utils;
IMPORT WINAPI;
PROCEDURE PutSeed*(seed: INTEGER);
BEGIN
WINAPI.srand(seed)
END PutSeed;
PROCEDURE Rnd*(range : INTEGER): INTEGER;
RETURN WINAPI.rand() MOD range
END Rnd;
PROCEDURE Utf8To16*(source: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR): INTEGER;
VAR i, j, L, u, N: INTEGER;
BEGIN
L := LEN(source);
N := LEN(dest);
N := N - N MOD 2 - 1;
i := 0;
j := 0;
WHILE (i < L) & (j < N) & (source[i] # 0X) DO
CASE source[i] OF
|00X..7FX: u := ORD(source[i]);
|0C1X..0DFX:
u := LSL(ORD(source[i]) - 0C0H, 6);
IF i + 1 < L THEN
u := u + ROR(LSL(ORD(source[i + 1]), 26), 26);
INC(i)
END
|0E1X..0EFX:
u := LSL(ORD(source[i]) - 0E0H, 12);
IF i + 1 < L THEN
u := u + ROR(LSL(ORD(source[i + 1]), 26), 20);
INC(i)
END;
IF i + 1 < L THEN
u := u + ROR(LSL(ORD(source[i + 1]), 26), 26);
INC(i)
END
(* |0F1X..0F7X:
|0F9X..0FBX:
|0FDX:*)
ELSE
END;
INC(i);
dest[j] := CHR(u MOD 256);
INC(j);
dest[j] := CHR(u DIV 256);
INC(j);
END;
IF j < N THEN
dest[j] := 0X;
dest[j + 1] := 0X
END
RETURN j DIV 2
END Utf8To16;
END Utils.

/programs/develop/oberon07/Lib/Windows32/WINAPI.ob07
0,0 → 1,241
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE WINAPI;
IMPORT SYSTEM, API;
CONST
OFS_MAXPATHNAME* = 128;
TYPE
DLL_ENTRY* = API.DLL_ENTRY;
STRING = ARRAY 260 OF CHAR;
TCoord* = RECORD
X*, Y*: WCHAR
END;
TSmallRect* = RECORD
Left*, Top*, Right*, Bottom*: WCHAR
END;
TConsoleScreenBufferInfo* = RECORD
dwSize*: TCoord;
dwCursorPosition*: TCoord;
wAttributes*: WCHAR;
srWindow*: TSmallRect;
dwMaximumWindowSize*: TCoord
END;
TSystemTime* = RECORD
Year*,
Month*,
DayOfWeek*,
Day*,
Hour*,
Min*,
Sec*,
MSec*: WCHAR
END;
PSecurityAttributes* = POINTER TO TSecurityAttributes;
TSecurityAttributes* = RECORD
nLength*: INTEGER;
lpSecurityDescriptor*: INTEGER;
bInheritHandle*: INTEGER
END;
TFileTime* = RECORD
dwLowDateTime*,
dwHighDateTime*: INTEGER
END;
TWin32FindData* = RECORD
dwFileAttributes*: SET;
ftCreationTime*: TFileTime;
ftLastAccessTime*: TFileTime;
ftLastWriteTime*: TFileTime;
nFileSizeHigh*: INTEGER;
nFileSizeLow*: INTEGER;
dwReserved0*: INTEGER;
dwReserved1*: INTEGER;
cFileName*: STRING;
cAlternateFileName*: ARRAY 14 OF CHAR
END;
OFSTRUCT* = RECORD
cBytes*: CHAR;
fFixedDisk*: CHAR;
nErrCode*: WCHAR;
Reserved1*: WCHAR;
Reserved2*: WCHAR;
szPathName*: ARRAY OFS_MAXPATHNAME OF CHAR
END;
POverlapped* = POINTER TO OVERLAPPED;
OVERLAPPED* = RECORD
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: INTEGER;
OffsetHigh*: INTEGER;
hEvent*: INTEGER
END;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleCursorPosition"]
SetConsoleCursorPosition* (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetConsoleScreenBufferInfo"]
GetConsoleScreenBufferInfo* (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputCharacterA"]
FillConsoleOutputCharacter* (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputAttribute"]
FillConsoleOutputAttribute* (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleTextAttribute"]
SetConsoleTextAttribute* (hConsoleOutput, wAttributes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle* (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetLocalTime"]
GetLocalTime* (T: TSystemTime);
PROCEDURE [windows-, "kernel32.dll", "RemoveDirectoryA"]
RemoveDirectory* (lpPathName: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetFileAttributesA"]
GetFileAttributes* (lpPathName: INTEGER): SET;
PROCEDURE [windows-, "kernel32.dll", "CreateDirectoryA"]
CreateDirectory* (lpPathName: INTEGER; lpSecurityAttributes: PSecurityAttributes): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FindFirstFileA"]
FindFirstFile* (lpFileName: INTEGER; lpFindFileData: TWin32FindData): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "DeleteFileA"]
DeleteFile* (lpFileName: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FindClose"]
FindClose* (hFindFile: INTEGER): 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", "SetFilePointer"]
SetFilePointer* (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
WriteFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadConsoleA"]
ReadConsole* (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
GetCommandLine* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalAlloc"]
GlobalAlloc* (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalFree"]
GlobalFree* (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteConsoleW"]
WriteConsoleW* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
ExitProcess* (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "WriteConsoleA"]
WriteConsole* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
GetTickCount* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "Sleep"]
Sleep* (dwMilliseconds: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "FreeLibrary"]
FreeLibrary* (hLibModule: INTEGER): INTEGER;
PROCEDURE [ccall, "msvcrt.dll", "rand"]
rand* (): INTEGER;
PROCEDURE [ccall, "msvcrt.dll", "srand"]
srand* (seed: INTEGER);
PROCEDURE [windows-, "user32.dll", "MessageBoxA"]
MessageBoxA* (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, "user32.dll", "MessageBoxW"]
MessageBox* (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, "user32.dll", "CreateWindowExA"]
CreateWindowEx* (
dwExStyle, lpClassName, lpWindowName, dwStyle, X, Y,
nWidth, nHeight, hWndParent, hMenu, hInstance, lpParam: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetProcAddress"]
GetProcAddress* (hModule, name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "LoadLibraryA"]
LoadLibraryA* (name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "AllocConsole"]
AllocConsole* (): BOOLEAN;
PROCEDURE [windows-, "kernel32.dll", "FreeConsole"]
FreeConsole* (): BOOLEAN;
PROCEDURE SetDllEntry* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
API.SetDll(process_detach, thread_detach, thread_attach)
END SetDllEntry;
END WINAPI.

/programs/develop/oberon07/Lib/Windows64/API.ob07
0,0 → 1,130
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT SYSTEM;
CONST
SectionAlignment = 1000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
heap: INTEGER;
process_detach,
thread_detach,
thread_attach: DLL_ENTRY;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetProcessHeap"] GetProcessHeap (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapAlloc"] HeapAlloc (hHeap, dwFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapFree"] HeapFree(hHeap, dwFlags, lpMem: 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 _NEW* (size: INTEGER): INTEGER;
RETURN HeapAlloc(heap, 8, size)
END _NEW;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
HeapFree(heap, 0, p)
RETURN 0
END _DISPOSE;
PROCEDURE init* (reserved, code: INTEGER);
BEGIN
process_detach := NIL;
thread_detach := NIL;
thread_attach := NIL;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - SectionAlignment;
heap := GetProcessHeap()
END init;
PROCEDURE exit* (code: INTEGER);
BEGIN
ExitProcess(code)
END exit;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
ExitThread(code)
END exit_thread;
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := 0;
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
IF thread_attach # NIL THEN
thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
IF thread_detach # NIL THEN
thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
IF process_detach # NIL THEN
process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
END
RETURN res
END dllentry;
PROCEDURE sofinit*;
END sofinit;
PROCEDURE SetDll* (_process_detach, _thread_detach, _thread_attach: DLL_ENTRY);
BEGIN
process_detach := _process_detach;
thread_detach := _thread_detach;
thread_attach := _thread_attach
END SetDll;
END API.

/programs/develop/oberon07/Lib/Windows64/Console.ob07
0,0 → 1,100
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Console;
IMPORT SYSTEM, WINAPI, In, Out;
CONST
Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3;
Red* = 4; Magenta* = 5; Brown* = 6; LightGray* = 7;
DarkGray* = 8; LightBlue* = 9; LightGreen* = 10; LightCyan* = 11;
LightRed* = 12; LightMagenta* = 13; Yellow* = 14; White* = 15;
VAR
hConsoleOutput: INTEGER;
PROCEDURE SetCursor* (X, Y: INTEGER);
BEGIN
WINAPI.SetConsoleCursorPosition(hConsoleOutput, X + Y * 65536)
END SetCursor;
PROCEDURE GetCursor* (VAR X, Y: INTEGER);
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
X := ORD(ScrBufInfo.dwCursorPosition.X);
Y := ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursor;
PROCEDURE Cls*;
VAR
fill: INTEGER;
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
fill := ORD(ScrBufInfo.dwSize.X) * ORD(ScrBufInfo.dwSize.Y);
WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputAttribute(hConsoleOutput, ORD(ScrBufInfo.wAttributes), fill, 0, SYSTEM.ADR(fill));
SetCursor(0, 0)
END Cls;
PROCEDURE SetColor* (FColor, BColor: INTEGER);
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
WINAPI.SetConsoleTextAttribute(hConsoleOutput, LSL(BColor, 4) + FColor)
END
END SetColor;
PROCEDURE GetCursorX* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.X)
END GetCursorX;
PROCEDURE GetCursorY* (): INTEGER;
VAR
ScrBufInfo: WINAPI.TConsoleScreenBufferInfo;
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo)
RETURN ORD(ScrBufInfo.dwCursorPosition.Y)
END GetCursorY;
PROCEDURE open*;
BEGIN
WINAPI.AllocConsole;
hConsoleOutput := WINAPI.GetStdHandle(-11);
In.Open;
Out.Open
END open;
PROCEDURE exit* (b: BOOLEAN);
BEGIN
WINAPI.FreeConsole
END exit;
END Console.

/programs/develop/oberon07/Lib/Windows64/DateTime.ob07
0,0 → 1,174
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE DateTime;
IMPORT WINAPI;
CONST
ERR* = -7.0E5;
VAR
DateTable: ARRAY 120000, 3 OF INTEGER;
MonthsTable: ARRAY 13, 4 OF INTEGER;
PROCEDURE Encode* (Year, Month, Day, Hour, Min, Sec, MSec: INTEGER): REAL;
VAR
d, bis: INTEGER;
res: REAL;
BEGIN
res := ERR;
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) &
(Day >= 1) & (Day <= 31) & (Hour >= 0) & (Hour <= 23) &
(Min >= 0) & (Min <= 59) & (Sec >= 0) & (Sec <= 59) &
(MSec >= 0) & (MSec <= 999) THEN
bis := ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0));
IF Day <= MonthsTable[Month][2 + bis] THEN
DEC(Year);
d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) +
MonthsTable[Month][bis] + Day - 693594;
res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000 + MSec) / 86400000.0
END
END
RETURN res
END Encode;
PROCEDURE Decode* (Date: REAL; VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
d, t: INTEGER;
L, R, M: INTEGER;
BEGIN
res := (Date >= -693593.0) & (Date < 2958466.0);
IF res THEN
d := FLOOR(Date);
t := FLOOR((Date - FLT(d)) * 86400000.0);
INC(d, 693593);
L := 0;
R := LEN(DateTable) - 1;
M := (L + R) DIV 2;
WHILE R - L > 1 DO
IF d > DateTable[M][0] THEN
L := M;
M := (L + R) DIV 2
ELSIF d < DateTable[M][0] THEN
R := M;
M := (L + R) DIV 2
ELSE
L := M;
R := M
END
END;
Year := DateTable[L][1];
Month := DateTable[L][2];
Day := d - DateTable[L][0] + 1;
Hour := t DIV 3600000; t := t MOD 3600000;
Min := t DIV 60000; t := t MOD 60000;
Sec := t DIV 1000;
MSec := t MOD 1000
END
RETURN res
END Decode;
PROCEDURE Now* (VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER);
VAR
T: WINAPI.TSystemTime;
BEGIN
WINAPI.GetLocalTime(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);
MSec := ORD(T.MSec)
END Now;
PROCEDURE NowEncode* (): REAL;
VAR
Year, Month, Day, Hour, Min, Sec, MSec: INTEGER;
BEGIN
Now(Year, Month, Day, Hour, Min, Sec, MSec)
RETURN Encode(Year, Month, Day, Hour, Min, Sec, MSec)
END NowEncode;
PROCEDURE init;
VAR
day, year, month, i: INTEGER;
Months: ARRAY 13 OF INTEGER;
BEGIN
Months[1] := 31; Months[2] := 28; Months[3] := 31; Months[4] := 30;
Months[5] := 31; Months[6] := 30; Months[7] := 31; Months[8] := 31;
Months[9] := 30; Months[10] := 31; Months[11] := 30; Months[12] := 31;
day := 0;
year := 1;
month := 1;
i := 0;
WHILE year <= 10000 DO
DateTable[i][0] := day;
DateTable[i][1] := year;
DateTable[i][2] := month;
INC(day, Months[month]);
IF (month = 2) & ((year MOD 4 = 0) & (year MOD 100 # 0) OR (year MOD 400 = 0)) THEN
INC(day)
END;
INC(month);
IF month > 12 THEN
month := 1;
INC(year)
END;
INC(i)
END;
MonthsTable[1][0] := 0;
FOR i := 2 TO 12 DO
MonthsTable[i][0] := MonthsTable[i - 1][0] + Months[i - 1]
END;
FOR i := 1 TO 12 DO
MonthsTable[i][2] := Months[i]
END;
Months[2] := 29;
MonthsTable[1][1] := 0;
FOR i := 2 TO 12 DO
MonthsTable[i][1] := MonthsTable[i - 1][1] + Months[i - 1]
END;
FOR i := 1 TO 12 DO
MonthsTable[i][3] := Months[i]
END
END init;
BEGIN
init
END DateTime.

/programs/develop/oberon07/Lib/Windows64/HOST.ob07
0,0 → 1,371
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, RTL;
CONST
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: WCHAR;
Reserved1: WCHAR;
Reserved2: WCHAR;
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
hConsoleOutput: INTEGER;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc: INTEGER;
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
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
_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
cond := C
END
END ChangeCond;
BEGIN
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 GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
BEGIN
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 FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
BEGIN
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
BEGIN
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END FileWrite;
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
_CloseHandle(F)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
ofstr: OFSTRUCT;
res: INTEGER;
BEGIN
res := _OpenFile(SYSTEM.ADR(FName[0]), ofstr, 0);
IF res = 0FFFFFFFFH THEN
res := -1
END
RETURN res
END FileOpen;
PROCEDURE OutChar* (c: CHAR);
VAR
count: INTEGER;
BEGIN
_WriteFile(hConsoleOutput, SYSTEM.ADR(c), 1, count, NIL)
END OutChar;
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 UnixTime;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
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;
maxreal := 1.9;
PACK(maxreal, 1023);
hConsoleOutput := _GetStdHandle(-11);
ParamParse
END HOST.

/programs/develop/oberon07/Lib/Windows64/In.ob07
0,0 → 1,295
(*
Copyright 2013, 2017, 2018, 2019 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
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/>.
*)
MODULE In;
IMPORT sys := SYSTEM;
TYPE
STRING = ARRAY 260 OF CHAR;
VAR
Done*: BOOLEAN;
hConsoleInput: INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadConsoleA"]
ReadConsole (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER): INTEGER;
PROCEDURE digit(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END digit;
PROCEDURE CheckInt(s: STRING; VAR first, last: INTEGER; VAR neg: BOOLEAN; Point: BOOLEAN): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
neg := FALSE;
WHILE (s[i] <= 20X) & (s[i] # 0X) DO
INC(i)
END;
IF s[i] = "-" THEN
neg := TRUE;
INC(i)
ELSIF s[i] = "+" THEN
INC(i)
END;
first := i;
WHILE digit(s[i]) DO
INC(i)
END;
last := i
RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first])
END CheckInt;
PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN;
VAR i: INTEGER; min: STRING;
BEGIN
i := 0;
min := "2147483648";
WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO
INC(i)
END
RETURN i = 10
END IsMinInt;
PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER;
CONST maxINT = 7FFFFFFFH;
VAR i, n, res: INTEGER; flag, neg: BOOLEAN;
BEGIN
res := 0;
flag := CheckInt(str, i, n, neg, FALSE);
err := ~flag;
IF flag & neg & IsMinInt(str, i) THEN
flag := FALSE;
neg := FALSE;
res := 80000000H
END;
WHILE flag & digit(str[i]) DO
IF res > maxINT DIV 10 THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END;
IF neg THEN
res := -res
END
RETURN res
END StrToInt;
PROCEDURE Space(s: STRING): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) & (s[i] <= 20X) DO
INC(i)
END
RETURN s[i] = 0X
END Space;
PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
Res := CheckInt(s, n, i, neg, TRUE);
IF Res THEN
IF s[i] = "." THEN
INC(i);
WHILE digit(s[i]) DO
INC(i)
END;
IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN
INC(i);
IF (s[i] = "+") OR (s[i] = "-") THEN
INC(i)
END;
Res := digit(s[i]);
WHILE digit(s[i]) DO
INC(i)
END
END
END
END
RETURN Res & (s[i] <= 20X)
END CheckReal;
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(VAR res, d: REAL; VAR i: INTEGER; str: STRING): BOOLEAN;
BEGIN
res := 0.0;
d := 1.0;
WHILE digit(str[i]) DO
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.0;
res := res + FLT(ORD(str[i]) - ORD("0")) * d;
INC(i)
END
END
RETURN str[i] # 0X
END part1;
PROCEDURE part2(VAR i, scale: INTEGER; VAR m, res: REAL; VAR minus, err: BOOLEAN; str: STRING): BOOLEAN;
BEGIN
INC(i);
m := 10.0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1
END;
scale := 0;
err := FALSE;
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN ~err
END part2;
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR scale: INTEGER; VAR res, m: REAL);
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0
ELSE
res := res * m;
INC(i)
END
END
END part3;
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1(res, d, i, str) & part2(i, scale, m, res, minus, err, str) THEN
part3(err, minus, scale, res, m)
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0;
err := TRUE
END
RETURN res
END StrToFloat;
PROCEDURE String*(VAR s: ARRAY OF CHAR);
VAR count, i: INTEGER; str: STRING;
BEGIN
ReadConsole(hConsoleInput, sys.ADR(str[0]), 256, sys.ADR(count), 0);
IF (str[count - 1] = 0AX) & (str[count - 2] = 0DX) THEN
DEC(count, 2)
END;
str[256] := 0X;
str[count] := 0X;
i := 0;
WHILE (i < LEN(s) - 1) & (i < LEN(str)) & (str[i] # 0X) DO
s[i] := str[i];
INC(i)
END;
s[i] := 0X;
Done := TRUE
END String;
PROCEDURE Char*(VAR x: CHAR);
VAR str: STRING;
BEGIN
String(str);
x := str[0];
Done := TRUE
END Char;
PROCEDURE Ln*;
VAR str: STRING;
BEGIN
String(str);
Done := TRUE
END Ln;
PROCEDURE Real*(VAR x: REAL);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToFloat(str, err);
Done := ~err
END Real;
PROCEDURE Int*(VAR x: INTEGER);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToInt(str, err);
Done := ~err
END Int;
PROCEDURE Open*;
BEGIN
hConsoleInput := GetStdHandle(-10);
Done := TRUE
END Open;
END In.

/programs/develop/oberon07/Lib/Windows64/Math.ob07
0,0 → 1,311
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
e *= 2.71828182845904523;
pi *= 3.14159265358979324;
ln2 *= 0.693147180559945309;
eps = 1.0E-16;
MaxCosArg = 1000000.0 * pi;
VAR
Exp: ARRAY 710 OF REAL;
PROCEDURE [stdcall64] sqrt* (x: REAL): REAL;
BEGIN
ASSERT(x >= 0.0);
SYSTEM.CODE(
0F2H, 0FH, 51H, 45H, 10H, (* sqrtsd xmm0, qword[rbp + 10h] *)
05DH, (* pop rbp *)
0C2H, 08H, 00H (* ret 8 *)
)
RETURN 0.0
END sqrt;
PROCEDURE exp* (x: REAL): REAL;
CONST
e25 = 1.284025416687741484; (* exp(0.25) *)
VAR
a, s, res: REAL;
neg: BOOLEAN;
n: INTEGER;
BEGIN
neg := x < 0.0;
IF neg THEN
x := -x
END;
IF x < FLT(LEN(Exp)) THEN
res := Exp[FLOOR(x)];
x := x - FLT(FLOOR(x));
WHILE x >= 0.25 DO
res := res * e25;
x := x - 0.25
END
ELSE
res := SYSTEM.INF();
x := 0.0
END;
n := 0;
a := 1.0;
s := 1.0;
REPEAT
INC(n);
a := a * x / FLT(n);
s := s + a
UNTIL a < eps;
IF neg THEN
res := 1.0 / (res * s)
ELSE
res := res * s
END
RETURN res
END exp;
PROCEDURE ln* (x: REAL): REAL;
VAR
a, x2, res: REAL;
n: INTEGER;
BEGIN
ASSERT(x > 0.0);
UNPK(x, n);
x := (x - 1.0) / (x + 1.0);
x2 := x * x;
res := x + FLT(n) * (ln2 * 0.5);
n := 1;
REPEAT
INC(n, 2);
x := x * x2;
a := x / FLT(n);
res := res + a
UNTIL a < eps
RETURN res * 2.0
END ln;
PROCEDURE power* (base, exponent: REAL): REAL;
BEGIN
ASSERT(base > 0.0)
RETURN exp(exponent * ln(base))
END power;
PROCEDURE log* (base, x: REAL): REAL;
BEGIN
ASSERT(base > 0.0);
ASSERT(x > 0.0)
RETURN ln(x) / ln(base)
END log;
PROCEDURE cos* (x: REAL): REAL;
VAR
a, res: REAL;
n: INTEGER;
BEGIN
x := ABS(x);
ASSERT(x <= MaxCosArg);
x := x - FLT( FLOOR(x / (2.0 * pi)) ) * (2.0 * pi);
x := x * x;
res := 0.0;
a := 1.0;
n := -1;
REPEAT
INC(n, 2);
res := res + a;
a := -a * x / FLT(n*n + n)
UNTIL ABS(a) < eps
RETURN res
END cos;
PROCEDURE sin* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x)
END sin;
PROCEDURE tan* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x) / x
END tan;
PROCEDURE arcsin* (x: REAL): REAL;
PROCEDURE arctan (x: REAL): REAL;
VAR
z, p, k: REAL;
BEGIN
p := x / (x * x + 1.0);
z := p * x;
x := 0.0;
k := 0.0;
REPEAT
k := k + 2.0;
x := x + p;
p := p * k * z / (k + 1.0)
UNTIL p < eps
RETURN x
END arctan;
BEGIN
ASSERT(ABS(x) <= 1.0);
IF ABS(x) >= 0.707 THEN
x := 0.5 * pi - arctan(sqrt(1.0 - x * x) / x)
ELSE
x := arctan(x / sqrt(1.0 - x * x))
END
RETURN x
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= 1.0)
RETURN 0.5 * pi - arcsin(x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arcsin(x / sqrt(1.0 + x * x))
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
BEGIN
ASSERT(x >= 1.0)
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) < 1.0)
RETURN 0.5 * ln((1.0 + x) / (1.0 - x))
END artanh;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
PROCEDURE init;
VAR
i: INTEGER;
BEGIN
Exp[0] := 1.0;
FOR i := 1 TO LEN(Exp) - 1 DO
Exp[i] := Exp[i - 1] * e
END
END init;
BEGIN
init
END Math.

/programs/develop/oberon07/Lib/Windows64/Out.ob07
0,0 → 1,308
(*
Copyright 2013, 2014, 2017, 2018, 2019 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
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/>.
*)
MODULE Out;
IMPORT sys := SYSTEM;
CONST
d = 1.0 - 5.0E-12;
TYPE
POverlapped* = POINTER TO OVERLAPPED;
OVERLAPPED* = RECORD
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: INTEGER;
OffsetHigh*: INTEGER;
hEvent*: INTEGER
END;
VAR
hConsoleOutput: INTEGER;
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
WriteFile (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteConsoleW"]
WriteConsoleW (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE Char*(x: CHAR);
VAR count: INTEGER;
BEGIN
WriteFile(hConsoleOutput, sys.ADR(x), 1, sys.ADR(count), NIL)
END Char;
PROCEDURE StringW*(s: ARRAY OF WCHAR);
VAR count: INTEGER;
BEGIN
WriteConsoleW(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), 0)
END StringW;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR len, i: INTEGER;
BEGIN
len := LENGTH(s);
FOR i := 0 TO len - 1 DO
Char(s[i])
END
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 32 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR s: SET;
BEGIN
sys.GET(sys.ADR(AValue), s)
RETURN (s * {52..62} = {52..62}) & ((s * {32..51} # {}) OR (s * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i, minInt: INTEGER;
BEGIN
minInt := 1;
minInt := ROR(minInt, 1);
IF x # minInt THEN
WriteInt(x, width)
ELSE
FOR i := 21 TO width DO
Char(20X)
END;
String("-9223372036854775808")
END
END Int;
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.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
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)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END;
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
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.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
END FixReal;
PROCEDURE Open*;
BEGIN
hConsoleOutput := GetStdHandle(-11)
END Open;
END Out.

/programs/develop/oberon07/Lib/Windows64/RTL.ob07
0,0 → 1,516
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, API;
CONST
bit_depth* = 64;
maxint* = 7FFFFFFFFFFFFFFFH;
minint* = 8000000000000000H;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
VAR
name: INTEGER;
types: INTEGER;
sets: ARRAY (MAX_SET + 1) * (MAX_SET + 1) OF INTEGER;
PROCEDURE [stdcall64] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 010H, (* mov rax, qword [rbp + 16] *)
048H, 085H, 0C0H, (* test rax, rax *)
07EH, 020H, (* jle L *)
0FCH, (* cld *)
057H, (* push rdi *)
056H, (* push rsi *)
048H, 08BH, 075H, 020H, (* mov rsi, qword [rbp + 32] *)
048H, 08BH, 07DH, 018H, (* mov rdi, qword [rbp + 24] *)
048H, 089H, 0C1H, (* mov rcx, rax *)
048H, 0C1H, 0E9H, 003H, (* shr rcx, 3 *)
0F3H, 048H, 0A5H, (* rep movsd *)
048H, 089H, 0C1H, (* mov rcx, rax *)
048H, 083H, 0E1H, 007H, (* and rcx, 7 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop rsi *)
05FH (* pop rdi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall64] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, dst, src);
res := TRUE
END
RETURN res
END _arrcpy;
PROCEDURE [stdcall64] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE [stdcall64] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
BEGIN
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 [stdcall64] _set* (b, a: INTEGER): INTEGER;
BEGIN
IF (a <= b) & (a <= MAX_SET) & (b >= 0) THEN
SYSTEM.GET((MIN(b, MAX_SET) * (MAX_SET + 1) + MAX(a, 0)) * WORD + SYSTEM.ADR(sets[0]), a)
ELSE
a := 0
END
RETURN a
END _set;
PROCEDURE [stdcall64] _set1* (a: INTEGER); (* {a} -> rax *)
BEGIN
SYSTEM.CODE(
048H, 031H, 0C0H, (* xor rax, rax *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *) (* rcx <- a *)
048H, 083H, 0F9H, 03FH, (* cmp rcx, 63 *)
077H, 004H, (* ja L *)
048H, 00FH, 0ABH, 0C8H (* bts rax, rcx *)
(* L: *)
)
END _set1;
PROCEDURE [stdcall64] _divmod* (y, x: INTEGER); (* (x div y) -> rax; (x mod y) -> rdx *)
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *) (* rax <- x *)
048H, 031H, 0D2H, (* xor rdx, rdx *)
048H, 085H, 0C0H, (* test rax, rax *)
074H, 022H, (* je L2 *)
07FH, 003H, (* jg L1 *)
048H, 0F7H, 0D2H, (* not rdx *)
(* L1: *)
049H, 089H, 0C0H, (* mov r8, rax *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *) (* rcx <- y *)
048H, 0F7H, 0F9H, (* idiv rcx *)
048H, 085H, 0D2H, (* test rdx, rdx *)
074H, 00EH, (* je L2 *)
049H, 031H, 0C8H, (* xor r8, rcx *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07DH, 006H, (* jge L2 *)
048H, 0FFH, 0C8H, (* dec rax *)
048H, 001H, 0CAH (* add rdx, rcx *)
(* L2: *)
)
END _divmod;
PROCEDURE [stdcall64] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, WORD)
END
END _new;
PROCEDURE [stdcall64] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - WORD)
END
END _dispose;
PROCEDURE [stdcall64] _length* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *)
048H, 0FFH, 0C8H, (* dec rax *)
(* L1: *)
048H, 0FFH, 0C0H, (* inc rax *)
080H, 038H, 000H, (* cmp byte [rax], 0 *)
074H, 005H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
048H, 0FFH, 0C0H, (* inc rax *)
(* L2: *)
048H, 02BH, 045H, 018H (* sub rax, qword [rbp + 24] *)
)
END _length;
PROCEDURE [stdcall64] _lengthw* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 018H, (* mov rax, qword [rbp + 24] *)
048H, 08BH, 04DH, 010H, (* mov rcx, qword [rbp + 16] *)
048H, 083H, 0E8H, 002H, (* sub rax, 2 *)
(* L1: *)
048H, 083H, 0C0H, 002H, (* add rax, 2 *)
066H, 083H, 038H, 000H, (* cmp word [rax], 0 *)
074H, 006H, (* jz L2 *)
0E2H, 0F4H, (* loop L1 *)
048H, 083H, 0C0H, 002H, (* add rax, 2 *)
(* L2: *)
048H, 02BH, 045H, 018H, (* sub rax, qword [rbp + 24] *)
048H, 0D1H, 0E8H (* shr rax, 1 *)
)
END _lengthw;
PROCEDURE [stdcall64] strncmp (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 04DH, 010H, (* mov rcx, qword[rbp + 16]; rcx <- a *)
048H, 08BH, 055H, 018H, (* mov rdx, qword[rbp + 24]; rdx <- b *)
04CH, 08BH, 045H, 020H, (* mov r8, qword[rbp + 32]; r8 <- n *)
04DH, 031H, 0C9H, (* xor r9, r9 *)
04DH, 031H, 0D2H, (* xor r10, r10 *)
048H, 0B8H, 000H, 000H,
000H, 000H, 000H, 000H,
000H, 080H, (* movabs rax, minint *)
(* L1: *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07EH, 024H, (* jle L3 *)
044H, 08AH, 009H, (* mov r9b, byte[rcx] *)
044H, 08AH, 012H, (* mov r10b, byte[rdx] *)
048H, 0FFH, 0C1H, (* inc rcx *)
048H, 0FFH, 0C2H, (* inc rdx *)
049H, 0FFH, 0C8H, (* dec r8 *)
04DH, 039H, 0D1H, (* cmp r9, r10 *)
074H, 008H, (* je L2 *)
04CH, 089H, 0C8H, (* mov rax, r9 *)
04CH, 029H, 0D0H, (* sub rax, r10 *)
0EBH, 008H, (* jmp L3 *)
(* L2: *)
04DH, 085H, 0C9H, (* test r9, r9 *)
075H, 0DAH, (* jne L1 *)
048H, 031H, 0C0H, (* xor rax, rax *)
(* L3: *)
05DH, (* pop rbp *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END strncmp;
PROCEDURE [stdcall64] strncmpw (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 04DH, 010H, (* mov rcx, qword[rbp + 16]; rcx <- a *)
048H, 08BH, 055H, 018H, (* mov rdx, qword[rbp + 24]; rdx <- b *)
04CH, 08BH, 045H, 020H, (* mov r8, qword[rbp + 32]; r8 <- n *)
04DH, 031H, 0C9H, (* xor r9, r9 *)
04DH, 031H, 0D2H, (* xor r10, r10 *)
048H, 0B8H, 000H, 000H,
000H, 000H, 000H, 000H,
000H, 080H, (* movabs rax, minint *)
(* L1: *)
04DH, 085H, 0C0H, (* test r8, r8 *)
07EH, 028H, (* jle L3 *)
066H, 044H, 08BH, 009H, (* mov r9w, word[rcx] *)
066H, 044H, 08BH, 012H, (* mov r10w, word[rdx] *)
048H, 083H, 0C1H, 002H, (* add rcx, 2 *)
048H, 083H, 0C2H, 002H, (* add rdx, 2 *)
049H, 0FFH, 0C8H, (* dec r8 *)
04DH, 039H, 0D1H, (* cmp r9, r10 *)
074H, 008H, (* je L2 *)
04CH, 089H, 0C8H, (* mov rax, r9 *)
04CH, 029H, 0D0H, (* sub rax, r10 *)
0EBH, 008H, (* jmp L3 *)
(* L2: *)
04DH, 085H, 0C9H, (* test r9, r9 *)
075H, 0D6H, (* jne L1 *)
048H, 031H, 0C0H, (* xor rax, rax *)
(* L3: *)
05DH, (* pop rbp *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END strncmpw;
PROCEDURE [stdcall64] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmp;
PROCEDURE [stdcall64] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2 * 2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1 * 2, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmpw;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
BEGIN
i := 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];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE [stdcall64] _error* (module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
CASE err OF
| 1: s := "assertion failure"
| 2: s := "NIL dereference"
| 3: s := "bad divisor"
| 4: s := "NIL procedure call"
| 5: s := "type guard error"
| 6: s := "index out of range"
| 7: s := "invalid CASE"
| 8: s := "array assignment error"
| 9: s := "CHR out of range"
|10: s := "WCHR out of range"
|11: s := "BYTE out of range"
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall64] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall64] _is* (t0, p: INTEGER): INTEGER;
BEGIN
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
END
RETURN p MOD 2
END _is;
PROCEDURE [stdcall64] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall64] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(p, p);
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
ELSE
p := 1
END
RETURN p MOD 2
END _guard;
PROCEDURE [stdcall64] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall64] _sofinit*;
BEGIN
API.sofinit
END _sofinit;
PROCEDURE [stdcall64] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall64] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
API.init(param, code);
types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
ASSERT(types # 0);
FOR i := 0 TO tcount - 1 DO
FOR j := 0 TO tcount - 1 DO
t0 := i; t1 := j;
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(_types + t1 * WORD, t1)
END;
SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
END
END;
FOR i := 0 TO MAX_SET DO
FOR j := 0 TO i DO
sets[i * (MAX_SET + 1) + j] := LSR(ASR(minint, i - j), MAX_SET - i)
END
END;
name := modname
END _init;
END RTL.

/programs/develop/oberon07/Lib/Windows64/UnixTime.ob07
0,0 → 1,64
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
All rights reserved.
*)
MODULE UnixTime;
VAR
days: ARRAY 12, 31, 2 OF INTEGER;
PROCEDURE init;
VAR
i, j, k, n0, n1: INTEGER;
BEGIN
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
days[i, j, 0] := 0;
days[i, j, 1] := 0;
END
END;
days[ 1, 28, 0] := -1;
FOR k := 0 TO 1 DO
days[ 1, 29, k] := -1;
days[ 1, 30, k] := -1;
days[ 3, 30, k] := -1;
days[ 5, 30, k] := -1;
days[ 8, 30, k] := -1;
days[10, 30, k] := -1;
END;
n0 := 0;
n1 := 0;
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
IF days[i, j, 0] = 0 THEN
days[i, j, 0] := n0;
INC(n0)
END;
IF days[i, j, 1] = 0 THEN
days[i, j, 1] := n1;
INC(n1)
END
END
END
END init;
PROCEDURE time* (year, month, day, hour, min, sec: INTEGER): INTEGER;
RETURN ((year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4) * 86400 + hour * 3600 + min * 60 + sec
END time;
BEGIN
init
END UnixTime.

/programs/develop/oberon07/Lib/Windows64/WINAPI.ob07
0,0 → 1,170
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE WINAPI;
IMPORT SYSTEM, API;
CONST
OFS_MAXPATHNAME* = 128;
TYPE
DLL_ENTRY* = API.DLL_ENTRY;
STRING = ARRAY 260 OF CHAR;
TCoord* = RECORD
X*, Y*: WCHAR
END;
TSmallRect* = RECORD
Left*, Top*, Right*, Bottom*: WCHAR
END;
TConsoleScreenBufferInfo* = RECORD
dwSize*: TCoord;
dwCursorPosition*: TCoord;
wAttributes*: WCHAR;
srWindow*: TSmallRect;
dwMaximumWindowSize*: TCoord
END;
TSystemTime* = RECORD
Year*,
Month*,
DayOfWeek*,
Day*,
Hour*,
Min*,
Sec*,
MSec*: WCHAR
END;
PSecurityAttributes* = POINTER TO TSecurityAttributes;
TSecurityAttributes* = RECORD
nLength*: INTEGER;
lpSecurityDescriptor*: INTEGER;
bInheritHandle*: INTEGER
END;
TFileTime* = RECORD
dwLowDateTime*,
dwHighDateTime*: INTEGER
END;
OFSTRUCT* = RECORD
cBytes*: CHAR;
fFixedDisk*: CHAR;
nErrCode*: WCHAR;
Reserved1*: WCHAR;
Reserved2*: WCHAR;
szPathName*: ARRAY OFS_MAXPATHNAME OF CHAR
END;
POverlapped* = POINTER TO OVERLAPPED;
OVERLAPPED* = RECORD
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: INTEGER;
OffsetHigh*: INTEGER;
hEvent*: INTEGER
END;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleCursorPosition"]
SetConsoleCursorPosition* (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetConsoleScreenBufferInfo"]
GetConsoleScreenBufferInfo* (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputCharacterA"]
FillConsoleOutputCharacter* (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputAttribute"]
FillConsoleOutputAttribute* (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleTextAttribute"]
SetConsoleTextAttribute* (hConsoleOutput, wAttributes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle* (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
CloseHandle* (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
WriteFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
GetCommandLine* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalAlloc"]
GlobalAlloc* (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalFree"]
GlobalFree* (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
ExitProcess* (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
GetTickCount* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "Sleep"]
Sleep* (dwMilliseconds: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "FreeLibrary"]
FreeLibrary* (hLibModule: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetProcAddress"]
GetProcAddress* (hModule, name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "LoadLibraryA"]
LoadLibraryA* (name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "AllocConsole"]
AllocConsole* (): BOOLEAN;
PROCEDURE [windows-, "kernel32.dll", "FreeConsole"]
FreeConsole* (): BOOLEAN;
PROCEDURE [windows-, "kernel32.dll", "GetLocalTime"]
GetLocalTime* (T: TSystemTime);
PROCEDURE SetDllEntry* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
API.SetDll(process_detach, thread_detach, thread_attach)
END SetDllEntry;
END WINAPI.