XenOn/kolibrios-fun
1
1
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Wiki Activity

Update oberon07 from akron1's github

Browse Source 
git-svn-id: svn://kolibrios.org@8097 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
maxcodehack 2020-10-13 07:58:51 +00:00
parent ed41eb9aa3
commit 2f54c7de00
147 changed files with 15779 additions and 5223 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
programs/develop/oberon07/Compiler
View File

Binary file not shown.

BIN
programs/develop/oberon07/Compiler.exe
View File

Binary file not shown.

BIN
programs/develop/oberon07/Compiler.kex
View File

Binary file not shown.

2
programs/develop/oberon07/GitHub.url
View File

@ -1,2 +0,0 @@
[InternetShortcut]
URL=https://github.com/AntKrotov/oberon-07-compiler

17
programs/develop/oberon07/Lib/KolibriOS/API.ob07
View File

@ -12,6 +12,8 @@ IMPORT SYSTEM, K := KOSAPI;
CONST
eol* = 0DX + 0AX;
MAX_SIZE = 16 * 400H;
HEAP_SIZE = 1 * 100000H;
@ -33,9 +35,8 @@ VAR
CriticalSection: CRITICAL_SECTION;
import*, multi: BOOLEAN;
_import*, multi: BOOLEAN;
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
@ -284,24 +285,24 @@ PROCEDURE imp_error;
BEGIN
OutString("import error: ");
IF K.imp_error.error = 1 THEN
OutString("can't load "); OutString(K.imp_error.lib)
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)
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);
PROCEDURE init* (import_, code: INTEGER);
BEGIN
multi := FALSE;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
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
_import := (K.dll_Load(import_) = 0) & (K.imp_error.error = 0);
IF ~_import THEN
imp_error
END
END init;

6
programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016, 2018 Anton Krotov
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
@ -24,7 +24,7 @@ TYPE
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
type,
_type,
procinfo,
com_area_name,
com_area,
@ -61,7 +61,7 @@ BEGIN
IF res # NIL THEN
res.s_com_area_name := "FFFFFFFF_color_dlg";
res.com_area := 0;
res.type := 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]);

92
programs/develop/oberon07/Lib/KolibriOS/HOST.ob07
View File

@ -13,7 +13,7 @@ IMPORT SYSTEM, K := KOSAPI, API, RTL;
CONST
slash* = "/";
OS* = "KOS";
eol* = 0DX + 0AX;
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
@ -24,6 +24,8 @@ CONST
TYPE
DAYS = ARRAY 12, 31, 2 OF INTEGER;
FNAME = ARRAY 520 OF CHAR;
FS = POINTER TO rFS;
@ -52,11 +54,11 @@ VAR
Console: BOOLEAN;
days: DAYS;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
@ -273,6 +275,10 @@ BEGIN
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
END chmod;
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9)
END GetTickCount;
@ -382,8 +388,8 @@ BEGIN
s[j] := c;
INC(j)
END;
INC(i);
END;
INC(i)
END
END;
s[j] := 0X
END GetArg;
@ -408,9 +414,9 @@ PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
PROCEDURE UnixTime* (): INTEGER;
VAR
date, time: INTEGER;
date, time, year, month, day, hour, min, sec: INTEGER;
BEGIN
date := K.sysfunc1(29);
@ -446,22 +452,26 @@ BEGIN
sec := (time MOD 16) * 10 + sec;
time := time DIV 16;
year := year + 2000
END now;
INC(year, 2000)
PROCEDURE UnixTime* (): INTEGER;
RETURN 0
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
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
@ -480,7 +490,7 @@ BEGIN
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (l # 0) THEN
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
@ -491,21 +501,55 @@ BEGIN
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), a);
SYSTEM.GET(SYSTEM.ADR(x) + 4, b)
RETURN a
END splitf;
PROCEDURE init (VAR days: DAYS);
VAR
i, j, n0, n1: INTEGER;
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
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;
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.

92
programs/develop/oberon07/Lib/KolibriOS/Math.ob07
View File

@ -1,18 +1,8 @@
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2013-2014, 2018-2020 Anton Krotov
All rights reserved.
*)
MODULE Math;
@ -235,6 +225,16 @@ BEGIN
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;
@ -349,6 +349,40 @@ BEGIN
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;
@ -381,4 +415,36 @@ BEGIN
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.

8
programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016, 2018 Anton Krotov
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
@ -24,7 +24,7 @@ TYPE
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
type,
_type,
procinfo,
com_area_name,
com_area,
@ -66,7 +66,7 @@ BEGIN
END
END Show;
PROCEDURE Create*(draw_window: DRAW_WINDOW; type: INTEGER; def_path, filter: ARRAY OF CHAR): Dialog;
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);
@ -88,7 +88,7 @@ BEGIN
IF res.filter_area # NIL THEN
res.s_com_area_name := "FFFFFFFF_open_dialog";
res.com_area := 0;
res.type := type;
res._type := _type;
res.draw_window := draw_window;
COPY(def_path, res.s_dir_default_path);
COPY(filter, res.filter_area.filter);

49
programs/develop/oberon07/Lib/KolibriOS/RTL.ob07
View File

@ -372,33 +372,29 @@ END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
INC(i);
a := a DIV 10
UNTIL a = 0;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
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, i, j: INTEGER;
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
@ -406,19 +402,12 @@ BEGIN
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE [stdcall] _error* (module, err, line: INTEGER);
PROCEDURE [stdcall] _error* (modnum, _module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
@ -437,10 +426,8 @@ BEGIN
|11: s := "BYTE out of range"
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
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);

