BlueGreycalmElegant

Català-Valencià – Catalan中文 – Chinese (Simplified)中文 – Chinese (Traditional)Česky – CzechDansk – DanishNederlands – DutchEnglish – EnglishSuomi – FinnishFrançais – FrenchDeutsch – Germanעברית – Hebrewहिंदी – HindiMagyar – HungarianBahasa Indonesia – IndonesianItaliano – Italian日本語 – Japanese한국어 – KoreanМакедонски – Macedonianमराठी – MarathiNorsk – NorwegianPolski – PolishPortuguês – PortuguesePortuguês – Portuguese (Brazil)Русский – RussianSlovenčina – SlovakSlovenščina – SlovenianEspañol – SpanishSvenska – SwedishTürkçe – TurkishУкраїнська – UkrainianOëzbekcha – Uzbek

Compare Revisions

• This comparison shows the changes necessary to convert path

  → /programs/develop/oberon07/Lib/ @ 6612

  → /programs/develop/oberon07/Lib/ @ 6613

  ↔ Reverse comparison

• Compare Path:	Rev

  With Path:	Rev

Regard whitespace Rev 6612 → Rev 6613

/programs/develop/oberon07/Lib/KolibriOS/API.ob07
0,0 → 1,193
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE API;
IMPORT sys := SYSTEM;
CONST
MAX_SIZE = 16 * 400H;
HEAP_SIZE = 1 * 100000H;
VAR
heap, endheap: INTEGER;
pockets: ARRAY MAX_SIZE DIV 32 + 1 OF INTEGER;
PROCEDURE [stdcall] zeromem*(size, adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
PROCEDURE strncmp*(a, b, n: INTEGER): INTEGER;
VAR A, B: CHAR; Res: INTEGER;
BEGIN
Res := 0;
WHILE n > 0 DO
sys.GET(a, A); INC(a);
sys.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
Res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN Res
END strncmp;
PROCEDURE [stdcall] sysfunc1(arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall] sysfunc2(arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall] sysfunc3(arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
PROCEDURE _NEW*(size: INTEGER): INTEGER;
VAR res, idx, temp: INTEGER;
BEGIN
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
res := pockets[idx];
IF res # 0 THEN
sys.GET(res, pockets[idx]);
sys.PUT(res, size);
INC(res, 4)
ELSE
IF heap + size >= endheap THEN
IF sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
heap := sysfunc3(68, 12, HEAP_SIZE);
endheap := heap + HEAP_SIZE
ELSE
heap := 0
END
END;
IF heap # 0 THEN
sys.PUT(heap, size);
res := heap + 4;
heap := heap + size
ELSE
endheap := 0;
res := 0
END
END
ELSE
IF sysfunc2(18, 16) > ASR(size, 10) THEN
res := sysfunc3(68, 12, size);
sys.PUT(res, size);
INC(res, 4)
ELSE
res := 0
END
END;
IF res # 0 THEN
zeromem(ASR(size, 2) - 1, res)
END
RETURN res
END _NEW;
PROCEDURE _DISPOSE*(ptr: INTEGER): INTEGER;
VAR size, idx: INTEGER;
BEGIN
DEC(ptr, 4);
sys.GET(ptr, size);
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
sys.PUT(ptr, pockets[idx]);
pockets[idx] := ptr
ELSE
size := sysfunc3(68, 13, ptr)
END
RETURN 0
END _DISPOSE;
PROCEDURE ExitProcess*(p1: INTEGER);
BEGIN
p1 := sysfunc1(-1)
END ExitProcess;
PROCEDURE OutChar(c: CHAR);
VAR res: INTEGER;
BEGIN
res := sysfunc3(63, 1, ORD(c))
END OutChar;
PROCEDURE DebugMsg*(lpText, lpCaption: INTEGER);
VAR c: CHAR;
BEGIN
IF lpCaption # 0 THEN
OutChar(0DX);
OutChar(0AX);
REPEAT
sys.GET(lpCaption, c);
IF c # 0X THEN
OutChar(c)
END;
INC(lpCaption)
UNTIL c = 0X;
OutChar(":");
OutChar(0DX);
OutChar(0AX)
END;
REPEAT
sys.GET(lpText, c);
IF c # 0X THEN
OutChar(c)
END;
INC(lpText)
UNTIL c = 0X;
IF lpCaption # 0 THEN
OutChar(0DX);
OutChar(0AX)
END
END DebugMsg;
PROCEDURE init* (p1: INTEGER);
BEGIN
p1 := sysfunc2(68, 11)
END init;
END API.

/programs/develop/oberon07/Lib/KolibriOS/Args.ob07
0,0 → 1,100
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Args;
IMPORT sys := SYSTEM, KOSAPI;
CONST
MAX_PARAM = 1024;
VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
PROCEDURE GetChar(adr: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR p, count, name: INTEGER; c: CHAR; cond: INTEGER;
PROCEDURE ChangeCond(A, B, C: INTEGER);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
cond := C
END
END ChangeCond;
BEGIN
p := KOSAPI.GetCommandLine();
name := KOSAPI.GetName();
Params[0, 0] := name;
WHILE GetChar(name) # 0X DO
INC(name)
END;
Params[0, 1] := name - 1;
cond := 0;
count := 1;
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE GetArg*(n: INTEGER; VAR s: ARRAY OF CHAR);
VAR i, j, len: INTEGER; c: CHAR;
BEGIN
j := 0;
IF n < argc + 1 THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i);
END;
END;
s[j] := 0X
END GetArg;
BEGIN
ParamParse
END Args.

/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07
0,0 → 1,105
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE ColorDlg;
IMPORT sys := SYSTEM, KOSAPI;
TYPE
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
type,
procinfo,
com_area_name,
com_area,
start_path: INTEGER;
draw_window: DRAW_WINDOW;
status*,
X, Y,
color_type,
color*: INTEGER;
procinf: ARRAY 1024 OF CHAR;
s_com_area_name: ARRAY 32 OF CHAR
END;
Dialog* = POINTER TO TDialog;
VAR
Dialog_start, Dialog_init: PROCEDURE [stdcall] (cd: Dialog);
PROCEDURE Show*(cd: Dialog);
BEGIN
IF cd # NIL THEN
cd.X := 0;
cd.Y := 0;
Dialog_start(cd)
END
END Show;
PROCEDURE Create*(draw_window: DRAW_WINDOW): Dialog;
VAR res: Dialog;
BEGIN
NEW(res);
IF res # NIL THEN
res.s_com_area_name := "FFFFFFFF_color_dlg";
res.com_area := 0;
res.type := 0;
res.color_type := 0;
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.ADR("/rd/1/colrdial");
res.draw_window := draw_window;
res.status := 0;
res.X := 0;
res.Y := 0;
res.color := 0;
Dialog_init(res)
END
RETURN res
END Create;
PROCEDURE Destroy*(VAR cd: Dialog);
BEGIN
IF cd # NIL THEN
DISPOSE(cd)
END
END Destroy;
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(sys.ADR(Dialog_init), "ColorDialog_init");
GetProc(sys.ADR(Dialog_start), "ColorDialog_start");
END Load;
BEGIN
Load
END ColorDlg.

/programs/develop/oberon07/Lib/KolibriOS/Console.ob07
0,0 → 1,66
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Console;
IMPORT ConsoleLib;
CONST
Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3;
Red* = 4; Magenta* = 5; Brown* = 6; LightGray* = 7;
DarkGray* = 8; LightBlue* = 9; LightGreen* = 10; LightCyan* = 11;
LightRed* = 12; LightMagenta* = 13; Yellow* = 14; White* = 15;
PROCEDURE SetCursor*(X, Y: INTEGER);
BEGIN
ConsoleLib.set_cursor_pos(X, Y)
END SetCursor;
PROCEDURE GetCursor*(VAR X, Y: INTEGER);
BEGIN
ConsoleLib.get_cursor_pos(X, Y)
END GetCursor;
PROCEDURE Cls*;
BEGIN
ConsoleLib.cls
END Cls;
PROCEDURE SetColor*(FColor, BColor: INTEGER);
VAR res: INTEGER;
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
res := ConsoleLib.set_flags(LSL(BColor, 4) + FColor)
END
END SetColor;
PROCEDURE GetCursorX*(): INTEGER;
VAR x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN x
END GetCursorX;
PROCEDURE GetCursorY*(): INTEGER;
VAR x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN y
END GetCursorY;
END Console.

/programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07
0,0 → 1,101
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE ConsoleLib;
IMPORT sys := SYSTEM, KOSAPI;
CONST
COLOR_BLUE* = 001H;
COLOR_GREEN* = 002H;
COLOR_RED* = 004H;
COLOR_BRIGHT* = 008H;
BGR_BLUE* = 010H;
BGR_GREEN* = 020H;
BGR_RED* = 040H;
BGR_BRIGHT* = 080H;
IGNORE_SPECIALS* = 100H;
WINDOW_CLOSED* = 200H;
TYPE
gets2_callback* = PROCEDURE [stdcall] (keycode: INTEGER; pstr: INTEGER; VAR n, pos: INTEGER);
VAR
version* : INTEGER;
init* : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
exit* : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
write_asciiz* : PROCEDURE [stdcall] (string: INTEGER);
write_string* : PROCEDURE [stdcall] (string, length: INTEGER);
get_flags* : PROCEDURE [stdcall] (): INTEGER;
set_flags* : PROCEDURE [stdcall] (new_flags: INTEGER): INTEGER;
get_font_height* : PROCEDURE [stdcall] (): INTEGER;
get_cursor_height* : PROCEDURE [stdcall] (): INTEGER;
set_cursor_height* : PROCEDURE [stdcall] (new_height: INTEGER): INTEGER;
getch* : PROCEDURE [stdcall] (): INTEGER;
getch2* : PROCEDURE [stdcall] (): INTEGER;
kbhit* : PROCEDURE [stdcall] (): INTEGER;
gets* : PROCEDURE [stdcall] (str, n: INTEGER): INTEGER;
gets2* : PROCEDURE [stdcall] (callback: gets2_callback; str, n: INTEGER): INTEGER;
cls* : PROCEDURE [stdcall] ();
get_cursor_pos* : PROCEDURE [stdcall] (VAR x, y: INTEGER);
set_cursor_pos* : PROCEDURE [stdcall] (x, y: INTEGER);
PROCEDURE open*(wnd_width, wnd_height, scr_width, scr_height: INTEGER; title: ARRAY OF CHAR);
BEGIN
init(wnd_width, wnd_height, scr_width, scr_height, sys.ADR(title[0]))
END open;
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/Console.obj");
ASSERT(Lib # 0);
GetProc(sys.ADR(version), "version");
GetProc(sys.ADR(init), "con_init");
GetProc(sys.ADR(exit), "con_exit");
GetProc(sys.ADR(write_asciiz), "con_write_asciiz");
GetProc(sys.ADR(write_string), "con_write_string");
GetProc(sys.ADR(get_flags), "con_get_flags");
GetProc(sys.ADR(set_flags), "con_set_flags");
GetProc(sys.ADR(get_font_height), "con_get_font_height");
GetProc(sys.ADR(get_cursor_height), "con_get_cursor_height");
GetProc(sys.ADR(set_cursor_height), "con_set_cursor_height");
GetProc(sys.ADR(getch), "con_getch");
GetProc(sys.ADR(getch2), "con_getch2");
GetProc(sys.ADR(kbhit), "con_kbhit");
GetProc(sys.ADR(gets), "con_gets");
GetProc(sys.ADR(gets2), "con_gets2");
GetProc(sys.ADR(cls), "con_cls");
GetProc(sys.ADR(get_cursor_pos), "con_get_cursor_pos");
GetProc(sys.ADR(set_cursor_pos), "con_set_cursor_pos");
END main;
BEGIN
main
END ConsoleLib.

/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07
0,0 → 1,140
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE DateTime;
IMPORT KOSAPI;
CONST ERR* = -7.0D5;
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL;
VAR d, i: INTEGER; M: ARRAY 13 OF CHAR; Res: LONGREAL;
BEGIN
Res := ERR;
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) &
(Day >= 1) & (Day <= 31) & (Hour >= 0) & (Hour <= 23) &
(Min >= 0) & (Min <= 59) & (Sec >= 0) & (Sec <= 59) THEN
M := "_303232332323";
IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN
M[2] := "1"
END;
IF Day <= ORD(M[Month]) - ORD("0") + 28 THEN
DEC(Year);
d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) + Day - 693594;
FOR i := 1 TO Month - 1 DO
d := d + ORD(M[i]) - ORD("0") + 28
END;
Res := LONG(FLT(d)) + LONG(FLT(Hour * 3600000 + Min * 60000 + Sec * 1000)) / 86400000.0D0
END
END
RETURN Res
END Encode;
PROCEDURE Decode*(Date: LONGREAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN;
VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 13 OF CHAR;
PROCEDURE MonthDay(n: INTEGER): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
Res := FALSE;
IF d > ORD(M[n]) - ORD("0") + 28 THEN
d := d - ORD(M[n]) + ORD("0") - 28;
INC(Month);
Res := TRUE
END
RETURN Res
END MonthDay;
BEGIN
IF (Date >= -693593.0D0) & (Date < 2958466.0D0) THEN
d := FLOOR(Date);
t := FLOOR((Date - LONG(FLT(d))) * 86400000.0D0);
d := d + 693593;
Year := 1;
Month := 1;
WHILE d > 0 DO
d := d - 365 - ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0));
INC(Year)
END;
IF d < 0 THEN
DEC(Year);
d := d + 365 + ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0))
END;
INC(d);
M := "_303232332323";
IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN
M[2] := "1"
END;
i := 1;
flag := TRUE;
WHILE flag & (i <= 12) DO
flag := MonthDay(i);
INC(i)
END;
Day := d;
Hour := t DIV 3600000;
t := t MOD 3600000;
Min := t DIV 60000;
t := t MOD 60000;
Sec := t DIV 1000;
Res := TRUE
ELSE
Res := FALSE
END
RETURN Res
END Decode;
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec: INTEGER);
VAR date, time: INTEGER;
BEGIN
date := KOSAPI.sysfunc1(29);
time := KOSAPI.sysfunc1(3);
Year := date MOD 16;
date := date DIV 16;
Year := (date MOD 16) * 10 + Year;
date := date DIV 16;
Month := date MOD 16;
date := date DIV 16;
Month := (date MOD 16) * 10 + Month;
date := date DIV 16;
Day := date MOD 16;
date := date DIV 16;
Day := (date MOD 16) * 10 + Day;
date := date DIV 16;
Hour := time MOD 16;
time := time DIV 16;
Hour := (time MOD 16) * 10 + Hour;
time := time DIV 16;
Min := time MOD 16;
time := time DIV 16;
Min := (time MOD 16) * 10 + Min;
time := time DIV 16;
Sec := time MOD 16;
time := time DIV 16;
Sec := (time MOD 16) * 10 + Sec;
time := time DIV 16;
Year := Year + 2000
END Now;
END DateTime.

