forked from KolibriOS/kolibrios
update Oberon07 and CEDIT by akron1
git-svn-id: svn://kolibrios.org@8859 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
Leency committed
1 parent
f3f40df401
commit
498da3221e
178 files changed
+5878
-14432
No files matched your search
Binary file not shown.
@@ -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, "", {});
|
||||
|
||||
@@ -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.
|
||||
Binary file not shown.
Binary file not shown.
@@ -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
|
||||
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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 / Дополнительные модули)
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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!
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -1,13 +0,0 @@
|
||||
MODULE Hello;
|
||||
|
||||
IMPORT Console, In, Out;
|
||||
|
||||
|
||||
BEGIN
|
||||
Console.open;
|
||||
|
||||
Out.String("Hello, world!");
|
||||
In.Ln;
|
||||
|
||||
Console.exit(TRUE)
|
||||
END Hello.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
@@ -0,0 +1,2 @@
|
||||
Compiler.exe source\Compiler.ob07 kosexe -out source\Compiler.kex -stk 2
|
||||
@pause
|
||||
@@ -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
|
||||
File renamed without changes.
File renamed without changes.
File renamed without changes.
@@ -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
|
||||
|
||||
+70
-22
@@ -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-библиотек.
|
||||
+2
-1
@@ -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;
|
||||
File renamed without changes.
File renamed without changes.
File renamed without changes.
Loaded 100 of 178 files, more files were not shown because too many files have changed in this diff.
Show more
Reference in new issue
Block a user