ace-dent/kolibrios-gitea
1
0
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Activity

Oberon07: some extensions

Browse Source 
git-svn-id: svn://kolibrios.org@7107 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
Anton Krotov 2017-11-02 16:36:50 +00:00
parent 5161f3acf0
commit b6bb3d2c62
17 changed files with 698 additions and 538 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.

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

@ -30,7 +30,6 @@
передается. Сообщения компилятора выводятся на консоль (Windows, передается. Сообщения компилятора выводятся на консоль (Windows,
KolibriOS), в терминал (Linux). KolibriOS), в терминал (Linux).
2. Папка Lib - библиотека модулей 2. Папка Lib - библиотека модулей
3. Ďŕďęŕ Source - čńőîäíűé ęîä ęîěďčë˙ňîđŕ
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
Отличия от оригинала Отличия от оригинала
@ -45,6 +44,8 @@
7. Семантика DIV и MOD уточнена для отрицательных чисел 7. Семантика DIV и MOD уточнена для отрицательных чисел
8. Добавлены однострочные комментарии (начинаются с пары символов "//") 8. Добавлены однострочные комментарии (начинаются с пары символов "//")
9. Разрешен экспорт переменных типов ARRAY и RECORD (только для чтения) 9. Разрешен экспорт переменных типов ARRAY и RECORD (только для чтения)
10. Ðàçðåøåíî íàñëåäîâàíèå îò òèïà-óêàçàòåëÿ
11. Äîáàâëåíû ïñåâäîíèìû òèïîâ (TYPE A = B)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
Особенности реализации Особенности реализации
@ -93,7 +94,7 @@
возвращает специальное вещественное значение "бесконечность" возвращает специальное вещественное значение "бесконечность"
PROCEDURE GET(a: INTEGER; PROCEDURE GET(a: INTEGER;
VAR v: ëţáîé îńíîâíîé ňčď, PROCEDURE, POINTER) VAR v: ëþáîé îñíîâíîé òèï, PROCEDURE, POINTER)
v := Память[a] v := Память[a]
PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER) PROCEDURE PUT(a: INTEGER; x: любой основной тип, PROCEDURE, POINTER)
@ -103,6 +104,11 @@
Копирует n байт памяти из Source в Dest, Копирует n байт памяти из Source в Dest,
области Source и Dest не должны перекрываться области Source и Dest не должны перекрываться
PROCEDURE COPY(VAR Source: ëþáîé òèï; VAR Dest: ëþáîé òèï; n: INTEGER)
Êîïèðóåò n áàéò ïàìÿòè èç Source â Dest.
Ýêâèâàëåíòíî
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n)
PROCEDURE CODE(s: ARRAY OF CHAR) PROCEDURE CODE(s: ARRAY OF CHAR)
Вставка машинного кода Вставка машинного кода
s - строковая константа шестнадцатиричных цифр s - строковая константа шестнадцатиричных цифр
@ -198,6 +204,12 @@ Oberon-
LSR(x, n: INTEGER): INTEGER LSR(x, n: INTEGER): INTEGER
Логический сдвиг x на n бит вправо. Логический сдвиг x на n бит вправо.
MIN(a, b: INTEGER): INTEGER
Ìèíèìóì èç äâóõ çíà÷åíèé.
MAX(a, b: INTEGER): INTEGER
Ìàêñèìóì èç äâóõ çíà÷åíèé.
BITS(x: INTEGER): SET BITS(x: INTEGER): SET
Интерпретирует x как значение типа SET. Интерпретирует x как значение типа SET.
Выполняется на этапе компиляции. Выполняется на этапе компиляции.
@ -853,4 +865,6 @@ MODULE kfonts -
MODULE RasterWorks - обертка библиотеки Rasterworks.obj MODULE RasterWorks - обертка библиотеки Rasterworks.obj
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
MODULE libimg - обертка библиотеки libimg.obj MODULE libimg - обертка библиотеки libimg.obj
------------------------------------------------------------------------------
MODULE NetDevices - îáåðòêà äëÿ ô.74 (ðàáîòà ñ ñåòåâûìè óñòðîéñòâàìè)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------

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

@ -30,7 +30,6 @@
¯¥à¥¤ ¥âáï. ‘®®¡é¥­¨ï ª®¬¯¨«ïâ®à  ¢ë¢®¤ïâáï ­  ª®­á®«ì (Windows, ¯¥à¥¤ ¥âáï. ‘®®¡é¥­¨ï ª®¬¯¨«ïâ®à  ¢ë¢®¤ïâáï ­  ª®­á®«ì (Windows,
KolibriOS), ¢ â¥à¬¨­ « (Linux). KolibriOS), ¢ â¥à¬¨­ « (Linux).
2. <09> ¯ª  Lib - ¡¨¡«¨®â¥ª  ¬®¤ã«¥© 2. <09> ¯ª  Lib - ¡¨¡«¨®â¥ª  ¬®¤ã«¥©
3. <09> ¯ª  Source - ¨á室­ë© ª®¤ ª®¬¯¨«ïâ®à 
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
Žâ«¨ç¨ï ®â ®à¨£¨­ «  Žâ«¨ç¨ï ®â ®à¨£¨­ « 
@ -45,6 +44,8 @@
7. ‘¥¬ ­â¨ª  DIV ¨ MOD ãâ®ç­¥­  ¤«ï ®âà¨æ â¥«ì­ëå ç¨á¥« 7. ‘¥¬ ­â¨ª  DIV ¨ MOD ãâ®ç­¥­  ¤«ï ®âà¨æ â¥«ì­ëå ç¨á¥«
8. „®¡ ¢«¥­ë ®¤­®áâà®ç­ë¥ ª®¬¬¥­â à¨¨ (­ ç¨­ îâáï á ¯ àë ᨬ¢®«®¢ "//") 8. „®¡ ¢«¥­ë ®¤­®áâà®ç­ë¥ ª®¬¬¥­â à¨¨ (­ ç¨­ îâáï á ¯ àë ᨬ¢®«®¢ "//")
9. <09> §à¥è¥­ íªá¯®àâ ¯¥à¥¬¥­­ëå ⨯®¢ ARRAY ¨ RECORD (⮫쪮 ¤«ï ç⥭¨ï) 9. <09> §à¥è¥­ íªá¯®àâ ¯¥à¥¬¥­­ëå ⨯®¢ ARRAY ¨ RECORD (⮫쪮 ¤«ï ç⥭¨ï)
10. <09> §à¥è¥­® ­ á«¥¤®¢ ­¨¥ ®â ⨯ -㪠§ â¥«ï
11. „®¡ ¢«¥­ë ¯á¥¢¤®­¨¬ë ⨯®¢ (TYPE A = B)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
Žá®¡¥­­®á⨠ॠ«¨§ æ¨¨ Žá®¡¥­­®á⨠ॠ«¨§ æ¨¨
@ -93,7 +94,7 @@
¢®§¢à é ¥â ᯥ樠«ì­®¥ ¢¥é¥á⢥­­®¥ §­ ç¥­¨¥ "¡¥áª®­¥ç­®áâì" ¢®§¢à é ¥â ᯥ樠«ì­®¥ ¢¥é¥á⢥­­®¥ §­ ç¥­¨¥ "¡¥áª®­¥ç­®áâì"
PROCEDURE GET(a: INTEGER; PROCEDURE GET(a: INTEGER;
VAR v: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER) VAR v: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER)
v := <20> ¬ïâì[a] v := <20> ¬ïâì[a]
PROCEDURE PUT(a: INTEGER; x: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER) PROCEDURE PUT(a: INTEGER; x: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER)
@ -103,6 +104,11 @@
Š®¯¨àã¥â n ¡ ©â ¯ ¬ï⨠¨§ Source ¢ Dest, Š®¯¨àã¥â n ¡ ©â ¯ ¬ï⨠¨§ Source ¢ Dest,
®¡« á⨠Source ¨ Dest ­¥ ¤®«¦­ë ¯¥à¥ªà뢠âìáï ®¡« á⨠Source ¨ Dest ­¥ ¤®«¦­ë ¯¥à¥ªà뢠âìáï
PROCEDURE COPY(VAR Source: «î¡®© ⨯; VAR Dest: «î¡®© ⨯; n: INTEGER)
Š®¯¨àã¥â n ¡ ©â ¯ ¬ï⨠¨§ Source ¢ Dest.
<09>ª¢¨¢ «¥­â­®
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n)
PROCEDURE CODE(s: ARRAY OF CHAR) PROCEDURE CODE(s: ARRAY OF CHAR)
‚áâ ¢ª  ¬ è¨­­®£® ª®¤  ‚áâ ¢ª  ¬ è¨­­®£® ª®¤ 
s - áâப®¢ ï ª®­áâ ­â  è¥áâ­ ¤æ â¨à¨ç­ëå æ¨äà s - áâப®¢ ï ª®­áâ ­â  è¥áâ­ ¤æ â¨à¨ç­ëå æ¨äà
@ -198,6 +204,12 @@ Oberon-ॠ
LSR(x, n: INTEGER): INTEGER LSR(x, n: INTEGER): INTEGER
‹®£¨ç¥áª¨© ᤢ¨£ x ­  n ¡¨â ¢¯à ¢®. ‹®£¨ç¥áª¨© ᤢ¨£ x ­  n ¡¨â ¢¯à ¢®.
MIN(a, b: INTEGER): INTEGER
Œ¨­¨¬ã¬ ¨§ ¤¢ãå §­ ç¥­¨©.
MAX(a, b: INTEGER): INTEGER
Œ ªá¨¬ã¬ ¨§ ¤¢ãå §­ ç¥­¨©.
BITS(x: INTEGER): SET BITS(x: INTEGER): SET
ˆ­â¥à¯à¥â¨àã¥â x ª ª §­ ç¥­¨¥ ⨯  SET. ˆ­â¥à¯à¥â¨àã¥â x ª ª §­ ç¥­¨¥ ⨯  SET.
‚믮«­ï¥âáï ­  íâ ¯¥ ª®¬¯¨«ï樨. ‚믮«­ï¥âáï ­  íâ ¯¥ ª®¬¯¨«ï樨.
@ -853,4 +865,6 @@ MODULE kfonts - ࠡ
MODULE RasterWorks - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ Rasterworks.obj MODULE RasterWorks - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ Rasterworks.obj
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
MODULE libimg - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ libimg.obj MODULE libimg - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ libimg.obj
------------------------------------------------------------------------------
MODULE NetDevices - ®¡¥à⪠ ¤«ï ä.74 (à ¡®â  á á¥â¥¢ë¬¨ ãáâனá⢠¬¨)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------

