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