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

  → /programs/develop/ @ 8097

  ↔ Reverse comparison

• Compare Path:	Rev

  With Path:	Rev

No changes between revisions

Regard whitespace Rev 8088 → Rev 8097

/programs/develop/oberon07/Docs/Oberon07.Report_2016_05_03.pdf
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property

/programs/develop/oberon07/Docs/x86_64.txt
File deleted
\ No newline at end of file

/programs/develop/oberon07/Docs/KOSLib.txt
File deleted
\ No newline at end of file

/programs/develop/oberon07/Docs/WinLib.txt
File deleted
\ No newline at end of file

/programs/develop/oberon07/Docs/x86.txt
File deleted
\ No newline at end of file

/programs/develop/oberon07/GitHub.url
File deleted

/programs/develop/oberon07/Compiler
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream

/programs/develop/oberon07/Compiler.exe
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream

/programs/develop/oberon07/Compiler.kex
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream

/programs/develop/oberon07/Lib/KolibriOS/API.ob07
12,6 → 12,8
CONST
eol* = 0DX + 0AX;
MAX_SIZE = 16 * 400H;
HEAP_SIZE = 1 * 100000H;
33,9 → 35,8
CriticalSection: CRITICAL_SECTION;
import*, multi: BOOLEAN;
_import*, multi: BOOLEAN;
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
284,24 → 285,24
BEGIN
OutString("import error: ");
IF K.imp_error.error = 1 THEN
OutString("can't load "); OutString(K.imp_error.lib)
OutString("can't load '"); OutString(K.imp_error.lib)
ELSIF K.imp_error.error = 2 THEN
OutString("not found "); OutString(K.imp_error.proc); OutString(" in "); OutString(K.imp_error.lib)
OutString("not found '"); OutString(K.imp_error.proc); OutString("' in '"); OutString(K.imp_error.lib)
END;
OutString("'");
OutLn
END imp_error;
PROCEDURE init* (_import, code: INTEGER);
PROCEDURE init* (import_, code: INTEGER);
BEGIN
multi := FALSE;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - SizeOfHeader;
K.sysfunc2(68, 11);
InitializeCriticalSection(CriticalSection);
K._init;
import := (K.dll_Load(_import) = 0) & (K.imp_error.error = 0);
IF ~import THEN
_import := (K.dll_Load(import_) = 0) & (K.imp_error.error = 0);
IF ~_import THEN
imp_error
END
END init;

/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
Copyright 2016, 2018, 2020 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
24,7 → 24,7
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
type,
_type,
procinfo,
com_area_name,
com_area,
61,7 → 61,7
IF res # NIL THEN
res.s_com_area_name := "FFFFFFFF_color_dlg";
res.com_area := 0;
res.type := 0;
res._type := 0;
res.color_type := 0;
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);

/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07
13,7 → 13,7
CONST
slash* = "/";
OS* = "KOS";
eol* = 0DX + 0AX;
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
24,6 → 24,8
TYPE
DAYS = ARRAY 12, 31, 2 OF INTEGER;
FNAME = ARRAY 520 OF CHAR;
FS = POINTER TO rFS;
52,11 → 54,11
Console: BOOLEAN;
days: DAYS;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
273,6 → 275,10
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
END chmod;
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9)
END GetTickCount;
382,9 → 388,9
s[j] := c;
INC(j)
END;
INC(i);
INC(i)
END
END;
END;
s[j] := 0X
END GetArg;
408,9 → 414,9
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
PROCEDURE UnixTime* (): INTEGER;
VAR
date, time: INTEGER;
date, time, year, month, day, hour, min, sec: INTEGER;
BEGIN
date := K.sysfunc1(29);
446,22 → 452,26
sec := (time MOD 16) * 10 + sec;
time := time DIV 16;
year := year + 2000
END now;
INC(year, 2000)
PROCEDURE UnixTime* (): INTEGER;
RETURN 0
RETURN ((year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4) * 86400 + hour * 3600 + min * 60 + sec
END UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
SYSTEM.GET32(SYSTEM.ADR(x), a);
SYSTEM.GET32(SYSTEM.ADR(x) + 4, b)
RETURN a
END splitf;
PROCEDURE d2s* (x: REAL): INTEGER;
VAR
h, l, s, e: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h);
e := splitf(x, l, h);
s := ASR(h, 31) MOD 2;
e := (h DIV 100000H) MOD 2048;
480,7 → 490,7
l := 0
ELSIF e = 2047 THEN
e := 1151;
IF (h MOD 100000H # 0) OR (l # 0) THEN
IF (h MOD 100000H # 0) OR (BITS(l) * {0..31} # {}) THEN
h := 80000H;
l := 0
END
491,21 → 501,55
END d2s;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
PROCEDURE init (VAR days: DAYS);
VAR
i, j, n0, n1: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), a);
SYSTEM.GET(SYSTEM.ADR(x) + 4, b)
RETURN a
END splitf;
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
days[i, j, 0] := 0;
days[i, j, 1] := 0;
END
END;
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
days[ 1, 28, 0] := -1;
FOR i := 0 TO 1 DO
days[ 1, 29, i] := -1;
days[ 1, 30, i] := -1;
days[ 3, 30, i] := -1;
days[ 5, 30, i] := -1;
days[ 8, 30, i] := -1;
days[10, 30, i] := -1;
END;
n0 := 0;
n1 := 0;
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
IF days[i, j, 0] = 0 THEN
days[i, j, 0] := n0;
INC(n0)
END;
IF days[i, j, 1] = 0 THEN
days[i, j, 1] := n1;
INC(n1)
END
END
END;
maxreal := 1.9;
PACK(maxreal, 1023);
Console := API.import;
Console := API._import;
IF Console THEN
con_init(-1, -1, -1, -1, SYSTEM.SADR("Oberon-07 for KolibriOS"))
END;
ParamParse
END init;
BEGIN
init(days)
END HOST.

/programs/develop/oberon07/Lib/KolibriOS/Math.ob07
1,18 → 1,8
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2013-2014, 2018-2020 Anton Krotov
All rights reserved.
*)
MODULE Math;
235,6 → 225,16
END frac;
PROCEDURE sqri* (x: INTEGER): INTEGER;
RETURN x * x
END sqri;
PROCEDURE sqrr* (x: REAL): REAL;
RETURN x * x
END sqrr;
PROCEDURE arcsin* (x: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
349,6 → 349,40
END power;
PROCEDURE ipower* (base: REAL; exponent: INTEGER): REAL;
VAR
i: INTEGER;
a: REAL;
BEGIN
a := 1.0;
IF base # 0.0 THEN
IF exponent # 0 THEN
IF exponent < 0 THEN
base := 1.0 / base
END;
i := ABS(exponent);
WHILE i > 0 DO
WHILE ~ODD(i) DO
i := LSR(i, 1);
base := sqrr(base)
END;
DEC(i);
a := a * base
END
ELSE
a := 1.0
END
ELSE
ASSERT(exponent > 0);
a := 0.0
END
RETURN a
END ipower;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
381,4 → 415,36
END fact;
PROCEDURE DegToRad* (x: REAL): REAL;
RETURN x * (pi / 180.0)
END DegToRad;
PROCEDURE RadToDeg* (x: REAL): REAL;
RETURN x * (180.0 / pi)
END RadToDeg;
(* Return hypotenuse of triangle *)
PROCEDURE hypot* (x, y: REAL): REAL;
VAR
a: REAL;
BEGIN
x := ABS(x);
y := ABS(y);
IF x > y THEN
a := x * sqrt(1.0 + sqrr(y / x))
ELSE
IF x > 0.0 THEN
a := y * sqrt(1.0 + sqrr(x / y))
ELSE
a := y
END
END
RETURN a
END hypot;
END Math.

/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
Copyright 2016, 2018, 2020 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
24,7 → 24,7
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
type,
_type,
procinfo,
com_area_name,
com_area,
66,7 → 66,7
END
END Show;
PROCEDURE Create*(draw_window: DRAW_WINDOW; type: INTEGER; def_path, filter: ARRAY OF CHAR): Dialog;
PROCEDURE Create*(draw_window: DRAW_WINDOW; _type: INTEGER; def_path, filter: ARRAY OF CHAR): Dialog;
VAR res: Dialog; n, i: INTEGER;
PROCEDURE replace(VAR str: ARRAY OF CHAR; c1, c2: CHAR);
88,7 → 88,7
IF res.filter_area # NIL THEN
res.s_com_area_name := "FFFFFFFF_open_dialog";
res.com_area := 0;
res.type := type;
res._type := _type;
res.draw_window := draw_window;
COPY(def_path, res.s_dir_default_path);
COPY(filter, res.filter_area.filter);

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

/programs/develop/oberon07/Lib/KolibriOS/libimg.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 KolibriOS team
Copyright 2016, 2018, 2020 KolibriOS team
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
203,7 → 203,7
img_create *: PROCEDURE (width, height, type: INTEGER): INTEGER;
img_create *: PROCEDURE (width, height, _type: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? creates an Image structure and initializes some its fields ;;

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

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

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

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

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

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

/programs/develop/oberon07/Lib/Linux32/Math.ob07
1,18 → 1,8
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2013-2014, 2018-2020 Anton Krotov
All rights reserved.
*)
MODULE Math;
235,6 → 225,16
END frac;
PROCEDURE sqri* (x: INTEGER): INTEGER;
RETURN x * x
END sqri;
PROCEDURE sqrr* (x: REAL): REAL;
RETURN x * x
END sqrr;
PROCEDURE arcsin* (x: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
349,6 → 349,40
END power;
PROCEDURE ipower* (base: REAL; exponent: INTEGER): REAL;
VAR
i: INTEGER;
a: REAL;
BEGIN
a := 1.0;
IF base # 0.0 THEN
IF exponent # 0 THEN
IF exponent < 0 THEN
base := 1.0 / base
END;
i := ABS(exponent);
WHILE i > 0 DO
WHILE ~ODD(i) DO
i := LSR(i, 1);
base := sqrr(base)
END;
DEC(i);
a := a * base
END
ELSE
a := 1.0
END
ELSE
ASSERT(exponent > 0);
a := 0.0
END
RETURN a
END ipower;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
381,4 → 415,36
END fact;
PROCEDURE DegToRad* (x: REAL): REAL;
RETURN x * (pi / 180.0)
END DegToRad;
PROCEDURE RadToDeg* (x: REAL): REAL;
RETURN x * (180.0 / pi)
END RadToDeg;
(* Return hypotenuse of triangle *)
PROCEDURE hypot* (x, y: REAL): REAL;
VAR
a: REAL;
BEGIN
x := ABS(x);
y := ABS(y);
IF x > y THEN
a := x * sqrt(1.0 + sqrr(y / x))
ELSE
IF x > 0.0 THEN
a := y * sqrt(1.0 + sqrr(x / y))
ELSE
a := y
END
END
RETURN a
END hypot;
END Math.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

/programs/develop/oberon07/Lib/RVM32I/Trap.ob07
0,0 → 1,128
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE Trap;
IMPORT SYSTEM;
PROCEDURE [code] sp* (): INTEGER
22, 0, 4; (* MOV R0, SP *)
PROCEDURE [code] syscall* (ptr: INTEGER)
22, 0, 4, (* MOV R0, SP *)
27, 0, 4, (* ADD R0, 4 *)
9, 0, 0, (* LDR32 R0, R0 *)
80, 0, 0; (* SYSCALL R0 *)
PROCEDURE Char (c: CHAR);
VAR
a: ARRAY 2 OF INTEGER;
BEGIN
a[0] := 8;
a[1] := ORD(c);
syscall(SYSTEM.ADR(a[0]))
END Char;
PROCEDURE String (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE s[i] # 0X DO
Char(s[i]);
INC(i)
END
END String;
PROCEDURE PString (ptr: INTEGER);
VAR
c: CHAR;
BEGIN
SYSTEM.GET(ptr, c);
WHILE c # 0X DO
Char(c);
INC(ptr);
SYSTEM.GET(ptr, c)
END
END PString;
PROCEDURE Ln;
BEGIN
String(0DX + 0AX)
END Ln;
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
BEGIN
i := 0;
a := x;
REPEAT
INC(i);
a := a DIV 10
UNTIL a = 0;
str[i] := 0X;
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END IntToStr;
PROCEDURE Int (x: INTEGER);
VAR
s: ARRAY 32 OF CHAR;
BEGIN
IntToStr(x, s);
String(s)
END Int;
PROCEDURE trap* (modnum, _module, err, line: INTEGER);
VAR
s: ARRAY 32 OF CHAR;
BEGIN
CASE err OF
| 1: s := "assertion failure"
| 2: s := "NIL dereference"
| 3: s := "bad divisor"
| 4: s := "NIL procedure call"
| 5: s := "type guard error"
| 6: s := "index out of range"
| 7: s := "invalid CASE"
| 8: s := "array assignment error"
| 9: s := "CHR out of range"
|10: s := "WCHR out of range"
|11: s := "BYTE out of range"
END;
Ln;
String("error ("); Int(err); String("): "); String(s); Ln;
String("module: "); PString(_module); Ln;
String("line: "); Int(line); Ln;
SYSTEM.CODE(0, 0, 0) (* STOP *)
END trap;
END Trap.

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

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

/programs/develop/oberon07/Lib/Windows32/UnixTime.ob07
File deleted
\ No newline at end of file

/programs/develop/oberon07/Lib/Windows32/Utils.ob07
File deleted
\ No newline at end of file

/programs/develop/oberon07/Lib/Windows32/API.ob07
12,6 → 12,8
CONST
eol* = 0DX + 0AX;
SectionAlignment = 1000H;
DLL_PROCESS_ATTACH = 1;
19,7 → 21,10
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
KERNEL = "kernel32.dll";
USER = "user32.dll";
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
27,7 → 32,6
VAR
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
heap: INTEGER;
36,15 → 40,14
thread_attach: DLL_ENTRY;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetProcessHeap"] GetProcessHeap (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapAlloc"] HeapAlloc (hHeap, dwFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapFree"] HeapFree(hHeap, dwFlags, lpMem: INTEGER);
PROCEDURE [windows-, KERNEL, ""] ExitProcess (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] ExitThread (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] GetProcessHeap (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] HeapAlloc (hHeap, dwFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] HeapFree (hHeap, dwFlags, lpMem: INTEGER);
PROCEDURE [windows-, USER, ""] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, "user32.dll", "MessageBoxA"] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
MessageBoxA(0, lpText, lpCaption, 16)
68,7 → 71,6
process_detach := NIL;
thread_detach := NIL;
thread_attach := NIL;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - SectionAlignment;
heap := GetProcessHeap()
END init;

/programs/develop/oberon07/Lib/Windows32/Args.ob07
1,7 → 1,7
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
54,7 → 54,7
BEGIN
p := WINAPI.GetCommandLine();
p := WINAPI.GetCommandLineA();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO

/programs/develop/oberon07/Lib/Windows32/Console.ob07
1,7 → 1,7
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
48,7 → 48,7
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
fill := ORD(ScrBufInfo.dwSize.X) * ORD(ScrBufInfo.dwSize.Y);
WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputCharacterA(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputAttribute(hConsoleOutput, ORD(ScrBufInfo.wAttributes), fill, 0, SYSTEM.ADR(fill));
SetCursor(0, 0)
END Cls;

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

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

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

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

/programs/develop/oberon07/Lib/Windows32/Math.ob07
1,18 → 1,8
(*
Copyright 2013, 2014, 2018, 2019 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2013-2014, 2018-2020 Anton Krotov
All rights reserved.
*)
MODULE Math;
235,6 → 225,16
END frac;
PROCEDURE sqri* (x: INTEGER): INTEGER;
RETURN x * x
END sqri;
PROCEDURE sqrr* (x: REAL): REAL;
RETURN x * x
END sqrr;
PROCEDURE arcsin* (x: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
349,6 → 349,40
END power;
PROCEDURE ipower* (base: REAL; exponent: INTEGER): REAL;
VAR
i: INTEGER;
a: REAL;
BEGIN
a := 1.0;
IF base # 0.0 THEN
IF exponent # 0 THEN
IF exponent < 0 THEN
base := 1.0 / base
END;
i := ABS(exponent);
WHILE i > 0 DO
WHILE ~ODD(i) DO
i := LSR(i, 1);
base := sqrr(base)
END;
DEC(i);
a := a * base
END
ELSE
a := 1.0
END
ELSE
ASSERT(exponent > 0);
a := 0.0
END
RETURN a
END ipower;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
381,4 → 415,36
END fact;
PROCEDURE DegToRad* (x: REAL): REAL;
RETURN x * (pi / 180.0)
END DegToRad;
PROCEDURE RadToDeg* (x: REAL): REAL;
RETURN x * (180.0 / pi)
END RadToDeg;
(* Return hypotenuse of triangle *)
PROCEDURE hypot* (x, y: REAL): REAL;
VAR
a: REAL;
BEGIN
x := ABS(x);
y := ABS(y);
IF x > y THEN
a := x * sqrt(1.0 + sqrr(y / x))
ELSE
IF x > 0.0 THEN
a := y * sqrt(1.0 + sqrr(x / y))
ELSE
a := y
END
END
RETURN a
END hypot;
END Math.

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

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

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

/programs/develop/oberon07/Lib/Windows64/UnixTime.ob07
File deleted
\ No newline at end of file

/programs/develop/oberon07/Lib/Windows64/API.ob07
12,6 → 12,8
CONST
eol* = 0DX + 0AX;
SectionAlignment = 1000H;
DLL_PROCESS_ATTACH = 1;
19,7 → 21,10
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
KERNEL = "kernel32.dll";
USER = "user32.dll";
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
27,7 → 32,6
VAR
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
heap: INTEGER;
36,15 → 40,14
thread_attach: DLL_ENTRY;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GetProcessHeap"] GetProcessHeap (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapAlloc"] HeapAlloc (hHeap, dwFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "HeapFree"] HeapFree(hHeap, dwFlags, lpMem: INTEGER);
PROCEDURE [windows-, KERNEL, ""] ExitProcess (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] ExitThread (code: INTEGER);
PROCEDURE [windows-, KERNEL, ""] GetProcessHeap (): INTEGER;
PROCEDURE [windows-, KERNEL, ""] HeapAlloc (hHeap, dwFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, KERNEL, ""] HeapFree (hHeap, dwFlags, lpMem: INTEGER);
PROCEDURE [windows-, USER, ""] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE [windows-, "user32.dll", "MessageBoxA"] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
MessageBoxA(0, lpText, lpCaption, 16)
68,7 → 71,6
process_detach := NIL;
thread_detach := NIL;
thread_attach := NIL;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - SectionAlignment;
heap := GetProcessHeap()
END init;

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

/programs/develop/oberon07/Lib/Windows64/Console.ob07
1,7 → 1,7
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
48,7 → 48,7
BEGIN
WINAPI.GetConsoleScreenBufferInfo(hConsoleOutput, ScrBufInfo);
fill := ORD(ScrBufInfo.dwSize.X) * ORD(ScrBufInfo.dwSize.Y);
WINAPI.FillConsoleOutputCharacter(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputCharacterA(hConsoleOutput, 20H, fill, 0, SYSTEM.ADR(fill));
WINAPI.FillConsoleOutputAttribute(hConsoleOutput, ORD(ScrBufInfo.wAttributes), fill, 0, SYSTEM.ADR(fill));
SetCursor(0, 0)
END Cls;

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

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

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

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

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

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

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

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

/programs/develop/oberon07/Samples/Dialogs.ob07
File deleted
\ No newline at end of file

/programs/develop/oberon07/Samples/HW_con.ob07
File deleted
\ No newline at end of file

/programs/develop/oberon07/Samples/HW.ob07
File deleted
\ No newline at end of file

/programs/develop/oberon07/Samples/KolibriOS/Dialogs.ob07
0,0 → 1,110
MODULE Dialogs;
IMPORT KOSAPI, sys := SYSTEM, OpenDlg, ColorDlg;
VAR header: ARRAY 1024 OF CHAR; back_color: INTEGER;
PROCEDURE WindowRedrawStatus(p: INTEGER);
BEGIN
KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER);
BEGIN
KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext)
END DefineAndDrawWindow;
PROCEDURE WaitForEvent(): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
PROCEDURE ExitApp;
BEGIN
KOSAPI.sysfunc1(-1)
END ExitApp;
PROCEDURE pause(t: INTEGER);
BEGIN
KOSAPI.sysfunc2(5, t)
END pause;
PROCEDURE Buttons;
PROCEDURE Button(id, X, Y, W, H: INTEGER; Caption: ARRAY OF CHAR);
VAR n, aux: INTEGER;
BEGIN
n := LENGTH(Caption);
aux := KOSAPI.sysfunc5(8, X * 65536 + W, Y * 65536 + H, id, 00C0C0C0H);
X := X + (W - 8 * n) DIV 2;
Y := Y + (H - 14) DIV 2;
aux := KOSAPI.sysfunc6(4, X * 65536 + Y, LSL(48, 24), sys.ADR(Caption[0]), n, 0)
END Button;
BEGIN
Button(17, 5, 5, 70, 25, "open");
Button(18, 85, 5, 70, 25, "color");
END Buttons;
PROCEDURE draw_window;
BEGIN
WindowRedrawStatus(1);
DefineAndDrawWindow(200, 200, 500, 100, back_color, 51, 0, 0, sys.ADR(header[0]));
Buttons;
WindowRedrawStatus(2);
END draw_window;
PROCEDURE OpenFile(Open: OpenDlg.Dialog);
BEGIN
IF Open # NIL THEN
OpenDlg.Show(Open, 500, 450);
WHILE Open.status = 2 DO
pause(30)
END;
IF Open.status = 1 THEN
COPY(Open.FilePath, header)
END
END
END OpenFile;
PROCEDURE SelColor(Color: ColorDlg.Dialog);
BEGIN
IF Color # NIL THEN
ColorDlg.Show(Color);
WHILE Color.status = 2 DO
pause(30)
END;
IF Color.status = 1 THEN
back_color := Color.color
END
END
END SelColor;
PROCEDURE main;
VAR Open: OpenDlg.Dialog; Color: ColorDlg.Dialog; res, al: INTEGER;
BEGIN
back_color := 00FFFFFFH;
header := "Dialogs";
draw_window;
Open := OpenDlg.Create(draw_window, 0, "/rd/1", "ASM|TXT|INI");
Color := ColorDlg.Create(draw_window);
WHILE TRUE DO
CASE WaitForEvent() OF
|1: draw_window
|3: res := KOSAPI.sysfunc1(17);
al := LSR(LSL(res, 24), 24);
res := LSR(res, 8);
IF al = 0 THEN
CASE res OF
| 1: ExitApp
|17: OpenFile(Open)
|18: SelColor(Color)
END
END
ELSE
END
END
END main;
BEGIN
main
END Dialogs.

/programs/develop/oberon07/Samples/KolibriOS/HW.ob07
0,0 → 1,50
MODULE HW;
IMPORT sys := SYSTEM, KOSAPI;
PROCEDURE WindowRedrawStatus(p: INTEGER);
BEGIN
KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER);
BEGIN
KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext)
END DefineAndDrawWindow;
PROCEDURE WriteTextToWindow(x, y, color: INTEGER; text: ARRAY OF CHAR);
BEGIN
KOSAPI.sysfunc6(4, x * 65536 + y, color + LSL(48, 24), sys.ADR(text[0]), LENGTH(text), 0)
END WriteTextToWindow;
PROCEDURE WaitForEvent(): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
PROCEDURE ExitApp;
BEGIN
KOSAPI.sysfunc1(-1)
END ExitApp;
PROCEDURE draw_window(header, text: ARRAY OF CHAR);
BEGIN
WindowRedrawStatus(1);
DefineAndDrawWindow(200, 200, 200, 100, 0FFFFFFH, 51, 0, 0, sys.ADR(header));
WriteTextToWindow(10, 10, 0FF0000H, text);
WindowRedrawStatus(2);
END draw_window;
PROCEDURE Main(header, text: ARRAY OF CHAR);
BEGIN
WHILE TRUE DO
CASE WaitForEvent() OF
|1: draw_window(header, text)
|3: ExitApp
ELSE
END
END
END Main;
BEGIN
Main("HW", "Hello, world!")
END HW.

/programs/develop/oberon07/Samples/KolibriOS/HW_con.ob07
0,0 → 1,63
MODULE HW_con;
IMPORT Out, In, Console, DateTime;
PROCEDURE OutInt2(n: INTEGER);
BEGIN
ASSERT((0 <= n) & (n <= 99));
IF n < 10 THEN
Out.Char("0")
END;
Out.Int(n, 0)
END OutInt2;
PROCEDURE OutMonth(n: INTEGER);
VAR
str: ARRAY 4 OF CHAR;
BEGIN
CASE n OF
| 1: str := "jan"
| 2: str := "feb"
| 3: str := "mar"
| 4: str := "apr"
| 5: str := "may"
| 6: str := "jun"
| 7: str := "jul"
| 8: str := "aug"
| 9: str := "sep"
|10: str := "oct"
|11: str := "nov"
|12: str := "dec"
END;
Out.String(str)
END OutMonth;
PROCEDURE main;
VAR
Year, Month, Day, Hour, Min, Sec, Msec: INTEGER;
BEGIN
Out.String("Hello, world!"); Out.Ln;
Console.SetColor(Console.White, Console.Red);
DateTime.Now(Year, Month, Day, Hour, Min, Sec, Msec);
Out.Int(Year, 0); Out.Char("-");
OutMonth(Month); Out.Char("-");
OutInt2(Day); Out.Char(" ");
OutInt2(Hour); Out.Char(":");
OutInt2(Min); Out.Char(":");
OutInt2(Sec)
END main;
BEGIN
Console.open;
main;
In.Ln;
Console.exit(TRUE)
END HW_con.

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

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

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

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

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

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

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

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

/programs/develop/oberon07/Samples/Linux/X11/filler/filler.txt
0,0 → 1,15

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

/programs/develop/oberon07/Samples/Windows/Console/Hello.ob07
0,0 → 1,13
MODULE Hello;
IMPORT Console, In, Out;
BEGIN
Console.open;
Out.String("Hello, world!");
In.Ln;
Console.exit(TRUE)
END Hello.

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

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

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

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

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

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

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

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

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

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

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

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

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

/programs/develop/oberon07/Source/AMD64.ob07
8,7 → 8,7
MODULE AMD64;
IMPORT IL, BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS, PATHS, PROG, TARGETS,
REG, C := CONSOLE, UTILS, S := STRINGS, PE32, ELF, X86;
REG, UTILS, S := STRINGS, PE32, ELF, X86, ERRORS;
CONST
27,6 → 27,8
rsi = 6;
rdi = 7;
MAX_XMM = 5;
je = 84H; jne = 85H; jl = 8CH; jge = 8DH; jle = 8EH; jg = 8FH; jb = 82H;
sete = 94H; setne = 95H; setl = 9CH; setge = 9DH; setle = 9EH; setg = 9FH; setc = 92H; setnc = 93H;
38,7 → 40,9
sBSS = BIN.PICBSS;
sIMP = BIN.PICIMP;
FPR_ERR = 41;
TYPE
COMMAND = IL.COMMAND;
65,7 → 69,11
Win64RegPar: ARRAY 4 OF INTEGER;
SystemVRegPar: ARRAY 6 OF INTEGER;
Xmm: ARRAY 1000 OF INTEGER;
fname: PATHS.PATH;
PROCEDURE OutByte (b: BYTE);
BEGIN
X86.OutByte(b)
96,24 → 104,19
END OutInt;
PROCEDURE isByte (n: INTEGER): BOOLEAN;
RETURN (-128 <= n) & (n <= 127)
END isByte;
PROCEDURE short (n: INTEGER): INTEGER;
RETURN 2 * ORD(isByte(n))
RETURN 2 * ORD(X86.isByte(n))
END short;
PROCEDURE long (n: INTEGER): INTEGER;
RETURN 40H * ORD(~isByte(n))
RETURN 40H * ORD(~X86.isByte(n))
END long;
PROCEDURE OutIntByte (n: INTEGER);
BEGIN
IF isByte(n) THEN
IF X86.isByte(n) THEN
OutByte(n MOD 256)
ELSE
OutInt(n)
191,10 → 194,10
END and;
PROCEDURE or (reg1, reg2: INTEGER); (* or reg1, reg2 *)
PROCEDURE _or (reg1, reg2: INTEGER); (* or reg1, reg2 *)
BEGIN
oprr(09H, reg1, reg2)
END or;
END _or;
PROCEDURE add (reg1, reg2: INTEGER); (* add reg1, reg2 *)
211,7 → 214,12
PROCEDURE xchg (reg1, reg2: INTEGER); (* xchg reg1, reg2 *)
BEGIN
IF rax IN {reg1, reg2} THEN
Rex(reg1 + reg2, 0);
OutByte(90H + (reg1 + reg2) MOD 8)
ELSE
oprr(87H, reg1, reg2)
END
END xchg;
270,17 → 278,9
PROCEDURE callimp (label: INTEGER);
VAR
reg: INTEGER;
BEGIN
reg := GetAnyReg();
lea(reg, label, sIMP);
IF reg >= 8 THEN (* call qword[reg] *)
OutByte(41H)
END;
OutByte2(0FFH, 10H + reg MOD 8);
drop
OutByte2(0FFH, 15H); (* call qword[rip + label + IMP] *)
X86.Reloc(sIMP, label)
END callimp;
383,8 → 383,7
oprlongc(reg, n, oprr)
ELSE
Rex(reg, 0);
OutByte2(81H + short(n), op + reg MOD 8);
OutIntByte(n)
X86.oprc(op, reg, n)
END
END oprc;
419,7 → 418,7
PROCEDURE orrc (reg, n: INTEGER); (* or reg, n *)
BEGIN
oprc(0C8H, reg, n, or)
oprc(0C8H, reg, n, _or)
END orrc;
440,7 → 439,7
push(reg2);
drop
ELSE
OutByte(68H + short(n)); OutIntByte(n) (* push n *)
X86.pushc(n)
END
END pushc;
553,21 → 552,6
END jcc;
PROCEDURE jmp (label: INTEGER); (* jmp label *)
BEGIN
X86.jmp(label)
END jmp;
PROCEDURE setcc (cc, reg: INTEGER); (* setcc reg8 *)
BEGIN
IF reg >= 8 THEN
OutByte(41H)
END;
OutByte3(0FH, cc, 0C0H + reg MOD 8)
END setcc;
PROCEDURE shiftrc (op, reg, n: INTEGER);
BEGIN
Rex(reg, 0);
829,7 → 813,7
cc := setnc
END;
OutByte2(7AH, 3 + reg DIV 8); (* jp L *)
setcc(cc, reg);
X86.setcc(cc, reg)
(* L: *)
END fcmp;
859,7 → 843,7
CASE opcode OF
|IL.opJMP:
jmp(param1)
X86.jmp(param1)
|IL.opCALL, IL.opWIN64CALL, IL.opSYSVCALL:
REG.Store(R);
907,24 → 891,24
|IL.opONERR:
pushc(param2);
jmp(param1)
X86.jmp(param1)
|IL.opPUSHC:
pushc(param2)
|IL.opPRECALL:
n := param2;
IF (param1 # 0) & (n # 0) THEN
PushAll(0);
IF (param2 # 0) & (xmm >= 0) THEN
subrc(rsp, 8)
END;
WHILE n > 0 DO
INC(Xmm[0]);
Xmm[Xmm[0]] := xmm + 1;
WHILE xmm >= 0 DO
subrc(rsp, 8);
movsdmr(rsp, 0, xmm);
DEC(xmm);
DEC(n)
DEC(xmm)
END;
ASSERT(xmm = -1);
PushAll(0)
ASSERT(xmm = -1)
|IL.opWIN64ALIGN16:
ASSERT(rax IN R.regs);
942,27 → 926,26
push(rax)
END
|IL.opRESF:
|IL.opRESF, IL.opRES:
ASSERT(R.top = -1);
ASSERT(xmm = -1);
n := Xmm[Xmm[0]]; DEC(Xmm[0]);
IF opcode = IL.opRESF THEN
INC(xmm);
n := param2;
IF n > 0 THEN
movsdmr(rsp, n * 8, xmm);
movsdmr(rsp, n * 8, 0);
DEC(xmm);
INC(n)
END;
WHILE n > 0 DO
INC(xmm);
movsdrm(xmm, rsp, 0);
addrc(rsp, 8);
DEC(n)
IF xmm + n > MAX_XMM THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END
ELSE
GetRegA
END;
|IL.opRES:
ASSERT(R.top = -1);
GetRegA;
n := param2;
WHILE n > 0 DO
INC(xmm);
movsdrm(xmm, rsp, 0);
1137,31 → 1120,29
IF reg2 # -1 THEN
mov(reg1, reg2)
ELSE
n := param2 * 8;
xor(reg1, reg1);
movrm32(reg1, rbp, n)
END
movrm32(reg1, rbp, param2 * 8)
END;
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32)
|IL.opGLOAD64:
reg1 := GetAnyReg();
lea(reg1, param2, sBSS);
movrm(reg1, reg1, 0)
Rex(0, reg1); (* mov reg1, qword[rip + param2 + BSS] *)
OutByte2(8BH, 05H + 8 * (reg1 MOD 8));
X86.Reloc(sBSS, param2)
|IL.opGLOAD8:
|IL.opGLOAD8, IL.opGLOAD16:
reg1 := GetAnyReg();
lea(reg1, param2, sBSS);
movzx(reg1, reg1, 0, FALSE)
Rex(0, reg1); (* movzx reg1, byte/word[rip + param2 + BSS] *)
OutByte3(0FH, 0B6H + ORD(opcode = IL.opGLOAD16), 05H + 8 * (reg1 MOD 8));
X86.Reloc(sBSS, param2)
|IL.opGLOAD16:
reg1 := GetAnyReg();
lea(reg1, param2, sBSS);
movzx(reg1, reg1, 0, TRUE)
|IL.opGLOAD32:
reg1 := GetAnyReg();
xor(reg1, reg1);
lea(reg1, param2, sBSS);
movrm32(reg1, reg1, 0)
movrm32(reg1, reg1, 0);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32)
|IL.opVLOAD64:
reg1 := GetAnyReg();
1177,9 → 1158,10
|IL.opVLOAD32:
reg1 := GetAnyReg();
reg2 := GetAnyReg();
xor(reg1, reg1);
movrm(reg2, rbp, param2 * 8);
movrm32(reg1, reg2, 0);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32);
drop
|IL.opLADR:
1186,14 → 1168,22
n := param2 * 8;
next := cmd.next(COMMAND);
IF (next.opcode = IL.opSAVEF) OR (next.opcode = IL.opSAVEFI) THEN
ASSERT(xmm >= 0);
movsdmr(rbp, n, xmm);
DEC(xmm);
cmd := next
ELSIF next.opcode = IL.opLOADF THEN
INC(xmm);
IF xmm > MAX_XMM THEN
ERRORS.ErrorMsg(fname, next.param1, next.param2, FPR_ERR)
END;
movsdrm(xmm, rbp, n);
cmd := next
ELSE
IF (next.opcode = IL.opADDC) & ~isLong(n + next.param2) THEN
INC(n, next.param2);
cmd := next
END;
reg1 := GetAnyReg();
Rex(0, reg1);
OutByte2(8DH, 45H + long(n) + (reg1 MOD 8) * 8); (* lea reg1, qword[rbp+n] *)
1201,6 → 1191,11
END
|IL.opGADR:
next := cmd.next(COMMAND);
IF (next.opcode = IL.opADDC) & ~isLong(param2 + next.param2) THEN
INC(param2, next.param2);
cmd := next
END;
lea(GetAnyReg(), param2, sBSS)
|IL.opVADR:
1311,15 → 1306,15
cc := X86.cond(opcode);
next := cmd.next(COMMAND);
IF next.opcode = IL.opJE THEN
IF next.opcode = IL.opJNZ THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJNE THEN
ELSIF next.opcode = IL.opJZ THEN
jcc(X86.inv0(cc), next.param1);
cmd := next
ELSE
reg1 := GetAnyReg();
setcc(cc + 16, reg1);
X86.setcc(cc + 16, reg1);
andrc(reg1, 1)
END
1342,36 → 1337,23
PushAll(n)
END
|IL.opACC:
IF (R.top # 0) OR (R.stk[0] # rax) THEN
PushAll(0);
GetRegA;
pop(rax);
DEC(R.pushed)
END
|IL.opJNZ:
|IL.opJNZ1:
UnOp(reg1);
test(reg1);
jcc(jne, param1)
|IL.opJZ:
UnOp(reg1);
test(reg1);
jcc(je, param1)
|IL.opJG:
UnOp(reg1);
test(reg1);
jcc(jg, param1)
|IL.opJE:
|IL.opJNZ:
UnOp(reg1);
test(reg1);
jcc(jne, param1);
drop
|IL.opJNE:
|IL.opJZ:
UnOp(reg1);
test(reg1);
jcc(je, param1);
1388,11 → 1370,11
cmprc(reg1, 64);
jcc(jb, L);
xor(reg1, reg1);
jmp(label);
X86.jmp(label);
X86.SetLabel(L);
Rex(reg2, reg1);
OutByte3(0FH, 0A3H, 0C0H + 8 * (reg1 MOD 8) + reg2 MOD 8); (* bt reg2, reg1 *)
setcc(setc, reg1);
X86.setcc(setc, reg1);
andrc(reg1, 1);
X86.SetLabel(label);
drop
1402,19 → 1384,19
Rex(reg1, 0);
OutByte2(0FH, 0BAH); (* bt reg1, param2 *)
OutByte2(0E0H + reg1 MOD 8, param2);
setcc(setc, reg1);
X86.setcc(setc, reg1);
andrc(reg1, 1)
|IL.opNOT:
UnOp(reg1);
test(reg1);
setcc(sete, reg1);
X86.setcc(sete, reg1);
andrc(reg1, 1)
|IL.opORD:
UnOp(reg1);
test(reg1);
setcc(setne, reg1);
X86.setcc(setne, reg1);
andrc(reg1, 1)
|IL.opABS:
1439,9 → 1421,9
X86.SetLabel(label);
cmprr(reg1, reg2);
IF opcode = IL.opEQB THEN
setcc(sete, reg1)
X86.setcc(sete, reg1)
ELSE
setcc(setne, reg1)
X86.setcc(setne, reg1)
END;
andrc(reg1, 1)
1453,7 → 1435,7
UnOp(reg1);
xorrc(reg1, param2)
|IL.opADDSL, IL.opADDSR:
|IL.opADDSC:
UnOp(reg1);
orrc(reg1, param2)
1688,19 → 1670,18
|IL.opSUBR, IL.opSUBL:
UnOp(reg1);
n := param2;
IF n = 1 THEN
IF param2 = 1 THEN
decr(reg1)
ELSIF n = -1 THEN
ELSIF param2 = -1 THEN
incr(reg1)
ELSIF n # 0 THEN
subrc(reg1, n)
ELSIF param2 # 0 THEN
subrc(reg1, param2)
END;
IF opcode = IL.opSUBL THEN
neg(reg1)
END
|IL.opADDL, IL.opADDR:
|IL.opADDC:
IF (param2 # 0) & ~isLong(param2) THEN
UnOp(reg1);
next := cmd.next(COMMAND);
1851,7 → 1832,7
|IL.opADDS:
BinOp(reg1, reg2);
or(reg1, reg2);
_or(reg1, reg2);
drop
|IL.opSUBS:
1860,7 → 1841,7
and(reg1, reg2);
drop
|IL.opNOP:
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opSWITCH:
UnOp(reg1);
2008,8 → 1989,8
reg1 := GetAnyReg();
CASE opcode OF
|IL.opEQP, IL.opEQIP: setcc(sete, reg1)
|IL.opNEP, IL.opNEIP: setcc(setne, reg1)
|IL.opEQP, IL.opEQIP: X86.setcc(sete, reg1)
|IL.opNEP, IL.opNEIP: X86.setcc(setne, reg1)
END;
andrc(reg1, 1)
2045,9 → 2026,8
drop
|IL.opCLEANUP:
n := param2 * 8;
IF n # 0 THEN
addrc(rsp, n)
IF param2 # 0 THEN
addrc(rsp, param2 * 8)
END
|IL.opPOPSP:
2056,10 → 2036,14
|IL.opLOADF:
UnOp(reg1);
INC(xmm);
IF xmm > MAX_XMM THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
movsdrm(xmm, reg1, 0);
drop
|IL.opPUSHF:
ASSERT(xmm >= 0);
subrc(rsp, 8);
movsdmr(rsp, 0, xmm);
DEC(xmm)
2067,66 → 2051,78
|IL.opCONSTF:
float := cmd.float;
INC(xmm);
reg1 := GetAnyReg();
lea(reg1, Numbers_Offs + Numbers_Count * 8, sDATA);
movsdrm(xmm, reg1, 0);
drop;
IF xmm > MAX_XMM THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
(* movsd xmm, qword ptr [rip + Numbers_Offs + Numbers_Count * 8 + DATA] *)
OutByte(0F2H);
IF xmm >= 8 THEN
OutByte(44H)
END;
OutByte3(0FH, 10H, 05H + 8 * (xmm MOD 8));
X86.Reloc(sDATA, Numbers_Offs + Numbers_Count * 8);
NewNumber(UTILS.splitf(float, a, b))
|IL.opSAVEF, IL.opSAVEFI:
ASSERT(xmm >= 0);
UnOp(reg1);
movsdmr(reg1, 0, xmm);
DEC(xmm);
drop
|IL.opADDF, IL.opADDFI:
|IL.opADDF:
ASSERT(xmm >= 1);
opxx(58H, xmm - 1, xmm);
DEC(xmm)
|IL.opSUBF:
ASSERT(xmm >= 1);
opxx(5CH, xmm - 1, xmm);
DEC(xmm)
|IL.opSUBFI:
ASSERT(xmm >= 1);
opxx(5CH, xmm, xmm - 1);
opxx(10H, xmm - 1, xmm);
DEC(xmm)
|IL.opMULF:
ASSERT(xmm >= 1);
opxx(59H, xmm - 1, xmm);
DEC(xmm)
|IL.opDIVF:
ASSERT(xmm >= 1);
opxx(5EH, xmm - 1, xmm);
DEC(xmm)
|IL.opDIVFI:
ASSERT(xmm >= 1);
opxx(5EH, xmm, xmm - 1);
opxx(10H, xmm - 1, xmm);
DEC(xmm)
|IL.opUMINF:
reg1 := GetAnyReg();
lea(reg1, Numbers_Offs, sDATA);
OutByte3(66H, 40H + reg1 DIV 8 + (xmm DIV 8) * 4, 0FH); (* xorpd xmm, xmmword[reg1] *)
OutByte2(57H, reg1 MOD 8 + (xmm MOD 8) * 8);
drop
|IL.opFABS, IL.opUMINF: (* andpd/xorpd xmm, xmmword[rip + Numbers_Offs + (16) + DATA] *)
ASSERT(xmm >= 0);
OutByte(66H);
IF xmm >= 8 THEN
OutByte(44H)
END;
OutByte3(0FH, 54H + 3 * ORD(opcode = IL.opUMINF), 05H + (xmm MOD 8) * 8);
X86.Reloc(sDATA, Numbers_Offs + 16 * ORD(opcode = IL.opFABS))
|IL.opFABS:
reg1 := GetAnyReg();
lea(reg1, Numbers_Offs + 16, sDATA);
OutByte3(66H, 40H + reg1 DIV 8 + (xmm DIV 8) * 4, 0FH); (* andpd xmm, xmmword[reg1] *)
OutByte2(54H, reg1 MOD 8 + (xmm MOD 8) * 8);
drop
|IL.opFLT:
UnOp(reg1);
INC(xmm);
IF xmm > MAX_XMM THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
OutByte(0F2H); Rex(reg1, xmm); OutByte(0FH); (* cvtsi2sd xmm, reg1 *)
OutByte2(2AH, 0C0H + (xmm MOD 8) * 8 + reg1 MOD 8);
drop
|IL.opFLOOR:
ASSERT(xmm >= 0);
reg1 := GetAnyReg();
subrc(rsp, 8);
OutByte3(00FH, 0AEH, 05CH); OutByte2(024H, 004H); (* stmxcsr dword[rsp+4]; *)
2141,15 → 2137,22
DEC(xmm)
|IL.opEQF .. IL.opGEF:
ASSERT(xmm >= 1);
fcmp(opcode, xmm);
DEC(xmm, 2)
|IL.opINF:
INC(xmm);
reg1 := GetAnyReg();
lea(reg1, Numbers_Offs + 32, sDATA);
movsdrm(xmm, reg1, 0);
drop
IF xmm > MAX_XMM THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
(* movsd xmm, qword ptr [rip + Numbers_Offs + 32 + DATA] *)
OutByte(0F2H);
IF xmm >= 8 THEN
OutByte(44H)
END;
OutByte3(0FH, 10H, 05H + 8 * (xmm MOD 8));
X86.Reloc(sDATA, Numbers_Offs + 32)
|IL.opPACK, IL.opPACKC:
IF opcode = IL.opPACK THEN
2175,7 → 2178,7
and(reg2, reg1);
pop(reg1);
or(reg2, reg1);
_or(reg2, reg1);
pop(reg1);
movmr(reg1, 0, reg2);
drop;
2218,7 → 2221,7
push(reg2);
lea(reg2, Numbers_Offs + 48, sDATA); (* {52..61} *)
movrm(reg2, reg2, 0);
or(reg1, reg2);
_or(reg1, reg2);
pop(reg2);
Rex(reg1, 0);
2248,26 → 2251,20
END
|IL.opGLOAD64_PARAM:
reg2 := GetAnyReg();
lea(reg2, param2, sBSS);
movrm(reg2, reg2, 0);
push(reg2);
drop
OutByte2(0FFH, 35H); (* push qword[rip + param2 + BSS] *)
X86.Reloc(sBSS, param2)
|IL.opCONST_PARAM:
pushc(param2)
|IL.opGLOAD32_PARAM:
|IL.opGLOAD32_PARAM, IL.opLOAD32_PARAM:
IF opcode = IL.opGLOAD32_PARAM THEN
reg1 := GetAnyReg();
xor(reg1, reg1);
lea(reg1, param2, sBSS);
lea(reg1, param2, sBSS)
ELSE
UnOp(reg1)
END;
movrm32(reg1, reg1, 0);
push(reg1);
drop
|IL.opLOAD32_PARAM:
UnOp(reg1);
movrm32(reg1, reg1, 0);
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32);
push(reg1);
2275,7 → 2272,6
|IL.opLLOAD32_PARAM:
reg1 := GetAnyReg();
xor(reg1, reg1);
reg2 := GetVarReg(param2);
IF reg2 # -1 THEN
mov(reg1, reg2)
2282,6 → 2278,8
ELSE
movrm32(reg1, rbp, param2 * 8)
END;
shiftrc(shl, reg1, 32);
shiftrc(shr, reg1, 32);
push(reg1);
drop
2313,12 → 2311,10
drop;
drop
ELSE
reg2 := GetAnyReg();
lea(reg2, param1, sBSS);
Rex(reg2, 0);
OutByte2(0C7H, reg2 MOD 8); (* mov qword[reg2], param2 *)
OutInt(param2);
drop
(* mov qword[rip + param1 - 4 + BSS], param2 *)
OutByte3(48H, 0C7H, 05H);
X86.Reloc(sBSS, param1 - 4);
OutInt(param2)
END
|IL.opLADR_SAVE:
2431,7 → 2427,7
oprr2(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), reg2, reg1) (* bts/btr reg2, reg1 *)
ELSE
n := param2 * 8;
OutByte2(73H, 5 + 3 * ORD(~isByte(n))); (* jnb L *)
OutByte2(73H, 5 + 3 * ORD(~X86.isByte(n))); (* jnb L *)
Rex(0, reg1);
OutByte3(0FH, 0ABH + 8 * ORD(opcode = IL.opLADR_EXCL), 45H + long(n) + 8 * (reg1 MOD 8));
OutIntByte(n) (* bts/btr qword[rbp+n], reg1 *)
2453,6 → 2449,9
OutByte(param2)
END
|IL.opFNAME:
fname := cmd(IL.FNAMECMD).fname
|IL.opLOOP, IL.opENDLOOP:
END;
2485,10 → 2484,9
push(rcx);
CallRTL(IL._dllentry);
test(rax);
jcc(je, dllret)
END;
IF target = TARGETS.Linux64 THEN
jcc(je, dllret);
pushc(0)
ELSIF target = TARGETS.Linux64 THEN
push(rsp)
ELSE
pushc(0)
2527,7 → 2525,7
exp: IL.EXPORT_PROC;
PROCEDURE import (imp: LISTS.LIST);
PROCEDURE _import (imp: LISTS.LIST);
VAR
lib: IL.IMPORT_LIB;
proc: IL.IMPORT_PROC;
2545,7 → 2543,7
lib := lib.next(IL.IMPORT_LIB)
END
END import;
END _import;
BEGIN
2598,7 → 2596,7
exp := exp.next(IL.EXPORT_PROC)
END;
import(IL.codes.import)
_import(IL.codes._import)
END epilog;
2631,6 → 2629,7
path, modname, ext: PATHS.PATH;
BEGIN
Xmm[0] := 0;
tcount := CHL.Length(IL.codes.types);
Win64RegPar[0] := rcx;

/programs/develop/oberon07/Source/ARITH.ob07
16,11 → 16,12
tBOOLEAN* = 4; tCHAR* = 5; tWCHAR* = 6;
tSTRING* = 7;
opEQ* = 0; opNE* = 1; opLT* = 2; opLE* = 3; opGT* = 4; opGE* = 5;
opIN* = 6; opIS* = 7;
TYPE
RELATION* = ARRAY 3 OF CHAR;
VALUE* = RECORD
typ*: INTEGER;
672,7 → 673,7
END equal;
PROCEDURE relation* (VAR v: VALUE; v2: VALUE; operator: RELATION; VAR error: INTEGER);
PROCEDURE relation* (VAR v: VALUE; v2: VALUE; op: INTEGER; VAR error: INTEGER);
VAR
res: BOOLEAN;
681,36 → 682,34
res := FALSE;
CASE operator[0] OF
CASE op OF
|"=":
|opEQ:
res := equal(v, v2, error)
|"#":
|opNE:
res := ~equal(v, v2, error)
|"<":
IF operator[1] = "=" THEN
|opLT:
res := less(v, v2, error)
|opLE:
res := less(v, v2, error);
IF error = 0 THEN
res := equal(v, v2, error) OR res
END
ELSE
res := less(v, v2, error)
END
|">":
IF operator[1] = "=" THEN
|opGE:
res := ~less(v, v2, error)
ELSE
|opGT:
res := less(v, v2, error);
IF error = 0 THEN
res := equal(v, v2, error) OR res
END;
res := ~res
END
|"I":
|opIN:
IF (v.typ = tINTEGER) & (v2.typ = tSET) THEN
IF range(v, 0, UTILS.target.maxSet) THEN
res := v.int IN v2.set
762,6 → 761,20
END setInt;
PROCEDURE concat* (VAR s: ARRAY OF CHAR; s1: ARRAY OF CHAR): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := LENGTH(s) + LENGTH(s1) < LEN(s);
IF res THEN
STRINGS.append(s, s1)
END
RETURN res
END concat;
PROCEDURE init;
VAR
i: INTEGER;

/programs/develop/oberon07/Source/BIN.ob07
1,7 → 1,7
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
56,7 → 56,7
vmajor*,
vminor*: WCHAR;
modname*: INTEGER;
import*: CHL.BYTELIST;
_import*: CHL.BYTELIST;
export*: CHL.BYTELIST;
rel_list*: LISTS.LIST;
imp_list*: LISTS.LIST;
86,7 → 86,7
program.data := CHL.CreateByteList();
program.code := CHL.CreateByteList();
program.import := CHL.CreateByteList();
program._import := CHL.CreateByteList();
program.export := CHL.CreateByteList()
RETURN program
120,7 → 120,7
END PutData;
PROCEDURE get32le* (array: CHL.BYTELIST; idx: INTEGER): INTEGER;
PROCEDURE get32le* (_array: CHL.BYTELIST; idx: INTEGER): INTEGER;
VAR
i: INTEGER;
x: INTEGER;
129,7 → 129,7
x := 0;
FOR i := 3 TO 0 BY -1 DO
x := LSL(x, 8) + CHL.GetByte(array, idx + i)
x := LSL(x, 8) + CHL.GetByte(_array, idx + i)
END;
IF UTILS.bit_depth = 64 THEN
143,13 → 143,13
END get32le;
PROCEDURE put32le* (array: CHL.BYTELIST; idx: INTEGER; x: INTEGER);
PROCEDURE put32le* (_array: CHL.BYTELIST; idx: INTEGER; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
CHL.SetByte(array, idx + i, UTILS.Byte(x, i))
CHL.SetByte(_array, idx + i, UTILS.Byte(x, i))
END
END put32le;
224,15 → 224,15
imp: IMPRT;
BEGIN
CHL.PushByte(program.import, 0);
CHL.PushByte(program.import, 0);
CHL.PushByte(program._import, 0);
CHL.PushByte(program._import, 0);
IF ODD(CHL.Length(program.import)) THEN
CHL.PushByte(program.import, 0)
IF ODD(CHL.Length(program._import)) THEN
CHL.PushByte(program._import, 0)
END;
NEW(imp);
imp.nameoffs := CHL.PushStr(program.import, name);
imp.nameoffs := CHL.PushStr(program._import, name);
imp.label := label;
LISTS.push(program.imp_list, imp)
END Import;
285,19 → 285,18
PROCEDURE GetIProc* (program: PROGRAM; n: INTEGER): IMPRT;
VAR
import: IMPRT;
res: IMPRT;
_import, res: IMPRT;
BEGIN
import := program.imp_list.first(IMPRT);
_import := program.imp_list.first(IMPRT);
res := NIL;
WHILE (import # NIL) & (n >= 0) DO
IF import.label # 0 THEN
res := import;
WHILE (_import # NIL) & (n >= 0) DO
IF _import.label # 0 THEN
res := _import;
DEC(n)
END;
import := import.next(IMPRT)
_import := _import.next(IMPRT)
END;
ASSERT(n = -1)
349,7 → 348,7
END fixup;
PROCEDURE InitArray* (VAR array: ARRAY OF BYTE; VAR idx: INTEGER; hex: ARRAY OF CHAR);
PROCEDURE InitArray* (VAR _array: ARRAY OF BYTE; VAR idx: INTEGER; hex: ARRAY OF CHAR);
VAR
i, k: INTEGER;
375,7 → 374,7
k := k DIV 2;
FOR i := 0 TO k - 1 DO
array[i + idx] := hexdgt(hex[2 * i]) * 16 + hexdgt(hex[2 * i + 1])
_array[i + idx] := hexdgt(hex[2 * i]) * 16 + hexdgt(hex[2 * i + 1])
END;
INC(idx, k)

/programs/develop/oberon07/Source/CHUNKLISTS.ob07
153,7 → 153,7
END GetStr;
PROCEDURE WriteToFile* (file: WR.FILE; list: BYTELIST);
PROCEDURE WriteToFile* (list: BYTELIST);
VAR
chunk: BYTECHUNK;
160,7 → 160,7
BEGIN
chunk := list.first(BYTECHUNK);
WHILE chunk # NIL DO
WR.Write(file, chunk.data, chunk.count);
WR.Write(chunk.data, chunk.count);
chunk := chunk.next(BYTECHUNK)
END
END WriteToFile;

/programs/develop/oberon07/Source/Compiler.ob07
8,7 → 8,7
MODULE Compiler;
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, PROG, C := CONSOLE,
ERRORS, STRINGS, WRITER, MSP430, THUMB, TARGETS;
ERRORS, STRINGS, WRITER, MSP430, THUMB, TARGETS, SCAN;
PROCEDURE keys (VAR options: PROG.OPTIONS; VAR out: PARS.PATH);
15,7 → 15,7
VAR
param: PARS.PATH;
i, j: INTEGER;
end: BOOLEAN;
_end: BOOLEAN;
value: INTEGER;
minor,
major: INTEGER;
24,7 → 24,7
BEGIN
out := "";
checking := options.checking;
end := FALSE;
_end := FALSE;
i := 3;
REPEAT
UTILS.GetArg(i, param);
113,11 → 113,19
DEC(i)
END
ELSIF param = "-lower" THEN
options.lower := TRUE
ELSIF param = "-pic" THEN
options.pic := TRUE
ELSIF param = "-def" THEN
INC(i);
UTILS.GetArg(i, param);
SCAN.NewDef(param)
ELSIF param = "" THEN
end := TRUE
_end := TRUE
ELSE
ERRORS.BadParam(param)
124,7 → 132,7
END;
INC(i)
UNTIL end;
UNTIL _end;
options.checking := checking
END keys;
165,6 → 173,7
options.stack := 2;
options.version := 65536;
options.pic := FALSE;
options.lower := FALSE;
options.checking := ST.chkALL;
PATHS.GetCurrentDirectory(app_path);
203,6 → 212,8
C.StringLn(" -stk <size> set size of stack in Mbytes (Windows, Linux, KolibriOS)"); C.Ln;
C.StringLn(" -nochk <'ptibcwra'> disable runtime checking (pointers, types, indexes,");
C.StringLn(" BYTE, CHR, WCHR)"); C.Ln;
C.StringLn(" -lower allow lower case for keywords"); C.Ln;
C.StringLn(" -def <identifier> define conditional compilation symbol"); C.Ln;
C.StringLn(" -ver <major.minor> set version of program (KolibriOS DLL)"); C.Ln;
C.StringLn(" -ram <size> set size of RAM in bytes (MSP430) or Kbytes (STM32)"); C.Ln;
C.StringLn(" -rom <size> set size of ROM in bytes (MSP430) or Kbytes (STM32)"); C.Ln;
226,6 → 237,8
ERRORS.Error(205)
END;
SCAN.NewDef(param);
IF TARGETS.Select(param) THEN
target := TARGETS.target
ELSE

/programs/develop/oberon07/Source/ELF.ob07
1,13 → 1,13
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
Copyright (c) 2019-2020, Anton Krotov
All rights reserved.
*)
MODULE ELF;
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS;
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS, PE32, UTILS;
CONST
85,9 → 85,6
END;
FILE = WR.FILE;
VAR
dynamic: LISTS.LIST;
97,75 → 94,38
hashtab, bucket, chain: CHL.INTLIST;
PROCEDURE align (n, _align: INTEGER): INTEGER;
PROCEDURE Write16 (w: WCHAR);
BEGIN
IF n MOD _align # 0 THEN
n := n + _align - (n MOD _align)
END
RETURN n
END align;
PROCEDURE Write16 (file: FILE; w: WCHAR);
BEGIN
WR.Write16LE(file, ORD(w))
WR.Write16LE(ORD(w))
END Write16;
PROCEDURE WritePH (file: FILE; ph: Elf32_Phdr);
PROCEDURE WritePH (ph: Elf32_Phdr);
BEGIN
WR.Write32LE(file, ph.p_type);
WR.Write32LE(file, ph.p_offset);
WR.Write32LE(file, ph.p_vaddr);
WR.Write32LE(file, ph.p_paddr);
WR.Write32LE(file, ph.p_filesz);
WR.Write32LE(file, ph.p_memsz);
WR.Write32LE(file, ph.p_flags);
WR.Write32LE(file, ph.p_align)
WR.Write32LE(ph.p_type);
WR.Write32LE(ph.p_offset);
WR.Write32LE(ph.p_vaddr);
WR.Write32LE(ph.p_paddr);
WR.Write32LE(ph.p_filesz);
WR.Write32LE(ph.p_memsz);
WR.Write32LE(ph.p_flags);
WR.Write32LE(ph.p_align)
END WritePH;
PROCEDURE WritePH64 (file: FILE; ph: Elf32_Phdr);
PROCEDURE WritePH64 (ph: Elf32_Phdr);
BEGIN
WR.Write32LE(file, ph.p_type);
WR.Write32LE(file, ph.p_flags);
WR.Write64LE(file, ph.p_offset);
WR.Write64LE(file, ph.p_vaddr);
WR.Write64LE(file, ph.p_paddr);
WR.Write64LE(file, ph.p_filesz);
WR.Write64LE(file, ph.p_memsz);
WR.Write64LE(file, ph.p_align)
WR.Write32LE(ph.p_type);
WR.Write32LE(ph.p_flags);
WR.Write64LE(ph.p_offset);
WR.Write64LE(ph.p_vaddr);
WR.Write64LE(ph.p_paddr);
WR.Write64LE(ph.p_filesz);
WR.Write64LE(ph.p_memsz);
WR.Write64LE(ph.p_align)
END WritePH64;
PROCEDURE fixup (program: BIN.PROGRAM; text, data, bss: INTEGER; amd64: BOOLEAN);
VAR
reloc: BIN.RELOC;
code: CHL.BYTELIST;
L, delta, delta0: INTEGER;
BEGIN
code := program.code;
delta0 := 3 - 7 * ORD(amd64);
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
L := BIN.get32le(code, reloc.offset);
delta := delta0 - reloc.offset - text;
CASE reloc.opcode OF
|BIN.PICDATA: BIN.put32le(code, reloc.offset, L + data + delta)
|BIN.PICCODE: BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L) + text + delta)
|BIN.PICBSS: BIN.put32le(code, reloc.offset, L + bss + delta)
END;
reloc := reloc.next(BIN.RELOC)
END
END fixup;
PROCEDURE NewDyn (tag, val: INTEGER);
VAR
dyn: Elf32_Dyn;
271,14 → 231,12
ehdr: Elf32_Ehdr;
phdr: ARRAY 16 OF Elf32_Phdr;
i, BaseAdr, offset, pad, VA, symCount: INTEGER;
i, BaseAdr, DynAdr, offset, pad, VA, symCount: INTEGER;
SizeOf: RECORD header, code, data, bss: INTEGER END;
Offset: RECORD symtab, reltab, hash, strtab, dyn: INTEGER END;
Offset: RECORD symtab, reltab, hash, strtab: INTEGER END;
File: FILE;
Interpreter: ARRAY 40 OF CHAR; lenInterpreter: INTEGER;
item: LISTS.ITEM;
285,6 → 243,8
Name: ARRAY 2048 OF CHAR;
Address: PE32.VIRTUAL_ADDR;
BEGIN
dynamic := LISTS.create(NIL);
symtab := LISTS.create(NIL);
431,12 → 391,12
Offset.hash := Offset.reltab + (8 + 16 * ORD(amd64)) * 2;
Offset.strtab := Offset.hash + (symCount * 2 + 2) * 4;
Offset.dyn := phdr[dyn].p_offset;
DynAdr := phdr[dyn].p_offset + BaseAdr;
item := LISTS.getidx(dynamic, 1); item(Elf32_Dyn).d_val := Offset.strtab + Offset.dyn + BaseAdr;
item := LISTS.getidx(dynamic, 3); item(Elf32_Dyn).d_val := Offset.symtab + Offset.dyn + BaseAdr;
item := LISTS.getidx(dynamic, 5); item(Elf32_Dyn).d_val := Offset.reltab + Offset.dyn + BaseAdr;
item := LISTS.getidx(dynamic, 8); item(Elf32_Dyn).d_val := Offset.hash + Offset.dyn + BaseAdr;
item := LISTS.getidx(dynamic, 1); item(Elf32_Dyn).d_val := Offset.strtab + DynAdr;
item := LISTS.getidx(dynamic, 3); item(Elf32_Dyn).d_val := Offset.symtab + DynAdr;
item := LISTS.getidx(dynamic, 5); item(Elf32_Dyn).d_val := Offset.reltab + DynAdr;
item := LISTS.getidx(dynamic, 8); item(Elf32_Dyn).d_val := Offset.hash + DynAdr;
phdr[dyn].p_filesz := Offset.strtab + CHL.Length(strtab) + 8 + 8 * ORD(amd64);
phdr[dyn].p_memsz := phdr[dyn].p_filesz;
450,12 → 410,12
phdr[header].p_offset := offset;
phdr[header].p_vaddr := BaseAdr;
phdr[header].p_paddr := BaseAdr;
phdr[header].p_filesz := 244 + 156 * ORD(amd64) + lenInterpreter + phdr[dyn].p_filesz;
phdr[header].p_filesz := SizeOf.header + lenInterpreter + phdr[dyn].p_filesz;
phdr[header].p_memsz := phdr[header].p_filesz;
phdr[header].p_flags := PF_R + PF_W;
phdr[header].p_align := 1000H;
offset := offset + phdr[header].p_filesz;
INC(offset, phdr[header].p_filesz);
VA := BaseAdr + offset + 1000H;
phdr[text].p_type := 1;
469,7 → 429,7
ehdr.e_entry := phdr[text].p_vaddr;
offset := offset + phdr[text].p_filesz;
INC(offset, phdr[text].p_filesz);
VA := BaseAdr + offset + 2000H;
pad := (16 - VA MOD 16) MOD 16;
482,7 → 442,7
phdr[data].p_flags := PF_R + PF_W;
phdr[data].p_align := 1000H;
offset := offset + phdr[data].p_filesz;
INC(offset, phdr[data].p_filesz);
VA := BaseAdr + offset + 3000H;
phdr[bss].p_type := 1;
494,8 → 454,13
phdr[bss].p_flags := PF_R + PF_W;
phdr[bss].p_align := 1000H;
fixup(program, ehdr.e_entry, phdr[data].p_vaddr + pad, align(phdr[bss].p_vaddr, 16), amd64);
Address.Code := ehdr.e_entry;
Address.Data := phdr[data].p_vaddr + pad;
Address.Bss := WR.align(phdr[bss].p_vaddr, 16);
Address.Import := 0;
PE32.fixup(program, Address, amd64);
item := symtab.first;
WHILE item # NIL DO
IF item(Elf32_Sym).value # 0 THEN
509,146 → 474,137
item := LISTS.getidx(dynamic, 11); item(Elf32_Dyn).d_val := BIN.GetLabel(program, fini) + ehdr.e_entry
END;
File := WR.Create(FileName);
WR.Create(FileName);
FOR i := 0 TO EI_NIDENT - 1 DO
WR.WriteByte(File, ehdr.e_ident[i])
WR.WriteByte(ehdr.e_ident[i])
END;
Write16(File, ehdr.e_type);
Write16(File, ehdr.e_machine);
Write16(ehdr.e_type);
Write16(ehdr.e_machine);
WR.Write32LE(File, ehdr.e_version);
WR.Write32LE(ehdr.e_version);
IF amd64 THEN
WR.Write64LE(File, ehdr.e_entry);
WR.Write64LE(File, ehdr.e_phoff);
WR.Write64LE(File, ehdr.e_shoff)
WR.Write64LE(ehdr.e_entry);
WR.Write64LE(ehdr.e_phoff);
WR.Write64LE(ehdr.e_shoff)
ELSE
WR.Write32LE(File, ehdr.e_entry);
WR.Write32LE(File, ehdr.e_phoff);
WR.Write32LE(File, ehdr.e_shoff)
WR.Write32LE(ehdr.e_entry);
WR.Write32LE(ehdr.e_phoff);
WR.Write32LE(ehdr.e_shoff)
END;
WR.Write32LE(File, ehdr.e_flags);
WR.Write32LE(ehdr.e_flags);
Write16(File, ehdr.e_ehsize);
Write16(File, ehdr.e_phentsize);
Write16(File, ehdr.e_phnum);
Write16(File, ehdr.e_shentsize);
Write16(File, ehdr.e_shnum);
Write16(File, ehdr.e_shstrndx);
Write16(ehdr.e_ehsize);
Write16(ehdr.e_phentsize);
Write16(ehdr.e_phnum);
Write16(ehdr.e_shentsize);
Write16(ehdr.e_shnum);
Write16(ehdr.e_shstrndx);
IF amd64 THEN
WritePH64(File, phdr[interp]);
WritePH64(File, phdr[dyn]);
WritePH64(File, phdr[header]);
WritePH64(File, phdr[text]);
WritePH64(File, phdr[data]);
WritePH64(File, phdr[bss])
WritePH64(phdr[interp]);
WritePH64(phdr[dyn]);
WritePH64(phdr[header]);
WritePH64(phdr[text]);
WritePH64(phdr[data]);
WritePH64(phdr[bss])
ELSE
WritePH(File, phdr[interp]);
WritePH(File, phdr[dyn]);
WritePH(File, phdr[header]);
WritePH(File, phdr[text]);
WritePH(File, phdr[data]);
WritePH(File, phdr[bss])
WritePH(phdr[interp]);
WritePH(phdr[dyn]);
WritePH(phdr[header]);
WritePH(phdr[text]);
WritePH(phdr[data]);
WritePH(phdr[bss])
END;
FOR i := 0 TO lenInterpreter - 1 DO
WR.WriteByte(File, ORD(Interpreter[i]))
WR.WriteByte(ORD(Interpreter[i]))
END;
i := 0;
IF amd64 THEN
item := dynamic.first;
WHILE item # NIL DO
WR.Write64LE(File, item(Elf32_Dyn).d_tag);
WR.Write64LE(File, item(Elf32_Dyn).d_val);
WR.Write64LE(item(Elf32_Dyn).d_tag);
WR.Write64LE(item(Elf32_Dyn).d_val);
item := item.next
END;
item := symtab.first;
WHILE item # NIL DO
WR.Write32LE(File, item(Elf32_Sym).name);
WR.WriteByte(File, ORD(item(Elf32_Sym).info));
WR.WriteByte(File, ORD(item(Elf32_Sym).other));
Write16(File, item(Elf32_Sym).shndx);
WR.Write64LE(File, item(Elf32_Sym).value);
WR.Write64LE(File, item(Elf32_Sym).size);
WR.Write32LE(item(Elf32_Sym).name);
WR.WriteByte(ORD(item(Elf32_Sym).info));
WR.WriteByte(ORD(item(Elf32_Sym).other));
Write16(item(Elf32_Sym).shndx);
WR.Write64LE(item(Elf32_Sym).value);
WR.Write64LE(item(Elf32_Sym).size);
item := item.next
END;
WR.Write64LE(File, phdr[dyn].p_filesz + Offset.dyn + BaseAdr - 16);
WR.Write32LE(File, 1);
WR.Write32LE(File, 1);
WR.Write64LE(File, 0);
WR.Write64LE(File, phdr[dyn].p_filesz + Offset.dyn + BaseAdr - 8);
WR.Write32LE(File, 1);
WR.Write32LE(File, 2);
WR.Write64LE(File, 0);
WR.Write64LE(phdr[dyn].p_filesz + DynAdr - 16);
WR.Write32LE(1);
WR.Write32LE(1);
WR.Write64LE(0);
WR.Write64LE(phdr[dyn].p_filesz + DynAdr - 8);
WR.Write32LE(1);
WR.Write32LE(2);
WR.Write64LE(0)
WR.Write32LE(File, symCount);
WR.Write32LE(File, symCount);
FOR i := 0 TO symCount - 1 DO
WR.Write32LE(File, CHL.GetInt(bucket, i))
END;
FOR i := 0 TO symCount - 1 DO
WR.Write32LE(File, CHL.GetInt(chain, i))
END;
CHL.WriteToFile(File, strtab);
WR.Write64LE(File, 0);
WR.Write64LE(File, 0)
ELSE
item := dynamic.first;
WHILE item # NIL DO
WR.Write32LE(File, item(Elf32_Dyn).d_tag);
WR.Write32LE(File, item(Elf32_Dyn).d_val);
WR.Write32LE(item(Elf32_Dyn).d_tag);
WR.Write32LE(item(Elf32_Dyn).d_val);
item := item.next
END;
item := symtab.first;
WHILE item # NIL DO
WR.Write32LE(File, item(Elf32_Sym).name);
WR.Write32LE(File, item(Elf32_Sym).value);
WR.Write32LE(File, item(Elf32_Sym).size);
WR.WriteByte(File, ORD(item(Elf32_Sym).info));
WR.WriteByte(File, ORD(item(Elf32_Sym).other));
Write16(File, item(Elf32_Sym).shndx);
WR.Write32LE(item(Elf32_Sym).name);
WR.Write32LE(item(Elf32_Sym).value);
WR.Write32LE(item(Elf32_Sym).size);
WR.WriteByte(ORD(item(Elf32_Sym).info));
WR.WriteByte(ORD(item(Elf32_Sym).other));
Write16(item(Elf32_Sym).shndx);
item := item.next
END;
WR.Write32LE(File, phdr[dyn].p_filesz + Offset.dyn + BaseAdr - 8);
WR.Write32LE(File, 00000101H);
WR.Write32LE(File, phdr[dyn].p_filesz + Offset.dyn + BaseAdr - 4);
WR.Write32LE(File, 00000201H);
WR.Write32LE(phdr[dyn].p_filesz + DynAdr - 8);
WR.Write32LE(00000101H);
WR.Write32LE(phdr[dyn].p_filesz + DynAdr - 4);
WR.Write32LE(00000201H)
WR.Write32LE(File, symCount);
WR.Write32LE(File, symCount);
END;
WR.Write32LE(symCount);
WR.Write32LE(symCount);
FOR i := 0 TO symCount - 1 DO
WR.Write32LE(File, CHL.GetInt(bucket, i))
WR.Write32LE(CHL.GetInt(bucket, i))
END;
FOR i := 0 TO symCount - 1 DO
WR.Write32LE(File, CHL.GetInt(chain, i))
WR.Write32LE(CHL.GetInt(chain, i))
END;
CHL.WriteToFile(File, strtab);
WR.Write32LE(File, 0);
WR.Write32LE(File, 0)
CHL.WriteToFile(strtab);
IF amd64 THEN
WR.Write64LE(0);
WR.Write64LE(0)
ELSE
WR.Write32LE(0);
WR.Write32LE(0)
END;
CHL.WriteToFile(File, program.code);
CHL.WriteToFile(program.code);
WHILE pad > 0 DO
WR.WriteByte(File, 0);
WR.WriteByte(0);
DEC(pad)
END;
CHL.WriteToFile(File, program.data);
WR.Close(File)
CHL.WriteToFile(program.data);
WR.Close;
UTILS.chmod(FileName)
END write;

/programs/develop/oberon07/Source/ERRORS.ob07
144,7 → 144,9
|114: str := "identifiers 'lib_init' and 'version' are reserved"
|115: str := "recursive constant definition"
|116: str := "procedure too deep nested"
|117: str := "string expected"
|118: str := "'$END', '$ELSE' or '$ELSIF' without '$IF'"
|119: str := "'$IF', '$ELSIF', '$ELSE' or '$END' expected"
|120: str := "too many formal parameters"
|121: str := "multiply defined handler"
|122: str := "bad divisor"
210,6 → 212,7
|205: Error1("not enough parameters")
|206: Error1("bad parameter <target>")
|207: Error3('inputfile name extension must be "', UTILS.FILE_EXT, '"')
|208: Error1("not enough RAM")
END
END Error;

/programs/develop/oberon07/Source/FILES.ob07
17,10 → 17,8
ptr: INTEGER;
buffer: ARRAY 64*1024 OF BYTE;
count: INTEGER;
count: INTEGER
chksum*: INTEGER
END;
VAR
85,8 → 83,7
IF ptr > 0 THEN
file := NewFile();
file.ptr := ptr;
file.count := 0;
file.chksum := 0
file.count := 0
ELSE
file := NIL
END

/programs/develop/oberon07/Source/HEX.ob07
7,46 → 7,48
MODULE HEX;
IMPORT FILES, WRITER, CHL := CHUNKLISTS;
IMPORT WRITER, CHL := CHUNKLISTS, UTILS;
PROCEDURE hexdgt (n: BYTE): BYTE;
BEGIN
IF n < 10 THEN
n := n + ORD("0")
ELSE
n := n - 10 + ORD("A")
END
VAR
RETURN n
END hexdgt;
chksum: INTEGER;
PROCEDURE Byte (file: FILES.FILE; byte: BYTE);
PROCEDURE Byte (byte: BYTE);
BEGIN
WRITER.WriteByte(file, hexdgt(byte DIV 16));
WRITER.WriteByte(file, hexdgt(byte MOD 16));
INC(file.chksum, byte);
WRITER.WriteByte(UTILS.hexdgt(byte DIV 16));
WRITER.WriteByte(UTILS.hexdgt(byte MOD 16));
INC(chksum, byte)
END Byte;
PROCEDURE NewLine (file: FILES.FILE);
PROCEDURE Byte4 (a, b, c, d: BYTE);
BEGIN
Byte(file, (-file.chksum) MOD 256);
file.chksum := 0;
WRITER.WriteByte(file, 0DH);
WRITER.WriteByte(file, 0AH)
Byte(a);
Byte(b);
Byte(c);
Byte(d)
END Byte4;
PROCEDURE NewLine;
BEGIN
Byte((-chksum) MOD 256);
chksum := 0;
WRITER.WriteByte(0DH);
WRITER.WriteByte(0AH)
END NewLine;
PROCEDURE StartCode (file: FILES.FILE);
PROCEDURE StartCode;
BEGIN
WRITER.WriteByte(file, ORD(":"));
file.chksum := 0
WRITER.WriteByte(ORD(":"));
chksum := 0
END StartCode;
PROCEDURE Data* (file: FILES.FILE; mem: ARRAY OF BYTE; idx, cnt: INTEGER);
PROCEDURE Data* (mem: ARRAY OF BYTE; idx, cnt: INTEGER);
VAR
i, len: INTEGER;
53,74 → 55,62
BEGIN
WHILE cnt > 0 DO
len := MIN(cnt, 16);
StartCode(file);
Byte(file, len);
Byte(file, idx DIV 256);
Byte(file, idx MOD 256);
Byte(file, 0);
StartCode;
Byte4(len, idx DIV 256, idx MOD 256, 0);
FOR i := 1 TO len DO
Byte(file, mem[idx]);
Byte(mem[idx]);
INC(idx)
END;
DEC(cnt, len);
NewLine(file)
NewLine
END
END Data;
PROCEDURE ExtLA* (file: FILES.FILE; LA: INTEGER);
PROCEDURE ExtLA* (LA: INTEGER);
BEGIN
ASSERT((0 <= LA) & (LA <= 0FFFFH));
StartCode(file);
Byte(file, 2);
Byte(file, 0);
Byte(file, 0);
Byte(file, 4);
Byte(file, LA DIV 256);
Byte(file, LA MOD 256);
NewLine(file)
StartCode;
Byte4(2, 0, 0, 4);
Byte(LA DIV 256);
Byte(LA MOD 256);
NewLine
END ExtLA;
PROCEDURE Data2* (file: FILES.FILE; mem: CHL.BYTELIST; idx, cnt, LA: INTEGER);
PROCEDURE Data2* (mem: CHL.BYTELIST; idx, cnt, LA: INTEGER);
VAR
i, len, offset: INTEGER;
BEGIN
ExtLA(file, LA);
ExtLA(LA);
offset := 0;
WHILE cnt > 0 DO
ASSERT(offset <= 65536);
IF offset = 65536 THEN
INC(LA);
ExtLA(file, LA);
ExtLA(LA);
offset := 0
END;
len := MIN(cnt, 16);
StartCode(file);
Byte(file, len);
Byte(file, offset DIV 256);
Byte(file, offset MOD 256);
Byte(file, 0);
StartCode;
Byte4(len, offset DIV 256, offset MOD 256, 0);
FOR i := 1 TO len DO
Byte(file, CHL.GetByte(mem, idx));
Byte(CHL.GetByte(mem, idx));
INC(idx);
INC(offset)
END;
DEC(cnt, len);
NewLine(file)
NewLine
END
END Data2;
PROCEDURE End* (file: FILES.FILE);
PROCEDURE End*;
BEGIN
StartCode(file);
Byte(file, 0);
Byte(file, 0);
Byte(file, 0);
Byte(file, 1);
NewLine(file)
StartCode;
Byte4(0, 0, 0, 1);
NewLine
END End;

/programs/develop/oberon07/Source/IL.ob07
7,14 → 7,11
MODULE IL;
IMPORT LISTS, SCAN, STRINGS, CHL := CHUNKLISTS, C := COLLECTIONS, TARGETS;
IMPORT LISTS, SCAN, STRINGS, CHL := CHUNKLISTS, C := COLLECTIONS, TARGETS, PATHS;
CONST
little_endian* = 0;
big_endian* = 1;
call_stack* = 0;
call_win64* = 1;
call_sysv* = 2;
22,7 → 19,7
opJMP* = 0; opLABEL* = 1; opCOPYS* = 2; opGADR* = 3; opCONST* = 4; opLLOAD32* = 5;
opCOPYA* = 6; opCASET* = 7; opMULC* = 8; opMUL* = 9; opDIV* = 10; opMOD* = 11;
opDIVL* = 12; opMODL* = 13; opDIVR* = 14; opMODR* = 15; opUMINUS* = 16;
opADD* = 17; opSUB* = 18; opADDL* = 19; opSUBL* = 20; opADDR* = 21; opSUBR* = 22;
opADD* = 17; opSUB* = 18; opONERR* = 19; opSUBL* = 20; opADDC* = 21; opSUBR* = 22;
opSAVE* = 23; opSAVEC* = 24; opSAVE8* = 25; opSAVE8C* = 26; opCHKBYTE* = 27; opDROP* = 28;
opNOT* = 29;
34,14 → 31,14
opVLOAD32* = 60; opGLOAD32* = 61;
opJNE* = 62; opJE* = 63;
opJZ* = 62; opJNZ* = 63;
opSAVE32* = 64; opLLOAD8* = 65;
opCONSTF* = 66; opLOADF* = 67; opSAVEF* = 68; opMULF* = 69; opDIVF* = 70; opDIVFI* = 71;
opUMINF* = 72; opADDFI* = 73; opSUBFI* = 74; opADDF* = 75; opSUBF* = 76;
opUMINF* = 72; opSAVEFI* = 73; opSUBFI* = 74; opADDF* = 75; opSUBF* = 76;
opACC* = 77; opJG* = 78;
opJNZ1* = 77; opJG* = 78;
opINCCB* = 79; opDECCB* = 80; opINCB* = 81; opDECB* = 82;
opCASEL* = 83; opCASER* = 84; opCASELR* = 85;
55,7 → 52,7
opSBOOL* = 100; opSBOOLC* = 101; opNOP* = 102;
opMULS* = 103; opMULSC* = 104; opDIVS* = 105; opDIVSC* = 106;
opADDS* = 107; opSUBS* = 108; opADDSL* = 109; opSUBSL* = 110; opADDSR* = 111; opSUBSR* = 112;
opADDS* = 107; opSUBS* = 108; opERR* = 109; opSUBSL* = 110; opADDSC* = 111; opSUBSR* = 112;
opUMINS* = 113; opIN* = 114; opINL* = 115; opINR* = 116;
opRSET* = 117; opRSETL* = 118; opRSETR* = 119; opRSET1* = 120; opLENGTH* = 121;
65,27 → 62,26
opPACK* = 134; opPACKC* = 135; opUNPK* = 136; opCOPY* = 137; opENTER* = 138; opLEAVE* = 139;
opCALL* = 140; opSAVEP* = 141; opCALLP* = 142; opEQP* = 143; opNEP* = 144; opLEAVER* = 145;
opGET* = 146; opSAVE16* = 147; opABS* = 148; opFABS* = 149; opFLOOR* = 150; opFLT* = 151;
opORD* = 153; opASR* = 154; opLSL* = 155; opROR* = 156;
opGETC* = 152; opORD* = 153; opASR* = 154; opLSL* = 155; opROR* = 156;
opASR1* = 157; opLSL1* = 158; opROR1* = 159; opASR2* = 160; opLSL2* = 161; opROR2* = 162;
opPUSHP* = 163; opLADR* = 164; opTYPEGP* = 165; opIS* = 166; opPUSHF* = 167; opVADR* = 168;
opPUSHT* = 169; opTYPEGR* = 170; opISREC* = 171; opCHKIDX* = 172; opPARAM* = 173;
opCHKIDX2* = 174; opLEN* = 175; opROT* = 176; opSAVES* = 177; opSADR* = 178; opERR* = 179;
opCHKIDX2* = 174; opLEN* = 175; opROT* = 176; opSAVES* = 177; opSADR* = 178; opLENGTHW* = 179;
opCHR* = 180; opENDSW* = 181; opLEAVEF* = 182; opCLEANUP* = 183; opMOVE* = 184;
opLSR* = 185; opLSR1* = 186; opLSR2* = 187;
opMIN* = 188; opMINC* = 189; opMAX* = 190; opMAXC* = 191; opJNZ* = 192;
opEQB* = 193; opNEB* = 194; opINF* = 195; opJZ* = 196; opVLOAD8* = 197; opGLOAD8* = 198;
opMIN* = 188; opMINC* = 189; opMAX* = 190; opMAXC* = 191; opSYSVALIGN16* = 192;
opEQB* = 193; opNEB* = 194; opINF* = 195; opWIN64ALIGN16* = 196; opVLOAD8* = 197; opGLOAD8* = 198;
opLLOAD16* = 199; opVLOAD16* = 200; opGLOAD16* = 201;
opLOAD64* = 202; opLLOAD64* = 203; opVLOAD64* = 204; opGLOAD64* = 205; opSAVE64* = 206;
opTYPEGD* = 207; opCALLI* = 208; opPUSHIP* = 209; opSAVEIP* = 210; opEQIP* = 211; opNEIP* = 212;
opSAVE16C* = 213; opWCHR* = 214; opGETC* = 215; opLENGTHW* = 216;
opSAVE16C* = 213; opWCHR* = 214; opHANDLER* = 215;
opSYSVCALL* = 217; opSYSVCALLI* = 218; opSYSVCALLP* = 219; opSYSVALIGN16* = 220; opWIN64ALIGN16* = 221;
opSYSVCALL* = 216; opSYSVCALLI* = 217; opSYSVCALLP* = 218; opFNAME* = 219;
opAND* = 220; opOR* = 221;
opONERR* = 222; opSAVEFI* = 223; opHANDLER* = 224;
opSADR_PARAM* = -1; opLOAD64_PARAM* = -2; opLLOAD64_PARAM* = -3; opGLOAD64_PARAM* = -4;
opVADR_PARAM* = -5; opCONST_PARAM* = -6; opGLOAD32_PARAM* = -7; opLLOAD32_PARAM* = -8;
opLOAD32_PARAM* = -9;
154,6 → 150,12
END;
FNAMECMD* = POINTER TO RECORD (COMMAND)
fname*: PATHS.PATH
END;
CMDSTACK = POINTER TO RECORD
data: ARRAY 1000 OF COMMAND;
192,7 → 194,7
endcall: CMDSTACK;
commands*: LISTS.LIST;
export*: LISTS.LIST;
import*: LISTS.LIST;
_import*: LISTS.LIST;
types*: CHL.INTLIST;
data*: CHL.BYTELIST;
dmin*: INTEGER;
204,7 → 206,6
charoffs: ARRAY 256 OF INTEGER;
wcharoffs: ARRAY 65536 OF INTEGER;
fregs: INTEGER;
wstr: ARRAY 4*1024 OF WCHAR
END;
212,7 → 213,7
VAR
codes*: CODES;
endianness, numRegsFloat, CPU: INTEGER;
CPU: INTEGER;
commands, variables: C.COLLECTION;
343,10 → 344,10
i := 0;
WHILE i < n DO
IF endianness = little_endian THEN
IF TARGETS.LittleEndian THEN
PutByte(ORD(codes.wstr[i]) MOD 256);
PutByte(ORD(codes.wstr[i]) DIV 256)
ELSIF endianness = big_endian THEN
ELSE
PutByte(ORD(codes.wstr[i]) DIV 256);
PutByte(ORD(codes.wstr[i]) MOD 256)
END;
373,10 → 374,10
INC(res)
END;
IF endianness = little_endian THEN
IF TARGETS.LittleEndian THEN
PutByte(c MOD 256);
PutByte(c DIV 256)
ELSIF endianness = big_endian THEN
ELSE
PutByte(c DIV 256);
PutByte(c MOD 256)
END;
410,19 → 411,19
END pop;
PROCEDURE pushBegEnd* (VAR beg, end: COMMAND);
PROCEDURE pushBegEnd* (VAR beg, _end: COMMAND);
BEGIN
push(codes.begcall, beg);
push(codes.endcall, end);
push(codes.endcall, _end);
beg := codes.last;
end := beg.next(COMMAND)
_end := beg.next(COMMAND)
END pushBegEnd;
PROCEDURE popBegEnd* (VAR beg, end: COMMAND);
PROCEDURE popBegEnd* (VAR beg, _end: COMMAND);
BEGIN
beg := pop(codes.begcall);
end := pop(codes.endcall)
_end := pop(codes.endcall)
END popBegEnd;
494,6 → 495,9
ELSIF (nov.opcode = opMULC) & (old_opcode = opMULC) THEN
cur.param2 := param2 * cur.param2
ELSIF (nov.opcode = opADDC) & (old_opcode = opADDC) THEN
cur.param2 := param2 + cur.param2
ELSE
old_opcode := -1
END
631,10 → 635,10
prev := codes.last;
not := prev.opcode = opNOT;
IF not THEN
IF opcode = opJE THEN
opcode := opJNE
ELSIF opcode = opJNE THEN
opcode := opJE
IF opcode = opJNZ THEN
opcode := opJZ
ELSIF opcode = opJZ THEN
opcode := opJNZ
ELSE
not := FALSE
END
645,10 → 649,79
IF not THEN
delete(prev)
END
END AddJmpCmd;
PROCEDURE AndOrOpt* (VAR label: INTEGER);
VAR
cur, prev: COMMAND;
i, op, l: INTEGER;
jz, not: BOOLEAN;
BEGIN
cur := codes.last;
not := cur.opcode = opNOT;
IF not THEN
cur := cur.prev(COMMAND)
END;
IF cur.opcode = opAND THEN
op := opAND
ELSIF cur.opcode = opOR THEN
op := opOR
ELSE
op := -1
END;
cur := codes.last;
IF op # -1 THEN
IF not THEN
IF op = opAND THEN
op := opOR
ELSE (* op = opOR *)
op := opAND
END;
prev := cur.prev(COMMAND);
delete(cur);
cur := prev
END;
FOR i := 1 TO 9 DO
IF i = 8 THEN
l := cur.param1
ELSIF i = 9 THEN
jz := cur.opcode = opJZ
END;
prev := cur.prev(COMMAND);
delete(cur);
cur := prev
END;
setlast(cur);
IF op = opAND THEN
label := l;
jz := ~jz
END;
IF jz THEN
AddJmpCmd(opJZ, label)
ELSE
AddJmpCmd(opJNZ, label)
END;
IF op = opOR THEN
SetLabel(l)
END
ELSE
AddJmpCmd(opJZ, label)
END;
setlast(codes.last)
END AndOrOpt;
PROCEDURE OnError* (line, error: INTEGER);
BEGIN
AddCmd2(opONERR, codes.errlabels[error], line)
661,7 → 734,7
BEGIN
AddCmd(op, t);
label := NewLabel();
AddJmpCmd(opJE, label);
AddJmpCmd(opJNZ, label);
OnError(line, error);
SetLabel(label)
END TypeGuard;
685,14 → 758,6
END New;
PROCEDURE fcmp* (opcode: INTEGER);
BEGIN
AddCmd(opcode, 0);
DEC(codes.fregs, 2);
ASSERT(codes.fregs >= 0)
END fcmp;
PROCEDURE not*;
VAR
prev: COMMAND;
707,6 → 772,14
END not;
PROCEDURE _ord*;
BEGIN
IF (codes.last.opcode # opAND) & (codes.last.opcode # opOR) THEN
AddCmd0(opORD)
END
END _ord;
PROCEDURE Enter* (label, params: INTEGER): COMMAND;
VAR
cmd: COMMAND;
900,44 → 973,10
AddCmd0(opSAVEFI)
ELSE
AddCmd0(opSAVEF)
END;
DEC(codes.fregs);
ASSERT(codes.fregs >= 0)
END
END savef;
PROCEDURE pushf*;
BEGIN
AddCmd0(opPUSHF);
DEC(codes.fregs);
ASSERT(codes.fregs >= 0)
END pushf;
PROCEDURE loadf* (): BOOLEAN;
BEGIN
AddCmd0(opLOADF);
INC(codes.fregs)
RETURN codes.fregs < numRegsFloat
END loadf;
PROCEDURE inf* (): BOOLEAN;
BEGIN
AddCmd0(opINF);
INC(codes.fregs)
RETURN codes.fregs < numRegsFloat
END inf;
PROCEDURE fbinop* (opcode: INTEGER);
BEGIN
AddCmd0(opcode);
DEC(codes.fregs);
ASSERT(codes.fregs > 0)
END fbinop;
PROCEDURE saves* (offset, length: INTEGER);
BEGIN
AddCmd2(opSAVES, length, offset)
954,22 → 993,6
END abs;
PROCEDURE floor*;
BEGIN
AddCmd0(opFLOOR);
DEC(codes.fregs);
ASSERT(codes.fregs >= 0)
END floor;
PROCEDURE flt* (): BOOLEAN;
BEGIN
AddCmd0(opFLT);
INC(codes.fregs)
RETURN codes.fregs < numRegsFloat
END flt;
PROCEDURE shift_minmax* (op: CHAR);
BEGIN
CASE op OF
1015,7 → 1038,7
END len;
PROCEDURE Float* (r: REAL);
PROCEDURE Float* (r: REAL; line, col: INTEGER);
VAR
cmd: COMMAND;
1023,45 → 1046,12
cmd := NewCmd();
cmd.opcode := opCONSTF;
cmd.float := r;
insert(codes.last, cmd);
INC(codes.fregs);
ASSERT(codes.fregs <= numRegsFloat)
cmd.param1 := line;
cmd.param2 := col;
insert(codes.last, cmd)
END Float;
PROCEDURE precall* (flt: BOOLEAN): INTEGER;
VAR
res: INTEGER;
BEGIN
res := codes.fregs;
AddCmd2(opPRECALL, ORD(flt), res);
codes.fregs := 0
RETURN res
END precall;
PROCEDURE resf* (fregs: INTEGER): BOOLEAN;
BEGIN
AddCmd(opRESF, fregs);
codes.fregs := fregs + 1
RETURN codes.fregs < numRegsFloat
END resf;
PROCEDURE res* (fregs: INTEGER);
BEGIN
AddCmd(opRES, fregs);
codes.fregs := fregs
END res;
PROCEDURE retf*;
BEGIN
DEC(codes.fregs);
ASSERT(codes.fregs = 0)
END retf;
PROCEDURE drop*;
BEGIN
AddCmd0(opDROP)
1068,7 → 1058,7
END drop;
PROCEDURE case* (a, b, L, R: INTEGER);
PROCEDURE _case* (a, b, L, R: INTEGER);
VAR
cmd: COMMAND;
1084,13 → 1074,19
AddCmd2(opCASEL, a, L);
AddCmd2(opCASER, b, R)
END
END case;
END _case;
PROCEDURE caset* (a, label: INTEGER);
PROCEDURE fname* (name: PATHS.PATH);
VAR
cmd: FNAMECMD;
BEGIN
AddCmd2(opCASET, label, a)
END caset;
NEW(cmd);
cmd.opcode := opFNAME;
cmd.fname := name;
insert(codes.last, cmd)
END fname;
PROCEDURE AddExp* (label: INTEGER; name: SCAN.LEXSTR);
1111,7 → 1107,7
p: IMPORT_PROC;
BEGIN
lib := codes.import.first(IMPORT_LIB);
lib := codes._import.first(IMPORT_LIB);
WHILE (lib # NIL) & (lib.name # dll) DO
lib := lib.next(IMPORT_LIB)
END;
1120,7 → 1116,7
NEW(lib);
lib.name := dll;
lib.procs := LISTS.create(NIL);
LISTS.push(codes.import, lib)
LISTS.push(codes._import, lib)
END;
p := lib.procs.first(IMPORT_PROC);
1153,7 → 1149,7
lib := imp(IMPORT_PROC).lib;
LISTS.delete(lib.procs, imp);
IF lib.procs.first = NIL THEN
LISTS.delete(codes.import, lib)
LISTS.delete(codes._import, lib)
END
END
END DelImport;
1169,13 → 1165,6
variables := C.create();
CPU := pCPU;
endianness := little_endian;
CASE CPU OF
|TARGETS.cpuAMD64: numRegsFloat := 6
|TARGETS.cpuX86: numRegsFloat := 8
|TARGETS.cpuMSP430: numRegsFloat := 0
|TARGETS.cpuTHUMB: numRegsFloat := 256
END;
NEW(codes.begcall);
codes.begcall.top := -1;
1183,7 → 1172,7
codes.endcall.top := -1;
codes.commands := LISTS.create(NIL);
codes.export := LISTS.create(NIL);
codes.import := LISTS.create(NIL);
codes._import := LISTS.create(NIL);
codes.types := CHL.CreateIntList();
codes.data := CHL.CreateByteList();
1195,8 → 1184,6
codes.lcount := 0;
codes.fregs := 0;
FOR i := 0 TO LEN(codes.charoffs) - 1 DO
codes.charoffs[i] := -1
END;

/programs/develop/oberon07/Source/KOS.ob07
1,7 → 1,7
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
19,8 → 19,6
TYPE
FILE = WR.FILE;
HEADER = RECORD
menuet01: ARRAY 9 OF CHAR;
29,29 → 27,19
END;
PROCEDURE align (n, _align: INTEGER): INTEGER;
BEGIN
IF n MOD _align # 0 THEN
n := n + _align - (n MOD _align)
END
RETURN n
END align;
PROCEDURE Import* (program: BIN.PROGRAM; idata: INTEGER; VAR ImportTable: CHL.INTLIST; VAR len, libcount, size: INTEGER);
VAR
i: INTEGER;
import: BIN.IMPRT;
imp: BIN.IMPRT;
BEGIN
libcount := 0;
import := program.imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
imp := program.imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
INC(libcount)
END;
import := import.next(BIN.IMPRT)
imp := imp.next(BIN.IMPRT)
END;
len := libcount * 2 + 2;
63,29 → 51,29
END;
i := 0;
import := program.imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
imp := program.imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF import.label = 0 THEN
IF imp.label = 0 THEN
CHL.SetInt(ImportTable, len, 0);
INC(len);
CHL.SetInt(ImportTable, i, idata + len * SIZE_OF_DWORD);
INC(i);
CHL.SetInt(ImportTable, i, import.nameoffs + size + idata);
CHL.SetInt(ImportTable, i, imp.nameoffs + size + idata);
INC(i)
ELSE
CHL.SetInt(ImportTable, len, import.nameoffs + size + idata);
import.label := len * SIZE_OF_DWORD;
CHL.SetInt(ImportTable, len, imp.nameoffs + size + idata);
imp.label := len * SIZE_OF_DWORD;
INC(len)
END;
import := import.next(BIN.IMPRT)
imp := imp.next(BIN.IMPRT)
END;
CHL.SetInt(ImportTable, len, 0);
CHL.SetInt(ImportTable, i, 0);
CHL.SetInt(ImportTable, i + 1, 0);
INC(len);
size := size + CHL.Length(program.import)
INC(size, CHL.Length(program._import))
END Import;
100,7 → 88,7
VAR
header: HEADER;
base, text, data, idata, bss: INTEGER;
base, text, data, idata, bss, offset: INTEGER;
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
109,8 → 97,6
i: INTEGER;
File: FILE;
ImportTable: CHL.INTLIST;
ILen, libcount, isize: INTEGER;
121,23 → 107,23
BEGIN
base := 0;
icount := CHL.Length(program.import);
icount := CHL.Length(program._import);
dcount := CHL.Length(program.data);
ccount := CHL.Length(program.code);
text := base + HEADER_SIZE;
data := align(text + ccount, FileAlignment);
idata := align(data + dcount, FileAlignment);
data := WR.align(text + ccount, FileAlignment);
idata := WR.align(data + dcount, FileAlignment);
Import(program, idata, ImportTable, ILen, libcount, isize);
bss := align(idata + isize, FileAlignment);
bss := WR.align(idata + isize, FileAlignment);
header.menuet01 := "MENUET01";
header.ver := 1;
header.start := text;
header.size := idata + isize - base;
header.mem := align(header.size + program.stack + program.bss + PARAM_SIZE * 2 + 4096, FileAlignment);
header.mem := WR.align(header.size + program.stack + program.bss + PARAM_SIZE * 2 + 4096, FileAlignment);
header.sp := base + header.mem - PARAM_SIZE * 2;
header.param := header.sp;
header.path := header.param + PARAM_SIZE;
146,73 → 132,74
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
L := BIN.get32le(code, reloc.offset);
delta := 3 - reloc.offset - text;
offset := reloc.offset;
L := BIN.get32le(code, offset);
delta := 3 - offset - text;
CASE reloc.opcode OF
|BIN.RIMP:
iproc := BIN.GetIProc(program, L);
BIN.put32le(code, reloc.offset, idata + iproc.label)
delta := idata + iproc.label
|BIN.RBSS:
BIN.put32le(code, reloc.offset, L + bss)
delta := L + bss
|BIN.RDATA:
BIN.put32le(code, reloc.offset, L + data)
delta := L + data
|BIN.RCODE:
BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L) + text)
delta := BIN.GetLabel(program, L) + text
|BIN.PICDATA:
BIN.put32le(code, reloc.offset, L + data + delta)
INC(delta, L + data)
|BIN.PICCODE:
BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L) + text + delta)
INC(delta, BIN.GetLabel(program, L) + text)
|BIN.PICBSS:
BIN.put32le(code, reloc.offset, L + bss + delta)
INC(delta, L + bss)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
BIN.put32le(code, reloc.offset, idata + iproc.label + delta)
INC(delta, idata + iproc.label)
|BIN.IMPTAB:
BIN.put32le(code, reloc.offset, idata + delta)
INC(delta, idata)
END;
BIN.put32le(code, offset, delta);
reloc := reloc.next(BIN.RELOC)
END;
File := WR.Create(FileName);
WR.Create(FileName);
FOR i := 0 TO 7 DO
WR.WriteByte(File, ORD(header.menuet01[i]))
WR.WriteByte(ORD(header.menuet01[i]))
END;
WR.Write32LE(File, header.ver);
WR.Write32LE(File, header.start);
WR.Write32LE(File, header.size);
WR.Write32LE(File, header.mem);
WR.Write32LE(File, header.sp);
WR.Write32LE(File, header.param);
WR.Write32LE(File, header.path);
WR.Write32LE(header.ver);
WR.Write32LE(header.start);
WR.Write32LE(header.size);
WR.Write32LE(header.mem);
WR.Write32LE(header.sp);
WR.Write32LE(header.param);
WR.Write32LE(header.path);
CHL.WriteToFile(File, code);
WR.Padding(File, FileAlignment);
CHL.WriteToFile(code);
WR.Padding(FileAlignment);
CHL.WriteToFile(File, program.data);
WR.Padding(File, FileAlignment);
CHL.WriteToFile(program.data);
WR.Padding(FileAlignment);
FOR i := 0 TO ILen - 1 DO
WR.Write32LE(File, CHL.GetInt(ImportTable, i))
WR.Write32LE(CHL.GetInt(ImportTable, i))
END;
CHL.WriteToFile(File, program.import);
CHL.WriteToFile(program._import);
WR.Close(File)
WR.Close
END write;

/programs/develop/oberon07/Source/LISTS.ob07
1,7 → 1,7
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
32,17 → 32,14
IF list.first = NIL THEN
list.first := item;
list.last := item;
item.prev := NIL;
item.next := NIL
item.prev := NIL
ELSE
ASSERT(list.last # NIL);
item.prev := list.last;
list.last.next := item;
item.next := NIL;
list.last := item
END
list.last.next := item
END;
list.last := item;
item.next := NIL
END push;
108,16 → 105,13
IF prev # NIL THEN
prev.next := nov;
nov.prev := prev;
cur.prev := nov;
nov.next := cur
nov.prev := prev
ELSE
nov.prev := NIL;
list.first := nov
END;
cur.prev := nov;
nov.next := cur;
list.first := nov
END
nov.next := cur
END insertL;

/programs/develop/oberon07/Source/MSCOFF.ob07
28,28 → 28,30
SH = PE32.IMAGE_SECTION_HEADER;
PROCEDURE WriteReloc (File: WR.FILE; VirtualAddress, SymbolTableIndex, Type: INTEGER);
PROCEDURE WriteReloc (VirtualAddress, SymbolTableIndex, Type: INTEGER);
BEGIN
WR.Write32LE(File, VirtualAddress);
WR.Write32LE(File, SymbolTableIndex);
WR.Write16LE(File, Type)
WR.Write32LE(VirtualAddress);
WR.Write32LE(SymbolTableIndex);
WR.Write16LE(Type)
END WriteReloc;
PROCEDURE Reloc (program: BIN.PROGRAM; File: WR.FILE);
PROCEDURE Reloc (program: BIN.PROGRAM);
VAR
reloc: BIN.RELOC;
offset: INTEGER;
BEGIN
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
offset := reloc.offset;
CASE reloc.opcode OF
|BIN.RIMP,
BIN.IMPTAB: WriteReloc(File, reloc.offset, 4, 6)
|BIN.RBSS: WriteReloc(File, reloc.offset, 5, 6)
|BIN.RDATA: WriteReloc(File, reloc.offset, 2, 6)
|BIN.RCODE: WriteReloc(File, reloc.offset, 1, 6)
BIN.IMPTAB: WriteReloc(offset, 4, 6)
|BIN.RBSS: WriteReloc(offset, 5, 6)
|BIN.RDATA: WriteReloc(offset, 2, 6)
|BIN.RCODE: WriteReloc(offset, 1, 6)
END;
reloc := reloc.next(BIN.RELOC)
62,6 → 64,7
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
res, L: INTEGER;
offset: INTEGER;
code: CHL.BYTELIST;
BEGIN
71,16 → 74,17
WHILE reloc # NIL DO
INC(res);
offset := reloc.offset;
IF reloc.opcode = BIN.RIMP THEN
L := BIN.get32le(code, reloc.offset);
L := BIN.get32le(code, offset);
iproc := BIN.GetIProc(program, L);
BIN.put32le(code, reloc.offset, iproc.label)
BIN.put32le(code, offset, iproc.label)
END;
IF reloc.opcode = BIN.RCODE THEN
L := BIN.get32le(code, reloc.offset);
BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L))
L := BIN.get32le(code, offset);
BIN.put32le(code, offset, BIN.GetLabel(program, L))
END;
reloc := reloc.next(BIN.RELOC)
92,7 → 96,6
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; ver: INTEGER);
VAR
File: WR.FILE;
exp: BIN.EXPRT;
n, i: INTEGER;
145,7 → 148,7
KOS.Import(program, 0, ImportTable, ILen, LibCount, isize);
ExpCount := LISTS.count(program.exp_list);
icount := CHL.Length(program.import);
icount := CHL.Length(program._import);
dcount := CHL.Length(program.data);
ccount := CHL.Length(program.code);
ecount := CHL.Length(program.export);
219,91 → 222,87
FileHeader.PointerToSymbolTable := idata.PointerToRelocations + ORD(idata.NumberOfRelocations) * 10;
File := WR.Create(FileName);
WR.Create(FileName);
PE32.WriteFileHeader(File, FileHeader);
PE32.WriteFileHeader(FileHeader);
PE32.WriteSectionHeader(File, flat);
PE32.WriteSectionHeader(File, data);
PE32.WriteSectionHeader(File, edata);
PE32.WriteSectionHeader(File, idata);
PE32.WriteSectionHeader(File, bss);
PE32.WriteSectionHeader(flat);
PE32.WriteSectionHeader(data);
PE32.WriteSectionHeader(edata);
PE32.WriteSectionHeader(idata);
PE32.WriteSectionHeader(bss);
CHL.WriteToFile(File, program.code);
CHL.WriteToFile(File, program.data);
CHL.WriteToFile(program.code);
CHL.WriteToFile(program.data);
exp := program.exp_list.first(BIN.EXPRT);
WHILE exp # NIL DO
WR.Write32LE(File, exp.nameoffs + edata.SizeOfRawData - ecount);
WR.Write32LE(File, exp.label);
WR.Write32LE(exp.nameoffs + edata.SizeOfRawData - ecount);
WR.Write32LE(exp.label);
exp := exp.next(BIN.EXPRT)
END;
WR.Write32LE(File, ((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD);
WR.Write32LE(File, ver);
WR.Write32LE(((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD);
WR.Write32LE(ver);
WR.Write32LE(File, 0);
WR.Write32LE(0);
PE32.WriteName(File, szversion);
CHL.WriteToFile(File, program.export);
PE32.WriteName(szversion);
CHL.WriteToFile(program.export);
FOR i := 0 TO ILen - 1 DO
WR.Write32LE(File, CHL.GetInt(ImportTable, i))
WR.Write32LE(CHL.GetInt(ImportTable, i))
END;
CHL.WriteToFile(File, program.import);
CHL.WriteToFile(program._import);
Reloc(program, File);
Reloc(program);
n := 0;
exp := program.exp_list.first(BIN.EXPRT);
WHILE exp # NIL DO
WriteReloc(File, n, 3, 6);
WriteReloc(n, 3, 6);
INC(n, 4);
WriteReloc(File, n, 1, 6);
WriteReloc(n, 1, 6);
INC(n, 4);
exp := exp.next(BIN.EXPRT)
END;
WriteReloc(File, n, 3, 6);
WriteReloc(n, 3, 6);
i := 0;
WHILE i < LibCount * 2 DO
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6);
INC(i);
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6);
INC(i)
FOR i := 0 TO LibCount * 2 - 1 DO
WriteReloc(i * SIZE_OF_DWORD, 4, 6)
END;
FOR i := LibCount * 2 TO ILen - 1 DO
IF CHL.GetInt(ImportTable, i) # 0 THEN
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6)
WriteReloc(i * SIZE_OF_DWORD, 4, 6)
END
END;
PE32.WriteName(File, "EXPORTS");
WriteReloc(File, 0, 3, 2);
PE32.WriteName("EXPORTS");
WriteReloc(0, 3, 2);
PE32.WriteName(File, ".flat");
WriteReloc(File, 0, 1, 3);
PE32.WriteName(".flat");
WriteReloc(0, 1, 3);
PE32.WriteName(File, ".data");
WriteReloc(File, 0, 2, 3);
PE32.WriteName(".data");
WriteReloc(0, 2, 3);
PE32.WriteName(File, ".edata");
WriteReloc(File, 0, 3, 3);
PE32.WriteName(".edata");
WriteReloc(0, 3, 3);
PE32.WriteName(File, ".idata");
WriteReloc(File, 0, 4, 3);
PE32.WriteName(".idata");
WriteReloc(0, 4, 3);
PE32.WriteName(File, ".bss");
WriteReloc(File, 0, 5, 3);
PE32.WriteName(".bss");
WriteReloc(0, 5, 3);
WR.Write32LE(File, 4);
WR.Write32LE(4);
WR.Close(File)
WR.Close
END write;

/programs/develop/oberon07/Source/MSP430.ob07
421,8 → 421,7
PROCEDURE xchg (reg1, reg2: INTEGER);
BEGIN
Push(reg1);
Push(reg2);
Pop(reg1);
mov(reg1, reg2);
Pop(reg2)
END xchg;
819,7 → 818,7
Op2(opADD, reg2 * 256, reg1);
drop
|IL.opADDL, IL.opADDR:
|IL.opADDC:
IF param2 # 0 THEN
UnOp(reg1);
Op2(opADD, imm(param2), reg1)
880,10 → 879,10
cc := cond(opcode);
next := cmd.next(COMMAND);
IF next.opcode = IL.opJE THEN
IF next.opcode = IL.opJNZ THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJNE THEN
ELSIF next.opcode = IL.opJZ THEN
jcc(ORD(BITS(cc) / {0}), next.param1);
cmd := next
ELSE
890,45 → 889,32
setcc(cc, GetAnyReg())
END
|IL.opNOP:
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opCODE:
EmitWord(param2)
|IL.opACC:
IF (R.top # 0) OR (R.stk[0] # ACC) THEN
PushAll(0);
GetRegA;
Pop(ACC);
DEC(R.pushed)
END
|IL.opDROP:
UnOp(reg1);
drop
|IL.opJNZ:
|IL.opJNZ1:
UnOp(reg1);
Test(reg1);
jcc(jne, param1)
|IL.opJZ:
UnOp(reg1);
Test(reg1);
jcc(je, param1)
|IL.opJG:
UnOp(reg1);
Test(reg1);
jcc(jg, param1)
|IL.opJE:
|IL.opJNZ:
UnOp(reg1);
Test(reg1);
jcc(jne, param1);
drop
|IL.opJNE:
|IL.opJZ:
UnOp(reg1);
Test(reg1);
jcc(je, param1);
958,6 → 944,11
drop;
Op2(opMOV + bw(param2 = 1), src_x(param1, SR), dst_x(0, reg2))
|IL.opCHKBYTE:
BinOp(reg1, reg2);
Op2(opCMP, imm(256), reg1);
jcc(jb, param1)
|IL.opCHKIDX:
UnOp(reg1);
Op2(opCMP, imm(param2), reg1);
1079,7 → 1070,7
Op2(opBIC, reg2 * 256, reg1);
drop
|IL.opADDSL, IL.opADDSR:
|IL.opADDSC:
UnOp(reg1);
Op2(opBIS, imm(param2), reg1)
1189,11 → 1180,6
INCL(R.regs, reg1);
ASSERT(REG.GetReg(R, reg1))
|IL.opCHKBYTE:
BinOp(reg1, reg2);
Op2(opCMP, imm(256), reg1);
jcc(jb, param1)
|IL.opLSL, IL.opASR, IL.opROR, IL.opLSR:
PushAll(2);
CASE opcode OF
1618,7 → 1604,7
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
VAR
i, adr, heap, stack, TextSize, TypesSize, bits, n: INTEGER;
i, adr, heap, stack, TextSize, TypesSize, bits, n, val: INTEGER;
Code, Data, Bss, Free: RECORD address, size: INTEGER END;
1626,8 → 1612,6
reloc: RELOC;
file: WR.FILE;
BEGIN
IdxWords.src := NOWORD;
IdxWords.dst := NOWORD;
1687,10 → 1671,11
reloc := RelList.first(RELOC);
WHILE reloc # NIL DO
adr := reloc.WordPtr.offset * 2;
val := reloc.WordPtr.val;
CASE reloc.section OF
|RCODE: PutWord(LabelOffs(reloc.WordPtr.val) * 2, adr)
|RDATA: PutWord(reloc.WordPtr.val + Data.address, adr)
|RBSS: PutWord(reloc.WordPtr.val + Bss.address, adr)
|RCODE: PutWord(LabelOffs(val) * 2, adr)
|RDATA: PutWord(val + Data.address, adr)
|RBSS: PutWord(val + Bss.address, adr)
END;
reloc := reloc.next(RELOC)
END;
1733,13 → 1718,13
PutWord(LabelOffs(IV[i]) * 2, adr)
END;
file := WR.Create(outname);
WR.Create(outname);
HEX.Data(file, mem, Code.address, TextSize);
HEX.Data(file, mem, 10000H - IntVectorSize - TypesSize, IntVectorSize + TypesSize);
HEX.End(file);
HEX.Data(mem, Code.address, TextSize);
HEX.Data(mem, 10000H - IntVectorSize - TypesSize, IntVectorSize + TypesSize);
HEX.End;
WR.Close(file);
WR.Close;
INC(TextSize, IntVectorSize + TypesSize);
INC(Bss.size, minStackSize + RTL.VarSize);

/programs/develop/oberon07/Source/PARS.ob07
34,7 → 34,7
EXPR* = RECORD
obj*: INTEGER;
type*: PROG.TYPE_;
_type*: PROG._TYPE;
value*: ARITH.VALUE;
stproc*: INTEGER;
readOnly*: BOOLEAN;
44,7 → 44,7
STATPROC = PROCEDURE (parser: PARSER);
EXPRPROC = PROCEDURE (parser: PARSER; VAR e: EXPR);
RETPROC = PROCEDURE (parser: PARSER; e: EXPR; t: PROG.TYPE_; pos: POSITION): BOOLEAN;
RETPROC = PROCEDURE (parser: PARSER; e: EXPR; t: PROG._TYPE; pos: POSITION): BOOLEAN;
rPARSER = RECORD (C.ITEM)
74,8 → 74,6
VAR
program*: PROG.PROGRAM;
parsers: C.COLLECTION;
lines*, modules: INTEGER;
133,10 → 131,10
BEGIN
SCAN.Next(parser.scanner, parser.lex);
errno := parser.lex.error;
IF (errno = 0) & (TARGETS.CPU = TARGETS.cpuMSP430) THEN
IF parser.lex.sym = SCAN.lxFLOAT THEN
IF errno = 0 THEN
IF (TARGETS.RealSize = 0) & (parser.lex.sym = SCAN.lxFLOAT) THEN
errno := -SCAN.lxERROR13
ELSIF (parser.lex.sym = SCAN.lxCHAR) & (parser.lex.value.typ = ARITH.tWCHAR) THEN
ELSIF (TARGETS.BitDepth = 16) & (parser.lex.sym = SCAN.lxCHAR) & (parser.lex.value.typ = ARITH.tWCHAR) THEN
errno := -SCAN.lxERROR10
END
END;
184,7 → 182,6
|SCAN.lxSEMI: err := 24
|SCAN.lxRETURN: err := 38
|SCAN.lxMODULE: err := 21
|SCAN.lxSTRING: err := 66
END;
check1(FALSE, parser, err)
227,7 → 224,7
IF (parser.sym = SCAN.lxCOMMA) OR (parser.sym = SCAN.lxSEMI) THEN
alias := FALSE;
unit := PROG.getUnit(program, name);
unit := PROG.getUnit(name);
IF unit # NIL THEN
check(unit.closed, pos, 31)
250,7 → 247,7
unit := parser2.unit;
destroy(parser2)
END;
IF unit = program.sysunit THEN
IF unit = PROG.program.sysunit THEN
parser.unit.sysimport := TRUE
END;
ident.unit := unit
350,7 → 347,7
END ConstExpression;
PROCEDURE FieldList (parser: PARSER; rec: PROG.TYPE_);
PROCEDURE FieldList (parser: PARSER; rec: PROG._TYPE);
VAR
name: SCAN.IDENT;
export: BOOLEAN;
387,18 → 384,18
END FieldList;
PROCEDURE FormalParameters (parser: PARSER; type: PROG.TYPE_);
PROCEDURE FormalParameters (parser: PARSER; _type: PROG._TYPE);
VAR
ident: PROG.IDENT;
PROCEDURE FPSection (parser: PARSER; type: PROG.TYPE_);
PROCEDURE FPSection (parser: PARSER; _type: PROG._TYPE);
VAR
ident: PROG.IDENT;
exit: BOOLEAN;
vPar: BOOLEAN;
dim: INTEGER;
t0, t1: PROG.TYPE_;
t0, t1: PROG._TYPE;
BEGIN
vPar := parser.sym = SCAN.lxVAR;
410,7 → 407,7
exit := FALSE;
WHILE (parser.sym = SCAN.lxIDENT) & ~exit DO
check1(PROG.addParam(type, parser.lex.ident, vPar), parser, 30);
check1(PROG.addParam(_type, parser.lex.ident, vPar), parser, 30);
Next(parser);
IF parser.sym = SCAN.lxCOMMA THEN
ExpectSym(parser, SCAN.lxIDENT)
427,17 → 424,17
ident := QIdent(parser, FALSE);
check1(ident.typ = PROG.idTYPE, parser, 68);
t0 := ident.type;
t0 := ident._type;
t1 := t0;
WHILE dim > 0 DO
t1 := PROG.enterType(program, PROG.tARRAY, -1, 0, parser.unit);
t1 := PROG.enterType(PROG.tARRAY, -1, 0, parser.unit);
t1.base := t0;
t0 := t1;
DEC(dim)
END;
PROG.setParams(type, t1);
PROG.setParams(_type, t1);
Next(parser);
exit := TRUE
ELSE
454,10 → 451,10
Next(parser);
IF (parser.sym = SCAN.lxVAR) OR (parser.sym = SCAN.lxIDENT) THEN
FPSection(parser, type);
FPSection(parser, _type);
WHILE parser.sym = SCAN.lxSEMI DO
Next(parser);
FPSection(parser, type)
FPSection(parser, _type)
END
END;
468,12 → 465,12
ExpectSym(parser, SCAN.lxIDENT);
ident := QIdent(parser, FALSE);
check1(ident.typ = PROG.idTYPE, parser, 68);
check1(~(ident.type.typ IN {PROG.tRECORD, PROG.tARRAY}), parser, 69);
check1( ~(ODD(type.call) & (ident.type.typ = PROG.tREAL)), parser, 113);
type.base := ident.type;
check1(~(ident._type.typ IN {PROG.tRECORD, PROG.tARRAY}), parser, 69);
check1( ~(ODD(_type.call) & (ident._type.typ = PROG.tREAL)), parser, 113);
_type.base := ident._type;
Next(parser)
ELSE
type.base := NIL
_type.base := NIL
END
END
503,6 → 500,8
sf := PROG.sf_linux
ELSIF parser.lex.s = "code" THEN
sf := PROG.sf_code
ELSIF parser.lex.s = "oberon" THEN
sf := PROG.sf_oberon
ELSIF parser.lex.s = "noalign" THEN
sf := PROG.sf_noalign
ELSE
509,7 → 508,7
check1(FALSE, parser, 124)
END;
check1(sf IN program.sysflags, parser, 125);
check1(sf IN PROG.program.sysflags, parser, 125);
IF proc THEN
check1(sf IN PROG.proc_flags, parser, 123)
532,6 → 531,12
res := PROG.systemv
|PROG.sf_code:
res := PROG.code
|PROG.sf_oberon:
IF TARGETS.OS IN {TARGETS.osWIN32, TARGETS.osLINUX32, TARGETS.osKOS} THEN
res := PROG.default32
ELSIF TARGETS.OS IN {TARGETS.osWIN64, TARGETS.osLINUX64} THEN
res := PROG.default64
END
|PROG.sf_windows:
IF TARGETS.OS = TARGETS.osWIN32 THEN
res := PROG.stdcall
552,16 → 557,34
END sysflag;
PROCEDURE procflag (parser: PARSER; VAR import: IL.IMPORT_PROC; isProc: BOOLEAN): INTEGER;
PROCEDURE procflag (parser: PARSER; VAR _import: IL.IMPORT_PROC; isProc: BOOLEAN): INTEGER;
VAR
call: INTEGER;
dll, proc: SCAN.LEXSTR;
pos: POSITION;
PROCEDURE getStr (parser: PARSER; VAR name: SCAN.LEXSTR);
VAR
pos: POSITION;
str: ARITH.VALUE;
BEGIN
getpos(parser, pos);
ConstExpression(parser, str);
IF str.typ = ARITH.tSTRING THEN
name := str.string(SCAN.IDENT).s
ELSIF str.typ = ARITH.tCHAR THEN
ARITH.charToStr(str, name)
ELSE
check(FALSE, pos, 117)
END
END getStr;
import := NIL;
BEGIN
_import := NIL;
IF parser.sym = SCAN.lxLSQUARE THEN
getpos(parser, pos);
check1(parser.unit.sysimport, parser, 54);
572,34 → 595,32
Next(parser);
INC(call)
END;
IF ~isProc THEN
checklex(parser, SCAN.lxRSQUARE)
END;
IF parser.sym = SCAN.lxCOMMA THEN
ExpectSym(parser, SCAN.lxSTRING);
dll := parser.lex.s;
IF isProc & (parser.sym = SCAN.lxCOMMA) THEN
Next(parser);
getStr(parser, dll);
STRINGS.UpCase(dll);
ExpectSym(parser, SCAN.lxCOMMA);
ExpectSym(parser, SCAN.lxSTRING);
proc := parser.lex.s;
checklex(parser, SCAN.lxCOMMA);
Next(parser);
import := IL.AddImp(dll, proc)
getStr(parser, proc);
_import := IL.AddImp(dll, proc)
END;
checklex(parser, SCAN.lxRSQUARE);
Next(parser)
ELSE
CASE TARGETS.BitDepth OF
|16: call := PROG.default16
|32: IF TARGETS.target = TARGETS.STM32CM3 THEN
|32: IF TARGETS.CPU = TARGETS.cpuX86 THEN
call := PROG.default32
ELSE
call := PROG.ccall
ELSE
call := PROG.default32
END
|64: call := PROG.default64
END
END;
IF import # NIL THEN
IF _import # NIL THEN
check(TARGETS.Import, pos, 70)
END
607,7 → 628,7
END procflag;
PROCEDURE type (parser: PARSER; VAR t: PROG.TYPE_; flags: SET);
PROCEDURE _type (parser: PARSER; VAR t: PROG._TYPE; flags: SET);
CONST
comma = 0;
closed = 1;
619,11 → 640,11
ident: PROG.IDENT;
unit: PROG.UNIT;
pos, pos2: POSITION;
fieldType: PROG.TYPE_;
fieldType: PROG._TYPE;
baseIdent: SCAN.IDENT;
a, b: INTEGER;
RecFlag: INTEGER;
import: IL.IMPORT_PROC;
_import: IL.IMPORT_PROC;
BEGIN
unit := parser.unit;
634,7 → 655,7
IF ident # NIL THEN
check1(ident.typ = PROG.idTYPE, parser, 49);
t := ident.type;
t := ident._type;
check1(t # NIL, parser, 50);
IF closed IN flags THEN
check1(t.closed, parser, 50)
656,13 → 677,13
check(ARITH.check(arrLen), pos, 39);
check(ARITH.getInt(arrLen) > 0, pos, 51);
t := PROG.enterType(program, PROG.tARRAY, -1, ARITH.getInt(arrLen), unit);
t := PROG.enterType(PROG.tARRAY, -1, ARITH.getInt(arrLen), unit);
IF parser.sym = SCAN.lxCOMMA THEN
type(parser, t.base, {comma, closed})
_type(parser, t.base, {comma, closed})
ELSIF parser.sym = SCAN.lxOF THEN
Next(parser);
type(parser, t.base, {closed})
_type(parser, t.base, {closed})
ELSE
check1(FALSE, parser, 47)
END;
681,7 → 702,7
getpos(parser, pos2);
Next(parser);
t := PROG.enterType(program, PROG.tRECORD, 0, 0, unit);
t := PROG.enterType(PROG.tRECORD, 0, 0, unit);
t.align := 1;
IF parser.sym = SCAN.lxLSQUARE THEN
698,7 → 719,7
ExpectSym(parser, SCAN.lxIDENT);
getpos(parser, pos);
type(parser, t.base, {closed});
_type(parser, t.base, {closed});
check(t.base.typ IN {PROG.tRECORD, PROG.tPOINTER}, pos, 52);
717,7 → 738,7
t.align := t.base.align
END
ELSE
t.base := program.stTypes.tANYREC
t.base := PROG.program.stTypes.tANYREC
END;
WHILE parser.sym = SCAN.lxIDENT DO
726,7 → 747,7
ASSERT(parser.sym = SCAN.lxCOLON);
Next(parser);
type(parser, fieldType, {closed});
_type(parser, fieldType, {closed});
check(PROG.setFields(t, fieldType), pos2, 104);
IF (fieldType.align > t.align) & ~t.noalign THEN
756,7 → 777,7
ExpectSym(parser, SCAN.lxTO);
Next(parser);
t := PROG.enterType(program, PROG.tPOINTER, TARGETS.AdrSize, 0, unit);
t := PROG.enterType(PROG.tPOINTER, TARGETS.AdrSize, 0, unit);
t.align := TARGETS.AdrSize;
getpos(parser, pos);
765,7 → 786,7
baseIdent := parser.lex.ident
END;
type(parser, t.base, {forward});
_type(parser, t.base, {forward});
IF t.base # NIL THEN
check(t.base.typ = PROG.tRECORD, pos, 58)
775,15 → 796,15
ELSIF parser.sym = SCAN.lxPROCEDURE THEN
NextPos(parser, pos);
t := PROG.enterType(program, PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit);
t := PROG.enterType(PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit);
t.align := TARGETS.AdrSize;
t.call := procflag(parser, import, FALSE);
t.call := procflag(parser, _import, FALSE);
FormalParameters(parser, t)
ELSE
check1(FALSE, parser, 49)
END
END type;
END _type;
PROCEDURE IdentDef (parser: PARSER; typ: INTEGER; VAR name: SCAN.IDENT): PROG.IDENT;
811,7 → 832,7
END IdentDef;
PROCEDURE ConstTypeDeclaration (parser: PARSER; const: BOOLEAN);
PROCEDURE ConstTypeDeclaration (parser: PARSER; _const: BOOLEAN);
VAR
ident: PROG.IDENT;
name: SCAN.IDENT;
818,7 → 839,7
pos: POSITION;
BEGIN
IF const THEN
IF _const THEN
ident := IdentDef(parser, PROG.idNONE, name)
ELSE
ident := IdentDef(parser, PROG.idTYPE, name)
827,7 → 848,7
checklex(parser, SCAN.lxEQ);
NextPos(parser, pos);
IF const THEN
IF _const THEN
ConstExpression(parser, ident.value);
IF ident.value.typ = ARITH.tINTEGER THEN
check(ARITH.check(ident.value), pos, 39)
835,9 → 856,9
check(ARITH.check(ident.value), pos, 40)
END;
ident.typ := PROG.idCONST;
ident.type := PROG.getType(program, ident.value.typ)
ident._type := PROG.getType(ident.value.typ)
ELSE
type(parser, ident.type, {})
_type(parser, ident._type, {})
END;
checklex(parser, SCAN.lxSEMI);
850,7 → 871,7
VAR
ident: PROG.IDENT;
name: SCAN.IDENT;
t: PROG.TYPE_;
t: PROG._TYPE;
BEGIN
861,7 → 882,7
ExpectSym(parser, SCAN.lxIDENT)
ELSIF parser.sym = SCAN.lxCOLON THEN
Next(parser);
type(parser, t, {});
_type(parser, t, {});
PROG.setVarsType(parser.unit, t);
checklex(parser, SCAN.lxSEMI);
Next(parser)
895,8 → 916,8
label: INTEGER;
enter: IL.COMMAND;
call: INTEGER;
t: PROG.TYPE_;
import: IL.IMPORT_PROC;
t: PROG._TYPE;
_import: IL.IMPORT_PROC;
endmod, b: BOOLEAN;
fparams: SET;
variables: LISTS.LIST;
912,16 → 933,19
unit := parser.unit;
call := procflag(parser, import, TRUE);
call := procflag(parser, _import, TRUE);
getpos(parser, pos);
pos1 := pos;
checklex(parser, SCAN.lxIDENT);
IF import # NIL THEN
IF _import # NIL THEN
proc := IdentDef(parser, PROG.idIMP, name);
proc.import := import;
program.procs.last(PROG.PROC).import := import
proc._import := _import;
IF _import.name = "" THEN
_import.name := name.s
END;
PROG.program.procs.last(PROG.PROC)._import := _import
ELSE
proc := IdentDef(parser, PROG.idPROC, name)
END;
928,8 → 952,8
check(PROG.openScope(unit, proc.proc), pos, 116);
proc.type := PROG.enterType(program, PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit);
t := proc.type;
proc._type := PROG.enterType(PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit);
t := proc._type;
t.align := TARGETS.AdrSize;
t.call := call;
959,7 → 983,7
WHILE param # NIL DO
ident := PROG.addIdent(unit, param.name, PROG.idPARAM);
ASSERT(ident # NIL);
ident.type := param.type;
ident._type := param._type;
ident.offset := param.offset;
IF param.vPar THEN
ident.typ := PROG.idVPAR
967,7 → 991,7
param := param.next(PROG.PARAM)
END;
IF import = NIL THEN
IF _import = NIL THEN
label := IL.NewLabel();
proc.proc.label := label;
proc.proc.used := handler;
983,10 → 1007,11
getpos(parser, pos2);
ConstExpression(parser, code);
check(code.typ = ARITH.tINTEGER, pos2, 43);
IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
check(ARITH.range(code, 0, 255), pos2, 42)
ELSIF TARGETS.CPU = TARGETS.cpuTHUMB THEN
check(ARITH.range(code, 0, 65535), pos2, 110)
IF TARGETS.WordSize > TARGETS.InstrSize THEN
CASE TARGETS.InstrSize OF
|1: check(ARITH.range(code, 0, 255), pos, 42)
|2: check(ARITH.range(code, 0, 65535), pos, 110)
END
END;
IL.AddCmd(IL.opCODE, ARITH.getInt(code));
comma := parser.sym = SCAN.lxCOMMA;
1001,7 → 1026,7
checklex(parser, SCAN.lxSEMI);
Next(parser);
IF import = NIL THEN
IF _import = NIL THEN
IF parser.main & proc.export & TARGETS.Dll THEN
IF TARGETS.target = TARGETS.KolibriOSDLL THEN
1015,13 → 1040,13
b := DeclarationSequence(parser)
END;
program.locsize := 0;
PROG.ResetLocSize;
IF call IN {PROG._win64, PROG.win64} THEN
fparams := PROG.getFloatParamsPos(proc.type, 3, int, flt);
enter := IL.Enter(label, LSL(ORD(fparams), 5) + MIN(proc.type.parSize, 4))
fparams := PROG.getFloatParamsPos(proc._type, 3, int, flt);
enter := IL.Enter(label, LSL(ORD(fparams), 5) + MIN(proc._type.parSize, 4))
ELSIF call IN {PROG._systemv, PROG.systemv} THEN
fparams := PROG.getFloatParamsPos(proc.type, PROG.MAXSYSVPARAM - 1, int, flt);
enter := IL.Enter(label, -(LSL(ORD(fparams), 5) + proc.type.parSize))
fparams := PROG.getFloatParamsPos(proc._type, PROG.MAXSYSVPARAM - 1, int, flt);
enter := IL.Enter(label, -(LSL(ORD(fparams), 5) + proc._type.parSize))
ELSIF codeProc THEN
ELSE
1042,9 → 1067,9
END;
IF ~codeProc THEN
proc.proc.leave := IL.Leave(t.base # NIL, (t.base # NIL) & (t.base.typ = PROG.tREAL), program.locsize,
proc.proc.leave := IL.Leave(t.base # NIL, (t.base # NIL) & (t.base.typ = PROG.tREAL), PROG.program.locsize,
t.parSize * ORD((t.call IN PROG.callee_clean_up) OR (t.call IN {PROG.systemv, PROG._systemv})));
enter.param2 := program.locsize;
enter.param2 := PROG.program.locsize;
checklex(parser, SCAN.lxEND)
ELSE
proc.proc.leave := IL.LeaveC()
1051,15 → 1076,16
END;
IF TARGETS.CPU = TARGETS.cpuMSP430 THEN
check((enter.param2 * ORD(~codeProc) + proc.type.parSize) * 2 + 16 < program.options.ram, pos1, 63)
check((enter.param2 * ORD(~codeProc) + proc._type.parSize) * 2 + 16 < PROG.program.options.ram, pos1, 63)
END
END;
IF parser.sym = SCAN.lxEND THEN
ExpectSym(parser, SCAN.lxIDENT);
Next(parser);
IF parser.sym = SCAN.lxIDENT THEN
getpos(parser, pos);
endname := parser.lex.ident;
IF ~codeProc & (import = NIL) THEN
IF ~codeProc & (_import = NIL) THEN
check(endname = name, pos, 60);
ExpectSym(parser, SCAN.lxSEMI);
Next(parser)
1075,9 → 1101,14
error(pos, 60)
END
END
ELSIF parser.sym = SCAN.lxSEMI THEN
Next(parser)
ELSE
checklex(parser, SCAN.lxIDENT)
END
END;
IF ~codeProc & (import = NIL) THEN
IF ~codeProc & (_import = NIL) THEN
variables := LISTS.create(NIL);
ELSE
variables := NIL
1085,7 → 1116,7
PROG.closeScope(unit, variables);
IF ~codeProc & (import = NIL) THEN
IF ~codeProc & (_import = NIL) THEN
enter.variables := variables
END
1157,7 → 1188,7
check1(parser.lex.s = parser.modname, parser, 23)
END;
unit := PROG.newUnit(program, parser.lex.ident);
unit := PROG.newUnit(parser.lex.ident);
parser.unit := unit;
1171,9 → 1202,7
INC(modules);
CONSOLE.String("compiling ");
IF TARGETS.CPU IN {TARGETS.cpuTHUMB, TARGETS.cpuMSP430} THEN
CONSOLE.String("("); CONSOLE.Int(modules); CONSOLE.String(") ")
END;
CONSOLE.String("("); CONSOLE.Int(modules); CONSOLE.String(") ");
CONSOLE.String(unit.name.s);
IF parser.unit.sysimport THEN
CONSOLE.String(" (SYSTEM)")
1180,6 → 1209,10
END;
CONSOLE.Ln;
IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
IL.fname(parser.fname)
END;
label := IL.NewLabel();
IL.AddJmpCmd(IL.opJMP, label);
1189,9 → 1222,7
IL.SetLabel(errlabel);
IL.StrAdr(name);
IL.Param1;
IF TARGETS.CPU IN {TARGETS.cpuTHUMB, TARGETS.cpuMSP430} THEN
IL.AddCmd(IL.opPUSHC, modules)
END;
IL.AddCmd(IL.opPUSHC, modules);
IL.AddCmd0(IL.opERR);
FOR errno := 1 TO LEN(IL.codes.errlabels) - 1 DO
1285,7 → 1316,7
PROCEDURE init* (options: PROG.OPTIONS);
BEGIN
program := PROG.create(options);
PROG.create(options);
parsers := C.create();
lines := 0;
modules := 0

/programs/develop/oberon07/Source/PE32.ob07
1,7 → 1,7
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
102,15 → 102,6
END;
IMAGE_NT_HEADERS = RECORD
Signature: ARRAY 4 OF BYTE;
FileHeader: IMAGE_FILE_HEADER;
OptionalHeader: IMAGE_OPTIONAL_HEADER
END;
IMAGE_SECTION_HEADER* = RECORD
Name*: NAME;
147,35 → 138,33
END;
VIRTUAL_ADDR = RECORD
VIRTUAL_ADDR* = RECORD
Code, Data, Bss, Import: INTEGER
Code*, Data*, Bss*, Import*: INTEGER
END;
FILE = WR.FILE;
VAR
Signature: ARRAY 4 OF BYTE;
FileHeader: IMAGE_FILE_HEADER;
OptionalHeader: IMAGE_OPTIONAL_HEADER;
VAR
msdos: ARRAY 128 OF BYTE;
PEHeader: IMAGE_NT_HEADERS;
SectionHeaders: ARRAY 16 OF IMAGE_SECTION_HEADER;
Relocations: LISTS.LIST;
bit64: BOOLEAN;
libcnt: INTEGER;
SizeOfWord: INTEGER;
PROCEDURE Export (program: BIN.PROGRAM; DataRVA: INTEGER; VAR ExportDir: IMAGE_EXPORT_DIRECTORY): INTEGER;
PROCEDURE Export (program: BIN.PROGRAM; name: INTEGER; VAR ExportDir: IMAGE_EXPORT_DIRECTORY): INTEGER;
BEGIN
ExportDir.Characteristics := 0;
ExportDir.TimeDateStamp := PEHeader.FileHeader.TimeDateStamp;
ExportDir.TimeDateStamp := FileHeader.TimeDateStamp;
ExportDir.MajorVersion := 0X;
ExportDir.MinorVersion := 0X;
ExportDir.Name := program.modname + DataRVA;
ExportDir.Name := name;
ExportDir.Base := 0;
ExportDir.NumberOfFunctions := LISTS.count(program.exp_list);
ExportDir.NumberOfNames := ExportDir.NumberOfFunctions;
187,27 → 176,17
END Export;
PROCEDURE align (n, _align: INTEGER): INTEGER;
BEGIN
IF n MOD _align # 0 THEN
n := n + _align - (n MOD _align)
END
RETURN n
END align;
PROCEDURE GetProcCount (lib: BIN.IMPRT): INTEGER;
VAR
import: BIN.IMPRT;
imp: BIN.IMPRT;
res: INTEGER;
BEGIN
res := 0;
import := lib.next(BIN.IMPRT);
WHILE (import # NIL) & (import.label # 0) DO
imp := lib.next(BIN.IMPRT);
WHILE (imp # NIL) & (imp.label # 0) DO
INC(res);
import := import.next(BIN.IMPRT)
imp := imp.next(BIN.IMPRT)
END
RETURN res
216,7 → 195,7
PROCEDURE GetImportSize (imp_list: LISTS.LIST): INTEGER;
VAR
import: BIN.IMPRT;
imp: BIN.IMPRT;
proccnt: INTEGER;
procoffs: INTEGER;
OriginalCurrentThunk,
225,33 → 204,33
BEGIN
libcnt := 0;
proccnt := 0;
import := imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
imp := imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
INC(libcnt)
ELSE
INC(proccnt)
END;
import := import.next(BIN.IMPRT)
imp := imp.next(BIN.IMPRT)
END;
procoffs := 0;
import := imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
import.OriginalFirstThunk := procoffs;
import.FirstThunk := procoffs + (GetProcCount(import) + 1);
OriginalCurrentThunk := import.OriginalFirstThunk;
CurrentThunk := import.FirstThunk;
procoffs := procoffs + (GetProcCount(import) + 1) * 2
imp := imp_list.first(BIN.IMPRT);
WHILE imp # NIL DO
IF imp.label = 0 THEN
imp.OriginalFirstThunk := procoffs;
imp.FirstThunk := procoffs + (GetProcCount(imp) + 1);
OriginalCurrentThunk := imp.OriginalFirstThunk;
CurrentThunk := imp.FirstThunk;
INC(procoffs, (GetProcCount(imp) + 1) * 2)
ELSE
import.OriginalFirstThunk := OriginalCurrentThunk;
import.FirstThunk := CurrentThunk;
imp.OriginalFirstThunk := OriginalCurrentThunk;
imp.FirstThunk := CurrentThunk;
INC(OriginalCurrentThunk);
INC(CurrentThunk)
END;
import := import.next(BIN.IMPRT)
imp := imp.next(BIN.IMPRT)
END
RETURN (libcnt + 1) * 5 * SIZE_OF_DWORD + (proccnt + libcnt) * 2 * SizeOfWord
258,40 → 237,40
END GetImportSize;
PROCEDURE fixup (program: BIN.PROGRAM; Address: VIRTUAL_ADDR);
PROCEDURE fixup* (program: BIN.PROGRAM; Address: VIRTUAL_ADDR; amd64: BOOLEAN);
VAR
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
code: CHL.BYTELIST;
L, delta, delta0, AdrImp: INTEGER;
L, delta, delta0, AdrImp, offset: INTEGER;
BEGIN
AdrImp := Address.Import + (libcnt + 1) * 5 * SIZE_OF_DWORD;
code := program.code;
reloc := program.rel_list.first(BIN.RELOC);
delta0 := 3 - 7 * ORD(bit64);
delta0 := 3 - 7 * ORD(amd64) - Address.Code;
WHILE reloc # NIL DO
L := BIN.get32le(code, reloc.offset);
delta := delta0 - reloc.offset - Address.Code;
offset := reloc.offset;
L := BIN.get32le(code, offset);
delta := delta0 - offset;
CASE reloc.opcode OF
|BIN.PICDATA:
BIN.put32le(code, reloc.offset, L + Address.Data + delta)
INC(delta, L + Address.Data)
|BIN.PICCODE:
BIN.put32le(code, reloc.offset, BIN.GetLabel(program, L) + Address.Code + delta)
INC(delta, BIN.GetLabel(program, L) + Address.Code)
|BIN.PICBSS:
BIN.put32le(code, reloc.offset, L + Address.Bss + delta)
INC(delta, L + Address.Bss)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
BIN.put32le(code, reloc.offset, iproc.FirstThunk * SizeOfWord + AdrImp + delta)
INC(delta, iproc.FirstThunk * SizeOfWord + AdrImp)
END;
BIN.put32le(code, offset, delta);
reloc := reloc.next(BIN.RELOC)
END
298,13 → 277,13
END fixup;
PROCEDURE WriteWord (file: FILE; w: WORD);
PROCEDURE WriteWord (w: WORD);
BEGIN
WR.Write16LE(file, ORD(w))
WR.Write16LE(ORD(w))
END WriteWord;
PROCEDURE WriteName* (File: FILE; name: NAME);
PROCEDURE WriteName* (name: NAME);
VAR
i, nameLen: INTEGER;
312,12 → 291,12
nameLen := LENGTH(name);
FOR i := 0 TO nameLen - 1 DO
WR.WriteByte(File, ORD(name[i]))
WR.WriteByte(ORD(name[i]))
END;
i := LEN(name) - nameLen;
WHILE i > 0 DO
WR.WriteByte(File, 0);
WR.WriteByte(0);
DEC(i)
END
324,7 → 303,7
END WriteName;
PROCEDURE WriteSectionHeader* (file: FILE; h: IMAGE_SECTION_HEADER);
PROCEDURE WriteSectionHeader* (h: IMAGE_SECTION_HEADER);
VAR
i, nameLen: INTEGER;
332,50 → 311,50
nameLen := LENGTH(h.Name);
FOR i := 0 TO nameLen - 1 DO
WR.WriteByte(file, ORD(h.Name[i]))
WR.WriteByte(ORD(h.Name[i]))
END;
i := LEN(h.Name) - nameLen;
WHILE i > 0 DO
WR.WriteByte(file, 0);
WR.WriteByte(0);
DEC(i)
END;
WR.Write32LE(file, h.VirtualSize);
WR.Write32LE(file, h.VirtualAddress);
WR.Write32LE(file, h.SizeOfRawData);
WR.Write32LE(file, h.PointerToRawData);
WR.Write32LE(file, h.PointerToRelocations);
WR.Write32LE(file, h.PointerToLinenumbers);
WR.Write32LE(h.VirtualSize);
WR.Write32LE(h.VirtualAddress);
WR.Write32LE(h.SizeOfRawData);
WR.Write32LE(h.PointerToRawData);
WR.Write32LE(h.PointerToRelocations);
WR.Write32LE(h.PointerToLinenumbers);
WriteWord(file, h.NumberOfRelocations);
WriteWord(file, h.NumberOfLinenumbers);
WriteWord(h.NumberOfRelocations);
WriteWord(h.NumberOfLinenumbers);
WR.Write32LE(file, h.Characteristics)
WR.Write32LE(h.Characteristics)
END WriteSectionHeader;
PROCEDURE WriteFileHeader* (file: FILE; h: IMAGE_FILE_HEADER);
PROCEDURE WriteFileHeader* (h: IMAGE_FILE_HEADER);
BEGIN
WriteWord(file, h.Machine);
WriteWord(file, h.NumberOfSections);
WriteWord(h.Machine);
WriteWord(h.NumberOfSections);
WR.Write32LE(file, h.TimeDateStamp);
WR.Write32LE(file, h.PointerToSymbolTable);
WR.Write32LE(file, h.NumberOfSymbols);
WR.Write32LE(h.TimeDateStamp);
WR.Write32LE(h.PointerToSymbolTable);
WR.Write32LE(h.NumberOfSymbols);
WriteWord(file, h.SizeOfOptionalHeader);
WriteWord(file, h.Characteristics)
WriteWord(h.SizeOfOptionalHeader);
WriteWord(h.Characteristics)
END WriteFileHeader;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; console, dll, amd64: BOOLEAN);
VAR
i, n: INTEGER;
i, n, temp: INTEGER;
Size: RECORD
Code, Data, Bss, Stack, Import, Reloc, Export: INTEGER
Code, Data, Bss, Import, Reloc, Export: INTEGER
END;
383,9 → 362,7
Address: VIRTUAL_ADDR;
File: FILE;
import: BIN.IMPRT;
_import: BIN.IMPRT;
ImportTable: CHL.INTLIST;
ExportDir: IMAGE_EXPORT_DIRECTORY;
392,99 → 369,93
export: BIN.EXPRT;
PROCEDURE WriteExportDir (file: FILE; e: IMAGE_EXPORT_DIRECTORY);
PROCEDURE WriteExportDir (e: IMAGE_EXPORT_DIRECTORY);
BEGIN
WR.Write32LE(file, e.Characteristics);
WR.Write32LE(file, e.TimeDateStamp);
WR.Write32LE(e.Characteristics);
WR.Write32LE(e.TimeDateStamp);
WriteWord(file, e.MajorVersion);
WriteWord(file, e.MinorVersion);
WriteWord(e.MajorVersion);
WriteWord(e.MinorVersion);
WR.Write32LE(file, e.Name);
WR.Write32LE(file, e.Base);
WR.Write32LE(file, e.NumberOfFunctions);
WR.Write32LE(file, e.NumberOfNames);
WR.Write32LE(file, e.AddressOfFunctions);
WR.Write32LE(file, e.AddressOfNames);
WR.Write32LE(file, e.AddressOfNameOrdinals)
WR.Write32LE(e.Name);
WR.Write32LE(e.Base);
WR.Write32LE(e.NumberOfFunctions);
WR.Write32LE(e.NumberOfNames);
WR.Write32LE(e.AddressOfFunctions);
WR.Write32LE(e.AddressOfNames);
WR.Write32LE(e.AddressOfNameOrdinals)
END WriteExportDir;
PROCEDURE WriteOptHeader (file: FILE; h: IMAGE_OPTIONAL_HEADER);
PROCEDURE WriteOptHeader (h: IMAGE_OPTIONAL_HEADER; amd64: BOOLEAN);
VAR
i: INTEGER;
BEGIN
WriteWord(file, h.Magic);
WriteWord(h.Magic);
WR.WriteByte(file, h.MajorLinkerVersion);
WR.WriteByte(file, h.MinorLinkerVersion);
WR.WriteByte(h.MajorLinkerVersion);
WR.WriteByte(h.MinorLinkerVersion);
WR.Write32LE(file, h.SizeOfCode);
WR.Write32LE(file, h.SizeOfInitializedData);
WR.Write32LE(file, h.SizeOfUninitializedData);
WR.Write32LE(file, h.AddressOfEntryPoint);
WR.Write32LE(file, h.BaseOfCode);
WR.Write32LE(h.SizeOfCode);
WR.Write32LE(h.SizeOfInitializedData);
WR.Write32LE(h.SizeOfUninitializedData);
WR.Write32LE(h.AddressOfEntryPoint);
WR.Write32LE(h.BaseOfCode);
IF bit64 THEN
WR.Write64LE(file, h.ImageBase)
IF amd64 THEN
WR.Write64LE(h.ImageBase)
ELSE
WR.Write32LE(file, h.BaseOfData);
WR.Write32LE(file, h.ImageBase)
WR.Write32LE(h.BaseOfData);
WR.Write32LE(h.ImageBase)
END;
WR.Write32LE(file, h.SectionAlignment);
WR.Write32LE(file, h.FileAlignment);
WR.Write32LE(h.SectionAlignment);
WR.Write32LE(h.FileAlignment);
WriteWord(file, h.MajorOperatingSystemVersion);
WriteWord(file, h.MinorOperatingSystemVersion);
WriteWord(file, h.MajorImageVersion);
WriteWord(file, h.MinorImageVersion);
WriteWord(file, h.MajorSubsystemVersion);
WriteWord(file, h.MinorSubsystemVersion);
WriteWord(h.MajorOperatingSystemVersion);
WriteWord(h.MinorOperatingSystemVersion);
WriteWord(h.MajorImageVersion);
WriteWord(h.MinorImageVersion);
WriteWord(h.MajorSubsystemVersion);
WriteWord(h.MinorSubsystemVersion);
WR.Write32LE(file, h.Win32VersionValue);
WR.Write32LE(file, h.SizeOfImage);
WR.Write32LE(file, h.SizeOfHeaders);
WR.Write32LE(file, h.CheckSum);
WR.Write32LE(h.Win32VersionValue);
WR.Write32LE(h.SizeOfImage);
WR.Write32LE(h.SizeOfHeaders);
WR.Write32LE(h.CheckSum);
WriteWord(file, h.Subsystem);
WriteWord(file, h.DllCharacteristics);
WriteWord(h.Subsystem);
WriteWord(h.DllCharacteristics);
IF bit64 THEN
WR.Write64LE(file, h.SizeOfStackReserve);
WR.Write64LE(file, h.SizeOfStackCommit);
WR.Write64LE(file, h.SizeOfHeapReserve);
WR.Write64LE(file, h.SizeOfHeapCommit)
IF amd64 THEN
WR.Write64LE(h.SizeOfStackReserve);
WR.Write64LE(h.SizeOfStackCommit);
WR.Write64LE(h.SizeOfHeapReserve);
WR.Write64LE(h.SizeOfHeapCommit)
ELSE
WR.Write32LE(file, h.SizeOfStackReserve);
WR.Write32LE(file, h.SizeOfStackCommit);
WR.Write32LE(file, h.SizeOfHeapReserve);
WR.Write32LE(file, h.SizeOfHeapCommit)
WR.Write32LE(h.SizeOfStackReserve);
WR.Write32LE(h.SizeOfStackCommit);
WR.Write32LE(h.SizeOfHeapReserve);
WR.Write32LE(h.SizeOfHeapCommit)
END;
WR.Write32LE(file, h.LoaderFlags);
WR.Write32LE(file, h.NumberOfRvaAndSizes);
WR.Write32LE(h.LoaderFlags);
WR.Write32LE(h.NumberOfRvaAndSizes);
FOR i := 0 TO LEN(h.DataDirectory) - 1 DO
WR.Write32LE(file, h.DataDirectory[i].VirtualAddress);
WR.Write32LE(file, h.DataDirectory[i].Size)
WR.Write32LE(h.DataDirectory[i].VirtualAddress);
WR.Write32LE(h.DataDirectory[i].Size)
END
END WriteOptHeader;
PROCEDURE WritePEHeader (file: FILE; h: IMAGE_NT_HEADERS);
PROCEDURE InitSection (VAR section: IMAGE_SECTION_HEADER; Name: NAME; VirtualSize: INTEGER; Characteristics: DWORD);
BEGIN
WR.Write(file, h.Signature, LEN(h.Signature));
WriteFileHeader(file, h.FileHeader);
WriteOptHeader(file, h.OptionalHeader)
END WritePEHeader;
PROCEDURE InitSection (VAR section: IMAGE_SECTION_HEADER; Name: NAME; Characteristics: DWORD);
BEGIN
section.Name := Name;
section.VirtualSize := VirtualSize;
section.SizeOfRawData := WR.align(VirtualSize, FileAlignment);
section.PointerToRelocations := 0;
section.PointerToLinenumbers := 0;
section.NumberOfRelocations := 0X;
494,14 → 465,11
BEGIN
bit64 := amd64;
SizeOfWord := SIZE_OF_DWORD * (ORD(bit64) + 1);
Relocations := LISTS.create(NIL);
SizeOfWord := SIZE_OF_DWORD * (ORD(amd64) + 1);
Size.Code := CHL.Length(program.code);
Size.Data := CHL.Length(program.data);
Size.Bss := program.bss;
Size.Stack := program.stack;
IF dll THEN
BaseAddress := 10000000H
509,123 → 477,109
BaseAddress := 400000H
END;
PEHeader.Signature[0] := 50H;
PEHeader.Signature[1] := 45H;
PEHeader.Signature[2] := 0;
PEHeader.Signature[3] := 0;
Signature[0] := 50H;
Signature[1] := 45H;
Signature[2] := 0;
Signature[3] := 0;
IF amd64 THEN
PEHeader.FileHeader.Machine := 08664X
FileHeader.Machine := 08664X
ELSE
PEHeader.FileHeader.Machine := 014CX
FileHeader.Machine := 014CX
END;
PEHeader.FileHeader.NumberOfSections := WCHR(4 + ORD(dll));
FileHeader.NumberOfSections := WCHR(4 + ORD(dll));
PEHeader.FileHeader.TimeDateStamp := UTILS.UnixTime();
PEHeader.FileHeader.PointerToSymbolTable := 0H;
PEHeader.FileHeader.NumberOfSymbols := 0H;
PEHeader.FileHeader.SizeOfOptionalHeader := WCHR(0E0H + 10H * ORD(amd64));
PEHeader.FileHeader.Characteristics := WCHR(010EH + (20H - 100H) * ORD(amd64) + 2000H * ORD(dll));
FileHeader.TimeDateStamp := UTILS.UnixTime();
FileHeader.PointerToSymbolTable := 0H;
FileHeader.NumberOfSymbols := 0H;
FileHeader.SizeOfOptionalHeader := WCHR(0E0H + 10H * ORD(amd64));
FileHeader.Characteristics := WCHR(010EH + (20H - 100H) * ORD(amd64) + 2000H * ORD(dll));
PEHeader.OptionalHeader.Magic := WCHR(010BH + 100H * ORD(amd64));
PEHeader.OptionalHeader.MajorLinkerVersion := UTILS.vMajor;
PEHeader.OptionalHeader.MinorLinkerVersion := UTILS.vMinor;
PEHeader.OptionalHeader.SizeOfCode := align(Size.Code, FileAlignment);
PEHeader.OptionalHeader.SizeOfInitializedData := 0;
PEHeader.OptionalHeader.SizeOfUninitializedData := 0;
PEHeader.OptionalHeader.AddressOfEntryPoint := SectionAlignment;
PEHeader.OptionalHeader.BaseOfCode := SectionAlignment;
PEHeader.OptionalHeader.BaseOfData := PEHeader.OptionalHeader.BaseOfCode + align(Size.Code, SectionAlignment);
PEHeader.OptionalHeader.ImageBase := BaseAddress;
PEHeader.OptionalHeader.SectionAlignment := SectionAlignment;
PEHeader.OptionalHeader.FileAlignment := FileAlignment;
PEHeader.OptionalHeader.MajorOperatingSystemVersion := 1X;
PEHeader.OptionalHeader.MinorOperatingSystemVersion := 0X;
PEHeader.OptionalHeader.MajorImageVersion := 0X;
PEHeader.OptionalHeader.MinorImageVersion := 0X;
PEHeader.OptionalHeader.MajorSubsystemVersion := 4X;
PEHeader.OptionalHeader.MinorSubsystemVersion := 0X;
PEHeader.OptionalHeader.Win32VersionValue := 0H;
PEHeader.OptionalHeader.SizeOfImage := SectionAlignment;
PEHeader.OptionalHeader.SizeOfHeaders := 400H;
PEHeader.OptionalHeader.CheckSum := 0;
PEHeader.OptionalHeader.Subsystem := WCHR((2 + ORD(console)) * ORD(~dll));
PEHeader.OptionalHeader.DllCharacteristics := 0040X;
PEHeader.OptionalHeader.SizeOfStackReserve := Size.Stack;
PEHeader.OptionalHeader.SizeOfStackCommit := Size.Stack DIV 16;
PEHeader.OptionalHeader.SizeOfHeapReserve := 100000H;
PEHeader.OptionalHeader.SizeOfHeapCommit := 10000H;
PEHeader.OptionalHeader.LoaderFlags := 0;
PEHeader.OptionalHeader.NumberOfRvaAndSizes := IMAGE_NUMBEROF_DIRECTORY_ENTRIES;
OptionalHeader.Magic := WCHR(010BH + 100H * ORD(amd64));
OptionalHeader.MajorLinkerVersion := UTILS.vMajor;
OptionalHeader.MinorLinkerVersion := UTILS.vMinor;
OptionalHeader.SizeOfCode := WR.align(Size.Code, FileAlignment);
OptionalHeader.SizeOfInitializedData := 0;
OptionalHeader.SizeOfUninitializedData := 0;
OptionalHeader.AddressOfEntryPoint := SectionAlignment;
OptionalHeader.BaseOfCode := SectionAlignment;
OptionalHeader.BaseOfData := OptionalHeader.BaseOfCode + WR.align(Size.Code, SectionAlignment);
OptionalHeader.ImageBase := BaseAddress;
OptionalHeader.SectionAlignment := SectionAlignment;
OptionalHeader.FileAlignment := FileAlignment;
OptionalHeader.MajorOperatingSystemVersion := 1X;
OptionalHeader.MinorOperatingSystemVersion := 0X;
OptionalHeader.MajorImageVersion := 0X;
OptionalHeader.MinorImageVersion := 0X;
OptionalHeader.MajorSubsystemVersion := 4X;
OptionalHeader.MinorSubsystemVersion := 0X;
OptionalHeader.Win32VersionValue := 0H;
OptionalHeader.SizeOfImage := SectionAlignment;
OptionalHeader.SizeOfHeaders := 400H;
OptionalHeader.CheckSum := 0;
OptionalHeader.Subsystem := WCHR((2 + ORD(console)) * ORD(~dll));
OptionalHeader.DllCharacteristics := 0040X;
OptionalHeader.SizeOfStackReserve := 100000H;
OptionalHeader.SizeOfStackCommit := 10000H;
OptionalHeader.SizeOfHeapReserve := 100000H;
OptionalHeader.SizeOfHeapCommit := 10000H;
OptionalHeader.LoaderFlags := 0;
OptionalHeader.NumberOfRvaAndSizes := IMAGE_NUMBEROF_DIRECTORY_ENTRIES;
InitSection(SectionHeaders[0], ".text", SHC_text);
SectionHeaders[0].VirtualSize := Size.Code;
FOR i := 0 TO IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1 DO
OptionalHeader.DataDirectory[i].VirtualAddress := 0;
OptionalHeader.DataDirectory[i].Size := 0
END;
InitSection(SectionHeaders[0], ".text", Size.Code, SHC_text);
SectionHeaders[0].VirtualAddress := SectionAlignment;
SectionHeaders[0].SizeOfRawData := align(Size.Code, FileAlignment);
SectionHeaders[0].PointerToRawData := PEHeader.OptionalHeader.SizeOfHeaders;
SectionHeaders[0].PointerToRawData := OptionalHeader.SizeOfHeaders;
InitSection(SectionHeaders[1], ".data", SHC_data);
SectionHeaders[1].VirtualSize := Size.Data;
SectionHeaders[1].VirtualAddress := align(SectionHeaders[0].VirtualAddress + SectionHeaders[0].VirtualSize, SectionAlignment);
SectionHeaders[1].SizeOfRawData := align(Size.Data, FileAlignment);
InitSection(SectionHeaders[1], ".data", Size.Data, SHC_data);
SectionHeaders[1].VirtualAddress := WR.align(SectionHeaders[0].VirtualAddress + SectionHeaders[0].VirtualSize, SectionAlignment);
SectionHeaders[1].PointerToRawData := SectionHeaders[0].PointerToRawData + SectionHeaders[0].SizeOfRawData;
InitSection(SectionHeaders[2], ".bss", SHC_bss);
SectionHeaders[2].VirtualSize := Size.Bss;
SectionHeaders[2].VirtualAddress := align(SectionHeaders[1].VirtualAddress + SectionHeaders[1].VirtualSize, SectionAlignment);
InitSection(SectionHeaders[2], ".bss", Size.Bss, SHC_bss);
SectionHeaders[2].VirtualAddress := WR.align(SectionHeaders[1].VirtualAddress + SectionHeaders[1].VirtualSize, SectionAlignment);
SectionHeaders[2].PointerToRawData := SectionHeaders[1].PointerToRawData + SectionHeaders[1].SizeOfRawData;
SectionHeaders[2].SizeOfRawData := 0;
SectionHeaders[2].PointerToRawData := SectionHeaders[1].PointerToRawData + SectionHeaders[1].SizeOfRawData;
Size.Import := GetImportSize(program.imp_list);
InitSection(SectionHeaders[3], ".idata", SHC_data);
SectionHeaders[3].VirtualSize := Size.Import + CHL.Length(program.import);
SectionHeaders[3].VirtualAddress := align(SectionHeaders[2].VirtualAddress + SectionHeaders[2].VirtualSize, SectionAlignment);
SectionHeaders[3].SizeOfRawData := align(SectionHeaders[3].VirtualSize, FileAlignment);
InitSection(SectionHeaders[3], ".idata", Size.Import + CHL.Length(program._import), SHC_data);
SectionHeaders[3].VirtualAddress := WR.align(SectionHeaders[2].VirtualAddress + SectionHeaders[2].VirtualSize, SectionAlignment);
SectionHeaders[3].PointerToRawData := SectionHeaders[2].PointerToRawData + SectionHeaders[2].SizeOfRawData;
Address.Code := SectionHeaders[0].VirtualAddress + PEHeader.OptionalHeader.ImageBase;
Address.Data := SectionHeaders[1].VirtualAddress + PEHeader.OptionalHeader.ImageBase;
Address.Bss := SectionHeaders[2].VirtualAddress + PEHeader.OptionalHeader.ImageBase;
Address.Import := SectionHeaders[3].VirtualAddress + PEHeader.OptionalHeader.ImageBase;
Address.Code := SectionHeaders[0].VirtualAddress + OptionalHeader.ImageBase;
Address.Data := SectionHeaders[1].VirtualAddress + OptionalHeader.ImageBase;
Address.Bss := SectionHeaders[2].VirtualAddress + OptionalHeader.ImageBase;
Address.Import := SectionHeaders[3].VirtualAddress + OptionalHeader.ImageBase;
fixup(program, Address);
fixup(program, Address, amd64);
IF dll THEN
Size.Export := Export(program, SectionHeaders[1].VirtualAddress, ExportDir);
Size.Export := Export(program, SectionHeaders[1].VirtualAddress + program.modname, ExportDir);
InitSection(SectionHeaders[4], ".edata", SHC_data);
SectionHeaders[4].VirtualSize := Size.Export + CHL.Length(program.export);
SectionHeaders[4].VirtualAddress := align(SectionHeaders[3].VirtualAddress + SectionHeaders[3].VirtualSize, SectionAlignment);
SectionHeaders[4].SizeOfRawData := align(SectionHeaders[4].VirtualSize, FileAlignment);
InitSection(SectionHeaders[4], ".edata", Size.Export + CHL.Length(program.export), SHC_data);
SectionHeaders[4].VirtualAddress := WR.align(SectionHeaders[3].VirtualAddress + SectionHeaders[3].VirtualSize, SectionAlignment);
SectionHeaders[4].PointerToRawData := SectionHeaders[3].PointerToRawData + SectionHeaders[3].SizeOfRawData;
END;
FOR i := 0 TO IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1 DO
PEHeader.OptionalHeader.DataDirectory[i].VirtualAddress := 0;
PEHeader.OptionalHeader.DataDirectory[i].Size := 0
OptionalHeader.DataDirectory[0].VirtualAddress := SectionHeaders[4].VirtualAddress;
OptionalHeader.DataDirectory[0].Size := SectionHeaders[4].VirtualSize
END;
IF dll THEN
PEHeader.OptionalHeader.DataDirectory[0].VirtualAddress := SectionHeaders[4].VirtualAddress;
PEHeader.OptionalHeader.DataDirectory[0].Size := SectionHeaders[4].VirtualSize
END;
OptionalHeader.DataDirectory[1].VirtualAddress := SectionHeaders[3].VirtualAddress;
OptionalHeader.DataDirectory[1].Size := SectionHeaders[3].VirtualSize;
PEHeader.OptionalHeader.DataDirectory[1].VirtualAddress := SectionHeaders[3].VirtualAddress;
PEHeader.OptionalHeader.DataDirectory[1].Size := SectionHeaders[3].VirtualSize;
FOR i := 0 TO ORD(PEHeader.FileHeader.NumberOfSections) - 1 DO
INC(PEHeader.OptionalHeader.SizeOfInitializedData, SectionHeaders[i].SizeOfRawData)
FOR i := 1 TO ORD(FileHeader.NumberOfSections) - 1 DO
INC(OptionalHeader.SizeOfInitializedData, SectionHeaders[i].SizeOfRawData)
END;
DEC(PEHeader.OptionalHeader.SizeOfInitializedData, SectionHeaders[0].SizeOfRawData);
DEC(PEHeader.OptionalHeader.SizeOfInitializedData, SectionHeaders[2].SizeOfRawData);
OptionalHeader.SizeOfUninitializedData := WR.align(SectionHeaders[2].VirtualSize, FileAlignment);
PEHeader.OptionalHeader.SizeOfUninitializedData := align(SectionHeaders[2].VirtualSize, FileAlignment);
FOR i := 0 TO ORD(PEHeader.FileHeader.NumberOfSections) - 1 DO
INC(PEHeader.OptionalHeader.SizeOfImage, align(SectionHeaders[i].VirtualSize, SectionAlignment))
FOR i := 0 TO ORD(FileHeader.NumberOfSections) - 1 DO
INC(OptionalHeader.SizeOfImage, WR.align(SectionHeaders[i].VirtualSize, SectionAlignment))
END;
n := 0;
634,23 → 588,25
BIN.InitArray(msdos, n, "0E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F");
BIN.InitArray(msdos, n, "742062652072756E20696E20444F53206D6F64652E0D0A240000000000000000");
File := WR.Create(FileName);
WR.Create(FileName);
WR.Write(File, msdos, LEN(msdos));
WR.Write(msdos, LEN(msdos));
WritePEHeader(File, PEHeader);
WR.Write(Signature, LEN(Signature));
WriteFileHeader(FileHeader);
WriteOptHeader(OptionalHeader, amd64);
FOR i := 0 TO ORD(PEHeader.FileHeader.NumberOfSections) - 1 DO
WriteSectionHeader(File, SectionHeaders[i])
FOR i := 0 TO ORD(FileHeader.NumberOfSections) - 1 DO
WriteSectionHeader(SectionHeaders[i])
END;
WR.Padding(File, FileAlignment);
WR.Padding(FileAlignment);
CHL.WriteToFile(File, program.code);
WR.Padding(File, FileAlignment);
CHL.WriteToFile(program.code);
WR.Padding(FileAlignment);
CHL.WriteToFile(File, program.data);
WR.Padding(File, FileAlignment);
CHL.WriteToFile(program.data);
WR.Padding(FileAlignment);
n := (libcnt + 1) * 5;
ImportTable := CHL.CreateIntList();
660,17 → 616,17
END;
i := 0;
import := program.imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
CHL.SetInt(ImportTable, i + 0, import.OriginalFirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
_import := program.imp_list.first(BIN.IMPRT);
WHILE _import # NIL DO
IF _import.label = 0 THEN
CHL.SetInt(ImportTable, i + 0, _import.OriginalFirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
CHL.SetInt(ImportTable, i + 1, 0);
CHL.SetInt(ImportTable, i + 2, 0);
CHL.SetInt(ImportTable, i + 3, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress);
CHL.SetInt(ImportTable, i + 4, import.FirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
i := i + 5
CHL.SetInt(ImportTable, i + 3, _import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress);
CHL.SetInt(ImportTable, i + 4, _import.FirstThunk * SizeOfWord + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
INC(i, 5)
END;
import := import.next(BIN.IMPRT)
_import := _import.next(BIN.IMPRT)
END;
CHL.SetInt(ImportTable, i + 0, 0);
679,29 → 635,30
CHL.SetInt(ImportTable, i + 3, 0);
CHL.SetInt(ImportTable, i + 4, 0);
import := program.imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label # 0 THEN
CHL.SetInt(ImportTable, import.OriginalFirstThunk + n, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress - 2);
CHL.SetInt(ImportTable, import.FirstThunk + n, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress - 2)
_import := program.imp_list.first(BIN.IMPRT);
WHILE _import # NIL DO
IF _import.label # 0 THEN
temp := _import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress - 2;
CHL.SetInt(ImportTable, _import.OriginalFirstThunk + n, temp);
CHL.SetInt(ImportTable, _import.FirstThunk + n, temp)
END;
import := import.next(BIN.IMPRT)
_import := _import.next(BIN.IMPRT)
END;
FOR i := 0 TO n - 1 DO
WR.Write32LE(File, CHL.GetInt(ImportTable, i))
WR.Write32LE(CHL.GetInt(ImportTable, i))
END;
FOR i := n TO CHL.Length(ImportTable) - 1 DO
IF amd64 THEN
WR.Write64LE(File, CHL.GetInt(ImportTable, i))
WR.Write64LE(CHL.GetInt(ImportTable, i))
ELSE
WR.Write32LE(File, CHL.GetInt(ImportTable, i))
WR.Write32LE(CHL.GetInt(ImportTable, i))
END
END;
CHL.WriteToFile(File, program.import);
WR.Padding(File, FileAlignment);
CHL.WriteToFile(program._import);
WR.Padding(FileAlignment);
IF dll THEN
709,29 → 666,29
INC(ExportDir.AddressOfNames, SectionHeaders[4].VirtualAddress);
INC(ExportDir.AddressOfNameOrdinals, SectionHeaders[4].VirtualAddress);
WriteExportDir(File, ExportDir);
WriteExportDir(ExportDir);
export := program.exp_list.first(BIN.EXPRT);
WHILE export # NIL DO
WR.Write32LE(File, export.label + SectionHeaders[0].VirtualAddress);
WR.Write32LE(export.label + SectionHeaders[0].VirtualAddress);
export := export.next(BIN.EXPRT)
END;
export := program.exp_list.first(BIN.EXPRT);
WHILE export # NIL DO
WR.Write32LE(File, export.nameoffs + Size.Export + SectionHeaders[4].VirtualAddress);
WR.Write32LE(export.nameoffs + Size.Export + SectionHeaders[4].VirtualAddress);
export := export.next(BIN.EXPRT)
END;
FOR i := 0 TO ExportDir.NumberOfFunctions - 1 DO
WriteWord(File, WCHR(i))
WriteWord(WCHR(i))
END;
CHL.WriteToFile(File, program.export);
WR.Padding(File, FileAlignment)
CHL.WriteToFile(program.export);
WR.Padding(FileAlignment)
END;
WR.Close(File)
WR.Close
END write;

/programs/develop/oberon07/Source/PROG.ob07
1,13 → 1,13
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE PROG;
IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS;
IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS, STRINGS;
CONST
24,7 → 24,7
tINTEGER* = 1; tBYTE* = 2; tCHAR* = 3; tSET* = 4;
tBOOLEAN* = 5; tREAL* = 6; tARRAY* = 7; tRECORD* = 8;
tPOINTER* = 9; tPROCEDURE* = 10; tSTRING* = 11; tNIL* = 12;
tCARD32* = 13; tANYREC* = 14; tWCHAR* = 15;
tCARD32* = 13; tANYREC* = 14; tWCHAR* = 15; tNONE* = 16;
BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD32, tWCHAR};
40,15 → 40,15
sysSADR* = 31; sysTYPEID* = 32; sysCOPY* = 33; sysINF* = 34;
sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38;
sysWSADR* = 39; sysPUT32* = 40; (*sysNOP* = 41; sysEINT* = 42;
sysDINT* = 43;*)
sysDINT* = 43;*)sysGET8* = 44; sysGET16* = 45; sysGET32* = 46;
default32* = 2;
default32* = 2; _default32* = default32 + 1;
stdcall* = 4; _stdcall* = stdcall + 1;
ccall* = 6; _ccall* = ccall + 1;
ccall16* = 8; _ccall16* = ccall16 + 1;
win64* = 10; _win64* = win64 + 1;
stdcall64* = 12; _stdcall64* = stdcall64 + 1;
default64* = 14;
default64* = 14; _default64* = default64 + 1;
systemv* = 16; _systemv* = systemv + 1;
default16* = 18;
code* = 20; _code* = code + 1;
59,10 → 59,10
sf_stdcall* = 0; sf_stdcall64* = 1; sf_ccall* = 2; sf_ccall16* = 3;
sf_win64* = 4; sf_systemv* = 5; sf_windows* = 6; sf_linux* = 7;
sf_code* = 8;
sf_noalign* = 9;
sf_code* = 8; sf_oberon* = 9;
sf_noalign* = 10;
proc_flags* = {sf_stdcall, sf_stdcall64, sf_ccall, sf_ccall16, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code};
proc_flags* = {sf_stdcall, sf_stdcall64, sf_ccall, sf_ccall16, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code, sf_oberon};
rec_flags* = {sf_noalign};
STACK_FRAME = 2;
73,7 → 73,7
OPTIONS* = RECORD
version*, stack*, ram*, rom*: INTEGER;
pic*: BOOLEAN;
pic*, lower*: BOOLEAN;
checking*: SET
END;
82,13 → 82,11
UNIT* = POINTER TO rUNIT;
PROGRAM* = POINTER TO rPROGRAM;
_TYPE* = POINTER TO rTYPE;
TYPE_* = POINTER TO rTYPE_;
FRWPTR* = POINTER TO RECORD (LISTS.ITEM)
type: TYPE_;
_type: _TYPE;
baseIdent: SCAN.IDENT;
linked: BOOLEAN;
102,7 → 100,7
label*: INTEGER;
used*: BOOLEAN;
processed*: BOOLEAN;
import*: LISTS.ITEM;
_import*: LISTS.ITEM;
using*: LISTS.LIST;
enter*,
leave*: LISTS.ITEM
117,7 → 115,6
rUNIT = RECORD (LISTS.ITEM)
program*: PROGRAM;
name*: SCAN.IDENT;
idents*: LISTS.LIST;
frwPointers: LISTS.LIST;
133,7 → 130,7
PARAM* = POINTER TO rPARAM;
rTYPE_ = RECORD (LISTS.ITEM)
rTYPE = RECORD (LISTS.ITEM)
typ*: INTEGER;
size*: INTEGER;
140,7 → 137,7
parSize*: INTEGER;
length*: INTEGER;
align*: INTEGER;
base*: TYPE_;
base*: _TYPE;
fields*: LISTS.LIST;
params*: LISTS.LIST;
unit*: UNIT;
147,7 → 144,7
closed*: BOOLEAN;
num*: INTEGER;
call*: INTEGER;
import*: BOOLEAN;
_import*: BOOLEAN;
noalign*: BOOLEAN
END;
154,7 → 151,7
rFIELD = RECORD (LISTS.ITEM)
type*: TYPE_;
_type*: _TYPE;
name*: SCAN.IDENT;
export*: BOOLEAN;
offset*: INTEGER
164,7 → 161,7
rPARAM = RECORD (LISTS.ITEM)
name*: SCAN.IDENT;
type*: TYPE_;
_type*: _TYPE;
vPar*: BOOLEAN;
offset*: INTEGER
175,10 → 172,10
name*: SCAN.IDENT;
typ*: INTEGER;
export*: BOOLEAN;
import*: LISTS.ITEM;
_import*: LISTS.ITEM;
unit*: UNIT;
value*: ARITH.VALUE;
type*: TYPE_;
_type*: _TYPE;
stproc*: INTEGER;
global*: BOOLEAN;
scopeLvl*: INTEGER;
188,7 → 185,7
END;
rPROGRAM = RECORD
PROGRAM = RECORD
recCount: INTEGER;
units*: LISTS.LIST;
206,18 → 203,20
stTypes*: RECORD
tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*,
tSTRING*, tNIL*, tCARD32*, tANYREC*: TYPE_
tSTRING*, tNIL*, tCARD32*, tANYREC*, tNONE*: _TYPE
END
END;
DELIMPORT = PROCEDURE (import: LISTS.ITEM);
DELIMPORT = PROCEDURE (_import: LISTS.ITEM);
VAR
LowerCase: BOOLEAN;
idents: C.COLLECTION;
program*: PROGRAM;
PROCEDURE NewIdent (): IDENT;
237,15 → 236,15
END NewIdent;
PROCEDURE getOffset* (program: PROGRAM; varIdent: IDENT): INTEGER;
PROCEDURE getOffset* (varIdent: IDENT): INTEGER;
VAR
size: INTEGER;
BEGIN
IF varIdent.offset = -1 THEN
size := varIdent.type.size;
size := varIdent._type.size;
IF varIdent.global THEN
IF UTILS.Align(program.bss, varIdent.type.align) THEN
IF UTILS.Align(program.bss, varIdent._type.align) THEN
IF UTILS.maxint - program.bss >= size THEN
varIdent.offset := program.bss;
INC(program.bss, size)
281,7 → 280,7
IF (ident.typ = idVAR) & (ident.offset = -1) THEN
ERRORS.HintMsg(ident.name.s, ident.pos.line, ident.pos.col, 0);
IF ident.export THEN
offset := getOffset(unit.program, ident)
offset := getOffset(ident)
END
END;
ident := ident.prev(IDENT)
322,7 → 321,6
item: IDENT;
res: BOOLEAN;
proc: PROC;
procs: LISTS.LIST;
BEGIN
ASSERT(unit # NIL);
337,8 → 335,8
item.typ := typ;
item.unit := NIL;
item.export := FALSE;
item.import := NIL;
item.type := NIL;
item._import := NIL;
item._type := NIL;
item.value.typ := 0;
item.stproc := 0;
348,13 → 346,12
IF item.typ IN {idPROC, idIMP} THEN
NEW(proc);
proc.import := NIL;
proc._import := NIL;
proc.label := 0;
proc.used := FALSE;
proc.processed := FALSE;
proc.using := LISTS.create(NIL);
procs := unit.program.procs;
LISTS.push(procs, proc);
LISTS.push(program.procs, proc);
item.proc := proc
END;
393,16 → 390,16
END UseProc;
PROCEDURE setVarsType* (unit: UNIT; type: TYPE_);
PROCEDURE setVarsType* (unit: UNIT; _type: _TYPE);
VAR
item: IDENT;
BEGIN
ASSERT(type # NIL);
ASSERT(_type # NIL);
item := unit.idents.last(IDENT);
WHILE (item # NIL) & (item.typ = idVAR) & (item.type = NIL) DO
item.type := type;
WHILE (item # NIL) & (item.typ = idVAR) & (item._type = NIL) DO
item._type := _type;
item := item.prev(IDENT)
END
END setVarsType;
481,10 → 478,10
ERRORS.HintMsg(del.name.s, del.pos.line, del.pos.col, 0)
END;
IF (variables # NIL) & (del.typ IN {idVAR, idPARAM}) & (del.offset # -1) THEN
IF del.type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN
IF del._type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN
lvar := IL.NewVar();
lvar.offset := del.offset;
lvar.size := del.type.size;
lvar.size := del._type.size;
IF del.typ = idVAR THEN
lvar.offset := -lvar.offset
END;
504,18 → 501,18
END closeScope;
PROCEDURE frwPtr* (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
PROCEDURE frwPtr* (unit: UNIT; _type: _TYPE; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
VAR
newptr: FRWPTR;
BEGIN
ASSERT(unit # NIL);
ASSERT(type # NIL);
ASSERT(_type # NIL);
ASSERT(baseIdent # NIL);
NEW(newptr);
newptr.type := type;
newptr._type := _type;
newptr.baseIdent := baseIdent;
newptr.pos := pos;
newptr.linked := FALSE;
539,8 → 536,8
ident := getIdent(unit, item.baseIdent, TRUE);
IF (ident # NIL) THEN
IF (ident.typ = idTYPE) & (ident.type.typ = tRECORD) THEN
item.type.base := ident.type;
IF (ident.typ = idTYPE) & (ident._type.typ = tRECORD) THEN
item._type.base := ident._type;
item.linked := TRUE
ELSE
item.notRecord := TRUE;
558,7 → 555,7
END linkPtr;
PROCEDURE isTypeEq* (t1, t2: TYPE_): BOOLEAN;
PROCEDURE isTypeEq* (t1, t2: _TYPE): BOOLEAN;
VAR
res: BOOLEAN;
param1, param2: LISTS.ITEM;
576,7 → 573,7
res := ((t1.call = t2.call) OR (t1.call IN {code, _code}) OR (t2.call IN {code, _code})) & ((param1 # NIL) = (param2 # NIL));
WHILE res & (param1 # NIL) & (param2 # NIL) DO
res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM).type, param2(PARAM).type);
res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM)._type, param2(PARAM)._type);
param1 := param1.next;
param2 := param2.next;
res := res & ((param1 # NIL) = (param2 # NIL))
594,7 → 591,7
END isTypeEq;
PROCEDURE isBaseOf* (t0, t1: TYPE_): BOOLEAN;
PROCEDURE isBaseOf* (t0, t1: _TYPE): BOOLEAN;
VAR
res: BOOLEAN;
617,12 → 614,12
END isBaseOf;
PROCEDURE isOpenArray* (t: TYPE_): BOOLEAN;
PROCEDURE isOpenArray* (t: _TYPE): BOOLEAN;
RETURN (t.typ = tARRAY) & (t.length = 0)
END isOpenArray;
PROCEDURE arrcomp* (src, dst: TYPE_): BOOLEAN;
PROCEDURE arrcomp* (src, dst: _TYPE): BOOLEAN;
RETURN (dst.typ = tARRAY) & isOpenArray(src) &
~isOpenArray(src.base) & ~isOpenArray(dst.base) &
isTypeEq(src.base, dst.base)
629,7 → 626,7
END arrcomp;
PROCEDURE getUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;
PROCEDURE getUnit* (name: SCAN.IDENT): UNIT;
VAR
item: UNIT;
642,7 → 639,7
item := item.next(UNIT)
END;
IF (item = NIL) & (name.s = "SYSTEM") THEN
IF (item = NIL) & ((name.s = "SYSTEM") OR LowerCase & (name.s = "system")) THEN
item := program.sysunit
END
650,36 → 647,40
END getUnit;
PROCEDURE enterStTypes (unit: UNIT; program: PROGRAM);
PROCEDURE enterStTypes (unit: UNIT);
PROCEDURE enter (unit: UNIT; name: SCAN.LEXSTR; _type: _TYPE);
VAR
ident: IDENT;
upper: SCAN.LEXSTR;
BEGIN
ident := addIdent(unit, SCAN.enterid("INTEGER"), idTYPE);
ident.type := program.stTypes.tINTEGER;
IF LowerCase THEN
ident := addIdent(unit, SCAN.enterid(name), idTYPE);
ident._type := _type
END;
upper := name;
STRINGS.UpCase(upper);
ident := addIdent(unit, SCAN.enterid(upper), idTYPE);
ident._type := _type
END enter;
ident := addIdent(unit, SCAN.enterid("BYTE"), idTYPE);
ident.type := program.stTypes.tBYTE;
ident := addIdent(unit, SCAN.enterid("CHAR"), idTYPE);
ident.type := program.stTypes.tCHAR;
BEGIN
enter(unit, "integer", program.stTypes.tINTEGER);
enter(unit, "byte", program.stTypes.tBYTE);
enter(unit, "char", program.stTypes.tCHAR);
enter(unit, "set", program.stTypes.tSET);
enter(unit, "boolean", program.stTypes.tBOOLEAN);
ident := addIdent(unit, SCAN.enterid("SET"), idTYPE);
ident.type := program.stTypes.tSET;
ident := addIdent(unit, SCAN.enterid("BOOLEAN"), idTYPE);
ident.type := program.stTypes.tBOOLEAN;
IF TARGETS.RealSize # 0 THEN
ident := addIdent(unit, SCAN.enterid("REAL"), idTYPE);
ident.type := program.stTypes.tREAL
enter(unit, "real", program.stTypes.tREAL)
END;
IF TARGETS.BitDepth >= 32 THEN
ident := addIdent(unit, SCAN.enterid("WCHAR"), idTYPE);
ident.type := program.stTypes.tWCHAR
enter(unit, "wchar", program.stTypes.tWCHAR)
END
END enterStTypes;
689,9 → 690,19
PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; proc: INTEGER);
VAR
ident: IDENT;
upper: SCAN.LEXSTR;
BEGIN
IF LowerCase THEN
ident := addIdent(unit, SCAN.enterid(name), idSTPROC);
ident.stproc := proc
ident.stproc := proc;
ident._type := program.stTypes.tNONE
END;
upper := name;
STRINGS.UpCase(upper);
ident := addIdent(unit, SCAN.enterid(upper), idSTPROC);
ident.stproc := proc;
ident._type := program.stTypes.tNONE
END EnterProc;
698,64 → 709,72
PROCEDURE EnterFunc (unit: UNIT; name: SCAN.LEXSTR; func: INTEGER);
VAR
ident: IDENT;
upper: SCAN.LEXSTR;
BEGIN
IF LowerCase THEN
ident := addIdent(unit, SCAN.enterid(name), idSTFUNC);
ident.stproc := func
ident.stproc := func;
ident._type := program.stTypes.tNONE
END;
upper := name;
STRINGS.UpCase(upper);
ident := addIdent(unit, SCAN.enterid(upper), idSTFUNC);
ident.stproc := func;
ident._type := program.stTypes.tNONE
END EnterFunc;
BEGIN
EnterProc(unit, "ASSERT", stASSERT);
EnterProc(unit, "DEC", stDEC);
EnterProc(unit, "EXCL", stEXCL);
EnterProc(unit, "INC", stINC);
EnterProc(unit, "INCL", stINCL);
EnterProc(unit, "NEW", stNEW);
EnterProc(unit, "COPY", stCOPY);
EnterProc(unit, "assert", stASSERT);
EnterProc(unit, "dec", stDEC);
EnterProc(unit, "excl", stEXCL);
EnterProc(unit, "inc", stINC);
EnterProc(unit, "incl", stINCL);
EnterProc(unit, "new", stNEW);
EnterProc(unit, "copy", stCOPY);
EnterFunc(unit, "ABS", stABS);
EnterFunc(unit, "ASR", stASR);
EnterFunc(unit, "CHR", stCHR);
EnterFunc(unit, "LEN", stLEN);
EnterFunc(unit, "LSL", stLSL);
EnterFunc(unit, "ODD", stODD);
EnterFunc(unit, "ORD", stORD);
EnterFunc(unit, "ROR", stROR);
EnterFunc(unit, "BITS", stBITS);
EnterFunc(unit, "LSR", stLSR);
EnterFunc(unit, "LENGTH", stLENGTH);
EnterFunc(unit, "MIN", stMIN);
EnterFunc(unit, "MAX", stMAX);
EnterFunc(unit, "abs", stABS);
EnterFunc(unit, "asr", stASR);
EnterFunc(unit, "chr", stCHR);
EnterFunc(unit, "len", stLEN);
EnterFunc(unit, "lsl", stLSL);
EnterFunc(unit, "odd", stODD);
EnterFunc(unit, "ord", stORD);
EnterFunc(unit, "ror", stROR);
EnterFunc(unit, "bits", stBITS);
EnterFunc(unit, "lsr", stLSR);
EnterFunc(unit, "length", stLENGTH);
EnterFunc(unit, "min", stMIN);
EnterFunc(unit, "max", stMAX);
IF TARGETS.RealSize # 0 THEN
EnterProc(unit, "PACK", stPACK);
EnterProc(unit, "UNPK", stUNPK);
EnterFunc(unit, "FLOOR", stFLOOR);
EnterFunc(unit, "FLT", stFLT)
EnterProc(unit, "pack", stPACK);
EnterProc(unit, "unpk", stUNPK);
EnterFunc(unit, "floor", stFLOOR);
EnterFunc(unit, "flt", stFLT)
END;
IF TARGETS.BitDepth >= 32 THEN
EnterFunc(unit, "WCHR", stWCHR)
EnterFunc(unit, "wchr", stWCHR)
END;
IF TARGETS.Dispose THEN
EnterProc(unit, "DISPOSE", stDISPOSE)
EnterProc(unit, "dispose", stDISPOSE)
END
END enterStProcs;
PROCEDURE newUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;
PROCEDURE newUnit* (name: SCAN.IDENT): UNIT;
VAR
unit: UNIT;
BEGIN
ASSERT(program # NIL);
ASSERT(name # NIL);
NEW(unit);
unit.program := program;
unit.name := name;
unit.closed := FALSE;
unit.idents := LISTS.create(NIL);
763,7 → 782,7
ASSERT(openScope(unit, NIL));
enterStTypes(unit, program);
enterStTypes(unit);
enterStProcs(unit);
ASSERT(openScope(unit, NIL));
785,7 → 804,7
END newUnit;
PROCEDURE getField* (self: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;
PROCEDURE getField* (self: _TYPE; name: SCAN.IDENT; unit: UNIT): FIELD;
VAR
field: FIELD;
817,7 → 836,7
END getField;
PROCEDURE addField* (self: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
PROCEDURE addField* (self: _TYPE; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
VAR
field: FIELD;
res: BOOLEAN;
832,7 → 851,7
field.name := name;
field.export := export;
field.type := NIL;
field._type := NIL;
field.offset := self.size;
LISTS.push(self.fields, field)
842,33 → 861,33
END addField;
PROCEDURE setFields* (self: TYPE_; type: TYPE_): BOOLEAN;
PROCEDURE setFields* (self: _TYPE; _type: _TYPE): BOOLEAN;
VAR
item: FIELD;
res: BOOLEAN;
BEGIN
ASSERT(type # NIL);
ASSERT(_type # NIL);
item := self.fields.first(FIELD);
WHILE (item # NIL) & (item.type # NIL) DO
WHILE (item # NIL) & (item._type # NIL) DO
item := item.next(FIELD)
END;
res := TRUE;
WHILE res & (item # NIL) & (item.type = NIL) DO
item.type := type;
WHILE res & (item # NIL) & (item._type = NIL) DO
item._type := _type;
IF ~self.noalign THEN
res := UTILS.Align(self.size, type.align)
res := UTILS.Align(self.size, _type.align)
ELSE
res := TRUE
END;
item.offset := self.size;
res := res & (UTILS.maxint - self.size >= type.size);
res := res & (UTILS.maxint - self.size >= _type.size);
IF res THEN
INC(self.size, type.size)
INC(self.size, _type.size)
END;
item := item.next(FIELD)
END
877,7 → 896,7
END setFields;
PROCEDURE getParam* (self: TYPE_; name: SCAN.IDENT): PARAM;
PROCEDURE getParam* (self: _TYPE; name: SCAN.IDENT): PARAM;
VAR
item: PARAM;
894,7 → 913,7
END getParam;
PROCEDURE addParam* (self: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
PROCEDURE addParam* (self: _TYPE; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
VAR
param: PARAM;
res: BOOLEAN;
908,7 → 927,7
NEW(param);
param.name := name;
param.type := NIL;
param._type := NIL;
param.vPar := vPar;
LISTS.push(self.params, param)
918,7 → 937,7
END addParam;
PROCEDURE Dim* (t: TYPE_): INTEGER;
PROCEDURE Dim* (t: _TYPE): INTEGER;
VAR
res: INTEGER;
932,7 → 951,7
END Dim;
PROCEDURE OpenBase* (t: TYPE_): TYPE_;
PROCEDURE OpenBase* (t: _TYPE): _TYPE;
BEGIN
WHILE isOpenArray(t) DO t := t.base END
RETURN t
939,7 → 958,7
END OpenBase;
PROCEDURE getFloatParamsPos* (self: TYPE_; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
PROCEDURE getFloatParamsPos* (self: _TYPE; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
VAR
res: SET;
param: PARAM;
950,7 → 969,7
flt := 0;
param := self.params.first(PARAM);
WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO
IF ~param.vPar & (param.type.typ = tREAL) THEN
IF ~param.vPar & (param._type.typ = tREAL) THEN
INCL(res, param.offset - STACK_FRAME);
INC(flt)
END;
963,7 → 982,7
END getFloatParamsPos;
PROCEDURE setParams* (self: TYPE_; type: TYPE_);
PROCEDURE setParams* (self: _TYPE; _type: _TYPE);
VAR
item: LISTS.ITEM;
param: PARAM;
970,42 → 989,42
word, size: INTEGER;
BEGIN
ASSERT(type # NIL);
ASSERT(_type # NIL);
word := UTILS.target.bit_depth DIV 8;
item := self.params.first;
WHILE (item # NIL) & (item(PARAM).type # NIL) DO
WHILE (item # NIL) & (item(PARAM)._type # NIL) DO
item := item.next
END;
WHILE (item # NIL) & (item(PARAM).type = NIL) DO
WHILE (item # NIL) & (item(PARAM)._type = NIL) DO
param := item(PARAM);
param.type := type;
param._type := _type;
IF param.vPar THEN
IF type.typ = tRECORD THEN
IF _type.typ = tRECORD THEN
size := 2
ELSIF isOpenArray(type) THEN
size := Dim(type) + 1
ELSIF isOpenArray(_type) THEN
size := Dim(_type) + 1
ELSE
size := 1
END;
param.offset := self.parSize + ORD(type.typ = tRECORD) + Dim(type) + STACK_FRAME;
param.offset := self.parSize + ORD(_type.typ = tRECORD) + Dim(_type) + STACK_FRAME;
INC(self.parSize, size)
ELSE
IF type.typ IN {tRECORD, tARRAY} THEN
IF isOpenArray(type) THEN
size := Dim(type) + 1
IF _type.typ IN {tRECORD, tARRAY} THEN
IF isOpenArray(_type) THEN
size := Dim(_type) + 1
ELSE
size := 1
END
ELSE
size := type.size;
size := _type.size;
ASSERT(UTILS.Align(size, word));
size := size DIV word
END;
param.offset := self.parSize + Dim(type) + STACK_FRAME;
param.offset := self.parSize + Dim(_type) + STACK_FRAME;
INC(self.parSize, size)
END;
1015,9 → 1034,9
END setParams;
PROCEDURE enterType* (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
PROCEDURE enterType* (typ, size, length: INTEGER; unit: UNIT): _TYPE;
VAR
t: TYPE_;
t: _TYPE;
BEGIN
NEW(t);
1038,7 → 1057,7
|64: t.call := default64
END;
t.import := FALSE;
t._import := FALSE;
t.noalign := FALSE;
t.parSize := 0;
1058,9 → 1077,9
END enterType;
PROCEDURE getType* (program: PROGRAM; typ: INTEGER): TYPE_;
PROCEDURE getType* (typ: INTEGER): _TYPE;
VAR
res: TYPE_;
res: _TYPE;
BEGIN
1078,7 → 1097,7
END getType;
PROCEDURE createSysUnit (program: PROGRAM);
PROCEDURE createSysUnit;
VAR
ident: IDENT;
unit: UNIT;
1087,50 → 1106,69
PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
VAR
ident: IDENT;
upper: SCAN.LEXSTR;
BEGIN
IF LowerCase THEN
ident := addIdent(sys, SCAN.enterid(name), idtyp);
ident.stproc := proc;
ident._type := program.stTypes.tNONE;
ident.export := TRUE
END;
upper := name;
STRINGS.UpCase(upper);
ident := addIdent(sys, SCAN.enterid(upper), idtyp);
ident.stproc := proc;
ident._type := program.stTypes.tNONE;
ident.export := TRUE
END EnterProc;
BEGIN
unit := newUnit(program, SCAN.enterid("$SYSTEM"));
unit := newUnit(SCAN.enterid("$SYSTEM"));
EnterProc(unit, "ADR", idSYSFUNC, sysADR);
EnterProc(unit, "SIZE", idSYSFUNC, sysSIZE);
EnterProc(unit, "SADR", idSYSFUNC, sysSADR);
EnterProc(unit, "TYPEID", idSYSFUNC, sysTYPEID);
EnterProc(unit, "adr", idSYSFUNC, sysADR);
EnterProc(unit, "size", idSYSFUNC, sysSIZE);
EnterProc(unit, "sadr", idSYSFUNC, sysSADR);
EnterProc(unit, "typeid", idSYSFUNC, sysTYPEID);
EnterProc(unit, "GET", idSYSPROC, sysGET);
EnterProc(unit, "PUT8", idSYSPROC, sysPUT8);
EnterProc(unit, "PUT", idSYSPROC, sysPUT);
EnterProc(unit, "CODE", idSYSPROC, sysCODE);
EnterProc(unit, "MOVE", idSYSPROC, sysMOVE);
EnterProc(unit, "get", idSYSPROC, sysGET);
EnterProc(unit, "get8", idSYSPROC, sysGET8);
EnterProc(unit, "put", idSYSPROC, sysPUT);
EnterProc(unit, "put8", idSYSPROC, sysPUT8);
EnterProc(unit, "code", idSYSPROC, sysCODE);
EnterProc(unit, "move", idSYSPROC, sysMOVE);
(*
IF program.target.sys = mConst.Target_iMSP430 THEN
EnterProc(unit, "NOP", idSYSPROC, sysNOP);
EnterProc(unit, "EINT", idSYSPROC, sysEINT);
EnterProc(unit, "DINT", idSYSPROC, sysDINT)
EnterProc(unit, "nop", idSYSPROC, sysNOP);
EnterProc(unit, "eint", idSYSPROC, sysEINT);
EnterProc(unit, "dint", idSYSPROC, sysDINT)
END;
*)
IF TARGETS.RealSize # 0 THEN
EnterProc(unit, "INF", idSYSFUNC, sysINF);
EnterProc(unit, "inf", idSYSFUNC, sysINF);
END;
IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
EnterProc(unit, "COPY", idSYSPROC, sysCOPY)
EnterProc(unit, "copy", idSYSPROC, sysCOPY)
END;
IF TARGETS.BitDepth >= 32 THEN
EnterProc(unit, "WSADR", idSYSFUNC, sysWSADR);
EnterProc(unit, "PUT32", idSYSPROC, sysPUT32);
EnterProc(unit, "PUT16", idSYSPROC, sysPUT16);
EnterProc(unit, "wsadr", idSYSFUNC, sysWSADR);
EnterProc(unit, "put16", idSYSPROC, sysPUT16);
EnterProc(unit, "put32", idSYSPROC, sysPUT32);
EnterProc(unit, "get16", idSYSPROC, sysGET16);
EnterProc(unit, "get32", idSYSPROC, sysGET32);
ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
ident.type := program.stTypes.tCARD32;
IF LowerCase THEN
ident := addIdent(unit, SCAN.enterid("card32"), idTYPE);
ident._type := program.stTypes.tCARD32;
ident.export := TRUE
END;
ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
ident._type := program.stTypes.tCARD32;
ident.export := TRUE;
END;
closeUnit(unit);
1138,7 → 1176,7
END createSysUnit;
PROCEDURE DelUnused* (program: PROGRAM; DelImport: DELIMPORT);
PROCEDURE DelUnused* (DelImport: DELIMPORT);
VAR
proc: PROC;
flag: BOOLEAN;
1180,10 → 1218,10
WHILE proc # NIL DO
IF ~proc.used THEN
IF proc.import = NIL THEN
IF proc._import = NIL THEN
IL.delete2(proc.enter, proc.leave)
ELSE
DelImport(proc.import)
DelImport(proc._import)
END
END;
proc := proc.next(PROC)
1192,24 → 1230,28
END DelUnused;
PROCEDURE create* (options: OPTIONS): PROGRAM;
VAR
program: PROGRAM;
PROCEDURE ResetLocSize*;
BEGIN
program.locsize := 0
END ResetLocSize;
PROCEDURE create* (options: OPTIONS);
BEGIN
LowerCase := options.lower;
SCAN.init(options.lower);
idents := C.create();
UTILS.SetBitDepth(TARGETS.BitDepth, TARGETS.RealSize = 8);
NEW(program);
program.options := options;
CASE TARGETS.OS OF
|TARGETS.osWIN32: program.sysflags := {sf_windows, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osLINUX32: program.sysflags := {sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osKOS: program.sysflags := {sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osWIN64: program.sysflags := {sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|TARGETS.osLINUX64: program.sysflags := {sf_linux, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|TARGETS.osWIN32: program.sysflags := {sf_oberon, sf_windows, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osLINUX32: program.sysflags := {sf_oberon, sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osKOS: program.sysflags := {sf_oberon, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osWIN64: program.sysflags := {sf_oberon, sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|TARGETS.osLINUX64: program.sysflags := {sf_oberon, sf_linux, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|TARGETS.osNONE: program.sysflags := {sf_code}
END;
1220,11 → 1262,11
program.types := LISTS.create(NIL);
program.procs := LISTS.create(NIL);
program.stTypes.tINTEGER := enterType(program, tINTEGER, TARGETS.WordSize, 0, NIL);
program.stTypes.tBYTE := enterType(program, tBYTE, 1, 0, NIL);
program.stTypes.tCHAR := enterType(program, tCHAR, 1, 0, NIL);
program.stTypes.tSET := enterType(program, tSET, TARGETS.WordSize, 0, NIL);
program.stTypes.tBOOLEAN := enterType(program, tBOOLEAN, 1, 0, NIL);
program.stTypes.tINTEGER := enterType(tINTEGER, TARGETS.WordSize, 0, NIL);
program.stTypes.tBYTE := enterType(tBYTE, 1, 0, NIL);
program.stTypes.tCHAR := enterType(tCHAR, 1, 0, NIL);
program.stTypes.tSET := enterType(tSET, TARGETS.WordSize, 0, NIL);
program.stTypes.tBOOLEAN := enterType(tBOOLEAN, 1, 0, NIL);
program.stTypes.tINTEGER.align := TARGETS.WordSize;
program.stTypes.tBYTE.align := 1;
1233,26 → 1275,24
program.stTypes.tBOOLEAN.align := 1;
IF TARGETS.BitDepth >= 32 THEN
program.stTypes.tWCHAR := enterType(program, tWCHAR, 2, 0, NIL);
program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL);
program.stTypes.tWCHAR := enterType(tWCHAR, 2, 0, NIL);
program.stTypes.tCARD32 := enterType(tCARD32, 4, 0, NIL);
program.stTypes.tWCHAR.align := 2;
program.stTypes.tCARD32.align := 4
END;
IF TARGETS.RealSize # 0 THEN
program.stTypes.tREAL := enterType(program, tREAL, TARGETS.RealSize, 0, NIL);
program.stTypes.tREAL := enterType(tREAL, TARGETS.RealSize, 0, NIL);
program.stTypes.tREAL.align := TARGETS.RealSize
END;
program.stTypes.tSTRING := enterType(program, tSTRING, TARGETS.WordSize, 0, NIL);
program.stTypes.tNIL := enterType(program, tNIL, TARGETS.WordSize, 0, NIL);
program.stTypes.tANYREC := enterType(program, tRECORD, 0, 0, NIL);
program.stTypes.tSTRING := enterType(tSTRING, TARGETS.WordSize, 0, NIL);
program.stTypes.tNIL := enterType(tNIL, TARGETS.WordSize, 0, NIL);
program.stTypes.tNONE := enterType(tNONE, 0, 0, NIL);
program.stTypes.tANYREC := enterType(tRECORD, 0, 0, NIL);
program.stTypes.tANYREC.closed := TRUE;
createSysUnit(program)
RETURN program
createSysUnit
END create;

/programs/develop/oberon07/Source/REG.ob07
1,7 → 1,7
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
156,7 → 156,7
PROCEDURE GetReg* (VAR R: REGS; reg: INTEGER): BOOLEAN;
VAR
free, n: INTEGER;
free: INTEGER;
res: BOOLEAN;
178,8 → 178,8
Put(R, reg);
res := TRUE
ELSE
n := InStk(R, reg);
IF n # -1 THEN
res := InStk(R, reg) # -1;
IF res THEN
free := GetFreeReg(R);
IF free # -1 THEN
Put(R, free);
192,12 → 192,9
IF free # reg THEN
exch(R, reg, free)
END
END;
res := TRUE
ELSE
res := FALSE
END
END
END
RETURN res
END GetReg;

/programs/develop/oberon07/Source/RVM32I.ob07
0,0 → 1,1302
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
MODULE RVM32I;
IMPORT
PROG, WR := WRITER, IL, CHL := CHUNKLISTS, REG, UTILS, STRINGS, ERRORS;
CONST
LTypes = 0;
LStrings = 1;
LGlobal = 2;
LHeap = 3;
LStack = 4;
numGPRs = 3;
R0 = 0; R1 = 1;
BP = 3; SP = 4;
ACC = R0;
GPRs = {0 .. 2} + {5 .. numGPRs + 1};
opSTOP = 0; opRET = 1; opENTER = 2; opNEG = 3; opNOT = 4; opABS = 5;
opXCHG = 6; opLDR8 = 7; opLDR16 = 8; opLDR32 = 9; opPUSH = 10; opPUSHC = 11;
opPOP = 12; opJGZ = 13; opJZ = 14; opJNZ = 15; opLLA = 16; opJGA = 17;
opJLA = 18; opJMP = 19; opCALL = 20; opCALLI = 21;
opMOV = 22; opMUL = 24; opADD = 26; opSUB = 28; opDIV = 30; opMOD = 32;
opSTR8 = 34; opSTR16 = 36; opSTR32 = 38; opINCL = 40; opEXCL = 42;
opIN = 44; opAND = 46; opOR = 48; opXOR = 50; opASR = 52; opLSR = 54;
opLSL = 56; opROR = 58; opMIN = 60; opMAX = 62; opEQ = 64; opNE = 66;
opLT = 68; opLE = 70; opGT = 72; opGE = 74; opBT = 76;
opMOVC = 23; opMULC = 25; opADDC = 27; opSUBC = 29; opDIVC = 31; opMODC = 33;
opSTR8C = 35; opSTR16C = 37; opSTR32C = 39; opINCLC = 41; opEXCLC = 43;
opINC = 45; opANDC = 47; opORC = 49; opXORC = 51; opASRC = 53; opLSRC = 55;
opLSLC = 57; opRORC = 59; opMINC = 61; opMAXC = 63; opEQC = 65; opNEC = 67;
opLTC = 69; opLEC = 71; opGTC = 73; opGEC = 75; opBTC = 77;
opLEA = 78; opLABEL = 79;
inf = 7F800000H;
VAR
R: REG.REGS; count: INTEGER;
PROCEDURE OutByte (n: BYTE);
BEGIN
WR.WriteByte(n);
INC(count)
END OutByte;
PROCEDURE OutInt (n: INTEGER);
BEGIN
WR.Write32LE(n);
INC(count, 4)
END OutInt;
PROCEDURE Emit (op, par1, par2: INTEGER);
BEGIN
OutInt(op);
OutInt(par1);
OutInt(par2)
END Emit;
PROCEDURE drop;
BEGIN
REG.Drop(R)
END drop;
PROCEDURE GetAnyReg (): INTEGER;
RETURN REG.GetAnyReg(R)
END GetAnyReg;
PROCEDURE GetAcc;
BEGIN
ASSERT(REG.GetReg(R, ACC))
END GetAcc;
PROCEDURE UnOp (VAR r: INTEGER);
BEGIN
REG.UnOp(R, r)
END UnOp;
PROCEDURE BinOp (VAR r1, r2: INTEGER);
BEGIN
REG.BinOp(R, r1, r2)
END BinOp;
PROCEDURE PushAll (NumberOfParameters: INTEGER);
BEGIN
REG.PushAll(R);
DEC(R.pushed, NumberOfParameters)
END PushAll;
PROCEDURE push (r: INTEGER);
BEGIN
Emit(opPUSH, r, 0)
END push;
PROCEDURE pop (r: INTEGER);
BEGIN
Emit(opPOP, r, 0)
END pop;
PROCEDURE mov (r1, r2: INTEGER);
BEGIN
Emit(opMOV, r1, r2)
END mov;
PROCEDURE xchg (r1, r2: INTEGER);
BEGIN
Emit(opXCHG, r1, r2)
END xchg;
PROCEDURE addrc (r, c: INTEGER);
BEGIN
Emit(opADDC, r, c)
END addrc;
PROCEDURE subrc (r, c: INTEGER);
BEGIN
Emit(opSUBC, r, c)
END subrc;
PROCEDURE movrc (r, c: INTEGER);
BEGIN
Emit(opMOVC, r, c)
END movrc;
PROCEDURE pushc (c: INTEGER);
BEGIN
Emit(opPUSHC, c, 0)
END pushc;
PROCEDURE add (r1, r2: INTEGER);
BEGIN
Emit(opADD, r1, r2)
END add;
PROCEDURE sub (r1, r2: INTEGER);
BEGIN
Emit(opSUB, r1, r2)
END sub;
PROCEDURE ldr32 (r1, r2: INTEGER);
BEGIN
Emit(opLDR32, r1, r2)
END ldr32;
PROCEDURE ldr16 (r1, r2: INTEGER);
BEGIN
Emit(opLDR16, r1, r2)
END ldr16;
PROCEDURE ldr8 (r1, r2: INTEGER);
BEGIN
Emit(opLDR8, r1, r2)
END ldr8;
PROCEDURE str32 (r1, r2: INTEGER);
BEGIN
Emit(opSTR32, r1, r2)
END str32;
PROCEDURE str16 (r1, r2: INTEGER);
BEGIN
Emit(opSTR16, r1, r2)
END str16;
PROCEDURE str8 (r1, r2: INTEGER);
BEGIN
Emit(opSTR8, r1, r2)
END str8;
PROCEDURE GlobalAdr (r, offset: INTEGER);
BEGIN
Emit(opLEA, r + 256 * LGlobal, offset)
END GlobalAdr;
PROCEDURE StrAdr (r, offset: INTEGER);
BEGIN
Emit(opLEA, r + 256 * LStrings, offset)
END StrAdr;
PROCEDURE ProcAdr (r, label: INTEGER);
BEGIN
Emit(opLLA, r, label)
END ProcAdr;
PROCEDURE jnz (r, label: INTEGER);
BEGIN
Emit(opJNZ, r, label)
END jnz;
PROCEDURE CallRTL (proc, par: INTEGER);
BEGIN
Emit(opCALL, IL.codes.rtl[proc], 0);
addrc(SP, par * 4)
END CallRTL;
PROCEDURE translate;
VAR
cmd: IL.COMMAND;
opcode, param1, param2: INTEGER;
r1, r2, r3: INTEGER;
BEGIN
cmd := IL.codes.commands.first(IL.COMMAND);
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
opcode := cmd.opcode;
CASE opcode OF
|IL.opJMP:
Emit(opJMP, param1, 0)
|IL.opLABEL:
Emit(opLABEL, param1, 0)
|IL.opCALL:
Emit(opCALL, param1, 0)
|IL.opCALLP:
UnOp(r1);
Emit(opCALLI, r1, 0);
drop;
ASSERT(R.top = -1)
|IL.opPUSHC:
pushc(param2)
|IL.opCLEANUP:
IF param2 # 0 THEN
addrc(SP, param2 * 4)
END
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opSADR:
StrAdr(GetAnyReg(), param2)
|IL.opGADR:
GlobalAdr(GetAnyReg(), param2)
|IL.opLADR:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4)
|IL.opPARAM:
IF param2 = 1 THEN
UnOp(r1);
push(r1);
drop
ELSE
ASSERT(R.top + 1 <= param2);
PushAll(param2)
END
|IL.opONERR:
pushc(param2);
Emit(opJMP, param1, 0)
|IL.opPRECALL:
PushAll(0)
|IL.opRES, IL.opRESF:
ASSERT(R.top = -1);
GetAcc
|IL.opENTER:
ASSERT(R.top = -1);
Emit(opLABEL, param1, 0);
Emit(opENTER, param2, 0)
|IL.opLEAVE, IL.opLEAVER, IL.opLEAVEF:
IF opcode # IL.opLEAVE THEN
UnOp(r1);
IF r1 # ACC THEN
GetAcc;
ASSERT(REG.Exchange(R, r1, ACC));
drop
END;
drop
END;
ASSERT(R.top = -1);
IF param1 > 0 THEN
mov(SP, BP)
END;
pop(BP);
Emit(opRET, 0, 0)
|IL.opLEAVEC:
Emit(opRET, 0, 0)
|IL.opCONST:
movrc(GetAnyReg(), param2)
|IL.opDROP:
UnOp(r1);
drop
|IL.opSAVEC:
UnOp(r1);
Emit(opSTR32C, r1, param2);
drop
|IL.opSAVE8C:
UnOp(r1);
Emit(opSTR8C, r1, param2 MOD 256);
drop
|IL.opSAVE16C:
UnOp(r1);
Emit(opSTR16C, r1, param2 MOD 65536);
drop
|IL.opSAVE, IL.opSAVE32, IL.opSAVEF:
BinOp(r2, r1);
str32(r1, r2);
drop;
drop
|IL.opSAVEFI:
BinOp(r2, r1);
str32(r2, r1);
drop;
drop
|IL.opSAVE8:
BinOp(r2, r1);
str8(r1, r2);
drop;
drop
|IL.opSAVE16:
BinOp(r2, r1);
str16(r1, r2);
drop;
drop
|IL.opGLOAD32:
r1 := GetAnyReg();
GlobalAdr(r1, param2);
ldr32(r1, r1)
|IL.opVADR, IL.opLLOAD32:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr32(r1, r1)
|IL.opVLOAD32:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr32(r1, r1);
ldr32(r1, r1)
|IL.opGLOAD16:
r1 := GetAnyReg();
GlobalAdr(r1, param2);
ldr16(r1, r1)
|IL.opLLOAD16:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr16(r1, r1)
|IL.opVLOAD16:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr32(r1, r1);
ldr16(r1, r1)
|IL.opGLOAD8:
r1 := GetAnyReg();
GlobalAdr(r1, param2);
ldr8(r1, r1)
|IL.opLLOAD8:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr8(r1, r1)
|IL.opVLOAD8:
r1 := GetAnyReg();
mov(r1, BP);
addrc(r1, param2 * 4);
ldr32(r1, r1);
ldr8(r1, r1)
|IL.opLOAD8:
UnOp(r1);
ldr8(r1, r1)
|IL.opLOAD16:
UnOp(r1);
ldr16(r1, r1)
|IL.opLOAD32, IL.opLOADF:
UnOp(r1);
ldr32(r1, r1)
|IL.opLOOP, IL.opENDLOOP:
|IL.opUMINUS:
UnOp(r1);
Emit(opNEG, r1, 0)
|IL.opADD:
BinOp(r1, r2);
add(r1, r2);
drop
|IL.opSUB:
BinOp(r1, r2);
sub(r1, r2);
drop
|IL.opADDC:
UnOp(r1);
addrc(r1, param2)
|IL.opSUBR:
UnOp(r1);
subrc(r1, param2)
|IL.opSUBL:
UnOp(r1);
subrc(r1, param2);
Emit(opNEG, r1, 0)
|IL.opMULC:
UnOp(r1);
Emit(opMULC, r1, param2)
|IL.opMUL:
BinOp(r1, r2);
Emit(opMUL, r1, r2);
drop
|IL.opDIV:
BinOp(r1, r2);
Emit(opDIV, r1, r2);
drop
|IL.opMOD:
BinOp(r1, r2);
Emit(opMOD, r1, r2);
drop
|IL.opDIVR:
UnOp(r1);
Emit(opDIVC, r1, param2)
|IL.opMODR:
UnOp(r1);
Emit(opMODC, r1, param2)
|IL.opDIVL:
UnOp(r1);
r2 := GetAnyReg();
movrc(r2, param2);
Emit(opDIV, r2, r1);
mov(r1, r2);
drop
|IL.opMODL:
UnOp(r1);
r2 := GetAnyReg();
movrc(r2, param2);
Emit(opMOD, r2, r1);
mov(r1, r2);
drop
|IL.opEQ:
BinOp(r1, r2);
Emit(opEQ, r1, r2);
drop
|IL.opNE:
BinOp(r1, r2);
Emit(opNE, r1, r2);
drop
|IL.opLT:
BinOp(r1, r2);
Emit(opLT, r1, r2);
drop
|IL.opLE:
BinOp(r1, r2);
Emit(opLE, r1, r2);
drop
|IL.opGT:
BinOp(r1, r2);
Emit(opGT, r1, r2);
drop
|IL.opGE:
BinOp(r1, r2);
Emit(opGE, r1, r2);
drop
|IL.opEQC:
UnOp(r1);
Emit(opEQC, r1, param2)
|IL.opNEC:
UnOp(r1);
Emit(opNEC, r1, param2)
|IL.opLTC:
UnOp(r1);
Emit(opLTC, r1, param2)
|IL.opLEC:
UnOp(r1);
Emit(opLEC, r1, param2)
|IL.opGTC:
UnOp(r1);
Emit(opGTC, r1, param2)
|IL.opGEC:
UnOp(r1);
Emit(opGEC, r1, param2)
|IL.opJNZ1:
UnOp(r1);
jnz(r1, param1)
|IL.opJG:
UnOp(r1);
Emit(opJGZ, r1, param1)
|IL.opJNZ:
UnOp(r1);
jnz(r1, param1);
drop
|IL.opJZ:
UnOp(r1);
Emit(opJZ, r1, param1);
drop
|IL.opMULS:
BinOp(r1, r2);
Emit(opAND, r1, r2);
drop
|IL.opMULSC:
UnOp(r1);
Emit(opANDC, r1, param2)
|IL.opDIVS:
BinOp(r1, r2);
Emit(opXOR, r1, r2);
drop
|IL.opDIVSC:
UnOp(r1);
Emit(opXORC, r1, param2)
|IL.opADDS:
BinOp(r1, r2);
Emit(opOR, r1, r2);
drop
|IL.opSUBS:
BinOp(r1, r2);
Emit(opNOT, r2, 0);
Emit(opAND, r1, r2);
drop
|IL.opADDSC:
UnOp(r1);
Emit(opORC, r1, param2)
|IL.opSUBSL:
UnOp(r1);
Emit(opNOT, r1, 0);
Emit(opANDC, r1, param2)
|IL.opSUBSR:
UnOp(r1);
Emit(opANDC, r1, ORD(-BITS(param2)))
|IL.opUMINS:
UnOp(r1);
Emit(opNOT, r1, 0)
|IL.opASR:
BinOp(r1, r2);
Emit(opASR, r1, r2);
drop
|IL.opLSL:
BinOp(r1, r2);
Emit(opLSL, r1, r2);
drop
|IL.opROR:
BinOp(r1, r2);
Emit(opROR, r1, r2);
drop
|IL.opLSR:
BinOp(r1, r2);
Emit(opLSR, r1, r2);
drop
|IL.opASR1:
r2 := GetAnyReg();
Emit(opMOVC, r2, param2);
BinOp(r1, r2);
Emit(opASR, r2, r1);
mov(r1, r2);
drop
|IL.opLSL1:
r2 := GetAnyReg();
Emit(opMOVC, r2, param2);
BinOp(r1, r2);
Emit(opLSL, r2, r1);
mov(r1, r2);
drop
|IL.opROR1:
r2 := GetAnyReg();
Emit(opMOVC, r2, param2);
BinOp(r1, r2);
Emit(opROR, r2, r1);
mov(r1, r2);
drop
|IL.opLSR1:
r2 := GetAnyReg();
Emit(opMOVC, r2, param2);
BinOp(r1, r2);
Emit(opLSR, r2, r1);
mov(r1, r2);
drop
|IL.opASR2:
UnOp(r1);
Emit(opASRC, r1, param2 MOD 32)
|IL.opLSL2:
UnOp(r1);
Emit(opLSLC, r1, param2 MOD 32)
|IL.opROR2:
UnOp(r1);
Emit(opRORC, r1, param2 MOD 32)
|IL.opLSR2:
UnOp(r1);
Emit(opLSRC, r1, param2 MOD 32)
|IL.opCHR:
UnOp(r1);
Emit(opANDC, r1, 255)
|IL.opWCHR:
UnOp(r1);
Emit(opANDC, r1, 65535)
|IL.opABS:
UnOp(r1);
Emit(opABS, r1, 0)
|IL.opLEN:
UnOp(r1);
drop;
EXCL(R.regs, r1);
WHILE param2 > 0 DO
UnOp(r2);
drop;
DEC(param2)
END;
INCL(R.regs, r1);
ASSERT(REG.GetReg(R, r1))
|IL.opSWITCH:
UnOp(r1);
IF param2 = 0 THEN
r2 := ACC
ELSE
r2 := R1
END;
IF r1 # r2 THEN
ASSERT(REG.GetReg(R, r2));
ASSERT(REG.Exchange(R, r1, r2));
drop
END;
drop
|IL.opENDSW:
|IL.opCASEL:
GetAcc;
Emit(opJLA, param1, param2);
drop
|IL.opCASER:
GetAcc;
Emit(opJGA, param1, param2);
drop
|IL.opCASELR:
GetAcc;
Emit(opJLA, param1, param2);
Emit(opJGA, param1, cmd.param3);
drop
|IL.opSBOOL:
BinOp(r2, r1);
Emit(opNEC, r2, 0);
str8(r1, r2);
drop;
drop
|IL.opSBOOLC:
UnOp(r1);
Emit(opSTR8C, r1, ORD(param2 # 0));
drop
|IL.opINCC:
UnOp(r1);
r2 := GetAnyReg();
ldr32(r2, r1);
addrc(r2, param2);
str32(r1, r2);
drop;
drop
|IL.opINCCB, IL.opDECCB:
IF opcode = IL.opDECCB THEN
param2 := -param2
END;
UnOp(r1);
r2 := GetAnyReg();
ldr8(r2, r1);
addrc(r2, param2);
str8(r1, r2);
drop;
drop
|IL.opINCB, IL.opDECB:
BinOp(r2, r1);
r3 := GetAnyReg();
ldr8(r3, r1);
IF opcode = IL.opINCB THEN
add(r3, r2)
ELSE
sub(r3, r2)
END;
str8(r1, r3);
drop;
drop;
drop
|IL.opINC, IL.opDEC:
BinOp(r2, r1);
r3 := GetAnyReg();
ldr32(r3, r1);
IF opcode = IL.opINC THEN
add(r3, r2)
ELSE
sub(r3, r2)
END;
str32(r1, r3);
drop;
drop;
drop
|IL.opINCL, IL.opEXCL:
BinOp(r2, r1);
IF opcode = IL.opINCL THEN
Emit(opINCL, r1, r2)
ELSE
Emit(opEXCL, r1, r2)
END;
drop;
drop
|IL.opINCLC, IL.opEXCLC:
UnOp(r1);
r2 := GetAnyReg();
ldr32(r2, r1);
IF opcode = IL.opINCLC THEN
Emit(opINCLC, r2, param2)
ELSE
Emit(opEXCLC, r2, param2)
END;
str32(r1, r2);
drop;
drop
|IL.opEQB, IL.opNEB:
BinOp(r1, r2);
Emit(opNEC, r1, 0);
Emit(opNEC, r2, 0);
IF opcode = IL.opEQB THEN
Emit(opEQ, r1, r2)
ELSE
Emit(opNE, r1, r2)
END;
drop
|IL.opCHKBYTE:
BinOp(r1, r2);
r3 := GetAnyReg();
mov(r3, r1);
Emit(opBTC, r3, 256);
jnz(r3, param1);
drop
|IL.opCHKIDX:
UnOp(r1);
r2 := GetAnyReg();
mov(r2, r1);
Emit(opBTC, r2, param2);
jnz(r2, param1);
drop
|IL.opCHKIDX2:
BinOp(r1, r2);
IF param2 # -1 THEN
r3 := GetAnyReg();
mov(r3, r2);
Emit(opBT, r3, r1);
jnz(r3, param1);
drop
END;
INCL(R.regs, r1);
DEC(R.top);
R.stk[R.top] := r2
|IL.opEQP, IL.opNEP:
ProcAdr(GetAnyReg(), param1);
BinOp(r1, r2);
IF opcode = IL.opEQP THEN
Emit(opEQ, r1, r2)
ELSE
Emit(opNE, r1, r2)
END;
drop
|IL.opSAVEP:
UnOp(r1);
r2 := GetAnyReg();
ProcAdr(r2, param2);
str32(r1, r2);
drop;
drop
|IL.opPUSHP:
ProcAdr(GetAnyReg(), param2)
|IL.opPUSHT:
UnOp(r1);
r2 := GetAnyReg();
mov(r2, r1);
subrc(r2, 4);
ldr32(r2, r2)
|IL.opGET, IL.opGETC:
IF opcode = IL.opGET THEN
BinOp(r1, r2)
ELSIF opcode = IL.opGETC THEN
UnOp(r2);
r1 := GetAnyReg();
movrc(r1, param1)
END;
drop;
drop;
CASE param2 OF
|1: ldr8(r1, r1); str8(r2, r1)
|2: ldr16(r1, r1); str16(r2, r1)
|4: ldr32(r1, r1); str32(r2, r1)
END
|IL.opNOT:
UnOp(r1);
Emit(opEQC, r1, 0)
|IL.opORD:
UnOp(r1);
Emit(opNEC, r1, 0)
|IL.opMIN:
BinOp(r1, r2);
Emit(opMIN, r1, r2);
drop
|IL.opMAX:
BinOp(r1, r2);
Emit(opMAX, r1, r2);
drop
|IL.opMINC:
UnOp(r1);
Emit(opMINC, r1, param2)
|IL.opMAXC:
UnOp(r1);
Emit(opMAXC, r1, param2)
|IL.opIN:
BinOp(r1, r2);
Emit(opIN, r1, r2);
drop
|IL.opINL:
r1 := GetAnyReg();
movrc(r1, param2);
BinOp(r2, r1);
Emit(opIN, r1, r2);
mov(r2, r1);
drop
|IL.opINR:
UnOp(r1);
Emit(opINC, r1, param2)
|IL.opERR:
CallRTL(IL._error, 4)
|IL.opEQS .. IL.opGES:
PushAll(4);
pushc(opcode - IL.opEQS);
CallRTL(IL._strcmp, 5);
GetAcc
|IL.opEQSW .. IL.opGESW:
PushAll(4);
pushc(opcode - IL.opEQSW);
CallRTL(IL._strcmpw, 5);
GetAcc
|IL.opCOPY:
PushAll(2);
pushc(param2);
CallRTL(IL._move, 3)
|IL.opMOVE:
PushAll(3);
CallRTL(IL._move, 3)
|IL.opCOPYA:
PushAll(4);
pushc(param2);
CallRTL(IL._arrcpy, 5);
GetAcc
|IL.opCOPYS:
PushAll(4);
pushc(param2);
CallRTL(IL._strcpy, 5)
|IL.opROT:
PushAll(0);
mov(ACC, SP);
push(ACC);
pushc(param2);
CallRTL(IL._rot, 2)
|IL.opLENGTH:
PushAll(2);
CallRTL(IL._length, 2);
GetAcc
|IL.opLENGTHW:
PushAll(2);
CallRTL(IL._lengthw, 2);
GetAcc
|IL.opSAVES:
UnOp(r2);
REG.PushAll_1(R);
r1 := GetAnyReg();
StrAdr(r1, param2);
push(r1);
drop;
push(r2);
drop;
pushc(param1);
CallRTL(IL._move, 3)
|IL.opRSET:
PushAll(2);
CallRTL(IL._set, 2);
GetAcc
|IL.opRSETR:
PushAll(1);
pushc(param2);
CallRTL(IL._set, 2);
GetAcc
|IL.opRSETL:
UnOp(r1);
REG.PushAll_1(R);
pushc(param2);
push(r1);
drop;
CallRTL(IL._set, 2);
GetAcc
|IL.opRSET1:
PushAll(1);
CallRTL(IL._set1, 1);
GetAcc
|IL.opNEW:
PushAll(1);
INC(param2, 8);
ASSERT(UTILS.Align(param2, 32));
pushc(param2);
pushc(param1);
CallRTL(IL._new, 3)
|IL.opTYPEGP:
UnOp(r1);
PushAll(0);
push(r1);
pushc(param2);
CallRTL(IL._guard, 2);
GetAcc
|IL.opIS:
PushAll(1);
pushc(param2);
CallRTL(IL._is, 2);
GetAcc
|IL.opISREC:
PushAll(2);
pushc(param2);
CallRTL(IL._guardrec, 3);
GetAcc
|IL.opTYPEGR:
PushAll(1);
pushc(param2);
CallRTL(IL._guardrec, 2);
GetAcc
|IL.opTYPEGD:
UnOp(r1);
PushAll(0);
subrc(r1, 4);
ldr32(r1, r1);
push(r1);
pushc(param2);
CallRTL(IL._guardrec, 2);
GetAcc
|IL.opCASET:
push(R1);
push(R1);
pushc(param2);
CallRTL(IL._guardrec, 2);
pop(R1);
jnz(ACC, param1)
|IL.opCONSTF:
movrc(GetAnyReg(), UTILS.d2s(cmd.float))
|IL.opMULF:
PushAll(2);
CallRTL(IL._fmul, 2);
GetAcc
|IL.opDIVF:
PushAll(2);
CallRTL(IL._fdiv, 2);
GetAcc
|IL.opDIVFI:
PushAll(2);
CallRTL(IL._fdivi, 2);
GetAcc
|IL.opADDF:
PushAll(2);
CallRTL(IL._fadd, 2);
GetAcc
|IL.opSUBFI:
PushAll(2);
CallRTL(IL._fsubi, 2);
GetAcc
|IL.opSUBF:
PushAll(2);
CallRTL(IL._fsub, 2);
GetAcc
|IL.opEQF..IL.opGEF:
PushAll(2);
pushc(opcode - IL.opEQF);
CallRTL(IL._fcmp, 3);
GetAcc
|IL.opFLOOR:
PushAll(1);
CallRTL(IL._floor, 1);
GetAcc
|IL.opFLT:
PushAll(1);
CallRTL(IL._flt, 1);
GetAcc
|IL.opUMINF:
UnOp(r1);
Emit(opXORC, r1, ORD({31}))
|IL.opFABS:
UnOp(r1);
Emit(opANDC, r1, ORD({0..30}))
|IL.opINF:
movrc(GetAnyReg(), inf)
|IL.opPUSHF:
UnOp(r1);
push(r1);
drop
|IL.opPACK:
PushAll(2);
CallRTL(IL._pack, 2)
|IL.opPACKC:
PushAll(1);
pushc(param2);
CallRTL(IL._pack, 2)
|IL.opUNPK:
PushAll(2);
CallRTL(IL._unpk, 2)
|IL.opCODE:
OutInt(param2)
END;
cmd := cmd.next(IL.COMMAND)
END;
ASSERT(R.pushed = 0);
ASSERT(R.top = -1)
END translate;
PROCEDURE prolog;
BEGIN
Emit(opLEA, SP + LStack * 256, 0);
Emit(opLEA, ACC + LTypes * 256, 0);
push(ACC);
Emit(opLEA, ACC + LHeap * 256, 0);
push(ACC);
pushc(CHL.Length(IL.codes.types));
CallRTL(IL._init, 3)
END prolog;
PROCEDURE epilog (ram: INTEGER);
VAR
tcount, dcount, i, offTypes, offStrings, szData, szGlobal, szHeapStack: INTEGER;
BEGIN
Emit(opSTOP, 0, 0);
offTypes := count;
tcount := CHL.Length(IL.codes.types);
FOR i := 0 TO tcount - 1 DO
OutInt(CHL.GetInt(IL.codes.types, i))
END;
offStrings := count;
dcount := CHL.Length(IL.codes.data);
FOR i := 0 TO dcount - 1 DO
OutByte(CHL.GetByte(IL.codes.data, i))
END;
IF dcount MOD 4 # 0 THEN
i := 4 - dcount MOD 4;
WHILE i > 0 DO
OutByte(0);
DEC(i)
END
END;
szData := count - offTypes;
szGlobal := (IL.codes.bss DIV 4 + 1) * 4;
szHeapStack := ram - szData - szGlobal;
OutInt(offTypes);
OutInt(offStrings);
OutInt(szGlobal DIV 4);
OutInt(szHeapStack DIV 4);
FOR i := 1 TO 8 DO
OutInt(0)
END
END epilog;
PROCEDURE CodeGen* (outname: ARRAY OF CHAR; target: INTEGER; options: PROG.OPTIONS);
CONST
minRAM = 32*1024;
maxRAM = 256*1024;
VAR
szData, szRAM: INTEGER;
BEGIN
szData := (CHL.Length(IL.codes.types) + CHL.Length(IL.codes.data) DIV 4 + IL.codes.bss DIV 4 + 2) * 4;
szRAM := MIN(MAX(options.ram, minRAM), maxRAM) * 1024;
IF szRAM - szData < 1024*1024 THEN
ERRORS.Error(208)
END;
count := 0;
WR.Create(outname);
REG.Init(R, push, pop, mov, xchg, NIL, NIL, GPRs, {});
prolog;
translate;
epilog(szRAM);
WR.Close
END CodeGen;
END RVM32I.

/programs/develop/oberon07/Source/SCAN.ob07
1,13 → 1,13
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
MODULE SCAN;
IMPORT TXT := TEXTDRV, AVL := AVLTREES, ARITH, S := STRINGS;
IMPORT TXT := TEXTDRV, AVL := AVLTREES, ARITH, S := STRINGS, ERRORS, LISTS;
CONST
48,6 → 48,12
LEXSTR* = ARRAY LEXLEN OF CHAR;
DEF = POINTER TO RECORD (LISTS.ITEM)
ident: LEXSTR
END;
IDENT* = POINTER TO RECORD (AVL.DATA)
s*: LEXSTR;
88,9 → 94,11
NewIdent: IDENT;
upto: BOOLEAN;
upto, LowerCase, _if: BOOLEAN;
def: LISTS.LIST;
PROCEDURE nodecmp (a, b: AVL.DATA): INTEGER;
RETURN ORD(a(IDENT).s > b(IDENT).s) - ORD(a(IDENT).s < b(IDENT).s)
END nodecmp;
166,7 → 174,7
VAR
c: CHAR;
hex: BOOLEAN;
error: INTEGER;
error, sym: INTEGER;
BEGIN
c := text.peak;
174,7 → 182,7
error := 0;
lex.sym := lxINTEGER;
sym := lxINTEGER;
hex := FALSE;
WHILE S.digit(c) DO
191,17 → 199,17
IF c = "H" THEN
putchar(lex, c);
TXT.next(text);
lex.sym := lxHEX
sym := lxHEX
ELSIF c = "X" THEN
putchar(lex, c);
TXT.next(text);
lex.sym := lxCHAR
sym := lxCHAR
ELSIF c = "." THEN
IF hex THEN
lex.sym := lxERROR01
sym := lxERROR01
ELSE
c := nextc(text);
208,9 → 216,9
IF c # "." THEN
putchar(lex, ".");
lex.sym := lxFLOAT
sym := lxFLOAT
ELSE
lex.sym := lxINTEGER;
sym := lxINTEGER;
text.peak := 7FX;
upto := TRUE
END;
235,7 → 243,7
c := nextc(text)
END
ELSE
lex.sym := lxERROR02
sym := lxERROR02
END
END
243,31 → 251,32
END
ELSIF hex THEN
lex.sym := lxERROR01
sym := lxERROR01
END;
IF lex.over & (lex.sym >= 0) THEN
lex.sym := lxERROR07
IF lex.over & (sym >= 0) THEN
sym := lxERROR07
END;
IF lex.sym = lxINTEGER THEN
IF sym = lxINTEGER THEN
ARITH.iconv(lex.s, lex.value, error)
ELSIF (lex.sym = lxHEX) OR (lex.sym = lxCHAR) THEN
ELSIF (sym = lxHEX) OR (sym = lxCHAR) THEN
ARITH.hconv(lex.s, lex.value, error)
ELSIF lex.sym = lxFLOAT THEN
ELSIF sym = lxFLOAT THEN
ARITH.fconv(lex.s, lex.value, error)
END;
CASE error OF
|0:
|1: lex.sym := lxERROR08
|2: lex.sym := lxERROR09
|3: lex.sym := lxERROR10
|4: lex.sym := lxERROR11
|5: lex.sym := lxERROR12
END
|1: sym := lxERROR08
|2: sym := lxERROR09
|3: sym := lxERROR10
|4: sym := lxERROR11
|5: sym := lxERROR12
END;
lex.sym := sym
END number;
349,6 → 358,9
PROCEDURE delimiter (text: TXT.TEXT; VAR lex: LEX; c: CHAR);
VAR
sym: INTEGER;
BEGIN
putchar(lex, c);
c := nextc(text);
355,19 → 367,19
CASE lex.s[0] OF
|"+":
lex.sym := lxPLUS
sym := lxPLUS
|"-":
lex.sym := lxMINUS
sym := lxMINUS
|"*":
lex.sym := lxMUL
sym := lxMUL
|"/":
lex.sym := lxSLASH;
sym := lxSLASH;
IF c = "/" THEN
lex.sym := lxCOMMENT;
sym := lxCOMMENT;
REPEAT
TXT.next(text)
UNTIL text.eol OR text.eof
374,91 → 386,93
END
|"~":
lex.sym := lxNOT
sym := lxNOT
|"&":
lex.sym := lxAND
sym := lxAND
|".":
lex.sym := lxPOINT;
sym := lxPOINT;
IF c = "." THEN
lex.sym := lxRANGE;
sym := lxRANGE;
putchar(lex, c);
TXT.next(text)
END
|",":
lex.sym := lxCOMMA
sym := lxCOMMA
|";":
lex.sym := lxSEMI
sym := lxSEMI
|"|":
lex.sym := lxBAR
sym := lxBAR
|"(":
lex.sym := lxLROUND;
sym := lxLROUND;
IF c = "*" THEN
lex.sym := lxCOMMENT;
sym := lxCOMMENT;
TXT.next(text);
comment(text)
END
|"[":
lex.sym := lxLSQUARE
sym := lxLSQUARE
|"{":
lex.sym := lxLCURLY
sym := lxLCURLY
|"^":
lex.sym := lxCARET
sym := lxCARET
|"=":
lex.sym := lxEQ
sym := lxEQ
|"#":
lex.sym := lxNE
sym := lxNE
|"<":
lex.sym := lxLT;
sym := lxLT;
IF c = "=" THEN
lex.sym := lxLE;
sym := lxLE;
putchar(lex, c);
TXT.next(text)
END
|">":
lex.sym := lxGT;
sym := lxGT;
IF c = "=" THEN
lex.sym := lxGE;
sym := lxGE;
putchar(lex, c);
TXT.next(text)
END
|":":
lex.sym := lxCOLON;
sym := lxCOLON;
IF c = "=" THEN
lex.sym := lxASSIGN;
sym := lxASSIGN;
putchar(lex, c);
TXT.next(text)
END
|")":
lex.sym := lxRROUND
sym := lxRROUND
|"]":
lex.sym := lxRSQUARE
sym := lxRSQUARE
|"}":
lex.sym := lxRCURLY
sym := lxRCURLY
END
END;
lex.sym := sym
END delimiter;
466,9 → 480,110
VAR
c: CHAR;
PROCEDURE check (cond: BOOLEAN; text: SCANNER; lex: LEX; errno: INTEGER);
BEGIN
IF ~cond THEN
ERRORS.ErrorMsg(text.fname, lex.pos.line, lex.pos.col, errno)
END
END check;
PROCEDURE IsDef (str: ARRAY OF CHAR): BOOLEAN;
VAR
cur: DEF;
BEGIN
cur := def.first(DEF);
WHILE (cur # NIL) & (cur.ident # str) DO
cur := cur.next(DEF)
END
RETURN cur # NIL
END IsDef;
PROCEDURE Skip (text: SCANNER);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i <= text.ifc) & ~text._skip[i] DO
INC(i)
END;
text.skip := i <= text.ifc
END Skip;
PROCEDURE prep_if (text: SCANNER; VAR lex: LEX);
VAR
skip: BOOLEAN;
BEGIN
INC(text.ifc);
text._elsif[text.ifc] := lex.sym = lxELSIF;
IF lex.sym = lxIF THEN
INC(text.elsec);
text._else[text.elsec] := FALSE
END;
_if := TRUE;
skip := TRUE;
text.skip := FALSE;
Next(text, lex);
check(lex.sym = lxLROUND, text, lex, 64);
Next(text, lex);
check(lex.sym = lxIDENT, text, lex, 22);
REPEAT
IF IsDef(lex.s) THEN
skip := FALSE
END;
Next(text, lex);
IF lex.sym = lxBAR THEN
Next(text, lex);
check(lex.sym = lxIDENT, text, lex, 22)
ELSE
check(lex.sym = lxRROUND, text, lex, 33)
END
UNTIL lex.sym = lxRROUND;
_if := FALSE;
text._skip[text.ifc] := skip;
Skip(text);
Next(text, lex)
END prep_if;
PROCEDURE prep_end (text: SCANNER; VAR lex: LEX);
BEGIN
check(text.ifc > 0, text, lex, 118);
IF lex.sym = lxEND THEN
WHILE text._elsif[text.ifc] DO
DEC(text.ifc)
END;
DEC(text.ifc);
DEC(text.elsec)
ELSIF (lex.sym = lxELSE) OR (lex.sym = lxELSIF) THEN
check(~text._else[text.elsec], text, lex, 118);
text._skip[text.ifc] := ~text._skip[text.ifc];
text._else[text.elsec] := lex.sym = lxELSE
END;
Skip(text);
IF lex.sym = lxELSIF THEN
prep_if(text, lex)
ELSE
Next(text, lex)
END
END prep_end;
BEGIN
REPEAT
c := text.peak;
WHILE S.space(c) DO
490,8 → 605,26
string(text, lex, c)
ELSIF delimiters[ORD(c)] THEN
delimiter(text, lex, c)
ELSIF c = "$" THEN
IF S.letter(nextc(text)) THEN
ident(text, lex);
IF lex.sym = lxIF THEN
IF ~_if THEN
prep_if(text, lex)
END
ELSIF (lex.sym = lxEND) OR (lex.sym = lxELSE) OR (lex.sym = lxELSIF) THEN
IF ~_if THEN
prep_end(text, lex)
END
ELSE
check(FALSE, text, lex, 119)
END
ELSE
check(FALSE, text, lex, 119)
END
ELSIF c = 0X THEN
lex.sym := lxEOF;
text.skip := FALSE;
IF text.eof THEN
INC(lex.pos.col)
END
514,7 → 647,7
lex.error := 0
END
UNTIL lex.sym # lxCOMMENT
UNTIL (lex.sym # lxCOMMENT) & ~text.skip
END Next;
530,7 → 663,7
END close;
PROCEDURE init;
PROCEDURE init* (lower: BOOLEAN);
VAR
i: INTEGER;
delim: ARRAY 23 OF CHAR;
539,15 → 672,23
PROCEDURE enterkw (key: INTEGER; kw: LEXSTR);
VAR
id: IDENT;
upper: LEXSTR;
BEGIN
IF LowerCase THEN
id := enterid(kw);
id.key := key
END;
upper := kw;
S.UpCase(upper);
id := enterid(upper);
id.key := key
END enterkw;
BEGIN
upto := FALSE;
LowerCase := lower;
FOR i := 0 TO 255 DO
delimiters[i] := FALSE
567,43 → 708,54
idents := NIL;
enterkw(lxARRAY, "ARRAY");
enterkw(lxBEGIN, "BEGIN");
enterkw(lxBY, "BY");
enterkw(lxCASE, "CASE");
enterkw(lxCONST, "CONST");
enterkw(lxDIV, "DIV");
enterkw(lxDO, "DO");
enterkw(lxELSE, "ELSE");
enterkw(lxELSIF, "ELSIF");
enterkw(lxEND, "END");
enterkw(lxFALSE, "FALSE");
enterkw(lxFOR, "FOR");
enterkw(lxIF, "IF");
enterkw(lxIMPORT, "IMPORT");
enterkw(lxIN, "IN");
enterkw(lxIS, "IS");
enterkw(lxMOD, "MOD");
enterkw(lxMODULE, "MODULE");
enterkw(lxNIL, "NIL");
enterkw(lxOF, "OF");
enterkw(lxOR, "OR");
enterkw(lxPOINTER, "POINTER");
enterkw(lxPROCEDURE, "PROCEDURE");
enterkw(lxRECORD, "RECORD");
enterkw(lxREPEAT, "REPEAT");
enterkw(lxRETURN, "RETURN");
enterkw(lxTHEN, "THEN");
enterkw(lxTO, "TO");
enterkw(lxTRUE, "TRUE");
enterkw(lxTYPE, "TYPE");
enterkw(lxUNTIL, "UNTIL");
enterkw(lxVAR, "VAR");
enterkw(lxWHILE, "WHILE")
enterkw(lxARRAY, "array");
enterkw(lxBEGIN, "begin");
enterkw(lxBY, "by");
enterkw(lxCASE, "case");
enterkw(lxCONST, "const");
enterkw(lxDIV, "div");
enterkw(lxDO, "do");
enterkw(lxELSE, "else");
enterkw(lxELSIF, "elsif");
enterkw(lxEND, "end");
enterkw(lxFALSE, "false");
enterkw(lxFOR, "for");
enterkw(lxIF, "if");
enterkw(lxIMPORT, "import");
enterkw(lxIN, "in");
enterkw(lxIS, "is");
enterkw(lxMOD, "mod");
enterkw(lxMODULE, "module");
enterkw(lxNIL, "nil");
enterkw(lxOF, "of");
enterkw(lxOR, "or");
enterkw(lxPOINTER, "pointer");
enterkw(lxPROCEDURE, "procedure");
enterkw(lxRECORD, "record");
enterkw(lxREPEAT, "repeat");
enterkw(lxRETURN, "return");
enterkw(lxTHEN, "then");
enterkw(lxTO, "to");
enterkw(lxTRUE, "true");
enterkw(lxTYPE, "type");
enterkw(lxUNTIL, "until");
enterkw(lxVAR, "var");
enterkw(lxWHILE, "while")
END init;
PROCEDURE NewDef* (str: ARRAY OF CHAR);
VAR
item: DEF;
BEGIN
init
NEW(item);
COPY(str, item.ident);
LISTS.push(def, item)
END NewDef;
BEGIN
def := LISTS.create(NIL)
END SCAN.

/programs/develop/oberon07/Source/STATEMENTS.ob07
9,7 → 9,7
IMPORT
PARS, PROG, SCAN, ARITH, STRINGS, LISTS, IL, X86, AMD64, MSP430, THUMB,
PARS, PROG, SCAN, ARITH, STRINGS, LISTS, IL, X86, AMD64, MSP430, THUMB, RVM32I,
ERRORS, UTILS, AVL := AVLTREES, CONSOLE, C := COLLECTIONS, TARGETS;
48,7 → 48,7
variant, self: INTEGER;
type: PROG.TYPE_;
_type: PROG._TYPE;
prev: CASE_LABEL
75,7 → 75,7
CPU: INTEGER;
tINTEGER, tBYTE, tCHAR, tWCHAR, tSET, tBOOLEAN, tREAL: PROG.TYPE_;
tINTEGER, tBYTE, tCHAR, tWCHAR, tSET, tBOOLEAN, tREAL: PROG._TYPE;
PROCEDURE isExpr (e: PARS.EXPR): BOOLEAN;
89,17 → 89,17
PROCEDURE isBoolean (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type = tBOOLEAN)
RETURN isExpr(e) & (e._type = tBOOLEAN)
END isBoolean;
PROCEDURE isInteger (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type = tINTEGER)
RETURN isExpr(e) & (e._type = tINTEGER)
END isInteger;
PROCEDURE isByte (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type = tBYTE)
RETURN isExpr(e) & (e._type = tBYTE)
END isByte;
109,42 → 109,42
PROCEDURE isReal (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type = tREAL)
RETURN isExpr(e) & (e._type = tREAL)
END isReal;
PROCEDURE isSet (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type = tSET)
RETURN isExpr(e) & (e._type = tSET)
END isSet;
PROCEDURE isString (e: PARS.EXPR): BOOLEAN;
RETURN (e.obj = eCONST) & (e.type.typ IN {PROG.tSTRING, PROG.tCHAR})
RETURN (e.obj = eCONST) & (e._type.typ IN {PROG.tSTRING, PROG.tCHAR})
END isString;
PROCEDURE isStringW (e: PARS.EXPR): BOOLEAN;
RETURN (e.obj = eCONST) & (e.type.typ IN {PROG.tSTRING, PROG.tCHAR, PROG.tWCHAR})
RETURN (e.obj = eCONST) & (e._type.typ IN {PROG.tSTRING, PROG.tCHAR, PROG.tWCHAR})
END isStringW;
PROCEDURE isChar (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type = tCHAR)
RETURN isExpr(e) & (e._type = tCHAR)
END isChar;
PROCEDURE isCharW (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type = tWCHAR)
RETURN isExpr(e) & (e._type = tWCHAR)
END isCharW;
PROCEDURE isPtr (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.tPOINTER)
RETURN isExpr(e) & (e._type.typ = PROG.tPOINTER)
END isPtr;
PROCEDURE isRec (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.tRECORD)
RETURN isExpr(e) & (e._type.typ = PROG.tRECORD)
END isRec;
154,27 → 154,27
PROCEDURE isArr (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.tARRAY)
RETURN isExpr(e) & (e._type.typ = PROG.tARRAY)
END isArr;
PROCEDURE isProc (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e.type.typ = PROG.tPROCEDURE) OR (e.obj IN {ePROC, eIMP})
RETURN isExpr(e) & (e._type.typ = PROG.tPROCEDURE) OR (e.obj IN {ePROC, eIMP})
END isProc;
PROCEDURE isNil (e: PARS.EXPR): BOOLEAN;
RETURN e.type.typ = PROG.tNIL
RETURN e._type.typ = PROG.tNIL
END isNil;
PROCEDURE isCharArray (e: PARS.EXPR): BOOLEAN;
RETURN isArr(e) & (e.type.base = tCHAR)
RETURN isArr(e) & (e._type.base = tCHAR)
END isCharArray;
PROCEDURE isCharArrayW (e: PARS.EXPR): BOOLEAN;
RETURN isArr(e) & (e.type.base = tWCHAR)
RETURN isArr(e) & (e._type.base = tWCHAR)
END isCharArrayW;
204,7 → 204,7
BEGIN
ASSERT(isString(e));
IF e.type = tCHAR THEN
IF e._type = tCHAR THEN
res := 1
ELSE
res := LENGTH(e.value.string(SCAN.IDENT).s)
237,7 → 237,7
BEGIN
ASSERT(isStringW(e));
IF e.type.typ IN {PROG.tCHAR, PROG.tWCHAR} THEN
IF e._type.typ IN {PROG.tCHAR, PROG.tWCHAR} THEN
res := 1
ELSE
res := _length(e.value.string(SCAN.IDENT).s)
257,11 → 257,11
PROCEDURE isStringW1 (e: PARS.EXPR): BOOLEAN;
RETURN (e.obj = eCONST) & isString(e) & (utf8strlen(e) = 1) & (strlen(e) > 1)
RETURN isString(e) & (utf8strlen(e) = 1) & (strlen(e) > 1)
END isStringW1;
PROCEDURE assigncomp (e: PARS.EXPR; t: PROG.TYPE_): BOOLEAN;
PROCEDURE assigncomp (e: PARS.EXPR; t: PROG._TYPE): BOOLEAN;
VAR
res: BOOLEAN;
268,7 → 268,7
BEGIN
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN
IF t = e.type THEN
IF t = e._type THEN
res := TRUE
ELSIF isInt(e) & (t.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN
IF (e.obj = eCONST) & (t = tBYTE) THEN
279,10 → 279,10
ELSIF
(e.obj = eCONST) & isChar(e) & (t = tWCHAR)
OR isStringW1(e) & (t = tWCHAR)
OR PROG.isBaseOf(t, e.type)
OR ~PROG.isOpenArray(t) & ~PROG.isOpenArray(e.type) & PROG.isTypeEq(t, e.type)
OR PROG.isBaseOf(t, e._type)
OR ~PROG.isOpenArray(t) & ~PROG.isOpenArray(e._type) & PROG.isTypeEq(t, e._type)
OR isNil(e) & (t.typ IN {PROG.tPOINTER, PROG.tPROCEDURE})
OR PROG.arrcomp(e.type, t)
OR PROG.arrcomp(e._type, t)
OR isString(e) & (t.typ = PROG.tARRAY) & (t.base = tCHAR) & (t.length > strlen(e))
OR isStringW(e) & (t.typ = PROG.tARRAY) & (t.base = tWCHAR) & (t.length > utf8strlen(e))
THEN
331,9 → 331,9
END;
offset := string.offsetW
ELSE
IF e.type.typ IN {PROG.tWCHAR, PROG.tCHAR} THEN
IF e._type.typ IN {PROG.tWCHAR, PROG.tCHAR} THEN
offset := IL.putstrW1(ARITH.Int(e.value))
ELSE (* e.type.typ = PROG.tSTRING *)
ELSE (* e._type.typ = PROG.tSTRING *)
string := e.value.string(SCAN.IDENT);
IF string.offsetW = -1 THEN
string.offsetW := IL.putstrW(string.s);
358,8 → 358,18
END CheckRange;
PROCEDURE assign (e: PARS.EXPR; VarType: PROG.TYPE_; line: INTEGER): BOOLEAN;
PROCEDURE Float (parser: PARS.PARSER; e: PARS.EXPR);
VAR
pos: PARS.POSITION;
BEGIN
getpos(parser, pos);
IL.Float(ARITH.Float(e.value), pos.line, pos.col)
END Float;
PROCEDURE assign (parser: PARS.PARSER; e: PARS.EXPR; VarType: PROG._TYPE; line: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
label: INTEGER;
366,7 → 376,7
BEGIN
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN
res := TRUE;
IF PROG.arrcomp(e.type, VarType) THEN
IF PROG.arrcomp(e._type, VarType) THEN
IF ~PROG.isOpenArray(VarType) THEN
IL.Const(VarType.length)
373,7 → 383,7
END;
IL.AddCmd(IL.opCOPYA, VarType.base.size);
label := IL.NewLabel();
IL.AddJmpCmd(IL.opJE, label);
IL.AddJmpCmd(IL.opJNZ, label);
IL.OnError(line, errCOPY);
IL.SetLabel(label)
414,7 → 424,7
END
ELSIF isReal(e) & (VarType = tREAL) THEN
IF e.obj = eCONST THEN
IL.Float(ARITH.Float(e.value))
Float(parser, e)
END;
IL.savef(e.obj = eCONST)
ELSIF isChar(e) & (VarType = tCHAR) THEN
433,19 → 443,19
ELSE
IL.AddCmd0(IL.opSAVE16)
END
ELSIF PROG.isBaseOf(VarType, e.type) THEN
ELSIF PROG.isBaseOf(VarType, e._type) THEN
IF VarType.typ = PROG.tPOINTER THEN
IL.AddCmd0(IL.opSAVE)
ELSE
IL.AddCmd(IL.opCOPY, VarType.size)
END
ELSIF (e.type.typ = PROG.tCARD32) & (VarType.typ = PROG.tCARD32) THEN
ELSIF (e._type.typ = PROG.tCARD32) & (VarType.typ = PROG.tCARD32) THEN
IL.AddCmd0(IL.opSAVE32)
ELSIF ~PROG.isOpenArray(VarType) & ~PROG.isOpenArray(e.type) & PROG.isTypeEq(VarType, e.type) THEN
ELSIF ~PROG.isOpenArray(VarType) & ~PROG.isOpenArray(e._type) & PROG.isTypeEq(VarType, e._type) THEN
IF e.obj = ePROC THEN
IL.AssignProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
IL.AssignImpProc(e.ident.import)
IL.AssignImpProc(e.ident._import)
ELSE
IF VarType.typ = PROG.tPROCEDURE THEN
IL.AddCmd0(IL.opSAVE)
481,11 → 491,11
PROCEDURE arrcomp (e: PARS.EXPR; p: PROG.PARAM): BOOLEAN;
VAR
t1, t2: PROG.TYPE_;
t1, t2: PROG._TYPE;
BEGIN
t1 := p.type;
t2 := e.type;
t1 := p._type;
t2 := e._type;
WHILE (t2.typ = PROG.tARRAY) & PROG.isOpenArray(t1) DO
t1 := t1.base;
t2 := t2.base
495,7 → 505,7
END arrcomp;
PROCEDURE ArrLen (t: PROG.TYPE_; n: INTEGER): INTEGER;
PROCEDURE ArrLen (t: PROG._TYPE; n: INTEGER): INTEGER;
VAR
res: INTEGER;
510,7 → 520,7
END ArrLen;
PROCEDURE OpenArray (t, t2: PROG.TYPE_);
PROCEDURE OpenArray (t, t2: PROG._TYPE);
VAR
n, d1, d2: INTEGER;
547,8 → 557,8
IF p.vPar THEN
PARS.check(isVar(e), pos, 93);
IF p.type.typ = PROG.tRECORD THEN
PARS.check(PROG.isBaseOf(p.type, e.type), pos, 66);
IF p._type.typ = PROG.tRECORD THEN
PARS.check(PROG.isBaseOf(p._type, e._type), pos, 66);
IF e.obj = eVREC THEN
IF e.ident # NIL THEN
IL.AddCmd(IL.opVADR, e.ident.offset - 1)
556,14 → 566,14
IL.AddCmd0(IL.opPUSHT)
END
ELSE
IL.Const(e.type.num)
IL.Const(e._type.num)
END;
IL.AddCmd(IL.opPARAM, 2)
ELSIF PROG.isOpenArray(p.type) THEN
ELSIF PROG.isOpenArray(p._type) THEN
PARS.check(arrcomp(e, p), pos, 66);
OpenArray(e.type, p.type)
OpenArray(e._type, p._type)
ELSE
PARS.check(PROG.isTypeEq(e.type, p.type), pos, 66);
PARS.check(PROG.isTypeEq(e._type, p._type), pos, 66);
IL.Param1
END;
PARS.check(~e.readOnly, pos, 94)
570,16 → 580,16
ELSE
PARS.check(isExpr(e) OR isProc(e), pos, 66);
IF PROG.isOpenArray(p.type) THEN
IF e.type.typ = PROG.tARRAY THEN
IF PROG.isOpenArray(p._type) THEN
IF e._type.typ = PROG.tARRAY THEN
PARS.check(arrcomp(e, p), pos, 66);
OpenArray(e.type, p.type)
ELSIF isString(e) & (p.type.typ = PROG.tARRAY) & (p.type.base = tCHAR) THEN
OpenArray(e._type, p._type)
ELSIF isString(e) & (p._type.typ = PROG.tARRAY) & (p._type.base = tCHAR) THEN
IL.StrAdr(String(e));
IL.Param1;
IL.Const(strlen(e) + 1);
IL.Param1
ELSIF isStringW(e) & (p.type.typ = PROG.tARRAY) & (p.type.base = tWCHAR) THEN
ELSIF isStringW(e) & (p._type.typ = PROG.tARRAY) & (p._type.base = tWCHAR) THEN
IL.StrAdr(StringW(e));
IL.Param1;
IL.Const(utf8strlen(e) + 1);
588,24 → 598,24
PARS.error(pos, 66)
END
ELSE
PARS.check(~PROG.isOpenArray(e.type), pos, 66);
PARS.check(assigncomp(e, p.type), pos, 66);
PARS.check(~PROG.isOpenArray(e._type), pos, 66);
PARS.check(assigncomp(e, p._type), pos, 66);
IF e.obj = eCONST THEN
IF e.type = tREAL THEN
IL.Float(ARITH.Float(e.value));
IL.pushf
ELSIF e.type.typ = PROG.tNIL THEN
IF e._type = tREAL THEN
Float(parser, e);
IL.AddCmd0(IL.opPUSHF)
ELSIF e._type.typ = PROG.tNIL THEN
IL.Const(0);
IL.Param1
ELSIF isStringW1(e) & (p.type = tWCHAR) THEN
ELSIF isStringW1(e) & (p._type = tWCHAR) THEN
IL.Const(StrToWChar(e.value.string(SCAN.IDENT).s));
IL.Param1
ELSIF (e.type.typ = PROG.tSTRING) OR
(e.type.typ IN {PROG.tCHAR, PROG.tWCHAR}) & (p.type.typ = PROG.tARRAY) & (p.type.base.typ IN {PROG.tCHAR, PROG.tWCHAR}) THEN
IF p.type.base = tCHAR THEN
ELSIF (e._type.typ = PROG.tSTRING) OR
(e._type.typ IN {PROG.tCHAR, PROG.tWCHAR}) & (p._type.typ = PROG.tARRAY) & (p._type.base.typ IN {PROG.tCHAR, PROG.tWCHAR}) THEN
IF p._type.base = tCHAR THEN
stroffs := String(e);
IL.StrAdr(stroffs);
IF (CPU = TARGETS.cpuMSP430) & (p.type.size - strlen(e) - 1 > MSP430.IntVectorSize) THEN
IF (CPU = TARGETS.cpuMSP430) & (p._type.size - strlen(e) - 1 > MSP430.IntVectorSize) THEN
ERRORS.WarningMsg(pos.line, pos.col, 0)
END
ELSE (* WCHAR *)
612,7 → 622,7
stroffs := StringW(e);
IL.StrAdr(stroffs)
END;
IL.set_dmin(stroffs + p.type.size);
IL.set_dmin(stroffs + p._type.size);
IL.Param1
ELSE
LoadConst(e);
623,12 → 633,12
IL.PushProc(e.ident.proc.label);
IL.Param1
ELSIF e.obj = eIMP THEN
IL.PushImpProc(e.ident.import);
IL.PushImpProc(e.ident._import);
IL.Param1
ELSIF isExpr(e) & (e.type = tREAL) THEN
IL.pushf
ELSIF isExpr(e) & (e._type = tREAL) THEN
IL.AddCmd0(IL.opPUSHF)
ELSE
IF (p.type = tBYTE) & (e.type = tINTEGER) & (chkBYTE IN Options.checking) THEN
IF (p._type = tBYTE) & (e._type = tINTEGER) & (chkBYTE IN Options.checking) THEN
CheckRange(256, pos.line, errBYTE)
END;
IL.Param1
651,6 → 661,7
pos: PARS.POSITION;
proc,
label,
size,
n, i: INTEGER;
code: ARITH.VALUE;
wchar,
716,7 → 727,8
END
ELSE
label := IL.NewLabel();
IL.AddJmpCmd(IL.opJE, label);
IL.not;
IL.AndOrOpt(label);
IL.OnError(pos.line, errASSERT);
IL.SetLabel(label)
END
724,7 → 736,7
|PROG.stINC, PROG.stDEC:
IL.pushBegEnd(begcall, endcall);
varparam(parser, pos, isInt, TRUE, e);
IF e.type = tINTEGER THEN
IF e._type = tINTEGER THEN
IF parser.sym = SCAN.lxCOMMA THEN
NextPos(parser, pos);
IL.setlast(begcall);
739,7 → 751,7
ELSE
IL.AddCmd(IL.opINCC, ORD(proc = PROG.stINC) * 2 - 1)
END
ELSE (* e.type = tBYTE *)
ELSE (* e._type = tBYTE *)
IF parser.sym = SCAN.lxCOMMA THEN
NextPos(parser, pos);
IL.setlast(begcall);
777,9 → 789,9
|PROG.stNEW:
varparam(parser, pos, isPtr, TRUE, e);
IF CPU = TARGETS.cpuMSP430 THEN
PARS.check(e.type.base.size + 16 < Options.ram, pos, 63)
PARS.check(e._type.base.size + 16 < Options.ram, pos, 63)
END;
IL.New(e.type.base.size, e.type.base.num)
IL.New(e._type.base.size, e._type.base.num)
|PROG.stDISPOSE:
varparam(parser, pos, isPtr, TRUE, e);
815,8 → 827,8
PARS.error(pos, 66)
END;
IF isCharArrayX(e) & ~PROG.isOpenArray(e.type) THEN
IL.Const(e.type.length)
IF isCharArrayX(e) & ~PROG.isOpenArray(e._type) THEN
IL.Const(e._type.length)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
832,11 → 844,11
varparam(parser, pos, isCharArray, TRUE, e1)
END;
wchar := e1.type.base = tWCHAR
wchar := e1._type.base = tWCHAR
END;
IF ~PROG.isOpenArray(e1.type) THEN
IL.Const(e1.type.length)
IF ~PROG.isOpenArray(e1._type) THEN
IL.Const(e1._type.length)
END;
IL.setlast(endcall.prev(IL.COMMAND));
850,10 → 862,10
IL.Const(strlen(e) + 1)
END
END;
IL.AddCmd(IL.opCOPYS, e1.type.base.size);
IL.AddCmd(IL.opCOPYS, e1._type.base.size);
IL.popBegEnd(begcall, endcall)
|PROG.sysGET:
|PROG.sysGET, PROG.sysGET8, PROG.sysGET16, PROG.sysGET32:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
PARS.checklex(parser, SCAN.lxCOMMA);
860,11 → 872,25
NextPos(parser, pos);
parser.designator(parser, e2);
PARS.check(isVar(e2), pos, 93);
PARS.check(e2.type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66);
IF proc = PROG.sysGET THEN
PARS.check(e2._type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66)
ELSE
PARS.check(e2._type.typ IN {PROG.tINTEGER, PROG.tBYTE, PROG.tCHAR, PROG.tSET, PROG.tWCHAR, PROG.tCARD32}, pos, 66)
END;
CASE proc OF
|PROG.sysGET: size := e2._type.size
|PROG.sysGET8: size := 1
|PROG.sysGET16: size := 2
|PROG.sysGET32: size := 4
END;
PARS.check(size <= e2._type.size, pos, 66);
IF e.obj = eCONST THEN
IL.AddCmd2(IL.opGETC, ARITH.Int(e.value), e2.type.size)
IL.AddCmd2(IL.opGETC, ARITH.Int(e.value), size)
ELSE
IL.AddCmd(IL.opGET, e2.type.size)
IL.AddCmd(IL.opGET, size)
END
|PROG.sysPUT, PROG.sysPUT8, PROG.sysPUT16, PROG.sysPUT32:
881,39 → 907,40
PARS.check(isExpr(e2), pos, 66);
IF proc = PROG.sysPUT THEN
PARS.check(e2.type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66);
PARS.check(e2._type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66);
IF e2.obj = eCONST THEN
IF e2.type = tREAL THEN
IL.Float(ARITH.Float(e2.value));
IF e2._type = tREAL THEN
Float(parser, e2);
IL.setlast(endcall.prev(IL.COMMAND));
IL.savef(FALSE)
ELSE
LoadConst(e2);
IL.setlast(endcall.prev(IL.COMMAND));
IL.SysPut(e2.type.size)
IL.SysPut(e2._type.size)
END
ELSE
IL.setlast(endcall.prev(IL.COMMAND));
IF e2.type = tREAL THEN
IF e2._type = tREAL THEN
IL.savef(FALSE)
ELSIF e2.type = tBYTE THEN
ELSIF e2._type = tBYTE THEN
IL.SysPut(tINTEGER.size)
ELSE
IL.SysPut(e2.type.size)
IL.SysPut(e2._type.size)
END
END
ELSIF (proc = PROG.sysPUT8) OR (proc = PROG.sysPUT16) OR (proc = PROG.sysPUT32) THEN
PARS.check(e2.type.typ IN {PROG.tINTEGER, PROG.tBYTE, PROG.tCHAR, PROG.tSET, PROG.tWCHAR, PROG.tCARD32}, pos, 66);
PARS.check(e2._type.typ IN {PROG.tINTEGER, PROG.tBYTE, PROG.tCHAR, PROG.tSET, PROG.tWCHAR, PROG.tCARD32}, pos, 66);
IF e2.obj = eCONST THEN
LoadConst(e2)
END;
IL.setlast(endcall.prev(IL.COMMAND));
CASE proc OF
|PROG.sysPUT8: IL.SysPut(1)
|PROG.sysPUT16: IL.SysPut(2)
|PROG.sysPUT32: IL.SysPut(4)
END
|PROG.sysPUT8: size := 1
|PROG.sysPUT16: size := 2
|PROG.sysPUT32: size := 4
END;
IL.SysPut(size)
END;
IL.popBegEnd(begcall, endcall)
940,7 → 967,7
FOR i := 1 TO 2 DO
parser.designator(parser, e);
PARS.check(isVar(e), pos, 93);
n := PROG.Dim(e.type);
n := PROG.Dim(e._type);
WHILE n > 0 DO
IL.drop;
DEC(n)
961,10 → 988,11
getpos(parser, pos);
PARS.ConstExpression(parser, code);
PARS.check(code.typ = ARITH.tINTEGER, pos, 43);
IF CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
PARS.check(ARITH.range(code, 0, 255), pos, 42)
ELSIF CPU = TARGETS.cpuTHUMB THEN
PARS.check(ARITH.range(code, 0, 65535), pos, 110)
IF TARGETS.WordSize > TARGETS.InstrSize THEN
CASE TARGETS.InstrSize OF
|1: PARS.check(ARITH.range(code, 0, 255), pos, 42)
|2: PARS.check(ARITH.range(code, 0, 65535), pos, 110)
END
END;
IL.AddCmd(IL.opCODE, ARITH.getInt(code));
comma := parser.sym = SCAN.lxCOMMA;
991,7 → 1019,7
END;
e.obj := eEXPR;
e.type := NIL
e._type := NIL
ELSIF e.obj IN {eSTFUNC, eSYSFUNC} THEN
1012,7 → 1040,7
NextPos(parser, pos);
PExpression(parser, e2);
PARS.check(isInt(e2), pos, 66);
e.type := tINTEGER;
e._type := tINTEGER;
IF (e.obj = eCONST) & (e2.obj = eCONST) THEN
ASSERT(ARITH.opInt(e.value, e2.value, shift_minmax(proc)))
ELSE
1029,7 → 1057,7
|PROG.stCHR:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e.type := tCHAR;
e._type := tCHAR;
IF e.obj = eCONST THEN
ARITH.setChar(e.value, ARITH.getInt(e.value));
PARS.check(ARITH.check(e.value), pos, 107)
1044,7 → 1072,7
|PROG.stWCHR:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e.type := tWCHAR;
e._type := tWCHAR;
IF e.obj = eCONST THEN
ARITH.setWChar(e.value, ARITH.getInt(e.value));
PARS.check(ARITH.check(e.value), pos, 101)
1059,58 → 1087,58
|PROG.stFLOOR:
PExpression(parser, e);
PARS.check(isReal(e), pos, 66);
e.type := tINTEGER;
e._type := tINTEGER;
IF e.obj = eCONST THEN
PARS.check(ARITH.floor(e.value), pos, 39)
ELSE
IL.floor
IL.AddCmd0(IL.opFLOOR)
END
|PROG.stFLT:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e.type := tREAL;
e._type := tREAL;
IF e.obj = eCONST THEN
ARITH.flt(e.value)
ELSE
PARS.check(IL.flt(), pos, 41)
IL.AddCmd2(IL.opFLT, pos.line, pos.col)
END
|PROG.stLEN:
cmd1 := IL.getlast();
varparam(parser, pos, isArr, FALSE, e);
IF e.type.length > 0 THEN
IF e._type.length > 0 THEN
cmd2 := IL.getlast();
IL.delete2(cmd1.next, cmd2);
IL.setlast(cmd1);
ASSERT(ARITH.setInt(e.value, e.type.length));
ASSERT(ARITH.setInt(e.value, e._type.length));
e.obj := eCONST
ELSE
IL.len(PROG.Dim(e.type))
IL.len(PROG.Dim(e._type))
END;
e.type := tINTEGER
e._type := tINTEGER
|PROG.stLENGTH:
PExpression(parser, e);
IF isCharArray(e) THEN
IF e.type.length > 0 THEN
IL.Const(e.type.length)
IF e._type.length > 0 THEN
IL.Const(e._type.length)
END;
IL.AddCmd0(IL.opLENGTH)
ELSIF isCharArrayW(e) THEN
IF e.type.length > 0 THEN
IL.Const(e.type.length)
IF e._type.length > 0 THEN
IL.Const(e._type.length)
END;
IL.AddCmd0(IL.opLENGTHW)
ELSE
PARS.error(pos, 66);
END;
e.type := tINTEGER
e._type := tINTEGER
|PROG.stODD:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e.type := tBOOLEAN;
e._type := tBOOLEAN;
IF e.obj = eCONST THEN
ARITH.odd(e.value)
ELSE
1128,10 → 1156,10
END
ELSE
IF isBoolean(e) THEN
IL.AddCmd0(IL.opORD)
IL._ord
END
END;
e.type := tINTEGER
e._type := tINTEGER
|PROG.stBITS:
PExpression(parser, e);
1139,12 → 1167,12
IF e.obj = eCONST THEN
ARITH.bits(e.value)
END;
e.type := tSET
e._type := tSET
|PROG.sysADR:
parser.designator(parser, e);
IF isVar(e) THEN
n := PROG.Dim(e.type);
n := PROG.Dim(e._type);
WHILE n > 0 DO
IL.drop;
DEC(n)
1152,17 → 1180,17
ELSIF e.obj = ePROC THEN
IL.PushProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
IL.PushImpProc(e.ident.import)
IL.PushImpProc(e.ident._import)
ELSE
PARS.error(pos, 108)
END;
e.type := tINTEGER
e._type := tINTEGER
|PROG.sysSADR:
PExpression(parser, e);
PARS.check(isString(e), pos, 66);
IL.StrAdr(String(e));
e.type := tINTEGER;
e._type := tINTEGER;
e.obj := eEXPR
|PROG.sysWSADR:
1169,33 → 1197,33
PExpression(parser, e);
PARS.check(isStringW(e), pos, 66);
IL.StrAdr(StringW(e));
e.type := tINTEGER;
e._type := tINTEGER;
e.obj := eEXPR
|PROG.sysTYPEID:
PExpression(parser, e);
PARS.check(e.obj = eTYPE, pos, 68);
IF e.type.typ = PROG.tRECORD THEN
ASSERT(ARITH.setInt(e.value, e.type.num))
ELSIF e.type.typ = PROG.tPOINTER THEN
ASSERT(ARITH.setInt(e.value, e.type.base.num))
IF e._type.typ = PROG.tRECORD THEN
ASSERT(ARITH.setInt(e.value, e._type.num))
ELSIF e._type.typ = PROG.tPOINTER THEN
ASSERT(ARITH.setInt(e.value, e._type.base.num))
ELSE
PARS.error(pos, 52)
END;
e.obj := eCONST;
e.type := tINTEGER
e._type := tINTEGER
|PROG.sysINF:
PARS.check(IL.inf(), pos, 41);
IL.AddCmd2(IL.opINF, pos.line, pos.col);
e.obj := eEXPR;
e.type := tREAL
e._type := tREAL
|PROG.sysSIZE:
PExpression(parser, e);
PARS.check(e.obj = eTYPE, pos, 68);
ASSERT(ARITH.setInt(e.value, e.type.size));
ASSERT(ARITH.setInt(e.value, e._type.size));
e.obj := eCONST;
e.type := tINTEGER
e._type := tINTEGER
END
1215,7 → 1243,7
PROCEDURE ActualParameters (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
proc: PROG.TYPE_;
proc: PROG._TYPE;
param: LISTS.ITEM;
e1: PARS.EXPR;
pos: PARS.POSITION;
1224,7 → 1252,7
ASSERT(parser.sym = SCAN.lxLROUND);
IF (e.obj IN {ePROC, eIMP}) OR isExpr(e) THEN
proc := e.type;
proc := e._type;
PARS.check1(proc.typ = PROG.tPROCEDURE, parser, 86);
PARS.Next(parser);
1251,7 → 1279,7
PARS.Next(parser);
e.obj := eEXPR;
e.type := proc.base
e._type := proc.base
ELSIF e.obj IN {eSTPROC, eSTFUNC, eSYSPROC, eSYSFUNC} THEN
stProc(parser, e)
1265,13 → 1293,13
PROCEDURE qualident (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
ident: PROG.IDENT;
import: BOOLEAN;
imp: BOOLEAN;
pos: PARS.POSITION;
BEGIN
PARS.checklex(parser, SCAN.lxIDENT);
getpos(parser, pos);
import := FALSE;
imp := FALSE;
ident := PROG.getIdent(parser.unit, parser.lex.ident, FALSE);
PARS.check1(ident # NIL, parser, 48);
IF ident.typ = PROG.idMODULE THEN
1279,7 → 1307,7
PARS.ExpectSym(parser, SCAN.lxIDENT);
ident := PROG.getIdent(ident.unit, parser.lex.ident, FALSE);
PARS.check1((ident # NIL) & ident.export, parser, 48);
import := TRUE
imp := TRUE
END;
PARS.Next(parser);
1289,24 → 1317,24
CASE ident.typ OF
|PROG.idCONST:
e.obj := eCONST;
e.type := ident.type;
e._type := ident._type;
e.value := ident.value
|PROG.idTYPE:
e.obj := eTYPE;
e.type := ident.type
e._type := ident._type
|PROG.idVAR:
e.obj := eVAR;
e.type := ident.type;
e.readOnly := import
e._type := ident._type;
e.readOnly := imp
|PROG.idPROC:
e.obj := ePROC;
e.type := ident.type
e._type := ident._type
|PROG.idIMP:
e.obj := eIMP;
e.type := ident.type
e._type := ident._type
|PROG.idVPAR:
e.type := ident.type;
IF e.type.typ = PROG.tRECORD THEN
e._type := ident._type;
IF e._type.typ = PROG.tRECORD THEN
e.obj := eVREC
ELSE
e.obj := eVPAR
1313,20 → 1341,24
END
|PROG.idPARAM:
e.obj := ePARAM;
e.type := ident.type;
e.readOnly := (e.type.typ IN {PROG.tRECORD, PROG.tARRAY})
e._type := ident._type;
e.readOnly := (e._type.typ IN {PROG.tRECORD, PROG.tARRAY})
|PROG.idSTPROC:
e.obj := eSTPROC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idSTFUNC:
e.obj := eSTFUNC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idSYSPROC:
e.obj := eSYSPROC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idSYSFUNC:
PARS.check(~parser.constexp, pos, 109);
e.obj := eSYSFUNC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idNONE:
PARS.error(pos, 115)
1345,12 → 1377,12
BEGIN
IF load THEN
IL.load(e.type.size)
IL.load(e._type.size)
END;
IF chkPTR IN Options.checking THEN
label := IL.NewLabel();
IL.AddJmpCmd(IL.opJNZ, label);
IL.AddJmpCmd(IL.opJNZ1, label);
IL.OnError(pos.line, error);
IL.SetLabel(label)
END
1373,7 → 1405,7
offset, n: INTEGER;
BEGIN
offset := e.ident.offset;
n := PROG.Dim(e.type);
n := PROG.Dim(e._type);
WHILE n >= 0 DO
IL.AddCmd(IL.opVADR, offset);
DEC(offset);
1384,7 → 1416,7
BEGIN
IF e.obj = eVAR THEN
offset := PROG.getOffset(PARS.program, e.ident);
offset := PROG.getOffset(e.ident);
IF e.ident.global THEN
IL.AddCmd(IL.opGADR, offset)
ELSE
1391,15 → 1423,15
IL.AddCmd(IL.opLADR, -offset)
END
ELSIF e.obj = ePARAM THEN
IF (e.type.typ = PROG.tRECORD) OR ((e.type.typ = PROG.tARRAY) & (e.type.length > 0)) THEN
IF (e._type.typ = PROG.tRECORD) OR ((e._type.typ = PROG.tARRAY) & (e._type.length > 0)) THEN
IL.AddCmd(IL.opVADR, e.ident.offset)
ELSIF PROG.isOpenArray(e.type) THEN
ELSIF PROG.isOpenArray(e._type) THEN
OpenArray(e)
ELSE
IL.AddCmd(IL.opLADR, e.ident.offset)
END
ELSIF e.obj IN {eVPAR, eVREC} THEN
IF PROG.isOpenArray(e.type) THEN
IF PROG.isOpenArray(e._type) THEN
OpenArray(e)
ELSE
IL.AddCmd(IL.opVADR, e.ident.offset)
1411,7 → 1443,7
PROCEDURE OpenIdx (parser: PARS.PARSER; pos: PARS.POSITION; e: PARS.EXPR);
VAR
label, offset, n, k: INTEGER;
type: PROG.TYPE_;
_type: PROG._TYPE;
BEGIN
1424,11 → 1456,11
IL.AddCmd(IL.opCHKIDX2, -1)
END;
type := PROG.OpenBase(e.type);
IF type.size # 1 THEN
IL.AddCmd(IL.opMULC, type.size)
_type := PROG.OpenBase(e._type);
IF _type.size # 1 THEN
IL.AddCmd(IL.opMULC, _type.size)
END;
n := PROG.Dim(e.type) - 1;
n := PROG.Dim(e._type) - 1;
k := n;
WHILE n > 0 DO
IL.AddCmd0(IL.opMUL);
1458,23 → 1490,23
WHILE parser.sym = SCAN.lxPOINT DO
getpos(parser, pos);
PARS.check1(isExpr(e) & (e.type.typ IN {PROG.tRECORD, PROG.tPOINTER}), parser, 73);
IF e.type.typ = PROG.tPOINTER THEN
PARS.check1(isExpr(e) & (e._type.typ IN {PROG.tRECORD, PROG.tPOINTER}), parser, 73);
IF e._type.typ = PROG.tPOINTER THEN
deref(pos, e, TRUE, errPTR)
END;
PARS.ExpectSym(parser, SCAN.lxIDENT);
IF e.type.typ = PROG.tPOINTER THEN
e.type := e.type.base;
IF e._type.typ = PROG.tPOINTER THEN
e._type := e._type.base;
e.readOnly := FALSE
END;
field := PROG.getField(e.type, parser.lex.ident, parser.unit);
field := PROG.getField(e._type, parser.lex.ident, parser.unit);
PARS.check1(field # NIL, parser, 74);
e.type := field.type;
e._type := field._type;
IF e.obj = eVREC THEN
e.obj := eVPAR
END;
IF field.offset # 0 THEN
IL.AddCmd(IL.opADDR, field.offset)
IL.AddCmd(IL.opADDC, field.offset)
END;
PARS.Next(parser);
e.ident := NIL
1489,10 → 1521,10
PARS.check(isInt(idx), pos, 76);
IF idx.obj = eCONST THEN
IF e.type.length > 0 THEN
PARS.check(ARITH.range(idx.value, 0, e.type.length - 1), pos, 83);
IF e._type.length > 0 THEN
PARS.check(ARITH.range(idx.value, 0, e._type.length - 1), pos, 83);
IF ARITH.Int(idx.value) > 0 THEN
IL.AddCmd(IL.opADDR, ARITH.Int(idx.value) * e.type.base.size)
IL.AddCmd(IL.opADDC, ARITH.Int(idx.value) * e._type.base.size)
END
ELSE
PARS.check(ARITH.range(idx.value, 0, UTILS.target.maxInt), pos, 83);
1500,12 → 1532,12
OpenIdx(parser, pos, e)
END
ELSE
IF e.type.length > 0 THEN
IF e._type.length > 0 THEN
IF chkIDX IN Options.checking THEN
CheckRange(e.type.length, pos.line, errIDX)
CheckRange(e._type.length, pos.line, errIDX)
END;
IF e.type.base.size # 1 THEN
IL.AddCmd(IL.opMULC, e.type.base.size)
IF e._type.base.size # 1 THEN
IL.AddCmd(IL.opMULC, e._type.base.size)
END;
IL.AddCmd0(IL.opADD)
ELSE
1513,7 → 1545,7
END
END;
e.type := e.type.base
e._type := e._type.base
UNTIL parser.sym # SCAN.lxCOMMA;
1525,15 → 1557,15
getpos(parser, pos);
PARS.check1(isPtr(e), parser, 77);
deref(pos, e, TRUE, errPTR);
e.type := e.type.base;
e._type := e._type.base;
e.readOnly := FALSE;
PARS.Next(parser);
e.ident := NIL;
e.obj := eVREC
ELSIF (parser.sym = SCAN.lxLROUND) & isExpr(e) & (e.type.typ IN {PROG.tRECORD, PROG.tPOINTER}) DO
ELSIF (parser.sym = SCAN.lxLROUND) & isExpr(e) & (e._type.typ IN {PROG.tRECORD, PROG.tPOINTER}) DO
IF e.type.typ = PROG.tRECORD THEN
IF e._type.typ = PROG.tRECORD THEN
PARS.check1(e.obj = eVREC, parser, 78)
END;
NextPos(parser, pos);
1540,26 → 1572,26
qualident(parser, t);
PARS.check(t.obj = eTYPE, pos, 79);
IF e.type.typ = PROG.tRECORD THEN
PARS.check(t.type.typ = PROG.tRECORD, pos, 80);
IF e._type.typ = PROG.tRECORD THEN
PARS.check(t._type.typ = PROG.tRECORD, pos, 80);
IF chkGUARD IN Options.checking THEN
IF e.ident = NIL THEN
IL.TypeGuard(IL.opTYPEGD, t.type.num, pos.line, errGUARD)
IL.TypeGuard(IL.opTYPEGD, t._type.num, pos.line, errGUARD)
ELSE
IL.AddCmd(IL.opVADR, e.ident.offset - 1);
IL.TypeGuard(IL.opTYPEGR, t.type.num, pos.line, errGUARD)
IL.TypeGuard(IL.opTYPEGR, t._type.num, pos.line, errGUARD)
END
END;
ELSE
PARS.check(t.type.typ = PROG.tPOINTER, pos, 81);
PARS.check(t._type.typ = PROG.tPOINTER, pos, 81);
IF chkGUARD IN Options.checking THEN
IL.TypeGuard(IL.opTYPEGP, t.type.base.num, pos.line, errGUARD)
IL.TypeGuard(IL.opTYPEGP, t._type.base.num, pos.line, errGUARD)
END
END;
PARS.check(PROG.isBaseOf(e.type, t.type), pos, 82);
PARS.check(PROG.isBaseOf(e._type, t._type), pos, 82);
e.type := t.type;
e._type := t._type;
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser)
1569,7 → 1601,7
END designator;
PROCEDURE ProcCall (e: PARS.EXPR; procType: PROG.TYPE_; isfloat: BOOLEAN; VAR fregs: INTEGER; parser: PARS.PARSER; pos: PARS.POSITION; CallStat: BOOLEAN);
PROCEDURE ProcCall (e: PARS.EXPR; procType: PROG._TYPE; isfloat: BOOLEAN; parser: PARS.PARSER; pos: PARS.POSITION; CallStat: BOOLEAN);
VAR
cconv,
parSize,
1594,7 → 1626,7
fparSize := 0
END;
IL.setlast(begcall);
fregs := IL.precall(isfloat);
IL.AddCmd(IL.opPRECALL, ORD(isfloat));
IF cconv IN {PROG._ccall16, PROG.ccall16} THEN
IL.AddCmd(IL.opALIGN16, parSize)
1606,7 → 1638,7
IL.setlast(endcall.prev(IL.COMMAND));
IF e.obj = eIMP THEN
IL.CallImp(e.ident.import, callconv, fparSize)
IL.CallImp(e.ident._import, callconv, fparSize)
ELSIF e.obj = ePROC THEN
IL.Call(e.ident.proc.label, callconv, fparSize)
ELSIF isExpr(e) THEN
1627,11 → 1659,14
IL.AddCmd(IL.opCLEANUP, parSize)
END;
IF ~CallStat THEN
IF CallStat THEN
IL.AddCmd0(IL.opRES);
IL.drop
ELSE
IF isfloat THEN
PARS.check(IL.resf(fregs), pos, 41)
IL.AddCmd2(IL.opRESF, pos.line, pos.col)
ELSE
IL.res(fregs)
IL.AddCmd0(IL.opRES)
END
END
END ProcCall;
1640,12 → 1675,9
PROCEDURE expression (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
pos, pos0, pos1: PARS.POSITION;
op: INTEGER;
e1: PARS.EXPR;
constant: BOOLEAN;
operator: ARITH.RELATION;
error: INTEGER;
op, cmp, error: INTEGER;
constant, eq: BOOLEAN;
PROCEDURE relation (sym: INTEGER): BOOLEAN;
1701,7 → 1733,7
END
END;
e.type := tSET;
e._type := tSET;
IF (e1.obj = eCONST) & (e2.obj = eCONST) THEN
ARITH.constrSet(e.value, e1.value, e2.value);
1732,7 → 1764,7
ASSERT(parser.sym = SCAN.lxLCURLY);
e.obj := eCONST;
e.type := tSET;
e._type := tSET;
ARITH.emptySet(e.value);
PARS.Next(parser);
1752,9 → 1784,9
ARITH.opSet(e.value, e1.value, "+")
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opADDSL, ARITH.Int(e.value))
IL.AddCmd(IL.opADDSC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opADDSR, ARITH.Int(e1.value))
IL.AddCmd(IL.opADDSC, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opADDS)
END;
1773,16 → 1805,15
pos: PARS.POSITION;
e1: PARS.EXPR;
isfloat: BOOLEAN;
fregs: INTEGER;
PROCEDURE LoadVar (e: PARS.EXPR; parser: PARS.PARSER; pos: PARS.POSITION);
BEGIN
IF ~(e.type.typ IN {PROG.tRECORD, PROG.tARRAY}) THEN
IF e.type = tREAL THEN
PARS.check(IL.loadf(), pos, 41)
IF ~(e._type.typ IN {PROG.tRECORD, PROG.tARRAY}) THEN
IF e._type = tREAL THEN
IL.AddCmd2(IL.opLOADF, pos.line, pos.col)
ELSE
IL.load(e.type.size)
IL.load(e._type.size)
END
END
END LoadVar;
1794,18 → 1825,18
IF (sym = SCAN.lxINTEGER) OR (sym = SCAN.lxHEX) OR (sym = SCAN.lxFLOAT) OR (sym = SCAN.lxCHAR) OR (sym = SCAN.lxSTRING) THEN
e.obj := eCONST;
e.value := parser.lex.value;
e.type := PROG.getType(PARS.program, e.value.typ);
e._type := PROG.getType(e.value.typ);
PARS.Next(parser)
ELSIF sym = SCAN.lxNIL THEN
e.obj := eCONST;
e.type := PARS.program.stTypes.tNIL;
e._type := PROG.program.stTypes.tNIL;
PARS.Next(parser)
ELSIF (sym = SCAN.lxTRUE) OR (sym = SCAN.lxFALSE) THEN
e.obj := eCONST;
ARITH.setbool(e.value, sym = SCAN.lxTRUE);
e.type := tBOOLEAN;
e._type := tBOOLEAN;
PARS.Next(parser)
ELSIF sym = SCAN.lxLCURLY THEN
1823,12 → 1854,12
IF parser.sym = SCAN.lxLROUND THEN
e1 := e;
ActualParameters(parser, e);
PARS.check(e.type # NIL, pos, 59);
isfloat := e.type = tREAL;
PARS.check(e._type # NIL, pos, 59);
isfloat := e._type = tREAL;
IF e1.obj IN {ePROC, eIMP} THEN
ProcCall(e1, e1.ident.type, isfloat, fregs, parser, pos, FALSE)
ProcCall(e1, e1.ident._type, isfloat, parser, pos, FALSE)
ELSIF isExpr(e1) THEN
ProcCall(e1, e1.type, isfloat, fregs, parser, pos, FALSE)
ProcCall(e1, e1._type, isfloat, parser, pos, FALSE)
END
END;
IL.popBegEnd(begcall, endcall)
1884,9 → 1915,7
IF e.obj = eCONST THEN
IL.Const(ORD(ARITH.getBool(e.value)))
END;
IL.AddCmd0(IL.opACC);
IL.AddJmpCmd(IL.opJZ, label);
IL.drop
IL.AndOrOpt(label)
END
END;
1914,11 → 1943,11
END
ELSIF isReal(e) THEN
IF e.obj = eCONST THEN
IL.Float(ARITH.Float(e.value))
Float(parser, e)
ELSIF e1.obj = eCONST THEN
IL.Float(ARITH.Float(e1.value))
Float(parser, e1)
END;
IL.fbinop(IL.opMULF)
IL.AddCmd0(IL.opMULF)
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opMULSC, ARITH.Int(e.value))
1946,13 → 1975,13
ELSE
IF isReal(e) THEN
IF e.obj = eCONST THEN
IL.Float(ARITH.Float(e.value));
IL.fbinop(IL.opDIVFI)
Float(parser, e);
IL.AddCmd0(IL.opDIVFI)
ELSIF e1.obj = eCONST THEN
IL.Float(ARITH.Float(e1.value));
IL.fbinop(IL.opDIVF)
Float(parser, e1);
IL.AddCmd0(IL.opDIVF)
ELSE
IL.fbinop(IL.opDIVF)
IL.AddCmd0(IL.opDIVF)
END
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
2007,15 → 2036,24
e.obj := eEXPR;
IF e1.obj = eCONST THEN
IL.Const(ORD(ARITH.getBool(e1.value)))
END;
IL.AddCmd0(IL.opACC)
END
END
END
END;
IF label # -1 THEN
IL.SetLabel(label)
label1 := IL.NewLabel();
IL.AddJmpCmd(IL.opJNZ, label1);
IL.SetLabel(label);
IL.Const(0);
IL.drop;
label := IL.NewLabel();
IL.AddJmpCmd(IL.opJMP, label);
IL.SetLabel(label1);
IL.Const(1);
IL.SetLabel(label);
IL.AddCmd0(IL.opAND)
END
END term;
2025,10 → 2063,11
pos: PARS.POSITION;
op: INTEGER;
e1: PARS.EXPR;
s, s1: SCAN.LEXSTR;
plus, minus: BOOLEAN;
label: INTEGER;
label, label1: INTEGER;
BEGIN
plus := parser.sym = SCAN.lxPLUS;
2081,9 → 2120,8
IF e.obj = eCONST THEN
IL.Const(ORD(ARITH.getBool(e.value)))
END;
IL.AddCmd0(IL.opACC);
IL.AddJmpCmd(IL.opJNZ, label);
IL.drop
IL.not;
IL.AndOrOpt(label)
END
END;
2093,47 → 2131,69
CASE op OF
|SCAN.lxPLUS, SCAN.lxMINUS:
IF op = SCAN.lxPLUS THEN
minus := op = SCAN.lxMINUS;
IF minus THEN
op := ORD("-")
ELSE
op := ORD("+")
ELSE
op := ORD("-")
END;
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), pos, 37);
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1) OR isString(e) & isString(e1) & ~minus, pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
CASE e.value.typ OF
|ARITH.tINTEGER: PARS.check(ARITH.opInt(e.value, e1.value, CHR(op)), pos, 39)
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, CHR(op)), pos, 40)
|ARITH.tSET: ARITH.opSet(e.value, e1.value, CHR(op))
|ARITH.tINTEGER:
PARS.check(ARITH.opInt(e.value, e1.value, CHR(op)), pos, 39)
|ARITH.tREAL:
PARS.check(ARITH.opFloat(e.value, e1.value, CHR(op)), pos, 40)
|ARITH.tSET:
ARITH.opSet(e.value, e1.value, CHR(op))
|ARITH.tCHAR, ARITH.tSTRING:
IF e.value.typ = ARITH.tCHAR THEN
ARITH.charToStr(e.value, s)
ELSE
s := e.value.string(SCAN.IDENT).s
END;
IF e1.value.typ = ARITH.tCHAR THEN
ARITH.charToStr(e1.value, s1)
ELSE
s1 := e1.value.string(SCAN.IDENT).s
END;
PARS.check(ARITH.concat(s, s1), pos, 5);
e.value.string := SCAN.enterid(s);
e.value.typ := ARITH.tSTRING;
e._type := PROG.program.stTypes.tSTRING
END
ELSE
IF isInt(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opADDL + ORD(op = ORD("-")), ARITH.Int(e.value))
IL.AddCmd(IL.opADDC - ORD(minus), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opADDR + ORD(op = ORD("-")), ARITH.Int(e1.value))
IL.AddCmd(IL.opADDC + ORD(minus), ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opADD + ORD(op = ORD("-")))
IL.AddCmd0(IL.opADD + ORD(minus))
END
ELSIF isReal(e) THEN
IF e.obj = eCONST THEN
IL.Float(ARITH.Float(e.value));
IL.fbinop(IL.opADDFI + ORD(op = ORD("-")))
Float(parser, e);
IL.AddCmd0(IL.opADDF - ORD(minus))
ELSIF e1.obj = eCONST THEN
IL.Float(ARITH.Float(e1.value));
IL.fbinop(IL.opADDF + ORD(op = ORD("-")))
Float(parser, e1);
IL.AddCmd0(IL.opADDF + ORD(minus))
ELSE
IL.fbinop(IL.opADDF + ORD(op = ORD("-")))
IL.AddCmd0(IL.opADDF + ORD(minus))
END
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opADDSL + ORD(op = ORD("-")), ARITH.Int(e.value))
IL.AddCmd(IL.opADDSC - ORD(minus), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opADDSR + ORD(op = ORD("-")), ARITH.Int(e1.value))
IL.AddCmd(IL.opADDSC + ORD(minus), ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opADDS + ORD(op = ORD("-")))
IL.AddCmd0(IL.opADDS + ORD(minus))
END
END;
e.obj := eEXPR
2148,15 → 2208,24
e.obj := eEXPR;
IF e1.obj = eCONST THEN
IL.Const(ORD(ARITH.getBool(e1.value)))
END;
IL.AddCmd0(IL.opACC)
END
END
END
END;
IF label # -1 THEN
IL.SetLabel(label)
label1 := IL.NewLabel();
IL.AddJmpCmd(IL.opJZ, label1);
IL.SetLabel(label);
IL.Const(1);
IL.drop;
label := IL.NewLabel();
IL.AddJmpCmd(IL.opJMP, label);
IL.SetLabel(label1);
IL.Const(0);
IL.SetLabel(label);
IL.AddCmd0(IL.opOR)
END
END SimpleExpression;
2168,12 → 2237,14
BEGIN
CASE op OF
|SCAN.lxEQ: res := 0
|SCAN.lxNE: res := 1
|SCAN.lxLT: res := 2
|SCAN.lxLE: res := 3
|SCAN.lxGT: res := 4
|SCAN.lxGE: res := 5
|SCAN.lxEQ: res := ARITH.opEQ
|SCAN.lxNE: res := ARITH.opNE
|SCAN.lxLT: res := ARITH.opLT
|SCAN.lxLE: res := ARITH.opLE
|SCAN.lxGT: res := ARITH.opGT
|SCAN.lxGE: res := ARITH.opGE
|SCAN.lxIN: res := ARITH.opIN
|SCAN.lxIS: res := ARITH.opIS
END
RETURN res
2186,12 → 2257,14
BEGIN
CASE op OF
|SCAN.lxEQ: res := 0
|SCAN.lxNE: res := 1
|SCAN.lxLT: res := 4
|SCAN.lxLE: res := 5
|SCAN.lxGT: res := 2
|SCAN.lxGE: res := 3
|SCAN.lxEQ: res := ARITH.opEQ
|SCAN.lxNE: res := ARITH.opNE
|SCAN.lxLT: res := ARITH.opGT
|SCAN.lxLE: res := ARITH.opGE
|SCAN.lxGT: res := ARITH.opLT
|SCAN.lxGE: res := ARITH.opLE
|SCAN.lxIN: res := ARITH.opIN
|SCAN.lxIS: res := ARITH.opIS
END
RETURN res
2211,9 → 2284,11
PROCEDURE strcmp (VAR e, e1: PARS.EXPR; op: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
cmp: INTEGER;
BEGIN
res := TRUE;
cmp := cmpcode(op);
IF isString(e) & isCharArray(e1) THEN
IL.StrAdr(String(e));
2220,36 → 2295,26
IL.Const(strlen(e) + 1);
IL.AddCmd0(IL.opEQS + invcmpcode(op))
ELSIF isString(e) & isCharArrayW(e1) THEN
ELSIF (isString(e) OR isStringW(e)) & isCharArrayW(e1) THEN
IL.StrAdr(StringW(e));
IL.Const(utf8strlen(e) + 1);
IL.AddCmd0(IL.opEQSW + invcmpcode(op))
ELSIF isStringW(e) & isCharArrayW(e1) THEN
IL.StrAdr(StringW(e));
IL.Const(utf8strlen(e) + 1);
IL.AddCmd0(IL.opEQSW + invcmpcode(op))
ELSIF isCharArray(e) & isString(e1) THEN
IL.StrAdr(String(e1));
IL.Const(strlen(e1) + 1);
IL.AddCmd0(IL.opEQS + cmpcode(op))
IL.AddCmd0(IL.opEQS + cmp)
ELSIF isCharArrayW(e) & isString(e1) THEN
ELSIF isCharArrayW(e) & (isString(e1) OR isStringW(e1)) THEN
IL.StrAdr(StringW(e1));
IL.Const(utf8strlen(e1) + 1);
IL.AddCmd0(IL.opEQSW + cmpcode(op))
IL.AddCmd0(IL.opEQSW + cmp)
ELSIF isCharArrayW(e) & isStringW(e1) THEN
IL.StrAdr(StringW(e1));
IL.Const(utf8strlen(e1) + 1);
IL.AddCmd0(IL.opEQSW + cmpcode(op))
ELSIF isCharArrayW(e) & isCharArrayW(e1) THEN
IL.AddCmd0(IL.opEQSW + cmpcode(op))
IL.AddCmd0(IL.opEQSW + cmp)
ELSIF isCharArray(e) & isCharArray(e1) THEN
IL.AddCmd0(IL.opEQS + cmpcode(op))
IL.AddCmd0(IL.opEQS + cmp)
ELSIF isString(e) & isString(e1) THEN
PARS.strcmp(e.value, e1.value, op)
2267,8 → 2332,8
getpos(parser, pos0);
SimpleExpression(parser, e);
IF relation(parser.sym) THEN
IF (isCharArray(e) OR isCharArrayW(e)) & (e.type.length # 0) THEN
IL.Const(e.type.length)
IF (isCharArray(e) OR isCharArrayW(e)) & (e._type.length # 0) THEN
IL.Const(e._type.length)
END;
op := parser.sym;
getpos(parser, pos);
2277,61 → 2342,50
getpos(parser, pos1);
SimpleExpression(parser, e1);
IF (isCharArray(e1) OR isCharArrayW(e1)) & (e1.type.length # 0) THEN
IL.Const(e1.type.length)
IF (isCharArray(e1) OR isCharArrayW(e1)) & (e1._type.length # 0) THEN
IL.Const(e1._type.length)
END;
constant := (e.obj = eCONST) & (e1.obj = eCONST);
CASE op OF
|SCAN.lxEQ: operator := "="
|SCAN.lxNE: operator := "#"
|SCAN.lxLT: operator := "<"
|SCAN.lxLE: operator := "<="
|SCAN.lxGT: operator := ">"
|SCAN.lxGE: operator := ">="
|SCAN.lxIN: operator := "IN"
|SCAN.lxIS: operator := ""
END;
error := 0;
cmp := cmpcode(op);
CASE op OF
|SCAN.lxEQ, SCAN.lxNE:
eq := op = SCAN.lxEQ;
IF isInt(e) & isInt(e1) OR isSet(e) & isSet(e1) OR isChar(e) & isChar(e1) OR isCharW(e) & isCharW(e1) OR
isCharW(e) & isChar(e1) & (e1.obj = eCONST) OR isCharW(e1) & isChar(e) & (e.obj = eCONST) OR
isCharW(e1) & (e1.obj = eCONST) & isChar(e) & (e.obj = eCONST) OR
isCharW(e) & (e.obj = eCONST) & isChar(e1) & (e1.obj = eCONST) OR
isPtr(e) & isPtr(e1) & (PROG.isBaseOf(e.type, e1.type) OR PROG.isBaseOf(e1.type, e.type)) THEN
isPtr(e) & isPtr(e1) & (PROG.isBaseOf(e._type, e1._type) OR PROG.isBaseOf(e1._type, e._type)) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, operator, error)
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opEQC + cmpcode(op), ARITH.Int(e.value))
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opEQC + cmpcode(op), ARITH.Int(e1.value))
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opEQ + cmpcode(op))
IL.AddCmd0(IL.opEQ + cmp)
END
END
ELSIF isStringW1(e) & isCharW(e1) THEN
IL.AddCmd(IL.opEQC + cmpcode(op), StrToWChar(e.value.string(SCAN.IDENT).s))
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e.value.string(SCAN.IDENT).s))
ELSIF isStringW1(e1) & isCharW(e) THEN
IL.AddCmd(IL.opEQC + cmpcode(op), StrToWChar(e1.value.string(SCAN.IDENT).s))
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e1.value.string(SCAN.IDENT).s))
ELSIF isBoolean(e) & isBoolean(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, operator, error)
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
BoolCmp(op = SCAN.lxEQ, ARITH.Int(e.value) # 0)
BoolCmp(eq, ARITH.Int(e.value) # 0)
ELSIF e1.obj = eCONST THEN
BoolCmp(op = SCAN.lxEQ, ARITH.Int(e1.value) # 0)
BoolCmp(eq, ARITH.Int(e1.value) # 0)
ELSE
IF op = SCAN.lxEQ THEN
IF eq THEN
IL.AddCmd0(IL.opEQB)
ELSE
IL.AddCmd0(IL.opNEB)
2341,14 → 2395,14
ELSIF isReal(e) & isReal(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, operator, error)
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
IL.Float(ARITH.Float(e.value))
Float(parser, e)
ELSIF e1.obj = eCONST THEN
IL.Float(ARITH.Float(e1.value))
Float(parser, e1)
END;
IL.fcmp(IL.opEQF + cmpcode(op))
IL.AddCmd0(IL.opEQF + cmp)
END
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN
2357,7 → 2411,7
END
ELSIF isPtr(e) & isNil(e1) OR isNil(e) & isPtr(e1) THEN
IL.AddCmd0(IL.opEQC + cmpcode(op))
IL.AddCmd0(IL.opEQC + cmp)
ELSIF isProc(e) & isNil(e1) THEN
IF e.obj IN {ePROC, eIMP} THEN
2364,9 → 2418,9
PARS.check(e.ident.global, pos0, 85);
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, op = SCAN.lxNE)
ARITH.setbool(e.value, ~eq)
ELSE
IL.AddCmd0(IL.opEQC + cmpcode(op))
IL.AddCmd0(IL.opEQC + cmp)
END
ELSIF isNil(e) & isProc(e1) THEN
2374,12 → 2428,12
PARS.check(e1.ident.global, pos1, 85);
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, op = SCAN.lxNE)
ARITH.setbool(e.value, ~eq)
ELSE
IL.AddCmd0(IL.opEQC + cmpcode(op))
IL.AddCmd0(IL.opEQC + cmp)
END
ELSIF isProc(e) & isProc(e1) & PROG.isTypeEq(e.type, e1.type) THEN
ELSIF isProc(e) & isProc(e1) & PROG.isTypeEq(e._type, e1._type) THEN
IF e.obj = ePROC THEN
PARS.check(e.ident.global, pos0, 85)
END;
2389,27 → 2443,27
IF (e.obj IN {ePROC, eIMP}) & (e1.obj IN {ePROC, eIMP}) THEN
constant := TRUE;
e.obj := eCONST;
IF op = SCAN.lxEQ THEN
IF eq THEN
ARITH.setbool(e.value, e.ident = e1.ident)
ELSE
ARITH.setbool(e.value, e.ident # e1.ident)
END
ELSIF e.obj = ePROC THEN
IL.ProcCmp(e.ident.proc.label, op = SCAN.lxEQ)
IL.ProcCmp(e.ident.proc.label, eq)
ELSIF e1.obj = ePROC THEN
IL.ProcCmp(e1.ident.proc.label, op = SCAN.lxEQ)
IL.ProcCmp(e1.ident.proc.label, eq)
ELSIF e.obj = eIMP THEN
IL.ProcImpCmp(e.ident.import, op = SCAN.lxEQ)
IL.ProcImpCmp(e.ident._import, eq)
ELSIF e1.obj = eIMP THEN
IL.ProcImpCmp(e1.ident.import, op = SCAN.lxEQ)
IL.ProcImpCmp(e1.ident._import, eq)
ELSE
IL.AddCmd0(IL.opEQ + cmpcode(op))
IL.AddCmd0(IL.opEQ + cmp)
END
ELSIF isNil(e) & isNil(e1) THEN
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, op = SCAN.lxEQ)
ARITH.setbool(e.value, eq)
ELSE
PARS.error(pos, 37)
2422,14 → 2476,14
isCharW(e) & (e.obj = eCONST) & isChar(e1) & (e1.obj = eCONST) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, operator, error)
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opEQC + invcmpcode(op), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opEQC + cmpcode(op), ARITH.Int(e1.value))
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opEQ + cmpcode(op))
IL.AddCmd0(IL.opEQ + cmp)
END
END
2437,20 → 2491,20
IL.AddCmd(IL.opEQC + invcmpcode(op), StrToWChar(e.value.string(SCAN.IDENT).s))
ELSIF isStringW1(e1) & isCharW(e) THEN
IL.AddCmd(IL.opEQC + cmpcode(op), StrToWChar(e1.value.string(SCAN.IDENT).s))
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e1.value.string(SCAN.IDENT).s))
ELSIF isReal(e) & isReal(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, operator, error)
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
IL.Float(ARITH.Float(e.value));
IL.fcmp(IL.opEQF + invcmpcode(op))
Float(parser, e);
IL.AddCmd0(IL.opEQF + invcmpcode(op))
ELSIF e1.obj = eCONST THEN
IL.Float(ARITH.Float(e1.value));
IL.fcmp(IL.opEQF + cmpcode(op))
Float(parser, e1);
IL.AddCmd0(IL.opEQF + cmp)
ELSE
IL.fcmp(IL.opEQF + cmpcode(op))
IL.AddCmd0(IL.opEQF + cmp)
END
END
2469,7 → 2523,7
PARS.check(ARITH.range(e.value, 0, UTILS.target.maxSet), pos0, 56)
END;
IF constant THEN
ARITH.relation(e.value, e1.value, operator, error)
ARITH.relation(e.value, e1.value, ARITH.opIN, error)
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opINL, ARITH.Int(e.value))
2486,25 → 2540,25
IF isRec(e) THEN
PARS.check(e.obj = eVREC, pos0, 78);
PARS.check(e1.type.typ = PROG.tRECORD, pos1, 80);
PARS.check(e1._type.typ = PROG.tRECORD, pos1, 80);
IF e.ident = NIL THEN
IL.TypeCheck(e1.type.num)
IL.TypeCheck(e1._type.num)
ELSE
IL.AddCmd(IL.opVADR, e.ident.offset - 1);
IL.TypeCheckRec(e1.type.num)
IL.TypeCheckRec(e1._type.num)
END
ELSE
PARS.check(e1.type.typ = PROG.tPOINTER, pos1, 81);
IL.TypeCheck(e1.type.base.num)
PARS.check(e1._type.typ = PROG.tPOINTER, pos1, 81);
IL.TypeCheck(e1._type.base.num)
END;
PARS.check(PROG.isBaseOf(e.type, e1.type), pos1, 82)
PARS.check(PROG.isBaseOf(e._type, e1._type), pos1, 82)
END;
ASSERT(error = 0);
e.type := tBOOLEAN;
e._type := tBOOLEAN;
IF ~constant THEN
e.obj := eEXPR
2520,7 → 2574,6
pos: PARS.POSITION;
line: INTEGER;
call: BOOLEAN;
fregs: INTEGER;
BEGIN
getpos(parser, pos);
2541,7 → 2594,7
IL.setlast(endcall.prev(IL.COMMAND));
PARS.check(assign(e1, e.type, line), pos, 91);
PARS.check(assign(parser, e1, e._type, line), pos, 91);
IF e1.obj = ePROC THEN
PARS.check(e1.ident.global, pos, 85)
END;
2551,7 → 2604,7
ELSIF parser.sym = SCAN.lxLROUND THEN
e1 := e;
ActualParameters(parser, e1);
PARS.check((e1.type = NIL) OR ODD(e.type.call), pos, 92);
PARS.check((e1._type = NIL) OR ODD(e._type.call), pos, 92);
call := TRUE
ELSE
IF e.obj IN {eSYSPROC, eSTPROC} THEN
2559,8 → 2612,8
call := FALSE
ELSE
PARS.check(isProc(e), pos, 86);
PARS.check((e.type.base = NIL) OR ODD(e.type.call), pos, 92);
PARS.check1(e.type.params.first = NIL, parser, 64);
PARS.check((e._type.base = NIL) OR ODD(e._type.call), pos, 92);
PARS.check1(e._type.params.first = NIL, parser, 64);
call := TRUE
END
END;
2567,9 → 2620,9
IF call THEN
IF e.obj IN {ePROC, eIMP} THEN
ProcCall(e, e.ident.type, FALSE, fregs, parser, pos, TRUE)
ProcCall(e, e.ident._type, FALSE, parser, pos, TRUE)
ELSIF isExpr(e) THEN
ProcCall(e, e.type, FALSE, fregs, parser, pos, TRUE)
ProcCall(e, e._type, FALSE, parser, pos, TRUE)
END
END;
2577,7 → 2630,7
END ElementaryStatement;
PROCEDURE IfStatement (parser: PARS.PARSER; if: BOOLEAN);
PROCEDURE IfStatement (parser: PARS.PARSER; _if: BOOLEAN);
VAR
e: PARS.EXPR;
pos: PARS.POSITION;
2587,7 → 2640,7
BEGIN
L := IL.NewLabel();
IF ~if THEN
IF ~_if THEN
IL.AddCmd0(IL.opLOOP);
IL.SetLabel(L)
END;
2605,10 → 2658,10
IL.AddJmpCmd(IL.opJMP, label)
END
ELSE
IL.AddJmpCmd(IL.opJNE, label)
IL.AndOrOpt(label)
END;
IF if THEN
IF _if THEN
PARS.checklex(parser, SCAN.lxTHEN)
ELSE
PARS.checklex(parser, SCAN.lxDO)
2617,25 → 2670,25
PARS.Next(parser);
parser.StatSeq(parser);
IL.AddJmpCmd(IL.opJMP, L);
IF ~_if OR (parser.sym # SCAN.lxEND) THEN
IL.AddJmpCmd(IL.opJMP, L)
END;
IL.SetLabel(label)
UNTIL parser.sym # SCAN.lxELSIF;
IF if THEN
IF _if THEN
IF parser.sym = SCAN.lxELSE THEN
PARS.Next(parser);
parser.StatSeq(parser)
END;
IL.SetLabel(L)
ELSE
IL.AddCmd0(IL.opENDLOOP)
END;
PARS.checklex(parser, SCAN.lxEND);
IF ~if THEN
IL.AddCmd0(IL.opENDLOOP)
END;
PARS.Next(parser)
END IfStatement;
2645,6 → 2698,7
e: PARS.EXPR;
pos: PARS.POSITION;
label: INTEGER;
L: IL.COMMAND;
BEGIN
IL.AddCmd0(IL.opLOOP);
2651,6 → 2705,7
label := IL.NewLabel();
IL.SetLabel(label);
L := IL.getlast();
PARS.Next(parser);
parser.StatSeq(parser);
2664,7 → 2719,8
IL.AddJmpCmd(IL.opJMP, label)
END
ELSE
IL.AddJmpCmd(IL.opJNE, label)
IL.AndOrOpt(label);
L.param1 := label
END;
IL.AddCmd0(IL.opENDLOOP)
2724,7 → 2780,7
pos: PARS.POSITION;
PROCEDURE Label (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR type: PROG.TYPE_): INTEGER;
PROCEDURE Label (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR _type: PROG._TYPE): INTEGER;
VAR
a: INTEGER;
label: PARS.EXPR;
2733,7 → 2789,7
BEGIN
getpos(parser, pos);
type := NIL;
_type := NIL;
IF isChar(caseExpr) THEN
PARS.ConstExpression(parser, value);
2754,13 → 2810,13
ELSIF isRecPtr(caseExpr) THEN
qualident(parser, label);
PARS.check(label.obj = eTYPE, pos, 79);
PARS.check(PROG.isBaseOf(caseExpr.type, label.type), pos, 99);
PARS.check(PROG.isBaseOf(caseExpr._type, label._type), pos, 99);
IF isRec(caseExpr) THEN
a := label.type.num
a := label._type.num
ELSE
a := label.type.base.num
a := label._type.base.num
END;
type := label.type
_type := label._type
END
RETURN a
2767,12 → 2823,12
END Label;
PROCEDURE CheckType (node: AVL.NODE; type: PROG.TYPE_; parser: PARS.PARSER; pos: PARS.POSITION);
PROCEDURE CheckType (node: AVL.NODE; _type: PROG._TYPE; parser: PARS.PARSER; pos: PARS.POSITION);
BEGIN
IF node # NIL THEN
PARS.check(~(PROG.isBaseOf(node.data(CASE_LABEL).type, type) OR PROG.isBaseOf(type, node.data(CASE_LABEL).type)), pos, 100);
CheckType(node.left, type, parser, pos);
CheckType(node.right, type, parser, pos)
PARS.check(~(PROG.isBaseOf(node.data(CASE_LABEL)._type, _type) OR PROG.isBaseOf(_type, node.data(CASE_LABEL)._type)), pos, 100);
CheckType(node.left, _type, parser, pos);
CheckType(node.right, _type, parser, pos)
END
END CheckType;
2798,12 → 2854,12
label.self := IL.NewLabel();
getpos(parser, pos1);
range.a := Label(parser, caseExpr, label.type);
range.a := Label(parser, caseExpr, label._type);
IF parser.sym = SCAN.lxRANGE THEN
PARS.check1(~isRecPtr(caseExpr), parser, 53);
NextPos(parser, pos);
range.b := Label(parser, caseExpr, label.type);
range.b := Label(parser, caseExpr, label._type);
PARS.check(range.a <= range.b, pos, 103)
ELSE
range.b := range.a
2812,7 → 2868,7
label.range := range;
IF isRecPtr(caseExpr) THEN
CheckType(tree, label.type, parser, pos1)
CheckType(tree, label._type, parser, pos1)
END;
tree := AVL.insert(tree, label, LabelCmp, newnode, node);
PARS.check(newnode, pos1, 100)
2843,10 → 2899,10
END CaseLabelList;
PROCEDURE case (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; end: INTEGER);
PROCEDURE _case (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; _end: INTEGER);
VAR
sym: INTEGER;
t: PROG.TYPE_;
t: PROG._TYPE;
variant: INTEGER;
node: AVL.NODE;
last: IL.COMMAND;
2859,8 → 2915,8
PARS.checklex(parser, SCAN.lxCOLON);
PARS.Next(parser);
IF isRecPtr(caseExpr) THEN
t := caseExpr.type;
caseExpr.ident.type := node.data(CASE_LABEL).type
t := caseExpr._type;
caseExpr.ident._type := node.data(CASE_LABEL)._type
END;
last := IL.getlast();
2871,16 → 2927,16
END;
parser.StatSeq(parser);
IL.AddJmpCmd(IL.opJMP, end);
IL.AddJmpCmd(IL.opJMP, _end);
IF isRecPtr(caseExpr) THEN
caseExpr.ident.type := t
caseExpr.ident._type := t
END
END
END case;
END _case;
PROCEDURE Table (node: AVL.NODE; else: INTEGER);
PROCEDURE Table (node: AVL.NODE; _else: INTEGER);
VAR
L, R: INTEGER;
range: RANGE;
2897,7 → 2953,7
IF left # NIL THEN
L := left.data(CASE_LABEL).self
ELSE
L := else
L := _else
END;
right := node.right;
2904,7 → 2960,7
IF right # NIL THEN
R := right.data(CASE_LABEL).self
ELSE
R := else
R := _else
END;
last := IL.getlast();
2918,7 → 2974,7
IL.setlast(v.cmd);
IL.SetLabel(node.data(CASE_LABEL).self);
IL.case(range.a, range.b, L, R);
IL._case(range.a, range.b, L, R);
IF v.processed THEN
IL.AddJmpCmd(IL.opJMP, node.data(CASE_LABEL).variant)
END;
2926,8 → 2982,8
IL.setlast(last);
Table(left, else);
Table(right, else)
Table(left, _else);
Table(right, _else)
END
END Table;
2935,8 → 2991,7
PROCEDURE TableT (node: AVL.NODE);
BEGIN
IF node # NIL THEN
IL.caset(node.data(CASE_LABEL).range.a, node.data(CASE_LABEL).variant);
IL.AddCmd2(IL.opCASET, node.data(CASE_LABEL).variant, node.data(CASE_LABEL).range.a);
TableT(node.left);
TableT(node.right)
END
2945,14 → 3000,14
PROCEDURE ParseCase (parser: PARS.PARSER; e: PARS.EXPR; pos: PARS.POSITION);
VAR
table, end, else: INTEGER;
table, _end, _else: INTEGER;
tree: AVL.NODE;
item: LISTS.ITEM;
BEGIN
LISTS.push(CaseVariants, NewVariant(0, NIL));
end := IL.NewLabel();
else := IL.NewLabel();
_end := IL.NewLabel();
_else := IL.NewLabel();
table := IL.NewLabel();
IL.AddCmd(IL.opSWITCH, ORD(isRecPtr(e)));
IL.AddJmpCmd(IL.opJMP, table);
2959,17 → 3014,17
tree := NIL;
case(parser, e, tree, end);
_case(parser, e, tree, _end);
WHILE parser.sym = SCAN.lxBAR DO
PARS.Next(parser);
case(parser, e, tree, end)
_case(parser, e, tree, _end)
END;
IL.SetLabel(else);
IL.SetLabel(_else);
IF parser.sym = SCAN.lxELSE THEN
PARS.Next(parser);
parser.StatSeq(parser);
IL.AddJmpCmd(IL.opJMP, end)
IL.AddJmpCmd(IL.opJMP, _end)
ELSE
IL.OnError(pos.line, errCASE)
END;
2980,14 → 3035,14
IF isRecPtr(e) THEN
IL.SetLabel(table);
TableT(tree);
IL.AddJmpCmd(IL.opJMP, else)
IL.AddJmpCmd(IL.opJMP, _else)
ELSE
tree.data(CASE_LABEL).self := table;
Table(tree, else)
Table(tree, _else)
END;
AVL.destroy(tree, DestroyLabel);
IL.SetLabel(end);
IL.SetLabel(_end);
IL.AddCmd0(IL.opENDSW);
REPEAT
3048,13 → 3103,13
ident := PROG.getIdent(parser.unit, parser.lex.ident, TRUE);
PARS.check1(ident # NIL, parser, 48);
PARS.check1(ident.typ = PROG.idVAR, parser, 93);
PARS.check1(ident.type = tINTEGER, parser, 97);
PARS.check1(ident._type = tINTEGER, parser, 97);
PARS.ExpectSym(parser, SCAN.lxASSIGN);
NextPos(parser, pos);
expression(parser, e);
PARS.check(isInt(e), pos, 76);
offset := PROG.getOffset(PARS.program, ident);
offset := PROG.getOffset(ident);
IF ident.global THEN
IL.AddCmd(IL.opGADR, offset)
3075,7 → 3130,7
ELSE
IL.AddCmd(IL.opLADR, -offset)
END;
IL.load(ident.type.size);
IL.load(ident._type.size);
PARS.checklex(parser, SCAN.lxTO);
NextPos(parser, pos2);
3112,7 → 3167,7
END
END;
IL.AddJmpCmd(IL.opJNE, L2);
IL.AddJmpCmd(IL.opJZ, L2);
PARS.checklex(parser, SCAN.lxDO);
PARS.Next(parser);
3171,7 → 3226,7
END StatSeq;
PROCEDURE chkreturn (parser: PARS.PARSER; e: PARS.EXPR; t: PROG.TYPE_; pos: PARS.POSITION): BOOLEAN;
PROCEDURE chkreturn (parser: PARS.PARSER; e: PARS.EXPR; t: PROG._TYPE; pos: PARS.POSITION): BOOLEAN;
VAR
res: BOOLEAN;
3179,24 → 3234,20
res := assigncomp(e, t);
IF res THEN
IF e.obj = eCONST THEN
IF e.type = tREAL THEN
IL.Float(ARITH.Float(e.value))
ELSIF e.type.typ = PROG.tNIL THEN
IF e._type = tREAL THEN
Float(parser, e)
ELSIF e._type.typ = PROG.tNIL THEN
IL.Const(0)
ELSE
LoadConst(e)
END
ELSIF (e.type = tINTEGER) & (t = tBYTE) & (chkBYTE IN Options.checking) THEN
ELSIF (e._type = tINTEGER) & (t = tBYTE) & (chkBYTE IN Options.checking) THEN
CheckRange(256, pos.line, errBYTE)
ELSIF e.obj = ePROC THEN
PARS.check(e.ident.global, pos, 85);
IL.PushProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
IL.PushImpProc(e.ident.import)
END;
IF e.type = tREAL THEN
IL.retf
IL.PushImpProc(e.ident._import)
END
END
3216,8 → 3267,8
BEGIN
id := PROG.getIdent(rtl, SCAN.enterid(name), FALSE);
IF (id # NIL) & (id.import # NIL) THEN
IL.set_rtl(idx, -id.import(IL.IMPORT_PROC).label);
IF (id # NIL) & (id._import # NIL) THEN
IL.set_rtl(idx, -id._import(IL.IMPORT_PROC).label);
id.proc.used := TRUE
ELSIF (id # NIL) & (id.proc # NIL) THEN
IL.set_rtl(idx, id.proc.label);
3229,7 → 3280,7
BEGIN
rtl := PARS.program.rtl;
rtl := PROG.program.rtl;
ASSERT(rtl # NIL);
getproc(rtl, "_strcmp", IL._strcmp);
3256,7 → 3307,7
getproc(rtl, "_isrec", IL._isrec);
getproc(rtl, "_dllentry", IL._dllentry);
getproc(rtl, "_sofinit", IL._sofinit)
ELSIF CPU = TARGETS.cpuTHUMB THEN
ELSIF CPU IN {TARGETS.cpuTHUMB, TARGETS.cpuRVM32I} THEN
getproc(rtl, "_fmul", IL._fmul);
getproc(rtl, "_fdiv", IL._fdiv);
getproc(rtl, "_fdivi", IL._fdivi);
3267,8 → 3318,11
getproc(rtl, "_floor", IL._floor);
getproc(rtl, "_flt", IL._flt);
getproc(rtl, "_pack", IL._pack);
getproc(rtl, "_unpk", IL._unpk)
getproc(rtl, "_unpk", IL._unpk);
IF CPU = TARGETS.cpuRVM32I THEN
getproc(rtl, "_error", IL._error)
END
END
END setrtl;
3279,13 → 3333,13
ext: PARS.PATH;
BEGIN
tINTEGER := PARS.program.stTypes.tINTEGER;
tBYTE := PARS.program.stTypes.tBYTE;
tCHAR := PARS.program.stTypes.tCHAR;
tSET := PARS.program.stTypes.tSET;
tBOOLEAN := PARS.program.stTypes.tBOOLEAN;
tWCHAR := PARS.program.stTypes.tWCHAR;
tREAL := PARS.program.stTypes.tREAL;
tINTEGER := PROG.program.stTypes.tINTEGER;
tBYTE := PROG.program.stTypes.tBYTE;
tCHAR := PROG.program.stTypes.tCHAR;
tSET := PROG.program.stTypes.tSET;
tBOOLEAN := PROG.program.stTypes.tBOOLEAN;
tWCHAR := PROG.program.stTypes.tWCHAR;
tREAL := PROG.program.stTypes.tREAL;
Options := options;
CPU := TARGETS.CPU;
3299,7 → 3353,7
IL.init(CPU);
IF CPU # TARGETS.cpuMSP430 THEN
IF TARGETS.RTL THEN
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn);
IF parser.open(parser, UTILS.RTL_NAME) THEN
parser.parse(parser);
3327,17 → 3381,17
PARS.destroy(parser);
IF PARS.program.bss > UTILS.MAX_GLOBAL_SIZE THEN
IF PROG.program.bss > UTILS.MAX_GLOBAL_SIZE THEN
ERRORS.Error(204)
END;
IF CPU # TARGETS.cpuMSP430 THEN
IF TARGETS.RTL THEN
setrtl
END;
PROG.DelUnused(PARS.program, IL.DelImport);
PROG.DelUnused(IL.DelImport);
IL.set_bss(PARS.program.bss);
IL.set_bss(PROG.program.bss);
CASE CPU OF
|TARGETS.cpuAMD64: AMD64.CodeGen(outname, target, options)
3344,6 → 3398,7
|TARGETS.cpuX86: X86.CodeGen(outname, target, options)
|TARGETS.cpuMSP430: MSP430.CodeGen(outname, target, options)
|TARGETS.cpuTHUMB: THUMB.CodeGen(outname, target, options)
|TARGETS.cpuRVM32I: RVM32I.CodeGen(outname, target, options)
END
END compile;

/programs/develop/oberon07/Source/STRINGS.ob07
10,9 → 10,20
IMPORT UTILS;
PROCEDURE copy* (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR; spos, dpos, count: INTEGER);
BEGIN
WHILE count > 0 DO
dst[dpos] := src[spos];
INC(spos);
INC(dpos);
DEC(count)
END
END copy;
PROCEDURE append* (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
n1, n2: INTEGER;
BEGIN
n1 := LENGTH(s1);
20,43 → 31,14
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
copy(s2, s1, 0, n1, n2);
s1[n1 + n2] := 0X
END append;
PROCEDURE reverse (VAR s: ARRAY OF CHAR);
VAR
i, j: INTEGER;
a, b: CHAR;
BEGIN
i := 0;
j := LENGTH(s) - 1;
WHILE i < j DO
a := s[i];
b := s[j];
s[i] := b;
s[j] := a;
INC(i);
DEC(j)
END
END reverse;
PROCEDURE IntToStr* (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
minus: BOOLEAN;
BEGIN
IF x = UTILS.minint THEN
67,48 → 49,35
END
ELSE
i := 0;
IF x < 0 THEN
x := -x;
i := 1;
str[0] := "-"
END;
minus := x < 0;
IF minus THEN
x := -x
END;
i := 0;
a := 0;
a := x;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
INC(i);
a := a DIV 10
UNTIL a = 0;
IF minus THEN
str[i] := "-";
INC(i)
END;
str[i] := 0X;
reverse(str)
REPEAT
DEC(i);
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10
UNTIL x = 0
END
END IntToStr;
PROCEDURE hexdgt (n: BYTE): BYTE;
BEGIN
IF n < 10 THEN
n := n + ORD("0")
ELSE
n := n - 10 + ORD("A")
END
RETURN n
END hexdgt;
PROCEDURE IntToHex* (x: INTEGER; VAR str: ARRAY OF CHAR; n: INTEGER);
BEGIN
str[n] := 0X;
WHILE n > 0 DO
str[n - 1] := CHR(hexdgt(x MOD 16));
str[n - 1] := CHR(UTILS.hexdgt(x MOD 16));
x := x DIV 16;
DEC(n)
END
115,17 → 84,6
END IntToHex;
PROCEDURE copy* (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR; spos, dpos, count: INTEGER);
BEGIN
WHILE count > 0 DO
dst[dpos] := src[spos];
INC(spos);
INC(dpos);
DEC(count)
END
END copy;
PROCEDURE search* (s: ARRAY OF CHAR; VAR pos: INTEGER; c: CHAR; forward: BOOLEAN);
VAR
length: INTEGER;
185,10 → 143,10
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(str)) & (str[i] # 0X) DO
i := LENGTH(str) - 1;
WHILE i >= 0 DO
cap(str[i]);
INC(i)
DEC(i)
END
END UpCase;

/programs/develop/oberon07/Source/TARGETS.ob07
24,13 → 24,19
Linux64* = 11;
Linux64SO* = 12;
STM32CM3* = 13;
RVM32I* = 14;
cpuX86* = 0; cpuAMD64* = 1; cpuMSP430* = 2; cpuTHUMB* = 3;
cpuRVM32I* = 4;
osNONE* = 0; osWIN32* = 1; osWIN64* = 2;
osLINUX32* = 3; osLINUX64* = 4; osKOS* = 5;
noDISPOSE = {MSP430, STM32CM3, RVM32I};
noRTL = {MSP430};
TYPE
STRING = ARRAY 32 OF CHAR;
37,7 → 43,7
TARGET = RECORD
target, CPU, BitDepth, OS, RealSize: INTEGER;
target, CPU, OS, RealSize: INTEGER;
ComLinePar*, LibDir, FileExt: STRING
END;
45,18 → 51,23
VAR
Targets*: ARRAY 14 OF TARGET;
Targets*: ARRAY 15 OF TARGET;
target*, CPU*, BitDepth*, OS*, RealSize*, WordSize*, AdrSize*: INTEGER;
CPUs: ARRAY 5 OF
RECORD
BitDepth, InstrSize: INTEGER;
LittleEndian: BOOLEAN
END;
target*, CPU*, BitDepth*, OS*, RealSize*, WordSize*, AdrSize*, InstrSize*: INTEGER;
ComLinePar*, LibDir*, FileExt*: STRING;
Import*, Dispose*, Dll*: BOOLEAN;
Import*, Dispose*, RTL*, Dll*, LittleEndian*: BOOLEAN;
PROCEDURE Enter (idx, CPU, BitDepth, RealSize, OS: INTEGER; ComLinePar, LibDir, FileExt: STRING);
PROCEDURE Enter (idx, CPU, RealSize, OS: INTEGER; ComLinePar, LibDir, FileExt: STRING);
BEGIN
Targets[idx].target := idx;
Targets[idx].CPU := CPU;
Targets[idx].BitDepth := BitDepth;
Targets[idx].RealSize := RealSize;
Targets[idx].OS := OS;
Targets[idx].ComLinePar := ComLinePar;
80,7 → 91,9
IF res THEN
target := Targets[i].target;
CPU := Targets[i].CPU;
BitDepth := Targets[i].BitDepth;
BitDepth := CPUs[CPU].BitDepth;
InstrSize := CPUs[CPU].InstrSize;
LittleEndian := CPUs[CPU].LittleEndian;
RealSize := Targets[i].RealSize;
OS := Targets[i].OS;
ComLinePar := Targets[i].ComLinePar;
88,7 → 101,8
FileExt := Targets[i].FileExt;
Import := OS IN {osWIN32, osWIN64, osKOS};
Dispose := ~(target IN {MSP430, STM32CM3});
Dispose := ~(target IN noDISPOSE);
RTL := ~(target IN noRTL);
Dll := target IN {Linux32SO, Linux64SO, Win32DLL, Win64DLL, KolibriOSDLL};
WordSize := BitDepth DIV 8;
AdrSize := WordSize
98,19 → 112,34
END Select;
PROCEDURE EnterCPU (cpu, BitDepth, InstrSize: INTEGER; LittleEndian: BOOLEAN);
BEGIN
Enter( MSP430, cpuMSP430, 16, 0, osNONE, "msp430", "MSP430", ".hex");
Enter( Win32C, cpuX86, 32, 8, osWIN32, "win32con", "Windows32", ".exe");
Enter( Win32GUI, cpuX86, 32, 8, osWIN32, "win32gui", "Windows32", ".exe");
Enter( Win32DLL, cpuX86, 32, 8, osWIN32, "win32dll", "Windows32", ".dll");
Enter( KolibriOS, cpuX86, 32, 8, osKOS, "kosexe", "KolibriOS", "");
Enter( KolibriOSDLL, cpuX86, 32, 8, osKOS, "kosdll", "KolibriOS", ".obj");
Enter( Win64C, cpuAMD64, 64, 8, osWIN64, "win64con", "Windows64", ".exe");
Enter( Win64GUI, cpuAMD64, 64, 8, osWIN64, "win64gui", "Windows64", ".exe");
Enter( Win64DLL, cpuAMD64, 64, 8, osWIN64, "win64dll", "Windows64", ".dll");
Enter( Linux32, cpuX86, 32, 8, osLINUX32, "linux32exe", "Linux32", "");
Enter( Linux32SO, cpuX86, 32, 8, osLINUX32, "linux32so", "Linux32", ".so");
Enter( Linux64, cpuAMD64, 64, 8, osLINUX64, "linux64exe", "Linux64", "");
Enter( Linux64SO, cpuAMD64, 64, 8, osLINUX64, "linux64so", "Linux64", ".so");
Enter( STM32CM3, cpuTHUMB, 32, 4, osNONE, "stm32cm3", "STM32CM3", ".hex");
CPUs[cpu].BitDepth := BitDepth;
CPUs[cpu].InstrSize := InstrSize;
CPUs[cpu].LittleEndian := LittleEndian
END EnterCPU;
BEGIN
EnterCPU(cpuX86, 32, 1, TRUE);
EnterCPU(cpuAMD64, 64, 1, TRUE);
EnterCPU(cpuMSP430, 16, 2, TRUE);
EnterCPU(cpuTHUMB, 32, 2, TRUE);
EnterCPU(cpuRVM32I, 32, 4, TRUE);
Enter( MSP430, cpuMSP430, 0, osNONE, "msp430", "MSP430", ".hex");
Enter( Win32C, cpuX86, 8, osWIN32, "win32con", "Windows32", ".exe");
Enter( Win32GUI, cpuX86, 8, osWIN32, "win32gui", "Windows32", ".exe");
Enter( Win32DLL, cpuX86, 8, osWIN32, "win32dll", "Windows32", ".dll");
Enter( KolibriOS, cpuX86, 8, osKOS, "kosexe", "KolibriOS", "");
Enter( KolibriOSDLL, cpuX86, 8, osKOS, "kosdll", "KolibriOS", ".obj");
Enter( Win64C, cpuAMD64, 8, osWIN64, "win64con", "Windows64", ".exe");
Enter( Win64GUI, cpuAMD64, 8, osWIN64, "win64gui", "Windows64", ".exe");
Enter( Win64DLL, cpuAMD64, 8, osWIN64, "win64dll", "Windows64", ".dll");
Enter( Linux32, cpuX86, 8, osLINUX32, "linux32exe", "Linux32", "");
Enter( Linux32SO, cpuX86, 8, osLINUX32, "linux32so", "Linux32", ".so");
Enter( Linux64, cpuAMD64, 8, osLINUX64, "linux64exe", "Linux64", "");
Enter( Linux64SO, cpuAMD64, 8, osLINUX64, "linux64so", "Linux64", ".so");
Enter( STM32CM3, cpuTHUMB, 4, osNONE, "stm32cm3", "STM32CM3", ".hex");
Enter( RVM32I, cpuRVM32I, 4, osNONE, "rvm32i", "RVM32I", ".bin");
END TARGETS.

/programs/develop/oberon07/Source/TEXTDRV.ob07
1,7 → 1,7
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
28,9 → 28,16
CR: BOOLEAN;
line*, col*: INTEGER;
ifc*: INTEGER;
elsec*: INTEGER;
eof*: BOOLEAN;
eol*: BOOLEAN;
peak*: CHAR
skip*: BOOLEAN;
peak*: CHAR;
_skip*,
_elsif*,
_else*: ARRAY 100 OF BOOLEAN;
fname*: ARRAY 2048 OF CHAR
END;
161,8 → 168,13
text.col := 1;
text.eof := FALSE;
text.eol := FALSE;
text.skip := FALSE;
text.ifc := 0;
text.elsec := 0;
text._skip[0] := FALSE;
text.peak := 0X;
text.file := FILES.open(name);
COPY(name, text.fname);
IF text.file # NIL THEN
load(text);
init(text)

/programs/develop/oberon07/Source/THUMB.ob07
616,14 → 616,14
PROCEDURE SetIV (idx, label, CodeAdr: INTEGER);
VAR
l, h: ANYCODE;
l, h: LISTS.ITEM;
BEGIN
l := CodeList.first(ANYCODE);
h := l.next(ANYCODE);
l := CodeList.first;
h := l.next;
WHILE idx > 0 DO
l := h.next(ANYCODE);
h := l.next(ANYCODE);
l := h.next;
h := l.next;
DEC(idx)
END;
label := BIN.GetLabel(program, label) * 2 + CodeAdr + 1;
784,8 → 784,9
PROCEDURE xchg (r1, r2: INTEGER);
BEGIN
push(r1); push(r2);
pop(r1); pop(r2)
push(r1);
mov(r1, r2);
pop(r2)
END xchg;
1092,7 → 1093,7
|IL.opCALLP:
UnOp(r1);
AddImm8(r1, 1);
AddImm8(r1, 1); (* Thumb mode *)
gen5(3, TRUE, FALSE, r1, 0); (* blx r1 *)
drop;
ASSERT(R.top = -1)
1176,7 → 1177,7
|IL.opERR:
call(genTrap)
|IL.opNOP:
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opSADR:
reloc(GetAnyReg(), BIN.RDATA + pic, stroffs + param2)
1347,37 → 1348,25
SetCC(jne, r1)
END
|IL.opACC:
IF (R.top # 0) OR (R.stk[0] # ACC) THEN
PushAll(0);
GetRegA;
pop(ACC);
DEC(R.pushed)
END
|IL.opDROP:
UnOp(r1);
drop
|IL.opJNZ:
|IL.opJNZ1:
UnOp(r1);
cbnz(r1, param1)
|IL.opJZ:
UnOp(r1);
cbz(r1, param1)
|IL.opJG:
UnOp(r1);
Tst(r1);
jcc(jg, param1)
|IL.opJE:
|IL.opJNZ:
UnOp(r1);
cbnz(r1, param1);
drop
|IL.opJNE:
|IL.opJZ:
UnOp(r1);
cbz(r1, param1);
drop
1435,10 → 1424,10
cc := cond(opcode);
next := cmd.next(COMMAND);
IF next.opcode = IL.opJE THEN
IF next.opcode = IL.opJNZ THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJNE THEN
ELSIF next.opcode = IL.opJZ THEN
jcc(inv0(cc), next.param1);
cmd := next
ELSE
1487,7 → 1476,7
END;
drop
|IL.opADDL, IL.opADDR:
|IL.opADDC:
UnOp(r1);
AddConst(r1, param2)
1761,7 → 1750,7
gen4(14, r2, r1); (* bic r1, r2 *)
drop
|IL.opADDSL, IL.opADDSR:
|IL.opADDSC:
MovConst(GetAnyReg(), param2);
BinOp(r1, r2);
gen4(12, r2, r1); (* orr r1, r2 *)
2014,7 → 2003,7
CallRTL(IL._fdivi, 2);
GetRegA
|IL.opADDF, IL.opADDFI:
|IL.opADDF:
PushAll(2);
CallRTL(IL._fadd, 2);
GetRegA
2336,8 → 2325,6
DataAdr, BssAdr, DataSize, BssSize, CodeSize: INTEGER;
File: WR.FILE;
BEGIN
IF target = TARGETS.STM32CM3 THEN
CortexM3
2387,12 → 2374,12
ERRORS.Error(204)
END;
File := WR.Create(outname);
WR.Create(outname);
HEX.Data2(File, program.code, 0, CodeSize, high(Target.FlashAdr));
HEX.End(File);
HEX.Data2(program.code, 0, CodeSize, high(Target.FlashAdr));
HEX.End;
WR.Close(File);
WR.Close;
C.StringLn("--------------------------------------------");
C.String( " rom: "); C.Int(CodeSize); C.String(" of "); C.Int(rom); C.String(" ("); C.Int(CodeSize * 100 DIV rom); C.StringLn("%)");

/programs/develop/oberon07/Source/UTILS.ob07
13,18 → 13,17
CONST
slash* = HOST.slash;
eol* = HOST.eol;
bit_depth* = HOST.bit_depth;
maxint* = HOST.maxint;
minint* = HOST.minint;
OS = HOST.OS;
min32* = -2147483647-1;
max32* = 2147483647;
vMajor* = 1;
vMinor* = 29;
vMinor* = 43;
FILE_EXT* = ".ob07";
RTL_NAME* = "RTL";
32,17 → 31,10
MAX_GLOBAL_SIZE* = 1600000000;
TYPE
DAYS = ARRAY 12, 31, 2 OF INTEGER;
VAR
time*: INTEGER;
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
target*:
61,9 → 53,7
bit_diff*: INTEGER;
days: DAYS;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF CHAR; bytes: INTEGER): INTEGER;
RETURN HOST.FileRead(F, Buffer, bytes)
END FileRead;
90,6 → 80,12
END FileOpen;
PROCEDURE chmod* (FName: ARRAY OF CHAR);
BEGIN
HOST.chmod(FName)
END chmod;
PROCEDURE GetArg* (i: INTEGER; VAR str: ARRAY OF CHAR);
BEGIN
HOST.GetArg(i, str)
134,25 → 130,8
END GetCurrentDirectory;
PROCEDURE GetUnixTime* (year, month, day, hour, min, sec: INTEGER): INTEGER;
RETURN ((year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4) * 86400 + hour * 3600 + min * 60 + sec
END GetUnixTime;
PROCEDURE UnixTime* (): INTEGER;
VAR
year, month, day, hour, min, sec: INTEGER;
res: INTEGER;
BEGIN
IF OS = "LINUX" THEN
res := HOST.UnixTime()
ELSE
HOST.now(year, month, day, hour, min, sec);
res := GetUnixTime(year, month, day, hour, min, sec)
END
RETURN res
RETURN HOST.UnixTime()
END UnixTime;
229,51 → 208,19
END Log2;
PROCEDURE init (VAR days: DAYS);
VAR
i, j, n0, n1: INTEGER;
PROCEDURE hexdgt* (n: BYTE): BYTE;
BEGIN
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
days[i, j, 0] := 0;
days[i, j, 1] := 0;
IF n < 10 THEN
INC(n, ORD("0"))
ELSE
INC(n, ORD("A") - 10)
END
END;
days[ 1, 28, 0] := -1;
RETURN n
END hexdgt;
FOR i := 0 TO 1 DO
days[ 1, 29, i] := -1;
days[ 1, 30, i] := -1;
days[ 3, 30, i] := -1;
days[ 5, 30, i] := -1;
days[ 8, 30, i] := -1;
days[10, 30, i] := -1;
END;
n0 := 0;
n1 := 0;
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
IF days[i, j, 0] = 0 THEN
days[i, j, 0] := n0;
INC(n0)
END;
IF days[i, j, 1] = 0 THEN
days[i, j, 1] := n1;
INC(n1)
END
END
END
END init;
BEGIN
time := GetTickCount();
COPY(HOST.eol, eol);
maxreal := HOST.maxreal;
init(days)
maxreal := HOST.maxreal
END UTILS.

/programs/develop/oberon07/Source/WRITER.ob07
1,7 → 1,7
(*
BSD 2-Clause License
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
10,20 → 10,16
IMPORT FILES, ERRORS, UTILS;
TYPE
FILE* = FILES.FILE;
VAR
counter*: INTEGER;
file: FILES.FILE;
PROCEDURE align (n, _align: INTEGER): INTEGER;
PROCEDURE align* (n, _align: INTEGER): INTEGER;
BEGIN
IF n MOD _align # 0 THEN
n := n + _align - (n MOD _align)
INC(n, _align - (n MOD _align))
END
RETURN n
30,7 → 26,7
END align;
PROCEDURE WriteByte* (file: FILE; n: BYTE);
PROCEDURE WriteByte* (n: BYTE);
BEGIN
IF FILES.WriteByte(file, n) THEN
INC(counter)
40,7 → 36,7
END WriteByte;
PROCEDURE Write* (file: FILE; chunk: ARRAY OF BYTE; bytes: INTEGER);
PROCEDURE Write* (chunk: ARRAY OF BYTE; bytes: INTEGER);
VAR
n: INTEGER;
53,36 → 49,36
END Write;
PROCEDURE Write64LE* (file: FILE; n: INTEGER);
PROCEDURE Write64LE* (n: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 7 DO
WriteByte(file, UTILS.Byte(n, i))
WriteByte(UTILS.Byte(n, i))
END
END Write64LE;
PROCEDURE Write32LE* (file: FILE; n: INTEGER);
PROCEDURE Write32LE* (n: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
WriteByte(file, UTILS.Byte(n, i))
WriteByte(UTILS.Byte(n, i))
END
END Write32LE;
PROCEDURE Write16LE* (file: FILE; n: INTEGER);
PROCEDURE Write16LE* (n: INTEGER);
BEGIN
WriteByte(file, UTILS.Byte(n, 0));
WriteByte(file, UTILS.Byte(n, 1))
WriteByte(UTILS.Byte(n, 0));
WriteByte(UTILS.Byte(n, 1))
END Write16LE;
PROCEDURE Padding* (file: FILE; FileAlignment: INTEGER);
PROCEDURE Padding* (FileAlignment: INTEGER);
VAR
i: INTEGER;
89,20 → 85,20
BEGIN
i := align(counter, FileAlignment) - counter;
WHILE i > 0 DO
WriteByte(file, 0);
WriteByte(0);
DEC(i)
END
END Padding;
PROCEDURE Create* (FileName: ARRAY OF CHAR): FILE;
PROCEDURE Create* (FileName: ARRAY OF CHAR);
BEGIN
counter := 0
RETURN FILES.create(FileName)
counter := 0;
file := FILES.create(FileName)
END Create;
PROCEDURE Close* (VAR file: FILE);
PROCEDURE Close*;
BEGIN
FILES.close(file)
END Close;

/programs/develop/oberon07/Source/X86.ob07
8,7 → 8,7
MODULE X86;
IMPORT IL, REG, UTILS, LISTS, BIN, PE32, KOS, MSCOFF, ELF, PROG,
CHL := CHUNKLISTS, PATHS, TARGETS;
CHL := CHUNKLISTS, PATHS, TARGETS, ERRORS;
CONST
22,6 → 22,8
esp = 4;
ebp = 5;
MAX_FR = 7;
sete = 94H; setne = 95H; setl = 9CH; setge = 9DH; setle = 9EH; setg = 9FH; setc = 92H; setnc = 93H;
je = 84H; jne = 85H; jl = 8CH; jge = 8DH; jle = 8EH; jg = 8FH; jb = 82H; jnb = 83H;
29,7 → 31,9
CODECHUNK = 8;
FPR_ERR = 41;
TYPE
COMMAND = IL.COMMAND;
92,7 → 96,11
tcount: INTEGER;
FR: ARRAY 1000 OF INTEGER;
fname: PATHS.PATH;
PROCEDURE OutByte* (n: BYTE);
VAR
c: CODE;
146,7 → 154,7
END OutWord;
PROCEDURE isByte (n: INTEGER): BOOLEAN;
PROCEDURE isByte* (n: INTEGER): BOOLEAN;
RETURN (-128 <= n) & (n <= 127)
END isByte;
182,24 → 190,24
END shift;
PROCEDURE mov (reg1, reg2: INTEGER);
PROCEDURE oprr (op: BYTE; reg1, reg2: INTEGER); (* op reg1, reg2 *)
BEGIN
OutByte2(89H, 0C0H + reg2 * 8 + reg1) (* mov reg1, reg2 *)
OutByte2(op, 0C0H + 8 * reg2 + reg1)
END oprr;
PROCEDURE mov (reg1, reg2: INTEGER); (* mov reg1, reg2 *)
BEGIN
oprr(89H, reg1, reg2)
END mov;
PROCEDURE xchg (reg1, reg2: INTEGER);
VAR
regs: SET;
PROCEDURE xchg (reg1, reg2: INTEGER); (* xchg reg1, reg2 *)
BEGIN
regs := {reg1, reg2};
IF regs = {eax, ecx} THEN
OutByte(91H) (* xchg eax, ecx *)
ELSIF regs = {eax, edx} THEN
OutByte(92H) (* xchg eax, edx *)
ELSIF regs = {ecx, edx} THEN
OutByte2(87H, 0D1H) (* xchg ecx, edx *)
IF eax IN {reg1, reg2} THEN
OutByte(90H + reg1 + reg2)
ELSE
oprr(87H, reg1, reg2)
END
END xchg;
216,14 → 224,24
END push;
PROCEDURE xor (reg1, reg2: INTEGER); (* xor reg1, reg2 *)
BEGIN
oprr(31H, reg1, reg2)
END xor;
PROCEDURE movrc (reg, n: INTEGER);
BEGIN
IF n = 0 THEN
xor(reg, reg)
ELSE
OutByte(0B8H + reg); (* mov reg, n *)
OutInt(n)
END
END movrc;
PROCEDURE pushc (n: INTEGER);
PROCEDURE pushc* (n: INTEGER);
BEGIN
OutByte(68H + short(n)); (* push n *)
OutIntByte(n)
248,67 → 266,85
END not;
PROCEDURE add (reg1, reg2: INTEGER);
PROCEDURE add (reg1, reg2: INTEGER); (* add reg1, reg2 *)
BEGIN
OutByte2(01H, 0C0H + reg2 * 8 + reg1) (* add reg1, reg2 *)
oprr(01H, reg1, reg2)
END add;
PROCEDURE andrc (reg, n: INTEGER);
PROCEDURE oprc* (op, reg, n: INTEGER);
BEGIN
OutByte2(81H + short(n), 0E0H + reg); (* and reg, n *)
IF (reg = eax) & ~isByte(n) THEN
CASE op OF
|0C0H: op := 05H (* add *)
|0E8H: op := 2DH (* sub *)
|0F8H: op := 3DH (* cmp *)
|0E0H: op := 25H (* and *)
|0C8H: op := 0DH (* or *)
|0F0H: op := 35H (* xor *)
END;
OutByte(op);
OutInt(n)
ELSE
OutByte2(81H + short(n), op + reg MOD 8);
OutIntByte(n)
END
END oprc;
PROCEDURE andrc (reg, n: INTEGER); (* and reg, n *)
BEGIN
oprc(0E0H, reg, n)
END andrc;
PROCEDURE orrc (reg, n: INTEGER);
PROCEDURE orrc (reg, n: INTEGER); (* or reg, n *)
BEGIN
OutByte2(81H + short(n), 0C8H + reg); (* or reg, n *)
OutIntByte(n)
oprc(0C8H, reg, n)
END orrc;
PROCEDURE addrc (reg, n: INTEGER);
PROCEDURE xorrc (reg, n: INTEGER); (* xor reg, n *)
BEGIN
OutByte2(81H + short(n), 0C0H + reg); (* add reg, n *)
OutIntByte(n)
END addrc;
oprc(0F0H, reg, n)
END xorrc;
PROCEDURE subrc (reg, n: INTEGER);
PROCEDURE addrc (reg, n: INTEGER); (* add reg, n *)
BEGIN
OutByte2(81H + short(n), 0E8H + reg); (* sub reg, n *)
OutIntByte(n)
END subrc;
oprc(0C0H, reg, n)
END addrc;
PROCEDURE cmprr (reg1, reg2: INTEGER);
PROCEDURE subrc (reg, n: INTEGER); (* sub reg, n *)
BEGIN
OutByte2(39H, 0C0H + reg2 * 8 + reg1) (* cmp reg1, reg2 *)
END cmprr;
oprc(0E8H, reg, n)
END subrc;
PROCEDURE cmprc (reg, n: INTEGER);
PROCEDURE cmprc (reg, n: INTEGER); (* cmp reg, n *)
BEGIN
IF n = 0 THEN
test(reg)
ELSE
OutByte2(81H + short(n), 0F8H + reg); (* cmp reg, n *)
OutIntByte(n)
oprc(0F8H, reg, n)
END
END cmprc;
PROCEDURE setcc (cond, reg: INTEGER);
PROCEDURE cmprr (reg1, reg2: INTEGER); (* cmp reg1, reg2 *)
BEGIN
OutByte3(0FH, cond, 0C0H + reg) (* setcc reg *)
END setcc;
oprr(39H, reg1, reg2)
END cmprr;
PROCEDURE xor (reg1, reg2: INTEGER);
PROCEDURE setcc* (cc, reg: INTEGER); (* setcc reg *)
BEGIN
OutByte2(31H, 0C0H + reg2 * 8 + reg1) (* xor reg1, reg2 *)
END xor;
IF reg >= 8 THEN
OutByte(41H)
END;
OutByte3(0FH, cc, 0C0H + reg MOD 8)
END setcc;
PROCEDURE ret*;
578,7 → 614,7
OutByte2(0DAH, 0E9H); (* fucompp *)
OutByte3(09BH, 0DFH, 0E0H); (* fstsw ax *)
OutByte(09EH); (* sahf *)
movrc(eax, 0)
OutByte(0B8H); OutInt(0) (* mov eax, 0 *)
END fcmp;
694,7 → 730,7
VAR
cmd, next: COMMAND;
reg1, reg2: INTEGER;
reg1, reg2, fr: INTEGER;
n, a, b, label, cc: INTEGER;
705,6 → 741,8
BEGIN
cmd := IL.codes.commands.first(COMMAND);
fr := -1;
WHILE cmd # NIL DO
param1 := cmd.param1;
738,16 → 776,18
ASSERT(R.top = -1)
|IL.opPRECALL:
n := param2;
IF (param1 # 0) & (n # 0) THEN
PushAll(0);
IF (param2 # 0) & (fr >= 0) THEN
subrc(esp, 8)
END;
WHILE n > 0 DO
INC(FR[0]);
FR[FR[0]] := fr + 1;
WHILE fr >= 0 DO
subrc(esp, 8);
OutByte3(0DDH, 01CH, 024H); (* fstp qword[esp] *)
DEC(n)
DEC(fr)
END;
PushAll(0)
ASSERT(fr = -1)
|IL.opALIGN16:
ASSERT(eax IN R.regs);
759,27 → 799,31
END;
push(eax)
|IL.opRES:
|IL.opRESF, IL.opRES:
ASSERT(R.top = -1);
GetRegA;
n := param2;
WHILE n > 0 DO
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *)
addrc(esp, 8);
DEC(n)
END
ASSERT(fr = -1);
n := FR[FR[0]]; DEC(FR[0]);
|IL.opRESF:
n := param2;
IF opcode = IL.opRESF THEN
INC(fr);
IF n > 0 THEN
OutByte3(0DDH, 5CH + long(n * 8), 24H);
OutIntByte(n * 8); (* fstp qword[esp + n*8] *)
DEC(fr);
INC(n)
END;
IF fr + n > MAX_FR THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END
ELSE
GetRegA
END;
WHILE n > 0 DO
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *)
addrc(esp, 8);
INC(fr);
DEC(n)
END
816,6 → 860,12
ASSERT(R.top = -1);
IF opcode = IL.opLEAVEF THEN
DEC(fr)
END;
ASSERT(fr = -1);
IF param1 > 0 THEN
mov(esp, ebp)
END;
849,9 → 899,8
END
|IL.opCLEANUP:
n := param2 * 4;
IF n # 0 THEN
addrc(esp, n)
IF param2 # 0 THEN
addrc(esp, param2 * 4)
END
|IL.opPOPSP:
863,9 → 912,14
|IL.opLABEL:
SetLabel(param1) (* L: *)
|IL.opNOP:
|IL.opNOP, IL.opAND, IL.opOR:
|IL.opGADR:
next := cmd.next(COMMAND);
IF next.opcode = IL.opADDC THEN
INC(param2, next.param2);
cmd := next
END;
reg1 := GetAnyReg();
IF pic THEN
Pic(reg1, BIN.PICBSS, param2)
875,7 → 929,12
END
|IL.opLADR:
next := cmd.next(COMMAND);
n := param2 * 4;
IF next.opcode = IL.opADDC THEN
INC(n, next.param2);
cmd := next
END;
OutByte2(8DH, 45H + GetAnyReg() * 8 + long(n)); (* lea reg1, dword[ebp + n] *)
OutIntByte(n)
907,7 → 966,6
drop
|IL.opVLOAD32:
n := param2 * 4;
reg1 := GetAnyReg();
movrm(reg1, ebp, param2 * 4);
movrm(reg1, reg1, 0)
979,7 → 1037,7
add(reg1, reg2);
drop
|IL.opADDL, IL.opADDR:
|IL.opADDC:
IF param2 # 0 THEN
UnOp(reg1);
next := cmd.next(COMMAND);
1010,18 → 1068,17
|IL.opSUB:
BinOp(reg1, reg2);
OutByte2(29H, 0C0H + reg2 * 8 + reg1); (* sub reg1, reg2 *)
oprr(29H, reg1, reg2); (* sub reg1, reg2 *)
drop
|IL.opSUBR, IL.opSUBL:
UnOp(reg1);
n := param2;
IF n = 1 THEN
IF param2 = 1 THEN
OutByte(48H + reg1) (* dec reg1 *)
ELSIF n = -1 THEN
ELSIF param2 = -1 THEN
OutByte(40H + reg1) (* inc reg1 *)
ELSIF n # 0 THEN
subrc(reg1, n)
ELSIF param2 # 0 THEN
subrc(reg1, param2)
END;
IF opcode = IL.opSUBL THEN
neg(reg1)
1179,10 → 1236,10
cc := cond(opcode);
next := cmd.next(COMMAND);
IF next.opcode = IL.opJE THEN
IF next.opcode = IL.opJNZ THEN
jcc(cc, next.param1);
cmd := next
ELSIF next.opcode = IL.opJNE THEN
ELSIF next.opcode = IL.opJZ THEN
jcc(inv0(cc), next.param1);
cmd := next
ELSE
1212,40 → 1269,27
END;
andrc(reg1, 1)
|IL.opACC:
IF (R.top # 0) OR (R.stk[0] # eax) THEN
PushAll(0);
GetRegA;
pop(eax);
DEC(R.pushed)
END
|IL.opDROP:
UnOp(reg1);
drop
|IL.opJNZ:
|IL.opJNZ1:
UnOp(reg1);
test(reg1);
jcc(jne, param1)
|IL.opJZ:
UnOp(reg1);
test(reg1);
jcc(je, param1)
|IL.opJG:
UnOp(reg1);
test(reg1);
jcc(jg, param1)
|IL.opJE:
|IL.opJNZ:
UnOp(reg1);
test(reg1);
jcc(jne, param1);
drop
|IL.opJNE:
|IL.opJZ:
UnOp(reg1);
test(reg1);
jcc(je, param1);
1389,7 → 1433,7
|IL.opMULS:
BinOp(reg1, reg2);
OutByte2(21H, 0C0H + reg2 * 8 + reg1); (* and reg1, reg2 *)
oprr(21H, reg1, reg2); (* and reg1, reg2 *)
drop
|IL.opMULSC:
1403,21 → 1447,20
|IL.opDIVSC:
UnOp(reg1);
OutByte2(81H + short(param2), 0F0H + reg1); (* xor reg1, n *)
OutIntByte(param2)
xorrc(reg1, param2)
|IL.opADDS:
BinOp(reg1, reg2);
OutByte2(9H, 0C0H + reg2 * 8 + reg1); (* or reg1, reg2 *)
oprr(9H, reg1, reg2); (* or reg1, reg2 *)
drop
|IL.opSUBS:
BinOp(reg1, reg2);
not(reg2);
OutByte2(21H, 0C0H + reg2 * 8 + reg1); (* and reg1, reg2 *)
oprr(21H, reg1, reg2); (* and reg1, reg2 *)
drop
|IL.opADDSL, IL.opADDSR:
|IL.opADDSC:
UnOp(reg1);
orrc(reg1, param2)
1508,9 → 1551,15
|IL.opMAXC, IL.opMINC:
UnOp(reg1);
cmprc(reg1, param2);
OutByte2(07DH + ORD(opcode = IL.opMINC), 5); (* jge/jle L *)
movrc(reg1, param2)
(* L: *)
label := NewLabel();
IF opcode = IL.opMINC THEN
cc := jle
ELSE
cc := jge
END;
jcc(cc, label);
movrc(reg1, param2);
SetLabel(label)
|IL.opIN, IL.opINR:
IF opcode = IL.opINR THEN
1824,15 → 1873,25
drop
|IL.opPUSHF:
ASSERT(fr >= 0);
DEC(fr);
subrc(esp, 8);
OutByte3(0DDH, 01CH, 024H) (* fstp qword[esp] *)
|IL.opLOADF:
INC(fr);
IF fr > MAX_FR THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
UnOp(reg1);
OutByte2(0DDH, reg1); (* fld qword[reg1] *)
drop
|IL.opCONSTF:
INC(fr);
IF fr > MAX_FR THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
float := cmd.float;
IF float = 0.0 THEN
OutByte2(0D9H, 0EEH) (* fldz *)
1850,35 → 1909,55
END
|IL.opSAVEF, IL.opSAVEFI:
ASSERT(fr >= 0);
DEC(fr);
UnOp(reg1);
OutByte2(0DDH, 018H + reg1); (* fstp qword[reg1] *)
drop
|IL.opADDF, IL.opADDFI:
|IL.opADDF:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0C1H) (* faddp st1, st *)
|IL.opSUBF:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0E9H) (* fsubp st1, st *)
|IL.opSUBFI:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0E1H) (* fsubrp st1, st *)
|IL.opMULF:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0C9H) (* fmulp st1, st *)
|IL.opDIVF:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0F9H) (* fdivp st1, st *)
|IL.opDIVFI:
ASSERT(fr >= 1);
DEC(fr);
OutByte2(0DEH, 0F1H) (* fdivrp st1, st *)
|IL.opUMINF:
ASSERT(fr >= 0);
OutByte2(0D9H, 0E0H) (* fchs *)
|IL.opFABS:
ASSERT(fr >= 0);
OutByte2(0D9H, 0E1H) (* fabs *)
|IL.opFLT:
INC(fr);
IF fr > MAX_FR THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
UnOp(reg1);
push(reg1);
OutByte3(0DBH, 004H, 024H); (* fild dword[esp] *)
1886,6 → 1965,8
drop
|IL.opFLOOR:
ASSERT(fr >= 0);
DEC(fr);
subrc(esp, 8);
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 004H); (* fstcw word[esp+4] *)
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 006H); (* fstcw word[esp+6] *)
1899,6 → 1980,8
addrc(esp, 4)
|IL.opEQF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 003H); (* jp L *)
setcc(sete, al)
1905,6 → 1988,8
(* L: *)
|IL.opNEF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 003H); (* jp L *)
setcc(setne, al)
1911,6 → 1996,8
(* L: *)
|IL.opLTF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 00EH); (* jp L *)
setcc(setc, al);
1921,6 → 2008,8
(* L: *)
|IL.opGTF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 00FH); (* jp L *)
setcc(setc, al);
1931,6 → 2020,8
(* L: *)
|IL.opLEF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 003H); (* jp L *)
setcc(setnc, al)
1937,6 → 2028,8
(* L: *)
|IL.opGEF:
ASSERT(fr >= 1);
DEC(fr, 2);
fcmp;
OutByte2(07AH, 010H); (* jp L *)
setcc(setc, al);
1948,6 → 2041,10
(* L: *)
|IL.opINF:
INC(fr);
IF fr > MAX_FR THEN
ERRORS.ErrorMsg(fname, param1, param2, FPR_ERR)
END;
pushc(7FF00000H);
pushc(0);
OutByte3(0DDH, 004H, 024H); (* fld qword[esp] *)
2076,6 → 2173,9
OutIntByte(n);
OutByte(param2)
|IL.opFNAME:
fname := cmd(IL.FNAMECMD).fname
|IL.opLOOP, IL.opENDLOOP:
END;
2084,8 → 2184,8
END;
ASSERT(R.pushed = 0);
ASSERT(R.top = -1)
ASSERT(R.top = -1);
ASSERT(fr = -1)
END translate;
2094,9 → 2194,9
reg1, entry, L, dcount: INTEGER;
BEGIN
entry := NewLabel();
SetLabel(entry);
dcount := CHL.Length(IL.codes.data);
IF target = TARGETS.Win32DLL THEN
push(ebp);
2106,19 → 2206,17
pushm(ebp, 8);
CallRTL(pic, IL._dllentry);
test(eax);
jcc(je, dllret)
jcc(je, dllret);
pushc(0)
ELSIF target = TARGETS.KolibriOSDLL THEN
SetLabel(dllinit)
END;
IF target = TARGETS.KolibriOS THEN
SetLabel(dllinit);
OutByte(68H); (* push IMPORT *)
Reloc(BIN.IMPTAB, 0)
ELSIF target = TARGETS.KolibriOS THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.IMPTAB, 0);
push(reg1); (* push IMPORT *)
drop
ELSIF target = TARGETS.KolibriOSDLL THEN
OutByte(68H); (* push IMPORT *)
Reloc(BIN.IMPTAB, 0)
ELSIF target = TARGETS.Linux32 THEN
push(esp)
ELSE
2129,39 → 2227,25
reg1 := GetAnyReg();
Pic(reg1, BIN.PICCODE, entry);
push(reg1); (* push CODE *)
drop
ELSE
OutByte(68H); (* push CODE *)
Reloc(BIN.RCODE, entry)
END;
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICDATA, 0);
push(reg1); (* push _data *)
drop
ELSE
OutByte(68H); (* push _data *)
Reloc(BIN.RDATA, 0)
END;
dcount := CHL.Length(IL.codes.data);
pushc(tcount);
IF pic THEN
reg1 := GetAnyReg();
Pic(reg1, BIN.PICDATA, tcount * 4 + dcount);
push(reg1); (* push _data + tcount * 4 + dcount *)
drop
ELSE
OutByte(68H); (* push CODE *)
Reloc(BIN.RCODE, entry);
OutByte(68H); (* push _data *)
Reloc(BIN.RDATA, 0);
pushc(tcount);
OutByte(68H); (* push _data + tcount * 4 + dcount *)
Reloc(BIN.RDATA, tcount * 4 + dcount)
END;
CallRTL(pic, IL._init);
IF target = TARGETS.Linux32 THEN
IF target IN {TARGETS.Win32C, TARGETS.Win32GUI, TARGETS.Linux32} THEN
L := NewLabel();
pushc(0);
push(esp);
2186,7 → 2270,7
dcount, i: INTEGER;
PROCEDURE import (imp: LISTS.LIST);
PROCEDURE _import (imp: LISTS.LIST);
VAR
lib: IL.IMPORT_LIB;
proc: IL.IMPORT_PROC;
2204,7 → 2288,7
lib := lib.next(IL.IMPORT_LIB)
END
END import;
END _import;
BEGIN
2256,12 → 2340,11
exp := exp.next(IL.EXPORT_PROC)
END;
import(IL.codes.import);
_import(IL.codes._import);
IL.set_bss(MAX(IL.codes.bss, MAX(IL.codes.dmin - CHL.Length(IL.codes.data), 4)));
BIN.SetParams(program, IL.codes.bss, stack * (1024 * 1024), WCHR(ver DIV 65536), WCHR(ver MOD 65536));
BIN.SetParams(program, IL.codes.bss, stack * (1024 * 1024), WCHR(ver DIV 65536), WCHR(ver MOD 65536))
END epilog;
2271,6 → 2354,7
opt: PROG.OPTIONS;
BEGIN
FR[0] := 0;
tcount := CHL.Length(IL.codes.types);
opt := options;

/programs/develop/oberon07/doc/CC.txt
0,0 → 1,36
Условная компиляция
синтаксис:
$IF "(" ident {"|" ident} ")"
<...>
{$ELSIF "(" ident {"|" ident} ")"}
<...>
[$ELSE]
<...>
$END
где ident:
- одно из возможных значений параметра <target> в командной строке
- пользовательский идентификатор, переданный с ключом -def при компиляции
примеры:
$IF (win64con | win64gui | win64dll)
OS := "WIN64";
$ELSIF (win32con | win32gui | win32dll)
OS := "WIN32";
$ELSIF (linux64exe | linux64so)
OS := "LINUX64";
$ELSIF (linux32exe | linux32so)
OS := "LINUX32";
$ELSE
OS := "UNKNOWN";
$END
$IF (CPUX86_64) (* -def CPUX86_64 *)
bit_depth := 64;
$ELSE
bit_depth := 32;
$END

/programs/develop/oberon07/doc/KOSLib.txt
0,0 → 1,566
==============================================================================
Библиотека (KolibriOS)
------------------------------------------------------------------------------
MODULE Out - консольный вывод
PROCEDURE Open
формально открывает консольный вывод
PROCEDURE Int(x, width: INTEGER)
вывод целого числа x;
width - количество знакомест, используемых для вывода
PROCEDURE Real(x: REAL; width: INTEGER)
вывод вещественного числа x в плавающем формате;
width - количество знакомест, используемых для вывода
PROCEDURE Char(x: CHAR)
вывод символа x
PROCEDURE FixReal(x: REAL; width, p: INTEGER)
вывод вещественного числа x в фиксированном формате;
width - количество знакомест, используемых для вывода;
p - количество знаков после десятичной точки
PROCEDURE Ln
переход на следующую строку
PROCEDURE String(s: ARRAY OF CHAR)
вывод строки s
------------------------------------------------------------------------------
MODULE In - консольный ввод
VAR Done: BOOLEAN
принимает значение TRUE в случае успешного выполнения
операции ввода, иначе FALSE
PROCEDURE Open
формально открывает консольный ввод,
также присваивает переменной Done значение TRUE
PROCEDURE Int(VAR x: INTEGER)
ввод числа типа INTEGER
PROCEDURE Char(VAR x: CHAR)
ввод символа
PROCEDURE Real(VAR x: REAL)
ввод числа типа REAL
PROCEDURE String(VAR s: ARRAY OF CHAR)
ввод строки
PROCEDURE Ln
ожидание нажатия ENTER
------------------------------------------------------------------------------
MODULE Console - дополнительные процедуры консольного вывода
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 Cls
очистка окна консоли
PROCEDURE SetColor(FColor, BColor: INTEGER)
установка цвета консольного вывода: FColor - цвет текста,
BColor - цвет фона, возможные значения - вышеперечисленные
константы
PROCEDURE SetCursor(x, y: INTEGER)
установка курсора консоли в позицию (x, y)
PROCEDURE GetCursor(VAR x, y: INTEGER)
записывает в параметры текущие координаты курсора консоли
PROCEDURE GetCursorX(): INTEGER
возвращает текущую x-координату курсора консоли
PROCEDURE GetCursorY(): INTEGER
возвращает текущую y-координату курсора консоли
------------------------------------------------------------------------------
MODULE ConsoleLib - обертка библиотеки console.obj
------------------------------------------------------------------------------
MODULE Math - математические функции
CONST
pi = 3.141592653589793E+00
e = 2.718281828459045E+00
PROCEDURE IsNan(x: REAL): BOOLEAN
возвращает TRUE, если x - не число
PROCEDURE IsInf(x: REAL): BOOLEAN
возвращает TRUE, если x - бесконечность
PROCEDURE sqrt(x: REAL): REAL
квадратный корень x
PROCEDURE exp(x: REAL): REAL
экспонента x
PROCEDURE ln(x: REAL): REAL
натуральный логарифм x
PROCEDURE sin(x: REAL): REAL
синус x
PROCEDURE cos(x: REAL): REAL
косинус x
PROCEDURE tan(x: REAL): REAL
тангенс x
PROCEDURE arcsin(x: REAL): REAL
арксинус x
PROCEDURE arccos(x: REAL): REAL
арккосинус x
PROCEDURE arctan(x: REAL): REAL
арктангенс x
PROCEDURE arctan2(y, x: REAL): REAL
арктангенс y/x
PROCEDURE power(base, exponent: REAL): REAL
возведение числа base в степень exponent
PROCEDURE log(base, x: REAL): REAL
логарифм x по основанию base
PROCEDURE sinh(x: REAL): REAL
гиперболический синус x
PROCEDURE cosh(x: REAL): REAL
гиперболический косинус x
PROCEDURE tanh(x: REAL): REAL
гиперболический тангенс x
PROCEDURE arsinh(x: REAL): REAL
обратный гиперболический синус x
PROCEDURE arcosh(x: REAL): REAL
обратный гиперболический косинус x
PROCEDURE artanh(x: REAL): REAL
обратный гиперболический тангенс x
PROCEDURE round(x: REAL): REAL
округление x до ближайшего целого
PROCEDURE frac(x: REAL): REAL;
дробная часть числа x
PROCEDURE floor(x: REAL): REAL
наибольшее целое число (представление как REAL),
не больше x: floor(1.2) = 1.0
PROCEDURE ceil(x: REAL): REAL
наименьшее целое число (представление как REAL),
не меньше x: ceil(1.2) = 2.0
PROCEDURE sgn(x: REAL): INTEGER
если x > 0 возвращает 1
если x < 0 возвращает -1
если x = 0 возвращает 0
PROCEDURE fact(n: INTEGER): REAL
факториал n
------------------------------------------------------------------------------
MODULE Debug - вывод на доску отладки
Интерфейс как модуль Out
PROCEDURE Open
открывает доску отладки
------------------------------------------------------------------------------
MODULE File - работа с файловой системой
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
CONST
SEEK_BEG = 0
SEEK_CUR = 1
SEEK_END = 2
PROCEDURE Load(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
Загружает в память файл с именем FName, записывает в параметр
size размер файла, возвращает адрес загруженного файла
или 0 (ошибка). При необходимости, распаковывает
файл (kunpack).
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN
Записывает структуру блока данных входа каталога для файла
или папки с именем FName в параметр Info.
При ошибке возвращает FALSE.
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN
возвращает TRUE, если файл с именем FName существует
PROCEDURE Close(VAR F: FS)
освобождает память, выделенную для информационной структуры
файла F и присваивает F значение NIL
PROCEDURE Open(FName: ARRAY OF CHAR): FS
возвращает указатель на информационную структуру файла с
именем FName, при ошибке возвращает NIL
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN
удаляет файл с именем FName, при ошибке возвращает FALSE
PROCEDURE Seek(F: FS; Offset, Origin: INTEGER): INTEGER
устанавливает позицию чтения-записи файла F на Offset,
относительно Origin = (SEEK_BEG - начало файла,
SEEK_CUR - текущая позиция, SEEK_END - конец файла),
возвращает позицию относительно начала файла, например:
Seek(F, 0, SEEK_END)
устанавливает позицию на конец файла и возвращает длину
файла; при ошибке возвращает -1
PROCEDURE Read(F: FS; Buffer, Count: INTEGER): INTEGER
Читает данные из файла в память. F - указатель на
информационную структуру файла, Buffer - адрес области
памяти, Count - количество байт, которое требуется прочитать
из файла; возвращает количество байт, которое было прочитано
и соответствующим образом изменяет позицию чтения/записи в
информационной структуре F.
PROCEDURE Write(F: FS; Buffer, Count: INTEGER): INTEGER
Записывает данные из памяти в файл. F - указатель на
информационную структуру файла, Buffer - адрес области
памяти, Count - количество байт, которое требуется записать
в файл; возвращает количество байт, которое было записано и
соответствующим образом изменяет позицию чтения/записи в
информационной структуре F.
PROCEDURE Create(FName: ARRAY OF CHAR): FS
создает новый файл с именем FName (полное имя), возвращает
указатель на информационную структуру файла,
при ошибке возвращает NIL
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN
создает папку с именем DirName, все промежуточные папки
должны существовать, при ошибке возвращает FALSE
PROCEDURE DeleteDir(DirName: ARRAY OF CHAR): BOOLEAN
удаляет пустую папку с именем DirName,
при ошибке возвращает FALSE
PROCEDURE DirExists(DirName: ARRAY OF CHAR): BOOLEAN
возвращает TRUE, если папка с именем DirName существует
------------------------------------------------------------------------------
MODULE Read - чтение основных типов данных из файла F
Процедуры возвращают TRUE в случае успешной операции чтения и
соответствующим образом изменяют позицию чтения/записи в
информационной структуре F
PROCEDURE Char(F: File.FS; VAR x: CHAR): BOOLEAN
PROCEDURE Int(F: File.FS; VAR x: INTEGER): BOOLEAN
PROCEDURE Real(F: File.FS; VAR x: REAL): BOOLEAN
PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN
PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN
PROCEDURE WChar(F: File.FS; VAR x: WCHAR): BOOLEAN
------------------------------------------------------------------------------
MODULE Write - запись основных типов данных в файл F
Процедуры возвращают TRUE в случае успешной операции записи и
соответствующим образом изменяют позицию чтения/записи в
информационной структуре F
PROCEDURE Char(F: File.FS; x: CHAR): BOOLEAN
PROCEDURE Int(F: File.FS; x: INTEGER): BOOLEAN
PROCEDURE Real(F: File.FS; x: REAL): BOOLEAN
PROCEDURE Boolean(F: File.FS; x: BOOLEAN): BOOLEAN
PROCEDURE Set(F: File.FS; x: SET): BOOLEAN
PROCEDURE WChar(F: File.FS; x: WCHAR): BOOLEAN
------------------------------------------------------------------------------
MODULE DateTime - дата, время
CONST ERR = -7.0E5
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER)
записывает в параметры компоненты текущей системной даты и
времени
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL
возвращает дату, полученную из компонентов
Year, Month, Day, Hour, Min, Sec;
при ошибке возвращает константу ERR = -7.0E5
PROCEDURE Decode(Date: REAL; VAR Year, Month, Day,
Hour, Min, Sec: INTEGER): BOOLEAN
извлекает компоненты
Year, Month, Day, Hour, Min, Sec из даты Date;
при ошибке возвращает FALSE
------------------------------------------------------------------------------
MODULE Args - параметры программы
VAR argc: INTEGER
количество параметров программы, включая имя
исполняемого файла
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR)
записывает в строку s n-й параметр программы,
нумерация параметров от 0 до argc - 1,
нулевой параметр -- имя исполняемого файла
------------------------------------------------------------------------------
MODULE KOSAPI
PROCEDURE sysfunc1(arg1: INTEGER): INTEGER
PROCEDURE sysfunc2(arg1, arg2: INTEGER): INTEGER
...
PROCEDURE sysfunc7(arg1, arg2, ..., arg7: INTEGER): INTEGER
Обертки для функций API ядра KolibriOS.
arg1 .. arg7 соответствуют регистрам
eax, ebx, ecx, edx, esi, edi, ebp;
возвращают значение регистра eax после системного вызова.
PROCEDURE sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER
Обертка для функций API ядра KolibriOS.
arg1 - регистр eax, arg2 - регистр ebx,
res2 - значение регистра ebx после системного вызова;
возвращает значение регистра eax после системного вызова.
PROCEDURE malloc(size: INTEGER): INTEGER
Выделяет блок памяти.
size - размер блока в байтах,
возвращает адрес выделенного блока
PROCEDURE free(ptr: INTEGER): INTEGER
Освобождает ранее выделенный блок памяти с адресом ptr,
возвращает 0
PROCEDURE realloc(ptr, size: INTEGER): INTEGER
Перераспределяет блок памяти,
ptr - адрес ранее выделенного блока,
size - новый размер,
возвращает указатель на перераспределенный блок,
0 при ошибке
PROCEDURE GetCommandLine(): INTEGER
Возвращает адрес строки параметров
PROCEDURE GetName(): INTEGER
Возвращает адрес строки с именем программы
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER
Загружает DLL с полным именем name. Возвращает адрес таблицы
экспорта. При ошибке возвращает 0.
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER
name - имя процедуры
lib - адрес таблицы экспорта DLL
Возвращает адрес процедуры. При ошибке возвращает 0.
------------------------------------------------------------------------------
MODULE ColorDlg - работа с диалогом "Color Dialog"
TYPE
Dialog = POINTER TO RECORD (* структура диалога *)
status: INTEGER (* состояние диалога:
0 - пользователь нажал Cancel
1 - пользователь нажал OK
2 - диалог открыт *)
color: INTEGER (* выбранный цвет *)
END
PROCEDURE Create(draw_window: DRAW_WINDOW): Dialog
создать диалог
draw_window - процедура перерисовки основного окна
(TYPE DRAW_WINDOW = PROCEDURE);
процедура возвращает указатель на структуру диалога
PROCEDURE Show(cd: Dialog)
показать диалог
cd - указатель на структуру диалога, который был создан ранее
процедурой Create
PROCEDURE Destroy(VAR cd: Dialog)
уничтожить диалог
cd - указатель на структуру диалога
------------------------------------------------------------------------------
MODULE OpenDlg - работа с диалогом "Open Dialog"
TYPE
Dialog = POINTER TO RECORD (* структура диалога *)
status: INTEGER (* состояние диалога:
0 - пользователь нажал Cancel
1 - пользователь нажал OK
2 - диалог открыт *)
FileName: ARRAY 4096 OF CHAR (* имя выбранного файла *)
FilePath: ARRAY 4096 OF CHAR (* полное имя выбранного
файла *)
END
PROCEDURE Create(draw_window: DRAW_WINDOW; type: INTEGER; def_path,
filter: ARRAY OF CHAR): Dialog
создать диалог
draw_window - процедура перерисовки основного окна
(TYPE DRAW_WINDOW = PROCEDURE)
type - тип диалога
0 - открыть
1 - сохранить
2 - выбрать папку
def_path - путь по умолчанию, папка def_path будет открыта
при первом запуске диалога
filter - в строке записано перечисление расширений файлов,
которые будут показаны в диалоговом окне, расширения
разделяются символом "|", например: "ASM|TXT|INI"
процедура возвращает указатель на структуру диалога
PROCEDURE Show(od: Dialog; Width, Height: INTEGER)
показать диалог
od - указатель на структуру диалога, который был создан ранее
процедурой Create
Width и Height - ширина и высота диалогового окна
PROCEDURE Destroy(VAR od: Dialog)
уничтожить диалог
od - указатель на структуру диалога
------------------------------------------------------------------------------
MODULE kfonts - работа с kf-шрифтами
CONST
bold = 1
italic = 2
underline = 4
strike_through = 8
smoothing = 16
bpp32 = 32
TYPE
TFont = POINTER TO TFont_desc (* указатель на шрифт *)
PROCEDURE LoadFont(file_name: ARRAY OF CHAR): TFont
загрузить шрифт из файла
file_name имя kf-файла
рез-т: указатель на шрифт/NIL (ошибка)
PROCEDURE SetSize(Font: TFont; font_size: INTEGER): BOOLEAN
установить размер шрифта
Font указатель на шрифт
font_size размер шрифта
рез-т: TRUE/FALSE (ошибка)
PROCEDURE Enabled(Font: TFont; font_size: INTEGER): BOOLEAN
проверить, есть ли шрифт, заданного размера
Font указатель на шрифт
font_size размер шрифта
рез-т: TRUE/FALSE (шрифта нет)
PROCEDURE Destroy(VAR Font: TFont)
выгрузить шрифт, освободить динамическую память
Font указатель на шрифт
Присваивает переменной Font значение NIL
PROCEDURE TextHeight(Font: TFont): INTEGER
получить высоту строки текста
Font указатель на шрифт
рез-т: высота строки текста в пикселях
PROCEDURE TextWidth(Font: TFont;
str, length, params: INTEGER): INTEGER
получить ширину строки текста
Font указатель на шрифт
str адрес строки текста в кодировке Win-1251
length количество символов в строке или -1, если строка
завершается нулем
params параметры-флаги см. ниже
рез-т: ширина строки текста в пикселях
PROCEDURE TextOut(Font: TFont;
canvas, x, y, str, length, color, params: INTEGER)
вывести текст в буфер
для вывода буфера в окно, использовать ф.65 или
ф.7 (если буфер 24-битный)
Font указатель на шрифт
canvas адрес графического буфера
структура буфера:
Xsize dd
Ysize dd
picture rb Xsize * Ysize * 4 (32 бита)
или Xsize * Ysize * 3 (24 бита)
x, y координаты текста относительно левого верхнего
угла буфера
str адрес строки текста в кодировке Win-1251
length количество символов в строке или -1, если строка
завершается нулем
color цвет текста 0x00RRGGBB
params параметры-флаги:
1 жирный
2 курсив
4 подчеркнутый
8 перечеркнутый
16 применить сглаживание
32 вывод в 32-битный буфер
возможно использование флагов в любых сочетаниях
------------------------------------------------------------------------------
MODULE RasterWorks - обертка библиотеки Rasterworks.obj
------------------------------------------------------------------------------
MODULE libimg - обертка библиотеки libimg.obj
------------------------------------------------------------------------------

/programs/develop/oberon07/doc/MSP430.txt
0,0 → 1,520
 Компилятор языка программирования Oberon-07/16 для
микроконтроллеров MSP430x{1,2}xx.
------------------------------------------------------------------------------
Параметры командной строки
Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI или
UTF-8 с BOM-сигнатурой.
Выход - hex-файл прошивки.
Параметры:
1) имя главного модуля
2) "msp430"
3) необязательные параметры-ключи
-out <file_name> имя результирующего файла; по умолчанию,
совпадает с именем главного модуля, но с расширением ".hex"
-ram <size> размер ОЗУ в байтах (128 - 2048) по умолчанию 128
-rom <size> размер ПЗУ в байтах (2048 - 24576) по умолчанию 2048
-nochk <"ptibcwra"> отключить проверки при выполнении
-lower разрешить ключевые слова и встроенные идентификаторы в
нижнем регистре
-def <имя> задать символ условной компиляции
параметр -nochk задается в виде строки из символов:
"p" - указатели
"t" - типы
"i" - индексы
"b" - неявное приведение INTEGER к BYTE
"c" - диапазон аргумента функции CHR
"a" - все проверки
Порядок символов может быть любым. Наличие в строке того или иного
символа отключает соответствующую проверку.
Например: -nochk it - отключить проверку индексов и охрану типа.
-nochk a - отключить все отключаемые проверки.
Например:
Compiler.exe "C:\example.ob07" msp430 -ram 128 -rom 4096 -nochk pti
Compiler.exe "C:\example.ob07" msp430 -out "C:\Ex1.hex" -ram 512 -rom 16384
В случае успешной компиляции, компилятор передает код завершения 0, иначе 1.
При работе компилятора в KolibriOS, код завершения не передается.
------------------------------------------------------------------------------
Отличия от оригинала
1. Расширен псевдомодуль SYSTEM
2. В идентификаторах допускается символ "_"
3. Усовершенствован оператор CASE (добавлены константные выражения в
метках вариантов и необязательная ветка ELSE)
4. Расширен набор стандартных процедур
5. Семантика охраны/проверки типа уточнена для нулевого указателя
6. Добавлены однострочные комментарии (начинаются с пары символов "//")
7. Разрешено наследование от типа-указателя
8. "Строки" можно заключать также в одиночные кавычки: 'строка'
9. Добавлена операция конкатенации строковых и символьных констант
10. Добавлены кодовые процедуры
11. Не реализована вещественная арифметика
------------------------------------------------------------------------------
Особенности реализации
1. Основные типы
Тип Диапазон значений Размер, байт
INTEGER -32768 .. 32767 2
CHAR символ ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET множество из целых чисел {0 .. 15} 2
BYTE 0 .. 255 1
2. Максимальная длина идентификаторов - 1024 символов
3. Максимальная длина строковых констант - 1024 символов (UTF-8)
4. Максимальная размерность открытых массивов - 5
5. Процедура NEW заполняет нулями выделенный блок памяти
6. Локальные переменные инициализируются нулями
7. В отличие от многих Oberon-реализаций, сборщик мусора и динамическая
модульность отсутствуют
8. Тип BYTE в выражениях всегда приводится к INTEGER
9. Контроль переполнения значений выражений не производится
10. Ошибки времени выполнения:
номер ошибка
1 ASSERT(x), при x = FALSE
2 разыменование нулевого указателя
3 целочисленное деление на неположительное число
4 вызов процедуры через процедурную переменную с нулевым значением
5 ошибка охраны типа
6 нарушение границ массива
7 непредусмотренное значение выражения в операторе CASE
8 ошибка копирования массивов v := x, если LEN(v) < LEN(x)
9 CHR(x), если (x < 0) OR (x > 255)
11 неявное приведение x:INTEGER к v:BYTE, если (x < 0) OR (x > 255)
------------------------------------------------------------------------------
Псевдомодуль SYSTEM
Псевдомодуль SYSTEM содержит низкоуровневые и небезопасные процедуры,
ошибки при использовании процедур псевдомодуля SYSTEM могут привести к
повреждению данных времени выполнения и аварийному завершению программы.
PROCEDURE ADR(v: любой тип): INTEGER
v - переменная или процедура;
возвращает адрес v
PROCEDURE SADR(x: строковая константа): INTEGER
возвращает адрес x
PROCEDURE SIZE(T): INTEGER
возвращает размер типа T
PROCEDURE TYPEID(T): INTEGER
T - тип-запись или тип-указатель,
возвращает номер типа в таблице типов-записей
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
PROCEDURE GET8(a: INTEGER; VAR x: INTEGER, SET, BYTE, CHAR)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 1)
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
Память[a] := x;
Если x: BYTE, то значение x будет расширено до 16 бит,
для записи байтов использовать SYSTEM.PUT8
PROCEDURE PUT8(a: INTEGER; x: INTEGER, SET, BYTE, CHAR)
Память[a] := младшие 8 бит (x)
PROCEDURE CODE(word1, word2,... : INTEGER)
Вставка машинного кода,
word1, word2 ... - целочисленные константы (константные
выражения) - машинные слова, например:
SYSTEM.CODE(0D032H, 0010H) (* BIS #16, SR; CPUOFF *)
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях.
------------------------------------------------------------------------------
Оператор CASE
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Сase {"|" Сase}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
Например:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
В метках вариантов можно использовать константные выражения, ветка ELSE
необязательна. Если значение x не соответствует ни одному варианту и ELSE
отсутствует, то программа прерывается с ошибкой времени выполнения.
------------------------------------------------------------------------------
Конкатенация строковых и символьных констант
Допускается конкатенация ("+") константных строк и символов типа CHAR:
str = CHR(39) + "string" + CHR(39); (* str = "'string'" *)
newline = 0DX + 0AX;
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
Оригинальное сообщение о языке не определяет поведение программы при
выполнении охраны p(T) и проверки типа p IS T при p = NIL. Во многих
Oberon-реализациях выполнение такой операции приводит к ошибке времени
выполнения. В данной реализации охрана типа нулевого указателя не приводит к
ошибке, а проверка типа дает результат FALSE. В ряде случаев это позволяет
значительно сократить частоту применения охраны типа.
------------------------------------------------------------------------------
Дополнительные стандартные процедуры
COPY (x: ARRAY OF CHAR; VAR v: ARRAY OF CHAR);
v := x;
Если LEN(v) < LEN(x), то строка x будет скопирована
не полностью.
LSR (x, n: INTEGER): INTEGER
Логический сдвиг x на n бит вправо.
MIN (a, b: INTEGER): INTEGER
Минимум из двух значений.
MAX (a, b: INTEGER): INTEGER
Максимум из двух значений.
BITS (x: INTEGER): SET
Интерпретирует x как значение типа SET.
Выполняется на этапе компиляции.
LENGTH (s: ARRAY OF CHAR): INTEGER
Длина 0X-завершенной строки s, без учета символа 0X.
Если символ 0X отсутствует, функция возвращает длину
массива s. s не может быть константой.
------------------------------------------------------------------------------
Использование регистров общего назначения R4 - R15
R4 - R7: регистровый стэк (промежуточные значения выражений)
R8 - R13: не используются
R14: указатель кучи
R15: используется при обработке прерываний
------------------------------------------------------------------------------
Вызов процедур и кадр стэка
Правила вызова похожи на соглашение cdecl (x86):
- параметры передаются через стэк справа налево
- результат, если есть, передается через регистр R4
- вызывающая процедура очищает стэк
Состояние стэка при выполнении процедуры:
меньшие адреса <- |var3|var2|var1|PC|arg1|arg2|arg3| -> бОльшие адреса
PC - значение регистра PC перед вызовом (адрес возврата)
argX - параметры в порядке объявления (слева направо)
varX - локальные переменные в порядке использования в процедуре
Размер каждого элемента в стэке (кроме локальных переменных структурных
типов) - 1 машинное слово (2 байта). Структурные переменные (массивы и
записи) занимают место в стэке в соответствии с их размером (с учетом
выравнивания).
Размещение локальных переменных зависит от их размеров и порядка
использования, и в общем случае неопределенно. Если переменная не
используется явно, то компилятор не выделяет для нее место в стэке.
------------------------------------------------------------------------------
Скрытые параметры процедур
Некоторые процедуры могут иметь скрытые параметры, они отсутствуют в списке
формальных параметров, но учитываются компилятором при трансляции вызовов.
Это возможно в следующих случаях:
1. Процедура имеет формальный параметр открытый массив:
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL);
Вызов транслируется так:
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x))
2. Процедура имеет формальный параметр-переменную типа RECORD:
PROCEDURE Proc (VAR x: Rec);
Вызов транслируется так:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
------------------------------------------------------------------------------
Кодовые процедуры
Компилятор поддерживает процедуры, написаные в машинных кодах.
Синтаксис:
PROCEDURE "[code]" имя [ (параметры): ТипРезультата ]
МашСлово, МашСлово,... МашСлово;
";" после заголовка и END "имя" в конце процедуры не ставятся.
МашСлово - целочисленная константа (в том числе и константное выражение).
Например:
PROCEDURE [code] asr (n, x: INTEGER): INTEGER (* ASR(x, n) -> R4 *)
4115H, 2, (* MOV 2(SP), R5; R5 <- n *)
4114H, 4, (* MOV 4(SP), R4; R4 <- x *)
0F035H, 15, (* AND #15, R5 *)
2400H + 3, (* JZ L1 *)
(* L2: *)
1104H, (* RRA R4 *)
8315H, (* SUB #1, R5 *)
2000H + 400H - 3; (* JNZ L2 *)
(* L1: *)
Компилятор автоматически добавляет к такой процедуре команду RET.
Способ передачи параметров и результата не изменяется.
Кодовые процедуры можно использовать также и для добавления в программу
константных данных:
PROCEDURE [code] sqr
0, 1, 4, 9, 16, 25, 36, 49, 64, 81;
Получить адрес такой "процедуры": SYSTEM.ADR(sqr).
Получить адрес n-го машинного слова: SYSTEM.ADR(sqr) + n * 2.
Чтобы использовать кодовые процедуры, необходимо импортировать псевдомодуль
SYSTEM.
------------------------------------------------------------------------------
Обработка прерываний
При появлении запроса на прерывание, процессор:
- помещает в стэк значение регистра PC
- помещает в стэк значение регистра SR
- очищает регистр SR
- выполняет переход по адресу IV[priority], где
IV - таблица векторов прерываний,
priority - приоритет прерывания (номер элемента в таблице IV) (0..30)
Компилятор генерирует код обработки прерываний:
; IV[0] = адрес следующей команды
PUSH #0 ; поместить в стэк приоритет прерывания
JMP Label ; перейти к обработчику
; IV[1] = адрес следующей команды
PUSH #1 ; поместить в стэк приоритет прерывания
JMP Label ; перейти к обработчику
...
; IV[priority] = адрес следующей команды
PUSH #priority ; поместить в стэк приоритет прерывания
JMP Label ; перейти к обработчику
...
; IV[30] = адрес следующей команды
PUSH #30 ; поместить в стэк приоритет прерывания
Label:
MOV SP, R15 ; настроить R15 на структуру данных прерывания (см. далее)
PUSH R4 ; сохранить рабочие регистры (R4 - R7)
...
PUSH R7
PUSH R15 ; передать параметр interrupt в обработчик (см. далее)
PUSH @R15 ; передать параметр priority в обработчик (см. далее)
CALL int ; вызвать обработчик (см. далее)
ADD #4, SP ; удалить из стэка параметры обработчика
POP R7 ; восстановить рабочие регистры (R7 - R4)
...
POP R4
ADD #2, SP ; удалить из стэка значение priority
RETI ; возврат из прерывания (восстановить SR и PC)
------------------------------------------------------------------------------
Обработка ошибок
В случае возникновения ошибки при выполнении программы, будет вызван общий
обработчик ошибок, который:
- запрещает прерывания
- сбрасывает стэк (во избежание переполнения в процессе обработки ошибки)
- передает параметры в пользовательский обработчик (см. далее)
- вызывает пользовательский обработчик (если он назначен)
- повторно запрещает прерывания
- выключает CPU и все тактовые сигналы
Если выключать CPU не требуется, то пользовательский обработчик может,
например, перезапустить программу.
------------------------------------------------------------------------------
Инициализация и финализация программы
В начало программы компилятор вставляет код, который:
- инициализирует регистры SP и R14
- выключает сторожевой таймер
- назначает пустой обработчик прерываний
- сбрасывает обработчик ошибок
В конец программы добавляет команду
BIS #16, SR; выключить CPU
------------------------------------------------------------------------------
Структура ОЗУ (RAM)
начало -> | спец. переменные | глобальные переменные | куча/стэк | <- конец
Компилятор поддерживает размер ОЗУ 128..2048 байт. В нижних адресах
располагаются специальные переменные, и далее пользовательские глобальные
переменные. Оставшаяся часть памяти отводится для кучи и стэка (не менее 64
байта). При старте программы, в регистр R14 записывается адрес начала области
кучи/стэка, а регистр SP настраивается на конец ОЗУ (начало_ОЗУ + размер_ОЗУ).
При выделении памяти процедурой NEW, значение регистра R14 увеличивается (если
есть свободная память). Таким образом, стэк и куча растут навстречу друг
другу. Проверка переполнения стэка не производится.
------------------------------------------------------------------------------
Структура ПЗУ (RОM)
начало -> |код|свободная область|спец. данные|векторы прерываний| <- конец
Компилятор поддерживает размер ПЗУ 2048..24576 байт. В верхних адресах
располагается таблица векторов прерываний (64 байта), адреса 0FFC0H..0FFFFH.
Непосредственно перед ней размещаются специальные данные. Программный
код начинается с адреса (10000H - размер_ПЗУ), этот адрес является также и
точкой входа в программу. Между кодом и спец. данными может оставаться
свободное пространство. Если размер ПЗУ больше, чем указан при компиляции,
то перед кодом будет свободная область. Таким способом можно зарезервировать
нижние сегменты флэш-памяти для записи во время выполнения программы.
==============================================================================
MODULE MSP430
CONST
биты регистра SR:
GIE = {3}
CPUOFF = {4}
OSCOFF = {5}
SCG0 = {6}
SCG1 = {7}
TYPE
TInterrupt = RECORD priority: INTEGER; sr: SET; pc: INTEGER END
структура данных прерывания
priority - приоритет прерывания:
адрес приоритет
0FFFEH 31
0FFFCH 30
0FFFAH 29
...
0FFC0H 0
sr - сохраненное значение регистра SR
pc - сохраненное значение регистра PC
TTrapProc = PROCEDURE (modNum, modName, err, line: INTEGER);
Процедура-обработчик ошибок.
modNum - номер модуля (в отчете о компиляции:
compiling (modNum) "modName" )
modName - адрес имени модуля
err - номер ошибки
line - номер строки
TIntProc = PROCEDURE (priority: INTEGER; interrupt: TInterrupt)
Процедура-обработчик прерываний.
priority - приоритет прерывания
interrupt - структура данных прерывания
PROCEDURE SetTrapProc (TrapProc: TTrapProc)
Назначить обработчик ошибок.
PROCEDURE SetIntProc (IntProc: TIntProc)
Назначить обработчик прерываний.
Нельзя вызывать эту процедуру с параметром NIL, т. к. для экономии
тактов, значение адреса обработчика прерываний не проверяется на NIL.
PROCEDURE Restart
Перезапустить программу.
При этом: очищается регистр SR, повторно выполняется код инициализации
программы (см. выше). Всё прочее состояние ОЗУ и регистров устройств
сохраняется.
PROCEDURE SetIntPC (interrupt: TInterrupt; NewPC: INTEGER)
interrupt.pc := NewPC
После возврата из прерывания, регистр PC получит значение NewPC.
PROCEDURE SetIntSR (interrupt: TInterrupt; NewSR: SET)
interrupt.sr := NewSR
После возврата из прерывания, регистр SR получит значение NewSR.
PROCEDURE DInt
Запретить прерывания.
PROCEDURE EInt
Разрешить прерывания.
PROCEDURE CpuOff
Выключить CPU (установить бит CPUOFF регистра SR).
PROCEDURE Halt
Запретить прерывания, выключить CPU и все тактовые сигналы.
PROCEDURE SetSR (bits: SET)
Установить биты bits регистра SR.
PROCEDURE ClrSR (bits: SET)
Сбросить биты bits регистра SR.
PROCEDURE GetFreeFlash (VAR address, size: INTEGER)
Получить адрес и размер свободной области Flash/ROM
(между кодом и данными).
PROCEDURE Delay (n: INTEGER)
Задержка выполнения программы на 1000*n тактов,
но не менее чем на 2000 тактов.
==============================================================================

/programs/develop/oberon07/doc/Oberon07.Report_2016_05_03.pdf
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/programs/develop/oberon07/doc/STM32.txt
0,0 → 1,404
 Компилятор языка программирования Oberon-07/16 для
микроконтроллеров STM32 Cortex-M3.
------------------------------------------------------------------------------
Параметры командной строки
Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI или
UTF-8 с BOM-сигнатурой.
Выход - hex-файл прошивки.
Параметры:
1) имя главного модуля
2) "stm32cm3"
3) необязательные параметры-ключи
-out <file_name> имя результирующего файла; по умолчанию,
совпадает с именем главного модуля, но с расширением ".hex"
-ram <size> размер ОЗУ в килобайтах (4 - 65536) по умолчанию 4
-rom <size> размер ПЗУ в килобайтах (16 - 65536) по умолчанию 16
-nochk <"ptibcwra"> отключить проверки при выполнении
-lower разрешить ключевые слова и встроенные идентификаторы в
нижнем регистре
-def <имя> задать символ условной компиляции
параметр -nochk задается в виде строки из символов:
"p" - указатели
"t" - типы
"i" - индексы
"b" - неявное приведение INTEGER к BYTE
"c" - диапазон аргумента функции CHR
"w" - диапазон аргумента функции WCHR
"r" - эквивалентно "bcw"
"a" - все проверки
Порядок символов может быть любым. Наличие в строке того или иного
символа отключает соответствующую проверку.
Например: -nochk it - отключить проверку индексов и охрану типа.
-nochk a - отключить все отключаемые проверки.
Например:
Compiler.exe "C:\example.ob07" stm32cm3 -ram 32 -rom 256 -nochk pti
Compiler.exe "C:\example.ob07" stm32cm3 -out "C:\Ex1.hex" -ram 8 -rom 32
В случае успешной компиляции, компилятор передает код завершения 0, иначе 1.
При работе компилятора в KolibriOS, код завершения не передается.
------------------------------------------------------------------------------
Отличия от оригинала
1. Расширен псевдомодуль SYSTEM
2. В идентификаторах допускается символ "_"
3. Усовершенствован оператор CASE (добавлены константные выражения в
метках вариантов и необязательная ветка ELSE)
4. Расширен набор стандартных процедур
5. Семантика охраны/проверки типа уточнена для нулевого указателя
6. Добавлены однострочные комментарии (начинаются с пары символов "//")
7. Разрешено наследование от типа-указателя
8. "Строки" можно заключать также в одиночные кавычки: 'строка'
9. Добавлен тип WCHAR
10. Добавлена операция конкатенации строковых и символьных констант
11. Добавлены кодовые процедуры
------------------------------------------------------------------------------
Особенности реализации
1. Основные типы
Тип Диапазон значений Размер, байт
INTEGER -2147483648 .. 2147483647 4
REAL 1.17E-38 .. 3.40E+38 4
CHAR символ ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET множество из целых чисел {0 .. 31} 4
BYTE 0 .. 255 1
WCHAR символ юникода (0X .. 0FFFFX) 2
2. Максимальная длина идентификаторов - 1024 символов
3. Максимальная длина строковых констант - 1024 символов (UTF-8)
4. Максимальная размерность открытых массивов - 5
5. Процедура NEW заполняет нулями выделенный блок памяти
6. Локальные переменные инициализируются нулями
7. В отличие от многих Oberon-реализаций, сборщик мусора и динамическая
модульность отсутствуют
8. Тип BYTE в выражениях всегда приводится к INTEGER
9. Контроль переполнения значений выражений не производится
------------------------------------------------------------------------------
Псевдомодуль SYSTEM
Псевдомодуль SYSTEM содержит низкоуровневые и небезопасные процедуры,
ошибки при использовании процедур псевдомодуля SYSTEM могут привести к
повреждению данных времени выполнения и аварийному завершению программы.
PROCEDURE ADR(v: любой тип): INTEGER
v - переменная или процедура;
возвращает адрес v
PROCEDURE SADR(x: строковая константа (CHAR UTF-8)): INTEGER
возвращает адрес x
PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER
возвращает адрес x
PROCEDURE SIZE(T): INTEGER
возвращает размер типа T
PROCEDURE TYPEID(T): INTEGER
T - тип-запись или тип-указатель,
возвращает номер типа в таблице типов-записей
PROCEDURE INF(): REAL
возвращает специальное вещественное значение "бесконечность"
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
PROCEDURE GET8(a: INTEGER;
VAR x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 1)
PROCEDURE GET16(a: INTEGER;
VAR x: INTEGER, SET, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 2)
PROCEDURE GET32(a: INTEGER; VAR x: INTEGER, SET, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 4)
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
Память[a] := x;
Если x: BYTE или x: WCHAR, то значение x будет расширено
до 32 бит, для записи байтов использовать SYSTEM.PUT8,
для WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 16 бит (x)
PROCEDURE PUT32(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 32 бит (x)
PROCEDURE CODE(hword1, hword2,... : INTEGER)
Вставка машинного кода,
hword1, hword2 ... - константы в диапазоне 0..65535,
например:
SYSTEM.CODE(0BF30H) (* wfi *)
Также, в модуле SYSTEM определен тип CARD32 (4 байта). Для типа CARD32 не
допускаются никакие явные операции, за исключением присваивания.
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях.
------------------------------------------------------------------------------
Оператор CASE
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Сase {"|" Сase}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
Например:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
В метках вариантов можно использовать константные выражения, ветка ELSE
необязательна. Если значение x не соответствует ни одному варианту и ELSE
отсутствует, то программа прерывается с ошибкой времени выполнения.
------------------------------------------------------------------------------
Тип WCHAR
Тип WCHAR добавлен в язык для удобной поддежки юникода. Для типов WCHAR и
ARRAY OF WCHAR допускаются все те же операции, как для типов CHAR и
ARRAY OF CHAR, за исключением встроенной процедуры CHR, которая возвращает
только тип CHAR. Для получения значения типа WCHAR, следует использовать
процедуру WCHR вместо CHR. Для правильной работы с типом, необходимо сохранять
исходный код в кодировке UTF-8 c BOM.
------------------------------------------------------------------------------
Конкатенация строковых и символьных констант
Допускается конкатенация ("+") константных строк и символов типа CHAR:
str = CHR(39) + "string" + CHR(39); (* str = "'string'" *)
newline = 0DX + 0AX;
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
Оригинальное сообщение о языке не определяет поведение программы при
выполнении охраны p(T) и проверки типа p IS T при p = NIL. Во многих
Oberon-реализациях выполнение такой операции приводит к ошибке времени
выполнения. В данной реализации охрана типа нулевого указателя не приводит к
ошибке, а проверка типа дает результат FALSE. В ряде случаев это позволяет
значительно сократить частоту применения охраны типа.
------------------------------------------------------------------------------
Дополнительные стандартные процедуры
COPY (x: ARRAY OF CHAR/WCHAR; VAR v: ARRAY OF CHAR/WCHAR);
v := x;
Если LEN(v) < LEN(x), то строка x будет скопирована
не полностью
LSR (x, n: INTEGER): INTEGER
Логический сдвиг x на n бит вправо.
MIN (a, b: INTEGER): INTEGER
Минимум из двух значений.
MAX (a, b: INTEGER): INTEGER
Максимум из двух значений.
BITS (x: INTEGER): SET
Интерпретирует x как значение типа SET.
Выполняется на этапе компиляции.
LENGTH (s: ARRAY OF CHAR/WCHAR): INTEGER
Длина 0X-завершенной строки s, без учета символа 0X.
Если символ 0X отсутствует, функция возвращает длину
массива s. s не может быть константой.
WCHR (n: INTEGER): WCHAR
Преобразование типа, аналогично CHR(n: INTEGER): CHAR
------------------------------------------------------------------------------
Использование регистров общего назначения R0 - R12
R0 - R3: регистровый стэк (промежуточные значения выражений)
R4 - R12: не используются
------------------------------------------------------------------------------
Вызов процедур и кадр стэка
Правила вызова похожи на соглашение cdecl (x86):
- параметры передаются через стэк справа налево
- результат, если есть, передается через регистр R0
- вызывающая процедура очищает стэк
Состояние стэка при выполнении процедуры:
меньшие адреса <- |var3|var2|var1|LR|arg1|arg2|arg3| -> бОльшие адреса
LR - сохраненный регистр LR (адрес возврата)
argX - параметры в порядке объявления (слева направо)
varX - локальные переменные в порядке использования в процедуре
Размер каждого элемента в стэке (кроме локальных переменных структурных
типов) - 1 машинное слово (4 байта). Структурные переменные (массивы и
записи) занимают место в стэке в соответствии с их размером (с учетом
выравнивания).
Размещение локальных переменных зависит от их размеров и порядка
использования, и в общем случае неопределенно. Если переменная не
используется явно, то компилятор не выделяет для нее место в стэке.
------------------------------------------------------------------------------
Скрытые параметры процедур
Некоторые процедуры могут иметь скрытые параметры, они отсутствуют в списке
формальных параметров, но учитываются компилятором при трансляции вызовов.
Это возможно в следующих случаях:
1. Процедура имеет формальный параметр открытый массив:
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL);
Вызов транслируется так:
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x))
2. Процедура имеет формальный параметр-переменную типа RECORD:
PROCEDURE Proc (VAR x: Rec);
Вызов транслируется так:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
------------------------------------------------------------------------------
Кодовые процедуры
Компилятор поддерживает процедуры, написаные в машинных кодах.
Синтаксис:
PROCEDURE "[code]" имя [ (параметры): ТипРезультата ]
МашКом, МашКом,... МашКом;
";" после заголовка и END "имя" в конце процедуры не ставятся.
МашКом - целочисленная константа [0..65535] (в том числе и константное
выражение).
Например:
PROCEDURE [code] WFI
0BF30H; (* wfi *)
Компилятор автоматически добавляет к такой процедуре команду возврата
(bx LR). Способ передачи параметров и результата не изменяется. Регистр LR,
при входе в процедуру не сохраняется.
Чтобы использовать кодовые процедуры, необходимо импортировать псевдомодуль
SYSTEM.
------------------------------------------------------------------------------
Обработка прерываний
При возникновении прерывания, будет вызван обработчик (если он объявлен).
Объявление обработчика:
PROCEDURE handler_name [iv]; (* процедура без параметров *)
iv - целочисленная константа (константное выражение), номер вектора прерывания
в таблице векторов, iv >= 2:
0 начальное значение SP
1 сброс
...
15 SysTick
...
59 TIM6
60 TIM7
...
например:
(* обработчик прерываний от TIM6 *)
PROCEDURE tim6 [59];
BEGIN
(* код обработки *)
END tim6;
Также, можно объявить общий обработчик (iv = 0), который будет вызван, если
не назначен индивидуальный. Общий обработчик получает параметр - номер вектора
прерывания. По значению этого параметра, обработчик должен определить источник
прерывания и выполнить соответствующие действия:
PROCEDURE handler (iv: INTEGER) [0];
BEGIN
IF iv = 59 THEN
(* TIM6 *)
ELSIF iv = 60 THEN
(* TIM7 *)
ELSIF ....
....
END
END handler;
В конец программы компилятор добавляет команду ожидания прерывания.
------------------------------------------------------------------------------
Обработка ошибок
В случае возникновения ошибки при выполнении программы, будет вызван
пользовательский обработчик (если он объявлен).
Объявление обработчика ошибок:
PROCEDURE trap (modNum, modName, err, line: INTEGER) [1];
BEGIN
END trap;
где,
modNum - номер модуля (в отчете о компиляции:
compiling (modNum) "modName" )
modName - адрес имени модуля
err - код ошибки
line - номер строки
Коды ошибок:
1 ASSERT(x), при x = FALSE
2 разыменование нулевого указателя
3 целочисленное деление на неположительное число
4 вызов процедуры через процедурную переменную с нулевым значением
5 ошибка охраны типа
6 нарушение границ массива
7 непредусмотренное значение выражения в операторе CASE
8 ошибка копирования массивов v := x, если LEN(v) < LEN(x)
9 CHR(x), если (x < 0) OR (x > 255)
10 WCHR(x), если (x < 0) OR (x > 65535)
11 неявное приведение x:INTEGER к v:BYTE, если (x < 0) OR (x > 255)
После возврата из обработчика программа будет перезапущена.
------------------------------------------------------------------------------

/programs/develop/oberon07/doc/WinLib.txt
0,0 → 1,312
==============================================================================
Библиотека (Windows)
------------------------------------------------------------------------------
MODULE Out - консольный вывод
PROCEDURE Open
открывает консольный вывод
PROCEDURE Int(x, width: INTEGER)
вывод целого числа x;
width - количество знакомест, используемых для вывода
PROCEDURE Real(x: REAL; width: INTEGER)
вывод вещественного числа x в плавающем формате;
width - количество знакомест, используемых для вывода
PROCEDURE Char(x: CHAR)
вывод символа x
PROCEDURE FixReal(x: REAL; width, p: INTEGER)
вывод вещественного числа x в фиксированном формате;
width - количество знакомест, используемых для вывода;
p - количество знаков после десятичной точки
PROCEDURE Ln
переход на следующую строку
PROCEDURE String(s: ARRAY OF CHAR)
вывод строки s (ASCII)
PROCEDURE StringW(s: ARRAY OF WCHAR)
вывод строки s (UTF-16)
------------------------------------------------------------------------------
MODULE In - консольный ввод
VAR Done: BOOLEAN
принимает значение TRUE в случае успешного выполнения
операции ввода и FALSE в противном случае
PROCEDURE Open
открывает консольный ввод,
также присваивает переменной Done значение TRUE
PROCEDURE Int(VAR x: INTEGER)
ввод числа типа INTEGER
PROCEDURE Char(VAR x: CHAR)
ввод символа
PROCEDURE Real(VAR x: REAL)
ввод числа типа REAL
PROCEDURE String(VAR s: ARRAY OF CHAR)
ввод строки
PROCEDURE Ln
ожидание нажатия ENTER
------------------------------------------------------------------------------
MODULE Console - дополнительные процедуры консольного вывода
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 Cls
очистка окна консоли
PROCEDURE SetColor(FColor, BColor: INTEGER)
установка цвета консольного вывода: FColor - цвет текста,
BColor - цвет фона, возможные значения - вышеперечисленные
константы
PROCEDURE SetCursor(x, y: INTEGER)
установка курсора консоли в позицию (x, y)
PROCEDURE GetCursor(VAR x, y: INTEGER)
записывает в параметры текущие координаты курсора консоли
PROCEDURE GetCursorX(): INTEGER
возвращает текущую x-координату курсора консоли
PROCEDURE GetCursorY(): INTEGER
возвращает текущую y-координату курсора консоли
------------------------------------------------------------------------------
MODULE Math - математические функции
CONST
pi = 3.141592653589793E+00
e = 2.718281828459045E+00
PROCEDURE IsNan(x: REAL): BOOLEAN
возвращает TRUE, если x - не число
PROCEDURE IsInf(x: REAL): BOOLEAN
возвращает TRUE, если x - бесконечность
PROCEDURE sqrt(x: REAL): REAL
квадратный корень x
PROCEDURE exp(x: REAL): REAL
экспонента x
PROCEDURE ln(x: REAL): REAL
натуральный логарифм x
PROCEDURE sin(x: REAL): REAL
синус x
PROCEDURE cos(x: REAL): REAL
косинус x
PROCEDURE tan(x: REAL): REAL
тангенс x
PROCEDURE arcsin(x: REAL): REAL
арксинус x
PROCEDURE arccos(x: REAL): REAL
арккосинус x
PROCEDURE arctan(x: REAL): REAL
арктангенс x
PROCEDURE arctan2(y, x: REAL): REAL
арктангенс y/x
PROCEDURE power(base, exponent: REAL): REAL
возведение числа base в степень exponent
PROCEDURE log(base, x: REAL): REAL
логарифм x по основанию base
PROCEDURE sinh(x: REAL): REAL
гиперболический синус x
PROCEDURE cosh(x: REAL): REAL
гиперболический косинус x
PROCEDURE tanh(x: REAL): REAL
гиперболический тангенс x
PROCEDURE arsinh(x: REAL): REAL
обратный гиперболический синус x
PROCEDURE arcosh(x: REAL): REAL
обратный гиперболический косинус x
PROCEDURE artanh(x: REAL): REAL
обратный гиперболический тангенс x
PROCEDURE round(x: REAL): REAL
округление x до ближайшего целого
PROCEDURE frac(x: REAL): REAL;
дробная часть числа x
PROCEDURE floor(x: REAL): REAL
наибольшее целое число (представление как REAL),
не больше x: floor(1.2) = 1.0
PROCEDURE ceil(x: REAL): REAL
наименьшее целое число (представление как REAL),
не меньше x: ceil(1.2) = 2.0
PROCEDURE sgn(x: REAL): INTEGER
если x > 0 возвращает 1
если x < 0 возвращает -1
если x = 0 возвращает 0
PROCEDURE fact(n: INTEGER): REAL
факториал n
------------------------------------------------------------------------------
MODULE File - работа с файловой системой
CONST
OPEN_R = 0
OPEN_W = 1
OPEN_RW = 2
SEEK_BEG = 0
SEEK_CUR = 1
SEEK_END = 2
PROCEDURE Create(FName: ARRAY OF CHAR): INTEGER
создает новый файл с именем FName (полное имя с путем),
открывет файл для записи и возвращает идентификатор файла
(целое число), в случае ошибки, возвращает -1
PROCEDURE Open(FName: ARRAY OF CHAR; Mode: INTEGER): INTEGER
открывает существующий файл с именем FName (полное имя с
путем) в режиме Mode = (OPEN_R (только чтение), OPEN_W
(только запись), OPEN_RW (чтение и запись)), возвращает
идентификатор файла (целое число), в случае ошибки,
возвращает -1
PROCEDURE Read(F, Buffer, Count: INTEGER): INTEGER
Читает данные из файла в память. F - числовой идентификатор
файла, Buffer - адрес области памяти, Count - количество байт,
которое требуется прочитать из файла; возвращает количество
байт, которое было прочитано из файла
PROCEDURE Write(F, Buffer, Count: INTEGER): INTEGER
Записывает данные из памяти в файл. F - числовой идентификатор
файла, Buffer - адрес области памяти, Count - количество байт,
которое требуется записать в файл; возвращает количество байт,
которое было записано в файл
PROCEDURE Seek(F, Offset, Origin: INTEGER): INTEGER
устанавливает позицию чтения-записи файла с идентификатором F
на Offset, относительно Origin = (SEEK_BEG - начало файла,
SEEK_CUR - текущая позиция, SEEK_END - конец файла),
возвращает позицию относительно начала файла, например:
Seek(F, 0, 2) - устанавливает позицию на конец файла и
возвращает длину файла; при ошибке возвращает -1
PROCEDURE Close(F: INTEGER)
закрывает ранее открытый файл с идентификатором F
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN
удаляет файл с именем FName (полное имя с путем),
возвращает TRUE, если файл успешно удален
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN
возвращает TRUE, если файл с именем FName (полное имя)
существует
PROCEDURE Load(FName: ARRAY OF CHAR; VAR Size: INTEGER): INTEGER
загружает в память существующий файл с именем FName (полное имя с
путем), возвращает адрес памяти, куда был загружен файл,
записывает размер файла в параметр Size;
при ошибке возвращает 0
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN
создает папку с именем DirName, все промежуточные папки
должны существовать. В случае ошибки, возвращает FALSE
PROCEDURE RemoveDir(DirName: ARRAY OF CHAR): BOOLEAN
удаляет пустую папку с именем DirName. В случае ошибки,
возвращает FALSE
PROCEDURE ExistsDir(DirName: ARRAY OF CHAR): BOOLEAN
возвращает TRUE, если папка с именем DirName существует
------------------------------------------------------------------------------
MODULE DateTime - дата, время
CONST ERR = -7.0E5
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec, MSec: INTEGER)
возвращает в параметрах компоненты текущей системной даты и
времени
PROCEDURE NowEncode(): REAL;
возвращает текущую системную дату и
время (представление REAL)
PROCEDURE Encode(Year, Month, Day,
Hour, Min, Sec, MSec: INTEGER): REAL
возвращает дату, полученную из компонентов
Year, Month, Day, Hour, Min, Sec, MSec;
при ошибке возвращает константу ERR = -7.0E5
PROCEDURE Decode(Date: REAL; VAR Year, Month, Day,
Hour, Min, Sec, MSec: INTEGER): BOOLEAN
извлекает компоненты
Year, Month, Day, Hour, Min, Sec, MSec из даты Date;
при ошибке возвращает FALSE
------------------------------------------------------------------------------
MODULE Args - параметры программы
VAR argc: INTEGER
количество параметров программы, включая имя
исполняемого файла
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR)
записывает в строку s n-й параметр программы,
нумерация параметров от 0 до argc - 1,
нулевой параметр -- имя исполняемого файла
------------------------------------------------------------------------------
MODULE Utils - разное
PROCEDURE Utf8To16(source: ARRAY OF CHAR;
VAR dest: ARRAY OF CHAR): INTEGER;
преобразует символы строки source из кодировки UTF-8 в
кодировку UTF-16, результат записывает в строку dest,
возвращает количество 16-битных символов, записанных в dest
PROCEDURE PutSeed(seed: INTEGER)
Инициализация генератора случайных чисел целым числом seed
PROCEDURE Rnd(range: INTEGER): INTEGER
Целые случайные числа в диапазоне 0 <= x < range
------------------------------------------------------------------------------
MODULE WINAPI - привязки к некоторым API-функциям Windows

/programs/develop/oberon07/doc/x86.txt
0,0 → 1,401
 Компилятор языка программирования Oberon-07/16 для i486
Windows/Linux/KolibriOS.
------------------------------------------------------------------------------
Параметры командной строки
Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI или
UTF-8 с BOM-сигнатурой.
Выход - испоняемый файл формата PE32, ELF или MENUET01/MSCOFF.
Параметры:
1) имя главного модуля
2) тип приложения
"win32con" - Windows console
"win32gui" - Windows GUI
"win32dll" - Windows DLL
"linux32exe" - Linux ELF-EXEC
"linux32so" - Linux ELF-SO
"kosexe" - KolibriOS
"kosdll" - KolibriOS DLL
3) необязательные параметры-ключи
-out <file_name> имя результирующего файла; по умолчанию,
совпадает с именем главного модуля, но с другим расширением
(соответствует типу исполняемого файла)
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб,
допустимо от 1 до 32 Мб)
-nochk <"ptibcwra"> отключить проверки при выполнении (см. ниже)
-lower разрешить ключевые слова и встроенные идентификаторы в
нижнем регистре
-def <имя> задать символ условной компиляции
-ver <major.minor> версия программы (только для kosdll)
параметр -nochk задается в виде строки из символов:
"p" - указатели
"t" - типы
"i" - индексы
"b" - неявное приведение INTEGER к BYTE
"c" - диапазон аргумента функции CHR
"w" - диапазон аргумента функции WCHR
"r" - эквивалентно "bcw"
"a" - все проверки
Порядок символов может быть любым. Наличие в строке того или иного
символа отключает соответствующую проверку.
Например: -nochk it - отключить проверку индексов и охрану типа.
-nochk a - отключить все отключаемые проверки.
Например:
Compiler.exe "C:\example.ob07" win32con -out "C:\example.exe" -stk 1
Compiler.exe "C:\example.ob07" win32dll -out "C:\example.dll"
Compiler.exe "C:\example.ob07" win32gui -out "C:\example.exe" -stk 4
Compiler.exe "C:\example.ob07" win32con -out "C:\example.exe" -nochk pti
Compiler.kex "/tmp0/1/example.ob07" kosexe -out "/tmp0/1/example.kex" -stk 4
Compiler.kex "/tmp0/1/example.ob07" kosdll -out "/tmp0/1/mydll.obj" -ver 2.7
Compiler.exe "C:\example.ob07" linux32exe -out "C:\example" -stk 1 -nochk a
В случае успешной компиляции, компилятор передает код завершения 0, иначе 1.
При работе компилятора в KolibriOS, код завершения не передается.
------------------------------------------------------------------------------
Отличия от оригинала
1. Расширен псевдомодуль SYSTEM
2. В идентификаторах допускается символ "_"
3. Добавлены системные флаги
4. Усовершенствован оператор CASE (добавлены константные выражения в
метках вариантов и необязательная ветка ELSE)
5. Расширен набор стандартных процедур
6. Семантика охраны/проверки типа уточнена для нулевого указателя
7. Добавлены однострочные комментарии (начинаются с пары символов "//")
8. Разрешено наследование от типа-указателя
9. Добавлен синтаксис для импорта процедур из внешних библиотек
10. "Строки" можно заключать также в одиночные кавычки: 'строка'
11. Добавлен тип WCHAR
12. Добавлена операция конкатенации строковых и символьных констант
------------------------------------------------------------------------------
Особенности реализации
1. Основные типы
Тип Диапазон значений Размер, байт
INTEGER -2147483648 .. 2147483647 4
REAL 4.94E-324 .. 1.70E+308 8
CHAR символ ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET множество из целых чисел {0 .. 31} 4
BYTE 0 .. 255 1
WCHAR символ юникода (0X .. 0FFFFX) 2
2. Максимальная длина идентификаторов - 1024 символов
3. Максимальная длина строковых констант - 1024 символов (UTF-8)
4. Максимальная размерность открытых массивов - 5
5. Процедура NEW заполняет нулями выделенный блок памяти
6. Глобальные и локальные переменные инициализируются нулями
7. В отличие от многих Oberon-реализаций, сборщик мусора и динамическая
модульность отсутствуют
8. Тип BYTE в выражениях всегда приводится к INTEGER
9. Контроль переполнения значений выражений не производится
10. Ошибки времени выполнения:
1 ASSERT(x), при x = FALSE
2 разыменование нулевого указателя
3 целочисленное деление на неположительное число
4 вызов процедуры через процедурную переменную с нулевым значением
5 ошибка охраны типа
6 нарушение границ массива
7 непредусмотренное значение выражения в операторе CASE
8 ошибка копирования массивов v := x, если LEN(v) < LEN(x)
9 CHR(x), если (x < 0) OR (x > 255)
10 WCHR(x), если (x < 0) OR (x > 65535)
11 неявное приведение x:INTEGER к v:BYTE, если (x < 0) OR (x > 255)
------------------------------------------------------------------------------
Псевдомодуль SYSTEM
Псевдомодуль SYSTEM содержит низкоуровневые и небезопасные процедуры,
ошибки при использовании процедур псевдомодуля SYSTEM могут привести к
повреждению данных времени выполнения и аварийному завершению программы.
PROCEDURE ADR(v: любой тип): INTEGER
v - переменная или процедура;
возвращает адрес v
PROCEDURE SADR(x: строковая константа (CHAR UTF-8)): INTEGER
возвращает адрес x
PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER
возвращает адрес x
PROCEDURE SIZE(T): INTEGER
возвращает размер типа T
PROCEDURE TYPEID(T): INTEGER
T - тип-запись или тип-указатель,
возвращает номер типа в таблице типов-записей
PROCEDURE INF(): REAL
возвращает специальное вещественное значение "бесконечность"
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
PROCEDURE GET8(a: INTEGER;
VAR x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 1)
PROCEDURE GET16(a: INTEGER;
VAR x: INTEGER, SET, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 2)
PROCEDURE GET32(a: INTEGER; VAR x: INTEGER, SET, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 4)
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
Память[a] := x;
Если x: BYTE или x: WCHAR, то значение x будет расширено
до 32 бит, для записи байтов использовать SYSTEM.PUT8,
для WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 16 бит (x)
PROCEDURE PUT32(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 32 бит (x)
PROCEDURE COPY(VAR Source: любой тип; VAR Dest: любой тип; n: INTEGER)
Копирует n байт памяти из Source в Dest.
Эквивалентно
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n)
PROCEDURE CODE(byte1, byte2,... : INTEGER)
Вставка машинного кода,
byte1, byte2 ... - константы в диапазоне 0..255,
например:
SYSTEM.CODE(08BH, 045H, 008H) (* mov eax, dword [ebp + 08h] *)
Также, в модуле SYSTEM определен тип CARD32 (4 байта). Для типа CARD32 не
допускаются никакие явные операции, за исключением присваивания.
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях.
------------------------------------------------------------------------------
Системные флаги
При объявлении процедурных типов и глобальных процедур, после ключевого
слова PROCEDURE может быть указан флаг соглашения о вызове: [stdcall],
[ccall], [ccall16], [windows], [linux], [oberon]. Например:
PROCEDURE [ccall] MyProc (x, y, z: INTEGER): INTEGER;
Если указан флаг [ccall16], то принимается соглашение ccall, но перед
вызовом указатель стэка будет выравнен по границе 16 байт.
Флаг [windows] - синоним для [stdcall], [linux] - синоним для [ccall16].
Знак "-" после имени флага ([stdcall-], [linux-], ...) означает, что
результат процедуры можно игнорировать (не допускается для типа REAL).
Если флаг не указан или указан флаг [oberon], то принимается внутреннее
соглашение о вызове.
При объявлении типов-записей, после ключевого слова RECORD может быть
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей
записи. Записи с системным флагом не могут иметь базовый тип и не могут быть
базовыми типами для других записей.
Для использования системных флагов, требуется импортировать SYSTEM.
------------------------------------------------------------------------------
Оператор CASE
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Сase {"|" Сase}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
Например:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
В метках вариантов можно использовать константные выражения, ветка ELSE
необязательна. Если значение x не соответствует ни одному варианту и ELSE
отсутствует, то программа прерывается с ошибкой времени выполнения.
------------------------------------------------------------------------------
Тип WCHAR
Тип WCHAR добавлен в язык для удобной поддежки юникода. Для типов WCHAR и
ARRAY OF WCHAR допускаются все те же операции, как для типов CHAR и
ARRAY OF CHAR, за исключением встроенной процедуры CHR, которая возвращает
только тип CHAR. Для получения значения типа WCHAR, следует использовать
процедуру WCHR вместо CHR. Для правильной работы с типом, необходимо сохранять
исходный код в кодировке UTF-8 c BOM.
------------------------------------------------------------------------------
Конкатенация строковых и символьных констант
Допускается конкатенация ("+") константных строк и символов типа CHAR:
str = CHR(39) + "string" + CHR(39); (* str = "'string'" *)
newline = 0DX + 0AX;
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
Оригинальное сообщение о языке не определяет поведение программы при
выполнении охраны p(T) и проверки типа p IS T при p = NIL. Во многих
Oberon-реализациях выполнение такой операции приводит к ошибке времени
выполнения. В данной реализации охрана типа нулевого указателя не приводит к
ошибке, а проверка типа дает результат FALSE. В ряде случаев это позволяет
значительно сократить частоту применения охраны типа.
------------------------------------------------------------------------------
Дополнительные стандартные процедуры
DISPOSE (VAR v: любой_указатель)
Освобождает память, выделенную процедурой NEW для
динамической переменной v^, и присваивает переменной v
значение NIL.
COPY (x: ARRAY OF CHAR/WCHAR; VAR v: ARRAY OF CHAR/WCHAR);
v := x;
Если LEN(v) < LEN(x), то строка x будет скопирована
не полностью
LSR (x, n: INTEGER): INTEGER
Логический сдвиг x на n бит вправо.
MIN (a, b: INTEGER): INTEGER
Минимум из двух значений.
MAX (a, b: INTEGER): INTEGER
Максимум из двух значений.
BITS (x: INTEGER): SET
Интерпретирует x как значение типа SET.
Выполняется на этапе компиляции.
LENGTH (s: ARRAY OF CHAR/WCHAR): INTEGER
Длина 0X-завершенной строки s, без учета символа 0X.
Если символ 0X отсутствует, функция возвращает длину
массива s. s не может быть константой.
WCHR (n: INTEGER): WCHAR
Преобразование типа, аналогично CHR(n: INTEGER): CHAR
------------------------------------------------------------------------------
Импортированные процедуры
Синтаксис импорта:
PROCEDURE [callconv, library, function] proc_name (FormalParam): Type;
- callconv -- соглашение о вызове
- library -- имя файла динамической библиотеки (строковая константа)
- function -- имя импортируемой процедуры (строковая константа), если
указана пустая строка, то имя процедуры = proc_name
например:
PROCEDURE [windows, "kernel32.dll", ""] ExitProcess (code: INTEGER);
PROCEDURE [stdcall, "Console.obj", "con_exit"] exit (bCloseWindow: BOOLEAN);
В конце объявления может быть добавлено (необязательно) "END proc_name;"
Объявления импортированных процедур должны располагаться в глобальной
области видимости модуля после объявления переменных, вместе с объявлением
"обычных" процедур, от которых импортированные отличаются только отсутствием
тела процедуры. В остальном, к таким процедурам применимы те же правила:
их можно вызвать, присвоить процедурной переменной или получить адрес.
Так как импортированная процедура всегда имеет явное указание соглашения о
вызове, то совместимый процедурный тип тоже должен быть объявлен с указанием
соглашения о вызове:
VAR
ExitProcess: PROCEDURE [windows] (code: INTEGER);
con_exit: PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
В KolibriOS импортировать процедуры можно только из библиотек, размещенных
в /rd/1/lib. Импортировать и вызывать функции инициализации библиотек
(lib_init, START) при этом не нужно.
Для Linux, импортированные процедуры не реализованы.
------------------------------------------------------------------------------
Скрытые параметры процедур
Некоторые процедуры могут иметь скрытые параметры, они отсутствуют в списке
формальных параметров, но учитываются компилятором при трансляции вызовов.
Это возможно в следующих случаях:
1. Процедура имеет формальный параметр открытый массив:
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL);
Вызов транслируется так:
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x))
2. Процедура имеет формальный параметр-переменную типа RECORD:
PROCEDURE Proc (VAR x: Rec);
Вызов транслируется так:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
Скрытые параметры необходимо учитывать при связи с внешними приложениями.
------------------------------------------------------------------------------
Модуль RTL
Все программы неявно используют модуль RTL. Компилятор транслирует
некоторые операции (проверка и охрана типа, сравнение строк, сообщения об
ошибках времени выполнения и др.) как вызовы процедур этого модуля. Не
следует вызывать эти процедуры явно.
Сообщения об ошибках времени выполнения выводятся в диалоговых окнах
(Windows), в терминал (Linux), на доску отладки (KolibriOS).
------------------------------------------------------------------------------
Модуль API
Существуют несколько реализаций модуля API (для различных ОС).
Как и модуль RTL, модуль API не предназначен для прямого использования.
Он обеспечивает связь RTL с ОС.
------------------------------------------------------------------------------
Генерация исполняемых файлов DLL
Разрешается экспортировать только процедуры. Для этого, процедура должна
находиться в главном модуле программы, и ее имя должно быть отмечено символом
экспорта ("*"). Нельзя экспортировать процедуры, которые импортированы из
других dll-библиотек.
KolibriOS DLL всегда экспортируют идентификаторы "version" (версия
программы) и "lib_init" - адрес процедуры инициализации DLL:
PROCEDURE [stdcall] lib_init (): INTEGER
Эта процедура должна быть вызвана перед использованием DLL.
Процедура всегда возвращает 1.

/programs/develop/oberon07/doc/x86_64.txt
0,0 → 1,381
 Компилятор языка программирования Oberon-07/16 для x86_64
Windows/Linux
------------------------------------------------------------------------------
Параметры командной строки
Вход - текстовые файлы модулей с расширением ".ob07", кодировка ANSI или
UTF-8 с BOM-сигнатурой.
Выход - испоняемый файл формата PE32+ или ELF64.
Параметры:
1) имя главного модуля
2) тип приложения
"win64con" - Windows64 console
"win64gui" - Windows64 GUI
"win64dll" - Windows64 DLL
"linux64exe" - Linux ELF64-EXEC
"linux64so" - Linux ELF64-SO
3) необязательные параметры-ключи
-out <file_name> имя результирующего файла; по умолчанию,
совпадает с именем главного модуля, но с другим расширением
(соответствует типу исполняемого файла)
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб,
допустимо от 1 до 32 Мб)
-nochk <"ptibcwra"> отключить проверки при выполнении
-lower разрешить ключевые слова и встроенные идентификаторы в
нижнем регистре
-def <имя> задать символ условной компиляции
параметр -nochk задается в виде строки из символов:
"p" - указатели
"t" - типы
"i" - индексы
"b" - неявное приведение INTEGER к BYTE
"c" - диапазон аргумента функции CHR
"w" - диапазон аргумента функции WCHR
"r" - эквивалентно "bcw"
"a" - все проверки
Порядок символов может быть любым. Наличие в строке того или иного
символа отключает соответствующую проверку.
Например: -nochk it - отключить проверку индексов и охрану типа.
-nochk a - отключить все отключаемые проверки.
Например:
Compiler.exe "C:\example.ob07" win64con -out "C:\example.exe" -stk 1
Compiler.exe "C:\example.ob07" win64dll -out "C:\example.dll" -nochk pti
Compiler "source/Compiler.ob07" linux64exe -out "source/Compiler" -nochk a
В случае успешной компиляции, компилятор передает код завершения 0, иначе 1.
------------------------------------------------------------------------------
Отличия от оригинала
1. Расширен псевдомодуль SYSTEM
2. В идентификаторах допускается символ "_"
3. Добавлены системные флаги
4. Усовершенствован оператор CASE (добавлены константные выражения в
метках вариантов и необязательная ветка ELSE)
5. Расширен набор стандартных процедур
6. Семантика охраны/проверки типа уточнена для нулевого указателя
7. Добавлены однострочные комментарии (начинаются с пары символов "//")
8. Разрешено наследование от типа-указателя
9. Добавлен синтаксис для импорта процедур из внешних библиотек
10. "Строки" можно заключать также в одиночные кавычки: 'строка'
11. Добавлен тип WCHAR
12. Добавлена операция конкатенации строковых и символьных констант
------------------------------------------------------------------------------
Особенности реализации
1. Основные типы
Тип Диапазон значений Размер, байт
INTEGER -9223372036854775808 .. 9223372036854775807 8
REAL 4.94E-324 .. 1.70E+308 8
CHAR символ ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET множество из целых чисел {0 .. 63} 8
BYTE 0 .. 255 1
WCHAR символ юникода (0X .. 0FFFFX) 2
2. Максимальная длина идентификаторов - 1024 символов
3. Максимальная длина строковых констант - 1024 символов (UTF-8)
4. Максимальная размерность открытых массивов - 5
5. Процедура NEW заполняет нулями выделенный блок памяти
6. Глобальные и локальные переменные инициализируются нулями
7. В отличие от многих Oberon-реализаций, сборщик мусора и динамическая
модульность отсутствуют
8. Тип BYTE в выражениях всегда приводится к INTEGER
9. Контроль переполнения значений выражений не производится
10. Ошибки времени выполнения:
1 ASSERT(x), при x = FALSE
2 разыменование нулевого указателя
3 целочисленное деление на неположительное число
4 вызов процедуры через процедурную переменную с нулевым значением
5 ошибка охраны типа
6 нарушение границ массива
7 непредусмотренное значение выражения в операторе CASE
8 ошибка копирования массивов v := x, если LEN(v) < LEN(x)
9 CHR(x), если (x < 0) OR (x > 255)
10 WCHR(x), если (x < 0) OR (x > 65535)
11 неявное приведение x:INTEGER к v:BYTE, если (x < 0) OR (x > 255)
------------------------------------------------------------------------------
Псевдомодуль SYSTEM
Псевдомодуль SYSTEM содержит низкоуровневые и небезопасные процедуры,
ошибки при использовании процедур псевдомодуля SYSTEM могут привести к
повреждению данных времени выполнения и аварийному завершению программы.
PROCEDURE ADR(v: любой тип): INTEGER
v - переменная или процедура;
возвращает адрес v
PROCEDURE SADR(x: строковая константа (CHAR UTF-8)): INTEGER
возвращает адрес x
PROCEDURE WSADR(x: строковая константа (WCHAR)): INTEGER
возвращает адрес x
PROCEDURE SIZE(T): INTEGER
возвращает размер типа T
PROCEDURE TYPEID(T): INTEGER
T - тип-запись или тип-указатель,
возвращает номер типа в таблице типов-записей
PROCEDURE INF(): REAL
возвращает специальное вещественное значение "бесконечность"
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Копирует n байт памяти из Source в Dest,
области Source и Dest не могут перекрываться
PROCEDURE GET(a: INTEGER;
VAR v: любой основной тип, PROCEDURE, POINTER)
v := Память[a]
PROCEDURE GET8(a: INTEGER;
VAR x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 1)
PROCEDURE GET16(a: INTEGER;
VAR x: INTEGER, SET, WCHAR, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 2)
PROCEDURE GET32(a: INTEGER; VAR x: INTEGER, SET, SYSTEM.CARD32)
Эквивалентно
SYSTEM.MOVE(a, SYSTEM.ADR(x), 4)
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
Память[a] := x;
Если x: BYTE или x: WCHAR, то значение x будет расширено
до 64 бит, для записи байтов использовать SYSTEM.PUT8,
для WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 16 бит (x)
PROCEDURE PUT32(a: INTEGER;
x: INTEGER, SET, BYTE, CHAR, WCHAR, SYSTEM.CARD32)
Память[a] := младшие 32 бит (x)
PROCEDURE COPY(VAR Source: любой тип; VAR Dest: любой тип; n: INTEGER)
Копирует n байт памяти из Source в Dest.
Эквивалентно
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n)
PROCEDURE CODE(byte1, byte2,... : BYTE)
Вставка машинного кода,
byte1, byte2 ... - константы в диапазоне 0..255,
например:
SYSTEM.CODE(048H,08BH,045H,010H) (* mov rax,qword[rbp+16] *)
Также, в модуле SYSTEM определен тип CARD32 (4 байта). Для типа CARD32 не
допускаются никакие явные операции, за исключением присваивания.
Функции псевдомодуля SYSTEM нельзя использовать в константных выражениях.
------------------------------------------------------------------------------
Системные флаги
При объявлении процедурных типов и глобальных процедур, после ключевого
слова PROCEDURE может быть указан флаг соглашения о вызове:
[win64], [systemv], [windows], [linux], [oberon].
Например:
PROCEDURE [win64] MyProc (x, y, z: INTEGER): INTEGER;
Флаг [windows] - синоним для [win64], [linux] - синоним для [systemv].
Знак "-" после имени флага ([win64-], [linux-], ...) означает, что
результат процедуры можно игнорировать (не допускается для типа REAL).
Если флаг не указан или указан флаг [oberon], то принимается внутреннее
соглашение о вызове. [win64] и [systemv] используются для связи с
операционной системой и внешними приложениями.
При объявлении типов-записей, после ключевого слова RECORD может быть
указан флаг [noalign]. Флаг [noalign] означает отсутствие выравнивания полей
записи. Записи с системным флагом не могут иметь базовый тип и не могут быть
базовыми типами для других записей.
Для использования системных флагов, требуется импортировать SYSTEM.
------------------------------------------------------------------------------
Оператор CASE
Синтаксис оператора CASE:
CaseStatement =
CASE Expression OF Сase {"|" Сase}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
Например:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
В метках вариантов можно использовать константные выражения, ветка ELSE
необязательна. Если значение x не соответствует ни одному варианту и ELSE
отсутствует, то программа прерывается с ошибкой времени выполнения.
------------------------------------------------------------------------------
Тип WCHAR
Тип WCHAR добавлен в язык для удобной поддежки юникода. Для типов WCHAR и
ARRAY OF WCHAR допускаются все те же операции, как для типов CHAR и
ARRAY OF CHAR, за исключением встроенной процедуры CHR, которая возвращает
только тип CHAR. Для получения значения типа WCHAR, следует использовать
процедуру WCHR вместо CHR. Для правильной работы с типом, необходимо сохранять
исходный код в кодировке UTF-8 c BOM.
------------------------------------------------------------------------------
Конкатенация строковых и символьных констант
Допускается конкатенация ("+") константных строк и символов типа CHAR:
str = CHR(39) + "string" + CHR(39); (* str = "'string'" *)
newline = 0DX + 0AX;
------------------------------------------------------------------------------
Проверка и охрана типа нулевого указателя
Оригинальное сообщение о языке не определяет поведение программы при
выполнении охраны p(T) и проверки типа p IS T при p = NIL. Во многих
Oberon-реализациях выполнение такой операции приводит к ошибке времени
выполнения. В данной реализации охрана типа нулевого указателя не приводит к
ошибке, а проверка типа дает результат FALSE. В ряде случаев это позволяет
значительно сократить частоту применения охраны типа.
------------------------------------------------------------------------------
Дополнительные стандартные процедуры
DISPOSE (VAR v: любой_указатель)
Освобождает память, выделенную процедурой NEW для
динамической переменной v^, и присваивает переменной v
значение NIL.
COPY (x: ARRAY OF CHAR/WCHAR; VAR v: ARRAY OF CHAR/WCHAR);
v := x;
Если LEN(v) < LEN(x), то строка x будет скопирована
не полностью
LSR (x, n: INTEGER): INTEGER
Логический сдвиг x на n бит вправо.
MIN (a, b: INTEGER): INTEGER
Минимум из двух значений.
MAX (a, b: INTEGER): INTEGER
Максимум из двух значений.
BITS (x: INTEGER): SET
Интерпретирует x как значение типа SET.
Выполняется на этапе компиляции.
LENGTH (s: ARRAY OF CHAR/WCHAR): INTEGER
Длина 0X-завершенной строки s, без учета символа 0X.
Если символ 0X отсутствует, функция возвращает длину
массива s. s не может быть константой.
WCHR (n: INTEGER): WCHAR
Преобразование типа, аналогично CHR(n: INTEGER): CHAR
------------------------------------------------------------------------------
Импортированные процедуры
Синтаксис импорта:
PROCEDURE [callconv, library, function] proc_name (FormalParam): Type;
- callconv -- соглашение о вызове
- library -- имя файла динамической библиотеки (строковая константа)
- function -- имя импортируемой процедуры (строковая константа), если
указана пустая строка, то имя процедуры = proc_name
например:
PROCEDURE [windows, "kernel32.dll", "ExitProcess"] exit (code: INTEGER);
PROCEDURE [windows, "kernel32.dll", ""] GetTickCount (): INTEGER;
В конце объявления может быть добавлено (необязательно) "END proc_name;"
Объявления импортированных процедур должны располагаться в глобальной
области видимости модуля после объявления переменных, вместе с объявлением
"обычных" процедур, от которых импортированные отличаются только отсутствием
тела процедуры. В остальном, к таким процедурам применимы те же правила:
их можно вызвать, присвоить процедурной переменной или получить адрес.
Так как импортированная процедура всегда имеет явное указание соглашения о
вызове, то совместимый процедурный тип тоже должен быть объявлен с указанием
соглашения о вызове:
VAR
ExitProcess: PROCEDURE [windows] (code: INTEGER);
Для Linux, импортированные процедуры не реализованы.
------------------------------------------------------------------------------
Скрытые параметры процедур
Некоторые процедуры могут иметь скрытые параметры, они отсутствуют в списке
формальных параметров, но учитываются компилятором при трансляции вызовов.
Это возможно в следующих случаях:
1. Процедура имеет формальный параметр открытый массив:
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL);
Вызов транслируется так:
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x))
2. Процедура имеет формальный параметр-переменную типа RECORD:
PROCEDURE Proc (VAR x: Rec);
Вызов транслируется так:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
Скрытые параметры необходимо учитывать при связи с внешними приложениями.
------------------------------------------------------------------------------
Модуль RTL
Все программы неявно используют модуль RTL. Компилятор транслирует
некоторые операции (проверка и охрана типа, сравнение строк, сообщения об
ошибках времени выполнения и др.) как вызовы процедур этого модуля. Не
следует вызывать эти процедуры явно.
Сообщения об ошибках времени выполнения выводятся в диалоговых окнах
(Windows), в терминал (Linux).
------------------------------------------------------------------------------
Модуль API
Существуют несколько реализаций модуля API (для различных ОС).
Как и модуль RTL, модуль API не предназначен для прямого использования.
Он обеспечивает связь RTL с ОС.
------------------------------------------------------------------------------
Генерация исполняемых файлов DLL
Разрешается экспортировать только процедуры. Для этого, процедура должна
находиться в главном модуле программы, ее имя должно быть отмечено символом
экспорта ("*") и должно быть указано соглашение о вызове. Нельзя
экспортировать процедуры, которые импортированы из других dll-библиотек.

/programs/develop/oberon07/tools/RVM32I.ob07
0,0 → 1,575
(*
BSD 2-Clause License
Copyright (c) 2020, Anton Krotov
All rights reserved.
*)
(*
RVM32I executor and disassembler
for win32 only
Usage:
RVM32I.exe <program file> -run [program parameters]
RVM32I.exe <program file> -dis <output file>
*)
MODULE RVM32I;
IMPORT SYSTEM, File, Args, Out, API, HOST, RTL;
CONST
opSTOP = 0; opRET = 1; opENTER = 2; opNEG = 3; opNOT = 4; opABS = 5;
opXCHG = 6; opLDR8 = 7; opLDR16 = 8; opLDR32 = 9; opPUSH = 10; opPUSHC = 11;
opPOP = 12; opJGZ = 13; opJZ = 14; opJNZ = 15; opLLA = 16; opJGA = 17;
opJLA = 18; opJMP = 19; opCALL = 20; opCALLI = 21;
opMOV = 22; opMUL = 24; opADD = 26; opSUB = 28; opDIV = 30; opMOD = 32;
opSTR8 = 34; opSTR16 = 36; opSTR32 = 38; opINCL = 40; opEXCL = 42;
opIN = 44; opAND = 46; opOR = 48; opXOR = 50; opASR = 52; opLSR = 54;
opLSL = 56; opROR = 58; opMIN = 60; opMAX = 62; opEQ = 64; opNE = 66;
opLT = 68; opLE = 70; opGT = 72; opGE = 74; opBT = 76;
opMOVC = 23; opMULC = 25; opADDC = 27; opSUBC = 29; opDIVC = 31; opMODC = 33;
opSTR8C = 35; opSTR16C = 37; opSTR32C = 39; opINCLC = 41; opEXCLC = 43;
opINC = 45; opANDC = 47; opORC = 49; opXORC = 51; opASRC = 53; opLSRC = 55;
opLSLC = 57; opRORC = 59; opMINC = 61; opMAXC = 63; opEQC = 65; opNEC = 67;
opLTC = 69; opLEC = 71; opGTC = 73; opGEC = 75; opBTC = 77;
opLEA = 78; opLABEL = 79; opSYSCALL = 80;
ACC = 0; BP = 3; SP = 4;
Types = 0;
Strings = 1;
Global = 2;
Heap = 3;
Stack = 4;
TYPE
COMMAND = POINTER TO RECORD
op, param1, param2: INTEGER;
next: COMMAND
END;
VAR
R: ARRAY 32 OF INTEGER;
Sections: ARRAY 5 OF RECORD address: INTEGER; name: ARRAY 16 OF CHAR END;
first, last: COMMAND;
Labels: ARRAY 30000 OF COMMAND;
F: INTEGER; buf: ARRAY 65536 OF BYTE; cnt: INTEGER;
PROCEDURE syscall (ptr: INTEGER);
VAR
fn, p1, p2, p3, p4, r: INTEGER;
proc2: PROCEDURE (a, b: INTEGER): INTEGER;
proc3: PROCEDURE (a, b, c: INTEGER): INTEGER;
proc4: PROCEDURE (a, b, c, d: INTEGER): INTEGER;
BEGIN
SYSTEM.GET(ptr, fn);
SYSTEM.GET(ptr + 4, p1);
SYSTEM.GET(ptr + 8, p2);
SYSTEM.GET(ptr + 12, p3);
SYSTEM.GET(ptr + 16, p4);
CASE fn OF
| 0: HOST.ExitProcess(p1)
| 1: SYSTEM.PUT(SYSTEM.ADR(proc2), SYSTEM.ADR(HOST.GetCurrentDirectory));
r := proc2(p1, p2)
| 2: SYSTEM.PUT(SYSTEM.ADR(proc3), SYSTEM.ADR(HOST.GetArg));
r := proc3(p1 + 2, p2, p3)
| 3: SYSTEM.PUT(SYSTEM.ADR(proc4), SYSTEM.ADR(HOST.FileRead));
SYSTEM.PUT(ptr, proc4(p1, p2, p3, p4))
| 4: SYSTEM.PUT(SYSTEM.ADR(proc4), SYSTEM.ADR(HOST.FileWrite));
SYSTEM.PUT(ptr, proc4(p1, p2, p3, p4))
| 5: SYSTEM.PUT(SYSTEM.ADR(proc2), SYSTEM.ADR(HOST.FileCreate));
SYSTEM.PUT(ptr, proc2(p1, p2))
| 6: HOST.FileClose(p1)
| 7: SYSTEM.PUT(SYSTEM.ADR(proc2), SYSTEM.ADR(HOST.FileOpen));
SYSTEM.PUT(ptr, proc2(p1, p2))
| 8: HOST.OutChar(CHR(p1))
| 9: SYSTEM.PUT(ptr, HOST.GetTickCount())
|10: SYSTEM.PUT(ptr, HOST.UnixTime())
|11: SYSTEM.PUT(SYSTEM.ADR(proc2), SYSTEM.ADR(HOST.isRelative));
SYSTEM.PUT(ptr, proc2(p1, p2))
|12: SYSTEM.PUT(SYSTEM.ADR(proc2), SYSTEM.ADR(HOST.chmod));
r := proc2(p1, p2)
END
END syscall;
PROCEDURE exec;
VAR
cmd: COMMAND;
param1, param2: INTEGER;
temp: INTEGER;
BEGIN
cmd := first;
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
CASE cmd.op OF
|opSTOP: cmd := last
|opRET: SYSTEM.MOVE(R[SP], SYSTEM.ADR(cmd), 4); INC(R[SP], 4)
|opENTER: DEC(R[SP], 4); SYSTEM.PUT32(R[SP], R[BP]); R[BP] := R[SP]; WHILE param1 > 0 DO DEC(R[SP], 4); SYSTEM.PUT32(R[SP], 0); DEC(param1) END
|opPOP: SYSTEM.GET32(R[SP], R[param1]); INC(R[SP], 4)
|opNEG: R[param1] := -R[param1]
|opNOT: R[param1] := ORD(-BITS(R[param1]))
|opABS: R[param1] := ABS(R[param1])
|opXCHG: temp := R[param1]; R[param1] := R[param2]; R[param2] := temp
|opLDR8: SYSTEM.GET8(R[param2], R[param1]); R[param1] := R[param1] MOD 256;
|opLDR16: SYSTEM.GET16(R[param2], R[param1]); R[param1] := R[param1] MOD 65536;
|opLDR32: SYSTEM.GET32(R[param2], R[param1])
|opPUSH: DEC(R[SP], 4); SYSTEM.PUT32(R[SP], R[param1])
|opPUSHC: DEC(R[SP], 4); SYSTEM.PUT32(R[SP], param1)
|opJGZ: IF R[param1] > 0 THEN cmd := Labels[cmd.param2] END
|opJZ: IF R[param1] = 0 THEN cmd := Labels[cmd.param2] END
|opJNZ: IF R[param1] # 0 THEN cmd := Labels[cmd.param2] END
|opLLA: SYSTEM.MOVE(SYSTEM.ADR(Labels[cmd.param2]), SYSTEM.ADR(R[param1]), 4)
|opJGA: IF R[ACC] > param1 THEN cmd := Labels[cmd.param2] END
|opJLA: IF R[ACC] < param1 THEN cmd := Labels[cmd.param2] END
|opJMP: cmd := Labels[cmd.param1]
|opCALL: DEC(R[SP], 4); SYSTEM.MOVE(SYSTEM.ADR(cmd), R[SP], 4); cmd := Labels[cmd.param1]
|opCALLI: DEC(R[SP], 4); SYSTEM.MOVE(SYSTEM.ADR(cmd), R[SP], 4); SYSTEM.MOVE(SYSTEM.ADR(R[param1]), SYSTEM.ADR(cmd), 4)
|opMOV: R[param1] := R[param2]
|opMOVC: R[param1] := param2
|opMUL: R[param1] := R[param1] * R[param2]
|opMULC: R[param1] := R[param1] * param2
|opADD: INC(R[param1], R[param2])
|opADDC: INC(R[param1], param2)
|opSUB: DEC(R[param1], R[param2])
|opSUBC: DEC(R[param1], param2)
|opDIV: R[param1] := R[param1] DIV R[param2]
|opDIVC: R[param1] := R[param1] DIV param2
|opMOD: R[param1] := R[param1] MOD R[param2]
|opMODC: R[param1] := R[param1] MOD param2
|opSTR8: SYSTEM.PUT8(R[param1], R[param2])
|opSTR8C: SYSTEM.PUT8(R[param1], param2)
|opSTR16: SYSTEM.PUT16(R[param1], R[param2])
|opSTR16C: SYSTEM.PUT16(R[param1], param2)
|opSTR32: SYSTEM.PUT32(R[param1], R[param2])
|opSTR32C: SYSTEM.PUT32(R[param1], param2)
|opINCL: SYSTEM.GET32(R[param1], temp); SYSTEM.PUT32(R[param1], ORD(BITS(temp) + {R[param2]}))
|opINCLC: SYSTEM.GET32(R[param1], temp); SYSTEM.PUT32(R[param1], ORD(BITS(temp) + {param2}))
|opEXCL: SYSTEM.GET32(R[param1], temp); SYSTEM.PUT32(R[param1], ORD(BITS(temp) - {R[param2]}))
|opEXCLC: SYSTEM.GET32(R[param1], temp); SYSTEM.PUT32(R[param1], ORD(BITS(temp) - {param2}))
|opIN: R[param1] := ORD(R[param1] IN BITS(R[param2]))
|opINC: R[param1] := ORD(R[param1] IN BITS(param2))
|opAND: R[param1] := ORD(BITS(R[param1]) * BITS(R[param2]))
|opANDC: R[param1] := ORD(BITS(R[param1]) * BITS(param2))
|opOR: R[param1] := ORD(BITS(R[param1]) + BITS(R[param2]))
|opORC: R[param1] := ORD(BITS(R[param1]) + BITS(param2))
|opXOR: R[param1] := ORD(BITS(R[param1]) / BITS(R[param2]))
|opXORC: R[param1] := ORD(BITS(R[param1]) / BITS(param2))
|opASR: R[param1] := ASR(R[param1], R[param2])
|opASRC: R[param1] := ASR(R[param1], param2)
|opLSR: R[param1] := LSR(R[param1], R[param2])
|opLSRC: R[param1] := LSR(R[param1], param2)
|opLSL: R[param1] := LSL(R[param1], R[param2])
|opLSLC: R[param1] := LSL(R[param1], param2)
|opROR: R[param1] := ROR(R[param1], R[param2])
|opRORC: R[param1] := ROR(R[param1], param2)
|opMIN: R[param1] := MIN(R[param1], R[param2])
|opMINC: R[param1] := MIN(R[param1], param2)
|opMAX: R[param1] := MAX(R[param1], R[param2])
|opMAXC: R[param1] := MAX(R[param1], param2)
|opEQ: R[param1] := ORD(R[param1] = R[param2])
|opEQC: R[param1] := ORD(R[param1] = param2)
|opNE: R[param1] := ORD(R[param1] # R[param2])
|opNEC: R[param1] := ORD(R[param1] # param2)
|opLT: R[param1] := ORD(R[param1] < R[param2])
|opLTC: R[param1] := ORD(R[param1] < param2)
|opLE: R[param1] := ORD(R[param1] <= R[param2])
|opLEC: R[param1] := ORD(R[param1] <= param2)
|opGT: R[param1] := ORD(R[param1] > R[param2])
|opGTC: R[param1] := ORD(R[param1] > param2)
|opGE: R[param1] := ORD(R[param1] >= R[param2])
|opGEC: R[param1] := ORD(R[param1] >= param2)
|opBT: R[param1] := ORD((R[param1] < R[param2]) & (R[param1] >= 0))
|opBTC: R[param1] := ORD((R[param1] < param2) & (R[param1] >= 0))
|opLEA: R[param1 MOD 256] := Sections[param1 DIV 256].address + param2
|opLABEL:
|opSYSCALL: syscall(R[param1])
END;
cmd := cmd.next
END
END exec;
PROCEDURE disasm (name: ARRAY OF CHAR; t_count, c_count, glob, heap: INTEGER);
VAR
cmd: COMMAND;
param1, param2, i, t, ptr: INTEGER;
b: BYTE;
PROCEDURE String (s: ARRAY OF CHAR);
VAR
n: INTEGER;
BEGIN
n := LENGTH(s);
IF n > LEN(buf) - cnt THEN
ASSERT(File.Write(F, SYSTEM.ADR(buf[0]), cnt) = cnt);
cnt := 0
END;
SYSTEM.MOVE(SYSTEM.ADR(s[0]), SYSTEM.ADR(buf[0]) + cnt, n);
INC(cnt, n)
END String;
PROCEDURE Ln;
BEGIN
String(0DX + 0AX)
END Ln;
PROCEDURE hexdgt (n: INTEGER): CHAR;
BEGIN
IF n < 10 THEN
INC(n, ORD("0"))
ELSE
INC(n, ORD("A") - 10)
END
RETURN CHR(n)
END hexdgt;
PROCEDURE Hex (x: INTEGER);
VAR
str: ARRAY 11 OF CHAR;
n: INTEGER;
BEGIN
n := 10;
str[10] := 0X;
WHILE n > 2 DO
str[n - 1] := hexdgt(x MOD 16);
x := x DIV 16;
DEC(n)
END;
str[1] := "x";
str[0] := "0";
String(str)
END Hex;
PROCEDURE Byte (x: BYTE);
VAR
str: ARRAY 5 OF CHAR;
BEGIN
str[4] := 0X;
str[3] := hexdgt(x MOD 16);
str[2] := hexdgt(x DIV 16);
str[1] := "x";
str[0] := "0";
String(str)
END Byte;
PROCEDURE Reg (n: INTEGER);
VAR
s: ARRAY 2 OF CHAR;
BEGIN
IF n = BP THEN
String("BP")
ELSIF n = SP THEN
String("SP")
ELSE
String("R");
s[1] := 0X;
IF n >= 10 THEN
s[0] := CHR(n DIV 10 + ORD("0"));
String(s)
END;
s[0] := CHR(n MOD 10 + ORD("0"));
String(s)
END
END Reg;
PROCEDURE Reg2 (r1, r2: INTEGER);
BEGIN
Reg(r1); String(", "); Reg(r2)
END Reg2;
PROCEDURE RegC (r, c: INTEGER);
BEGIN
Reg(r); String(", "); Hex(c)
END RegC;
PROCEDURE RegL (r, label: INTEGER);
BEGIN
Reg(r); String(", L"); Hex(label)
END RegL;
BEGIN
Sections[Types].name := "TYPES";
Sections[Strings].name := "STRINGS";
Sections[Global].name := "GLOBAL";
Sections[Heap].name := "HEAP";
Sections[Stack].name := "STACK";
F := File.Create(name);
ASSERT(F > 0);
cnt := 0;
String("CODE:"); Ln;
cmd := first;
WHILE cmd # NIL DO
param1 := cmd.param1;
param2 := cmd.param2;
CASE cmd.op OF
|opSTOP: String("STOP")
|opRET: String("RET")
|opENTER: String("ENTER "); Hex(param1)
|opPOP: String("POP "); Reg(param1)
|opNEG: String("NEG "); Reg(param1)
|opNOT: String("NOT "); Reg(param1)
|opABS: String("ABS "); Reg(param1)
|opXCHG: String("XCHG "); Reg2(param1, param2)
|opLDR8: String("LDR8 "); Reg2(param1, param2)
|opLDR16: String("LDR16 "); Reg2(param1, param2)
|opLDR32: String("LDR32 "); Reg2(param1, param2)
|opPUSH: String("PUSH "); Reg(param1)
|opPUSHC: String("PUSH "); Hex(param1)
|opJGZ: String("JGZ "); RegL(param1, param2)
|opJZ: String("JZ "); RegL(param1, param2)
|opJNZ: String("JNZ "); RegL(param1, param2)
|opLLA: String("LLA "); RegL(param1, param2)
|opJGA: String("JGA "); Hex(param1); String(", L"); Hex(param2)
|opJLA: String("JLA "); Hex(param1); String(", L"); Hex(param2)
|opJMP: String("JMP L"); Hex(param1)
|opCALL: String("CALL L"); Hex(param1)
|opCALLI: String("CALL "); Reg(param1)
|opMOV: String("MOV "); Reg2(param1, param2)
|opMOVC: String("MOV "); RegC(param1, param2)
|opMUL: String("MUL "); Reg2(param1, param2)
|opMULC: String("MUL "); RegC(param1, param2)
|opADD: String("ADD "); Reg2(param1, param2)
|opADDC: String("ADD "); RegC(param1, param2)
|opSUB: String("SUB "); Reg2(param1, param2)
|opSUBC: String("SUB "); RegC(param1, param2)
|opDIV: String("DIV "); Reg2(param1, param2)
|opDIVC: String("DIV "); RegC(param1, param2)
|opMOD: String("MOD "); Reg2(param1, param2)
|opMODC: String("MOD "); RegC(param1, param2)
|opSTR8: String("STR8 "); Reg2(param1, param2)
|opSTR8C: String("STR8 "); RegC(param1, param2)
|opSTR16: String("STR16 "); Reg2(param1, param2)
|opSTR16C: String("STR16 "); RegC(param1, param2)
|opSTR32: String("STR32 "); Reg2(param1, param2)
|opSTR32C: String("STR32 "); RegC(param1, param2)
|opINCL: String("INCL "); Reg2(param1, param2)
|opINCLC: String("INCL "); RegC(param1, param2)
|opEXCL: String("EXCL "); Reg2(param1, param2)
|opEXCLC: String("EXCL "); RegC(param1, param2)
|opIN: String("IN "); Reg2(param1, param2)
|opINC: String("IN "); RegC(param1, param2)
|opAND: String("AND "); Reg2(param1, param2)
|opANDC: String("AND "); RegC(param1, param2)
|opOR: String("OR "); Reg2(param1, param2)
|opORC: String("OR "); RegC(param1, param2)
|opXOR: String("XOR "); Reg2(param1, param2)
|opXORC: String("XOR "); RegC(param1, param2)
|opASR: String("ASR "); Reg2(param1, param2)
|opASRC: String("ASR "); RegC(param1, param2)
|opLSR: String("LSR "); Reg2(param1, param2)
|opLSRC: String("LSR "); RegC(param1, param2)
|opLSL: String("LSL "); Reg2(param1, param2)
|opLSLC: String("LSL "); RegC(param1, param2)
|opROR: String("ROR "); Reg2(param1, param2)
|opRORC: String("ROR "); RegC(param1, param2)
|opMIN: String("MIN "); Reg2(param1, param2)
|opMINC: String("MIN "); RegC(param1, param2)
|opMAX: String("MAX "); Reg2(param1, param2)
|opMAXC: String("MAX "); RegC(param1, param2)
|opEQ: String("EQ "); Reg2(param1, param2)
|opEQC: String("EQ "); RegC(param1, param2)
|opNE: String("NE "); Reg2(param1, param2)
|opNEC: String("NE "); RegC(param1, param2)
|opLT: String("LT "); Reg2(param1, param2)
|opLTC: String("LT "); RegC(param1, param2)
|opLE: String("LE "); Reg2(param1, param2)
|opLEC: String("LE "); RegC(param1, param2)
|opGT: String("GT "); Reg2(param1, param2)
|opGTC: String("GT "); RegC(param1, param2)
|opGE: String("GE "); Reg2(param1, param2)
|opGEC: String("GE "); RegC(param1, param2)
|opBT: String("BT "); Reg2(param1, param2)
|opBTC: String("BT "); RegC(param1, param2)
|opLEA: String("LEA "); Reg(param1 MOD 256); String(", "); String(Sections[param1 DIV 256].name); String(" + "); Hex(param2)
|opLABEL: String("L"); Hex(param1); String(":")
|opSYSCALL: String("SYSCALL "); Reg(param1)
END;
Ln;
cmd := cmd.next
END;
String("TYPES:");
ptr := Sections[Types].address;
FOR i := 0 TO t_count - 1 DO
IF i MOD 4 = 0 THEN
Ln; String("WORD ")
ELSE
String(", ")
END;
SYSTEM.GET32(ptr, t); INC(ptr, 4);
Hex(t)
END;
Ln;
String("STRINGS:");
ptr := Sections[Strings].address;
FOR i := 0 TO c_count - 1 DO
IF i MOD 8 = 0 THEN
Ln; String("BYTE ")
ELSE
String(", ")
END;
SYSTEM.GET8(ptr, b); INC(ptr);
Byte(b)
END;
Ln;
String("GLOBAL:"); Ln;
String("WORDS "); Hex(glob); Ln;
String("HEAP:"); Ln;
String("WORDS "); Hex(heap); Ln;
String("STACK:"); Ln;
String("WORDS 8"); Ln;
ASSERT(File.Write(F, SYSTEM.ADR(buf[0]), cnt) = cnt);
File.Close(F)
END disasm;
PROCEDURE GetCommand (adr: INTEGER): COMMAND;
VAR
op, param1, param2: INTEGER;
res: COMMAND;
BEGIN
op := 0; param1 := 0; param2 := 0;
SYSTEM.GET32(adr, op);
SYSTEM.GET32(adr + 4, param1);
SYSTEM.GET32(adr + 8, param2);
NEW(res);
res.op := op;
res.param1 := param1;
res.param2 := param2;
res.next := NIL
RETURN res
END GetCommand;
PROCEDURE main;
VAR
name, param: ARRAY 1024 OF CHAR;
cmd: COMMAND;
file, fsize, n: INTEGER;
descr: ARRAY 12 OF INTEGER;
offTypes, offStrings, GlobalSize, HeapStackSize, DescrSize: INTEGER;
BEGIN
Out.Open;
Args.GetArg(1, name);
F := File.Open(name, File.OPEN_R);
IF F > 0 THEN
DescrSize := LEN(descr) * SYSTEM.SIZE(INTEGER);
fsize := File.Seek(F, 0, File.SEEK_END);
ASSERT(fsize > DescrSize);
file := API._NEW(fsize);
ASSERT(file # 0);
n := File.Seek(F, 0, File.SEEK_BEG);
ASSERT(fsize = File.Read(F, file, fsize));
File.Close(F);
SYSTEM.MOVE(file + fsize - DescrSize, SYSTEM.ADR(descr[0]), DescrSize);
offTypes := descr[0];
ASSERT(offTypes < fsize - DescrSize);
ASSERT(offTypes > 0);
ASSERT(offTypes MOD 12 = 0);
offStrings := descr[1];
ASSERT(offStrings < fsize - DescrSize);
ASSERT(offStrings > 0);
ASSERT(offStrings MOD 4 = 0);
ASSERT(offStrings > offTypes);
GlobalSize := descr[2];
ASSERT(GlobalSize > 0);
HeapStackSize := descr[3];
ASSERT(HeapStackSize > 0);
Sections[Types].address := API._NEW(offStrings - offTypes);
ASSERT(Sections[Types].address # 0);
SYSTEM.MOVE(file + offTypes, Sections[Types].address, offStrings - offTypes);
Sections[Strings].address := API._NEW(fsize - offStrings - DescrSize);
ASSERT(Sections[Strings].address # 0);
SYSTEM.MOVE(file + offStrings, Sections[Strings].address, fsize - offStrings - DescrSize);
Sections[Global].address := API._NEW(GlobalSize * 4);
ASSERT(Sections[Global].address # 0);
Sections[Heap].address := API._NEW(HeapStackSize * 4);
ASSERT(Sections[Heap].address # 0);
Sections[Stack].address := Sections[Heap].address + HeapStackSize * 4 - 32;
n := offTypes DIV 12;
first := GetCommand(file + offTypes - n * 12);
last := first;
DEC(n);
WHILE n > 0 DO
cmd := GetCommand(file + offTypes - n * 12);
IF cmd.op = opLABEL THEN
Labels[cmd.param1] := cmd
END;
last.next := cmd;
last := cmd;
DEC(n)
END;
file := API._DISPOSE(file);
Args.GetArg(2, param);
IF param = "-dis" THEN
Args.GetArg(3, name);
IF name # "" THEN
disasm(name, (offStrings - offTypes) DIV 4, fsize - offStrings - DescrSize, GlobalSize, HeapStackSize)
END
ELSIF param = "-run" THEN
exec
END
ELSE
Out.String("file not found"); Out.Ln
END
END main;
BEGIN
ASSERT(RTL.bit_depth = 32);
main
END RVM32I.