Sweetbread/kolibrios
1
0
Fork 0
forked from KolibriOS/kolibrios
Code Issues Pull Requests Actions Activity

update Oberon07 and CEDIT by akron1

Browse Source 
git-svn-id: svn://kolibrios.org@8859 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
Kirill Lipatov (Leency) 2021-06-15 17:33:16 +00:00
parent f3f40df401
commit 498da3221e
178 changed files with 5878 additions and 14432 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
programs/develop/cedit/CEDIT
View File

Binary file not shown.

35
programs/develop/cedit/SRC/CEdit.ob07
View File

@ -28,7 +28,7 @@ IMPORT
RW, Ini, box_lib, Icons;
CONST
header = "CEdit (14-jun-2021)";
header = "CEdit (15-jun-2021)";
ShellFilter = "";
EditFilter = "SH|ASM|TXT|INC|OB07|C|CPP|H|PAS|PP|LUA|INI";
@ -78,15 +78,16 @@ CONST
btnTop = MainMenuHeight + 3;
toolBtnSize = 24;
toolbarDelim = 7;
iconPad = (toolBtnSize - Icons.SIZE) DIV 2;
TOP = btnTop + toolBtnSize + 7;
RIGHT = scrollWidth - 2;
BOTTOM = scrollWidth + 25;
BOTTOM = scrollWidth + 18;
minWinWidth = 635; minWinHeight = 542;
SEARCH_PADDING = 10;
searchLeft = 10;
searchLeft = 0;
EditBox_Width = 180;
EDITBOX_MAXCHARS = 500;
@ -270,8 +271,6 @@ END Replaced;
PROCEDURE toolbarIcons;
CONST
iconPad = (toolBtnSize - Icons.SIZE) DIV 2;
VAR
x, color: INTEGER;
BEGIN
@ -329,7 +328,7 @@ END toolbarIcons;
PROCEDURE WriteModified (x, y: INTEGER);
BEGIN
modified := text.modified;
K.DrawRect(x, TOP + canvas.height + scrollWidth - 1, 9*fontWidth, BOTTOM - scrollWidth + 1, K.winColor);
K.DrawRect(x, TOP + canvas.height + scrollWidth - 1, 8*fontWidth, BOTTOM - scrollWidth + 1, K.winColor);
IF modified THEN
K.DrawText866(x, y, K.textColor, "modified")
END
@ -353,7 +352,7 @@ BEGIN
WritePos(y);
IF modified # text.modified THEN
WriteModified(width - 9*fontWidth, y)
WriteModified(width - 8*fontWidth, y)
END;
T.getScroll(text, scrollX, scrollY);
@ -445,8 +444,6 @@ END SearchPanel;
PROCEDURE draw_window;
CONST
iconPad = (toolBtnSize - Icons.SIZE) DIV 2;
VAR
width, height, x, y: INTEGER;
@ -527,13 +524,13 @@ BEGIN
INC(x, toolBtnSize + 5 + toolbarDelim);
drawToolbarBtn(btnBuild, x);
Icons.draw(icons, 54, x + iconPad, btnTop + iconPad);
INC(x, toolBtnSize + 5);
drawToolbarBtn(btnRun, x);
Icons.draw(icons, 53, x + iconPad, btnTop + iconPad);
INC(x, toolBtnSize + 5);
toolbarIcons;
K.CreateButton(btnUp, LEFT + canvas.width - 1, TOP, scrollWidth - 1, scrollWidth, K.btnColor, 0X);
K.DrawText69(LEFT + canvas.width - 1 + (scrollWidth - 6) DIV 2, TOP + (scrollWidth - 9) DIV 2, K.btnTextColor, 18X);
K.CreateButton(btnDown, LEFT + canvas.width - 1, TOP + canvas.height - scrollWidth - 1, scrollWidth - 1, scrollWidth, K.btnColor, 0X);
@ -549,19 +546,19 @@ BEGIN
y := (btnHeight - fontHeight) DIV 2 + btnTop;
CASE text.enc OF
|E.UTF8: K.DrawText866(width - 6*fontWidth, y, K.textColor, "UTF-8")
|E.UTF8BOM: K.DrawText866(width - 10*fontWidth, y, K.textColor, "UTF-8-BOM")
|E.CP866: K.DrawText866(width - 6*fontWidth, y, K.textColor, "CP866")
|E.W1251: K.DrawText866(width - 13*fontWidth, y, K.textColor, "Windows-1251")
|E.UTF8: K.DrawText866(width - 5*fontWidth, y, K.textColor, "UTF-8")
|E.UTF8BOM: K.DrawText866(width - 9*fontWidth, y, K.textColor, "UTF-8-BOM")
|E.CP866: K.DrawText866(width - 5*fontWidth, y, K.textColor, "CP866")
|E.W1251: K.DrawText866(width - 12*fontWidth, y, K.textColor, "Windows-1251")
END;
IF search THEN
SearchPanel(searchLeft, TOP)
END;
y := height - (BOTTOM - scrollWidth) + (BOTTOM - scrollWidth - 16) DIV 2;
K.DrawRect(LEFT + 16*fontWidth, TOP + canvas.height + scrollWidth - 1, width - LEFT - 25*fontWidth, BOTTOM - scrollWidth + 1, K.winColor);
K.DrawRect(LEFT + 16*fontWidth, TOP + canvas.height + scrollWidth - 1, width - LEFT - 24*fontWidth, BOTTOM - scrollWidth + 1, K.winColor);
K.DrawText866(LEFT + 16*fontWidth, y, K.textColor, text.fileName);
WriteModified(width - 9*fontWidth, y);
WriteModified(width - 8*fontWidth, y);
repaint
END;
K.EndDraw
@ -753,7 +750,7 @@ PROCEDURE Search;
BEGIN
search := ~search;
IF search THEN
LEFT := searchLeft + EditBox_Width + SEARCH_PADDING*3;
LEFT := searchLeft + EditBox_Width + SEARCH_PADDING*2 + 5;
IF T.search(text, searchText, cs, whole) THEN END
ELSE
LEFT := searchLeft;
@ -1245,7 +1242,7 @@ BEGIN
winHeight := MAX(winHeight, minWinHeight);
cliWidth := winWidth;
cliHeight := winHeight;
LEFT := 10;
LEFT := searchLeft;
canvas := G.CreateCanvas(winWidth - (LEFT + RIGHT + 10), winHeight - (TOP + BOTTOM + 4) - K.SkinHeight());
font1 := G.CreateFont(1, "", {});
font2 := G.CreateFont(2, "", {});

127
programs/develop/cedit/SRC/Icons.ob07 Normal file
View File