/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07
0,0 → 1,287
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Debug;
IMPORT KOSAPI, sys := SYSTEM;
CONST
d = 1.0D0 - 5.0D-12;
VAR
Realp: PROCEDURE (x: LONGREAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
VAR res: INTEGER;
BEGIN
res := KOSAPI.sysfunc3(63, 1, ORD(c))
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR n, i: INTEGER;
BEGIN
n := LENGTH(s);
FOR i := 0 TO n - 1 DO
Char(s[i])
END
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
sys.GET(sys.ADR(AValue) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
PROCEDURE OutInf(x: LONGREAL; width: INTEGER);
VAR s: ARRAY 4 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0D0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0D0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0D0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0D0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0D0) & (y # 0.0D0) DO
y := y * 10.0D0;
DEC(e)
END;
IF e < 0 THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char("1");
x := 0.0D0
ELSE
Char("0");
x := x * 10.0D0
END
ELSE
WHILE e >= 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x > 9.0D0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(p)
END
END
END FixReal;
PROCEDURE Real*(x: LONGREAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0D0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
WHILE (x < 1.0D0) & (x # 0.0D0) DO
x := x * 10.0D0;
DEC(e)
END;
IF x > 9.0D0 + d THEN
x := 1.0D0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE Open*;
TYPE
info_struct = RECORD
subfunc: INTEGER;
flags: INTEGER;
param: INTEGER;
rsrvd1: INTEGER;
rsrvd2: INTEGER;
fname: ARRAY 1024 OF CHAR
END;
VAR info: info_struct; res: INTEGER;
BEGIN
info.subfunc := 7;
info.flags := 0;
info.param := sys.ADR(" ");
info.rsrvd1 := 0;
info.rsrvd2 := 0;
info.fname := "/rd/1/develop/board";
res := KOSAPI.sysfunc2(70, sys.ADR(info))
END Open;
BEGIN
Realp := Real
END Debug.

/programs/develop/oberon07/Lib/KolibriOS/File.ob07
0,0 → 1,255
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE File;
IMPORT sys := SYSTEM, KOSAPI;
CONST
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
TYPE
FNAME* = ARRAY 520 OF CHAR;
FS* = POINTER TO rFS;
rFS* = RECORD
subfunc*, pos*, hpos*, bytes*, buffer*: INTEGER;
name*: FNAME
END;
FD* = POINTER TO rFD;
rFD* = RECORD
attr*: INTEGER;
ntyp*: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create*, date_create*,
time_access*, date_access*,
time_modif*, date_modif*,
size*, hsize*: INTEGER;
name*: FNAME
END;
PROCEDURE [stdcall] f_68_27(file_name: INTEGER; VAR size: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("6A44"); (* push 68 *)
sys.CODE("58"); (* pop eax *)
sys.CODE("6A1B"); (* push 27 *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("8B4D08"); (* mov ecx, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D0C"); (* mov ecx, [ebp + 0Ch] *)
sys.CODE("8911"); (* mov [ecx], edx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END f_68_27;
PROCEDURE Load*(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
RETURN f_68_27(sys.ADR(FName[0]), size)
END Load;
PROCEDURE GetFileInfo*(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR res2: INTEGER; fs: rFS;
BEGIN
fs.subfunc := 5;
fs.pos := 0;
fs.hpos := 0;
fs.bytes := 0;
fs.buffer := sys.ADR(Info);
COPY(FName, fs.name)
RETURN KOSAPI.sysfunc22(70, sys.ADR(fs), res2) = 0
END GetFileInfo;
PROCEDURE Exists*(FName: ARRAY OF CHAR): BOOLEAN;
VAR fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
END Exists;
PROCEDURE Close*(VAR F: FS);
BEGIN
IF F # NIL THEN
DISPOSE(F)
END
END Close;
PROCEDURE Open*(FName: ARRAY OF CHAR): FS;
VAR F: FS;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 0;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name)
END
ELSE
F := NIL
END
RETURN F
END Open;
PROCEDURE Delete*(FName: ARRAY OF CHAR): BOOLEAN;
VAR F: FS; res, res2: INTEGER;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 8;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
ELSE
res := -1
END
RETURN res = 0
END Delete;
PROCEDURE Seek*(F: FS; Offset, Origin: INTEGER): INTEGER;
VAR res: INTEGER; fd: rFD;
BEGIN
IF (F # NIL) & GetFileInfo(F.name, fd) & (BITS(fd.attr) * {4} = {}) THEN
CASE Origin OF
|SEEK_BEG: F.pos := Offset
|SEEK_CUR: F.pos := F.pos + Offset
|SEEK_END: F.pos := fd.size + Offset
ELSE
END;
res := F.pos
ELSE
res := -1
END
RETURN res
END Seek;
PROCEDURE Read*(F: FS; Buffer, Count: INTEGER): INTEGER;
VAR res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 0;
F.bytes := Count;
F.buffer := Buffer;
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Read;
PROCEDURE Write*(F: FS; Buffer, Count: INTEGER): INTEGER;
VAR res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 3;
F.bytes := Count;
F.buffer := Buffer;
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Write;
PROCEDURE Create*(FName: ARRAY OF CHAR): FS;
VAR F: FS; res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 2;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
IF KOSAPI.sysfunc22(70, sys.ADR(F^), res2) # 0 THEN
DISPOSE(F)
END
END
RETURN F
END Create;
PROCEDURE DirExists*(FName: ARRAY OF CHAR): BOOLEAN;
VAR fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & (4 IN BITS(fd.attr))
END DirExists;
PROCEDURE CreateDir*(DirName: ARRAY OF CHAR): BOOLEAN;
VAR F: FS; res, res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 9;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(DirName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
RETURN res = 0
END CreateDir;
PROCEDURE DeleteDir*(DirName: ARRAY OF CHAR): BOOLEAN;
VAR F: FS; res, res2: INTEGER;
BEGIN
IF DirExists(DirName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 8;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(DirName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
ELSE
res := -1
END
RETURN res = 0
END DeleteDir;
END File.

/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07
0,0 → 1,270
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
CONST
OS* = "KOS";
Slash* = "/";
TYPE
FILENAME = ARRAY 2048 OF CHAR;
OFSTRUCT = RECORD
subfunc, pos, hpos, bytes, buf: INTEGER;
name: FILENAME
END;
VAR
con_init : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
con_exit : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
con_write_asciiz : PROCEDURE [stdcall] (string: INTEGER);
fsize, sec*, dsec*: INTEGER;
PROCEDURE [stdcall] sysfunc1(arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall] sysfunc2(arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall] sysfunc3(arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall] sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8919"); (* mov [ecx], ebx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc22;
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR cur, procname, adr: INTEGER;
PROCEDURE streq(str1, str2: INTEGER): BOOLEAN;
VAR c1, c2: CHAR;
BEGIN
REPEAT
sys.GET(str1, c1);
sys.GET(str2, c2);
INC(str1);
INC(str2)
UNTIL (c1 # c2) OR (c1 = 0X)
RETURN c1 = c2
END streq;
BEGIN
adr := 0;
IF (lib # 0) & (name # "") THEN
cur := lib;
REPEAT
sys.GET(cur, procname);
INC(cur, 8)
UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0]));
IF procname # 0 THEN
sys.GET(cur - 4, adr)
END
END
RETURN adr
END GetProcAdr;
PROCEDURE Time*(VAR sec, dsec: INTEGER);
VAR t: INTEGER;
BEGIN
t := sysfunc2(26, 9);
sec := t DIV 100;
dsec := t MOD 100
END Time;
PROCEDURE init*;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := GetProcAdr(name, Lib);
sys.PUT(v, a)
END GetProc;
BEGIN
Time(sec, dsec);
Lib := sysfunc3(68, 19, sys.ADR("/rd/1/lib/console.obj"));
IF Lib # 0 THEN
GetProc(sys.ADR(con_init), "con_init");
GetProc(sys.ADR(con_exit), "con_exit");
GetProc(sys.ADR(con_write_asciiz), "con_write_asciiz");
IF con_init # NIL THEN
con_init(-1, -1, -1, -1, sys.ADR("Oberon-07/11 for KolibriOS"))
END
END
END init;
PROCEDURE ExitProcess* (n: INTEGER);
BEGIN
IF con_exit # NIL THEN
con_exit(FALSE)
END;
n := sysfunc1(-1)
END ExitProcess;
PROCEDURE GetCommandLine*(): INTEGER;
VAR param: INTEGER;
BEGIN
sys.GET(28, param)
RETURN param
END GetCommandLine;
PROCEDURE GetName*(): INTEGER;
VAR name: INTEGER;
BEGIN
sys.GET(32, name)
RETURN name
END GetName;
PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN sysfunc3(68, 12, size)
END malloc;
PROCEDURE CloseFile*(hObject: INTEGER);
VAR pFS: POINTER TO OFSTRUCT;
BEGIN
sys.PUT(sys.ADR(pFS), hObject);
DISPOSE(pFS)
END CloseFile;
PROCEDURE _OCFile(FileName: ARRAY OF CHAR; VAR FS: OFSTRUCT; mode: INTEGER; VAR fsize: INTEGER): INTEGER;
VAR buf: ARRAY 40 OF CHAR; res: INTEGER;
BEGIN
FS.subfunc := mode;
FS.pos := 0;
FS.hpos := 0;
FS.bytes := 0;
FS.buf := sys.ADR(buf);
COPY(FileName, FS.name);
IF sysfunc22(70, sys.ADR(FS), res) = 0 THEN
res := sys.ADR(FS);
sys.GET(sys.ADR(buf) + 32, fsize)
ELSE
res := 0
END
RETURN res
END _OCFile;
PROCEDURE IOFile(VAR FS: OFSTRUCT; Buffer, bytes, io: INTEGER): INTEGER;
VAR res1, res: INTEGER;
BEGIN
FS.subfunc := io;
FS.bytes := bytes;
FS.buf := Buffer;
res1 := sysfunc22(70, sys.ADR(FS), res);
IF res = -1 THEN
res := 0
END;
FS.pos := FS.pos + res
RETURN res
END IOFile;
PROCEDURE OCFile(FName: ARRAY OF CHAR; mode: INTEGER): INTEGER;
VAR FS: OFSTRUCT; pFS: POINTER TO OFSTRUCT; res: INTEGER;
BEGIN
IF _OCFile(FName, FS, mode, fsize) # 0 THEN
NEW(pFS);
IF pFS = NIL THEN
res := 0
ELSE
sys.GET(sys.ADR(pFS), res);
pFS^ := FS
END
ELSE
res := 0
END
RETURN res
END OCFile;
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN OCFile(FName, 2)
END CreateFile;
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN OCFile(FName, 5)
END OpenFile;
PROCEDURE FileSize* (F: INTEGER): INTEGER;
RETURN fsize
END FileSize;
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR pFS: POINTER TO OFSTRUCT; res: INTEGER;
BEGIN
IF hFile # 0 THEN
sys.PUT(sys.ADR(pFS), hFile);
res := IOFile(pFS^, Buffer, nNumberOfBytes, 3 * ORD(write))
ELSE
res := 0
END
RETURN res
END FileRW;
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR n: INTEGER;
BEGIN
n := ORD(str[0] = 3X);
IF con_write_asciiz # NIL THEN
con_write_asciiz(sys.ADR(str[n]))
ELSE
API.DebugMsg(sys.ADR(str[n]), 0)
END
END OutString;
END HOST.

/programs/develop/oberon07/Lib/KolibriOS/In.ob07
0,0 → 1,296
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE In;
IMPORT sys := SYSTEM, ConsoleLib;
TYPE
STRING = ARRAY 260 OF CHAR;
VAR
Done* : BOOLEAN;
PROCEDURE digit(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END digit;
PROCEDURE CheckInt(s: STRING; VAR first, last: INTEGER; VAR neg: BOOLEAN; Point: BOOLEAN): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
neg := FALSE;
WHILE (s[i] <= 20X) & (s[i] # 0X) DO
INC(i)
END;
IF s[i] = "-" THEN
neg := TRUE;
INC(i)
ELSIF s[i] = "+" THEN
INC(i)
END;
first := i;
WHILE digit(s[i]) DO
INC(i)
END;
last := i
RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first])
END CheckInt;
PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN;
VAR i: INTEGER; min: STRING;
BEGIN
i := 0;
min := "2147483648";
WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO
INC(i)
END
RETURN i = 10
END IsMinInt;
PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER;
CONST maxINT = 7FFFFFFFH;
VAR i, n, res: INTEGER; flag, neg: BOOLEAN;
BEGIN
res := 0;
flag := CheckInt(str, i, n, neg, FALSE);
err := ~flag;
IF flag & neg & IsMinInt(str, i) THEN
flag := FALSE;
neg := FALSE;
res := 80000000H
END;
WHILE flag & digit(str[i]) DO
IF res > maxINT DIV 10 THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END;
IF neg THEN
res := -res
END
RETURN res
END StrToInt;
PROCEDURE Space(s: STRING): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) & (s[i] <= 20X) DO
INC(i)
END
RETURN s[i] = 0X
END Space;
PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
Res := CheckInt(s, n, i, neg, TRUE);
IF Res THEN
IF s[i] = "." THEN
INC(i);
WHILE digit(s[i]) DO
INC(i)
END;
IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN
INC(i);
IF (s[i] = "+") OR (s[i] = "-") THEN
INC(i)
END;
Res := digit(s[i]);
WHILE digit(s[i]) DO
INC(i)
END
END
END
END
RETURN Res & (s[i] <= 20X)
END CheckReal;
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): LONGREAL;
CONST maxDBL = 1.69D308; maxINT = 7FFFFFFFH;
VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, neg: BOOLEAN;
PROCEDURE part1(): BOOLEAN;
BEGIN
res := 0.0D0;
d := 1.0D0;
WHILE digit(str[i]) DO
res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0")));
INC(i)
END;
IF str[i] = "." THEN
INC(i);
WHILE digit(str[i]) DO
d := d / 10.0D0;
res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d;
INC(i)
END
END
RETURN str[i] # 0X
END part1;
PROCEDURE part2(): BOOLEAN;
BEGIN
INC(i);
m := 10.0D0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1D0
END;
scale := 0;
err := FALSE;
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0D0
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0D0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN ~err
END part2;
PROCEDURE part3;
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0D0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0D0
ELSE
res := res * m;
INC(i)
END
END
END part3;
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1() & part2() THEN
part3
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0D0;
err := TRUE
END
RETURN res
END StrToFloat;
PROCEDURE String*(VAR s: ARRAY OF CHAR);
VAR res, length: INTEGER; str: STRING;
BEGIN
res := ConsoleLib.gets(sys.ADR(str[0]), LEN(str));
length := LENGTH(str);
IF length > 0 THEN
str[length - 1] := 0X
END;
COPY(str, s);
Done := TRUE
END String;
PROCEDURE Char*(VAR x: CHAR);
VAR str: STRING;
BEGIN
String(str);
x := str[0];
Done := TRUE
END Char;
PROCEDURE Ln*;
VAR str: STRING;
BEGIN
String(str);
Done := TRUE
END Ln;
PROCEDURE LongReal*(VAR x: LONGREAL);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToFloat(str, err);
Done := ~err
END LongReal;
PROCEDURE Real*(VAR x: REAL);
CONST maxREAL = 3.39E38;
VAR y: LONGREAL;
BEGIN
LongReal(y);
IF Done THEN
IF ABS(y) > LONG(maxREAL) THEN
x := 0.0;
Done := FALSE
ELSE
x := SHORT(y)
END
END
END Real;
PROCEDURE Int*(VAR x: INTEGER);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToInt(str, err);
Done := ~err
END Int;
PROCEDURE Open*;
BEGIN
Done := TRUE
END Open;
END In.

/programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07
0,0 → 1,323
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE KOSAPI;
IMPORT sys := SYSTEM;
TYPE STRING = ARRAY 1024 OF CHAR;
VAR DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER);
PROCEDURE [stdcall] sysfunc1*(arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall] sysfunc2*(arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall] sysfunc3*(arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall] sysfunc4*(arg1, arg2, arg3, arg4: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21000"); (* ret 10h *)
RETURN 0
END sysfunc4;
PROCEDURE [stdcall] sysfunc5*(arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
RETURN 0
END sysfunc5;
PROCEDURE [stdcall] sysfunc6*(arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("57"); (* push edi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5F"); (* pop edi *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21800"); (* ret 18h *)
RETURN 0
END sysfunc6;
PROCEDURE [stdcall] sysfunc7*(arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("57"); (* push edi *)
sys.CODE("55"); (* push ebp *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *)
sys.CODE("8B6D20"); (* mov ebp, [ebp + 20h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5D"); (* pop ebp *)
sys.CODE("5F"); (* pop edi *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21C00"); (* ret 1Ch *)
RETURN 0
END sysfunc7;
PROCEDURE [stdcall] sysfunc22*(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8919"); (* mov [ecx], ebx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc22;
PROCEDURE [stdcall] malloc*(size: INTEGER): INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
size := sysfunc3(68, 12, size);
sys.CODE("61") (* popa *)
RETURN size
END malloc;
PROCEDURE [stdcall] free*(ptr: INTEGER): INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
IF ptr # 0 THEN
ptr := sysfunc3(68, 13, ptr)
END;
sys.CODE("61") (* popa *)
RETURN 0
END free;
PROCEDURE [stdcall] realloc*(ptr, size: INTEGER): INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
ptr := sysfunc4(68, 20, size, ptr);
sys.CODE("61") (* popa *)
RETURN ptr
END realloc;
PROCEDURE GetCommandLine*(): INTEGER;
VAR param: INTEGER;
BEGIN
sys.GET(28, param)
RETURN param
END GetCommandLine;
PROCEDURE GetName*(): INTEGER;
VAR name: INTEGER;
BEGIN
sys.GET(32, name)
RETURN name
END GetName;
PROCEDURE [stdcall] dll_init2(arg1, arg2, arg3, arg4, arg5: INTEGER);
BEGIN
sys.CODE("60"); (* pusha *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("FFD6"); (* call esi *)
sys.CODE("61"); (* popa *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
END dll_init2;
PROCEDURE GetProcAdr*(name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR cur, procname, adr: INTEGER;
PROCEDURE streq(str1, str2: INTEGER): BOOLEAN;
VAR c1, c2: CHAR;
BEGIN
REPEAT
sys.GET(str1, c1);
sys.GET(str2, c2);
INC(str1);
INC(str2)
UNTIL (c1 # c2) OR (c1 = 0X)
RETURN c1 = c2
END streq;
BEGIN
adr := 0;
IF (lib # 0) & (name # "") THEN
cur := lib;
REPEAT
sys.GET(cur, procname);
INC(cur, 8)
UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0]));
IF procname # 0 THEN
sys.GET(cur - 4, adr)
END
END
RETURN adr
END GetProcAdr;
PROCEDURE init(dll: INTEGER);
VAR lib_init: INTEGER;
BEGIN
lib_init := GetProcAdr("lib_init", dll);
IF lib_init # 0 THEN
DLL_INIT(lib_init)
END;
lib_init := GetProcAdr("START", dll);
IF lib_init # 0 THEN
DLL_INIT(lib_init)
END;
END init;
PROCEDURE [stdcall] dll_Load(import_table: INTEGER): INTEGER;
VAR imp, lib, exp, proc, res: INTEGER;
fail, done: BOOLEAN;
procname, libname: STRING;
PROCEDURE GetStr(adr, i: INTEGER; VAR str: STRING);
VAR c: CHAR;
BEGIN
REPEAT
sys.GET(adr, c); INC(adr);
str[i] := c; INC(i)
UNTIL c = 0X
END GetStr;
BEGIN
sys.CODE("60"); (* pusha *)
fail := FALSE;
done := FALSE;
res := 0;
libname := "/rd/1/lib/";
REPEAT
sys.GET(import_table, imp);
IF imp # 0 THEN
sys.GET(import_table + 4, lib);
GetStr(lib, 10, libname);
exp := sysfunc3(68, 19, sys.ADR(libname[0]));
fail := exp = 0;
ELSE
done := TRUE
END;
IF fail THEN
done := TRUE
END;
IF (imp # 0) & ~fail THEN
REPEAT
sys.GET(imp, proc);
IF proc # 0 THEN
GetStr(proc, 0, procname);
proc := GetProcAdr(procname, exp);
IF proc # 0 THEN
sys.PUT(imp, proc);
INC(imp, 4);
END
END
UNTIL proc = 0;
init(exp);
INC(import_table, 8)
END
UNTIL done;
IF fail THEN
res := 1
END;
import_table := res;
sys.CODE("61") (* popa *)
RETURN import_table
END dll_Load;
PROCEDURE [stdcall] dll_Init(entry: INTEGER);
BEGIN
sys.CODE("60"); (* pusha *)
IF entry # 0 THEN
dll_init2(sys.ADR(malloc), sys.ADR(free), sys.ADR(realloc), sys.ADR(dll_Load), entry)
END;
sys.CODE("61"); (* popa *)
END dll_Init;
PROCEDURE LoadLib*(name: ARRAY OF CHAR): INTEGER;
VAR Lib: INTEGER;
BEGIN
Lib := sysfunc3(68, 19, sys.ADR(name[0]));
IF Lib # 0 THEN
init(Lib)
END
RETURN Lib
END LoadLib;
BEGIN
DLL_INIT := dll_Init
END KOSAPI.

/programs/develop/oberon07/Lib/KolibriOS/Math.ob07
0,0 → 1,254
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Math;
IMPORT sys := SYSTEM;
CONST pi* = 3.141592653589793D+00;
e* = 2.718281828459045D+00;
VAR Inf*, nInf*: LONGREAL;
PROCEDURE IsNan*(x: LONGREAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(x), l);
sys.GET(sys.ADR(x) + 4, h);
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf*(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
PROCEDURE Max(A, B: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF A > B THEN
Res := A
ELSE
Res := B
END
RETURN Res
END Max;
PROCEDURE Min(A, B: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF A < B THEN
Res := A
ELSE
Res := B
END
RETURN Res
END Min;
PROCEDURE SameValue(A, B: LONGREAL): BOOLEAN;
VAR Epsilon: LONGREAL; Res: BOOLEAN;
BEGIN
Epsilon := Max(Min(ABS(A), ABS(B)) * 1.0D-12, 1.0D-12);
IF A > B THEN
Res := (A - B) <= Epsilon
ELSE
Res := (B - A) <= Epsilon
END
RETURN Res
END SameValue;
PROCEDURE IsZero(x: LONGREAL): BOOLEAN;
RETURN ABS(x) <= 1.0D-12
END IsZero;
PROCEDURE [stdcall] sqrt*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D9FAC9C20800")
RETURN 0.0D0
END sqrt;
PROCEDURE [stdcall] sin*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D9FEC9C20800")
RETURN 0.0D0
END sin;
PROCEDURE [stdcall] cos*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D9FFC9C20800")
RETURN 0.0D0
END cos;
PROCEDURE [stdcall] tan*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D9F2DEC9C9C20800")
RETURN 0.0D0
END tan;
PROCEDURE [stdcall] arctan2*(y, x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508DD4510D9F3C9C21000")
RETURN 0.0D0
END arctan2;
PROCEDURE [stdcall] ln*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("D9EDDD4508D9F1C9C20800")
RETURN 0.0D0
END ln;
PROCEDURE [stdcall] log*(base, x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("D9E8DD4510D9F1D9E8DD4508D9F1DEF9C9C21000")
RETURN 0.0D0
END log;
PROCEDURE [stdcall] exp*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D9EADEC9D9C0D9FCDCE9D9C9D9F0D9E8DEC1D9FDDDD9C9C20800")
RETURN 0.0D0
END exp;
PROCEDURE [stdcall] round*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D97DF4D97DF666814DF60003D96DF6D9FCD96DF4C9C20800")
RETURN 0.0D0
END round;
PROCEDURE [stdcall] frac*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("50DD4508D9C0D93C24D97C240266814C2402000FD96C2402D9FCD92C24DEE9C9C20800")
RETURN 0.0D0
END frac;
PROCEDURE arcsin*(x: LONGREAL): LONGREAL;
RETURN arctan2(x, sqrt(1.0D0 - x * x))
END arcsin;
PROCEDURE arccos*(x: LONGREAL): LONGREAL;
RETURN arctan2(sqrt(1.0D0 - x * x), x)
END arccos;
PROCEDURE arctan*(x: LONGREAL): LONGREAL;
RETURN arctan2(x, 1.0D0)
END arctan;
PROCEDURE sinh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF IsZero(x) THEN
Res := 0.0D0
ELSE
Res := (exp(x) - exp(-x)) / 2.0D0
END
RETURN Res
END sinh;
PROCEDURE cosh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF IsZero(x) THEN
Res := 1.0D0
ELSE
Res := (exp(x) + exp(-x)) / 2.0D0
END
RETURN Res
END cosh;
PROCEDURE tanh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF IsZero(x) THEN
Res := 0.0D0
ELSE
Res := sinh(x) / cosh(x)
END
RETURN Res
END tanh;
PROCEDURE arcsinh*(x: LONGREAL): LONGREAL;
RETURN ln(x + sqrt((x * x) + 1.0D0))
END arcsinh;
PROCEDURE arccosh*(x: LONGREAL): LONGREAL;
RETURN ln(x + sqrt((x - 1.0D0) / (x + 1.0D0)) * (x + 1.0D0))
END arccosh;
PROCEDURE arctanh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF SameValue(x, 1.0D0) THEN
Res := Inf
ELSIF SameValue(x, -1.0D0) THEN
Res := nInf
ELSE
Res := 0.5D0 * ln((1.0D0 + x) / (1.0D0 - x))
END
RETURN Res
END arctanh;
PROCEDURE floor*(x: LONGREAL): LONGREAL;
VAR f: LONGREAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0D0 THEN
x := x - 1.0D0
END
RETURN x
END floor;
PROCEDURE ceil*(x: LONGREAL): LONGREAL;
VAR f: LONGREAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0D0 THEN
x := x + 1.0D0
END
RETURN x
END ceil;
PROCEDURE power*(base, exponent: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF exponent = 0.0D0 THEN
Res := 1.0D0
ELSIF (base = 0.0D0) & (exponent > 0.0D0) THEN
Res := 0.0D0
ELSE
Res := exp(exponent * ln(base))
END
RETURN Res
END power;
PROCEDURE sgn*(x: LONGREAL): INTEGER;
VAR Res: INTEGER;
BEGIN
IF x > 0.0D0 THEN
Res := 1
ELSIF x < 0.0D0 THEN
Res := -1
ELSE
Res := 0
END
RETURN Res
END sgn;
BEGIN
Inf := sys.INF(LONGREAL);
nInf := -sys.INF(LONGREAL)
END Math.

/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07
0,0 → 1,153
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE OpenDlg;
IMPORT sys := SYSTEM, KOSAPI;
TYPE
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
type,
procinfo,
com_area_name,
com_area,
opendir_path,
dir_default_path,
start_path: INTEGER;
draw_window: DRAW_WINDOW;
status*,
openfile_path,
filename_area: INTEGER;
filter_area:
POINTER TO RECORD
size: INTEGER;
filter: ARRAY 4096 OF CHAR
END;
X, Y: INTEGER;
procinf: ARRAY 1024 OF CHAR;
s_com_area_name: ARRAY 32 OF CHAR;
s_opendir_path,
s_dir_default_path,
FilePath*,
FileName*: ARRAY 4096 OF CHAR
END;
Dialog* = POINTER TO TDialog;
VAR
Dialog_start, Dialog_init: PROCEDURE [stdcall] (od: Dialog);
PROCEDURE Show*(od: Dialog; Width, Height: INTEGER);
BEGIN
IF od # NIL THEN
od.X := Width;
od.Y := Height;
Dialog_start(od)
END
END Show;
PROCEDURE Create*(draw_window: DRAW_WINDOW; type: INTEGER; def_path, filter: ARRAY OF CHAR): Dialog;
VAR res: Dialog; n, i: INTEGER;
PROCEDURE replace(VAR str: ARRAY OF CHAR; c1, c2: CHAR);
VAR i: INTEGER;
BEGIN
i := LENGTH(str) - 1;
WHILE i >= 0 DO
IF str[i] = c1 THEN
str[i] := c2
END;
DEC(i)
END
END replace;
BEGIN
NEW(res);
IF res # NIL THEN
NEW(res.filter_area);
IF res.filter_area # NIL THEN
res.s_com_area_name := "FFFFFFFF_open_dialog";
res.com_area := 0;
res.type := type;
res.draw_window := draw_window;
COPY(def_path, res.s_dir_default_path);
COPY(filter, res.filter_area.filter);
n := LENGTH(res.filter_area.filter);
FOR i := 0 TO 3 DO
res.filter_area.filter[n + i] := "|"
END;
res.filter_area.filter[n + 4] := 0X;
res.X := 0;
res.Y := 0;
res.s_opendir_path := res.s_dir_default_path;
res.FilePath := "";
res.FileName := "";
res.status := 0;
res.filter_area.size := LENGTH(res.filter_area.filter);
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.ADR("/rd/1/File managers/opendial");
res.opendir_path := sys.ADR(res.s_opendir_path[0]);
res.dir_default_path := sys.ADR(res.s_dir_default_path[0]);
res.openfile_path := sys.ADR(res.FilePath[0]);
res.filename_area := sys.ADR(res.FileName[0]);
replace(res.filter_area.filter, "|", 0X);
Dialog_init(res)
ELSE
DISPOSE(res)
END
END
RETURN res
END Create;
PROCEDURE Destroy*(VAR od: Dialog);
BEGIN
IF od # NIL THEN
DISPOSE(od.filter_area);
DISPOSE(od)
END
END Destroy;
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(sys.ADR(Dialog_init), "OpenDialog_init");
GetProc(sys.ADR(Dialog_start), "OpenDialog_start");
END Load;
BEGIN
Load
END OpenDlg.

/programs/develop/oberon07/Lib/KolibriOS/Out.ob07
0,0 → 1,262
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Out;
IMPORT ConsoleLib, sys := SYSTEM;
CONST
d = 1.0D0 - 5.0D-12;
VAR
Realp: PROCEDURE (x: LONGREAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
BEGIN
ConsoleLib.write_string(sys.ADR(c), 1)
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
BEGIN
ConsoleLib.write_string(sys.ADR(s[0]), LENGTH(s))
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
sys.GET(sys.ADR(AValue) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
PROCEDURE OutInf(x: LONGREAL; width: INTEGER);
VAR s: ARRAY 4 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0D0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0D0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0D0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0D0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0D0) & (y # 0.0D0) DO
y := y * 10.0D0;
DEC(e)
END;
IF e < 0 THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char("1");
x := 0.0D0
ELSE
Char("0");
x := x * 10.0D0
END
ELSE
WHILE e >= 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x > 9.0D0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(p)
END
END
END FixReal;
PROCEDURE Real*(x: LONGREAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0D0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
WHILE (x < 1.0D0) & (x # 0.0D0) DO
x := x * 10.0D0;
DEC(e)
END;
IF x > 9.0D0 + d THEN
x := 1.0D0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE Open*;
END Open;
BEGIN
Realp := Real
END Out.

/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07
0,0 → 1,279
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN
API.ExitProcess(n)
END _halt;
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
END
END _disprec;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
BEGIN
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
END
RETURN res
END _saverec;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: INTEGER;
BEGIN
m := bsize * idx;
FOR i := 4 TO Dim + 2 DO
m := m * Arr[i]
END;
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := c + m
ELSE
Arr[3] := 0
END
END _arrayidx;
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
BEGIN
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
END
END _arrayidx1;
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: INTEGER;
BEGIN
FOR i := 1 TO n DO
t := Arr[0];
FOR j := 0 TO m + n - 1 DO
Arr[j] := Arr[j + 1]
END;
Arr[m + n] := t
END
END _arrayrot;
PROCEDURE Min(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END Min;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
BEGIN
sys.CODE("8B4508"); // mov eax, [ebp + 08h]
sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch]
sys.CODE("48"); // dec eax
// L1:
sys.CODE("40"); // inc eax
sys.CODE("803800"); // cmp byte ptr [eax], 0
sys.CODE("7403"); // jz L2
sys.CODE("E2F8"); // loop L1
sys.CODE("40"); // inc eax
// L2:
sys.CODE("2B4508"); // sub eax, [ebp + 08h]
sys.CODE("C9"); // leave
sys.CODE("C20800"); // ret 08h
RETURN 0
END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN
_savearr(Min(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b)));
IF i = 0 THEN
i := _length(a) - _length(b)
END;
CASE op OF
|0: Res := i = 0
|1: Res := i # 0
|2: Res := i < 0
|3: Res := i > 0
|4: Res := i <= 0
|5: Res := i >= 0
ELSE
END
RETURN Res
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
BEGIN
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END Int;
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER);
VAR msg, int: STRING; pos, n: INTEGER;
PROCEDURE StrAppend(s: STRING);
VAR i, n: INTEGER;
BEGIN
n := LEN(s);
i := 0;
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
END
END StrAppend;
BEGIN
pos := 0;
n := line MOD 16;
line := line DIV 16;
CASE n OF
|1: StrAppend("assertion failure")
|2: StrAppend("variable of a procedure type has NIL as value")
|3: StrAppend("typeguard error")
|4: StrAppend("inadmissible dynamic type")
|5: StrAppend("index check error")
|6: StrAppend("NIL pointer dereference")
|7: StrAppend("invalid value in case statement")
|8: StrAppend("division by zero")
ELSE
END;
StrAppend(0DX);
StrAppend(0AX);
StrAppend("module ");
StrAppend(modname);
StrAppend(0DX);
StrAppend(0AX);
StrAppend("line ");
Int(line, int);
StrAppend(int);
IF m = 2 THEN
StrAppend(0DX);
StrAppend(0AX);
StrAppend("code ");
Int(code, int);
StrAppend(int)
END;
API.DebugMsg(sys.ADR(msg), SelfName)
END _assrt;
PROCEDURE [stdcall] _close*;
BEGIN
IF CloseProc # NIL THEN
CloseProc
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
BEGIN
API.zeromem(gsize, gadr);
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL
END _init;
PROCEDURE SetClose*(proc: PROC);
BEGIN
CloseProc := proc
END SetClose;
END RTL.

/programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07
0,0 → 1,124
(*
Copyright 2016 KolibriOS team
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE RasterWorks;
IMPORT sys := SYSTEM, KOSAPI;
CONST
(* flags *)
bold *= 1;
italic *= 2;
underline *= 4;
strike_through *= 8;
align_right *= 16;
align_center *= 32;
bpp32 *= 128;
(* encoding *)
cp866 *= 1;
utf16le *= 2;
utf8 *= 3;
VAR
// draw text on 24bpp or 32bpp image
// autofits text between 'x' and 'xSize'
drawText *: PROCEDURE (canvas, x, y, string, charQuantity, fontColor, params: INTEGER): INTEGER;
(*
[canvas]:
xSize dd ?
ySize dd ?
picture rb xSize * ySize * bpp
fontColor dd AARRGGBB
AA = alpha channel ; 0 = transparent, FF = non transparent
params dd ffeewwhh
hh = char height
ww = char width ; 0 = auto (proportional)
ee = encoding ; 1 = cp866, 2 = UTF-16LE, 3 = UTF-8
ff = flags ; 0001 = bold, 0010 = italic
; 0100 = underline, 1000 = strike-through
00010000 = align right, 00100000 = align center
01000000 = set text area between higher and lower halfs of 'x'
10000000 = 32bpp canvas insted of 24bpp
all flags combinable, except align right + align center
returns: char width (0 = error)
*)
// calculate amount of valid chars in UTF-8 string
// supports zero terminated string (set byteQuantity = -1)
cntUTF_8 *: PROCEDURE (string, byteQuantity: INTEGER): INTEGER;
// calculate amount of chars that fits given width
charsFit *: PROCEDURE (areaWidth, charHeight: INTEGER): INTEGER;
// calculate string width in pixels
strWidth *: PROCEDURE (charQuantity, charHeight: INTEGER): INTEGER;
PROCEDURE params* (charHeight, charWidth, encoding, flags: INTEGER): INTEGER;
(*
hh = char height
ww = char width ; 0 = auto (proportional)
ee = encoding ; 1 = cp866, 2 = UTF-16LE, 3 = UTF-8
ff = flags ; 0001 = bold, 0010 = italic
; 0100 = underline, 1000 = strike-through
00010000 = align right, 00100000 = align center
01000000 = set text area between higher and lower halfs of 'x'
10000000 = 32bpp canvas insted of 24bpp
all flags combinable, except align right + align center
*)
RETURN charHeight + LSL(charWidth, 8) + LSL(encoding, 16) + LSL(flags, 24)
END params;
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/RasterWorks.obj");
ASSERT(Lib # 0);
GetProc(sys.ADR(drawText), "drawText");
GetProc(sys.ADR(cntUTF_8), "cntUTF-8");
GetProc(sys.ADR(charsFit), "charsFit");
GetProc(sys.ADR(strWidth), "strWidth");
END main;
BEGIN
main
END RasterWorks.

/programs/develop/oberon07/Lib/KolibriOS/Read.ob07
0,0 → 1,50
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Read;
IMPORT File, sys := SYSTEM;
PROCEDURE Char*(F: File.FS; VAR x: CHAR): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR)
END Char;
PROCEDURE Int*(F: File.FS; VAR x: INTEGER): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER)
END Int;
PROCEDURE Real*(F: File.FS; VAR x: REAL): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL)
END Real;
PROCEDURE LongReal*(F: File.FS; VAR x: LONGREAL): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL)
END LongReal;
PROCEDURE Boolean*(F: File.FS; VAR x: BOOLEAN): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN)
END Boolean;
PROCEDURE Set*(F: File.FS; VAR x: SET): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET)
END Set;
PROCEDURE Card16*(F: File.FS; VAR x: sys.CARD16): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(sys.CARD16)) = sys.SIZE(sys.CARD16)
END Card16;
END Read.

/programs/develop/oberon07/Lib/KolibriOS/Write.ob07
0,0 → 1,50
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Write;
IMPORT File, sys := SYSTEM;
PROCEDURE Char*(F: File.FS; x: CHAR): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR)
END Char;
PROCEDURE Int*(F: File.FS; x: INTEGER): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER)
END Int;
PROCEDURE Real*(F: File.FS; x: REAL): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL)
END Real;
PROCEDURE LongReal*(F: File.FS; x: LONGREAL): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL)
END LongReal;
PROCEDURE Boolean*(F: File.FS; x: BOOLEAN): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN)
END Boolean;
PROCEDURE Set*(F: File.FS; x: SET): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET)
END Set;
PROCEDURE Card16*(F: File.FS; x: sys.CARD16): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(sys.CARD16)) = sys.SIZE(sys.CARD16)
END Card16;
END Write.

/programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07
0,0 → 1,478
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE kfonts;
IMPORT sys := SYSTEM;
CONST
MIN_FONT_SIZE = 8;
MAX_FONT_SIZE = 46;
bold *= 1;
italic *= 2;
underline *= 4;
strike_through *= 8;
smoothing *= 16;
bpp32 *= 32;
TYPE
Glyph = RECORD
base: INTEGER;
xsize, ysize: INTEGER;
width: INTEGER
END;
TFont_desc = RECORD
data, size, font, char_size, width, height, font_size, mem, mempos: INTEGER;
glyphs: ARRAY 4, 256 OF Glyph
END;
TFont* = POINTER TO TFont_desc;
PROCEDURE [stdcall] LoadFile(file_name: INTEGER; VAR size: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("6A44"); (* push 68 *)
sys.CODE("58"); (* pop eax *)
sys.CODE("6A1B"); (* push 27 *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("8B4D08"); (* mov ecx, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D0C"); (* mov ecx, [ebp + 0Ch] *)
sys.CODE("8911"); (* mov [ecx], edx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END LoadFile;
PROCEDURE [stdcall] sysfunc3(arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall] zeromem(size, adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN);
VAR xsize, ysize: INTEGER;
BEGIN
sys.GET(buf, xsize);
sys.GET(buf + 4, ysize);
INC(buf, 8);
IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN
IF bpp32 THEN
sys.PUT(buf + 4 * (xsize * y + x), color)
ELSE
sys.MOVE(sys.ADR(color), buf + 3 * (xsize * y + x), 3)
END
END
END pset;
PROCEDURE pget(buf, x, y: INTEGER; bpp32: BOOLEAN): INTEGER;
VAR xsize, ysize, color: INTEGER;
BEGIN
sys.GET(buf, xsize);
sys.GET(buf + 4, ysize);
INC(buf, 8);
IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN
IF bpp32 THEN
sys.GET(buf + 4 * (xsize * y + x), color)
ELSE
sys.MOVE(buf + 3 * (xsize * y + x), sys.ADR(color), 3)
END
END
RETURN color
END pget;
PROCEDURE getrgb(color: INTEGER; VAR r, g, b: INTEGER);
BEGIN
b := LSR(LSL(color, 24), 24);
g := LSR(LSL(color, 16), 24);
r := LSR(LSL(color, 8), 24);
END getrgb;
PROCEDURE rgb(r, g, b: INTEGER): INTEGER;
RETURN b + LSL(g, 8) + LSL(r, 16)
END rgb;
PROCEDURE create_glyph(VAR Font: TFont_desc; VAR glyph: Glyph; xsize, ysize: INTEGER);
VAR res: INTEGER;
BEGIN
glyph.base := Font.mempos;
glyph.xsize := xsize;
glyph.ysize := ysize;
Font.mempos := Font.mempos + xsize * ysize
END create_glyph;
PROCEDURE getpix(Font: TFont_desc; n, x, y, xsize: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(Font.mem + n + x + y * xsize, res)
RETURN res
END getpix;
PROCEDURE setpix(VAR Font: TFont_desc; n, x, y, xsize: INTEGER; c: CHAR);
BEGIN
sys.PUT(Font.mem + n + x + y * xsize, c)
END setpix;
PROCEDURE smooth(VAR Font: TFont_desc; n, xsize, ysize: INTEGER);
VAR x, y: INTEGER;
BEGIN
FOR y := 1 TO ysize - 1 DO
FOR x := 1 TO xsize - 1 DO
IF (getpix(Font, n, x, y, xsize) = 1X) & (getpix(Font, n, x - 1, y - 1, xsize) = 1X) &
(getpix(Font, n, x - 1, y, xsize) = 0X) & (getpix(Font, n, x, y - 1, xsize) = 0X) THEN
setpix(Font, n, x - 1, y, xsize, 2X);
setpix(Font, n, x, y - 1, xsize, 2X)
END;
IF (getpix(Font, n, x, y, xsize) = 0X) & (getpix(Font, n, x - 1, y - 1, xsize) = 0X) &
(getpix(Font, n, x - 1, y, xsize) = 1X) & (getpix(Font, n, x, y - 1, xsize) = 1X) THEN
setpix(Font, n, x, y, xsize, 2X);
setpix(Font, n, x - 1, y - 1, xsize, 2X)
END
END
END
END smooth;
PROCEDURE _bold(VAR Font: TFont_desc; src, dst, src_xsize, dst_xsize, n: INTEGER);
VAR i, j, k: INTEGER; pix: CHAR;
BEGIN
FOR i := 0 TO src_xsize - 1 DO
FOR j := 0 TO Font.height - 1 DO
pix := getpix(Font, src, i, j, src_xsize);
IF pix = 1X THEN
FOR k := 0 TO n DO
setpix(Font, dst, i + k, j, dst_xsize, pix)
END
END
END
END
END _bold;
PROCEDURE make_glyph(VAR Font: TFont_desc; c: INTEGER);
VAR ptr, i, j, max, x, y: INTEGER; s: SET; eoc: BOOLEAN;
glyph: Glyph; pix: CHAR; bold_width: INTEGER;
BEGIN
create_glyph(Font, glyph, Font.width, Font.height);
x := 0;
y := 0;
max := 0;
ptr := Font.font + Font.char_size * c;
eoc := FALSE;
REPEAT
sys.GET(ptr, s);
INC(ptr, 4);
FOR i := 0 TO 31 DO
IF ~eoc THEN
IF i IN s THEN
setpix(Font, glyph.base, x, y, Font.width, 1X);
IF x > max THEN
max := x
END
ELSE
setpix(Font, glyph.base, x, y, Font.width, 0X)
END
END;
INC(x);
IF x = Font.width THEN
x := 0;
INC(y);
eoc := eoc OR (y = Font.height)
END
END
UNTIL eoc;
IF max = 0 THEN
max := Font.width DIV 3
END;
glyph.width := max;
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
Font.glyphs[0, c] := glyph;
bold_width := 1;
create_glyph(Font, glyph, Font.width + bold_width, Font.height);
_bold(Font, Font.glyphs[0, c].base, glyph.base, Font.glyphs[0, c].xsize, glyph.xsize, bold_width);
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max + bold_width;
Font.glyphs[1, c] := glyph;
create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3, Font.height);
FOR i := 0 TO Font.glyphs[0, c].xsize - 1 DO
FOR j := 0 TO Font.height - 1 DO
pix := getpix(Font, Font.glyphs[0, c].base, i, j, Font.glyphs[0, c].xsize);
IF pix = 1X THEN
setpix(Font, glyph.base, i + (Font.height - 1 - j) DIV 3, j, glyph.xsize, pix)
END
END
END;
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max;
Font.glyphs[2, c] := glyph;
create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3 + bold_width, Font.height);
_bold(Font, Font.glyphs[2, c].base, glyph.base, Font.glyphs[2, c].xsize, glyph.xsize, bold_width);
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max + bold_width;
Font.glyphs[3, c] := glyph;
END make_glyph;
PROCEDURE OutChar(Font: TFont_desc; c: INTEGER; x, y: INTEGER; buf: INTEGER; bpp32, smoothing: BOOLEAN; color, style: INTEGER): INTEGER;
VAR i, x0, y0, xsize, mem, xmax: INTEGER; r, g, b, r0, g0, b0: INTEGER; ch: CHAR; glyph: Glyph;
BEGIN
x0 := x;
y0 := y;
style := style MOD 4;
glyph := Font.glyphs[style, c];
xsize := glyph.xsize;
xmax := x0 + xsize;
mem := Font.mem + glyph.base;
FOR i := mem TO mem + xsize * Font.height - 1 DO
sys.GET(i, ch);
IF ch = 1X THEN
pset(buf, x, y, color, bpp32)
ELSIF (ch = 2X) & smoothing THEN
getrgb(pget(buf, x, y, bpp32), r, g, b);
getrgb(color, r0, g0, b0);
r := (r * 3 + r0) DIV 4;
g := (g * 3 + g0) DIV 4;
b := (b * 3 + b0) DIV 4;
pset(buf, x, y, rgb(r, g, b), bpp32)
END;
INC(x);
IF x = xmax THEN
x := x0;
INC(y)
END
END
RETURN glyph.width
END OutChar;
PROCEDURE hline(buf, x, y, width, color: INTEGER; bpp32: BOOLEAN);
VAR i: INTEGER;
BEGIN
FOR i := x TO x + width - 1 DO
pset(buf, i, y, color, bpp32)
END
END hline;
PROCEDURE TextOut*(Font: TFont; canvas, x, y, str, length, color, params: INTEGER);
VAR width: INTEGER; c: CHAR; bpp32, smoothing: BOOLEAN;
BEGIN
IF Font # NIL THEN
smoothing := 4 IN BITS(params);
bpp32 := 5 IN BITS(params);
sys.GET(str, c);
WHILE (length > 0) OR (length = -1) & (c # 0X) DO
INC(str);
width := OutChar(Font^, ORD(c), x, y, canvas, bpp32, smoothing, color, params);
IF 3 IN BITS(params) THEN
hline(canvas, x + ORD(1 IN BITS(params)) * ((Font.height DIV 2) DIV 3), y + Font.height DIV 2, width, color, bpp32)
END;
IF 2 IN BITS(params) THEN
hline(canvas, x, y + Font.height - 1, width, color, bpp32)
END;
x := x + width;
IF length > 0 THEN
DEC(length)
END;
sys.GET(str, c)
END
END
END TextOut;
PROCEDURE TextWidth*(Font: TFont; str, length, params: INTEGER): INTEGER;
VAR res: INTEGER; c: CHAR;
BEGIN
res := 0;
params := params MOD 4;
IF Font # NIL THEN
sys.GET(str, c);
WHILE (length > 0) OR (length = -1) & (c # 0X) DO
INC(str);
res := res + Font.glyphs[params, ORD(c)].width;
IF length > 0 THEN
DEC(length)
END;
sys.GET(str, c)
END
END
RETURN res
END TextWidth;
PROCEDURE TextHeight*(Font: TFont): INTEGER;
VAR res: INTEGER;
BEGIN
IF Font # NIL THEN
res := Font.height
ELSE
res := 0
END
RETURN res
END TextHeight;
PROCEDURE SetSize*(_Font: TFont; font_size: INTEGER): BOOLEAN;
VAR temp, offset, fsize, i, memsize, mem: INTEGER;
c: CHAR; Font, Font2: TFont_desc;
BEGIN
offset := -1;
IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (_Font # NIL) THEN
Font := _Font^;
Font2 := Font;
temp := Font.data + (font_size - 8) * 4;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN
sys.GET(temp, offset);
IF offset # -1 THEN
Font.font_size := font_size;
INC(offset, 156);
offset := offset + Font.data;
IF (Font.data <= offset) & (offset <= Font.size + Font.data - 4) THEN
sys.GET(offset, fsize);
IF fsize > 256 + 6 THEN
temp := offset + fsize - 1;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 1) THEN
sys.GET(temp, c);
IF c # 0X THEN
Font.height := ORD(c);
DEC(temp);
sys.GET(temp, c);
IF c # 0X THEN
Font.width := ORD(c);
DEC(fsize, 6);
Font.char_size := fsize DIV 256;
IF fsize MOD 256 # 0 THEN
INC(Font.char_size)
END;
IF Font.char_size > 0 THEN
Font.font := offset + 4;
Font.mempos := 0;
memsize := (Font.width + 10) * Font.height * 1024;
mem := Font.mem;
Font.mem := sysfunc3(68, 12, memsize);
IF Font.mem # 0 THEN
IF mem # 0 THEN
mem := sysfunc3(68, 13, mem)
END;
zeromem(memsize DIV 4, Font.mem);
FOR i := 0 TO 255 DO
make_glyph(Font, i)
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
END;
ELSE
offset := -1
END;
IF offset # -1 THEN
_Font^ := Font
ELSE
_Font^ := Font2
END
END
RETURN offset # -1
END SetSize;
PROCEDURE Enabled*(Font: TFont; font_size: INTEGER): BOOLEAN;
VAR offset, temp: INTEGER;
BEGIN
offset := -1;
IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (Font # NIL) THEN
temp := Font.data + (font_size - 8) * 4;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN
sys.GET(temp, offset)
END
END
RETURN offset # -1
END Enabled;
PROCEDURE Destroy*(VAR Font: TFont);
BEGIN
IF Font # NIL THEN
IF Font.mem # 0 THEN
Font.mem := sysfunc3(68, 13, Font.mem)
END;
IF Font.data # 0 THEN
Font.data := sysfunc3(68, 13, Font.data)
END;
DISPOSE(Font)
END
END Destroy;
PROCEDURE LoadFont*(file_name: ARRAY OF CHAR): TFont;
VAR Font: TFont; data, size, n: INTEGER;
BEGIN
data := LoadFile(sys.ADR(file_name[0]), size);
IF (data # 0) & (size > 156) THEN
NEW(Font);
Font.data := data;
Font.size := size;
Font.font_size := 0;
n := MIN_FONT_SIZE;
WHILE ~SetSize(Font, n) & (n <= MAX_FONT_SIZE) DO
INC(n)
END;
IF Font.font_size = 0 THEN
Destroy(Font)
END
ELSE
IF data # 0 THEN
data := sysfunc3(68, 13, data)
END;
Font := NIL
END
RETURN Font
END LoadFont;
END kfonts.

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

/programs/develop/oberon07/Lib/Linux32/API.ob07
0,0 → 1,143
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE API;
IMPORT sys := SYSTEM;
TYPE
TP* = ARRAY 2 OF INTEGER;
VAR
Param*: INTEGER;
sec* : INTEGER;
dsec* : INTEGER;
stdin* : INTEGER;
stdout* : INTEGER;
stderr* : INTEGER;
dlopen* : PROCEDURE [cdecl] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [cdecl] (handle, symbol: INTEGER): INTEGER;
_malloc* : PROCEDURE [cdecl] (size: INTEGER): INTEGER;
free* : PROCEDURE [cdecl] (ptr: INTEGER);
fopen* : PROCEDURE [cdecl] (fname, fmode: INTEGER): INTEGER;
fclose*, ftell* : PROCEDURE [cdecl] (file: INTEGER): INTEGER;
fwrite*, fread* : PROCEDURE [cdecl] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fseek* : PROCEDURE [cdecl] (file, offset, origin: INTEGER): INTEGER;
exit* : PROCEDURE [cdecl] (code: INTEGER);
strncmp* : PROCEDURE [cdecl] (str1, str2, n: INTEGER): INTEGER;
strlen* : PROCEDURE [cdecl] (str: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [cdecl] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
PROCEDURE malloc* (Bytes: INTEGER): INTEGER;
VAR res: INTEGER;
BEGIN
Bytes := Align(Bytes, 4);
res := _malloc(Bytes);
IF res # 0 THEN
zeromem(ASR(Bytes, 2), res)
END
RETURN res
END malloc;
PROCEDURE Free* (hMem: INTEGER): INTEGER;
BEGIN
free(hMem)
RETURN 0
END Free;
PROCEDURE _NEW*(size: INTEGER): INTEGER;
RETURN malloc(size)
END _NEW;
PROCEDURE _DISPOSE*(p: INTEGER): INTEGER;
RETURN Free(p)
END _DISPOSE;
PROCEDURE ConOut(str, length: INTEGER);
BEGIN
length := fwrite(str, length, 1, stdout)
END ConOut;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
VAR eol: ARRAY 3 OF CHAR;
BEGIN
eol[0] := 0DX;
eol[1] := 0AX;
eol[2] := 00X;
ConOut(sys.ADR(eol), 2);
ConOut(lpCaption, strlen(lpCaption));
ConOut(sys.ADR(":"), 1);
ConOut(sys.ADR(eol), 2);
ConOut(lpText, strlen(lpText));
ConOut(sys.ADR(eol), 2);
END DebugMsg;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
exit(code)
END ExitProcess;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
VAR H: INTEGER;
BEGIN
H := dlsym(hMOD, sys.ADR(name[0]));
ASSERT(H # 0);
sys.PUT(adr, H);
END GetProc;
PROCEDURE init* (esp: INTEGER);
VAR lib, proc: INTEGER;
BEGIN
Param := esp;
sys.MOVE(Param + 12, sys.ADR(dlopen), 4);
sys.MOVE(Param + 16, sys.ADR(dlsym), 4);
sys.MOVE(Param + 20, sys.ADR(exit), 4);
sys.MOVE(Param + 24, sys.ADR(stdin), 4);
sys.MOVE(Param + 28, sys.ADR(stdout), 4);
sys.MOVE(Param + 32, sys.ADR(stderr), 4);
sys.MOVE(Param + 36, sys.ADR(_malloc), 4);
sys.MOVE(Param + 40, sys.ADR(free), 4);
sys.MOVE(Param + 44, sys.ADR(fopen), 4);
sys.MOVE(Param + 48, sys.ADR(fclose), 4);
sys.MOVE(Param + 52, sys.ADR(fwrite), 4);
sys.MOVE(Param + 56, sys.ADR(fread), 4);
sys.MOVE(Param + 60, sys.ADR(fseek), 4);
sys.MOVE(Param + 64, sys.ADR(ftell), 4);
lib := dlopen(sys.ADR("libc.so.6"), 1);
ASSERT(lib # 0);
GetProc("strncmp", lib, sys.ADR(strncmp));
GetProc("strlen", lib, sys.ADR(strlen));
lib := dlopen(sys.ADR("librt.so.1"), 1);
ASSERT(lib # 0);
GetProc("clock_gettime", lib, sys.ADR(clock_gettime));
END init;
END API.

/programs/develop/oberon07/Lib/Linux32/HOST.ob07
0,0 → 1,121
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
CONST
OS* = "LNX";
Slash* = "/";
VAR
fsize : INTEGER;
sec* : INTEGER;
dsec* : INTEGER;
PROCEDURE GetCommandLine* (): INTEGER;
RETURN API.Param
END GetCommandLine;
PROCEDURE CloseFile* (File: INTEGER);
BEGIN
File := API.fclose(File)
END CloseFile;
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR res: INTEGER;
BEGIN
IF write THEN
res := API.fwrite(Buffer, nNumberOfBytes, 1, hFile) * nNumberOfBytes
ELSE
res := API.fread(Buffer, nNumberOfBytes, 1, hFile) * nNumberOfBytes
END
RETURN res
END FileRW;
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR res: INTEGER;
BEGIN
res := FileRW(API.stdout, sys.ADR(str), LENGTH(str), TRUE)
END OutString;
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(sys.ADR(FName), sys.ADR("wb"))
END CreateFile;
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
VAR F, res: INTEGER;
BEGIN
F := API.fopen(sys.ADR(FName), sys.ADR("rb"));
IF F # 0 THEN
res := API.fseek(F, 0, 2);
fsize := API.ftell(F);
res := API.fseek(F, 0, 0)
END
RETURN F
END OpenFile;
PROCEDURE FileSize* (F: INTEGER): INTEGER;
RETURN fsize
END FileSize;
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
PROCEDURE malloc* (Bytes: INTEGER): INTEGER;
VAR res: INTEGER;
BEGIN
Bytes := Align(Bytes, 4);
res := API.malloc(Bytes);
IF res # 0 THEN
API.zeromem(ASR(Bytes, 2), res)
END
RETURN res
END malloc;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
API.exit(code)
END ExitProcess;
PROCEDURE Time* (VAR sec, dsec: INTEGER);
VAR tp: API.TP;
BEGIN
IF API.clock_gettime(0, tp) = 0 THEN
sec := tp[0];
dsec := tp[1] DIV 10000000
ELSE
sec := 0;
dsec := 0
END
END Time;
PROCEDURE init*;
BEGIN
Time(sec, dsec)
END init;
PROCEDURE GetName*(): INTEGER;
RETURN 0
END GetName;
END HOST.

/programs/develop/oberon07/Lib/Linux32/RTL.ob07
0,0 → 1,279
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN
API.ExitProcess(n)
END _halt;
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
END
END _disprec;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
BEGIN
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
END
RETURN res
END _saverec;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: INTEGER;
BEGIN
m := bsize * idx;
FOR i := 4 TO Dim + 2 DO
m := m * Arr[i]
END;
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := c + m
ELSE
Arr[3] := 0
END
END _arrayidx;
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
BEGIN
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
END
END _arrayidx1;
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: INTEGER;
BEGIN
FOR i := 1 TO n DO
t := Arr[0];
FOR j := 0 TO m + n - 1 DO
Arr[j] := Arr[j + 1]
END;
Arr[m + n] := t
END
END _arrayrot;
PROCEDURE Min(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END Min;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
BEGIN
sys.CODE("8B4508"); // mov eax, [ebp + 08h]
sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch]
sys.CODE("48"); // dec eax
// L1:
sys.CODE("40"); // inc eax
sys.CODE("803800"); // cmp byte ptr [eax], 0
sys.CODE("7403"); // jz L2
sys.CODE("E2F8"); // loop L1
sys.CODE("40"); // inc eax
// L2:
sys.CODE("2B4508"); // sub eax, [ebp + 08h]
sys.CODE("C9"); // leave
sys.CODE("C20800"); // ret 08h
RETURN 0
END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN
_savearr(Min(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b)));
IF i = 0 THEN
i := _length(a) - _length(b)
END;
CASE op OF
|0: Res := i = 0
|1: Res := i # 0
|2: Res := i < 0
|3: Res := i > 0
|4: Res := i <= 0
|5: Res := i >= 0
ELSE
END
RETURN Res
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
BEGIN
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END Int;
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER);
VAR msg, int: STRING; pos, n: INTEGER;
PROCEDURE StrAppend(s: STRING);
VAR i, n: INTEGER;
BEGIN
n := LEN(s);
i := 0;
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
END
END StrAppend;
BEGIN
pos := 0;
n := line MOD 16;
line := line DIV 16;
CASE n OF
|1: StrAppend("assertion failure")
|2: StrAppend("variable of a procedure type has NIL as value")
|3: StrAppend("typeguard error")
|4: StrAppend("inadmissible dynamic type")
|5: StrAppend("index check error")
|6: StrAppend("NIL pointer dereference")
|7: StrAppend("invalid value in case statement")
|8: StrAppend("division by zero")
ELSE
END;
StrAppend(0DX);
StrAppend(0AX);
StrAppend("module ");
StrAppend(modname);
StrAppend(0DX);
StrAppend(0AX);
StrAppend("line ");
Int(line, int);
StrAppend(int);
IF m = 2 THEN
StrAppend(0DX);
StrAppend(0AX);
StrAppend("code ");
Int(code, int);
StrAppend(int)
END;
API.DebugMsg(sys.ADR(msg), SelfName)
END _assrt;
PROCEDURE [stdcall] _close*;
BEGIN
IF CloseProc # NIL THEN
CloseProc
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
BEGIN
API.zeromem(gsize, gadr);
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL;
END _init;
PROCEDURE SetClose*(proc: PROC);
BEGIN
CloseProc := proc
END SetClose;
END RTL.

/programs/develop/oberon07/Lib/Windows32/API.ob07
0,0 → 1,75
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE API;
IMPORT sys := SYSTEM;
VAR
Alloc*: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER;
Free*: PROCEDURE [winapi] (hMem: INTEGER): INTEGER;
MessageBoxA*: PROCEDURE [winapi] (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
strncmp*: PROCEDURE [cdecl] (a, b, n: INTEGER): INTEGER;
GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER;
LoadLibraryA*: PROCEDURE [winapi] (name: INTEGER): INTEGER;
PROCEDURE zeromem*(size, adr: INTEGER);
END zeromem;
PROCEDURE DebugMsg*(lpText, lpCaption: INTEGER);
BEGIN
MessageBoxA(0, lpText, lpCaption, 16)
END DebugMsg;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
VAR H: INTEGER;
BEGIN
H := GetProcAddress(hMOD, sys.ADR(name[0]));
ASSERT(H # 0);
sys.PUT(adr, H);
END GetProc;
PROCEDURE _NEW*(size: INTEGER): INTEGER;
RETURN Alloc(64, size)
END _NEW;
PROCEDURE _DISPOSE*(p: INTEGER): INTEGER;
RETURN Free(p)
END _DISPOSE;
PROCEDURE init* (esp: INTEGER);
VAR lib: INTEGER;
BEGIN
sys.GET(esp, GetProcAddress);
sys.GET(esp + 4, LoadLibraryA);
lib := LoadLibraryA(sys.ADR("kernel32.dll"));
GetProc("ExitProcess", lib, sys.ADR(ExitProcess));
GetProc("GlobalAlloc", lib, sys.ADR(Alloc));
GetProc("GlobalFree", lib, sys.ADR(Free));
lib := LoadLibraryA(sys.ADR("msvcrt.dll"));
GetProc("strncmp", lib, sys.ADR(strncmp));
lib := LoadLibraryA(sys.ADR("user32.dll"));
GetProc("MessageBoxA", lib, sys.ADR(MessageBoxA));
END init;
END API.

/programs/develop/oberon07/Lib/Windows32/HOST.ob07
0,0 → 1,141
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
CONST
OS* = "WIN";
Slash* = "\";
OFS_MAXPATHNAME = 128;
TYPE
OFSTRUCT = RECORD
cBytes: CHAR;
fFixedDisk: CHAR;
nErrCode: sys.CARD16;
Reserved1: sys.CARD16;
Reserved2: sys.CARD16;
szPathName: ARRAY OFS_MAXPATHNAME OF CHAR
END;
VAR
sec*, dsec*, hConsoleOutput: INTEGER;
GetStdHandle: PROCEDURE [winapi] (nStdHandle: INTEGER): INTEGER;
CloseFile*: PROCEDURE [winapi] (hObject: INTEGER): INTEGER;
_CreateFile*: PROCEDURE [winapi] (lpFileName, dwDesiredAccess, dwShareMode, lpSecurityAttributes,
dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: INTEGER): INTEGER;
_OpenFile*: PROCEDURE [winapi] (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
ReadFile, WriteFile: PROCEDURE [winapi] (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, lpOverlapped: INTEGER): INTEGER;
GetCommandLine*: PROCEDURE [winapi] (): INTEGER;
GetTickCount: PROCEDURE [winapi] (): INTEGER;
Alloc: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
SetFilePointer: PROCEDURE [winapi] (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
PROCEDURE FileRW*(hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR res: INTEGER;
BEGIN
IF write THEN
WriteFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0)
ELSE
ReadFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0)
END
RETURN res
END FileRW;
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR res: INTEGER;
BEGIN
res := FileRW(hConsoleOutput, sys.ADR(str[0]), LENGTH(str), TRUE)
END OutString;
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
VAR res: INTEGER;
BEGIN
res := _CreateFile(sys.ADR(FName[0]), 0C0000000H, 0, 0, 2, 80H, 0);
IF res = -1 THEN
res := 0
END
RETURN res
END CreateFile;
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
VAR res: INTEGER; ofstr: OFSTRUCT;
BEGIN
res := _OpenFile(sys.ADR(FName[0]), ofstr, 0);
IF res = -1 THEN
res := 0
END
RETURN res
END OpenFile;
PROCEDURE FileSize*(F: INTEGER): INTEGER;
VAR res: INTEGER;
BEGIN
res := SetFilePointer(F, 0, 0, 2);
SetFilePointer(F, 0, 0, 0)
RETURN res
END FileSize;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
BEGIN
sys.PUT(adr, API.GetProcAddress(hMOD, sys.ADR(name[0])))
END GetProc;
PROCEDURE Time*(VAR sec, dsec: INTEGER);
VAR t: INTEGER;
BEGIN
t := GetTickCount() DIV 10;
sec := t DIV 100;
dsec := t MOD 100
END Time;
PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN Alloc(64, size)
END malloc;
PROCEDURE init*;
VAR lib: INTEGER;
BEGIN
lib := API.LoadLibraryA(sys.ADR("kernel32.dll"));
GetProc("GetTickCount", lib, sys.ADR(GetTickCount));
Time(sec, dsec);
GetProc("GetStdHandle", lib, sys.ADR(GetStdHandle));
GetProc("CreateFileA", lib, sys.ADR(_CreateFile));
GetProc("CloseHandle", lib, sys.ADR(CloseFile));
GetProc("OpenFile", lib, sys.ADR(_OpenFile));
GetProc("ReadFile", lib, sys.ADR(ReadFile));
GetProc("WriteFile", lib, sys.ADR(WriteFile));
GetProc("GetCommandLineA", lib, sys.ADR(GetCommandLine));
GetProc("ExitProcess", lib, sys.ADR(ExitProcess));
GetProc("GlobalAlloc", lib, sys.ADR(Alloc));
GetProc("SetFilePointer", lib, sys.ADR(SetFilePointer));
hConsoleOutput := GetStdHandle(-11)
END init;
PROCEDURE GetName*(): INTEGER;
RETURN 0
END GetName;
END HOST.

/programs/develop/oberon07/Lib/Windows32/RTL.ob07
0,0 → 1,279
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN
API.ExitProcess(n)
END _halt;
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
END
END _disprec;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
BEGIN
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
END
RETURN res
END _saverec;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: INTEGER;
BEGIN
m := bsize * idx;
FOR i := 4 TO Dim + 2 DO
m := m * Arr[i]
END;
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := c + m
ELSE
Arr[3] := 0
END
END _arrayidx;
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
BEGIN
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
END
END _arrayidx1;
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: INTEGER;
BEGIN
FOR i := 1 TO n DO
t := Arr[0];
FOR j := 0 TO m + n - 1 DO
Arr[j] := Arr[j + 1]
END;
Arr[m + n] := t
END
END _arrayrot;
PROCEDURE Min(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END Min;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
BEGIN
sys.CODE("8B4508"); // mov eax, [ebp + 08h]
sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch]
sys.CODE("48"); // dec eax
// L1:
sys.CODE("40"); // inc eax
sys.CODE("803800"); // cmp byte ptr [eax], 0
sys.CODE("7403"); // jz L2
sys.CODE("E2F8"); // loop L1
sys.CODE("40"); // inc eax
// L2:
sys.CODE("2B4508"); // sub eax, [ebp + 08h]
sys.CODE("C9"); // leave
sys.CODE("C20800"); // ret 08h
RETURN 0
END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN
_savearr(Min(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b)));
IF i = 0 THEN
i := _length(a) - _length(b)
END;
CASE op OF
|0: Res := i = 0
|1: Res := i # 0
|2: Res := i < 0
|3: Res := i > 0
|4: Res := i <= 0
|5: Res := i >= 0
ELSE
END
RETURN Res
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
BEGIN
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END Int;
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER);
VAR msg, int: STRING; pos, n: INTEGER;
PROCEDURE StrAppend(s: STRING);
VAR i, n: INTEGER;
BEGIN
n := LEN(s);
i := 0;
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
END
END StrAppend;
BEGIN
pos := 0;
n := line MOD 16;
line := line DIV 16;
CASE n OF
|1: StrAppend("assertion failure")
|2: StrAppend("variable of a procedure type has NIL as value")
|3: StrAppend("typeguard error")
|4: StrAppend("inadmissible dynamic type")
|5: StrAppend("index check error")
|6: StrAppend("NIL pointer dereference")
|7: StrAppend("invalid value in case statement")
|8: StrAppend("division by zero")
ELSE
END;
StrAppend(0DX);
StrAppend(0AX);
StrAppend("module ");
StrAppend(modname);
StrAppend(0DX);
StrAppend(0AX);
StrAppend("line ");
Int(line, int);
StrAppend(int);
IF m = 2 THEN
StrAppend(0DX);
StrAppend(0AX);
StrAppend("code ");
Int(code, int);
StrAppend(int)
END;
API.DebugMsg(sys.ADR(msg), SelfName)
END _assrt;
PROCEDURE [stdcall] _close*;
BEGIN
IF CloseProc # NIL THEN
CloseProc
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
BEGIN
API.zeromem(gsize, gadr);
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL;
END _init;
PROCEDURE SetClose*(proc: PROC);
BEGIN
CloseProc := proc
END SetClose;
END RTL.