47
programs/develop/oberon07/Lib/KolibriOS/API.ob07
View File

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify 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 it under the terms of the GNU Lesser General Public License as published by
@ -107,34 +107,34 @@ BEGIN
ELSE ELSE
temp := 0; temp := 0;
IF heap + size >= endheap THEN IF heap + size >= endheap THEN
IF sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN IF sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
temp := sysfunc3(68, 12, HEAP_SIZE) temp := sysfunc3(68, 12, HEAP_SIZE)
ELSE ELSE
temp := 0 temp := 0
END; END;
IF temp # 0 THEN IF temp # 0 THEN
mem_commit(temp, HEAP_SIZE); mem_commit(temp, HEAP_SIZE);
heap := temp; heap := temp;
endheap := heap + HEAP_SIZE endheap := heap + HEAP_SIZE
ELSE ELSE
temp := -1 temp := -1
END END
END; END;
IF (heap # 0) & (temp # -1) THEN IF (heap # 0) & (temp # -1) THEN
sys.PUT(heap, size); sys.PUT(heap, size);
res := heap + 4; res := heap + 4;
heap := heap + size heap := heap + size
ELSE ELSE
res := 0 res := 0
END END
END END
ELSE ELSE
IF sysfunc2(18, 16) > ASR(size, 10) THEN IF sysfunc2(18, 16) > ASR(size, 10) THEN
res := sysfunc3(68, 12, size); res := sysfunc3(68, 12, size);
IF res # 0 THEN IF res # 0 THEN
mem_commit(res, size); mem_commit(res, size);
sys.PUT(res, size); sys.PUT(res, size);
INC(res, 4) INC(res, 4)
END END
ELSE ELSE
res := 0 res := 0
@ -166,6 +166,11 @@ BEGIN
p1 := sysfunc1(-1) p1 := sysfunc1(-1)
END ExitProcess; END ExitProcess;
PROCEDURE ExitThread*(p1: INTEGER);
BEGIN
p1 := sysfunc1(-1)
END ExitThread;
PROCEDURE OutChar(c: CHAR); PROCEDURE OutChar(c: CHAR);
VAR res: INTEGER; VAR res: INTEGER;
BEGIN BEGIN
@ -181,7 +186,7 @@ BEGIN
REPEAT REPEAT
sys.GET(lpCaption, c); sys.GET(lpCaption, c);
IF c # 0X THEN IF c # 0X THEN
OutChar(c) OutChar(c)
END; END;
INC(lpCaption) INC(lpCaption)
UNTIL c = 0X; UNTIL c = 0X;

54
programs/develop/oberon07/Lib/KolibriOS/HOST.ob07
View File

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify 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 it under the terms of the GNU Lesser General Public License as published by
@ -35,46 +35,12 @@ TYPE
VAR VAR
con_init : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER); con_init : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
con_exit : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN); con_exit : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
con_write_asciiz : PROCEDURE [stdcall] (string: INTEGER); con_write_asciiz : PROCEDURE [stdcall] (string: INTEGER);
fsize, sec*, dsec*: INTEGER; fsize, sec*, dsec*: INTEGER;
PROCEDURE [stdcall] sysfunc1(arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall] sysfunc2(arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall] sysfunc3(arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall] sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER; PROCEDURE [stdcall] sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
BEGIN BEGIN
sys.CODE("53"); (* push ebx *) sys.CODE("53"); (* push ebx *)
@ -122,7 +88,7 @@ END GetProcAdr;
PROCEDURE Time*(VAR sec, dsec: INTEGER); PROCEDURE Time*(VAR sec, dsec: INTEGER);
VAR t: INTEGER; VAR t: INTEGER;
BEGIN BEGIN
t := sysfunc2(26, 9); t := API.sysfunc2(26, 9);
sec := t DIV 100; sec := t DIV 100;
dsec := t MOD 100 dsec := t MOD 100
END Time; END Time;
@ -139,10 +105,10 @@ VAR Lib: INTEGER;
BEGIN BEGIN
Time(sec, dsec); Time(sec, dsec);
Lib := sysfunc3(68, 19, sys.ADR("/rd/1/lib/console.obj")); Lib := API.sysfunc3(68, 19, sys.ADR("/rd/1/lib/console.obj"));
IF Lib # 0 THEN IF Lib # 0 THEN
GetProc(sys.ADR(con_init), "con_init"); GetProc(sys.ADR(con_init), "con_init");
GetProc(sys.ADR(con_exit), "con_exit"); GetProc(sys.ADR(con_exit), "con_exit");
GetProc(sys.ADR(con_write_asciiz), "con_write_asciiz"); GetProc(sys.ADR(con_write_asciiz), "con_write_asciiz");
IF con_init # NIL THEN IF con_init # NIL THEN
con_init(-1, -1, -1, -1, sys.ADR("Oberon-07/11 for KolibriOS")) con_init(-1, -1, -1, -1, sys.ADR("Oberon-07/11 for KolibriOS"))
@ -155,7 +121,7 @@ BEGIN
IF con_exit # NIL THEN IF con_exit # NIL THEN
con_exit(FALSE) con_exit(FALSE)
END; END;
n := sysfunc1(-1) API.ExitProcess(0)
END ExitProcess; END ExitProcess;
PROCEDURE GetCommandLine*(): INTEGER; PROCEDURE GetCommandLine*(): INTEGER;
@ -173,7 +139,7 @@ BEGIN
END GetName; END GetName;
PROCEDURE malloc*(size: INTEGER): INTEGER; PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN sysfunc3(68, 12, size) RETURN API.sysfunc3(68, 12, size)
END malloc; END malloc;
PROCEDURE CloseFile*(hObject: INTEGER); PROCEDURE CloseFile*(hObject: INTEGER);

107
programs/develop/oberon07/Lib/KolibriOS/NetDevices.ob07 Normal file
View File

@ -0,0 +1,107 @@
(*
Copyright 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE NetDevices;
IMPORT sys := SYSTEM, K := KOSAPI;
CONST
//net devices types
LOOPBACK* = 0;
ETH* = 1;
SLIP* = 2;
//Link status
LINK_DOWN* = 0;
LINK_UNKNOWN* = 1;
LINK_FD* = 2; //full duplex flag
LINK_10M* = 4;
LINK_100M* = 8;
LINK_1G* = 12;
TYPE
DEVICENAME* = ARRAY 64 OF CHAR;
PROCEDURE Number* (): INTEGER;
RETURN K.sysfunc2(74, -1)
END Number;
PROCEDURE Type* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256)
END Type;
PROCEDURE Name* (num: INTEGER; VAR name: DEVICENAME): BOOLEAN;
VAR err: BOOLEAN;
BEGIN
err := K.sysfunc3(74, num * 256 + 1, sys.ADR(name[0])) = -1;
IF err THEN
name := ""
END
RETURN ~err
END Name;
PROCEDURE Reset* (num: INTEGER): BOOLEAN;
RETURN K.sysfunc2(74, num * 256 + 2) # -1
END Reset;
PROCEDURE Stop* (num: INTEGER): BOOLEAN;
RETURN K.sysfunc2(74, num * 256 + 3) # -1
END Stop;
PROCEDURE Pointer* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 4)
END Pointer;
PROCEDURE SentPackets* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 6)
END SentPackets;
PROCEDURE ReceivedPackets* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 7)
END ReceivedPackets;
PROCEDURE SentBytes* (num: INTEGER; VAR hValue: INTEGER): INTEGER;
RETURN K.sysfunc22(74, num * 256 + 8, hValue)
END SentBytes;
PROCEDURE ReceivedBytes* (num: INTEGER; VAR hValue: INTEGER): INTEGER;
RETURN K.sysfunc22(74, num * 256 + 9, hValue)
END ReceivedBytes;
PROCEDURE LinkStatus* (num: INTEGER): INTEGER;
RETURN K.sysfunc2(74, num * 256 + 10)
END LinkStatus;
END NetDevices.

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

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify 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 it under the terms of the GNU Lesser General Public License as published by
@ -28,6 +28,7 @@ TYPE
VAR VAR
SelfName, rtab: INTEGER; CloseProc: PROC; SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
PROCEDURE [stdcall] _halt*(n: INTEGER); PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN BEGIN
@ -116,26 +117,18 @@ BEGIN
END END
END _arrayrot; END _arrayrot;
PROCEDURE Min(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END Min;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
BEGIN BEGIN
sys.CODE("8B4508"); // mov eax, [ebp + 08h] sys.CODE("8B4508"); // mov eax, [ebp + 08h]
sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch] sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch]
sys.CODE("48"); // dec eax sys.CODE("48"); // dec eax
// L1: // L1:
sys.CODE("40"); // inc eax sys.CODE("40"); // inc eax
sys.CODE("803800"); // cmp byte ptr [eax], 0 sys.CODE("803800"); // cmp byte ptr [eax], 0
sys.CODE("7403"); // jz L2 sys.CODE("7403"); // jz L2
sys.CODE("E2F8"); // loop L1 sys.CODE("E2F8"); // loop L1
sys.CODE("40"); // inc eax sys.CODE("40"); // inc eax
// L2: // L2:
sys.CODE("2B4508"); // sub eax, [ebp + 08h] sys.CODE("2B4508"); // sub eax, [ebp + 08h]
sys.CODE("C9"); // leave sys.CODE("C9"); // leave
sys.CODE("C20800"); // ret 08h sys.CODE("C20800"); // ret 08h
@ -144,7 +137,7 @@ END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN BEGIN
_savearr(Min(alen, blen), a, b); _savearr(MIN(alen, blen), a, b);
IF blen > alen THEN IF blen > alen THEN
sys.PUT(b + alen, 0X) sys.PUT(b + alen, 0X)
END END
@ -153,7 +146,7 @@ END _strcopy;
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN; VAR i: INTEGER; Res: BOOLEAN;
BEGIN BEGIN
i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b))); i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b)));
IF i = 0 THEN IF i = 0 THEN
i := _length(a) - _length(b) i := _length(a) - _length(b)
END; END;
@ -252,7 +245,8 @@ BEGIN
Int(code, int); Int(code, int);
StrAppend(int) StrAppend(int)
END; END;
API.DebugMsg(sys.ADR(msg), SelfName) API.DebugMsg(sys.ADR(msg), SelfName);
API.ExitThread(0)
END _assrt; END _assrt;
PROCEDURE [stdcall] _close*; PROCEDURE [stdcall] _close*;
@ -264,11 +258,14 @@ END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
BEGIN BEGIN
API.zeromem(gsize, gadr); IF ~init THEN
API.init(esp); API.zeromem(gsize, gadr);
SelfName := self; init := TRUE;
rtab := rec; API.init(esp);
CloseProc := NIL SelfName := self;
rtab := rec;
CloseProc := NIL
END
END _init; END _init;
PROCEDURE SetClose*(proc: PROC); PROCEDURE SetClose*(proc: PROC);

51
programs/develop/oberon07/Lib/Linux32/API.ob07
View File

