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

  → /programs/develop/oberon07/lib/ @ 8859

  ↔ Reverse comparison

• Compare Path:	Rev

  With Path:	Rev

Regard whitespace Rev 8858 → Rev 8859

/programs/develop/oberon07/lib/KolibriOS/API.ob07
0,0 → 1,332
(*
BSD 2-Clause License
Copyright (c) 2018, 2020-2021, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT SYSTEM, K := KOSAPI;
CONST
eol* = 0DX + 0AX;
BIT_DEPTH* = 32;
MAX_SIZE = 16 * 400H;
HEAP_SIZE = 1 * 100000H;
_new = 1;
_dispose = 2;
SizeOfHeader = 36;
TYPE
CRITICAL_SECTION = ARRAY 2 OF INTEGER;
VAR
heap, endheap: INTEGER;
pockets: ARRAY MAX_SIZE DIV 32 + 1 OF INTEGER;
CriticalSection: CRITICAL_SECTION;
_import*, multi: BOOLEAN;
base*: INTEGER;
PROCEDURE [stdcall] zeromem* (dwords: INTEGER; adr: INTEGER);
BEGIN
SYSTEM.CODE(
0FCH, (* cld *)
031H, 0C0H, (* xor eax, eax *)
057H, (* push edi *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *)
0F3H, 0ABH, (* rep stosd *)
05FH (* pop edi *)
)
END zeromem;
PROCEDURE mem_commit* (adr, size: INTEGER);
VAR
tmp: INTEGER;
BEGIN
FOR tmp := adr TO adr + size - 1 BY 4096 DO
SYSTEM.PUT(tmp, 0)
END
END mem_commit;
PROCEDURE switch_task;
BEGIN
K.sysfunc2(68, 1)
END switch_task;
PROCEDURE futex_create (ptr: INTEGER): INTEGER;
RETURN K.sysfunc3(77, 0, ptr)
END futex_create;
PROCEDURE futex_wait (futex, value, timeout: INTEGER);
BEGIN
K.sysfunc5(77, 2, futex, value, timeout)
END futex_wait;
PROCEDURE futex_wake (futex, number: INTEGER);
BEGIN
K.sysfunc4(77, 3, futex, number)
END futex_wake;
PROCEDURE EnterCriticalSection* (VAR CriticalSection: CRITICAL_SECTION);
BEGIN
switch_task;
futex_wait(CriticalSection[0], 1, 10000);
CriticalSection[1] := 1
END EnterCriticalSection;
PROCEDURE LeaveCriticalSection* (VAR CriticalSection: CRITICAL_SECTION);
BEGIN
CriticalSection[1] := 0;
futex_wake(CriticalSection[0], 1)
END LeaveCriticalSection;
PROCEDURE InitializeCriticalSection* (VAR CriticalSection: CRITICAL_SECTION);
BEGIN
CriticalSection[0] := futex_create(SYSTEM.ADR(CriticalSection[1]));
CriticalSection[1] := 0
END InitializeCriticalSection;
PROCEDURE __NEW (size: INTEGER): INTEGER;
VAR
res, idx, temp: INTEGER;
BEGIN
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
res := pockets[idx];
IF res # 0 THEN
SYSTEM.GET(res, pockets[idx]);
SYSTEM.PUT(res, size);
INC(res, 4)
ELSE
temp := 0;
IF heap + size >= endheap THEN
IF K.sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
temp := K.sysfunc3(68, 12, HEAP_SIZE)
ELSE
temp := 0
END;
IF temp # 0 THEN
mem_commit(temp, HEAP_SIZE);
heap := temp;
endheap := heap + HEAP_SIZE
ELSE
temp := -1
END
END;
IF (heap # 0) & (temp # -1) THEN
SYSTEM.PUT(heap, size);
res := heap + 4;
heap := heap + size
ELSE
res := 0
END
END
ELSE
IF K.sysfunc2(18, 16) > ASR(size, 10) THEN
res := K.sysfunc3(68, 12, size);
IF res # 0 THEN
mem_commit(res, size);
SYSTEM.PUT(res, size);
INC(res, 4)
END
ELSE
res := 0
END
END;
IF (res # 0) & (size <= MAX_SIZE) THEN
zeromem(ASR(size, 2) - 1, res)
END
RETURN res
END __NEW;
PROCEDURE __DISPOSE (ptr: INTEGER): INTEGER;
VAR
size, idx: INTEGER;
BEGIN
DEC(ptr, 4);
SYSTEM.GET(ptr, size);
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
SYSTEM.PUT(ptr, pockets[idx]);
pockets[idx] := ptr
ELSE
size := K.sysfunc3(68, 13, ptr)
END
RETURN 0
END __DISPOSE;
PROCEDURE NEW_DISPOSE (func, arg: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF multi THEN
EnterCriticalSection(CriticalSection)
END;
IF func = _new THEN
res := __NEW(arg)
ELSIF func = _dispose THEN
res := __DISPOSE(arg)
END;
IF multi THEN
LeaveCriticalSection(CriticalSection)
END
RETURN res
END NEW_DISPOSE;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
RETURN NEW_DISPOSE(_new, size)
END _NEW;
PROCEDURE _DISPOSE* (ptr: INTEGER): INTEGER;
RETURN NEW_DISPOSE(_dispose, ptr)
END _DISPOSE;
PROCEDURE exit* (p1: INTEGER);
BEGIN
K.sysfunc1(-1)
END exit;
PROCEDURE exit_thread* (p1: INTEGER);
BEGIN
K.sysfunc1(-1)
END exit_thread;
PROCEDURE OutChar (c: CHAR);
BEGIN
K.sysfunc3(63, 1, ORD(c))
END OutChar;
PROCEDURE OutLn;
BEGIN
OutChar(0DX);
OutChar(0AX)
END OutLn;
PROCEDURE OutStr (pchar: INTEGER);
VAR
c: CHAR;
BEGIN
IF pchar # 0 THEN
REPEAT
SYSTEM.GET(pchar, c);
IF c # 0X THEN
OutChar(c)
END;
INC(pchar)
UNTIL c = 0X
END
END OutStr;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
IF lpCaption # 0 THEN
OutLn;
OutStr(lpCaption);
OutChar(":");
OutLn
END;
OutStr(lpText);
IF lpCaption # 0 THEN
OutLn
END
END DebugMsg;
PROCEDURE OutString (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
OutChar(s[i]);
INC(i)
END
END OutString;
PROCEDURE imp_error;
BEGIN
OutString("import error: ");
IF K.imp_error.error = 1 THEN
OutString("can't load '"); OutString(K.imp_error.lib)
ELSIF K.imp_error.error = 2 THEN
OutString("not found '"); OutString(K.imp_error.proc); OutString("' in '"); OutString(K.imp_error.lib)
END;
OutString("'");
OutLn
END imp_error;
PROCEDURE init* (import_, code: INTEGER);
BEGIN
multi := FALSE;
base := code - SizeOfHeader;
K.sysfunc2(68, 11);
InitializeCriticalSection(CriticalSection);
K._init;
_import := (K.dll_Load(import_) = 0) & (K.imp_error.error = 0);
IF ~_import THEN
imp_error
END
END init;
PROCEDURE SetMultiThr* (value: BOOLEAN);
BEGIN
multi := value
END SetMultiThr;
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9) * 10
END GetTickCount;
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
END sofinit;
END API.

/programs/develop/oberon07/lib/KolibriOS/File.ob07
0,0 → 1,330
(*
Copyright 2016, 2018, 2021 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 File;
IMPORT sys := SYSTEM, KOSAPI;
CONST
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
TYPE
FNAME* = ARRAY 520 OF CHAR;
FS* = POINTER TO rFS;
rFS* = RECORD
subfunc*, pos*, hpos*, bytes*, buffer*: INTEGER;
name*: FNAME
END;
FD* = POINTER TO rFD;
rFD* = RECORD
attr*: INTEGER;
ntyp*: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create*, date_create*,
time_access*, date_access*,
time_modif*, date_modif*,
size*, hsize*: INTEGER;
name*: FNAME
END;
PROCEDURE [stdcall] f_68_27 (file_name: INTEGER; VAR size: INTEGER): INTEGER;
BEGIN
sys.CODE(
053H, (* push ebx *)
06AH, 044H, (* push 68 *)
058H, (* pop eax *)
06AH, 01BH, (* push 27 *)
05BH, (* pop ebx *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *)
0CDH, 040H, (* int 64 *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
089H, 011H, (* mov dword [ecx], edx *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 8 *)
)
RETURN 0
END f_68_27;
PROCEDURE Load* (FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
RETURN f_68_27(sys.ADR(FName[0]), size)
END Load;
PROCEDURE GetFileInfo* (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR
res2: INTEGER; fs: rFS;
BEGIN
fs.subfunc := 5;
fs.pos := 0;
fs.hpos := 0;
fs.bytes := 0;
fs.buffer := sys.ADR(Info);
COPY(FName, fs.name)
RETURN KOSAPI.sysfunc22(70, sys.ADR(fs), res2) = 0
END GetFileInfo;
PROCEDURE FileSize* (FName: ARRAY OF CHAR): INTEGER;
VAR
Info: rFD;
res: INTEGER;
BEGIN
IF GetFileInfo(FName, Info) THEN
res := Info.size
ELSE
res := -1
END
RETURN res
END FileSize;
PROCEDURE Exists* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
END Exists;
PROCEDURE Close* (VAR F: FS);
BEGIN
IF F # NIL THEN
DISPOSE(F)
END
END Close;
PROCEDURE Open* (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 0;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name)
END
ELSE
F := NIL
END
RETURN F
END Open;
PROCEDURE Delete* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
F: FS;
res, res2: INTEGER;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 8;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
ELSE
res := -1
END
RETURN res = 0
END Delete;
PROCEDURE Seek* (F: FS; Offset, Origin: INTEGER): INTEGER;
VAR
res: INTEGER;
fd: rFD;
BEGIN
IF (F # NIL) & GetFileInfo(F.name, fd) & (BITS(fd.attr) * {4} = {}) THEN
CASE Origin OF
|SEEK_BEG: F.pos := Offset
|SEEK_CUR: F.pos := F.pos + Offset
|SEEK_END: F.pos := fd.size + Offset
ELSE
END;
res := F.pos
ELSE
res := -1
END
RETURN res
END Seek;
PROCEDURE Read* (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 0;
F.bytes := Count;
F.buffer := Buffer;
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Read;
PROCEDURE Write* (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 3;
F.bytes := Count;
F.buffer := Buffer;
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Write;
PROCEDURE Create* (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 2;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
IF KOSAPI.sysfunc22(70, sys.ADR(F^), res2) # 0 THEN
DISPOSE(F)
END
END
RETURN F
END Create;
PROCEDURE DirExists* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & (4 IN BITS(fd.attr))
END DirExists;
PROCEDURE CreateDir* (DirName: ARRAY OF CHAR): BOOLEAN;
VAR
F: FS;
res, res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 9;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(DirName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
RETURN res = 0
END CreateDir;
PROCEDURE DeleteDir* (DirName: ARRAY OF CHAR): BOOLEAN;
VAR
F: FS;
res, res2: INTEGER;
BEGIN
IF DirExists(DirName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 8;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(DirName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
ELSE
res := -1
END
RETURN res = 0
END DeleteDir;
END File.

/programs/develop/oberon07/lib/KolibriOS/HOST.ob07
0,0 → 1,552
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, K := KOSAPI, API;
CONST
slash* = "/";
eol* = 0DX + 0AX;
bit_depth* = API.BIT_DEPTH;
maxint* = ROR(-2, 1);
minint* = ROR(1, 1);
MAX_PARAM = 1024;
TYPE
DAYS = ARRAY 12, 31, 2 OF INTEGER;
FNAME = ARRAY 520 OF CHAR;
FS = POINTER TO rFS;
rFS = RECORD
subfunc, pos, hpos, bytes, buffer: INTEGER;
name: FNAME
END;
FD = POINTER TO rFD;
rFD = RECORD
attr: INTEGER;
ntyp: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create, date_create,
time_access, date_access,
time_modif, date_modif,
size, hsize: INTEGER;
name: FNAME
END;
VAR
Console: BOOLEAN;
days: DAYS;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
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);
PROCEDURE [stdcall, "Console.obj", "con_write_string"] con_write_string (string, length: INTEGER);
PROCEDURE ExitProcess* (p1: INTEGER);
BEGIN
IF Console THEN
con_exit(FALSE)
END;
K.sysfunc1(-1)
END ExitProcess;
PROCEDURE OutChar* (c: CHAR);
BEGIN
IF Console THEN
con_write_string(SYSTEM.ADR(c), 1)
ELSE
K.sysfunc3(63, 1, ORD(c))
END
END OutChar;
PROCEDURE GetFileInfo (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR
res2: INTEGER;
fs: rFS;
BEGIN
fs.subfunc := 5;
fs.pos := 0;
fs.hpos := 0;
fs.bytes := 0;
fs.buffer := SYSTEM.ADR(Info);
COPY(FName, fs.name)
RETURN K.sysfunc22(70, SYSTEM.ADR(fs), res2) = 0
END GetFileInfo;
PROCEDURE Exists (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
END Exists;
PROCEDURE Close (VAR F: FS);
BEGIN
IF F # NIL THEN
DISPOSE(F)
END
END Close;
PROCEDURE Open (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 0;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name)
END
ELSE
F := NIL
END
RETURN F
END Open;
PROCEDURE Read (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 0;
F.bytes := Count;
F.buffer := Buffer;
res := K.sysfunc22(70, SYSTEM.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Read;
PROCEDURE Write (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 3;
F.bytes := Count;
F.buffer := Buffer;
res := K.sysfunc22(70, SYSTEM.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Write;
PROCEDURE Create (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 2;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
IF K.sysfunc22(70, SYSTEM.ADR(F^), res2) # 0 THEN
DISPOSE(F)
END
END
RETURN F
END Create;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
n: INTEGER;
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
n := Read(fs, SYSTEM.ADR(Buffer[0]), bytes);
IF n = 0 THEN
n := -1
END
RETURN n
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
n: INTEGER;
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
n := Write(fs, SYSTEM.ADR(Buffer[0]), bytes);
IF n = 0 THEN
n := -1
END
RETURN n
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
VAR
fs: FS;
res: INTEGER;
BEGIN
fs := Create(FName);
SYSTEM.GET(SYSTEM.ADR(fs), res)
RETURN res
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
VAR
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
Close(fs)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
fs: FS;
res: INTEGER;
BEGIN
fs := Open(FName);
SYSTEM.GET(SYSTEM.ADR(fs), res)
RETURN res
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
END chmod;
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9)
END GetTickCount;
PROCEDURE AppAdr (): INTEGER;
VAR
buf: ARRAY 1024 OF CHAR;
a: INTEGER;
BEGIN
a := K.sysfunc3(9, SYSTEM.ADR(buf), -1);
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a)
RETURN a
END AppAdr;
PROCEDURE GetCommandLine (): INTEGER;
VAR
param: INTEGER;
BEGIN
SYSTEM.GET(28 + AppAdr(), param)
RETURN param
END GetCommandLine;
PROCEDURE GetName (): INTEGER;
VAR
name: INTEGER;
BEGIN
SYSTEM.GET(32 + AppAdr(), name)
RETURN name
END GetName;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR
p, count, name, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; c: CHAR; VAR cond: 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
END ChangeCond;
BEGIN
p := GetCommandLine();
name := GetName();
Params[0, 0] := name;
WHILE GetChar(name) # 0X DO
INC(name)
END;
Params[0, 1] := name - 1;
cond := 0;
count := 1;
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE 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 GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
n := K.sysfunc4(30, 2, SYSTEM.ADR(path[0]), LEN(path) - 2);
path[n - 1] := slash;
path[n] := 0X
END GetCurrentDirectory;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
PROCEDURE UnixTime* (): INTEGER;
VAR
date, time, year, month, day, hour, min, sec: INTEGER;
BEGIN
date := K.sysfunc1(29);
time := K.sysfunc1(3);
year := date MOD 16;
date := date DIV 16;
year := (date MOD 16) * 10 + year;
date := date DIV 16;
month := date MOD 16;
date := date DIV 16;
month := (date MOD 16) * 10 + month;
date := date DIV 16;
day := date MOD 16;
date := date DIV 16;
day := (date MOD 16) * 10 + day;
date := date DIV 16;
hour := time MOD 16;
time := time DIV 16;
hour := (time MOD 16) * 10 + hour;
time := time DIV 16;
min := time MOD 16;
time := time DIV 16;
min := (time MOD 16) * 10 + min;
time := time DIV 16;
sec := time MOD 16;
time := time DIV 16;
sec := (time MOD 16) * 10 + sec;
time := time DIV 16;
INC(year, 2000)
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 UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
SYSTEM.GET32(SYSTEM.ADR(x), a);
SYSTEM.GET32(SYSTEM.ADR(x) + 4, b)
RETURN a
END splitf;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
e := splitf(x, l, 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 init (VAR days: DAYS);
VAR
i, j, 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 i := 0 TO 1 DO
days[ 1, 29, i] := -1;
days[ 1, 30, i] := -1;
days[ 3, 30, i] := -1;
days[ 5, 30, i] := -1;
days[ 8, 30, i] := -1;
days[10, 30, i] := -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;
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 init;
BEGIN
init(days)
END HOST.

/programs/develop/oberon07/lib/KolibriOS/OpenDlg.ob07
0,0 → 1,158
(*
Copyright 2016, 2018, 2020, 2021 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 OpenDlg;
IMPORT sys := SYSTEM, KOSAPI;
CONST
topen* = 0;
tsave* = 1;
tdir* = 2;
TYPE
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
_type*,
procinfo,
com_area_name,
com_area,
opendir_path,
dir_default_path,
start_path: INTEGER;
draw_window: DRAW_WINDOW;
status*,
openfile_path,
filename_area: INTEGER;
filter_area:
POINTER TO RECORD
size: INTEGER;
filter: ARRAY 4096 OF CHAR
END;
X, Y: INTEGER;
procinf: ARRAY 1024 OF CHAR;
s_com_area_name: ARRAY 32 OF CHAR;
s_opendir_path,
s_dir_default_path,
FilePath*,
FileName*: ARRAY 4096 OF CHAR
END;
Dialog* = POINTER TO TDialog;
VAR
Dialog_start, Dialog_init: PROCEDURE [stdcall] (od: Dialog);
PROCEDURE Show*(od: Dialog; Width, Height: INTEGER);
BEGIN
IF od # NIL THEN
od.X := Width;
od.Y := Height;
Dialog_start(od)
END
END Show;
PROCEDURE Create*(draw_window: DRAW_WINDOW; _type: INTEGER; def_path, filter: ARRAY OF CHAR): Dialog;
VAR res: Dialog; n, i: INTEGER;
PROCEDURE replace(VAR str: ARRAY OF CHAR; c1, c2: CHAR);
VAR i: INTEGER;
BEGIN
i := LENGTH(str) - 1;
WHILE i >= 0 DO
IF str[i] = c1 THEN
str[i] := c2
END;
DEC(i)
END
END replace;
BEGIN
NEW(res);
IF res # NIL THEN
NEW(res.filter_area);
IF res.filter_area # NIL THEN
res.s_com_area_name := "FFFFFFFF_open_dialog";
res.com_area := 0;
res._type := _type;
res.draw_window := draw_window;
COPY(def_path, res.s_dir_default_path);
COPY(filter, res.filter_area.filter);
n := LENGTH(res.filter_area.filter);
FOR i := 0 TO 3 DO
res.filter_area.filter[n + i] := "|"
END;
res.filter_area.filter[n + 4] := 0X;
res.X := 0;
res.Y := 0;
res.s_opendir_path := res.s_dir_default_path;
res.FilePath := "";
res.FileName := "";
res.status := 0;
res.filter_area.size := LENGTH(res.filter_area.filter);
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.SADR("/rd/1/File managers/opendial");
res.opendir_path := sys.ADR(res.s_opendir_path[0]);
res.dir_default_path := sys.ADR(res.s_dir_default_path[0]);
res.openfile_path := sys.ADR(res.FilePath[0]);
res.filename_area := sys.ADR(res.FileName[0]);
replace(res.filter_area.filter, "|", 0X);
Dialog_init(res)
ELSE
DISPOSE(res)
END
END
RETURN res
END Create;
PROCEDURE Destroy*(VAR od: Dialog);
BEGIN
IF od # NIL THEN
DISPOSE(od.filter_area);
DISPOSE(od)
END
END Destroy;
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(Lib, sys.ADR(Dialog_init), "OpenDialog_init");
GetProc(Lib, sys.ADR(Dialog_start), "OpenDialog_start");
END Load;
BEGIN
Load
END OpenDlg.

/programs/develop/oberon07/lib/KolibriOS/RTL.ob07
0,0 → 1,543
(*
BSD 2-Clause License
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, API;
CONST
minint = ROR(1, 1);
WORD = API.BIT_DEPTH DIV 8;
VAR
name: INTEGER;
types: INTEGER;
PROCEDURE [stdcall] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall] _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 [stdcall] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE [stdcall] _rot* (Len, Ptr: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- Len *)
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- Ptr *)
049H, (* dec ecx *)
053H, (* push ebx *)
08BH, 018H, (* mov ebx, dword [eax] *)
(* L: *)
08BH, 050H, 004H, (* mov edx, dword [eax + 4] *)
089H, 010H, (* mov dword [eax], edx *)
083H, 0C0H, 004H, (* add eax, 4 *)
049H, (* dec ecx *)
075H, 0F5H, (* jnz L *)
089H, 018H, (* mov dword [eax], ebx *)
05BH, (* pop ebx *)
05DH, (* pop ebp *)
0C2H, 008H, 000H (* ret 8 *)
)
END _rot;
PROCEDURE [stdcall] _set* (b, a: INTEGER); (* {a..b} -> eax *)
BEGIN
SYSTEM.CODE(
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- b *)
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- a *)
039H, 0C8H, (* cmp eax, ecx *)
07FH, 033H, (* jg L1 *)
083H, 0F8H, 01FH, (* cmp eax, 31 *)
07FH, 02EH, (* jg L1 *)
085H, 0C9H, (* test ecx, ecx *)
07CH, 02AH, (* jl L1 *)
083H, 0F9H, 01FH, (* cmp ecx, 31 *)
07EH, 005H, (* jle L3 *)
0B9H, 01FH, 000H, 000H, 000H, (* mov ecx, 31 *)
(* L3: *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L2 *)
031H, 0C0H, (* xor eax, eax *)
(* L2: *)
089H, 0CAH, (* mov edx, ecx *)
029H, 0C2H, (* sub edx, eax *)
0B8H, 000H, 000H, 000H, 080H, (* mov eax, 0x80000000 *)
087H, 0CAH, (* xchg edx, ecx *)
0D3H, 0F8H, (* sar eax, cl *)
087H, 0CAH, (* xchg edx, ecx *)
083H, 0E9H, 01FH, (* sub ecx, 31 *)
0F7H, 0D9H, (* neg ecx *)
0D3H, 0E8H, (* shr eax, cl *)
05DH, (* pop ebp *)
0C2H, 008H, 000H, (* ret 8 *)
(* L1: *)
031H, 0C0H, (* xor eax, eax *)
05DH, (* pop ebp *)
0C2H, 008H, 000H (* ret 8 *)
)
END _set;
PROCEDURE [stdcall] _set1* (a: INTEGER); (* {a} -> eax *)
BEGIN
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;
PROCEDURE [stdcall] _divmod* (y, x: INTEGER); (* (x div y) -> eax; (x mod y) -> edx *)
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- x *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
074H, 018H, (* je L2 *)
07FH, 002H, (* jg L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
089H, 0C3H, (* mov ebx, eax *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- y *)
0F7H, 0F9H, (* idiv ecx *)
085H, 0D2H, (* test edx, edx *)
074H, 009H, (* je L2 *)
031H, 0CBH, (* xor ebx, ecx *)
085H, 0DBH, (* test ebx, ebx *)
07DH, 003H, (* jge L2 *)
048H, (* dec eax *)
001H, 0CAH, (* add edx, ecx *)
(* L2: *)
05BH (* pop ebx *)
)
END _divmod;
PROCEDURE [stdcall] _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 [stdcall] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - WORD)
END
END _dispose;
PROCEDURE [stdcall] _length* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH (* sub eax, dword [ebp + 0Ch] *)
)
END _length;
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H (* shr eax, 1 *)
)
END _lengthw;
PROCEDURE [stdcall] strncmp (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
056H, (* push esi *)
057H, (* push edi *)
053H, (* push ebx *)
08BH, 075H, 008H, (* mov esi, dword[ebp + 8]; esi <- a *)
08BH, 07DH, 00CH, (* mov edi, dword[ebp + 12]; edi <- b *)
08BH, 05DH, 010H, (* mov ebx, dword[ebp + 16]; ebx <- n *)
031H, 0C9H, (* xor ecx, ecx *)
031H, 0D2H, (* xor edx, edx *)
0B8H,
000H, 000H, 000H, 080H, (* mov eax, minint *)
(* L1: *)
085H, 0DBH, (* test ebx, ebx *)
07EH, 017H, (* jle L3 *)
08AH, 00EH, (* mov cl, byte[esi] *)
08AH, 017H, (* mov dl, byte[edi] *)
046H, (* inc esi *)
047H, (* inc edi *)
04BH, (* dec ebx *)
039H, 0D1H, (* cmp ecx, edx *)
074H, 006H, (* je L2 *)
089H, 0C8H, (* mov eax, ecx *)
029H, 0D0H, (* sub eax, edx *)
0EBH, 006H, (* jmp L3 *)
(* L2: *)
085H, 0C9H, (* test ecx, ecx *)
075H, 0E7H, (* jne L1 *)
031H, 0C0H, (* xor eax, eax *)
(* L3: *)
05BH, (* pop ebx *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05DH, (* pop ebp *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END strncmp;
PROCEDURE [stdcall] strncmpw (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
056H, (* push esi *)
057H, (* push edi *)
053H, (* push ebx *)
08BH, 075H, 008H, (* mov esi, dword[ebp + 8]; esi <- a *)
08BH, 07DH, 00CH, (* mov edi, dword[ebp + 12]; edi <- b *)
08BH, 05DH, 010H, (* mov ebx, dword[ebp + 16]; ebx <- n *)
031H, 0C9H, (* xor ecx, ecx *)
031H, 0D2H, (* xor edx, edx *)
0B8H,
000H, 000H, 000H, 080H, (* mov eax, minint *)
(* L1: *)
085H, 0DBH, (* test ebx, ebx *)
07EH, 01BH, (* jle L3 *)
066H, 08BH, 00EH, (* mov cx, word[esi] *)
066H, 08BH, 017H, (* mov dx, word[edi] *)
046H, (* inc esi *)
046H, (* inc esi *)
047H, (* inc edi *)
047H, (* inc edi *)
04BH, (* dec ebx *)
039H, 0D1H, (* cmp ecx, edx *)
074H, 006H, (* je L2 *)
089H, 0C8H, (* mov eax, ecx *)
029H, 0D0H, (* sub eax, edx *)
0EBH, 006H, (* jmp L3 *)
(* L2: *)
085H, 0C9H, (* test ecx, ecx *)
075H, 0E3H, (* jne L1 *)
031H, 0C0H, (* xor eax, eax *)
(* L3: *)
05BH, (* pop ebx *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05DH, (* pop ebp *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END strncmpw;
PROCEDURE [stdcall] _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 [stdcall] _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: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE [stdcall] _error* (modnum, _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 + "module: "); PCharToStr(_module, temp); append(s, temp);
append(s, API.eol + "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall] _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 [stdcall] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall] _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 [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall] _sofinit*;
BEGIN
API.sofinit
END _sofinit;
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
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;
name := modname
END _init;
END RTL.

/programs/develop/oberon07/lib/KolibriOS/ColorDlg.ob07
0,0 → 1,105
(*
Copyright 2016, 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 ColorDlg;
IMPORT sys := SYSTEM, KOSAPI;
TYPE
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
_type,
procinfo,
com_area_name,
com_area,
start_path: INTEGER;
draw_window: DRAW_WINDOW;
status*,
X, Y,
color_type,
color*: INTEGER;
procinf: ARRAY 1024 OF CHAR;
s_com_area_name: ARRAY 32 OF CHAR
END;
Dialog* = POINTER TO TDialog;
VAR
Dialog_start, Dialog_init: PROCEDURE [stdcall] (cd: Dialog);
PROCEDURE Show*(cd: Dialog);
BEGIN
IF cd # NIL THEN
cd.X := 0;
cd.Y := 0;
Dialog_start(cd)
END
END Show;
PROCEDURE Create*(draw_window: DRAW_WINDOW): Dialog;
VAR res: Dialog;
BEGIN
NEW(res);
IF res # NIL THEN
res.s_com_area_name := "FFFFFFFF_color_dlg";
res.com_area := 0;
res._type := 0;
res.color_type := 0;
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.SADR("/rd/1/colrdial");
res.draw_window := draw_window;
res.status := 0;
res.X := 0;
res.Y := 0;
res.color := 0;
Dialog_init(res)
END
RETURN res
END Create;
PROCEDURE Destroy*(VAR cd: Dialog);
BEGIN
IF cd # NIL THEN
DISPOSE(cd)
END
END Destroy;
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(Lib, sys.ADR(Dialog_init), "ColorDialog_init");
GetProc(Lib, sys.ADR(Dialog_start), "ColorDialog_start");
END Load;
BEGIN
Load
END ColorDlg.

/programs/develop/oberon07/lib/KolibriOS/Math.ob07
0,0 → 1,450
(*
BSD 2-Clause License
Copyright (c) 2013-2014, 2018-2020 Anton Krotov
All rights reserved.
*)
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 sqri* (x: INTEGER): INTEGER;
RETURN x * x
END sqri;
PROCEDURE sqrr* (x: REAL): REAL;
RETURN x * x
END sqrr;
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 ipower* (base: REAL; exponent: INTEGER): REAL;
VAR
i: INTEGER;
a: REAL;
BEGIN
a := 1.0;
IF base # 0.0 THEN
IF exponent # 0 THEN
IF exponent < 0 THEN
base := 1.0 / base
END;
i := ABS(exponent);
WHILE i > 0 DO
WHILE ~ODD(i) DO
i := LSR(i, 1);
base := sqrr(base)
END;
DEC(i);
a := a * base
END
ELSE
a := 1.0
END
ELSE
ASSERT(exponent > 0);
a := 0.0
END
RETURN a
END ipower;
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 DegToRad* (x: REAL): REAL;
RETURN x * (pi / 180.0)
END DegToRad;
PROCEDURE RadToDeg* (x: REAL): REAL;
RETURN x * (180.0 / pi)
END RadToDeg;
(* Return hypotenuse of triangle *)
PROCEDURE hypot* (x, y: REAL): REAL;
VAR
a: REAL;
BEGIN
x := ABS(x);
y := ABS(y);
IF x > y THEN
a := x * sqrt(1.0 + sqrr(y / x))
ELSE
IF x > 0.0 THEN
a := y * sqrt(1.0 + sqrr(x / y))
ELSE
a := y
END
END
RETURN a
END hypot;
END Math.

/programs/develop/oberon07/lib/KolibriOS/libimg.ob07
0,0 → 1,435
(*
Copyright 2016, 2018, 2020 KolibriOS team
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 libimg;
IMPORT sys := SYSTEM, KOSAPI;
CONST
FLIP_VERTICAL *= 1;
FLIP_HORIZONTAL *= 2;
ROTATE_90_CW *= 1;
ROTATE_180 *= 2;
ROTATE_270_CW *= 3;
ROTATE_90_CCW *= ROTATE_270_CW;
ROTATE_270_CCW *= ROTATE_90_CW;
// scale type corresponding img_scale params
LIBIMG_SCALE_INTEGER *= 1; // scale factor ; reserved 0
LIBIMG_SCALE_TILE *= 2; // new width ; new height
LIBIMG_SCALE_STRETCH *= 3; // new width ; new height
LIBIMG_SCALE_FIT_RECT *= 4; // new width ; new height
LIBIMG_SCALE_FIT_WIDTH *= 5; // new width ; new height
LIBIMG_SCALE_FIT_HEIGHT *= 6; // new width ; new height
LIBIMG_SCALE_FIT_MAX *= 7; // new width ; new height
// interpolation algorithm
LIBIMG_INTER_NONE *= 0; // use it with LIBIMG_SCALE_INTEGER, LIBIMG_SCALE_TILE, etc
LIBIMG_INTER_BILINEAR *= 1;
LIBIMG_INTER_DEFAULT *= LIBIMG_INTER_BILINEAR;
// list of format id's
LIBIMG_FORMAT_BMP *= 1;
LIBIMG_FORMAT_ICO *= 2;
LIBIMG_FORMAT_CUR *= 3;
LIBIMG_FORMAT_GIF *= 4;
LIBIMG_FORMAT_PNG *= 5;
LIBIMG_FORMAT_JPEG *= 6;
LIBIMG_FORMAT_TGA *= 7;
LIBIMG_FORMAT_PCX *= 8;
LIBIMG_FORMAT_XCF *= 9;
LIBIMG_FORMAT_TIFF *= 10;
LIBIMG_FORMAT_PNM *= 11;
LIBIMG_FORMAT_WBMP *= 12;
LIBIMG_FORMAT_XBM *= 13;
LIBIMG_FORMAT_Z80 *= 14;
// encode flags (byte 0x02 of common option)
LIBIMG_ENCODE_STRICT_SPECIFIC *= 01H;
LIBIMG_ENCODE_STRICT_BIT_DEPTH *= 02H;
LIBIMG_ENCODE_DELETE_ALPHA *= 08H;
LIBIMG_ENCODE_FLUSH_ALPHA *= 10H;
// values for Image.Type
// must be consecutive to allow fast switch on Image.Type in support functions
bpp8i *= 1; // indexed
bpp24 *= 2;
bpp32 *= 3;
bpp15 *= 4;
bpp16 *= 5;
bpp1 *= 6;
bpp8g *= 7; // grayscale
bpp2i *= 8;
bpp4i *= 9;
bpp8a *= 10; // grayscale with alpha channel; application layer only!!! kernel doesn't handle this image type, libimg can only create and destroy such images
// bits in Image.Flags
IsAnimated *= 1;
TYPE
Image* = RECORD
Checksum *: INTEGER;
Width *: INTEGER;
Height *: INTEGER;
Next *: INTEGER;
Previous *: INTEGER;
Type *: INTEGER; // one of bppN
Data *: INTEGER;
Palette *: INTEGER; // used iff Type eq bpp1, bpp2, bpp4 or bpp8i
Extended *: INTEGER;
Flags *: INTEGER; // bitfield
Delay *: INTEGER // used iff IsAnimated is set in Flags
END;
ImageDecodeOptions* = RECORD
UsedSize *: INTEGER; // if >=8, the field BackgroundColor is valid, and so on
BackgroundColor *: INTEGER // used for transparent images as background
END;
FormatsTableEntry* = RECORD
Format_id *: INTEGER;
Is *: INTEGER;
Decode *: INTEGER;
Encode *: INTEGER;
Capabilities *: INTEGER
END;
VAR
img_is_img *: PROCEDURE (data, length: INTEGER): INTEGER;
img_to_rgb2 *: PROCEDURE (img: INTEGER; out: INTEGER);
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes image data into RGB triplets and stores them where out points to ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to source image ;;
;> out = where to store RGB triplets ;;
;;================================================================================================;;
*)
img_to_rgb *: PROCEDURE (img: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes image data into RGB triplets and returns pointer to memory area containing them ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to source image ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to rgb_data (array of [rgb] triplets) ;;
;;================================================================================================;;
*)
img_decode *: PROCEDURE (data, length, options: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes loaded into memory graphic file ;;
;;------------------------------------------------------------------------------------------------;;
;> data = pointer to file in memory ;;
;> length = size in bytes of memory area pointed to by data ;;
;> options = 0 / pointer to the structure of additional options ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to image ;;
;;================================================================================================;;
*)
img_encode *: PROCEDURE (img: INTEGER; common, specific: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? encode image to some format ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to input image ;;
;> common = some most important options ;;
; 0x00 : byte : format id ;;
; 0x01 : byte : fast encoding (0) / best compression ratio (255) ;;
; 0 : store uncompressed data (if supported both by the format and libimg) ;;
; 1 - 255 : use compression, if supported ;;
; this option may be ignored if any format specific options are defined ;;
; i.e. the 0 here will be ignored if some compression algorithm is specified ;;
; 0x02 : byte : flags (bitfield) ;;
; 0x01 : return an error if format specific conditions cannot be met ;;
; 0x02 : preserve current bit depth. means 8bpp/16bpp/24bpp and so on ;;
; 0x04 : delete alpha channel, if any ;;
; 0x08 : flush alpha channel with 0xff, if any; add it if none ;;
; 0x03 : byte : reserved, must be 0 ;;
;> specific = 0 / pointer to the structure of format specific options ;;
; see <format_name>.inc for description ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to encoded data ;;
;;================================================================================================;;
*)
img_create *: PROCEDURE (width, height, _type: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? creates an Image structure and initializes some its fields ;;
;;------------------------------------------------------------------------------------------------;;
;> width = width of an image in pixels ;;
;> height = height of an image in pixels ;;
;> type = one of the bppN constants ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to image ;;
;;================================================================================================;;
*)
img_destroy *: PROCEDURE (img: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? frees memory occupied by an image and all the memory regions its fields point to ;;
;? follows Previous/Next pointers and deletes all the images in sequence ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE (fail) / TRUE (success) ;;
;;================================================================================================;;
*)
img_destroy_layer *: PROCEDURE (img: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? frees memory occupied by an image and all the memory regions its fields point to ;;
;? for image sequences deletes only one frame and fixes Previous/Next pointers ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE (fail) / TRUE (success) ;;
;;================================================================================================;;
*)
img_count *: PROCEDURE (img: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? Get number of images in the list (e.g. in animated GIF file) ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;;------------------------------------------------------------------------------------------------;;
;< -1 (fail) / >0 (ok) ;;
;;================================================================================================;;
*)
img_flip *: PROCEDURE (img: INTEGER; flip_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Flip all layers of image ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> flip_kind = one of FLIP_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_flip_layer *: PROCEDURE (img: INTEGER; flip_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Flip image layer ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> flip_kind = one of FLIP_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_rotate *: PROCEDURE (img: INTEGER; rotate_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Rotate all layers of image ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> rotate_kind = one of ROTATE_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_rotate_layer *: PROCEDURE (img: INTEGER; rotate_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Rotate image layer ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> rotate_kind = one of ROTATE_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_draw *: PROCEDURE (img: INTEGER; x, y, width, height, xpos, ypos: INTEGER);
(*
;;------------------------------------------------------------------------------------------------;;
;? Draw image in the window ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> x = x-coordinate in the window ;;
;> y = y-coordinate in the window ;;
;> width = maximum width to draw ;;
;> height = maximum height to draw ;;
;> xpos = offset in image by x-axis ;;
;> ypos = offset in image by y-axis ;;
;;================================================================================================;;
*)
img_scale *: PROCEDURE (src: INTEGER; crop_x, crop_y, crop_width, crop_height: INTEGER; dst: INTEGER; scale, inter, param1, param2: INTEGER ): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? scale _image ;;
;;------------------------------------------------------------------------------------------------;;
;> src = pointer to source image ;;
;> crop_x = left coord of cropping rect ;;
;> crop_y = top coord of cropping rect ;;
;> crop_width = width of cropping rect ;;
;> crop_height = height of cropping rect ;;
;> dst = pointer to resulting image / 0 ;;
;> scale = how to change width and height. see libimg.inc ;;
;> inter = interpolation algorithm ;;
;> param1 = see libimg.inc ;;
;> param2 = see libimg.inc ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to scaled image ;;
;;================================================================================================;;
*)
img_convert *: PROCEDURE (src, dst: INTEGER; dst_type, flags, param: INTEGER);
(*
;;------------------------------------------------------------------------------------------------;;
;? scale _image ;;
;;------------------------------------------------------------------------------------------------;;
;> src = pointer to source image ;;
;> flags = see libimg.inc ;;
;> dst_type = the Image.Type of converted image ;;
;> dst = pointer to destination image, if any ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to converted image ;;
;;================================================================================================;;
*)
img_formats_table *: ARRAY 20 OF FormatsTableEntry;
PROCEDURE GetImageStruct* (img: INTEGER; VAR ImageStruct: Image): BOOLEAN;
BEGIN
IF img # 0 THEN
sys.MOVE(img, sys.ADR(ImageStruct), sys.SIZE(Image))
END
RETURN img # 0
END GetImageStruct;
PROCEDURE GetFormatsTable(ptr: INTEGER);
VAR i: INTEGER; eot: BOOLEAN;
BEGIN
i := 0;
REPEAT
sys.MOVE(ptr, sys.ADR(img_formats_table[i]), sys.SIZE(FormatsTableEntry));
ptr := ptr + sys.SIZE(FormatsTableEntry);
eot := img_formats_table[i].Format_id = 0;
INC(i)
UNTIL eot OR (i = LEN(img_formats_table))
END GetFormatsTable;
PROCEDURE main;
VAR Lib, formats_table_ptr: INTEGER;
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/libimg.obj");
ASSERT(Lib # 0);
GetProc(Lib, sys.ADR(img_is_img) , "img_is_img");
GetProc(Lib, sys.ADR(img_to_rgb) , "img_to_rgb");
GetProc(Lib, sys.ADR(img_to_rgb2) , "img_to_rgb2");
GetProc(Lib, sys.ADR(img_decode) , "img_decode");
GetProc(Lib, sys.ADR(img_encode) , "img_encode");
GetProc(Lib, sys.ADR(img_create) , "img_create");
GetProc(Lib, sys.ADR(img_destroy) , "img_destroy");
GetProc(Lib, sys.ADR(img_destroy_layer) , "img_destroy_layer");
GetProc(Lib, sys.ADR(img_count) , "img_count");
GetProc(Lib, sys.ADR(img_flip) , "img_flip");
GetProc(Lib, sys.ADR(img_flip_layer) , "img_flip_layer");
GetProc(Lib, sys.ADR(img_rotate) , "img_rotate");
GetProc(Lib, sys.ADR(img_rotate_layer) , "img_rotate_layer");
GetProc(Lib, sys.ADR(img_draw) , "img_draw");
GetProc(Lib, sys.ADR(img_scale) , "img_scale");
GetProc(Lib, sys.ADR(img_convert) , "img_convert");
GetProc(Lib, sys.ADR(formats_table_ptr) , "img_formats_table");
GetFormatsTable(formats_table_ptr)
END main;
BEGIN
main
END libimg.

/programs/develop/oberon07/lib/KolibriOS/Args.ob07
0,0 → 1,100
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 Args;
IMPORT sys := SYSTEM, KOSAPI;
CONST
MAX_PARAM = 1024;
VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
PROCEDURE GetChar(adr: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR p, count, name: INTEGER; c: CHAR; cond: INTEGER;
PROCEDURE ChangeCond(A, B, C: INTEGER; c: CHAR; VAR cond: 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
END ChangeCond;
BEGIN
p := KOSAPI.GetCommandLine();
name := KOSAPI.GetName();
Params[0, 0] := name;
WHILE GetChar(name) # 0X DO
INC(name)
END;
Params[0, 1] := name - 1;
cond := 0;
count := 1;
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
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;
BEGIN
ParamParse
END Args.

/programs/develop/oberon07/lib/KolibriOS/Console.ob07
0,0 → 1,94
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 Console;
IMPORT ConsoleLib, 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;
PROCEDURE SetCursor* (X, Y: INTEGER);
BEGIN
ConsoleLib.set_cursor_pos(X, Y)
END SetCursor;
PROCEDURE GetCursor* (VAR X, Y: INTEGER);
BEGIN
ConsoleLib.get_cursor_pos(X, Y)
END GetCursor;
PROCEDURE Cls*;
BEGIN
ConsoleLib.cls
END Cls;
PROCEDURE SetColor* (FColor, BColor: INTEGER);
VAR
res: INTEGER;
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
res := ConsoleLib.set_flags(LSL(BColor, 4) + FColor)
END
END SetColor;
PROCEDURE GetCursorX* (): INTEGER;
VAR
x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN x
END GetCursorX;
PROCEDURE GetCursorY* (): INTEGER;
VAR
x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN y
END GetCursorY;
PROCEDURE open*;
BEGIN
ConsoleLib.open(-1, -1, -1, -1, "");
In.Open;
Out.Open
END open;
PROCEDURE exit* (bCloseWindow: BOOLEAN);
BEGIN
ConsoleLib.exit(bCloseWindow)
END exit;
END Console.

/programs/develop/oberon07/lib/KolibriOS/ConsoleLib.ob07
0,0 → 1,103
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 ConsoleLib;
IMPORT sys := SYSTEM, KOSAPI;
CONST
COLOR_BLUE* = 001H;
COLOR_GREEN* = 002H;
COLOR_RED* = 004H;
COLOR_BRIGHT* = 008H;
BGR_BLUE* = 010H;
BGR_GREEN* = 020H;
BGR_RED* = 040H;
BGR_BRIGHT* = 080H;
IGNORE_SPECIALS* = 100H;
WINDOW_CLOSED* = 200H;
TYPE
gets2_callback* = PROCEDURE [stdcall] (keycode: INTEGER; pstr: INTEGER; VAR n, pos: INTEGER);
VAR
version* : INTEGER;
init* : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
exit* : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
write_asciiz* : PROCEDURE [stdcall] (string: INTEGER);
write_string* : PROCEDURE [stdcall] (string, length: INTEGER);
get_flags* : PROCEDURE [stdcall] (): INTEGER;
set_flags* : PROCEDURE [stdcall] (new_flags: INTEGER): INTEGER;
get_font_height* : PROCEDURE [stdcall] (): INTEGER;
get_cursor_height* : PROCEDURE [stdcall] (): INTEGER;
set_cursor_height* : PROCEDURE [stdcall] (new_height: INTEGER): INTEGER;
getch* : PROCEDURE [stdcall] (): INTEGER;
getch2* : PROCEDURE [stdcall] (): INTEGER;
kbhit* : PROCEDURE [stdcall] (): INTEGER;
gets* : PROCEDURE [stdcall] (str, n: INTEGER): INTEGER;
gets2* : PROCEDURE [stdcall] (callback: gets2_callback; str, n: INTEGER): INTEGER;
cls* : PROCEDURE [stdcall] ();
get_cursor_pos* : PROCEDURE [stdcall] (VAR x, y: INTEGER);
set_cursor_pos* : PROCEDURE [stdcall] (x, y: INTEGER);
set_title* : PROCEDURE [stdcall] (title: INTEGER);
PROCEDURE open*(wnd_width, wnd_height, scr_width, scr_height: INTEGER; title: ARRAY OF CHAR);
BEGIN
init(wnd_width, wnd_height, scr_width, scr_height, sys.ADR(title[0]))
END open;
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/Console.obj");
ASSERT(Lib # 0);
GetProc(Lib, sys.ADR(version), "version");
GetProc(Lib, sys.ADR(init), "con_init");
GetProc(Lib, sys.ADR(exit), "con_exit");
GetProc(Lib, sys.ADR(write_asciiz), "con_write_asciiz");
GetProc(Lib, sys.ADR(write_string), "con_write_string");
GetProc(Lib, sys.ADR(get_flags), "con_get_flags");
GetProc(Lib, sys.ADR(set_flags), "con_set_flags");
GetProc(Lib, sys.ADR(get_font_height), "con_get_font_height");
GetProc(Lib, sys.ADR(get_cursor_height), "con_get_cursor_height");
GetProc(Lib, sys.ADR(set_cursor_height), "con_set_cursor_height");
GetProc(Lib, sys.ADR(getch), "con_getch");
GetProc(Lib, sys.ADR(getch2), "con_getch2");
GetProc(Lib, sys.ADR(kbhit), "con_kbhit");
GetProc(Lib, sys.ADR(gets), "con_gets");
GetProc(Lib, sys.ADR(gets2), "con_gets2");
GetProc(Lib, sys.ADR(cls), "con_cls");
GetProc(Lib, sys.ADR(get_cursor_pos), "con_get_cursor_pos");
GetProc(Lib, sys.ADR(set_cursor_pos), "con_set_cursor_pos");
GetProc(Lib, sys.ADR(set_title), "con_set_title");
END main;
BEGIN
main
END ConsoleLib.

/programs/develop/oberon07/lib/KolibriOS/DateTime.ob07
0,0 → 1,141
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 DateTime;
IMPORT KOSAPI;
CONST ERR* = -7.0E5;
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL;
VAR d, i: INTEGER; M: ARRAY 14 OF CHAR; Res: REAL;
BEGIN
Res := ERR;
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) &
(Day >= 1) & (Day <= 31) & (Hour >= 0) & (Hour <= 23) &
(Min >= 0) & (Min <= 59) & (Sec >= 0) & (Sec <= 59) THEN
M := "_303232332323";
IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN
M[2] := "1"
END;
IF Day <= ORD(M[Month]) - ORD("0") + 28 THEN
DEC(Year);
d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) + Day - 693594;
FOR i := 1 TO Month - 1 DO
d := d + ORD(M[i]) - ORD("0") + 28
END;
Res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000) / 86400000.0
END
END
RETURN Res
END Encode;
PROCEDURE Decode*(Date: REAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN;
VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 14 OF CHAR;
PROCEDURE MonthDay(n: INTEGER; VAR d, Month: INTEGER; M: ARRAY OF CHAR): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
Res := FALSE;
IF d > ORD(M[n]) - ORD("0") + 28 THEN
d := d - ORD(M[n]) + ORD("0") - 28;
INC(Month);
Res := TRUE
END
RETURN Res
END MonthDay;
BEGIN
IF (Date >= -693593.0) & (Date < 2958466.0) THEN
d := FLOOR(Date);
t := FLOOR((Date - FLT(d)) * 86400000.0);
d := d + 693593;
Year := 1;
Month := 1;
WHILE d > 0 DO
d := d - 365 - ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0));
INC(Year)
END;
IF d < 0 THEN
DEC(Year);
d := d + 365 + ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0))
END;
INC(d);
M := "_303232332323";
IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN
M[2] := "1"
END;
i := 1;
flag := TRUE;
WHILE flag & (i <= 12) DO
flag := MonthDay(i, d, Month, M);
INC(i)
END;
Day := d;
Hour := t DIV 3600000;
t := t MOD 3600000;
Min := t DIV 60000;
t := t MOD 60000;
Sec := t DIV 1000;
Res := TRUE
ELSE
Res := FALSE
END
RETURN Res
END Decode;
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec, Msec: INTEGER);
VAR date, time: INTEGER;
BEGIN
date := KOSAPI.sysfunc1(29);
time := KOSAPI.sysfunc1(3);
Year := date MOD 16;
date := date DIV 16;
Year := (date MOD 16) * 10 + Year;
date := date DIV 16;
Month := date MOD 16;
date := date DIV 16;
Month := (date MOD 16) * 10 + Month;
date := date DIV 16;
Day := date MOD 16;
date := date DIV 16;
Day := (date MOD 16) * 10 + Day;
date := date DIV 16;
Hour := time MOD 16;
time := time DIV 16;
Hour := (time MOD 16) * 10 + Hour;
time := time DIV 16;
Min := time MOD 16;
time := time DIV 16;
Min := (time MOD 16) * 10 + Min;
time := time DIV 16;
Sec := time MOD 16;
time := time DIV 16;
Sec := (time MOD 16) * 10 + Sec;
time := time DIV 16;
Year := Year + 2000;
Msec := 0
END Now;
END DateTime.

/programs/develop/oberon07/lib/KolibriOS/Debug.ob07
0,0 → 1,292
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 Debug;
IMPORT KOSAPI, sys := SYSTEM;
CONST
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
VAR res: INTEGER;
BEGIN
res := KOSAPI.sysfunc3(63, 1, ORD(c))
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR n, i: INTEGER;
BEGIN
n := LENGTH(s);
FOR i := 0 TO n - 1 DO
Char(s[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(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
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;
Realp := Real;
_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*;
TYPE
info_struct = RECORD
subfunc: INTEGER;
flags: INTEGER;
param: INTEGER;
rsrvd1: INTEGER;
rsrvd2: INTEGER;
fname: ARRAY 1024 OF CHAR
END;
VAR info: info_struct; res: INTEGER;
BEGIN
info.subfunc := 7;
info.flags := 0;
info.param := sys.SADR(" ");
info.rsrvd1 := 0;
info.rsrvd2 := 0;
info.fname := "/rd/1/develop/board";
res := KOSAPI.sysfunc2(70, sys.ADR(info))
END Open;
END Debug.

/programs/develop/oberon07/lib/KolibriOS/In.ob07
0,0 → 1,282
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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, ConsoleLib;
TYPE
STRING = ARRAY 260 OF CHAR;
VAR
Done* : BOOLEAN;
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 (str: STRING; VAR res, d: REAL; VAR i: INTEGER): 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 (str: STRING; VAR i, scale: INTEGER; VAR minus, err: BOOLEAN; VAR m, res: REAL): 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 res, m: REAL; VAR scale: INTEGER);
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(str, res, d, i) & part2(str, i, scale, minus, err, m, res) THEN
part3(err, minus, res, m, scale)
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0;
err := TRUE
END
RETURN res
END StrToFloat;
PROCEDURE String*(VAR s: ARRAY OF CHAR);
VAR res, length: INTEGER; str: STRING;
BEGIN
res := ConsoleLib.gets(sys.ADR(str[0]), LEN(str));
length := LENGTH(str);
IF length > 0 THEN
str[length - 1] := 0X
END;
COPY(str, s);
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
Done := TRUE
END Open;
END In.

/programs/develop/oberon07/lib/KolibriOS/KOSAPI.ob07
0,0 → 1,430
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
All rights reserved.
*)
MODULE KOSAPI;
IMPORT SYSTEM;
TYPE
STRING = ARRAY 1024 OF CHAR;
VAR
DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER);
imp_error*: RECORD
proc*, lib*: STRING;
error*: INTEGER
END;
PROCEDURE [stdcall-] sysfunc1* (arg1: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
0CDH, 040H, (* int 64 *)
0C9H, (* leave *)
0C2H, 004H, 000H (* ret 4 *)
)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall-] sysfunc2* (arg1, arg2: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 8 *)
)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall-] sysfunc3* (arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall-] sysfunc4* (arg1, arg2, arg3, arg4: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 16 *)
)
RETURN 0
END sysfunc4;
PROCEDURE [stdcall-] sysfunc5* (arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
0CDH, 040H, (* int 64 *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 014H, 000H (* ret 20 *)
)
RETURN 0
END sysfunc5;
PROCEDURE [stdcall-] sysfunc6* (arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
0CDH, 040H, (* int 64 *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END sysfunc6;
PROCEDURE [stdcall-] sysfunc7* (arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
055H, (* push ebp *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
08BH, 06DH, 020H, (* mov ebp, dword [ebp + 32] *)
0CDH, 040H, (* int 64 *)
05DH, (* pop ebp *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 01CH, 000H (* ret 28 *)
)
RETURN 0
END sysfunc7;
PROCEDURE [stdcall-] sysfunc22* (arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
0CDH, 040H, (* int 64 *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 019H, (* mov dword [ecx], ebx *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END sysfunc22;
PROCEDURE mem_commit (adr, size: INTEGER);
VAR
tmp: INTEGER;
BEGIN
FOR tmp := adr TO adr + size - 1 BY 4096 DO
SYSTEM.PUT(tmp, 0)
END
END mem_commit;
PROCEDURE [stdcall] malloc* (size: INTEGER): INTEGER;
VAR
ptr: INTEGER;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
IF sysfunc2(18, 16) > ASR(size, 10) THEN
ptr := sysfunc3(68, 12, size);
IF ptr # 0 THEN
mem_commit(ptr, size)
END
ELSE
ptr := 0
END;
SYSTEM.CODE(061H) (* popa *)
RETURN ptr
END malloc;
PROCEDURE [stdcall] free* (ptr: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
IF ptr # 0 THEN
ptr := sysfunc3(68, 13, ptr)
END;
SYSTEM.CODE(061H) (* popa *)
RETURN 0
END free;
PROCEDURE [stdcall] realloc* (ptr, size: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
ptr := sysfunc4(68, 20, size, ptr);
SYSTEM.CODE(061H) (* popa *)
RETURN ptr
END realloc;
PROCEDURE AppAdr (): INTEGER;
VAR
buf: ARRAY 1024 OF CHAR;
a: INTEGER;
BEGIN
a := sysfunc3(9, SYSTEM.ADR(buf), -1);
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a)
RETURN a
END AppAdr;
PROCEDURE GetCommandLine* (): INTEGER;
VAR
param: INTEGER;
BEGIN
SYSTEM.GET(28 + AppAdr(), param)
RETURN param
END GetCommandLine;
PROCEDURE GetName* (): INTEGER;
VAR
name: INTEGER;
BEGIN
SYSTEM.GET(32 + AppAdr(), name)
RETURN name
END GetName;
PROCEDURE [stdcall] dll_init2 (arg1, arg2, arg3, arg4, arg5: INTEGER);
BEGIN
SYSTEM.CODE(
060H, (* pusha *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
0FFH, 0D6H, (* call esi *)
061H, (* popa *)
0C9H, (* leave *)
0C2H, 014H, 000H (* ret 20 *)
)
END dll_init2;
PROCEDURE GetProcAdr* (name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR
cur, procname, adr: INTEGER;
PROCEDURE streq (str1, str2: INTEGER): BOOLEAN;
VAR
c1, c2: CHAR;
BEGIN
REPEAT
SYSTEM.GET(str1, c1);
SYSTEM.GET(str2, c2);
INC(str1);
INC(str2)
UNTIL (c1 # c2) OR (c1 = 0X)
RETURN c1 = c2
END streq;
BEGIN
adr := 0;
IF (lib # 0) & (name # "") THEN
cur := lib;
REPEAT
SYSTEM.GET(cur, procname);
INC(cur, 8)
UNTIL (procname = 0) OR streq(procname, SYSTEM.ADR(name[0]));
IF procname # 0 THEN
SYSTEM.GET(cur - 4, adr)
END
END
RETURN adr
END GetProcAdr;
PROCEDURE init (dll: INTEGER);
VAR
lib_init: INTEGER;
BEGIN
lib_init := GetProcAdr("lib_init", dll);
IF lib_init # 0 THEN
DLL_INIT(lib_init)
END;
lib_init := GetProcAdr("START", dll);
IF lib_init # 0 THEN
DLL_INIT(lib_init)
END
END init;
PROCEDURE GetStr (adr, i: INTEGER; VAR str: STRING);
VAR
c: CHAR;
BEGIN
REPEAT
SYSTEM.GET(adr, c); INC(adr);
str[i] := c; INC(i)
UNTIL c = 0X
END GetStr;
PROCEDURE [stdcall] dll_Load* (import_table: INTEGER): INTEGER;
VAR
imp, lib, exp, proc, res: INTEGER;
fail, done: BOOLEAN;
procname, libname: STRING;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
fail := FALSE;
done := FALSE;
res := 0;
libname := "/rd/1/lib/";
REPEAT
SYSTEM.GET(import_table, imp);
IF imp # 0 THEN
SYSTEM.GET(import_table + 4, lib);
GetStr(lib, 10, libname);
exp := sysfunc3(68, 19, SYSTEM.ADR(libname[0]));
fail := exp = 0;
ELSE
done := TRUE
END;
IF fail THEN
done := TRUE;
imp_error.proc := "";
imp_error.lib := libname;
imp_error.error := 1
END;
IF (imp # 0) & ~fail THEN
REPEAT
SYSTEM.GET(imp, proc);
IF proc # 0 THEN
GetStr(proc, 0, procname);
proc := GetProcAdr(procname, exp);
IF proc # 0 THEN
SYSTEM.PUT(imp, proc);
INC(imp, 4)
ELSE
imp_error.proc := procname;
imp_error.lib := libname;
imp_error.error := 2
END
END
UNTIL proc = 0;
init(exp);
INC(import_table, 8)
END
UNTIL done;
IF fail THEN
res := 1
END;
import_table := res;
SYSTEM.CODE(061H) (* popa *)
RETURN import_table
END dll_Load;
PROCEDURE [stdcall] dll_Init (entry: INTEGER);
BEGIN
SYSTEM.CODE(060H); (* pusha *)
IF entry # 0 THEN
dll_init2(SYSTEM.ADR(malloc), SYSTEM.ADR(free), SYSTEM.ADR(realloc), SYSTEM.ADR(dll_Load), entry)
END;
SYSTEM.CODE(061H); (* popa *)
END dll_Init;
PROCEDURE LoadLib* (name: ARRAY OF CHAR): INTEGER;
VAR
Lib: INTEGER;
BEGIN
DLL_INIT := dll_Init;
Lib := sysfunc3(68, 19, SYSTEM.ADR(name[0]));
IF Lib # 0 THEN
init(Lib)
END
RETURN Lib
END LoadLib;
PROCEDURE _init*;
BEGIN
DLL_INIT := dll_Init;
imp_error.lib := "";
imp_error.proc := "";
imp_error.error := 0
END _init;
END KOSAPI.

/programs/develop/oberon07/lib/KolibriOS/NetDevices.ob07
0,0 → 1,107
(*
Copyright 2017 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 NetDevices;
IMPORT sys := SYSTEM, K := KOSAPI;
CONST
//net devices types
LOOPBACK* = 0;
ETH* = 1;
SLIP* = 2;
//Link status
LINK_DOWN* = 0;
LINK_UNKNOWN* = 1;
LINK_FD* = 2; //full duplex flag
LINK_10M* = 4;
LINK_100M* = 8;
LINK_1G* = 12;
TYPE
DEVICENAME* = ARRAY 64 OF CHAR;
PROCEDURE Number* (): INTEGER;
RETURN K.sysfunc2(74, -1)
END Number;
PROCEDURE Type* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256)
END Type;
PROCEDURE Name* (num: INTEGER; VAR name: DEVICENAME): BOOLEAN;
VAR err: BOOLEAN;
BEGIN
err := K.sysfunc3(74, num * 256 + 1, sys.ADR(name[0])) = -1;
IF err THEN
name := ""
END
RETURN ~err
END Name;
PROCEDURE Reset* (num: INTEGER): BOOLEAN;
RETURN K.sysfunc2(74, num * 256 + 2) # -1
END Reset;
PROCEDURE Stop* (num: INTEGER): BOOLEAN;
RETURN K.sysfunc2(74, num * 256 + 3) # -1
END Stop;
PROCEDURE Pointer* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 4)
END Pointer;
PROCEDURE SentPackets* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 6)
END SentPackets;
PROCEDURE ReceivedPackets* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 7)
END ReceivedPackets;
PROCEDURE SentBytes* (num: INTEGER; VAR hValue: INTEGER): INTEGER;
RETURN K.sysfunc22(74, num * 256 + 8, hValue)
END SentBytes;
PROCEDURE ReceivedBytes* (num: INTEGER; VAR hValue: INTEGER): INTEGER;
RETURN K.sysfunc22(74, num * 256 + 9, hValue)
END ReceivedBytes;
PROCEDURE LinkStatus* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 10)
END LinkStatus;
END NetDevices.

/programs/develop/oberon07/lib/KolibriOS/Out.ob07
0,0 → 1,267
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 ConsoleLib, sys := SYSTEM;
CONST
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
BEGIN
ConsoleLib.write_string(sys.ADR(c), 1)
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
BEGIN
ConsoleLib.write_string(sys.ADR(s[0]), LENGTH(s))
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(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
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;
Realp := Real;
_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/KolibriOS/RasterWorks.ob07
0,0 → 1,124
(*
Copyright 2016, 2018 KolibriOS team
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 RasterWorks;
IMPORT sys := SYSTEM, KOSAPI;
CONST
(* flags *)
bold *= 1;
italic *= 2;
underline *= 4;
strike_through *= 8;
align_right *= 16;
align_center *= 32;
bpp32 *= 128;
(* encoding *)
cp866 *= 1;
utf16le *= 2;
utf8 *= 3;
VAR
// draw text on 24bpp or 32bpp image
// autofits text between 'x' and 'xSize'
drawText *: PROCEDURE (canvas, x, y, string, charQuantity, fontColor, params: INTEGER): INTEGER;
(*
[canvas]:
xSize dd ?
ySize dd ?
picture rb xSize * ySize * bpp
fontColor dd AARRGGBB
AA = alpha channel ; 0 = transparent, FF = non transparent
params dd ffeewwhh
hh = char height
ww = char width ; 0 = auto (proportional)
ee = encoding ; 1 = cp866, 2 = UTF-16LE, 3 = UTF-8
ff = flags ; 0001 = bold, 0010 = italic
; 0100 = underline, 1000 = strike-through
00010000 = align right, 00100000 = align center
01000000 = set text area between higher and lower halfs of 'x'
10000000 = 32bpp canvas insted of 24bpp
all flags combinable, except align right + align center
returns: char width (0 = error)
*)
// calculate amount of valid chars in UTF-8 string
// supports zero terminated string (set byteQuantity = -1)
cntUTF_8 *: PROCEDURE (string, byteQuantity: INTEGER): INTEGER;
// calculate amount of chars that fits given width
charsFit *: PROCEDURE (areaWidth, charHeight: INTEGER): INTEGER;
// calculate string width in pixels
strWidth *: PROCEDURE (charQuantity, charHeight: INTEGER): INTEGER;
PROCEDURE params* (charHeight, charWidth, encoding, flags: INTEGER): INTEGER;
(*
hh = char height
ww = char width ; 0 = auto (proportional)
ee = encoding ; 1 = cp866, 2 = UTF-16LE, 3 = UTF-8
ff = flags ; 0001 = bold, 0010 = italic
; 0100 = underline, 1000 = strike-through
00010000 = align right, 00100000 = align center
01000000 = set text area between higher and lower halfs of 'x'
10000000 = 32bpp canvas insted of 24bpp
all flags combinable, except align right + align center
*)
RETURN charHeight + LSL(charWidth, 8) + LSL(encoding, 16) + LSL(flags, 24)
END params;
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/RasterWorks.obj");
ASSERT(Lib # 0);
GetProc(Lib, sys.ADR(drawText), "drawText");
GetProc(Lib, sys.ADR(cntUTF_8), "cntUTF-8");
GetProc(Lib, sys.ADR(charsFit), "charsFit");
GetProc(Lib, sys.ADR(strWidth), "strWidth");
END main;
BEGIN
main
END RasterWorks.

/programs/develop/oberon07/lib/KolibriOS/Read.ob07
0,0 → 1,46
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 Read;
IMPORT File, sys := SYSTEM;
PROCEDURE Char*(F: File.FS; VAR x: CHAR): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR)
END Char;
PROCEDURE Int*(F: File.FS; VAR x: INTEGER): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER)
END Int;
PROCEDURE Real*(F: File.FS; VAR x: REAL): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL)
END Real;
PROCEDURE Boolean*(F: File.FS; VAR x: BOOLEAN): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN)
END Boolean;
PROCEDURE Set*(F: File.FS; VAR x: SET): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET)
END Set;
PROCEDURE WChar*(F: File.FS; VAR x: WCHAR): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(WCHAR)) = sys.SIZE(WCHAR)
END WChar;
END Read.

/programs/develop/oberon07/lib/KolibriOS/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/KolibriOS/Vector.ob07
0,0 → 1,121
(*
Copyright 2016 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 Vector;
IMPORT sys := SYSTEM, K := KOSAPI;
TYPE
DESC_VECTOR = RECORD
data : INTEGER;
count : INTEGER;
size : INTEGER
END;
VECTOR* = POINTER TO DESC_VECTOR;
ANYREC* = RECORD END;
ANYPTR* = POINTER TO ANYREC;
DESTRUCTOR* = PROCEDURE (VAR ptr: ANYPTR);
PROCEDURE count* (vector: VECTOR): INTEGER;
BEGIN
ASSERT(vector # NIL)
RETURN vector.count
END count;
PROCEDURE push* (vector: VECTOR; value: ANYPTR);
BEGIN
ASSERT(vector # NIL);
IF vector.count = vector.size THEN
vector.data := K.realloc(vector.data, (vector.size + 1024) * 4);
ASSERT(vector.data # 0);
vector.size := vector.size + 1024
END;
sys.PUT(vector.data + vector.count * 4, value);
INC(vector.count)
END push;
PROCEDURE get* (vector: VECTOR; idx: INTEGER): ANYPTR;
VAR res: ANYPTR;
BEGIN
ASSERT(vector # NIL);
ASSERT( (0 <= idx) & (idx < vector.count) );
sys.GET(vector.data + idx * 4, res)
RETURN res
END get;
PROCEDURE put* (vector: VECTOR; idx: INTEGER; value: ANYPTR);
BEGIN
ASSERT(vector # NIL);
ASSERT( (0 <= idx) & (idx < vector.count) );
sys.PUT(vector.data + idx * 4, value)
END put;
PROCEDURE create* (size: INTEGER): VECTOR;
VAR vector: VECTOR;
BEGIN
NEW(vector);
IF vector # NIL THEN
vector.data := K.malloc(4 * size);
IF vector.data # 0 THEN
vector.size := size;
vector.count := 0
ELSE
DISPOSE(vector)
END
END
RETURN vector
END create;
PROCEDURE def_destructor (VAR any: ANYPTR);
BEGIN
DISPOSE(any)
END def_destructor;
PROCEDURE destroy* (VAR vector: VECTOR; destructor: DESTRUCTOR);
VAR i: INTEGER;
any: ANYPTR;
BEGIN
ASSERT(vector # NIL);
IF destructor = NIL THEN
destructor := def_destructor
END;
FOR i := 0 TO vector.count - 1 DO
any := get(vector, i);
destructor(any)
END;
vector.data := K.free(vector.data);
DISPOSE(vector)
END destroy;
END Vector.

/programs/develop/oberon07/lib/KolibriOS/Write.ob07
0,0 → 1,46
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 Write;
IMPORT File, sys := SYSTEM;
PROCEDURE Char*(F: File.FS; x: CHAR): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR)
END Char;
PROCEDURE Int*(F: File.FS; x: INTEGER): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER)
END Int;
PROCEDURE Real*(F: File.FS; x: REAL): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL)
END Real;
PROCEDURE Boolean*(F: File.FS; x: BOOLEAN): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN)
END Boolean;
PROCEDURE Set*(F: File.FS; x: SET): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET)
END Set;
PROCEDURE WChar*(F: File.FS; x: WCHAR): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(WCHAR)) = sys.SIZE(WCHAR)
END WChar;
END Write.

/programs/develop/oberon07/lib/KolibriOS/kfonts.ob07
0,0 → 1,492
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
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 kfonts;
IMPORT sys := SYSTEM, File, KOSAPI;
CONST
MIN_FONT_SIZE = 8;
MAX_FONT_SIZE = 46;
bold *= 1;
italic *= 2;
underline *= 4;
strike_through *= 8;
smoothing *= 16;
bpp32 *= 32;
TYPE
Glyph = RECORD
base: INTEGER;
xsize, ysize: INTEGER;
width: INTEGER
END;
TFont_desc = RECORD
data, size, font, char_size, width, height, font_size, mem, mempos: INTEGER;
glyphs: ARRAY 4, 256 OF Glyph
END;
TFont* = POINTER TO TFont_desc;
PROCEDURE [stdcall] zeromem(size, adr: INTEGER);
BEGIN
sys.CODE(057H, 08BH, 07DH, 00CH, 08BH, 04DH, 008H, 033H, 0C0H, 09CH, 0FCH, 0F3H, 0ABH, 09DH, 05FH)
END zeromem;
PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN);
VAR xsize, ysize: INTEGER;
BEGIN
sys.GET(buf, xsize);
sys.GET(buf + 4, ysize);
INC(buf, 8);
IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN
IF bpp32 THEN
sys.PUT(buf + 4 * (xsize * y + x), color)
ELSE
sys.MOVE(sys.ADR(color), buf + 3 * (xsize * y + x), 3)
END
END
END pset;
PROCEDURE pget(buf, x, y: INTEGER; bpp32: BOOLEAN): INTEGER;
VAR xsize, ysize, color: INTEGER;
BEGIN
sys.GET(buf, xsize);
sys.GET(buf + 4, ysize);
INC(buf, 8);
IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN
IF bpp32 THEN
sys.GET(buf + 4 * (xsize * y + x), color)
ELSE
sys.MOVE(buf + 3 * (xsize * y + x), sys.ADR(color), 3)
END
END
RETURN color
END pget;
PROCEDURE getrgb(color: INTEGER; VAR r, g, b: INTEGER);
BEGIN
b := LSR(LSL(color, 24), 24);
g := LSR(LSL(color, 16), 24);
r := LSR(LSL(color, 8), 24);
END getrgb;
PROCEDURE rgb(r, g, b: INTEGER): INTEGER;
RETURN b + LSL(g, 8) + LSL(r, 16)
END rgb;
PROCEDURE create_glyph(VAR Font: TFont_desc; VAR glyph: Glyph; xsize, ysize: INTEGER);
BEGIN
glyph.base := Font.mempos;
glyph.xsize := xsize;
glyph.ysize := ysize;
Font.mempos := Font.mempos + xsize * ysize
END create_glyph;
PROCEDURE getpix(Font: TFont_desc; n, x, y, xsize: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(Font.mem + n + x + y * xsize, res)
RETURN res
END getpix;
PROCEDURE setpix(VAR Font: TFont_desc; n, x, y, xsize: INTEGER; c: CHAR);
BEGIN
sys.PUT(Font.mem + n + x + y * xsize, c)
END setpix;
PROCEDURE smooth(VAR Font: TFont_desc; n, xsize, ysize: INTEGER);
VAR x, y: INTEGER;
BEGIN
FOR y := 1 TO ysize - 1 DO
FOR x := 1 TO xsize - 1 DO
IF (getpix(Font, n, x, y, xsize) = 1X) & (getpix(Font, n, x - 1, y - 1, xsize) = 1X) &
(getpix(Font, n, x - 1, y, xsize) = 0X) & (getpix(Font, n, x, y - 1, xsize) = 0X) THEN
setpix(Font, n, x - 1, y, xsize, 2X);
setpix(Font, n, x, y - 1, xsize, 2X)
END;
IF (getpix(Font, n, x, y, xsize) = 0X) & (getpix(Font, n, x - 1, y - 1, xsize) = 0X) &
(getpix(Font, n, x - 1, y, xsize) = 1X) & (getpix(Font, n, x, y - 1, xsize) = 1X) THEN
setpix(Font, n, x, y, xsize, 2X);
setpix(Font, n, x - 1, y - 1, xsize, 2X)
END
END
END
END smooth;
PROCEDURE _bold(VAR Font: TFont_desc; src, dst, src_xsize, dst_xsize, n: INTEGER);
VAR i, j, k: INTEGER; pix: CHAR;
BEGIN
FOR i := 0 TO src_xsize - 1 DO
FOR j := 0 TO Font.height - 1 DO
pix := getpix(Font, src, i, j, src_xsize);
IF pix = 1X THEN
FOR k := 0 TO n DO
setpix(Font, dst, i + k, j, dst_xsize, pix)
END
END
END
END
END _bold;
PROCEDURE make_glyph(VAR Font: TFont_desc; c: INTEGER);
VAR ptr, i, j, max, x, y: INTEGER; s: SET; eoc: BOOLEAN;
glyph: Glyph; pix: CHAR; bold_width: INTEGER;
BEGIN
create_glyph(Font, glyph, Font.width, Font.height);
x := 0;
y := 0;
max := 0;
ptr := Font.font + Font.char_size * c;
eoc := FALSE;
REPEAT
sys.GET(ptr, s);
INC(ptr, 4);
FOR i := 0 TO 31 DO
IF ~eoc THEN
IF i IN s THEN
setpix(Font, glyph.base, x, y, Font.width, 1X);
IF x > max THEN
max := x
END
ELSE
setpix(Font, glyph.base, x, y, Font.width, 0X)
END
END;
INC(x);
IF x = Font.width THEN
x := 0;
INC(y);
eoc := eoc OR (y = Font.height)
END
END
UNTIL eoc;
IF max = 0 THEN
max := Font.width DIV 3
END;
glyph.width := max;
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
Font.glyphs[0, c] := glyph;
bold_width := 1;
create_glyph(Font, glyph, Font.width + bold_width, Font.height);
_bold(Font, Font.glyphs[0, c].base, glyph.base, Font.glyphs[0, c].xsize, glyph.xsize, bold_width);
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max + bold_width;
Font.glyphs[1, c] := glyph;
create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3, Font.height);
FOR i := 0 TO Font.glyphs[0, c].xsize - 1 DO
FOR j := 0 TO Font.height - 1 DO
pix := getpix(Font, Font.glyphs[0, c].base, i, j, Font.glyphs[0, c].xsize);
IF pix = 1X THEN
setpix(Font, glyph.base, i + (Font.height - 1 - j) DIV 3, j, glyph.xsize, pix)
END
END
END;
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max;
Font.glyphs[2, c] := glyph;
create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3 + bold_width, Font.height);
_bold(Font, Font.glyphs[2, c].base, glyph.base, Font.glyphs[2, c].xsize, glyph.xsize, bold_width);
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max + bold_width;
Font.glyphs[3, c] := glyph;
END make_glyph;
PROCEDURE OutChar(Font: TFont_desc; c: INTEGER; x, y: INTEGER; buf: INTEGER; bpp32, smoothing: BOOLEAN; color, style: INTEGER): INTEGER;
VAR i, x0, y0, xsize, mem, xmax: INTEGER; r, g, b, r0, g0, b0: INTEGER; ch: CHAR; glyph: Glyph;
BEGIN
x0 := x;
y0 := y;
style := style MOD 4;
glyph := Font.glyphs[style, c];
xsize := glyph.xsize;
xmax := x0 + xsize;
mem := Font.mem + glyph.base;
getrgb(color, r0, g0, b0);
FOR i := mem TO mem + xsize * Font.height - 1 DO
sys.GET(i, ch);
IF ch = 1X THEN
pset(buf, x, y, color, bpp32);
ELSIF (ch = 2X) & smoothing THEN
getrgb(pget(buf, x, y, bpp32), r, g, b);
r := (r * 3 + r0) DIV 4;
g := (g * 3 + g0) DIV 4;
b := (b * 3 + b0) DIV 4;
pset(buf, x, y, rgb(r, g, b), bpp32)
END;
INC(x);
IF x = xmax THEN
x := x0;
INC(y)
END
END
RETURN glyph.width
END OutChar;
PROCEDURE hline(buf, x, y, width, color: INTEGER; bpp32: BOOLEAN);
VAR i: INTEGER;
BEGIN
FOR i := x TO x + width - 1 DO
pset(buf, i, y, color, bpp32)
END
END hline;
PROCEDURE TextWidth*(Font: TFont; str, length, params: INTEGER): INTEGER;
VAR res: INTEGER; c: CHAR;
BEGIN
res := 0;
params := params MOD 4;
IF Font # NIL THEN
sys.GET(str, c);
WHILE (length > 0) OR (length = -1) & (c # 0X) DO
INC(str);
res := res + Font.glyphs[params, ORD(c)].width;
IF length > 0 THEN
DEC(length)
END;
IF length # 0 THEN
sys.GET(str, c)
END
END
END
RETURN res
END TextWidth;
PROCEDURE TextHeight*(Font: TFont): INTEGER;
VAR res: INTEGER;
BEGIN
IF Font # NIL THEN
res := Font.height
ELSE
res := 0
END
RETURN res
END TextHeight;
PROCEDURE TextClipLeft(Font: TFont; str, length, params: INTEGER; VAR x: INTEGER): INTEGER;
VAR x1: INTEGER; c: CHAR;
BEGIN
params := params MOD 4;
sys.GET(str, c);
WHILE (length > 0) OR (length = -1) & (c # 0X) DO
INC(str);
x1 := x;
x := x + Font.glyphs[params, ORD(c)].width;
IF x > 0 THEN
length := 0;
END;
IF length > 0 THEN
DEC(length)
END;
IF length # 0 THEN
sys.GET(str, c)
END
END;
x := x1
RETURN str - 1
END TextClipLeft;
PROCEDURE TextOut*(Font: TFont; canvas, x, y, str, length, color, params: INTEGER);
VAR width, xsize, ysize, str1, n: INTEGER; c: CHAR; bpp32, smoothing, underline, strike: BOOLEAN;
BEGIN
IF Font # NIL THEN
sys.GET(canvas, xsize);
sys.GET(canvas + 4, ysize);
IF (y <= -TextHeight(Font)) OR (y >= ysize) THEN
length := 0
END;
IF length # 0 THEN
smoothing := 4 IN BITS(params);
bpp32 := 5 IN BITS(params);
underline := 2 IN BITS(params);
strike := 3 IN BITS(params);
str1 := TextClipLeft(Font, str, length, params, x);
n := str1 - str;
str := str1;
IF length >= n THEN
length := length - n
END;
sys.GET(str, c)
END;
WHILE (length > 0) OR (length = -1) & (c # 0X) DO
INC(str);
width := OutChar(Font^, ORD(c), x, y, canvas, bpp32, smoothing, color, params);
IF strike THEN
hline(canvas, x + ORD(1 IN BITS(params)) * ((Font.height DIV 2) DIV 3), y + Font.height DIV 2, width + 2, color, bpp32)
END;
IF underline THEN
hline(canvas, x, y + Font.height - 1, width + 2, color, bpp32)
END;
x := x + width;
IF x > xsize THEN
length := 0
END;
IF length > 0 THEN
DEC(length)
END;
IF length # 0 THEN
sys.GET(str, c)
END
END
END
END TextOut;
PROCEDURE SetSize*(_Font: TFont; font_size: INTEGER): BOOLEAN;
VAR temp, offset, fsize, i, memsize, mem: INTEGER;
c: CHAR; Font, Font2: TFont_desc;
BEGIN
offset := -1;
IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (_Font # NIL) THEN
Font := _Font^;
Font2 := Font;
temp := Font.data + (font_size - 8) * 4;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN
sys.GET(temp, offset);
IF offset # -1 THEN
Font.font_size := font_size;
INC(offset, 156);
offset := offset + Font.data;
IF (Font.data <= offset) & (offset <= Font.size + Font.data - 4) THEN
sys.GET(offset, fsize);
IF fsize > 256 + 6 THEN
temp := offset + fsize - 1;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 1) THEN
sys.GET(temp, c);
IF c # 0X THEN
Font.height := ORD(c);
DEC(temp);
sys.GET(temp, c);
IF c # 0X THEN
Font.width := ORD(c);
DEC(fsize, 6);
Font.char_size := fsize DIV 256;
IF fsize MOD 256 # 0 THEN
INC(Font.char_size)
END;
IF Font.char_size > 0 THEN
Font.font := offset + 4;
Font.mempos := 0;
memsize := (Font.width + 10) * Font.height * 1024;
mem := Font.mem;
Font.mem := KOSAPI.sysfunc3(68, 12, memsize);
IF Font.mem # 0 THEN
IF mem # 0 THEN
mem := KOSAPI.sysfunc3(68, 13, mem)
END;
zeromem(memsize DIV 4, Font.mem);
FOR i := 0 TO 255 DO
make_glyph(Font, i)
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
END;
ELSE
offset := -1
END;
IF offset # -1 THEN
_Font^ := Font
ELSE
_Font^ := Font2
END
END
RETURN offset # -1
END SetSize;
PROCEDURE Enabled*(Font: TFont; font_size: INTEGER): BOOLEAN;
VAR offset, temp: INTEGER;
BEGIN
offset := -1;
IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (Font # NIL) THEN
temp := Font.data + (font_size - 8) * 4;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN
sys.GET(temp, offset)
END
END
RETURN offset # -1
END Enabled;
PROCEDURE Destroy*(VAR Font: TFont);
BEGIN
IF Font # NIL THEN
IF Font.mem # 0 THEN
Font.mem := KOSAPI.sysfunc3(68, 13, Font.mem)
END;
IF Font.data # 0 THEN
Font.data := KOSAPI.sysfunc3(68, 13, Font.data)
END;
DISPOSE(Font)
END
END Destroy;
PROCEDURE LoadFont*(file_name: ARRAY OF CHAR): TFont;
VAR Font: TFont; data, size, n: INTEGER;
BEGIN
data := File.Load(file_name, size);
IF (data # 0) & (size > 156) THEN
NEW(Font);
Font.data := data;
Font.size := size;
Font.font_size := 0;
n := MIN_FONT_SIZE;
WHILE ~SetSize(Font, n) & (n <= MAX_FONT_SIZE) DO
INC(n)
END;
IF Font.font_size = 0 THEN
Destroy(Font)
END
ELSE
IF data # 0 THEN
data := KOSAPI.sysfunc3(68, 13, data)
END;
Font := NIL
END
RETURN Font
END LoadFont;
END kfonts.

/programs/develop/oberon07/lib/RVMxI/32/FPU.ob07
0,0 → 1,460
(*
BSD 2-Clause License
Copyright (c) 2020-2021, Anton Krotov
All rights reserved.
*)
MODULE FPU;
CONST
INF = 07F800000H;
NINF = 0FF800000H;
NAN = 07FC00000H;
PROCEDURE div2 (b, a: INTEGER): INTEGER;
VAR
n, e, r, s: INTEGER;
BEGIN
s := ORD(BITS(a) / BITS(b) - {0..30});
e := (a DIV 800000H) MOD 256 - (b DIV 800000H) MOD 256 + 127;
a := a MOD 800000H + 800000H;
b := b MOD 800000H + 800000H;
n := 800000H;
r := 0;
IF a < b THEN
a := a * 2;
DEC(e)
END;
WHILE (a > 0) & (n > 0) DO
IF a >= b THEN
INC(r, n);
DEC(a, b)
END;
a := a * 2;
n := n DIV 2
END;
IF e <= 0 THEN
e := 0;
r := 800000H;
s := 0
ELSIF e >= 255 THEN
e := 255;
r := 800000H
END
RETURN (r - 800000H) + e * 800000H + s
END div2;
PROCEDURE mul2 (b, a: INTEGER): INTEGER;
VAR
e, r, s: INTEGER;
BEGIN
s := ORD(BITS(a) / BITS(b) - {0..30});
e := (a DIV 800000H) MOD 256 + (b DIV 800000H) MOD 256 - 127;
a := a MOD 800000H + 800000H;
b := b MOD 800000H + 800000H;
r := a * (b MOD 256);
b := b DIV 256;
r := LSR(r, 8);
INC(r, a * (b MOD 256));
b := b DIV 256;
r := LSR(r, 8);
INC(r, a * (b MOD 256));
r := LSR(r, 7);
IF r >= 1000000H THEN
r := r DIV 2;
INC(e)
END;
IF e <= 0 THEN
e := 0;
r := 800000H;
s := 0
ELSIF e >= 255 THEN
e := 255;
r := 800000H
END
RETURN (r - 800000H) + e * 800000H + s
END mul2;
PROCEDURE add2 (b, a: INTEGER): INTEGER;
VAR
t, e, d: INTEGER;
BEGIN
e := (a DIV 800000H) MOD 256;
t := (b DIV 800000H) MOD 256;
d := e - t;
a := a MOD 800000H + 800000H;
b := b MOD 800000H + 800000H;
IF d > 0 THEN
IF d < 24 THEN
b := LSR(b, d)
ELSE
b := 0
END
ELSIF d < 0 THEN
IF d > -24 THEN
a := LSR(a, -d)
ELSE
a := 0
END;
e := t
END;
INC(a, b);
IF a >= 1000000H THEN
a := a DIV 2;
INC(e)
END;
IF e >= 255 THEN
e := 255;
a := 800000H
END
RETURN (a - 800000H) + e * 800000H
END add2;
PROCEDURE sub2 (b, a: INTEGER): INTEGER;
VAR
t, e, d, s: INTEGER;
BEGIN
e := (a DIV 800000H) MOD 256;
t := (b DIV 800000H) MOD 256;
a := a MOD 800000H + 800000H;
b := b MOD 800000H + 800000H;
d := e - t;
IF (d > 0) OR (d = 0) & (a >= b) THEN
s := 0
ELSE
e := t;
d := -d;
t := a;
a := b;
b := t;
s := 80000000H
END;
IF d > 0 THEN
IF d < 24 THEN
b := LSR(b, d)
ELSE
b := 0
END
END;
DEC(a, b);
IF a = 0 THEN
e := 0;
a := 800000H;
s := 0
ELSE
WHILE a < 800000H DO
a := a * 2;
DEC(e)
END
END;
IF e <= 0 THEN
e := 0;
a := 800000H;
s := 0
END
RETURN (a - 800000H) + e * 800000H + s
END sub2;
PROCEDURE zero (VAR x: INTEGER);
BEGIN
IF LSR(LSL(x, 1), 24) = 0 THEN
x := 0
END
END zero;
PROCEDURE isNaN (a: INTEGER): BOOLEAN;
RETURN (a > INF) OR (a < 0) & (a > NINF)
END isNaN;
PROCEDURE isInf (a: INTEGER): BOOLEAN;
RETURN LSL(a, 1) = 0FF000000H
END isInf;
PROCEDURE isNormal (a, b: INTEGER): BOOLEAN;
RETURN (LSR(LSL(a, 1), 24) # 255) & (LSR(LSL(a, 1), 24) # 0) &
(LSR(LSL(b, 1), 24) # 255) & (LSR(LSL(b, 1), 24) # 0)
END isNormal;
PROCEDURE add* (b, a: INTEGER): INTEGER;
VAR
r: INTEGER;
BEGIN
zero(a); zero(b);
IF isNormal(a, b) THEN
IF a > 0 THEN
IF b > 0 THEN
r := add2(b, a)
ELSE
r := sub2(b, a)
END
ELSE
IF b > 0 THEN
r := sub2(a, b)
ELSE
r := add2(b, a) + 80000000H
END
END
ELSIF isNaN(a) OR isNaN(b) THEN
r := NAN
ELSIF isInf(a) & isInf(b) THEN
IF a = b THEN
r := a
ELSE
r := NAN
END
ELSIF isInf(a) THEN
r := a
ELSIF isInf(b) THEN
r := b
ELSIF a = 0 THEN
r := b
ELSIF b = 0 THEN
r := a
END
RETURN r
END add;
PROCEDURE sub* (b, a: INTEGER): INTEGER;
VAR
r: INTEGER;
BEGIN
zero(a); zero(b);
IF isNormal(a, b) THEN
IF a > 0 THEN
IF b > 0 THEN
r := sub2(b, a)
ELSE
r := add2(b, a)
END
ELSE
IF b > 0 THEN
r := add2(b, a) + 80000000H
ELSE
r := sub2(a, b)
END
END
ELSIF isNaN(a) OR isNaN(b) THEN
r := NAN
ELSIF isInf(a) & isInf(b) THEN
IF a # b THEN
r := a
ELSE
r := NAN
END
ELSIF isInf(a) THEN
r := a
ELSIF isInf(b) THEN
r := INF + ORD(BITS(b) / {31} - {0..30})
ELSIF (a = 0) & (b = 0) THEN
r := 0
ELSIF a = 0 THEN
r := ORD(BITS(b) / {31})
ELSIF b = 0 THEN
r := a
END
RETURN r
END sub;
PROCEDURE mul* (b, a: INTEGER): INTEGER;
VAR
r: INTEGER;
BEGIN
zero(a); zero(b);
IF isNormal(a, b) THEN
r := mul2(b, a)
ELSIF isNaN(a) OR isNaN(b) OR (isInf(a) & (b = 0)) OR (isInf(b) & (a = 0)) THEN
r := NAN
ELSIF isInf(a) OR isInf(b) THEN
r := INF + ORD(BITS(a) / BITS(b) - {0..30})
ELSIF (a = 0) OR (b = 0) THEN
r := 0
END
RETURN r
END mul;
PROCEDURE _div* (b, a: INTEGER): INTEGER;
VAR
r: INTEGER;
BEGIN
zero(a); zero(b);
IF isNormal(a, b) THEN
r := div2(b, a)
ELSIF isNaN(a) OR isNaN(b) OR isInf(a) & isInf(b) THEN
r := NAN
ELSIF isInf(a) THEN
r := INF + ORD(BITS(a) / BITS(b) - {0..30})
ELSIF isInf(b) THEN
r := 0
ELSIF a = 0 THEN
IF b = 0 THEN
r := NAN
ELSE
r := 0
END
ELSIF b = 0 THEN
IF a > 0 THEN
r := INF
ELSE
r := NINF
END
END
RETURN r
END _div;
PROCEDURE cmp* (op, b, a: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
zero(a); zero(b);
IF isNaN(a) OR isNaN(b) THEN
res := op = 1
ELSE
IF (a < 0) & (b < 0) THEN
INC(op, 6)
END;
CASE op OF
|0, 6: res := a = b
|1, 7: res := a # b
|2, 10: res := a < b
|3, 11: res := a <= b
|4, 8: res := a > b
|5, 9: res := a >= b
END
END
RETURN res
END cmp;
PROCEDURE flt* (x: INTEGER): INTEGER;
VAR
n, y, s: INTEGER;
BEGIN
IF x = 0 THEN
s := 0;
x := 800000H;
n := -126
ELSIF x = 80000000H THEN
s := 80000000H;
x := 800000H;
n := 32
ELSE
IF x < 0 THEN
s := 80000000H;
x := -x
ELSE
s := 0
END;
n := 0;
y := x;
WHILE y > 0 DO
y := y DIV 2;
INC(n)
END;
IF n > 24 THEN
x := LSR(x, n - 24)
ELSE
x := LSL(x, 24 - n)
END
END
RETURN (x - 800000H) + (n + 126) * 800000H + s
END flt;
PROCEDURE floor* (x: INTEGER): INTEGER;
VAR
r, e: INTEGER;
BEGIN
zero(x);
e := (x DIV 800000H) MOD 256 - 127;
r := x MOD 800000H + 800000H;
IF (0 <= e) & (e <= 22) THEN
r := LSR(r, 23 - e) + ORD((x < 0) & (LSL(r, e + 9) # 0))
ELSIF (23 <= e) & (e <= 54) THEN
r := LSL(r, e - 23)
ELSIF (e < 0) & (x < 0) THEN
r := 1
ELSE
r := 0
END;
IF x < 0 THEN
r := -r
END
RETURN r
END floor;
END FPU.

/programs/develop/oberon07/lib/RVMxI/32/HOST.ob07
0,0 → 1,185
(*
BSD 2-Clause License
Copyright (c) 2020-2021, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, Trap;
CONST
$IF (host_linux)
slash* = "/";
eol* = 0AX;
$ELSE
slash* = "\";
eol* = 0DX + 0AX;
$END
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
VAR
maxreal*: REAL;
PROCEDURE syscall0 (fn: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall0;
PROCEDURE syscall1 (fn, p1: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall1;
PROCEDURE syscall2 (fn, p1, p2: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall2;
PROCEDURE syscall3 (fn, p1, p2, p3: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall3;
PROCEDURE syscall4 (fn, p1, p2, p3, p4: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall4;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
code := syscall1(0, code)
END ExitProcess;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
a: INTEGER;
BEGIN
a := syscall2(1, LEN(path), SYSTEM.ADR(path[0]))
END GetCurrentDirectory;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
n := syscall3(2, n, LEN(s), SYSTEM.ADR(s[0]))
END GetArg;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
RETURN syscall4(3, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes)
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN syscall4(4, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes)
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN syscall2(5, LEN(FName), SYSTEM.ADR(FName[0]))
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
F := syscall1(6, F)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN syscall2(7, LEN(FName), SYSTEM.ADR(FName[0]))
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
VAR
a: INTEGER;
BEGIN
a := syscall2(12, LEN(FName), SYSTEM.ADR(FName[0]))
END chmod;
PROCEDURE OutChar* (c: CHAR);
VAR
a: INTEGER;
BEGIN
a := syscall1(8, ORD(c))
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
RETURN syscall0(9)
END GetTickCount;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN syscall2(11, LEN(path), SYSTEM.ADR(path[0])) # 0
END isRelative;
PROCEDURE UnixTime* (): INTEGER;
RETURN syscall0(10)
END UnixTime;
PROCEDURE s2d (x: INTEGER; VAR h, l: INTEGER);
VAR
s, e, f: INTEGER;
BEGIN
s := ASR(x, 31) MOD 2;
f := x MOD 800000H;
e := (x DIV 800000H) MOD 256;
IF e = 255 THEN
e := 2047
ELSE
INC(e, 896)
END;
h := LSL(s, 31) + LSL(e, 20) + (f DIV 8);
l := (f MOD 8) * 20000000H
END s2d;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
i: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), i)
RETURN i
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
s2d(d2s(x), b, a)
RETURN a
END splitf;
BEGIN
maxreal := 1.9;
PACK(maxreal, 127)
END HOST.

/programs/develop/oberon07/lib/RVMxI/32/Out.ob07
0,0 → 1,273
(*
BSD 2-Clause License
Copyright (c) 2016, 2018, 2020, Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT HOST, SYSTEM;
PROCEDURE Char* (c: CHAR);
BEGIN
HOST.OutChar(c)
END Char;
PROCEDURE String* (s: ARRAY OF CHAR);
VAR
i, n: INTEGER;
BEGIN
n := LENGTH(s) - 1;
FOR i := 0 TO n DO
Char(s[i])
END
END String;
PROCEDURE Int* (x, width: INTEGER);
VAR
i, a: INTEGER;
str: ARRAY 12 OF CHAR;
BEGIN
IF x = 80000000H THEN
COPY("-2147483648", str);
DEC(width, 11)
ELSE
i := 0;
IF x < 0 THEN
x := -x;
i := 1;
str[0] := "-"
END;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
DEC(width, i);
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END;
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
String(str)
END Int;
PROCEDURE Inf (x: REAL; width: INTEGER);
VAR
s: ARRAY 5 OF CHAR;
BEGIN
DEC(width, 4);
IF x # x THEN
s := " Nan"
ELSIF x = SYSTEM.INF() THEN
s := "+Inf"
ELSIF x = -SYSTEM.INF() THEN
s := "-Inf"
END;
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
String(s)
END Inf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
PROCEDURE unpk10 (VAR x: REAL; VAR n: INTEGER);
VAR
a, b: REAL;
BEGIN
ASSERT(x > 0.0);
n := 0;
WHILE x < 1.0 DO
x := x * 10.0;
DEC(n)
END;
a := 10.0;
b := 1.0;
WHILE a <= x DO
b := a;
a := a * 10.0;
INC(n)
END;
x := x / b
END unpk10;
PROCEDURE _Real (x: REAL; width: INTEGER);
VAR
n, k, p: INTEGER;
BEGIN
p := MIN(MAX(width - 7, 1), 10);
width := width - p - 7;
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
IF x < 0.0 THEN
Char("-");
x := -x
ELSE
Char(20X)
END;
unpk10(x, n);
k := FLOOR(x);
Char(CHR(k + 30H));
Char(".");
WHILE p > 0 DO
x := (x - FLT(k)) * 10.0;
k := FLOOR(x);
Char(CHR(k + 30H));
DEC(p)
END;
Char("E");
IF n >= 0 THEN
Char("+")
ELSE
Char("-")
END;
n := ABS(n);
Char(CHR(n DIV 10 + 30H));
Char(CHR(n MOD 10 + 30H))
END _Real;
PROCEDURE Real* (x: REAL; width: INTEGER);
BEGIN
IF (x # x) OR (ABS(x) = SYSTEM.INF()) THEN
Inf(x, width)
ELSIF x = 0.0 THEN
WHILE width > 17 DO
Char(20X);
DEC(width)
END;
DEC(width, 8);
String(" 0.0");
WHILE width > 0 DO
Char("0");
DEC(width)
END;
String("E+00")
ELSE
_Real(x, width)
END
END Real;
PROCEDURE _FixReal (x: REAL; width, p: INTEGER);
VAR
n, k: INTEGER;
minus: BOOLEAN;
BEGIN
minus := x < 0.0;
IF minus THEN
x := -x
END;
unpk10(x, n);
DEC(width, 3 + MAX(p, 0) + MAX(n, 0));
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
IF minus THEN
Char("-")
ELSE
Char(20X)
END;
IF n < 0 THEN
INC(n);
Char("0");
Char(".");
WHILE (n < 0) & (p > 0) DO
Char("0");
INC(n);
DEC(p)
END
ELSE
WHILE n >= 0 DO
k := FLOOR(x);
Char(CHR(k + 30H));
x := (x - FLT(k)) * 10.0;
DEC(n)
END;
Char(".")
END;
WHILE p > 0 DO
k := FLOOR(x);
Char(CHR(k + 30H));
x := (x - FLT(k)) * 10.0;
DEC(p)
END
END _FixReal;
PROCEDURE FixReal* (x: REAL; width, p: INTEGER);
BEGIN
IF (x # x) OR (ABS(x) = SYSTEM.INF()) THEN
Inf(x, width)
ELSIF x = 0.0 THEN
DEC(width, 3 + MAX(p, 0));
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
String(" 0.");
WHILE p > 0 DO
Char("0");
DEC(p)
END
ELSE
_FixReal(x, width, p)
END
END FixReal;
PROCEDURE Open*;
END Open;
END Out.

/programs/develop/oberon07/lib/RVMxI/32/RTL.ob07
0,0 → 1,411
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, F := FPU, Trap;
CONST
bit_depth = 32;
maxint = 7FFFFFFFH;
minint = 80000000H;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
VAR
Heap, Types, TypesCount: INTEGER;
PROCEDURE _error* (modnum, _module, err, line: INTEGER);
BEGIN
Trap.trap(modnum, _module, err, line)
END _error;
PROCEDURE _fmul* (b, a: INTEGER): INTEGER;
RETURN F.mul(b, a)
END _fmul;
PROCEDURE _fdiv* (b, a: INTEGER): INTEGER;
RETURN F._div(b, a)
END _fdiv;
PROCEDURE _fdivi* (b, a: INTEGER): INTEGER;
RETURN F._div(a, b)
END _fdivi;
PROCEDURE _fadd* (b, a: INTEGER): INTEGER;
RETURN F.add(b, a)
END _fadd;
PROCEDURE _fsub* (b, a: INTEGER): INTEGER;
RETURN F.sub(b, a)
END _fsub;
PROCEDURE _fsubi* (b, a: INTEGER): INTEGER;
RETURN F.sub(a, b)
END _fsubi;
PROCEDURE _fcmp* (op, b, a: INTEGER): BOOLEAN;
RETURN F.cmp(op, b, a)
END _fcmp;
PROCEDURE _floor* (x: INTEGER): INTEGER;
RETURN F.floor(x)
END _floor;
PROCEDURE _flt* (x: INTEGER): INTEGER;
RETURN F.flt(x)
END _flt;
PROCEDURE _pack* (n: INTEGER; VAR x: SET);
BEGIN
n := LSL((LSR(ORD(x), 23) MOD 256 + n) MOD 256, 23);
x := x - {23..30} + BITS(n)
END _pack;
PROCEDURE _unpk* (VAR n: INTEGER; VAR x: SET);
BEGIN
n := LSR(ORD(x), 23) MOD 256 - 127;
x := x - {30} + {23..29}
END _unpk;
PROCEDURE _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 _set* (b, a: INTEGER): INTEGER;
BEGIN
IF (a <= b) & (a <= MAX_SET) & (b >= 0) THEN
IF b > MAX_SET THEN
b := MAX_SET
END;
IF a < 0 THEN
a := 0
END;
a := LSR(ASR(minint, b - a), MAX_SET - b)
ELSE
a := 0
END
RETURN a
END _set;
PROCEDURE _set1* (a: INTEGER): INTEGER;
BEGIN
IF ASR(a, 5) = 0 THEN
a := LSL(1, a)
ELSE
a := 0
END
RETURN a
END _set1;
PROCEDURE _length* (len, str: INTEGER): INTEGER;
VAR
c: CHAR;
res: INTEGER;
BEGIN
res := 0;
REPEAT
SYSTEM.GET(str, c);
INC(str);
DEC(len);
INC(res)
UNTIL (len = 0) OR (c = 0X);
RETURN res - ORD(c = 0X)
END _length;
PROCEDURE _move* (bytes, dest, source: INTEGER);
VAR
b: BYTE;
i: INTEGER;
BEGIN
IF (source MOD WORD = 0) & (dest MOD WORD = 0) THEN
WHILE bytes >= WORD DO
SYSTEM.GET(source, i);
SYSTEM.PUT(dest, i);
INC(source, WORD);
INC(dest, WORD);
DEC(bytes, WORD)
END
END;
WHILE bytes > 0 DO
SYSTEM.GET(source, b);
SYSTEM.PUT8(dest, b);
INC(source);
INC(dest);
DEC(bytes)
END
END _move;
PROCEDURE _lengthw* (len, str: INTEGER): INTEGER;
VAR
c: WCHAR;
res: INTEGER;
BEGIN
res := 0;
REPEAT
SYSTEM.GET(str, c);
INC(str, 2);
DEC(len);
INC(res)
UNTIL (len = 0) OR (c = 0X);
RETURN res - ORD(c = 0X)
END _lengthw;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := minint;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a);
SYSTEM.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
res := 0;
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE _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 strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := minint;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a, 2);
SYSTEM.GET(b, B); INC(b, 2);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
res := 0;
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE _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 _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 _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE _new* (t, size: INTEGER; VAR p: INTEGER);
VAR
ptr: INTEGER;
BEGIN
ptr := Heap;
IF ptr + size < Trap.sp() - 64 THEN
INC(Heap, size);
p := ptr + WORD;
SYSTEM.PUT(ptr, t);
INC(ptr, WORD);
DEC(size, WORD);
WHILE size > 0 DO
SYSTEM.PUT(ptr, 0);
INC(ptr, WORD);
DEC(size, WORD)
END
ELSE
p := 0
END
END _new;
PROCEDURE _guard* (t, p: INTEGER): BOOLEAN;
VAR
_type: INTEGER;
BEGIN
SYSTEM.GET(p, p);
IF p # 0 THEN
SYSTEM.GET(p - WORD, _type);
WHILE (_type # t) & (_type # 0) DO
SYSTEM.GET(Types + _type * WORD, _type)
END
ELSE
_type := t
END
RETURN _type = t
END _guard;
PROCEDURE _is* (t, p: INTEGER): BOOLEAN;
VAR
_type: INTEGER;
BEGIN
_type := 0;
IF p # 0 THEN
SYSTEM.GET(p - WORD, _type);
WHILE (_type # t) & (_type # 0) DO
SYSTEM.GET(Types + _type * WORD, _type)
END
END
RETURN _type = t
END _is;
PROCEDURE _guardrec* (t0, t1: INTEGER): BOOLEAN;
BEGIN
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(Types + t1 * WORD, t1)
END
RETURN t1 = t0
END _guardrec;
PROCEDURE _init* (tcount, heap, types: INTEGER);
BEGIN
Heap := heap;
TypesCount := tcount;
Types := types
END _init;
END RTL.

/programs/develop/oberon07/lib/RVMxI/32/Trap.ob07
0,0 → 1,133
(*
BSD 2-Clause License
Copyright (c) 2020-2021, Anton Krotov
All rights reserved.
*)
MODULE Trap;
IMPORT SYSTEM;
CONST
SP = 4;
PROCEDURE [code] sp* (): INTEGER
22, 0, SP; (* MOV R0, SP *)
PROCEDURE [code] syscall* (ptr: INTEGER)
22, 0, SP, (* MOV R0, SP *)
27, 0, 4, (* ADD R0, 4 *)
9, 0, 0, (* LDW R0, R0 *)
67, 0, 0; (* SYSCALL R0 *)
PROCEDURE Char (c: CHAR);
VAR
a: ARRAY 2 OF INTEGER;
BEGIN
a[0] := 8;
a[1] := ORD(c);
syscall(SYSTEM.ADR(a[0]))
END Char;
PROCEDURE String (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE s[i] # 0X DO
Char(s[i]);
INC(i)
END
END String;
PROCEDURE PString (ptr: INTEGER);
VAR
c: CHAR;
BEGIN
SYSTEM.GET(ptr, c);
WHILE c # 0X DO
Char(c);
INC(ptr);
SYSTEM.GET(ptr, c)
END
END PString;
PROCEDURE Ln;
BEGIN
String(0DX + 0AX)
END Ln;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END IntToStr;
PROCEDURE Int (x: INTEGER);
VAR
s: ARRAY 32 OF CHAR;
BEGIN
IntToStr(x, s);
String(s)
END Int;
PROCEDURE trap* (modnum, _module, err, line: INTEGER);
VAR
s: ARRAY 32 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;
Ln;
String("error ("); Int(err); String("): "); String(s); Ln;
String("module: "); PString(_module); Ln;
String("line: "); Int(line); Ln;
SYSTEM.CODE(0, 0, 0) (* STOP *)
END trap;
END Trap.

/programs/develop/oberon07/lib/RVMxI/64/HOST.ob07
0,0 → 1,201
(*
BSD 2-Clause License
Copyright (c) 2020-2021, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, Trap;
CONST
$IF (host_linux)
slash* = "/";
eol* = 0AX;
$ELSE
slash* = "\";
eol* = 0DX + 0AX;
$END
bit_depth* = 64;
maxint* = ROR(-2, 1);
minint* = ROR(1, 1);
VAR
maxreal*: REAL;
PROCEDURE syscall0 (fn: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall0;
PROCEDURE syscall1 (fn, p1: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall1;
PROCEDURE syscall2 (fn, p1, p2: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall2;
PROCEDURE syscall3 (fn, p1, p2, p3: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall3;
PROCEDURE syscall4 (fn, p1, p2, p3, p4: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall4;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
code := syscall1(0, code)
END ExitProcess;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
a: INTEGER;
BEGIN
a := syscall2(1, LEN(path), SYSTEM.ADR(path[0]))
END GetCurrentDirectory;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
n := syscall3(2, n, LEN(s), SYSTEM.ADR(s[0]))
END GetArg;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
RETURN syscall4(3, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes)
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN syscall4(4, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes)
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN syscall2(5, LEN(FName), SYSTEM.ADR(FName[0]))
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
F := syscall1(6, F)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN syscall2(7, LEN(FName), SYSTEM.ADR(FName[0]))
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
VAR
a: INTEGER;
BEGIN
a := syscall2(12, LEN(FName), SYSTEM.ADR(FName[0]))
END chmod;
PROCEDURE OutChar* (c: CHAR);
VAR
a: INTEGER;
BEGIN
a := syscall1(8, ORD(c))
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
RETURN syscall0(9)
END GetTickCount;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN syscall2(11, LEN(path), SYSTEM.ADR(path[0])) # 0
END isRelative;
PROCEDURE UnixTime* (): INTEGER;
RETURN syscall0(10)
END UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
a := 0;
b := 0;
SYSTEM.GET32(SYSTEM.ADR(x), a);
SYSTEM.GET32(SYSTEM.ADR(x) + 4, b);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
e := splitf(x, l, 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;
BEGIN
maxreal := 1.9;
PACK(maxreal, 1023)
END HOST.

/programs/develop/oberon07/lib/RVMxI/64/Out.ob07
0,0 → 1,288
(*
BSD 2-Clause License
Copyright (c) 2016, 2018, 2020-2021 Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT HOST, SYSTEM;
PROCEDURE Char* (c: CHAR);
BEGIN
HOST.OutChar(c)
END Char;
PROCEDURE String* (s: ARRAY OF CHAR);
VAR
i, n: INTEGER;
BEGIN
n := LENGTH(s) - 1;
FOR i := 0 TO n DO
Char(s[i])
END
END String;
PROCEDURE Int* (x, width: INTEGER);
VAR
i, a: INTEGER;
str: ARRAY 21 OF CHAR;
BEGIN
IF x = ROR(1, 1) THEN
str := "-9223372036854775808";
DEC(width, 20)
ELSE
i := 0;
IF x < 0 THEN
x := -x;
i := 1;
str[0] := "-"
END;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
DEC(width, i);
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END;
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
String(str)
END Int;
PROCEDURE IsNan (x: REAL): BOOLEAN;
CONST
INF = LSR(ASR(ROR(1, 1), 10), 1);
NINF = ASR(ASR(ROR(1, 1), 10), 1);
VAR
a: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), a)
RETURN (a > INF) OR (a < 0) & (a > NINF)
END IsNan;
PROCEDURE Inf (x: REAL; width: INTEGER);
VAR
s: ARRAY 5 OF CHAR;
BEGIN
DEC(width, 4);
IF IsNan(x) THEN
s := " Nan"
ELSIF x = SYSTEM.INF() THEN
s := "+Inf"
ELSIF x = -SYSTEM.INF() THEN
s := "-Inf"
END;
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
String(s)
END Inf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
PROCEDURE unpk10 (VAR x: REAL; VAR n: INTEGER);
VAR
a, b: REAL;
BEGIN
ASSERT(x > 0.0);
n := 0;
WHILE x < 1.0 DO
x := x * 10.0;
DEC(n)
END;
a := 10.0;
b := 1.0;
WHILE a <= x DO
b := a;
a := a * 10.0;
INC(n)
END;
x := x / b
END unpk10;
PROCEDURE _Real (x: REAL; width: INTEGER);
VAR
n, k, p: INTEGER;
BEGIN
p := MIN(MAX(width - 8, 1), 15);
width := width - p - 8;
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
IF x < 0.0 THEN
Char("-");
x := -x
ELSE
Char(20X)
END;
unpk10(x, n);
k := FLOOR(x);
Char(CHR(k + 30H));
Char(".");
WHILE p > 0 DO
x := (x - FLT(k)) * 10.0;
k := FLOOR(x);
Char(CHR(k + 30H));
DEC(p)
END;
Char("E");
IF n >= 0 THEN
Char("+")
ELSE
Char("-")
END;
n := ABS(n);
Char(CHR(n DIV 100 + 30H)); n := n MOD 100;
Char(CHR(n DIV 10 + 30H));
Char(CHR(n MOD 10 + 30H))
END _Real;
PROCEDURE Real* (x: REAL; width: INTEGER);
BEGIN
IF IsNan(x) OR (ABS(x) = SYSTEM.INF()) THEN
Inf(x, width)
ELSIF x = 0.0 THEN
WHILE width > 23 DO
Char(20X);
DEC(width)
END;
DEC(width, 9);
String(" 0.0");
WHILE width > 0 DO
Char("0");
DEC(width)
END;
String("E+000")
ELSE
_Real(x, width)
END
END Real;
PROCEDURE _FixReal (x: REAL; width, p: INTEGER);
VAR
n, k: INTEGER;
minus: BOOLEAN;
BEGIN
minus := x < 0.0;
IF minus THEN
x := -x
END;
unpk10(x, n);
DEC(width, 3 + MAX(p, 0) + MAX(n, 0));
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
IF minus THEN
Char("-")
ELSE
Char(20X)
END;
IF n < 0 THEN
INC(n);
Char("0");
Char(".");
WHILE (n < 0) & (p > 0) DO
Char("0");
INC(n);
DEC(p)
END
ELSE
WHILE n >= 0 DO
k := FLOOR(x);
Char(CHR(k + 30H));
x := (x - FLT(k)) * 10.0;
DEC(n)
END;
Char(".")
END;
WHILE p > 0 DO
k := FLOOR(x);
Char(CHR(k + 30H));
x := (x - FLT(k)) * 10.0;
DEC(p)
END
END _FixReal;
PROCEDURE FixReal* (x: REAL; width, p: INTEGER);
BEGIN
IF IsNan(x) OR (ABS(x) = SYSTEM.INF()) THEN
Inf(x, width)
ELSIF x = 0.0 THEN
DEC(width, 3 + MAX(p, 0));
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
String(" 0.");
WHILE p > 0 DO
Char("0");
DEC(p)
END
ELSE
_FixReal(x, width, p)
END
END FixReal;
PROCEDURE Open*;
END Open;
END Out.

/programs/develop/oberon07/lib/RVMxI/64/RTL.ob07
0,0 → 1,432
(*
BSD 2-Clause License
Copyright (c) 2019-2021, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, Trap;
CONST
bit_depth = 64;
maxint = ROR(-2, 1);
minint = ROR(1, 1);
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
VAR
Heap, Types, TypesCount: INTEGER;
PROCEDURE _error* (modnum, _module, err, line: INTEGER);
BEGIN
Trap.trap(modnum, _module, err, line)
END _error;
PROCEDURE syscall1 (fn, p1: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall1;
PROCEDURE syscall2 (fn, p1, p2: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall2;
PROCEDURE syscall3 (fn, p1, p2, p3: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall3;
PROCEDURE _fmul* (b, a: INTEGER): INTEGER;
RETURN syscall2(100, b, a)
END _fmul;
PROCEDURE _fdiv* (b, a: INTEGER): INTEGER;
RETURN syscall2(101, b, a)
END _fdiv;
PROCEDURE _fdivi* (b, a: INTEGER): INTEGER;
RETURN syscall2(101, a, b)
END _fdivi;
PROCEDURE _fadd* (b, a: INTEGER): INTEGER;
RETURN syscall2(102, b, a)
END _fadd;
PROCEDURE _fsub* (b, a: INTEGER): INTEGER;
RETURN syscall2(103, b, a)
END _fsub;
PROCEDURE _fsubi* (b, a: INTEGER): INTEGER;
RETURN syscall2(103, a, b)
END _fsubi;
PROCEDURE _fcmp* (op, b, a: INTEGER): BOOLEAN;
RETURN syscall3(104, op, b, a) # 0
END _fcmp;
PROCEDURE _floor* (x: INTEGER): INTEGER;
RETURN syscall1(105, x)
END _floor;
PROCEDURE _flt* (x: INTEGER): INTEGER;
RETURN syscall1(106, x)
END _flt;
PROCEDURE _pack* (n: INTEGER; VAR x: SET);
BEGIN
n := LSL((LSR(ORD(x), 52) MOD 2048 + n) MOD 2048, 52);
x := x - {52..62} + BITS(n)
END _pack;
PROCEDURE _unpk* (VAR n: INTEGER; VAR x: SET);
BEGIN
n := LSR(ORD(x), 52) MOD 2048 - 1023;
x := x - {62} + {52..61}
END _unpk;
PROCEDURE _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 _set* (b, a: INTEGER): INTEGER;
BEGIN
IF (a <= b) & (a <= MAX_SET) & (b >= 0) THEN
IF b > MAX_SET THEN
b := MAX_SET
END;
IF a < 0 THEN
a := 0
END;
a := LSR(ASR(minint, b - a), MAX_SET - b)
ELSE
a := 0
END
RETURN a
END _set;
PROCEDURE _set1* (a: INTEGER): INTEGER;
BEGIN
IF ASR(a, 6) = 0 THEN
a := LSL(1, a)
ELSE
a := 0
END
RETURN a
END _set1;
PROCEDURE _length* (len, str: INTEGER): INTEGER;
VAR
c: CHAR;
res: INTEGER;
BEGIN
res := 0;
REPEAT
SYSTEM.GET(str, c);
INC(str);
DEC(len);
INC(res)
UNTIL (len = 0) OR (c = 0X);
RETURN res - ORD(c = 0X)
END _length;
PROCEDURE _move* (bytes, dest, source: INTEGER);
VAR
b: BYTE;
i: INTEGER;
BEGIN
IF (source MOD WORD = 0) & (dest MOD WORD = 0) THEN
WHILE bytes >= WORD DO
SYSTEM.GET(source, i);
SYSTEM.PUT(dest, i);
INC(source, WORD);
INC(dest, WORD);
DEC(bytes, WORD)
END
END;
WHILE bytes > 0 DO
SYSTEM.GET(source, b);
SYSTEM.PUT8(dest, b);
INC(source);
INC(dest);
DEC(bytes)
END
END _move;
PROCEDURE _lengthw* (len, str: INTEGER): INTEGER;
VAR
c: WCHAR;
res: INTEGER;
BEGIN
res := 0;
REPEAT
SYSTEM.GET(str, c);
INC(str, 2);
DEC(len);
INC(res)
UNTIL (len = 0) OR (c = 0X);
RETURN res - ORD(c = 0X)
END _lengthw;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := minint;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a);
SYSTEM.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
res := 0;
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE _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 strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := minint;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a, 2);
SYSTEM.GET(b, B); INC(b, 2);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
res := 0;
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE _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 _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 _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE _new* (t, size: INTEGER; VAR p: INTEGER);
VAR
ptr: INTEGER;
BEGIN
ptr := Heap;
IF ptr + size < Trap.sp() - 128 THEN
INC(Heap, size);
p := ptr + WORD;
SYSTEM.PUT(ptr, t);
INC(ptr, WORD);
DEC(size, WORD);
WHILE size > 0 DO
SYSTEM.PUT(ptr, 0);
INC(ptr, WORD);
DEC(size, WORD)
END
ELSE
p := 0
END
END _new;
PROCEDURE _guard* (t, p: INTEGER): BOOLEAN;
VAR
_type: INTEGER;
BEGIN
SYSTEM.GET(p, p);
IF p # 0 THEN
SYSTEM.GET(p - WORD, _type);
WHILE (_type # t) & (_type # 0) DO
SYSTEM.GET(Types + _type * WORD, _type)
END
ELSE
_type := t
END
RETURN _type = t
END _guard;
PROCEDURE _is* (t, p: INTEGER): BOOLEAN;
VAR
_type: INTEGER;
BEGIN
_type := 0;
IF p # 0 THEN
SYSTEM.GET(p - WORD, _type);
WHILE (_type # t) & (_type # 0) DO
SYSTEM.GET(Types + _type * WORD, _type)
END
END
RETURN _type = t
END _is;
PROCEDURE _guardrec* (t0, t1: INTEGER): BOOLEAN;
BEGIN
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(Types + t1 * WORD, t1)
END
RETURN t1 = t0
END _guardrec;
PROCEDURE _init* (tcount, heap, types: INTEGER);
BEGIN
Heap := heap;
TypesCount := tcount;
Types := types
END _init;
END RTL.

/programs/develop/oberon07/lib/RVMxI/64/Trap.ob07
0,0 → 1,133
(*
BSD 2-Clause License
Copyright (c) 2020-2021, Anton Krotov
All rights reserved.
*)
MODULE Trap;
IMPORT SYSTEM;
CONST
SP = 4;
PROCEDURE [code] sp* (): INTEGER
22, 0, SP; (* MOV R0, SP *)
PROCEDURE [code] syscall* (ptr: INTEGER)
22, 0, SP, (* MOV R0, SP *)
27, 0, 8, (* ADD R0, 8 *)
16, 0, 0, (* LDD R0, R0 *)
67, 0, 0; (* SYSCALL R0 *)
PROCEDURE Char (c: CHAR);
VAR
a: ARRAY 2 OF INTEGER;
BEGIN
a[0] := 8;
a[1] := ORD(c);
syscall(SYSTEM.ADR(a[0]))
END Char;
PROCEDURE String (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE s[i] # 0X DO
Char(s[i]);
INC(i)
END
END String;
PROCEDURE PString (ptr: INTEGER);
VAR
c: CHAR;
BEGIN
SYSTEM.GET(ptr, c);
WHILE c # 0X DO
Char(c);
INC(ptr);
SYSTEM.GET(ptr, c)
END
END PString;
PROCEDURE Ln;
BEGIN
String(0DX + 0AX)
END Ln;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END IntToStr;
PROCEDURE Int (x: INTEGER);
VAR
s: ARRAY 32 OF CHAR;
BEGIN
IntToStr(x, s);
String(s)
END Int;
PROCEDURE trap* (modnum, _module, err, line: INTEGER);
VAR
s: ARRAY 32 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;
Ln;
String("error ("); Int(err); String("): "); String(s); Ln;
String("module: "); PString(_module); Ln;
String("line: "); Int(line); Ln;
SYSTEM.CODE(0, 0, 0) (* STOP *)
END trap;
END Trap.

/programs/develop/oberon07/lib/Math/CMath.ob07
0,0 → 1,462
(* ***********************************************
Модуль работы с комплексными числами.
Вадим Исаев, 2020
Module for complex numbers.
Vadim Isaev, 2020
*************************************************** *)
MODULE CMath;
IMPORT Math, Out;
TYPE
complex* = POINTER TO RECORD
re*: REAL;
im*: REAL
END;
VAR
result: complex;
i* : complex;
_0*: complex;
(* Инициализация комплексного числа.
Init complex number. *)
PROCEDURE CInit* (re : REAL; im: REAL): complex;
VAR
temp: complex;
BEGIN
NEW(temp);
temp.re:=re;
temp.im:=im;
RETURN temp
END CInit;
(* Четыре основных арифметических операций.
Four base operations +, -, * , / *)
(* Сложение
addition : z := z1 + z2 *)
PROCEDURE CAdd* (z1, z2: complex): complex;
BEGIN
result.re := z1.re + z2.re;
result.im := z1.im + z2.im;
RETURN result
END CAdd;
(* Сложение с REAL.
addition : z := z1 + r1 *)
PROCEDURE CAdd_r* (z1: complex; r1: REAL): complex;
BEGIN
result.re := z1.re + r1;
result.im := z1.im;
RETURN result
END CAdd_r;
(* Сложение с INTEGER.
addition : z := z1 + i1 *)
PROCEDURE CAdd_i* (z1: complex; i1: INTEGER): complex;
BEGIN
result.re := z1.re + FLT(i1);
result.im := z1.im;
RETURN result
END CAdd_i;
(* Смена знака.
substraction : z := - z1 *)
PROCEDURE CNeg (z1 : complex): complex;
BEGIN
result.re := -z1.re;
result.im := -z1.im;
RETURN result
END CNeg;
(* Вычитание.
substraction : z := z1 - z2 *)
PROCEDURE CSub* (z1, z2 : complex): complex;
BEGIN
result.re := z1.re - z2.re;
result.im := z1.im - z2.im;
RETURN result
END CSub;
(* Вычитание REAL.
substraction : z := z1 - r1 *)
PROCEDURE CSub_r1* (z1 : complex; r1 : REAL): complex;
BEGIN
result.re := z1.re - r1;
result.im := z1.im;
RETURN result
END CSub_r1;
(* Вычитание из REAL.
substraction : z := r1 - z1 *)
PROCEDURE CSub_r2* (r1 : REAL; z1 : complex): complex;
BEGIN
result.re := r1 - z1.re;
result.im := - z1.im;
RETURN result
END CSub_r2;
(* Вычитание INTEGER.
substraction : z := z1 - i1 *)
PROCEDURE CSub_i* (z1 : complex; i1 : INTEGER): complex;
BEGIN
result.re := z1.re - FLT(i1);
result.im := z1.im;
RETURN result
END CSub_i;
(* Умножение.
multiplication : z := z1 * z2 *)
PROCEDURE CMul (z1, z2 : complex): complex;
BEGIN
result.re := (z1.re * z2.re) - (z1.im * z2.im);
result.im := (z1.re * z2.im) + (z1.im * z2.re);
RETURN result
END CMul;
(* Умножение с REAL.
multiplication : z := z1 * r1 *)
PROCEDURE CMul_r (z1 : complex; r1 : REAL): complex;
BEGIN
result.re := z1.re * r1;
result.im := z1.im * r1;
RETURN result
END CMul_r;
(* Умножение с INTEGER.
multiplication : z := z1 * i1 *)
PROCEDURE CMul_i (z1 : complex; i1 : INTEGER): complex;
BEGIN
result.re := z1.re * FLT(i1);
result.im := z1.im * FLT(i1);
RETURN result
END CMul_i;
(* Деление.
division : z := znum / zden *)
PROCEDURE CDiv (z1, z2 : complex): complex;
(* The following algorithm is used to properly handle
denominator overflow:
| a + b(d/c) c - a(d/c)
| ---------- + ---------- I if |d| < |c|
a + b I | c + d(d/c) a + d(d/c)
------- = |
c + d I | b + a(c/d) -a+ b(c/d)
| ---------- + ---------- I if |d| >= |c|
| d + c(c/d) d + c(c/d)
*)
VAR
tmp, denom : REAL;
BEGIN
IF ( ABS(z2.re) > ABS(z2.im) ) THEN
tmp := z2.im / z2.re;
denom := z2.re + z2.im * tmp;
result.re := (z1.re + z1.im * tmp) / denom;
result.im := (z1.im - z1.re * tmp) / denom;
ELSE
tmp := z2.re / z2.im;
denom := z2.im + z2.re * tmp;
result.re := (z1.im + z1.re * tmp) / denom;
result.im := (-z1.re + z1.im * tmp) / denom;
END;
RETURN result
END CDiv;
(* Деление на REAL.
division : z := znum / r1 *)
PROCEDURE CDiv_r* (z1 : complex; r1 : REAL): complex;
BEGIN
result.re := z1.re / r1;
result.im := z1.im / r1;
RETURN result
END CDiv_r;
(* Деление на INTEGER.
division : z := znum / i1 *)
PROCEDURE CDiv_i* (z1 : complex; i1 : INTEGER): complex;
BEGIN
result.re := z1.re / FLT(i1);
result.im := z1.im / FLT(i1);
RETURN result
END CDiv_i;
(* fonctions elementaires *)
(* Вывод на экран.
out complex number *)
PROCEDURE CPrint* (z: complex; width: INTEGER);
BEGIN
Out.Real(z.re, width);
IF z.im>=0.0 THEN
Out.String("+");
END;
Out.Real(z.im, width);
Out.String("i");
END CPrint;
PROCEDURE CPrintLn* (z: complex; width: INTEGER);
BEGIN
CPrint(z, width);
Out.Ln;
END CPrintLn;
(* Вывод на экран с фиксированным кол-вом знаков
после запятой (p) *)
PROCEDURE CPrintFix* (z: complex; width, p: INTEGER);
BEGIN
Out.FixReal(z.re, width, p);
IF z.im>=0.0 THEN
Out.String("+");
END;
Out.FixReal(z.im, width, p);
Out.String("i");
END CPrintFix;
PROCEDURE CPrintFixLn* (z: complex; width, p: INTEGER);
BEGIN
CPrintFix(z, width, p);
Out.Ln;
END CPrintFixLn;
(* Модуль числа.
module : r = |z| *)
PROCEDURE CMod* (z1 : complex): REAL;
BEGIN
RETURN Math.sqrt((z1.re * z1.re) + (z1.im * z1.im))
END CMod;
(* Квадрат числа.
square : r := z*z *)
PROCEDURE CSqr* (z1: complex): complex;
BEGIN
result.re := z1.re * z1.re - z1.im * z1.im;
result.im := 2.0 * z1.re * z1.im;
RETURN result
END CSqr;
(* Квадратный корень числа.
square root : r := sqrt(z) *)
PROCEDURE CSqrt* (z1: complex): complex;
VAR
root, q: REAL;
BEGIN
IF (z1.re#0.0) OR (z1.im#0.0) THEN
root := Math.sqrt(0.5 * (ABS(z1.re) + CMod(z1)));
q := z1.im / (2.0 * root);
IF z1.re >= 0.0 THEN
result.re := root;
result.im := q;
ELSE
IF z1.im < 0.0 THEN
result.re := - q;
result.im := - root
ELSE
result.re := q;
result.im := root
END
END
ELSE
result := z1;
END;
RETURN result
END CSqrt;
(* Экспонента.
exponantial : r := exp(z) *)
(* exp(x + iy) = exp(x).exp(iy) = exp(x).[cos(y) + i sin(y)] *)
PROCEDURE CExp* (z: complex): complex;
VAR
expz : REAL;
BEGIN
expz := Math.exp(z.re);
result.re := expz * Math.cos(z.im);
result.im := expz * Math.sin(z.im);
RETURN result
END CExp;
(* Натуральный логарифм.
natural logarithm : r := ln(z) *)
(* ln( p exp(i0)) = ln(p) + i0 + 2kpi *)
PROCEDURE CLn* (z: complex): complex;
BEGIN
result.re := Math.ln(CMod(z));
result.im := Math.arctan2(z.im, z.re);
RETURN result
END CLn;
(* Число в степени.
exp : z := z1^z2 *)
PROCEDURE CPower* (z1, z2 : complex): complex;
VAR
a: complex;
BEGIN
a:=CLn(z1);
a:=CMul(z2, a);
result:=CExp(a);
RETURN result
END CPower;
(* Число в степени REAL.
multiplication : z := z1^r *)
PROCEDURE CPower_r* (z1: complex; r: REAL): complex;
VAR
a: complex;
BEGIN
a:=CLn(z1);
a:=CMul_r(a, r);
result:=CExp(a);
RETURN result
END CPower_r;
(* Обратное число.
inverse : r := 1 / z *)
PROCEDURE CInv* (z: complex): complex;
VAR
denom : REAL;
BEGIN
denom := (z.re * z.re) + (z.im * z.im);
(* generates a fpu exception if denom=0 as for reals *)
result.re:=z.re/denom;
result.im:=-z.im/denom;
RETURN result
END CInv;
(* direct trigonometric functions *)
(* Косинус.
complex cosinus *)
(* cos(x+iy) = cos(x).cos(iy) - sin(x).sin(iy) *)
(* cos(ix) = cosh(x) et sin(ix) = i.sinh(x) *)
PROCEDURE CCos* (z: complex): complex;
BEGIN
result.re := Math.cos(z.re) * Math.cosh(z.im);
result.im := - Math.sin(z.re) * Math.sinh(z.im);
RETURN result
END CCos;
(* Синус.
sinus complex *)
(* sin(x+iy) = sin(x).cos(iy) + cos(x).sin(iy) *)
(* cos(ix) = cosh(x) et sin(ix) = i.sinh(x) *)
PROCEDURE CSin (z: complex): complex;
BEGIN
result.re := Math.sin(z.re) * Math.cosh(z.im);
result.im := Math.cos(z.re) * Math.sinh(z.im);
RETURN result
END CSin;
(* Тангенс.
tangente *)
PROCEDURE CTg* (z: complex): complex;
VAR
temp1, temp2: complex;
BEGIN
temp1:=CSin(z);
temp2:=CCos(z);
result:=CDiv(temp1, temp2);
RETURN result
END CTg;
(* inverse complex hyperbolic functions *)
(* Гиперболический арккосинус.
hyberbolic arg cosinus *)
(* _________ *)
(* argch(z) = -/+ ln(z + i.V 1 - z.z) *)
PROCEDURE CArcCosh* (z : complex): complex;
BEGIN
result:=CNeg(CLn(CAdd(z, CMul(i, CSqrt(CSub_r2(1.0, CMul(z, z)))))));
RETURN result
END CArcCosh;
(* Гиперболический арксинус.
hyperbolic arc sinus *)
(* ________ *)
(* argsh(z) = ln(z + V 1 + z.z) *)
PROCEDURE CArcSinh* (z : complex): complex;
BEGIN
result:=CLn(CAdd(z, CSqrt(CAdd_r(CMul(z, z), 1.0))));
RETURN result
END CArcSinh;
(* Гиперболический арктангенс.
hyperbolic arc tangent *)
(* argth(z) = 1/2 ln((z + 1) / (1 - z)) *)
PROCEDURE CArcTgh (z : complex): complex;
BEGIN
result:=CDiv_r(CLn(CDiv(CAdd_r(z, 1.0), CSub_r2(1.0, z))), 2.0);
RETURN result
END CArcTgh;
(* trigonometriques inverses *)
(* Арккосинус.
arc cosinus complex *)
(* arccos(z) = -i.argch(z) *)
PROCEDURE CArcCos* (z: complex): complex;
BEGIN
result := CNeg(CMul(i, CArcCosh(z)));
RETURN result
END CArcCos;
(* Арксинус.
arc sinus complex *)
(* arcsin(z) = -i.argsh(i.z) *)
PROCEDURE CArcSin* (z : complex): complex;
BEGIN
result := CNeg(CMul(i, CArcSinh(z)));
RETURN result
END CArcSin;
(* Арктангенс.
arc tangente complex *)
(* arctg(z) = -i.argth(i.z) *)
PROCEDURE CArcTg* (z : complex): complex;
BEGIN
result := CNeg(CMul(i, CArcTgh(CMul(i, z))));
RETURN result
END CArcTg;
BEGIN
result:=CInit(0.0, 0.0);
i :=CInit(0.0, 1.0);
_0:=CInit(0.0, 0.0);
END CMath.

/programs/develop/oberon07/lib/Math/MathBits.ob07
0,0 → 1,33
(* ****************************************
Дополнение к модулю Math.
Побитовые операции над целыми числами.
Вадим Исаев, 2020
Additional functions to the module Math.
Bitwise operations on integers.
Vadim Isaev, 2020
******************************************* *)
MODULE MathBits;
PROCEDURE iand* (x, y: INTEGER): INTEGER;
RETURN ORD(BITS(x) * BITS(y))
END iand;
PROCEDURE ior* (x, y: INTEGER): INTEGER;
RETURN ORD(BITS(x) + BITS(y))
END ior;
PROCEDURE ixor* (x, y: INTEGER): INTEGER;
RETURN ORD(BITS(x) / BITS(y))
END ixor;
PROCEDURE inot* (x: INTEGER): INTEGER;
RETURN ORD(-BITS(x))
END inot;
END MathBits.

/programs/develop/oberon07/lib/Math/MathRound.ob07
0,0 → 1,99
(* ******************************************
Дополнительные функции к модулю Math.
Функции округления.
Вадим Исаев, 2020
-------------------------------------
Additional functions to the module Math.
Rounding functions.
Vadim Isaev, 2020
********************************************* *)
MODULE MathRound;
IMPORT Math;
(* Возвращается целая часть числа x.
Returns the integer part of a argument x.*)
PROCEDURE trunc* (x: REAL): REAL;
VAR
a: REAL;
BEGIN
a := FLT(FLOOR(x));
IF (x < 0.0) & (x # a) THEN
a := a + 1.0
END
RETURN a
END trunc;
(* Возвращается дробная часть числа x.
Returns the fractional part of the argument x *)
PROCEDURE frac* (x: REAL): REAL;
RETURN x - trunc(x)
END frac;
(* Округление к ближайшему целому.
Rounding to the nearest integer. *)
PROCEDURE round* (x: REAL): REAL;
VAR
a: REAL;
BEGIN
a := trunc(x);
IF ABS(frac(x)) >= 0.5 THEN
a := a + FLT(Math.sgn(x))
END
RETURN a
END round;
(* Округление к бОльшему целому.
Rounding to a largest integer *)
PROCEDURE ceil* (x: REAL): REAL;
VAR
a: REAL;
BEGIN
a := FLT(FLOOR(x));
IF x # a THEN
a := a + 1.0
END
RETURN a
END ceil;
(* Округление к меньшему целому.
Rounding to a smallest integer *)
PROCEDURE floor* (x: REAL): REAL;
RETURN FLT(FLOOR(x))
END floor;
(* Округление до определённого количества знаков:
- если Digits отрицательное, то округление
в знаках после десятичной запятой;
- если Digits положительное, то округление
в знаках до запятой *)
PROCEDURE SimpleRoundTo* (AValue: REAL; Digits: INTEGER): REAL;
VAR
RV, a : REAL;
BEGIN
RV := Math.ipower(10.0, -Digits);
IF AValue < 0.0 THEN
a := trunc((AValue * RV) - 0.5)
ELSE
a := trunc((AValue * RV) + 0.5)
END
RETURN a / RV
END SimpleRoundTo;
END MathRound.

/programs/develop/oberon07/lib/Math/MathStat.ob07
0,0 → 1,238
(* ********************************************
Дополнение к модулю Math.
Статистические процедуры.
-------------------------------------
Additional functions to the module Math.
Statistical functions
*********************************************** *)
MODULE MathStat;
IMPORT Math;
(*Минимальное значение. Нецелое *)
PROCEDURE MinValue* (data: ARRAY OF REAL; N: INTEGER): REAL;
VAR
i: INTEGER;
a: REAL;
BEGIN
a := data[0];
FOR i := 1 TO N - 1 DO
IF data[i] < a THEN
a := data[i]
END
END
RETURN a
END MinValue;
(*Минимальное значение. Целое *)
PROCEDURE MinIntValue* (data: ARRAY OF INTEGER; N: INTEGER): INTEGER;
VAR
i: INTEGER;
a: INTEGER;
BEGIN
a := data[0];
FOR i := 1 TO N - 1 DO
IF data[i] < a THEN
a := data[i]
END
END
RETURN a
END MinIntValue;
(*Максимальное значение. Нецелое *)
PROCEDURE MaxValue* (data: ARRAY OF REAL; N: INTEGER): REAL;
VAR
i: INTEGER;
a: REAL;
BEGIN
a := data[0];
FOR i := 1 TO N - 1 DO
IF data[i] > a THEN
a := data[i]
END
END
RETURN a
END MaxValue;
(*Максимальное значение. Целое *)
PROCEDURE MaxIntValue* (data: ARRAY OF INTEGER; N: INTEGER): INTEGER;
VAR
i: INTEGER;
a: INTEGER;
BEGIN
a := data[0];
FOR i := 1 TO N - 1 DO
IF data[i] > a THEN
a := data[i]
END
END
RETURN a
END MaxIntValue;
(* Сумма значений массива *)
PROCEDURE Sum* (data: ARRAY OF REAL; Count: INTEGER): REAL;
VAR
a: REAL;
i: INTEGER;
BEGIN
a := 0.0;
FOR i := 0 TO Count - 1 DO
a := a + data[i]
END
RETURN a
END Sum;
(* Сумма целых значений массива *)
PROCEDURE SumInt* (data: ARRAY OF INTEGER; Count: INTEGER): INTEGER;
VAR
a: INTEGER;
i: INTEGER;
BEGIN
a := 0;
FOR i := 0 TO Count - 1 DO
a := a + data[i]
END
RETURN a
END SumInt;
(* Сумма квадратов значений массива *)
PROCEDURE SumOfSquares* (data : ARRAY OF REAL; Count: INTEGER): REAL;
VAR
a: REAL;
i: INTEGER;
BEGIN
a := 0.0;
FOR i := 0 TO Count - 1 DO
a := a + Math.sqrr(data[i])
END
RETURN a
END SumOfSquares;
(* Сумма значений и сумма квадратов значений массмва *)
PROCEDURE SumsAndSquares* (data: ARRAY OF REAL; Count : INTEGER;
VAR sum, sumofsquares : REAL);
VAR
i: INTEGER;
temp: REAL;
BEGIN
sumofsquares := 0.0;
sum := 0.0;
FOR i := 0 TO Count - 1 DO
temp := data[i];
sumofsquares := sumofsquares + Math.sqrr(temp);
sum := sum + temp
END
END SumsAndSquares;
(* Средниее значений массива *)
PROCEDURE Mean* (data: ARRAY OF REAL; Count: INTEGER): REAL;
RETURN Sum(data, Count) / FLT(Count)
END Mean;
PROCEDURE MeanAndTotalVariance* (data: ARRAY OF REAL; Count: INTEGER;
VAR mu: REAL; VAR variance: REAL);
VAR
i: INTEGER;
BEGIN
mu := Mean(data, Count);
variance := 0.0;
FOR i := 0 TO Count - 1 DO
variance := variance + Math.sqrr(data[i] - mu)
END
END MeanAndTotalVariance;
(* Вычисление статистической дисперсии равной сумме квадратов разницы
между каждым конкретным значением массива Data и средним значением *)
PROCEDURE TotalVariance* (data: ARRAY OF REAL; Count: INTEGER): REAL;
VAR
mu, tv: REAL;
BEGIN
MeanAndTotalVariance(data, Count, mu, tv)
RETURN tv
END TotalVariance;
(* Типовая дисперсия всех значений массива *)
PROCEDURE Variance* (data: ARRAY OF REAL; Count: INTEGER): REAL;
VAR
a: REAL;
BEGIN
IF Count = 1 THEN
a := 0.0
ELSE
a := TotalVariance(data, Count) / FLT(Count - 1)
END
RETURN a
END Variance;
(* Стандартное среднеквадратичное отклонение *)
PROCEDURE StdDev* (data: ARRAY OF REAL; Count: INTEGER): REAL;
RETURN Math.sqrt(Variance(data, Count))
END StdDev;
(* Среднее арифметическое всех значений массива, и среднее отклонение *)
PROCEDURE MeanAndStdDev* (data: ARRAY OF REAL; Count: INTEGER;
VAR mean: REAL; VAR stdDev: REAL);
VAR
totalVariance: REAL;
BEGIN
MeanAndTotalVariance(data, Count, mean, totalVariance);
IF Count < 2 THEN
stdDev := 0.0
ELSE
stdDev := Math.sqrt(totalVariance / FLT(Count - 1))
END
END MeanAndStdDev;
(* Евклидова норма для всех значений массива *)
PROCEDURE Norm* (data: ARRAY OF REAL; Count: INTEGER): REAL;
VAR
a: REAL;
i: INTEGER;
BEGIN
a := 0.0;
FOR i := 0 TO Count - 1 DO
a := a + Math.sqrr(data[i])
END
RETURN Math.sqrt(a)
END Norm;
END MathStat.

/programs/develop/oberon07/lib/Math/Rand.ob07
0,0 → 1,81
(* ************************************
Генератор какбыслучайных чисел,
Линейный конгруэнтный метод,
алгоритм Лемера.
Вадим Исаев, 2020
-------------------------------
Generator pseudorandom numbers,
Linear congruential generator,
Algorithm by D. H. Lehmer.
Vadim Isaev, 2020
*************************************** *)
MODULE Rand;
IMPORT HOST, Math;
CONST
RAND_MAX = 2147483647;
VAR
seed: INTEGER;
PROCEDURE Randomize*;
BEGIN
seed := HOST.GetTickCount()
END Randomize;
(* Целые какбыслучайные числа до RAND_MAX *)
PROCEDURE RandomI* (): INTEGER;
CONST
a = 630360016;
BEGIN
seed := (a * seed) MOD RAND_MAX
RETURN seed
END RandomI;
(* Какбыслучайные числа с плавающей запятой от 0 до 1 *)
PROCEDURE RandomR* (): REAL;
RETURN FLT(RandomI()) / FLT(RAND_MAX)
END RandomR;
(* Какбыслучайное число в диапазоне от 0 до l.
Return a random number in a range 0 ... l *)
PROCEDURE RandomITo* (aTo: INTEGER): INTEGER;
RETURN FLOOR(RandomR() * FLT(aTo))
END RandomITo;
(* Какбыслучайное число в диапазоне.
Return a random number in a range *)
PROCEDURE RandomIRange* (aFrom, aTo: INTEGER): INTEGER;
RETURN FLOOR(RandomR() * FLT(aTo - aFrom)) + aFrom
END RandomIRange;
(* Какбыслучайное число. Распределение Гаусса *)
PROCEDURE RandG* (mean, stddev: REAL): REAL;
VAR
U, S: REAL;
BEGIN
REPEAT
U := 2.0 * RandomR() - 1.0;
S := Math.sqrr(U) + Math.sqrr(2.0 * RandomR() - 1.0)
UNTIL (1.0E-20 < S) & (S <= 1.0)
RETURN Math.sqrt(-2.0 * Math.ln(S) / S) * U * stddev + mean
END RandG;
BEGIN
seed := 654321
END Rand.

/programs/develop/oberon07/lib/Math/RandExt.ob07
0,0 → 1,298
(* ************************************************************
Дополнительные алгоритмы генераторов какбыслучайных чисел.
Вадим Исаев, 2020
Additional generators of pseudorandom numbers.
Vadim Isaev, 2020
************************************************************ *)
MODULE RandExt;
IMPORT HOST, MathRound, MathBits;
CONST
(* Для алгоритма Мерсена-Твистера *)
N = 624;
M = 397;
MATRIX_A = 9908B0DFH; (* constant vector a *)
UPPER_MASK = 80000000H; (* most significant w-r bits *)
LOWER_MASK = 7FFFFFFFH; (* least significant r bits *)
INT_MAX = 4294967295;
TYPE
(* структура служебных данных, для алгоритма mrg32k3a *)
random_t = RECORD
mrg32k3a_seed : REAL;
mrg32k3a_x : ARRAY 3 OF REAL;
mrg32k3a_y : ARRAY 3 OF REAL
END;
(* Для алгоритма Мерсена-Твистера *)
MTKeyArray = ARRAY N OF INTEGER;
VAR
(* Для алгоритма mrg32k3a *)
prndl: random_t;
(* Для алгоритма Мерсена-Твистера *)
mt : MTKeyArray; (* the array for the state vector *)
mti : INTEGER; (* mti == N+1 means mt[N] is not initialized *)
(* ---------------------------------------------------------------------------
Генератор какбыслучайных чисел в диапазоне [a,b].
Алгоритм 133б из книги "Агеев и др. - Бибилотека алгоритмов 101б-150б",
стр. 53.
Переделка из Algol на Oberon и доработка, Вадим Исаев, 2020
Generator pseudorandom numbers, algorithm 133b from
Comm ACM 5,10 (Oct 1962) 553.
Convert from Algol to Oberon Vadim Isaev, 2020.
Входные параметры:
a - начальное вычисляемое значение, тип REAL;
b - конечное вычисляемое значение, тип REAL;
seed - начальное значение для генерации случайного числа.
Должно быть в диапазоне от 10 000 000 000 до 34 359 738 368 (2^35),
нечётное.
--------------------------------------------------------------------------- *)
PROCEDURE alg133b* (a, b: REAL; VAR seed: INTEGER): REAL;
CONST
m35 = 34359738368;
m36 = 68719476736;
m37 = 137438953472;
VAR
x: INTEGER;
BEGIN
IF seed # 0 THEN
IF (seed MOD 2 = 0) THEN
seed := seed + 1
END;
x:=seed;
seed:=0;
END;
x:=5*x;
IF x>=m37 THEN
x:=x-m37
END;
IF x>=m36 THEN
x:=x-m36
END;
IF x>=m35 THEN
x:=x-m35
END;
RETURN FLT(x) / FLT(m35) * (b - a) + a
END alg133b;
(* ----------------------------------------------------------
Генератор почти равномерно распределённых
какбыслучайных чисел mrg32k3a
(Combined Multiple Recursive Generator) от 0 до 1.
Период повторения последовательности = 2^127
Generator pseudorandom numbers,
algorithm mrg32k3a.
Переделка из FreePascal на Oberon, Вадим Исаев, 2020
Convert from FreePascal to Oberon, Vadim Isaev, 2020
---------------------------------------------------------- *)
(* Инициализация генератора.
Входные параметры:
seed - значение для инициализации. Любое. Если передать
ноль, то вместо ноля будет подставлено кол-во
процессорных тиков. *)
PROCEDURE mrg32k3a_init* (seed: REAL);
BEGIN
prndl.mrg32k3a_x[0] := 1.0;
prndl.mrg32k3a_x[1] := 1.0;
prndl.mrg32k3a_y[0] := 1.0;
prndl.mrg32k3a_y[1] := 1.0;
prndl.mrg32k3a_y[2] := 1.0;
IF seed # 0.0 THEN
prndl.mrg32k3a_x[2] := seed;
ELSE
prndl.mrg32k3a_x[2] := FLT(HOST.GetTickCount());
END;
END mrg32k3a_init;
(* Генератор какбыслучайных чисел от 0.0 до 1.0. *)
PROCEDURE mrg32k3a* (): REAL;
CONST
(* random MRG32K3A algorithm constants *)
MRG32K3A_NORM = 2.328306549295728E-10;
MRG32K3A_M1 = 4294967087.0;
MRG32K3A_M2 = 4294944443.0;
MRG32K3A_A12 = 1403580.0;
MRG32K3A_A13 = 810728.0;
MRG32K3A_A21 = 527612.0;
MRG32K3A_A23 = 1370589.0;
RAND_BUFSIZE = 512;
VAR
xn, yn, result: REAL;
BEGIN
(* Часть 1 *)
xn := MRG32K3A_A12 * prndl.mrg32k3a_x[1] - MRG32K3A_A13 * prndl.mrg32k3a_x[2];
xn := xn - MathRound.trunc(xn / MRG32K3A_M1) * MRG32K3A_M1;
IF xn < 0.0 THEN
xn := xn + MRG32K3A_M1;
END;
prndl.mrg32k3a_x[2] := prndl.mrg32k3a_x[1];
prndl.mrg32k3a_x[1] := prndl.mrg32k3a_x[0];
prndl.mrg32k3a_x[0] := xn;
(* Часть 2 *)
yn := MRG32K3A_A21 * prndl.mrg32k3a_y[0] - MRG32K3A_A23 * prndl.mrg32k3a_y[2];
yn := yn - MathRound.trunc(yn / MRG32K3A_M2) * MRG32K3A_M2;
IF yn < 0.0 THEN
yn := yn + MRG32K3A_M2;
END;
prndl.mrg32k3a_y[2] := prndl.mrg32k3a_y[1];
prndl.mrg32k3a_y[1] := prndl.mrg32k3a_y[0];
prndl.mrg32k3a_y[0] := yn;
(* Смешение частей *)
IF xn <= yn THEN
result := ((xn - yn + MRG32K3A_M1) * MRG32K3A_NORM)
ELSE
result := (xn - yn) * MRG32K3A_NORM;
END;
RETURN result
END mrg32k3a;
(* -------------------------------------------------------------------
Генератор какбыслучайных чисел, алгоритм Мерсена-Твистера (MT19937).
Переделка из Delphi в Oberon Вадим Исаев, 2020.
Mersenne Twister Random Number Generator.
A C-program for MT19937, with initialization improved 2002/1/26.
Coded by Takuji Nishimura and Makoto Matsumoto.
Adapted for DMath by Jean Debord - Feb. 2007
Adapted for Oberon-07 by Vadim Isaev - May 2020
------------------------------------------------------------ *)
(* Initializes MT generator with a seed *)
PROCEDURE InitMT(Seed : INTEGER);
VAR
i : INTEGER;
BEGIN
mt[0] := MathBits.iand(Seed, INT_MAX);
FOR i := 1 TO N-1 DO
mt[i] := (1812433253 * MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) + i);
(* See Knuth TAOCP Vol2. 3rd Ed. P.106 For multiplier.
In the previous versions, MSBs of the seed affect
only MSBs of the array mt[].
2002/01/09 modified by Makoto Matsumoto *)
mt[i] := MathBits.iand(mt[i], INT_MAX);
(* For >32 Bit machines *)
END;
mti := N;
END InitMT;
(* Initialize MT generator with an array InitKey[0..(KeyLength - 1)] *)
PROCEDURE InitMTbyArray(InitKey : MTKeyArray; KeyLength : INTEGER);
VAR
i, j, k, k1 : INTEGER;
BEGIN
InitMT(19650218);
i := 1;
j := 0;
IF N > KeyLength THEN
k1 := N
ELSE
k1 := KeyLength;
END;
FOR k := k1 TO 1 BY -1 DO
(* non linear *)
mt[i] := MathBits.ixor(mt[i], (MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) * 1664525)) + InitKey[j] + j;
mt[i] := MathBits.iand(mt[i], INT_MAX); (* for WORDSIZE > 32 machines *)
INC(i);
INC(j);
IF i >= N THEN
mt[0] := mt[N-1];
i := 1;
END;
IF j >= KeyLength THEN
j := 0;
END;
END;
FOR k := N-1 TO 1 BY -1 DO
(* non linear *)
mt[i] := MathBits.ixor(mt[i], (MathBits.ixor(mt[i-1], LSR(mt[i-1], 30)) * 1566083941)) - i;
mt[i] := MathBits.iand(mt[i], INT_MAX); (* for WORDSIZE > 32 machines *)
INC(i);
IF i >= N THEN
mt[0] := mt[N-1];
i := 1;
END;
END;
mt[0] := UPPER_MASK; (* MSB is 1; assuring non-zero initial array *)
END InitMTbyArray;
(* Generates a integer Random number on [-2^31 .. 2^31 - 1] interval *)
PROCEDURE IRanMT(): INTEGER;
VAR
mag01 : ARRAY 2 OF INTEGER;
y,k : INTEGER;
BEGIN
IF mti >= N THEN (* generate N words at one Time *)
(* If IRanMT() has not been called, a default initial seed is used *)
IF mti = N + 1 THEN
InitMT(5489);
END;
FOR k := 0 TO (N-M)-1 DO
y := MathBits.ior(MathBits.iand(mt[k], UPPER_MASK), MathBits.iand(mt[k+1], LOWER_MASK));
mt[k] := MathBits.ixor(MathBits.ixor(mt[k+M], LSR(y, 1)), mag01[MathBits.iand(y, 1H)]);
END;
FOR k := (N-M) TO (N-2) DO
y := MathBits.ior(MathBits.iand(mt[k], UPPER_MASK), MathBits.iand(mt[k+1], LOWER_MASK));
mt[k] := MathBits.ixor(mt[k - (N - M)], MathBits.ixor(LSR(y, 1), mag01[MathBits.iand(y, 1H)]));
END;
y := MathBits.ior(MathBits.iand(mt[N-1], UPPER_MASK), MathBits.iand(mt[0], LOWER_MASK));
mt[N-1] := MathBits.ixor(mt[M-1], MathBits.ixor(LSR(y, 1), mag01[MathBits.iand(y, 1H)]));
mti := 0;
END;
y := mt[mti];
INC(mti);
(* Tempering *)
y := MathBits.ixor(y, LSR(y, 11));
y := MathBits.ixor(y, MathBits.iand(LSL(y, 7), 9D2C5680H));
y := MathBits.ixor(y, MathBits.iand(LSL(y, 15), 4022730752));
y := MathBits.ixor(y, LSR(y, 18));
RETURN y
END IRanMT;
(* Generates a real Random number on [0..1] interval *)
PROCEDURE RRanMT(): REAL;
BEGIN
RETURN FLT(IRanMT())/FLT(INT_MAX)
END RRanMT;
END RandExt.

/programs/develop/oberon07/lib/RVM32I/FPU.ob07
0,0 → 1,465
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE FPU;
CONST
INF = 07F800000H;
NINF = 0FF800000H;
NAN = 07FC00000H;
PROCEDURE div2 (b, a: INTEGER): INTEGER;
VAR
n, e, r, s: INTEGER;
BEGIN
s := ORD(BITS(a) / BITS(b) - {0..30});
e := (a DIV 800000H) MOD 256 - (b DIV 800000H) MOD 256 + 127;
a := a MOD 800000H + 800000H;
b := b MOD 800000H + 800000H;
n := 800000H;
r := 0;
IF a < b THEN
a := a * 2;
DEC(e)
END;
WHILE (a > 0) & (n > 0) DO
IF a >= b THEN
INC(r, n);
DEC(a, b)
END;
a := a * 2;
n := n DIV 2
END;
IF e <= 0 THEN
e := 0;
r := 800000H;
s := 0
ELSIF e >= 255 THEN
e := 255;
r := 800000H
END
RETURN (r - 800000H) + e * 800000H + s
END div2;
PROCEDURE mul2 (b, a: INTEGER): INTEGER;
VAR
e, r, s: INTEGER;
BEGIN
s := ORD(BITS(a) / BITS(b) - {0..30});
e := (a DIV 800000H) MOD 256 + (b DIV 800000H) MOD 256 - 127;
a := a MOD 800000H + 800000H;
b := b MOD 800000H + 800000H;
r := a * (b MOD 256);
b := b DIV 256;
r := LSR(r, 8);
INC(r, a * (b MOD 256));
b := b DIV 256;
r := LSR(r, 8);
INC(r, a * (b MOD 256));
r := LSR(r, 7);
IF r >= 1000000H THEN
r := r DIV 2;
INC(e)
END;
IF e <= 0 THEN
e := 0;
r := 800000H;
s := 0
ELSIF e >= 255 THEN
e := 255;
r := 800000H
END
RETURN (r - 800000H) + e * 800000H + s
END mul2;
PROCEDURE add2 (b, a: INTEGER): INTEGER;
VAR
ea, eb, e, d, r: INTEGER;
BEGIN
ea := (a DIV 800000H) MOD 256;
eb := (b DIV 800000H) MOD 256;
d := ea - eb;
a := a MOD 800000H + 800000H;
b := b MOD 800000H + 800000H;
IF d > 0 THEN
IF d < 24 THEN
b := LSR(b, d)
ELSE
b := 0
END;
e := ea
ELSIF d < 0 THEN
IF d > -24 THEN
a := LSR(a, -d)
ELSE
a := 0
END;
e := eb
ELSE
e := ea
END;
r := a + b;
IF r >= 1000000H THEN
r := r DIV 2;
INC(e)
END;
IF e >= 255 THEN
e := 255;
r := 800000H
END
RETURN (r - 800000H) + e * 800000H
END add2;
PROCEDURE sub2 (b, a: INTEGER): INTEGER;
VAR
ea, eb, e, d, r, s: INTEGER;
BEGIN
ea := (a DIV 800000H) MOD 256;
eb := (b DIV 800000H) MOD 256;
a := a MOD 800000H + 800000H;
b := b MOD 800000H + 800000H;
d := ea - eb;
IF (d > 0) OR (d = 0) & (a >= b) THEN
s := 0
ELSE
ea := eb;
d := -d;
r := a;
a := b;
b := r;
s := 80000000H
END;
e := ea;
IF d > 0 THEN
IF d < 24 THEN
b := LSR(b, d)
ELSE
b := 0
END
END;
r := a - b;
IF r = 0 THEN
e := 0;
r := 800000H;
s := 0
ELSE
WHILE r < 800000H DO
r := r * 2;
DEC(e)
END
END;
IF e <= 0 THEN
e := 0;
r := 800000H;
s := 0
END
RETURN (r - 800000H) + e * 800000H + s
END sub2;
PROCEDURE zero (VAR x: INTEGER);
BEGIN
IF BITS(x) * {23..30} = {} THEN
x := 0
END
END zero;
PROCEDURE isNaN (a: INTEGER): BOOLEAN;
RETURN (a > INF) OR (a < 0) & (a > NINF)
END isNaN;
PROCEDURE isInf (a: INTEGER): BOOLEAN;
RETURN (a = INF) OR (a = NINF)
END isInf;
PROCEDURE isNormal (a: INTEGER): BOOLEAN;
RETURN (BITS(a) * {23..30} # {23..30}) & (BITS(a) * {23..30} # {})
END isNormal;
PROCEDURE add* (b, a: INTEGER): INTEGER;
VAR
r: INTEGER;
BEGIN
zero(a); zero(b);
IF isNormal(a) & isNormal(b) THEN
IF (a > 0) & (b > 0) THEN
r := add2(b, a)
ELSIF (a < 0) & (b < 0) THEN
r := add2(b, a) + 80000000H
ELSIF (a > 0) & (b < 0) THEN
r := sub2(b, a)
ELSIF (a < 0) & (b > 0) THEN
r := sub2(a, b)
END
ELSIF isNaN(a) OR isNaN(b) THEN
r := NAN
ELSIF isInf(a) & isInf(b) THEN
IF a = b THEN
r := a
ELSE
r := NAN
END
ELSIF isInf(a) THEN
r := a
ELSIF isInf(b) THEN
r := b
ELSIF a = 0 THEN
r := b
ELSIF b = 0 THEN
r := a
END
RETURN r
END add;
PROCEDURE sub* (b, a: INTEGER): INTEGER;
VAR
r: INTEGER;
BEGIN
zero(a); zero(b);
IF isNormal(a) & isNormal(b) THEN
IF (a > 0) & (b > 0) THEN
r := sub2(b, a)
ELSIF (a < 0) & (b < 0) THEN
r := sub2(a, b)
ELSIF (a > 0) & (b < 0) THEN
r := add2(b, a)
ELSIF (a < 0) & (b > 0) THEN
r := add2(b, a) + 80000000H
END
ELSIF isNaN(a) OR isNaN(b) THEN
r := NAN
ELSIF isInf(a) & isInf(b) THEN
IF a # b THEN
r := a
ELSE
r := NAN
END
ELSIF isInf(a) THEN
r := a
ELSIF isInf(b) THEN
r := INF + ORD(BITS(b) / {31} - {0..30})
ELSIF (a = 0) & (b = 0) THEN
r := 0
ELSIF a = 0 THEN
r := ORD(BITS(b) / {31})
ELSIF b = 0 THEN
r := a
END
RETURN r
END sub;
PROCEDURE mul* (b, a: INTEGER): INTEGER;
VAR
r: INTEGER;
BEGIN
zero(a); zero(b);
IF isNormal(a) & isNormal(b) THEN
r := mul2(b, a)
ELSIF isNaN(a) OR isNaN(b) THEN
r := NAN
ELSIF (isInf(a) & (b = 0)) OR (isInf(b) & (a = 0)) THEN
r := NAN
ELSIF isInf(a) OR isInf(b) THEN
r := INF + ORD(BITS(a) / BITS(b) - {0..30})
ELSIF (a = 0) OR (b = 0) THEN
r := 0
END
RETURN r
END mul;
PROCEDURE _div* (b, a: INTEGER): INTEGER;
VAR
r: INTEGER;
BEGIN
zero(a); zero(b);
IF isNormal(a) & isNormal(b) THEN
r := div2(b, a)
ELSIF isNaN(a) OR isNaN(b) THEN
r := NAN
ELSIF isInf(a) & isInf(b) THEN
r := NAN
ELSIF isInf(a) THEN
r := INF + ORD(BITS(a) / BITS(b) - {0..30})
ELSIF isInf(b) THEN
r := 0
ELSIF a = 0 THEN
IF b = 0 THEN
r := NAN
ELSE
r := 0
END
ELSIF b = 0 THEN
IF a > 0 THEN
r := INF
ELSE
r := NINF
END
END
RETURN r
END _div;
PROCEDURE cmp* (op, b, a: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
zero(a); zero(b);
IF isNaN(a) OR isNaN(b) THEN
res := op = 1
ELSIF (a < 0) & (b < 0) THEN
CASE op OF
|0: res := a = b
|1: res := a # b
|2: res := a > b
|3: res := a >= b
|4: res := a < b
|5: res := a <= b
END
ELSE
CASE op OF
|0: res := a = b
|1: res := a # b
|2: res := a < b
|3: res := a <= b
|4: res := a > b
|5: res := a >= b
END
END
RETURN res
END cmp;
PROCEDURE flt* (x: INTEGER): INTEGER;
VAR
n, y, r, s: INTEGER;
BEGIN
IF x = 0 THEN
s := 0;
r := 800000H;
n := -126
ELSIF x = 80000000H THEN
s := 80000000H;
r := 800000H;
n := 32
ELSE
IF x < 0 THEN
s := 80000000H
ELSE
s := 0
END;
n := 0;
y := ABS(x);
r := y;
WHILE y > 0 DO
y := y DIV 2;
INC(n)
END;
IF n > 24 THEN
r := LSR(r, n - 24)
ELSE
r := LSL(r, 24 - n)
END
END
RETURN (r - 800000H) + (n + 126) * 800000H + s
END flt;
PROCEDURE floor* (x: INTEGER): INTEGER;
VAR
r, e: INTEGER;
BEGIN
zero(x);
e := (x DIV 800000H) MOD 256 - 127;
r := x MOD 800000H + 800000H;
IF (0 <= e) & (e <= 22) THEN
r := LSR(r, 23 - e) + ORD((x < 0) & (LSL(r, e + 9) # 0))
ELSIF (23 <= e) & (e <= 54) THEN
r := LSL(r, e - 23)
ELSIF (e < 0) & (x < 0) THEN
r := 1
ELSE
r := 0
END;
IF x < 0 THEN
r := -r
END
RETURN r
END floor;
END FPU.

/programs/develop/oberon07/lib/RVM32I/HOST.ob07
0,0 → 1,176
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, Trap;
CONST
slash* = "\";
eol* = 0DX + 0AX;
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
VAR
maxreal*: REAL;
PROCEDURE syscall0 (fn: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall0;
PROCEDURE syscall1 (fn, p1: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall1;
PROCEDURE syscall2 (fn, p1, p2: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall2;
PROCEDURE syscall3 (fn, p1, p2, p3: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall3;
PROCEDURE syscall4 (fn, p1, p2, p3, p4: INTEGER): INTEGER;
BEGIN
Trap.syscall(SYSTEM.ADR(fn))
RETURN fn
END syscall4;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
code := syscall1(0, code)
END ExitProcess;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
a: INTEGER;
BEGIN
a := syscall2(1, LEN(path), SYSTEM.ADR(path[0]))
END GetCurrentDirectory;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
n := syscall3(2, n, LEN(s), SYSTEM.ADR(s[0]))
END GetArg;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
RETURN syscall4(3, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes)
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN syscall4(4, F, LEN(Buffer), SYSTEM.ADR(Buffer[0]), bytes)
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN syscall2(5, LEN(FName), SYSTEM.ADR(FName[0]))
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
F := syscall1(6, F)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN syscall2(7, LEN(FName), SYSTEM.ADR(FName[0]))
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
VAR
a: INTEGER;
BEGIN
a := syscall2(12, LEN(FName), SYSTEM.ADR(FName[0]))
END chmod;
PROCEDURE OutChar* (c: CHAR);
VAR
a: INTEGER;
BEGIN
a := syscall1(8, ORD(c))
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
RETURN syscall0(9)
END GetTickCount;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN syscall2(11, LEN(path), SYSTEM.ADR(path[0])) # 0
END isRelative;
PROCEDURE UnixTime* (): INTEGER;
RETURN syscall0(10)
END UnixTime;
PROCEDURE s2d (x: INTEGER; VAR h, l: INTEGER);
VAR
s, e, f: INTEGER;
BEGIN
s := ASR(x, 31) MOD 2;
f := x MOD 800000H;
e := (x DIV 800000H) MOD 256;
IF e = 255 THEN
e := 2047
ELSE
INC(e, 896)
END;
h := LSL(s, 31) + LSL(e, 20) + (f DIV 8);
l := (f MOD 8) * 20000000H
END s2d;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
i: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), i)
RETURN i
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
s2d(d2s(x), b, a)
RETURN a
END splitf;
BEGIN
maxreal := 1.9;
PACK(maxreal, 127)
END HOST.

/programs/develop/oberon07/lib/RVM32I/Out.ob07
0,0 → 1,273
(*
BSD 2-Clause License
Copyright (c) 2016, 2018, 2020, Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT HOST, SYSTEM;
PROCEDURE Char* (c: CHAR);
BEGIN
HOST.OutChar(c)
END Char;
PROCEDURE String* (s: ARRAY OF CHAR);
VAR
i, n: INTEGER;
BEGIN
n := LENGTH(s) - 1;
FOR i := 0 TO n DO
Char(s[i])
END
END String;
PROCEDURE Int* (x, width: INTEGER);
VAR
i, a: INTEGER;
str: ARRAY 12 OF CHAR;
BEGIN
IF x = 80000000H THEN
COPY("-2147483648", str);
DEC(width, 11)
ELSE
i := 0;
IF x < 0 THEN
x := -x;
i := 1;
str[0] := "-"
END;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
DEC(width, i);
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END;
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
String(str)
END Int;
PROCEDURE Inf (x: REAL; width: INTEGER);
VAR
s: ARRAY 5 OF CHAR;
BEGIN
DEC(width, 4);
IF x # x THEN
s := " Nan"
ELSIF x = SYSTEM.INF() THEN
s := "+Inf"
ELSIF x = -SYSTEM.INF() THEN
s := "-Inf"
END;
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
String(s)
END Inf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
PROCEDURE unpk10 (VAR x: REAL; VAR n: INTEGER);
VAR
a, b: REAL;
BEGIN
ASSERT(x > 0.0);
n := 0;
WHILE x < 1.0 DO
x := x * 10.0;
DEC(n)
END;
a := 10.0;
b := 1.0;
WHILE a <= x DO
b := a;
a := a * 10.0;
INC(n)
END;
x := x / b
END unpk10;
PROCEDURE _Real (x: REAL; width: INTEGER);
VAR
n, k, p: INTEGER;
BEGIN
p := MIN(MAX(width - 7, 1), 10);
width := width - p - 7;
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
IF x < 0.0 THEN
Char("-");
x := -x
ELSE
Char(20X)
END;
unpk10(x, n);
k := FLOOR(x);
Char(CHR(k + 30H));
Char(".");
WHILE p > 0 DO
x := (x - FLT(k)) * 10.0;
k := FLOOR(x);
Char(CHR(k + 30H));
DEC(p)
END;
Char("E");
IF n >= 0 THEN
Char("+")
ELSE
Char("-")
END;
n := ABS(n);
Char(CHR(n DIV 10 + 30H));
Char(CHR(n MOD 10 + 30H))
END _Real;
PROCEDURE Real* (x: REAL; width: INTEGER);
BEGIN
IF (x # x) OR (ABS(x) = SYSTEM.INF()) THEN
Inf(x, width)
ELSIF x = 0.0 THEN
WHILE width > 17 DO
Char(20X);
DEC(width)
END;
DEC(width, 8);
String(" 0.0");
WHILE width > 0 DO
Char("0");
DEC(width)
END;
String("E+00")
ELSE
_Real(x, width)
END
END Real;
PROCEDURE _FixReal (x: REAL; width, p: INTEGER);
VAR
n, k: INTEGER;
minus: BOOLEAN;
BEGIN
minus := x < 0.0;
IF minus THEN
x := -x
END;
unpk10(x, n);
DEC(width, 3 + MAX(p, 0) + MAX(n, 0));
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
IF minus THEN
Char("-")
ELSE
Char(20X)
END;
IF n < 0 THEN
INC(n);
Char("0");
Char(".");
WHILE (n < 0) & (p > 0) DO
Char("0");
INC(n);
DEC(p)
END
ELSE
WHILE n >= 0 DO
k := FLOOR(x);
Char(CHR(k + 30H));
x := (x - FLT(k)) * 10.0;
DEC(n)
END;
Char(".")
END;
WHILE p > 0 DO
k := FLOOR(x);
Char(CHR(k + 30H));
x := (x - FLT(k)) * 10.0;
DEC(p)
END
END _FixReal;
PROCEDURE FixReal* (x: REAL; width, p: INTEGER);
BEGIN
IF (x # x) OR (ABS(x) = SYSTEM.INF()) THEN
Inf(x, width)
ELSIF x = 0.0 THEN
DEC(width, 3 + MAX(p, 0));
WHILE width > 0 DO
Char(20X);
DEC(width)
END;
String(" 0.");
WHILE p > 0 DO
Char("0");
DEC(p)
END
ELSE
_FixReal(x, width, p)
END
END FixReal;
PROCEDURE Open*;
END Open;
END Out.

/programs/develop/oberon07/lib/RVM32I/RTL.ob07
0,0 → 1,390
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, F := FPU, Trap;
CONST
bit_depth = 32;
maxint = 7FFFFFFFH;
minint = 80000000H;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
VAR
Heap, Types, TypesCount: INTEGER;
PROCEDURE _error* (modnum, _module, err, line: INTEGER);
BEGIN
Trap.trap(modnum, _module, err, line)
END _error;
PROCEDURE _fmul* (b, a: INTEGER): INTEGER;
RETURN F.mul(b, a)
END _fmul;
PROCEDURE _fdiv* (b, a: INTEGER): INTEGER;
RETURN F._div(b, a)
END _fdiv;
PROCEDURE _fdivi* (b, a: INTEGER): INTEGER;
RETURN F._div(a, b)
END _fdivi;
PROCEDURE _fadd* (b, a: INTEGER): INTEGER;
RETURN F.add(b, a)
END _fadd;
PROCEDURE _fsub* (b, a: INTEGER): INTEGER;
RETURN F.sub(b, a)
END _fsub;
PROCEDURE _fsubi* (b, a: INTEGER): INTEGER;
RETURN F.sub(a, b)
END _fsubi;
PROCEDURE _fcmp* (op, b, a: INTEGER): BOOLEAN;
RETURN F.cmp(op, b, a)
END _fcmp;
PROCEDURE _floor* (x: INTEGER): INTEGER;
RETURN F.floor(x)
END _floor;
PROCEDURE _flt* (x: INTEGER): INTEGER;
RETURN F.flt(x)
END _flt;
PROCEDURE _pack* (n: INTEGER; VAR x: SET);
BEGIN
n := LSL((LSR(ORD(x), 23) MOD 256 + n) MOD 256, 23);
x := x - {23..30} + BITS(n)
END _pack;
PROCEDURE _unpk* (VAR n: INTEGER; VAR x: SET);
BEGIN
n := LSR(ORD(x), 23) MOD 256 - 127;
x := x - {30} + {23..29}
END _unpk;
PROCEDURE _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 _set* (b, a: INTEGER): INTEGER;
BEGIN
IF (a <= b) & (a <= MAX_SET) & (b >= 0) THEN
IF b > MAX_SET THEN
b := MAX_SET
END;
IF a < 0 THEN
a := 0
END;
a := LSR(ASR(minint, b - a), MAX_SET - b)
ELSE
a := 0
END
RETURN a
END _set;
PROCEDURE _set1* (a: INTEGER): INTEGER;
BEGIN
IF ASR(a, 5) = 0 THEN
a := LSL(1, a)
ELSE
a := 0
END
RETURN a
END _set1;
PROCEDURE _length* (len, str: INTEGER): INTEGER;
VAR
c: CHAR;
res: INTEGER;
BEGIN
res := 0;
REPEAT
SYSTEM.GET(str, c);
INC(str);
DEC(len);
INC(res)
UNTIL (len = 0) OR (c = 0X);
RETURN res - ORD(c = 0X)
END _length;
PROCEDURE _move* (bytes, dest, source: INTEGER);
VAR
b: BYTE;
i: INTEGER;
BEGIN
WHILE ((source MOD WORD # 0) OR (dest MOD WORD # 0)) & (bytes > 0) DO
SYSTEM.GET(source, b);
SYSTEM.PUT8(dest, b);
INC(source);
INC(dest);
DEC(bytes)
END;
WHILE bytes >= WORD DO
SYSTEM.GET(source, i);
SYSTEM.PUT(dest, i);
INC(source, WORD);
INC(dest, WORD);
DEC(bytes, WORD)
END;
WHILE bytes > 0 DO
SYSTEM.GET(source, b);
SYSTEM.PUT8(dest, b);
INC(source);
INC(dest);
DEC(bytes)
END
END _move;
PROCEDURE _lengthw* (len, str: INTEGER): INTEGER;
VAR
c: WCHAR;
res: INTEGER;
BEGIN
res := 0;
REPEAT
SYSTEM.GET(str, c);
INC(str, 2);
DEC(len);
INC(res)
UNTIL (len = 0) OR (c = 0X);
RETURN res - ORD(c = 0X)
END _lengthw;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a);
SYSTEM.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmp;
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a, 2);
SYSTEM.GET(b, B); INC(b, 2);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = WCHR(0) THEN
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmpw;
PROCEDURE _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 _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE _new* (t, size: INTEGER; VAR p: INTEGER);
BEGIN
IF Heap + size < Trap.sp() - 64 THEN
p := Heap + WORD;
REPEAT
SYSTEM.PUT(Heap, t);
INC(Heap, WORD);
DEC(size, WORD);
t := 0
UNTIL size = 0
ELSE
p := 0
END
END _new;
PROCEDURE _guard* (t, p: INTEGER): BOOLEAN;
VAR
_type: INTEGER;
BEGIN
SYSTEM.GET(p, p);
IF p # 0 THEN
SYSTEM.GET(p - WORD, _type);
WHILE (_type # t) & (_type # 0) DO
SYSTEM.GET(Types + _type * WORD, _type)
END
ELSE
_type := t
END
RETURN _type = t
END _guard;
PROCEDURE _is* (t, p: INTEGER): BOOLEAN;
VAR
_type: INTEGER;
BEGIN
_type := 0;
IF p # 0 THEN
SYSTEM.GET(p - WORD, _type);
WHILE (_type # t) & (_type # 0) DO
SYSTEM.GET(Types + _type * WORD, _type)
END
END
RETURN _type = t
END _is;
PROCEDURE _guardrec* (t0, t1: INTEGER): BOOLEAN;
BEGIN
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(Types + t1 * WORD, t1)
END
RETURN t1 = t0
END _guardrec;
PROCEDURE _init* (tcount, heap, types: INTEGER);
BEGIN
Heap := heap;
TypesCount := tcount;
Types := types
END _init;
END RTL.

/programs/develop/oberon07/lib/RVM32I/Trap.ob07
0,0 → 1,128
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Trap;
IMPORT SYSTEM;
PROCEDURE [code] sp* (): INTEGER
22, 0, 4; (* MOV R0, SP *)
PROCEDURE [code] syscall* (ptr: INTEGER)
22, 0, 4, (* MOV R0, SP *)
27, 0, 4, (* ADD R0, 4 *)
9, 0, 0, (* LDR32 R0, R0 *)
80, 0, 0; (* SYSCALL R0 *)
PROCEDURE Char (c: CHAR);
VAR
a: ARRAY 2 OF INTEGER;
BEGIN
a[0] := 8;
a[1] := ORD(c);
syscall(SYSTEM.ADR(a[0]))
END Char;
PROCEDURE String (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE s[i] # 0X DO
Char(s[i]);
INC(i)
END
END String;
PROCEDURE PString (ptr: INTEGER);
VAR
c: CHAR;
BEGIN
SYSTEM.GET(ptr, c);
WHILE c # 0X DO
Char(c);
INC(ptr);
SYSTEM.GET(ptr, c)
END
END PString;
PROCEDURE Ln;
BEGIN
String(0DX + 0AX)
END Ln;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END IntToStr;
PROCEDURE Int (x: INTEGER);
VAR
s: ARRAY 32 OF CHAR;
BEGIN
IntToStr(x, s);
String(s)
END Int;
PROCEDURE trap* (modnum, _module, err, line: INTEGER);
VAR
s: ARRAY 32 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;
Ln;
String("error ("); Int(err); String("): "); String(s); Ln;
String("module: "); PString(_module); Ln;
String("line: "); Int(line); Ln;
SYSTEM.CODE(0, 0, 0) (* STOP *)
END trap;
END Trap.