@ -0,0 +1,127 @@
(*
Copyright 2021 Anton Krotov
This file is part of CEdit.
CEdit is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
CEdit 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 General Public License for more details.
You should have received a copy of the GNU General Public License
along with CEdit. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Icons;
IMPORT
LibImg, K := KolibriOS, SYSTEM;
CONST
fileName = "/rd/1/Icons16.png";
SIZE* = 18;
VAR
source: INTEGER;
PROCEDURE copy (src, dst: INTEGER);
VAR
src_sizeX, src_sizeY, dst_sizeX, dst_sizeY,
src_data, dst_data: INTEGER;
BEGIN
LibImg.GetInf(src, src_sizeX, src_sizeY, src_data);
LibImg.GetInf(dst, dst_sizeX, dst_sizeY, dst_data);
ASSERT(src_sizeX = dst_sizeX);
ASSERT(src_sizeY = dst_sizeY);
SYSTEM.MOVE(src_data, dst_data, src_sizeX*src_sizeY*3)
END copy;
PROCEDURE load (): INTEGER;
VAR
y: INTEGER;
BEGIN
RETURN LibImg.LoadFromFile(fileName, SIZE, y)
END load;
PROCEDURE draw* (icons, n, x, y: INTEGER);
VAR
sizeX, sizeY, data: INTEGER;
BEGIN
LibImg.GetInf(icons, sizeX, sizeY, data);
K.DrawImage(data + SIZE*SIZE*3*n, SIZE, SIZE, x, y)
END draw;
PROCEDURE gray (icons: INTEGER);
VAR
sizeX, sizeY, data, x, y: INTEGER;
b, g, r, gr: BYTE;
BEGIN
LibImg.GetInf(icons, sizeX, sizeY, data);
FOR y := 0 TO sizeY - 1 DO
FOR x := 0 TO sizeX - 1 DO
SYSTEM.GET8(data, b);
SYSTEM.GET8(data + 1, g);
SYSTEM.GET8(data + 2, r);
gr := (r + g + b) DIV 3;
SYSTEM.PUT8(data, gr);
SYSTEM.PUT8(data + 1, gr);
SYSTEM.PUT8(data + 2, gr);
INC(data, 3);
END
END
END gray;
PROCEDURE iconsBackColor (icons: INTEGER);
VAR
sizeX, sizeY, data, x, y: INTEGER;
b, g, r: BYTE;
BEGIN
LibImg.GetInf(icons, sizeX, sizeY, data);
FOR y := 0 TO sizeY - 1 DO
FOR x := 0 TO sizeX - 1 DO
SYSTEM.GET8(data, b);
SYSTEM.GET8(data + 1, g);
SYSTEM.GET8(data + 2, r);
IF b + g + r = 765 THEN
b := K.toolbarColor MOD 256;
g := K.toolbarColor DIV 256 MOD 256;
r := K.toolbarColor DIV 65536 MOD 256
END;
SYSTEM.PUT8(data, b);
SYSTEM.PUT8(data + 1, g);
SYSTEM.PUT8(data + 2, r);
INC(data, 3);
END
END
END iconsBackColor;
PROCEDURE get* (VAR icons, grayIcons: INTEGER);
BEGIN
IF source = 0 THEN
source := load();
icons := load();
grayIcons := load()
ELSE
copy(source, icons);
copy(source, grayIcons)
END;
gray(grayIcons);
iconsBackColor(icons);
iconsBackColor(grayIcons)
END get;
BEGIN
source := 0
END Icons.

BIN
programs/develop/oberon07/Compiler
View File

Binary file not shown.

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

Binary file not shown.

2
programs/develop/oberon07/LICENSE
View File

@ -1,6 +1,6 @@
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
Copyright (c) 2018-2021, Anton Krotov
All rights reserved.
Redistribution and use in source and binary forms, with or without

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

@ -1,520 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, API;
CONST
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
VAR
name: INTEGER;
types: INTEGER;
PROCEDURE [stdcall] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, dst, src);
res := TRUE
END
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE [stdcall] _rot* (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 [stdcall] _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 [stdcall] _set1* (a: INTEGER); (* {a} -> eax *)
BEGIN
SYSTEM.CODE(
031H, 0C0H, (* xor eax, eax *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- a *)
083H, 0F9H, 01FH, (* cmp ecx, 31 *)
077H, 003H, (* ja L *)
00FH, 0ABH, 0C8H (* bts eax, ecx *)
(* L: *)
)
END _set1;
PROCEDURE [stdcall] _divmod* (y, x: INTEGER); (* (x div y) -> eax; (x mod y) -> edx *)
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- x *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
074H, 018H, (* je L2 *)
07FH, 002H, (* jg L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
089H, 0C3H, (* mov ebx, eax *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- y *)
0F7H, 0F9H, (* idiv ecx *)
085H, 0D2H, (* test edx, edx *)
074H, 009H, (* je L2 *)
031H, 0CBH, (* xor ebx, ecx *)
085H, 0DBH, (* test ebx, ebx *)
07DH, 003H, (* jge L2 *)
048H, (* dec eax *)
001H, 0CAH, (* add edx, ecx *)
(* L2: *)
05BH (* pop ebx *)
)
END _divmod;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, WORD)
END
END _new;
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - WORD)
END
END _dispose;
PROCEDURE [stdcall] _length* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH (* sub eax, dword [ebp + 0Ch] *)
)
END _length;
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H (* shr eax, 1 *)
)
END _lengthw;
PROCEDURE [stdcall] strncmp (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
056H, (* push esi *)
057H, (* push edi *)
053H, (* push ebx *)
08BH, 075H, 008H, (* mov esi, dword[ebp + 8]; esi <- a *)
08BH, 07DH, 00CH, (* mov edi, dword[ebp + 12]; edi <- b *)
08BH, 05DH, 010H, (* mov ebx, dword[ebp + 16]; ebx <- n *)
031H, 0C9H, (* xor ecx, ecx *)
031H, 0D2H, (* xor edx, edx *)
0B8H,
000H, 000H, 000H, 080H, (* mov eax, minint *)
(* L1: *)
085H, 0DBH, (* test ebx, ebx *)
07EH, 017H, (* jle L3 *)
08AH, 00EH, (* mov cl, byte[esi] *)
08AH, 017H, (* mov dl, byte[edi] *)
046H, (* inc esi *)
047H, (* inc edi *)
04BH, (* dec ebx *)
039H, 0D1H, (* cmp ecx, edx *)
074H, 006H, (* je L2 *)
089H, 0C8H, (* mov eax, ecx *)
029H, 0D0H, (* sub eax, edx *)
0EBH, 006H, (* jmp L3 *)
(* L2: *)
085H, 0C9H, (* test ecx, ecx *)
075H, 0E7H, (* jne L1 *)
031H, 0C0H, (* xor eax, eax *)
(* L3: *)
05BH, (* pop ebx *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05DH, (* pop ebp *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END strncmp;
PROCEDURE [stdcall] strncmpw (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
056H, (* push esi *)
057H, (* push edi *)
053H, (* push ebx *)
08BH, 075H, 008H, (* mov esi, dword[ebp + 8]; esi <- a *)
08BH, 07DH, 00CH, (* mov edi, dword[ebp + 12]; edi <- b *)
08BH, 05DH, 010H, (* mov ebx, dword[ebp + 16]; ebx <- n *)
031H, 0C9H, (* xor ecx, ecx *)
031H, 0D2H, (* xor edx, edx *)
0B8H,
000H, 000H, 000H, 080H, (* mov eax, minint *)
(* L1: *)
085H, 0DBH, (* test ebx, ebx *)
07EH, 01BH, (* jle L3 *)
066H, 08BH, 00EH, (* mov cx, word[esi] *)
066H, 08BH, 017H, (* mov dx, word[edi] *)
046H, (* inc esi *)
046H, (* inc esi *)
047H, (* inc edi *)
047H, (* inc edi *)
04BH, (* dec ebx *)
039H, 0D1H, (* cmp ecx, edx *)
074H, 006H, (* je L2 *)
089H, 0C8H, (* mov eax, ecx *)
029H, 0D0H, (* sub eax, edx *)
0EBH, 006H, (* jmp L3 *)
(* L2: *)
085H, 0C9H, (* test ecx, ecx *)
075H, 0E3H, (* jne L1 *)
031H, 0C0H, (* xor eax, eax *)
(* L3: *)
05BH, (* pop ebx *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05DH, (* pop ebp *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END strncmpw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmp;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2 * 2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1 * 2, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmpw;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE [stdcall] _error* (modnum, _module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
CASE err OF
| 1: s := "assertion failure"
| 2: s := "NIL dereference"
| 3: s := "bad divisor"
| 4: s := "NIL procedure call"
| 5: s := "type guard error"
| 6: s := "index out of range"
| 7: s := "invalid CASE"
| 8: s := "array assignment error"
| 9: s := "CHR out of range"
|10: s := "WCHR out of range"
|11: s := "BYTE out of range"
END;
append(s, API.eol + "module: "); PCharToStr(_module, temp); append(s, temp);
append(s, API.eol + "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): INTEGER;
BEGIN
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
END
RETURN p MOD 2
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(p, p);
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
ELSE
p := 1
END
RETURN p MOD 2
END _guard;
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall] _sofinit*;
BEGIN
API.sofinit
END _sofinit;
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
ASSERT(types # 0);
FOR i := 0 TO tcount - 1 DO
FOR j := 0 TO tcount - 1 DO
t0 := i; t1 := j;
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(_types + t1 * WORD, t1)
END;
SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
END
END;
name := modname
END _init;
END RTL.

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

@ -1,123 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT SYSTEM;
CONST
eol* = 0AX;
BIT_DEPTH* = 32;
RTLD_LAZY = 1;
TYPE
SOFINI = PROCEDURE;
VAR
MainParam*, libc*: INTEGER;
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: 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 DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
puts(lpCaption);
puts(lpText)
END DebugMsg;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
VAR
res, ptr, words: INTEGER;
BEGIN
res := malloc(size);
IF res # 0 THEN
ptr := res;
words := size DIV SYSTEM.SIZE(INTEGER);
WHILE words > 0 DO
SYSTEM.PUT(ptr, 0);
INC(ptr, SYSTEM.SIZE(INTEGER));
DEC(words)
END
END
RETURN res
END _NEW;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
free(p)
RETURN 0
END _DISPOSE;
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
sym := dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetSym;
PROCEDURE init* (sp, code: INTEGER);
BEGIN
fini := NIL;
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
libc := dlopen(SYSTEM.SADR("libc.so.6"), RTLD_LAZY);
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 dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END sofinit;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
fini := ProcFini
END SetFini;
END API.

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

@ -1,70 +0,0 @@
(*
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
View File

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

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

@ -1,248 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, API, RTL;
CONST
slash* = "/";
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;
libc, librt: INTEGER;
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
exit(code)
END ExitProcess;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (n < argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
RETURN res
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
END FileCreate;
PROCEDURE FileClose* (File: INTEGER);
BEGIN
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 fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
END FileOpen;
PROCEDURE OutChar* (c: CHAR);
VAR
res: INTEGER;
BEGIN
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
VAR
tp: TP;
res: INTEGER;
BEGIN
IF clock_gettime(0, tp) = 0 THEN
res := tp[0] * 100 + tp[1] DIV 10000000
ELSE
res := 0
END
RETURN res
END GetTickCount;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
PROCEDURE UnixTime* (): INTEGER;
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
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
sym := API.dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetSym;
BEGIN
maxreal := 1.9;
PACK(maxreal, 1023);
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
View File

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

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

@ -1,106 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE LINAPI;
IMPORT SYSTEM, API, Libdl;
TYPE
TP* = ARRAY 2 OF INTEGER;
SOFINI* = PROCEDURE;
VAR
libc*, librt*: INTEGER;
stdout*,
stdin*,
stderr* : INTEGER;
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
API.SetFini(ProcFini)
END SetFini;
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;
BEGIN
libc := API.libc;
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));
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 := Libdl.open("librt.so.1", Libdl.LAZY);
GetSym(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END init;
PROCEDURE [stdcall-] syscall* (eax, ebx, ecx, edx, esi, edi: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
0CDH, 080H, (* int 128 *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END syscall;
BEGIN
init
END LINAPI.

65
programs/develop/oberon07/Lib/Linux32/Libdl.ob07
View File

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

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

@ -1,450 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2013-2014, 2018-2020 Anton Krotov
All rights reserved.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
pi* = 3.141592653589793;
e* = 2.718281828459045;
PROCEDURE IsNan* (x: REAL): BOOLEAN;
VAR
h, l: SET;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf* (x: REAL): BOOLEAN;
RETURN ABS(x) = SYSTEM.INF()
END IsInf;
PROCEDURE Max (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a > b THEN
res := a
ELSE
res := b
END
RETURN res
END Max;
PROCEDURE Min (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a < b THEN
res := a
ELSE
res := b
END
RETURN res
END Min;
PROCEDURE SameValue (a, b: REAL): BOOLEAN;
VAR
eps: REAL;
res: BOOLEAN;
BEGIN
eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);
IF a > b THEN
res := (a - b) <= eps
ELSE
res := (b - a) <= eps
END
RETURN res
END SameValue;
PROCEDURE IsZero (x: REAL): BOOLEAN;
RETURN ABS(x) <= 1.0E-12
END IsZero;
PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FAH, (* fsqrt *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sqrt;
PROCEDURE [stdcall] sin* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FEH, (* fsin *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sin;
PROCEDURE [stdcall] cos* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FFH, (* fcos *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END cos;
PROCEDURE [stdcall] tan* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FBH, (* fsincos *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END tan;
PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F3H, (* fpatan *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END arctan2;
PROCEDURE [stdcall] ln* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0D9H, 0EDH, (* fldln2 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END ln;
PROCEDURE [stdcall] log* (base, x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F1H, (* fyl2x *)
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END log;
PROCEDURE [stdcall] exp* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0EAH, (* fldl2e *)
0DEH, 0C9H, 0D9H, 0C0H,
0D9H, 0FCH, 0DCH, 0E9H,
0D9H, 0C9H, 0D9H, 0F0H,
0D9H, 0E8H, 0DEH, 0C1H,
0D9H, 0FDH, 0DDH, 0D9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END exp;
PROCEDURE [stdcall] round* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 07DH, 0F4H, 0D9H,
07DH, 0F6H, 066H, 081H,
04DH, 0F6H, 000H, 003H,
0D9H, 06DH, 0F6H, 0D9H,
0FCH, 0D9H, 06DH, 0F4H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END round;
PROCEDURE [stdcall] frac* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
050H,
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0C0H, 0D9H, 03CH,
024H, 0D9H, 07CH, 024H,
002H, 066H, 081H, 04CH,
024H, 002H, 000H, 00FH,
0D9H, 06CH, 024H, 002H,
0D9H, 0FCH, 0D9H, 02CH,
024H, 0DEH, 0E9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END frac;
PROCEDURE sqri* (x: INTEGER): INTEGER;
RETURN x * x
END sqri;
PROCEDURE sqrr* (x: REAL): REAL;
RETURN x * x
END sqrr;
PROCEDURE arcsin* (x: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
RETURN arctan2(sqrt(1.0 - x * x), x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, 1.0)
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF SameValue(x, 1.0) THEN
res := SYSTEM.INF()
ELSIF SameValue(x, -1.0) THEN
res := -SYSTEM.INF()
ELSE
res := 0.5 * ln((1.0 + x) / (1.0 - x))
END
RETURN res
END artanh;
PROCEDURE floor* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0 THEN
x := x - 1.0
END
RETURN x
END floor;
PROCEDURE ceil* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0 THEN
x := x + 1.0
END
RETURN x
END ceil;
PROCEDURE power* (base, exponent: REAL): REAL;
VAR
res: REAL;
BEGIN
IF exponent = 0.0 THEN
res := 1.0
ELSIF (base = 0.0) & (exponent > 0.0) THEN
res := 0.0
ELSE
res := exp(exponent * ln(base))
END
RETURN res
END power;
PROCEDURE ipower* (base: REAL; exponent: INTEGER): REAL;
VAR
i: INTEGER;
a: REAL;
BEGIN
a := 1.0;
IF base # 0.0 THEN
IF exponent # 0 THEN
IF exponent < 0 THEN
base := 1.0 / base
END;
i := ABS(exponent);
WHILE i > 0 DO
WHILE ~ODD(i) DO
i := LSR(i, 1);
base := sqrr(base)
END;
DEC(i);
a := a * base
END
ELSE
a := 1.0
END
ELSE
ASSERT(exponent > 0);
a := 0.0
END
RETURN a
END ipower;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
PROCEDURE DegToRad* (x: REAL): REAL;
RETURN x * (pi / 180.0)
END DegToRad;
PROCEDURE RadToDeg* (x: REAL): REAL;
RETURN x * (180.0 / pi)
END RadToDeg;
(* Return hypotenuse of triangle *)
PROCEDURE hypot* (x, y: REAL): REAL;
VAR
a: REAL;
BEGIN
x := ABS(x);
y := ABS(y);
IF x > y THEN
a := x * sqrt(1.0 + sqrr(y / x))
ELSE
IF x > 0.0 THEN
a := y * sqrt(1.0 + sqrr(x / y))
ELSE
a := y
END
END
RETURN a
END hypot;
END Math.

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

@ -1,77 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT SYSTEM, Libdl;
VAR
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);
BEGIN
printf1(SYSTEM.SADR("%c"), ORD(x))
END 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("%*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, precision: INTEGER);
BEGIN
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.

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

@ -1,123 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT SYSTEM;
CONST
eol* = 0AX;
BIT_DEPTH* = 64;
RTLD_LAZY = 1;
TYPE
SOFINI = PROCEDURE;
VAR
MainParam*, libc*: INTEGER;
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: 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 DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
puts(lpCaption);
puts(lpText)
END DebugMsg;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
VAR
res, ptr, words: INTEGER;
BEGIN
res := malloc(size);
IF res # 0 THEN
ptr := res;
words := size DIV SYSTEM.SIZE(INTEGER);
WHILE words > 0 DO
SYSTEM.PUT(ptr, 0);
INC(ptr, SYSTEM.SIZE(INTEGER));
DEC(words)
END
END
RETURN res
END _NEW;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
free(p)
RETURN 0
END _DISPOSE;
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
sym := dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetSym;
PROCEDURE init* (sp, code: INTEGER);
BEGIN
fini := NIL;
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
libc := dlopen(SYSTEM.SADR("libc.so.6"), RTLD_LAZY);
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 dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN 0
END dllentry;
PROCEDURE sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END sofinit;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
fini := ProcFini
END SetFini;
END API.

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

@ -1,70 +0,0 @@
(*
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
View File

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

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

@ -1,254 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, API, RTL;
CONST
slash* = "/";
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;
libc, librt: INTEGER;
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
exit(code)
END ExitProcess;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (n < argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F);
IF res <= 0 THEN
res := -1
END
RETURN res
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
END FileCreate;
PROCEDURE FileClose* (File: INTEGER);
BEGIN
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 fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
END FileOpen;
PROCEDURE OutChar* (c: CHAR);
VAR
res: INTEGER;
BEGIN
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
VAR
tp: TP;
res: INTEGER;
BEGIN
IF clock_gettime(0, tp) = 0 THEN
res := tp[0] * 100 + tp[1] DIV 10000000
ELSE
res := 0
END
RETURN res
END GetTickCount;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
PROCEDURE UnixTime* (): INTEGER;
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
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
PROCEDURE GetSym (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
sym := API.dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetSym;
BEGIN
maxreal := 1.9;
PACK(maxreal, 1023);
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
View File

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

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

@ -1,101 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE LINAPI;
IMPORT SYSTEM, API, Libdl;
TYPE
TP* = ARRAY 2 OF INTEGER;
SOFINI* = PROCEDURE;
VAR
libc*, librt*: INTEGER;
stdout*,
stdin*,
stderr* : INTEGER;
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE SetFini* (ProcFini: SOFINI);
BEGIN
API.SetFini(ProcFini)
END SetFini;
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;
BEGIN
libc := API.libc;
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));
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 := Libdl.open("librt.so.1", Libdl.LAZY);
GetSym(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END init;
PROCEDURE [stdcall64-] syscall* (rax, rdi, rsi, rdx, r10, r8, r9: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
048H, 08BH, 045H, 010H, (* mov rax, qword [rbp + 16] *)
048H, 08BH, 07DH, 018H, (* mov rdi, qword [rbp + 24] *)
048H, 08BH, 075H, 020H, (* mov rsi, qword [rbp + 32] *)
048H, 08BH, 055H, 028H, (* mov rdx, qword [rbp + 40] *)
04CH, 08BH, 055H, 030H, (* mov r10, qword [rbp + 48] *)
04CH, 08BH, 045H, 038H, (* mov r8, qword [rbp + 56] *)
04CH, 08BH, 04DH, 040H, (* mov r9, qword [rbp + 64] *)
00FH, 005H, (* syscall *)
0C9H, (* leave *)
0C2H, 038H, 000H (* ret 56 *)
)
RETURN 0
END syscall;
BEGIN
init
END LINAPI.

65
programs/develop/oberon07/Lib/Linux64/Libdl.ob07
View File

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

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

@ -1,480 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
pi* = 3.1415926535897932384626433832795028841972E0;
e* = 2.7182818284590452353602874713526624977572E0;
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
LnInfinity, LnSmall, large, miny: REAL;
PROCEDURE [stdcall64] sqrt* (x: REAL): REAL;
BEGIN
ASSERT(x >= ZERO);
SYSTEM.CODE(
0F2H, 0FH, 51H, 45H, 10H, (* sqrtsd xmm0, qword[rbp + 10h] *)
05DH, (* pop rbp *)
0C2H, 08H, 00H (* ret 8 *)
)
RETURN 0.0
END sqrt;
PROCEDURE 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
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
xn, g, p, q, z: REAL;
n: INTEGER;
BEGIN
IF x > LnInfinity THEN
x := SYSTEM.INF()
ELSIF x < LnSmall THEN
x := ZERO
ELSIF ABS(x) < eps THEN
x := ONE
ELSE
IF x >= ZERO THEN
n := FLOOR(ln2Inv * x + HALF)
ELSE
n := FLOOR(ln2Inv * x - HALF)
END;
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 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
zn, zd, r, z, w, p, q, xn: REAL;
n: INTEGER;
BEGIN
ASSERT(x > ZERO);
UNPK(x, n);
x := x * HALF;
IF x > sqrtHalf THEN
zn := x - ONE;
zd := x * HALF + HALF;
INC(n)
ELSE
zn := x - HALF;
zd := zn * HALF + HALF
END;
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 (xn * c2 + r) + xn * c1
END ln;
PROCEDURE power* (base, exponent: REAL): REAL;
BEGIN
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 > ZERO);
ASSERT(x > ZERO)
RETURN ln(x) / ln(base)
END log;
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
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);
IF x # y THEN
xn := xn - HALF
END;
x1 := FLT(FLOOR(x));
f := ((x1 - xn * c1) + (x - x1)) - xn * c2;
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 x
END SinCos;
PROCEDURE sin* (x: REAL): REAL;
BEGIN
IF x < ZERO THEN
x := SinCos(x, -x, -ONE)
ELSE
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) <= ONE)
RETURN arctan2(sqrt(ONE - x * x), x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, ONE)
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - ONE / x) * HALF
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + ONE / x) * HALF
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := ONE
ELSIF x < -15.0 THEN
x := -ONE
ELSE
x := exp(TWO * x);
x := (x - ONE) / (x + ONE)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + ONE))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
BEGIN
ASSERT(x >= ONE)
RETURN ln(x + sqrt(x * x - ONE))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) < ONE)
RETURN HALF * ln((ONE + x) / (ONE - x))
END artanh;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > ZERO THEN
res := 1
ELSIF x < ZERO THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := ONE;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
PROCEDURE DegToRad* (x: REAL): REAL;
RETURN x * (pi / 180.0)
END DegToRad;
PROCEDURE RadToDeg* (x: REAL): REAL;
RETURN x * (180.0 / pi)
END RadToDeg;
(* Return hypotenuse of triangle *)
PROCEDURE hypot* (x, y: REAL): REAL;
VAR
a: REAL;
BEGIN
x := ABS(x);
y := ABS(y);
IF x > y THEN
a := x * sqrt(1.0 + sqrr(y / x))
ELSE
IF x > 0.0 THEN
a := y * sqrt(1.0 + sqrr(x / y))
ELSE
a := y
END
END
RETURN a
END hypot;
BEGIN
large := 1.9;
PACK(large, expoMax);
miny := ONE / large;
LnInfinity := ln(large);
LnSmall := ln(miny);
END Math.

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

@ -1,87 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT SYSTEM, Libdl;
VAR
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);
BEGIN
printf1(SYSTEM.SADR("%c"), ORD(x))
END 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
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, precision: INTEGER);
BEGIN
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.

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

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

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

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

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

@ -1,132 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT SYSTEM;
CONST
eol* = 0DX + 0AX;
SectionAlignment = 1000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
KERNEL = "kernel32.dll";
USER = "user32.dll";
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
base*: INTEGER;
heap: INTEGER;
process_detach,
thread_detach,
thread_attach: DLL_ENTRY;
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);
BEGIN
MessageBoxA(0, lpText, lpCaption, 16)
END DebugMsg;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
RETURN HeapAlloc(heap, 8, size)
END _NEW;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
HeapFree(heap, 0, p)
RETURN 0
END _DISPOSE;
PROCEDURE init* (reserved, code: INTEGER);
BEGIN
process_detach := NIL;
thread_detach := NIL;
thread_attach := NIL;
base := code - SectionAlignment;
heap := GetProcessHeap()
END init;
PROCEDURE exit* (code: INTEGER);
BEGIN
ExitProcess(code)
END exit;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
ExitThread(code)
END exit_thread;
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := 0;
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
IF thread_attach # NIL THEN
thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
IF thread_detach # NIL THEN
thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
IF process_detach # NIL THEN
process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
END
RETURN res
END dllentry;
PROCEDURE sofinit*;
END sofinit;
PROCEDURE SetDll* (_process_detach, _thread_detach, _thread_attach: DLL_ENTRY);
BEGIN
process_detach := _process_detach;
thread_detach := _thread_detach;
thread_attach := _thread_attach
END SetDll;
END API.

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

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

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

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

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

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

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

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

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

@ -1,333 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, RTL;
CONST
slash* = "\";
eol* = 0DX + 0AX;
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
MAX_PARAM = 1024;
OFS_MAXPATHNAME = 128;
TYPE
POverlapped = POINTER TO OVERLAPPED;
OVERLAPPED = RECORD
Internal: INTEGER;
InternalHigh: INTEGER;
Offset: INTEGER;
OffsetHigh: INTEGER;
hEvent: INTEGER
END;
OFSTRUCT = RECORD
cBytes: CHAR;
fFixedDisk: CHAR;
nErrCode: WCHAR;
Reserved1: WCHAR;
Reserved2: WCHAR;
szPathName: ARRAY OFS_MAXPATHNAME OF CHAR
END;
PSecurityAttributes = POINTER TO TSecurityAttributes;
TSecurityAttributes = RECORD
nLength: INTEGER;
lpSecurityDescriptor: INTEGER;
bInheritHandle: INTEGER
END;
VAR
hConsoleOutput: INTEGER;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc: INTEGER;
maxreal*: REAL;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
_GetTickCount (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
_GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
_GetCommandLine (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
_ReadFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
_WriteFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
_CloseHandle (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CreateFileA"]
_CreateFile (
lpFileName, dwDesiredAccess, dwShareMode: INTEGER;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition, dwFlagsAndAttributes,
hTemplateFile: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
_OpenFile (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCurrentDirectoryA"]
_GetCurrentDirectory (nBufferLength, lpBuffer: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
_ExitProcess (code: INTEGER);
PROCEDURE [ccall, "msvcrt.dll", "time"]
_time (ptr: INTEGER): INTEGER;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
_ExitProcess(code)
END ExitProcess;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
n := _GetCurrentDirectory(LEN(path), SYSTEM.ADR(path[0]));
path[n] := slash;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR
p, count, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; VAR cond: INTEGER; c: CHAR);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
cond := C
END
END ChangeCond;
BEGIN
p := _GetCommandLine();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, cond, c); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, cond, c); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, cond, c); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
BEGIN
j := 0;
IF n < argc THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i)
END
END;
s[j] := 0X
END GetArg;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, res, NIL) = 0 THEN
res := -1
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, res, NIL) = 0 THEN
res := -1
END
RETURN res
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN _CreateFile(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
_CloseHandle(F)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
ofstr: OFSTRUCT;
res: INTEGER;
BEGIN
res := _OpenFile(SYSTEM.ADR(FName[0]), ofstr, 0);
IF res = 0FFFFFFFFH THEN
res := -1
END
RETURN res
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
END chmod;
PROCEDURE OutChar* (c: CHAR);
VAR
count: INTEGER;
BEGIN
_WriteFile(hConsoleOutput, SYSTEM.ADR(c), 1, count, NIL)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
RETURN _GetTickCount() DIV 10
END GetTickCount;
PROCEDURE letter (c: CHAR): BOOLEAN;
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z")
END letter;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN ~(letter(path[0]) & (path[1] = ":"))
END isRelative;
PROCEDURE UnixTime* (): INTEGER;
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
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
BEGIN
maxreal := 1.9;
PACK(maxreal, 1023);
hConsoleOutput := _GetStdHandle(-11);
ParamParse
END HOST.

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

@ -1,80 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE In;
IMPORT SYSTEM;
CONST
MAX_LEN = 1024;
VAR
Done*: BOOLEAN;
hConsoleInput: INTEGER;
s: ARRAY MAX_LEN + 4 OF CHAR;
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
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;
s[count] := 0X;
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
hConsoleInput := GetStdHandle(-10);
Done := TRUE
END Open;
END In.

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

@ -1,450 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2013-2014, 2018-2020 Anton Krotov
All rights reserved.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
pi* = 3.141592653589793;
e* = 2.718281828459045;
PROCEDURE IsNan* (x: REAL): BOOLEAN;
VAR
h, l: SET;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf* (x: REAL): BOOLEAN;
RETURN ABS(x) = SYSTEM.INF()
END IsInf;
PROCEDURE Max (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a > b THEN
res := a
ELSE
res := b
END
RETURN res
END Max;
PROCEDURE Min (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF a < b THEN
res := a
ELSE
res := b
END
RETURN res
END Min;
PROCEDURE SameValue (a, b: REAL): BOOLEAN;
VAR
eps: REAL;
res: BOOLEAN;
BEGIN
eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);
IF a > b THEN
res := (a - b) <= eps
ELSE
res := (b - a) <= eps
END
RETURN res
END SameValue;
PROCEDURE IsZero (x: REAL): BOOLEAN;
RETURN ABS(x) <= 1.0E-12
END IsZero;
PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FAH, (* fsqrt *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sqrt;
PROCEDURE [stdcall] sin* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FEH, (* fsin *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sin;
PROCEDURE [stdcall] cos* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FFH, (* fcos *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END cos;
PROCEDURE [stdcall] tan* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FBH, (* fsincos *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END tan;
PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F3H, (* fpatan *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END arctan2;
PROCEDURE [stdcall] ln* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0D9H, 0EDH, (* fldln2 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END ln;
PROCEDURE [stdcall] log* (base, x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F1H, (* fyl2x *)
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END log;
PROCEDURE [stdcall] exp* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0EAH, (* fldl2e *)
0DEH, 0C9H, 0D9H, 0C0H,
0D9H, 0FCH, 0DCH, 0E9H,
0D9H, 0C9H, 0D9H, 0F0H,
0D9H, 0E8H, 0DEH, 0C1H,
0D9H, 0FDH, 0DDH, 0D9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END exp;
PROCEDURE [stdcall] round* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 07DH, 0F4H, 0D9H,
07DH, 0F6H, 066H, 081H,
04DH, 0F6H, 000H, 003H,
0D9H, 06DH, 0F6H, 0D9H,
0FCH, 0D9H, 06DH, 0F4H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END round;
PROCEDURE [stdcall] frac* (x: REAL): REAL;
BEGIN
SYSTEM.CODE(
050H,
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0C0H, 0D9H, 03CH,
024H, 0D9H, 07CH, 024H,
002H, 066H, 081H, 04CH,
024H, 002H, 000H, 00FH,
0D9H, 06CH, 024H, 002H,
0D9H, 0FCH, 0D9H, 02CH,
024H, 0DEH, 0E9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END frac;
PROCEDURE sqri* (x: INTEGER): INTEGER;
RETURN x * x
END sqri;
PROCEDURE sqrr* (x: REAL): REAL;
RETURN x * x
END sqrr;
PROCEDURE arcsin* (x: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
RETURN arctan2(sqrt(1.0 - x * x), x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, 1.0)
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF SameValue(x, 1.0) THEN
res := SYSTEM.INF()
ELSIF SameValue(x, -1.0) THEN
res := -SYSTEM.INF()
ELSE
res := 0.5 * ln((1.0 + x) / (1.0 - x))
END
RETURN res
END artanh;
PROCEDURE floor* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0 THEN
x := x - 1.0
END
RETURN x
END floor;
PROCEDURE ceil* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0 THEN
x := x + 1.0
END
RETURN x
END ceil;
PROCEDURE power* (base, exponent: REAL): REAL;
VAR
res: REAL;
BEGIN
IF exponent = 0.0 THEN
res := 1.0
ELSIF (base = 0.0) & (exponent > 0.0) THEN
res := 0.0
ELSE
res := exp(exponent * ln(base))
END
RETURN res
END power;
PROCEDURE ipower* (base: REAL; exponent: INTEGER): REAL;
VAR
i: INTEGER;
a: REAL;
BEGIN
a := 1.0;
IF base # 0.0 THEN
IF exponent # 0 THEN
IF exponent < 0 THEN
base := 1.0 / base
END;
i := ABS(exponent);
WHILE i > 0 DO
WHILE ~ODD(i) DO
i := LSR(i, 1);
base := sqrr(base)
END;
DEC(i);
a := a * base
END
ELSE
a := 1.0
END
ELSE
ASSERT(exponent > 0);
a := 0.0
END
RETURN a
END ipower;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
PROCEDURE DegToRad* (x: REAL): REAL;
RETURN x * (pi / 180.0)
END DegToRad;
PROCEDURE RadToDeg* (x: REAL): REAL;
RETURN x * (180.0 / pi)
END RadToDeg;
(* Return hypotenuse of triangle *)
PROCEDURE hypot* (x, y: REAL): REAL;
VAR
a: REAL;
BEGIN
x := ABS(x);
y := ABS(y);
IF x > y THEN
a := x * sqrt(1.0 + sqrr(y / x))
ELSE
IF x > 0.0 THEN
a := y * sqrt(1.0 + sqrr(x / y))
ELSE
a := y
END
END
RETURN a
END hypot;
END Math.

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

@ -1,77 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT SYSTEM;
VAR
hConsoleOutput: 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
printf1(SYSTEM.SADR("%c"), ORD(x))
END Char;
PROCEDURE StringW* (s: ARRAY OF WCHAR);
BEGIN
WriteConsoleW(hConsoleOutput, SYSTEM.ADR(s[0]), LENGTH(s), 0, 0)
END StringW;
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(CHR(13) + CHR(10)))
END Ln;
PROCEDURE Int* (x, width: INTEGER);
BEGIN
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, precision: INTEGER);
BEGIN
printf3(SYSTEM.SADR("%*.*f"), width, precision, x)
END FixReal;
PROCEDURE Open*;
BEGIN
hConsoleOutput := GetStdHandle(-11)
END Open;
END Out.

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

@ -1,520 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT SYSTEM, API;
CONST
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
WORD = bit_depth DIV 8;
MAX_SET = bit_depth - 1;
VAR
name: INTEGER;
types: INTEGER;
PROCEDURE [stdcall] _move* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, dst, src);
res := TRUE
END
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, dst, src)
END _strcpy;
PROCEDURE [stdcall] _rot* (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 [stdcall] _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 [stdcall] _set1* (a: INTEGER); (* {a} -> eax *)
BEGIN
SYSTEM.CODE(
031H, 0C0H, (* xor eax, eax *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- a *)
083H, 0F9H, 01FH, (* cmp ecx, 31 *)
077H, 003H, (* ja L *)
00FH, 0ABH, 0C8H (* bts eax, ecx *)
(* L: *)
)
END _set1;
PROCEDURE [stdcall] _divmod* (y, x: INTEGER); (* (x div y) -> eax; (x mod y) -> edx *)
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 00CH, (* mov eax, dword [ebp + 12] *) (* eax <- x *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
074H, 018H, (* je L2 *)
07FH, 002H, (* jg L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
089H, 0C3H, (* mov ebx, eax *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *) (* ecx <- y *)
0F7H, 0F9H, (* idiv ecx *)
085H, 0D2H, (* test edx, edx *)
074H, 009H, (* je L2 *)
031H, 0CBH, (* xor ebx, ecx *)
085H, 0DBH, (* test ebx, ebx *)
07DH, 003H, (* jge L2 *)
048H, (* dec eax *)
001H, 0CAH, (* add edx, ecx *)
(* L2: *)
05BH (* pop ebx *)
)
END _divmod;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, WORD)
END
END _new;
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - WORD)
END
END _dispose;
PROCEDURE [stdcall] _length* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH (* sub eax, dword [ebp + 0Ch] *)
)
END _length;
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H (* shr eax, 1 *)
)
END _lengthw;
PROCEDURE [stdcall] strncmp (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
056H, (* push esi *)
057H, (* push edi *)
053H, (* push ebx *)
08BH, 075H, 008H, (* mov esi, dword[ebp + 8]; esi <- a *)
08BH, 07DH, 00CH, (* mov edi, dword[ebp + 12]; edi <- b *)
08BH, 05DH, 010H, (* mov ebx, dword[ebp + 16]; ebx <- n *)
031H, 0C9H, (* xor ecx, ecx *)
031H, 0D2H, (* xor edx, edx *)
0B8H,
000H, 000H, 000H, 080H, (* mov eax, minint *)
(* L1: *)
085H, 0DBH, (* test ebx, ebx *)
07EH, 017H, (* jle L3 *)
08AH, 00EH, (* mov cl, byte[esi] *)
08AH, 017H, (* mov dl, byte[edi] *)
046H, (* inc esi *)
047H, (* inc edi *)
04BH, (* dec ebx *)
039H, 0D1H, (* cmp ecx, edx *)
074H, 006H, (* je L2 *)
089H, 0C8H, (* mov eax, ecx *)
029H, 0D0H, (* sub eax, edx *)
0EBH, 006H, (* jmp L3 *)
(* L2: *)
085H, 0C9H, (* test ecx, ecx *)
075H, 0E7H, (* jne L1 *)
031H, 0C0H, (* xor eax, eax *)
(* L3: *)
05BH, (* pop ebx *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05DH, (* pop ebp *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END strncmp;
PROCEDURE [stdcall] strncmpw (a, b, n: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
056H, (* push esi *)
057H, (* push edi *)
053H, (* push ebx *)
08BH, 075H, 008H, (* mov esi, dword[ebp + 8]; esi <- a *)
08BH, 07DH, 00CH, (* mov edi, dword[ebp + 12]; edi <- b *)
08BH, 05DH, 010H, (* mov ebx, dword[ebp + 16]; ebx <- n *)
031H, 0C9H, (* xor ecx, ecx *)
031H, 0D2H, (* xor edx, edx *)
0B8H,
000H, 000H, 000H, 080H, (* mov eax, minint *)
(* L1: *)
085H, 0DBH, (* test ebx, ebx *)
07EH, 01BH, (* jle L3 *)
066H, 08BH, 00EH, (* mov cx, word[esi] *)
066H, 08BH, 017H, (* mov dx, word[edi] *)
046H, (* inc esi *)
046H, (* inc esi *)
047H, (* inc edi *)
047H, (* inc edi *)
04BH, (* dec ebx *)
039H, 0D1H, (* cmp ecx, edx *)
074H, 006H, (* je L2 *)
089H, 0C8H, (* mov eax, ecx *)
029H, 0D0H, (* sub eax, edx *)
0EBH, 006H, (* jmp L3 *)
(* L2: *)
085H, 0C9H, (* test ecx, ecx *)
075H, 0E3H, (* jne L1 *)
031H, 0C0H, (* xor eax, eax *)
(* L3: *)
05BH, (* pop ebx *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05DH, (* pop ebp *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END strncmpw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmp;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2 * 2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1 * 2, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmpw;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
SYSTEM.MOVE(SYSTEM.ADR(s2[0]), SYSTEM.ADR(s1[n1]), n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE [stdcall] _error* (modnum, _module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
CASE err OF
| 1: s := "assertion failure"
| 2: s := "NIL dereference"
| 3: s := "bad divisor"
| 4: s := "NIL procedure call"
| 5: s := "type guard error"
| 6: s := "index out of range"
| 7: s := "invalid CASE"
| 8: s := "array assignment error"
| 9: s := "CHR out of range"
|10: s := "WCHR out of range"
|11: s := "BYTE out of range"
END;
append(s, API.eol + "module: "); PCharToStr(_module, temp); append(s, temp);
append(s, API.eol + "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): INTEGER;
BEGIN
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
END
RETURN p MOD 2
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(p, p);
IF p # 0 THEN
SYSTEM.GET(p - WORD, p);
SYSTEM.GET(t0 + p + types, p)
ELSE
p := 1
END
RETURN p MOD 2
END _guard;
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
RETURN API.dllentry(hinstDLL, fdwReason, lpvReserved)
END _dllentry;
PROCEDURE [stdcall] _sofinit*;
BEGIN
API.sofinit
END _sofinit;
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
ASSERT(types # 0);
FOR i := 0 TO tcount - 1 DO
FOR j := 0 TO tcount - 1 DO
t0 := i; t1 := j;
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(_types + t1 * WORD, t1)
END;
SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
END
END;
name := modname
END _init;
END RTL.

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

@ -1,224 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE WINAPI;
IMPORT SYSTEM, API;
CONST
OFS_MAXPATHNAME* = 128;
KERNEL = "kernel32.dll";
USER = "user32.dll";
MSVCRT = "msvcrt.dll";
TYPE
DLL_ENTRY* = API.DLL_ENTRY;
STRING = ARRAY 260 OF CHAR;
TCoord* = RECORD
X*, Y*: WCHAR
END;
TSmallRect* = RECORD
Left*, Top*, Right*, Bottom*: WCHAR
END;
TConsoleScreenBufferInfo* = RECORD
dwSize*: TCoord;
dwCursorPosition*: TCoord;
wAttributes*: WCHAR;
srWindow*: TSmallRect;
dwMaximumWindowSize*: TCoord
END;
TSystemTime* = RECORD
Year*,
Month*,
DayOfWeek*,
Day*,
Hour*,
Min*,
Sec*,
MSec*: WCHAR
END;
tm* = RECORD
sec*,
min*,
hour*,
mday*,
mon*,
year*,
wday*,
yday*,
isdst*: SYSTEM.CARD32
END;
PSecurityAttributes* = POINTER TO TSecurityAttributes;
TSecurityAttributes* = RECORD
nLength*: SYSTEM.CARD32;
lpSecurityDescriptor*: INTEGER;
bInheritHandle*: SYSTEM.CARD32 (* BOOL *)
END;
TFileTime* = RECORD
dwLowDateTime*,
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*: BYTE;
fFixedDisk*: BYTE;
nErrCode*: WCHAR;
Reserved1*: WCHAR;
Reserved2*: WCHAR;
szPathName*: ARRAY OFS_MAXPATHNAME OF CHAR
END;
POverlapped* = POINTER TO OVERLAPPED;
OVERLAPPED* = RECORD
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: SYSTEM.CARD32;
OffsetHigh*: SYSTEM.CARD32;
hEvent*: INTEGER
END;
PROCEDURE [windows-, KERNEL, ""] SetConsoleCursorPosition* (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetConsoleScreenBufferInfo* (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FillConsoleOutputCharacterA* (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FillConsoleOutputAttribute* (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] SetConsoleTextAttribute* (hConsoleOutput, wAttributes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetStdHandle* (nStdHandle: INTEGER): INTEGER;
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, ""] CloseHandle* (hObject: 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, ""] ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, KERNEL, ""] WriteFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, KERNEL, ""] ReadConsoleA* (hConsoleInput, lpBuffer, nNumberOfCharsToRead, lpNumberOfCharsRead, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetCommandLineA* (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GlobalAlloc* (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GlobalFree* (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] WriteConsoleW* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] ExitProcess* (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] WriteConsoleA* (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetTickCount* (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] Sleep* (dwMilliseconds: INTEGER);
PROCEDURE [windows-, KERNEL, ""] FreeLibrary* (hLibModule: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetProcAddress* (hModule, name: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] LoadLibraryA* (name: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] AllocConsole* (): BOOLEAN;
PROCEDURE [windows-, KERNEL, ""] FreeConsole* (): BOOLEAN;
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 [ccall-, MSVCRT, ""] time* (ptr: INTEGER): INTEGER;
PROCEDURE [ccall-, MSVCRT, ""] mktime* (time: tm): INTEGER;
PROCEDURE SetDllEntry* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
API.SetDll(process_detach, thread_detach, thread_attach)
END SetDllEntry;
END WINAPI.

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

@ -1,132 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT SYSTEM;
CONST
eol* = 0DX + 0AX;
SectionAlignment = 1000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
KERNEL = "kernel32.dll";
USER = "user32.dll";
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
base*: INTEGER;
heap: INTEGER;
process_detach,
thread_detach,
thread_attach: DLL_ENTRY;
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);
BEGIN
MessageBoxA(0, lpText, lpCaption, 16)
END DebugMsg;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
RETURN HeapAlloc(heap, 8, size)
END _NEW;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
HeapFree(heap, 0, p)
RETURN 0
END _DISPOSE;
PROCEDURE init* (reserved, code: INTEGER);
BEGIN
process_detach := NIL;
thread_detach := NIL;
thread_attach := NIL;
base := code - SectionAlignment;
heap := GetProcessHeap()
END init;
PROCEDURE exit* (code: INTEGER);
BEGIN
ExitProcess(code)
END exit;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
ExitThread(code)
END exit_thread;
PROCEDURE dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := 0;
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
IF thread_attach # NIL THEN
thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
IF thread_detach # NIL THEN
thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
IF process_detach # NIL THEN
process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
END
RETURN res
END dllentry;
PROCEDURE sofinit*;
END sofinit;
PROCEDURE SetDll* (_process_detach, _thread_detach, _thread_attach: DLL_ENTRY);
BEGIN
process_detach := _process_detach;
thread_detach := _thread_detach;
thread_attach := _thread_attach
END SetDll;
END API.

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

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

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

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

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

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

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

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

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

@ -1,339 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT SYSTEM, RTL;
CONST
slash* = "\";
eol* = 0DX + 0AX;
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
MAX_PARAM = 1024;
OFS_MAXPATHNAME = 128;
TYPE
POverlapped = POINTER TO OVERLAPPED;
OVERLAPPED = RECORD
Internal: INTEGER;
InternalHigh: INTEGER;
Offset: INTEGER;
OffsetHigh: INTEGER;
hEvent: INTEGER
END;
OFSTRUCT = RECORD
cBytes: CHAR;
fFixedDisk: CHAR;
nErrCode: WCHAR;
Reserved1: WCHAR;
Reserved2: WCHAR;
szPathName: ARRAY OFS_MAXPATHNAME OF CHAR
END;
PSecurityAttributes = POINTER TO TSecurityAttributes;
TSecurityAttributes = RECORD
nLength: INTEGER;
lpSecurityDescriptor: INTEGER;
bInheritHandle: INTEGER
END;
VAR
hConsoleOutput: INTEGER;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc: INTEGER;
maxreal*: REAL;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
_GetTickCount (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
_GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
_GetCommandLine (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
_ReadFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
_WriteFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
_CloseHandle (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CreateFileA"]
_CreateFile (
lpFileName, dwDesiredAccess, dwShareMode: INTEGER;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition, dwFlagsAndAttributes,
hTemplateFile: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
_OpenFile (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCurrentDirectoryA"]
_GetCurrentDirectory (nBufferLength, lpBuffer: INTEGER): INTEGER;
PROCEDURE [windows, "kernel32.dll", "ExitProcess"]
_ExitProcess (code: INTEGER);
PROCEDURE [windows, "msvcrt.dll", "time"]
_time (ptr: INTEGER): INTEGER;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
_ExitProcess(code)
END ExitProcess;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
n := _GetCurrentDirectory(LEN(path), SYSTEM.ADR(path[0]));
path[n] := slash;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR
p, count, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; VAR cond: INTEGER; c: CHAR);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
cond := C
END
END ChangeCond;
BEGIN
p := _GetCommandLine();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, cond, c); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, cond, c); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, cond, c); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
BEGIN
j := 0;
IF n < argc THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i)
END
END;
s[j] := 0X
END GetArg;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, res, NIL) = 0 THEN
res := -1
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, res, NIL) = 0 THEN
res := -1
END
RETURN res
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN _CreateFile(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
_CloseHandle(F)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
ofstr: OFSTRUCT;
res: INTEGER;
BEGIN
res := _OpenFile(SYSTEM.ADR(FName[0]), ofstr, 0);
IF res = 0FFFFFFFFH THEN
res := -1
END
RETURN res
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
END chmod;
PROCEDURE OutChar* (c: CHAR);
VAR
count: INTEGER;
BEGIN
_WriteFile(hConsoleOutput, SYSTEM.ADR(c), 1, count, NIL)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
RETURN _GetTickCount() DIV 10
END GetTickCount;
PROCEDURE letter (c: CHAR): BOOLEAN;
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z")
END letter;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN ~(letter(path[0]) & (path[1] = ":"))
END isRelative;
PROCEDURE UnixTime* (): INTEGER;
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
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
IF e <= 896 THEN
h := (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8 + 800000H;
REPEAT
h := h DIV 2;
INC(e)
UNTIL e = 897;
e := 896;
l := (h MOD 8) * 20000000H;
h := h DIV 8
ELSIF (1151 <= e) & (e < 2047) THEN
e := 1151;
h := 0;
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
END;
DEC(e, 896)
RETURN LSL(s, 31) + LSL(e, 23) + (h MOD 100000H) * 8 + (l DIV 20000000H) MOD 8
END d2s;
BEGIN
maxreal := 1.9;
PACK(maxreal, 1023);
hConsoleOutput := _GetStdHandle(-11);
ParamParse
END HOST.

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

@ -1,80 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE In;
IMPORT SYSTEM;
CONST
MAX_LEN = 1024;
VAR
Done*: BOOLEAN;
hConsoleInput: INTEGER;
s: ARRAY MAX_LEN + 4 OF CHAR;
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 String* (VAR str: ARRAY OF CHAR);
VAR
count: INTEGER;
BEGIN
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;
s[count] := 0X;
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
hConsoleInput := GetStdHandle(-10);
Done := TRUE
END Open;
END In.

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

@ -1,480 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE Math;
IMPORT SYSTEM;
CONST
pi* = 3.1415926535897932384626433832795028841972E0;
e* = 2.7182818284590452353602874713526624977572E0;
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
LnInfinity, LnSmall, large, miny: REAL;
PROCEDURE [stdcall64] sqrt* (x: REAL): REAL;
BEGIN
ASSERT(x >= ZERO);
SYSTEM.CODE(
0F2H, 0FH, 51H, 45H, 10H, (* sqrtsd xmm0, qword[rbp + 10h] *)
05DH, (* pop rbp *)
0C2H, 08H, 00H (* ret 8 *)
)
RETURN 0.0
END sqrt;
PROCEDURE 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
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
xn, g, p, q, z: REAL;
n: INTEGER;
BEGIN
IF x > LnInfinity THEN
x := SYSTEM.INF()
ELSIF x < LnSmall THEN
x := ZERO
ELSIF ABS(x) < eps THEN
x := ONE
ELSE
IF x >= ZERO THEN
n := FLOOR(ln2Inv * x + HALF)
ELSE
n := FLOOR(ln2Inv * x - HALF)
END;
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 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
zn, zd, r, z, w, p, q, xn: REAL;
n: INTEGER;
BEGIN
ASSERT(x > ZERO);
UNPK(x, n);
x := x * HALF;
IF x > sqrtHalf THEN
zn := x - ONE;
zd := x * HALF + HALF;
INC(n)
ELSE
zn := x - HALF;
zd := zn * HALF + HALF
END;
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 (xn * c2 + r) + xn * c1
END ln;
PROCEDURE power* (base, exponent: REAL): REAL;
BEGIN
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 > ZERO);
ASSERT(x > ZERO)
RETURN ln(x) / ln(base)
END log;
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
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);
IF x # y THEN
xn := xn - HALF
END;
x1 := FLT(FLOOR(x));
f := ((x1 - xn * c1) + (x - x1)) - xn * c2;
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 x
END SinCos;
PROCEDURE sin* (x: REAL): REAL;
BEGIN
IF x < ZERO THEN
x := SinCos(x, -x, -ONE)
ELSE
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) <= ONE)
RETURN arctan2(sqrt(ONE - x * x), x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, ONE)
END arctan;
PROCEDURE sinh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x - ONE / x) * HALF
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
BEGIN
x := exp(x)
RETURN (x + ONE / x) * HALF
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
BEGIN
IF x > 15.0 THEN
x := ONE
ELSIF x < -15.0 THEN
x := -ONE
ELSE
x := exp(TWO * x);
x := (x - ONE) / (x + ONE)
END
RETURN x
END tanh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + ONE))
END arsinh;
PROCEDURE arcosh* (x: REAL): REAL;
BEGIN
ASSERT(x >= ONE)
RETURN ln(x + sqrt(x * x - ONE))
END arcosh;
PROCEDURE artanh* (x: REAL): REAL;
BEGIN
ASSERT(ABS(x) < ONE)
RETURN HALF * ln((ONE + x) / (ONE - x))
END artanh;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
IF x > ZERO THEN
res := 1
ELSIF x < ZERO THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := ONE;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
PROCEDURE DegToRad* (x: REAL): REAL;
RETURN x * (pi / 180.0)
END DegToRad;
PROCEDURE RadToDeg* (x: REAL): REAL;
RETURN x * (180.0 / pi)
END RadToDeg;
(* Return hypotenuse of triangle *)
PROCEDURE hypot* (x, y: REAL): REAL;
VAR
a: REAL;
BEGIN
x := ABS(x);
y := ABS(y);
IF x > y THEN
a := x * sqrt(1.0 + sqrr(y / x))
ELSE
IF x > 0.0 THEN
a := y * sqrt(1.0 + sqrr(x / y))
ELSE
a := y
END
END
RETURN a
END hypot;
BEGIN
large := 1.9;
PACK(large, expoMax);
miny := ONE / large;
LnInfinity := ln(large);
LnSmall := ln(miny);
END Math.

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

@ -1,86 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Out;
IMPORT SYSTEM;
VAR
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", ""]
WriteConsoleW (hConsoleOutput, lpBuffer, nNumberOfCharsToWrite, lpNumberOfCharsWritten, lpReserved: INTEGER);
PROCEDURE [windows, "kernel32.dll", ""]
GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE Char* (x: CHAR);
BEGIN
printf1(SYSTEM.SADR("%c"), ORD(x))
END Char;
PROCEDURE StringW* (s: ARRAY OF WCHAR);
BEGIN
WriteConsoleW(hConsoleOutput, SYSTEM.ADR(s[0]), LENGTH(s), 0, 0)
END StringW;
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(CHR(13) + CHR(10)))
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
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, precision: INTEGER);
BEGIN
printf3(SYSTEM.SADR("%*.*f"), width, precision, intval(x))
END FixReal;
PROCEDURE Open*;
BEGIN
hConsoleOutput := GetStdHandle(-11)
END Open;
END Out.

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

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

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

@ -1,224 +0,0 @@
(*
BSD 2-Clause License
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE WINAPI;
IMPORT SYSTEM, API;
CONST
OFS_MAXPATHNAME* = 128;
KERNEL = "kernel32.dll";
USER = "user32.dll";
MSVCRT = "msvcrt.dll";
TYPE
DLL_ENTRY* = API.DLL_ENTRY;
STRING = ARRAY 260 OF CHAR;
TCoord* = RECORD
X*, Y*: WCHAR
END;
TSmallRect* = RECORD
Left*, Top*, Right*, Bottom*: WCHAR
END;
TConsoleScreenBufferInfo* = RECORD
dwSize*: TCoord;
dwCursorPosition*: TCoord;
wAttributes*: WCHAR;
srWindow*: TSmallRect;
dwMaximumWindowSize*: TCoord
END;
TSystemTime* = RECORD
Year*,
Month*,
DayOfWeek*,
Day*,
Hour*,
Min*,
Sec*,
MSec*: WCHAR
END;
tm* = RECORD
sec*,
min*,
hour*,
mday*,
mon*,
year*,
wday*,
yday*,
isdst*: SYSTEM.CARD32
END;
PSecurityAttributes* = POINTER TO TSecurityAttributes;
TSecurityAttributes* = RECORD
nLength*: SYSTEM.CARD32;
lpSecurityDescriptor*: INTEGER;
bInheritHandle*: SYSTEM.CARD32 (* BOOL *)
END;
TFileTime* = RECORD
dwLowDateTime*,
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*: BYTE;
fFixedDisk*: BYTE;
nErrCode*: WCHAR;
Reserved1*: WCHAR;
Reserved2*: WCHAR;
szPathName*: ARRAY OFS_MAXPATHNAME OF CHAR
END;
POverlapped* = POINTER TO OVERLAPPED;
OVERLAPPED* = RECORD
Internal*: INTEGER;
InternalHigh*: INTEGER;
Offset*: SYSTEM.CARD32;
OffsetHigh*: SYSTEM.CARD32;
hEvent*: INTEGER
END;
PROCEDURE [windows-, KERNEL, ""] SetConsoleCursorPosition* (hConsoleOutput, dwCursorPosition: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetConsoleScreenBufferInfo* (hConsoleOutput: INTEGER; ConsoleScreenBufferInfo: TConsoleScreenBufferInfo): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FillConsoleOutputCharacterA* (hConsoleOutput, cCaracter, nLength, dwWriteCoord, lpNumberOfCharsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] FillConsoleOutputAttribute* (hConsoleOutput, wAttribute, nLength, dwWriteCoord, lpNumberOfAttrsWritten: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] SetConsoleTextAttribute* (hConsoleOutput, wAttributes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetStdHandle* (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] CloseHandle* (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] WriteFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, KERNEL, ""] ReadFile* (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetCommandLineA* (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GlobalAlloc* (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GlobalFree* (hMem: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] ExitProcess* (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] GetTickCount* (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] Sleep* (dwMilliseconds: INTEGER);
PROCEDURE [windows-, KERNEL, ""] FreeLibrary* (hLibModule: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] GetProcAddress* (hModule, name: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] LoadLibraryA* (name: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] AllocConsole* (): BOOLEAN;
PROCEDURE [windows-, KERNEL, ""] FreeConsole* (): BOOLEAN;
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);
BEGIN
API.SetDll(process_detach, thread_detach, thread_attach)
END SetDllEntry;
END WINAPI.

6
programs/develop/oberon07/README.md Normal file
View File

@ -0,0 +1,6 @@
Oberon-07 compiler for x64 (Windows, Linux), x86 (Windows, Linux, KolibriOS), MSP430x{1,2}xx, STM32 Cortex-M3
============================================
**Links:**
https://github.com/prospero78/obGraph (Тест графических возможностей компилятора Оберона-07)
https://github.com/VadimAnIsaev/Oberon-07-additional-modules (Additional modules / Дополнительные модули)

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

@ -1,52 +0,0 @@
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
View File

@ -1,74 +0,0 @@
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
View File

@ -1,89 +0,0 @@
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
View File

@ -1,292 +0,0 @@
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
View File

@ -1,142 +0,0 @@
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
View File

@ -1,74 +0,0 @@
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
View File

@ -1,74 +0,0 @@
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
View File

@ -1,221 +0,0 @@
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
View File

@ -1,15 +0,0 @@

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
View File

@ -1,292 +0,0 @@
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
View File

@ -1,142 +0,0 @@
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
View File

@ -1,74 +0,0 @@
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
View File

@ -1,43 +0,0 @@
(*
Пример для 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
View File

@ -1,103 +0,0 @@
(*
Пример для 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
View File

@ -1,157 +0,0 @@
(*
Пример для 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
View File

@ -1,106 +0,0 @@
(*
Пример для 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
View File

@ -1,118 +0,0 @@
(*
Пример для 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
View File

@ -1,143 +0,0 @@
(*
Пример для 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
View File

@ -1,57 +0,0 @@
(*
Пример для 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
View File

@ -1,114 +0,0 @@
(*
Пример для 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
View File

@ -1,366 +0,0 @@
(*
Пример для 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
View File

@ -1,79 +0,0 @@
(*
Пример для 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
View File

@ -1,143 +0,0 @@
(*
Пример для 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
View File

@ -1,58 +0,0 @@
(*
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
View File

@ -1,101 +0,0 @@
(*
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
View File

@ -1,13 +0,0 @@
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
View File

@ -1,26 +0,0 @@
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
View File

@ -1,48 +0,0 @@
(*
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
View File

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

75
programs/develop/oberon07/Samples/Windows/Console/SierpinskiCarpet.ob07
View File

@ -1,75 +0,0 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
MODULE SierpinskiCarpet;
IMPORT In, Out, Console;
VAR
order: INTEGER;
PROCEDURE pow(b, n: INTEGER): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := 1;
FOR i := 1 TO n DO
res := res * b
END
RETURN res
END pow;
PROCEDURE in_carpet(x, y: INTEGER): BOOLEAN;
VAR
res, exit: BOOLEAN;
BEGIN
exit := FALSE;
res := TRUE;
WHILE (x > 0) & (y > 0) & (exit = FALSE) DO
IF (x MOD 3 = 1) & (y MOD 3 = 1) THEN
res := FALSE;
exit := TRUE
END;
y := y DIV 3;
x := x DIV 3
END
RETURN res
END in_carpet;
PROCEDURE PrintSierpinski(n: INTEGER);
VAR
i, j, l: INTEGER;
BEGIN
l := pow(3, n) - 1;
FOR i := 0 TO l DO
FOR j := 0 TO l DO
IF in_carpet(i, j) THEN
Out.Char("#")
ELSE
Out.Char(" ")
END
END;
Out.Ln
END
END PrintSierpinski;
BEGIN
Console.open;
Out.String("Input carpet order(0..3):");
In.Int(order);
PrintSierpinski(order);
In.Ln;
Console.exit(TRUE)
END SierpinskiCarpet.

44
programs/develop/oberon07/Samples/Windows/Console/SierpinskiTriangle.ob07
View File

@ -1,44 +0,0 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
MODULE SierpinskiTriangle;
IMPORT In, Out, Console;
VAR
order: INTEGER;
PROCEDURE PrintSierpinski(order: INTEGER);
VAR
x, y, k, size: INTEGER;
BEGIN
size := LSL(1, order) - 1;
FOR y := size TO 0 BY -1 DO
FOR k := 1 TO y DO
Out.Char(" ")
END;
FOR x := 0 TO size - y DO
IF BITS(x) * BITS(y) = {} THEN
Out.String("* ")
ELSE
Out.String(" ")
END
END;
Out.Ln
END
END PrintSierpinski;
BEGIN
Console.open;
Out.String("Input triangle order(0..5):");
In.Int(order);
PrintSierpinski(order);
In.Ln;
Console.exit(TRUE)
END SierpinskiTriangle.

51
programs/develop/oberon07/Samples/Windows/Console/Sieve.ob07
View File

@ -1,51 +0,0 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(* This was taken from the CRITICAL MASS MODULA-3 examples *)
(* The "Sieve" program demonstrates the use of arrays,
loops and conditionals. *)
MODULE Sieve;
IMPORT In, Out, Console;
(* Search in interval 2 to 1000 for prime numbers. *)
CONST
LastNum = 1000;
(* "prime" is an array of booleans ranging from 2 to "LastNum". *)
VAR
prime: ARRAY LastNum + 2 OF BOOLEAN;
i, j: INTEGER;
BEGIN
Console.open;
Out.String("Primes in range 2.."); Out.Int(LastNum, 1); Out.Char(":"); Out.Ln;
(* Initialize all elements of the array to "TRUE".
(Note that we could have initialized the array during
the assignment.) *)
FOR i := 2 TO LastNum DO
prime[i] := TRUE
END;
(* Loop through all integers between 2 and "LastNum". Print each prime
number, starting from 2 and mark all numbers that are divisible by
that prime number to "FALSE". Repeat the step until we've exhausted
all the numbers in the interval.*)
FOR i := 2 TO LastNum DO
IF prime[i] THEN
Out.Int(i, 3);
Out.Char(" ");
FOR j := i TO LastNum DO
IF j MOD i = 0 THEN
prime[j] := FALSE
END
END
END
END;
Out.Ln; In.Ln;
Console.exit(TRUE)
END Sieve.

56
programs/develop/oberon07/Samples/Windows/Console/SpiralMatrix.ob07
View File

@ -1,56 +0,0 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(*
Produce a spiral array.
A spiral array is a square arrangement of the first (Width * Height) natural numbers,
where the numbers increase sequentially as you go around the edges of the array spiraling inwards.
*)
MODULE SpiralMatrix;
IMPORT In, Out, Console;
VAR
Width, Height: INTEGER;
PROCEDURE spiral(w, h, x, y: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF y # 0 THEN
res := w + spiral(h - 1, w, y - 1, w - x - 1)
ELSE
res := x
END
RETURN res
END spiral;
PROCEDURE print_spiral(w, h: INTEGER);
VAR
i, j: INTEGER;
BEGIN
FOR i := 0 TO h - 1 DO
FOR j := 0 TO w - 1 DO
Out.Int(spiral(w, h, j, i), 4)
END;
Out.Ln
END
END print_spiral;
BEGIN
Console.open;
Out.String("Input width of matrix(1, 2, 3, ...):"); In.Int(Width);
Out.String("Input height of matrix:(1, 2, 3, ...)"); In.Int(Height);
print_spiral(Width, Height);
In.Ln;
Console.exit(TRUE)
END SpiralMatrix.

44
programs/develop/oberon07/Samples/Windows/Console/TempConv.ob07
View File

@ -1,44 +0,0 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(* This program is a good example of proper formatting, it is *)
(* easy to read and very easy to understand. It should be a *)
(* snap to update a program that is well written like this. You *)
(* should begin to develop good formatting practice early in *)
(* your programming career. *)
MODULE TempConv;
IMPORT In, Out, Console;
VAR
Count : INTEGER; (* a variable used for counting *)
Centigrade : INTEGER; (* the temperature in centigrade *)
Farenheit : INTEGER; (* the temperature in farenheit *)
BEGIN
Console.open;
Out.String("Farenheit to Centigrade temperature table");
Out.Ln;
Out.Ln;
FOR Count := -2 TO 12 DO
Centigrade := 10 * Count;
Farenheit := 32 + Centigrade * 9 DIV 5;
Out.String(" C =");
Out.Int(Centigrade, 5);
Out.String(" F =");
Out.Int(Farenheit, 5);
IF Centigrade = 0 THEN
Out.String(" Freezing point of water");
END;
IF Centigrade = 100 THEN
Out.String(" Boiling point of water");
END;
Out.Ln;
END; (* of main loop *)
In.Ln;
Console.exit(TRUE)
END TempConv.

117
programs/develop/oberon07/Samples/Windows/Console/exp.ob07
View File

@ -1,117 +0,0 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(* Print first 'PRINT' digits of 'e'.
*
* Originally written in Pascal by Scott Hemphill
* Rewritten in Modula-2 and modified by Andrew Cadach
*
*)
MODULE exp;
IMPORT In, Out, Console;
CONST
PRINT = 1024;
DIGITS = PRINT + (PRINT + 31) DIV 32;
TYPE
number = ARRAY DIGITS + 1 OF INTEGER;
VAR
s, x: number;
xs, i: INTEGER;
PROCEDURE init (VAR x: number; n: INTEGER);
VAR
i: INTEGER;
BEGIN
x[0] := n;
FOR i := 1 TO DIGITS DO x[i] := 0 END
END init;
PROCEDURE divide (VAR x: number; xs, n: INTEGER;
VAR y: number; VAR ys: INTEGER);
VAR
i, c: INTEGER;
BEGIN
c := 0;
FOR i := xs TO DIGITS DO
c := 10 * c + x[i];
y[i] := c DIV n;
c := c MOD n
END;
ys := xs;
WHILE (ys <= DIGITS) & (y[ys] = 0) DO INC(ys) END
END divide;
PROCEDURE add (VAR s, x: number; xs: INTEGER);
VAR
i, c: INTEGER;
BEGIN
c := 0;
FOR i := DIGITS TO xs BY -1 DO
c := c + s[i] + x[i];
IF c >= 10 THEN
s[i] := c - 10;
c := 1
ELSE
s[i] := c;
c := 0
END
END;
i := xs;
WHILE c # 0 DO
DEC(i);
c := c + s[i];
IF c >= 10 THEN
s[i] := c - 10;
c := 1
ELSE
s[i] := c;
c := 0
END
END
END add;
BEGIN
Console.open;
init(s, 0);
init(x, 1);
xs := 0;
add(s, x, xs);
i := 0;
REPEAT
INC(i);
divide(x, xs, i, x, xs);
add(s, x, xs);
UNTIL xs > DIGITS;
Out.Ln;
Out.String (" e = ");
Out.Char (CHR(s[0] + ORD("0")));
Out.Char (".");
FOR i := 1 TO PRINT DO
Out.Char (CHR(s[i] + ORD("0")));
IF i MOD 64 = 0 THEN
Out.Ln;
Out.Int (i, 5);
Out.String (" ")
END
END;
Out.Ln;
Out.Ln;
In.Ln;
Console.exit(TRUE)
END exp.

59
programs/develop/oberon07/Samples/Windows/Console/fact.ob07
View File

@ -1,59 +0,0 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(*
* Written by Andrew Cadach
*
* Recursive (extremely uneficient:-) implementation of factorial
*
* n * (n-1)!, n <> 0
* By definition, n! =
* 1, n = 0
*
*)
MODULE fact;
IMPORT In, Out, Console;
CONST
MAX_INTEGER = ROR(-2, 1);
VAR
i, r: INTEGER;
PROCEDURE f (n: INTEGER): INTEGER;
VAR
Res: INTEGER;
BEGIN
IF n = 0 THEN
Res := 1
ELSE
Res := n * f (n - 1)
END
RETURN Res
END f;
BEGIN
Console.open;
i := 0;
REPEAT
r := f(i);
Out.String ("The factorial of ");
Out.Int (i, 2);
Out.String (" is ");
Out.Int (r, 0);
Out.Ln;
INC(i)
UNTIL r >= MAX_INTEGER DIV i;
In.Ln;
Console.exit(TRUE)
END fact.

117
programs/develop/oberon07/Samples/Windows/Console/hailst.ob07
View File

@ -1,117 +0,0 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(*
The Hailstone sequence of numbers can be generated
from a starting positive integer, n by:
IF n is 1 THEN the sequence ends.
IF n is even THEN the next n of the sequence = n / 2
IF n is odd THEN the next n of the sequence = (3 * n) + 1
The (unproven) Collatz conjecture is that the hailstone sequence
for any starting number always terminates.
*)
MODULE hailst;
IMPORT In, Out, API, Console;
CONST
maxCard = ROR(-2, 1) DIV 3;
List = 1;
Count = 2;
Max = 3;
VAR
a: INTEGER;
PROCEDURE HALT(code: INTEGER);
BEGIN
In.Ln; Console.exit(TRUE); API.exit(code)
END HALT;
PROCEDURE HailStone(start, _type: INTEGER): INTEGER;
VAR
n, max, count, res: INTEGER;
exit: BOOLEAN;
BEGIN
count := 1;
n := start;
max := n;
exit := FALSE;
WHILE exit # TRUE DO
IF _type = List THEN
Out.Int (n, 12);
IF count MOD 6 = 0 THEN Out.Ln END
END;
IF n # 1 THEN
IF ODD(n) THEN
IF n < maxCard THEN
n := 3 * n + 1;
IF n > max THEN max := n END
ELSE
Out.String("Exceeding max value for type INTEGER at:");
Out.Ln;
Out.String("n = "); Out.Int(start, 1);
Out.String(", count = "); Out.Int(count, 1);
Out.String(", intermediate value ");
Out.Int(n, 1);
Out.String(". Aborting.");
Out.Ln;
HALT(2)
END
ELSE
n := n DIV 2
END;
INC(count)
ELSE
exit := TRUE
END
END;
IF _type = Max THEN res := max ELSE res := count END
RETURN res
END HailStone;
PROCEDURE FindMax(num: INTEGER);
VAR
val, maxCount, maxVal, cnt: INTEGER;
BEGIN
maxCount := 0;
maxVal := 0;
FOR val := 2 TO num DO
cnt := HailStone(val, Count);
IF cnt > maxCount THEN
maxVal := val;
maxCount := cnt
END
END;
Out.String("Longest sequence below "); Out.Int(num, 1);
Out.String(" is "); Out.Int(HailStone(maxVal, Count), 1);
Out.String(" for n = "); Out.Int(maxVal, 1);
Out.String(" with an intermediate maximum of ");
Out.Int(HailStone(maxVal, Max), 1);
Out.Ln
END FindMax;
BEGIN
Console.open;
a := HailStone(27, List);
Out.Ln;
Out.String("Iterations total = "); Out.Int(HailStone(27, Count), 1);
Out.String(" max value = "); Out.Int(HailStone(27, Max), 1);
Out.Ln;
FindMax(100000);
Out.String("Done.");
Out.Ln; In.Ln;
Console.exit(TRUE)
END hailst.

123
programs/develop/oberon07/Samples/Windows/Console/postfix.ob07
View File

@ -1,123 +0,0 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(* Example program from Programming In Modula-2, N. Wirth., pg. 56, *)
(* - no WINDOWS in this example *)
(* this program translates a small language into postfix form
* the language is
*
* expression = term { [ "+" | "-" ] term }
*
* term = factor { [ "*" | "/" ] factor }
*
* factor = letter | "(" expression ")"
*
* letter = "a" | 'b" | … | "z"
*
* try as input
* a+b
* a*b+c
* a+b*c
* a*(b/(c-d))
*)
MODULE postfix;
IMPORT In, Out, Console;
CONST
OUT_LINE_SIZE = 80;
IN_LINE_SIZE = 80;
VAR
ch : CHAR;
i, index : INTEGER;
out_line : ARRAY OUT_LINE_SIZE OF CHAR;
in_line : ARRAY IN_LINE_SIZE OF CHAR;
cur_ch : INTEGER;
PROCEDURE NextChar(): CHAR;
BEGIN
INC(cur_ch)
RETURN in_line[cur_ch - 1]
END NextChar;
PROCEDURE expression;
VAR
addop :CHAR;
PROCEDURE term;
VAR
mulop :CHAR;
PROCEDURE factor;
BEGIN (* factor *)
IF ch = "(" THEN
ch := NextChar();
expression;
WHILE ch # ")" DO
ch := NextChar()
END (* WHILE *)
ELSE
WHILE (ch < "a") OR (ch > "z") DO
ch := NextChar()
END; (* WHILE *)
out_line[index] := ch;
index := index + 1
END; (* IF *)
ch := NextChar()
END factor;
BEGIN (* term *)
factor;
WHILE (ch = "*") OR (ch = "/") DO
mulop := ch;
ch := NextChar();
factor;
out_line[index] := mulop;
index := index + 1
END (* WHILE *)
END term;
BEGIN (* expression *)
term;
WHILE (ch = "+") OR (ch = "-") DO
addop := ch;
ch := NextChar();
term;
out_line[index] := addop;
index := index + 1
END (* WHILE *)
END expression;
BEGIN (* Postfix *)
Console.open;
index := 1; cur_ch := 0;
Out.String("Enter expression:");
In.String(in_line);
ch := NextChar();
WHILE ch > " " DO
expression;
FOR i := 1 TO index - 1 DO
Out.Char(out_line[i])
END; (* FOR *)
Out.Ln;
index := 1; cur_ch := 0;
Out.String("Enter expression:");
In.String(in_line);
ch := NextChar()
END; (* WHILE *)
Console.exit(TRUE)
END postfix.

79
programs/develop/oberon07/Samples/Windows/Console/sequence012.ob07
View File

@ -1,79 +0,0 @@
(*
adapted to Oberon-07 by 0CodErr, KolibriOS team
*)
(* Find sequence of digits 0, 1, 2 and of lengths 1 ... 90, such
that they contain no two adjacent subsequences that are equal *)
MODULE sequence012;
IMPORT In, Out, Console;
CONST
maxlength = 75;
VAR
n: INTEGER;
good: BOOLEAN;
s: ARRAY maxlength OF INTEGER;
PROCEDURE printsequence;
VAR
k: INTEGER;
BEGIN
Out.Char(" ");
FOR k := 1 TO n DO Out.Int(s[k], 1) END;
Out.Ln
END printsequence;
PROCEDURE changesequence;
BEGIN
IF s[n] = 3 THEN
DEC(n);
changesequence
ELSE
s[n] := s[n] + 1
END
END changesequence;
PROCEDURE try;
VAR
i, l, nhalf: INTEGER;
BEGIN
IF n <= 1 THEN
good := TRUE
ELSE
l := 0; nhalf := n DIV 2;
REPEAT
INC(l); i := 0;
REPEAT
good := s[n - i] # s[n - l - i];
INC(i)
UNTIL good OR (i = l)
UNTIL ~good OR (l >= nhalf)
END
END try;
BEGIN
Console.open;
n := 0;
REPEAT
INC(n);
s[n] := 1; try;
WHILE ~good DO
changesequence;
try
END;
printsequence
UNTIL n >= maxlength - 1;
In.Ln;
Console.exit(TRUE)
END sequence012.

2
programs/develop/oberon07/SelfKolibriOS.cmd Normal file
View File

@ -0,0 +1,2 @@
Compiler.exe source\Compiler.ob07 kosexe -out source\Compiler.kex -stk 2
@pause

61
programs/develop/oberon07/doc/CC.txt Normal file
View File

@ -0,0 +1,61 @@
Условная компиляция
синтаксис:
$IF "(" ident {"|" ident} ")"
<...>
{$ELSIF "(" ident {"|" ident} ")"}
<...>
[$ELSE]
<...>
$END
где ident:
- одно из возможных значений параметра <target> в командной строке
- пользовательский идентификатор, переданный с ключом -def при компиляции
- один из возможных предопределенных идентификаторов:
WINDOWS - приложение Windows
LINUX - приложение Linux
KOLIBRIOS - приложение KolibriOS
CPU_X86 - приложение для процессора x86 (32-бит)
CPU_X8664 - приложение для процессора x86_64
примеры:
$IF (win64con | win64gui | win64dll)
OS := "WIN64";
$ELSIF (win32con | win32gui | win32dll)
OS := "WIN32";
$ELSIF (linux64exe | linux64so)
OS := "LINUX64";
$ELSIF (linux32exe | linux32so)
OS := "LINUX32";
$ELSE
OS := "UNKNOWN";
$END
$IF (debug) (* -def debug *)
print("debug");
$END
$IF (WINDOWS)
$IF (CPU_X86)
(*windows 32*)
$ELSIF (CPU_X8664)
(*windows 64*)
$END
$ELSIF (LINUX)
$IF (CPU_X86)
(*linux 32*)
$ELSIF (CPU_X8664)
(*linux 64*)
$END
$END

0
programs/develop/oberon07/Docs/KOSLib.txt → programs/develop/oberon07/doc/KOSLib.txt
View File

0
programs/develop/oberon07/Docs/Oberon07.Report_2016_05_03.pdf → programs/develop/oberon07/doc/Oberon07.Report_2016_05_03.pdf
View File

0
programs/develop/oberon07/Docs/WinLib.txt → programs/develop/oberon07/doc/WinLib.txt
View File

91
programs/develop/oberon07/Docs/x86.txt → programs/develop/oberon07/doc/x86.txt
View File

@ -25,6 +25,9 @@ UTF-8 с BOM-сигнатурой.
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб,
допустимо от 1 до 32 Мб)
-nochk <"ptibcwra"> отключить проверки при выполнении (см. ниже)
-lower разрешить ключевые слова и встроенные идентификаторы в
нижнем регистре
-def <имя> задать символ условной компиляции
-ver <major.minor> версия программы (только для kosdll)
параметр -nochk задается в виде строки из символов:
@ -71,6 +74,10 @@ UTF-8 с BOM-сигнатурой.
9. Добавлен синтаксис для импорта процедур из внешних библиотек
10. "Строки" можно заключать также в одиночные кавычки: 'строка'
11. Добавлен тип WCHAR
12. Добавлена операция конкатенации строковых и символьных констант
13. Возможен импорт модулей с указанием пути и имени файла
14. Добавлен специальный синтаксис для условной компиляции (см. CC.txt)
15. Имя процедуры в конце объявления (после END) необязательно
------------------------------------------------------------------------------
Особенности реализации
@ -87,8 +94,8 @@ UTF-8 с BOM-сигнатурой.
BYTE 0 .. 255 1
WCHAR символ юникода (0X .. 0FFFFX) 2
2. Максимальная длина идентификаторов - 1024 символов
3. Максимальная длина строковых констант - 1024 символов (UTF-8)
2. Максимальная длина идентификаторов - 255 символов
3. Максимальная длина строковых констант - 511 символов (UTF-8)
4. Максимальная размерность открытых массивов - 5
5. Процедура NEW заполняет нулями выделенный блок памяти
6. Глобальные и локальные переменные инициализируются нулями
@ -137,25 +144,45 @@ UTF-8 с BOM-сигнатурой.
PROCEDURE INF(): REAL
возвращает специальное вещественное значение "бесконечность"
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
PROCEDURE GET8(a: INTEGER;
VAR x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 1)
PROCEDURE GET16(a: INTEGER;
VAR x: INTEGER, SET, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 2)
PROCEDURE GET32(a: INTEGER; VAR x: INTEGER, SET, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 4)
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
Память[a] := x;
Если x: BYTE или x: WCHAR, то значение x будет расширено
до 32 бит, для записи байтов использовать SYSTEM.PUT8,
для WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
PROCEDURE PUT8(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
PROCEDURE PUT16(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 16 бит (x)
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE PUT32(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 32 бит (x)
PROCEDURE COPY(VAR Source: любой тип; VAR Dest: любой тип; n: INTEGER)
Копирует n байт памяти из Source в Dest.
@ -168,6 +195,8 @@ UTF-8 с BOM-сигнатурой.
например:
SYSTEM.CODE(08BH, 045H, 008H) (* mov eax, dword [ebp + 08h] *)
Также, в модуле SYSTEM определен тип CARD32 (4 байта). Для типа CARD32 не
допускаются никакие явные операции, за исключением присваивания.
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях.
@ -176,15 +205,17 @@ UTF-8 с BOM-сигнатурой.
При объявлении процедурных типов и глобальных процедур, после ключевого
слова PROCEDURE может быть указан флаг соглашения о вызове: [stdcall],
[ccall], [ccall16], [windows], [linux]. Например:
[cdecl], [ccall], [windows], [linux], [oberon]. Например:
PROCEDURE [ccall] MyProc (x, y, z: INTEGER): INTEGER;
Если указан флаг [ccall16], то принимается соглашение ccall, но перед
Если указан флаг [ccall], то принимается соглашение cdecl, но перед
вызовом указатель стэка будет выравнен по границе 16 байт.
Флаг [windows] - синоним для [stdcall], [linux] - синоним для [ccall16].
Флаг [windows] - синоним для [stdcall], [linux] - синоним для [ccall].
Знак "-" после имени флага ([stdcall-], [linux-], ...) означает, что
результат процедуры можно игнорировать (не допускается для типа REAL).
Если флаг не указан или указан флаг [oberon], то принимается внутреннее
соглашение о вызове.
При объявлении типов-записей, после ключевого слова RECORD может быть
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей
@ -198,7 +229,7 @@ UTF-8 с BOM-сигнатурой.
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Сase {"|" Сase}
CASE Expression OF Case {"|" Case}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
@ -226,7 +257,16 @@ ARRAY OF WCHAR допускаются все те же операции, как
ARRAY OF CHAR, за исключением встроенной процедуры CHR, которая возвращает
только тип CHAR. Для получения значения типа WCHAR, следует использовать
процедуру WCHR вместо CHR. Для правильной работы с типом, необходимо сохранять
исходный код в кодировке UTF-8 c BOM.
исходный код в кодировке UTF-8 с BOM.
------------------------------------------------------------------------------
Конкатенация строковых и символьных констант
Допускается конкатенация ("+") константных строк и символов типа CHAR:
str = CHR(39) + "string" + CHR(39); (* str = "'string'" *)
newline = 0DX + 0AX;
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
@ -272,20 +312,30 @@ Oberon-реализациях выполнение такой операции
WCHR (n: INTEGER): WCHAR
Преобразование типа, аналогично CHR(n: INTEGER): CHAR
------------------------------------------------------------------------------
Импорт модулей с указанием пути и имени файла
Примеры:
IMPORT Math IN "./lib/math.ob07"; (* относительно текущего модуля *)
IMPORT M1 IN "C:\lib\math.ob07"; (* абсолютный путь *)
------------------------------------------------------------------------------
Импортированные процедуры
Синтаксис импорта:
PROCEDURE [callconv, "library", "function"] proc_name (FormalParam): Type;
PROCEDURE [callconv, library, function] proc_name (FormalParam): Type;
- callconv -- соглашение о вызове
- "library" -- имя файла динамической библиотеки
- "function" -- имя импортируемой процедуры
- library -- имя файла динамической библиотеки (строковая константа)
- function -- имя импортируемой процедуры (строковая константа), если
указана пустая строка, то имя процедуры = proc_name
например:
PROCEDURE [windows, "kernel32.dll", "ExitProcess"] exit (code: INTEGER);
PROCEDURE [windows, "kernel32.dll", ""] ExitProcess (code: INTEGER);
PROCEDURE [stdcall, "Console.obj", "con_exit"] exit (bCloseWindow: BOOLEAN);
@ -327,6 +377,8 @@ Oberon-реализациях выполнение такой операции
Вызов транслируется так:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
Скрытые параметры необходимо учитывать при связи с внешними приложениями.
------------------------------------------------------------------------------
Модуль RTL
@ -349,8 +401,11 @@ Oberon-реализациях выполнение такой операции
Разрешается экспортировать только процедуры. Для этого, процедура должна
находиться в главном модуле программы, и ее имя должно быть отмечено символом
экспорта ("*"). KolibriOS DLL всегда экспортируют идентификаторы "version"
(версия программы) и "lib_init" - адрес процедуры инициализации DLL:
экспорта ("*"). Нельзя экспортировать процедуры, которые импортированы из
других dll-библиотек.
KolibriOS DLL всегда экспортируют идентификаторы "version" (версия
программы) и "lib_init" - адрес процедуры инициализации DLL:
PROCEDURE [stdcall] lib_init (): INTEGER

92
programs/develop/oberon07/Docs/x86_64.txt → programs/develop/oberon07/doc/x86_64.txt
View File

@ -23,6 +23,9 @@ UTF-8 с BOM-сигнатурой.
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб,
допустимо от 1 до 32 Мб)
-nochk <"ptibcwra"> отключить проверки при выполнении
-lower разрешить ключевые слова и встроенные идентификаторы в
нижнем регистре
-def <имя> задать символ условной компиляции
параметр -nochk задается в виде строки из символов:
"p" - указатели
@ -63,6 +66,10 @@ UTF-8 с BOM-сигнатурой.
9. Добавлен синтаксис для импорта процедур из внешних библиотек
10. "Строки" можно заключать также в одиночные кавычки: 'строка'
11. Добавлен тип WCHAR
12. Добавлена операция конкатенации строковых и символьных констант
13. Возможен импорт модулей с указанием пути и имени файла
14. Добавлен специальный синтаксис для условной компиляции (см. CC.txt)
15. Имя процедуры в конце объявления (после END) необязательно
------------------------------------------------------------------------------
Особенности реализации
@ -79,8 +86,8 @@ UTF-8 с BOM-сигнатурой.
BYTE 0 .. 255 1
WCHAR символ юникода (0X .. 0FFFFX) 2
2. Максимальная длина идентификаторов - 1024 символов
3. Максимальная длина строковых констант - 1024 символов (UTF-8)
2. Максимальная длина идентификаторов - 255 символов
3. Максимальная длина строковых констант - 511 символов (UTF-8)
4. Максимальная размерность открытых массивов - 5
5. Процедура NEW заполняет нулями выделенный блок памяти
6. Глобальные и локальные переменные инициализируются нулями
@ -129,29 +136,46 @@ UTF-8 с BOM-сигнатурой.
PROCEDURE INF(): REAL
возвращает специальное вещественное значение "бесконечность"
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
PROCEDURE GET8(a: INTEGER;
VAR x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 1)
PROCEDURE GET16(a: INTEGER;
VAR x: INTEGER, SET, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 2)
PROCEDURE GET32(a: INTEGER; VAR x: INTEGER, SET, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 4)
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
Память[a] := x;
Если x: BYTE или x: WCHAR, то значение x будет расширено
до 64 бит, для записи байтов использовать SYSTEM.PUT8,
для WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
PROCEDURE PUT8(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
PROCEDURE PUT16(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 16 бит (x)
PROCEDURE PUT32(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
PROCEDURE PUT32(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 32 бит (x)
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE COPY(VAR Source: любой тип; VAR Dest: любой тип; n: INTEGER)
Копирует n байт памяти из Source в Dest.
Эквивалентно
@ -173,18 +197,19 @@ UTF-8 с BOM-сигнатурой.
Системные флаги
При объявлении процедурных типов и глобальных процедур, после ключевого
слова PROCEDURE может быть указан флаг соглашения о вызове: [win64], [systemv],
[windows], [linux].
слова PROCEDURE может быть указан флаг соглашения о вызове:
[win64], [systemv], [windows], [linux], [oberon], [ccall].
Например:
PROCEDURE [win64] MyProc (x, y, z: INTEGER): INTEGER;
Флаг [windows] - синоним для [win64], [linux] - синоним для [systemv].
Флаг [ccall] - синоним для [win64] или [systemv] (зависит от целевой ОС).
Знак "-" после имени флага ([win64-], [linux-], ...) означает, что
результат процедуры можно игнорировать (не допускается для типа REAL).
Если флаг не указан, то принимается внутреннее соглашение о вызове.
[win64] и [systemv] используются для связи с операционной системой и внешними
приложениями.
Если флаг не указан или указан флаг [oberon], то принимается внутреннее
соглашение о вызове. [win64] и [systemv] используются для связи с
операционной системой и внешними приложениями.
При объявлении типов-записей, после ключевого слова RECORD может быть
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей
@ -198,7 +223,7 @@ UTF-8 с BOM-сигнатурой.
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Сase {"|" Сase}
CASE Expression OF Case {"|" Case}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
@ -226,7 +251,16 @@ ARRAY OF WCHAR допускаются все те же операции, как
ARRAY OF CHAR, за исключением встроенной процедуры CHR, которая возвращает
только тип CHAR. Для получения значения типа WCHAR, следует использовать
процедуру WCHR вместо CHR. Для правильной работы с типом, необходимо сохранять
исходный код в кодировке UTF-8 c BOM.
исходный код в кодировке UTF-8 с BOM.
------------------------------------------------------------------------------
Конкатенация строковых и символьных констант
Допускается конкатенация ("+") константных строк и символов типа CHAR:
str = CHR(39) + "string" + CHR(39); (* str = "'string'" *)
newline = 0DX + 0AX;
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
@ -272,21 +306,32 @@ Oberon-реализациях выполнение такой операции
WCHR (n: INTEGER): WCHAR
Преобразование типа, аналогично CHR(n: INTEGER): CHAR
------------------------------------------------------------------------------
Импорт модулей с указанием пути и имени файла
Примеры:
IMPORT Math IN "./lib/math.ob07"; (* относительно текущего модуля *)
IMPORT M1 IN "C:\lib\math.ob07"; (* абсолютный путь *)
------------------------------------------------------------------------------
Импортированные процедуры
Синтаксис импорта:
PROCEDURE [callconv, "library", "function"] proc_name (FormalParam): Type;
PROCEDURE [callconv, library, function] proc_name (FormalParam): Type;
- callconv -- соглашение о вызове
- "library" -- имя файла динамической библиотеки
- "function" -- имя импортируемой процедуры
- library -- имя файла динамической библиотеки (строковая константа)
- function -- имя импортируемой процедуры (строковая константа), если
указана пустая строка, то имя процедуры = proc_name
например:
PROCEDURE [win64, "kernel32.dll", "ExitProcess"] exit (code: INTEGER);
PROCEDURE [windows, "kernel32.dll", "ExitProcess"] exit (code: INTEGER);
PROCEDURE [windows, "kernel32.dll", ""] GetTickCount (): INTEGER;
В конце объявления может быть добавлено (необязательно) "END proc_name;"
@ -301,7 +346,7 @@ Oberon-реализациях выполнение такой операции
соглашения о вызове:
VAR
ExitProcess: PROCEDURE [win64] (code: INTEGER);
ExitProcess: PROCEDURE [windows] (code: INTEGER);
Для Linux, импортированные процедуры не реализованы.
@ -321,6 +366,8 @@ Oberon-реализациях выполнение такой операции
Вызов транслируется так:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
Скрытые параметры необходимо учитывать при связи с внешними приложениями.
------------------------------------------------------------------------------
Модуль RTL
@ -343,4 +390,5 @@ Oberon-реализациях выполнение такой операции
Разрешается экспортировать только процедуры. Для этого, процедура должна
находиться в главном модуле программы, ее имя должно быть отмечено символом
экспорта ("*") и должно быть указано соглашение о вызове.
экспорта ("*") и должно быть указано соглашение о вызове. Нельзя
экспортировать процедуры, которые импортированы из других dll-библиотек.

3
programs/develop/oberon07/Lib/KolibriOS/API.ob07 → programs/develop/oberon07/lib/KolibriOS/API.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, 2020, Anton Krotov
Copyright (c) 2018, 2020-2021, Anton Krotov
All rights reserved.
*)
@ -13,6 +13,7 @@ IMPORT SYSTEM, K := KOSAPI;
CONST
eol* = 0DX + 0AX;
BIT_DEPTH* = 32;
MAX_SIZE = 16 * 400H;
HEAP_SIZE = 1 * 100000H;

0
programs/develop/oberon07/Lib/KolibriOS/Args.ob07 → programs/develop/oberon07/lib/KolibriOS/Args.ob07
View File

0
programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07 → programs/develop/oberon07/lib/KolibriOS/ColorDlg.ob07
View File

0
programs/develop/oberon07/Lib/KolibriOS/Console.ob07 → programs/develop/oberon07/lib/KolibriOS/Console.ob07
View File

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