@ -1,4 +1,4 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify This program is free software: you can redistribute it and/or modify
@ -27,22 +27,22 @@ VAR
Param*: INTEGER; Param*: INTEGER;
sec* : INTEGER; sec* : INTEGER;
dsec* : INTEGER; dsec* : INTEGER;
stdin* : INTEGER; stdin* : INTEGER;
stdout* : INTEGER; stdout* : INTEGER;
stderr* : INTEGER; stderr* : INTEGER;
dlopen* : PROCEDURE [cdecl] (filename, flag: INTEGER): INTEGER; dlopen* : PROCEDURE [cdecl] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [cdecl] (handle, symbol: INTEGER): INTEGER; dlsym* : PROCEDURE [cdecl] (handle, symbol: INTEGER): INTEGER;
_malloc* : PROCEDURE [cdecl] (size: INTEGER): INTEGER; _malloc* : PROCEDURE [cdecl] (size: INTEGER): INTEGER;
free* : PROCEDURE [cdecl] (ptr: INTEGER); free* : PROCEDURE [cdecl] (ptr: INTEGER);
fopen* : PROCEDURE [cdecl] (fname, fmode: INTEGER): INTEGER; fopen* : PROCEDURE [cdecl] (fname, fmode: INTEGER): INTEGER;
fclose*, ftell* : PROCEDURE [cdecl] (file: INTEGER): INTEGER; fclose*, ftell* : PROCEDURE [cdecl] (file: INTEGER): INTEGER;
fwrite*, fread* : PROCEDURE [cdecl] (buffer, bytes, blocks, file: INTEGER): INTEGER; fwrite*, fread* : PROCEDURE [cdecl] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fseek* : PROCEDURE [cdecl] (file, offset, origin: INTEGER): INTEGER; fseek* : PROCEDURE [cdecl] (file, offset, origin: INTEGER): INTEGER;
exit* : PROCEDURE [cdecl] (code: INTEGER); exit* : PROCEDURE [cdecl] (code: INTEGER);
strncmp* : PROCEDURE [cdecl] (str1, str2, n: INTEGER): INTEGER; strncmp* : PROCEDURE [cdecl] (str1, str2, n: INTEGER): INTEGER;
strlen* : PROCEDURE [cdecl] (str: INTEGER): INTEGER; strlen* : PROCEDURE [cdecl] (str: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [cdecl] (clock_id: INTEGER; VAR tp: TP): INTEGER; clock_gettime* : PROCEDURE [cdecl] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER); PROCEDURE [stdcall] zeromem* (size, adr: INTEGER);
@ -103,6 +103,11 @@ BEGIN
exit(code) exit(code)
END ExitProcess; END ExitProcess;
PROCEDURE ExitThread* (code: INTEGER);
BEGIN
exit(code)
END ExitThread;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER); PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
VAR H: INTEGER; VAR H: INTEGER;
BEGIN BEGIN
@ -116,19 +121,19 @@ VAR lib, proc: INTEGER;
BEGIN BEGIN
Param := esp; Param := esp;
sys.MOVE(Param + 12, sys.ADR(dlopen), 4); sys.MOVE(Param + 12, sys.ADR(dlopen), 4);
sys.MOVE(Param + 16, sys.ADR(dlsym), 4); sys.MOVE(Param + 16, sys.ADR(dlsym), 4);
sys.MOVE(Param + 20, sys.ADR(exit), 4); sys.MOVE(Param + 20, sys.ADR(exit), 4);
sys.MOVE(Param + 24, sys.ADR(stdin), 4); sys.MOVE(Param + 24, sys.ADR(stdin), 4);
sys.MOVE(Param + 28, sys.ADR(stdout), 4); sys.MOVE(Param + 28, sys.ADR(stdout), 4);
sys.MOVE(Param + 32, sys.ADR(stderr), 4); sys.MOVE(Param + 32, sys.ADR(stderr), 4);
sys.MOVE(Param + 36, sys.ADR(_malloc), 4); sys.MOVE(Param + 36, sys.ADR(_malloc), 4);
sys.MOVE(Param + 40, sys.ADR(free), 4); sys.MOVE(Param + 40, sys.ADR(free), 4);
sys.MOVE(Param + 44, sys.ADR(fopen), 4); sys.MOVE(Param + 44, sys.ADR(fopen), 4);
sys.MOVE(Param + 48, sys.ADR(fclose), 4); sys.MOVE(Param + 48, sys.ADR(fclose), 4);
sys.MOVE(Param + 52, sys.ADR(fwrite), 4); sys.MOVE(Param + 52, sys.ADR(fwrite), 4);
sys.MOVE(Param + 56, sys.ADR(fread), 4); sys.MOVE(Param + 56, sys.ADR(fread), 4);
sys.MOVE(Param + 60, sys.ADR(fseek), 4); sys.MOVE(Param + 60, sys.ADR(fseek), 4);
sys.MOVE(Param + 64, sys.ADR(ftell), 4); sys.MOVE(Param + 64, sys.ADR(ftell), 4);
lib := dlopen(sys.ADR("libc.so.6"), 1); lib := dlopen(sys.ADR("libc.so.6"), 1);
ASSERT(lib # 0); ASSERT(lib # 0);

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

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify 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 it under the terms of the GNU Lesser General Public License as published by
@ -28,6 +28,7 @@ TYPE
VAR VAR
SelfName, rtab: INTEGER; CloseProc: PROC; SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
PROCEDURE [stdcall] _halt*(n: INTEGER); PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN BEGIN
@ -116,26 +117,18 @@ BEGIN
END END
END _arrayrot; END _arrayrot;
PROCEDURE Min(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END Min;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
BEGIN BEGIN
sys.CODE("8B4508"); // mov eax, [ebp + 08h] sys.CODE("8B4508"); // mov eax, [ebp + 08h]
sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch] sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch]
sys.CODE("48"); // dec eax sys.CODE("48"); // dec eax
// L1: // L1:
sys.CODE("40"); // inc eax sys.CODE("40"); // inc eax
sys.CODE("803800"); // cmp byte ptr [eax], 0 sys.CODE("803800"); // cmp byte ptr [eax], 0
sys.CODE("7403"); // jz L2 sys.CODE("7403"); // jz L2
sys.CODE("E2F8"); // loop L1 sys.CODE("E2F8"); // loop L1
sys.CODE("40"); // inc eax sys.CODE("40"); // inc eax
// L2: // L2:
sys.CODE("2B4508"); // sub eax, [ebp + 08h] sys.CODE("2B4508"); // sub eax, [ebp + 08h]
sys.CODE("C9"); // leave sys.CODE("C9"); // leave
sys.CODE("C20800"); // ret 08h sys.CODE("C20800"); // ret 08h
@ -144,7 +137,7 @@ END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN BEGIN
_savearr(Min(alen, blen), a, b); _savearr(MIN(alen, blen), a, b);
IF blen > alen THEN IF blen > alen THEN
sys.PUT(b + alen, 0X) sys.PUT(b + alen, 0X)
END END
@ -153,7 +146,7 @@ END _strcopy;
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN; VAR i: INTEGER; Res: BOOLEAN;
BEGIN BEGIN
i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b))); i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b)));
IF i = 0 THEN IF i = 0 THEN
i := _length(a) - _length(b) i := _length(a) - _length(b)
END; END;
@ -252,7 +245,8 @@ BEGIN
Int(code, int); Int(code, int);
StrAppend(int) StrAppend(int)
END; END;
API.DebugMsg(sys.ADR(msg), SelfName) API.DebugMsg(sys.ADR(msg), SelfName);
API.ExitThread(0)
END _assrt; END _assrt;
PROCEDURE [stdcall] _close*; PROCEDURE [stdcall] _close*;
@ -264,11 +258,14 @@ END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
BEGIN BEGIN
API.zeromem(gsize, gadr); IF ~init THEN
API.init(esp); API.zeromem(gsize, gadr);
SelfName := self; init := TRUE;
rtab := rec; API.init(esp);
CloseProc := NIL; SelfName := self;
rtab := rec;
CloseProc := NIL
END
END _init; END _init;
PROCEDURE SetClose*(proc: PROC); PROCEDURE SetClose*(proc: PROC);

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

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify 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 it under the terms of the GNU Lesser General Public License as published by
@ -25,6 +25,8 @@ VAR
Free*: PROCEDURE [winapi] (hMem: INTEGER): INTEGER; Free*: PROCEDURE [winapi] (hMem: INTEGER): INTEGER;
MessageBoxA*: PROCEDURE [winapi] (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER; MessageBoxA*: PROCEDURE [winapi] (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER); ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
ExitThread*: PROCEDURE [winapi] (code: INTEGER);
GetCurrentThreadId*: PROCEDURE [winapi] (): INTEGER;
strncmp*: PROCEDURE [cdecl] (a, b, n: INTEGER): INTEGER; strncmp*: PROCEDURE [cdecl] (a, b, n: INTEGER): INTEGER;
GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER; GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER;
@ -62,6 +64,8 @@ BEGIN
lib := LoadLibraryA(sys.ADR("kernel32.dll")); lib := LoadLibraryA(sys.ADR("kernel32.dll"));
GetProc("ExitProcess", lib, sys.ADR(ExitProcess)); GetProc("ExitProcess", lib, sys.ADR(ExitProcess));
GetProc("ExitThread", lib, sys.ADR(ExitThread));
GetProc("GetCurrentThreadId", lib, sys.ADR(GetCurrentThreadId));
GetProc("GlobalAlloc", lib, sys.ADR(Alloc)); GetProc("GlobalAlloc", lib, sys.ADR(Alloc));
GetProc("GlobalFree", lib, sys.ADR(Free)); GetProc("GlobalFree", lib, sys.ADR(Free));

14
programs/develop/oberon07/Lib/Windows32/HOST.ob07
View File

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify 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 it under the terms of the GNU Lesser General Public License as published by
@ -49,7 +49,6 @@ VAR
ReadFile, WriteFile: PROCEDURE [winapi] (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, lpOverlapped: INTEGER): INTEGER; ReadFile, WriteFile: PROCEDURE [winapi] (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, lpOverlapped: INTEGER): INTEGER;
GetCommandLine*: PROCEDURE [winapi] (): INTEGER; GetCommandLine*: PROCEDURE [winapi] (): INTEGER;
GetTickCount: PROCEDURE [winapi] (): INTEGER; GetTickCount: PROCEDURE [winapi] (): INTEGER;
Alloc: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER); ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
SetFilePointer: PROCEDURE [winapi] (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER; SetFilePointer: PROCEDURE [winapi] (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
@ -71,7 +70,7 @@ BEGIN
END OutString; END OutString;
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER; PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
VAR res: INTEGER; VAR res: INTEGER;
BEGIN BEGIN
res := _CreateFile(sys.ADR(FName[0]), 0C0000000H, 0, 0, 2, 80H, 0); res := _CreateFile(sys.ADR(FName[0]), 0C0000000H, 0, 0, 2, 80H, 0);
IF res = -1 THEN IF res = -1 THEN
@ -112,12 +111,12 @@ BEGIN
END Time; END Time;
PROCEDURE malloc*(size: INTEGER): INTEGER; PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN Alloc(64, size) RETURN API.Alloc(64, size)
END malloc; END malloc;
PROCEDURE init*; PROCEDURE init*;
VAR lib: INTEGER; VAR lib: INTEGER;
BEGIN BEGIN
lib := API.LoadLibraryA(sys.ADR("kernel32.dll")); lib := API.LoadLibraryA(sys.ADR("kernel32.dll"));
GetProc("GetTickCount", lib, sys.ADR(GetTickCount)); GetProc("GetTickCount", lib, sys.ADR(GetTickCount));
Time(sec, dsec); Time(sec, dsec);
@ -128,9 +127,8 @@ BEGIN
GetProc("ReadFile", lib, sys.ADR(ReadFile)); GetProc("ReadFile", lib, sys.ADR(ReadFile));
GetProc("WriteFile", lib, sys.ADR(WriteFile)); GetProc("WriteFile", lib, sys.ADR(WriteFile));
GetProc("GetCommandLineA", lib, sys.ADR(GetCommandLine)); GetProc("GetCommandLineA", lib, sys.ADR(GetCommandLine));
GetProc("ExitProcess", lib, sys.ADR(ExitProcess));
GetProc("GlobalAlloc", lib, sys.ADR(Alloc));
GetProc("SetFilePointer", lib, sys.ADR(SetFilePointer)); GetProc("SetFilePointer", lib, sys.ADR(SetFilePointer));
ExitProcess := API.ExitProcess;
hConsoleOutput := GetStdHandle(-11) hConsoleOutput := GetStdHandle(-11)
END init; END init;

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

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This program is free software: you can redistribute it and/or modify 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 it under the terms of the GNU Lesser General Public License as published by
@ -28,6 +28,8 @@ TYPE
VAR VAR
SelfName, rtab: INTEGER; CloseProc: PROC; SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
main_thread_id: INTEGER;
PROCEDURE [stdcall] _halt*(n: INTEGER); PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN BEGIN
@ -116,26 +118,18 @@ BEGIN
END END
END _arrayrot; END _arrayrot;
PROCEDURE Min(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END Min;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
BEGIN BEGIN
sys.CODE("8B4508"); // mov eax, [ebp + 08h] sys.CODE("8B4508"); // mov eax, [ebp + 08h]
sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch] sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch]
sys.CODE("48"); // dec eax sys.CODE("48"); // dec eax
// L1: // L1:
sys.CODE("40"); // inc eax sys.CODE("40"); // inc eax
sys.CODE("803800"); // cmp byte ptr [eax], 0 sys.CODE("803800"); // cmp byte ptr [eax], 0
sys.CODE("7403"); // jz L2 sys.CODE("7403"); // jz L2
sys.CODE("E2F8"); // loop L1 sys.CODE("E2F8"); // loop L1
sys.CODE("40"); // inc eax sys.CODE("40"); // inc eax
// L2: // L2:
sys.CODE("2B4508"); // sub eax, [ebp + 08h] sys.CODE("2B4508"); // sub eax, [ebp + 08h]
sys.CODE("C9"); // leave sys.CODE("C9"); // leave
sys.CODE("C20800"); // ret 08h sys.CODE("C20800"); // ret 08h
@ -144,7 +138,7 @@ END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN BEGIN
_savearr(Min(alen, blen), a, b); _savearr(MIN(alen, blen), a, b);
IF blen > alen THEN IF blen > alen THEN
sys.PUT(b + alen, 0X) sys.PUT(b + alen, 0X)
END END
@ -153,7 +147,7 @@ END _strcopy;
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN; VAR i: INTEGER; Res: BOOLEAN;
BEGIN BEGIN
i := API.strncmp(sys.ADR(a), sys.ADR(b), Min(LEN(a), LEN(b))); i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b)));
IF i = 0 THEN IF i = 0 THEN
i := _length(a) - _length(b) i := _length(a) - _length(b)
END; END;
@ -252,7 +246,11 @@ BEGIN
Int(code, int); Int(code, int);
StrAppend(int) StrAppend(int)
END; END;
API.DebugMsg(sys.ADR(msg), SelfName) IF API.GetCurrentThreadId() = main_thread_id THEN
API.ExitProcess(0)
ELSE
API.ExitThread(0)
END
END _assrt; END _assrt;
PROCEDURE [stdcall] _close*; PROCEDURE [stdcall] _close*;
@ -264,11 +262,15 @@ END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
BEGIN BEGIN
API.zeromem(gsize, gadr); IF ~init THEN
API.init(esp); API.zeromem(gsize, gadr);
SelfName := self; init := TRUE;
rtab := rec; API.init(esp);
CloseProc := NIL; main_thread_id := API.GetCurrentThreadId();
SelfName := self;
rtab := rec;
CloseProc := NIL
END
END _init; END _init;
PROCEDURE SetClose*(proc: PROC); PROCEDURE SetClose*(proc: PROC);

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

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This file is part of Compiler. This file is part of Compiler.
@ -52,10 +52,10 @@ CONST
stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8; stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8;
stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15; stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15;
stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22; stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22;
stBITS = 23; stLSR = 24; stLENGTH = 25; stBITS = 23; stLSR = 24; stLENGTH = 25; stMIN = 26; stMAX = 27;
sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105; sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; sysCOPY = 109;
TYPE TYPE
@ -198,11 +198,11 @@ BEGIN
loc := id.Offset loc := id.Offset
ELSIF (id.VarKind = DECL.paramvar) OR (id.T.tType IN TSTRUCT) THEN ELSIF (id.VarKind = DECL.paramvar) OR (id.T.tType IN TSTRUCT) THEN
IF DECL.Dim(e.T) > 0 THEN IF DECL.Dim(e.T) > 0 THEN
n := DECL.Dim(e.T); n := DECL.Dim(e.T);
FOR i := n TO 1 BY -1 DO FOR i := n TO 1 BY -1 DO
X86.LocalAdr(id.Offset + i * 4, bases); X86.LocalAdr(id.Offset + i * 4, bases);
X86.Load(TINTEGER) X86.Load(TINTEGER)
END END
END; END;
X86.LocalAdr(id.Offset, bases); X86.LocalAdr(id.Offset, bases);
X86.Load(TINTEGER) X86.Load(TINTEGER)
@ -219,9 +219,9 @@ BEGIN
ELSIF id.T.tType = TSTRING THEN ELSIF id.T.tType = TSTRING THEN
s := DECL.GetString(e.Value); s := DECL.GetString(e.Value);
IF s.Len = 1 THEN IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0])) X86.PushConst(ORD(s.Str[0]))
ELSE ELSE
X86.PushInt(s.Number) X86.PushInt(s.Number)
END END
END END
|IDPROC: |IDPROC:
@ -249,32 +249,32 @@ BEGIN
e.deref := FALSE; e.deref := FALSE;
Assert2(e.T.tType IN TOBJECT, 105); Assert2(e.T.tType IN TOBJECT, 105);
IF e.T.tType = TPOINTER THEN IF e.T.tType = TPOINTER THEN
e.Read := FALSE; e.Read := FALSE;
LoadVar; LoadVar;
e.T := e.T.Base; e.T := e.T.Base;
X86.Load(TINTEGER); X86.Load(TINTEGER);
IF ~guard THEN IF ~guard THEN
X86.CheckNIL X86.CheckNIL
END END
END; END;
NextCheck(lxIDENT); NextCheck(lxIDENT);
Coord(coord); Coord(coord);
name := SCAN.id; name := SCAN.id;
T := e.T; T := e.T;
REPEAT REPEAT
f := DECL.GetField(T, name); f := DECL.GetField(T, name);
T := T.Base T := T.Base
UNTIL (f # NIL) OR (T = NIL); UNTIL (f # NIL) OR (T = NIL);
Assert(f # NIL, coord, 99); Assert(f # NIL, coord, 99);
IF f.Unit # DECL.unit THEN IF f.Unit # DECL.unit THEN
Assert(f.Export, coord, 99) Assert(f.Export, coord, 99)
END; END;
IF glob # -1 THEN IF glob # -1 THEN
glob := glob + f.Offset glob := glob + f.Offset
ELSIF loc # -1 THEN ELSIF loc # -1 THEN
loc := loc + f.Offset loc := loc + f.Offset
ELSE ELSE
X86.Field(f.Offset) X86.Field(f.Offset)
END; END;
e.T := f.T; e.T := f.T;
e.vparam := FALSE; e.vparam := FALSE;
@ -283,29 +283,29 @@ BEGIN
|lxLSquare: |lxLSquare:
LoadVar; LoadVar;
REPEAT REPEAT
Assert2(e.T.tType = TARRAY, 102); Assert2(e.T.tType = TARRAY, 102);
NextCoord(coord); NextCoord(coord);
pExpr(e1); pExpr(e1);
IntType(e1.T, coord); IntType(e1.T, coord);
Load(e1); Load(e1);
IF e.T.Len = 0 THEN IF e.T.Len = 0 THEN
BaseT := DECL.OpenBase(e.T); BaseT := DECL.OpenBase(e.T);
X86.PushConst(BaseT.Size); X86.PushConst(BaseT.Size);
X86.OpenIdx(DECL.Dim(e.T)) X86.OpenIdx(DECL.Dim(e.T))
ELSE ELSE
IF e1.eType = eCONST THEN IF e1.eType = eCONST THEN
idx := FLOOR(e1.Value); idx := FLOOR(e1.Value);
Assert((idx >= 0) & (idx < e.T.Len), coord, 159); Assert((idx >= 0) & (idx < e.T.Len), coord, 159);
IF e.T.Base.Size # 1 THEN IF e.T.Base.Size # 1 THEN
X86.Drop; X86.Drop;
X86.PushConst(e.T.Base.Size * idx) X86.PushConst(e.T.Base.Size * idx)
END; END;
X86.Idx X86.Idx
ELSE ELSE
X86.FixIdx(e.T.Len, e.T.Base.Size) X86.FixIdx(e.T.Len, e.T.Base.Size)
END END
END; END;
e.T := e.T.Base e.T := e.T.Base
UNTIL SCAN.tLex # lxComma; UNTIL SCAN.tLex # lxComma;
Check(lxRSquare); Check(lxRSquare);
e.vparam := FALSE; e.vparam := FALSE;
@ -317,7 +317,7 @@ BEGIN
e.Read := FALSE; e.Read := FALSE;
X86.Load(TINTEGER); X86.Load(TINTEGER);
IF ~guard THEN IF ~guard THEN
X86.CheckNIL X86.CheckNIL
END; END;
e.T := e.T.Base; e.T := e.T.Base;
e.vparam := FALSE; e.vparam := FALSE;
@ -327,36 +327,36 @@ BEGIN
|lxLRound: |lxLRound:
LoadVar; LoadVar;
IF e.T.tType IN TOBJECT THEN IF e.T.tType IN TOBJECT THEN
IF e.T.tType = TRECORD THEN IF e.T.tType = TRECORD THEN
Assert2(e.vparam, 108) Assert2(e.vparam, 108)
END; END;
NextCheck(lxIDENT); NextCheck(lxIDENT);
Coord(coord); Coord(coord);
T := DECL.IdType(coord); T := DECL.IdType(coord);
Assert(T # NIL, coord, 42); Assert(T # NIL, coord, 42);
IF e.T.tType = TRECORD THEN IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord, 106) Assert(T.tType = TRECORD, coord, 106)
ELSE ELSE
Assert(T.tType = TPOINTER, coord, 107) Assert(T.tType = TPOINTER, coord, 107)
END; END;
Assert(BaseOf(e.T, T), coord, 108); Assert(BaseOf(e.T, T), coord, 108);
e.T := T; e.T := T;
Check(lxRRound); Check(lxRRound);
Next; Next;
IF e.T.tType = TPOINTER THEN IF e.T.tType = TPOINTER THEN
IF (SCAN.tLex = lxDot) OR (SCAN.tLex = lxCaret) THEN IF (SCAN.tLex = lxDot) OR (SCAN.tLex = lxCaret) THEN
X86.DupLoadCheck X86.DupLoadCheck
ELSE ELSE
X86.DupLoad X86.DupLoad
END; END;
guard := TRUE; guard := TRUE;
T := T.Base T := T.Base
ELSE ELSE
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level) X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END; END;
X86.Guard(T.Number, FALSE) X86.Guard(T.Number, FALSE)
ELSE ELSE
break := TRUE break := TRUE
END END
ELSE ELSE
break := TRUE break := TRUE
@ -393,8 +393,10 @@ BEGIN
pExpr(b); pExpr(b);
IntType(b.T, coord); IntType(b.T, coord);
IF b.eType = eCONST THEN IF b.eType = eCONST THEN
Assert(ASR(FLOOR(b.Value), 5) = 0, coord, 53); Assert(ASR(FLOOR(b.Value), 5) = 0, coord, 53);
Assert(a.Value <= b.Value, coord, 54) IF a.eType = eCONST THEN
Assert(a.Value <= b.Value, coord, 54)
END
END; END;
Load(b) Load(b)
ELSE ELSE
@ -547,10 +549,10 @@ BEGIN
Load(e1); Load(e1);
IF e1.eType = eCONST THEN IF e1.eType = eCONST THEN
IF e1.T.tType = TSTRING THEN IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value); str := DECL.GetString(e1.Value);
e.Value := LONG(FLT(ORD(str.Str[0]))) e.Value := LONG(FLT(ORD(str.Str[0])))
ELSE ELSE
e.Value := e1.Value e.Value := e1.Value
END; END;
e.eType := eCONST e.eType := eCONST
END; END;
@ -606,8 +608,8 @@ BEGIN
IF e1.T.tType = TSTRING THEN IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value); str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN IF str.Len = 1 THEN
X86.Mono(str.Number); X86.Mono(str.Number);
X86.StrMono X86.StrMono
END; END;
e.Value := LONG(FLT(LENGTH(str.Str))); e.Value := LONG(FLT(LENGTH(str.Str)));
e.eType := eCONST e.eType := eCONST
@ -615,13 +617,39 @@ BEGIN
Str(e1); Str(e1);
e.T := inttype; e.T := inttype;
X86.StFunc(X86.stLENGTH) X86.StFunc(X86.stLENGTH)
|stMIN, stMAX:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
NextCoord(coord);
pExpr(e2);
IntType(e2.T, coord);
Load(e2);
IF (e1.eType = eCONST) & (e2.eType = eCONST) THEN
a := FLOOR(e1.Value);
b := FLOOR(e2.Value);
CASE func OF
|stMIN: a := MIN(a, b)
|stMAX: a := MAX(a, b)
ELSE
END;
e.Value := LONG(FLT(a));
e.eType := eCONST
END;
IF func = stMIN THEN
X86.StFunc(X86.stMIN)
ELSE
X86.StFunc(X86.stMAX)
END;
e.T := inttype
|sysADR: |sysADR:
Assert((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxSTRING) OR (SCAN.tLex = lxCHX), coord, 43); Assert((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxSTRING) OR (SCAN.tLex = lxCHX), coord, 43);
IF SCAN.tLex = lxIDENT THEN IF SCAN.tLex = lxIDENT THEN
Designator(e1); Designator(e1);
Assert((e1.eType = eVAR) OR (e1.eType = ePROC) OR (e1.T = strtype), coord, 43); Assert((e1.eType = eVAR) OR (e1.eType = ePROC) OR (e1.T = strtype), coord, 43);
IF e1.eType = ePROC THEN IF e1.eType = ePROC THEN
X86.PushInt(e1.id.Number) X86.PushInt(e1.id.Number)
END END
ELSE ELSE
pFactor(e1) pFactor(e1)
@ -629,8 +657,8 @@ BEGIN
IF e1.T = strtype THEN IF e1.T = strtype THEN
str := DECL.GetString(e1.Value); str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN IF str.Len = 1 THEN
X86.Drop; X86.Drop;
X86.PushInt(str.Number) X86.PushInt(str.Number)
END END
END; END;
e.T := inttype; e.T := inttype;
@ -645,7 +673,7 @@ BEGIN
e.T := inttype; e.T := inttype;
Assert(T.tType IN TOBJECT, coord, 47); Assert(T.tType IN TOBJECT, coord, 47);
IF T.tType = TPOINTER THEN IF T.tType = TPOINTER THEN
T := T.Base T := T.Base
END; END;
e.Value := LONG(FLT(T.Number)); e.Value := LONG(FLT(T.Number));
X86.PushConst(T.Number) X86.PushConst(T.Number)
@ -676,9 +704,9 @@ VAR sp: INTEGER; stk: ARRAY 100, 2 OF DECL.pTYPE;
VAR Res: BOOLEAN; VAR Res: BOOLEAN;
BEGIN BEGIN
IF (T1.tType = TARRAY) & (T2.tType = TARRAY) & (T1.Len = 0) & (T2.Len = 0) THEN IF (T1.tType = TARRAY) & (T2.tType = TARRAY) & (T1.Len = 0) & (T2.Len = 0) THEN
Res := TypeComp(T1.Base, T2.Base) Res := TypeComp(T1.Base, T2.Base)
ELSE ELSE
Res := ProcTypeComp1(T1, T2) Res := ProcTypeComp1(T1, T2)
END END
RETURN Res RETURN Res
END TypeComp; END TypeComp;
@ -689,8 +717,8 @@ VAR sp: INTEGER; stk: ARRAY 100, 2 OF DECL.pTYPE;
i := 0; i := 0;
res := FALSE; res := FALSE;
WHILE (i < sp) & ~res DO WHILE (i < sp) & ~res DO
res := ((stk[i][0] = T1) & (stk[i][1] = T2)) OR ((stk[i][0] = T2) & (stk[i][1] = T1)); res := ((stk[i][0] = T1) & (stk[i][1] = T2)) OR ((stk[i][0] = T2) & (stk[i][1] = T1));
INC(i) INC(i)
END END
RETURN res RETURN res
END Check; END Check;
@ -703,16 +731,16 @@ VAR sp: INTEGER; stk: ARRAY 100, 2 OF DECL.pTYPE;
Res := TRUE Res := TRUE
ELSE ELSE
IF (T1.tType = TPROC) & (T2.tType = TPROC) & (T1 # T2) THEN IF (T1.tType = TPROC) & (T2.tType = TPROC) & (T1 # T2) THEN
Res := (T1.Call = T2.Call) & (T1.Fields.Count = T2.Fields.Count) & ProcTypeComp1(T1.Base, T2.Base); Res := (T1.Call = T2.Call) & (T1.Fields.Count = T2.Fields.Count) & ProcTypeComp1(T1.Base, T2.Base);
fp := T1.Fields.First(DECL.FIELD); fp := T1.Fields.First(DECL.FIELD);
ft := T2.Fields.First(DECL.FIELD); ft := T2.Fields.First(DECL.FIELD);
WHILE Res & (fp # NIL) DO WHILE Res & (fp # NIL) DO
Res := (fp.ByRef = ft.ByRef) & TypeComp(fp.T, ft.T); Res := (fp.ByRef = ft.ByRef) & TypeComp(fp.T, ft.T);
fp := fp.Next(DECL.FIELD); fp := fp.Next(DECL.FIELD);
ft := ft.Next(DECL.FIELD) ft := ft.Next(DECL.FIELD)
END END
ELSE ELSE
Res := T1 = T2 Res := T1 = T2
END END
END; END;
DEC(sp) DEC(sp)
@ -750,25 +778,25 @@ BEGIN
|TARRAY: |TARRAY:
IF param THEN IF param THEN
IF T.Len = 0 THEN IF T.Len = 0 THEN
IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := TRUE Res := TRUE
ELSE ELSE
Res := ArrComp(e.T, T) Res := ArrComp(e.T, T)
END END
ELSE ELSE
IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := LenString(e.Value) <= T.Len Res := LenString(e.Value) <= T.Len
ELSE ELSE
Res := e.T = T Res := e.T = T
END END
END END
ELSE ELSE
IF T.Len = 0 THEN IF T.Len = 0 THEN
Res := FALSE Res := FALSE
ELSIF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN ELSIF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := LenString(e.Value) <= T.Len Res := LenString(e.Value) <= T.Len
ELSE ELSE
Res := e.T = T Res := e.T = T
END END
END END
|TRECORD: Res := BaseOf(T, e.T) |TRECORD: Res := BaseOf(T, e.T)
@ -789,17 +817,17 @@ BEGIN
CASE T.tType OF CASE T.tType OF
|TINTEGER, TREAL, TLONGREAL, TCHAR, |TINTEGER, TREAL, TLONGREAL, TCHAR,
TSET, TBOOLEAN, TPOINTER, TCARD16: TSET, TBOOLEAN, TPOINTER, TCARD16:
Res := e.T = T Res := e.T = T
|TARRAY: |TARRAY:
IF T.Len > 0 THEN IF T.Len > 0 THEN
Res := e.T = T Res := e.T = T
ELSE ELSE
Res := ArrComp(e.T, T) Res := ArrComp(e.T, T)
END END
|TRECORD: |TRECORD:
Res := BaseOf(T, e.T) Res := BaseOf(T, e.T)
|TPROC: |TPROC:
Res := ProcTypeComp(e.T, T) Res := ProcTypeComp(e.T, T)
ELSE ELSE
END END
ELSE ELSE
@ -826,12 +854,12 @@ BEGIN
END; END;
IF param.ByRef & (e1.T.tType = TRECORD) THEN IF param.ByRef & (e1.T.tType = TRECORD) THEN
IF e1.vparam THEN IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level); X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER) X86.Load(TINTEGER)
ELSIF e1.deref THEN ELSIF e1.deref THEN
X86.DerefType(0) X86.DerefType(0)
ELSE ELSE
X86.PushConst(e1.T.Number) X86.PushConst(e1.T.Number)
END END
END; END;
IF ~param.ByRef & (param.T.tType IN TFLOAT) THEN IF ~param.ByRef & (param.T.tType IN TFLOAT) THEN
@ -840,24 +868,24 @@ BEGIN
IF (e1.T.tType = TSTRING) & (param.T.tType = TARRAY) THEN IF (e1.T.tType = TSTRING) & (param.T.tType = TARRAY) THEN
s := DECL.GetString(e1.Value); s := DECL.GetString(e1.Value);
IF s.Len = 1 THEN IF s.Len = 1 THEN
X86.Mono(s.Number) X86.Mono(s.Number)
END; END;
IF param.T.Len = 0 THEN IF param.T.Len = 0 THEN
A[0] := s.Len + 1; A[0] := s.Len + 1;
X86.OpenArray(A, 1) X86.OpenArray(A, 1)
END END
END; END;
IF (e1.T.tType = TARRAY) & (DECL.Dim(param.T) > DECL.Dim(e1.T)) THEN IF (e1.T.tType = TARRAY) & (DECL.Dim(param.T) > DECL.Dim(e1.T)) THEN
n := DECL.Dim(param.T) - DECL.Dim(e1.T); n := DECL.Dim(param.T) - DECL.Dim(e1.T);
TA := DECL.OpenBase(e1.T); TA := DECL.OpenBase(e1.T);
FOR i := 0 TO n - 1 DO FOR i := 0 TO n - 1 DO
A[i] := TA.Len; A[i] := TA.Len;
TA := TA.Base TA := TA.Base
END; END;
IF DECL.Dim(e1.T) = 0 THEN IF DECL.Dim(e1.T) = 0 THEN
X86.OpenArray(A, n) X86.OpenArray(A, n)
ELSE ELSE
X86.ExtArray(A, n, DECL.Dim(e1.T)) X86.ExtArray(A, n, DECL.Dim(e1.T))
END END
END; END;
param := param.Next(DECL.FIELD); param := param.Next(DECL.FIELD);
@ -881,24 +909,24 @@ BEGIN
Designator(e); Designator(e);
IF e.eType = ePROC THEN IF e.eType = ePROC THEN
IF SCAN.tLex = lxLRound THEN IF SCAN.tLex = lxLRound THEN
Assert2(e.id.T.Base.tType # TVOID, 73); Assert2(e.id.T.Base.tType # TVOID, 73);
Next; Next;
X86.PushCall(begcall); X86.PushCall(begcall);
Call(e.id.T.Fields.First(DECL.FIELD)); Call(e.id.T.Fields.First(DECL.FIELD));
X86.EndCall; X86.EndCall;
e.eType := eEXP; e.eType := eEXP;
e.T := e.id.T.Base; e.T := e.id.T.Base;
IF e.id.Level = 3 THEN IF e.id.Level = 3 THEN
ccall := 0 ccall := 0
ELSIF e.id.Level > DECL.curBlock.Level THEN ELSIF e.id.Level > DECL.curBlock.Level THEN
ccall := 1 ccall := 1
ELSE ELSE
ccall := 2 ccall := 2
END; END;
X86.Call(e.id.Number, TRUE, e.T.tType IN TFLOAT, e.id.T.Call, ccall, e.id.Level - 3, X86.Call(e.id.Number, TRUE, e.T.tType IN TFLOAT, e.id.T.Call, ccall, e.id.Level - 3,
DECL.curBlock.Level - 3, e.id.ParamSize, DECL.curBlock.LocalSize) DECL.curBlock.Level - 3, e.id.ParamSize, DECL.curBlock.LocalSize)
ELSE ELSE
X86.PushInt(e.id.Number) X86.PushInt(e.id.Number)
END END
ELSIF (e.eType = eVAR) & (e.T.tType = TPROC) & (SCAN.tLex = lxLRound) THEN ELSIF (e.eType = eVAR) & (e.T.tType = TPROC) & (SCAN.tLex = lxLRound) THEN
Assert2(e.T.Base.tType # TVOID, 73); Assert2(e.T.Base.tType # TVOID, 73);
@ -934,9 +962,9 @@ BEGIN
e.Value := LONG(FLT(p)); e.Value := LONG(FLT(p));
s := DECL.GetString(e.Value); s := DECL.GetString(e.Value);
IF s.Len = 1 THEN IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0])) X86.PushConst(ORD(s.Str[0]))
ELSE ELSE
X86.PushInt(s.Number) X86.PushInt(s.Number)
END END
ELSE ELSE
str2 := DECL.AddMono(SCAN.vCHX); str2 := DECL.AddMono(SCAN.vCHX);
@ -1037,17 +1065,17 @@ BEGIN
Assert(m # 0, coord, 48); Assert(m # 0, coord, 48);
n := log2(m); n := log2(m);
IF n = -1 THEN IF n = -1 THEN
X86.idivmod(Op = lxMOD) X86.idivmod(Op = lxMOD)
ELSE ELSE
X86.Drop; X86.Drop;
IF Op = lxMOD THEN IF Op = lxMOD THEN
n := ORD(-BITS(LSL(-1, n))); n := ORD(-BITS(LSL(-1, n)));
X86.PushConst(n); X86.PushConst(n);
X86.Set(lxMult) X86.Set(lxMult)
ELSE ELSE
X86.PushConst(n); X86.PushConst(n);
X86.StFunc(X86.stASR) X86.StFunc(X86.stASR)
END END
END END
ELSE ELSE
X86.idivmod(Op = lxMOD) X86.idivmod(Op = lxMOD)
@ -1146,9 +1174,9 @@ BEGIN
IF (uOp = lxMinus) & (e.eType = eCONST) THEN IF (uOp = lxMinus) & (e.eType = eCONST) THEN
CASE e.T.tType OF CASE e.T.tType OF
|TINTEGER: |TINTEGER:
Assert(e.Value # LONG(FLT(SCAN.minINT)), ucoord, DECL.IOVER) Assert(e.Value # LONG(FLT(SCAN.minINT)), ucoord, DECL.IOVER)
|TSET: |TSET:
e.Value := -LONG(FLT(ORD(-BITS(FLOOR(e.Value))))) e.Value := -LONG(FLT(ORD(-BITS(FLOOR(e.Value)))))
ELSE ELSE
END; END;
e.Value := -e.Value e.Value := -e.Value
@ -1189,25 +1217,25 @@ BEGIN
IF Op = lxIS THEN IF Op = lxIS THEN
Assert(e.T.tType IN TOBJECT, coord, 37); Assert(e.T.tType IN TOBJECT, coord, 37);
IF e.T.tType = TRECORD THEN IF e.T.tType = TRECORD THEN
Assert(e.vparam, coord, 37) Assert(e.vparam, coord, 37)
END; END;
Check(lxIDENT); Check(lxIDENT);
Coord(coord2); Coord(coord2);
T := DECL.IdType(coord2); T := DECL.IdType(coord2);
Assert(T # NIL, coord2, 42); Assert(T # NIL, coord2, 42);
IF e.T.tType = TRECORD THEN IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord2, 106) Assert(T.tType = TRECORD, coord2, 106)
ELSE ELSE
Assert(T.tType = TPOINTER, coord2, 107) Assert(T.tType = TPOINTER, coord2, 107)
END; END;
Assert(BaseOf(e.T, T), coord, 37); Assert(BaseOf(e.T, T), coord, 37);
IF e.T.tType = TRECORD THEN IF e.T.tType = TRECORD THEN
X86.Drop; X86.Drop;
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level) X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END; END;
Load(e); Load(e);
IF e.T.tType = TPOINTER THEN IF e.T.tType = TPOINTER THEN
T := T.Base T := T.Base
END; END;
X86.Guard(T.Number, TRUE); X86.Guard(T.Number, TRUE);
e.T := booltype; e.T := booltype;
@ -1228,16 +1256,16 @@ BEGIN
IF ~DECL.Const THEN IF ~DECL.Const THEN
CASE e.T.tType OF CASE e.T.tType OF
|TREAL, TLONGREAL: |TREAL, TLONGREAL:
X86.PushFlt(e.Value) X86.PushFlt(e.Value)
|TINTEGER, TSET, TBOOLEAN, TNIL: |TINTEGER, TSET, TBOOLEAN, TNIL:
X86.PushConst(FLOOR(e.Value)) X86.PushConst(FLOOR(e.Value))
|TSTRING: |TSTRING:
s := DECL.GetString(e.Value); s := DECL.GetString(e.Value);
IF s.Len = 1 THEN IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0])) X86.PushConst(ORD(s.Str[0]))
ELSE ELSE
X86.PushInt(s.Number) X86.PushInt(s.Number)
END END
ELSE ELSE
END END
END END
@ -1468,32 +1496,32 @@ BEGIN
iValue := FLOOR(Value); iValue := FLOOR(Value);
Assert(iValue # 0, coord, 122); Assert(iValue # 0, coord, 122);
IF iValue < 0 THEN IF iValue < 0 THEN
IF proc = stINC THEN IF proc = stINC THEN
proc := stDEC proc := stDEC
ELSE ELSE
proc := stINC proc := stINC
END; END;
iValue := -iValue iValue := -iValue
END; END;
IF iValue # 1 THEN IF iValue # 1 THEN
X86.PushConst(iValue); X86.PushConst(iValue);
IF proc = stDEC THEN IF proc = stDEC THEN
X86.StProc(X86.stDEC) X86.StProc(X86.stDEC)
ELSE ELSE
X86.StProc(X86.stINC) X86.StProc(X86.stINC)
END END
ELSE ELSE
IF proc = stDEC THEN IF proc = stDEC THEN
X86.StProc(X86.stDEC1) X86.StProc(X86.stDEC1)
ELSE ELSE
X86.StProc(X86.stINC1) X86.StProc(X86.stINC1)
END END
END END
ELSE ELSE
IF proc = stDEC THEN IF proc = stDEC THEN
X86.StProc(X86.stDEC1) X86.StProc(X86.stDEC1)
ELSE ELSE
X86.StProc(X86.stINC1) X86.StProc(X86.stINC1)
END END
END END
|stINCL, stEXCL: |stINCL, stEXCL:
@ -1521,8 +1549,8 @@ BEGIN
IF e1.T.tType = TSTRING THEN IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value); str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN IF str.Len = 1 THEN
X86.Mono(str.Number); X86.Mono(str.Number);
X86.StrMono X86.StrMono
END END
END; END;
Str(e1); Str(e1);
@ -1571,18 +1599,18 @@ BEGIN
Assert(e2.T.tType = TINTEGER, coord, 128); Assert(e2.T.tType = TINTEGER, coord, 128);
Assert(~e2.Read, coord, 115); Assert(~e2.Read, coord, 115);
IF e1.T.tType = TLONGREAL THEN IF e1.T.tType = TLONGREAL THEN
X86.StProc(X86.stUNPK) X86.StProc(X86.stUNPK)
ELSE ELSE
X86.StProc(X86.stUNPK1) X86.StProc(X86.stUNPK1)
END END
ELSE ELSE
Expr(e2); Expr(e2);
IntType(e2.T, coord); IntType(e2.T, coord);
Load(e2); Load(e2);
IF e1.T.tType = TLONGREAL THEN IF e1.T.tType = TLONGREAL THEN
X86.StProc(X86.stPACK) X86.StProc(X86.stPACK)
ELSE ELSE
X86.StProc(X86.stPACK1) X86.StProc(X86.stPACK1)
END END
END END
|sysPUT, sysGET: |sysPUT, sysGET:
@ -1606,9 +1634,9 @@ BEGIN
Expr(e2); Expr(e2);
Assert(~(e2.T.tType IN TSTRUCT), coord, 90); Assert(~(e2.T.tType IN TSTRUCT), coord, 90);
IF e2.T.tType = TSTRING THEN IF e2.T.tType = TSTRING THEN
Assert(LenString(e2.Value) = 1, coord, 94) Assert(LenString(e2.Value) = 1, coord, 94)
ELSIF e2.T.tType = TVOID THEN ELSIF e2.T.tType = TVOID THEN
e2.T := inttype e2.T := inttype
END; END;
Load(e2); Load(e2);
X86.Save(e2.T.tType) X86.Save(e2.T.tType)
@ -1636,12 +1664,29 @@ BEGIN
Expr(e1); Expr(e1);
IntType(e1.T, coord); IntType(e1.T, coord);
Load(e1); Load(e1);
|sysCOPY:
begcall := X86.current;
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Check(lxComma);
X86.PushCall(begcall);
X86.Param;
NextCoord(coord);
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Check(lxComma);
X86.EndCall;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
Load(e1);
ELSE ELSE
Assert(FALSE, coord2, 132) Assert(FALSE, coord2, 132)
END; END;
Check(lxRRound); Check(lxRRound);
Next; Next;
IF proc = sysMOVE THEN IF (proc = sysMOVE) OR (proc = sysCOPY) THEN
X86.StProc(X86.sysMOVE) X86.StProc(X86.sysMOVE)
END END
END StProc; END StProc;
@ -1664,21 +1709,21 @@ BEGIN
X86.PushConst(e1.T.Size); X86.PushConst(e1.T.Size);
X86.PushConst(e1.T.Number); X86.PushConst(e1.T.Number);
IF e1.vparam THEN IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level); X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER) X86.Load(TINTEGER)
ELSIF e1.deref THEN ELSIF e1.deref THEN
X86.DerefType(12) X86.DerefType(12)
ELSE ELSE
X86.PushConst(e1.T.Number) X86.PushConst(e1.T.Number)
END END
ELSIF e2.T.tType = TARRAY THEN ELSIF e2.T.tType = TARRAY THEN
X86.PushConst(e2.T.Size) X86.PushConst(e2.T.Size)
ELSIF (e2.T.tType = TSTRING) & (e1.T.tType = TARRAY) THEN ELSIF (e2.T.tType = TSTRING) & (e1.T.tType = TARRAY) THEN
s := DECL.GetString(e2.Value); s := DECL.GetString(e2.Value);
IF s.Len = 1 THEN IF s.Len = 1 THEN
X86.Mono(s.Number) X86.Mono(s.Number)
END; END;
X86.PushConst(UTILS.min(s.Len + 1, e1.T.Len)) X86.PushConst(MIN(s.Len + 1, e1.T.Len))
END; END;
X86.Save(e1.T.tType) X86.Save(e1.T.tType)
ELSIF e1.eType = ePROC THEN ELSIF e1.eType = ePROC THEN
@ -1718,7 +1763,7 @@ BEGIN
Assert(AssComp(e2, e1.T, FALSE), coord, 131); Assert(AssComp(e2, e1.T, FALSE), coord, 131);
Assert(~((e2.eType = ePROC) & (e2.id.Level > 3)), coord, 116); Assert(~((e2.eType = ePROC) & (e2.id.Level > 3)), coord, 116);
IF e2.eType = eVAR THEN IF e2.eType = eVAR THEN
X86.Load(TPROC) X86.Load(TPROC)
END; END;
X86.Save(TPROC) X86.Save(TPROC)
ELSE ELSE
@ -1779,19 +1824,19 @@ VAR SelfName, SelfPath, CName, CExt, FName, Path, StdPath,
PROCEDURE hexdgt(c: CHAR): BOOLEAN; PROCEDURE hexdgt(c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9") OR RETURN ("0" <= c) & (c <= "9") OR
("A" <= c) & (c <= "F") OR ("A" <= c) & (c <= "F") OR
("a" <= c) & (c <= "f") ("a" <= c) & (c <= "f")
END hexdgt; END hexdgt;
PROCEDURE hex(c: CHAR): INTEGER; PROCEDURE hex(c: CHAR): INTEGER;
VAR res: INTEGER; VAR res: INTEGER;
BEGIN BEGIN
IF ("0" <= c) & (c <= "9") THEN IF ("0" <= c) & (c <= "9") THEN
res := ORD(c) - ORD("0") res := ORD(c) - ORD("0")
ELSIF ("A" <= c) & (c <= "F") THEN ELSIF ("A" <= c) & (c <= "F") THEN
res := ORD(c) - ORD("A") + 10 res := ORD(c) - ORD("A") + 10
ELSIF ("a" <= c) & (c <= "f") THEN ELSIF ("a" <= c) & (c <= "f") THEN
res := ORD(c) - ORD("a") + 10 res := ORD(c) - ORD("a") + 10
END END
RETURN res RETURN res
END hex; END hex;

288
programs/develop/oberon07/Source/DECL.ob07
View File

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This file is part of Compiler. This file is part of Compiler.
@ -43,10 +43,10 @@ CONST
stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8; stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8;
stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15; stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15;
stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22; stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22;
stBITS = 23; stLSR = 24; stLENGTH = 25; stBITS = 23; stLSR = 24; stLENGTH = 25; stMIN = 26; stMAX = 27;
sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105; sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; sysCOPY = 109;
TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7; TNIL = 8; TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7; TNIL = 8;
TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14; TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14;
@ -261,25 +261,25 @@ VAR code: INTEGER;
BEGIN BEGIN
IF SCAN.tLex # key THEN IF SCAN.tLex # key THEN
CASE key OF CASE key OF
|lxMODULE: code := 21 |lxMODULE: code := 21
|lxIDENT: code := 22 |lxIDENT: code := 22
|lxSemi: code := 23 |lxSemi: code := 23
|lxEND: code := 24 |lxEND: code := 24
|lxDot: code := 25 |lxDot: code := 25
|lxEQ: code := 35 |lxEQ: code := 35
|lxRRound: code := 38 |lxRRound: code := 38
|lxTO: code := 40 |lxTO: code := 40
|lxOF: code := 41 |lxOF: code := 41
|lxRCurly: code := 51 |lxRCurly: code := 51
|lxLRound: code := 56 |lxLRound: code := 56
|lxComma: code := 61 |lxComma: code := 61
|lxTHEN: code := 98 |lxTHEN: code := 98
|lxRSquare: code := 109 |lxRSquare: code := 109
|lxDO: code := 118 |lxDO: code := 118
|lxUNTIL: code := 119 |lxUNTIL: code := 119
|lxAssign: code := 120 |lxAssign: code := 120
|lxRETURN: code := 124 |lxRETURN: code := 124
|lxColon: code := 157 |lxColon: code := 157
ELSE ELSE
END; END;
Assert2(FALSE, code) Assert2(FALSE, code)
@ -386,37 +386,39 @@ END PushSysType;
PROCEDURE StIdent; PROCEDURE StIdent;
BEGIN BEGIN
Guard; Guard;
PushStProc("ABS", stABS); PushStProc("ABS", stABS);
PushStProc("ASR", stASR); PushStProc("ASR", stASR);
PushStProc("ASSERT", stASSERT); PushStProc("ASSERT", stASSERT);
PushStType("BOOLEAN", TBOOLEAN); PushStType("BOOLEAN", TBOOLEAN);
PushStType("CHAR", TCHAR); PushStType("CHAR", TCHAR);
PushStProc("CHR", stCHR); PushStProc("CHR", stCHR);
PushStProc("COPY", stCOPY); PushStProc("COPY", stCOPY);
PushStProc("DEC", stDEC); PushStProc("DEC", stDEC);
PushStProc("DISPOSE", stDISPOSE); PushStProc("DISPOSE", stDISPOSE);
PushStProc("EXCL", stEXCL); PushStProc("EXCL", stEXCL);
PushStProc("FLOOR", stFLOOR); PushStProc("FLOOR", stFLOOR);
PushStProc("FLT", stFLT); PushStProc("FLT", stFLT);
PushStProc("INC", stINC); PushStProc("INC", stINC);
PushStProc("INCL", stINCL); PushStProc("INCL", stINCL);
PushStType("INTEGER", TINTEGER); PushStType("INTEGER", TINTEGER);
PushStProc("LEN", stLEN); PushStProc("LEN", stLEN);
PushStProc("LSL", stLSL); PushStProc("LSL", stLSL);
PushStProc("LONG", stLONG); PushStProc("LONG", stLONG);
PushStType("LONGREAL", TLONGREAL); PushStType("LONGREAL", TLONGREAL);
PushStProc("NEW", stNEW); PushStProc("NEW", stNEW);
PushStProc("ODD", stODD); PushStProc("ODD", stODD);
PushStProc("ORD", stORD); PushStProc("ORD", stORD);
PushStProc("PACK", stPACK); PushStProc("PACK", stPACK);
PushStType("REAL", TREAL); PushStType("REAL", TREAL);
PushStProc("ROR", stROR); PushStProc("ROR", stROR);
PushStType("SET", TSET); PushStType("SET", TSET);
PushStProc("SHORT", stSHORT); PushStProc("SHORT", stSHORT);
PushStProc("UNPK", stUNPK); PushStProc("UNPK", stUNPK);
PushStProc("BITS", stBITS); PushStProc("BITS", stBITS);
PushStProc("LSR", stLSR); PushStProc("LSR", stLSR);
PushStProc("LENGTH", stLENGTH); PushStProc("LENGTH", stLENGTH);
PushStProc("MIN", stMIN);
PushStProc("MAX", stMAX);
Guard Guard
END StIdent; END StIdent;
@ -428,9 +430,9 @@ BEGIN
WHILE (cur # NIL) & (cur.iType # IDGUARD) DO WHILE (cur # NIL) & (cur.iType # IDGUARD) DO
IF cur.Name = Name THEN IF cur.Name = Name THEN
IF (Unit # unit) & ~cur.Export THEN IF (Unit # unit) & ~cur.Export THEN
res := NIL res := NIL
ELSE ELSE
res := cur res := cur
END; END;
cur := NIL cur := NIL
ELSE ELSE
@ -533,9 +535,9 @@ BEGIN
Res := Arith(a, b, Ta, Op, coord) Res := Arith(a, b, Ta, Op, coord)
ELSIF Ta.tType = TSET THEN ELSIF Ta.tType = TSET THEN
CASE Op OF CASE Op OF
|lxPlus: Res := LONG(FLT(ORD(BITS(ai) + BITS(bi)))) |lxPlus: Res := LONG(FLT(ORD(BITS(ai) + BITS(bi))))
|lxMinus: Res := LONG(FLT(ORD(BITS(ai) - BITS(bi)))) |lxMinus: Res := LONG(FLT(ORD(BITS(ai) - BITS(bi))))
|lxMult: Res := LONG(FLT(ORD(BITS(ai) * BITS(bi)))) |lxMult: Res := LONG(FLT(ORD(BITS(ai) * BITS(bi))))
|lxSlash: Res := LONG(FLT(ORD(BITS(ai) / BITS(bi)))) |lxSlash: Res := LONG(FLT(ORD(BITS(ai) / BITS(bi))))
ELSE ELSE
END END
@ -636,23 +638,23 @@ BEGIN
NamePtrBase := Name; NamePtrBase := Name;
id := GetQIdent(Unit, Name); id := GetQIdent(Unit, Name);
IF Unit # unit THEN IF Unit # unit THEN
Assert2(id # NIL, 42); Assert2(id # NIL, 42);
Assert2(id.iType = IDTYPE, 77); Assert2(id.iType = IDTYPE, 77);
Coord(coord); Coord(coord);
Next; Next;
Res := id.T Res := id.T
ELSE ELSE
IF id = NIL THEN IF id = NIL THEN
Assert2((unit.Level = 3) & unit.typedecl, 42); Assert2((unit.Level = 3) & unit.typedecl, 42);
Coord(coord); Coord(coord);
Next; Next;
Res := NIL Res := NIL
ELSE ELSE
Assert2(id.iType = IDTYPE, 77); Assert2(id.iType = IDTYPE, 77);
Coord(coord); Coord(coord);
Next; Next;
Res := id.T Res := id.T
END END
END END
ELSE ELSE
Assert2(FALSE, 77) Assert2(FALSE, 77)
@ -689,21 +691,21 @@ BEGIN
cur.T := Tf; cur.T := Tf;
IF Rec THEN IF Rec THEN
IF Tf.Align > Tr.Align THEN IF Tf.Align > Tr.Align THEN
Tr.Align := Tf.Align Tr.Align := Tf.Align
END; END;
IF Tr.Rec = record THEN IF Tr.Rec = record THEN
cur.Offset := FieldOffset(Tf.Align, Tr.Size); cur.Offset := FieldOffset(Tf.Align, Tr.Size);
Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83); Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
Tr.Size := cur.Offset + Tf.Size Tr.Size := cur.Offset + Tf.Size
ELSIF Tr.Rec = noalign THEN ELSIF Tr.Rec = noalign THEN
cur.Offset := FieldOffset(1, Tr.Size); cur.Offset := FieldOffset(1, Tr.Size);
Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83); Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
Tr.Size := cur.Offset + Tf.Size Tr.Size := cur.Offset + Tf.Size
ELSIF Tr.Rec = union THEN ELSIF Tr.Rec = union THEN
IF Tf.Size > Tr.Size THEN IF Tf.Size > Tr.Size THEN
Tr.Size := Tf.Size Tr.Size := Tf.Size
END; END;
cur.Offset := 0 cur.Offset := 0
END END
ELSE ELSE
Tr.Len := Tr.Len + 4 * (ORD((Tf.tType = TRECORD) & cur.ByRef) + Dim(Tf) + ORD((Tf.tType = TLONGREAL) & ~cur.ByRef) + 1) Tr.Len := Tr.Len + 4 * (ORD((Tf.tType = TRECORD) & cur.ByRef) + Dim(Tf) + ORD((Tf.tType = TLONGREAL) & ~cur.ByRef) + 1)
@ -734,7 +736,7 @@ BEGIN
field := GetField(T, Name); field := GetField(T, Name);
IF field # NIL THEN IF field # NIL THEN
IF (field.Unit = unit) OR field.Export THEN IF (field.Unit = unit) OR field.Export THEN
res := FALSE res := FALSE
END END
END; END;
T := T.Base T := T.Base
@ -744,7 +746,7 @@ END Unique;
PROCEDURE notrecurs(id: BOOLEAN; T: pTYPE): BOOLEAN; PROCEDURE notrecurs(id: BOOLEAN; T: pTYPE): BOOLEAN;
RETURN ~(id & (unit.Idents.Last(IDENT).iType = IDTYPE) & (unit.Idents.Last(IDENT).T = T) & RETURN ~(id & (unit.Idents.Last(IDENT).iType = IDTYPE) & (unit.Idents.Last(IDENT).T = T) &
(T.tType IN TSTRUCT)) (T.tType IN TSTRUCT))
END notrecurs; END notrecurs;
PROCEDURE ReadFields(T: pTYPE); PROCEDURE ReadFields(T: pTYPE);
@ -776,9 +778,9 @@ BEGIN
Assert(notrecurs(id_T, Tf), coord, 96); Assert(notrecurs(id_T, Tf), coord, 96);
SetFields(T, Tf, TRUE); SetFields(T, Tf, TRUE);
IF SCAN.tLex = lxSemi THEN IF SCAN.tLex = lxSemi THEN
NextCheck(lxIDENT) NextCheck(lxIDENT)
ELSE ELSE
Assert2(SCAN.tLex = lxEND, 86) Assert2(SCAN.tLex = lxEND, 86)
END END
ELSE ELSE
Assert2(FALSE, 85) Assert2(FALSE, 85)
@ -819,9 +821,9 @@ BEGIN
ProgSize := ProgSize + UTILS.Align(ProgSize) ProgSize := ProgSize + UTILS.Align(ProgSize)
ELSE ELSE
IF cur.VarKind = 0 THEN IF cur.VarKind = 0 THEN
cur.Offset := curBlock.ParamSize - curBlock.VarSize - n cur.Offset := curBlock.ParamSize - curBlock.VarSize - n
ELSE ELSE
cur.Offset := curBlock.VarSize - 8 + 4 * (cur.Level + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD))) cur.Offset := curBlock.VarSize - 8 + 4 * (cur.Level + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
END END
END; END;
Assert2(curBlock.VarSize <= SCAN.maxINT - n, 93); Assert2(curBlock.VarSize <= SCAN.maxINT - n, 93);
@ -901,9 +903,9 @@ BEGIN
INC(curBlock.ParamCount); INC(curBlock.ParamCount);
fp := unit.Idents.Last(IDENT); fp := unit.Idents.Last(IDENT);
IF ByRef THEN IF ByRef THEN
fp.VarKind := paramvar fp.VarKind := paramvar
ELSE ELSE
fp.VarKind := param fp.VarKind := param
END END
END; END;
Next; Next;
@ -915,7 +917,7 @@ BEGIN
Assert(Dim(Tf) <= X86.ADIM, coord, 110); Assert(Dim(Tf) <= X86.ADIM, coord, 110);
SetFields(T, Tf, FALSE); SetFields(T, Tf, FALSE);
IF proc THEN IF proc THEN
SetVars(Tf) SetVars(Tf)
END; END;
cont := FALSE cont := FALSE
ELSE ELSE
@ -932,9 +934,9 @@ BEGIN
REPEAT REPEAT
Section(T); Section(T);
IF SCAN.tLex = lxSemi THEN IF SCAN.tLex = lxSemi THEN
Next Next
ELSE ELSE
break := TRUE break := TRUE
END END
UNTIL break UNTIL break
END END
@ -1054,6 +1056,9 @@ BEGIN
Check(lxIDENT); Check(lxIDENT);
nov.Base := IdType(coord); nov.Base := IdType(coord);
Assert(nov.Base # NIL, coord, 42); Assert(nov.Base # NIL, coord, 42);
IF (nov.Base.tType = TPOINTER) & (nov.Base.Base.tType = TRECORD) THEN
nov.Base := nov.Base.Base
END;
Assert(nov.Base.tType = TRECORD, coord, 80); Assert(nov.Base.tType = TRECORD, coord, 80);
Assert(notrecurs(TRUE, nov.Base), coord, 96); Assert(notrecurs(TRUE, nov.Base), coord, 96);
nov.Size := nov.Base.Size; nov.Size := nov.Base.Size;
@ -1194,10 +1199,16 @@ BEGIN
last := unit.Idents.Last(IDENT); last := unit.Idents.Last(IDENT);
Check(lxEQ); Check(lxEQ);
Next; Next;
NEW(NewType);
MemErr(NewType = NIL); IF SCAN.tLex = lxIDENT THEN
last.T := NewType; last.T := ParseType(coord)
T := StructType(FALSE, NewType); ELSE
NEW(NewType);
MemErr(NewType = NIL);
last.T := NewType;
T := StructType(FALSE, NewType)
END;
Check(lxSemi); Check(lxSemi);
Next Next
END END
@ -1210,16 +1221,16 @@ BEGIN
IdentDef; IdentDef;
PushIdent(Name, coord, IDVAR, NIL, NIL, Export, 0); PushIdent(Name, coord, IDVAR, NIL, NIL, Export, 0);
IF SCAN.tLex = lxComma THEN IF SCAN.tLex = lxComma THEN
NextCheck(lxIDENT) NextCheck(lxIDENT)
ELSIF SCAN.tLex = lxColon THEN ELSIF SCAN.tLex = lxColon THEN
NextCoord(coord); NextCoord(coord);
T := ParseType(coord); T := ParseType(coord);
Assert(T # NIL, coord, 42); Assert(T # NIL, coord, 42);
SetVars(T); SetVars(T);
Check(lxSemi); Check(lxSemi);
Next Next
ELSE ELSE
Assert2(FALSE, 85) Assert2(FALSE, 85)
END END
END END
END; END;
@ -1237,8 +1248,8 @@ BEGIN
id.Proc := curproc; id.Proc := curproc;
IF id.Export & main THEN IF id.Export & main THEN
IF Platform IN {1, 6} THEN IF Platform IN {1, 6} THEN
curproc.used := TRUE; curproc.used := TRUE;
Assert((Name # SCAN._START) & (Name # SCAN._version), coord, 133) Assert((Name # SCAN._START) & (Name # SCAN._version), coord, 133)
END; END;
X86.ProcExport(id.Number, Name, X86.NewLabel()) X86.ProcExport(id.Number, Name, X86.NewLabel())
END; END;
@ -1266,7 +1277,7 @@ BEGIN
Expr(e); Expr(e);
Assert(AssComp(e, curBlock.T.Base, FALSE), coord, 125); Assert(AssComp(e, curBlock.T.Base, FALSE), coord, 125);
IF e.eType = eVAR THEN IF e.eType = eVAR THEN
X86.Load(e.T.tType) X86.Load(e.T.tType)
END END
ELSE ELSE
Assert2(SCAN.tLex # lxRETURN, 123) Assert2(SCAN.tLex # lxRETURN, 123)
@ -1335,12 +1346,12 @@ VAR cond: INTEGER; coord, namecoord: SCAN.TCoord;
SCAN.Backup(unit.scanner); SCAN.Backup(unit.scanner);
COPY(name.Name, FName); COPY(name.Name, FName);
IF ~((~self.Std & pReadModule(Path, FName, UTILS.Ext)) OR pReadModule(Std, FName, UTILS.Ext)) THEN IF ~((~self.Std & pReadModule(Path, FName, UTILS.Ext)) OR pReadModule(Std, FName, UTILS.Ext)) THEN
IF FName = "SYSTEM" THEN IF FName = "SYSTEM" THEN
unit := sys; unit := sys;
self.sys := TRUE self.sys := TRUE
ELSE ELSE
Assert(FALSE, namecoord, 32) Assert(FALSE, namecoord, 32)
END END
END; END;
SCAN.Recover(self.scanner); SCAN.Recover(self.scanner);
u := unit; u := unit;
@ -1363,28 +1374,28 @@ BEGIN
Next; Next;
CASE cond OF CASE cond OF
|0: Check(lxIDENT); |0: Check(lxIDENT);
name := SCAN.id; name := SCAN.id;
Coord(coord); Coord(coord);
Coord(namecoord); Coord(namecoord);
alias := name; alias := name;
cond := 1 cond := 1
|1: CASE SCAN.tLex OF |1: CASE SCAN.tLex OF
|lxComma: AddUnit(0) |lxComma: AddUnit(0)
|lxSemi: AddUnit(4); Next |lxSemi: AddUnit(4); Next
|lxAssign: cond := 2 |lxAssign: cond := 2
ELSE ELSE
Assert2(FALSE, 28) Assert2(FALSE, 28)
END END
|2: Check(lxIDENT); |2: Check(lxIDENT);
name := SCAN.id; name := SCAN.id;
Coord(namecoord); Coord(namecoord);
cond := 3 cond := 3
|3: CASE SCAN.tLex OF |3: CASE SCAN.tLex OF
|lxComma: AddUnit(0) |lxComma: AddUnit(0)
|lxSemi: AddUnit(4); Next |lxSemi: AddUnit(4); Next
ELSE ELSE
Assert2(FALSE, 29) Assert2(FALSE, 29)
END END
ELSE ELSE
END END
END END
@ -1409,14 +1420,15 @@ VAR temp: UNIT;
BEGIN BEGIN
temp := unit; temp := unit;
Header(SCAN.AddNode("SYSTEM")); Header(SCAN.AddNode("SYSTEM"));
PushSysProc("ADR", sysADR); PushSysProc("ADR", sysADR);
PushSysProc("SIZE", sysSIZE); PushSysProc("SIZE", sysSIZE);
PushSysProc("TYPEID", sysTYPEID); PushSysProc("TYPEID", sysTYPEID);
PushSysProc("GET", sysGET); PushSysProc("GET", sysGET);
PushSysProc("PUT", sysPUT); PushSysProc("PUT", sysPUT);
PushSysProc("CODE", sysCODE); PushSysProc("CODE", sysCODE);
PushSysProc("MOVE", sysMOVE); PushSysProc("MOVE", sysMOVE);
PushSysProc("INF", sysINF); PushSysProc("COPY", sysCOPY);
PushSysProc("INF", sysINF);
PushSysType("CARD16", TCARD16); PushSysType("CARD16", TCARD16);
sys := unit; sys := unit;
unit := temp unit := temp
@ -1531,7 +1543,7 @@ VAR cur: Proc;
WHILE cur # NIL DO WHILE cur # NIL DO
p := cur.Proc(Proc); p := cur.Proc(Proc);
IF ~p.used THEN IF ~p.used THEN
ProcHandling(p) ProcHandling(p)
END; END;
cur := cur.Next(IDENT) cur := cur.Next(IDENT)
END; END;

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

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This file is part of Compiler. This file is part of Compiler.
@ -200,7 +200,7 @@ BEGIN
| 77: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ⨯ " | 77: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ⨯ "
| 78: str := "¤«¨­  ⨯ -¬ áᨢ  ¤®«¦­  ¡ëâì ¡®«ìè¥ ­ã«ï" | 78: str := "¤«¨­  ⨯ -¬ áᨢ  ¤®«¦­  ¡ëâì ¡®«ìè¥ ­ã«ï"
| 79: str := "®¦¨¤ «®áì 'OF' ¨«¨ ','" | 79: str := "®¦¨¤ «®áì 'OF' ¨«¨ ','"
| 80: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨" | 80: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨ ¨«¨ ⨯ -㪠§ â¥«ï"
| 81: str := "¡ §®¢ë© ⨯ ⨯ -㪠§ â¥«ï ¤®«¦¥­ ¡ëâì § ¯¨áìî" | 81: str := "¡ §®¢ë© ⨯ ⨯ -㪠§ â¥«ï ¤®«¦¥­ ¡ëâì § ¯¨áìî"
| 82: str := "⨯ १ã«ìâ â  ¯à®æ¥¤ãàë ­¥ ¬®¦¥â ¡ëâì § ¯¨áìî ¨«¨ ¬ áᨢ®¬" | 82: str := "⨯ १ã«ìâ â  ¯à®æ¥¤ãàë ­¥ ¬®¦¥â ¡ëâì § ¯¨áìî ¨«¨ ¬ áᨢ®¬"
| 83: str := "à §¬¥à ⨯  ᫨誮¬ ¢¥«¨ª" | 83: str := "à §¬¥à ⨯  ᫨誮¬ ¢¥«¨ª"

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

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This file is part of Compiler. This file is part of Compiler.
@ -28,7 +28,7 @@ CONST
Ext* = ".ob07"; Ext* = ".ob07";
MAX_PATH = 1024; MAX_PATH = 1024;
MAX_PARAM = 1024; MAX_PARAM = 1024;
Date* = 1451606400; (* 2016-01-01 *) Date* = 1509580800; (* 2017-11-02 *)
TYPE TYPE
@ -53,7 +53,7 @@ TYPE
VAR VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER; Params: ARRAY MAX_PARAM, 2 OF INTEGER;
ParamCount*, Line*, Unit*: INTEGER; ParamCount*, Line*, Unit*: INTEGER;
FileName: STRING; FileName: STRING;
PROCEDURE SetFile*(F: STRING); PROCEDURE SetFile*(F: STRING);
@ -113,8 +113,8 @@ BEGIN
WHILE (j < len) & (i <= Params[n, 1]) DO WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i); c := GetChar(i);
IF c # 22X THEN IF c # 22X THEN
str[j] := c; str[j] := c;
INC(j) INC(j)
END; END;
INC(i) INC(i)
END END
@ -199,14 +199,6 @@ BEGIN
Line := newLine Line := newLine
END UnitLine; END UnitLine;
PROCEDURE min*(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END min;
PROCEDURE Align*(n: INTEGER): INTEGER; PROCEDURE Align*(n: INTEGER): INTEGER;
RETURN (4 - n MOD 4) MOD 4 RETURN (4 - n MOD 4) MOD 4
END Align; END Align;
@ -333,7 +325,7 @@ BEGIN
END; END;
Path[i + 1] := 0X Path[i + 1] := 0X
END Split; END Split;
PROCEDURE LinuxParam; PROCEDURE LinuxParam;
VAR p, i, str: INTEGER; c: CHAR; VAR p, i, str: INTEGER; c: CHAR;
BEGIN BEGIN
@ -350,7 +342,7 @@ BEGIN
Params[i, 1] := str - 1 Params[i, 1] := str - 1
END; END;
DEC(ParamCount) DEC(ParamCount)
END LinuxParam; END LinuxParam;
PROCEDURE Time*; PROCEDURE Time*;
VAR sec, dsec: INTEGER; VAR sec, dsec: INTEGER;

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

@ -1,5 +1,5 @@
(* (*
Copyright 2016 Anton Krotov Copyright 2016, 2017 Anton Krotov
This file is part of Compiler. This file is part of Compiler.
@ -36,7 +36,7 @@ CONST
stDEC* = 14; stINCL* = 15; stEXCL* = 16; stCOPY* = 17; stNEW* = 18; stASSERT* = 19; stDEC* = 14; stINCL* = 15; stEXCL* = 16; stCOPY* = 17; stNEW* = 18; stASSERT* = 19;
stPACK* = 20; stUNPK* = 21; stDISPOSE* = 22; stFABS* = 23; stINC1* = 24; stPACK* = 20; stUNPK* = 21; stDISPOSE* = 22; stFABS* = 23; stINC1* = 24;
stDEC1* = 25; stASSERT1* = 26; stUNPK1* = 27; stPACK1* = 28; stLSR* = 29; stDEC1* = 25; stASSERT1* = 26; stUNPK1* = 27; stPACK1* = 28; stLSR* = 29;
stLENGTH* = 30; stLENGTH* = 30; stMIN* = 31; stMAX* = 32;
sysMOVE* = 108; sysMOVE* = 108;
@ -1232,7 +1232,9 @@ BEGIN
|stASR: PopECX; OutCode("58D3F8"); PushEAX |stASR: PopECX; OutCode("58D3F8"); PushEAX
|stLSL: PopECX; OutCode("58D3E0"); PushEAX |stLSL: PopECX; OutCode("58D3E0"); PushEAX
|stLSR: PopECX; OutCode("58D3E8"); PushEAX |stLSR: PopECX; OutCode("58D3E8"); PushEAX
|stORD: PopEDX; OutCode("85D274036A015A"); PushEDX |stORD: PopEDX; OutCode("85D274036A015A"); PushEDX;
|stMIN: PopEDX; OutCode("3914247E025852");
|stMAX: PopEDX; OutCode("3B14247E025852");
|stLENGTH: CallRTL(_length); PushEAX |stLENGTH: CallRTL(_length); PushEAX
ELSE ELSE
END END
@ -1269,12 +1271,12 @@ BEGIN
|TCHAR, TBOOLEAN: |TCHAR, TBOOLEAN:
IF lastcmd.tcmd = ECMD THEN IF lastcmd.tcmd = ECMD THEN
del; del;
OutCode("33D28A"); OutCode("0FB6");
IntByte("55", "95", offset); IntByte("55", "95", offset);
PushEDX PushEDX
ELSE ELSE
PopEDX; PopEDX;
OutCode("33C98A0A"); OutCode("0FB60A");
PushECX PushECX
END END
|TLONGREAL: |TLONGREAL: