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

update

Browse Source 
git-svn-id: svn://kolibrios.org@7693 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
Anton Krotov 2019-09-26 20:23:06 +00:00
parent 885116b9fb
commit c4dee82cbc
44 changed files with 8006 additions and 3960 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

Binary file not shown.

20
programs/develop/oberon07/Docs/About1251.txt
View File

@ -17,6 +17,7 @@ UTF-8
"kos" - KolibriOS
"obj" - KolibriOS DLL
"elfexe" - Linux ELF-EXEC
"elfso" - Linux ELF-SO
4) необязательные параметры-ключи
-stk <size> размер стэка в мегабайтах (по умолчанию 2 Мб)
-base <address> адрес загрузки исполняемого файла в килобайтах
@ -144,10 +145,10 @@ UTF-8
до 32 бит, для записи байтов использовать SYSTEM.PUT8,
для WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER; x: INTEGER, BYTE, CHAR, WCHAR)
PROCEDURE PUT8(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
Память[a] := младшие 8 бит (x)
PROCEDURE PUT16(a: INTEGER; x: INTEGER, BYTE, CHAR, WCHAR)
PROCEDURE PUT16(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
Память[a] := младшие 16 бит (x)
PROCEDURE MOVE(Source, Dest, n: INTEGER)
@ -358,8 +359,8 @@ Oberon-
Все программы неявно используют модуль RTL. Компилятор транслирует
некоторые операции (проверка и охрана типа, сравнение строк, сообщения об
ошибках времени выполнения и др.) как вызовы процедур этого модуля. Не
следует явно вызывать эти процедуры, за исключением процедуры SetDll,
если приложение компилируется как Windows DLL:
следует явно вызывать эти процедуры, за исключением процедур SetDll и SetFini
если приложение компилируется как Windows DLL или Linux SO, соответственно:
PROCEDURE SetDll
(process_detach, thread_detach, thread_attach: DLL_ENTRY);
@ -372,8 +373,15 @@ SetDll
- создании нового потока (thread_attach)
- уничтожении потока (thread_detach)
Для прочих типов приложений, вызов процедуры SetDll не влияет на
PROCEDURE SetFini (ProcFini: PROC);
где TYPE PROC = PROCEDURE (* без параметров *)
SetFini назначает процедуру ProcFini вызываемой при выгрузке so-библиотеки.
Для прочих типов приложений, вызов процедур SetDll и SetFini не влияет на
поведение программы.
Сообщения об ошибках времени выполнения выводятся в диалоговых окнах
(Windows), в терминал (Linux), на доску отладки (KolibriOS).
@ -396,5 +404,3 @@ SetDll
Эта процедура должна быть вызвана перед использованием DLL.
Процедура всегда возвращает 1.
Для Linux, генерация динамических библиотек не реализована.

20
programs/develop/oberon07/Docs/About866.txt
View File

@ -17,6 +17,7 @@ UTF-8
"kos" - KolibriOS
"obj" - KolibriOS DLL
"elfexe" - Linux ELF-EXEC
"elfso" - Linux ELF-SO
4) ­¥®¡ï§ â¥«ì­ë¥ ¯ à ¬¥âàë-ª«îç¨
-stk <size> à §¬¥à áâíª  ¢ ¬¥£ ¡ ©â å (¯® 㬮«ç ­¨î 2 Œ¡)
-base <address>  ¤à¥á § £à㧪¨ ¨á¯®«­ï¥¬®£® ä ©«  ¢ ª¨«®¡ ©â å
@ -144,10 +145,10 @@ UTF-8
¤® 32 ¡¨â, ¤«ï § ¯¨á¨ ¡ ©â®¢ ¨á¯®«ì§®¢ âì SYSTEM.PUT8,
¤«ï WCHAR -- SYSTEM.PUT16
PROCEDURE PUT8(a: INTEGER; x: INTEGER, BYTE, CHAR, WCHAR)
PROCEDURE PUT8(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
<20> ¬ïâì[a] := ¬« ¤è¨¥ 8 ¡¨â (x)
PROCEDURE PUT16(a: INTEGER; x: INTEGER, BYTE, CHAR, WCHAR)
PROCEDURE PUT16(a: INTEGER; x: INTEGER, SET, BYTE, CHAR, WCHAR)
<20> ¬ïâì[a] := ¬« ¤è¨¥ 16 ¡¨â (x)
PROCEDURE MOVE(Source, Dest, n: INTEGER)
@ -358,8 +359,8 @@ Oberon-ॠ
‚ᥠ¯à®£à ¬¬ë ­¥ï¢­® ¨á¯®«ì§ãîâ ¬®¤ã«ì RTL. Š®¬¯¨«ïâ®à â࠭᫨àã¥â
­¥ª®â®àë¥ ®¯¥à æ¨¨ (¯à®¢¥àª  ¨ ®åà ­  ⨯ , áà ¢­¥­¨¥ áâப, á®®¡é¥­¨ï ®¡
®è¨¡ª å ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¨ ¤à.) ª ª ¢ë§®¢ë ¯à®æ¥¤ãà í⮣® ¬®¤ã«ï. <20>¥
á«¥¤ã¥â ® ¢ë§ë¢ âì í⨠¯à®æ¥¤ãàë, §  ¨áª«î祭¨¥¬ ¯à®æ¥¤ãàë SetDll,
¥á«¨ ¯à¨«®¦¥­¨¥ ª®¬¯¨«¨àã¥âáï ª ª Windows DLL:
á«¥¤ã¥â ® ¢ë§ë¢ âì í⨠¯à®æ¥¤ãàë, §  ¨áª«î祭¨¥¬ ¯à®æ¥¤ãà SetDll ¨ SetFini
¥á«¨ ¯à¨«®¦¥­¨¥ ª®¬¯¨«¨àã¥âáï ª ª Windows DLL ¨«¨ Linux SO, ᮮ⢥âá⢥­­®:
PROCEDURE SetDll
(process_detach, thread_detach, thread_attach: DLL_ENTRY);
@ -372,8 +373,15 @@ SetDll
- ᮧ¤ ­¨¨ ­®¢®£® ¯®â®ª  (thread_attach)
- ã­¨ç⮦¥­¨¨ ¯®â®ª  (thread_detach)
„«ï ¯à®ç¨å ⨯®¢ ¯à¨«®¦¥­¨©, ¢ë§®¢ ¯à®æ¥¤ãàë SetDll ­¥ ¢«¨ï¥â ­ 
PROCEDURE SetFini (ProcFini: PROC);
£¤¥ TYPE PROC = PROCEDURE (* ¡¥§ ¯ à ¬¥â஢ *)
SetFini ­ §­ ç ¥â ¯à®æ¥¤ãàã ProcFini ¢ë§ë¢ ¥¬®© ¯à¨ ¢ë£à㧪¥ so-¡¨¡«¨®â¥ª¨.
„«ï ¯à®ç¨å ⨯®¢ ¯à¨«®¦¥­¨©, ¢ë§®¢ ¯à®æ¥¤ãà SetDll ¨ SetFini ­¥ ¢«¨ï¥â ­ 
¯®¢¥¤¥­¨¥ ¯à®£à ¬¬ë.
‘®®¡é¥­¨ï ®¡ ®è¨¡ª å ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¢ë¢®¤ïâáï ¢ ¤¨ «®£®¢ëå ®ª­ å
(Windows), ¢ â¥à¬¨­ « (Linux), ­  ¤®áªã ®â« ¤ª¨ (KolibriOS).
@ -396,5 +404,3 @@ SetDll
<EFBFBD>â  ¯à®æ¥¤ãà  ¤®«¦­  ¡ëâì ¢ë§¢ ­  ¯¥à¥¤ ¨á¯®«ì§®¢ ­¨¥¬ DLL.
<EFBFBD>à®æ¥¤ãà  ¢á¥£¤  ¢®§¢à é ¥â 1.
„«ï Linux, £¥­¥à æ¨ï ¤¨­ ¬¨ç¥áª¨å ¡¨¡«¨®â¥ª ­¥ ॠ«¨§®¢ ­ .

15
programs/develop/oberon07/Docs/KOSLib1251.txt
View File

@ -98,8 +98,8 @@ MODULE Math -
CONST
pi = 3.141592653589793D+00
e = 2.718281828459045D+00
pi = 3.141592653589793E+00
e = 2.718281828459045E+00
PROCEDURE IsNan(x: REAL): BOOLEAN
@ -153,13 +153,13 @@ MODULE Math -
PROCEDURE tanh(x: REAL): REAL
ãèïåðáîëè÷åñêèé òàíãåíñ x
PROCEDURE arcsinh(x: REAL): REAL
PROCEDURE arsinh(x: REAL): REAL
îáðàòíûé ãèïåðáîëè÷åñêèé ñèíóñ x
PROCEDURE arccosh(x: REAL): REAL
PROCEDURE arcosh(x: REAL): REAL
îáðàòíûé ãèïåðáîëè÷åñêèé êîñèíóñ x
PROCEDURE arctanh(x: REAL): REAL
PROCEDURE artanh(x: REAL): REAL
îáðàòíûé ãèïåðáîëè÷åñêèé òàíãåíñ x
PROCEDURE round(x: REAL): REAL
@ -181,6 +181,9 @@ MODULE Math -
åñëè x < 0 âîçâðàùàåò -1
åñëè x = 0 âîçâðàùàåò 0
PROCEDURE fact(n: INTEGER): REAL
ôàêòîðèàë n
------------------------------------------------------------------------------
MODULE Debug - âûâîä íà äîñêó îòëàäêè
Èíòåðôåéñ êàê ìîäóëü Out
@ -337,7 +340,7 @@ MODULE DateTime -
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL
âîçâðàùàåò äàòó, ïîëó÷åííóþ èç êîìïîíåíòîâ
Year, Month, Day, Hour, Min, Sec;
ïðè îøèáêå âîçâðàùàåò êîíñòàíòó ERR = -7.0D5
ïðè îøèáêå âîçâðàùàåò êîíñòàíòó ERR = -7.0E5
PROCEDURE Decode(Date: REAL; VAR Year, Month, Day,
Hour, Min, Sec: INTEGER): BOOLEAN

15
programs/develop/oberon07/Docs/KOSLib866.txt
View File

@ -98,8 +98,8 @@ MODULE Math -
CONST
pi = 3.141592653589793D+00
e = 2.718281828459045D+00
pi = 3.141592653589793E+00
e = 2.718281828459045E+00
PROCEDURE IsNan(x: REAL): BOOLEAN
@ -153,13 +153,13 @@ MODULE Math -
PROCEDURE tanh(x: REAL): REAL
£¨¯¥à¡®«¨ç¥áª¨© â ­£¥­á x
PROCEDURE arcsinh(x: REAL): REAL
PROCEDURE arsinh(x: REAL): REAL
®¡à â­ë© £¨¯¥à¡®«¨ç¥áª¨© ᨭãá x
PROCEDURE arccosh(x: REAL): REAL
PROCEDURE arcosh(x: REAL): REAL
®¡à â­ë© £¨¯¥à¡®«¨ç¥áª¨© ª®á¨­ãá x
PROCEDURE arctanh(x: REAL): REAL
PROCEDURE artanh(x: REAL): REAL
®¡à â­ë© £¨¯¥à¡®«¨ç¥áª¨© â ­£¥­á x
PROCEDURE round(x: REAL): REAL
@ -181,6 +181,9 @@ MODULE Math -
¥á«¨ x < 0 ¢®§¢à é ¥â -1
¥á«¨ x = 0 ¢®§¢à é ¥â 0
PROCEDURE fact(n: INTEGER): REAL
ä ªâ®à¨ « n
------------------------------------------------------------------------------
MODULE Debug - ¢ë¢®¤ ­  ¤®áªã ®â« ¤ª¨
ˆ­â¥àä¥©á ª ª ¬®¤ã«ì Out
@ -337,7 +340,7 @@ MODULE DateTime -
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL
¢®§¢à é ¥â ¤ âã, ¯®«ã祭­ãî ¨§ ª®¬¯®­¥­â®¢
Year, Month, Day, Hour, Min, Sec;
¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â ª®­áâ ­âã ERR = -7.0D5
¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â ª®­áâ ­âã ERR = -7.0E5
PROCEDURE Decode(Date: REAL; VAR Year, Month, Day,
Hour, Min, Sec: INTEGER): BOOLEAN

71
programs/develop/oberon07/Lib/KolibriOS/Math.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2013, 2014, 2018 Anton Krotov
Copyright 2013, 2014, 2018, 2019 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
@ -251,58 +251,45 @@ END arctan;
PROCEDURE sinh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF IsZero(x) THEN
res := 0.0
ELSE
res := (exp(x) - exp(-x)) / 2.0
END
RETURN res
x := exp(x)
RETURN (x - 1.0 / x) * 0.5
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF IsZero(x) THEN
res := 1.0
ELSE
res := (exp(x) + exp(-x)) / 2.0
END
RETURN res
x := exp(x)
RETURN (x + 1.0 / x) * 0.5
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF IsZero(x) THEN
res := 0.0
IF x > 15.0 THEN
x := 1.0
ELSIF x < -15.0 THEN
x := -1.0
ELSE
res := sinh(x) / cosh(x)
x := exp(2.0 * x);
x := (x - 1.0) / (x + 1.0)
END
RETURN res
RETURN x
END tanh;
PROCEDURE arcsinh* (x: REAL): REAL;
RETURN ln(x + sqrt((x * x) + 1.0))
END arcsinh;
PROCEDURE arsinh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
PROCEDURE arccosh* (x: REAL): REAL;
RETURN ln(x + sqrt((x - 1.0) / (x + 1.0)) * (x + 1.0))
END arccosh;
PROCEDURE arcosh* (x: REAL): REAL;
RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
PROCEDURE arctanh* (x: REAL): REAL;
PROCEDURE artanh* (x: REAL): REAL;
VAR
res: REAL;
@ -315,7 +302,7 @@ BEGIN
res := 0.5 * ln((1.0 + x) / (1.0 - x))
END
RETURN res
END arctanh;
END artanh;
PROCEDURE floor* (x: REAL): REAL;
@ -374,8 +361,24 @@ BEGIN
ELSE
res := 0
END
RETURN res
END sgn;
PROCEDURE fact* (n: INTEGER): REAL;
VAR
res: REAL;
BEGIN
res := 1.0;
WHILE n > 1 DO
res := res * FLT(n);
DEC(n)
END
RETURN res
END fact;
END Math.

2
programs/develop/oberon07/Lib/KolibriOS/NetDevices.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify

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

@ -22,11 +22,13 @@ CONST
DLL_PROCESS_DETACH = 0;
SIZE_OF_DWORD = 4;
MAX_SET = 31;
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
PROC = PROCEDURE;
VAR
@ -40,6 +42,8 @@ VAR
thread_attach: DLL_ENTRY
END;
fini: PROC;
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
BEGIN
@ -107,18 +111,12 @@ BEGIN
END _arrcpy;
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
PROCEDURE [stdcall] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
@ -137,32 +135,29 @@ BEGIN
END _rot;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
BEGIN
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
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;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
a := LSR(ASR(ROR(1, 1), b - a), MAX_SET - b)
ELSE
res := 0
a := 0
END
RETURN res
END _set2;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
RETURN a
END _set;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
RETURN _set(b, a)
END _set2;
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
@ -185,7 +180,7 @@ BEGIN
END divmod;
PROCEDURE div_ (x, y: INTEGER): INTEGER;
PROCEDURE [stdcall] _div2* (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
@ -196,10 +191,10 @@ BEGIN
END
RETURN div
END div_;
END _div2;
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
PROCEDURE [stdcall] _mod2* (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
@ -210,29 +205,19 @@ BEGIN
END
RETURN mod
END mod_;
END _mod2;
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(a, b)
RETURN _div2(a, b)
END _div;
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
RETURN div_(a, b)
END _div2;
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
RETURN mod_(a, b)
RETURN _mod2(a, b)
END _mod;
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
@ -251,50 +236,6 @@ BEGIN
END _dispose;
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 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 = 0X THEN
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _length* (len, str: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
@ -345,16 +286,71 @@ BEGIN
END _lengthw;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := minint;
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
res := 0;
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := minint;
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 = 0X THEN
res := 0;
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
@ -370,21 +366,25 @@ BEGIN
END _strcmp;
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmp(op, len2, str2, len1, str1)
END _strcmp2;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2 * 2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1 * 2, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
@ -400,11 +400,6 @@ BEGIN
END _strcmpw;
PROCEDURE [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmpw(op, len2, str2, len1, str1)
END _strcmpw2;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
@ -470,14 +465,14 @@ BEGIN
END append;
PROCEDURE [stdcall] _error* (module, err: INTEGER);
PROCEDURE [stdcall] _error* (module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err MOD 16 OF
CASE err OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
@ -494,7 +489,7 @@ BEGIN
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
@ -502,69 +497,42 @@ BEGIN
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
(* r IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): INTEGER;
BEGIN
(* p IS t0 *)
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
ELSE
t1 := -1
SYSTEM.GET(p - SIZE_OF_DWORD, p);
SYSTEM.GET(t0 + p + types, p)
END
RETURN t1 = t0
RETURN p MOD 2
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
(* r:t1 IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
(* p IS t0 *)
SYSTEM.GET(p, p);
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
SYSTEM.GET(p - SIZE_OF_DWORD, p);
SYSTEM.GET(t0 + p + types, p)
ELSE
t1 := t0
p := 1
END
RETURN t1 = t0
RETURN p MOD 2
END _guard;
@ -613,18 +581,50 @@ BEGIN
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
PROCEDURE [stdcall] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := _types;
types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
ASSERT(types # 0);
FOR i := 0 TO tcount - 1 DO
FOR j := 0 TO tcount - 1 DO
t0 := i; t1 := j;
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(_types + t1 * SIZE_OF_DWORD, t1)
END;
SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
END
END;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
fini := NIL
END _init;
PROCEDURE [stdcall] _sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END _sofinit;
PROCEDURE SetFini* (ProcFini: PROC);
BEGIN
fini := ProcFini
END SetFini;
END RTL.

2
programs/develop/oberon07/Lib/KolibriOS/Vector.ob07
View File

@ -1,4 +1,4 @@
(*
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify

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

@ -38,16 +38,6 @@ VAR
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE dlopen* (filename: ARRAY OF CHAR): INTEGER;
RETURN API.dlopen(SYSTEM.ADR(filename[0]), 1)
END dlopen;
PROCEDURE dlsym* (handle: INTEGER; symbol: ARRAY OF CHAR): INTEGER;
RETURN API.dlsym(handle, SYSTEM.ADR(symbol[0]))
END dlsym;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;

286
programs/develop/oberon07/Lib/Linux32/RTL.ob07
View File

@ -22,11 +22,13 @@ CONST
DLL_PROCESS_DETACH = 0;
SIZE_OF_DWORD = 4;
MAX_SET = 31;
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
PROC = PROCEDURE;
VAR
@ -40,6 +42,8 @@ VAR
thread_attach: DLL_ENTRY
END;
fini: PROC;
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
BEGIN
@ -107,18 +111,12 @@ BEGIN
END _arrcpy;
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
PROCEDURE [stdcall] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
@ -137,32 +135,29 @@ BEGIN
END _rot;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
BEGIN
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
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;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
a := LSR(ASR(ROR(1, 1), b - a), MAX_SET - b)
ELSE
res := 0
a := 0
END
RETURN res
END _set2;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
RETURN a
END _set;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
RETURN _set(b, a)
END _set2;
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
@ -185,7 +180,7 @@ BEGIN
END divmod;
PROCEDURE div_ (x, y: INTEGER): INTEGER;
PROCEDURE [stdcall] _div2* (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
@ -196,10 +191,10 @@ BEGIN
END
RETURN div
END div_;
END _div2;
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
PROCEDURE [stdcall] _mod2* (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
@ -210,29 +205,19 @@ BEGIN
END
RETURN mod
END mod_;
END _mod2;
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(a, b)
RETURN _div2(a, b)
END _div;
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
RETURN div_(a, b)
END _div2;
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
RETURN mod_(a, b)
RETURN _mod2(a, b)
END _mod;
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
@ -251,50 +236,6 @@ BEGIN
END _dispose;
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 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 = 0X THEN
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _length* (len, str: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
@ -345,16 +286,71 @@ BEGIN
END _lengthw;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := minint;
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
res := 0;
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := minint;
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 = 0X THEN
res := 0;
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
@ -370,21 +366,25 @@ BEGIN
END _strcmp;
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmp(op, len2, str2, len1, str1)
END _strcmp2;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2 * 2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1 * 2, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
@ -400,11 +400,6 @@ BEGIN
END _strcmpw;
PROCEDURE [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmpw(op, len2, str2, len1, str1)
END _strcmpw2;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
@ -470,14 +465,14 @@ BEGIN
END append;
PROCEDURE [stdcall] _error* (module, err: INTEGER);
PROCEDURE [stdcall] _error* (module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err MOD 16 OF
CASE err OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
@ -494,7 +489,7 @@ BEGIN
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
@ -502,69 +497,42 @@ BEGIN
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
(* r IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): INTEGER;
BEGIN
(* p IS t0 *)
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
ELSE
t1 := -1
SYSTEM.GET(p - SIZE_OF_DWORD, p);
SYSTEM.GET(t0 + p + types, p)
END
RETURN t1 = t0
RETURN p MOD 2
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
(* r:t1 IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
(* p IS t0 *)
SYSTEM.GET(p, p);
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
SYSTEM.GET(p - SIZE_OF_DWORD, p);
SYSTEM.GET(t0 + p + types, p)
ELSE
t1 := t0
p := 1
END
RETURN t1 = t0
RETURN p MOD 2
END _guard;
@ -613,18 +581,50 @@ BEGIN
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
PROCEDURE [stdcall] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := _types;
types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
ASSERT(types # 0);
FOR i := 0 TO tcount - 1 DO
FOR j := 0 TO tcount - 1 DO
t0 := i; t1 := j;
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(_types + t1 * SIZE_OF_DWORD, t1)
END;
SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
END
END;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
fini := NIL
END _init;
PROCEDURE [stdcall] _sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END _sofinit;
PROCEDURE SetFini* (ProcFini: PROC);
BEGIN
fini := ProcFini
END SetFini;
END RTL.

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

@ -13,12 +13,14 @@ VAR
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
heap: INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GlobalAlloc"] Alloc (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalFree"] Free (hMem: INTEGER): 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-, "user32.dll", "MessageBoxA"] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
@ -30,19 +32,22 @@ END DebugMsg;
PROCEDURE _NEW* (size: INTEGER): INTEGER;
RETURN Alloc(64, size)
RETURN HeapAlloc(heap, 8, size)
END _NEW;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
RETURN Free(p)
BEGIN
HeapFree(heap, 0, p)
RETURN 0
END _DISPOSE;
PROCEDURE init* (reserved, code: INTEGER);
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - 4096
base := code - 4096;
heap := GetProcessHeap()
END init;

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

@ -22,11 +22,13 @@ CONST
DLL_PROCESS_DETACH = 0;
SIZE_OF_DWORD = 4;
MAX_SET = 31;
TYPE
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
PROC = PROCEDURE;
VAR
@ -40,6 +42,8 @@ VAR
thread_attach: DLL_ENTRY
END;
fini: PROC;
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
BEGIN
@ -107,18 +111,12 @@ BEGIN
END _arrcpy;
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
PROCEDURE [stdcall] _strcpy* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
@ -137,32 +135,29 @@ BEGIN
END _rot;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
BEGIN
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
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;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
a := LSR(ASR(ROR(1, 1), b - a), MAX_SET - b)
ELSE
res := 0
a := 0
END
RETURN res
END _set2;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
RETURN a
END _set;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
RETURN _set(b, a)
END _set2;
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
@ -185,7 +180,7 @@ BEGIN
END divmod;
PROCEDURE div_ (x, y: INTEGER): INTEGER;
PROCEDURE [stdcall] _div2* (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
@ -196,10 +191,10 @@ BEGIN
END
RETURN div
END div_;
END _div2;
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
PROCEDURE [stdcall] _mod2* (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
@ -210,29 +205,19 @@ BEGIN
END
RETURN mod
END mod_;
END _mod2;
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(a, b)
RETURN _div2(a, b)
END _div;
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
RETURN div_(a, b)
END _div2;
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
RETURN mod_(a, b)
RETURN _mod2(a, b)
END _mod;
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
@ -251,50 +236,6 @@ BEGIN
END _dispose;
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 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 = 0X THEN
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _length* (len, str: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
@ -345,16 +286,71 @@ BEGIN
END _lengthw;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := minint;
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
res := 0;
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := minint;
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 = 0X THEN
res := 0;
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: CHAR;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
@ -370,21 +366,25 @@ BEGIN
END _strcmp;
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmp(op, len2, str2, len1, str1)
END _strcmp2;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
c: WCHAR;
BEGIN
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
IF res = minint THEN
IF len1 > len2 THEN
SYSTEM.GET(str1 + len2 * 2, c);
res := ORD(c)
ELSIF len1 < len2 THEN
SYSTEM.GET(str2 + len1 * 2, c);
res := -ORD(c)
ELSE
res := 0
END
END;
CASE op OF
@ -400,11 +400,6 @@ BEGIN
END _strcmpw;
PROCEDURE [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmpw(op, len2, str2, len1, str1)
END _strcmpw2;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
@ -470,14 +465,14 @@ BEGIN
END append;
PROCEDURE [stdcall] _error* (module, err: INTEGER);
PROCEDURE [stdcall] _error* (module, err, line: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err MOD 16 OF
CASE err OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
@ -494,7 +489,7 @@ BEGIN
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
append(s, "line: "); IntToStr(line, temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
@ -502,69 +497,42 @@ BEGIN
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): INTEGER;
BEGIN
(* r IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): INTEGER;
BEGIN
(* p IS t0 *)
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
ELSE
t1 := -1
SYSTEM.GET(p - SIZE_OF_DWORD, p);
SYSTEM.GET(t0 + p + types, p)
END
RETURN t1 = t0
RETURN p MOD 2
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): INTEGER;
BEGIN
(* r:t1 IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
SYSTEM.GET(t0 + t1 + types, t0)
RETURN t0 MOD 2
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): INTEGER;
BEGIN
(* p IS t0 *)
SYSTEM.GET(p, p);
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
SYSTEM.GET(p - SIZE_OF_DWORD, p);
SYSTEM.GET(t0 + p + types, p)
ELSE
t1 := t0
p := 1
END
RETURN t1 = t0
RETURN p MOD 2
END _guard;
@ -613,18 +581,50 @@ BEGIN
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
PROCEDURE [stdcall] _init* (modname: INTEGER; tcount, _types: INTEGER; code, param: INTEGER);
VAR
t0, t1, i, j: INTEGER;
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := _types;
types := API._NEW(tcount * tcount + SYSTEM.SIZE(INTEGER));
ASSERT(types # 0);
FOR i := 0 TO tcount - 1 DO
FOR j := 0 TO tcount - 1 DO
t0 := i; t1 := j;
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(_types + t1 * SIZE_OF_DWORD, t1)
END;
SYSTEM.PUT8(i * tcount + j + types, ORD(t0 = t1))
END
END;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
fini := NIL
END _init;
PROCEDURE [stdcall] _sofinit*;
BEGIN
IF fini # NIL THEN
fini
END
END _sofinit;
PROCEDURE SetFini* (ProcFini: PROC);
BEGIN
fini := ProcFini
END SetFini;
END RTL.

1112
programs/develop/oberon07/Source/AMD64.ob07
View File

File diff suppressed because it is too large Load Diff

76
programs/develop/oberon07/Source/ARITH.ob07
View File

@ -7,7 +7,7 @@
MODULE ARITH;
IMPORT AVLTREES, STRINGS, MACHINE, UTILS;
IMPORT AVLTREES, STRINGS, UTILS;
CONST
@ -53,10 +53,7 @@ BEGIN
ELSIF v.typ = tWCHAR THEN
res := v.int
ELSIF v.typ = tSET THEN
res := ORD(v.set);
IF MACHINE._64to32 THEN
res := MACHINE.Int32To64(res)
END
res := UTILS.Long(ORD(v.set))
ELSIF v.typ = tBOOLEAN THEN
res := ORD(v.bool)
END
@ -88,13 +85,13 @@ VAR
BEGIN
error := FALSE;
IF (v.typ = tINTEGER) & ((v.int < MACHINE.target.minInt) OR (v.int > MACHINE.target.maxInt)) THEN
IF (v.typ = tINTEGER) & ((v.int < UTILS.target.minInt) OR (v.int > UTILS.target.maxInt)) THEN
error := TRUE
ELSIF (v.typ = tCHAR) & ((v.int < 0) OR (v.int > 255)) THEN
error := TRUE
ELSIF (v.typ = tWCHAR) & ((v.int < 0) OR (v.int > 65535)) THEN
error := TRUE
ELSIF (v.typ = tREAL) & ((v.float < -MACHINE.target.maxReal) OR (v.float > MACHINE.target.maxReal)) THEN
ELSIF (v.typ = tREAL) & ((v.float < -UTILS.target.maxReal) OR (v.float > UTILS.target.maxReal)) THEN
error := TRUE
END
@ -172,7 +169,7 @@ BEGIN
n := i
END;
IF (n # -1) & (i - n + 1 > MACHINE.target.maxHex) THEN
IF (n # -1) & (i - n + 1 > UTILS.target.maxHex) THEN
error := 2
ELSE
value := value * 16 + d;
@ -181,9 +178,7 @@ BEGIN
END;
IF MACHINE._64to32 THEN
value := MACHINE.Int32To64(value);
END;
value := UTILS.Long(value);
IF (s[i] = "X") & (n # -1) & (i - n > 4) THEN
error := 3
@ -471,58 +466,53 @@ END mulInt;
PROCEDURE _ASR (x, n: INTEGER): INTEGER;
BEGIN
IF MACHINE._64to32 THEN
x := MACHINE.Int32To64(x)
END
RETURN ASR(x, n)
RETURN ASR(UTILS.Long(x), n)
END _ASR;
PROCEDURE _LSR (x, n: INTEGER): INTEGER;
BEGIN
IF MACHINE._64to32 THEN
x := MACHINE.Int64To32(x);
x := LSR(x, n);
x := MACHINE.Int32To64(x)
ELSE
x := LSR(x, n)
END
RETURN x
RETURN UTILS.Long(LSR(UTILS.Short(x), n))
END _LSR;
PROCEDURE _LSL (x, n: INTEGER): INTEGER;
BEGIN
x := LSL(x, n);
IF MACHINE._64to32 THEN
x := MACHINE.Int32To64(x)
END
RETURN x
RETURN UTILS.Long(LSL(x, n))
END _LSL;
PROCEDURE _ROR1_32 (x: INTEGER): INTEGER;
BEGIN
x := MACHINE.Int64To32(x);
x := UTILS.Short(x);
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 31)))
RETURN MACHINE.Int32To64(x)
RETURN UTILS.Long(x)
END _ROR1_32;
PROCEDURE _ROR1_16 (x: INTEGER): INTEGER;
BEGIN
x := x MOD 65536;
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 15)))
RETURN UTILS.Long(x)
END _ROR1_16;
PROCEDURE _ROR (x, n: INTEGER): INTEGER;
BEGIN
IF MACHINE._64to32 THEN
CASE UTILS.bit_diff OF
|0: x := ROR(x, n)
|16, 48:
n := n MOD 16;
WHILE n > 0 DO
x := _ROR1_16(x);
DEC(n)
END
|32:
n := n MOD 32;
WHILE n > 0 DO
x := _ROR1_32(x);
DEC(n)
END
ELSE
x := ROR(x, n)
END
RETURN x
@ -587,11 +577,7 @@ BEGIN
CASE v.typ OF
|tCHAR, tWCHAR:
|tBOOLEAN: v.int := ORD(v.bool)
|tSET:
v.int := ORD(v.set);
IF MACHINE._64to32 THEN
v.int := MACHINE.Int32To64(v.int)
END
|tSET: v.int := UTILS.Long(ORD(v.set))
END;
v.typ := tINTEGER
END ord;
@ -787,7 +773,7 @@ BEGIN
|"I":
IF (v.typ = tINTEGER) & (v2.typ = tSET) THEN
IF range(v, 0, MACHINE.target.maxSet) THEN
IF range(v, 0, UTILS.target.maxSet) THEN
res := v.int IN v2.set
ELSE
error := 2

2
programs/develop/oberon07/Source/AVLTREES.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)

39
programs/develop/oberon07/Source/BIN.ob07
View File

@ -7,7 +7,7 @@
MODULE BIN;
IMPORT LISTS, MACHINE, CHL := CHUNKLISTS, ARITH, UTILS;
IMPORT LISTS, CHL := CHUNKLISTS, ARITH, UTILS;
CONST
@ -138,7 +138,10 @@ BEGIN
END;
IF UTILS.bit_depth = 64 THEN
x := MACHINE.Int32To64(x)
x := LSL(x, 16);
x := LSL(x, 16);
x := ASR(x, 16);
x := ASR(x, 16)
END
RETURN x
@ -151,7 +154,7 @@ VAR
BEGIN
FOR i := 0 TO 3 DO
CHL.SetByte(array, idx + i, MACHINE.Byte(x, i))
CHL.SetByte(array, idx + i, UTILS.Byte(x, i))
END
END put32le;
@ -162,7 +165,7 @@ VAR
BEGIN
FOR i := 0 TO 3 DO
CHL.PushByte(program.data, MACHINE.Byte(x, i))
CHL.PushByte(program.data, UTILS.Byte(x, i))
END
END PutData32LE;
@ -173,7 +176,7 @@ VAR
BEGIN
FOR i := 0 TO 7 DO
CHL.PushByte(program.data, MACHINE.Byte(x, i))
CHL.PushByte(program.data, UTILS.Byte(x, i))
END
END PutData64LE;
@ -203,7 +206,7 @@ VAR
BEGIN
FOR i := 0 TO 3 DO
CHL.PushByte(program.code, MACHINE.Byte(x, i))
CHL.PushByte(program.code, UTILS.Byte(x, i))
END
END PutCode32LE;
@ -217,7 +220,6 @@ END SetLabel;
PROCEDURE Import* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER);
VAR
imp: IMPRT;
i: INTEGER;
BEGIN
CHL.PushByte(program.import, 0);
@ -228,16 +230,9 @@ BEGIN
END;
NEW(imp);
imp.nameoffs := CHL.Length(program.import);
imp.nameoffs := CHL.PushStr(program.import, name);
imp.label := label;
LISTS.push(program.imp_list, imp);
i := 0;
WHILE name[i] # 0X DO
CHL.PushByte(program.import, ORD(name[i]));
INC(i)
END;
CHL.PushByte(program.import, 0)
LISTS.push(program.imp_list, imp)
END Import;
@ -262,19 +257,11 @@ END less;
PROCEDURE Export* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER);
VAR
exp, cur: EXPRT;
i: INTEGER;
BEGIN
NEW(exp);
exp.nameoffs := CHL.Length(program.export);
exp.label := CHL.GetInt(program.labels, label);
i := 0;
WHILE name[i] # 0X DO
CHL.PushByte(program.export, ORD(name[i]));
INC(i)
END;
CHL.PushByte(program.export, 0);
exp.nameoffs := CHL.PushStr(program.export, name);
cur := program.exp_list.first(EXPRT);
WHILE (cur # NIL) & less(program.export, cur, exp) DO
@ -389,7 +376,7 @@ BEGIN
array[i + idx] := hexdgt(hex[2 * i]) * 16 + hexdgt(hex[2 * i + 1])
END;
idx := idx + k
INC(idx, k)
END InitArray;

37
programs/develop/oberon07/Source/CHUNKLISTS.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
@ -118,6 +118,41 @@ BEGIN
END PushByte;
PROCEDURE PushStr* (list: BYTELIST; str: ARRAY OF CHAR): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := list.length;
i := 0;
REPEAT
PushByte(list, ORD(str[i]));
INC(i)
UNTIL str[i - 1] = 0X
RETURN res
END PushStr;
PROCEDURE GetStr* (list: BYTELIST; pos: INTEGER; VAR str: ARRAY OF CHAR): BOOLEAN;
VAR
i: INTEGER;
res: BOOLEAN;
BEGIN
res := FALSE;
i := 0;
WHILE (pos < list.length) & (i < LEN(str)) & ~res DO
str[i] := CHR(GetByte(list, pos));
res := str[i] = 0X;
INC(pos);
INC(i)
END
RETURN res
END GetStr;
PROCEDURE WriteToFile* (file: WR.FILE; list: BYTELIST);
VAR
chunk: BYTECHUNK;

2
programs/develop/oberon07/Source/COLLECTIONS.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)

32
programs/develop/oberon07/Source/CONSOLE.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
@ -23,22 +23,32 @@ BEGIN
END String;
PROCEDURE Int* (n: INTEGER);
PROCEDURE Int* (x: INTEGER);
VAR
s: ARRAY 32 OF CHAR;
s: ARRAY 24 OF CHAR;
BEGIN
STRINGS.IntToStr(n, s);
STRINGS.IntToStr(x, s);
String(s)
END Int;
PROCEDURE Int2* (n: INTEGER);
PROCEDURE Hex* (x, n: INTEGER);
VAR
s: ARRAY 24 OF CHAR;
BEGIN
IF n < 10 THEN
STRINGS.IntToHex(x, s, n);
String(s)
END Hex;
PROCEDURE Int2* (x: INTEGER);
BEGIN
IF x < 10 THEN
String("0")
END;
Int(n)
Int(x)
END Int2;
@ -55,16 +65,16 @@ BEGIN
END StringLn;
PROCEDURE IntLn* (n: INTEGER);
PROCEDURE IntLn* (x: INTEGER);
BEGIN
Int(n);
Int(x);
Ln
END IntLn;
PROCEDURE Int2Ln* (n: INTEGER);
PROCEDURE Int2Ln* (x: INTEGER);
BEGIN
Int2(n);
Int2(x);
Ln
END Int2Ln;

12
programs/develop/oberon07/Source/CONSTANTS.ob07
View File

@ -9,8 +9,8 @@ MODULE CONSTANTS;
CONST
vMajor* = 0;
vMinor* = 98;
vMajor* = 1;
vMinor* = 0;
FILE_EXT* = ".ob07";
RTL_NAME* = "RTL";
@ -26,7 +26,10 @@ CONST
Target_iGUI64* = 7;
Target_iDLL64* = 8;
Target_iELF32* = 9;
Target_iELF64* = 10;
Target_iELFSO32* = 10;
Target_iELF64* = 11;
Target_iELFSO64* = 12;
Target_iMSP430* = 13;
Target_sConsole* = "console";
Target_sGUI* = "gui";
@ -37,7 +40,10 @@ CONST
Target_sGUI64* = "gui64";
Target_sDLL64* = "dll64";
Target_sELF32* = "elfexe";
Target_sELFSO32* = "elfso";
Target_sELF64* = "elfexe64";
Target_sELFSO64* = "elfso64";
Target_sMSP430* = "msp430";
END CONSTANTS.

142
programs/develop/oberon07/Source/Compiler.ob07
View File

@ -7,7 +7,7 @@
MODULE Compiler;
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, C := CONSOLE, ERRORS, STRINGS, mConst := CONSTANTS, WRITER;
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, PROG, C := CONSOLE, ERRORS, STRINGS, mConst := CONSTANTS, WRITER, MSP430;
PROCEDURE Target (s: ARRAY OF CHAR): INTEGER;
@ -33,8 +33,14 @@ BEGIN
res := mConst.Target_iDLL64
ELSIF s = mConst.Target_sELF32 THEN
res := mConst.Target_iELF32
ELSIF s = mConst.Target_sELFSO32 THEN
res := mConst.Target_iELFSO32
ELSIF s = mConst.Target_sELF64 THEN
res := mConst.Target_iELF64
ELSIF s = mConst.Target_sELFSO64 THEN
res := mConst.Target_iELFSO64
ELSIF s = mConst.Target_sMSP430 THEN
res := mConst.Target_iMSP430
ELSE
res := 0
END
@ -43,7 +49,7 @@ BEGIN
END Target;
PROCEDURE keys (VAR StackSize, BaseAddress, Version: INTEGER; VAR pic: BOOLEAN; VAR checking: SET);
PROCEDURE keys (VAR options: PROG.OPTIONS);
VAR
param: PARS.PATH;
i, j: INTEGER;
@ -51,8 +57,10 @@ VAR
value: INTEGER;
minor,
major: INTEGER;
checking: SET;
BEGIN
checking := options.checking;
end := FALSE;
i := 4;
REPEAT
@ -62,7 +70,7 @@ BEGIN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) & (1 <= value) & (value <= 32) THEN
StackSize := value
options.stack := value
END;
IF param[0] = "-" THEN
DEC(i)
@ -72,7 +80,27 @@ BEGIN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) THEN
BaseAddress := ((value DIV 64) * 64) * 1024
options.base := ((value DIV 64) * 64) * 1024
END;
IF param[0] = "-" THEN
DEC(i)
END
ELSIF param = "-ram" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) THEN
options.ram := value
END;
IF param[0] = "-" THEN
DEC(i)
END
ELSIF param = "-rom" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) THEN
options.rom := value
END;
IF param[0] = "-" THEN
DEC(i)
@ -109,32 +137,34 @@ BEGIN
END;
INC(j)
END
END;
END
ELSIF param = "-ver" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToVer(param, major, minor) THEN
Version := major * 65536 + minor
options.version := major * 65536 + minor
END;
IF param[0] = "-" THEN
DEC(i)
END
ELSIF param = "-pic" THEN
pic := TRUE
options.pic := TRUE
ELSIF param = "" THEN
end := TRUE
ELSE
ERRORS.error3("bad parameter: ", param, "")
ERRORS.BadParam(param)
END;
INC(i)
UNTIL end
UNTIL end;
options.checking := checking
END keys;
@ -149,38 +179,34 @@ VAR
outname: PARS.PATH;
param: PARS.PATH;
temp: PARS.PATH;
target: INTEGER;
bit_depth: INTEGER;
time: INTEGER;
StackSize,
Version,
BaseAdr: INTEGER;
pic: BOOLEAN;
checking: SET;
bits64: BOOLEAN;
options: PROG.OPTIONS;
BEGIN
StackSize := 2;
Version := 65536;
pic := FALSE;
checking := ST.chkALL;
options.stack := 2;
options.version := 65536;
options.pic := FALSE;
options.checking := ST.chkALL;
PATHS.GetCurrentDirectory(app_path);
lib_path := app_path;
UTILS.GetArg(1, inname);
C.Ln;
C.String("Akron Oberon Compiler v"); C.Int(mConst.vMajor); C.String("."); C.Int2(mConst.vMinor);
C.String(" ("); C.Int(UTILS.bit_depth); C.StringLn("-bit)");
C.StringLn("Copyright (c) 2018-2019, Anton Krotov");
IF inname = "" THEN
C.String("Akron Oberon-07/16 Compiler v"); C.Int(mConst.vMajor); C.String("."); C.Int2(mConst.vMinor);
C.String(" ("); C.Int(UTILS.bit_depth); C.StringLn("-bit)"); C.Ln;
C.Ln;
C.StringLn("Usage: Compiler <main module> <output> <target> [optional settings]"); C.Ln;
IF UTILS.bit_depth = 64 THEN
C.StringLn('target = console | gui | dll | console64 | gui64 | dll64 | kos | obj | elfexe | elfexe64'); C.Ln;
C.StringLn('target = console | gui | dll | console64 | gui64 | dll64 | kos | obj | elfexe | elfso | elfexe64 | elfso64 | msp430'); C.Ln;
ELSIF UTILS.bit_depth = 32 THEN
C.StringLn('target = console | gui | dll | kos | obj | elfexe'); C.Ln;
C.StringLn('target = console | gui | dll | kos | obj | elfexe | elfso | msp430'); C.Ln;
END;
C.StringLn("optional settings:"); C.Ln;
C.StringLn(" -stk <size> set size of stack in megabytes"); C.Ln;
@ -188,14 +214,17 @@ BEGIN
C.StringLn(' -ver <major.minor> set version of program'); C.Ln;
C.StringLn(' -nochk <"ptibcwra"> disable runtime checking (pointers, types, indexes,');
C.StringLn(' BYTE, CHR, WCHR)'); C.Ln;
C.StringLn(" -ram <size> set size of RAM in bytes (MSP430)"); C.Ln;
C.StringLn(" -rom <size> set size of ROM in bytes (MSP430)"); C.Ln;
UTILS.Exit(0)
END;
PATHS.split(inname, path, modname, ext);
IF ext # mConst.FILE_EXT THEN
ERRORS.error3('inputfile name extension must be "', mConst.FILE_EXT, '"')
ERRORS.Error(207)
END;
IF PATHS.isRelative(path) THEN
PATHS.RelPath(app_path, path, temp);
path := temp
@ -203,7 +232,7 @@ BEGIN
UTILS.GetArg(2, outname);
IF outname = "" THEN
ERRORS.error1("not enough parameters")
ERRORS.Error(205)
END;
IF PATHS.isRelative(outname) THEN
PATHS.RelPath(app_path, outname, temp);
@ -212,59 +241,70 @@ BEGIN
UTILS.GetArg(3, param);
IF param = "" THEN
ERRORS.error1("not enough parameters")
ERRORS.Error(205)
END;
target := Target(param);
IF target = 0 THEN
ERRORS.error1("bad parameter <target>")
ERRORS.Error(206)
END;
bits64 := target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64, mConst.Target_iELF64};
IF bits64 THEN
IF UTILS.bit_depth = 32 THEN
ERRORS.error1("bad parameter <target>")
END;
PARS.init(64, target)
ELSE
PARS.init(32, target)
CASE target OF
|mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64, mConst.Target_iELF64, mConst.Target_iELFSO64:
bit_depth := 64
|mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL,
mConst.Target_iKolibri, mConst.Target_iObject, mConst.Target_iELF32, mConst.Target_iELFSO32:
bit_depth := 32
|mConst.Target_iMSP430:
bit_depth := 16;
options.ram := MSP430.minRAM;
options.rom := MSP430.minROM
END;
PARS.program.dll := target IN {mConst.Target_iDLL, mConst.Target_iObject, mConst.Target_iDLL64};
PARS.program.obj := target = mConst.Target_iObject;
IF UTILS.bit_depth < bit_depth THEN
ERRORS.Error(206)
END;
STRINGS.append(lib_path, "lib");
STRINGS.append(lib_path, UTILS.slash);
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN
CASE target OF
|mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL:
IF target = mConst.Target_iDLL THEN
BaseAdr := 10000000H
options.base := 10000000H
ELSE
BaseAdr := 400000H
options.base := 400000H
END;
STRINGS.append(lib_path, "Windows32")
ELSIF target IN {mConst.Target_iKolibri, mConst.Target_iObject} THEN
|mConst.Target_iKolibri, mConst.Target_iObject:
STRINGS.append(lib_path, "KolibriOS")
ELSIF target = mConst.Target_iELF32 THEN
|mConst.Target_iELF32, mConst.Target_iELFSO32:
STRINGS.append(lib_path, "Linux32")
ELSIF target = mConst.Target_iELF64 THEN
|mConst.Target_iELF64, mConst.Target_iELFSO64:
STRINGS.append(lib_path, "Linux64")
ELSIF target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN
|mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64:
STRINGS.append(lib_path, "Windows64")
|mConst.Target_iMSP430:
STRINGS.append(lib_path, "MSP430")
END;
STRINGS.append(lib_path, UTILS.slash);
keys(StackSize, BaseAdr, Version, pic, checking);
keys(options);
ST.compile(path, lib_path, modname, outname, target, Version, StackSize, BaseAdr, pic, checking);
PARS.init(bit_depth, target, options);
PARS.program.dll := target IN {mConst.Target_iELFSO32, mConst.Target_iELFSO64, mConst.Target_iDLL, mConst.Target_iDLL64, mConst.Target_iObject};
PARS.program.obj := target = mConst.Target_iObject;
ST.compile(path, lib_path, modname, outname, target, options);
time := UTILS.GetTickCount() - UTILS.time;

391
programs/develop/oberon07/Source/ELF.ob07
View File

@ -7,7 +7,7 @@
MODULE ELF;
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS;
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS, LISTS;
CONST
@ -68,9 +68,35 @@ TYPE
END;
Elf32_Dyn = POINTER TO RECORD (LISTS.ITEM)
d_tag, d_val: INTEGER
END;
Elf32_Sym = POINTER TO RECORD (LISTS.ITEM)
name, value, size: INTEGER;
info, other: CHAR;
shndx: WCHAR
END;
FILE = WR.FILE;
VAR
dynamic: LISTS.LIST;
strtab: CHL.BYTELIST;
symtab: LISTS.LIST;
hashtab, bucket, chain: CHL.INTLIST;
PROCEDURE align (n, _align: INTEGER): INTEGER;
BEGIN
IF n MOD _align # 0 THEN
@ -136,7 +162,75 @@ BEGIN
END fixup;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; amd64: BOOLEAN);
PROCEDURE NewDyn (tag, val: INTEGER);
VAR
dyn: Elf32_Dyn;
BEGIN
NEW(dyn);
dyn.d_tag := tag;
dyn.d_val := val;
LISTS.push(dynamic, dyn)
END NewDyn;
PROCEDURE NewSym (name, value, size: INTEGER; info, other: CHAR; shndx: WCHAR);
VAR
sym: Elf32_Sym;
BEGIN
NEW(sym);
sym.name := name;
sym.value := value;
sym.size := size;
sym.info := info;
sym.other := other;
sym.shndx := shndx;
LISTS.push(symtab, sym)
END NewSym;
PROCEDURE HashStr (name: ARRAY OF CHAR): INTEGER;
VAR
i, h: INTEGER;
g: SET;
BEGIN
h := 0;
i := 0;
WHILE name[i] # 0X DO
h := h * 16 + ORD(name[i]);
g := BITS(h) * {28..31};
h := ORD(BITS(h) / BITS(LSR(ORD(g), 24)) - g);
INC(i)
END
RETURN h
END HashStr;
PROCEDURE MakeHash (bucket, chain: CHL.INTLIST; symCount: INTEGER);
VAR
symi, hi, k: INTEGER;
BEGIN
FOR symi := 0 TO symCount - 1 DO
CHL.SetInt(chain, symi, 0);
hi := CHL.GetInt(hashtab, symi) MOD symCount;
IF CHL.GetInt(bucket, hi) # 0 THEN
k := symi;
WHILE CHL.GetInt(chain, k) # 0 DO
k := CHL.GetInt(chain, k)
END;
CHL.SetInt(chain, k, CHL.GetInt(bucket, hi))
END;
CHL.SetInt(bucket, hi, symi)
END
END MakeHash;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; fini: INTEGER; so, amd64: BOOLEAN);
CONST
interp = 0;
dyn = 1;
@ -145,33 +239,67 @@ CONST
data = 4;
bss = 5;
linuxInterpreter64 = "/lib64/ld-linux-x86-64.so.2";
linuxInterpreter32 = "/lib/ld-linux.so.2";
exeBaseAddress32 = 8048000H;
exeBaseAddress64 = 400000H;
dllBaseAddress = 0;
DT_NULL = 0;
DT_NEEDED = 1;
DT_HASH = 4;
DT_STRTAB = 5;
DT_SYMTAB = 6;
DT_RELA = 7;
DT_RELASZ = 8;
DT_RELAENT = 9;
DT_STRSZ = 10;
DT_SYMENT = 11;
DT_INIT = 12;
DT_FINI = 13;
DT_SONAME = 14;
DT_REL = 17;
DT_RELSZ = 18;
DT_RELENT = 19;
VAR
ehdr: Elf32_Ehdr;
phdr: ARRAY 16 OF Elf32_Phdr;
i, LoadAdr, offset, pad, VA: INTEGER;
i, BaseAdr, offset, pad, VA, symCount: INTEGER;
SizeOf: RECORD header, code, data, bss: INTEGER END;
Offset: RECORD symtab, reltab, hash, strtab, dyn: INTEGER END;
File: FILE;
str: ARRAY 40 OF CHAR; lstr: INTEGER;
Dyn: ARRAY 350 OF BYTE;
Interpreter: ARRAY 40 OF CHAR; lenInterpreter: INTEGER;
item: LISTS.ITEM;
Name: ARRAY 2048 OF CHAR;
BEGIN
IF amd64 THEN
str := "/lib64/ld-linux-x86-64.so.2"
ELSE
str := "/lib/ld-linux.so.2"
END;
lstr := LENGTH(str);
dynamic := LISTS.create(NIL);
symtab := LISTS.create(NIL);
strtab := CHL.CreateByteList();
IF amd64 THEN
LoadAdr := 400000H
BaseAdr := exeBaseAddress64;
Interpreter := linuxInterpreter64
ELSE
LoadAdr := 08048000H
BaseAdr := exeBaseAddress32;
Interpreter := linuxInterpreter32
END;
IF so THEN
BaseAdr := dllBaseAddress
END;
lenInterpreter := LENGTH(Interpreter) + 1;
SizeOf.code := CHL.Length(program.code);
SizeOf.data := CHL.Length(program.data);
SizeOf.bss := program.bss;
@ -192,7 +320,12 @@ BEGIN
ehdr.e_ident[i] := 0
END;
ehdr.e_type := WCHR(ET_EXEC);
IF so THEN
ehdr.e_type := WCHR(ET_DYN)
ELSE
ehdr.e_type := WCHR(ET_EXEC)
END;
ehdr.e_version := 1;
ehdr.e_shoff := 0;
ehdr.e_flags := 0;
@ -218,24 +351,92 @@ BEGIN
phdr[interp].p_type := 3;
phdr[interp].p_offset := SizeOf.header;
phdr[interp].p_vaddr := LoadAdr + phdr[interp].p_offset;
phdr[interp].p_paddr := LoadAdr + phdr[interp].p_offset;
phdr[interp].p_filesz := lstr + 1;
phdr[interp].p_memsz := lstr + 1;
phdr[interp].p_vaddr := BaseAdr + phdr[interp].p_offset;
phdr[interp].p_paddr := phdr[interp].p_vaddr;
phdr[interp].p_filesz := lenInterpreter;
phdr[interp].p_memsz := lenInterpreter;
phdr[interp].p_flags := PF_R;
phdr[interp].p_align := 1;
phdr[dyn].p_type := 2;
phdr[dyn].p_offset := phdr[interp].p_offset + phdr[interp].p_filesz;
phdr[dyn].p_vaddr := LoadAdr + phdr[dyn].p_offset;
phdr[dyn].p_paddr := LoadAdr + phdr[dyn].p_offset;
IF amd64 THEN
phdr[dyn].p_filesz := 0A0H;
phdr[dyn].p_memsz := 0A0H
ELSE
phdr[dyn].p_filesz := 50H;
phdr[dyn].p_memsz := 50H
phdr[dyn].p_vaddr := BaseAdr + phdr[dyn].p_offset;
phdr[dyn].p_paddr := phdr[dyn].p_vaddr;
hashtab := CHL.CreateIntList();
CHL.PushInt(hashtab, HashStr(""));
NewSym(CHL.PushStr(strtab, ""), 0, 0, 0X, 0X, 0X);
CHL.PushInt(hashtab, HashStr("dlopen"));
NewSym(CHL.PushStr(strtab, "dlopen"), 0, 0, 12X, 0X, 0X);
CHL.PushInt(hashtab, HashStr("dlsym"));
NewSym(CHL.PushStr(strtab, "dlsym"), 0, 0, 12X, 0X, 0X);
IF so THEN
item := program.exp_list.first;
WHILE item # NIL DO
ASSERT(CHL.GetStr(program.export, item(BIN.EXPRT).nameoffs, Name));
CHL.PushInt(hashtab, HashStr(Name));
NewSym(CHL.PushStr(strtab, Name), item(BIN.EXPRT).label, 0, 12X, 0X, 0X);
item := item.next
END;
ASSERT(CHL.GetStr(program.data, program.modname, Name))
END;
symCount := LISTS.count(symtab);
bucket := CHL.CreateIntList();
chain := CHL.CreateIntList();
FOR i := 1 TO symCount DO
CHL.PushInt(bucket, 0);
CHL.PushInt(chain, 0)
END;
MakeHash(bucket, chain, symCount);
NewDyn(DT_NEEDED, CHL.PushStr(strtab, "libdl.so.2"));
NewDyn(DT_STRTAB, 0);
NewDyn(DT_STRSZ, CHL.Length(strtab));
NewDyn(DT_SYMTAB, 0);
IF amd64 THEN
NewDyn(DT_SYMENT, 24);
NewDyn(DT_RELA, 0);
NewDyn(DT_RELASZ, 48);
NewDyn(DT_RELAENT, 24)
ELSE
NewDyn(DT_SYMENT, 16);
NewDyn(DT_REL, 0);
NewDyn(DT_RELSZ, 16);
NewDyn(DT_RELENT, 8)
END;
NewDyn(DT_HASH, 0);
IF so THEN
NewDyn(DT_SONAME, CHL.PushStr(strtab, Name));
NewDyn(DT_INIT, 0);
NewDyn(DT_FINI, 0)
END;
NewDyn(DT_NULL, 0);
Offset.symtab := LISTS.count(dynamic) * (8 + 8 * ORD(amd64));
Offset.reltab := Offset.symtab + symCount * (16 + 8 * ORD(amd64));
Offset.hash := Offset.reltab + (8 + 16 * ORD(amd64)) * 2;
Offset.strtab := Offset.hash + (symCount * 2 + 2) * 4;
Offset.dyn := phdr[dyn].p_offset;
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;
phdr[dyn].p_filesz := Offset.strtab + CHL.Length(strtab) + 8 + 8 * ORD(amd64);
phdr[dyn].p_memsz := phdr[dyn].p_filesz;
phdr[dyn].p_flags := PF_R;
phdr[dyn].p_align := 1;
@ -243,20 +444,15 @@ BEGIN
phdr[header].p_type := 1;
phdr[header].p_offset := offset;
phdr[header].p_vaddr := LoadAdr;
phdr[header].p_paddr := LoadAdr;
IF amd64 THEN
phdr[header].p_filesz := 305H;
phdr[header].p_memsz := 305H
ELSE
phdr[header].p_filesz := 1D0H;
phdr[header].p_memsz := 1D0H
END;
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_memsz := phdr[header].p_filesz;
phdr[header].p_flags := PF_R + PF_W;
phdr[header].p_align := 1000H;
offset := offset + phdr[header].p_filesz;
VA := LoadAdr + offset + 1000H;
VA := BaseAdr + offset + 1000H;
phdr[text].p_type := 1;
phdr[text].p_offset := offset;
@ -270,7 +466,7 @@ BEGIN
ehdr.e_entry := phdr[text].p_vaddr;
offset := offset + phdr[text].p_filesz;
VA := LoadAdr + offset + 2000H;
VA := BaseAdr + offset + 2000H;
pad := (16 - VA MOD 16) MOD 16;
phdr[data].p_type := 1;
@ -283,7 +479,7 @@ BEGIN
phdr[data].p_align := 1000H;
offset := offset + phdr[data].p_filesz;
VA := LoadAdr + offset + 3000H;
VA := BaseAdr + offset + 3000H;
phdr[bss].p_type := 1;
phdr[bss].p_offset := offset;
@ -294,7 +490,20 @@ BEGIN
phdr[bss].p_flags := PF_R + PF_W;
phdr[bss].p_align := 1000H;
fixup(program, phdr[text].p_vaddr, phdr[data].p_vaddr + pad, align(phdr[bss].p_vaddr, 16), amd64);
fixup(program, ehdr.e_entry, phdr[data].p_vaddr + pad, align(phdr[bss].p_vaddr, 16), amd64);
item := symtab.first;
WHILE item # NIL DO
IF item(Elf32_Sym).value # 0 THEN
INC(item(Elf32_Sym).value, ehdr.e_entry)
END;
item := item.next
END;
IF so THEN
item := LISTS.getidx(dynamic, 10); item(Elf32_Dyn).d_val := ehdr.e_entry;
item := LISTS.getidx(dynamic, 11); item(Elf32_Dyn).d_val := BIN.GetLabel(program, fini) + ehdr.e_entry
END;
File := WR.Create(FileName);
@ -340,34 +549,94 @@ BEGIN
WritePH(File, phdr[bss])
END;
FOR i := 0 TO lstr DO
WR.WriteByte(File, ORD(str[i]))
FOR i := 0 TO lenInterpreter - 1 DO
WR.WriteByte(File, ORD(Interpreter[i]))
END;
i := 0;
IF amd64 THEN
BIN.InitArray(Dyn, i, "01000000000000000E000000000000000500000000000000DC02400000000000");
BIN.InitArray(Dyn, i, "0A00000000000000190000000000000006000000000000004C02400000000000");
BIN.InitArray(Dyn, i, "0B00000000000000180000000000000007000000000000009402400000000000");
BIN.InitArray(Dyn, i, "0800000000000000300000000000000009000000000000001800000000000000");
BIN.InitArray(Dyn, i, "0400000000000000C40240000000000000000000000000000000000000000000");
BIN.InitArray(Dyn, i, "0000000000000000000000000000000000000000000000000100000012000000");
BIN.InitArray(Dyn, i, "0000000000000000000000000000000008000000120000000000000000000000");
BIN.InitArray(Dyn, i, "0000000000000000F50240000000000001000000010000000000000000000000");
BIN.InitArray(Dyn, i, "FD02400000000000010000000200000000000000000000000100000003000000");
BIN.InitArray(Dyn, i, "0000000001000000020000000000000000646C6F70656E00646C73796D006C69");
BIN.InitArray(Dyn, i, "62646C2E736F2E320000000000000000000000000000000000")
ELSE
BIN.InitArray(Dyn, i, "010000000E00000005000000AF8104080A000000190000000600000057810408");
BIN.InitArray(Dyn, i, "0B00000010000000110000008781040812000000100000001300000008000000");
BIN.InitArray(Dyn, i, "0400000097810408000000000000000000000000000000000000000000000000");
BIN.InitArray(Dyn, i, "0100000000000000000000001200000008000000000000000000000012000000");
BIN.InitArray(Dyn, i, "C881040801010000CC8104080102000001000000030000000000000001000000");
BIN.InitArray(Dyn, i, "020000000000000000646C6F70656E00646C73796D006C6962646C2E736F2E32");
BIN.InitArray(Dyn, i, "000000000000000000")
item := dynamic.first;
WHILE item # NIL DO
WR.Write64LE(File, item(Elf32_Dyn).d_tag);
WR.Write64LE(File, item(Elf32_Dyn).d_val);
item := item.next
END;
WR.Write(File, Dyn, i);
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);
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.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);
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);
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(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.Write32LE(File, 0);
WR.Write32LE(File, 0)
END;
CHL.WriteToFile(File, program.code);
WHILE pad > 0 DO

80
programs/develop/oberon07/Source/ERRORS.ob07
View File

@ -7,25 +7,35 @@
MODULE ERRORS;
IMPORT C := CONSOLE, UTILS;
IMPORT C := CONSOLE, UTILS, mConst := CONSTANTS;
PROCEDURE hintmsg* (name: ARRAY OF CHAR; line, col, hint: INTEGER);
PROCEDURE HintMsg* (name: ARRAY OF CHAR; line, col, hint: INTEGER);
BEGIN
IF hint = 0 THEN
C.String(" hint ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
C.String("variable '"); C.String(name); C.StringLn("' never used")
END
END hintmsg;
END HintMsg;
PROCEDURE errormsg* (fname: ARRAY OF CHAR; line, col, errno: INTEGER);
PROCEDURE WarningMsg* (line, col, warning: INTEGER);
BEGIN
C.String(" warning ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
CASE warning OF
|0: C.StringLn("passing a string value as a fixed array")
|1: C.StringLn("endless FOR loop")
END
END WarningMsg;
PROCEDURE ErrorMsg* (fname: ARRAY OF CHAR; line, col, errno: INTEGER);
VAR
str: ARRAY 80 OF CHAR;
BEGIN
C.Ln;
C.String(" error ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
C.String(" error ("); C.Int(errno); C.String(") ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
CASE errno OF
| 1: str := "missing 'H' or 'X'"
@ -36,6 +46,7 @@ BEGIN
| 6: str := "identifier too long"
| 7: str := "number too long"
| 8..12: str := "number too large"
| 13: str := "real numbers not supported"
| 21: str := "'MODULE' expected"
| 22: str := "identifier expected"
@ -79,7 +90,7 @@ BEGIN
| 60: str := "identifier does not match procedure name"
| 61: str := "illegally marked identifier"
| 62: str := "expression should be constant"
| 63: str := "'stdcall', 'ccall', 'ccall16', 'windows' or 'linux' expected"
| 63: str := "not enough RAM"
| 64: str := "'(' expected"
| 65: str := "',' expected"
| 66: str := "incompatible parameter"
@ -126,46 +137,81 @@ BEGIN
|107: str := "too large parameter of CHR"
|108: str := "a variable or a procedure expected"
|109: str := "expression should be constant"
|110: str := "'noalign' expected"
|111: str := "record [noalign] cannot have a base type"
|112: str := "record [noalign] cannot be a base type"
|113: str := "result type of procedure should not be REAL"
|114: str := "identifiers 'lib_init' and 'version' are reserved"
|115: str := "recursive constant definition"
|116: str := "procedure too deep nested"
|117: str := "'stdcall64', 'win64', 'systemv', 'windows' or 'linux' expected"
|118: str := "this flag for Windows only"
|119: str := "this flag for Linux only"
|120: str := "too many formal parameters"
|122: str := "negative divisor"
|123: str := "illegal flag"
|124: str := "unknown flag"
|125: str := "flag not supported"
END;
C.StringLn(str);
C.String(" file: "); C.StringLn(fname);
UTILS.Exit(1)
END errormsg;
END ErrorMsg;
PROCEDURE error1* (s1: ARRAY OF CHAR);
PROCEDURE Error1 (s1: ARRAY OF CHAR);
BEGIN
C.Ln;
C.StringLn(s1);
UTILS.Exit(1)
END error1;
END Error1;
PROCEDURE error3* (s1, s2, s3: ARRAY OF CHAR);
PROCEDURE Error3 (s1, s2, s3: ARRAY OF CHAR);
BEGIN
C.Ln;
C.String(s1); C.String(s2); C.StringLn(s3);
UTILS.Exit(1)
END error3;
END Error3;
PROCEDURE error5* (s1, s2, s3, s4, s5: ARRAY OF CHAR);
PROCEDURE Error5 (s1, s2, s3, s4, s5: ARRAY OF CHAR);
BEGIN
C.Ln;
C.String(s1); C.String(s2); C.String(s3); C.String(s4); C.StringLn(s5);
UTILS.Exit(1)
END error5;
END Error5;
PROCEDURE WrongRTL* (ProcName: ARRAY OF CHAR);
BEGIN
Error5("procedure ", mConst.RTL_NAME, ".", ProcName, " not found")
END WrongRTL;
PROCEDURE BadParam* (param: ARRAY OF CHAR);
BEGIN
Error3("bad parameter: ", param, "")
END BadParam;
PROCEDURE FileNotFound* (Path, Name, Ext: ARRAY OF CHAR);
BEGIN
Error5("file ", Path, Name, Ext, " not found")
END FileNotFound;
PROCEDURE Error* (n: INTEGER);
BEGIN
CASE n OF
|201: Error1("writing file error")
|202: Error1("too many relocations")
|203: Error1("size of program is too large")
|204: Error1("size of global variables is too large")
|205: Error1("not enough parameters")
|206: Error1("bad parameter <target>")
|207: Error3('inputfile name extension must be "', mConst.FILE_EXT, '"')
END
END Error;
END ERRORS.

2
programs/develop/oberon07/Source/FILES.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)

1182
programs/develop/oberon07/Source/IL.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

2
programs/develop/oberon07/Source/KOS.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)

20
programs/develop/oberon07/Source/LISTS.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
@ -168,6 +168,24 @@ BEGIN
END count;
PROCEDURE getidx* (list: LIST; idx: INTEGER): ITEM;
VAR
item: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(idx >= 0);
item := list.first;
WHILE (item # NIL) & (idx > 0) DO
item := item.next;
DEC(idx)
END
RETURN item
END getidx;
PROCEDURE create* (list: LIST): LIST;
BEGIN
IF list = NIL THEN

4
programs/develop/oberon07/Source/MSCOFF.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
@ -136,7 +136,7 @@ VAR
PROCEDURE SetNumberOfRelocations (VAR section: SH; NumberOfRelocations: INTEGER);
BEGIN
IF NumberOfRelocations >= 65536 THEN
ERRORS.error1("too many relocations")
ERRORS.Error(202)
END;
section.NumberOfRelocations := WCHR(NumberOfRelocations)
END SetNumberOfRelocations;

1793
programs/develop/oberon07/Source/MSP430.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

677
programs/develop/oberon07/Source/MSP430RTL.ob07 Normal file
View File

@ -0,0 +1,677 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE MSP430RTL;
CONST
_mul* = 0;
_divmod* = 1;
_lsl* = 2;
_asr* = 3;
_ror* = 4;
_lsr* = 5;
_in* = 6;
_in2* = 7;
_set1* = 8;
_incl* = 9;
_excl* = 10;
_move* = 11;
_set* = 12;
_arrcpy* = 13;
_rot* = 14;
_strcmp* = 15;
_error* = 16;
_is* = 17;
_guard* = 18;
_guardrec* = 19;
_length* = 20;
_new* = 21;
HP = 14;
LenIV* = 32;
iv = 10000H - LenIV * 2;
sp = iv - 2;
empty_proc* = sp - 2;
free_size = empty_proc - 2;
free_adr = free_size - 2;
bits = free_adr - 272;
bits_offs = bits - 32;
DataSize* = iv - bits_offs;
types = bits_offs - 2;
IntVectorSize* = LenIV * 2 + DataSize;
VarSize* = 4;
TYPE
EMITPROC = PROCEDURE (n: INTEGER);
VAR
ram*, trap*, int*: INTEGER;
rtl*: ARRAY 22 OF
RECORD
label*: INTEGER;
used: BOOLEAN
END;
Label, Word, Call: EMITPROC;
PROCEDURE Gen*;
PROCEDURE Word1 (word: INTEGER);
BEGIN
Word(word)
END Word1;
PROCEDURE Word2 (word1, word2: INTEGER);
BEGIN
Word1(word1);
Word1(word2)
END Word2;
PROCEDURE Word3 (word1, word2, word3: INTEGER);
BEGIN
Word1(word1);
Word1(word2);
Word1(word3)
END Word3;
BEGIN
(* _lsl (n, x: INTEGER): INTEGER *)
IF rtl[_lsl].used THEN
Label(rtl[_lsl].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 3); (* JZ L1 *)
(* L2: *)
Word1(5404H); (* ADD R4, R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 3); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _asr (n, x: INTEGER): INTEGER *)
IF rtl[_asr].used THEN
Label(rtl[_asr].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 3); (* JZ L1 *)
(* L2: *)
Word1(1104H); (* RRA R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 3); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _ror (n, x: INTEGER): INTEGER *)
IF rtl[_ror].used THEN
Label(rtl[_ror].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 5); (* JZ L1 *)
Word1(4406H); (* MOV R4, R6 *)
(* L2: *)
Word1(1006H); (* RRC R6 *)
Word1(1004H); (* RRC R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 4); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _lsr (n, x: INTEGER): INTEGER *)
IF rtl[_lsr].used THEN
Label(rtl[_lsr].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- n *)
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- x *)
Word2(0F035H, 15); (* AND #15, R5 *)
Word1(2400H + 4); (* JZ L1 *)
(* L2: *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1004H); (* RRC R4 *)
Word1(8315H); (* SUB #1, R5 *)
Word1(2000H + 400H - 4); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _set (b, a: INTEGER): SET *)
IF rtl[_set].used THEN
Label(rtl[_set].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- b *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- a *)
Word1(9504H); (* CMP R5, R4 *)
Word1(3800H + 24); (* JL L1 *)
Word2(9035H, 16); (* CMP #16, R5 *)
Word1(3400H + 21); (* JGE L1 *)
Word1(9304H); (* CMP #0, R4 *)
Word1(3800H + 19); (* JL L1 *)
Word2(9034H, 16); (* CMP #16, R4 *)
Word1(3800H + 2); (* JL L2 *)
Word2(4034H, 15); (* MOV #15, R4 *)
(* L2: *)
Word1(9305H); (* CMP #0, R5 *)
Word1(3400H + 1); (* JGE L3 *)
Word1(4305H); (* MOV #0, R5 *)
(* L3: *)
Word1(8504H); (* SUB R5, R4 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits_offs); (* ADD bits_offs, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word1(5505H); (* ADD R5, R5 *)
Word1(5405H); (* ADD R4, R5 *)
Word2(5035H, bits); (* ADD bits, R5 *)
Word1(4524H); (* MOV @R5, R4 *)
Word1(4130H); (* MOV @SP+, PC *)
(* L1: *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H) (* RET *)
END;
(* _set1 (a: INTEGER): SET *)
IF rtl[_set1].used THEN
Label(rtl[_set1].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- a *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 5); (* JNZ L1 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word1(4130H); (* MOV @SP+, PC *)
(* L1: *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H) (* RET *)
END;
(* _in2 (i, s: INTEGER): BOOLEAN *)
IF rtl[_in2].used THEN
Label(rtl[_in2].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- i *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(0F114H, 4); (* AND 4(SP), R4 *)
Word1(2400H + 1); (* JZ L1 *)
Word1(4314H); (* MOV #1, R4 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _in (s, i: INTEGER): BOOLEAN *)
IF rtl[_in].used THEN
Label(rtl[_in].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 9); (* JNZ L2 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(0F114H, 2); (* AND 2(SP), R4 *)
Word1(2400H + 3); (* JZ L1 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4130H); (* MOV @SP+, PC *)
(* L2: *)
Word1(4304H); (* MOV #0, R4 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _incl (VAR s: SET; i: INTEGER) *)
IF rtl[_incl].used THEN
Label(rtl[_incl].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 8); (* JNZ L1 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- @s *)
Word2(0D485H, 0); (* BIS R4, 0(R5) *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _excl (VAR s: SET; i: INTEGER) *)
IF rtl[_excl].used THEN
Label(rtl[_excl].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- i *)
Word2(0B034H, 0FFF0H); (* BIT #0FFF0H, R4 *)
Word1(2000H + 8); (* JNZ L1 *)
Word1(5404H); (* ADD R4, R4 *)
Word2(5034H, bits); (* ADD bits, R4 *)
Word1(4424H); (* MOV @R4, R4 *)
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- @s *)
Word2(0C485H, 0); (* BIC R4, 0(R5) *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _rot (len, adr: INTEGER) *)
IF rtl[_rot].used THEN
Label(rtl[_rot].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- len *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- adr *)
Word1(8314H); (* SUB #1, R4 *)
Word1(5404H); (* ADD R4, R4 *)
Word1(1225H); (* PUSH @R5 *)
Word1(4406H); (* MOV R4, R6 *)
(* L1: *)
Word3(4595H, 2, 0); (* MOV 2(R5), 0(R5) *)
Word1(5325H); (* ADD #2, R5 *)
Word1(8326H); (* SUB #2, R6 *)
Word1(2000H + 400H - 6); (* JNZ L1 *)
Word2(41B5H, 0); (* MOV @SP+, 0(R5) *)
Word1(4130H) (* RET *)
END;
(* _divmod (b, a: INTEGER): INTEGER (* res -> R4, mod -> R5 *) *)
IF rtl[_divmod].used THEN
Label(rtl[_divmod].label);
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- a *)
Word1(4304H); (* MOV #0, R4 *)
(* L1: *)
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- b *)
Word1(9605H); (* CMP R6, R5 *)
Word1(3800H + 17); (* JL L3 *)
Word1(4327H); (* MOV #2, R7 *)
Word1(5606H); (* ADD R6, R6 *)
(* L4: *)
Word1(9306H); (* CMP #0, R6 *)
Word1(2400H + 6); (* JZ L2 *)
Word1(3800H + 5); (* JL L2 *)
Word1(9605H); (* CMP R6, R5 *)
Word1(3800H + 3); (* JL L2 *)
Word1(5606H); (* ADD R6, R6 *)
Word1(5707H); (* ADD R7, R7 *)
Word1(3C00H + 400H - 8); (* JMP L4 *)
(* L2: *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1006H); (* RRC R6 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1007H); (* RRC R7 *)
Word1(8605H); (* SUB R6, R5 *)
Word1(5704H); (* ADD R7, R4 *)
Word1(3C00H + 400H - 21); (* JMP L1 *)
(* L3: *)
(*----------- (a < 0) --------------*)
(* L1: *)
Word1(9305H); (* CMP #0, R5 *)
Word1(3400H + 23); (* JGE L3 *)
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- b *)
Word1(4327H); (* MOV #2, R7 *)
Word1(5606H); (* ADD R6, R6 *)
Word1(0E335H); (* XOR #-1, R5 *)
Word1(5315H); (* ADD #1, R5 *)
(* L4: *)
Word1(9306H); (* CMP #0, R6 *)
Word1(2400H + 6); (* JZ L2 *)
Word1(3800H + 5); (* JL L2 *)
Word1(9605H); (* CMP R6, R5 *)
Word1(3800H + 3); (* JL L2 *)
Word1(5606H); (* ADD R6, R6 *)
Word1(5707H); (* ADD R7, R7 *)
Word1(3C00H + 400H - 8); (* JMP L4 *)
(* L2: *)
Word1(0E335H); (* XOR #-1, R5 *)
Word1(5315H); (* ADD #1, R5 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1006H); (* RRC R6 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1007H); (* RRC R7 *)
Word1(5605H); (* ADD R6, R5 *)
Word1(8704H); (* SUB R7, R4 *)
Word1(3C00H + 400H - 25); (* JMP L1 *)
(* L3: *)
Word1(4130H) (* RET *)
END;
(* _mul (a, b: INTEGER): INTEGER *)
IF rtl[_mul].used THEN
Label(rtl[_mul].label);
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- a *)
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- b *)
Word1(4304H); (* MOV #0, R4; res := 0 *)
Word1(9306H); (* CMP #0, R6 *)
Word1(2400H + 7); (* JZ L1 *)
(* L2: *)
Word1(0B316H); (* BIT #1, R6 *)
Word1(2400H + 1); (* JZ L3 *)
Word1(5504H); (* ADD R5, R4 *)
(* L3: *)
Word1(5505H); (* ADD R5, R5 *)
Word1(0C312H); (* BIC #1, SR *)
Word1(1006H); (* RRC R6 *)
Word1(2000H + 400H - 7); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _error (module, err, line: INTEGER) *)
IF rtl[_error].used THEN
Label(rtl[_error].label);
Word1(0C232H); (* BIC #8, SR; DINT *)
Word1(4303H); (* MOV R3, R3; NOP *)
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- module *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- err *)
Word2(4116H, 6); (* MOV 6(SP), R6; R6 <- line *)
Word2(4211H, sp); (* MOV sp(SR), SP *)
Word1(1206H); (* PUSH R6 *)
Word1(1204H); (* PUSH R4 *)
Word1(1205H); (* PUSH R5 *)
Word2(4214H, trap); (* MOV trap(SR), R4 *)
Word1(9304H); (* TST R4 *)
Word1(2400H + 1); (* JZ L *)
Word1(1284H); (* CALL R4 *)
(* L: *)
Word2(04032H, 0F0H) (* MOV CPUOFF+OSCOFF+SCG0+SCG1, SR *)
END;
(* _new (t, size: INTEGER; VAR ptr: INTEGER) *)
IF rtl[_new].used THEN
Label(rtl[_new].label);
Word1(1202H); (* PUSH SR *)
Word1(4302H); (* MOV #0, SR *)
Word1(4303H); (* NOP *)
Word1(4104H); (* MOV SP, R4 *)
Word2(8034H, 16); (* SUB #16, R4 *)
Word1(4005H + 100H * HP); (* MOV HP, R5 *)
Word2(5115H, 6); (* ADD 6(SP), R5 *)
Word1(9504H); (* CMP R5, R4 *)
Word2(4114H, 8); (* MOV 8(SP), R4 *)
Word1(3800H + 12); (* JL L1 *)
Word3(4190H + HP, 4, 0); (* MOV 4(SP), 0(HP) *)
Word1(5320H + HP); (* ADD #2, HP *)
Word2(4084H + 100H * HP, 0); (* MOV HP, 0(R4) *)
(* L3 *)
Word2(4380H + HP, 0); (* MOV #0, 0(HP) *)
Word1(5320H + HP); (* ADD #2, HP *)
Word1(9500H + HP); (* CMP R5, HP *)
Word1(3800H + 400H - 5); (* JL L3 *)
Word1(3C00H + 2); (* JMP L2 *)
(* L1 *)
Word2(4384H, 0); (* MOV #0, 0(R4) *)
(* L2 *)
Word1(1300H) (* RETI *)
END;
(* _guardrec (t0, t1: INTEGER): INTEGER *)
IF rtl[_guardrec].used THEN
Label(rtl[_guardrec].label);
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- t0 *)
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- t1 *)
Word2(4036H, types); (* MOV #types, R6 *)
(* L3: *)
Word1(9305H); (* CMP #0, R5 *)
Word1(2400H + 8); (* JZ L1 *)
Word1(9405H); (* CMP R4, R5 *)
Word1(2400H + 10); (* JZ L2 *)
Word1(5505H); (* ADD R5, R5 *)
Word1(0E335H); (* XOR #-1, R5 *)
Word1(5315H); (* ADD #1, R5 *)
Word1(5605H); (* ADD R6, R5 *)
Word1(4525H); (* MOV @R5, R5 *)
Word1(3C00H + 400H - 10); (* JMP L3 *)
(* L1: *)
Word1(9405H); (* CMP R4, R5 *)
Word1(2400H + 2); (* JZ L2 *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H); (* MOV @SP+, PC *)
(* L2: *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4130H) (* RET *)
END;
(* _is (t, p: INTEGER): INTEGER *)
IF rtl[_is].used THEN
Label(rtl[_is].label);
Word2(4114H, 4); (* MOV 4(SP), R4; R4 <- p *)
Word2(4115H, 2); (* MOV 2(SP), R5; R5 <- t *)
Word1(9304H); (* TST R4 *)
Word1(2400H + 2); (* JZ L *)
Word2(4414H, -2); (* MOV -2(R4), R4 *)
(* L: *)
Word1(1204H); (* PUSH R4 *)
Word1(1205H); (* PUSH R5 *)
Call(rtl[_guardrec].label); (* CALL _guardrec *)
Word1(5221H); (* ADD #4, SP *)
Word1(4130H) (* RET *)
END;
(* _guard (t, p: INTEGER): INTEGER *)
IF rtl[_guard].used THEN
Label(rtl[_guard].label);
Word2(4115H, 4); (* MOV 4(SP), R5; R5 <- p *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4525H); (* MOV @R5, R5 *)
Word1(9305H); (* TST R5 *)
Word1(2400H + 9); (* JZ L *)
Word2(4515H, -2); (* MOV -2(R5), R5 *)
Word2(4114H, 2); (* MOV 2(SP), R4; R4 <- t *)
Word1(1205H); (* PUSH R5 *)
Word1(1204H); (* PUSH R4 *)
Call(rtl[_guardrec].label); (* CALL _guardrec *)
Word1(5221H); (* ADD #4, SP *)
(* L: *)
Word1(4130H) (* RET *)
END;
(* _move (bytes, dest, source: INTEGER) *)
IF rtl[_move].used THEN
Label(rtl[_move].label);
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- bytes *)
Word2(4117H, 4); (* MOV 4(SP), R7; R7 <- dest *)
Word2(4115H, 6); (* MOV 6(SP), R5; R5 <- source *)
Word1(9306H); (* CMP #0, R6 *)
Word1(3800H + 6); (* JL L1 *)
Word1(2400H + 5); (* JZ L1 *)
(* L2: *)
Word2(45F7H, 0); (* MOV.B @R5+, 0(R7) *)
Word1(5317H); (* ADD #1, R7 *)
Word1(8316H); (* SUB #1, R6 *)
Word1(2000H + 400H - 5); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _arrcpy (base_size, len_dst, dst, len_src, src: INTEGER) *)
IF rtl[_arrcpy].used THEN
Label(rtl[_arrcpy].label);
Word3(9191H, 8, 4); (* CMP 8(SP), 4(SP) *)
Word1(3800H + 18); (* JL L1 *)
Word2(1211H, 12); (* PUSH 12(SP) *)
Word2(1211H, 10); (* PUSH 10(SP) *)
Word2(1211H, 14); (* PUSH 14(SP) *)
Word2(1211H, 10); (* PUSH 10(SP) *)
Call(rtl[_mul].label); (* CALL _mul *)
Word1(5221H); (* ADD #4, SP *)
Word1(1204H); (* PUSH R4 *)
Call(rtl[_move].label); (* CALL _move *)
Word2(5031H, 6); (* ADD #6, SP *)
Word1(4314H); (* MOV #1, R4 *)
Word1(4130H); (* RET *)
(* L1 *)
Word1(4304H); (* MOV #0, R4 *)
Word1(4130H) (* RET *)
END;
(* _length (len, str: INTEGER): INTEGER *)
IF rtl[_length].used THEN
Label(rtl[_length].label);
Word2(4116H, 2); (* MOV 2(SP), R6; R6 <- len *)
Word2(4117H, 4); (* MOV 4(SP), R7; R7 <- str *)
Word1(4304H); (* MOV #0, R4; res := 0 *)
(* L2: *)
Word1(4775H); (* MOV.B @R7+, R5 *)
Word1(9305H); (* CMP #0, R5 *)
Word1(2400H + 3); (* JZ L1 *)
Word1(5314H); (* ADD #1, R4 *)
Word1(8316H); (* SUB #1, R6 *)
Word1(2000H + 400H - 6); (* JNZ L2 *)
(* L1: *)
Word1(4130H) (* RET *)
END;
(* _strcmp (op, len2, str2, len1, str1: INTEGER): BOOLEAN *)
IF rtl[_strcmp].used THEN
Label(rtl[_strcmp].label);
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- len2 *)
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- len1 *)
Word1(9607H); (* CMP R6, R7 *)
Word1(3400H + 1); (* JGE L5 *)
Word1(4706H); (* MOV R7, R6 *)
(* L5: *)
Word1(1206H); (* PUSH R6 *)
Word2(4116H, 12); (* MOV 12(SP), R6; R6 <- str1 *)
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- str2 *)
(* L3: *)
Word2(9381H, 0); (* CMP #0, 0(SP) *)
Word1(2400H + 11); (* JZ L1 *)
Word1(4674H); (* MOV.B @R6+, R4 *)
Word1(4775H); (* MOV.B @R7+, R5 *)
Word2(8391H, 0); (* SUB #1, 0(SP) *)
Word1(9405H); (* CMP R4, R5 *)
Word1(2400H + 2); (* JZ L2 *)
Word1(8504H); (* SUB R5, R4 *)
Word1(3C00H + 5); (* JMP L4 *)
(* L2: *)
Word1(9304H); (* CMP #0, R4 *)
Word1(2000H + 400H - 13); (* JNZ L3 *)
Word1(3C00H + 2); (* JMP L4 *)
(* L1: *)
Word2(4034H, 8000H); (* MOV #8000H, R4 *)
(* L4: *)
Word1(5321H); (* ADD #2, SP *)
Word2(9034H, 8000H); (* CMP #8000H, R4 *)
Word1(2000H + 18); (* JNZ L6 *)
Word2(4116H, 4); (* MOV 4(SP), R6; R6 <- len2 *)
Word2(4117H, 8); (* MOV 8(SP), R7; R7 <- len1 *)
Word1(9607H); (* CMP R6, R7 *)
Word1(2400H + 11); (* JZ L7 *)
Word1(3800H + 4); (* JL L8 *)
Word2(5116H, 10); (* ADD 10(SP), R6 *)
Word1(4664H); (* MOV.B @R6, R4 *)
Word1(3C00H + 7); (* JMP L6 *)
(* L8: *)
Word2(5117H, 6); (* ADD 6(SP), R7 *)
Word1(4764H); (* MOV.B @R7, R4 *)
Word1(0E334H); (* XOR #-1, R4 *)
Word1(5314H); (* ADD #1, R4 *)
Word1(3C00H + 1); (* JMP L6 *)
(* L7: *)
Word1(4304H); (* MOV #0, R4 *)
(* L6: *)
Word2(5110H, 2); (* ADD 2(SP), PC; PC <- PC + op *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(2400H + 1); (* JZ L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(4303H); (* NOP *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(2000H + 1); (* JNZ L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(4303H); (* NOP *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(3800H + 1); (* JL L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(4303H); (* NOP *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(3800H + 2); (* JL L *)
Word1(2400H + 1); (* JZ L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4304H); (* MOV #0, R4 *)
Word1(3800H + 2); (* JL L *)
Word1(2400H + 1); (* JZ L *)
Word1(4314H); (* MOV #1, R4 *)
(* L *)
Word1(4130H); (* RET *)
Word1(9304H); (* CMP #0, R4 *)
Word1(4314H); (* MOV #1, R4 *)
Word1(3400H + 1); (* JGE L *)
Word1(4304H); (* MOV #0, R4 *)
(* L *)
Word1(4130H) (* RET *)
END
END Gen;
PROCEDURE Set* (idx, label: INTEGER);
BEGIN
rtl[idx].label := label;
rtl[idx].used := FALSE
END Set;
PROCEDURE Used* (idx: INTEGER);
BEGIN
rtl[idx].used := TRUE;
IF (idx = _guard) OR (idx = _is) THEN
rtl[_guardrec].used := TRUE
ELSIF idx = _arrcpy THEN
rtl[_move].used := TRUE;
rtl[_mul].used := TRUE
END
END Used;
PROCEDURE Init* (pLabel, pWord, pCall: EMITPROC; ramSize: INTEGER);
BEGIN
Label := pLabel;
Word := pWord;
Call := pCall;
IF ramSize > 2048 THEN
ram := 1100H
ELSE
ram := 200H
END;
trap := ram;
int := trap + 2
END Init;
END MSP430RTL.

397
programs/develop/oberon07/Source/PARS.ob07
View File

@ -7,7 +7,7 @@
MODULE PARS;
IMPORT PROG, SCAN, ARITH, STRINGS, ERRORS, LISTS, CODE, CONSOLE, PATHS, MACHINE, C := COLLECTIONS, mConst := CONSTANTS;
IMPORT PROG, SCAN, ARITH, STRINGS, ERRORS, LISTS, IL, CONSOLE, PATHS, UTILS, C := COLLECTIONS, mConst := CONSTANTS;
CONST
@ -24,6 +24,12 @@ TYPE
PARSER* = POINTER TO rPARSER;
POSITION* = RECORD (SCAN.POSITION)
parser*: PARSER
END;
EXPR* = RECORD
obj*: INTEGER;
@ -37,7 +43,7 @@ TYPE
STATPROC = PROCEDURE (parser: PARSER);
EXPRPROC = PROCEDURE (parser: PARSER; VAR e: EXPR);
RETPROC = PROCEDURE (parser: PARSER; e: EXPR; t: PROG.TYPE_; pos: SCAN.POSITION): BOOLEAN;
RETPROC = PROCEDURE (parser: PARSER; e: EXPR; t: PROG.TYPE_; pos: POSITION): BOOLEAN;
rPARSER = RECORD (C.ITEM)
@ -83,34 +89,40 @@ BEGIN
END destroy;
PROCEDURE error* (parser: PARSER; pos: SCAN.POSITION; errno: INTEGER);
PROCEDURE getpos (parser: PARSER; VAR pos: POSITION);
BEGIN
ERRORS.errormsg(parser.fname, pos.line, pos.col, errno)
pos.line := parser.lex.pos.line;
pos.col := parser.lex.pos.col;
pos.parser := parser
END getpos;
PROCEDURE error* (pos: POSITION; errno: INTEGER);
BEGIN
ERRORS.ErrorMsg(pos.parser.fname, pos.line, pos.col, errno)
END error;
PROCEDURE check* (condition: BOOLEAN; parser: PARSER; pos: SCAN.POSITION; errno: INTEGER);
PROCEDURE check* (condition: BOOLEAN; pos: POSITION; errno: INTEGER);
BEGIN
IF ~condition THEN
error(parser, pos, errno)
error(pos, errno)
END
END check;
PROCEDURE check1* (condition: BOOLEAN; parser: PARSER; errno: INTEGER);
VAR
pos: POSITION;
BEGIN
IF ~condition THEN
error(parser, parser.lex.pos, errno)
getpos(parser, pos);
error(pos, errno)
END
END check1;
PROCEDURE getpos (parser: PARSER; VAR pos: SCAN.POSITION);
BEGIN
pos := parser.lex.pos
END getpos;
PROCEDURE Next* (parser: PARSER);
VAR
errno: INTEGER;
@ -118,6 +130,14 @@ VAR
BEGIN
SCAN.Next(parser.scanner, parser.lex);
errno := parser.lex.error;
IF (errno = 0) & (program.target.sys = mConst.Target_iMSP430) THEN
IF parser.lex.sym = SCAN.lxFLOAT THEN
errno := -SCAN.lxERROR13
ELSIF (parser.lex.sym = SCAN.lxCHAR) & (parser.lex.value.typ = ARITH.tWCHAR) THEN
errno := -SCAN.lxERROR10
END
END;
IF errno # 0 THEN
check1(FALSE, parser, errno)
END;
@ -125,10 +145,10 @@ BEGIN
END Next;
PROCEDURE NextPos* (parser: PARSER; VAR pos: SCAN.POSITION);
PROCEDURE NextPos (parser: PARSER; VAR pos: POSITION);
BEGIN
Next(parser);
pos := parser.lex.pos
getpos(parser, pos)
END NextPos;
@ -180,15 +200,12 @@ PROCEDURE ImportList (parser: PARSER);
VAR
name: SCAN.IDENT;
parser2: PARSER;
pos: SCAN.POSITION;
pos: POSITION;
alias: BOOLEAN;
unit: PROG.UNIT;
ident: PROG.IDENT;
units: PROG.UNITS;
BEGIN
units := program.units;
alias := FALSE;
REPEAT
@ -199,18 +216,18 @@ BEGIN
getpos(parser, pos);
IF ~alias THEN
ident := parser.unit.idents.add(parser.unit, name, PROG.idMODULE);
check(ident # NIL, parser, pos, 30)
ident := PROG.addIdent(parser.unit, name, PROG.idMODULE);
check(ident # NIL, pos, 30)
END;
Next(parser);
IF (parser.sym = SCAN.lxCOMMA) OR (parser.sym = SCAN.lxSEMI) THEN
alias := FALSE;
unit := units.get(units, name);
unit := PROG.getUnit(program, name);
IF unit # NIL THEN
check(unit.closed, parser, pos, 31)
check(unit.closed, pos, 31)
ELSE
parser2 := parser.create(parser.path, parser.lib_path,
parser.StatSeq, parser.expression, parser.designator, parser.chkreturn);
@ -220,9 +237,9 @@ BEGIN
destroy(parser2);
parser2 := parser.create(parser.lib_path, parser.lib_path,
parser.StatSeq, parser.expression, parser.designator, parser.chkreturn);
check(parser2.open(parser2, name.s), parser, pos, 29)
check(parser2.open(parser2, name.s), pos, 29)
ELSE
check(FALSE, parser, pos, 29)
error(pos, 29)
END
END;
@ -257,7 +274,7 @@ VAR
BEGIN
ASSERT(parser.sym = SCAN.lxIDENT);
ident := parser.unit.idents.get(parser.unit, parser.lex.ident, FALSE);
ident := PROG.getIdent(parser.unit, parser.lex.ident, FALSE);
IF ~forward THEN
check1(ident # NIL, parser, 48)
@ -267,7 +284,7 @@ BEGIN
unit := ident.unit;
ExpectSym(parser, SCAN.lxPOINT);
ExpectSym(parser, SCAN.lxIDENT);
ident := unit.idents.get(unit, parser.lex.ident, FALSE);
ident := PROG.getIdent(unit, parser.lex.ident, FALSE);
check1((ident # NIL) & ident.export, parser, 48)
END
@ -312,21 +329,20 @@ BEGIN
END;
ARITH.setbool(v, bool)
END strcmp;
PROCEDURE ConstExpression* (parser: PARSER; VAR v: ARITH.VALUE);
VAR
e: EXPR;
pos: SCAN.POSITION;
pos: POSITION;
BEGIN
getpos(parser, pos);
parser.constexp := TRUE;
parser.expression(parser, e);
parser.constexp := FALSE;
check(e.obj = eCONST, parser, pos, 62);
check(e.obj = eCONST, pos, 62);
v := e.value
END ConstExpression;
@ -335,7 +351,7 @@ PROCEDURE FieldList (parser: PARSER; rec: PROG.TYPE_);
VAR
name: SCAN.IDENT;
export: BOOLEAN;
pos: SCAN.POSITION;
pos: POSITION;
BEGIN
ASSERT(parser.sym = SCAN.lxIDENT);
@ -355,7 +371,7 @@ BEGIN
Next(parser)
END;
check(rec.fields.add(rec, name, export), parser, pos, 30);
check(PROG.addField(rec, name, export), pos, 30);
IF parser.sym = SCAN.lxCOMMA THEN
ExpectSym(parser, SCAN.lxIDENT)
@ -391,7 +407,7 @@ VAR
exit := FALSE;
WHILE (parser.sym = SCAN.lxIDENT) & ~exit DO
check1(type.params.add(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)
@ -412,13 +428,13 @@ VAR
t1 := t0;
WHILE dim > 0 DO
t1 := program.enterType(program, PROG.tARRAY, -1, 0, parser.unit);
t1 := PROG.enterType(program, PROG.tARRAY, -1, 0, parser.unit);
t1.base := t0;
t0 := t1;
DEC(dim)
END;
type.params.set(type, t1);
PROG.setParams(type, t1);
Next(parser);
exit := TRUE
ELSE
@ -449,7 +465,7 @@ BEGIN
ExpectSym(parser, SCAN.lxIDENT);
ident := QIdent(parser, FALSE);
check1(ident.typ = PROG.idTYPE, parser, 68);
check1((ident.type.typ # PROG.tRECORD) & (ident.type.typ # PROG.tARRAY), parser, 69);
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)
@ -461,54 +477,83 @@ BEGIN
END FormalParameters;
PROCEDURE sysflag (parser: PARSER): INTEGER;
PROCEDURE sysflag (parser: PARSER; proc: BOOLEAN): INTEGER;
VAR
res: INTEGER;
res, sf: INTEGER;
BEGIN
IF parser.lex.s = "stdcall" THEN
res := PROG.stdcall
sf := PROG.sf_stdcall
ELSIF parser.lex.s = "stdcall64" THEN
res := PROG.stdcall64
sf := PROG.sf_stdcall64
ELSIF parser.lex.s = "ccall" THEN
res := PROG.ccall
sf := PROG.sf_ccall
ELSIF parser.lex.s = "ccall16" THEN
res := PROG.ccall16
sf := PROG.sf_ccall16
ELSIF parser.lex.s = "win64" THEN
res := PROG.win64
sf := PROG.sf_win64
ELSIF parser.lex.s = "systemv" THEN
res := PROG.systemv
sf := PROG.sf_systemv
ELSIF parser.lex.s = "windows" THEN
sf := PROG.sf_windows
ELSIF parser.lex.s = "linux" THEN
sf := PROG.sf_linux
ELSIF parser.lex.s = "code" THEN
sf := PROG.sf_code
ELSIF parser.lex.s = "noalign" THEN
sf := PROG.sf_noalign
ELSE
check1(FALSE, parser, 124)
END;
check1(sf IN program.target.sysflags, parser, 125);
IF proc THEN
check1(sf IN PROG.proc_flags, parser, 123)
ELSE
check1(sf IN PROG.rec_flags, parser, 123)
END;
CASE sf OF
|PROG.sf_stdcall:
res := PROG.stdcall
|PROG.sf_stdcall64:
res := PROG.stdcall64
|PROG.sf_ccall:
res := PROG.ccall
|PROG.sf_ccall16:
res := PROG.ccall16
|PROG.sf_win64:
res := PROG.win64
|PROG.sf_systemv:
res := PROG.systemv
|PROG.sf_code:
res := PROG.code
|PROG.sf_windows:
IF program.target.sys IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN
res := PROG.stdcall
ELSIF program.target.sys IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN
res := PROG.win64
ELSE
check1(FALSE, parser, 118)
END
ELSIF parser.lex.s = "linux" THEN
IF program.target.sys = mConst.Target_iELF32 THEN
|PROG.sf_linux:
IF program.target.sys IN {mConst.Target_iELF32, mConst.Target_iELFSO32} THEN
res := PROG.ccall16
ELSIF program.target.sys = mConst.Target_iELF64 THEN
ELSIF program.target.sys IN {mConst.Target_iELF64, mConst.Target_iELFSO64} THEN
res := PROG.systemv
ELSE
check1(FALSE, parser, 119)
END
ELSIF parser.lex.s = "noalign" THEN
|PROG.sf_noalign:
res := PROG.noalign
ELSE
res := 0
END
RETURN res
END sysflag;
PROCEDURE procflag (parser: PARSER; VAR import: CODE.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: SCAN.POSITION;
pos: POSITION;
BEGIN
@ -518,12 +563,7 @@ BEGIN
getpos(parser, pos);
check1(parser.unit.sysimport, parser, 54);
Next(parser);
call := sysflag(parser);
IF program.target.bit_depth = 64 THEN
check1(call IN PROG.callconv64, parser, 117)
ELSIF program.target.bit_depth = 32 THEN
check1(call IN PROG.callconv32, parser, 63)
END;
call := sysflag(parser, TRUE);
Next(parser);
IF parser.sym = SCAN.lxMINUS THEN
Next(parser);
@ -539,20 +579,21 @@ BEGIN
ExpectSym(parser, SCAN.lxSTRING);
proc := parser.lex.s;
Next(parser);
import := CODE.AddImp(dll, proc)
import := IL.AddImp(dll, proc)
END;
checklex(parser, SCAN.lxRSQUARE);
Next(parser)
ELSE
IF program.target.bit_depth = 32 THEN
call := PROG.default
ELSIF program.target.bit_depth = 64 THEN
call := PROG.default64
CASE program.target.bit_depth OF
|16: call := PROG.default16
|32: call := PROG.default32
|64: call := PROG.default64
END
END;
IF import # NIL THEN
check(~(program.target.sys IN {mConst.Target_iELF32, mConst.Target_iELF64}), parser, pos, 70)
check(~(program.target.sys IN {mConst.Target_iELF32, mConst.Target_iELF64, mConst.Target_iELFSO32,
mConst.Target_iELFSO64, mConst.Target_iMSP430}), pos, 70)
END
RETURN call
@ -570,12 +611,12 @@ VAR
typeSize: ARITH.VALUE;
ident: PROG.IDENT;
unit: PROG.UNIT;
pos, pos2: SCAN.POSITION;
pos, pos2: POSITION;
fieldType: PROG.TYPE_;
baseIdent: SCAN.IDENT;
a, b: INTEGER;
RecFlag: INTEGER;
import: CODE.IMPORT_PROC;
import: IL.IMPORT_PROC;
BEGIN
unit := parser.unit;
@ -604,11 +645,11 @@ BEGIN
ConstExpression(parser, arrLen);
check(arrLen.typ = ARITH.tINTEGER, parser, pos, 43);
check(ARITH.check(arrLen), parser, pos, 39);
check(ARITH.getInt(arrLen) > 0, parser, pos, 51);
check(arrLen.typ = ARITH.tINTEGER, pos, 43);
check(ARITH.check(arrLen), pos, 39);
check(ARITH.getInt(arrLen) > 0, pos, 51);
t := program.enterType(program, PROG.tARRAY, -1, ARITH.getInt(arrLen), unit);
t := PROG.enterType(program, PROG.tARRAY, -1, ARITH.getInt(arrLen), unit);
IF parser.sym = SCAN.lxCOMMA THEN
type(parser, t.base, {comma, closed})
@ -623,8 +664,8 @@ BEGIN
a := t.length;
b := t.base.size;
check(ARITH.mulInt(a, b), parser, pos2, 104);
check(ARITH.setInt(typeSize, a), parser, pos2, 104);
check(ARITH.mulInt(a, b), pos2, 104);
check(ARITH.setInt(typeSize, a), pos2, 104);
t.size := a;
t.closed := TRUE
@ -633,19 +674,14 @@ BEGIN
getpos(parser, pos2);
Next(parser);
t := program.enterType(program, PROG.tRECORD, 0, 0, unit);
t := PROG.enterType(program, PROG.tRECORD, 0, 0, unit);
t.align := 1;
IF parser.sym = SCAN.lxLSQUARE THEN
check1(parser.unit.sysimport, parser, 54);
Next(parser);
RecFlag := sysflag(parser);
IF RecFlag = PROG.noalign THEN
t.noalign := TRUE
ELSE
check1(FALSE, parser, 110)
END;
RecFlag := sysflag(parser, FALSE);
t.noalign := RecFlag = PROG.noalign;
ExpectSym(parser, SCAN.lxRSQUARE);
Next(parser)
END;
@ -657,14 +693,14 @@ BEGIN
type(parser, t.base, {closed});
check(t.base.typ IN {PROG.tRECORD, PROG.tPOINTER}, parser, pos, 52);
check(t.base.typ IN {PROG.tRECORD, PROG.tPOINTER}, pos, 52);
IF t.base.typ = PROG.tPOINTER THEN
t.base := t.base.base;
check(t.base # NIL, parser, pos, 55)
check(t.base # NIL, pos, 55)
END;
check(~t.base.noalign, parser, pos, 112);
check(~t.base.noalign, pos, 112);
checklex(parser, SCAN.lxRROUND);
Next(parser);
@ -684,7 +720,7 @@ BEGIN
Next(parser);
type(parser, fieldType, {closed});
check(t.fields.set(t, fieldType), parser, pos2, 104);
check(PROG.setFields(t, fieldType), pos2, 104);
IF (fieldType.align > t.align) & ~t.noalign THEN
t.align := fieldType.align
@ -699,11 +735,11 @@ BEGIN
t.closed := TRUE;
CODE.AddRec(t.base.num);
IL.AddRec(t.base.num);
IF ~t.noalign THEN
check(MACHINE.Align(t.size, t.align), parser, pos2, 104);
check(ARITH.setInt(typeSize, t.size), parser, pos2, 104)
check(UTILS.Align(t.size, t.align), pos2, 104);
check(ARITH.setInt(typeSize, t.size), pos2, 104)
END;
checklex(parser, SCAN.lxEND);
@ -713,7 +749,7 @@ BEGIN
ExpectSym(parser, SCAN.lxTO);
Next(parser);
t := program.enterType(program, PROG.tPOINTER, program.target.adr, 0, unit);
t := PROG.enterType(program, PROG.tPOINTER, program.target.adr, 0, unit);
t.align := program.target.adr;
getpos(parser, pos);
@ -725,14 +761,14 @@ BEGIN
type(parser, t.base, {forward});
IF t.base # NIL THEN
check(t.base.typ = PROG.tRECORD, parser, pos, 58)
check(t.base.typ = PROG.tRECORD, pos, 58)
ELSE
unit.pointers.add(unit, t, baseIdent, pos)
PROG.frwPtr(unit, t, baseIdent, pos)
END
ELSIF parser.sym = SCAN.lxPROCEDURE THEN
NextPos(parser, pos);
t := program.enterType(program, PROG.tPROCEDURE, program.target.adr, 0, unit);
t := PROG.enterType(program, PROG.tPROCEDURE, program.target.adr, 0, unit);
t.align := program.target.adr;
t.call := procflag(parser, import, FALSE);
FormalParameters(parser, t)
@ -746,15 +782,15 @@ END type;
PROCEDURE IdentDef (parser: PARSER; typ: INTEGER; VAR name: SCAN.IDENT): PROG.IDENT;
VAR
ident: PROG.IDENT;
pos: SCAN.POSITION;
pos: POSITION;
BEGIN
ASSERT(parser.sym = SCAN.lxIDENT);
name := parser.lex.ident;
getpos(parser, pos);
ident := parser.unit.idents.add(parser.unit, name, typ);
check(ident # NIL, parser, pos, 30);
ident := PROG.addIdent(parser.unit, name, typ);
check(ident # NIL, pos, 30);
ident.pos := pos;
Next(parser);
@ -772,7 +808,7 @@ PROCEDURE ConstTypeDeclaration (parser: PARSER; const: BOOLEAN);
VAR
ident: PROG.IDENT;
name: SCAN.IDENT;
pos: SCAN.POSITION;
pos: POSITION;
BEGIN
IF const THEN
@ -787,12 +823,12 @@ BEGIN
IF const THEN
ConstExpression(parser, ident.value);
IF ident.value.typ = ARITH.tINTEGER THEN
check(ARITH.check(ident.value), parser, pos, 39)
check(ARITH.check(ident.value), pos, 39)
ELSIF ident.value.typ = ARITH.tREAL THEN
check(ARITH.check(ident.value), parser, pos, 40)
check(ARITH.check(ident.value), pos, 40)
END;
ident.typ := PROG.idCONST;
ident.type := program.getType(program, ident.value.typ)
ident.type := PROG.getType(program, ident.value.typ)
ELSE
type(parser, ident.type, {})
END;
@ -819,7 +855,7 @@ BEGIN
ELSIF parser.sym = SCAN.lxCOLON THEN
Next(parser);
type(parser, t, {});
parser.unit.setvars(parser.unit, t);
PROG.setVarsType(parser.unit, t);
checklex(parser, SCAN.lxSEMI);
Next(parser)
ELSE
@ -835,6 +871,7 @@ PROCEDURE DeclarationSequence (parser: PARSER): BOOLEAN;
VAR
ptr: PROG.FRWPTR;
endmod: BOOLEAN;
pos: POSITION;
PROCEDURE ProcDeclaration (parser: PARSER): BOOLEAN;
@ -842,20 +879,24 @@ VAR
proc: PROG.IDENT;
endname,
name: SCAN.IDENT;
param: LISTS.ITEM;
param: PROG.PARAM;
unit: PROG.UNIT;
ident: PROG.IDENT;
e: EXPR;
pos: SCAN.POSITION;
pos, pos1,
pos2: POSITION;
label: INTEGER;
enter: CODE.COMMAND;
enter: IL.COMMAND;
call: INTEGER;
t: PROG.TYPE_;
import: CODE.IMPORT_PROC;
import: IL.IMPORT_PROC;
endmod, b: BOOLEAN;
fparams: SET;
variables: LISTS.LIST;
int, flt: INTEGER;
comma: BOOLEAN;
code: ARITH.VALUE;
codeProc: BOOLEAN;
BEGIN
endmod := FALSE;
@ -865,6 +906,7 @@ VAR
call := procflag(parser, import, TRUE);
getpos(parser, pos);
pos1 := pos;
checklex(parser, SCAN.lxIDENT);
IF import # NIL THEN
@ -875,29 +917,56 @@ VAR
proc := IdentDef(parser, PROG.idPROC, name)
END;
check(unit.scope.open(unit, proc.proc), parser, pos, 116);
check(PROG.openScope(unit, proc.proc), pos, 116);
proc.type := program.enterType(program, PROG.tPROCEDURE, program.target.adr, 0, unit);
proc.type := PROG.enterType(program, PROG.tPROCEDURE, program.target.adr, 0, unit);
t := proc.type;
t.align := program.target.adr;
t.call := call;
FormalParameters(parser, t);
codeProc := call IN {PROG.code, PROG._code};
IF call IN {PROG.systemv, PROG._systemv} THEN
check(t.params.size <= PROG.MAXSYSVPARAM, parser, pos, 120)
check(t.parSize <= PROG.MAXSYSVPARAM, pos, 120)
END;
param := t.params.first;
param := t.params.first(PROG.PARAM);
WHILE param # NIL DO
ident := unit.idents.add(unit, param(PROG.PARAM).name, PROG.idPARAM);
ident := PROG.addIdent(unit, param.name, PROG.idPARAM);
ASSERT(ident # NIL);
ident.type := param(PROG.PARAM).type;
ident.offset := param(PROG.PARAM).offset;
IF param(PROG.PARAM).vPar THEN
ident.type := param.type;
ident.offset := param.offset;
IF param.vPar THEN
ident.typ := PROG.idVPAR
END;
param := param.next
param := param.next(PROG.PARAM)
END;
IF import = NIL THEN
label := IL.NewLabel();
proc.proc.label := label
END;
IF codeProc THEN
enter := IL.EnterC(label);
comma := FALSE;
WHILE (parser.sym # SCAN.lxSEMI) OR comma DO
getpos(parser, pos2);
ConstExpression(parser, code);
check(code.typ = ARITH.tINTEGER, pos2, 43);
IF program.target.sys # mConst.Target_iMSP430 THEN
check(ARITH.range(code, 0, 255), pos2, 42)
END;
IL.AddCmd(IL.opCODE, ARITH.getInt(code));
comma := parser.sym = SCAN.lxCOMMA;
IF comma THEN
Next(parser)
ELSE
checklex(parser, SCAN.lxSEMI)
END
END
END;
checklex(parser, SCAN.lxSEMI);
@ -905,55 +974,64 @@ VAR
IF import = NIL THEN
label := CODE.NewLabel();
proc.proc.label := label;
IF parser.main & proc.export & program.dll THEN
IF program.obj THEN
check((proc.name.s # "lib_init") & (proc.name.s # "version"), parser, pos, 114)
check((proc.name.s # "lib_init") & (proc.name.s # "version"), pos, 114)
END;
CODE.AddExp(label, proc.name.s);
IL.AddExp(label, proc.name.s);
proc.proc.used := TRUE
END;
b := DeclarationSequence(parser);
IF ~codeProc THEN
b := DeclarationSequence(parser)
END;
program.locsize := 0;
IF call IN {PROG._win64, PROG.win64} THEN
fparams := proc.type.params.getfparams(proc.type, 3, int, flt);
enter := CODE.Enter(label, LSL(ORD(fparams), 5) + MIN(proc.type.params.size, 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 := proc.type.params.getfparams(proc.type, PROG.MAXSYSVPARAM - 1, int, flt);
enter := CODE.Enter(label, -(LSL(ORD(fparams), 5) + proc.type.params.size))
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
enter := CODE.Enter(label, 0)
enter := IL.Enter(label, 0)
END;
proc.proc.enter := enter;
IF parser.sym = SCAN.lxBEGIN THEN
IF ~codeProc & (parser.sym = SCAN.lxBEGIN) THEN
Next(parser);
parser.StatSeq(parser)
END;
IF t.base # NIL THEN
IF ~codeProc & (t.base # NIL) THEN
checklex(parser, SCAN.lxRETURN);
NextPos(parser, pos);
parser.expression(parser, e);
check(parser.chkreturn(parser, e, t.base, pos), parser, pos, 87)
check(parser.chkreturn(parser, e, t.base, pos), pos, 87)
END;
proc.proc.leave := CODE.Leave(t.base # NIL, (t.base # NIL) & (t.base.typ = PROG.tREAL),
t.params.size * ORD((t.call IN PROG.callee_clean_up) OR (t.call IN {PROG.systemv, PROG._systemv})));
IF ~codeProc THEN
proc.proc.leave := IL.Leave(t.base # NIL, (t.base # NIL) & (t.base.typ = PROG.tREAL), program.locsize,
t.parSize * ORD((t.call IN PROG.callee_clean_up) OR (t.call IN {PROG.systemv, PROG._systemv})));
enter.param2 := program.locsize;
checklex(parser, SCAN.lxEND)
ELSE
proc.proc.leave := IL.LeaveC()
END;
IF program.target.sys = mConst.Target_iMSP430 THEN
check((enter.param2 * ORD(~codeProc) + proc.type.parSize) * 2 + 16 < program.target.options.ram, pos1, 63)
END
END;
IF parser.sym = SCAN.lxEND THEN
ExpectSym(parser, SCAN.lxIDENT);
getpos(parser, pos);
endname := parser.lex.ident;
IF import = NIL THEN
check(endname = name, parser, pos, 60);
IF ~codeProc & (import = NIL) THEN
check(endname = name, pos, 60);
ExpectSym(parser, SCAN.lxSEMI);
Next(parser)
ELSE
@ -965,20 +1043,20 @@ VAR
ExpectSym(parser, SCAN.lxSEMI);
Next(parser)
ELSE
check(FALSE, parser, pos, 60)
error(pos, 60)
END
END
END;
IF import = NIL THEN
IF ~codeProc & (import = NIL) THEN
variables := LISTS.create(NIL);
ELSE
variables := NIL
END;
unit.scope.close(unit, variables);
PROG.closeScope(unit, variables);
IF import = NIL THEN
IF ~codeProc & (import = NIL) THEN
enter.variables := variables
END
@ -1001,12 +1079,15 @@ BEGIN
END
END;
ptr := parser.unit.pointers.link(parser.unit);
ptr := PROG.linkPtr(parser.unit);
IF ptr # NIL THEN
pos.line := ptr.pos.line;
pos.col := ptr.pos.col;
pos.parser := parser;
IF ptr.notRecord THEN
error(parser, ptr.pos, 58)
error(pos, 58)
ELSE
error(parser, ptr.pos, 48)
error(pos, 48)
END
END;
@ -1033,6 +1114,8 @@ VAR
label: INTEGER;
name: INTEGER;
endmod: BOOLEAN;
errlabel: INTEGER;
errno: INTEGER;
BEGIN
ASSERT(parser # NIL);
@ -1045,7 +1128,7 @@ BEGIN
check1(parser.lex.s = parser.modname, parser, 23)
END;
unit := program.units.create(program.units, parser.lex.ident);
unit := PROG.newUnit(program, parser.lex.ident);
parser.unit := unit;
@ -1062,19 +1145,26 @@ BEGIN
END;
CONSOLE.Ln;
label := CODE.NewLabel();
CODE.AddJmpCmd(CODE.opJMP, label);
label := IL.NewLabel();
IL.AddJmpCmd(IL.opJMP, label);
name := CODE.putstr(unit.name.s);
name := IL.putstr(unit.name.s);
CODE.SetErrLabel;
CODE.AddCmd(CODE.opSADR, name);
CODE.AddCmd(CODE.opPARAM, 1);
CODE.AddCmd0(CODE.opERR);
errlabel := IL.NewLabel();
IL.SetLabel(errlabel);
IL.StrAdr(name);
IL.Param1;
IL.AddCmd0(IL.opERR);
FOR errno := 1 TO LEN(IL.codes.errlabels) - 1 DO
IL.SetErrLabel(errno);
IL.AddCmd(IL.opPUSHC, errno);
IL.AddJmpCmd(IL.opJMP, errlabel)
END;
endmod := DeclarationSequence(parser);
CODE.SetLabel(label);
IL.SetLabel(label);
IF ~endmod THEN
@ -1091,8 +1181,7 @@ BEGIN
END;
unit.close(unit)
PROG.closeUnit(unit)
END parse;
@ -1156,9 +1245,9 @@ BEGIN
END create;
PROCEDURE init* (bit_depth, sys: INTEGER);
PROCEDURE init* (bit_depth, target: INTEGER; options: PROG.OPTIONS);
BEGIN
program := PROG.create(bit_depth, sys);
program := PROG.create(bit_depth, target, options);
parsers := C.create()
END init;

2
programs/develop/oberon07/Source/PATHS.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)

462
programs/develop/oberon07/Source/PROG.ob07
View File

@ -7,7 +7,7 @@
MODULE PROG;
IMPORT SCAN, LISTS, ARITH, ERRORS, MACHINE, C := COLLECTIONS, mConst := CONSTANTS, CODE, UTILS;
IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, mConst := CONSTANTS, IL, UTILS;
CONST
@ -39,9 +39,10 @@ CONST
sysMOVE* = 27; stLENGTH* = 28; stMIN* = 29; stMAX* = 30;
sysSADR* = 31; sysTYPEID* = 32; sysCOPY* = 33; sysINF* = 34;
sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38;
sysWSADR* = 39; sysPUT32* = 40;
sysWSADR* = 39; sysPUT32* = 40; (*sysNOP* = 41; sysEINT* = 42;
sysDINT* = 43;*)
default* = 2;
default32* = 2;
stdcall* = 4; _stdcall* = stdcall + 1;
ccall* = 6; _ccall* = ccall + 1;
ccall16* = 8; _ccall16* = ccall16 + 1;
@ -49,19 +50,34 @@ CONST
stdcall64* = 12; _stdcall64* = stdcall64 + 1;
default64* = 14;
systemv* = 16; _systemv* = systemv + 1;
default16* = 18;
code* = 20; _code* = code + 1;
noalign* = 20;
noalign* = 22;
callee_clean_up* = {default, stdcall, _stdcall, default64, stdcall64, _stdcall64};
caller_clean_up* = {ccall, ccall16, win64, systemv, _ccall, _ccall16, _win64, _systemv};
callconv32* = {default, stdcall, ccall, ccall16, _stdcall, _ccall, _ccall16};
callconv64* = {default64, win64, stdcall64, systemv, _win64, _stdcall64, _systemv};
callee_clean_up* = {default32, stdcall, _stdcall, default64, stdcall64, _stdcall64};
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;
proc_flags* = {sf_stdcall, sf_stdcall64, sf_ccall, sf_ccall16, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code};
rec_flags* = {sf_noalign};
STACK_FRAME = 2;
TYPE
OPTIONS* = RECORD
version*, stack*, base*, ram*, rom*: INTEGER;
pic*: BOOLEAN;
checking*: SET
END;
IDENT* = POINTER TO rIDENT;
UNIT* = POINTER TO rUNIT;
@ -81,13 +97,6 @@ TYPE
END;
IDENTS = POINTER TO RECORD (LISTS.LIST)
add*: PROCEDURE (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
get*: PROCEDURE (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT
END;
PROC* = POINTER TO RECORD (LISTS.ITEM)
label*: INTEGER;
@ -110,31 +119,13 @@ TYPE
program*: PROGRAM;
name*: SCAN.IDENT;
idents*: IDENTS;
idents*: LISTS.LIST;
frwPointers: LISTS.LIST;
gscope: IDENT;
closed*: BOOLEAN;
scopeLvl*: INTEGER;
sysimport*: BOOLEAN;
scopes*: ARRAY MAXSCOPE OF PROC;
scope*: RECORD
open*: PROCEDURE (unit: UNIT; proc: PROC): BOOLEAN;
close*: PROCEDURE (unit: UNIT; variables: LISTS.LIST)
END;
close*: PROCEDURE (unit: UNIT);
setvars*: PROCEDURE (unit: UNIT; type: TYPE_);
pointers*: RECORD
add*: PROCEDURE (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
link*: PROCEDURE (unit: UNIT): FRWPTR
END
scopes*: ARRAY MAXSCOPE OF PROC
END;
@ -142,34 +133,16 @@ TYPE
PARAM* = POINTER TO rPARAM;
FIELDS = POINTER TO RECORD (LISTS.LIST)
add*: PROCEDURE (rec: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
get*: PROCEDURE (rec: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;
set*: PROCEDURE (rec: TYPE_; type: TYPE_): BOOLEAN
END;
PARAMS = POINTER TO RECORD (LISTS.LIST)
size*: INTEGER;
add*: PROCEDURE (proc: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
get*: PROCEDURE (proc: TYPE_; name: SCAN.IDENT): PARAM;
set*: PROCEDURE (proc: TYPE_; type: TYPE_);
getfparams*: PROCEDURE (proc: TYPE_; maxparam: INTEGER; VAR int, flt: INTEGER): SET
END;
rTYPE_ = RECORD (LISTS.ITEM)
typ*: INTEGER;
size*: INTEGER;
parSize*: INTEGER;
length*: INTEGER;
align*: INTEGER;
base*: TYPE_;
fields*: FIELDS;
params*: PARAMS;
fields*: LISTS.LIST;
params*: LISTS.LIST;
unit*: UNIT;
closed*: BOOLEAN;
num*: INTEGER;
@ -215,19 +188,10 @@ TYPE
END;
UNITS* = POINTER TO RECORD (LISTS.LIST)
program: PROGRAM;
create*: PROCEDURE (units: UNITS; name: SCAN.IDENT): UNIT;
get*: PROCEDURE (units: UNITS; name: SCAN.IDENT): UNIT
END;
rPROGRAM = RECORD
recCount: INTEGER;
units*: UNITS;
units*: LISTS.LIST;
types*: LISTS.LIST;
sysunit*: UNIT;
rtl*: UNIT;
@ -240,8 +204,8 @@ TYPE
stTypes*: RECORD
tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*, tSTRING*, tNIL*,
tCARD16*, tCARD32*, tANYREC*: TYPE_
tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*,
tSTRING*, tNIL*, tCARD16*, tCARD32*, tANYREC*: TYPE_
END;
@ -250,12 +214,11 @@ TYPE
bit_depth*: INTEGER;
word*: INTEGER;
adr*: INTEGER;
sys*: INTEGER
sys*: INTEGER;
sysflags*: SET;
options*: OPTIONS
END;
enterType*: PROCEDURE (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
getType*: PROCEDURE (program: PROGRAM; typ: INTEGER): TYPE_
END
END;
@ -292,7 +255,7 @@ VAR
BEGIN
IF varIdent.offset = -1 THEN
IF varIdent.global THEN
IF MACHINE.Align(program.bss, varIdent.type.align) THEN
IF UTILS.Align(program.bss, varIdent.type.align) THEN
IF UTILS.maxint - program.bss >= varIdent.type.size THEN
varIdent.offset := program.bss;
INC(program.bss, varIdent.type.size)
@ -301,7 +264,7 @@ BEGIN
ELSE
word := program.target.word;
size := varIdent.type.size;
IF MACHINE.Align(size, word) THEN
IF UTILS.Align(size, word) THEN
size := size DIV word;
IF UTILS.maxint - program.locsize >= size THEN
INC(program.locsize, size);
@ -315,7 +278,7 @@ BEGIN
END getOffset;
PROCEDURE close (unit: UNIT);
PROCEDURE closeUnit* (unit: UNIT);
VAR
ident, prev: IDENT;
offset: INTEGER;
@ -324,7 +287,7 @@ BEGIN
ident := unit.idents.last(IDENT);
WHILE (ident # NIL) & (ident.typ # idGUARD) DO
IF (ident.typ = idVAR) & (ident.offset = -1) THEN
ERRORS.hintmsg(ident.name.s, ident.pos.line, ident.pos.col, 0);
ERRORS.HintMsg(ident.name.s, ident.pos.line, ident.pos.col, 0);
IF ident.export THEN
offset := getOffset(unit.program, ident)
END
@ -343,7 +306,7 @@ BEGIN
END;
unit.closed := TRUE
END close;
END closeUnit;
PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;
@ -362,7 +325,7 @@ BEGIN
END unique;
PROCEDURE addIdent (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
PROCEDURE addIdent* (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
VAR
item: IDENT;
res: BOOLEAN;
@ -438,7 +401,7 @@ BEGIN
END UseProc;
PROCEDURE setvars (unit: UNIT; type: TYPE_);
PROCEDURE setVarsType* (unit: UNIT; type: TYPE_);
VAR
item: IDENT;
@ -450,10 +413,10 @@ BEGIN
item.type := type;
item := item.prev(IDENT)
END
END setvars;
END setVarsType;
PROCEDURE getIdent (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;
PROCEDURE getIdent* (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;
VAR
item: IDENT;
@ -462,7 +425,7 @@ BEGIN
item := unit.idents.last(IDENT);
ASSERT(item # NIL);
IF item # NIL THEN
IF currentScope THEN
WHILE (item.name # ident) & (item.typ # idGUARD) DO
@ -477,11 +440,13 @@ BEGIN
END
END
END
RETURN item
END getIdent;
PROCEDURE openScope (unit: UNIT; proc: PROC): BOOLEAN;
PROCEDURE openScope* (unit: UNIT; proc: PROC): BOOLEAN;
VAR
item: IDENT;
res: BOOLEAN;
@ -508,11 +473,11 @@ BEGIN
END openScope;
PROCEDURE closeScope (unit: UNIT; variables: LISTS.LIST);
PROCEDURE closeScope* (unit: UNIT; variables: LISTS.LIST);
VAR
item: IDENT;
del: IDENT;
lvar: CODE.LOCALVAR;
lvar: IL.LOCALVAR;
BEGIN
item := unit.idents.last(IDENT);
@ -521,11 +486,11 @@ BEGIN
del := item;
item := item.prev(IDENT);
IF (del.typ = idVAR) & (del.offset = -1) THEN
ERRORS.hintmsg(del.name.s, del.pos.line, del.pos.col, 0)
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
lvar := CODE.NewVar();
lvar := IL.NewVar();
lvar.offset := del.offset;
lvar.size := del.type.size;
IF del.typ = idVAR THEN
@ -548,7 +513,7 @@ BEGIN
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;
@ -566,10 +531,10 @@ BEGIN
newptr.notRecord := FALSE;
LISTS.push(unit.frwPointers, newptr)
END frwptr;
END frwPtr;
PROCEDURE linkptr (unit: UNIT): FRWPTR;
PROCEDURE linkPtr* (unit: UNIT): FRWPTR;
VAR
item: FRWPTR;
ident: IDENT;
@ -580,7 +545,7 @@ BEGIN
item := unit.frwPointers.last(FRWPTR);
WHILE (item # NIL) & ~item.linked & (res = NIL) DO
ident := unit.idents.get(unit, item.baseIdent, TRUE);
ident := getIdent(unit, item.baseIdent, TRUE);
IF (ident # NIL) THEN
IF (ident.typ = idTYPE) & (ident.type.typ = tRECORD) THEN
@ -599,7 +564,7 @@ BEGIN
END
RETURN res
END linkptr;
END linkPtr;
PROCEDURE isTypeEq* (t1, t2: TYPE_): BOOLEAN;
@ -617,7 +582,7 @@ BEGIN
param1 := t1.params.first;
param2 := t2.params.first;
res := (t1.call = t2.call) & ((param1 # NIL) = (param2 # NIL));
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);
@ -643,18 +608,21 @@ VAR
res: BOOLEAN;
BEGIN
res := ((t0.typ = tPOINTER) & (t1.typ = tPOINTER)) OR ((t0.typ = tRECORD) & (t1.typ = tRECORD));
res := (t0.typ = t1.typ) & (t0.typ IN {tPOINTER, tRECORD});
IF (t0.typ = tPOINTER) & (t1.typ = tPOINTER) THEN
IF res & (t0.typ = tPOINTER) THEN
t0 := t0.base;
t1 := t1.base
END;
WHILE res & (t1 # NIL) & (t1 # t0) DO
IF res THEN
WHILE (t1 # NIL) & (t1 # t0) DO
t1 := t1.base
END;
res := t1 # NIL
END
RETURN res & (t1 = t0)
RETURN res
END isBaseOf;
@ -663,148 +631,141 @@ PROCEDURE isOpenArray* (t: TYPE_): BOOLEAN;
END isOpenArray;
PROCEDURE getunit (units: UNITS; name: SCAN.IDENT): UNIT;
PROCEDURE getUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;
VAR
item: UNIT;
BEGIN
ASSERT(name # NIL);
item := units.first(UNIT);
item := program.units.first(UNIT);
WHILE (item # NIL) & (item.name # name) DO
item := item.next(UNIT)
END;
IF (item = NIL) & (name.s = "SYSTEM") THEN
item := units.program.sysunit
item := program.sysunit
END
RETURN item
END getunit;
END getUnit;
PROCEDURE enterStTypes (unit: UNIT; program: PROGRAM);
VAR
ident: IDENT;
stName: SCAN.IDENT;
BEGIN
stName := SCAN.enterid("INTEGER");
ident := addIdent(unit, stName, idTYPE);
ident := addIdent(unit, SCAN.enterid("INTEGER"), idTYPE);
ident.type := program.stTypes.tINTEGER;
stName := SCAN.enterid("BYTE");
ident := addIdent(unit, stName, idTYPE);
ident := addIdent(unit, SCAN.enterid("BYTE"), idTYPE);
ident.type := program.stTypes.tBYTE;
stName := SCAN.enterid("CHAR");
ident := addIdent(unit, stName, idTYPE);
ident := addIdent(unit, SCAN.enterid("CHAR"), idTYPE);
ident.type := program.stTypes.tCHAR;
stName := SCAN.enterid("WCHAR");
ident := addIdent(unit, stName, idTYPE);
ident.type := program.stTypes.tWCHAR;
stName := SCAN.enterid("SET");
ident := addIdent(unit, stName, idTYPE);
ident := addIdent(unit, SCAN.enterid("SET"), idTYPE);
ident.type := program.stTypes.tSET;
stName := SCAN.enterid("BOOLEAN");
ident := addIdent(unit, stName, idTYPE);
ident := addIdent(unit, SCAN.enterid("BOOLEAN"), idTYPE);
ident.type := program.stTypes.tBOOLEAN;
stName := SCAN.enterid("REAL");
ident := addIdent(unit, stName, idTYPE);
IF program.target.sys # mConst.Target_iMSP430 THEN
ident := addIdent(unit, SCAN.enterid("REAL"), idTYPE);
ident.type := program.stTypes.tREAL;
ident := addIdent(unit, SCAN.enterid("WCHAR"), idTYPE);
ident.type := program.stTypes.tWCHAR
END
END enterStTypes;
PROCEDURE enterStProcs (unit: UNIT);
PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; proc: INTEGER);
VAR
ident: IDENT;
BEGIN
ident := addIdent(unit, SCAN.enterid(name), idtyp);
ident := addIdent(unit, SCAN.enterid(name), idSTPROC);
ident.stproc := proc
END EnterProc;
PROCEDURE EnterFunc (unit: UNIT; name: SCAN.LEXSTR; func: INTEGER);
VAR
ident: IDENT;
BEGIN
EnterProc(unit, "ASSERT", idSTPROC, stASSERT);
EnterProc(unit, "DEC", idSTPROC, stDEC);
EnterProc(unit, "EXCL", idSTPROC, stEXCL);
EnterProc(unit, "INC", idSTPROC, stINC);
EnterProc(unit, "INCL", idSTPROC, stINCL);
EnterProc(unit, "NEW", idSTPROC, stNEW);
EnterProc(unit, "PACK", idSTPROC, stPACK);
EnterProc(unit, "UNPK", idSTPROC, stUNPK);
EnterProc(unit, "DISPOSE", idSTPROC, stDISPOSE);
EnterProc(unit, "COPY", idSTPROC, stCOPY);
ident := addIdent(unit, SCAN.enterid(name), idSTFUNC);
ident.stproc := func
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);
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 unit.program.target.sys # mConst.Target_iMSP430 THEN
EnterProc(unit, "PACK", stPACK);
EnterProc(unit, "UNPK", stUNPK);
EnterProc(unit, "DISPOSE", stDISPOSE);
EnterFunc(unit, "WCHR", stWCHR);
EnterFunc(unit, "FLOOR", stFLOOR);
EnterFunc(unit, "FLT", stFLT)
END
EnterProc(unit, "ABS", idSTFUNC, stABS);
EnterProc(unit, "ASR", idSTFUNC, stASR);
EnterProc(unit, "CHR", idSTFUNC, stCHR);
EnterProc(unit, "WCHR", idSTFUNC, stWCHR);
EnterProc(unit, "FLOOR", idSTFUNC, stFLOOR);
EnterProc(unit, "FLT", idSTFUNC, stFLT);
EnterProc(unit, "LEN", idSTFUNC, stLEN);
EnterProc(unit, "LSL", idSTFUNC, stLSL);
EnterProc(unit, "ODD", idSTFUNC, stODD);
EnterProc(unit, "ORD", idSTFUNC, stORD);
EnterProc(unit, "ROR", idSTFUNC, stROR);
EnterProc(unit, "BITS", idSTFUNC, stBITS);
EnterProc(unit, "LSR", idSTFUNC, stLSR);
EnterProc(unit, "LENGTH", idSTFUNC, stLENGTH);
EnterProc(unit, "MIN", idSTFUNC, stMIN);
EnterProc(unit, "MAX", idSTFUNC, stMAX);
END enterStProcs;
PROCEDURE newunit (units: UNITS; name: SCAN.IDENT): UNIT;
PROCEDURE newUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;
VAR
unit: UNIT;
idents: IDENTS;
BEGIN
ASSERT(units # NIL);
ASSERT(program # NIL);
ASSERT(name # NIL);
NEW(unit);
NEW(idents);
ASSERT(LISTS.create(idents) = idents);
idents.add := addIdent;
idents.get := getIdent;
unit.program := units.program;
unit.program := program;
unit.name := name;
unit.closed := FALSE;
unit.idents := idents;
unit.idents := LISTS.create(NIL);
unit.frwPointers := LISTS.create(NIL);
unit.scope.open := openScope;
unit.scope.close := closeScope;
unit.close := close;
unit.setvars := setvars;
unit.pointers.add := frwptr;
unit.pointers.link := linkptr;
ASSERT(openScope(unit, NIL));
ASSERT(unit.scope.open(unit, NIL));
enterStTypes(unit, units.program);
enterStTypes(unit, program);
enterStProcs(unit);
ASSERT(unit.scope.open(unit, NIL));
ASSERT(openScope(unit, NIL));
unit.gscope := unit.idents.last(IDENT);
LISTS.push(units, unit);
LISTS.push(program.units, unit);
unit.scopeLvl := 0;
unit.scopes[0] := NIL;
@ -812,14 +773,14 @@ BEGIN
unit.sysimport := FALSE;
IF unit.name.s = mConst.RTL_NAME THEN
unit.program.rtl := unit
program.rtl := unit
END
RETURN unit
END newunit;
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;
@ -851,7 +812,7 @@ BEGIN
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;
@ -876,7 +837,7 @@ BEGIN
END addField;
PROCEDURE setFields (self: TYPE_; type: TYPE_): BOOLEAN;
PROCEDURE setFields* (self: TYPE_; type: TYPE_): BOOLEAN;
VAR
item: FIELD;
res: BOOLEAN;
@ -895,7 +856,7 @@ BEGIN
WHILE res & (item # NIL) & (item.type = NIL) DO
item.type := type;
IF ~self.noalign THEN
res := MACHINE.Align(self.size, type.align)
res := UTILS.Align(self.size, type.align)
ELSE
res := TRUE
END;
@ -911,7 +872,7 @@ BEGIN
END setFields;
PROCEDURE getParam (self: TYPE_; name: SCAN.IDENT): PARAM;
PROCEDURE getParam* (self: TYPE_; name: SCAN.IDENT): PARAM;
VAR
item: PARAM;
@ -928,7 +889,7 @@ BEGIN
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;
@ -936,7 +897,7 @@ VAR
BEGIN
ASSERT(name # NIL);
res := self.params.get(self, name) = NIL;
res := getParam(self, name) = NIL;
IF res THEN
NEW(param);
@ -973,7 +934,7 @@ BEGIN
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;
@ -991,13 +952,13 @@ BEGIN
param := param.next(PARAM)
END;
int := self.params.size - flt
int := self.parSize - flt
RETURN res
END getFloatParamsPos;
PROCEDURE setParams (self: TYPE_; type: TYPE_);
PROCEDURE setParams* (self: TYPE_; type: TYPE_);
VAR
item: LISTS.ITEM;
param: PARAM;
@ -1006,7 +967,7 @@ VAR
BEGIN
ASSERT(type # NIL);
word := MACHINE.target.bit_depth DIV 8;
word := UTILS.target.bit_depth DIV 8;
item := self.params.first;
@ -1025,8 +986,8 @@ BEGIN
ELSE
size := 1
END;
param.offset := self.params.size + ORD(type.typ = tRECORD) + Dim(type) + STACK_FRAME;
INC(self.params.size, size)
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
@ -1036,11 +997,11 @@ BEGIN
END
ELSE
size := type.size;
ASSERT(MACHINE.Align(size, word));
ASSERT(UTILS.Align(size, word));
size := size DIV word
END;
param.offset := self.params.size + Dim(type) + STACK_FRAME;
INC(self.params.size, size)
param.offset := self.parSize + Dim(type) + STACK_FRAME;
INC(self.parSize, size)
END;
item := item.next
@ -1049,47 +1010,32 @@ BEGIN
END setParams;
PROCEDURE enterType (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
PROCEDURE enterType* (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
VAR
t: TYPE_;
fields: FIELDS;
params: PARAMS;
BEGIN
NEW(t);
NEW(fields);
ASSERT(LISTS.create(fields) = fields);
NEW(params);
ASSERT(LISTS.create(params) = params);
t.typ := typ;
t.size := size;
t.length := length;
t.align := 0;
t.base := NIL;
t.fields := fields;
t.params := params;
t.fields := LISTS.create(NIL);
t.params := LISTS.create(NIL);
t.unit := unit;
t.num := 0;
IF program.target.bit_depth = 32 THEN
t.call := default
ELSIF program.target.bit_depth = 64 THEN
t.call := default64
CASE program.target.bit_depth OF
|16: t.call := default16
|32: t.call := default32
|64: t.call := default64
END;
t.import := FALSE;
t.noalign := FALSE;
t.fields.add := addField;
t.fields.get := getField;
t.fields.set := setFields;
t.params.add := addParam;
t.params.get := getParam;
t.params.getfparams := getFloatParamsPos;
t.params.set := setParams;
t.params.size := 0;
t.parSize := 0;
IF typ IN {tARRAY, tRECORD} THEN
t.closed := FALSE;
@ -1107,7 +1053,7 @@ BEGIN
END enterType;
PROCEDURE getType (program: PROGRAM; typ: INTEGER): TYPE_;
PROCEDURE getType* (program: PROGRAM; typ: INTEGER): TYPE_;
VAR
res: TYPE_;
@ -1154,22 +1100,30 @@ VAR
BEGIN
unit := program.units.create(program.units, SCAN.enterid("$SYSTEM"));
unit := newUnit(program, SCAN.enterid("$SYSTEM"));
EnterProc(unit, "ADR", idSYSFUNC, sysADR);
EnterProc(unit, "SIZE", idSYSFUNC, sysSIZE);
EnterProc(unit, "SADR", idSYSFUNC, sysSADR);
EnterProc(unit, "WSADR", idSYSFUNC, sysWSADR);
EnterProc(unit, "TYPEID", idSYSFUNC, sysTYPEID);
EnterProc(unit, "INF", idSYSFUNC, sysINF);
EnterProc(unit, "GET", idSYSPROC, sysGET);
EnterProc(unit, "PUT", idSYSPROC, sysPUT);
EnterProc(unit, "PUT8", idSYSPROC, sysPUT8);
EnterProc(unit, "PUT16", idSYSPROC, sysPUT16);
EnterProc(unit, "PUT32", idSYSPROC, sysPUT32);
EnterProc(unit, "PUT", idSYSPROC, sysPUT);
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)
END;
*)
IF program.target.sys # mConst.Target_iMSP430 THEN
EnterProc(unit, "WSADR", idSYSFUNC, sysWSADR);
EnterProc(unit, "INF", idSYSFUNC, sysINF);
EnterProc(unit, "PUT32", idSYSPROC, sysPUT32);
EnterProc(unit, "PUT16", idSYSPROC, sysPUT16);
EnterProc(unit, "COPY", idSYSPROC, sysCOPY);
ident := addIdent(unit, SCAN.enterid("CARD16"), idTYPE);
@ -1178,9 +1132,10 @@ BEGIN
ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
ident.type := program.stTypes.tCARD32;
ident.export := TRUE;
ident.export := TRUE
END;
unit.close(unit);
closeUnit(unit);
program.sysunit := unit
END createSysUnit;
@ -1211,7 +1166,6 @@ VAR
BEGIN
REPEAT
flag := FALSE;
proc := program.procs.first(PROC);
@ -1230,7 +1184,7 @@ BEGIN
WHILE proc # NIL DO
IF ~proc.used THEN
IF proc.import = NIL THEN
CODE.delete2(proc.enter, proc.leave)
IL.delete2(proc.enter, proc.leave)
ELSE
DelImport(proc.import)
END
@ -1241,63 +1195,81 @@ BEGIN
END DelUnused;
PROCEDURE create* (bit_depth, sys: INTEGER): PROGRAM;
PROCEDURE create* (bit_depth, target: INTEGER; options: OPTIONS): PROGRAM;
VAR
program: PROGRAM;
units: UNITS;
BEGIN
idents := C.create();
MACHINE.SetBitDepth(bit_depth);
UTILS.SetBitDepth(bit_depth);
NEW(program);
NEW(units);
ASSERT(LISTS.create(units) = units);
program.target.bit_depth := bit_depth;
program.target.word := bit_depth DIV 8;
program.target.adr := bit_depth DIV 8;
program.target.sys := sys;
program.target.sys := target;
program.target.options := options;
CASE target OF
|mConst.Target_iConsole,
mConst.Target_iGUI,
mConst.Target_iDLL: program.target.sysflags := {sf_windows, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|mConst.Target_iELF32,
mConst.Target_iELFSO32: program.target.sysflags := {sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|mConst.Target_iKolibri,
mConst.Target_iObject: program.target.sysflags := {sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|mConst.Target_iConsole64,
mConst.Target_iGUI64,
mConst.Target_iDLL64: program.target.sysflags := {sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|mConst.Target_iELF64,
mConst.Target_iELFSO64: program.target.sysflags := {sf_linux, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|mConst.Target_iMSP430: program.target.sysflags := {sf_code}
END;
program.recCount := -1;
program.bss := 0;
program.units := units;
program.units := LISTS.create(NIL);
program.types := LISTS.create(NIL);
program.procs := LISTS.create(NIL);
program.enterType := enterType;
program.getType := getType;
program.stTypes.tINTEGER := enterType(program, tINTEGER, program.target.word, 0, NIL);
program.stTypes.tBYTE := enterType(program, tBYTE, 1, 0, NIL);
program.stTypes.tCHAR := enterType(program, tCHAR, 1, 0, NIL);
program.stTypes.tWCHAR := enterType(program, tWCHAR, 2, 0, NIL);
program.stTypes.tSET := enterType(program, tSET, program.target.word, 0, NIL);
program.stTypes.tBOOLEAN := enterType(program, tBOOLEAN, 1, 0, NIL);
IF target # mConst.Target_iMSP430 THEN
program.stTypes.tWCHAR := enterType(program, tWCHAR, 2, 0, NIL);
program.stTypes.tREAL := enterType(program, tREAL, 8, 0, NIL);
program.stTypes.tCARD16 := enterType(program, tCARD16, 2, 0, NIL);
program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL)
END;
program.stTypes.tSTRING := enterType(program, tSTRING, program.target.word, 0, NIL);
program.stTypes.tNIL := enterType(program, tNIL, program.target.word, 0, NIL);
program.stTypes.tCARD16 := enterType(program, tCARD16, 2, 0, NIL);
program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL);
program.stTypes.tANYREC := enterType(program, tRECORD, 0, 0, NIL);
program.stTypes.tANYREC.closed := TRUE;
program.stTypes.tINTEGER.align := program.stTypes.tINTEGER.size;
program.stTypes.tBYTE.align := 1;
program.stTypes.tCHAR.align := program.stTypes.tCHAR.size;
program.stTypes.tWCHAR.align := program.stTypes.tWCHAR.size;
program.stTypes.tSET.align := program.stTypes.tSET.size;
program.stTypes.tBOOLEAN.align := program.stTypes.tBOOLEAN.size;
IF target # mConst.Target_iMSP430 THEN
program.stTypes.tWCHAR.align := program.stTypes.tWCHAR.size;
program.stTypes.tREAL.align := program.stTypes.tREAL.size;
program.stTypes.tCARD16.align := program.stTypes.tCARD16.size;
program.stTypes.tCARD32.align := program.stTypes.tCARD32.size;
units.program := program;
units.create := newunit;
units.get := getunit;
program.stTypes.tCARD32.align := program.stTypes.tCARD32.size
END;
program.dll := FALSE;
program.obj := FALSE;

52
programs/develop/oberon07/Source/REG.ob07
View File

@ -12,8 +12,10 @@ CONST
N = 16;
R0* = 0; R1* = 1; R2* = 2;
R0* = 0; R1* = 1; R2* = 2; R3* = 3;
R4* = 4; R5* = 5; R6* = 6; R7* = 7;
R8* = 8; R9* = 9; R10* = 10; R11* = 11;
R12* = 12; R13* = 13; R14* = 14; R15* = 15;
NVR = 32;
@ -24,7 +26,7 @@ TYPE
OP2 = PROCEDURE (arg1, arg2: INTEGER);
OP3 = PROCEDURE (arg1, arg2, arg3: INTEGER);
REGS* = POINTER TO RECORD
REGS* = RECORD
regs*: SET;
stk*: ARRAY N OF INTEGER;
@ -42,7 +44,7 @@ TYPE
END;
PROCEDURE push (R: REGS);
PROCEDURE push (VAR R: REGS);
VAR
i, reg: INTEGER;
@ -58,7 +60,7 @@ BEGIN
END push;
PROCEDURE pop (R: REGS; reg: INTEGER);
PROCEDURE pop (VAR R: REGS; reg: INTEGER);
VAR
i: INTEGER;
@ -111,7 +113,7 @@ BEGIN
END GetFreeReg;
PROCEDURE Put (R: REGS; reg: INTEGER);
PROCEDURE Put (VAR R: REGS; reg: INTEGER);
BEGIN
EXCL(R.regs, reg);
INC(R.top);
@ -119,7 +121,7 @@ BEGIN
END Put;
PROCEDURE PopAnyReg (R: REGS): INTEGER;
PROCEDURE PopAnyReg (VAR R: REGS): INTEGER;
VAR
reg: INTEGER;
@ -134,7 +136,7 @@ BEGIN
END PopAnyReg;
PROCEDURE GetAnyReg* (R: REGS): INTEGER;
PROCEDURE GetAnyReg* (VAR R: REGS): INTEGER;
VAR
reg: INTEGER;
@ -152,13 +154,13 @@ BEGIN
END GetAnyReg;
PROCEDURE GetReg* (R: REGS; reg: INTEGER): BOOLEAN;
PROCEDURE GetReg* (VAR R: REGS; reg: INTEGER): BOOLEAN;
VAR
free, n: INTEGER;
res: BOOLEAN;
PROCEDURE exch (R: REGS; reg1, reg2: INTEGER);
PROCEDURE exch (VAR R: REGS; reg1, reg2: INTEGER);
VAR
n1, n2: INTEGER;
@ -201,7 +203,7 @@ BEGIN
END GetReg;
PROCEDURE Exchange* (R: REGS; reg1, reg2: INTEGER): BOOLEAN;
PROCEDURE Exchange* (VAR R: REGS; reg1, reg2: INTEGER): BOOLEAN;
VAR
n1, n2: INTEGER;
res: BOOLEAN;
@ -239,14 +241,14 @@ BEGIN
END Exchange;
PROCEDURE Drop* (R: REGS);
PROCEDURE Drop* (VAR R: REGS);
BEGIN
INCL(R.regs, R.stk[R.top]);
DEC(R.top)
END Drop;
PROCEDURE BinOp* (R: REGS; VAR reg1, reg2: INTEGER);
PROCEDURE BinOp* (VAR R: REGS; VAR reg1, reg2: INTEGER);
BEGIN
IF R.top > 0 THEN
reg1 := R.stk[R.top - 1];
@ -261,7 +263,7 @@ BEGIN
END BinOp;
PROCEDURE UnOp* (R: REGS; VAR reg: INTEGER);
PROCEDURE UnOp* (VAR R: REGS; VAR reg: INTEGER);
BEGIN
IF R.top >= 0 THEN
reg := R.stk[R.top]
@ -271,7 +273,7 @@ BEGIN
END UnOp;
PROCEDURE PushAll* (R: REGS);
PROCEDURE PushAll* (VAR R: REGS);
BEGIN
WHILE R.top >= 0 DO
push(R)
@ -279,7 +281,15 @@ BEGIN
END PushAll;
PROCEDURE Lock* (R: REGS; reg, offs, size: INTEGER);
PROCEDURE PushAll_1* (VAR R: REGS);
BEGIN
WHILE R.top >= 1 DO
push(R)
END
END PushAll_1;
PROCEDURE Lock* (VAR R: REGS; reg, offs, size: INTEGER);
BEGIN
ASSERT(reg IN R.vregs);
ASSERT(offs # 0);
@ -291,7 +301,7 @@ BEGIN
END Lock;
PROCEDURE Release* (R: REGS; reg: INTEGER);
PROCEDURE Release* (VAR R: REGS; reg: INTEGER);
BEGIN
ASSERT(reg IN R.vregs);
R.offs[reg] := 0
@ -350,7 +360,7 @@ BEGIN
END Restore;
PROCEDURE Reset* (R: REGS);
PROCEDURE Reset* (VAR R: REGS);
VAR
i: INTEGER;
@ -401,14 +411,11 @@ BEGIN
END GetAnyVarReg;
PROCEDURE Create* (push, pop: OP1; mov, xch: OP2; load, save: OP3; regs, vregs: SET): REGS;
PROCEDURE Init* (VAR R: REGS; push, pop: OP1; mov, xch: OP2; load, save: OP3; regs, vregs: SET);
VAR
R: REGS;
i: INTEGER;
BEGIN
NEW(R);
R.regs := regs;
R.pushed := 0;
R.top := -1;
@ -427,8 +434,7 @@ BEGIN
R.size[i] := 0
END
RETURN R
END Create;
END Init;
END REG.

285
programs/develop/oberon07/Source/SCAN.ob07
View File

@ -1,13 +1,13 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE SCAN;
IMPORT TEXTDRV, AVL := AVLTREES, ARITH, S := STRINGS, C := COLLECTIONS;
IMPORT TXT := TEXTDRV, AVL := AVLTREES, ARITH, S := STRINGS;
CONST
@ -18,29 +18,30 @@ CONST
lxCHAR* = 4; lxFLOAT* = 5; lxSTRING* = 6; lxCOMMENT* = 7;
lxEOF* = 8;
lxKW = 101;
lxPLUS* = 21; lxMINUS* = 22; lxMUL* = 23; lxSLASH* = 24;
lxNOT* = 25; lxAND* = 26; lxPOINT* = 27; lxCOMMA* = 28;
lxSEMI* = 29; lxBAR* = 30; lxLROUND* = 31; lxLSQUARE* = 32;
lxLCURLY* = 33; lxCARET* = 34; lxEQ* = 35; lxNE* = 36;
lxLT* = 37; lxGT* = 38; lxCOLON* = 39; lxRROUND* = 40;
lxRSQUARE* = 41; lxRCURLY* = 42; lxLE* = 43; lxGE* = 44;
lxASSIGN* = 45; lxRANGE* = 46;
lxARRAY* = 101; lxBEGIN* = 102; lxBY* = 103; lxCASE* = 104;
lxCONST* = 105; lxDIV* = 106; lxDO* = 107; lxELSE* = 108;
lxELSIF* = 109; lxEND* = 110; lxFALSE* = 111; lxFOR* = 112;
lxIF* = 113; lxIMPORT* = 114; lxIN* = 115; lxIS* = 116;
lxMOD* = 117; lxMODULE* = 118; lxNIL* = 119; lxOF* = 120;
lxOR* = 121; lxPOINTER* = 122; lxPROCEDURE* = 123; lxRECORD* = 124;
lxREPEAT* = 125; lxRETURN* = 126; lxTHEN* = 127; lxTO* = 128;
lxTRUE* = 129; lxTYPE* = 130; lxUNTIL* = 131; lxVAR* = 132;
lxWHILE* = 133;
lxKW = 51;
lxPLUS* = 201; lxMINUS* = 202; lxMUL* = 203; lxSLASH* = 204;
lxNOT* = 205; lxAND* = 206; lxPOINT* = 207; lxCOMMA* = 208;
lxSEMI* = 209; lxBAR* = 210; lxLROUND* = 211; lxLSQUARE* = 212;
lxLCURLY* = 213; lxCARET* = 214; lxEQ* = 215; lxNE* = 216;
lxLT* = 217; lxGT* = 218; lxCOLON* = 219; lxRROUND* = 220;
lxRSQUARE* = 221; lxRCURLY* = 222; lxLE* = 223; lxGE* = 224;
lxASSIGN* = 225; lxRANGE* = 226;
lxARRAY* = 51; lxBEGIN* = 52; lxBY* = 53; lxCASE* = 54;
lxCONST* = 55; lxDIV* = 56; lxDO* = 57; lxELSE* = 58;
lxELSIF* = 59; lxEND* = 60; lxFALSE* = 61; lxFOR* = 62;
lxIF* = 63; lxIMPORT* = 64; lxIN* = 65; lxIS* = 66;
lxMOD* = 67; lxMODULE* = 68; lxNIL* = 69; lxOF* = 70;
lxOR* = 71; lxPOINTER* = 72; lxPROCEDURE* = 73; lxRECORD* = 74;
lxREPEAT* = 75; lxRETURN* = 76; lxTHEN* = 77; lxTO* = 78;
lxTRUE* = 79; lxTYPE* = 80; lxUNTIL* = 81; lxVAR* = 82;
lxWHILE* = 83;
lxERROR01 = -1; lxERROR02 = -2; lxERROR03 = -3; lxERROR04 = -4;
lxERROR05 = -5; lxERROR06 = -6; lxERROR07 = -7; lxERROR08 = -8;
lxERROR09 = -9; lxERROR10 = -10; lxERROR11 = -11; lxERROR12 = -12;
lxERROR01* = -1; lxERROR02* = -2; lxERROR03* = -3; lxERROR04* = -4;
lxERROR05* = -5; lxERROR06* = -6; lxERROR07* = -7; lxERROR08* = -8;
lxERROR09* = -9; lxERROR10* = -10; lxERROR11* = -11; lxERROR12* = -12;
lxERROR13* = -13;
TYPE
@ -75,12 +76,7 @@ TYPE
END;
SCANNER* = POINTER TO RECORD (C.ITEM)
text: TEXTDRV.TEXT;
range: BOOLEAN
END;
SCANNER* = TXT.TEXT;
KEYWORD = ARRAY 10 OF CHAR;
@ -90,15 +86,13 @@ VAR
vocabulary: RECORD
KW: ARRAY 33 OF KEYWORD;
delimiters: ARRAY 256 OF BOOLEAN;
idents: AVL.NODE;
ident: IDENT
END;
scanners: C.COLLECTION;
upto: BOOLEAN;
PROCEDURE nodecmp (a, b: AVL.DATA): INTEGER;
@ -109,36 +103,27 @@ END nodecmp;
PROCEDURE key (VAR lex: LEX);
VAR
L, R, M: INTEGER;
found: BOOLEAN;
BEGIN
L := 0;
R := LEN(vocabulary.KW) - 1;
found := FALSE;
REPEAT
M := (L + R) DIV 2;
WHILE L # M DO
IF lex.s # vocabulary.KW[M] THEN
IF lex.s > vocabulary.KW[M] THEN
L := M;
M := (L + R) DIV 2
ELSIF lex.s < vocabulary.KW[M] THEN
R := M;
M := (L + R) DIV 2
L := M + 1
ELSE
lex.sym := lxKW + M;
L := M;
R := M
R := M - 1
END
END;
IF L # R THEN
IF lex.s = vocabulary.KW[L] THEN
lex.sym := lxKW + L
END;
IF lex.s = vocabulary.KW[R] THEN
lex.sym := lxKW + R
ELSE
found := TRUE;
lex.sym := lxKW + M
END
END
UNTIL found OR (L > R)
END key;
@ -173,18 +158,24 @@ BEGIN
END putchar;
PROCEDURE ident (text: TEXTDRV.TEXT; VAR lex: LEX);
PROCEDURE nextc (text: TXT.TEXT): CHAR;
BEGIN
TXT.next(text)
RETURN text.peak
END nextc;
PROCEDURE ident (text: TXT.TEXT; VAR lex: LEX);
VAR
c: CHAR;
BEGIN
c := text.peak(text);
c := text.peak;
ASSERT(S.letter(c));
WHILE S.letter(c) OR S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
c := nextc(text)
END;
IF lex.over THEN
@ -201,44 +192,40 @@ BEGIN
END ident;
PROCEDURE number (text: TEXTDRV.TEXT; VAR lex: LEX; VAR range: BOOLEAN);
PROCEDURE number (text: TXT.TEXT; VAR lex: LEX);
VAR
c: CHAR;
hex: BOOLEAN;
error: INTEGER;
BEGIN
c := text.peak(text);
c := text.peak;
ASSERT(S.digit(c));
error := 0;
range := FALSE;
lex.sym := lxINTEGER;
hex := FALSE;
WHILE S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
c := nextc(text)
END;
WHILE S.hexdigit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text);
c := nextc(text);
hex := TRUE
END;
IF c = "H" THEN
putchar(lex, c);
text.nextc(text);
TXT.next(text);
lex.sym := lxHEX
ELSIF c = "X" THEN
putchar(lex, c);
text.nextc(text);
TXT.next(text);
lex.sym := lxCHAR
ELSIF c = "." THEN
@ -247,39 +234,35 @@ BEGIN
lex.sym := lxERROR01
ELSE
text.nextc(text);
c := text.peak(text);
c := nextc(text);
IF c # "." THEN
putchar(lex, ".");
lex.sym := lxFLOAT
ELSE
lex.sym := lxINTEGER;
range := TRUE
text.peak := 7FX;
upto := TRUE
END;
WHILE S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
c := nextc(text)
END;
IF c = "E" THEN
putchar(lex, c);
text.nextc(text);
c := text.peak(text);
c := nextc(text);
IF (c = "+") OR (c = "-") THEN
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
c := nextc(text)
END;
IF S.digit(c) THEN
WHILE S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
c := nextc(text)
END
ELSE
lex.sym := lxERROR02
@ -289,11 +272,8 @@ BEGIN
END
ELSE
IF hex THEN
ELSIF hex THEN
lex.sym := lxERROR01
END
END;
@ -321,31 +301,23 @@ BEGIN
END number;
PROCEDURE string (text: TEXTDRV.TEXT; VAR lex: LEX);
PROCEDURE string (text: TXT.TEXT; VAR lex: LEX; quot: CHAR);
VAR
c, c1: CHAR;
c: CHAR;
n: INTEGER;
quot: CHAR;
BEGIN
quot := text.peak(text);
ASSERT((quot = '"') OR (quot = "'"));
text.nextc(text);
c := text.peak(text);
c1 := c;
c := nextc(text);
n := 0;
WHILE (c # quot) & (c # 0X) & ~text.eol & ~text.eof DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text);
c := nextc(text);
INC(n)
END;
IF c = quot THEN
text.nextc(text);
TXT.next(text);
IF lex.over THEN
lex.sym := lxERROR05
ELSE
@ -353,7 +325,7 @@ BEGIN
lex.sym := lxSTRING
ELSE
lex.sym := lxCHAR;
ARITH.setChar(lex.value, ORD(c1))
ARITH.setChar(lex.value, ORD(lex.s[0]))
END
END
ELSE
@ -369,7 +341,7 @@ BEGIN
END string;
PROCEDURE comment (text: TEXTDRV.TEXT);
PROCEDURE comment (text: TXT.TEXT);
VAR
c: CHAR;
cond, depth: INTEGER;
@ -380,8 +352,8 @@ BEGIN
REPEAT
c := text.peak(text);
text.nextc(text);
c := text.peak;
TXT.next(text);
IF c = "*" THEN
IF cond = 1 THEN
@ -406,21 +378,12 @@ BEGIN
END comment;
PROCEDURE delimiter (text: TEXTDRV.TEXT; VAR lex: LEX; VAR range: BOOLEAN);
VAR
c: CHAR;
PROCEDURE delimiter (text: TXT.TEXT; VAR lex: LEX; c: CHAR);
BEGIN
c := text.peak(text);
IF range THEN
ASSERT(c = ".")
END;
putchar(lex, c);
text.nextc(text);
c := nextc(text);
CASE c OF
CASE lex.s[0] OF
|"+":
lex.sym := lxPLUS
@ -433,10 +396,10 @@ BEGIN
|"/":
lex.sym := lxSLASH;
IF text.peak(text) = "/" THEN
IF c = "/" THEN
lex.sym := lxCOMMENT;
REPEAT
text.nextc(text)
TXT.next(text)
UNTIL text.eol OR text.eof
END
@ -447,24 +410,12 @@ BEGIN
lex.sym := lxAND
|".":
IF range THEN
putchar(lex, ".");
lex.sym := lxRANGE;
range := FALSE;
DEC(lex.pos.col)
ELSE
lex.sym := lxPOINT;
c := text.peak(text);
IF c = "." THEN
lex.sym := lxRANGE;
putchar(lex, c);
text.nextc(text)
END
TXT.next(text)
END
|",":
@ -478,12 +429,10 @@ BEGIN
|"(":
lex.sym := lxLROUND;
c := text.peak(text);
IF c = "*" THEN
lex.sym := lxCOMMENT;
putchar(lex, c);
text.nextc(text);
TXT.next(text);
comment(text)
END
@ -504,32 +453,29 @@ BEGIN
|"<":
lex.sym := lxLT;
c := text.peak(text);
IF c = "=" THEN
lex.sym := lxLE;
putchar(lex, c);
text.nextc(text)
TXT.next(text)
END
|">":
lex.sym := lxGT;
c := text.peak(text);
IF c = "=" THEN
lex.sym := lxGE;
putchar(lex, c);
text.nextc(text)
TXT.next(text)
END
|":":
lex.sym := lxCOLON;
c := text.peak(text);
IF c = "=" THEN
lex.sym := lxASSIGN;
putchar(lex, c);
text.nextc(text)
TXT.next(text)
END
|")":
@ -546,26 +492,21 @@ BEGIN
END delimiter;
PROCEDURE Next* (scanner: SCANNER; VAR lex: LEX);
PROCEDURE Next* (text: SCANNER; VAR lex: LEX);
VAR
c: CHAR;
text: TEXTDRV.TEXT;
BEGIN
text := scanner.text;
REPEAT
c := text.peak(text);
c := text.peak;
WHILE S.space(c) DO
text.nextc(text);
c := text.peak(text)
c := nextc(text)
END;
lex.s[0] := 0X;
lex.length := 0;
lex.sym := lxUNDEF;
lex.pos.line := text.line;
lex.pos.col := text.col;
lex.ident := NIL;
@ -574,19 +515,26 @@ BEGIN
IF S.letter(c) THEN
ident(text, lex)
ELSIF S.digit(c) THEN
number(text, lex, scanner.range)
number(text, lex)
ELSIF (c = '"') OR (c = "'") THEN
string(text, lex)
string(text, lex, c)
ELSIF vocabulary.delimiters[ORD(c)] THEN
delimiter(text, lex, scanner.range)
delimiter(text, lex, c)
ELSIF c = 0X THEN
lex.sym := lxEOF;
IF text.eof THEN
INC(lex.pos.col)
END
ELSIF (c = 7FX) & upto THEN
upto := FALSE;
lex.sym := lxRANGE;
putchar(lex, ".");
putchar(lex, ".");
DEC(lex.pos.col);
TXT.next(text)
ELSE
putchar(lex, c);
text.nextc(text);
TXT.next(text);
lex.sym := lxERROR04
END;
@ -601,53 +549,14 @@ BEGIN
END Next;
PROCEDURE NewScanner (): SCANNER;
VAR
scan: SCANNER;
citem: C.ITEM;
BEGIN
citem := C.pop(scanners);
IF citem = NIL THEN
NEW(scan)
ELSE
scan := citem(SCANNER)
END
RETURN scan
END NewScanner;
PROCEDURE open* (name: ARRAY OF CHAR): SCANNER;
VAR
scanner: SCANNER;
text: TEXTDRV.TEXT;
BEGIN
text := TEXTDRV.create();
IF text.open(text, name) THEN
scanner := NewScanner();
scanner.text := text;
scanner.range := FALSE
ELSE
scanner := NIL;
TEXTDRV.destroy(text)
END
RETURN scanner
RETURN TXT.open(name)
END open;
PROCEDURE close* (VAR scanner: SCANNER);
BEGIN
IF scanner # NIL THEN
IF scanner.text # NIL THEN
TEXTDRV.destroy(scanner.text)
END;
C.push(scanners, scanner);
scanner := NIL
END
TXT.close(scanner)
END close;
@ -656,14 +565,16 @@ VAR
i: INTEGER;
delim: ARRAY 23 OF CHAR;
PROCEDURE enterkw (VAR i: INTEGER; kw: KEYWORD);
BEGIN
vocabulary.KW[i] := kw;
INC(i)
END enterkw;
BEGIN
scanners := C.create();
upto := FALSE;
FOR i := 0 TO 255 DO
vocabulary.delimiters[i] := FALSE

1705
programs/develop/oberon07/Source/STATEMENTS.ob07
View File

File diff suppressed because it is too large Load Diff

23
programs/develop/oberon07/Source/STRINGS.ob07
View File

@ -92,6 +92,29 @@ BEGIN
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));
x := x DIV 16;
DEC(n)
END
END IntToHex;
PROCEDURE copy* (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR; spos, dpos, count: INTEGER);
BEGIN
WHILE count > 0 DO

111
programs/develop/oberon07/Source/TEXTDRV.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
@ -30,10 +30,7 @@ TYPE
line*, col*: INTEGER;
eof*: BOOLEAN;
eol*: BOOLEAN;
open*: PROCEDURE (text: TEXT; name: ARRAY OF CHAR): BOOLEAN;
peak*: PROCEDURE (text: TEXT): CHAR;
nextc*: PROCEDURE (text: TEXT)
peak*: CHAR
END;
@ -43,26 +40,6 @@ VAR
texts: C.COLLECTION;
PROCEDURE reset (text: TEXT);
BEGIN
text.chunk[0] := 0;
text.pos := 0;
text.size := 0;
text.file := NIL;
text.utf8 := FALSE;
text.CR := FALSE;
text.line := 1;
text.col := 1;
text.eof := FALSE;
text.eol := FALSE
END reset;
PROCEDURE peak (text: TEXT): CHAR;
RETURN CHR(text.chunk[text.pos])
END peak;
PROCEDURE load (text: TEXT);
BEGIN
IF ~text.eof THEN
@ -71,24 +48,27 @@ BEGIN
IF text.size = 0 THEN
text.eof := TRUE;
text.chunk[0] := 0
END
END;
text.peak := CHR(text.chunk[0])
END
END load;
PROCEDURE next (text: TEXT);
PROCEDURE next* (text: TEXT);
VAR
c: CHAR;
BEGIN
IF text.pos < text.size - 1 THEN
INC(text.pos)
INC(text.pos);
text.peak := CHR(text.chunk[text.pos])
ELSE
load(text)
END;
IF ~text.eof THEN
c := peak(text);
c := text.peak;
IF c = CR THEN
INC(text.line);
@ -123,7 +103,6 @@ END next;
PROCEDURE init (text: TEXT);
BEGIN
IF (text.pos = 0) & (text.size >= 3) THEN
IF (text.chunk[0] = 0EFH) &
(text.chunk[1] = 0BBH) &
@ -140,27 +119,26 @@ BEGIN
END;
text.line := 1;
text.col := 1
text.col := 1;
text.peak := CHR(text.chunk[text.pos])
END init;
PROCEDURE open (text: TEXT; name: ARRAY OF CHAR): BOOLEAN;
PROCEDURE close* (VAR text: TEXT);
BEGIN
ASSERT(text # NIL);
reset(text);
text.file := FILES.open(name);
IF text # NIL THEN
IF text.file # NIL THEN
load(text);
init(text)
FILES.close(text.file)
END;
C.push(texts, text);
text := NIL
END
RETURN text.file # NIL
END open;
END close;
PROCEDURE NewText (): TEXT;
PROCEDURE open* (name: ARRAY OF CHAR): TEXT;
VAR
text: TEXT;
citem: C.ITEM;
@ -171,37 +149,30 @@ BEGIN
NEW(text)
ELSE
text := citem(TEXT)
END
RETURN text
END NewText;
PROCEDURE create* (): TEXT;
VAR
text: TEXT;
BEGIN
text := NewText();
reset(text);
text.open := open;
text.peak := peak;
text.nextc := next
RETURN text
END create;
PROCEDURE destroy* (VAR text: TEXT);
BEGIN
IF text # NIL THEN
IF text.file # NIL THEN
FILES.close(text.file)
END;
C.push(texts, text);
text := NIL
IF text # NIL THEN
text.chunk[0] := 0;
text.pos := 0;
text.size := 0;
text.utf8 := FALSE;
text.CR := FALSE;
text.line := 1;
text.col := 1;
text.eof := FALSE;
text.eol := FALSE;
text.peak := 0X;
text.file := FILES.open(name);
IF text.file # NIL THEN
load(text);
init(text)
ELSE
close(text)
END
END destroy;
END
RETURN text
END open;
BEGIN

9
programs/develop/oberon07/Source/UNIXTIME.ob07
View File

@ -1,7 +1,7 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
@ -55,12 +55,7 @@ END init;
PROCEDURE time* (year, month, day, hour, min, sec: INTEGER): INTEGER;
VAR
d, s: INTEGER;
BEGIN
d := (year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4;
s := d * 86400 + hour * 3600 + min * 60 + sec
RETURN s
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 time;

89
programs/develop/oberon07/Source/UTILS.ob07
View File

@ -20,6 +20,9 @@ CONST
OS = HOST.OS;
min32* = -2147483647-1;
max32* = 2147483647;
VAR
@ -29,6 +32,22 @@ VAR
maxreal*: REAL;
target*:
RECORD
bit_depth*,
maxInt*,
minInt*,
maxSet*,
maxHex*: INTEGER;
maxReal*: REAL
END;
bit_diff*: INTEGER;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN HOST.FileRead(F, Buffer, bytes)
@ -112,6 +131,76 @@ BEGIN
END UnixTime;
PROCEDURE SetBitDepth* (BitDepth: INTEGER);
BEGIN
ASSERT((BitDepth = 16) OR (BitDepth = 32) OR (BitDepth = 64));
bit_diff := bit_depth - BitDepth;
ASSERT(bit_diff >= 0);
target.bit_depth := BitDepth;
target.maxSet := BitDepth - 1;
target.maxHex := BitDepth DIV 4;
target.minInt := ASR(minint, bit_diff);
target.maxInt := ASR(maxint, bit_diff);
target.maxReal := 1.9;
PACK(target.maxReal, 1023);
END SetBitDepth;
PROCEDURE Byte* (n: INTEGER; idx: INTEGER): BYTE;
RETURN ASR(n, 8 * idx) MOD 256
END Byte;
PROCEDURE Align* (VAR bytes: INTEGER; align: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF bytes MOD align # 0 THEN
res := maxint - bytes >= align - (bytes MOD align);
IF res THEN
bytes := bytes + align - (bytes MOD align)
END
ELSE
res := TRUE
END
RETURN res
END Align;
PROCEDURE Long* (value: INTEGER): INTEGER;
RETURN ASR(LSL(value, bit_diff), bit_diff)
END Long;
PROCEDURE Short* (value: INTEGER): INTEGER;
RETURN LSR(LSL(value, bit_diff), bit_diff)
END Short;
PROCEDURE Log2* (x: INTEGER): INTEGER;
VAR
n: INTEGER;
BEGIN
ASSERT(x > 0);
n := 0;
WHILE ~ODD(x) DO
x := x DIV 2;
INC(n)
END;
IF x # 1 THEN
n := -1
END
RETURN n
END Log2;
BEGIN
time := GetTickCount();
COPY(HOST.eol, eol);

16
programs/develop/oberon07/Source/WRITER.ob07
View File

@ -1,13 +1,13 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE WRITER;
IMPORT FILES, ERRORS, MACHINE;
IMPORT FILES, ERRORS, UTILS;
TYPE
@ -35,7 +35,7 @@ BEGIN
IF FILES.WriteByte(file, n) THEN
INC(counter)
ELSE
ERRORS.error1("writing file error")
ERRORS.Error(201)
END
END WriteByte;
@ -47,7 +47,7 @@ VAR
BEGIN
n := FILES.write(file, chunk, bytes);
IF n # bytes THEN
ERRORS.error1("writing file error")
ERRORS.Error(201)
END;
INC(counter, n)
END Write;
@ -59,7 +59,7 @@ VAR
BEGIN
FOR i := 0 TO 7 DO
WriteByte(file, MACHINE.Byte(n, i))
WriteByte(file, UTILS.Byte(n, i))
END
END Write64LE;
@ -70,15 +70,15 @@ VAR
BEGIN
FOR i := 0 TO 3 DO
WriteByte(file, MACHINE.Byte(n, i))
WriteByte(file, UTILS.Byte(n, i))
END
END Write32LE;
PROCEDURE Write16LE* (file: FILE; n: INTEGER);
BEGIN
WriteByte(file, MACHINE.Byte(n, 0));
WriteByte(file, MACHINE.Byte(n, 1))
WriteByte(file, UTILS.Byte(n, 0));
WriteByte(file, UTILS.Byte(n, 1))
END Write16LE;

944
programs/develop/oberon07/Source/X86.ob07
View File

File diff suppressed because it is too large Load Diff