4
programs/develop/oberon07/Lib/KolibriOS/libimg.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016, 2018 KolibriOS team
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
@ -203,7 +203,7 @@ VAR
img_create *: PROCEDURE (width, height, type: INTEGER): INTEGER;
img_create *: PROCEDURE (width, height, _type: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? creates an Image structure and initializes some its fields ;;

86
programs/develop/oberon07/Lib/Linux32/API.ob07
View File

@ -12,54 +12,34 @@ IMPORT SYSTEM;
CONST
RTLD_LAZY* = 1;
eol* = 0AX;
BIT_DEPTH* = 32;
RTLD_LAZY = 1;
TYPE
TP* = ARRAY 2 OF INTEGER;
SOFINI* = PROCEDURE;
SOFINI = PROCEDURE;
VAR
eol*: ARRAY 2 OF CHAR;
MainParam*: INTEGER;
MainParam*, libc*: INTEGER;
libc*, librt*: INTEGER;
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): INTEGER;
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): INTEGER;
stdout*,
stdin*,
stderr* : INTEGER;
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
_exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
exit*,
exit_thread* : PROCEDURE [linux] (code: INTEGER);
puts : PROCEDURE [linux] (pStr: INTEGER);
malloc : PROCEDURE [linux] (size: INTEGER): INTEGER;
free : PROCEDURE [linux] (ptr: INTEGER);
fini: SOFINI;
PROCEDURE putc* (c: CHAR);
VAR
res: INTEGER;
BEGIN
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END putc;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
puts(lpCaption);
@ -94,7 +74,7 @@ BEGIN
END _DISPOSE;
PROCEDURE GetProcAdr (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
@ -102,7 +82,7 @@ BEGIN
sym := dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetProcAdr;
END GetSym;
PROCEDURE init* (sp, code: INTEGER);
@ -111,42 +91,16 @@ BEGIN
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
eol := 0AX;
libc := dlopen(SYSTEM.SADR("libc.so.6"), RTLD_LAZY);
GetProcAdr(libc, "malloc", SYSTEM.ADR(malloc));
GetProcAdr(libc, "free", SYSTEM.ADR(free));
GetProcAdr(libc, "exit", SYSTEM.ADR(_exit));
GetProcAdr(libc, "stdout", SYSTEM.ADR(stdout));
GetProcAdr(libc, "stdin", SYSTEM.ADR(stdin));
GetProcAdr(libc, "stderr", SYSTEM.ADR(stderr));
SYSTEM.GET(stdout - SYSTEM.SIZE(INTEGER), stdout);
SYSTEM.GET(stdin - SYSTEM.SIZE(INTEGER), stdin);
SYSTEM.GET(stderr - SYSTEM.SIZE(INTEGER), stderr);
GetProcAdr(libc, "puts", SYSTEM.ADR(puts));
GetProcAdr(libc, "fwrite", SYSTEM.ADR(fwrite));
GetProcAdr(libc, "fread", SYSTEM.ADR(fread));
GetProcAdr(libc, "fopen", SYSTEM.ADR(fopen));
GetProcAdr(libc, "fclose", SYSTEM.ADR(fclose));
GetProcAdr(libc, "time", SYSTEM.ADR(time));
librt := dlopen(SYSTEM.SADR("librt.so.1"), RTLD_LAZY);
GetProcAdr(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
GetSym(libc, "exit", SYSTEM.ADR(exit_thread));
exit := exit_thread;
GetSym(libc, "puts", SYSTEM.ADR(puts));
GetSym(libc, "malloc", SYSTEM.ADR(malloc));
GetSym(libc, "free", SYSTEM.ADR(free));
END init;
PROCEDURE exit* (code: INTEGER);
BEGIN
_exit(code)
END exit;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
_exit(code)
END exit_thread;
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;

70
programs/develop/oberon07/Lib/Linux32/Args.ob07 Normal file
View File

@ -0,0 +1,70 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Args;
IMPORT SYSTEM, API;
VAR
argc*, envc*: INTEGER;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (0 <= n) & (n <= argc + envc) & (n # argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetEnv* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
IF (0 <= n) & (n < envc) THEN
GetArg(n + argc + 1, s)
ELSE
s[0] := 0X
END
END GetEnv;
PROCEDURE init;
VAR
ptr: INTEGER;
BEGIN
IF API.MainParam # 0 THEN
envc := -1;
SYSTEM.GET(API.MainParam, argc);
REPEAT
SYSTEM.GET(API.MainParam + (envc + argc + 3) * SYSTEM.SIZE(INTEGER), ptr);
INC(envc)
UNTIL ptr = 0
ELSE
envc := 0;
argc := 0
END
END init;
BEGIN
init
END Args.

132
programs/develop/oberon07/Lib/Linux32/File.ob07 Normal file
View File

@ -0,0 +1,132 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE File;
IMPORT SYSTEM, Libdl, API;
CONST
OPEN_R* = "rb"; OPEN_W* = "wb"; OPEN_RW* = "r+b";
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
VAR
fwrite,
fread : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fseek : PROCEDURE [linux] (file, offset, origin: INTEGER): INTEGER;
ftell : PROCEDURE [linux] (file: INTEGER): INTEGER;
fopen : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose : PROCEDURE [linux] (file: INTEGER): INTEGER;
remove : PROCEDURE [linux] (fname: INTEGER): INTEGER;
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
sym := Libdl.sym(lib, name);
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetSym;
PROCEDURE init;
VAR
libc: INTEGER;
BEGIN
libc := Libdl.open("libc.so.6", Libdl.LAZY);
ASSERT(libc # 0);
GetSym(libc, "fread", SYSTEM.ADR(fread));
GetSym(libc, "fwrite", SYSTEM.ADR(fwrite));
GetSym(libc, "fseek", SYSTEM.ADR(fseek));
GetSym(libc, "ftell", SYSTEM.ADR(ftell));
GetSym(libc, "fopen", SYSTEM.ADR(fopen));
GetSym(libc, "fclose", SYSTEM.ADR(fclose));
GetSym(libc, "remove", SYSTEM.ADR(remove));
END init;
PROCEDURE Delete* (FName: ARRAY OF CHAR): BOOLEAN;
RETURN remove(SYSTEM.ADR(FName[0])) = 0
END Delete;
PROCEDURE Close* (F: INTEGER);
BEGIN
F := fclose(F)
END Close;
PROCEDURE Open* (FName, Mode: ARRAY OF CHAR): INTEGER;
RETURN fopen(SYSTEM.ADR(FName[0]), SYSTEM.ADR(Mode[0]))
END Open;
PROCEDURE Create* (FName: ARRAY OF CHAR): INTEGER;
RETURN Open(FName, OPEN_W)
END Create;
PROCEDURE Seek* (F, Offset, Origin: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF fseek(F, Offset, Origin) = 0 THEN
res := ftell(F)
ELSE
res := -1
END
RETURN res
END Seek;
PROCEDURE Write* (F, Buffer, Count: INTEGER): INTEGER;
RETURN fwrite(Buffer, 1, Count, F)
END Write;
PROCEDURE Read* (F, Buffer, Count: INTEGER): INTEGER;
RETURN fread(Buffer, 1, Count, F)
END Read;
PROCEDURE Load* (FName: ARRAY OF CHAR; VAR Size: INTEGER): INTEGER;
VAR
res, n, F: INTEGER;
BEGIN
res := 0;
F := Open(FName, OPEN_R);
IF F > 0 THEN
Size := Seek(F, 0, SEEK_END);
n := Seek(F, 0, SEEK_BEG);
res := API._NEW(Size);
IF (res = 0) OR (Read(F, res, Size) # Size) THEN
IF res # 0 THEN
res := API._DISPOSE(res);
Size := 0
END
END;
Close(F)
END
RETURN res
END Load;
BEGIN
init
END File.

102
programs/develop/oberon07/Lib/Linux32/HOST.ob07
View File

@ -13,25 +13,42 @@ IMPORT SYSTEM, API, RTL;
CONST
slash* = "/";
OS* = "LINUX";
eol* = 0AX;
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
RTLD_LAZY = 1;
TYPE
TP = ARRAY 2 OF INTEGER;
VAR
maxreal*: REAL;
argc: INTEGER;
eol*: ARRAY 2 OF CHAR;
libc, librt: INTEGER;
maxreal*: REAL;
stdout: INTEGER;
fread, fwrite : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose : PROCEDURE [linux] (file: INTEGER): INTEGER;
_chmod : PROCEDURE [linux] (fname: INTEGER; mode: SET): INTEGER;
time : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
clock_gettime : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
exit : PROCEDURE [linux] (code: INTEGER);
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
API.exit(code)
exit(code)
END ExitProcess;
@ -75,7 +92,7 @@ VAR
res: INTEGER;
BEGIN
res := API.fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
res := fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
@ -89,7 +106,7 @@ VAR
res: INTEGER;
BEGIN
res := API.fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
res := fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
@ -99,34 +116,45 @@ END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
RETURN fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
END FileCreate;
PROCEDURE FileClose* (File: INTEGER);
BEGIN
File := API.fclose(File)
File := fclose(File)
END FileClose;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
VAR
res: INTEGER;
BEGIN
res := _chmod(SYSTEM.ADR(FName[0]), {0, 2..8}) (* rwxrwxr-x *)
END chmod;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
RETURN fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
END FileOpen;
PROCEDURE OutChar* (c: CHAR);
VAR
res: INTEGER;
BEGIN
API.putc(c)
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
VAR
tp: API.TP;
tp: TP;
res: INTEGER;
BEGIN
IF API.clock_gettime(0, tp) = 0 THEN
IF clock_gettime(0, tp) = 0 THEN
res := tp[0] * 100 + tp[1] DIV 10000000
ELSE
res := 0
@ -141,22 +169,25 @@ PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN API.time(0)
RETURN time(0)
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
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
@ -175,7 +206,7 @@ BEGIN
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (l # 0) THEN
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
@ -186,23 +217,32 @@ BEGIN
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
res: INTEGER;
sym: INTEGER;
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
sym := API.dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetSym;
BEGIN
eol := 0AX;
maxreal := 1.9;
PACK(maxreal, 1023);
SYSTEM.GET(API.MainParam, argc)
SYSTEM.GET(API.MainParam, argc);
libc := API.libc;
GetSym(libc, "fread", SYSTEM.ADR(fread));
GetSym(libc, "fwrite", SYSTEM.ADR(fwrite));
GetSym(libc, "fopen", SYSTEM.ADR(fopen));
GetSym(libc, "fclose", SYSTEM.ADR(fclose));
GetSym(libc, "chmod", SYSTEM.ADR(_chmod));
GetSym(libc, "time", SYSTEM.ADR(time));
GetSym(libc, "exit", SYSTEM.ADR(exit));
GetSym(libc, "stdout", SYSTEM.ADR(stdout)); SYSTEM.GET(stdout - SYSTEM.SIZE(INTEGER), stdout);
librt := API.dlopen(SYSTEM.SADR("librt.so.1"), RTLD_LAZY);
GetSym(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END HOST.

85
programs/develop/oberon07/Lib/Linux32/In.ob07 Normal file
View File

@ -0,0 +1,85 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE In;
IMPORT SYSTEM, Libdl;
CONST
MAX_LEN = 10240;
VAR
Done*: BOOLEAN;
s: ARRAY MAX_LEN + 4 OF CHAR;
sscanf: PROCEDURE [linux] (buf: INTEGER; fmt: INTEGER; adr: INTEGER): INTEGER;
gets: PROCEDURE [linux] (buf: INTEGER);
PROCEDURE String* (VAR str: ARRAY OF CHAR);
BEGIN
gets(SYSTEM.ADR(s[0]));
COPY(s, str);
str[LEN(str) - 1] := 0X;
Done := TRUE
END String;
PROCEDURE Int* (VAR x: INTEGER);
BEGIN
String(s);
Done := sscanf(SYSTEM.ADR(s[0]), SYSTEM.SADR("%d"), SYSTEM.ADR(x)) = 1
END Int;
PROCEDURE Real* (VAR x: REAL);
BEGIN
String(s);
Done := sscanf(SYSTEM.ADR(s[0]), SYSTEM.SADR("%lf"), SYSTEM.ADR(x)) = 1
END Real;
PROCEDURE Char* (VAR x: CHAR);
BEGIN
String(s);
x := s[0]
END Char;
PROCEDURE Ln*;
BEGIN
String(s)
END Ln;
PROCEDURE Open*;
BEGIN
Done := TRUE
END Open;
PROCEDURE init;
VAR
libc: INTEGER;
BEGIN
libc := Libdl.open("libc.so.6", Libdl.LAZY);
ASSERT(libc # 0);
SYSTEM.PUT(SYSTEM.ADR(sscanf), Libdl.sym(libc, "sscanf"));
ASSERT(sscanf # NIL);
SYSTEM.PUT(SYSTEM.ADR(gets), Libdl.sym(libc, "gets"));
ASSERT(gets # NIL);
END init;
BEGIN
init
END In.

89
programs/develop/oberon07/Lib/Linux32/LINAPI.ob07
View File

@ -7,19 +7,17 @@
MODULE LINAPI;
IMPORT SYSTEM, API;
IMPORT SYSTEM, API, Libdl;
TYPE
TP* = API.TP;
SOFINI* = API.SOFINI;
TP* = ARRAY 2 OF INTEGER;
SOFINI* = PROCEDURE;
VAR
argc*, envc*: INTEGER;
libc*, librt*: INTEGER;
stdout*,
@ -39,79 +37,44 @@ VAR
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (0 <= n) & (n <= argc + envc) & (n # argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetEnv* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
IF (0 <= n) & (n < envc) THEN
GetArg(n + argc + 1, s)
ELSE
s[0] := 0X
END
END GetEnv;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
API.SetFini(ProcFini)
END SetFini;
PROCEDURE init;
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
ptr: INTEGER;
sym: INTEGER;
BEGIN
IF API.MainParam # 0 THEN
envc := -1;
SYSTEM.GET(API.MainParam, argc);
REPEAT
SYSTEM.GET(API.MainParam + (envc + argc + 3) * SYSTEM.SIZE(INTEGER), ptr);
INC(envc)
UNTIL ptr = 0
ELSE
envc := 0;
argc := 0
END;
sym := Libdl.sym(lib, name);
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetSym;
PROCEDURE init;
BEGIN
libc := API.libc;
stdout := API.stdout;
stdin := API.stdin;
stderr := API.stderr;
GetSym(libc, "exit", SYSTEM.ADR(exit));
GetSym(libc, "puts", SYSTEM.ADR(puts));
GetSym(libc, "malloc", SYSTEM.ADR(malloc));
GetSym(libc, "free", SYSTEM.ADR(free));
GetSym(libc, "fread", SYSTEM.ADR(fread));
GetSym(libc, "fwrite", SYSTEM.ADR(fwrite));
GetSym(libc, "fopen", SYSTEM.ADR(fopen));
GetSym(libc, "fclose", SYSTEM.ADR(fclose));
GetSym(libc, "time", SYSTEM.ADR(time));
malloc := API.malloc;
free := API.free;
exit := API._exit;
puts := API.puts;
fwrite := API.fwrite;
fread := API.fread;
fopen := API.fopen;
fclose := API.fclose;
time := API.time;
GetSym(libc, "stdout", SYSTEM.ADR(stdout)); SYSTEM.GET(stdout - SYSTEM.SIZE(INTEGER), stdout);
GetSym(libc, "stdin", SYSTEM.ADR(stdin)); SYSTEM.GET(stdin - SYSTEM.SIZE(INTEGER), stdin);
GetSym(libc, "stderr", SYSTEM.ADR(stderr)); SYSTEM.GET(stderr - SYSTEM.SIZE(INTEGER), stderr);
librt := API.librt;
librt := Libdl.open("librt.so.1", Libdl.LAZY);
clock_gettime := API.clock_gettime
GetSym(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END init;

92
programs/develop/oberon07/Lib/Linux32/Math.ob07
View File

@ -1,18 +1,8 @@
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2013-2014, 2018-2020 Anton Krotov
All rights reserved.
*)
MODULE Math;
@ -235,6 +225,16 @@ BEGIN
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;
@ -349,6 +349,40 @@ BEGIN
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;
@ -381,4 +415,36 @@ BEGIN
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.

284
programs/develop/oberon07/Lib/Linux32/Out.ob07
View File

@ -1,277 +1,77 @@
(*
Copyright 2013, 2014, 2017, 2018, 2019 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, Libdl;
CONST
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: REAL; width: INTEGER);
printf1: PROCEDURE [linux] (fmt: INTEGER; x: INTEGER);
printf2: PROCEDURE [linux] (fmt: INTEGER; width, x: INTEGER);
printf3: PROCEDURE [linux] (fmt: INTEGER; width, precision: INTEGER; x: REAL);
PROCEDURE Char*(x: CHAR);
PROCEDURE Char* (x: CHAR);
BEGIN
API.putc(x)
printf1(SYSTEM.SADR("%c"), ORD(x))
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR
i: INTEGER;
PROCEDURE String* (s: ARRAY OF CHAR);
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
Char(s[i]);
INC(i)
END
printf2(SYSTEM.SADR("%.*s"), LENGTH(s), SYSTEM.ADR(s[0]))
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
sys.GET(sys.ADR(AValue) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0AX)
printf1(SYSTEM.SADR("%s"), SYSTEM.SADR(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;
PROCEDURE Int* (x, width: INTEGER);
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
printf2(SYSTEM.SADR("%*d"), width, x)
END Int;
PROCEDURE Real* (x: REAL; width: INTEGER);
BEGIN
printf3(SYSTEM.SADR("%*.*E"), width, MAX(MIN(width - 8, 15), 1), x)
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
PROCEDURE FixReal* (x: REAL; width, precision: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
printf3(SYSTEM.SADR("%*.*f"), width, precision, x)
END FixReal;
PROCEDURE Open*;
END Open;
PROCEDURE init;
VAR
libc, printf: INTEGER;
BEGIN
libc := Libdl.open("libc.so.6", Libdl.LAZY);
ASSERT(libc # 0);
printf := Libdl.sym(libc, "printf");
ASSERT(printf # 0);
SYSTEM.PUT(SYSTEM.ADR(printf1), printf);
SYSTEM.PUT(SYSTEM.ADR(printf2), printf);
SYSTEM.PUT(SYSTEM.ADR(printf3), printf);
END init;
BEGIN
init
END Out.

49
programs/develop/oberon07/Lib/Linux32/RTL.ob07
View File

@ -372,33 +372,29 @@ END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
INC(i);
a := a DIV 10
UNTIL a = 0;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
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, i, j: INTEGER;
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
@ -406,19 +402,12 @@ BEGIN
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE [stdcall] _error* (module, err, line: INTEGER);
PROCEDURE [stdcall] _error* (modnum, _module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
@ -437,10 +426,8 @@ BEGIN
|11: s := "BYTE out of range"
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
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);

86
programs/develop/oberon07/Lib/Linux64/API.ob07
View File

@ -12,54 +12,34 @@ IMPORT SYSTEM;
CONST
RTLD_LAZY* = 1;
eol* = 0AX;
BIT_DEPTH* = 64;
RTLD_LAZY = 1;
TYPE
TP* = ARRAY 2 OF INTEGER;
SOFINI* = PROCEDURE;
SOFINI = PROCEDURE;
VAR
eol*: ARRAY 2 OF CHAR;
MainParam*: INTEGER;
MainParam*, libc*: INTEGER;
libc*, librt*: INTEGER;
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): INTEGER;
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): INTEGER;
stdout*,
stdin*,
stderr* : INTEGER;
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
_exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
exit*,
exit_thread* : PROCEDURE [linux] (code: INTEGER);
puts : PROCEDURE [linux] (pStr: INTEGER);
malloc : PROCEDURE [linux] (size: INTEGER): INTEGER;
free : PROCEDURE [linux] (ptr: INTEGER);
fini: SOFINI;
PROCEDURE putc* (c: CHAR);
VAR
res: INTEGER;
BEGIN
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END putc;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
puts(lpCaption);
@ -94,7 +74,7 @@ BEGIN
END _DISPOSE;
PROCEDURE GetProcAdr (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
@ -102,7 +82,7 @@ BEGIN
sym := dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetProcAdr;
END GetSym;
PROCEDURE init* (sp, code: INTEGER);
@ -111,42 +91,16 @@ BEGIN
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
eol := 0AX;
libc := dlopen(SYSTEM.SADR("libc.so.6"), RTLD_LAZY);
GetProcAdr(libc, "malloc", SYSTEM.ADR(malloc));
GetProcAdr(libc, "free", SYSTEM.ADR(free));
GetProcAdr(libc, "exit", SYSTEM.ADR(_exit));
GetProcAdr(libc, "stdout", SYSTEM.ADR(stdout));
GetProcAdr(libc, "stdin", SYSTEM.ADR(stdin));
GetProcAdr(libc, "stderr", SYSTEM.ADR(stderr));
SYSTEM.GET(stdout - SYSTEM.SIZE(INTEGER), stdout);
SYSTEM.GET(stdin - SYSTEM.SIZE(INTEGER), stdin);
SYSTEM.GET(stderr - SYSTEM.SIZE(INTEGER), stderr);
GetProcAdr(libc, "puts", SYSTEM.ADR(puts));
GetProcAdr(libc, "fwrite", SYSTEM.ADR(fwrite));
GetProcAdr(libc, "fread", SYSTEM.ADR(fread));
GetProcAdr(libc, "fopen", SYSTEM.ADR(fopen));
GetProcAdr(libc, "fclose", SYSTEM.ADR(fclose));
GetProcAdr(libc, "time", SYSTEM.ADR(time));
librt := dlopen(SYSTEM.SADR("librt.so.1"), RTLD_LAZY);
GetProcAdr(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
GetSym(libc, "exit", SYSTEM.ADR(exit_thread));
exit := exit_thread;
GetSym(libc, "puts", SYSTEM.ADR(puts));
GetSym(libc, "malloc", SYSTEM.ADR(malloc));
GetSym(libc, "free", SYSTEM.ADR(free));
END init;
PROCEDURE exit* (code: INTEGER);
BEGIN
_exit(code)
END exit;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
_exit(code)
END exit_thread;
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;

70
programs/develop/oberon07/Lib/Linux64/Args.ob07 Normal file
View File

@ -0,0 +1,70 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Args;
IMPORT SYSTEM, API;
VAR
argc*, envc*: INTEGER;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (0 <= n) & (n <= argc + envc) & (n # argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetEnv* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
IF (0 <= n) & (n < envc) THEN
GetArg(n + argc + 1, s)
ELSE
s[0] := 0X
END
END GetEnv;
PROCEDURE init;
VAR
ptr: INTEGER;
BEGIN
IF API.MainParam # 0 THEN
envc := -1;
SYSTEM.GET(API.MainParam, argc);
REPEAT
SYSTEM.GET(API.MainParam + (envc + argc + 3) * SYSTEM.SIZE(INTEGER), ptr);
INC(envc)
UNTIL ptr = 0
ELSE
envc := 0;
argc := 0
END
END init;
BEGIN
init
END Args.

132
programs/develop/oberon07/Lib/Linux64/File.ob07 Normal file
View File

@ -0,0 +1,132 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE File;
IMPORT SYSTEM, Libdl, API;
CONST
OPEN_R* = "rb"; OPEN_W* = "wb"; OPEN_RW* = "r+b";
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
VAR
fwrite,
fread : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fseek : PROCEDURE [linux] (file, offset, origin: INTEGER): INTEGER;
ftell : PROCEDURE [linux] (file: INTEGER): INTEGER;
fopen : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose : PROCEDURE [linux] (file: INTEGER): INTEGER;
remove : PROCEDURE [linux] (fname: INTEGER): INTEGER;
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
sym := Libdl.sym(lib, name);
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetSym;
PROCEDURE init;
VAR
libc: INTEGER;
BEGIN
libc := Libdl.open("libc.so.6", Libdl.LAZY);
ASSERT(libc # 0);
GetSym(libc, "fread", SYSTEM.ADR(fread));
GetSym(libc, "fwrite", SYSTEM.ADR(fwrite));
GetSym(libc, "fseek", SYSTEM.ADR(fseek));
GetSym(libc, "ftell", SYSTEM.ADR(ftell));
GetSym(libc, "fopen", SYSTEM.ADR(fopen));
GetSym(libc, "fclose", SYSTEM.ADR(fclose));
GetSym(libc, "remove", SYSTEM.ADR(remove));
END init;
PROCEDURE Delete* (FName: ARRAY OF CHAR): BOOLEAN;
RETURN remove(SYSTEM.ADR(FName[0])) = 0
END Delete;
PROCEDURE Close* (F: INTEGER);
BEGIN
F := fclose(F)
END Close;
PROCEDURE Open* (FName, Mode: ARRAY OF CHAR): INTEGER;
RETURN fopen(SYSTEM.ADR(FName[0]), SYSTEM.ADR(Mode[0]))
END Open;
PROCEDURE Create* (FName: ARRAY OF CHAR): INTEGER;
RETURN Open(FName, OPEN_W)
END Create;
PROCEDURE Seek* (F, Offset, Origin: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF fseek(F, Offset, Origin) = 0 THEN
res := ftell(F)
ELSE
res := -1
END
RETURN res
END Seek;
PROCEDURE Write* (F, Buffer, Count: INTEGER): INTEGER;
RETURN fwrite(Buffer, 1, Count, F)
END Write;
PROCEDURE Read* (F, Buffer, Count: INTEGER): INTEGER;
RETURN fread(Buffer, 1, Count, F)
END Read;
PROCEDURE Load* (FName: ARRAY OF CHAR; VAR Size: INTEGER): INTEGER;
VAR
res, n, F: INTEGER;
BEGIN
res := 0;
F := Open(FName, OPEN_R);
IF F > 0 THEN
Size := Seek(F, 0, SEEK_END);
n := Seek(F, 0, SEEK_BEG);
res := API._NEW(Size);
IF (res = 0) OR (Read(F, res, Size) # Size) THEN
IF res # 0 THEN
res := API._DISPOSE(res);
Size := 0
END
END;
Close(F)
END
RETURN res
END Load;
BEGIN
init
END File.

106
programs/develop/oberon07/Lib/Linux64/HOST.ob07
View File

@ -13,25 +13,42 @@ IMPORT SYSTEM, API, RTL;
CONST
slash* = "/";
OS* = "LINUX";
eol* = 0AX;
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
RTLD_LAZY = 1;
TYPE
TP = ARRAY 2 OF INTEGER;
VAR
maxreal*: REAL;
argc: INTEGER;
eol*: ARRAY 2 OF CHAR;
libc, librt: INTEGER;
maxreal*: REAL;
stdout: INTEGER;
fread, fwrite : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose : PROCEDURE [linux] (file: INTEGER): INTEGER;
_chmod : PROCEDURE [linux] (fname: INTEGER; mode: SET): INTEGER;
time : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
clock_gettime : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
exit : PROCEDURE [linux] (code: INTEGER);
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
API.exit(code)
exit(code)
END ExitProcess;
@ -75,7 +92,7 @@ VAR
res: INTEGER;
BEGIN
res := API.fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
res := fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
@ -89,7 +106,7 @@ VAR
res: INTEGER;
BEGIN
res := API.fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
res := fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
@ -99,34 +116,45 @@ END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
RETURN fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
END FileCreate;
PROCEDURE FileClose* (File: INTEGER);
BEGIN
File := API.fclose(File)
File := fclose(File)
END FileClose;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
VAR
res: INTEGER;
BEGIN
res := _chmod(SYSTEM.ADR(FName[0]), {0, 2..8}) (* rwxrwxr-x *)
END chmod;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
RETURN fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
END FileOpen;
PROCEDURE OutChar* (c: CHAR);
VAR
res: INTEGER;
BEGIN
API.putc(c)
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
VAR
tp: API.TP;
tp: TP;
res: INTEGER;
BEGIN
IF API.clock_gettime(0, tp) = 0 THEN
IF clock_gettime(0, tp) = 0 THEN
res := tp[0] * 100 + tp[1] DIV 10000000
ELSE
res := 0
@ -141,22 +169,31 @@ PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN API.time(0)
RETURN time(0)
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
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
@ -186,23 +223,32 @@ BEGIN
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
res: INTEGER;
sym: INTEGER;
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
sym := API.dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetSym;
BEGIN
eol := 0AX;
maxreal := 1.9;
PACK(maxreal, 1023);
SYSTEM.GET(API.MainParam, argc)
SYSTEM.GET(API.MainParam, argc);
libc := API.libc;
GetSym(libc, "fread", SYSTEM.ADR(fread));
GetSym(libc, "fwrite", SYSTEM.ADR(fwrite));
GetSym(libc, "fopen", SYSTEM.ADR(fopen));
GetSym(libc, "fclose", SYSTEM.ADR(fclose));
GetSym(libc, "chmod", SYSTEM.ADR(_chmod));
GetSym(libc, "time", SYSTEM.ADR(time));
GetSym(libc, "exit", SYSTEM.ADR(exit));
GetSym(libc, "stdout", SYSTEM.ADR(stdout)); SYSTEM.GET(stdout - SYSTEM.SIZE(INTEGER), stdout);
librt := API.dlopen(SYSTEM.SADR("librt.so.1"), RTLD_LAZY);
GetSym(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END HOST.

85
programs/develop/oberon07/Lib/Linux64/In.ob07 Normal file
View File

@ -0,0 +1,85 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE In;
IMPORT SYSTEM, Libdl;
CONST
MAX_LEN = 10240;
VAR
Done*: BOOLEAN;
s: ARRAY MAX_LEN + 4 OF CHAR;
sscanf: PROCEDURE [linux] (buf: INTEGER; fmt: INTEGER; adr: INTEGER): INTEGER;
gets: PROCEDURE [linux] (buf: INTEGER);
PROCEDURE String* (VAR str: ARRAY OF CHAR);
BEGIN
gets(SYSTEM.ADR(s[0]));
COPY(s, str);
str[LEN(str) - 1] := 0X;
Done := TRUE
END String;
PROCEDURE Int* (VAR x: INTEGER);
BEGIN
String(s);
Done := sscanf(SYSTEM.ADR(s[0]), SYSTEM.SADR("%lld"), SYSTEM.ADR(x)) = 1
END Int;
PROCEDURE Real* (VAR x: REAL);
BEGIN
String(s);
Done := sscanf(SYSTEM.ADR(s[0]), SYSTEM.SADR("%lf"), SYSTEM.ADR(x)) = 1
END Real;
PROCEDURE Char* (VAR x: CHAR);
BEGIN
String(s);
x := s[0]
END Char;
PROCEDURE Ln*;
BEGIN
String(s)
END Ln;
PROCEDURE Open*;
BEGIN
Done := TRUE
END Open;
PROCEDURE init;
VAR
libc: INTEGER;
BEGIN
libc := Libdl.open("libc.so.6", Libdl.LAZY);
ASSERT(libc # 0);
SYSTEM.PUT(SYSTEM.ADR(sscanf), Libdl.sym(libc, "sscanf"));
ASSERT(sscanf # NIL);
SYSTEM.PUT(SYSTEM.ADR(gets), Libdl.sym(libc, "gets"));
ASSERT(gets # NIL);
END init;
BEGIN
init
END In.

89
programs/develop/oberon07/Lib/Linux64/LINAPI.ob07
View File

@ -7,19 +7,17 @@
MODULE LINAPI;
IMPORT SYSTEM, API;
IMPORT SYSTEM, API, Libdl;
TYPE
TP* = API.TP;
SOFINI* = API.SOFINI;
TP* = ARRAY 2 OF INTEGER;
SOFINI* = PROCEDURE;
VAR
argc*, envc*: INTEGER;
libc*, librt*: INTEGER;
stdout*,
@ -39,79 +37,44 @@ VAR
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (0 <= n) & (n <= argc + envc) & (n # argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetEnv* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
IF (0 <= n) & (n < envc) THEN
GetArg(n + argc + 1, s)
ELSE
s[0] := 0X
END
END GetEnv;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
API.SetFini(ProcFini)
END SetFini;
PROCEDURE init;
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
ptr: INTEGER;
sym: INTEGER;
BEGIN
IF API.MainParam # 0 THEN
envc := -1;
SYSTEM.GET(API.MainParam, argc);
REPEAT
SYSTEM.GET(API.MainParam + (envc + argc + 3) * SYSTEM.SIZE(INTEGER), ptr);
INC(envc)
UNTIL ptr = 0
ELSE
envc := 0;
argc := 0
END;
sym := Libdl.sym(lib, name);
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetSym;
PROCEDURE init;
BEGIN
libc := API.libc;
stdout := API.stdout;
stdin := API.stdin;
stderr := API.stderr;
GetSym(libc, "exit", SYSTEM.ADR(exit));
GetSym(libc, "puts", SYSTEM.ADR(puts));
GetSym(libc, "malloc", SYSTEM.ADR(malloc));
GetSym(libc, "free", SYSTEM.ADR(free));
GetSym(libc, "fread", SYSTEM.ADR(fread));
GetSym(libc, "fwrite", SYSTEM.ADR(fwrite));
GetSym(libc, "fopen", SYSTEM.ADR(fopen));
GetSym(libc, "fclose", SYSTEM.ADR(fclose));
GetSym(libc, "time", SYSTEM.ADR(time));
malloc := API.malloc;
free := API.free;
exit := API._exit;
puts := API.puts;
fwrite := API.fwrite;
fread := API.fread;
fopen := API.fopen;
fclose := API.fclose;
time := API.time;
GetSym(libc, "stdout", SYSTEM.ADR(stdout)); SYSTEM.GET(stdout - SYSTEM.SIZE(INTEGER), stdout);
GetSym(libc, "stdin", SYSTEM.ADR(stdin)); SYSTEM.GET(stdin - SYSTEM.SIZE(INTEGER), stdin);
GetSym(libc, "stderr", SYSTEM.ADR(stderr)); SYSTEM.GET(stderr - SYSTEM.SIZE(INTEGER), stderr);
librt := API.librt;
librt := Libdl.open("librt.so.1", Libdl.LAZY);
clock_gettime := API.clock_gettime
GetSym(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END init;

447
programs/develop/oberon07/Lib/Linux64/Math.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
@ -12,22 +12,32 @@ IMPORT SYSTEM;
CONST
e *= 2.71828182845904523;
pi *= 3.14159265358979324;
ln2 *= 0.693147180559945309;
pi* = 3.1415926535897932384626433832795028841972E0;
e* = 2.7182818284590452353602874713526624977572E0;
eps = 1.0E-16;
MaxCosArg = 1000000.0 * pi;
ZERO = 0.0E0;
ONE = 1.0E0;
HALF = 0.5E0;
TWO = 2.0E0;
sqrtHalf = 0.70710678118654752440E0;
eps = 5.5511151E-17;
ln2Inv = 1.44269504088896340735992468100189213E0;
piInv = ONE / pi;
Limit = 1.0536712E-8;
piByTwo = pi / TWO;
expoMax = 1023;
expoMin = 1 - expoMax;
VAR
Exp: ARRAY 710 OF REAL;
LnInfinity, LnSmall, large, miny: REAL;
PROCEDURE [stdcall64] sqrt* (x: REAL): REAL;
BEGIN
ASSERT(x >= 0.0);
ASSERT(x >= ZERO);
SYSTEM.CODE(
0F2H, 0FH, 51H, 45H, 10H, (* sqrtsd xmm0, qword[rbp + 10h] *)
05DH, (* pop rbp *)
@ -38,205 +48,340 @@ BEGIN
END sqrt;
PROCEDURE sqri* (x: INTEGER): INTEGER;
RETURN x * x
END sqri;
PROCEDURE sqrr* (x: REAL): REAL;
RETURN x * x
END sqrr;
PROCEDURE exp* (x: REAL): REAL;
CONST
e25 = 1.284025416687741484; (* exp(0.25) *)
c1 = 0.693359375E0;
c2 = -2.1219444005469058277E-4;
P0 = 0.249999999999999993E+0;
P1 = 0.694360001511792852E-2;
P2 = 0.165203300268279130E-4;
Q1 = 0.555538666969001188E-1;
Q2 = 0.495862884905441294E-3;
VAR
a, s, res: REAL;
neg: BOOLEAN;
xn, g, p, q, z: REAL;
n: INTEGER;
BEGIN
neg := x < 0.0;
IF neg THEN
x := -x
END;
IF x < FLT(LEN(Exp)) THEN
res := Exp[FLOOR(x)];
x := x - FLT(FLOOR(x));
WHILE x >= 0.25 DO
res := res * e25;
x := x - 0.25
END
IF x > LnInfinity THEN
x := SYSTEM.INF()
ELSIF x < LnSmall THEN
x := ZERO
ELSIF ABS(x) < eps THEN
x := ONE
ELSE
res := SYSTEM.INF();
x := 0.0
END;
IF x >= ZERO THEN
n := FLOOR(ln2Inv * x + HALF)
ELSE
n := FLOOR(ln2Inv * x - HALF)
END;
n := 0;
a := 1.0;
s := 1.0;
REPEAT
INC(n);
a := a * x / FLT(n);
s := s + a
UNTIL a < eps;
IF neg THEN
res := 1.0 / (res * s)
ELSE
res := res * s
xn := FLT(n);
g := (x - xn * c1) - xn * c2;
z := g * g;
p := ((P2 * z + P1) * z + P0) * g;
q := (Q2 * z + Q1) * z + HALF;
x := HALF + p / (q - p);
PACK(x, n + 1)
END
RETURN res
RETURN x
END exp;
PROCEDURE ln* (x: REAL): REAL;
CONST
c1 = 355.0E0 / 512.0E0;
c2 = -2.121944400546905827679E-4;
P0 = -0.64124943423745581147E+2;
P1 = 0.16383943563021534222E+2;
P2 = -0.78956112887491257267E+0;
Q0 = -0.76949932108494879777E+3;
Q1 = 0.31203222091924532844E+3;
Q2 = -0.35667977739034646171E+2;
VAR
a, x2, res: REAL;
zn, zd, r, z, w, p, q, xn: REAL;
n: INTEGER;
BEGIN
ASSERT(x > 0.0);
ASSERT(x > ZERO);
UNPK(x, n);
x := x * HALF;
x := (x - 1.0) / (x + 1.0);
x2 := x * x;
res := x + FLT(n) * (ln2 * 0.5);
n := 1;
IF x > sqrtHalf THEN
zn := x - ONE;
zd := x * HALF + HALF;
INC(n)
ELSE
zn := x - HALF;
zd := zn * HALF + HALF
END;
REPEAT
INC(n, 2);
x := x * x2;
a := x / FLT(n);
res := res + a
UNTIL a < eps
z := zn / zd;
w := z * z;
q := ((w + Q2) * w + Q1) * w + Q0;
p := w * ((P2 * w + P1) * w + P0);
r := z + z * (p / q);
xn := FLT(n)
RETURN res * 2.0
RETURN (xn * c2 + r) + xn * c1
END ln;
PROCEDURE power* (base, exponent: REAL): REAL;
BEGIN
ASSERT(base > 0.0)
ASSERT(base > ZERO)
RETURN exp(exponent * ln(base))
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 log* (base, x: REAL): REAL;
BEGIN
ASSERT(base > 0.0);
ASSERT(x > 0.0)
ASSERT(base > ZERO);
ASSERT(x > ZERO)
RETURN ln(x) / ln(base)
END log;
PROCEDURE cos* (x: REAL): REAL;
PROCEDURE SinCos (x, y, sign: REAL): REAL;
CONST
ymax = 210828714;
c1 = 3.1416015625E0;
c2 = -8.908910206761537356617E-6;
r1 = -0.16666666666666665052E+0;
r2 = 0.83333333333331650314E-2;
r3 = -0.19841269841201840457E-3;
r4 = 0.27557319210152756119E-5;
r5 = -0.25052106798274584544E-7;
r6 = 0.16058936490371589114E-9;
r7 = -0.76429178068910467734E-12;
r8 = 0.27204790957888846175E-14;
VAR
a, res: REAL;
n: INTEGER;
xn, f, x1, g: REAL;
BEGIN
ASSERT(y < FLT(ymax));
n := FLOOR(y * piInv + HALF);
xn := FLT(n);
IF ODD(n) THEN
sign := -sign
END;
x := ABS(x);
ASSERT(x <= MaxCosArg);
IF x # y THEN
xn := xn - HALF
END;
x := x - FLT( FLOOR(x / (2.0 * pi)) ) * (2.0 * pi);
x := x * x;
res := 0.0;
a := 1.0;
n := -1;
x1 := FLT(FLOOR(x));
f := ((x1 - xn * c1) + (x - x1)) - xn * c2;
REPEAT
INC(n, 2);
res := res + a;
a := -a * x / FLT(n*n + n)
UNTIL ABS(a) < eps
IF ABS(f) < Limit THEN
x := sign * f
ELSE
g := f * f;
g := (((((((r8 * g + r7) * g + r6) * g + r5) * g + r4) * g + r3) * g + r2) * g + r1) * g;
g := f + f * g;
x := sign * g
END
RETURN res
END cos;
RETURN x
END SinCos;
PROCEDURE sin* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x)
END sin;
PROCEDURE tan* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x) / x
END tan;
PROCEDURE arcsin* (x: REAL): REAL;
PROCEDURE arctan (x: REAL): REAL;
VAR
z, p, k: REAL;
BEGIN
p := x / (x * x + 1.0);
z := p * x;
x := 0.0;
k := 0.0;
REPEAT
k := k + 2.0;
x := x + p;
p := p * k * z / (k + 1.0)
UNTIL p < eps
RETURN x
END arctan;
BEGIN
ASSERT(ABS(x) <= 1.0);
IF ABS(x) >= 0.707 THEN
x := 0.5 * pi - arctan(sqrt(1.0 - x * x) / x)
IF x < ZERO THEN
x := SinCos(x, -x, -ONE)
ELSE
x := arctan(x / sqrt(1.0 - x * x))
x := SinCos(x, x, ONE)
END
RETURN x
END sin;
PROCEDURE cos* (x: REAL): REAL;
RETURN SinCos(x, ABS(x) + piByTwo, ONE)
END cos;
PROCEDURE tan* (x: REAL): REAL;
VAR
s, c: REAL;
BEGIN
s := sin(x);
c := sqrt(ONE - s * s);
x := ABS(x) / (TWO * pi);
x := x - FLT(FLOOR(x));
IF (0.25 < x) & (x < 0.75) THEN
c := -c
END
RETURN s / c
END tan;
PROCEDURE arctan2* (y, x: REAL): REAL;
CONST
P0 = 0.216062307897242551884E+3; P1 = 0.3226620700132512059245E+3;
P2 = 0.13270239816397674701E+3; P3 = 0.1288838303415727934E+2;
Q0 = 0.2160623078972426128957E+3; Q1 = 0.3946828393122829592162E+3;
Q2 = 0.221050883028417680623E+3; Q3 = 0.3850148650835119501E+2;
Sqrt3 = 1.7320508075688772935E0;
VAR
atan, z, z2, p, q: REAL;
yExp, xExp, Quadrant: INTEGER;
BEGIN
IF ABS(x) < miny THEN
ASSERT(ABS(y) >= miny);
atan := piByTwo
ELSE
z := y;
UNPK(z, yExp);
z := x;
UNPK(z, xExp);
IF yExp - xExp >= expoMax - 3 THEN
atan := piByTwo
ELSIF yExp - xExp < expoMin + 3 THEN
atan := ZERO
ELSE
IF ABS(y) > ABS(x) THEN
z := ABS(x / y);
Quadrant := 2
ELSE
z := ABS(y / x);
Quadrant := 0
END;
IF z > TWO - Sqrt3 THEN
z := (z * Sqrt3 - ONE) / (Sqrt3 + z);
INC(Quadrant)
END;
IF ABS(z) < Limit THEN
atan := z
ELSE
z2 := z * z;
p := (((P3 * z2 + P2) * z2 + P1) * z2 + P0) * z;
q := (((z2 + Q3) * z2 + Q2) * z2 + Q1) * z2 + Q0;
atan := p / q
END;
CASE Quadrant OF
|0:
|1: atan := atan + pi / 6.0
|2: atan := piByTwo - atan
|3: atan := pi / 3.0 - atan
END
END;
IF x < ZERO THEN
atan := pi - atan
END
END;
IF y < ZERO THEN
atan := -atan
END
RETURN atan
END arctan2;
PROCEDURE arcsin* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= ONE)
RETURN arctan2(x, sqrt(ONE - x * x))
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= 1.0)
RETURN 0.5 * pi - arcsin(x)
ASSERT(ABS(x) <= ONE)
RETURN arctan2(sqrt(ONE - x * x), x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arcsin(x / sqrt(1.0 + x * x))
RETURN arctan2(x, ONE)
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
RETURN (x - ONE / x) * HALF
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
RETURN (x + ONE / x) * HALF
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
x := ONE
ELSIF x < -15.0 THEN
x := -1.0
x := -ONE
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
x := exp(TWO * x);
x := (x - ONE) / (x + ONE)
END
RETURN x
@ -244,21 +389,21 @@ END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
RETURN ln(x + sqrt(x * x + ONE))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
BEGIN
ASSERT(x >= 1.0)
RETURN ln(x + sqrt(x * x - 1.0))
ASSERT(x >= ONE)
RETURN ln(x + sqrt(x * x - ONE))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) < 1.0)
RETURN 0.5 * ln((1.0 + x) / (1.0 - x))
ASSERT(ABS(x) < ONE)
RETURN HALF * ln((ONE + x) / (ONE - x))
END artanh;
@ -267,9 +412,9 @@ VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
IF x > ZERO THEN
res := 1
ELSIF x < 0.0 THEN
ELSIF x < ZERO THEN
res := -1
ELSE
res := 0
@ -284,7 +429,7 @@ VAR
res: REAL;
BEGIN
res := 1.0;
res := ONE;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
@ -294,18 +439,42 @@ BEGIN
END fact;
PROCEDURE init;
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
i: INTEGER;
a: REAL;
BEGIN
Exp[0] := 1.0;
FOR i := 1 TO LEN(Exp) - 1 DO
Exp[i] := Exp[i - 1] * e
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
END init;
RETURN a
END hypot;
BEGIN
init
large := 1.9;
PACK(large, expoMax);
miny := ONE / large;
LnInfinity := ln(large);
LnSmall := ln(miny);
END Math.

299
programs/develop/oberon07/Lib/Linux64/Out.ob07
View File

@ -1,276 +1,87 @@
(*
Copyright 2013, 2014, 2017, 2018, 2019 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, Libdl;
CONST
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: REAL; width: INTEGER);
printf1: PROCEDURE [linux] (fmt: INTEGER; x: INTEGER);
printf2: PROCEDURE [linux] (fmt: INTEGER; width, x: INTEGER);
printf3: PROCEDURE [linux] (fmt: INTEGER; width, precision, x: INTEGER);
PROCEDURE Char*(x: CHAR);
PROCEDURE Char* (x: CHAR);
BEGIN
API.putc(x)
printf1(SYSTEM.SADR("%c"), ORD(x))
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
PROCEDURE String* (s: ARRAY OF CHAR);
BEGIN
printf2(SYSTEM.SADR("%.*s"), LENGTH(s), SYSTEM.ADR(s[0]))
END String;
PROCEDURE Ln*;
BEGIN
printf1(SYSTEM.SADR("%s"), SYSTEM.SADR(0AX))
END Ln;
PROCEDURE Int* (x, width: INTEGER);
BEGIN
printf2(SYSTEM.SADR("%*lld"), width, x)
END Int;
PROCEDURE intval (x: REAL): INTEGER;
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
Char(s[i]);
INC(i)
END
END String;
SYSTEM.GET(SYSTEM.ADR(x), i)
RETURN i
END intval;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 24 OF CHAR; neg: BOOLEAN;
PROCEDURE Real* (x: REAL; width: INTEGER);
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR s: SET;
BEGIN
sys.GET(sys.ADR(AValue), s)
RETURN (s * {52..62} = {52..62}) & ((s * {32..51} # {}) OR (s * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0AX)
END Ln;
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END;
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0
END
ELSE
WHILE e >= 0 DO
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
printf3(SYSTEM.SADR("%*.*E"), width, MAX(MIN(width - 8, 15), 1), intval(x))
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
PROCEDURE FixReal* (x: REAL; width, precision: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
printf3(SYSTEM.SADR("%*.*f"), width, precision, intval(x))
END FixReal;
PROCEDURE Open*;
END Open;
PROCEDURE init;
VAR
libc, printf: INTEGER;
BEGIN
libc := Libdl.open("libc.so.6", Libdl.LAZY);
ASSERT(libc # 0);
printf := Libdl.sym(libc, "printf");
ASSERT(printf # 0);
SYSTEM.PUT(SYSTEM.ADR(printf1), printf);
SYSTEM.PUT(SYSTEM.ADR(printf2), printf);
SYSTEM.PUT(SYSTEM.ADR(printf3), printf);
END init;
BEGIN
init
END Out.

49
programs/develop/oberon07/Lib/Linux64/RTL.ob07
View File

@ -350,33 +350,29 @@ END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
INC(i);
a := a DIV 10
UNTIL a = 0;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
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, i, j: INTEGER;
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
@ -384,19 +380,12 @@ BEGIN
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE [stdcall64] _error* (module, err, line: INTEGER);
PROCEDURE [stdcall64] _error* (modnum, _module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
@ -415,10 +404,8 @@ BEGIN
|11: s := "BYTE out of range"
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
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);

125
programs/develop/oberon07/Lib/MSP430/MSP430.ob07 Normal file
View File

@ -0,0 +1,125 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE MSP430;
IMPORT SYSTEM;
CONST
iv = 0FFC0H;
bsl = iv - 2;
sp = bsl - 2;
empty_proc = sp - 2;
free_size = empty_proc - 2;
free_adr = free_size - 2;
bits = free_adr - 272;
bits_offs = bits - 32;
types = bits_offs - 2;
ram = 200H;
trap = ram;
int = trap + 2;
GIE* = {3};
CPUOFF* = {4};
OSCOFF* = {5};
SCG0* = {6};
SCG1* = {7};
TYPE
TInterrupt* = RECORD priority*: INTEGER; sr*: SET; pc*: INTEGER END;
TTrapProc* = PROCEDURE (modNum, modName, err, line: INTEGER);
TIntProc* = PROCEDURE (priority: INTEGER; interrupt: TInterrupt);
PROCEDURE SetTrapProc* (TrapProc: TTrapProc);
BEGIN
SYSTEM.PUT(trap, TrapProc)
END SetTrapProc;
PROCEDURE SetIntProc* (IntProc: TIntProc);
BEGIN
SYSTEM.PUT(int, IntProc)
END SetIntProc;
PROCEDURE SetIntPC* (interrupt: TInterrupt; NewPC: INTEGER);
BEGIN
SYSTEM.PUT(SYSTEM.ADR(interrupt.pc), NewPC)
END SetIntPC;
PROCEDURE SetIntSR* (interrupt: TInterrupt; NewSR: SET);
BEGIN
SYSTEM.PUT(SYSTEM.ADR(interrupt.sr), NewSR)
END SetIntSR;
PROCEDURE [code] DInt*
0C232H; (* BIC #8, SR *)
PROCEDURE [code] EInt*
0D232H; (* BIS #8, SR *)
PROCEDURE [code] CpuOff*
0D032H, 16; (* BIS #16, SR *)
PROCEDURE [code] Halt*
4032H, 0F0H; (* MOV CPUOFF+OSCOFF+SCG0+SCG1, SR *)
PROCEDURE [code] Restart*
4302H, (* MOV #0, SR *)
4210H, 0FFFEH; (* MOV 0FFFEH(SR), PC *)
PROCEDURE [code] SetSR* (bits: SET)
0D112H, 2; (* BIS 2(SP), SR *)
PROCEDURE [code] ClrSR* (bits: SET)
0C112H, 2; (* BIC 2(SP), SR *)
PROCEDURE GetFreeFlash* (VAR address, size: INTEGER);
BEGIN
SYSTEM.GET(free_adr, address);
SYSTEM.GET(free_size, size)
END GetFreeFlash;
PROCEDURE [code] Delay* (n: INTEGER)
4035H, 124, (* MOV #124, R5 *)
(* L2: *)
4114H, 2, (* MOV 2(SP), R4 *)
8324H, (* SUB #2, R4 *)
(* L1: *)
4303H, (* NOP *)
4303H, (* NOP *)
4303H, (* NOP *)
4303H, (* NOP *)
4303H, (* NOP *)
8314H, (* SUB #1, R4 *)
3800H - 7, (* JGE L1 *)
8315H, (* SUB #1, R5 *)
3800H - 12; (* JGE L2 *)
END MSP430.

462
programs/develop/oberon07/Lib/Math/CMath.ob07 Normal file
View File

@ -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.

33
programs/develop/oberon07/Lib/Math/MathBits.ob07 Normal file
View File

@ -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.

99
programs/develop/oberon07/Lib/Math/MathRound.ob07 Normal file
View File

@ -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.

238
programs/develop/oberon07/Lib/Math/MathStat.ob07 Normal file
View File

@ -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.

81
programs/develop/oberon07/Lib/Math/Rand.ob07 Normal file
View File

@ -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.

298
programs/develop/oberon07/Lib/Math/RandExt.ob07 Normal file
View File

@ -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.

465
programs/develop/oberon07/Lib/RVM32I/FPU.ob07 Normal file
View File

@ -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.

176
programs/develop/oberon07/Lib/RVM32I/HOST.ob07 Normal file
View File

@ -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.

273
programs/develop/oberon07/Lib/RVM32I/Out.ob07 Normal file
View File

@ -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.

390
programs/develop/oberon07/Lib/RVM32I/RTL.ob07 Normal file
View File

@ -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.

128
programs/develop/oberon07/Lib/RVM32I/Trap.ob07 Normal file
View File

@ -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.

465
programs/develop/oberon07/Lib/STM32CM3/FPU.ob07 Normal file
View File

@ -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.

388
programs/develop/oberon07/Lib/STM32CM3/RTL.ob07 Normal file
View File

@ -0,0 +1,388 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, F := FPU;
CONST
bit_depth = 32;
maxint = 7FFFFFFFH;
minint = 80000000H;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
VAR
Heap, Types, TypesCount: INTEGER;
PROCEDURE [code] sp (): INTEGER
4668H; (* mov r0, sp *)
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 < 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.

20
programs/develop/oberon07/Lib/Windows32/API.ob07
View File

@ -12,6 +12,8 @@ IMPORT SYSTEM;
CONST
eol* = 0DX + 0AX;
SectionAlignment = 1000H;
DLL_PROCESS_ATTACH = 1;
@ -19,6 +21,9 @@ CONST
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
KERNEL = "kernel32.dll";
USER = "user32.dll";
TYPE
@ -27,7 +32,6 @@ TYPE
VAR
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
heap: INTEGER;
@ -36,13 +40,12 @@ VAR
thread_attach: DLL_ENTRY;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetProcessHeap"] GetProcessHeap (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapAlloc"] HeapAlloc (hHeap, dwFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapFree"] HeapFree(hHeap, dwFlags, lpMem: INTEGER);
PROCEDURE [windows-, "user32.dll", "MessageBoxA"] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] ExitProcess (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] ExitThread (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] GetProcessHeap (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] HeapAlloc (hHeap, dwFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] HeapFree (hHeap, dwFlags, lpMem: INTEGER);
PROCEDURE [windows-, USER, ""] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
@ -68,7 +71,6 @@ BEGIN
process_detach := NIL;
thread_detach := NIL;
thread_attach := NIL;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - SectionAlignment;
heap := GetProcessHeap()
END init;

4
programs/develop/oberon07/Lib/Windows32/Args.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
@ -54,7 +54,7 @@ VAR
BEGIN
p := WINAPI.GetCommandLine();
p := WINAPI.GetCommandLineA();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO

4
programs/develop/oberon07/Lib/Windows32/Console.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
@ -48,7 +48,7 @@ VAR
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
fill := ORD(ScrBufInfo.dwSize.X) * ORD(ScrBufInfo.dwSize.Y);
WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputCharacterA(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputAttribute(hConsoleOutput, ORD(ScrBufInfo.wAttributes), fill, 0, SYSTEM.ADR(fill));
SetCursor(0, 0)
END Cls;

27
programs/develop/oberon07/Lib/Windows32/DateTime.ob07
View File

@ -1,13 +1,13 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE DateTime;
IMPORT WINAPI;
IMPORT WINAPI, SYSTEM;
CONST
@ -116,6 +116,29 @@ BEGIN
END NowEncode;
PROCEDURE NowUnixTime* (): INTEGER;
RETURN WINAPI.time(0)
END NowUnixTime;
PROCEDURE UnixTime* (Year, Month, Day, Hour, Min, Sec: INTEGER): INTEGER;
VAR
t: WINAPI.tm;
BEGIN
DEC(Year, 1900);
DEC(Month);
SYSTEM.GET(SYSTEM.ADR(Sec), t.sec);
SYSTEM.GET(SYSTEM.ADR(Min), t.min);
SYSTEM.GET(SYSTEM.ADR(Hour), t.hour);
SYSTEM.GET(SYSTEM.ADR(Day), t.mday);
SYSTEM.GET(SYSTEM.ADR(Month), t.mon);
SYSTEM.GET(SYSTEM.ADR(Year), t.year);
RETURN WINAPI.mktime(t)
END UnixTime;
PROCEDURE init;
VAR
day, year, month, i: INTEGER;

37
programs/develop/oberon07/Lib/Windows32/File.ob07
View File

@ -1,13 +1,13 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE File;
IMPORT SYSTEM, WINAPI;
IMPORT SYSTEM, WINAPI, API;
CONST
@ -20,12 +20,14 @@ PROCEDURE Exists* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
FindData: WINAPI.TWin32FindData;
Handle: INTEGER;
attr: SET;
BEGIN
Handle := WINAPI.FindFirstFile(SYSTEM.ADR(FName[0]), FindData);
Handle := WINAPI.FindFirstFileA(SYSTEM.ADR(FName[0]), FindData);
IF Handle # -1 THEN
WINAPI.FindClose(Handle);
IF 4 IN FindData.dwFileAttributes THEN
SYSTEM.GET32(SYSTEM.ADR(FindData.dwFileAttributes), attr);
IF 4 IN attr THEN
Handle := -1
END
END
@ -35,12 +37,12 @@ END Exists;
PROCEDURE Delete* (FName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.DeleteFile(SYSTEM.ADR(FName[0])) # 0
RETURN WINAPI.DeleteFileA(SYSTEM.ADR(FName[0])) # 0
END Delete;
PROCEDURE Create* (FName: ARRAY OF CHAR): INTEGER;
RETURN WINAPI.CreateFile(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
RETURN WINAPI.CreateFileA(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END Create;
@ -65,13 +67,11 @@ END Seek;
PROCEDURE Read* (F, Buffer, Count: INTEGER): INTEGER;
VAR
res, n: INTEGER;
res: INTEGER;
BEGIN
IF WINAPI.ReadFile(F, Buffer, Count, SYSTEM.ADR(n), NIL) = 0 THEN
IF WINAPI.ReadFile(F, Buffer, Count, SYSTEM.ADR(res), NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
@ -80,13 +80,11 @@ END Read;
PROCEDURE Write* (F, Buffer, Count: INTEGER): INTEGER;
VAR
res, n: INTEGER;
res: INTEGER;
BEGIN
IF WINAPI.WriteFile(F, Buffer, Count, SYSTEM.ADR(n), NIL) = 0 THEN
IF WINAPI.WriteFile(F, Buffer, Count, SYSTEM.ADR(res), NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
@ -104,11 +102,10 @@ BEGIN
IF F # -1 THEN
Size := Seek(F, 0, SEEK_END);
n := Seek(F, 0, SEEK_BEG);
res := WINAPI.GlobalAlloc(64, Size);
res := API._NEW(Size);
IF (res = 0) OR (Read(F, res, Size) # Size) THEN
IF res # 0 THEN
WINAPI.GlobalFree(Size);
res := 0;
res := API._DISPOSE(res);
Size := 0
END
END;
@ -120,7 +117,7 @@ END Load;
PROCEDURE RemoveDir* (DirName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.RemoveDirectory(SYSTEM.ADR(DirName[0])) # 0
RETURN WINAPI.RemoveDirectoryA(SYSTEM.ADR(DirName[0])) # 0
END RemoveDir;
@ -129,13 +126,13 @@ VAR
Code: SET;
BEGIN
Code := WINAPI.GetFileAttributes(SYSTEM.ADR(DirName[0]))
Code := WINAPI.GetFileAttributesA(SYSTEM.ADR(DirName[0]))
RETURN (Code # {0..31}) & (4 IN Code)
END ExistsDir;
PROCEDURE CreateDir* (DirName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.CreateDirectory(SYSTEM.ADR(DirName[0]), NIL) # 0
RETURN WINAPI.CreateDirectoryA(SYSTEM.ADR(DirName[0]), NIL) # 0
END CreateDir;

84
programs/develop/oberon07/Lib/Windows32/HOST.ob07
View File

@ -13,7 +13,7 @@ IMPORT SYSTEM, RTL;
CONST
slash* = "\";
OS* = "WINDOWS";
eol* = 0DX + 0AX;
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
@ -59,19 +59,6 @@ TYPE
END;
TSystemTime = RECORD
Year,
Month,
DayOfWeek,
Day,
Hour,
Min,
Sec,
MSec: WCHAR
END;
VAR
@ -80,8 +67,6 @@ VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc: INTEGER;
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
@ -116,12 +101,12 @@ PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
PROCEDURE [windows-, "kernel32.dll", "GetCurrentDirectoryA"]
_GetCurrentDirectory (nBufferLength, lpBuffer: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetSystemTime"]
_GetSystemTime (T: TSystemTime);
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
_ExitProcess (code: INTEGER);
PROCEDURE [ccall, "msvcrt.dll", "time"]
_time (ptr: INTEGER): INTEGER;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
@ -215,13 +200,11 @@ END GetArg;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
res: INTEGER;
BEGIN
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, res, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
@ -230,13 +213,11 @@ END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
res: INTEGER;
BEGIN
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, res, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
@ -269,6 +250,10 @@ BEGIN
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
END chmod;
PROCEDURE OutChar* (c: CHAR);
VAR
count: INTEGER;
@ -292,33 +277,25 @@ PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
VAR
T: TSystemTime;
BEGIN
_GetSystemTime(T);
year := ORD(T.Year);
month := ORD(T.Month);
day := ORD(T.Day);
hour := ORD(T.Hour);
min := ORD(T.Min);
sec := ORD(T.Sec)
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN 0
RETURN _time(0)
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
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
@ -337,7 +314,7 @@ BEGIN
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (l # 0) THEN
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
@ -348,22 +325,7 @@ BEGIN
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
maxreal := 1.9;
PACK(maxreal, 1023);
hConsoleOutput := _GetStdHandle(-11);

309
programs/develop/oberon07/Lib/Windows32/In.ob07
View File

@ -1,289 +1,80 @@
(*
Copyright 2013, 2017, 2018 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE In;
IMPORT sys := SYSTEM, WINAPI;
IMPORT SYSTEM;
TYPE
STRING = ARRAY 260 OF CHAR;
CONST
MAX_LEN = 1024;
VAR
Done*: BOOLEAN;
hConsoleInput: INTEGER;
Done*: BOOLEAN;
hConsoleInput: INTEGER;
s: ARRAY MAX_LEN + 4 OF CHAR;
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;
PROCEDURE [ccall, "msvcrt.dll", ""] sscanf (buf: INTEGER; fmt: INTEGER; adr: INTEGER): INTEGER;
PROCEDURE [windows, "kernel32.dll", ""] GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows, "kernel32.dll", ""] ReadConsoleA (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER);
PROCEDURE String* (VAR str: ARRAY OF CHAR);
VAR
count: INTEGER;
BEGIN
i := 0;
neg := FALSE;
WHILE (s[i] <= 20X) & (s[i] # 0X) DO
INC(i)
END;
IF s[i] = "-" THEN
neg := TRUE;
INC(i)
ELSIF s[i] = "+" THEN
INC(i)
END;
first := i;
WHILE digit(s[i]) DO
INC(i)
END;
last := i
RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first])
END CheckInt;
PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN;
VAR i: INTEGER; min: STRING;
BEGIN
i := 0;
min := "2147483648";
WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO
INC(i)
END
RETURN i = 10
END IsMinInt;
PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER;
CONST maxINT = 7FFFFFFFH;
VAR i, n, res: INTEGER; flag, neg: BOOLEAN;
BEGIN
res := 0;
flag := CheckInt(str, i, n, neg, FALSE);
err := ~flag;
IF flag & neg & IsMinInt(str, i) THEN
flag := FALSE;
neg := FALSE;
res := 80000000H
END;
WHILE flag & digit(str[i]) DO
IF res > maxINT DIV 10 THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END;
IF neg THEN
res := -res
END
RETURN res
END StrToInt;
PROCEDURE Space(s: STRING): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) & (s[i] <= 20X) DO
INC(i)
END
RETURN s[i] = 0X
END Space;
PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
Res := CheckInt(s, n, i, neg, TRUE);
IF Res THEN
IF s[i] = "." THEN
INC(i);
WHILE digit(s[i]) DO
INC(i)
END;
IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN
INC(i);
IF (s[i] = "+") OR (s[i] = "-") THEN
INC(i)
END;
Res := digit(s[i]);
WHILE digit(s[i]) DO
INC(i)
END
END
END
END
RETURN Res & (s[i] <= 20X)
END CheckReal;
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): REAL;
CONST maxDBL = 1.69E308; maxINT = 7FFFFFFFH;
VAR i, scale: INTEGER; res, m, d: REAL; minus, neg: BOOLEAN;
PROCEDURE part1(VAR res, d: REAL; VAR i: INTEGER; str: STRING): BOOLEAN;
BEGIN
res := 0.0;
d := 1.0;
WHILE digit(str[i]) DO
res := res * 10.0 + FLT(ORD(str[i]) - ORD("0"));
INC(i)
ReadConsoleA(hConsoleInput, SYSTEM.ADR(s[0]), MAX_LEN, SYSTEM.ADR(count), 0);
IF (s[count - 1] = 0AX) & (s[count - 2] = 0DX) THEN
DEC(count, 2)
END;
IF str[i] = "." THEN
INC(i);
WHILE digit(str[i]) DO
d := d / 10.0;
res := res + FLT(ORD(str[i]) - ORD("0")) * d;
INC(i)
END
END
RETURN str[i] # 0X
END part1;
PROCEDURE part2(VAR i, scale: INTEGER; VAR m, res: REAL; VAR minus, err: BOOLEAN; str: STRING): BOOLEAN;
BEGIN
INC(i);
m := 10.0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1
END;
scale := 0;
err := FALSE;
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN ~err
END part2;
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR scale: INTEGER; VAR res, m: REAL);
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0
ELSE
res := res * m;
INC(i)
END
END
END part3;
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1(res, d, i, str) & part2(i, scale, m, res, minus, err, str) THEN
part3(err, minus, scale, res, m)
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0;
err := TRUE
END
RETURN res
END StrToFloat;
PROCEDURE String*(VAR s: ARRAY OF CHAR);
VAR count, i: INTEGER; str: STRING;
BEGIN
WINAPI.ReadConsole(hConsoleInput, sys.ADR(str[0]), 256, sys.ADR(count), 0);
IF (str[count - 1] = 0AX) & (str[count - 2] = 0DX) THEN
DEC(count, 2)
END;
str[256] := 0X;
str[count] := 0X;
i := 0;
WHILE (i < LEN(s) - 1) & (i < LEN(str)) & (str[i] # 0X) DO
s[i] := str[i];
INC(i)
END;
s[i] := 0X;
Done := TRUE
s[count] := 0X;
COPY(s, str);
str[LEN(str) - 1] := 0X;
Done := TRUE
END String;
PROCEDURE Char*(VAR x: CHAR);
VAR str: STRING;
BEGIN
String(str);
x := str[0];
Done := TRUE
END Char;
PROCEDURE Ln*;
VAR str: STRING;
PROCEDURE Int* (VAR x: INTEGER);
BEGIN
String(str);
Done := TRUE
END Ln;
String(s);
Done := sscanf(SYSTEM.ADR(s[0]), SYSTEM.SADR("%d"), SYSTEM.ADR(x)) = 1
END Int;
PROCEDURE Real*(VAR x: REAL);
VAR str: STRING; err: BOOLEAN;
PROCEDURE Real* (VAR x: REAL);
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToFloat(str, err);
Done := ~err
String(s);
Done := sscanf(SYSTEM.ADR(s[0]), SYSTEM.SADR("%lf"), SYSTEM.ADR(x)) = 1
END Real;
PROCEDURE Int*(VAR x: INTEGER);
VAR str: STRING; err: BOOLEAN;
PROCEDURE Char* (VAR x: CHAR);
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToInt(str, err);
Done := ~err
END Int;
String(s);
x := s[0]
END Char;
PROCEDURE Ln*;
BEGIN
String(s)
END Ln;
PROCEDURE Open*;
BEGIN
hConsoleInput := WINAPI.GetStdHandle(-10);
Done := TRUE
hConsoleInput := GetStdHandle(-10);
Done := TRUE
END Open;
END In.

92
programs/develop/oberon07/Lib/Windows32/Math.ob07
View File

@ -1,18 +1,8 @@
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2013-2014, 2018-2020 Anton Krotov
All rights reserved.
*)
MODULE Math;
@ -235,6 +225,16 @@ BEGIN
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;
@ -349,6 +349,40 @@ BEGIN
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;
@ -381,4 +415,36 @@ BEGIN
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.

281
programs/develop/oberon07/Lib/Windows32/Out.ob07
View File

@ -1,280 +1,77 @@
(*
Copyright 2013, 2014, 2017, 2018 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT sys := SYSTEM, WINAPI;
IMPORT SYSTEM;
CONST
d = 1.0 - 5.0E-12;
VAR
hConsoleOutput: INTEGER;
Realp: PROCEDURE (x: REAL; width: INTEGER);
hConsoleOutput: INTEGER;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR count: INTEGER;
PROCEDURE [ccall, "msvcrt.dll", "printf"] printf1 (fmt: INTEGER; x: INTEGER);
PROCEDURE [ccall, "msvcrt.dll", "printf"] printf2 (fmt: INTEGER; width, x: INTEGER);
PROCEDURE [ccall, "msvcrt.dll", "printf"] printf3 (fmt: INTEGER; width, precision: INTEGER; x: REAL);
PROCEDURE [windows, "kernel32.dll", ""]
WriteConsoleW (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER);
PROCEDURE [windows, "kernel32.dll", ""]
GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE Char* (x: CHAR);
BEGIN
WINAPI.WriteFile(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), NIL)
END String;
PROCEDURE StringW*(s: ARRAY OF WCHAR);
VAR count: INTEGER;
BEGIN
WINAPI.WriteConsoleW(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), 0)
END StringW;
PROCEDURE Char*(x: CHAR);
VAR count: INTEGER;
BEGIN
WINAPI.WriteFile(hConsoleOutput, sys.ADR(x), 1, sys.ADR(count), NIL)
printf1(SYSTEM.SADR("%c"), ORD(x))
END Char;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR h, l: SET;
PROCEDURE StringW* (s: ARRAY OF WCHAR);
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;
WriteConsoleW(hConsoleOutput, SYSTEM.ADR(s[0]), LENGTH(s), 0, 0)
END StringW;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
PROCEDURE String* (s: ARRAY OF CHAR);
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
printf2(SYSTEM.SADR("%.*s"), LENGTH(s), SYSTEM.ADR(s[0]))
END String;
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)
printf1(SYSTEM.SADR("%s"), SYSTEM.SADR(CHR(13) + CHR(10)))
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;
PROCEDURE Int* (x, width: INTEGER);
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
printf2(SYSTEM.SADR("%*d"), width, x)
END Int;
PROCEDURE Real* (x: REAL; width: INTEGER);
BEGIN
printf3(SYSTEM.SADR("%*.*E"), width, MAX(MIN(width - 8, 15), 1), x)
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
PROCEDURE FixReal* (x: REAL; width, precision: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
printf3(SYSTEM.SADR("%*.*f"), width, precision, x)
END FixReal;
PROCEDURE Open*;
BEGIN
hConsoleOutput := WINAPI.GetStdHandle(-11)
hConsoleOutput := GetStdHandle(-11)
END Open;
END Out.

49
programs/develop/oberon07/Lib/Windows32/RTL.ob07
View File

@ -372,33 +372,29 @@ END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
INC(i);
a := a DIV 10
UNTIL a = 0;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
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, i, j: INTEGER;
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
@ -406,19 +402,12 @@ BEGIN
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE [stdcall] _error* (module, err, line: INTEGER);
PROCEDURE [stdcall] _error* (modnum, _module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
@ -437,10 +426,8 @@ BEGIN
|11: s := "BYTE out of range"
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
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);

64
programs/develop/oberon07/Lib/Windows32/UnixTime.ob07
View File

@ -1,64 +0,0 @@
(*
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.

76
programs/develop/oberon07/Lib/Windows32/Utils.ob07
View File

@ -1,76 +0,0 @@
(*
Copyright 2013, 2017, 2018, 2020 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Utils;
IMPORT WINAPI;
PROCEDURE PutSeed*(seed: INTEGER);
BEGIN
WINAPI.srand(seed)
END PutSeed;
PROCEDURE Rnd*(range : INTEGER): INTEGER;
RETURN WINAPI.rand() MOD range
END Rnd;
PROCEDURE Utf8To16*(source: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR): INTEGER;
VAR i, j, L, u, N: INTEGER;
BEGIN
L := LEN(source);
N := LEN(dest);
N := N - N MOD 2 - 1;
i := 0;
j := 0;
WHILE (i < L) & (j < N) & (source[i] # 0X) DO
CASE source[i] OF
|00X..7FX: u := ORD(source[i]);
|0C1X..0DFX:
u := LSL(ORD(source[i]) - 0C0H, 6);
IF i + 1 < L THEN
u := u + ROR(LSL(ORD(source[i + 1]), 26), 26);
INC(i)
END
|0E1X..0EFX:
u := LSL(ORD(source[i]) - 0E0H, 12);
IF i + 1 < L THEN
u := u + ROR(LSL(ORD(source[i + 1]), 26), 20);
INC(i)
END;
IF i + 1 < L THEN
u := u + ROR(LSL(ORD(source[i + 1]), 26), 26);
INC(i)
END
(* |0F1X..0F7X:
|0F9X..0FBX:
|0FDX:*)
ELSE
END;
INC(i);
dest[j] := CHR(u MOD 256);
INC(j);
dest[j] := CHR(u DIV 256);
INC(j);
END;
IF j < N THEN
dest[j] := 0X;
dest[j + 1] := 0X
END
RETURN j DIV 2
END Utf8To16;
END Utils.

167
programs/develop/oberon07/Lib/Windows32/WINAPI.ob07
View File

@ -14,6 +14,10 @@ CONST
OFS_MAXPATHNAME* = 128;
KERNEL = "kernel32.dll";
USER = "user32.dll";
MSVCRT = "msvcrt.dll";
TYPE
@ -56,42 +60,59 @@ TYPE
END;
tm* = RECORD
sec*,
min*,
hour*,
mday*,
mon*,
year*,
wday*,
yday*,
isdst*: SYSTEM.CARD32
END;
PSecurityAttributes* = POINTER TO TSecurityAttributes;
TSecurityAttributes* = RECORD
nLength*: INTEGER;
nLength*: SYSTEM.CARD32;
lpSecurityDescriptor*: INTEGER;
bInheritHandle*: INTEGER
bInheritHandle*: SYSTEM.CARD32 (* BOOL *)
END;
TFileTime* = RECORD
dwLowDateTime*,
dwHighDateTime*: INTEGER
dwHighDateTime*: SYSTEM.CARD32
END;
TWin32FindData* = RECORD
dwFileAttributes*: SET;
dwFileAttributes*: SYSTEM.CARD32;
ftCreationTime*: TFileTime;
ftLastAccessTime*: TFileTime;
ftLastWriteTime*: TFileTime;
nFileSizeHigh*: INTEGER;
nFileSizeLow*: INTEGER;
dwReserved0*: INTEGER;
dwReserved1*: INTEGER;
nFileSizeHigh*: SYSTEM.CARD32;
nFileSizeLow*: SYSTEM.CARD32;
dwReserved0*: SYSTEM.CARD32;
dwReserved1*: SYSTEM.CARD32;
cFileName*: STRING;
cAlternateFileName*: ARRAY 14 OF CHAR
cAlternateFileName*: ARRAY 14 OF CHAR;
dwFileType*: SYSTEM.CARD32;
dwCreatorType*: SYSTEM.CARD32;
wFinderFlags*: WCHAR
END;
OFSTRUCT* = RECORD
cBytes*: CHAR;
fFixedDisk*: CHAR;
cBytes*: BYTE;
fFixedDisk*: BYTE;
nErrCode*: WCHAR;
Reserved1*: WCHAR;
Reserved2*: WCHAR;
@ -105,131 +126,93 @@ TYPE
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: INTEGER;
OffsetHigh*: INTEGER;
Offset*: SYSTEM.CARD32;
OffsetHigh*: SYSTEM.CARD32;
hEvent*: INTEGER
END;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleCursorPosition"]
SetConsoleCursorPosition* (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] SetConsoleCursorPosition* (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetConsoleScreenBufferInfo"]
GetConsoleScreenBufferInfo* (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetConsoleScreenBufferInfo* (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputCharacterA"]
FillConsoleOutputCharacter* (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FillConsoleOutputCharacterA* (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputAttribute"]
FillConsoleOutputAttribute* (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FillConsoleOutputAttribute* (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleTextAttribute"]
SetConsoleTextAttribute* (hConsoleOutput, wAttributes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] SetConsoleTextAttribute* (hConsoleOutput, wAttributes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle* (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetStdHandle* (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetLocalTime"]
GetLocalTime* (T: TSystemTime);
PROCEDURE [windows-, KERNEL, ""] GetLocalTime* (T: TSystemTime);
PROCEDURE [windows-, "kernel32.dll", "RemoveDirectoryA"]
RemoveDirectory* (lpPathName: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] RemoveDirectoryA* (lpPathName: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetFileAttributesA"]
GetFileAttributes* (lpPathName: INTEGER): SET;
PROCEDURE [windows-, KERNEL, ""] GetFileAttributesA* (lpPathName: INTEGER): SET;
PROCEDURE [windows-, "kernel32.dll", "CreateDirectoryA"]
CreateDirectory* (lpPathName: INTEGER; lpSecurityAttributes: PSecurityAttributes): INTEGER;
PROCEDURE [windows-, KERNEL, ""] CreateDirectoryA* (lpPathName: INTEGER; lpSecurityAttributes: PSecurityAttributes): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FindFirstFileA"]
FindFirstFile* (lpFileName: INTEGER; lpFindFileData: TWin32FindData): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FindFirstFileA* (lpFileName: INTEGER; lpFindFileData: TWin32FindData): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "DeleteFileA"]
DeleteFile* (lpFileName: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] DeleteFileA* (lpFileName: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FindClose"]
FindClose* (hFindFile: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FindClose* (hFindFile: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
CloseHandle* (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] CloseHandle* (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CreateFileA"]
CreateFile* (
PROCEDURE [windows-, KERNEL, ""] CreateFileA* (
lpFileName, dwDesiredAccess, dwShareMode: INTEGER;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
OpenFile* (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] OpenFile* (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "SetFilePointer"]
SetFilePointer* (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] SetFilePointer* (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, KERNEL, ""] ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
WriteFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, KERNEL, ""] WriteFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadConsoleA"]
ReadConsole* (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] ReadConsoleA* (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
GetCommandLine* (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetCommandLineA* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalAlloc"]
GlobalAlloc* (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GlobalAlloc* (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalFree"]
GlobalFree* (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GlobalFree* (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteConsoleW"]
WriteConsoleW* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] WriteConsoleW* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
ExitProcess* (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] ExitProcess* (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "WriteConsoleA"]
WriteConsole* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] WriteConsoleA* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
GetTickCount* (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetTickCount* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "Sleep"]
Sleep* (dwMilliseconds: INTEGER);
PROCEDURE [windows-, KERNEL, ""] Sleep* (dwMilliseconds: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "FreeLibrary"]
FreeLibrary* (hLibModule: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FreeLibrary* (hLibModule: INTEGER): INTEGER;
PROCEDURE [ccall, "msvcrt.dll", "rand"]
rand* (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetProcAddress* (hModule, name: INTEGER): INTEGER;
PROCEDURE [ccall, "msvcrt.dll", "srand"]
srand* (seed: INTEGER);
PROCEDURE [windows-, KERNEL, ""] LoadLibraryA* (name: INTEGER): INTEGER;
PROCEDURE [windows-, "user32.dll", "MessageBoxA"]
MessageBoxA* (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] AllocConsole* (): BOOLEAN;
PROCEDURE [windows-, "user32.dll", "MessageBoxW"]
MessageBox* (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FreeConsole* (): BOOLEAN;
PROCEDURE [windows-, "user32.dll", "CreateWindowExA"]
CreateWindowEx* (
PROCEDURE [windows-, USER, ""] MessageBoxA* (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, USER, ""] MessageBoxW* (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, USER, ""] CreateWindowExA* (
dwExStyle, lpClassName, lpWindowName, dwStyle, X, Y,
nWidth, nHeight, hWndParent, hMenu, hInstance, lpParam: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetProcAddress"]
GetProcAddress* (hModule, name: INTEGER): INTEGER;
PROCEDURE [ccall-, MSVCRT, ""] time* (ptr: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "LoadLibraryA"]
LoadLibraryA* (name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "AllocConsole"]
AllocConsole* (): BOOLEAN;
PROCEDURE [windows-, "kernel32.dll", "FreeConsole"]
FreeConsole* (): BOOLEAN;
PROCEDURE [ccall-, MSVCRT, ""] mktime* (time: tm): INTEGER;
PROCEDURE SetDllEntry* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
@ -238,4 +221,4 @@ BEGIN
END SetDllEntry;
END WINAPI.
END WINAPI.

20
programs/develop/oberon07/Lib/Windows64/API.ob07
View File

@ -12,6 +12,8 @@ IMPORT SYSTEM;
CONST
eol* = 0DX + 0AX;
SectionAlignment = 1000H;
DLL_PROCESS_ATTACH = 1;
@ -19,6 +21,9 @@ CONST
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
KERNEL = "kernel32.dll";
USER = "user32.dll";
TYPE
@ -27,7 +32,6 @@ TYPE
VAR
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
heap: INTEGER;
@ -36,13 +40,12 @@ VAR
thread_attach: DLL_ENTRY;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetProcessHeap"] GetProcessHeap (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapAlloc"] HeapAlloc (hHeap, dwFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapFree"] HeapFree(hHeap, dwFlags, lpMem: INTEGER);
PROCEDURE [windows-, "user32.dll", "MessageBoxA"] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] ExitProcess (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] ExitThread (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] GetProcessHeap (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] HeapAlloc (hHeap, dwFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] HeapFree (hHeap, dwFlags, lpMem: INTEGER);
PROCEDURE [windows-, USER, ""] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
@ -68,7 +71,6 @@ BEGIN
process_detach := NIL;
thread_detach := NIL;
thread_attach := NIL;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - SectionAlignment;
heap := GetProcessHeap()
END init;

101
programs/develop/oberon07/Lib/Windows64/Args.ob07 Normal file
View File

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

4
programs/develop/oberon07/Lib/Windows64/Console.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
@ -48,7 +48,7 @@ VAR
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
fill := ORD(ScrBufInfo.dwSize.X) * ORD(ScrBufInfo.dwSize.Y);
WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputCharacterA(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputAttribute(hConsoleOutput, ORD(ScrBufInfo.wAttributes), fill, 0, SYSTEM.ADR(fill));
SetCursor(0, 0)
END Cls;

27
programs/develop/oberon07/Lib/Windows64/DateTime.ob07
View File

@ -1,13 +1,13 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE DateTime;
IMPORT WINAPI;
IMPORT WINAPI, SYSTEM;
CONST
@ -116,6 +116,29 @@ BEGIN
END NowEncode;
PROCEDURE NowUnixTime* (): INTEGER;
RETURN WINAPI.time(0)
END NowUnixTime;
PROCEDURE UnixTime* (Year, Month, Day, Hour, Min, Sec: INTEGER): INTEGER;
VAR
t: WINAPI.tm;
BEGIN
DEC(Year, 1900);
DEC(Month);
SYSTEM.GET(SYSTEM.ADR(Sec), t.sec);
SYSTEM.GET(SYSTEM.ADR(Min), t.min);
SYSTEM.GET(SYSTEM.ADR(Hour), t.hour);
SYSTEM.GET(SYSTEM.ADR(Day), t.mday);
SYSTEM.GET(SYSTEM.ADR(Month), t.mon);
SYSTEM.GET(SYSTEM.ADR(Year), t.year);
RETURN WINAPI.mktime(t)
END UnixTime;
PROCEDURE init;
VAR
day, year, month, i: INTEGER;

139
programs/develop/oberon07/Lib/Windows64/File.ob07 Normal file
View File

@ -0,0 +1,139 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE File;
IMPORT SYSTEM, WINAPI, API;
CONST
OPEN_R* = 0; OPEN_W* = 1; OPEN_RW* = 2;
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
PROCEDURE Exists* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
FindData: WINAPI.TWin32FindData;
Handle: INTEGER;
attr: SET;
BEGIN
Handle := WINAPI.FindFirstFileA(SYSTEM.ADR(FName[0]), FindData);
IF Handle # -1 THEN
WINAPI.FindClose(Handle);
SYSTEM.GET32(SYSTEM.ADR(FindData.dwFileAttributes), attr);
IF 4 IN attr THEN
Handle := -1
END
END
RETURN Handle # -1
END Exists;
PROCEDURE Delete* (FName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.DeleteFileA(SYSTEM.ADR(FName[0])) # 0
END Delete;
PROCEDURE Create* (FName: ARRAY OF CHAR): INTEGER;
RETURN WINAPI.CreateFileA(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END Create;
PROCEDURE Close* (F: INTEGER);
BEGIN
WINAPI.CloseHandle(F)
END Close;
PROCEDURE Open* (FName: ARRAY OF CHAR; Mode: INTEGER): INTEGER;
VAR
ofstr: WINAPI.OFSTRUCT;
BEGIN
RETURN WINAPI.OpenFile(SYSTEM.ADR(FName[0]), ofstr, Mode)
END Open;
PROCEDURE Seek* (F, Offset, Origin: INTEGER): INTEGER;
RETURN WINAPI.SetFilePointer(F, Offset MOD 100000000H, SYSTEM.ADR(Offset) + 4, Origin)
END Seek;
PROCEDURE Read* (F, Buffer, Count: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF WINAPI.ReadFile(F, Buffer, Count, SYSTEM.ADR(res), NIL) = 0 THEN
res := -1
END
RETURN res
END Read;
PROCEDURE Write* (F, Buffer, Count: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF WINAPI.WriteFile(F, Buffer, Count, SYSTEM.ADR(res), NIL) = 0 THEN
res := -1
END
RETURN res
END Write;
PROCEDURE Load* (FName: ARRAY OF CHAR; VAR Size: INTEGER): INTEGER;
VAR
res, n, F: INTEGER;
BEGIN
res := 0;
F := Open(FName, OPEN_R);
IF F # -1 THEN
Size := Seek(F, 0, SEEK_END);
n := Seek(F, 0, SEEK_BEG);
res := API._NEW(Size);
IF (res = 0) OR (Read(F, res, Size) # Size) THEN
IF res # 0 THEN
res := API._DISPOSE(res);
Size := 0
END
END;
Close(F)
END
RETURN res
END Load;
PROCEDURE RemoveDir* (DirName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.RemoveDirectoryA(SYSTEM.ADR(DirName[0])) # 0
END RemoveDir;
PROCEDURE ExistsDir* (DirName: ARRAY OF CHAR): BOOLEAN;
VAR
Code: SET;
BEGIN
Code := WINAPI.GetFileAttributesA(SYSTEM.ADR(DirName[0]))
RETURN (Code # {0..31}) & (4 IN Code)
END ExistsDir;
PROCEDURE CreateDir* (DirName: ARRAY OF CHAR): BOOLEAN;
RETURN WINAPI.CreateDirectoryA(SYSTEM.ADR(DirName[0]), NIL) # 0
END CreateDir;
END File.

88
programs/develop/oberon07/Lib/Windows64/HOST.ob07
View File

@ -13,7 +13,7 @@ IMPORT SYSTEM, RTL;
CONST
slash* = "\";
OS* = "WINDOWS";
eol* = 0DX + 0AX;
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
@ -59,19 +59,6 @@ TYPE
END;
TSystemTime = RECORD
Year,
Month,
DayOfWeek,
Day,
Hour,
Min,
Sec,
MSec: WCHAR
END;
VAR
@ -80,8 +67,6 @@ VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc: INTEGER;
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
@ -116,12 +101,12 @@ PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
PROCEDURE [windows-, "kernel32.dll", "GetCurrentDirectoryA"]
_GetCurrentDirectory (nBufferLength, lpBuffer: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetSystemTime"]
_GetSystemTime (T: TSystemTime);
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
PROCEDURE [windows, "kernel32.dll", "ExitProcess"]
_ExitProcess (code: INTEGER);
PROCEDURE [windows, "msvcrt.dll", "time"]
_time (ptr: INTEGER): INTEGER;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
@ -215,13 +200,11 @@ END GetArg;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
res: INTEGER;
BEGIN
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, res, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
@ -230,13 +213,11 @@ END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
res: INTEGER;
BEGIN
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, res, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
@ -269,6 +250,10 @@ BEGIN
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
END chmod;
PROCEDURE OutChar* (c: CHAR);
VAR
count: INTEGER;
@ -292,24 +277,23 @@ PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
PROCEDURE UnixTime* (): INTEGER;
RETURN _time(0)
END UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
T: TSystemTime;
res: INTEGER;
BEGIN
_GetSystemTime(T);
year := ORD(T.Year);
month := ORD(T.Month);
day := ORD(T.Day);
hour := ORD(T.Hour);
min := ORD(T.Min);
sec := ORD(T.Sec)
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN 0
END UnixTime;
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;
@ -317,8 +301,7 @@ VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
@ -348,22 +331,7 @@ BEGIN
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
maxreal := 1.9;
PACK(maxreal, 1023);
hConsoleOutput := _GetStdHandle(-11);

307
programs/develop/oberon07/Lib/Windows64/In.ob07
View File

@ -1,290 +1,74 @@
(*
Copyright 2013, 2017, 2018, 2019 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE In;
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
TYPE
STRING = ARRAY 260 OF CHAR;
CONST
MAX_LEN = 1024;
VAR
Done*: BOOLEAN;
hConsoleInput: INTEGER;
Done*: BOOLEAN;
hConsoleInput: INTEGER;
s: ARRAY MAX_LEN + 4 OF CHAR;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadConsoleA"]
ReadConsole (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows, "msvcrt.dll", ""] sscanf (buf: INTEGER; fmt: INTEGER; adr: INTEGER): INTEGER;
PROCEDURE [windows, "kernel32.dll", ""] GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows, "kernel32.dll", ""] ReadConsoleA (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER);
PROCEDURE digit(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END digit;
PROCEDURE CheckInt(s: STRING; VAR first, last: INTEGER; VAR neg: BOOLEAN; Point: BOOLEAN): BOOLEAN;
VAR i: INTEGER;
PROCEDURE String* (VAR str: ARRAY OF CHAR);
VAR
count: INTEGER;
BEGIN
i := 0;
neg := FALSE;
WHILE (s[i] <= 20X) & (s[i] # 0X) DO
INC(i)
END;
IF s[i] = "-" THEN
neg := TRUE;
INC(i)
ELSIF s[i] = "+" THEN
INC(i)
END;
first := i;
WHILE digit(s[i]) DO
INC(i)
END;
last := i
RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first])
END CheckInt;
PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN;
VAR i: INTEGER; min: STRING;
BEGIN
i := 0;
min := "2147483648";
WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO
INC(i)
END
RETURN i = 10
END IsMinInt;
PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER;
CONST maxINT = 7FFFFFFFH;
VAR i, n, res: INTEGER; flag, neg: BOOLEAN;
BEGIN
res := 0;
flag := CheckInt(str, i, n, neg, FALSE);
err := ~flag;
IF flag & neg & IsMinInt(str, i) THEN
flag := FALSE;
neg := FALSE;
res := 80000000H
END;
WHILE flag & digit(str[i]) DO
IF res > maxINT DIV 10 THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END;
IF neg THEN
res := -res
END
RETURN res
END StrToInt;
PROCEDURE Space(s: STRING): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) & (s[i] <= 20X) DO
INC(i)
END
RETURN s[i] = 0X
END Space;
PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
Res := CheckInt(s, n, i, neg, TRUE);
IF Res THEN
IF s[i] = "." THEN
INC(i);
WHILE digit(s[i]) DO
INC(i)
END;
IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN
INC(i);
IF (s[i] = "+") OR (s[i] = "-") THEN
INC(i)
END;
Res := digit(s[i]);
WHILE digit(s[i]) DO
INC(i)
END
END
END
END
RETURN Res & (s[i] <= 20X)
END CheckReal;
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): REAL;
CONST maxDBL = 1.69E308; maxINT = 7FFFFFFFH;
VAR i, scale: INTEGER; res, m, d: REAL; minus, neg: BOOLEAN;
PROCEDURE part1(VAR res, d: REAL; VAR i: INTEGER; str: STRING): BOOLEAN;
BEGIN
res := 0.0;
d := 1.0;
WHILE digit(str[i]) DO
res := res * 10.0 + FLT(ORD(str[i]) - ORD("0"));
INC(i)
ReadConsoleA(hConsoleInput, SYSTEM.ADR(s[0]), MAX_LEN, SYSTEM.ADR(count), 0);
IF (s[count - 1] = 0AX) & (s[count - 2] = 0DX) THEN
DEC(count, 2)
END;
IF str[i] = "." THEN
INC(i);
WHILE digit(str[i]) DO
d := d / 10.0;
res := res + FLT(ORD(str[i]) - ORD("0")) * d;
INC(i)
END
END
RETURN str[i] # 0X
END part1;
PROCEDURE part2(VAR i, scale: INTEGER; VAR m, res: REAL; VAR minus, err: BOOLEAN; str: STRING): BOOLEAN;
BEGIN
INC(i);
m := 10.0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1
END;
scale := 0;
err := FALSE;
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN ~err
END part2;
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR scale: INTEGER; VAR res, m: REAL);
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0
ELSE
res := res * m;
INC(i)
END
END
END part3;
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1(res, d, i, str) & part2(i, scale, m, res, minus, err, str) THEN
part3(err, minus, scale, res, m)
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0;
err := TRUE
END
RETURN res
END StrToFloat;
PROCEDURE String*(VAR s: ARRAY OF CHAR);
VAR count, i: INTEGER; str: STRING;
BEGIN
ReadConsole(hConsoleInput, sys.ADR(str[0]), 256, sys.ADR(count), 0);
IF (str[count - 1] = 0AX) & (str[count - 2] = 0DX) THEN
DEC(count, 2)
END;
str[256] := 0X;
str[count] := 0X;
i := 0;
WHILE (i < LEN(s) - 1) & (i < LEN(str)) & (str[i] # 0X) DO
s[i] := str[i];
INC(i)
END;
s[i] := 0X;
Done := TRUE
s[count] := 0X;
COPY(s, str);
str[LEN(str) - 1] := 0X;
Done := TRUE
END String;
PROCEDURE Char*(VAR x: CHAR);
VAR str: STRING;
BEGIN
String(str);
x := str[0];
Done := TRUE
END Char;
PROCEDURE Ln*;
VAR str: STRING;
PROCEDURE Int* (VAR x: INTEGER);
BEGIN
String(str);
Done := TRUE
END Ln;
String(s);
Done := sscanf(SYSTEM.ADR(s[0]), SYSTEM.SADR("%lld"), SYSTEM.ADR(x)) = 1
END Int;
PROCEDURE Real*(VAR x: REAL);
VAR str: STRING; err: BOOLEAN;
PROCEDURE Real* (VAR x: REAL);
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToFloat(str, err);
Done := ~err
String(s);
Done := sscanf(SYSTEM.ADR(s[0]), SYSTEM.SADR("%lf"), SYSTEM.ADR(x)) = 1
END Real;
PROCEDURE Int*(VAR x: INTEGER);
VAR str: STRING; err: BOOLEAN;
PROCEDURE Char* (VAR x: CHAR);
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToInt(str, err);
Done := ~err
END Int;
String(s);
x := s[0]
END Char;
PROCEDURE Ln*;
BEGIN
String(s)
END Ln;
PROCEDURE Open*;
BEGIN
@ -292,4 +76,5 @@ BEGIN
Done := TRUE
END Open;
END In.

447
programs/develop/oberon07/Lib/Windows64/Math.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
@ -12,22 +12,32 @@ IMPORT SYSTEM;
CONST
e *= 2.71828182845904523;
pi *= 3.14159265358979324;
ln2 *= 0.693147180559945309;
pi* = 3.1415926535897932384626433832795028841972E0;
e* = 2.7182818284590452353602874713526624977572E0;
eps = 1.0E-16;
MaxCosArg = 1000000.0 * pi;
ZERO = 0.0E0;
ONE = 1.0E0;
HALF = 0.5E0;
TWO = 2.0E0;
sqrtHalf = 0.70710678118654752440E0;
eps = 5.5511151E-17;
ln2Inv = 1.44269504088896340735992468100189213E0;
piInv = ONE / pi;
Limit = 1.0536712E-8;
piByTwo = pi / TWO;
expoMax = 1023;
expoMin = 1 - expoMax;
VAR
Exp: ARRAY 710 OF REAL;
LnInfinity, LnSmall, large, miny: REAL;
PROCEDURE [stdcall64] sqrt* (x: REAL): REAL;
BEGIN
ASSERT(x >= 0.0);
ASSERT(x >= ZERO);
SYSTEM.CODE(
0F2H, 0FH, 51H, 45H, 10H, (* sqrtsd xmm0, qword[rbp + 10h] *)
05DH, (* pop rbp *)
@ -38,205 +48,340 @@ BEGIN
END sqrt;
PROCEDURE sqri* (x: INTEGER): INTEGER;
RETURN x * x
END sqri;
PROCEDURE sqrr* (x: REAL): REAL;
RETURN x * x
END sqrr;
PROCEDURE exp* (x: REAL): REAL;
CONST
e25 = 1.284025416687741484; (* exp(0.25) *)
c1 = 0.693359375E0;
c2 = -2.1219444005469058277E-4;
P0 = 0.249999999999999993E+0;
P1 = 0.694360001511792852E-2;
P2 = 0.165203300268279130E-4;
Q1 = 0.555538666969001188E-1;
Q2 = 0.495862884905441294E-3;
VAR
a, s, res: REAL;
neg: BOOLEAN;
xn, g, p, q, z: REAL;
n: INTEGER;
BEGIN
neg := x < 0.0;
IF neg THEN
x := -x
END;
IF x < FLT(LEN(Exp)) THEN
res := Exp[FLOOR(x)];
x := x - FLT(FLOOR(x));
WHILE x >= 0.25 DO
res := res * e25;
x := x - 0.25
END
IF x > LnInfinity THEN
x := SYSTEM.INF()
ELSIF x < LnSmall THEN
x := ZERO
ELSIF ABS(x) < eps THEN
x := ONE
ELSE
res := SYSTEM.INF();
x := 0.0
END;
IF x >= ZERO THEN
n := FLOOR(ln2Inv * x + HALF)
ELSE
n := FLOOR(ln2Inv * x - HALF)
END;
n := 0;
a := 1.0;
s := 1.0;
REPEAT
INC(n);
a := a * x / FLT(n);
s := s + a
UNTIL a < eps;
IF neg THEN
res := 1.0 / (res * s)
ELSE
res := res * s
xn := FLT(n);
g := (x - xn * c1) - xn * c2;
z := g * g;
p := ((P2 * z + P1) * z + P0) * g;
q := (Q2 * z + Q1) * z + HALF;
x := HALF + p / (q - p);
PACK(x, n + 1)
END
RETURN res
RETURN x
END exp;
PROCEDURE ln* (x: REAL): REAL;
CONST
c1 = 355.0E0 / 512.0E0;
c2 = -2.121944400546905827679E-4;
P0 = -0.64124943423745581147E+2;
P1 = 0.16383943563021534222E+2;
P2 = -0.78956112887491257267E+0;
Q0 = -0.76949932108494879777E+3;
Q1 = 0.31203222091924532844E+3;
Q2 = -0.35667977739034646171E+2;
VAR
a, x2, res: REAL;
zn, zd, r, z, w, p, q, xn: REAL;
n: INTEGER;
BEGIN
ASSERT(x > 0.0);
ASSERT(x > ZERO);
UNPK(x, n);
x := x * HALF;
x := (x - 1.0) / (x + 1.0);
x2 := x * x;
res := x + FLT(n) * (ln2 * 0.5);
n := 1;
IF x > sqrtHalf THEN
zn := x - ONE;
zd := x * HALF + HALF;
INC(n)
ELSE
zn := x - HALF;
zd := zn * HALF + HALF
END;
REPEAT
INC(n, 2);
x := x * x2;
a := x / FLT(n);
res := res + a
UNTIL a < eps
z := zn / zd;
w := z * z;
q := ((w + Q2) * w + Q1) * w + Q0;
p := w * ((P2 * w + P1) * w + P0);
r := z + z * (p / q);
xn := FLT(n)
RETURN res * 2.0
RETURN (xn * c2 + r) + xn * c1
END ln;
PROCEDURE power* (base, exponent: REAL): REAL;
BEGIN
ASSERT(base > 0.0)
ASSERT(base > ZERO)
RETURN exp(exponent * ln(base))
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 log* (base, x: REAL): REAL;
BEGIN
ASSERT(base > 0.0);
ASSERT(x > 0.0)
ASSERT(base > ZERO);
ASSERT(x > ZERO)
RETURN ln(x) / ln(base)
END log;
PROCEDURE cos* (x: REAL): REAL;
PROCEDURE SinCos (x, y, sign: REAL): REAL;
CONST
ymax = 210828714;
c1 = 3.1416015625E0;
c2 = -8.908910206761537356617E-6;
r1 = -0.16666666666666665052E+0;
r2 = 0.83333333333331650314E-2;
r3 = -0.19841269841201840457E-3;
r4 = 0.27557319210152756119E-5;
r5 = -0.25052106798274584544E-7;
r6 = 0.16058936490371589114E-9;
r7 = -0.76429178068910467734E-12;
r8 = 0.27204790957888846175E-14;
VAR
a, res: REAL;
n: INTEGER;
xn, f, x1, g: REAL;
BEGIN
ASSERT(y < FLT(ymax));
n := FLOOR(y * piInv + HALF);
xn := FLT(n);
IF ODD(n) THEN
sign := -sign
END;
x := ABS(x);
ASSERT(x <= MaxCosArg);
IF x # y THEN
xn := xn - HALF
END;
x := x - FLT( FLOOR(x / (2.0 * pi)) ) * (2.0 * pi);
x := x * x;
res := 0.0;
a := 1.0;
n := -1;
x1 := FLT(FLOOR(x));
f := ((x1 - xn * c1) + (x - x1)) - xn * c2;
REPEAT
INC(n, 2);
res := res + a;
a := -a * x / FLT(n*n + n)
UNTIL ABS(a) < eps
IF ABS(f) < Limit THEN
x := sign * f
ELSE
g := f * f;
g := (((((((r8 * g + r7) * g + r6) * g + r5) * g + r4) * g + r3) * g + r2) * g + r1) * g;
g := f + f * g;
x := sign * g
END
RETURN res
END cos;
RETURN x
END SinCos;
PROCEDURE sin* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x)
END sin;
PROCEDURE tan* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= MaxCosArg);
x := cos(x)
RETURN sqrt(1.0 - x * x) / x
END tan;
PROCEDURE arcsin* (x: REAL): REAL;
PROCEDURE arctan (x: REAL): REAL;
VAR
z, p, k: REAL;
BEGIN
p := x / (x * x + 1.0);
z := p * x;
x := 0.0;
k := 0.0;
REPEAT
k := k + 2.0;
x := x + p;
p := p * k * z / (k + 1.0)
UNTIL p < eps
RETURN x
END arctan;
BEGIN
ASSERT(ABS(x) <= 1.0);
IF ABS(x) >= 0.707 THEN
x := 0.5 * pi - arctan(sqrt(1.0 - x * x) / x)
IF x < ZERO THEN
x := SinCos(x, -x, -ONE)
ELSE
x := arctan(x / sqrt(1.0 - x * x))
x := SinCos(x, x, ONE)
END
RETURN x
END sin;
PROCEDURE cos* (x: REAL): REAL;
RETURN SinCos(x, ABS(x) + piByTwo, ONE)
END cos;
PROCEDURE tan* (x: REAL): REAL;
VAR
s, c: REAL;
BEGIN
s := sin(x);
c := sqrt(ONE - s * s);
x := ABS(x) / (TWO * pi);
x := x - FLT(FLOOR(x));
IF (0.25 < x) & (x < 0.75) THEN
c := -c
END
RETURN s / c
END tan;
PROCEDURE arctan2* (y, x: REAL): REAL;
CONST
P0 = 0.216062307897242551884E+3; P1 = 0.3226620700132512059245E+3;
P2 = 0.13270239816397674701E+3; P3 = 0.1288838303415727934E+2;
Q0 = 0.2160623078972426128957E+3; Q1 = 0.3946828393122829592162E+3;
Q2 = 0.221050883028417680623E+3; Q3 = 0.3850148650835119501E+2;
Sqrt3 = 1.7320508075688772935E0;
VAR
atan, z, z2, p, q: REAL;
yExp, xExp, Quadrant: INTEGER;
BEGIN
IF ABS(x) < miny THEN
ASSERT(ABS(y) >= miny);
atan := piByTwo
ELSE
z := y;
UNPK(z, yExp);
z := x;
UNPK(z, xExp);
IF yExp - xExp >= expoMax - 3 THEN
atan := piByTwo
ELSIF yExp - xExp < expoMin + 3 THEN
atan := ZERO
ELSE
IF ABS(y) > ABS(x) THEN
z := ABS(x / y);
Quadrant := 2
ELSE
z := ABS(y / x);
Quadrant := 0
END;
IF z > TWO - Sqrt3 THEN
z := (z * Sqrt3 - ONE) / (Sqrt3 + z);
INC(Quadrant)
END;
IF ABS(z) < Limit THEN
atan := z
ELSE
z2 := z * z;
p := (((P3 * z2 + P2) * z2 + P1) * z2 + P0) * z;
q := (((z2 + Q3) * z2 + Q2) * z2 + Q1) * z2 + Q0;
atan := p / q
END;
CASE Quadrant OF
|0:
|1: atan := atan + pi / 6.0
|2: atan := piByTwo - atan
|3: atan := pi / 3.0 - atan
END
END;
IF x < ZERO THEN
atan := pi - atan
END
END;
IF y < ZERO THEN
atan := -atan
END
RETURN atan
END arctan2;
PROCEDURE arcsin* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= ONE)
RETURN arctan2(x, sqrt(ONE - x * x))
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) <= 1.0)
RETURN 0.5 * pi - arcsin(x)
ASSERT(ABS(x) <= ONE)
RETURN arctan2(sqrt(ONE - x * x), x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arcsin(x / sqrt(1.0 + x * x))
RETURN arctan2(x, ONE)
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
RETURN (x - ONE / x) * HALF
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
RETURN (x + ONE / x) * HALF
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
x := ONE
ELSIF x < -15.0 THEN
x := -1.0
x := -ONE
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
x := exp(TWO * x);
x := (x - ONE) / (x + ONE)
END
RETURN x
@ -244,21 +389,21 @@ END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
RETURN ln(x + sqrt(x * x + ONE))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
BEGIN
ASSERT(x >= 1.0)
RETURN ln(x + sqrt(x * x - 1.0))
ASSERT(x >= ONE)
RETURN ln(x + sqrt(x * x - ONE))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) < 1.0)
RETURN 0.5 * ln((1.0 + x) / (1.0 - x))
ASSERT(ABS(x) < ONE)
RETURN HALF * ln((ONE + x) / (ONE - x))
END artanh;
@ -267,9 +412,9 @@ VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
IF x > ZERO THEN
res := 1
ELSIF x < 0.0 THEN
ELSIF x < ZERO THEN
res := -1
ELSE
res := 0
@ -284,7 +429,7 @@ VAR
res: REAL;
BEGIN
res := 1.0;
res := ONE;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
@ -294,18 +439,42 @@ BEGIN
END fact;
PROCEDURE init;
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
i: INTEGER;
a: REAL;
BEGIN
Exp[0] := 1.0;
FOR i := 1 TO LEN(Exp) - 1 DO
Exp[i] := Exp[i - 1] * e
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
END init;
RETURN a
END hypot;
BEGIN
init
large := 1.9;
PACK(large, expoMax);
miny := ONE / large;
LnInfinity := ln(large);
LnSmall := ln(miny);
END Math.

310
programs/develop/oberon07/Lib/Windows64/Out.ob07
View File

@ -1,308 +1,86 @@
(*
Copyright 2013, 2014, 2017, 2018, 2019 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
CONST
d = 1.0 - 5.0E-12;
TYPE
POverlapped* = POINTER TO OVERLAPPED;
OVERLAPPED* = RECORD
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: INTEGER;
OffsetHigh*: INTEGER;
hEvent*: INTEGER
END;
VAR
hConsoleOutput: INTEGER;
Realp: PROCEDURE (x: REAL; width: INTEGER);
hConsoleOutput: INTEGER;
PROCEDURE [windows, "msvcrt.dll", "printf"] printf1 (fmt: INTEGER; x: INTEGER);
PROCEDURE [windows, "msvcrt.dll", "printf"] printf2 (fmt: INTEGER; width, x: INTEGER);
PROCEDURE [windows, "msvcrt.dll", "printf"] printf3 (fmt: INTEGER; width, precision, x: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
PROCEDURE [windows, "kernel32.dll", ""]
WriteConsoleW (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER);
PROCEDURE [windows, "kernel32.dll", ""]
GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
WriteFile (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteConsoleW"]
WriteConsoleW (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE Char*(x: CHAR);
VAR count: INTEGER;
PROCEDURE Char* (x: CHAR);
BEGIN
WriteFile(hConsoleOutput, sys.ADR(x), 1, sys.ADR(count), NIL)
printf1(SYSTEM.SADR("%c"), ORD(x))
END Char;
PROCEDURE StringW*(s: ARRAY OF WCHAR);
VAR count: INTEGER;
PROCEDURE StringW* (s: ARRAY OF WCHAR);
BEGIN
WriteConsoleW(hConsoleOutput, sys.ADR(s[0]), LENGTH(s), sys.ADR(count), 0)
WriteConsoleW(hConsoleOutput, SYSTEM.ADR(s[0]), LENGTH(s), 0, 0)
END StringW;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR len, i: INTEGER;
PROCEDURE String* (s: ARRAY OF CHAR);
BEGIN
len := LENGTH(s);
FOR i := 0 TO len - 1 DO
Char(s[i])
END
printf2(SYSTEM.SADR("%.*s"), LENGTH(s), SYSTEM.ADR(s[0]))
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 32 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR s: SET;
BEGIN
sys.GET(sys.ADR(AValue), s)
RETURN (s * {52..62} = {52..62}) & ((s * {32..51} # {}) OR (s * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i, minInt: INTEGER;
BEGIN
minInt := 1;
minInt := ROR(minInt, 1);
IF x # minInt THEN
WriteInt(x, width)
ELSE
FOR i := 21 TO width DO
Char(20X)
END;
String("-9223372036854775808")
END
END Int;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
printf1(SYSTEM.SADR("%s"), SYSTEM.SADR(CHR(13) + CHR(10)))
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;
PROCEDURE Int* (x, width: INTEGER);
BEGIN
Realp := Real;
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
_FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
printf2(SYSTEM.SADR("%*lld"), width, x)
END Int;
PROCEDURE intval (x: REAL): INTEGER;
VAR
i: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), i)
RETURN i
END intval;
PROCEDURE Real* (x: REAL; width: INTEGER);
BEGIN
printf3(SYSTEM.SADR("%*.*E"), width, MAX(MIN(width - 8, 15), 1), intval(x))
END Real;
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
PROCEDURE FixReal* (x: REAL; width, precision: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
printf3(SYSTEM.SADR("%*.*f"), width, precision, intval(x))
END FixReal;
PROCEDURE Open*;
BEGIN
hConsoleOutput := GetStdHandle(-11)
END Open;
END Out.

49
programs/develop/oberon07/Lib/Windows64/RTL.ob07
View File

@ -350,33 +350,29 @@ END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
INC(i);
a := a DIV 10
UNTIL a = 0;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
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, i, j: INTEGER;
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
@ -384,19 +380,12 @@ BEGIN
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE [stdcall64] _error* (module, err, line: INTEGER);
PROCEDURE [stdcall64] _error* (modnum, _module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
@ -415,10 +404,8 @@ BEGIN
|11: s := "BYTE out of range"
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
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);

64
programs/develop/oberon07/Lib/Windows64/UnixTime.ob07
View File

@ -1,64 +0,0 @@
(*
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.

152
programs/develop/oberon07/Lib/Windows64/WINAPI.ob07
View File

@ -14,6 +14,10 @@ CONST
OFS_MAXPATHNAME* = 128;
KERNEL = "kernel32.dll";
USER = "user32.dll";
MSVCRT = "msvcrt.dll";
TYPE
@ -56,27 +60,59 @@ TYPE
END;
tm* = RECORD
sec*,
min*,
hour*,
mday*,
mon*,
year*,
wday*,
yday*,
isdst*: SYSTEM.CARD32
END;
PSecurityAttributes* = POINTER TO TSecurityAttributes;
TSecurityAttributes* = RECORD
nLength*: INTEGER;
nLength*: SYSTEM.CARD32;
lpSecurityDescriptor*: INTEGER;
bInheritHandle*: INTEGER
bInheritHandle*: SYSTEM.CARD32 (* BOOL *)
END;
TFileTime* = RECORD
dwLowDateTime*,
dwHighDateTime*: INTEGER
dwHighDateTime*: SYSTEM.CARD32
END;
TWin32FindData* = RECORD
dwFileAttributes*: SYSTEM.CARD32;
ftCreationTime*: TFileTime;
ftLastAccessTime*: TFileTime;
ftLastWriteTime*: TFileTime;
nFileSizeHigh*: SYSTEM.CARD32;
nFileSizeLow*: SYSTEM.CARD32;
dwReserved0*: SYSTEM.CARD32;
dwReserved1*: SYSTEM.CARD32;
cFileName*: STRING;
cAlternateFileName*: ARRAY 14 OF CHAR;
dwFileType*: SYSTEM.CARD32;
dwCreatorType*: SYSTEM.CARD32;
wFinderFlags*: WCHAR
END;
OFSTRUCT* = RECORD
cBytes*: CHAR;
fFixedDisk*: CHAR;
cBytes*: BYTE;
fFixedDisk*: BYTE;
nErrCode*: WCHAR;
Reserved1*: WCHAR;
Reserved2*: WCHAR;
@ -90,75 +126,93 @@ TYPE
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: INTEGER;
OffsetHigh*: INTEGER;
Offset*: SYSTEM.CARD32;
OffsetHigh*: SYSTEM.CARD32;
hEvent*: INTEGER
END;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleCursorPosition"]
SetConsoleCursorPosition* (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] SetConsoleCursorPosition* (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetConsoleScreenBufferInfo"]
GetConsoleScreenBufferInfo* (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetConsoleScreenBufferInfo* (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputCharacterA"]
FillConsoleOutputCharacter* (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FillConsoleOutputCharacterA* (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "FillConsoleOutputAttribute"]
FillConsoleOutputAttribute* (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FillConsoleOutputAttribute* (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "SetConsoleTextAttribute"]
SetConsoleTextAttribute* (hConsoleOutput, wAttributes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] SetConsoleTextAttribute* (hConsoleOutput, wAttributes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
GetStdHandle* (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetStdHandle* (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
CloseHandle* (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] CloseHandle* (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
WriteFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, KERNEL, ""] WriteFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, KERNEL, ""] ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
GetCommandLine* (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetCommandLineA* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalAlloc"]
GlobalAlloc* (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GlobalAlloc* (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalFree"]
GlobalFree* (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GlobalFree* (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
ExitProcess* (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] ExitProcess* (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
GetTickCount* (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetTickCount* (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "Sleep"]
Sleep* (dwMilliseconds: INTEGER);
PROCEDURE [windows-, KERNEL, ""] Sleep* (dwMilliseconds: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "FreeLibrary"]
FreeLibrary* (hLibModule: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FreeLibrary* (hLibModule: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetProcAddress"]
GetProcAddress* (hModule, name: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetProcAddress* (hModule, name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "LoadLibraryA"]
LoadLibraryA* (name: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] LoadLibraryA* (name: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "AllocConsole"]
AllocConsole* (): BOOLEAN;
PROCEDURE [windows-, KERNEL, ""] AllocConsole* (): BOOLEAN;
PROCEDURE [windows-, "kernel32.dll", "FreeConsole"]
FreeConsole* (): BOOLEAN;
PROCEDURE [windows-, KERNEL, ""] FreeConsole* (): BOOLEAN;
PROCEDURE [windows-, "kernel32.dll", "GetLocalTime"]
GetLocalTime* (T: TSystemTime);
PROCEDURE [windows-, KERNEL, ""] GetLocalTime* (T: TSystemTime);
PROCEDURE [windows-, KERNEL, ""] RemoveDirectoryA* (lpPathName: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetFileAttributesA* (lpPathName: INTEGER): SET;
PROCEDURE [windows-, KERNEL, ""] CreateDirectoryA* (lpPathName: INTEGER; lpSecurityAttributes: PSecurityAttributes): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FindFirstFileA* (lpFileName: INTEGER; lpFindFileData: TWin32FindData): INTEGER;
PROCEDURE [windows-, KERNEL, ""] DeleteFileA* (lpFileName: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FindClose* (hFindFile: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] CreateFileA* (
lpFileName, dwDesiredAccess, dwShareMode: INTEGER;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] OpenFile* (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] SetFilePointer* (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] ReadConsoleA* (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] WriteConsoleW* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] WriteConsoleA* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, USER, ""] MessageBoxA* (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, USER, ""] MessageBoxW* (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, USER, ""] CreateWindowExA* (
dwExStyle, lpClassName, lpWindowName, dwStyle, X, Y,
nWidth, nHeight, hWndParent, hMenu, hInstance, lpParam: INTEGER): INTEGER;
PROCEDURE [windows-, MSVCRT, ""] time* (ptr: INTEGER): INTEGER;
PROCEDURE [windows-, MSVCRT, ""] mktime* (time: tm): INTEGER;
PROCEDURE SetDllEntry* (process_detach, thread_detach, thread_attach: DLL_ENTRY);

0
programs/develop/oberon07/Samples/Dialogs.ob07 → programs/develop/oberon07/Samples/KolibriOS/Dialogs.ob07
View File

0
programs/develop/oberon07/Samples/HW.ob07 → programs/develop/oberon07/Samples/KolibriOS/HW.ob07
View File

0
programs/develop/oberon07/Samples/HW_con.ob07 → programs/develop/oberon07/Samples/KolibriOS/HW_con.ob07
View File

52
programs/develop/oberon07/Samples/Linux/HW.ob07 Normal file
View File

@ -0,0 +1,52 @@
MODULE HW;
IMPORT SYSTEM, Libdl, Args;
VAR
libc: INTEGER;
puts: PROCEDURE [linux] (pStr: INTEGER);
PROCEDURE OutStringLn (s: ARRAY OF CHAR);
BEGIN
puts(SYSTEM.ADR(s[0]))
END OutStringLn;
PROCEDURE main;
VAR
i: INTEGER;
s: ARRAY 80 OF CHAR;
BEGIN
OutStringLn("Hello");
OutStringLn("");
i := 0;
WHILE i < Args.argc DO
Args.GetArg(i, s);
INC(i);
OutStringLn(s)
END;
OutStringLn("");
i := 0;
WHILE i < Args.envc DO
Args.GetEnv(i, s);
INC(i);
OutStringLn(s)
END;
OutStringLn("");
OutStringLn("Bye")
END main;
BEGIN
libc := Libdl.open("libc.so.6", Libdl.LAZY);
SYSTEM.PUT(SYSTEM.ADR(puts), Libdl.sym(libc, "puts"));
ASSERT(puts # NIL);
main
END HW.

74
programs/develop/oberon07/Samples/Linux/X11/animation/_unix.ob07 Normal file
View File

@ -0,0 +1,74 @@
MODULE _unix; (* connect to unix host *)
IMPORT SYSTEM, API;
(* how to find C declarations:
- gcc -E preprocess only (to stdout) (preprocessor expand)
- grep -r name /usr/include/*
- ldd progfile
- objdump -T progfile (-t) (-x)
*)
CONST RTLD_LAZY = 1;
BIT_DEPTH* = API.BIT_DEPTH;
VAR sym, libc, libdl :INTEGER;
_dlopen* :PROCEDURE [linux] (name, flags :INTEGER) :INTEGER;
_dlsym* :PROCEDURE [linux] (p, name :INTEGER) :INTEGER;
_dlclose* :PROCEDURE [linux] (p :INTEGER) :INTEGER;
_open* :PROCEDURE [linux] (name, flags, mode :INTEGER) :INTEGER;
_close* :PROCEDURE [linux] (fd :INTEGER) :INTEGER;
_read* :PROCEDURE [linux] (fd, buf, sz :INTEGER): INTEGER;
_write* :PROCEDURE [linux] (fd, buf, sz :INTEGER) :INTEGER;
_exit* :PROCEDURE [linux] (n :INTEGER);
_malloc* :PROCEDURE [linux] (sz :INTEGER) :INTEGER;
_select* :PROCEDURE [linux] (cnt, readfds, writefds, exceptfds, timeout :INTEGER) :INTEGER;
(* error message to stderr *)
PROCEDURE writeChar (c :CHAR);
VAR ri :INTEGER;
BEGIN ri := _write (2, SYSTEM.ADR(c), 1); ASSERT (ri = 1) END writeChar;
PROCEDURE writeString (s :ARRAY OF CHAR);
VAR i :INTEGER;
BEGIN i := 0; WHILE s[i] # 0X DO writeChar (s[i]); INC(i) END; END writeString;
PROCEDURE nl;
BEGIN writeChar (0AX) END nl;
PROCEDURE getSymAdr (lib :INTEGER; name :ARRAY OF CHAR; adr :INTEGER);
BEGIN
sym := _dlsym (lib, SYSTEM.ADR(name[0]));
IF sym = 0 THEN writeString ("error: dlsym: "); writeString (name); nl END;
ASSERT (sym # 0);
SYSTEM.PUT (adr, sym)
END getSymAdr;
PROCEDURE finish*;
VAR ri :INTEGER;
BEGIN
IF libc # 0 THEN ri := _dlclose (libc); libc := 0 END;
IF libdl # 0 THEN ri := _dlclose (libdl); libdl := 0 END;
END finish;
BEGIN
_dlopen := API.dlopen;
_dlsym := API.dlsym;
libc := _dlopen (SYSTEM.SADR("libc.so.6"), RTLD_LAZY); ASSERT (libc # 0);
(* getSymAdr is not used for write() to get writeString() error message going *);
sym := _dlsym (libc, SYSTEM.SADR("write")); ASSERT (sym # 0); SYSTEM.PUT (SYSTEM.ADR(_write), sym);
libdl := _dlopen (SYSTEM.SADR("libdl.so.2"), RTLD_LAZY); ASSERT (libdl # 0);
getSymAdr (libdl, "dlclose", SYSTEM.ADR(_dlclose));
getSymAdr (libc, "open", SYSTEM.ADR(_open));
getSymAdr (libc, "close", SYSTEM.ADR(_close));
getSymAdr (libc, "read", SYSTEM.ADR(_read));
getSymAdr (libc, "exit", SYSTEM.ADR(_exit));
getSymAdr (libc, "malloc", SYSTEM.ADR(_malloc));
getSymAdr (libc, "select", SYSTEM.ADR(_select));
END _unix.

89
programs/develop/oberon07/Samples/Linux/X11/animation/animation.ob07 Normal file
View File

@ -0,0 +1,89 @@
MODULE animation; (* moving turtle example *)
(* demonstrates use of timeout and select() to display a moving turtle in an X11 window *)
IMPORT SYSTEM, gr;
CONST
Side = 8; (* nr of pixels of a square side *)
VAR base, stride, screenBufSize :INTEGER;
currentX :INTEGER;
PROCEDURE drawSquare (x, y, color :INTEGER);
VAR p, i, j :INTEGER;
BEGIN
p := (y*stride + x*4)*Side;
ASSERT (p + (Side-1)*stride + (Side-1)*4 <= screenBufSize);
p := base + p;
FOR j := 0 TO Side-1 DO
FOR i := 0 TO Side-1 DO SYSTEM.PUT32 (p, color); INC(p, 4) END;
p := p + stride - Side*4;
END;
END drawSquare;
PROCEDURE putLine (x : INTEGER; y: INTEGER;str : ARRAY OF CHAR);
VAR z, x1: INTEGER;
BEGIN
FOR z := 0 TO LEN(str) - 1 DO
x1 := (x + z) MOD 100;
IF str[z] = "b" THEN drawSquare(x1, y, 0600000H); END; (* brown *)
IF str[z] = "g" THEN drawSquare(x1, y, 000C000H); END; (* green *)
END;
END putLine;
PROCEDURE turtlePicture (x , y : INTEGER);
BEGIN
putLine(x, y + 0 , "....bb........");
putLine(x, y + 1 , "....bbb.......");
putLine(x, y + 2 , "....bbbb......");
putLine(x, y + 3 , ".bb..bbb......");
putLine(x, y + 4 , ".bgggbbbgbbgb.");
putLine(x, y + 5 , ".ggggggggbbbb.");
putLine(x, y + 6 , "bggggggggbbbb.");
putLine(x, y + 7 , ".ggggggg......");
putLine(x, y + 8 , ".bb..bbb......");
putLine(x, y + 9 , "....bbbb......");
putLine(x, y + 10, ".....bbb......");
putLine(x, y + 11, ".....bb.......")
END turtlePicture;
PROCEDURE drawAll;
BEGIN
gr.screenBegin;
gr.clear (0C0F0FFH); (* light blue *)
turtlePicture (currentX, 15);
gr.screenEnd;
END drawAll;
PROCEDURE run*;
VAR stop :BOOLEAN;
ev :gr.EventPars;
ch :CHAR;
BEGIN
base := gr.base; stride := gr.stride;
gr.createWindow (800, 480);
screenBufSize := gr.winHeight * stride;
stop := FALSE; currentX := 15;
drawAll;
REPEAT
gr.nextEvent (400, ev);
IF ev[0] = gr.EventTimeOut THEN
drawAll;
INC (currentX, 4);
ELSIF ev[0] = gr.EventKeyPressed THEN
ch := CHR(ev[4]);
IF (ch = "q") OR (ch = 0AX) OR (ch = " ") THEN stop := TRUE END;
IF ev[2] = 9 (* ESC *) THEN stop := TRUE END;
END;
UNTIL stop;
gr.finish;
END run;
BEGIN
run;
END animation.

292
programs/develop/oberon07/Samples/Linux/X11/animation/gr.ob07 Normal file
View File

@ -0,0 +1,292 @@
MODULE gr; (* connect to libX11 *)
IMPORT SYSTEM, unix, out;
(*
X11 documentation in:
- http://tronche.com/gui/x/xlib/ an X11 reference
- http://www.sbin.org/doc/Xlib an X11 tutorial (this domain has disappeared)
*)
CONST
InputOutput = 1;
StructureNotifyMask = 20000H; (* input event mask *)
ExposureMask = 8000H; KeyPressMask = 1; KeyReleaseMask = 2;
ButtonPressMask = 4; ButtonReleaseMask = 8; (* PointerNotionMask *)
ZPixmap = 2;
Expose = 12; (* X event type *) ConfigureNotify = 22; KeyPress = 2; ButtonPress = 4;
EventTimeOut* = 80; (* 0, 0, 0, 0 *)
EventResize* = 81; (* 0, w, h, 0 *)
EventKeyPressed* = 82; (* isPrintable, keyCode (X11 scan code), state, keySym (ASCII) *)
EventKeyReleased* = 83; (* 0, keyCode, state, 0 *)
EventButtonPressed* = 84; (* button, x, y, state *)
EventButtonReleased* = 85; (* button, x, y, state *)
(* mouse button 1-5 = Left, Middle, Right, Scroll wheel up, Scroll wheel down *)
bit64 = ORD(unix.BIT_DEPTH = 64);
TYPE EventPars* = ARRAY 5 OF INTEGER;
XEvent = RECORD
val :ARRAY 192 OF BYTE (* union { ..., long pad[24]; } *)
(* val :ARRAY 48 OF CARD32; *)
END;
VAR ScreenWidth*, ScreenHeight* :INTEGER;
winWidth*, winHeight* :INTEGER; (* draw by writing to pixel buffer: *)
base*, stride* :INTEGER; (* width, height, base ptr, stride in bytes, 32-bit RGB *)
painting :BOOLEAN;
libX11 :INTEGER; (* handle to dynamic library *)
XOpenDisplay :PROCEDURE [linux] (name :INTEGER) :INTEGER;
XCloseDisplay :PROCEDURE [linux] (display :INTEGER);
XSynchronize :PROCEDURE [linux] (display, onoff :INTEGER) :INTEGER; (* return prev onoff *)
XConnectionNumber :PROCEDURE [linux] (display :INTEGER) :INTEGER;
XCreateWindow :PROCEDURE [linux] (display, parent_window, x, y, w, h, border_width, depth,
class, visual, valuemask, attributes :INTEGER) :INTEGER; (* Window *)
XDefaultScreen :PROCEDURE [linux] (display :INTEGER) :INTEGER;
XDefaultGC :PROCEDURE [linux] (display, screenNr :INTEGER) :INTEGER; (* GC *)
XDisplayWidth :PROCEDURE [linux] (display, screenNr :INTEGER) :INTEGER;
XDisplayHeight :PROCEDURE [linux] (display, screenNr :INTEGER) :INTEGER;
XDefaultVisual :PROCEDURE [linux] (display, screenNr :INTEGER) :INTEGER; (* visual *)
XDefaultRootWindow :PROCEDURE [linux] (display :INTEGER) :INTEGER; (* Window *)
XDefaultDepth :PROCEDURE [linux] (display, screenNr :INTEGER) :INTEGER;
XSelectInput :PROCEDURE [linux] (display, window, event_mask :INTEGER);
XMapWindow :PROCEDURE [linux] (display, window :INTEGER);
XNextEvent :PROCEDURE [linux] (display, XEvent_p :INTEGER);
XPending :PROCEDURE [linux] (display :INTEGER) :INTEGER;
XLookupString :PROCEDURE [linux] (key_event, buffer_return, buflen, keysym_return, status_in_out :INTEGER) :INTEGER;
XCreateImage :PROCEDURE [linux] (display, visual, depth, format, offset, data,
width, height, bitmap_pad, bytes_per_line :INTEGER) :INTEGER; (* ptr to XImage *)
XPutImage :PROCEDURE [linux] (display, window, gc, image, sx, sy, dx, dy, w, h :INTEGER);
display, screen, window, gc, img :INTEGER;
connectionNr :INTEGER; (* fd of X11 socket *)
readX11 :unix.fd_set; (* used by select() timeout on X11 socket *)
PROCEDURE getSymAdr (lib :INTEGER; name :ARRAY OF CHAR; adr :INTEGER);
VAR sym :INTEGER;
BEGIN
sym := unix.dlsym (lib, SYSTEM.ADR(name[0]));
IF sym = 0 THEN out.formatStr ("error: dlsym: %", name); out.nl END;
ASSERT (sym # 0);
SYSTEM.PUT (adr, sym)
END getSymAdr;
PROCEDURE init;
BEGIN
display := XOpenDisplay (0);
IF display = 0 THEN out.str ("error: can not open X11 display."); out.nl; out.exit(1) END;
(* ri := XSynchronize (display, 1); *)
connectionNr := XConnectionNumber (display); ASSERT (connectionNr < unix.FD_SETSIZE);
NEW (readX11); unix.FD_ZERO(readX11); unix.FD_SET (connectionNr, readX11);
screen := XDefaultScreen (display); gc := XDefaultGC (display, screen);
ScreenWidth := XDisplayWidth (display, screen); ScreenHeight := XDisplayHeight (display, screen);
base := unix.malloc (ScreenWidth * ScreenHeight * 4);
IF base = 0 THEN
out.formatInt2 ("error: can not allocate screen buffer % x %", ScreenWidth, ScreenHeight); out.nl; out.exit(1);
END;
stride := ScreenWidth * 4;
img := XCreateImage (display, XDefaultVisual (display, screen), XDefaultDepth (display, screen),
ZPixmap, 0, base, ScreenWidth, ScreenHeight, 32, 0);
END init;
PROCEDURE finish*;
VAR ri :INTEGER;
BEGIN
IF display # 0 THEN XCloseDisplay(display); display := 0 END;
IF libX11 # 0 THEN ri := unix.dlclose (libX11); libX11 := 0 END;
END finish;
PROCEDURE createWindow* (w, h :INTEGER);
VAR eventMask :INTEGER;
BEGIN
IF (w > ScreenWidth) OR (h > ScreenHeight) THEN
out.str ("error: X11.createWindow: window too large"); out.exit(1);
END;
ASSERT ((w >= 0) & (h >= 0));
window := XCreateWindow (display, XDefaultRootWindow (display), 0, 0, w, h, 0,
XDefaultDepth (display, screen), InputOutput, XDefaultVisual (display, screen), 0, 0);
winWidth := w; winHeight := h;
eventMask := StructureNotifyMask + ExposureMask + KeyPressMask + ButtonPressMask;
XSelectInput (display, window, eventMask);
XMapWindow (display, window);
END createWindow;
PROCEDURE screenBegin*;
(* intended to enable future cooperation with iOS / MacOS *)
BEGIN
ASSERT (~painting); painting := TRUE
END screenBegin;
PROCEDURE screenEnd*;
BEGIN
ASSERT (painting);
XPutImage (display, window, gc, img, 0, 0, 0, 0, winWidth, winHeight);
painting := FALSE;
END screenEnd;
PROCEDURE readInt (e :XEvent; i :INTEGER) :INTEGER;
(* treat XEvent byte array as int array *)
VAR n :INTEGER;
BEGIN
ASSERT (i >= 0);
ASSERT (i < 48);
i := i * 4;
n := e.val[i+3]*1000000H + e.val[i+2]*10000H + e.val[i+1]*100H + e.val[i];
RETURN n
END readInt;
PROCEDURE nextEvent* (msTimeOut :INTEGER; VAR ev :EventPars);
VAR _type, n, ri :INTEGER;
event :XEvent;
x, y, w, h :INTEGER;
timeout :unix.timespec;
BEGIN
(* struct XEvent (64-bit):
any: 4 type 8 serial 4 send_event 8 display 8 window 8 window
expose: 40 any 4 x, y, w, h, count
xconfigure: 48 any 4 x, y, w, h
xkey / xbutton / xmotion: 48 any 8 sub_window 8 time_ms 4 x, y, x_root, y_root 4 state 4 keycode/button
*)
(* struct XEvent (32-bit):
any: 4 type 4 serial 4 send_event 4 display 4 window
expose: 20 any 4 x, y, w, h, count
xconfigure: 24 any 4 x, y, w, h
xkey / xbutton / xmotion: 24 any 4 sub_window 4 time_ms 4 x, y, x_root, y_root 4 state 4 keycode/button
*)
_type := 0;
WHILE _type = 0 DO
IF (msTimeOut > 0) & (XPending(display) = 0) THEN
timeout.tv_sec := msTimeOut DIV 1000; timeout.tv_usec := (msTimeOut MOD 1000) * 1000;
ri := unix.select (connectionNr + 1, readX11, NIL, NIL, timeout); ASSERT (ri # -1);
IF ri = 0 THEN _type := EventTimeOut; ev[1] := 0; ev[2] := 0; ev[3] := 0; ev[4] := 0 END;
END;
IF _type = 0 THEN
XNextEvent (display, SYSTEM.ADR(event));
CASE readInt (event, 0) OF
Expose :
x := readInt (event, 5 + 5 * bit64); y := readInt (event, 6 + 5 * bit64);
w := readInt (event, 7 + 5 * bit64); h := readInt (event, 8 + 5 * bit64);
XPutImage (display, window, gc, img, x, y, x, y, w, h);
| ConfigureNotify :
w := readInt (event, 8 + 6 * bit64); h := readInt (event, 9 + 6 * bit64);
IF (w # winWidth) & (h # winHeight) THEN
ASSERT ((w >= 0) & (h >= 0));
IF w > ScreenWidth THEN w := ScreenWidth END;
IF h > ScreenHeight THEN h := ScreenHeight END;
winWidth := w; winHeight := h;
ev[0] := EventResize; ev[1] := 0; ev[2] := w; ev[3] := h; ev[4] := 0;
END;
| KeyPress :
_type := EventKeyPressed;
x := XLookupString (SYSTEM.ADR(event), 0, 0, SYSTEM.ADR(n), 0); (* KeySym *)
IF (n = 8) OR (n = 10) OR (n >= 32) & (n <= 126) THEN ev[1] := 1 ELSE ev[1] := 0; n := 0 END; (* isprint *)
ev[2] := readInt (event, 13 + 8 * bit64); (* keycode *)
ev[3] := readInt (event, 12 + 8 * bit64); (* state *)
ev[4] := n; (* KeySym *)
| ButtonPress :
_type := EventButtonPressed;
ev[1] := readInt (event, 13 + 8 * bit64); (* button *)
ev[2] := readInt (event, 8 + 8 * bit64); (* x *)
ev[3] := readInt (event, 9 + 8 * bit64); (* y *)
ev[4] := readInt (event, 12 + 8 * bit64); (* state *)
ELSE
END
END
END;
ev[0] := _type
END nextEvent;
PROCEDURE clear* (color :INTEGER); (* fill window area with color *)
VAR p, i, j :INTEGER;
BEGIN
FOR j := 0 TO winHeight-1 DO
p := base + j*stride;
FOR i := 0 TO winWidth-1 DO SYSTEM.PUT32 (p, color); INC (p, 4) END
END
END clear;
(*
PROCEDURE blitError (stride, x, y, w, h :INTEGER);
BEGIN
o.formatInt ("error: screen.blit (src, %)", stride);
o.formatInt2 (", %, %", x, y);
o.formatInt2 (", %, %) out of bounds", w, h); o.nl;
ASSERT (FALSE)
END blitError;
PROCEDURE blit* (src, srcStride, x, y, w, h :INTEGER);
VAR dstStride, p :INTEGER;
BEGIN
IF (x < 0) OR (y < 0) THEN blitError (srcStride, x, y, w, h) END;
IF (w <= 0) OR (h <= 0) THEN blitError (srcStride, x, y, w, h) END;
IF (x + w > ScreenWidth) OR (y + h > ScreenHeight) THEN blitError (srcStride, x, y, w, h) END;
dstStride := ScreenWidth - w;
p := ScreenBase + y * ScreenWidth + x * 4;
REPEAT
SYSTEM.COPY (src, p, w);
INC (src, srcStride); INC (p, dstStride); DEC (h)
UNTIL h = 0
END blit;
*)
(*
PROCEDURE setPixel* (x, y, color :INTEGER);
VAR p :INTEGER;
BEGIN
ASSERT ((x >= 0) & (x < ScreenWidth) & (y >= 0) & (y < ScreenHeight));
screenBegin; p := base + (y*ScreenWidth + x)*4; SYSTEM.PUT32 (p, color); p := p + 4 screenEnd
END setPixel;
*)
(*
PROCEDURE loop; (* example main loop *)
VAR e :EventPars;
stop :BOOLEAN;
BEGIN
createWindow (200, 200);
stop := FALSE;
REPEAT
nextEvent (0, e);
IF e[0] = EventKeyPressed THEN stop := TRUE END;
UNTIL stop;
XCloseDisplay (display);
END loop;
*)
BEGIN
libX11 := unix.dlopen (SYSTEM.SADR("libX11.so.6"), unix.RTLD_LAZY); ASSERT (libX11 # 0);
getSymAdr (libX11, "XOpenDisplay", SYSTEM.ADR(XOpenDisplay));
getSymAdr (libX11, "XCloseDisplay", SYSTEM.ADR(XCloseDisplay));
getSymAdr (libX11, "XSynchronize", SYSTEM.ADR(XSynchronize));
getSymAdr (libX11, "XConnectionNumber", SYSTEM.ADR(XConnectionNumber));
getSymAdr (libX11, "XCreateWindow", SYSTEM.ADR(XCreateWindow));
getSymAdr (libX11, "XDefaultScreen", SYSTEM.ADR(XDefaultScreen));
getSymAdr (libX11, "XDefaultGC", SYSTEM.ADR(XDefaultGC));
getSymAdr (libX11, "XDisplayWidth", SYSTEM.ADR(XDisplayWidth));
getSymAdr (libX11, "XDisplayHeight", SYSTEM.ADR(XDisplayHeight));
getSymAdr (libX11, "XDefaultVisual", SYSTEM.ADR(XDefaultVisual));
getSymAdr (libX11, "XDefaultRootWindow", SYSTEM.ADR(XDefaultRootWindow));
getSymAdr (libX11, "XDefaultDepth", SYSTEM.ADR(XDefaultDepth));
getSymAdr (libX11, "XSelectInput", SYSTEM.ADR(XSelectInput));
getSymAdr (libX11, "XMapWindow", SYSTEM.ADR(XMapWindow));
getSymAdr (libX11, "XNextEvent", SYSTEM.ADR(XNextEvent));
getSymAdr (libX11, "XPending", SYSTEM.ADR(XPending));
getSymAdr (libX11, "XLookupString", SYSTEM.ADR(XLookupString));
getSymAdr (libX11, "XCreateImage", SYSTEM.ADR(XCreateImage));
getSymAdr (libX11, "XPutImage", SYSTEM.ADR(XPutImage));
init;
END gr.

142
programs/develop/oberon07/Samples/Linux/X11/animation/out.ob07 Normal file
View File

@ -0,0 +1,142 @@
MODULE out; (* formatted output to stdout *)
(* Wim Niemann, Jan Tuitman 06-OCT-2016 *)
IMPORT SYSTEM, _unix;
(* example: IMPORT o:=out;
o.str("Hello, World!");o.nl;
o.formatInt("n = %", 3);o.nl;
*)
(*
The output functions buffer the characters in buf. This buffer is flushed when out.nl is
called and also when the buffer is full.
Calling flush once per line is far more efficient then one system call per
character, but this is noticable only at very long outputs.
*)
CONST MAX = 63; (* last position in buf *)
VAR len :INTEGER; (* string length in buf *)
buf :ARRAY MAX+1 OF BYTE;
PROCEDURE exit* (n :INTEGER);
(* prevent IMPORT unix for many programs *)
BEGIN _unix._exit(n) END exit;
PROCEDURE writeChars;
(* write buf to the output function and set to empty string *)
VAR ri :INTEGER;
BEGIN
IF len > 0 THEN
(* buf[len] := 0X; *)
ri := _unix._write (1, SYSTEM.ADR(buf), len); ASSERT (ri = len); (* stdout *)
len := 0
END
END writeChars;
PROCEDURE nl*; (* append a newline to buf and flush *)
BEGIN
IF len = MAX THEN writeChars END;
buf[len] := 0AH; INC(len);
(* unix: 0AX; Oberon: 0DX;
Windows: IF len >= MAX-1 THEN 0DX 0AX; *)
writeChars;
END nl;
PROCEDURE char* (c :CHAR);
(* append char to the end of buf *)
BEGIN
IF len = MAX THEN writeChars END;
buf[len] := ORD(c); INC(len)
END char;
PROCEDURE str* (t :ARRAY OF CHAR);
(* append t to buf *)
VAR j :INTEGER;
BEGIN
j := 0; WHILE t[j] # 0X DO char(t[j]); INC(j) END
END str;
PROCEDURE int* (n :INTEGER);
(* append integer; append n to d, return TRUE on overflow of d *)
VAR j :INTEGER;
sign :BOOLEAN;
dig :ARRAY 11 OF CHAR; (* assume 32 bit INTEGER *)
BEGIN
sign := FALSE; IF n < 0 THEN sign := TRUE; n := -n END;
IF n < 0 THEN
str ("-2147483648");
ELSE
j := 0;
REPEAT dig[j] := CHR (n MOD 10 + 30H); n := n DIV 10; INC(j) UNTIL n = 0;
IF sign THEN char ("-") END;
REPEAT DEC(j); char(dig[j]) UNTIL j = 0;
END
END int;
PROCEDURE formatInt* (t :ARRAY OF CHAR; n :INTEGER);
(* append formatted string t. Replace the first % by n *)
VAR j :INTEGER;
BEGIN
j := 0; WHILE (t[j] # 0X) & (t[j] # "%") DO char(t[j]); INC(j) END;
IF t[j] = "%" THEN
int(n); INC(j);
WHILE t[j] # 0X DO char(t[j]); INC(j) END
END
END formatInt;
PROCEDURE formatInt2* (t:ARRAY OF CHAR; n1, n2 :INTEGER);
(* append formatted string t. Replace the first two % by n1 and n2 *)
VAR j :INTEGER;
BEGIN
j := 0; WHILE (t[j] # 0X) & (t[j] # "%") DO char(t[j]); INC(j) END;
IF t[j] = "%" THEN
int(n1); INC(j);
WHILE (t[j] # 0X) & (t[j] # "%") DO char(t[j]); INC(j) END;
IF t[j] = "%" THEN
int(n2); INC(j);
WHILE t[j] # 0X DO char(t[j]); INC(j) END
END
END
END formatInt2;
PROCEDURE formatStr* (t, u :ARRAY OF CHAR);
(* append formatted string. Replace the first % in t by u *)
VAR j, k :INTEGER;
BEGIN
j := 0; WHILE (t[j] # 0X) & (t[j] # "%") DO char(t[j]); INC(j) END;
IF t[j] = "%" THEN
k := 0; WHILE u[k] # 0X DO char(u[k]); INC(k) END;
INC(j); WHILE t[j] # 0X DO char(t[j]); INC(j) END
END
END formatStr;
PROCEDURE hex* (n, width :INTEGER);
(* print width positions of n as hex string. If necessary, prefix with leading zeroes *)
(* note: if n needs more positions than width, the first hex digits are not printed *)
VAR j :INTEGER;
dig :ARRAY 9 OF CHAR;
BEGIN
ASSERT(width > 0);
ASSERT (width <= 8);
dig[width] := 0X;
REPEAT
j := n MOD 16; n := n DIV 16;
IF j < 10 THEN j := ORD("0") + j ELSE j := ORD("A") + j - 10 END;
DEC(width); dig[width] := CHR(j)
UNTIL width = 0;
str (dig);
END hex;
PROCEDURE flush*;
(* this routine comes at the end. It won't hardly ever be called
because nl also flushes. It is present only in case you
want to write a flushed string which does not end with nl. *)
BEGIN writeChars END flush;
(* note: global variable 'len' must be 0 on init. Within the core, bodies of imported modules
are not executed, so rely on zero initialisation by Modules.Load *)
END out.

74
programs/develop/oberon07/Samples/Linux/X11/animation/unix.ob07 Normal file
View File

@ -0,0 +1,74 @@
MODULE unix; (* connect to unix host *)
IMPORT SYSTEM, _unix;
(* provide some Oberon friendly POSIX without need for SYSTEM *)
CONST RTLD_LAZY* = 1;
O_RDONLY* = 0;
O_NEWFILE* = 0C2H; (* O_RDWR | O_CREAT | O_EXCL *)
(* O_RDONLY=0, O_WRONLY=1, O_RDWR=2, O_CREAT=0x40, O_EXCL=0x80, O_TRUNC=0x200 *)
FD_SETSIZE* = 1024; (* fd for select() must be smaller than FD_SETSIZE *)
BIT_DEPTH* = _unix.BIT_DEPTH;
LEN_FD_SET = FD_SETSIZE DIV BIT_DEPTH;
TYPE
timespec* = RECORD
tv_sec*, tv_usec* :INTEGER
END;
fd_set* = POINTER TO RECORD (* for select() *)
bits* :ARRAY LEN_FD_SET OF SET (* 1024 bits *)
END;
VAR
dlopen* :PROCEDURE [linux] (name, flags :INTEGER) :INTEGER;
dlsym* :PROCEDURE [linux] (p, name :INTEGER) :INTEGER;
dlclose* :PROCEDURE [linux] (p :INTEGER) :INTEGER;
close* :PROCEDURE [linux] (fd :INTEGER) :INTEGER;
exit* :PROCEDURE [linux] (n :INTEGER);
malloc* :PROCEDURE [linux] (sz :INTEGER) :INTEGER;
PROCEDURE open* (path :ARRAY OF CHAR; flag, perm :INTEGER) :INTEGER;
BEGIN RETURN _unix._open (SYSTEM.ADR(path[0]), flag, perm) END open;
PROCEDURE read* (fd :INTEGER; VAR buf :ARRAY OF BYTE; len :INTEGER) :INTEGER;
BEGIN RETURN _unix._read (fd, SYSTEM.ADR(buf[0]), len) END read;
PROCEDURE readByte* (fd :INTEGER; VAR n :BYTE) :INTEGER;
BEGIN RETURN _unix._read (fd, SYSTEM.ADR(n), 1) END readByte;
PROCEDURE write* (fd :INTEGER; buf :ARRAY OF BYTE; len :INTEGER) :INTEGER;
BEGIN RETURN _unix._write (fd, SYSTEM.ADR(buf[0]), len) END write;
PROCEDURE writeByte* (fd :INTEGER; n :BYTE) :INTEGER;
BEGIN RETURN _unix._write (fd, SYSTEM.ADR(n), 1) END writeByte;
PROCEDURE FD_ZERO* (VAR selectSet :fd_set);
VAR i :INTEGER;
BEGIN FOR i := 0 TO LEN_FD_SET-1 DO selectSet.bits[i] := {} END END FD_ZERO;
PROCEDURE FD_SET* (fd :INTEGER; VAR selectSet :fd_set); (* set fd bit in a select() fd_set *)
BEGIN INCL(selectSet.bits[fd DIV BIT_DEPTH], fd MOD BIT_DEPTH)
END FD_SET;
PROCEDURE select* (cnt :INTEGER; readfds, writefds, exceptfds :fd_set; timeout :timespec) :INTEGER;
VAR n1, n2, n3 :INTEGER;
BEGIN
n1 := 0; IF readfds # NIL THEN n1 := SYSTEM.ADR (readfds.bits[0]) END;
n2 := 0; IF writefds # NIL THEN n2 := SYSTEM.ADR (writefds.bits[0]) END;
n3 := 0; IF exceptfds # NIL THEN n3 := SYSTEM.ADR (exceptfds.bits[0]) END;
RETURN _unix._select (cnt, n1, n2, n3, SYSTEM.ADR(timeout))
END select;
PROCEDURE finish*;
BEGIN _unix.finish; END finish;
BEGIN
dlopen := _unix._dlopen;
dlsym := _unix._dlsym;
dlclose := _unix._dlclose;
close := _unix._close;
exit := _unix._exit;
malloc := _unix._malloc;
END unix.

74
programs/develop/oberon07/Samples/Linux/X11/filler/_unix.ob07 Normal file
View File

@ -0,0 +1,74 @@
MODULE _unix; (* connect to unix host *)
IMPORT SYSTEM, API;
(* how to find C declarations:
- gcc -E preprocess only (to stdout) (preprocessor expand)
- grep -r name /usr/include/*
- ldd progfile
- objdump -T progfile (-t) (-x)
*)
CONST RTLD_LAZY = 1;
BIT_DEPTH* = API.BIT_DEPTH;
VAR sym, libc, libdl :INTEGER;
_dlopen* :PROCEDURE [linux] (name, flags :INTEGER) :INTEGER;
_dlsym* :PROCEDURE [linux] (p, name :INTEGER) :INTEGER;
_dlclose* :PROCEDURE [linux] (p :INTEGER) :INTEGER;
_open* :PROCEDURE [linux] (name, flags, mode :INTEGER) :INTEGER;
_close* :PROCEDURE [linux] (fd :INTEGER) :INTEGER;
_read* :PROCEDURE [linux] (fd, buf, sz :INTEGER): INTEGER;
_write* :PROCEDURE [linux] (fd, buf, sz :INTEGER) :INTEGER;
_exit* :PROCEDURE [linux] (n :INTEGER);
_malloc* :PROCEDURE [linux] (sz :INTEGER) :INTEGER;
_select* :PROCEDURE [linux] (cnt, readfds, writefds, exceptfds, timeout :INTEGER) :INTEGER;
(* error message to stderr *)
PROCEDURE writeChar (c :CHAR);
VAR ri :INTEGER;
BEGIN ri := _write (2, SYSTEM.ADR(c), 1); ASSERT (ri = 1) END writeChar;
PROCEDURE writeString (s :ARRAY OF CHAR);
VAR i :INTEGER;
BEGIN i := 0; WHILE s[i] # 0X DO writeChar (s[i]); INC(i) END; END writeString;
PROCEDURE nl;
BEGIN writeChar (0AX) END nl;
PROCEDURE getSymAdr (lib :INTEGER; name :ARRAY OF CHAR; adr :INTEGER);
BEGIN
sym := _dlsym (lib, SYSTEM.ADR(name[0]));
IF sym = 0 THEN writeString ("error: dlsym: "); writeString (name); nl END;
ASSERT (sym # 0);
SYSTEM.PUT (adr, sym)
END getSymAdr;
PROCEDURE finish*;
VAR ri :INTEGER;
BEGIN
IF libc # 0 THEN ri := _dlclose (libc); libc := 0 END;
IF libdl # 0 THEN ri := _dlclose (libdl); libdl := 0 END;
END finish;
BEGIN
_dlopen := API.dlopen;
_dlsym := API.dlsym;
libc := _dlopen (SYSTEM.SADR("libc.so.6"), RTLD_LAZY); ASSERT (libc # 0);
(* getSymAdr is not used for write() to get writeString() error message going *);
sym := _dlsym (libc, SYSTEM.SADR("write")); ASSERT (sym # 0); SYSTEM.PUT (SYSTEM.ADR(_write), sym);
libdl := _dlopen (SYSTEM.SADR("libdl.so.2"), RTLD_LAZY); ASSERT (libdl # 0);
getSymAdr (libdl, "dlclose", SYSTEM.ADR(_dlclose));
getSymAdr (libc, "open", SYSTEM.ADR(_open));
getSymAdr (libc, "close", SYSTEM.ADR(_close));
getSymAdr (libc, "read", SYSTEM.ADR(_read));
getSymAdr (libc, "exit", SYSTEM.ADR(_exit));
getSymAdr (libc, "malloc", SYSTEM.ADR(_malloc));
getSymAdr (libc, "select", SYSTEM.ADR(_select));
END _unix.

221
programs/develop/oberon07/Samples/Linux/X11/filler/filler.ob07 Normal file
View File

@ -0,0 +1,221 @@
MODULE filler; (* filler game, color more fields than the opponent *)
IMPORT SYSTEM, out, unix, gr;
CONST
Side = 14; (* nr of pixels of a field side *)
width = 62; height = 48; (* board size *)
nrFields = width * height;
BackGroundColor = 0B0B050H;
VAR fdRandom :INTEGER; (* /dev/urandom *)
base, stride, screenBufSize :INTEGER;
palette :ARRAY 6 OF INTEGER;
field :ARRAY nrFields OF INTEGER; (* color 0..5 *)
visit :ARRAY nrFields OF INTEGER; (* 0 unvisited, 1 neighbour to do, 2 done *)
Acount, Acolor, Bcount, Bcolor :INTEGER; (* player conquered fields and current color *)
rndSeed, rndIndex :INTEGER;
PROCEDURE check (b :BOOLEAN; n :INTEGER);
BEGIN
IF ~b THEN
out.formatInt ("internal check failed: filler.mod: %", n); out.nl;
out.exit(1)
END
END check;
PROCEDURE random6 () :INTEGER; (* return random 0..5 *)
VAR n :INTEGER;
b :BYTE;
BEGIN
IF rndIndex = 3 THEN
(* 6 ^ 3 = 216 so 3 random6 nrs fit in one random byte, don't waste entropy *)
n := unix.readByte (fdRandom, b); ASSERT (n = 1);
rndSeed := b; rndIndex := 0;
END;
n := rndSeed MOD 6; rndSeed := rndSeed DIV 6; INC (rndIndex)
RETURN n
END random6;
PROCEDURE drawRect (x, y, color :INTEGER);
VAR p, i, j :INTEGER;
BEGIN
p := (y*stride + x*4)*Side;
check (p + (Side-1)*stride + (Side-1)*4 <= screenBufSize, 20);
p := base + p;
FOR j := 0 TO Side-1 DO
FOR i := 0 TO Side-1 DO SYSTEM.PUT32 (p, color); INC(p, 4) END;
p := p + stride - Side*4;
END;
END drawRect;
PROCEDURE clearVisit;
VAR i :INTEGER;
BEGIN FOR i := 0 TO nrFields-1 DO visit[i] := 0 END; END clearVisit;
PROCEDURE doNeighbour (i, old, new, v :INTEGER; VAR changed :BOOLEAN);
(* helper routine for connect() *)
BEGIN
IF visit[i] = 0 THEN
IF (v = 1) & (field[i] = old) THEN visit[i] := 1; changed := TRUE END;
IF field[i] = new THEN visit[i] := 2; changed := TRUE END
END
END doNeighbour;
(*
all visit := 0; count := 0; visit[corner] := 1
repeat
changed := false;
foreach:
if (visit = 1) or (visit = 2) then
curVisit = visit
color := new; visit := 3; count++
foreach neighbour:
if visit = 0 then
if curVisit = 1 then
if color = old then visit := 1; changed := true
if color = new then visit := 2; changed := true
if curVisit = 2 then
if color = new then visit := 2; changed := true
until no changes
*)
PROCEDURE connect (old, new :INTEGER) :INTEGER;
VAR count, i, x, y, v :INTEGER;
changed :BOOLEAN;
BEGIN
out.formatInt2 ("connect: old new % % ", old+1, new+1);
count := 0;
REPEAT
changed := FALSE;
FOR i := 0 TO nrFields-1 DO
v := visit[i];
IF (v=1) OR (v=2) THEN
field[i] := new; visit[i] := 3; INC(count);
x := i MOD width; y := i DIV width;
IF x > 0 THEN doNeighbour (i-1, old, new, v, changed) END;
IF x < width-1 THEN doNeighbour (i+1, old, new, v, changed) END;
IF y > 0 THEN doNeighbour (i-width, old, new, v, changed) END;
IF y < height-1 THEN doNeighbour (i+width, old, new, v, changed) END;
END
END
UNTIL ~changed
RETURN count
END connect;
PROCEDURE doMaxGainNeighbour (i, old, new, v :INTEGER; VAR changed :BOOLEAN);
(* helper routine for maxGain() *)
BEGIN
IF visit[i] = 0 THEN
IF v = 1 THEN
IF field[i] = old THEN visit[i] := 1 ELSE visit[i] := 2 END;
changed := TRUE
ELSE
IF field[i] = new THEN visit[i] := 2; changed := TRUE END
END
END
END doMaxGainNeighbour;
(* v=1 & field=old -> visit := 1
v=1 & field # old -> visit := 2
v=2 & field = new -> visit := 2
*)
PROCEDURE maxGain (old :INTEGER) :INTEGER;
(* return the color which will conquer the most fields *)
VAR
i, x, y, new, v :INTEGER;
max :ARRAY 6 OF INTEGER;
changed :BOOLEAN;
BEGIN
FOR i := 0 TO 5 DO max[i] := 0 END;
REPEAT
changed := FALSE;
FOR i := 0 TO nrFields-1 DO
v := visit[i];
IF (v=1) OR (v=2) THEN
visit[i] := 3; new := field[i]; INC (max[new]);
x := i MOD width; y := i DIV width;
IF x > 0 THEN doMaxGainNeighbour (i-1, old, new, v, changed) END;
IF x < width-1 THEN doMaxGainNeighbour (i+1, old, new, v, changed) END;
IF y > 0 THEN doMaxGainNeighbour (i-width, old, new, v, changed) END;
IF y < height-1 THEN doMaxGainNeighbour (i+width, old, new, v, changed) END;
END
END
UNTIL ~changed;
x := -1; y := -1; max[Acolor] := -1; max[Bcolor] := -1;
out.str ("maxGain"); out.nl;
FOR i := 0 TO 5 DO out.formatInt2 (" % %", i+1, max[i]); out.nl END;
FOR i := 0 TO 5 DO IF (max[i] > y) & (i # old) THEN x := i; y := max[i] END END
RETURN x
END maxGain;
PROCEDURE drawAll;
VAR x, y :INTEGER;
BEGIN
gr.screenBegin;
gr.clear (BackGroundColor);
FOR y := 0 TO 5 DO drawRect (0, 6 + y DIV 3 + 2*y, palette[y]) END;
FOR y := 0 TO 47 DO
FOR x := 0 TO 61 DO drawRect (x+2, y, palette[ field[y*width + x] ]) END
END;
gr.screenEnd;
END drawAll;
PROCEDURE run*;
VAR stop :BOOLEAN;
ev :gr.EventPars;
x, y, i, old :INTEGER;
ch :CHAR;
BEGIN
FOR i := 0 TO nrFields-1 DO field[i] := random6() END;
Acolor := field[47*width]; field[47*width+1] := Acolor; field[46*width] := Acolor; field[46*width+1] := Acolor;
Bcolor := field[width-1]; field[width-2] := Bcolor; field[2*width-2] := Bcolor; field[2*width-1] := Bcolor;
base := gr.base; stride := gr.stride;
gr.createWindow (1000, 700);
screenBufSize := gr.winHeight * stride;
stop := FALSE;
drawAll;
REPEAT
gr.nextEvent (0, ev);
IF ev[0] = gr.EventKeyPressed THEN
(* o.formatInt("key pressed %",ev[2]);o.nl; *)
(* ev[2]: q=24, ESC=9, CR=36 *)
ch := CHR (ev[4]);
IF ev[2] = 9 THEN stop := TRUE END; (* ESC *)
(* IF ch = "q" THEN stop := TRUE END; *)
IF (ch >= "1") & (ch <= "6") THEN
i := ev[4] - ORD("1");
IF (i # Acolor) & (i # Bcolor) THEN
(* player A *)
old := Acolor; Acolor := i;
out.formatInt ("play color %", Acolor+1); out.nl;
clearVisit; visit[47*width] := 1;
Acount := connect (old, Acolor)
;out.formatInt ("count A = %", Acount); out.nl; out.nl;
(* player B *)
clearVisit; visit[width-1] := 1; old := field[width-1];
Bcolor := maxGain (old);
clearVisit; visit[width-1] := 1;
Bcount := connect (old, Bcolor);
out.formatInt ("count B = %", Bcount); out.nl; out.nl;
drawAll;
END
END;
ELSIF ev[0] = gr.EventButtonPressed THEN
x := ev[2] DIV Side; y := ev[3] DIV Side;
END;
UNTIL stop;
gr.finish;
unix.finish;
END run;
BEGIN
fdRandom := unix.open ("/dev/urandom", unix.O_RDONLY, 0); ASSERT (fdRandom # -1);
rndIndex := 3;
(* a partial copy of the lexaloffle pico-8 16-color palette *)
palette[0] := 0FF004DH; (* red *)
palette[1] := 0FFA300H; (* orange *)
palette[2] := 07E2553H; (* dark purple *)
palette[3] := 0008751H; (* dark green *)
palette[4] := 029ADFFH; (* blue *)
palette[5] := 0FF77A8H; (* pink *)
run;
END filler.

15
programs/develop/oberon07/Samples/Linux/X11/filler/filler.txt Normal file
View File

@ -0,0 +1,15 @@

Filler game
Player and computer each try to conquer the most fields.
Player starts at left bottom and computer at right top.
At each turn, a new color is chosen and area extended.
Press 1 .. 6 to choose color. At the left side of the board the top
color has nr 1 and the bottom color nr 6. The current colors of player
and opponent can not be chosen. The current area receives the new color
and is extended with all bordering areas of the chosen color.
Have fun!

292
programs/develop/oberon07/Samples/Linux/X11/filler/gr.ob07 Normal file
View File

@ -0,0 +1,292 @@
MODULE gr; (* connect to libX11 *)
IMPORT SYSTEM, unix, out;
(*
X11 documentation in:
- http://tronche.com/gui/x/xlib/ an X11 reference
- http://www.sbin.org/doc/Xlib an X11 tutorial (this domain has disappeared)
*)
CONST
InputOutput = 1;
StructureNotifyMask = 20000H; (* input event mask *)
ExposureMask = 8000H; KeyPressMask = 1; KeyReleaseMask = 2;
ButtonPressMask = 4; ButtonReleaseMask = 8; (* PointerNotionMask *)
ZPixmap = 2;
Expose = 12; (* X event type *) ConfigureNotify = 22; KeyPress = 2; ButtonPress = 4;
EventTimeOut* = 80; (* 0, 0, 0, 0 *)
EventResize* = 81; (* 0, w, h, 0 *)
EventKeyPressed* = 82; (* isPrintable, keyCode (X11 scan code), state, keySym (ASCII) *)
EventKeyReleased* = 83; (* 0, keyCode, state, 0 *)
EventButtonPressed* = 84; (* button, x, y, state *)
EventButtonReleased* = 85; (* button, x, y, state *)
(* mouse button 1-5 = Left, Middle, Right, Scroll wheel up, Scroll wheel down *)
bit64 = ORD(unix.BIT_DEPTH = 64);
TYPE EventPars* = ARRAY 5 OF INTEGER;
XEvent = RECORD
val :ARRAY 192 OF BYTE (* union { ..., long pad[24]; } *)
(* val :ARRAY 48 OF CARD32; *)
END;
VAR ScreenWidth*, ScreenHeight* :INTEGER;
winWidth*, winHeight* :INTEGER; (* draw by writing to pixel buffer: *)
base*, stride* :INTEGER; (* width, height, base ptr, stride in bytes, 32-bit RGB *)
painting :BOOLEAN;
libX11 :INTEGER; (* handle to dynamic library *)
XOpenDisplay :PROCEDURE [linux] (name :INTEGER) :INTEGER;
XCloseDisplay :PROCEDURE [linux] (display :INTEGER);
XSynchronize :PROCEDURE [linux] (display, onoff :INTEGER) :INTEGER; (* return prev onoff *)
XConnectionNumber :PROCEDURE [linux] (display :INTEGER) :INTEGER;
XCreateWindow :PROCEDURE [linux] (display, parent_window, x, y, w, h, border_width, depth,
class, visual, valuemask, attributes :INTEGER) :INTEGER; (* Window *)
XDefaultScreen :PROCEDURE [linux] (display :INTEGER) :INTEGER;
XDefaultGC :PROCEDURE [linux] (display, screenNr :INTEGER) :INTEGER; (* GC *)
XDisplayWidth :PROCEDURE [linux] (display, screenNr :INTEGER) :INTEGER;
XDisplayHeight :PROCEDURE [linux] (display, screenNr :INTEGER) :INTEGER;
XDefaultVisual :PROCEDURE [linux] (display, screenNr :INTEGER) :INTEGER; (* visual *)
XDefaultRootWindow :PROCEDURE [linux] (display :INTEGER) :INTEGER; (* Window *)
XDefaultDepth :PROCEDURE [linux] (display, screenNr :INTEGER) :INTEGER;
XSelectInput :PROCEDURE [linux] (display, window, event_mask :INTEGER);
XMapWindow :PROCEDURE [linux] (display, window :INTEGER);
XNextEvent :PROCEDURE [linux] (display, XEvent_p :INTEGER);
XPending :PROCEDURE [linux] (display :INTEGER) :INTEGER;
XLookupString :PROCEDURE [linux] (key_event, buffer_return, buflen, keysym_return, status_in_out :INTEGER) :INTEGER;
XCreateImage :PROCEDURE [linux] (display, visual, depth, format, offset, data,
width, height, bitmap_pad, bytes_per_line :INTEGER) :INTEGER; (* ptr to XImage *)
XPutImage :PROCEDURE [linux] (display, window, gc, image, sx, sy, dx, dy, w, h :INTEGER);
display, screen, window, gc, img :INTEGER;
connectionNr :INTEGER; (* fd of X11 socket *)
readX11 :unix.fd_set; (* used by select() timeout on X11 socket *)
PROCEDURE getSymAdr (lib :INTEGER; name :ARRAY OF CHAR; adr :INTEGER);
VAR sym :INTEGER;
BEGIN
sym := unix.dlsym (lib, SYSTEM.ADR(name[0]));
IF sym = 0 THEN out.formatStr ("error: dlsym: %", name); out.nl END;
ASSERT (sym # 0);
SYSTEM.PUT (adr, sym)
END getSymAdr;
PROCEDURE init;
BEGIN
display := XOpenDisplay (0);
IF display = 0 THEN out.str ("error: can not open X11 display."); out.nl; out.exit(1) END;
(* ri := XSynchronize (display, 1); *)
connectionNr := XConnectionNumber (display); ASSERT (connectionNr < unix.FD_SETSIZE);
NEW (readX11); unix.FD_ZERO(readX11); unix.FD_SET (connectionNr, readX11);
screen := XDefaultScreen (display); gc := XDefaultGC (display, screen);
ScreenWidth := XDisplayWidth (display, screen); ScreenHeight := XDisplayHeight (display, screen);
base := unix.malloc (ScreenWidth * ScreenHeight * 4);
IF base = 0 THEN
out.formatInt2 ("error: can not allocate screen buffer % x %", ScreenWidth, ScreenHeight); out.nl; out.exit(1);
END;
stride := ScreenWidth * 4;
img := XCreateImage (display, XDefaultVisual (display, screen), XDefaultDepth (display, screen),
ZPixmap, 0, base, ScreenWidth, ScreenHeight, 32, 0);
END init;
PROCEDURE finish*;
VAR ri :INTEGER;
BEGIN
IF display # 0 THEN XCloseDisplay(display); display := 0 END;
IF libX11 # 0 THEN ri := unix.dlclose (libX11); libX11 := 0 END;
END finish;
PROCEDURE createWindow* (w, h :INTEGER);
VAR eventMask :INTEGER;
BEGIN
IF (w > ScreenWidth) OR (h > ScreenHeight) THEN
out.str ("error: X11.createWindow: window too large"); out.exit(1);
END;
ASSERT ((w >= 0) & (h >= 0));
window := XCreateWindow (display, XDefaultRootWindow (display), 0, 0, w, h, 0,
XDefaultDepth (display, screen), InputOutput, XDefaultVisual (display, screen), 0, 0);
winWidth := w; winHeight := h;
eventMask := StructureNotifyMask + ExposureMask + KeyPressMask + ButtonPressMask;
XSelectInput (display, window, eventMask);
XMapWindow (display, window);
END createWindow;
PROCEDURE screenBegin*;
(* intended to enable future cooperation with iOS / MacOS *)
BEGIN
ASSERT (~painting); painting := TRUE
END screenBegin;
PROCEDURE screenEnd*;
BEGIN
ASSERT (painting);
XPutImage (display, window, gc, img, 0, 0, 0, 0, winWidth, winHeight);
painting := FALSE;
END screenEnd;
PROCEDURE readInt (e :XEvent; i :INTEGER) :INTEGER;
(* treat XEvent byte array as int array *)
VAR n :INTEGER;
BEGIN
ASSERT (i >= 0);
ASSERT (i < 48);
i := i * 4;
n := e.val[i+3]*1000000H + e.val[i+2]*10000H + e.val[i+1]*100H + e.val[i];
RETURN n
END readInt;
PROCEDURE nextEvent* (msTimeOut :INTEGER; VAR ev :EventPars);
VAR _type, n, ri :INTEGER;
event :XEvent;
x, y, w, h :INTEGER;
timeout :unix.timespec;
BEGIN
(* struct XEvent (64-bit):
any: 4 type 8 serial 4 send_event 8 display 8 window 8 window
expose: 40 any 4 x, y, w, h, count
xconfigure: 48 any 4 x, y, w, h
xkey / xbutton / xmotion: 48 any 8 sub_window 8 time_ms 4 x, y, x_root, y_root 4 state 4 keycode/button
*)
(* struct XEvent (32-bit):
any: 4 type 4 serial 4 send_event 4 display 4 window
expose: 20 any 4 x, y, w, h, count
xconfigure: 24 any 4 x, y, w, h
xkey / xbutton / xmotion: 24 any 4 sub_window 4 time_ms 4 x, y, x_root, y_root 4 state 4 keycode/button
*)
_type := 0;
WHILE _type = 0 DO
IF (msTimeOut > 0) & (XPending(display) = 0) THEN
timeout.tv_sec := msTimeOut DIV 1000; timeout.tv_usec := (msTimeOut MOD 1000) * 1000;
ri := unix.select (connectionNr + 1, readX11, NIL, NIL, timeout); ASSERT (ri # -1);
IF ri = 0 THEN _type := EventTimeOut; ev[1] := 0; ev[2] := 0; ev[3] := 0; ev[4] := 0 END;
END;
IF _type = 0 THEN
XNextEvent (display, SYSTEM.ADR(event));
CASE readInt (event, 0) OF
Expose :
x := readInt (event, 5 + 5 * bit64); y := readInt (event, 6 + 5 * bit64);
w := readInt (event, 7 + 5 * bit64); h := readInt (event, 8 + 5 * bit64);
XPutImage (display, window, gc, img, x, y, x, y, w, h);
| ConfigureNotify :
w := readInt (event, 8 + 6 * bit64); h := readInt (event, 9 + 6 * bit64);
IF (w # winWidth) & (h # winHeight) THEN
ASSERT ((w >= 0) & (h >= 0));
IF w > ScreenWidth THEN w := ScreenWidth END;
IF h > ScreenHeight THEN h := ScreenHeight END;
winWidth := w; winHeight := h;
ev[0] := EventResize; ev[1] := 0; ev[2] := w; ev[3] := h; ev[4] := 0;
END;
| KeyPress :
_type := EventKeyPressed;
x := XLookupString (SYSTEM.ADR(event), 0, 0, SYSTEM.ADR(n), 0); (* KeySym *)
IF (n = 8) OR (n = 10) OR (n >= 32) & (n <= 126) THEN ev[1] := 1 ELSE ev[1] := 0; n := 0 END; (* isprint *)
ev[2] := readInt (event, 13 + 8 * bit64); (* keycode *)
ev[3] := readInt (event, 12 + 8 * bit64); (* state *)
ev[4] := n; (* KeySym *)
| ButtonPress :
_type := EventButtonPressed;
ev[1] := readInt (event, 13 + 8 * bit64); (* button *)
ev[2] := readInt (event, 8 + 8 * bit64); (* x *)
ev[3] := readInt (event, 9 + 8 * bit64); (* y *)
ev[4] := readInt (event, 12 + 8 * bit64); (* state *)
ELSE
END
END
END;
ev[0] := _type
END nextEvent;
PROCEDURE clear* (color :INTEGER); (* fill window area with color *)
VAR p, i, j :INTEGER;
BEGIN
FOR j := 0 TO winHeight-1 DO
p := base + j*stride;
FOR i := 0 TO winWidth-1 DO SYSTEM.PUT32 (p, color); INC (p, 4) END
END
END clear;
(*
PROCEDURE blitError (stride, x, y, w, h :INTEGER);
BEGIN
o.formatInt ("error: screen.blit (src, %)", stride);
o.formatInt2 (", %, %", x, y);
o.formatInt2 (", %, %) out of bounds", w, h); o.nl;
ASSERT (FALSE)
END blitError;
PROCEDURE blit* (src, srcStride, x, y, w, h :INTEGER);
VAR dstStride, p :INTEGER;
BEGIN
IF (x < 0) OR (y < 0) THEN blitError (srcStride, x, y, w, h) END;
IF (w <= 0) OR (h <= 0) THEN blitError (srcStride, x, y, w, h) END;
IF (x + w > ScreenWidth) OR (y + h > ScreenHeight) THEN blitError (srcStride, x, y, w, h) END;
dstStride := ScreenWidth - w;
p := ScreenBase + y * ScreenWidth + x * 4;
REPEAT
SYSTEM.COPY (src, p, w);
INC (src, srcStride); INC (p, dstStride); DEC (h)
UNTIL h = 0
END blit;
*)
(*
PROCEDURE setPixel* (x, y, color :INTEGER);
VAR p :INTEGER;
BEGIN
ASSERT ((x >= 0) & (x < ScreenWidth) & (y >= 0) & (y < ScreenHeight));
screenBegin; p := base + (y*ScreenWidth + x)*4; SYSTEM.PUT32 (p, color); p := p + 4 screenEnd
END setPixel;
*)
(*
PROCEDURE loop; (* example main loop *)
VAR e :EventPars;
stop :BOOLEAN;
BEGIN
createWindow (200, 200);
stop := FALSE;
REPEAT
nextEvent (0, e);
IF e[0] = EventKeyPressed THEN stop := TRUE END;
UNTIL stop;
XCloseDisplay (display);
END loop;
*)
BEGIN
libX11 := unix.dlopen (SYSTEM.SADR("libX11.so.6"), unix.RTLD_LAZY); ASSERT (libX11 # 0);
getSymAdr (libX11, "XOpenDisplay", SYSTEM.ADR(XOpenDisplay));
getSymAdr (libX11, "XCloseDisplay", SYSTEM.ADR(XCloseDisplay));
getSymAdr (libX11, "XSynchronize", SYSTEM.ADR(XSynchronize));
getSymAdr (libX11, "XConnectionNumber", SYSTEM.ADR(XConnectionNumber));
getSymAdr (libX11, "XCreateWindow", SYSTEM.ADR(XCreateWindow));
getSymAdr (libX11, "XDefaultScreen", SYSTEM.ADR(XDefaultScreen));
getSymAdr (libX11, "XDefaultGC", SYSTEM.ADR(XDefaultGC));
getSymAdr (libX11, "XDisplayWidth", SYSTEM.ADR(XDisplayWidth));
getSymAdr (libX11, "XDisplayHeight", SYSTEM.ADR(XDisplayHeight));
getSymAdr (libX11, "XDefaultVisual", SYSTEM.ADR(XDefaultVisual));
getSymAdr (libX11, "XDefaultRootWindow", SYSTEM.ADR(XDefaultRootWindow));
getSymAdr (libX11, "XDefaultDepth", SYSTEM.ADR(XDefaultDepth));
getSymAdr (libX11, "XSelectInput", SYSTEM.ADR(XSelectInput));
getSymAdr (libX11, "XMapWindow", SYSTEM.ADR(XMapWindow));
getSymAdr (libX11, "XNextEvent", SYSTEM.ADR(XNextEvent));
getSymAdr (libX11, "XPending", SYSTEM.ADR(XPending));
getSymAdr (libX11, "XLookupString", SYSTEM.ADR(XLookupString));
getSymAdr (libX11, "XCreateImage", SYSTEM.ADR(XCreateImage));
getSymAdr (libX11, "XPutImage", SYSTEM.ADR(XPutImage));
init;
END gr.

142
programs/develop/oberon07/Samples/Linux/X11/filler/out.ob07 Normal file
View File

@ -0,0 +1,142 @@
MODULE out; (* formatted output to stdout *)
(* Wim Niemann, Jan Tuitman 06-OCT-2016 *)
IMPORT SYSTEM, _unix;
(* example: IMPORT o:=out;
o.str("Hello, World!");o.nl;
o.formatInt("n = %", 3);o.nl;
*)
(*
The output functions buffer the characters in buf. This buffer is flushed when out.nl is
called and also when the buffer is full.
Calling flush once per line is far more efficient then one system call per
character, but this is noticable only at very long outputs.
*)
CONST MAX = 63; (* last position in buf *)
VAR len :INTEGER; (* string length in buf *)
buf :ARRAY MAX+1 OF BYTE;
PROCEDURE exit* (n :INTEGER);
(* prevent IMPORT unix for many programs *)
BEGIN _unix._exit(n) END exit;
PROCEDURE writeChars;
(* write buf to the output function and set to empty string *)
VAR ri :INTEGER;
BEGIN
IF len > 0 THEN
(* buf[len] := 0X; *)
ri := _unix._write (1, SYSTEM.ADR(buf), len); ASSERT (ri = len); (* stdout *)
len := 0
END
END writeChars;
PROCEDURE nl*; (* append a newline to buf and flush *)
BEGIN
IF len = MAX THEN writeChars END;
buf[len] := 0AH; INC(len);
(* unix: 0AX; Oberon: 0DX;
Windows: IF len >= MAX-1 THEN 0DX 0AX; *)
writeChars;
END nl;
PROCEDURE char* (c :CHAR);
(* append char to the end of buf *)
BEGIN
IF len = MAX THEN writeChars END;
buf[len] := ORD(c); INC(len)
END char;
PROCEDURE str* (t :ARRAY OF CHAR);
(* append t to buf *)
VAR j :INTEGER;
BEGIN
j := 0; WHILE t[j] # 0X DO char(t[j]); INC(j) END
END str;
PROCEDURE int* (n :INTEGER);
(* append integer; append n to d, return TRUE on overflow of d *)
VAR j :INTEGER;
sign :BOOLEAN;
dig :ARRAY 11 OF CHAR; (* assume 32 bit INTEGER *)
BEGIN
sign := FALSE; IF n < 0 THEN sign := TRUE; n := -n END;
IF n < 0 THEN
str ("-2147483648");
ELSE
j := 0;
REPEAT dig[j] := CHR (n MOD 10 + 30H); n := n DIV 10; INC(j) UNTIL n = 0;
IF sign THEN char ("-") END;
REPEAT DEC(j); char(dig[j]) UNTIL j = 0;
END
END int;
PROCEDURE formatInt* (t :ARRAY OF CHAR; n :INTEGER);
(* append formatted string t. Replace the first % by n *)
VAR j :INTEGER;
BEGIN
j := 0; WHILE (t[j] # 0X) & (t[j] # "%") DO char(t[j]); INC(j) END;
IF t[j] = "%" THEN
int(n); INC(j);
WHILE t[j] # 0X DO char(t[j]); INC(j) END
END
END formatInt;
PROCEDURE formatInt2* (t:ARRAY OF CHAR; n1, n2 :INTEGER);
(* append formatted string t. Replace the first two % by n1 and n2 *)
VAR j :INTEGER;
BEGIN
j := 0; WHILE (t[j] # 0X) & (t[j] # "%") DO char(t[j]); INC(j) END;
IF t[j] = "%" THEN
int(n1); INC(j);
WHILE (t[j] # 0X) & (t[j] # "%") DO char(t[j]); INC(j) END;
IF t[j] = "%" THEN
int(n2); INC(j);
WHILE t[j] # 0X DO char(t[j]); INC(j) END
END
END
END formatInt2;
PROCEDURE formatStr* (t, u :ARRAY OF CHAR);
(* append formatted string. Replace the first % in t by u *)
VAR j, k :INTEGER;
BEGIN
j := 0; WHILE (t[j] # 0X) & (t[j] # "%") DO char(t[j]); INC(j) END;
IF t[j] = "%" THEN
k := 0; WHILE u[k] # 0X DO char(u[k]); INC(k) END;
INC(j); WHILE t[j] # 0X DO char(t[j]); INC(j) END
END
END formatStr;
PROCEDURE hex* (n, width :INTEGER);
(* print width positions of n as hex string. If necessary, prefix with leading zeroes *)
(* note: if n needs more positions than width, the first hex digits are not printed *)
VAR j :INTEGER;
dig :ARRAY 9 OF CHAR;
BEGIN
ASSERT(width > 0);
ASSERT (width <= 8);
dig[width] := 0X;
REPEAT
j := n MOD 16; n := n DIV 16;
IF j < 10 THEN j := ORD("0") + j ELSE j := ORD("A") + j - 10 END;
DEC(width); dig[width] := CHR(j)
UNTIL width = 0;
str (dig);
END hex;
PROCEDURE flush*;
(* this routine comes at the end. It won't hardly ever be called
because nl also flushes. It is present only in case you
want to write a flushed string which does not end with nl. *)
BEGIN writeChars END flush;
(* note: global variable 'len' must be 0 on init. Within the core, bodies of imported modules
are not executed, so rely on zero initialisation by Modules.Load *)
END out.

74
programs/develop/oberon07/Samples/Linux/X11/filler/unix.ob07 Normal file
View File

@ -0,0 +1,74 @@
MODULE unix; (* connect to unix host *)
IMPORT SYSTEM, _unix;
(* provide some Oberon friendly POSIX without need for SYSTEM *)
CONST RTLD_LAZY* = 1;
O_RDONLY* = 0;
O_NEWFILE* = 0C2H; (* O_RDWR | O_CREAT | O_EXCL *)
(* O_RDONLY=0, O_WRONLY=1, O_RDWR=2, O_CREAT=0x40, O_EXCL=0x80, O_TRUNC=0x200 *)
FD_SETSIZE* = 1024; (* fd for select() must be smaller than FD_SETSIZE *)
BIT_DEPTH* = _unix.BIT_DEPTH;
LEN_FD_SET = FD_SETSIZE DIV BIT_DEPTH;
TYPE
timespec* = RECORD
tv_sec*, tv_usec* :INTEGER
END;
fd_set* = POINTER TO RECORD (* for select() *)
bits* :ARRAY LEN_FD_SET OF SET (* 1024 bits *)
END;
VAR
dlopen* :PROCEDURE [linux] (name, flags :INTEGER) :INTEGER;
dlsym* :PROCEDURE [linux] (p, name :INTEGER) :INTEGER;
dlclose* :PROCEDURE [linux] (p :INTEGER) :INTEGER;
close* :PROCEDURE [linux] (fd :INTEGER) :INTEGER;
exit* :PROCEDURE [linux] (n :INTEGER);
malloc* :PROCEDURE [linux] (sz :INTEGER) :INTEGER;
PROCEDURE open* (path :ARRAY OF CHAR; flag, perm :INTEGER) :INTEGER;
BEGIN RETURN _unix._open (SYSTEM.ADR(path[0]), flag, perm) END open;
PROCEDURE read* (fd :INTEGER; VAR buf :ARRAY OF BYTE; len :INTEGER) :INTEGER;
BEGIN RETURN _unix._read (fd, SYSTEM.ADR(buf[0]), len) END read;
PROCEDURE readByte* (fd :INTEGER; VAR n :BYTE) :INTEGER;
BEGIN RETURN _unix._read (fd, SYSTEM.ADR(n), 1) END readByte;
PROCEDURE write* (fd :INTEGER; buf :ARRAY OF BYTE; len :INTEGER) :INTEGER;
BEGIN RETURN _unix._write (fd, SYSTEM.ADR(buf[0]), len) END write;
PROCEDURE writeByte* (fd :INTEGER; n :BYTE) :INTEGER;
BEGIN RETURN _unix._write (fd, SYSTEM.ADR(n), 1) END writeByte;
PROCEDURE FD_ZERO* (VAR selectSet :fd_set);
VAR i :INTEGER;
BEGIN FOR i := 0 TO LEN_FD_SET-1 DO selectSet.bits[i] := {} END END FD_ZERO;
PROCEDURE FD_SET* (fd :INTEGER; VAR selectSet :fd_set); (* set fd bit in a select() fd_set *)
BEGIN INCL(selectSet.bits[fd DIV BIT_DEPTH], fd MOD BIT_DEPTH)
END FD_SET;
PROCEDURE select* (cnt :INTEGER; readfds, writefds, exceptfds :fd_set; timeout :timespec) :INTEGER;
VAR n1, n2, n3 :INTEGER;
BEGIN
n1 := 0; IF readfds # NIL THEN n1 := SYSTEM.ADR (readfds.bits[0]) END;
n2 := 0; IF writefds # NIL THEN n2 := SYSTEM.ADR (writefds.bits[0]) END;
n3 := 0; IF exceptfds # NIL THEN n3 := SYSTEM.ADR (exceptfds.bits[0]) END;
RETURN _unix._select (cnt, n1, n2, n3, SYSTEM.ADR(timeout))
END select;
PROCEDURE finish*;
BEGIN _unix.finish; END finish;
BEGIN
dlopen := _unix._dlopen;
dlsym := _unix._dlsym;
dlclose := _unix._dlclose;
close := _unix._close;
exit := _unix._exit;
malloc := _unix._malloc;
END unix.

43
programs/develop/oberon07/Samples/MSP430/Blink.ob07 Normal file
View File

@ -0,0 +1,43 @@
(*
Пример для LaunchPad MSP-EXP430G2 Rev1.5
Мигает красный светодиод.
*)
MODULE Blink;
IMPORT SYSTEM, MSP430;
CONST
REDLED = {0};
(* регистры порта P1 *)
P1OUT = 21H;
P1DIR = 22H;
PROCEDURE inv_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) / bits)
END inv_bits;
BEGIN
(* инициализация регистра P1DIR *)
SYSTEM.PUT8(P1DIR, REDLED);
(* бесконечный цикл *)
WHILE TRUE DO
(* изменить состояние светодиода *)
inv_bits(P1OUT, REDLED);
(* задержка *)
MSP430.Delay(800)
END
END Blink.

103
programs/develop/oberon07/Samples/MSP430/Button.ob07 Normal file
View File

@ -0,0 +1,103 @@
(*
Пример для LaunchPad MSP-EXP430G2 Rev1.5
Мигает зеленый светодиод.
При нажатии на кнопку P1.3, включается/выключается красный светодиод.
*)
MODULE Button;
IMPORT SYSTEM, MSP430;
CONST
REDLED = {0};
GREENLED = {6};
BUTTON = {3};
(* регистры порта P1 *)
P1OUT = 21H;
P1DIR = 22H;
P1IFG = 23H;
P1IE = 25H;
P1REN = 27H;
PROCEDURE test_bits (mem: INTEGER; bits: SET): SET;
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b)
RETURN bits * BITS(b)
END test_bits;
PROCEDURE set_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) + bits)
END set_bits;
PROCEDURE clr_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) - bits)
END clr_bits;
PROCEDURE inv_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) / bits)
END inv_bits;
(* обработчик прерываний *)
PROCEDURE int (priority: INTEGER; interrupt: MSP430.TInterrupt);
BEGIN
IF priority = 18 THEN (* прерывание от порта P1 *)
IF test_bits(P1IFG, BUTTON) = BUTTON THEN (* нажата кнопка *)
inv_bits(P1OUT, REDLED); (* изменить состояние светодиода *)
MSP430.Delay(500); (* задержка для отпускания кнопки *)
clr_bits(P1IFG, BUTTON) (* сбросить флаг прерывания *)
END
END
END int;
PROCEDURE main;
BEGIN
(* инициализация регистров порта P1 *)
SYSTEM.PUT8(P1DIR, REDLED + GREENLED); (* выход *)
set_bits(P1REN, BUTTON); (* включить подтягивающий резистор *)
set_bits(P1OUT, BUTTON); (* подтяжка к питанию *)
set_bits(P1IE, BUTTON); (* разрешить прерывания от кнопки *)
MSP430.SetIntProc(int); (* назначить обработчик прерываний *)
MSP430.EInt; (* разрешить прерывания *)
(* бесконечный цикл *)
WHILE TRUE DO
inv_bits(P1OUT, GREENLED); (* изменить состояние светодиода *)
MSP430.Delay(800) (* задержка *)
END
END main;
BEGIN
main
END Button.

157
programs/develop/oberon07/Samples/MSP430/Flash.ob07 Normal file
View File

@ -0,0 +1,157 @@
(*
Пример для LaunchPad MSP-EXP430G2 Rev1.5
Запись флэш-памяти.
При успешном завершении, включается зеленый светодиод,
иначе - красный.
*)
MODULE Flash;
IMPORT SYSTEM, MSP430;
CONST
REDLED = {0};
GREENLED = {6};
(* регистры порта P1 *)
P1OUT = 21H;
P1DIR = 22H;
FERASE = {1}; (* режим "стереть" *)
FWRITE = {6}; (* режим "записать" *)
PROCEDURE set_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) + bits)
END set_bits;
PROCEDURE clr_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) - bits)
END clr_bits;
(*
стирание и запись флэш-памяти
adr - адрес
value - значение для записи
mode - режим (стереть/записать)
*)
PROCEDURE Write (adr, value: INTEGER; mode: SET);
CONST
(* сторожевой таймер *)
WDTCTL = 0120H;
WDTHOLD = {7};
WDTPW = {9, 11, 12, 14};
(* регистры контроллера флэш-памяти *)
FCTL1 = 0128H;
ERASE = {1};
WRT = {6};
FCTL2 = 012AH;
FN0 = {0};
FN1 = {1};
FN2 = {2};
FN3 = {3};
FN4 = {4};
FN5 = {5};
FSSEL0 = {6};
FSSEL1 = {7};
FCTL3 = 012CH;
LOCK = {4};
FWKEY = {8, 10, 13, 15};
VAR
wdt: SET;
BEGIN
IF (mode = ERASE) OR (mode = WRT) THEN (* проверить заданный режим *)
SYSTEM.GET(WDTCTL, wdt); (* сохранить значение регистра сторожевого таймера *)
SYSTEM.PUT(WDTCTL, WDTPW + WDTHOLD); (* остановить сторожевой таймер *)
SYSTEM.PUT(FCTL2, FWKEY + FSSEL1 + FN0); (* тактовый генератор контроллера флэш-памяти = SMCLK, делитель = 2 *)
SYSTEM.PUT(FCTL3, FWKEY); (* сбросить флаг LOCK *)
SYSTEM.PUT(FCTL1, FWKEY + mode); (* установить режим (записать или стереть) *)
SYSTEM.PUT(adr, value); (* запись *)
SYSTEM.PUT(FCTL1, FWKEY); (* сбросить режим *)
SYSTEM.PUT(FCTL3, FWKEY + LOCK); (* установить LOCK *)
SYSTEM.PUT(WDTCTL, WDTPW + wdt * {0..7}) (* восстановить сторожевой таймер *)
END
END Write;
(* обработчик ошибок *)
PROCEDURE trap (modNum, modName, err, line: INTEGER);
BEGIN
set_bits(P1OUT, REDLED) (* включить красный светодиод *)
END trap;
PROCEDURE main;
CONST
seg_adr = 0FC00H; (* адрес сегмента для стирания и записи (ДОЛЖЕН БЫТЬ СВОБОДНЫМ!) *)
VAR
adr, x, i: INTEGER;
free: RECORD address, size: INTEGER END;
BEGIN
(* инициализация регистров порта P1 *)
SYSTEM.PUT8(P1DIR, REDLED + GREENLED); (* выход *)
(* выключить светодиоды *)
clr_bits(P1OUT, REDLED + GREENLED);
MSP430.SetTrapProc(trap); (* назначить обработчик ошибок *)
ASSERT(seg_adr MOD 512 = 0); (* адрес сегмента должен быть кратным 512 *)
MSP430.GetFreeFlash(free.address, free.size);
(* проверить, свободен ли сегмент *)
ASSERT(free.address <= seg_adr);
ASSERT(seg_adr + 511 <= free.address + free.size);
Write(seg_adr, 0, FERASE); (* стереть сегмент *)
(* записать в сегмент числа 0..255 (256 слов) *)
adr := seg_adr;
FOR i := 0 TO 255 DO
Write(adr, i, FWRITE);
INC(adr, 2)
END;
(* проверить запись *)
adr := seg_adr;
FOR i := 0 TO 255 DO
SYSTEM.GET(adr, x);
ASSERT(x = i); (* если x # i, будет вызван обработчик ошибок *)
INC(adr, 2)
END;
(* если нет ошибок, включить зеленый светодиод *)
set_bits(P1OUT, GREENLED)
END main;
BEGIN
main
END Flash.

106
programs/develop/oberon07/Samples/MSP430/Restart.ob07 Normal file
View File

@ -0,0 +1,106 @@
(*
Пример для LaunchPad MSP-EXP430G2 Rev1.5
При нажатии на кнопку P1.3, инкрементируется
переменная-счетчик перезапусков и программа
перезапускается.
В зависимости от четности счетчика перезапусков,
включается зеленый или красный светодиод.
*)
MODULE Restart;
IMPORT SYSTEM, MSP430;
CONST
REDLED = {0};
GREENLED = {6};
BUTTON = {3};
(* регистры порта P1 *)
P1OUT = 21H;
P1DIR = 22H;
P1IFG = 23H;
P1IE = 25H;
P1REN = 27H;
VAR
count: INTEGER; (* счетчик перезапусков *)
PROCEDURE set_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) + bits)
END set_bits;
PROCEDURE clr_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) - bits)
END clr_bits;
PROCEDURE test_bits (mem: INTEGER; bits: SET): SET;
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b)
RETURN bits * BITS(b)
END test_bits;
(* обработчик прерываний *)
PROCEDURE int (priority: INTEGER; interrupt: MSP430.TInterrupt);
BEGIN
IF priority = 18 THEN (* прерывание от порта P1 *)
IF test_bits(P1IFG, BUTTON) = BUTTON THEN (* нажата кнопка *)
INC(count); (* увеличить счетчик *)
MSP430.Delay(500); (* задержка для отпускания кнопки *)
clr_bits(P1IFG, BUTTON); (* сбросить флаг прерывания *)
MSP430.Restart (* перезапустить программу *)
END
END
END int;
PROCEDURE main;
BEGIN
(* инициализация регистров порта P1 *)
SYSTEM.PUT8(P1DIR, REDLED + GREENLED); (* выход *)
set_bits(P1REN, BUTTON); (* включить подтягивающий резистор *)
set_bits(P1OUT, BUTTON); (* подтяжка к питанию *)
set_bits(P1IE, BUTTON); (* разрешить прерывания от кнопки *)
(* выключить светодиоды *)
clr_bits(P1OUT, REDLED + GREENLED);
MSP430.SetIntProc(int); (* назначить обработчик прерываний *)
MSP430.EInt; (* разрешить прерывания *)
IF ODD(count) THEN
set_bits(P1OUT, GREENLED) (* нечетное - вкл. зеленый *)
ELSE
set_bits(P1OUT, REDLED) (* четное - вкл. красный *)
END
END main;
BEGIN
main
END Restart.

118
programs/develop/oberon07/Samples/MSP430/TimerA.ob07 Normal file
View File

@ -0,0 +1,118 @@
(*
Пример для LaunchPad MSP-EXP430G2 Rev1.5
Светодиоды мигают по сигналам от таймера A
*)
MODULE TimerA;
IMPORT SYSTEM, MSP430;
CONST
REDLED = {0};
GREENLED = {6};
(* регистры порта P1 *)
P1OUT = 21H;
P1DIR = 22H;
(* регистры таймера A *)
TACTL = 0160H;
(* биты регистра TACTL *)
TAIFG = {0};
TAIE = {1};
TACLR = {2};
MC0 = {4};
MC1 = {5};
ID0 = {6};
ID1 = {7};
TASSEL0 = {8};
TASSEL1 = {9};
TAR = 0170H;
TACCTL0 = 0162H;
(* биты регистра TACCTL0 *)
CCIE = {4};
CAP = {8};
TACCR0 = 0172H;
PROCEDURE set_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) + bits)
END set_bits;
PROCEDURE clr_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) - bits)
END clr_bits;
PROCEDURE inv_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) / bits)
END inv_bits;
(* обработчик прерываний *)
PROCEDURE int (priority: INTEGER; interrupt: MSP430.TInterrupt);
VAR
x: SET;
BEGIN
IF priority = 24 THEN (* прерывание от таймера A *)
SYSTEM.GET(TACTL, x); (* взять регистр TACTL *)
IF TAIFG * x = TAIFG THEN (* прерывание было *)
inv_bits(P1OUT, REDLED); (* изменить состояние светодиода *)
inv_bits(P1OUT, GREENLED); (* изменить состояние светодиода *)
SYSTEM.PUT(TACTL, x - TAIFG) (* сбросить флаг прерывания и обновить регистр TACTL *)
END
END
END int;
PROCEDURE main;
BEGIN
(* инициализация регистра P1DIR *)
SYSTEM.PUT8(P1DIR, REDLED + GREENLED);
(* начальное состояние светодиодов *)
set_bits(P1OUT, GREENLED); (* включен *)
clr_bits(P1OUT, REDLED); (* выключен *)
MSP430.SetIntProc(int); (* назначить обработчик прерываний *)
MSP430.EInt; (* разрешить прерывания *)
(* инициализация регистров таймера A *)
SYSTEM.PUT(TAR, 0);
SYSTEM.PUT(TACCTL0, CCIE + CAP);
SYSTEM.PUT(TACCR0, 1000);
SYSTEM.PUT(TACTL, TAIE + MC0 + TASSEL0)
END main;
BEGIN
main
END TimerA.

143
programs/develop/oberon07/Samples/MSP430/TwoTimers.ob07 Normal file
View File

@ -0,0 +1,143 @@
(*
Пример для LaunchPad MSP-EXP430G2 Rev1.5
Зеленый светодиод мигает по сигналам от таймера A,
красный - по сигналам от сторожевого таймера в интервальном режиме
*)
MODULE TwoTimers;
IMPORT SYSTEM, MSP430;
CONST
REDLED = {0};
GREENLED = {6};
(* регистры порта P1 *)
P1OUT = 21H;
P1DIR = 22H;
(* регистр разрешения прерываний 1 *)
IE1 = 00H;
(* биты регистра IE1 *)
WDTIE = {0};
NMIIE = {4};
(* регистр флагов прерываний 1 *)
IFG1 = 02H;
(* биты регистра IFG1 *)
WDTIFG = {0};
NMIIFG = {4};
WDTCTL = 0120H; (* регистр сторожевого таймера *)
(* биты регистра WDTCTL *)
WDTIS0 = {0};
WDTIS1 = {1};
WDTSSEL = {2};
WDTCNTCL = {3};
WDTTMSEL = {4};
WDTNMI = {5};
WDTNMIES = {6};
WDTHOLD = {7};
WDTPW = {9, 11, 12, 14}; (* ключ защиты *)
(* регистры таймера A *)
TACTL = 0160H;
(* биты регистра TACTL *)
TAIFG = {0};
TAIE = {1};
TACLR = {2};
MC0 = {4};
MC1 = {5};
ID0 = {6};
ID1 = {7};
TASSEL0 = {8};
TASSEL1 = {9};
TAR = 0170H;
TACCTL0 = 0162H;
(* биты регистра TACCTL0 *)
CCIE = {4};
CAP = {8};
TACCR0 = 0172H;
PROCEDURE set_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) + bits)
END set_bits;
PROCEDURE inv_bits (mem: INTEGER; bits: SET);
VAR
b: BYTE;
BEGIN
SYSTEM.GET(mem, b);
SYSTEM.PUT8(mem, BITS(b) / bits)
END inv_bits;
(* обработчик прерываний *)
PROCEDURE int (priority: INTEGER; interrupt: MSP430.TInterrupt);
VAR
x: SET;
BEGIN
IF priority = 26 THEN (* прерывание от сторожевого таймера *)
inv_bits(P1OUT, REDLED) (* изменить состояние светодиода *)
ELSIF priority = 24 THEN (* прерывание от таймера A *)
SYSTEM.GET(TACTL, x); (* взять регистр TACTL *)
IF TAIFG * x = TAIFG THEN (* прерывание было *)
inv_bits(P1OUT, GREENLED); (* изменить состояние светодиода *)
SYSTEM.PUT(TACTL, x - TAIFG) (* сбросить флаг прерывания и обновить регистр TACTL *)
END
END
END int;
PROCEDURE main;
BEGIN
(* инициализация регистра P1DIR *)
set_bits(P1DIR, REDLED + GREENLED);
(* начальное состояние светодиодов - включены *)
set_bits(P1OUT, REDLED + GREENLED);
MSP430.SetIntProc(int); (* назначить обработчик прерываний *)
MSP430.EInt; (* разрешить прерывания *)
(* инициализация регистров таймера A *)
SYSTEM.PUT(TAR, 0);
SYSTEM.PUT(TACCTL0, CCIE + CAP);
SYSTEM.PUT(TACCR0, 1500);
SYSTEM.PUT(TACTL, TAIE + MC0 + TASSEL0);
(* инициализация регистров сторожевого таймера *)
set_bits(IE1, WDTIE);
SYSTEM.PUT(WDTCTL, WDTPW + WDTIS1 + WDTSSEL + WDTCNTCL + WDTTMSEL)
END main;
BEGIN
main
END TwoTimers.

57
programs/develop/oberon07/Samples/STM32CM3/Blink.ob07 Normal file
View File

@ -0,0 +1,57 @@
(*
Пример для STM32L152C-DISCO
В зависимости от значения константы LED,
мигает синий или зеленый светодиод.
*)
MODULE Blink;
IMPORT SYSTEM;
CONST
GPIOB = 40020400H;
GPIOB_MODER = GPIOB;
GPIOB_BSRR = GPIOB + 18H;
RCC = 40023800H;
RCC_AHBENR = RCC + 1CH;
Blue = 6; (* PB6 *)
Green = 7; (* PB7 *)
LED = Blue;
VAR
x: SET;
state: BOOLEAN;
PROCEDURE Delay (x: INTEGER);
BEGIN
REPEAT
DEC(x)
UNTIL x = 0
END Delay;
BEGIN
(* подключить GPIOB *)
SYSTEM.GET(RCC_AHBENR, x);
SYSTEM.PUT(RCC_AHBENR, x + {1});
(* настроить PB6 или PB7 на выход *)
SYSTEM.GET(GPIOB_MODER, x);
SYSTEM.PUT(GPIOB_MODER, x - {LED * 2 - 1} + {LED * 2});
state := FALSE;
REPEAT
(* включить или выключить светодиод *)
SYSTEM.PUT(GPIOB_BSRR, {LED + 16 * ORD(state)});
state := ~state;
Delay(200000)
UNTIL FALSE
END Blink.

114
programs/develop/oberon07/Samples/STM32CM3/Button.ob07 Normal file
View File

@ -0,0 +1,114 @@
(*
Пример для STM32L152C-DISCO
При нажатии на кнопку USER (PA0), меняется
состояние светодиодов.
*)
MODULE Button;
IMPORT SYSTEM;
CONST
GPIOA = 40020000H;
GPIOAMODER = GPIOA;
GPIOAOTYPER = GPIOA + 04H;
GPIOAOSPEEDR = GPIOA + 08H;
GPIOAPUPDR = GPIOA + 0CH;
GPIOAIDR = GPIOA + 10H;
GPIOAODR = GPIOA + 14H;
GPIOABSRR = GPIOA + 18H;
GPIOALCKR = GPIOA + 1CH;
GPIOAAFRL = GPIOA + 20H;
GPIOAAFRH = GPIOA + 24H;
GPIOABRR = GPIOA + 28H;
GPIOB = 40020400H;
GPIOBMODER = GPIOB;
GPIOBOTYPER = GPIOB + 04H;
GPIOBOSPEEDR = GPIOB + 08H;
GPIOBPUPDR = GPIOB + 0CH;
GPIOBIDR = GPIOB + 10H;
GPIOBODR = GPIOB + 14H;
GPIOBBSRR = GPIOB + 18H;
GPIOBLCKR = GPIOB + 1CH;
GPIOBAFRL = GPIOB + 20H;
GPIOBAFRH = GPIOB + 24H;
GPIOBBRR = GPIOB + 28H;
RCC = 40023800H;
RCC_CR = RCC;
RCC_AHBENR = RCC + 1CH;
RCC_APB2ENR = RCC + 20H;
RCC_APB1ENR = RCC + 24H;
NVIC = 0E000E100H;
NVIC_ISER0 = NVIC;
NVIC_ISER1 = NVIC + 04H;
NVIC_ISER2 = NVIC + 08H;
NVIC_ICER0 = NVIC + 80H;
NVIC_ICER1 = NVIC + 84H;
NVIC_ICER2 = NVIC + 88H;
EXTI = 040010400H;
EXTI_IMR = EXTI;
EXTI_RTSR = EXTI + 08H;
EXTI_FTSR = EXTI + 0CH;
EXTI_PR = EXTI + 14H;
LINE0 = {0};
Blue = 6;
Green = 7;
VAR
x: SET;
state: INTEGER;
(* обработчик прерываний от EXTI0 *)
PROCEDURE PushButton [22];
BEGIN
SYSTEM.PUT(EXTI_PR, LINE0); (* сбросить флаг прерывания *)
state := (state + 1) MOD 4;
(* изменить состояние светодиодов *)
CASE state OF
|0: SYSTEM.PUT(GPIOBBSRR, {Blue + 16, Green + 16})
|1: SYSTEM.PUT(GPIOBBSRR, {Blue, Green + 16})
|2: SYSTEM.PUT(GPIOBBSRR, {Blue + 16, Green})
|3: SYSTEM.PUT(GPIOBBSRR, {Blue, Green})
END
END PushButton;
BEGIN
state := 0;
(* подключить GPIOA и GPIOB *)
SYSTEM.GET(RCC_AHBENR, x);
SYSTEM.PUT(RCC_AHBENR, x + {0, 1});
(* настроить PB6 и PB7 на выход *)
SYSTEM.GET(GPIOBMODER, x);
SYSTEM.PUT(GPIOBMODER, x + {12, 14} - {13, 15});
(* настроить PA0 на вход *)
SYSTEM.GET(GPIOAMODER, x);
SYSTEM.PUT(GPIOAMODER, x - {0, 1});
(* разрешить прерывания от EXTI0 (позиция 6) *)
SYSTEM.PUT(NVIC_ISER0, {6});
(* разрешить прерывания от LINE0 по нарастающему краю импульса *)
SYSTEM.PUT(EXTI_IMR, LINE0);
SYSTEM.PUT(EXTI_RTSR, LINE0);
END Button.

366
programs/develop/oberon07/Samples/STM32CM3/LCD.ob07 Normal file
View File

@ -0,0 +1,366 @@
(*
Пример для STM32L152C-DISCO
Работа со встроенным ЖКИ.
использовано:
https://habr.com/ru/post/173709/
*)
MODULE LCD;
IMPORT SYSTEM;
CONST
GPIOA = 40020000H;
GPIOAMODER = GPIOA;
GPIOAOTYPER = GPIOA + 04H;
GPIOAOSPEEDR = GPIOA + 08H;
GPIOAPUPDR = GPIOA + 0CH;
GPIOAIDR = GPIOA + 10H;
GPIOAODR = GPIOA + 14H;
GPIOABSRR = GPIOA + 18H;
GPIOALCKR = GPIOA + 1CH;
GPIOAAFRL = GPIOA + 20H;
GPIOAAFRH = GPIOA + 24H;
GPIOABRR = GPIOA + 28H;
GPIOB = 40020400H;
GPIOBMODER = GPIOB;
GPIOBOTYPER = GPIOB + 04H;
GPIOBOSPEEDR = GPIOB + 08H;
GPIOBPUPDR = GPIOB + 0CH;
GPIOBIDR = GPIOB + 10H;
GPIOBODR = GPIOB + 14H;
GPIOBBSRR = GPIOB + 18H;
GPIOBLCKR = GPIOB + 1CH;
GPIOBAFRL = GPIOB + 20H;
GPIOBAFRH = GPIOB + 24H;
GPIOBBRR = GPIOB + 28H;
GPIOC = 40020800H;
GPIOCMODER = GPIOC;
GPIOCOTYPER = GPIOC + 04H;
GPIOCOSPEEDR = GPIOC + 08H;
GPIOCPUPDR = GPIOC + 0CH;
GPIOCIDR = GPIOC + 10H;
GPIOCODR = GPIOC + 14H;
GPIOCBSRR = GPIOC + 18H;
GPIOCLCKR = GPIOC + 1CH;
GPIOCAFRL = GPIOC + 20H;
GPIOCAFRH = GPIOC + 24H;
GPIOCBRR = GPIOC + 28H;
RCC = 40023800H;
RCC_CR = RCC;
RCC_AHBENR = RCC + 1CH;
RCC_APB2ENR = RCC + 20H;
RCC_APB1ENR = RCC + 24H;
RCC_CSR = RCC + 34H;
PWR = 40007000H;
PWR_CR = PWR;
LCD = 40002400H;
LCD_CR = LCD;
LCD_FCR = LCD + 04H;
LCD_SR = LCD + 08H;
LCD_RAM = LCD + 14H;
AFM = 2;
AF11 = 11;
PinsA = {1..3, 8..10, 15};
PinsB = {3..5, 8..15};
PinsC = {0..3, 6..11};
A = 0; H = 7;
B = 1; J = 8;
C = 2; K = 9;
D = 3; M = 10;
E = 4; N = 11;
F = 5; P = 12;
G = 6; Q = 13;
DP = 14; COLON = 15; BAR = 16;
VAR
display: ARRAY 6, 17 OF INTEGER;
digits: ARRAY 10 OF SET;
PROCEDURE SetPinsMode (reg: INTEGER; pins: SET; mode: INTEGER);
VAR
x: SET;
pin: INTEGER;
BEGIN
mode := mode MOD 4;
SYSTEM.GET(reg, x);
FOR pin := 0 TO 30 BY 2 DO
IF (pin DIV 2) IN pins THEN
x := x - {pin, pin + 1} + BITS(LSL(mode, pin))
END
END;
SYSTEM.PUT(reg, x)
END SetPinsMode;
PROCEDURE SRBits (adr: INTEGER; setbits, resetbits: SET);
VAR
x: SET;
BEGIN
SYSTEM.GET(adr, x);
SYSTEM.PUT(adr, x - resetbits + setbits)
END SRBits;
PROCEDURE SetBits (adr: INTEGER; bits: SET);
VAR
x: SET;
BEGIN
SYSTEM.GET(adr, x);
SYSTEM.PUT(adr, x + bits)
END SetBits;
PROCEDURE ResetBits (adr: INTEGER; bits: SET);
VAR
x: SET;
BEGIN
SYSTEM.GET(adr, x);
SYSTEM.PUT(adr, x - bits)
END ResetBits;
PROCEDURE TestBits (adr: INTEGER; bits: SET): BOOLEAN;
VAR
x: SET;
BEGIN
SYSTEM.GET(adr, x);
RETURN x * bits = bits
END TestBits;
PROCEDURE Init;
VAR
i, j: INTEGER;
seg: ARRAY 30 OF INTEGER;
BEGIN
FOR i := 0 TO 29 DO
seg[i] := i
END;
FOR i := 3 TO 11 DO
seg[i] := i + 4
END;
seg[18] := 17;
seg[19] := 16;
FOR i := 20 TO 23 DO
seg[i] := i - 2
END;
j := 0;
FOR i := 0 TO 5 DO
display[i, A] := 256 + seg[28 - j];
display[i, B] := 0 + seg[28 - j];
display[i, C] := 256 + seg[j + 1];
display[i, D] := 256 + seg[j];
display[i, E] := 0 + seg[j];
display[i, F] := 256 + seg[29 - j];
display[i, G] := 0 + seg[29 - j];
display[i, H] := 768 + seg[29 - j];
display[i, J] := 768 + seg[28 - j];
display[i, K] := 512 + seg[28 - j];
display[i, M] := 0 + seg[j + 1];
display[i, N] := 768 + seg[j];
display[i, P] := 512 + seg[j];
display[i, Q] := 512 + seg[29 - j];
INC(j, 2)
END;
display[0, DP] := 768 + 1;
display[1, DP] := 768 + 7;
display[2, DP] := 768 + 9;
display[3, DP] := 768 + 11;
display[0, COLON] := 512 + 1;
display[1, COLON] := 512 + 7;
display[2, COLON] := 512 + 9;
display[3, COLON] := 512 + 11;
display[0, BAR] := 768 + 15;
display[1, BAR] := 512 + 15;
display[2, BAR] := 768 + 13;
display[3, BAR] := 512 + 13;
digits[0] := {A, B, C, D, E, F};
digits[1] := {B, C};
digits[2] := {A, B, M, G, E, D};
digits[3] := {A, B, M, G, C, D};
digits[4] := {F, G, M, B, C};
digits[5] := {A, F, G, M, C, D};
digits[6] := {A, F, G, M, C, D, E};
digits[7] := {F, A, B, C};
digits[8] := {A, B, C, D, E, F, G, M};
digits[9] := {A, B, C, D, F, G, M};
END Init;
PROCEDURE ResetSeg (seg: INTEGER);
BEGIN
ResetBits(LCD_RAM + (seg DIV 256) * 2 * 4, {seg MOD 256})
END ResetSeg;
PROCEDURE SetSeg (seg: INTEGER);
BEGIN
SetBits(LCD_RAM + (seg DIV 256) * 2 * 4, {seg MOD 256})
END SetSeg;
PROCEDURE Digit (pos, dgt: INTEGER);
VAR
s: SET;
i: INTEGER;
BEGIN
s := digits[dgt];
FOR i := 0 TO 13 DO
IF i IN s THEN
SetSeg(display[pos, i])
ELSE
ResetSeg(display[pos, i])
END
END
END Digit;
PROCEDURE WhileBits (adr: INTEGER; bits: SET);
BEGIN
WHILE TestBits(adr, bits) DO END
END WhileBits;
PROCEDURE UntilBits (adr: INTEGER; bits: SET);
BEGIN
REPEAT UNTIL TestBits(adr, bits)
END UntilBits;
PROCEDURE main;
VAR
i: INTEGER;
BEGIN
Init;
(* подключить GPIOA, GPIOB, GPIOC *)
SetBits(RCC_AHBENR, {0, 1, 2});
(* настроить на режим альтернативной функции *)
SetPinsMode(GPIOAMODER, PinsA, AFM);
(* 400 кГц *)
SetPinsMode(GPIOAOSPEEDR, PinsA, 0);
(* без подтягивающих резисторов *)
SetPinsMode(GPIOAPUPDR, PinsA, 0);
(* режим push-pull *)
ResetBits(GPIOAOTYPER, PinsA);
(* альтернативная функция AF11 = 0BH *)
SYSTEM.PUT(GPIOAAFRL, 0BBB0H);
SYSTEM.PUT(GPIOAAFRH, 0B0000BBBH);
(* аналогично для GPIOB *)
SetPinsMode(GPIOBMODER, PinsB, AFM);
SetPinsMode(GPIOBOSPEEDR, PinsB, 0);
SetPinsMode(GPIOBPUPDR, PinsB, 0);
ResetBits(GPIOBOTYPER, PinsB);
SYSTEM.PUT(GPIOBAFRL, 000BBB000H);
SYSTEM.PUT(GPIOBAFRH, 0BBBBBBBBH);
(* аналогично для GPIOC *)
SetPinsMode(GPIOCMODER, PinsC, AFM);
SetPinsMode(GPIOCOSPEEDR, PinsC, 0);
SetPinsMode(GPIOCPUPDR, PinsC, 0);
ResetBits(GPIOCOTYPER, PinsC);
SYSTEM.PUT(GPIOCAFRL, 0BB00BBBBH);
SYSTEM.PUT(GPIOCAFRH, 00000BBBBH);
(* подключить контроллер ЖКИ *)
SetBits(RCC_APB1ENR, {9, 28}); (* LCDEN = {9}; PWREN = {28} *)
(* разрешить запись в регистр RCC_CSR *)
SetBits(PWR_CR, {8}); (* DBP = {8} *)
(* сбросить источник тактирования *)
SetBits(RCC_CSR, {23}); (* RTCRST = {23} *)
(* выбрать новый источник *)
ResetBits(RCC_CSR, {23}); (* RTCRST = {23} *)
(* включить НЧ генератор *)
SetBits(RCC_CSR, {8}); (* LSEON = {8} *)
(* ждать готовность НЧ генератора *)
UntilBits(RCC_CSR, {9}); (* LSERDY = {9} *)
(* выбрать НЧ генератор как источник тактирования *)
SRBits(RCC_CSR, {16}, {17}); (* RCC_CSR[17:16] := 01b *)
(* настроить контроллер ЖКИ *)
SRBits(LCD_CR, {2, 3, 6, 7}, {4, 5}); (* MUX_SEG = {7}; BIAS1 = {6}; BIAS0 = {5}; DUTY2 = {4}; DUTY1 = {3}; DUTY0 = {2} *)
(* Установить значения коэффициентов деления частоты тактового сигнала LCDCLK *)
SRBits(LCD_FCR, {11, 18, 24}, {10..12, 18..25}); (* LCD_FCR[12:10] := 010b; LCD_FCR[21:18] := 0001b; LCD_FCR[25:22] := 0100b *)
(* ждать синхронизацию регистра LCD_FCR *)
UntilBits(LCD_SR, {5}); (* FCRSF = {5} *)
(* выбрать внутренний источник напряжения для ЖКИ и разрешить его работу *)
SRBits(LCD_CR, {0}, {1}); (* LCD_CR_VSEL = {1}; LCD_CR_LCDEN = {0} *)
(* ждать готовность контроллера ЖКИ *)
UntilBits(LCD_SR, {0, 4}); (* LCD_SR_RDY = {4}; LCD_SR_ENS = {0} *)
(* ждать завершение предыдущей записи *)
WhileBits(LCD_SR, {2}); (* LCD_SR_UDR = {2} *)
(* начать запись *)
FOR i := 0 TO 5 DO
Digit(i, i + 1) (* 123456 *)
END;
SetSeg(display[1, DP]); (* 12.3456 *)
SetSeg(display[3, COLON]); (* 12.34:56 *)
SetSeg(display[0, BAR]); (* 12.34:56_ *)
(* завершить запись *)
SetBits(LCD_SR, {2}) (* LCD_SR_UDR = {2} *)
END main;
BEGIN
main
END LCD.

79
programs/develop/oberon07/Samples/STM32CM3/SysTick.ob07 Normal file
View File

@ -0,0 +1,79 @@
(*
Пример для STM32L152C-DISCO
Светодиоды мигают по прерыванию от системного таймера.
*)
MODULE SysTick;
IMPORT SYSTEM;
CONST
GPIOB = 40020400H;
GPIOBMODER = GPIOB;
GPIOBOTYPER = GPIOB + 04H;
GPIOBOSPEEDR = GPIOB + 08H;
GPIOBPUPDR = GPIOB + 0CH;
GPIOBIDR = GPIOB + 10H;
GPIOBODR = GPIOB + 14H;
GPIOBBSRR = GPIOB + 18H;
GPIOBLCKR = GPIOB + 1CH;
GPIOBAFRL = GPIOB + 20H;
GPIOBAFRH = GPIOB + 24H;
GPIOBBRR = GPIOB + 28H;
RCC = 40023800H;
RCC_CR = RCC;
RCC_AHBENR = RCC + 1CH;
RCC_APB2ENR = RCC + 20H;
RCC_APB1ENR = RCC + 24H;
STK = 0E000E010H;
STK_CTRL = STK;
ENABLE = {0};
TICKINT = {1};
CLKSOURCE = {2};
STK_LOAD = STK + 04H;
STK_VAL = STK + 08H;
STK_CALIB = STK + 0CH;
Blue = 6;
Green = 7;
VAR
x: SET; state: BOOLEAN;
(* обработчик прерываний от System tick timer *)
PROCEDURE tick [15];
BEGIN
state := ~state;
(* включить или выключить светодиоды *)
SYSTEM.PUT(GPIOBBSRR, {Blue + 16 * ORD(state)});
SYSTEM.PUT(GPIOBBSRR, {Green + 16 * ORD(state)})
END tick;
BEGIN
state := FALSE;
(* подключить GPIOB *)
SYSTEM.GET(RCC_AHBENR, x);
SYSTEM.PUT(RCC_AHBENR, x + {1});
(* настроить PB6 и PB7 на выход *)
SYSTEM.GET(GPIOBMODER, x);
SYSTEM.PUT(GPIOBMODER, x + {12, 14} - {13, 15});
(* настроить и запустить SysTick *)
SYSTEM.PUT(STK_LOAD, 1048576);
SYSTEM.PUT(STK_CTRL, ENABLE + TICKINT + CLKSOURCE);
END SysTick.

143
programs/develop/oberon07/Samples/STM32CM3/TIM67.ob07 Normal file
View File

@ -0,0 +1,143 @@
(*
Пример для STM32L152C-DISCO
Синий светодиод мигает по прерыванию от таймера TIM6,
зеленый - от TIM7.
*)
MODULE TIM67;
IMPORT SYSTEM;
CONST
GPIOB = 40020400H;
GPIOBMODER = GPIOB;
GPIOBOTYPER = GPIOB + 04H;
GPIOBOSPEEDR = GPIOB + 08H;
GPIOBPUPDR = GPIOB + 0CH;
GPIOBIDR = GPIOB + 10H;
GPIOBODR = GPIOB + 14H;
GPIOBBSRR = GPIOB + 18H;
GPIOBLCKR = GPIOB + 1CH;
GPIOBAFRL = GPIOB + 20H;
GPIOBAFRH = GPIOB + 24H;
GPIOBBRR = GPIOB + 28H;
RCC = 40023800H;
RCC_CR = RCC;
RCC_AHBENR = RCC + 1CH;
RCC_APB2ENR = RCC + 20H;
RCC_APB1ENR = RCC + 24H;
TIM6 = 40001000H;
TIM6_CR1 = TIM6;
CEN = {0};
UDIS = {1};
URS = {2};
OPM = {3};
ARPE = {7};
TIM6_CR2 = TIM6 + 04H;
TIM6_DIER = TIM6 + 0CH;
UIE = {0};
TIM6_SR = TIM6 + 10H;
UIF = {0};
TIM6_EGR = TIM6 + 14H;
UG = {0};
TIM6_CNT = TIM6 + 24H;
TIM6_PSC = TIM6 + 28H;
TIM6_ARR = TIM6 + 2CH;
TIM7 = 40001400H;
TIM7_CR1 = TIM7;
TIM7_CR2 = TIM7 + 04H;
TIM7_DIER = TIM7 + 0CH;
TIM7_SR = TIM7 + 10H;
TIM7_EGR = TIM7 + 14H;
TIM7_CNT = TIM7 + 24H;
TIM7_PSC = TIM7 + 28H;
TIM7_ARR = TIM7 + 2CH;
NVIC = 0E000E100H;
NVIC_ISER0 = NVIC;
NVIC_ISER1 = NVIC + 04H;
NVIC_ISER2 = NVIC + 08H;
NVIC_ICER0 = NVIC + 80H;
NVIC_ICER1 = NVIC + 84H;
NVIC_ICER2 = NVIC + 88H;
BLUELED = 6;
GREENLED = 7;
VAR
x: SET;
state1, state2: BOOLEAN;
(* обработчик прерываний от TIM6 *)
PROCEDURE tim6 [59];
BEGIN
SYSTEM.PUT(TIM6_SR, 0); (* сбросить флаг прерывания *)
state1 := ~state1;
(* включить или выключить синий светодиод *)
SYSTEM.PUT(GPIOBBSRR, {BLUELED + 16 * ORD(state1)})
END tim6;
(* обработчик прерываний от TIM7 *)
PROCEDURE tim7 [60];
BEGIN
SYSTEM.PUT(TIM7_SR, 0); (* сбросить флаг прерывания *)
state2 := ~state2;
(* включить или выключить зеленый светодиод *)
SYSTEM.PUT(GPIOBBSRR, {GREENLED + 16 * ORD(state2)})
END tim7;
BEGIN
state1 := FALSE;
state2 := FALSE;
(* подключить GPIOB *)
SYSTEM.GET(RCC_AHBENR, x);
SYSTEM.PUT(RCC_AHBENR, x + {1});
(* подключить TIM6 и TIM7 *)
SYSTEM.GET(RCC_APB1ENR, x);
SYSTEM.PUT(RCC_APB1ENR, x + {4, 5});
(* настроить PB6 и PB7 на выход *)
SYSTEM.GET(GPIOBMODER, x);
SYSTEM.PUT(GPIOBMODER, x + {12, 14} - {13, 15});
(* разрешить прерывания от таймеров TIM6 (позиция 43) и TIM7 (позиция 44) *)
SYSTEM.PUT(NVIC_ISER1, {11, 12});
(* настроить и запустить TIM6 *)
SYSTEM.PUT(TIM6_ARR, 31);
SYSTEM.PUT(TIM6_PSC, 65535);
SYSTEM.PUT(TIM6_DIER, UIE);
SYSTEM.GET(TIM6_CR1, x);
SYSTEM.PUT(TIM6_CR1, x + CEN - (UDIS + URS + OPM + ARPE));
(* настроить и запустить TIM7 *)
SYSTEM.PUT(TIM7_ARR, 8000);
SYSTEM.PUT(TIM7_PSC, 80);
SYSTEM.PUT(TIM7_DIER, UIE);
SYSTEM.GET(TIM7_CR1, x);
SYSTEM.PUT(TIM7_CR1, x + CEN - (UDIS + URS + OPM + ARPE));
END TIM67.

58
programs/develop/oberon07/Samples/Windows/Console/Doors.ob07 Normal file
View File

@ -0,0 +1,58 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(*
There are 100 doors in a row that are all initially closed.
You make 100 passes by the doors.
The first time through, visit every door and toggle the door (if the door is closed, open it; if it is open, close it).
The second time, only visit every 2nd door (door #2, #4, #6, ...), and toggle it.
The third time, visit every 3rd door (door #3, #6, #9, ...), etc, until you only visit the 100th door.
What state are the doors in after the last pass? Which are open, which are closed?
*)
MODULE Doors;
IMPORT In, Out, Console;
CONST
CLOSED = FALSE;
OPEN = TRUE;
TYPE
List = ARRAY 101 OF BOOLEAN;
VAR
Doors: List;
I, J: INTEGER;
BEGIN
Console.open;
FOR I := 1 TO 100 DO
FOR J := 1 TO 100 DO
IF J MOD I = 0 THEN
IF Doors[J] = CLOSED THEN
Doors[J] := OPEN
ELSE
Doors[J] := CLOSED
END
END
END
END;
FOR I := 1 TO 100 DO
Out.Int(I, 3);
Out.String(" is ");
IF Doors[I] = CLOSED THEN
Out.String("Closed.")
ELSE
Out.String("Open.")
END;
Out.Ln
END;
In.Ln;
Console.exit(TRUE)
END Doors.

101
programs/develop/oberon07/Samples/Windows/Console/HeapSort.ob07 Normal file
View File

@ -0,0 +1,101 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(* ********* Zonnon online collection ***********
* Sorting: Heap Sort (Chapter 2, Example 2.8)
*
* This example is a part of Prof. Nikalus Wirth's book
* www.zonnon.ethz.ch/usergroup
* (c) ETH Zurich
*)
MODULE HeapSort;
IMPORT In, Out, Console;
CONST
MAX_SIZE = 20;
TYPE
DefaultArray = ARRAY MAX_SIZE OF INTEGER;
VAR
MyArray: DefaultArray;
(***** Implementation *****)
PROCEDURE sift(VAR a: DefaultArray; L,R:INTEGER);
VAR
i, j, x: INTEGER;
BEGIN
i := L; j:= 2 * L; x:= a[L];
IF (j < R) & (a[j] < a[j + 1]) THEN j := j + 1 END;
WHILE (j <= R) & (x < a[j]) DO
a[i] := a[j]; i := j; j := 2 * j;
IF (j < R) & (a[j] < a[j + 1]) THEN j := j + 1 END
END;
a[i] := x
END sift;
PROCEDURE HeapSort(VAR a: DefaultArray; n: INTEGER);
VAR
L, R, x: INTEGER;
BEGIN
L := (n DIV 2); R := n - 1;
WHILE L > 0 DO L := L - 1; sift(a, L, R) END;
WHILE R > 0 DO
x := a[0]; a[0] := a[R]; a[R]:= x;
R := R - 1; sift(a, L, R)
END
END HeapSort;
(***** Example support *****)
PROCEDURE FillTheArray;
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO MAX_SIZE - 1 DO
MyArray[i] := ABS(10 - i)
END
END FillTheArray;
PROCEDURE PrintTheArray;
VAR
i: INTEGER;
BEGIN
Out.String("Array:"); Out.Ln;
FOR i := 0 TO MAX_SIZE - 1 DO
Out.Int(MyArray[i], 2); Out.String(", ")
END;
Out.Ln
END PrintTheArray;
PROCEDURE Execute;
BEGIN
HeapSort(MyArray, MAX_SIZE)
END Execute;
BEGIN
Console.open;
Out.String("Example 2.8 (Heap sort)"); Out.Ln;
FillTheArray;
PrintTheArray;
Execute;
PrintTheArray;
Out.String("Press Enter to continue"); In.Ln;
Console.exit(TRUE)
END HeapSort.

13
programs/develop/oberon07/Samples/Windows/Console/Hello.ob07 Normal file
View File

@ -0,0 +1,13 @@
MODULE Hello;
IMPORT Console, In, Out;
BEGIN
Console.open;
Out.String("Hello, world!");
In.Ln;
Console.exit(TRUE)
END Hello.

26
programs/develop/oberon07/Samples/Windows/Console/HelloRus.ob07 Normal file
View File

@ -0,0 +1,26 @@
MODULE HelloRus;
IMPORT Console, In, Out;
PROCEDURE main;
VAR
str: ARRAY 10 OF WCHAR;
BEGIN
str := "Привет!";
Out.StringW(str); Out.Ln;
str[2] := "е";
str[5] := "д";
Out.StringW(str)
END main;
BEGIN
Console.open;
main;
In.Ln;
Console.exit(TRUE)
END HelloRus.

48
programs/develop/oberon07/Samples/Windows/Console/MagicSquares.ob07 Normal file
View File

@ -0,0 +1,48 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(* ********* Zonnon online collection ***********
* Magic Squares
*
* This example is a part of Prof. Nikalus Wirth's book
* www.zonnon.ethz.ch/usergroup
* (c) ETH Zurich
*)
MODULE MagicSquares; (*NW 11.8.97*)
IMPORT In, Out, Console;
PROCEDURE Generate; (*magic square of order 3, 5, 7, ... *)
VAR
i, j, x, nx, nsq, n: INTEGER;
M: ARRAY 13, 13 OF INTEGER;
BEGIN
Out.String("Enter magic square order(3, 5, 7, ..., 13): "); In.Int(n); nsq := n * n; x := 0;
i := n DIV 2; j := n - 1;
WHILE x < nsq DO
nx := n + x; j := (j - 1) MOD n; INC(x);
Out.Int(i, 1); Out.Char(9X);
Out.Int(j, 1); Out.Ln;
M[i, j] := x;
WHILE x < nx DO
i := (i + 1) MOD n; j := (j + 1) MOD n;
INC(x); M[i, j] := x
END
END;
FOR i := 0 TO n - 1 DO
FOR j := 0 TO n - 1 DO Out.Int(M[i, j], 6) END;
Out.Ln
END
END Generate;
BEGIN
Console.open;
Generate;
Out.String("Press Enter to continue"); In.Ln;
Console.exit(TRUE)
END MagicSquares.

52
programs/develop/oberon07/Samples/Windows/Console/MultiplicationTables.ob07 Normal file
View File

@ -0,0 +1,52 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(*
Produce a formatted NxN multiplication table
Only print the top half triangle of products
*)
MODULE MultiplicationTables;
IMPORT In, Out, Console;
CONST
N = 18;
VAR
I, J: INTEGER;
BEGIN
Console.open;
FOR J := 1 TO N - 1 DO
Out.Int(J, 3);
Out.String(" ")
END;
Out.Int(N, 3);
Out.Ln;
FOR J := 0 TO N - 1 DO
Out.String("----")
END;
Out.String("+");
Out.Ln;
FOR I := 1 TO N DO
FOR J := 1 TO N DO
IF J < I THEN
Out.String(" ")
ELSE
Out.Int(I * J, 3);
Out.String(" ")
END
END;
Out.String("| ");
Out.Int(I, 2);
Out.Ln
END;
In.Ln;
Console.exit(TRUE)
END MultiplicationTables.

Some files were not shown because too many files have changed in this diff Show More