Subversion Repositories Kolibri OS

Compare Revisions

No changes between revisions

Regard whitespace Rev 7597 → Rev 7209

/programs/develop/oberon07/Compiler.kex
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
/programs/develop/oberon07/Docs/Oberon07.Report_2016_05_03.pdf
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property
/programs/develop/oberon07/Docs/KOSLib1251.txt
File deleted
\ No newline at end of file
/programs/develop/oberon07/Docs/About1251.txt
1,73 → 1,53
Êîìïèëÿòîð ÿçûêà ïðîãðàììèðîâàíèÿ Oberon-07/16 äëÿ i486
Êîìïèëÿòîð ÿçûêà ïðîãðàììèðîâàíèÿ Oberon-07/11 äëÿ i386
Windows/Linux/KolibriOS.
------------------------------------------------------------------------------
 
Ïàðàìåòðû êîìàíäíîé ñòðîêè
Ñîñòàâ ïðîãðàììû
 
Âõîä - òåêñòîâûå ôàéëû ìîäóëåé ñ ðàñøèðåíèåì ".ob07", êîäèðîâêà ANSI èëè
UTF-8 ñ BOM-ñèãíàòóðîé.
Âûõîä - èñïîíÿåìûé ôàéë ôîðìàòà PE32, ELF èëè MENUET01/MSCOFF.
1. Compiler.kex (KolibriOS) - èñïîëíÿåìûé ôàéë êîìïèëÿòîðà.
Âõîä - òåêñòîâûå ôàéëû ìîäóëåé ñ ðàñøèðåíèåì ".ob07", êîäèðîâêà ANSI
èëè UTF-8 ñ BOM-ñèãíàòóðîé.
Âûõîä - èñïîëíÿåìûé ôàéë ôîðìàòà PE, ELF èëè MENUET01/MS COFF.
Ïàðàìåòðû:
1) èìÿ ãëàâíîãî ìîäóëÿ
2) èìÿ ðåçóëüòèðóþùåãî ôàéëà
3) òèï ïðèëîæåíèÿ è ïëàòôîðìà
"console" - Windows console
2) òèï ïðèëîæåíèÿ è ïëàòôîðìà
"con" - Windows console
"gui" - Windows GUI
"dll" - Windows DLL
"elf" - Linux
"kos" - KolibriOS
"obj" - KolibriOS DLL
"elfexe" - Linux ELF-EXEC
4) íåîáÿçàòåëüíûå ïàðàìåòðû-êëþ÷è
-stk <size> ðàçìåð ñòýêà â ìåãàáàéòàõ (ïî óìîë÷àíèþ 2 Ìá)
-base <address> àäðåñ çàãðóçêè èñïîëíÿåìîãî ôàéëà â êèëîáàéòàõ
-ver <major.minor> âåðñèÿ ïðîãðàììû (òîëüêî äëÿ obj)
-nochk <"ptibcwra"> îòêëþ÷èòü ïðîâåðêè ïðè âûïîëíåíèè (ñì. íèæå)
 
ïàðàìåòð -nochk çàäàåòñÿ â âèäå ñòðîêè èç ñèìâîëîâ:
"p" - óêàçàòåëè
"t" - òèïû
"i" - èíäåêñû
"b" - íåÿâíîå ïðèâåäåíèå INTEGER ê BYTE
"c" - äèàïàçîí àðãóìåíòà ôóíêöèè CHR
"w" - äèàïàçîí àðãóìåíòà ôóíêöèè WCHR
"r" - ýêâèâàëåíòíî "bcw"
"a" - âñå ïðîâåðêè
 
Ïîðÿäîê ñèìâîëîâ ìîæåò áûòü ëþáûì. Íàëè÷èå â ñòðîêå òîãî èëè èíîãî
ñèìâîëà îòêëþ÷àåò ñîîòâåòñòâóþùóþ ïðîâåðêó.
 
Íàïðèìåð: -nochk it - îòêëþ÷èòü ïðîâåðêó èíäåêñîâ è îõðàíó òèïà.
-nochk a - îòêëþ÷èòü âñå îòêëþ÷àåìûå ïðîâåðêè.
 
"kem" - KolibriOS ñ àäðåñîì çàãðóçêè 0x10000 äëÿ âîçìîæíîãî
èñïîëíåíèÿ â ýìóëÿòîðå
3) ðàçìåð ñòýêà â ìåãàáàéòàõ, íåîáÿçàòåëüíûé ïàðàìåòð, ïî óìîë÷àíèþ -
1 Ìá, äëÿ ELF èãíîðèðóåòñÿ. Åñëè 2-é ïàðàìåòð = "obj" (KolibriOS DLL),
òî 3-é ïàðàìåòð çàäàåòñÿ øåñòíàäöàòèðè÷íûì ÷èñëîì
(0x00000001 .. 0xffffffff) è îïðåäåëÿåò âåðñèþ ïðîãðàììû,
ïî óìîë÷àíèþ - 0x00010000 (v1.0).
Íàïðèìåð:
"C:\oberon-07\example.ob07" con 1
"C:\oberon-07\example.ob07" obj 0x00020005 (* v2.5 *)
 ñëó÷àå óñïåøíîé êîìïèëÿöèè, êîìïèëÿòîð ïåðåäàåò êîä çàâåðøåíèÿ 0,
èíà÷å 1. Ïðè ðàáîòå êîìïèëÿòîðà â KolibriOS, êîä çàâåðøåíèÿ íå
ïåðåäàåòñÿ. Ñîîáùåíèÿ êîìïèëÿòîðà âûâîäÿòñÿ íà êîíñîëü (Windows,
KolibriOS), â òåðìèíàë (Linux).
2. Ïàïêà Lib - áèáëèîòåêà ìîäóëåé
 
Compiler.exe "C:\example.ob07" "C:\example.exe" console -stk 1
Compiler.exe "C:\example.ob07" "C:\example.dll" dll
Compiler.exe "C:\example.ob07" "C:\example.exe" gui -stk 4
Compiler.exe "C:\example.ob07" "C:\example.exe" console -nochk pti
Compiler.kex "/tmp0/1/example.ob07" "/tmp0/1/example.kex" kos -stk 2
Compiler.kex "/tmp0/1/example.ob07" "/tmp0/1/example.obj" obj -ver 2.7
Compiler.exe "C:\example.ob07" "C:\example" elfexe
 
 ñëó÷àå óñïåøíîé êîìïèëÿöèè, êîìïèëÿòîð ïåðåäàåò êîä çàâåðøåíèÿ 0, èíà÷å 1.
Ïðè ðàáîòå êîìïèëÿòîðà â KolibriOS, êîä çàâåðøåíèÿ íå ïåðåäàåòñÿ.
 
------------------------------------------------------------------------------
Îòëè÷èÿ îò îðèãèíàëà
 
1. Ðàñøèðåí ïñåâäîìîäóëü SYSTEM
2. Â èäåíòèôèêàòîðàõ äîïóñêàåòñÿ ñèìâîë "_"
2. Ðàçðåøåí ñèìâîë "_" â èäåíòèôèêàòîðàõ
3. Äîáàâëåíû ñèñòåìíûå ôëàãè
4. Óñîâåðøåíñòâîâàí îïåðàòîð CASE (äîáàâëåíû êîíñòàíòíûå âûðàæåíèÿ â
ìåòêàõ âàðèàíòîâ è íåîáÿçàòåëüíàÿ âåòêà ELSE)
4. Îïåðàòîð CASE ðåàëèçîâàí â ñîîòâåòñòâèè ñ ñèíòàêñèñîì è ñåìàíòèêîé
äàííîãî îïåðàòîðà â ÿçûêå Oberon (Revision 1.10.90)
5. Ðàñøèðåí íàáîð ñòàíäàðòíûõ ïðîöåäóð
6. Ñåìàíòèêà îõðàíû/ïðîâåðêè òèïà óòî÷íåíà äëÿ íóëåâîãî óêàçàòåëÿ
7. Ñåìàíòèêà DIV è MOD óòî÷íåíà äëÿ îòðèöàòåëüíûõ ÷èñåë
8. Äîáàâëåíû îäíîñòðî÷íûå êîììåíòàðèè (íà÷èíàþòñÿ ñ ïàðû ñèìâîëîâ "//")
9. Ðàçðåøåíî íàñëåäîâàíèå îò òèïà-óêàçàòåëÿ
10. Äîáàâëåí ñèíòàêñèñ äëÿ èìïîðòà ïðîöåäóð èç âíåøíèõ áèáëèîòåê
11. "Ñòðîêè" ìîæíî çàêëþ÷àòü òàêæå â îäèíî÷íûå êàâû÷êè: 'ñòðîêà'
12. Äîáàâëåí òèï WCHAR
9. Ðàçðåøåí ýêñïîðò ïåðåìåííûõ òèïîâ ARRAY è RECORD (òîëüêî äëÿ ÷òåíèÿ)
10. Ðàçðåøåíî íàñëåäîâàíèå îò òèïà-óêàçàòåëÿ
11. Äîáàâëåíû ïñåâäîíèìû òèïîâ (TYPE A = B)
 
------------------------------------------------------------------------------
Îñîáåííîñòè ðåàëèçàöèè
77,36 → 57,22
Òèï Äèàïàçîí çíà÷åíèé Ðàçìåð, áàéò
 
INTEGER -2147483648 .. 2147483647 4
REAL 4.94E-324 .. 1.70E+308 8
REAL 1.40E-45 .. 3.34E+38 4
LONGREAL 4.94E-324 .. 1.70E+308 8
CHAR ñèìâîë ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET ìíîæåñòâî èç öåëûõ ÷èñåë {0 .. 31} 4
BYTE 0 .. 255 1
WCHAR ñèìâîë þíèêîäà (0X .. 0FFFFX) 2
 
2. Ìàêñèìàëüíàÿ äëèíà èäåíòèôèêàòîðîâ - 1024 ñèìâîëîâ
3. Ìàêñèìàëüíàÿ äëèíà ñòðîêîâûõ êîíñòàíò - 1024 ñèìâîëîâ (UTF-8)
4. Ìàêñèìàëüíàÿ ðàçìåðíîñòü îòêðûòûõ ìàññèâîâ - 5
5. Ïðîöåäóðà NEW çàïîëíÿåò íóëÿìè âûäåëåííûé áëîê ïàìÿòè
6. Ãëîáàëüíûå è ëîêàëüíûå ïåðåìåííûå èíèöèàëèçèðóþòñÿ íóëÿìè
7.  îòëè÷èå îò ìíîãèõ Oberon-ðåàëèçàöèé, ñáîðùèê ìóñîðà è äèíàìè÷åñêàÿ
2. Ìàêñèìàëüíàÿ äëèíà èäåíòèôèêàòîðîâ - 255 ñèìâîëîâ
3. Ìàêñèìàëüíàÿ äëèíà ñòðîêîâûõ êîíñòàíò - 255 ñèìâîëîâ
4. Ìàêñèìàëüíàÿ äëèíà ñòðîê èñõîäíîãî êîäà - 511 ñèìâîëîâ
5. Ìàêñèìàëüíàÿ ðàçìåðíîñòü îòêðûòûõ ìàññèâîâ - 5
6. Ìàêñèìàëüíîå êîëè÷åñòâî îáúÿâëåííûõ òèïîâ-çàïèñåé - 2047
7. Ïðîöåäóðà NEW çàïîëíÿåò íóëÿìè âûäåëåííûé áëîê ïàìÿòè
8. Ãëîáàëüíûå è ëîêàëüíûå ïåðåìåííûå èíèöèàëèçèðóþòñÿ íóëÿìè
9.  îòëè÷èå îò ìíîãèõ Oberon-ðåàëèçàöèé, ñáîðùèê ìóñîðà è äèíàìè÷åñêàÿ
ìîäóëüíîñòü îòñóòñòâóþò
8. Òèï BYTE â âûðàæåíèÿõ âñåãäà ïðèâîäèòñÿ ê INTEGER
9. Êîíòðîëü ïåðåïîëíåíèÿ çíà÷åíèé âûðàæåíèé íå ïðîèçâîäèòñÿ
10. Îøèáêè âðåìåíè âûïîëíåíèÿ:
 
- ASSERT(x), ïðè x = FALSE
- ðàçûìåíîâàíèå íóëåâîãî óêàçàòåëÿ
- öåëî÷èñëåííîå äåëåíèå íà 0
- âûçîâ ïðîöåäóðû ÷åðåç ïðîöåäóðíóþ ïåðåìåííóþ ñ íóëåâûì çíà÷åíèåì
- îøèáêà îõðàíû òèïà
- íàðóøåíèå ãðàíèö ìàññèâà
- íåïðåäóñìîòðåííîå çíà÷åíèå âûðàæåíèÿ â îïåðàòîðå CASE
- îøèáêà êîïèðîâàíèÿ ìàññèâîâ v := x, åñëè LEN(v) < LEN(x)
- íåÿâíîå ïðèâåäåíèå x:INTEGER ê v:BYTE, åñëè (x < 0) OR (x > 255)
- CHR(x), åñëè (x < 0) OR (x > 255)
- WCHR(x), åñëè (x < 0) OR (x > 65535)
 
------------------------------------------------------------------------------
Ïñåâäîìîäóëü SYSTEM
 
115,15 → 81,9
ïîâðåæäåíèþ äàííûõ âðåìåíè âûïîëíåíèÿ è àâàðèéíîìó çàâåðøåíèþ ïðîãðàììû.
 
PROCEDURE ADR(v: ëþáîé òèï): INTEGER
v - ïåðåìåííàÿ èëè ïðîöåäóðà;
v - ïåðåìåííàÿ, ïðîöåäóðà èëè ñòðîêîâàÿ êîíñòàíòà;
âîçâðàùàåò àäðåñ v
 
PROCEDURE SADR(x: ñòðîêîâàÿ êîíñòàíòà (CHAR UTF-8)): INTEGER
âîçâðàùàåò àäðåñ x
 
PROCEDURE WSADR(x: ñòðîêîâàÿ êîíñòàíòà (WCHAR)): INTEGER
âîçâðàùàåò àäðåñ x
 
PROCEDURE SIZE(T): INTEGER
âîçâðàùàåò ðàçìåð òèïà T
 
131,7 → 91,8
T - òèï-çàïèñü èëè òèï-óêàçàòåëü,
âîçâðàùàåò íîìåð òèïà â òàáëèöå òèïîâ-çàïèñåé
 
PROCEDURE INF(): REAL
PROCEDURE INF(T): T
T - REAL èëè LONGREAL,
âîçâðàùàåò ñïåöèàëüíîå âåùåñòâåííîå çíà÷åíèå "áåñêîíå÷íîñòü"
 
PROCEDURE GET(a: INTEGER;
139,20 → 100,11
v := Ïàìÿòü[a]
 
PROCEDURE PUT(a: INTEGER; x: ëþáîé îñíîâíîé òèï, PROCEDURE, POINTER)
Ïàìÿòü[a] := x;
Åñëè x: BYTE èëè x: WCHAR, òî çíà÷åíèå x áóäåò ðàñøèðåíî
äî 32 áèò, äëÿ çàïèñè áàéòîâ èñïîëüçîâàòü SYSTEM.PUT8,
äëÿ WCHAR -- SYSTEM.PUT16
Ïàìÿòü[a] := x
 
PROCEDURE PUT8(a: INTEGER; x: INTEGER, BYTE, CHAR, WCHAR)
Ïàìÿòü[a] := ìëàäøèå 8 áèò (x)
 
PROCEDURE PUT16(a: INTEGER; x: INTEGER, BYTE, CHAR, WCHAR)
Ïàìÿòü[a] := ìëàäøèå 16 áèò (x)
 
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Êîïèðóåò n áàéò ïàìÿòè èç Source â Dest,
îáëàñòè Source è Dest íå ìîãóò ïåðåêðûâàòüñÿ
îáëàñòè Source è Dest íå äîëæíû ïåðåêðûâàòüñÿ
 
PROCEDURE COPY(VAR Source: ëþáîé òèï; VAR Dest: ëþáîé òèï; n: INTEGER)
Êîïèðóåò n áàéò ïàìÿòè èç Source â Dest.
159,11 → 111,11
Ýêâèâàëåíòíî
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n)
 
PROCEDURE CODE(byte1, byte2,... : INTEGER)
Âñòàâêà ìàøèííîãî êîäà,
byte1, byte2 ... - êîíñòàíòû â äèàïàçîíå 0..255,
íàïðèìåð:
SYSTEM.CODE(08BH, 045H, 008H) (* mov eax, dword [ebp + 08h] *)
PROCEDURE CODE(s: ARRAY OF CHAR)
Âñòàâêà ìàøèííîãî êîäà
s - ñòðîêîâàÿ êîíñòàíòà øåñòíàäöàòèðè÷íûõ öèôð
êîëè÷åñòâî öèôð äîëæíî áûòü ÷åòíûì
íàïðèìåð: SYSTEM.CODE("B801000000") (* mov eax, 1 *)
 
Òàêæå â ìîäóëå SYSTEM îïðåäåëåí òèï CARD16 (2 áàéòà). Äëÿ òèïà CARD16 íå
äîïóñêàþòñÿ íèêàêèå ÿâíûå îïåðàöèè, çà èñêëþ÷åíèåì ïðèñâàèâàíèÿ.
190,20 → 142,20
Ñèñòåìíûå ôëàãè
 
Ïðè îáúÿâëåíèè ïðîöåäóðíûõ òèïîâ è ãëîáàëüíûõ ïðîöåäóð, ïîñëå êëþ÷åâîãî
ñëîâà PROCEDURE ìîæåò áûòü óêàçàí ôëàã ñîãëàøåíèÿ î âûçîâå: [stdcall],
[ccall], [ccall16], [windows], [linux]. Íàïðèìåð:
ñëîâà PROCEDURE ìîæåò áûòü óêàçàí ôëàã ñîãëàøåíèÿ âûçîâà: [stdcall], [cdecl]
èëè [winapi]. Íàïðèìåð:
 
PROCEDURE [ccall] MyProc (x, y, z: INTEGER): INTEGER;
PROCEDURE [cdecl] MyProc(x, y, z: INTEGER): INTEGER;
 
Åñëè óêàçàí ôëàã [ccall16], òî ïðèíèìàåòñÿ ñîãëàøåíèå ccall, íî ïåðåä
âûçîâîì óêàçàòåëü ñòýêà áóäåò âûðàâíåí ïî ãðàíèöå 16 áàéò.
Ôëàã [windows] - ñèíîíèì äëÿ [stdcall], [linux] - ñèíîíèì äëÿ [ccall16].
Çíàê "-" ïîñëå èìåíè ôëàãà ([stdcall-], [linux-], ...) îçíà÷àåò, ÷òî
ðåçóëüòàò ïðîöåäóðû ìîæíî èãíîðèðîâàòü (íå äîïóñêàåòñÿ äëÿ òèïà REAL).
 
Åñëè óêàçàí ôëàã [winapi], òî ïðèíèìàåòñÿ ñîãëàøåíèå stdcall è
ïðîöåäóðó-ôóíêöèþ ìîæíî âûçâàòü êàê ñîáñòâåííî ïðîöåäóðó, âíå âûðàæåíèÿ.
Ôëàã [winapi] äîñòóïåí òîëüêî äëÿ ïëàòôîðìû Windows.
Ïðè îáúÿâëåíèè òèïîâ-çàïèñåé, ïîñëå êëþ÷åâîãî ñëîâà RECORD ìîæåò áûòü
óêàçàí ôëàã [noalign]. Ôëàã [noalign] îçíà÷àåò îòñóòñòâèå âûðàâíèâàíèÿ ïîëåé
çàïèñè. Çàïèñè ñ ñèñòåìíûì ôëàãîì íå ìîãóò èìåòü áàçîâûé òèï è íå ìîãóò áûòü
óêàçàí ôëàã [noalign] èëè [union]. Ôëàã [noalign] îçíà÷àåò îòñóòñòâèå
âûðàâíèâàíèÿ ïîëåé çàïèñè, à ôëàã [union] îçíà÷àåò, ÷òî ñìåùåíèÿ âñåõ ïîëåé
çàïèñè ðàâíû íóëþ, ïðè ýòîì ðàçìåð çàïèñè ðàâåí ðàçìåðó íàèáîëüøåãî ïîëÿ.
Çàïèñè RECORD [union] ... END ñîîòâåòñòâóþò îáúåäèíåíèÿì (union) â ÿçûêå C.
Çàïèñè ñ ñèñòåìíûìè ôëàãàìè íå ìîãóò èìåòü áàçîâîãî òèïà è íå ìîãóò áûòü
áàçîâûìè òèïàìè äëÿ äðóãèõ çàïèñåé.
Äëÿ èñïîëüçîâàíèÿ ñèñòåìíûõ ôëàãîâ, òðåáóåòñÿ èìïîðòèðîâàòü SYSTEM.
 
230,20 → 182,10
END
 
 ìåòêàõ âàðèàíòîâ ìîæíî èñïîëüçîâàòü êîíñòàíòíûå âûðàæåíèÿ, âåòêà ELSE
íåîáÿçàòåëüíà. Åñëè çíà÷åíèå x íå ñîîòâåòñòâóåò íè îäíîìó âàðèàíòó è ELSE
îòñóòñòâóåò, òî ïðîãðàììà ïðåðûâàåòñÿ ñ îøèáêîé âðåìåíè âûïîëíåíèÿ.
íåîáÿçàòåëüíà. Åñëè íå âûïîëíåí íè îäèí âàðèàíò è ELSE îòñóòñòâóåò, òî
ïðîãðàììà ïðåðûâàåòñÿ ñ îøèáêîé âðåìåíè âûïîëíåíèÿ.
 
------------------------------------------------------------------------------
Òèï WCHAR
 
Òèï WCHAR äîáàâëåí â ÿçûê äëÿ óäîáíîé ïîääåæêè þíèêîäà. Äëÿ òèïîâ WCHAR è
ARRAY OF WCHAR äîïóñêàþòñÿ âñå òå æå îïåðàöèè, êàê äëÿ òèïîâ CHAR è
ARRAY OF CHAR, çà èñêëþ÷åíèåì âñòðîåííîé ïðîöåäóðû CHR, êîòîðàÿ âîçâðàùàåò
òîëüêî òèï CHAR. Äëÿ ïîëó÷åíèÿ çíà÷åíèÿ òèïà WCHAR, ñëåäóåò èñïîëüçîâàòü
ïðîöåäóðó WCHR âìåñòî CHR. Äëÿ ïðàâèëüíîé ðàáîòû ñ òèïîì, íåîáõîäèìî ñîõðàíÿòü
èñõîäíûé êîä â êîäèðîâêå UTF-8 c BOM.
 
------------------------------------------------------------------------------
Ïðîâåðêà è îõðàíà òèïà íóëåâîãî óêàçàòåëÿ
 
Îðèãèíàëüíîå ñîîáùåíèå î ÿçûêå íå îïðåäåëÿåò ïîâåäåíèå ïðîãðàììû ïðè
261,11 → 203,6
äèíàìè÷åñêîé ïåðåìåííîé v^, è ïðèñâàèâàåò ïåðåìåííîé v
çíà÷åíèå NIL.
 
COPY (x: ARRAY OF CHAR/WCHAR; VAR v: ARRAY OF CHAR/WCHAR);
v := x;
Åñëè LEN(v) < LEN(x), òî ñòðîêà x áóäåò ñêîïèðîâàíà
íå ïîëíîñòüþ
 
LSR (x, n: INTEGER): INTEGER
Ëîãè÷åñêèé ñäâèã x íà n áèò âïðàâî.
 
279,14 → 216,11
Èíòåðïðåòèðóåò x êàê çíà÷åíèå òèïà SET.
Âûïîëíÿåòñÿ íà ýòàïå êîìïèëÿöèè.
 
LENGTH (s: ARRAY OF CHAR/WCHAR): INTEGER
LENGTH(s: ARRAY OF CHAR): INTEGER
Äëèíà 0X-çàâåðøåííîé ñòðîêè s, áåç ó÷åòà ñèìâîëà 0X.
Åñëè ñèìâîë 0X îòñóòñòâóåò, ôóíêöèÿ âîçâðàùàåò äëèíó
ìàññèâà s. s íå ìîæåò áûòü êîíñòàíòîé.
ìàññèâà s.
 
WCHR (n: INTEGER): WCHAR
Ïðåîáðàçîâàíèå òèïà, àíàëîãè÷íî CHR(n: INTEGER): CHAR
 
------------------------------------------------------------------------------
DIV è MOD
 
298,45 → 232,6
-5 -3 1 -2
 
------------------------------------------------------------------------------
Èìïîðòèðîâàííûå ïðîöåäóðû
 
Ñèíòàêñèñ èìïîðòà:
 
PROCEDURE [callconv, "library", "function"] proc_name (FormalParam): Type;
 
- callconv -- ñîãëàøåíèå î âûçîâå
- "library" -- èìÿ ôàéëà äèíàìè÷åñêîé áèáëèîòåêè
- "function" -- èìÿ èìïîðòèðóåìîé ïðîöåäóðû
 
íàïðèìåð:
 
PROCEDURE [windows, "kernel32.dll", "ExitProcess"] exit (code: INTEGER);
 
PROCEDURE [stdcall, "Console.obj", "con_exit"] exit (bCloseWindow: BOOLEAN);
 
 êîíöå îáúÿâëåíèÿ ìîæåò áûòü äîáàâëåíî (íåîáÿçàòåëüíî) "END proc_name;"
 
Îáúÿâëåíèÿ èìïîðòèðîâàííûõ ïðîöåäóð äîëæíû ðàñïîëàãàòüñÿ â ãëîáàëüíîé
îáëàñòè âèäèìîñòè ìîäóëÿ ïîñëå îáúÿâëåíèÿ ïåðåìåííûõ, âìåñòå ñ îáúÿâëåíèåì
"îáû÷íûõ" ïðîöåäóð, îò êîòîðûõ èìïîðòèðîâàííûå îòëè÷àþòñÿ òîëüêî îòñóòñòâèåì
òåëà ïðîöåäóðû. Â îñòàëüíîì, ê òàêèì ïðîöåäóðàì ïðèìåíèìû òå æå ïðàâèëà:
èõ ìîæíî âûçâàòü, ïðèñâîèòü ïðîöåäóðíîé ïåðåìåííîé èëè ïîëó÷èòü àäðåñ.
 
Òàê êàê èìïîðòèðîâàííàÿ ïðîöåäóðà âñåãäà èìååò ÿâíîå óêàçàíèå ñîãëàøåíèÿ î
âûçîâå, òî ñîâìåñòèìûé ïðîöåäóðíûé òèï òîæå äîëæåí áûòü îáúÿâëåí ñ óêàçàíèåì
ñîãëàøåíèÿ î âûçîâå:
 
VAR
ExitProcess: PROCEDURE [windows] (code: INTEGER);
con_exit: PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
 
 KolibriOS èìïîðòèðîâàòü ïðîöåäóðû ìîæíî òîëüêî èç áèáëèîòåê, ðàçìåùåííûõ
â /rd/1/lib. Èìïîðòèðîâàòü è âûçûâàòü ôóíêöèè èíèöèàëèçàöèè áèáëèîòåê
(lib_init, START) ïðè ýòîì íå íóæíî.
 
Äëÿ Linux, èìïîðòèðîâàííûå ïðîöåäóðû íå ðåàëèçîâàíû.
 
------------------------------------------------------------------------------
Ñêðûòûå ïàðàìåòðû ïðîöåäóð
 
Íåêîòîðûå ïðîöåäóðû ìîãóò èìåòü ñêðûòûå ïàðàìåòðû, îíè îòñóòñòâóþò â ñïèñêå
344,13 → 239,21
Ýòî âîçìîæíî â ñëåäóþùèõ ñëó÷àÿõ:
 
1. Ïðîöåäóðà èìååò ôîðìàëüíûé ïàðàìåòð îòêðûòûé ìàññèâ:
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL);
PROCEDURE Proc(x: ARRAY OF ARRAY OF LONGREAL);
Âûçîâ òðàíñëèðóåòñÿ òàê:
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x))
Proc(SYSTEM.ADR(x), LEN(x), LEN(x[0])
2. Ïðîöåäóðà èìååò ôîðìàëüíûé ïàðàìåòð-ïåðåìåííóþ òèïà RECORD:
PROCEDURE Proc (VAR x: Rec);
Âûçîâ òðàíñëèðóåòñÿ òàê:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
3. Ïðîöåäóðà ÿâëÿåòñÿ âëîæåííîé, ãëóáèíà âëîæåíèÿ k,
äëÿ ãëîáàëüíûõ ïðîöåäóð k = 0:
PROCEDURE Proc(p1, ..., pn);
Âûçîâ òðàíñëèðóåòñÿ òàê:
Proc(base(k - 1), base(k - 2), ..., base(0), p1, ..., pn),
ãäå base(m) - àäðåñ áàçû êàäðà ñòýêà îõâàòûâàþùåé ïðîöåäóðû ãëóáèíû
âëîæåíèÿ m (èñïîëüçóåòñÿ äëÿ äîñòóïà ê ëîêàëüíûì ïåðåìåííûì
îõâàòûâàþùåé ïðîöåäóðû)
 
------------------------------------------------------------------------------
Ìîäóëü RTL
358,21 → 261,13
Âñå ïðîãðàììû íåÿâíî èñïîëüçóþò ìîäóëü RTL. Êîìïèëÿòîð òðàíñëèðóåò
íåêîòîðûå îïåðàöèè (ïðîâåðêà è îõðàíà òèïà, ñðàâíåíèå ñòðîê, ñîîáùåíèÿ îá
îøèáêàõ âðåìåíè âûïîëíåíèÿ è äð.) êàê âûçîâû ïðîöåäóð ýòîãî ìîäóëÿ. Íå
ñëåäóåò ÿâíî âûçûâàòü ýòè ïðîöåäóðû, çà èñêëþ÷åíèåì ïðîöåäóðû SetDll,
åñëè ïðèëîæåíèå êîìïèëèðóåòñÿ êàê Windows DLL:
ñëåäóåò ÿâíî âûçûâàòü ýòè ïðîöåäóðû, çà èñêëþ÷åíèåì ïðîöåäóðû SetClose:
 
PROCEDURE SetDll
(process_detach, thread_detach, thread_attach: DLL_ENTRY);
ãäå TYPE DLL_ENTRY =
PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
PROCEDURE SetClose(proc: PROC), ãäå TYPE PROC = PROCEDURE
 
SetDll íàçíà÷àåò ïðîöåäóðû process_detach, thread_detach, thread_attach
âûçûâàåìûìè ïðè
- âûãðóçêå dll-áèáëèîòåêè (process_detach)
- ñîçäàíèè íîâîãî ïîòîêà (thread_attach)
- óíè÷òîæåíèè ïîòîêà (thread_detach)
 
Äëÿ ïðî÷èõ òèïîâ ïðèëîæåíèé, âûçîâ ïðîöåäóðû SetDll íå âëèÿåò íà
SetClose íàçíà÷àåò ïðîöåäóðó proc (áåç ïàðàìåòðîâ) âûçûâàåìîé ïðè âûãðóçêå
dll-áèáëèîòåêè (Windows), åñëè ïðèëîæåíèå êîìïèëèðóåòñÿ êàê Windows DLL. Äëÿ
ïðî÷èõ òèïîâ ïðèëîæåíèé è ïëàòôîðì âûçîâ ïðîöåäóðû SetClose íå âëèÿåò íà
ïîâåäåíèå ïðîãðàììû.
Ñîîáùåíèÿ îá îøèáêàõ âðåìåíè âûïîëíåíèÿ âûâîäÿòñÿ â äèàëîãîâûõ îêíàõ
(Windows), â òåðìèíàë (Linux), íà äîñêó îòëàäêè (KolibriOS).
380,9 → 275,9
------------------------------------------------------------------------------
Ìîäóëü API
 
Ñóùåñòâóþò íåñêîëüêî ðåàëèçàöèé ìîäóëÿ API (äëÿ ðàçëè÷íûõ ÎÑ).
Êàê è ìîäóëü RTL, ìîäóëü API íå ïðåäíàçíà÷åí äëÿ ïðÿìîãî èñïîëüçîâàíèÿ.
Îí îáåñïå÷èâàåò ñâÿçü RTL ñ ÎÑ.
Ñóùåñòâóþò òðè ðåàëèçàöèè ìîäóëÿ API: äëÿ Windows, Linux è KolibriOS. Êàê è
ìîäóëü RTL, ìîäóëü API íå ïðåäíàçíà÷åí äëÿ ïðÿìîãî èñïîëüçîâàíèÿ. Îí
îáåñïå÷èâàåò êðîññïëàòôîðìåííîñòü êîìïèëÿòîðà.
 
------------------------------------------------------------------------------
Ãåíåðàöèÿ èñïîëíÿåìûõ ôàéëîâ DLL
396,5 → 291,582
 
Ýòà ïðîöåäóðà äîëæíà áûòü âûçâàíà ïåðåä èñïîëüçîâàíèåì DLL.
Ïðîöåäóðà âñåãäà âîçâðàùàåò 1.
 íàñòîÿùåå âðåìÿ ãåíåðàöèÿ DLL äëÿ Linux íå ðåàëèçîâàíà.
 
Äëÿ Linux, ãåíåðàöèÿ äèíàìè÷åñêèõ áèáëèîòåê íå ðåàëèçîâàíà.
==============================================================================
==============================================================================
 
Áèáëèîòåêà (KolibriOS)
 
------------------------------------------------------------------------------
MODULE Out - êîíñîëüíûé âûâîä
 
PROCEDURE Open
ôîðìàëüíî îòêðûâàåò êîíñîëüíûé âûâîä
 
PROCEDURE Int(x, width: INTEGER)
âûâîä öåëîãî ÷èñëà x;
width - êîëè÷åñòâî çíàêîìåñò, èñïîëüçóåìûõ äëÿ âûâîäà
 
PROCEDURE Real(x: LONGREAL; width: INTEGER)
âûâîä âåùåñòâåííîãî ÷èñëà x â ïëàâàþùåì ôîðìàòå;
width - êîëè÷åñòâî çíàêîìåñò, èñïîëüçóåìûõ äëÿ âûâîäà
 
PROCEDURE Char(x: CHAR)
âûâîä ñèìâîëà x
 
PROCEDURE FixReal(x: LONGREAL; width, p: INTEGER)
âûâîä âåùåñòâåííîãî ÷èñëà x â ôèêñèðîâàííîì ôîðìàòå;
width - êîëè÷åñòâî çíàêîìåñò, èñïîëüçóåìûõ äëÿ âûâîäà;
p - êîëè÷åñòâî çíàêîâ ïîñëå äåñÿòè÷íîé òî÷êè
 
PROCEDURE Ln
ïåðåõîä íà ñëåäóþùóþ ñòðîêó
 
PROCEDURE String(s: ARRAY OF CHAR)
âûâîä ñòðîêè s
 
------------------------------------------------------------------------------
MODULE In - êîíñîëüíûé ââîä
 
VAR Done: BOOLEAN
ïðèíèìàåò çíà÷åíèå TRUE â ñëó÷àå óñïåøíîãî âûïîëíåíèÿ
îïåðàöèè ââîäà, èíà÷å FALSE
 
PROCEDURE Open
ôîðìàëüíî îòêðûâàåò êîíñîëüíûé ââîä,
òàêæå ïðèñâàèâàåò ïåðåìåííîé Done çíà÷åíèå TRUE
 
PROCEDURE Int(VAR x: INTEGER)
ââîä ÷èñëà òèïà INTEGER
 
PROCEDURE Char(VAR x: CHAR)
ââîä ñèìâîëà
 
PROCEDURE Real(VAR x: REAL)
ââîä ÷èñëà òèïà REAL
 
PROCEDURE LongReal(VAR x: LONGREAL)
ââîä ÷èñëà òèïà LONGREAL
 
PROCEDURE String(VAR s: ARRAY OF CHAR)
ââîä ñòðîêè
 
PROCEDURE Ln
îæèäàíèå íàæàòèÿ ENTER
 
------------------------------------------------------------------------------
MODULE Console - äîïîëíèòåëüíûå ïðîöåäóðû êîíñîëüíîãî âûâîäà
 
CONST
 
Ñëåäóþùèå êîíñòàíòû îïðåäåëÿþò öâåò êîíñîëüíîãî âûâîäà
 
Black = 0 Blue = 1 Green = 2
Cyan = 3 Red = 4 Magenta = 5
Brown = 6 LightGray = 7 DarkGray = 8
LightBlue = 9 LightGreen = 10 LightCyan = 11
LightRed = 12 LightMagenta = 13 Yellow = 14
White = 15
 
PROCEDURE Cls
î÷èñòêà îêíà êîíñîëè
 
PROCEDURE SetColor(FColor, BColor: INTEGER)
óñòàíîâêà öâåòà êîíñîëüíîãî âûâîäà: FColor - öâåò òåêñòà,
BColor - öâåò ôîíà, âîçìîæíûå çíà÷åíèÿ - âûøåïåðå÷èñëåííûå
êîíñòàíòû
 
PROCEDURE SetCursor(x, y: INTEGER)
óñòàíîâêà êóðñîðà êîíñîëè â ïîçèöèþ (x, y)
 
PROCEDURE GetCursor(VAR x, y: INTEGER)
çàïèñûâàåò â ïàðàìåòðû òåêóùèå êîîðäèíàòû êóðñîðà êîíñîëè
 
PROCEDURE GetCursorX(): INTEGER
âîçâðàùàåò òåêóùóþ x-êîîðäèíàòó êóðñîðà êîíñîëè
 
PROCEDURE GetCursorY(): INTEGER
âîçâðàùàåò òåêóùóþ y-êîîðäèíàòó êóðñîðà êîíñîëè
 
------------------------------------------------------------------------------
MODULE ConsoleLib - îáåðòêà áèáëèîòåêè console.obj
 
------------------------------------------------------------------------------
MODULE Math - ìàòåìàòè÷åñêèå ôóíêöèè
 
CONST
 
pi = 3.141592653589793D+00
e = 2.718281828459045D+00
 
VAR
 
Inf, nInf: LONGREAL
ïîëîæèòåëüíàÿ è îòðèöàòåëüíàÿ áåñêîíå÷íîñòü
 
PROCEDURE IsNan(x: LONGREAL): BOOLEAN
âîçâðàùàåò TRUE, åñëè x - íå ÷èñëî
 
PROCEDURE IsInf(x: LONGREAL): BOOLEAN
âîçâðàùàåò TRUE, åñëè x - áåñêîíå÷íîñòü
 
PROCEDURE sqrt(x: LONGREAL): LONGREAL
êâàäðàòíûé êîðåíü x
 
PROCEDURE exp(x: LONGREAL): LONGREAL
ýêñïîíåíòà x
 
PROCEDURE ln(x: LONGREAL): LONGREAL
íàòóðàëüíûé ëîãàðèôì x
 
PROCEDURE sin(x: LONGREAL): LONGREAL
ñèíóñ x
 
PROCEDURE cos(x: LONGREAL): LONGREAL
êîñèíóñ x
 
PROCEDURE tan(x: LONGREAL): LONGREAL
òàíãåíñ x
 
PROCEDURE arcsin(x: LONGREAL): LONGREAL
àðêñèíóñ x
 
PROCEDURE arccos(x: LONGREAL): LONGREAL
àðêêîñèíóñ x
 
PROCEDURE arctan(x: LONGREAL): LONGREAL
àðêòàíãåíñ x
 
PROCEDURE arctan2(y, x: LONGREAL): LONGREAL
àðêòàíãåíñ y/x
 
PROCEDURE power(base, exponent: LONGREAL): LONGREAL
âîçâåäåíèå ÷èñëà base â ñòåïåíü exponent
 
PROCEDURE log(base, x: LONGREAL): LONGREAL
ëîãàðèôì x ïî îñíîâàíèþ base
 
PROCEDURE sinh(x: LONGREAL): LONGREAL
ãèïåðáîëè÷åñêèé ñèíóñ x
 
PROCEDURE cosh(x: LONGREAL): LONGREAL
ãèïåðáîëè÷åñêèé êîñèíóñ x
 
PROCEDURE tanh(x: LONGREAL): LONGREAL
ãèïåðáîëè÷åñêèé òàíãåíñ x
 
PROCEDURE arcsinh(x: LONGREAL): LONGREAL
îáðàòíûé ãèïåðáîëè÷åñêèé ñèíóñ x
 
PROCEDURE arccosh(x: LONGREAL): LONGREAL
îáðàòíûé ãèïåðáîëè÷åñêèé êîñèíóñ x
 
PROCEDURE arctanh(x: LONGREAL): LONGREAL
îáðàòíûé ãèïåðáîëè÷åñêèé òàíãåíñ x
 
PROCEDURE round(x: LONGREAL): LONGREAL
îêðóãëåíèå x äî áëèæàéøåãî öåëîãî
 
PROCEDURE frac(x: LONGREAL): LONGREAL;
äðîáíàÿ ÷àñòü ÷èñëà x
 
PROCEDURE floor(x: LONGREAL): LONGREAL
íàèáîëüøåå öåëîå ÷èñëî (ïðåäñòàâëåíèå êàê LONGREAL),
íå áîëüøå x: floor(1.2) = 1.0
 
PROCEDURE ceil(x: LONGREAL): LONGREAL
íàèìåíüøåå öåëîå ÷èñëî (ïðåäñòàâëåíèå êàê LONGREAL),
íå ìåíüøå x: ceil(1.2) = 2.0
 
PROCEDURE sgn(x: LONGREAL): INTEGER
åñëè x > 0 âîçâðàùàåò 1
åñëè x < 0 âîçâðàùàåò -1
åñëè x = 0 âîçâðàùàåò 0
 
------------------------------------------------------------------------------
MODULE Debug - âûâîä íà äîñêó îòëàäêè
Èíòåðôåéñ êàê ìîäóëü Out
 
PROCEDURE Open
îòêðûâàåò äîñêó îòëàäêè
 
------------------------------------------------------------------------------
MODULE File - ðàáîòà ñ ôàéëîâîé ñèñòåìîé
 
TYPE
 
FNAME = ARRAY 520 OF CHAR
 
FS = POINTER TO rFS
 
rFS = RECORD (* èíôîðìàöèîííàÿ ñòðóêòóðà ôàéëà *)
subfunc, pos, hpos, bytes, buffer: INTEGER;
name: FNAME
END
 
FD = POINTER TO rFD
 
rFD = RECORD (* ñòðóêòóðà áëîêà äàííûõ âõîäà êàòàëîãà *)
attr: INTEGER;
ntyp: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create, date_create,
time_access, date_access,
time_modif, date_modif,
size, hsize: INTEGER;
name: FNAME
END
 
CONST
 
SEEK_BEG = 0
SEEK_CUR = 1
SEEK_END = 2
 
PROCEDURE Load(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
Çàãðóæàåò â ïàìÿòü ôàéë ñ èìåíåì FName, çàïèñûâàåò â ïàðàìåòð
size ðàçìåð ôàéëà, âîçâðàùàåò àäðåñ çàãðóæåííîãî ôàéëà
èëè 0 (îøèáêà). Ïðè íåîáõîäèìîñòè, ðàñïàêîâûâàåò
ôàéë (kunpack).
 
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN
Çàïèñûâàåò ñòðóêòóðó áëîêà äàííûõ âõîäà êàòàëîãà äëÿ ôàéëà
èëè ïàïêè ñ èìåíåì FName â ïàðàìåòð Info.
Ïðè îøèáêå âîçâðàùàåò FALSE.
 
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN
âîçâðàùàåò TRUE, åñëè ôàéë ñ èìåíåì FName ñóùåñòâóåò
 
PROCEDURE Close(VAR F: FS)
îñâîáîæäàåò ïàìÿòü, âûäåëåííóþ äëÿ èíôîðìàöèîííîé ñòðóêòóðû
ôàéëà F è ïðèñâàèâàåò F çíà÷åíèå NIL
 
PROCEDURE Open(FName: ARRAY OF CHAR): FS
âîçâðàùàåò óêàçàòåëü íà èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà ñ
èìåíåì FName, ïðè îøèáêå âîçâðàùàåò NIL
 
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN
óäàëÿåò ôàéë ñ èìåíåì FName, ïðè îøèáêå âîçâðàùàåò FALSE
 
PROCEDURE Seek(F: FS; Offset, Origin: INTEGER): INTEGER
óñòàíàâëèâàåò ïîçèöèþ ÷òåíèÿ-çàïèñè ôàéëà F íà Offset,
îòíîñèòåëüíî Origin = (SEEK_BEG - íà÷àëî ôàéëà,
SEEK_CUR - òåêóùàÿ ïîçèöèÿ, SEEK_END - êîíåö ôàéëà),
âîçâðàùàåò ïîçèöèþ îòíîñèòåëüíî íà÷àëà ôàéëà, íàïðèìåð:
Seek(F, 0, SEEK_END)
óñòàíàâëèâàåò ïîçèöèþ íà êîíåö ôàéëà è âîçâðàùàåò äëèíó
ôàéëà; ïðè îøèáêå âîçâðàùàåò -1
 
PROCEDURE Read(F: FS; Buffer, Count: INTEGER): INTEGER
×èòàåò äàííûå èç ôàéëà â ïàìÿòü. F - óêàçàòåëü íà
èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà, Buffer - àäðåñ îáëàñòè
ïàìÿòè, Count - êîëè÷åñòâî áàéò, êîòîðîå òðåáóåòñÿ ïðî÷èòàòü
èç ôàéëà; âîçâðàùàåò êîëè÷åñòâî áàéò, êîòîðîå áûëî ïðî÷èòàíî
è ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿåò ïîçèöèþ ÷òåíèÿ/çàïèñè â
èíôîðìàöèîííîé ñòðóêòóðå F.
 
PROCEDURE Write(F: FS; Buffer, Count: INTEGER): INTEGER
Çàïèñûâàåò äàííûå èç ïàìÿòè â ôàéë. F - óêàçàòåëü íà
èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà, Buffer - àäðåñ îáëàñòè
ïàìÿòè, Count - êîëè÷åñòâî áàéò, êîòîðîå òðåáóåòñÿ çàïèñàòü
â ôàéë; âîçâðàùàåò êîëè÷åñòâî áàéò, êîòîðîå áûëî çàïèñàíî è
ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿåò ïîçèöèþ ÷òåíèÿ/çàïèñè â
èíôîðìàöèîííîé ñòðóêòóðå F.
 
PROCEDURE Create(FName: ARRAY OF CHAR): FS
ñîçäàåò íîâûé ôàéë ñ èìåíåì FName (ïîëíîå èìÿ), âîçâðàùàåò
óêàçàòåëü íà èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà,
ïðè îøèáêå âîçâðàùàåò NIL
 
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN
ñîçäàåò ïàïêó ñ èìåíåì DirName, âñå ïðîìåæóòî÷íûå ïàïêè
äîëæíû ñóùåñòâîâàòü, ïðè îøèáêå âîçâðàùàåò FALSE
 
PROCEDURE DeleteDir(DirName: ARRAY OF CHAR): BOOLEAN
óäàëÿåò ïóñòóþ ïàïêó ñ èìåíåì DirName,
ïðè îøèáêå âîçâðàùàåò FALSE
 
PROCEDURE DirExists(DirName: ARRAY OF CHAR): BOOLEAN
âîçâðàùàåò TRUE, åñëè ïàïêà ñ èìåíåì DirName ñóùåñòâóåò
 
------------------------------------------------------------------------------
MODULE Read - ÷òåíèå îñíîâíûõ òèïîâ äàííûõ èç ôàéëà F
 
Ïðîöåäóðû âîçâðàùàþò TRUE â ñëó÷àå óñïåøíîé îïåðàöèè ÷òåíèÿ è
ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿþò ïîçèöèþ ÷òåíèÿ/çàïèñè â
èíôîðìàöèîííîé ñòðóêòóðå F
 
PROCEDURE Char(F: File.FS; VAR x: CHAR): BOOLEAN
 
PROCEDURE Int(F: File.FS; VAR x: INTEGER): BOOLEAN
 
PROCEDURE Real(F: File.FS; VAR x: REAL): BOOLEAN
 
PROCEDURE LongReal(F: File.FS; VAR x: LONGREAL): BOOLEAN
 
PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN
 
PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN
 
PROCEDURE Card16(F: File.FS; VAR x: SYSTEM.CARD16): BOOLEAN
 
------------------------------------------------------------------------------
MODULE Write - çàïèñü îñíîâíûõ òèïîâ äàííûõ â ôàéë F
 
Ïðîöåäóðû âîçâðàùàþò TRUE â ñëó÷àå óñïåøíîé îïåðàöèè çàïèñè è
ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿþò ïîçèöèþ ÷òåíèÿ/çàïèñè â
èíôîðìàöèîííîé ñòðóêòóðå F
 
PROCEDURE Char(F: File.FS; x: CHAR): BOOLEAN
 
PROCEDURE Int(F: File.FS; x: INTEGER): BOOLEAN
 
PROCEDURE Real(F: File.FS; x: REAL): BOOLEAN
 
PROCEDURE LongReal(F: File.FS; x: LONGREAL): BOOLEAN
 
PROCEDURE Boolean(F: File.FS; x: BOOLEAN): BOOLEAN
 
PROCEDURE Set(F: File.FS; x: SET): BOOLEAN
 
PROCEDURE Card16(F: File.FS; x: SYSTEM.CARD16): BOOLEAN
 
------------------------------------------------------------------------------
MODULE DateTime - äàòà, âðåìÿ
 
CONST ERR = -7.0D5
 
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER)
çàïèñûâàåò â ïàðàìåòðû êîìïîíåíòû òåêóùåé ñèñòåìíîé äàòû è
âðåìåíè
 
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL
âîçâðàùàåò äàòó, ïîëó÷åííóþ èç êîìïîíåíòîâ
Year, Month, Day, Hour, Min, Sec;
ïðè îøèáêå âîçâðàùàåò êîíñòàíòó ERR = -7.0D5
 
PROCEDURE Decode(Date: LONGREAL; VAR Year, Month, Day,
Hour, Min, Sec: INTEGER): BOOLEAN
èçâëåêàåò êîìïîíåíòû
Year, Month, Day, Hour, Min, Sec èç äàòû Date;
ïðè îøèáêå âîçâðàùàåò FALSE
 
------------------------------------------------------------------------------
MODULE Args - ïàðàìåòðû ïðîãðàììû
 
VAR argc: INTEGER
êîëè÷åñòâî ïàðàìåòðîâ ïðîãðàììû, âêëþ÷àÿ èìÿ
èñïîëíÿåìîãî ôàéëà
 
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR)
çàïèñûâàåò â ñòðîêó s n-é ïàðàìåòð ïðîãðàììû,
íóìåðàöèÿ ïàðàìåòðîâ îò 0 äî argc - 1,
íóëåâîé ïàðàìåòð -- èìÿ èñïîëíÿåìîãî ôàéëà
 
------------------------------------------------------------------------------
MODULE KOSAPI
 
PROCEDURE sysfunc1(arg1: INTEGER): INTEGER
PROCEDURE sysfunc2(arg1, arg2: INTEGER): INTEGER
...
PROCEDURE sysfunc7(arg1, arg2, ..., arg7: INTEGER): INTEGER
Îáåðòêè äëÿ ôóíêöèé API ÿäðà KolibriOS.
arg1 .. arg7 ñîîòâåòñòâóþò ðåãèñòðàì
eax, ebx, ecx, edx, esi, edi, ebp;
âîçâðàùàþò çíà÷åíèå ðåãèñòðà eax ïîñëå ñèñòåìíîãî âûçîâà.
 
PROCEDURE sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER
Îáåðòêà äëÿ ôóíêöèé API ÿäðà KolibriOS.
arg1 - ðåãèñòð eax, arg2 - ðåãèñòð ebx,
res2 - çíà÷åíèå ðåãèñòðà ebx ïîñëå ñèñòåìíîãî âûçîâà;
âîçâðàùàåò çíà÷åíèå ðåãèñòðà eax ïîñëå ñèñòåìíîãî âûçîâà.
 
PROCEDURE malloc(size: INTEGER): INTEGER
Âûäåëÿåò áëîê ïàìÿòè.
size - ðàçìåð áëîêà â áàéòàõ,
âîçâðàùàåò àäðåñ âûäåëåííîãî áëîêà
 
PROCEDURE free(ptr: INTEGER): INTEGER
Îñâîáîæäàåò ðàíåå âûäåëåííûé áëîê ïàìÿòè ñ àäðåñîì ptr,
âîçâðàùàåò 0
 
PROCEDURE realloc(ptr, size: INTEGER): INTEGER
Ïåðåðàñïðåäåëÿåò áëîê ïàìÿòè,
ptr - àäðåñ ðàíåå âûäåëåííîãî áëîêà,
size - íîâûé ðàçìåð,
âîçâðàùàåò óêàçàòåëü íà ïåðåðàñïðåäåëåííûé áëîê,
0 ïðè îøèáêå
 
PROCEDURE GetCommandLine(): INTEGER
Âîçâðàùàåò àäðåñ ñòðîêè ïàðàìåòðîâ
 
PROCEDURE GetName(): INTEGER
Âîçâðàùàåò àäðåñ ñòðîêè ñ èìåíåì ïðîãðàììû
 
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER
Çàãðóæàåò DLL ñ ïîëíûì èìåíåì name. Âîçâðàùàåò àäðåñ òàáëèöû
ýêñïîðòà. Ïðè îøèáêå âîçâðàùàåò 0.
 
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER
name - èìÿ ïðîöåäóðû
lib - àäðåñ òàáëèöû ýêñïîðòà DLL
Âîçâðàùàåò àäðåñ ïðîöåäóðû. Ïðè îøèáêå âîçâðàùàåò 0.
 
------------------------------------------------------------------------------
MODULE ColorDlg - ðàáîòà ñ äèàëîãîì "Color Dialog"
 
TYPE
 
Dialog = POINTER TO RECORD (* ñòðóêòóðà äèàëîãà *)
status: INTEGER (* ñîñòîÿíèå äèàëîãà:
0 - ïîëüçîâàòåëü íàæàë Cancel
1 - ïîëüçîâàòåëü íàæàë OK
2 - äèàëîã îòêðûò *)
 
color: INTEGER (* âûáðàííûé öâåò *)
END
 
PROCEDURE Create(draw_window: DRAW_WINDOW): Dialog
ñîçäàòü äèàëîã
draw_window - ïðîöåäóðà ïåðåðèñîâêè îñíîâíîãî îêíà
(TYPE DRAW_WINDOW = PROCEDURE);
ïðîöåäóðà âîçâðàùàåò óêàçàòåëü íà ñòðóêòóðó äèàëîãà
 
PROCEDURE Show(cd: Dialog)
ïîêàçàòü äèàëîã
cd - óêàçàòåëü íà ñòðóêòóðó äèàëîãà, êîòîðûé áûë ñîçäàí ðàíåå
ïðîöåäóðîé Create
 
PROCEDURE Destroy(VAR cd: Dialog)
óíè÷òîæèòü äèàëîã
cd - óêàçàòåëü íà ñòðóêòóðó äèàëîãà
 
------------------------------------------------------------------------------
MODULE OpenDlg - ðàáîòà ñ äèàëîãîì "Open Dialog"
 
TYPE
 
Dialog = POINTER TO RECORD (* ñòðóêòóðà äèàëîãà *)
status: INTEGER (* ñîñòîÿíèå äèàëîãà:
0 - ïîëüçîâàòåëü íàæàë Cancel
1 - ïîëüçîâàòåëü íàæàë OK
2 - äèàëîã îòêðûò *)
 
FileName: ARRAY 4096 OF CHAR (* èìÿ âûáðàííîãî ôàéëà *)
FilePath: ARRAY 4096 OF CHAR (* ïîëíîå èìÿ âûáðàííîãî
ôàéëà *)
END
 
PROCEDURE Create(draw_window: DRAW_WINDOW; type: INTEGER; def_path,
filter: ARRAY OF CHAR): Dialog
ñîçäàòü äèàëîã
draw_window - ïðîöåäóðà ïåðåðèñîâêè îñíîâíîãî îêíà
(TYPE DRAW_WINDOW = PROCEDURE)
type - òèï äèàëîãà
0 - îòêðûòü
1 - ñîõðàíèòü
2 - âûáðàòü ïàïêó
def_path - ïóòü ïî óìîë÷àíèþ, ïàïêà def_path áóäåò îòêðûòà
ïðè ïåðâîì çàïóñêå äèàëîãà
filter - â ñòðîêå çàïèñàíî ïåðå÷èñëåíèå ðàñøèðåíèé ôàéëîâ,
êîòîðûå áóäóò ïîêàçàíû â äèàëîãîâîì îêíå, ðàñøèðåíèÿ
ðàçäåëÿþòñÿ ñèìâîëîì "|", íàïðèìåð: "ASM|TXT|INI"
ïðîöåäóðà âîçâðàùàåò óêàçàòåëü íà ñòðóêòóðó äèàëîãà
 
PROCEDURE Show(od: Dialog; Width, Height: INTEGER)
ïîêàçàòü äèàëîã
od - óêàçàòåëü íà ñòðóêòóðó äèàëîãà, êîòîðûé áûë ñîçäàí ðàíåå
ïðîöåäóðîé Create
Width è Height - øèðèíà è âûñîòà äèàëîãîâîãî îêíà
 
PROCEDURE Destroy(VAR od: Dialog)
óíè÷òîæèòü äèàëîã
od - óêàçàòåëü íà ñòðóêòóðó äèàëîãà
 
------------------------------------------------------------------------------
MODULE kfonts - ðàáîòà ñ kf-øðèôòàìè
 
CONST
 
bold = 1
italic = 2
underline = 4
strike_through = 8
smoothing = 16
bpp32 = 32
 
TYPE
 
TFont = POINTER TO TFont_desc (* óêàçàòåëü íà øðèôò *)
 
PROCEDURE LoadFont(file_name: ARRAY OF CHAR): TFont
çàãðóçèòü øðèôò èç ôàéëà
file_name èìÿ kf-ôàéëà
ðåç-ò: óêàçàòåëü íà øðèôò/NIL (îøèáêà)
 
PROCEDURE SetSize(Font: TFont; font_size: INTEGER): BOOLEAN
óñòàíîâèòü ðàçìåð øðèôòà
Font óêàçàòåëü íà øðèôò
font_size ðàçìåð øðèôòà
ðåç-ò: TRUE/FALSE (îøèáêà)
 
PROCEDURE Enabled(Font: TFont; font_size: INTEGER): BOOLEAN
ïðîâåðèòü, åñòü ëè øðèôò, çàäàííîãî ðàçìåðà
Font óêàçàòåëü íà øðèôò
font_size ðàçìåð øðèôòà
ðåç-ò: TRUE/FALSE (øðèôòà íåò)
 
PROCEDURE Destroy(VAR Font: TFont)
âûãðóçèòü øðèôò, îñâîáîäèòü äèíàìè÷åñêóþ ïàìÿòü
Font óêàçàòåëü íà øðèôò
Ïðèñâàèâàåò ïåðåìåííîé Font çíà÷åíèå NIL
 
PROCEDURE TextHeight(Font: TFont): INTEGER
ïîëó÷èòü âûñîòó ñòðîêè òåêñòà
Font óêàçàòåëü íà øðèôò
ðåç-ò: âûñîòà ñòðîêè òåêñòà â ïèêñåëÿõ
 
PROCEDURE TextWidth(Font: TFont;
str, length, params: INTEGER): INTEGER
ïîëó÷èòü øèðèíó ñòðîêè òåêñòà
Font óêàçàòåëü íà øðèôò
str àäðåñ ñòðîêè òåêñòà â êîäèðîâêå Win-1251
length êîëè÷åñòâî ñèìâîëîâ â ñòðîêå èëè -1, åñëè ñòðîêà
çàâåðøàåòñÿ íóëåì
params ïàðàìåòðû-ôëàãè ñì. íèæå
ðåç-ò: øèðèíà ñòðîêè òåêñòà â ïèêñåëÿõ
 
PROCEDURE TextOut(Font: TFont;
canvas, x, y, str, length, color, params: INTEGER)
âûâåñòè òåêñò â áóôåð
äëÿ âûâîäà áóôåðà â îêíî, èñïîëüçîâàòü ô.65 èëè
ô.7 (åñëè áóôåð 24-áèòíûé)
Font óêàçàòåëü íà øðèôò
canvas àäðåñ ãðàôè÷åñêîãî áóôåðà
ñòðóêòóðà áóôåðà:
Xsize dd
Ysize dd
picture rb Xsize * Ysize * 4 (32 áèòà)
èëè Xsize * Ysize * 3 (24 áèòà)
x, y êîîðäèíàòû òåêñòà îòíîñèòåëüíî ëåâîãî âåðõíåãî
óãëà áóôåðà
str àäðåñ ñòðîêè òåêñòà â êîäèðîâêå Win-1251
length êîëè÷åñòâî ñèìâîëîâ â ñòðîêå èëè -1, åñëè ñòðîêà
çàâåðøàåòñÿ íóëåì
color öâåò òåêñòà 0x00RRGGBB
params ïàðàìåòðû-ôëàãè:
1 æèðíûé
2 êóðñèâ
4 ïîä÷åðêíóòûé
8 ïåðå÷åðêíóòûé
16 ïðèìåíèòü ñãëàæèâàíèå
32 âûâîä â 32-áèòíûé áóôåð
âîçìîæíî èñïîëüçîâàíèå ôëàãîâ â ëþáûõ ñî÷åòàíèÿõ
------------------------------------------------------------------------------
MODULE RasterWorks - îáåðòêà áèáëèîòåêè Rasterworks.obj
------------------------------------------------------------------------------
MODULE libimg - îáåðòêà áèáëèîòåêè libimg.obj
------------------------------------------------------------------------------
MODULE NetDevices - îáåðòêà äëÿ ô.74 (ðàáîòà ñ ñåòåâûìè óñòðîéñòâàìè)
------------------------------------------------------------------------------
/programs/develop/oberon07/Docs/About866.txt
0,0 → 1,872
Š®¬¯¨«ïâ®à ï§ëª  ¯à®£à ¬¬¨à®¢ ­¨ï Oberon-07/11 ¤«ï i386
Windows/Linux/KolibriOS.
------------------------------------------------------------------------------
 
‘®áâ ¢ ¯à®£à ¬¬ë
 
1. Compiler.kex (KolibriOS) - ¨á¯®«­ï¥¬ë© ä ©« ª®¬¯¨«ïâ®à .
‚室 - ⥪áâ®¢ë¥ ä ©«ë ¬®¤ã«¥© á à áè¨à¥­¨¥¬ ".ob07", ª®¤¨à®¢ª  ANSI
¨«¨ UTF-8 á BOM-ᨣ­ âãன.
‚ë室 - ¨á¯®«­ï¥¬ë© ä ©« ä®à¬ â  PE, ELF ¨«¨ MENUET01/MS COFF.
 à ¬¥âàë:
1) ¨¬ï £« ¢­®£® ¬®¤ã«ï
2) ⨯ ¯à¨«®¦¥­¨ï ¨ ¯« âä®à¬ 
"con" - Windows console
"gui" - Windows GUI
"dll" - Windows DLL
"elf" - Linux
"kos" - KolibriOS
"obj" - KolibriOS DLL
"kem" - KolibriOS á  ¤à¥á®¬ § £à㧪¨ 0x10000 ¤«ï ¢®§¬®¦­®£®
¨á¯®«­¥­¨ï ¢ í¬ã«ïâ®à¥
3) à §¬¥à áâíª  ¢ ¬¥£ ¡ ©â å, ­¥®¡ï§ â¥«ì­ë© ¯ à ¬¥âà, ¯® 㬮«ç ­¨î -
1 Œ¡, ¤«ï ELF ¨£­®à¨àã¥âáï. …᫨ 2-© ¯ à ¬¥âà = "obj" (KolibriOS DLL),
â® 3-© ¯ à ¬¥âà § ¤ ¥âáï è¥áâ­ ¤æ â¨à¨ç­ë¬ ç¨á«®¬
(0x00000001 .. 0xffffffff) ¨ ®¯à¥¤¥«ï¥â ¢¥àá¨î ¯à®£à ¬¬ë,
¯® 㬮«ç ­¨î - 0x00010000 (v1.0).
 ¯à¨¬¥à:
"C:\oberon-07\example.ob07" con 1
"C:\oberon-07\example.ob07" obj 0x00020005 (* v2.5 *)
‚ á«ãç ¥ ãᯥ譮© ª®¬¯¨«ï樨, ª®¬¯¨«ïâ®à ¯¥à¥¤ ¥â ª®¤ § ¢¥à襭¨ï 0,
¨­ ç¥ 1. à¨ à ¡®â¥ ª®¬¯¨«ïâ®à  ¢ KolibriOS, ª®¤ § ¢¥à襭¨ï ­¥
¯¥à¥¤ ¥âáï. ‘®®¡é¥­¨ï ª®¬¯¨«ïâ®à  ¢ë¢®¤ïâáï ­  ª®­á®«ì (Windows,
KolibriOS), ¢ â¥à¬¨­ « (Linux).
2.  ¯ª  Lib - ¡¨¡«¨®â¥ª  ¬®¤ã«¥©
 
------------------------------------------------------------------------------
Žâ«¨ç¨ï ®â ®à¨£¨­ « 
 
1.  áè¨à¥­ ¯á¥¢¤®¬®¤ã«ì SYSTEM
2.  §à¥è¥­ ᨬ¢®« "_" ¢ ¨¤¥­â¨ä¨ª â®à å
3. „®¡ ¢«¥­ë á¨á⥬­ë¥ ä« £¨
4. Ž¯¥à â®à CASE ॠ«¨§®¢ ­ ¢ ᮮ⢥âá⢨¨ á ᨭ⠪á¨á®¬ ¨ ᥬ ­â¨ª®©
¤ ­­®£® ®¯¥à â®à  ¢ ï§ëª¥ Oberon (Revision 1.10.90)
5.  áè¨à¥­ ­ ¡®à áâ ­¤ àâ­ëå ¯à®æ¥¤ãà
6. ‘¥¬ ­â¨ª  ®åà ­ë/¯à®¢¥àª¨ ⨯  ãâ®ç­¥­  ¤«ï ­ã«¥¢®£® 㪠§ â¥«ï
7. ‘¥¬ ­â¨ª  DIV ¨ MOD ãâ®ç­¥­  ¤«ï ®âà¨æ â¥«ì­ëå ç¨á¥«
8. „®¡ ¢«¥­ë ®¤­®áâà®ç­ë¥ ª®¬¬¥­â à¨¨ (­ ç¨­ îâáï á ¯ àë ᨬ¢®«®¢ "//")
9.  §à¥è¥­ íªá¯®àâ ¯¥à¥¬¥­­ëå ⨯®¢ ARRAY ¨ RECORD (⮫쪮 ¤«ï ç⥭¨ï)
10.  §à¥è¥­® ­ á«¥¤®¢ ­¨¥ ®â ⨯ -㪠§ â¥«ï
11. „®¡ ¢«¥­ë ¯á¥¢¤®­¨¬ë ⨯®¢ (TYPE A = B)
 
------------------------------------------------------------------------------
Žá®¡¥­­®á⨠ॠ«¨§ æ¨¨
 
1. Žá­®¢­ë¥ ⨯ë
 
’¨¯ „¨ ¯ §®­ §­ ç¥­¨©  §¬¥à, ¡ ©â
 
INTEGER -2147483648 .. 2147483647 4
REAL 1.40E-45 .. 3.34E+38 4
LONGREAL 4.94E-324 .. 1.70E+308 8
CHAR ᨬ¢®« ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET ¬­®¦¥á⢮ ¨§ 楫ëå ç¨á¥« {0 .. 31} 4
 
2. Œ ªá¨¬ «ì­ ï ¤«¨­  ¨¤¥­â¨ä¨ª â®à®¢ - 255 ᨬ¢®«®¢
3. Œ ªá¨¬ «ì­ ï ¤«¨­  áâப®¢ëå ª®­áâ ­â - 255 ᨬ¢®«®¢
4. Œ ªá¨¬ «ì­ ï ¤«¨­  áâப ¨á室­®£® ª®¤  - 511 ᨬ¢®«®¢
5. Œ ªá¨¬ «ì­ ï à §¬¥à­®áâì ®âªàëâëå ¬ áᨢ®¢ - 5
6. Œ ªá¨¬ «ì­®¥ ª®«¨ç¥á⢮ ®¡ê¥­­ëå ⨯®¢-§ ¯¨á¥© - 2047
7. à®æ¥¤ãà  NEW § ¯®«­ï¥â ­ã«ï¬¨ ¢ë¤¥«¥­­ë© ¡«®ª ¯ ¬ïâ¨
8. ƒ«®¡ «ì­ë¥ ¨ «®ª «ì­ë¥ ¯¥à¥¬¥­­ë¥ ¨­¨æ¨ «¨§¨àãîâáï ­ã«ï¬¨
9. ‚ ®â«¨ç¨¥ ®â ¬­®£¨å Oberon-ॠ«¨§ æ¨©, á¡®à騪 ¬ãá®à  ¨ ¤¨­ ¬¨ç¥áª ï
¬®¤ã«ì­®áâì ®âáãâáâ¢ãîâ
 
------------------------------------------------------------------------------
á¥¢¤®¬®¤ã«ì SYSTEM
 
á¥¢¤®¬®¤ã«ì SYSTEM ᮤ¥à¦¨â ­¨§ª®ã஢­¥¢ë¥ ¨ ­¥¡¥§®¯ á­ë¥ ¯à®æ¥¤ãàë,
®è¨¡ª¨ ¯à¨ ¨á¯®«ì§®¢ ­¨¨ ¯à®æ¥¤ãà ¯á¥¢¤®¬®¤ã«ï SYSTEM ¬®£ã⠯ਢ¥á⨠ª
¯®¢à¥¦¤¥­¨î ¤ ­­ëå ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¨  ¢ à¨©­®¬ã § ¢¥à襭¨î ¯à®£à ¬¬ë.
 
PROCEDURE ADR(v: «î¡®© ⨯): INTEGER
v - ¯¥à¥¬¥­­ ï, ¯à®æ¥¤ãà  ¨«¨ áâப®¢ ï ª®­áâ ­â ;
¢®§¢à é ¥â  ¤à¥á v
 
PROCEDURE SIZE(T): INTEGER
¢®§¢à é ¥â à §¬¥à ⨯  T
 
PROCEDURE TYPEID(T): INTEGER
T - ⨯-§ ¯¨áì ¨«¨ ⨯-㪠§ â¥«ì,
¢®§¢à é ¥â ­®¬¥à ⨯  ¢ â ¡«¨æ¥ ⨯®¢-§ ¯¨á¥©
 
PROCEDURE INF(T): T
T - REAL ¨«¨ LONGREAL,
¢®§¢à é ¥â ᯥ樠«ì­®¥ ¢¥é¥á⢥­­®¥ §­ ç¥­¨¥ "¡¥áª®­¥ç­®áâì"
 
PROCEDURE GET(a: INTEGER;
VAR v: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER)
v :=  ¬ïâì[a]
 
PROCEDURE PUT(a: INTEGER; x: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER)
 ¬ïâì[a] := x
 
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Š®¯¨àã¥â n ¡ ©â ¯ ¬ï⨠¨§ 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)
‚áâ ¢ª  ¬ è¨­­®£® ª®¤ 
s - áâப®¢ ï ª®­áâ ­â  è¥áâ­ ¤æ â¨à¨ç­ëå æ¨äà
ª®«¨ç¥á⢮ æ¨äà ¤®«¦­® ¡ëâì ç¥â­ë¬
­ ¯à¨¬¥à: SYSTEM.CODE("B801000000") (* mov eax, 1 *)
 
’ ª¦¥ ¢ ¬®¤ã«¥ SYSTEM ®¯à¥¤¥«¥­ ⨯ CARD16 (2 ¡ ©â ). „«ï ⨯  CARD16 ­¥
¤®¯ã᪠îâáï ­¨ª ª¨¥ ï¢­ë¥ ®¯¥à æ¨¨, §  ¨áª«î祭¨¥¬ ¯à¨á¢ ¨¢ ­¨ï.
à¥®¡à §®¢ ­¨ï CARD16 -> INTEGER ¨ INTEGER -> CARD16 ¬®£ãâ ¡ëâì ॠ«¨§®¢ ­ë
⠪:
 
PROCEDURE Card16ToInt(w: SYSTEM.CARD16): INTEGER;
VAR i: INTEGER;
BEGIN
SYSTEM.PUT(SYSTEM.ADR(i), w)
RETURN i
END Card16ToInt;
 
PROCEDURE IntToCard16(i: INTEGER): SYSTEM.CARD16;
VAR w: SYSTEM.CARD16;
BEGIN
SYSTEM.GET(SYSTEM.ADR(i), w)
RETURN w
END IntToCard16;
 
”㭪樨 ¯á¥¢¤®¬®¤ã«ï SYSTEM ­¥«ì§ï ¨á¯®«ì§®¢ âì ¢ ª®­áâ ­â­ëå ¢ëà ¦¥­¨ïå.
 
------------------------------------------------------------------------------
‘¨á⥬­ë¥ ä« £¨
 
à¨ ®¡ê¥­¨¨ ¯à®æ¥¤ãà­ëå ⨯®¢ ¨ £«®¡ «ì­ëå ¯à®æ¥¤ãà, ¯®á«¥ ª«î祢®£®
á«®¢  PROCEDURE ¬®¦¥â ¡ëâì 㪠§ ­ ä« £ ᮣ« è¥­¨ï ¢ë§®¢ : [stdcall], [cdecl]
¨«¨ [winapi].  ¯à¨¬¥à:
 
PROCEDURE [cdecl] MyProc(x, y, z: INTEGER): INTEGER;
 
…᫨ 㪠§ ­ ä« £ [winapi], â® ¯à¨­¨¬ ¥âáï ᮣ« è¥­¨¥ stdcall ¨
¯à®æ¥¤ãàã-äã­ªæ¨î ¬®¦­® ¢ë§¢ âì ª ª ᮡá⢥­­® ¯à®æ¥¤ãàã, ¢­¥ ¢ëà ¦¥­¨ï.
”« £ [winapi] ¤®áâ㯥­ ⮫쪮 ¤«ï ¯« âä®à¬ë Windows.
à¨ ®¡ê¥­¨¨ ⨯®¢-§ ¯¨á¥©, ¯®á«¥ ª«î祢®£® á«®¢  RECORD ¬®¦¥â ¡ëâì
㪠§ ­ ä« £ [noalign] ¨«¨ [union]. ”« £ [noalign] ®§­ ç ¥â ®âáãâá⢨¥
¢ëà ¢­¨¢ ­¨ï ¯®«¥© § ¯¨á¨,   ä« £ [union] ®§­ ç ¥â, ç⮠ᬥ饭¨ï ¢á¥å ¯®«¥©
§ ¯¨á¨ à ¢­ë ­ã«î, ¯à¨ í⮬ à §¬¥à § ¯¨á¨ à ¢¥­ à §¬¥àã ­ ¨¡®«ì襣® ¯®«ï.
‡ ¯¨á¨ RECORD [union] ... END ᮮ⢥âáâ¢ãîâ ®¡ê¥¤¨­¥­¨ï¬ (union) ¢ ï§ëª¥ C.
‡ ¯¨á¨ á á¨á⥬­ë¬¨ ä« £ ¬¨ ­¥ ¬®£ãâ ¨¬¥âì ¡ §®¢®£® ⨯  ¨ ­¥ ¬®£ãâ ¡ëâì
¡ §®¢ë¬¨ ⨯ ¬¨ ¤«ï ¤àã£¨å § ¯¨á¥©.
„«ï ¨á¯®«ì§®¢ ­¨ï á¨á⥬­ëå ä« £®¢, âॡã¥âáï ¨¬¯®àâ¨à®¢ âì SYSTEM.
 
------------------------------------------------------------------------------
Ž¯¥à â®à CASE
 
‘¨­â ªá¨á ®¯¥à â®à  CASE:
 
CaseStatement =
CASE Expression OF ‘ase {"|" ‘ase}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
 
 ¯à¨¬¥à:
 
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
 
‚ ¬¥âª å ¢ à¨ ­â®¢ ¬®¦­® ¨á¯®«ì§®¢ âì ª®­áâ ­â­ë¥ ¢ëà ¦¥­¨ï, ¢¥âª  ELSE
­¥®¡ï§ â¥«ì­ . …᫨ ­¥ ¢ë¯®«­¥­ ­¨ ®¤¨­ ¢ à¨ ­â ¨ ELSE ®âáãâáâ¢ã¥â, â®
¯à®£à ¬¬  ¯à¥à뢠¥âáï á ®è¨¡ª®© ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï.
 
------------------------------------------------------------------------------
à®¢¥àª  ¨ ®åà ­  ⨯  ­ã«¥¢®£® 㪠§ â¥«ï
 
Žà¨£¨­ «ì­®¥ á®®¡é¥­¨¥ ® ï§ëª¥ ­¥ ®¯à¥¤¥«ï¥â ¯®¢¥¤¥­¨¥ ¯à®£à ¬¬ë ¯à¨
¢ë¯®«­¥­¨¨ ®åà ­ë p(T) ¨ ¯à®¢¥àª¨ ⨯  p IS T ¯à¨ p = NIL. ‚® ¬­®£¨å
Oberon-ॠ«¨§ æ¨ïå ¢ë¯®«­¥­¨¥ â ª®© ®¯¥à æ¨¨ ¯à¨¢®¤¨â ª ®è¨¡ª¥ ¢à¥¬¥­¨
¢ë¯®«­¥­¨ï. ‚ ¤ ­­®© ॠ«¨§ æ¨¨ ®åà ­  ⨯  ­ã«¥¢®£® 㪠§ â¥«ï ­¥ ¯à¨¢®¤¨â ª
®è¨¡ª¥,   ¯à®¢¥àª  ⨯  ¤ ¥â १ã«ìâ â FALSE. ‚ à拉 á«ãç ¥¢ íâ® ¯®§¢®«ï¥â
§­ ç¨â¥«ì­® ᮪à â¨âì ç áâ®â㠯ਬ¥­¥­¨ï ®åà ­ë ⨯ .
 
------------------------------------------------------------------------------
„®¯®«­¨â¥«ì­ë¥ áâ ­¤ àâ­ë¥ ¯à®æ¥¤ãàë
 
DISPOSE(VAR v: «î¡®©_㪠§ â¥«ì)
Žá¢®¡®¦¤ ¥â ¯ ¬ïâì, ¢ë¤¥«¥­­ãî ¯à®æ¥¤ãன NEW ¤«ï
¤¨­ ¬¨ç¥áª®© ¯¥à¥¬¥­­®© v^, ¨ ¯à¨á¢ ¨¢ ¥â ¯¥à¥¬¥­­®© v
§­ ç¥­¨¥ NIL.
 
LSR(x, n: INTEGER): INTEGER
‹®£¨ç¥áª¨© ᤢ¨£ x ­  n ¡¨â ¢¯à ¢®.
 
MIN(a, b: INTEGER): INTEGER
Œ¨­¨¬ã¬ ¨§ ¤¢ãå §­ ç¥­¨©.
 
MAX(a, b: INTEGER): INTEGER
Œ ªá¨¬ã¬ ¨§ ¤¢ãå §­ ç¥­¨©.
 
BITS(x: INTEGER): SET
ˆ­â¥à¯à¥â¨àã¥â x ª ª §­ ç¥­¨¥ ⨯  SET.
‚믮«­ï¥âáï ­  íâ ¯¥ ª®¬¯¨«ï樨.
 
LENGTH(s: ARRAY OF CHAR): INTEGER
„«¨­  0X-§ ¢¥à襭­®© áâப¨ s, ¡¥§ ãç¥â  ᨬ¢®«  0X.
…᫨ ᨬ¢®« 0X ®âáãâáâ¢ã¥â, äã­ªæ¨ï ¢®§¢à é ¥â ¤«¨­ã
¬ áᨢ  s.
 
------------------------------------------------------------------------------
DIV ¨ MOD
 
x y x DIV y x MOD y
 
5 3 1 2
-5 3 -2 1
5 -3 -2 -1
-5 -3 1 -2
 
------------------------------------------------------------------------------
‘ªàëâë¥ ¯ à ¬¥âàë ¯à®æ¥¤ãà
 
¥ª®â®àë¥ ¯à®æ¥¤ãàë ¬®£ãâ ¨¬¥âì áªàëâë¥ ¯ à ¬¥âàë, ®­¨ ®âáãâáâ¢ãîâ ¢ ᯨ᪥
ä®à¬ «ì­ëå ¯ à ¬¥â஢, ­® ãç¨â뢠îâáï ª®¬¯¨«ïâ®à®¬ ¯à¨ âà ­á«ï樨 ¢ë§®¢®¢.
â® ¢®§¬®¦­® ¢ á«¥¤ãîé¨å á«ãç ïå:
 
1. à®æ¥¤ãà  ¨¬¥¥â ä®à¬ «ì­ë© ¯ à ¬¥âà ®âªàëâë© ¬ áᨢ:
PROCEDURE Proc(x: ARRAY OF ARRAY OF LONGREAL);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(SYSTEM.ADR(x), LEN(x), LEN(x[0])
2. à®æ¥¤ãà  ¨¬¥¥â ä®à¬ «ì­ë© ¯ à ¬¥âà-¯¥à¥¬¥­­ãî ⨯  RECORD:
PROCEDURE Proc(VAR x: Rec);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
3. à®æ¥¤ãà  ï¢«ï¥âáï ¢«®¦¥­­®©, £«ã¡¨­  ¢«®¦¥­¨ï k,
¤«ï £«®¡ «ì­ëå ¯à®æ¥¤ãà k = 0:
PROCEDURE Proc(p1, ..., pn);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(base(k - 1), base(k - 2), ..., base(0), p1, ..., pn),
£¤¥ base(m) -  ¤à¥á ¡ §ë ª ¤à  áâíª  ®å¢ â뢠î饩 ¯à®æ¥¤ãàë £«ã¡¨­ë
¢«®¦¥­¨ï m (¨á¯®«ì§ã¥âáï ¤«ï ¤®áâ㯠 ª «®ª «ì­ë¬ ¯¥à¥¬¥­­ë¬
®å¢ â뢠î饩 ¯à®æ¥¤ãàë)
 
------------------------------------------------------------------------------
Œ®¤ã«ì RTL
 
‚ᥠ¯à®£à ¬¬ë ­¥ï¢­® ¨á¯®«ì§ãîâ ¬®¤ã«ì RTL. Š®¬¯¨«ïâ®à â࠭᫨àã¥â
­¥ª®â®àë¥ ®¯¥à æ¨¨ (¯à®¢¥àª  ¨ ®åà ­  ⨯ , áà ¢­¥­¨¥ áâப, á®®¡é¥­¨ï ®¡
®è¨¡ª å ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¨ ¤à.) ª ª ¢ë§®¢ë ¯à®æ¥¤ãà í⮣® ¬®¤ã«ï. ¥
á«¥¤ã¥â ® ¢ë§ë¢ âì í⨠¯à®æ¥¤ãàë, §  ¨áª«î祭¨¥¬ ¯à®æ¥¤ãàë SetClose:
 
PROCEDURE SetClose(proc: PROC), £¤¥ TYPE PROC = PROCEDURE
 
SetClose ­ §­ ç ¥â ¯à®æ¥¤ãàã proc (¡¥§ ¯ à ¬¥â஢) ¢ë§ë¢ ¥¬®© ¯à¨ ¢ë£à㧪¥
dll-¡¨¡«¨®â¥ª¨ (Windows), ¥á«¨ ¯à¨«®¦¥­¨¥ ª®¬¯¨«¨àã¥âáï ª ª Windows DLL. „«ï
¯à®ç¨å ⨯®¢ ¯à¨«®¦¥­¨© ¨ ¯« âä®à¬ ¢ë§®¢ ¯à®æ¥¤ãàë SetClose ­¥ ¢«¨ï¥â ­ 
¯®¢¥¤¥­¨¥ ¯à®£à ¬¬ë.
‘®®¡é¥­¨ï ®¡ ®è¨¡ª å ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¢ë¢®¤ïâáï ¢ ¤¨ «®£®¢ëå ®ª­ å
(Windows), ¢ â¥à¬¨­ « (Linux), ­  ¤®áªã ®â« ¤ª¨ (KolibriOS).
 
------------------------------------------------------------------------------
Œ®¤ã«ì API
 
‘ãé¥áâ¢ãîâ âਠॠ«¨§ æ¨¨ ¬®¤ã«ï API: ¤«ï Windows, Linux ¨ KolibriOS. Š ª ¨
¬®¤ã«ì RTL, ¬®¤ã«ì API ­¥ ¯à¥¤­ §­ ç¥­ ¤«ï ¯àאַ£® ¨á¯®«ì§®¢ ­¨ï. Ž­
®¡¥á¯¥ç¨¢ ¥â ªà®áᯫ âä®à¬¥­­®áâì ª®¬¯¨«ïâ®à .
 
------------------------------------------------------------------------------
ƒ¥­¥à æ¨ï ¨á¯®«­ï¥¬ëå ä ©«®¢ DLL
 
 §à¥è ¥âáï íªá¯®àâ¨à®¢ âì ⮫쪮 ¯à®æ¥¤ãàë. „«ï í⮣®, ¯à®æ¥¤ãà  ¤®«¦­ 
­ å®¤¨âìáï ¢ £« ¢­®¬ ¬®¤ã«¥ ¯à®£à ¬¬ë, ¨ ¥¥ ¨¬ï ¤®«¦­® ¡ëâì ®â¬¥ç¥­® ᨬ¢®«®¬
íªá¯®àâ  ("*"). KolibriOS DLL ¢á¥£¤  íªá¯®àâ¨àãîâ ¨¤¥­â¨ä¨ª â®àë "version"
(¢¥àá¨ï ¯à®£à ¬¬ë) ¨ "lib_init" -  ¤à¥á ¯à®æ¥¤ãàë ¨­¨æ¨ «¨§ æ¨¨ DLL:
 
PROCEDURE [stdcall] lib_init(): INTEGER
 
â  ¯à®æ¥¤ãà  ¤®«¦­  ¡ëâì ¢ë§¢ ­  ¯¥à¥¤ ¨á¯®«ì§®¢ ­¨¥¬ DLL.
à®æ¥¤ãà  ¢á¥£¤  ¢®§¢à é ¥â 1.
‚ ­ áâ®ï饥 ¢à¥¬ï £¥­¥à æ¨ï DLL ¤«ï Linux ­¥ ॠ«¨§®¢ ­ .
 
==============================================================================
==============================================================================
 
¨¡«¨®â¥ª  (KolibriOS)
 
------------------------------------------------------------------------------
MODULE Out - ª®­á®«ì­ë© ¢ë¢®¤
 
PROCEDURE Open
ä®à¬ «ì­® ®âªà뢠¥â ª®­á®«ì­ë© ¢ë¢®¤
 
PROCEDURE Int(x, width: INTEGER)
¢ë¢®¤ 楫®£® ç¨á«  x;
width - ª®«¨ç¥á⢮ §­ ª®¬¥áâ, ¨á¯®«ì§ã¥¬ëå ¤«ï ¢ë¢®¤ 
 
PROCEDURE Real(x: LONGREAL; width: INTEGER)
¢ë¢®¤ ¢¥é¥á⢥­­®£® ç¨á«  x ¢ ¯« ¢ î饬 ä®à¬ â¥;
width - ª®«¨ç¥á⢮ §­ ª®¬¥áâ, ¨á¯®«ì§ã¥¬ëå ¤«ï ¢ë¢®¤ 
 
PROCEDURE Char(x: CHAR)
¢ë¢®¤ ᨬ¢®«  x
 
PROCEDURE FixReal(x: LONGREAL; width, p: INTEGER)
¢ë¢®¤ ¢¥é¥á⢥­­®£® ç¨á«  x ¢ 䨪á¨à®¢ ­­®¬ ä®à¬ â¥;
width - ª®«¨ç¥á⢮ §­ ª®¬¥áâ, ¨á¯®«ì§ã¥¬ëå ¤«ï ¢ë¢®¤ ;
p - ª®«¨ç¥á⢮ §­ ª®¢ ¯®á«¥ ¤¥áïâ¨ç­®© â®çª¨
 
PROCEDURE Ln
¯¥à¥å®¤ ­  á«¥¤ãîéãî áâபã
 
PROCEDURE String(s: ARRAY OF CHAR)
¢ë¢®¤ áâப¨ s
 
------------------------------------------------------------------------------
MODULE In - ª®­á®«ì­ë© ¢¢®¤
 
VAR Done: BOOLEAN
¯à¨­¨¬ ¥â §­ ç¥­¨¥ TRUE ¢ á«ãç ¥ ãᯥ譮£® ¢ë¯®«­¥­¨ï
®¯¥à æ¨¨ ¢¢®¤ , ¨­ ç¥ FALSE
 
PROCEDURE Open
ä®à¬ «ì­® ®âªà뢠¥â ª®­á®«ì­ë© ¢¢®¤,
â ª¦¥ ¯à¨á¢ ¨¢ ¥â ¯¥à¥¬¥­­®© Done §­ ç¥­¨¥ TRUE
 
PROCEDURE Int(VAR x: INTEGER)
¢¢®¤ ç¨á«  ⨯  INTEGER
 
PROCEDURE Char(VAR x: CHAR)
¢¢®¤ ᨬ¢®« 
 
PROCEDURE Real(VAR x: REAL)
¢¢®¤ ç¨á«  ⨯  REAL
 
PROCEDURE LongReal(VAR x: LONGREAL)
¢¢®¤ ç¨á«  ⨯  LONGREAL
 
PROCEDURE String(VAR s: ARRAY OF CHAR)
¢¢®¤ áâப¨
 
PROCEDURE Ln
®¦¨¤ ­¨¥ ­ ¦ â¨ï ENTER
 
------------------------------------------------------------------------------
MODULE Console - ¤®¯®«­¨â¥«ì­ë¥ ¯à®æ¥¤ãàë ª®­á®«ì­®£® ¢ë¢®¤ 
 
CONST
 
‘«¥¤ãî騥 ª®­áâ ­âë ®¯à¥¤¥«ïîâ 梥⠪®­á®«ì­®£® ¢ë¢®¤ 
 
Black = 0 Blue = 1 Green = 2
Cyan = 3 Red = 4 Magenta = 5
Brown = 6 LightGray = 7 DarkGray = 8
LightBlue = 9 LightGreen = 10 LightCyan = 11
LightRed = 12 LightMagenta = 13 Yellow = 14
White = 15
 
PROCEDURE Cls
®ç¨á⪠ ®ª­  ª®­á®«¨
 
PROCEDURE SetColor(FColor, BColor: INTEGER)
ãáâ ­®¢ª  æ¢¥â  ª®­á®«ì­®£® ¢ë¢®¤ : FColor - 梥â ⥪áâ ,
BColor - 梥â ä®­ , ¢®§¬®¦­ë¥ §­ ç¥­¨ï - ¢ë襯¥à¥ç¨á«¥­­ë¥
ª®­áâ ­âë
 
PROCEDURE SetCursor(x, y: INTEGER)
ãáâ ­®¢ª  ªãàá®à  ª®­á®«¨ ¢ ¯®§¨æ¨î (x, y)
 
PROCEDURE GetCursor(VAR x, y: INTEGER)
§ ¯¨á뢠¥â ¢ ¯ à ¬¥âàë ⥪ã騥 ª®®à¤¨­ âë ªãàá®à  ª®­á®«¨
 
PROCEDURE GetCursorX(): INTEGER
¢®§¢à é ¥â ⥪ãéãî x-ª®®à¤¨­ âã ªãàá®à  ª®­á®«¨
 
PROCEDURE GetCursorY(): INTEGER
¢®§¢à é ¥â ⥪ãéãî y-ª®®à¤¨­ âã ªãàá®à  ª®­á®«¨
 
------------------------------------------------------------------------------
MODULE ConsoleLib - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ console.obj
 
------------------------------------------------------------------------------
MODULE Math - ¬ â¥¬ â¨ç¥áª¨¥ ä㭪樨
 
CONST
 
pi = 3.141592653589793D+00
e = 2.718281828459045D+00
 
VAR
 
Inf, nInf: LONGREAL
¯®«®¦¨â¥«ì­ ï ¨ ®âà¨æ â¥«ì­ ï ¡¥áª®­¥ç­®áâì
 
PROCEDURE IsNan(x: LONGREAL): BOOLEAN
¢®§¢à é ¥â TRUE, ¥á«¨ x - ­¥ ç¨á«®
 
PROCEDURE IsInf(x: LONGREAL): BOOLEAN
¢®§¢à é ¥â TRUE, ¥á«¨ x - ¡¥áª®­¥ç­®áâì
 
PROCEDURE sqrt(x: LONGREAL): LONGREAL
ª¢ ¤à â­ë© ª®à¥­ì x
 
PROCEDURE exp(x: LONGREAL): LONGREAL
íªá¯®­¥­â  x
 
PROCEDURE ln(x: LONGREAL): LONGREAL
­ âãà «ì­ë© «®£ à¨ä¬ x
 
PROCEDURE sin(x: LONGREAL): LONGREAL
ᨭãá x
 
PROCEDURE cos(x: LONGREAL): LONGREAL
ª®á¨­ãá x
 
PROCEDURE tan(x: LONGREAL): LONGREAL
â ­£¥­á x
 
PROCEDURE arcsin(x: LONGREAL): LONGREAL
 àªá¨­ãá x
 
PROCEDURE arccos(x: LONGREAL): LONGREAL
 àªª®á¨­ãá x
 
PROCEDURE arctan(x: LONGREAL): LONGREAL
 àªâ ­£¥­á x
 
PROCEDURE arctan2(y, x: LONGREAL): LONGREAL
 àªâ ­£¥­á y/x
 
PROCEDURE power(base, exponent: LONGREAL): LONGREAL
¢®§¢¥¤¥­¨¥ ç¨á«  base ¢ á⥯¥­ì exponent
 
PROCEDURE log(base, x: LONGREAL): LONGREAL
«®£ à¨ä¬ x ¯® ®á­®¢ ­¨î base
 
PROCEDURE sinh(x: LONGREAL): LONGREAL
£¨¯¥à¡®«¨ç¥áª¨© ᨭãá x
 
PROCEDURE cosh(x: LONGREAL): LONGREAL
£¨¯¥à¡®«¨ç¥áª¨© ª®á¨­ãá x
 
PROCEDURE tanh(x: LONGREAL): LONGREAL
£¨¯¥à¡®«¨ç¥áª¨© â ­£¥­á x
 
PROCEDURE arcsinh(x: LONGREAL): LONGREAL
®¡à â­ë© £¨¯¥à¡®«¨ç¥áª¨© ᨭãá x
 
PROCEDURE arccosh(x: LONGREAL): LONGREAL
®¡à â­ë© £¨¯¥à¡®«¨ç¥áª¨© ª®á¨­ãá x
 
PROCEDURE arctanh(x: LONGREAL): LONGREAL
®¡à â­ë© £¨¯¥à¡®«¨ç¥áª¨© â ­£¥­á x
 
PROCEDURE round(x: LONGREAL): LONGREAL
®ªà㣫¥­¨¥ x ¤® ¡«¨¦ ©è¥£® 楫®£®
 
PROCEDURE frac(x: LONGREAL): LONGREAL;
¤à®¡­ ï ç áâì ç¨á«  x
 
PROCEDURE floor(x: LONGREAL): LONGREAL
­ ¨¡®«ì襥 楫®¥ ç¨á«® (¯à¥¤áâ ¢«¥­¨¥ ª ª LONGREAL),
­¥ ¡®«ìè¥ x: floor(1.2) = 1.0
 
PROCEDURE ceil(x: LONGREAL): LONGREAL
­ ¨¬¥­ì襥 楫®¥ ç¨á«® (¯à¥¤áâ ¢«¥­¨¥ ª ª LONGREAL),
­¥ ¬¥­ìè¥ x: ceil(1.2) = 2.0
 
PROCEDURE sgn(x: LONGREAL): INTEGER
¥á«¨ x > 0 ¢®§¢à é ¥â 1
¥á«¨ x < 0 ¢®§¢à é ¥â -1
¥á«¨ x = 0 ¢®§¢à é ¥â 0
 
------------------------------------------------------------------------------
MODULE Debug - ¢ë¢®¤ ­  ¤®áªã ®â« ¤ª¨
ˆ­â¥àä¥©á ª ª ¬®¤ã«ì Out
 
PROCEDURE Open
®âªà뢠¥â ¤®áªã ®â« ¤ª¨
 
------------------------------------------------------------------------------
MODULE File - à ¡®â  á ä ©«®¢®© á¨á⥬®©
 
TYPE
 
FNAME = ARRAY 520 OF CHAR
 
FS = POINTER TO rFS
 
rFS = RECORD (* ¨­ä®à¬ æ¨®­­ ï áâàãªâãà  ä ©«  *)
subfunc, pos, hpos, bytes, buffer: INTEGER;
name: FNAME
END
 
FD = POINTER TO rFD
 
rFD = RECORD (* áâàãªâãà  ¡«®ª  ¤ ­­ëå ¢å®¤  ª â «®£  *)
attr: INTEGER;
ntyp: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create, date_create,
time_access, date_access,
time_modif, date_modif,
size, hsize: INTEGER;
name: FNAME
END
 
CONST
 
SEEK_BEG = 0
SEEK_CUR = 1
SEEK_END = 2
 
PROCEDURE Load(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
‡ £à㦠¥â ¢ ¯ ¬ïâì ä ©« á ¨¬¥­¥¬ FName, § ¯¨á뢠¥â ¢ ¯ à ¬¥âà
size à §¬¥à ä ©« , ¢®§¢à é ¥â  ¤à¥á § £à㦥­­®£® ä ©« 
¨«¨ 0 (®è¨¡ª ). à¨ ­¥®¡å®¤¨¬®áâ¨, à á¯ ª®¢ë¢ ¥â
ä ©« (kunpack).
 
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN
‡ ¯¨á뢠¥â áâàãªâãàã ¡«®ª  ¤ ­­ëå ¢å®¤  ª â «®£  ¤«ï ä ©« 
¨«¨ ¯ ¯ª¨ á ¨¬¥­¥¬ FName ¢ ¯ à ¬¥âà Info.
à¨ ®è¨¡ª¥ ¢®§¢à é ¥â FALSE.
 
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN
¢®§¢à é ¥â TRUE, ¥á«¨ ä ©« á ¨¬¥­¥¬ FName áãé¥áâ¢ã¥â
 
PROCEDURE Close(VAR F: FS)
®á¢®¡®¦¤ ¥â ¯ ¬ïâì, ¢ë¤¥«¥­­ãî ¤«ï ¨­ä®à¬ æ¨®­­®© áâàãªâãàë
ä ©«  F ¨ ¯à¨á¢ ¨¢ ¥â F §­ ç¥­¨¥ NIL
 
PROCEDURE Open(FName: ARRAY OF CHAR): FS
¢®§¢à é ¥â 㪠§ â¥«ì ­  ¨­ä®à¬ æ¨®­­ãî áâàãªâãàã ä ©«  á
¨¬¥­¥¬ FName, ¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â NIL
 
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN
㤠«ï¥â ä ©« á ¨¬¥­¥¬ FName, ¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â FALSE
 
PROCEDURE Seek(F: FS; Offset, Origin: INTEGER): INTEGER
ãáâ ­ ¢«¨¢ ¥â ¯®§¨æ¨î ç⥭¨ï-§ ¯¨á¨ ä ©«  F ­  Offset,
®â­®á¨â¥«ì­® Origin = (SEEK_BEG - ­ ç «® ä ©« ,
SEEK_CUR - ⥪ãé ï ¯®§¨æ¨ï, SEEK_END - ª®­¥æ ä ©« ),
¢®§¢à é ¥â ¯®§¨æ¨î ®â­®á¨â¥«ì­® ­ ç «  ä ©« , ­ ¯à¨¬¥à:
Seek(F, 0, SEEK_END)
ãáâ ­ ¢«¨¢ ¥â ¯®§¨æ¨î ­  ª®­¥æ ä ©«  ¨ ¢®§¢à é ¥â ¤«¨­ã
ä ©« ; ¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â -1
 
PROCEDURE Read(F: FS; Buffer, Count: INTEGER): INTEGER
—¨â ¥â ¤ ­­ë¥ ¨§ ä ©«  ¢ ¯ ¬ïâì. F - 㪠§ â¥«ì ­ 
¨­ä®à¬ æ¨®­­ãî áâàãªâãàã ä ©« , Buffer -  ¤à¥á ®¡« áâ¨
¯ ¬ïâ¨, Count - ª®«¨ç¥á⢮ ¡ ©â, ª®â®à®¥ âॡã¥âáï ¯à®ç¨â âì
¨§ ä ©« ; ¢®§¢à é ¥â ª®«¨ç¥á⢮ ¡ ©â, ª®â®à®¥ ¡ë«® ¯à®ç¨â ­®
¨ ᮮ⢥âáâ¢ãî騬 ®¡à §®¬ ¨§¬¥­ï¥â ¯®§¨æ¨î ç⥭¨ï/§ ¯¨á¨ ¢
¨­ä®à¬ æ¨®­­®© áâàãªâãॠF.
 
PROCEDURE Write(F: FS; Buffer, Count: INTEGER): INTEGER
‡ ¯¨á뢠¥â ¤ ­­ë¥ ¨§ ¯ ¬ï⨠¢ ä ©«. F - 㪠§ â¥«ì ­ 
¨­ä®à¬ æ¨®­­ãî áâàãªâãàã ä ©« , Buffer -  ¤à¥á ®¡« áâ¨
¯ ¬ïâ¨, Count - ª®«¨ç¥á⢮ ¡ ©â, ª®â®à®¥ âॡã¥âáï § ¯¨á âì
¢ ä ©«; ¢®§¢à é ¥â ª®«¨ç¥á⢮ ¡ ©â, ª®â®à®¥ ¡ë«® § ¯¨á ­® ¨
ᮮ⢥âáâ¢ãî騬 ®¡à §®¬ ¨§¬¥­ï¥â ¯®§¨æ¨î ç⥭¨ï/§ ¯¨á¨ ¢
¨­ä®à¬ æ¨®­­®© áâàãªâãॠF.
 
PROCEDURE Create(FName: ARRAY OF CHAR): FS
ᮧ¤ ¥â ­®¢ë© ä ©« á ¨¬¥­¥¬ FName (¯®«­®¥ ¨¬ï), ¢®§¢à é ¥â
㪠§ â¥«ì ­  ¨­ä®à¬ æ¨®­­ãî áâàãªâãàã ä ©« ,
¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â NIL
 
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN
ᮧ¤ ¥â ¯ ¯ªã á ¨¬¥­¥¬ DirName, ¢á¥ ¯à®¬¥¦ãâ®ç­ë¥ ¯ ¯ª¨
¤®«¦­ë áãé¥á⢮¢ âì, ¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â FALSE
 
PROCEDURE DeleteDir(DirName: ARRAY OF CHAR): BOOLEAN
㤠«ï¥â ¯ãáâãî ¯ ¯ªã á ¨¬¥­¥¬ DirName,
¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â FALSE
 
PROCEDURE DirExists(DirName: ARRAY OF CHAR): BOOLEAN
¢®§¢à é ¥â TRUE, ¥á«¨ ¯ ¯ª  á ¨¬¥­¥¬ DirName áãé¥áâ¢ã¥â
 
------------------------------------------------------------------------------
MODULE Read - ç⥭¨¥ ®á­®¢­ëå ⨯®¢ ¤ ­­ëå ¨§ ä ©«  F
 
à®æ¥¤ãàë ¢®§¢à é îâ TRUE ¢ á«ãç ¥ ãᯥ譮© ®¯¥à æ¨¨ ç⥭¨ï ¨
ᮮ⢥âáâ¢ãî騬 ®¡à §®¬ ¨§¬¥­ïîâ ¯®§¨æ¨î ç⥭¨ï/§ ¯¨á¨ ¢
¨­ä®à¬ æ¨®­­®© áâàãªâãॠF
 
PROCEDURE Char(F: File.FS; VAR x: CHAR): BOOLEAN
 
PROCEDURE Int(F: File.FS; VAR x: INTEGER): BOOLEAN
 
PROCEDURE Real(F: File.FS; VAR x: REAL): BOOLEAN
 
PROCEDURE LongReal(F: File.FS; VAR x: LONGREAL): BOOLEAN
 
PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN
 
PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN
 
PROCEDURE Card16(F: File.FS; VAR x: SYSTEM.CARD16): BOOLEAN
 
------------------------------------------------------------------------------
MODULE Write - § ¯¨áì ®á­®¢­ëå ⨯®¢ ¤ ­­ëå ¢ ä ©« F
 
à®æ¥¤ãàë ¢®§¢à é îâ TRUE ¢ á«ãç ¥ ãᯥ譮© ®¯¥à æ¨¨ § ¯¨á¨ ¨
ᮮ⢥âáâ¢ãî騬 ®¡à §®¬ ¨§¬¥­ïîâ ¯®§¨æ¨î ç⥭¨ï/§ ¯¨á¨ ¢
¨­ä®à¬ æ¨®­­®© áâàãªâãॠF
 
PROCEDURE Char(F: File.FS; x: CHAR): BOOLEAN
 
PROCEDURE Int(F: File.FS; x: INTEGER): BOOLEAN
 
PROCEDURE Real(F: File.FS; x: REAL): BOOLEAN
 
PROCEDURE LongReal(F: File.FS; x: LONGREAL): BOOLEAN
 
PROCEDURE Boolean(F: File.FS; x: BOOLEAN): BOOLEAN
 
PROCEDURE Set(F: File.FS; x: SET): BOOLEAN
 
PROCEDURE Card16(F: File.FS; x: SYSTEM.CARD16): BOOLEAN
 
------------------------------------------------------------------------------
MODULE DateTime - ¤ â , ¢à¥¬ï
 
CONST ERR = -7.0D5
 
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER)
§ ¯¨á뢠¥â ¢ ¯ à ¬¥âàë ª®¬¯®­¥­âë ⥪ã饩 á¨á⥬­®© ¤ âë ¨
¢à¥¬¥­¨
 
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL
¢®§¢à é ¥â ¤ âã, ¯®«ã祭­ãî ¨§ ª®¬¯®­¥­â®¢
Year, Month, Day, Hour, Min, Sec;
¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â ª®­áâ ­âã ERR = -7.0D5
 
PROCEDURE Decode(Date: LONGREAL; VAR Year, Month, Day,
Hour, Min, Sec: INTEGER): BOOLEAN
¨§¢«¥ª ¥â ª®¬¯®­¥­âë
Year, Month, Day, Hour, Min, Sec ¨§ ¤ âë Date;
¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â FALSE
 
------------------------------------------------------------------------------
MODULE Args - ¯ à ¬¥âàë ¯à®£à ¬¬ë
 
VAR argc: INTEGER
ª®«¨ç¥á⢮ ¯ à ¬¥â஢ ¯à®£à ¬¬ë, ¢ª«îç ï ¨¬ï
¨á¯®«­ï¥¬®£® ä ©« 
 
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR)
§ ¯¨á뢠¥â ¢ áâபã s n-© ¯ à ¬¥âà ¯à®£à ¬¬ë,
­ã¬¥à æ¨ï ¯ à ¬¥â஢ ®â 0 ¤® argc - 1,
­ã«¥¢®© ¯ à ¬¥âà -- ¨¬ï ¨á¯®«­ï¥¬®£® ä ©« 
 
------------------------------------------------------------------------------
MODULE KOSAPI
 
PROCEDURE sysfunc1(arg1: INTEGER): INTEGER
PROCEDURE sysfunc2(arg1, arg2: INTEGER): INTEGER
...
PROCEDURE sysfunc7(arg1, arg2, ..., arg7: INTEGER): INTEGER
Ž¡¥à⪨ ¤«ï ä㭪権 API ï¤à  KolibriOS.
arg1 .. arg7 ᮮ⢥âáâ¢ãîâ ॣ¨áâà ¬
eax, ebx, ecx, edx, esi, edi, ebp;
¢®§¢à é îâ §­ ç¥­¨¥ ॣ¨áâà  eax ¯®á«¥ á¨á⥬­®£® ¢ë§®¢ .
 
PROCEDURE sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER
Ž¡¥à⪠ ¤«ï ä㭪権 API ï¤à  KolibriOS.
arg1 - ॣ¨áâà eax, arg2 - ॣ¨áâà ebx,
res2 - §­ ç¥­¨¥ ॣ¨áâà  ebx ¯®á«¥ á¨á⥬­®£® ¢ë§®¢ ;
¢®§¢à é ¥â §­ ç¥­¨¥ ॣ¨áâà  eax ¯®á«¥ á¨á⥬­®£® ¢ë§®¢ .
 
PROCEDURE malloc(size: INTEGER): INTEGER
‚뤥«ï¥â ¡«®ª ¯ ¬ïâ¨.
size - à §¬¥à ¡«®ª  ¢ ¡ ©â å,
¢®§¢à é ¥â  ¤à¥á ¢ë¤¥«¥­­®£® ¡«®ª 
 
PROCEDURE free(ptr: INTEGER): INTEGER
Žá¢®¡®¦¤ ¥â à ­¥¥ ¢ë¤¥«¥­­ë© ¡«®ª ¯ ¬ïâ¨ á  ¤à¥á®¬ ptr,
¢®§¢à é ¥â 0
 
PROCEDURE realloc(ptr, size: INTEGER): INTEGER
¥à¥à á¯à¥¤¥«ï¥â ¡«®ª ¯ ¬ïâ¨,
ptr -  ¤à¥á à ­¥¥ ¢ë¤¥«¥­­®£® ¡«®ª ,
size - ­®¢ë© à §¬¥à,
¢®§¢à é ¥â 㪠§ â¥«ì ­  ¯¥à¥à á¯à¥¤¥«¥­­ë© ¡«®ª,
0 ¯à¨ ®è¨¡ª¥
 
PROCEDURE GetCommandLine(): INTEGER
‚®§¢à é ¥â  ¤à¥á áâப¨ ¯ à ¬¥â஢
 
PROCEDURE GetName(): INTEGER
‚®§¢à é ¥â  ¤à¥á áâப¨ á ¨¬¥­¥¬ ¯à®£à ¬¬ë
 
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER
‡ £à㦠¥â DLL á ¯®«­ë¬ ¨¬¥­¥¬ name. ‚®§¢à é ¥â  ¤à¥á â ¡«¨æë
íªá¯®àâ . à¨ ®è¨¡ª¥ ¢®§¢à é ¥â 0.
 
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER
name - ¨¬ï ¯à®æ¥¤ãàë
lib -  ¤à¥á â ¡«¨æë íªá¯®àâ  DLL
‚®§¢à é ¥â  ¤à¥á ¯à®æ¥¤ãàë. à¨ ®è¨¡ª¥ ¢®§¢à é ¥â 0.
 
------------------------------------------------------------------------------
MODULE ColorDlg - à ¡®â  á ¤¨ «®£®¬ "Color Dialog"
 
TYPE
 
Dialog = POINTER TO RECORD (* áâàãªâãà  ¤¨ «®£  *)
status: INTEGER (* á®áâ®ï­¨¥ ¤¨ «®£ :
0 - ¯®«ì§®¢ â¥«ì ­ ¦ « Cancel
1 - ¯®«ì§®¢ â¥«ì ­ ¦ « OK
2 - ¤¨ «®£ ®âªàëâ *)
 
color: INTEGER (* ¢ë¡à ­­ë© 梥â *)
END
 
PROCEDURE Create(draw_window: DRAW_WINDOW): Dialog
ᮧ¤ âì ¤¨ «®£
draw_window - ¯à®æ¥¤ãà  ¯¥à¥à¨á®¢ª¨ ®á­®¢­®£® ®ª­ 
(TYPE DRAW_WINDOW = PROCEDURE);
¯à®æ¥¤ãà  ¢®§¢à é ¥â 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£ 
 
PROCEDURE Show(cd: Dialog)
¯®ª § âì ¤¨ «®£
cd - 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£ , ª®â®àë© ¡ë« ᮧ¤ ­ à ­¥¥
¯à®æ¥¤ãன Create
 
PROCEDURE Destroy(VAR cd: Dialog)
ã­¨ç⮦¨âì ¤¨ «®£
cd - 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£ 
 
------------------------------------------------------------------------------
MODULE OpenDlg - à ¡®â  á ¤¨ «®£®¬ "Open Dialog"
 
TYPE
 
Dialog = POINTER TO RECORD (* áâàãªâãà  ¤¨ «®£  *)
status: INTEGER (* á®áâ®ï­¨¥ ¤¨ «®£ :
0 - ¯®«ì§®¢ â¥«ì ­ ¦ « Cancel
1 - ¯®«ì§®¢ â¥«ì ­ ¦ « OK
2 - ¤¨ «®£ ®âªàëâ *)
 
FileName: ARRAY 4096 OF CHAR (* ¨¬ï ¢ë¡à ­­®£® ä ©«  *)
FilePath: ARRAY 4096 OF CHAR (* ¯®«­®¥ ¨¬ï ¢ë¡à ­­®£®
ä ©«  *)
END
 
PROCEDURE Create(draw_window: DRAW_WINDOW; type: INTEGER; def_path,
filter: ARRAY OF CHAR): Dialog
ᮧ¤ âì ¤¨ «®£
draw_window - ¯à®æ¥¤ãà  ¯¥à¥à¨á®¢ª¨ ®á­®¢­®£® ®ª­ 
(TYPE DRAW_WINDOW = PROCEDURE)
type - ⨯ ¤¨ «®£ 
0 - ®âªàëâì
1 - á®åà ­¨âì
2 - ¢ë¡à âì ¯ ¯ªã
def_path - ¯ãâì ¯® 㬮«ç ­¨î, ¯ ¯ª  def_path ¡ã¤¥â ®âªàëâ 
¯à¨ ¯¥à¢®¬ § ¯ã᪥ ¤¨ «®£ 
filter - ¢ áâப¥ § ¯¨á ­® ¯¥à¥ç¨á«¥­¨¥ à áè¨à¥­¨© ä ©«®¢,
ª®â®àë¥ ¡ã¤ãâ ¯®ª § ­ë ¢ ¤¨ «®£®¢®¬ ®ª­¥, à áè¨à¥­¨ï
à §¤¥«ïîâáï ᨬ¢®«®¬ "|", ­ ¯à¨¬¥à: "ASM|TXT|INI"
¯à®æ¥¤ãà  ¢®§¢à é ¥â 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£ 
 
PROCEDURE Show(od: Dialog; Width, Height: INTEGER)
¯®ª § âì ¤¨ «®£
od - 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£ , ª®â®àë© ¡ë« ᮧ¤ ­ à ­¥¥
¯à®æ¥¤ãன Create
Width ¨ Height - è¨à¨­  ¨ ¢ëá®â  ¤¨ «®£®¢®£® ®ª­ 
 
PROCEDURE Destroy(VAR od: Dialog)
ã­¨ç⮦¨âì ¤¨ «®£
od - 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£ 
 
------------------------------------------------------------------------------
MODULE kfonts - à ¡®â  á kf-èà¨äâ ¬¨
 
CONST
 
bold = 1
italic = 2
underline = 4
strike_through = 8
smoothing = 16
bpp32 = 32
 
TYPE
 
TFont = POINTER TO TFont_desc (* 㪠§ â¥«ì ­  èà¨äâ *)
 
PROCEDURE LoadFont(file_name: ARRAY OF CHAR): TFont
§ £à㧨âì èà¨äâ ¨§ ä ©« 
file_name ¨¬ï kf-ä ©« 
१-â: 㪠§ â¥«ì ­  èà¨äâ/NIL (®è¨¡ª )
 
PROCEDURE SetSize(Font: TFont; font_size: INTEGER): BOOLEAN
ãáâ ­®¢¨âì à §¬¥à èà¨äâ 
Font 㪠§ â¥«ì ­  èà¨äâ
font_size à §¬¥à èà¨äâ 
१-â: TRUE/FALSE (®è¨¡ª )
 
PROCEDURE Enabled(Font: TFont; font_size: INTEGER): BOOLEAN
¯à®¢¥à¨âì, ¥áâì «¨ èà¨äâ, § ¤ ­­®£® à §¬¥à 
Font 㪠§ â¥«ì ­  èà¨äâ
font_size à §¬¥à èà¨äâ 
१-â: TRUE/FALSE (èà¨äâ  ­¥â)
 
PROCEDURE Destroy(VAR Font: TFont)
¢ë£à㧨âì èà¨äâ, ®á¢®¡®¤¨âì ¤¨­ ¬¨ç¥áªãî ¯ ¬ïâì
Font 㪠§ â¥«ì ­  èà¨äâ
à¨á¢ ¨¢ ¥â ¯¥à¥¬¥­­®© Font §­ ç¥­¨¥ NIL
 
PROCEDURE TextHeight(Font: TFont): INTEGER
¯®«ãç¨âì ¢ëá®âã áâப¨ ⥪áâ 
Font 㪠§ â¥«ì ­  èà¨äâ
१-â: ¢ëá®â  áâப¨ ⥪áâ  ¢ ¯¨ªá¥«ïå
 
PROCEDURE TextWidth(Font: TFont;
str, length, params: INTEGER): INTEGER
¯®«ãç¨âì è¨à¨­ã áâப¨ ⥪áâ 
Font 㪠§ â¥«ì ­  èà¨äâ
str  ¤à¥á áâப¨ ⥪áâ  ¢ ª®¤¨à®¢ª¥ Win-1251
length ª®«¨ç¥á⢮ ᨬ¢®«®¢ ¢ áâப¥ ¨«¨ -1, ¥á«¨ áâப 
§ ¢¥àè ¥âáï ­ã«¥¬
params ¯ à ¬¥âàë-ä« £¨ á¬. ­¨¦¥
१-â: è¨à¨­  áâப¨ ⥪áâ  ¢ ¯¨ªá¥«ïå
 
PROCEDURE TextOut(Font: TFont;
canvas, x, y, str, length, color, params: INTEGER)
¢ë¢¥á⨠⥪áâ ¢ ¡ãä¥à
¤«ï ¢ë¢®¤  ¡ãä¥à  ¢ ®ª­®, ¨á¯®«ì§®¢ âì ä.65 ¨«¨
ä.7 (¥á«¨ ¡ãä¥à 24-¡¨â­ë©)
Font 㪠§ â¥«ì ­  èà¨äâ
canvas  ¤à¥á £à ä¨ç¥áª®£® ¡ãä¥à 
áâàãªâãà  ¡ãä¥à :
Xsize dd
Ysize dd
picture rb Xsize * Ysize * 4 (32 ¡¨â )
¨«¨ Xsize * Ysize * 3 (24 ¡¨â )
x, y ª®®à¤¨­ âë ⥪áâ  ®â­®á¨â¥«ì­® «¥¢®£® ¢¥àå­¥£®
㣫  ¡ãä¥à 
str  ¤à¥á áâப¨ ⥪áâ  ¢ ª®¤¨à®¢ª¥ Win-1251
length ª®«¨ç¥á⢮ ᨬ¢®«®¢ ¢ áâப¥ ¨«¨ -1, ¥á«¨ áâப 
§ ¢¥àè ¥âáï ­ã«¥¬
color 梥â ⥪áâ  0x00RRGGBB
params ¯ à ¬¥âàë-ä« £¨:
1 ¦¨à­ë©
2 ªãàᨢ
4 ¯®¤ç¥àª­ãâë©
8 ¯¥à¥ç¥àª­ãâë©
16 ¯à¨¬¥­¨âì ᣫ ¦¨¢ ­¨¥
32 ¢ë¢®¤ ¢ 32-¡¨â­ë© ¡ãä¥à
¢®§¬®¦­® ¨á¯®«ì§®¢ ­¨¥ ä« £®¢ ¢ «î¡ëå á®ç¥â ­¨ïå
------------------------------------------------------------------------------
MODULE RasterWorks - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ Rasterworks.obj
------------------------------------------------------------------------------
MODULE libimg - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ libimg.obj
------------------------------------------------------------------------------
MODULE NetDevices - ®¡¥à⪠ ¤«ï ä.74 (à ¡®â  á á¥â¥¢ë¬¨ ãáâனá⢠¬¨)
------------------------------------------------------------------------------
/programs/develop/oberon07/Docs/Oberon07.report.fb2
0,0 → 1,693
<?xml encoding = "windows-1252"?>
<FictionBook xmlns:l="http://www.w3.org/1999/xlink" xmlns="http://www.gribuser.ru/xml/fictionbook/2.0">
<description></description>
<body>
<section><title><p>The Programming Language Oberon</p><p>Revision 22.9.2011</p><p>Niklaus Wirth</p></title>
<epigraph><p>Make it as simple as possible, but not simpler.</p><text-author>(A. Einstein)</text-author></epigraph>
<p>Table of Contents</p>
<empty-line/>
<p><a l:href="#1">1. Introduction</a></p>
<p><a l:href="#2">2. Syntax</a></p>
<p><a l:href="#3">3. Vocabulary</a></p>
<p><a l:href="#4">4. Declarations and scope rules</a></p>
<p><a l:href="#5">5. Constant declarations</a></p>
<p><a l:href="#6">6. Type declarations</a></p>
<p><a l:href="#7">7. Variable declarations</a></p>
<p><a l:href="#8">8. Expressions</a></p>
<p><a l:href="#9">9. Statements</a></p>
<p><a l:href="#10">10. Procedure declarations</a></p>
<p><a l:href="#11">11. Modules</a></p>
<p><a l:href="#app">Appendix: The Syntax of Oberon</a></p>
<section id="1"><title><p>1. Introduction</p></title>
<p>Oberon is a general-purpose programming language that evolved from Modula-2. Its principal new feature is the concept of type extension. It permits the construction of new data types on the basis of existing ones and to relate them.</p>
<p>This report is not intended as a programmer's tutorial. It is intentionally kept concise. Its function is to serve as a reference for programmers, implementors, and manual writers. What remains unsaid is mostly left so intentionally, either because it is derivable from stated rules of the language, or because it would unnecessarily restrict the freedom of implementors.</p>
<p>This document describes the language defined in 1988/90 as revised in 2007/11.</p>
</section>
<section id="2"><title><p>2. Syntax</p></title>
<p>A language is an infinite set of sentences, namely the sentences well formed according to its syntax. In Oberon, these sentences are called compilation units. Each unit is a finite sequence of <emphasis>symbols</emphasis> from a finite vocabulary. The vocabulary of Oberon consists of identifiers, numbers, strings, operators, delimiters, and comments. They are called <emphasis>lexical symbols</emphasis> and are composed of sequences of <emphasis>characters</emphasis>. (Note the distinction between symbols and characters.)</p>
<p>To describe the syntax, an extended Backus-Naur Formalism called EBNF is used. Brackets [ and ] denote optionality of the enclosed sentential form, and braces { and } denote its repetition (possibly 0 times). Syntactic entities (non-terminal symbols) are denoted by English words expressing their intuitive meaning. Symbols of the language vocabulary (terminal symbols) are denoted by strings enclosed in quote marks or by words in capital letters.</p>
</section>
<section id="3"><title><p>3. Vocabulary</p></title>
<p>The following lexical rules must be observed when composing symbols. Blanks and line breaks must not occur within symbols (except in comments, and blanks in strings). They are ignored unless they are essential to separate two consecutive symbols. Capital and lower-case letters are considered as being distinct.</p>
<p><emphasis>Identifiers</emphasis> are sequences of letters and digits. The first character must be a letter.</p>
<empty-line/>
<p><code> ident = letter {letter | digit}.</code></p>
<empty-line/>
<p>Examples:</p>
<empty-line/>
<p><code> x scan Oberon GetSymbol firstLetter</code></p>
<empty-line/>
<p><emphasis>Numbers</emphasis> are (unsigned) integers or real numbers. Integers are sequences of digits and may be followed by a suffix letter. If no suffix is specified, the representation is decimal. The suffix H indicates hexadecimal representation.</p>
<p>A <emphasis>real number</emphasis> always contains a decimal point. Optionally it may also contain a decimal scale factor. The letter E is pronounced as "times ten to the power of". A real number is of type REAL, unless it contains a scale factor with the letter D, in which case it is of type LONGREAL.</p>
<empty-line/>
<p><code> number = integer | real.</code></p>
<p><code> integer = digit {digit} | digit {hexDigit} "H".</code></p>
<p><code> real = digit {digit} "." {digit} [ScaleFactor].</code></p>
<p><code> ScaleFactor = ("E" | "D") ["+" | "-"] digit {digit}.</code></p>
<p><code> hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".</code></p>
<p><code> digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".</code></p>
<empty-line/>
<p>Examples:</p>
<empty-line/>
<p><code> 1987</code></p>
<p><code> 100H = 256</code></p>
<p><code> 12.3</code></p>
<p><code> 4.567E8 = 456700000</code></p>
<empty-line/>
<p><emphasis>Strings</emphasis> are sequences of characters enclosed in quote marks ("). A string cannot contain the delimiting quote mark. Alternatively, a single-character string may be specified by the ordinal number of the character in hexadecimal notation followed by an "X". The number of characters in a string is called the <emphasis>length</emphasis> of the string.</p>
<empty-line/>
<p><code> string = """ {character} """ | digit {hexdigit} "X" .</code></p>
<empty-line/>
<p>Examples:</p>
<empty-line/>
<p><code> "OBERON" "Don't worry!" 22X</code></p>
<empty-line/>
<p><emphasis>Operators</emphasis> and <emphasis>delimiters</emphasis> are the special characters, character pairs, or reserved words listed below. These reserved words consist exclusively of capital letters and cannot be used in the role of identifiers.</p>
<empty-line/>
<p><code> + := ARRAY IMPORT THEN</code></p>
<p><code> - ^ BEGIN IN TO</code></p>
<p><code> * = BY IS TRUE</code></p>
<p><code> / # CASE MOD TYPE</code></p>
<p><code> ~ &lt; CONST MODULE UNTIL</code></p>
<p><code> &amp; &gt; DIV NIL VAR</code></p>
<p><code> . &lt;= DO OF WHILE</code></p>
<p><code> , &gt;= ELSE OR</code></p>
<p><code> ; .. ELSIF POINTER</code></p>
<p><code> | : END PROCEDURE</code></p>
<p><code> ( ) FALSE RECORD</code></p>
<p><code> [ ] FOR REPEAT</code></p>
<p><code> { } IF RETURN</code></p>
<empty-line/>
<p><emphasis>Comments</emphasis> may be inserted between any two symbols in a program. They are arbitrary character sequences opened by the bracket (* and closed by *). Comments do not affect the meaning of a program. They may be nested.</p>
</section>
<section id="4"><title><p>4. Declarations and scope rules</p></title>
<p>Every identifier occurring in a program must be introduced by a declaration, unless it is a predefined identifier. Declarations also serve to specify certain permanent properties of an object, such as whether it is a constant, a type, a variable, or a procedure.</p>
<p>The identifier is then used to refer to the associated object. This is possible in those parts of a program only which are within the <emphasis>scope</emphasis> of the declaration. No identifier may denote more than one object within a given scope. The scope extends textually from the point of the declaration to the end of the block (procedure or module) to which the declaration belongs and hence to which the object is local. The scope rule has the following amendments:</p>
<p>1. If a type <emphasis>T</emphasis> is defined as POINTER TO T1 <a l:href="#6.4">(see 6.4)</a>, the identifier <emphasis>T1</emphasis> can be declared textually following the declaration of <emphasis>T</emphasis>, but it must lie within the same scope.</p>
<p>2. Field identifiers of a record declaration <a l:href="#6.3">(see 6.3)</a> are valid in field designators only.</p>
<p>In its declaration, an identifier in the global scope may be followed by an export mark (*) to indicate that it be <emphasis>exported</emphasis> from its declaring module. In this case, the identifier may be used in other modules, if they import the declaring module. The identifier is then prefixed by the identifier designating its module <a l:href="#11">(see Ch. 11)</a>. The prefix and the identifier are separated by a period and together are called a <emphasis>qualified identifier</emphasis>.</p>
<empty-line/>
<p><code> qualident = [ident "."] ident.</code></p>
<p><code> identdef = ident ["*"].</code></p>
<empty-line/>
<p>The following identifiers are predefined; their meaning is defined in section <a l:href="#6.1">6.1</a> (types) or <a l:href="#10.2">10.2</a> (procedures):</p>
<empty-line/>
<p><code> ABS ASR ASSERT BOOLEAN CHAR</code></p>
<p><code> CHR COPY DEC EXCL FLOOR</code></p>
<p><code> FLT INC INCL INTEGER LEN</code></p>
<p><code> LSL LONG LONGREAL NEW ODD</code></p>
<p><code> ORD PACK REAL ROR SET</code></p>
<p><code> SHORT UNPK</code></p>
</section>
<section id="5"><title><p>5. Constant declarations</p></title>
<p>A constant declaration associates an identifier with a constant value.</p>
<empty-line/>
<p><code> ConstantDeclaration = identdef "=" ConstExpression.</code></p>
<p><code> ConstExpression = expression.</code></p>
<empty-line/>
<p>A constant expression can be evaluated by a mere textual scan without actually executing the program. Its operands are constants <a l:href="#8">(see Ch. 8)</a>. Examples of constant declarations are:</p>
<empty-line/>
<p><code> N = 100</code></p>
<p><code> limit = 2*N - 1</code></p>
<p><code> all = {0 .. WordSize-1}</code></p>
<p><code> name = "Oberon"</code></p>
</section>
<section id="6"><title><p>6. Type declarations</p></title>
<p>A data type determines the set of values which variables of that type may assume, and the operators that are applicable. A type declaration is used to associate an identifier with a type. The types define the structure of variables of this type and, by implication, the operators that are applicable to components. There are two different structures, namely arrays and records, with different component selectors.</p>
<empty-line/>
<p><code> TypeDeclaration = identdef "=" StrucType.</code></p>
<p><code> StrucType = ArrayType | RecordType | PointerType | ProcedureType.</code></p>
<p><code> type = qualident | StrucType.</code></p>
<empty-line/>
<p>Examples:</p>
<empty-line/>
<p><code> Table = ARRAY N OF REAL</code></p>
<p><code> Tree = POINTER TO Node</code></p>
<p><code> Node = RECORD</code></p>
<p><code> key: INTEGER;</code></p>
<p><code> left, right: Tree</code></p>
<p><code> END</code></p>
<p><code> CenterNode = RECORD (Node)</code></p>
<p><code> name: ARRAY 32 OF CHAR;</code></p>
<p><code> subnode: Tree</code></p>
<p><code> END</code></p>
<p><code> Function = PROCEDURE (x: INTEGER): INTEGER</code></p>
<section id="6.1"><title><p>6.1. Basic types</p></title>
<p>The following basic types are denoted by predeclared identifiers. The associated operators are defined in <a l:href="#8.2">8.2</a>, and the predeclared function procedures in <a l:href="#10.2">10.2</a>. The values of a given basic type are the following:</p>
<empty-line/>
<p><code> BOOLEAN the truth values TRUE and FALSE</code></p>
<p><code> CHAR the characters of a standard character set</code></p>
<p><code> INTEGER the integers</code></p>
<p><code> REAL real numbers</code></p>
<p><code> LONGREAL real numbers</code></p>
<p><code> SET the sets of integers between 0 and 31</code></p>
<empty-line/>
<p>The type LONGREAL is intended to represent real numbers with a higher number of digits than REAL. However, the two types may be identical.</p>
</section>
<section id="6.2"><title><p>6.2. Array types</p></title>
<p>An array is a structure consisting of a fixed number of elements which are all of the same type, called the <emphasis>element type</emphasis>. The number of elements of an array is called its <emphasis>length</emphasis>. The elements of the array are designated by indices, which are integers between 0 and the length minus 1.</p>
<empty-line/>
<p><code> ArrayType = ARRAY length {"," length} OF type.</code></p>
<p><code> length = ConstExpression.</code></p>
<empty-line/>
<p>A declaration of the form</p>
<empty-line/>
<p><code> ARRAY N0, N1, ... , Nk OF T</code></p>
<p></p><empty-line/>is understood as an abbreviation of the declaration<empty-line/>
<p><code> ARRAY N0 OF</code></p>
<p><code> ARRAY N1 OF</code></p>
<p><code> ...</code></p>
<p><code> ARRAY Nk OF T</code></p>
<empty-line/>
<p>Examples of array types:</p>
<empty-line/>
<p><code> ARRAY N OF INTEGER</code></p>
<p><code> ARRAY 10, 20 OF REAL</code></p>
</section>
<section id="6.3"><title><p>6.3. Record types</p></title>
<p>A record type is a structure consisting of a fixed number of elements of possibly different types. The record type declaration specifies for each element, called <emphasis>field</emphasis>, its type and an identifier which denotes the field. The scope of these field identifiers is the record definition itself, but they are also visible within field designators <a l:href="#8.1">(see 8.1)</a> referring to elements of record variables.</p>
<empty-line/>
<p><code> RecordType = RECORD ["(" BaseType ")"] [FieldListSequence] END.</code></p>
<p><code> BaseType = qualident.</code></p>
<p><code> FieldListSequence = FieldList {";" FieldList}.</code></p>
<p><code> FieldList = IdentList ":" type.</code></p>
<p><code> IdentList = identdef {"," identdef}.</code></p>
<empty-line/>
<p>If a record type is exported, field identifiers that are to be visible outside the declaring module must be marked. They are called <emphasis>public fields</emphasis>; unmarked fields are called <emphasis>private fields</emphasis>.</p>
<p>Record types are extensible, i.e. a record type can be defined as an extension of another record type. In the examples above, <emphasis>CenterNode</emphasis> (directly) extends <emphasis>Node</emphasis>, which is the (direct) base type of <emphasis>CenterNode</emphasis>. More specifically, <emphasis>CenterNode</emphasis> extends <emphasis>Node</emphasis> with the fields <emphasis>name</emphasis> and <emphasis>subnode</emphasis>.</p>
<p><emphasis>Definition</emphasis>: A type <emphasis>T</emphasis> extends a type <emphasis>T0</emphasis>, if it equals <emphasis>T0</emphasis>, or if it directly extends an extension of <emphasis>T0</emphasis>. Conversely, a type <emphasis>T0</emphasis> is a base type of <emphasis>T</emphasis>, if it equals <emphasis>T</emphasis>, or if it is the direct base type of a base type of <emphasis>T</emphasis>.</p>
<p>Examples of record types:</p>
<empty-line/>
<p><code> RECORD day, month, year: INTEGER</code></p>
<p><code> END</code></p>
<p><code> RECORD</code></p>
<p><code> name, firstname: ARRAY 32 OF CHAR;</code></p>
<p><code> age: INTEGER;</code></p>
<p><code> salary: REAL</code></p>
<p><code> END</code></p>
</section>
<section id="6.4"><title><p>6.4. Pointer types</p></title>
<p>Variables of a pointer type <emphasis>P</emphasis> assume as values pointers to variables of some type <emphasis>T</emphasis>. It must be a record type. The pointer type <emphasis>P</emphasis> is said to be <emphasis>bound to T</emphasis>, and <emphasis>T</emphasis> is the <emphasis>pointer base type of P</emphasis>. Pointer types inherit the extension relation of their base types, if there is any. If a type <emphasis>T</emphasis> is an extension of <emphasis>T0</emphasis> and <emphasis>P</emphasis> is a pointer type bound to <emphasis>T</emphasis>, then <emphasis>P</emphasis> is also an extension of <emphasis>P0, the pointer type bound to T0</emphasis>.</p>
<empty-line/>
<p><code> PointerType = POINTER TO type.</code></p>
<empty-line/>
<p>If <emphasis>p</emphasis> is a variable of type P = POINTER TO T, then a call of the predefined procedure NEW(p) has the following effect <a l:href="#10.2">(see 10.2)</a>: A variable of type <emphasis>T</emphasis> is allocated in free storage, and a pointer to it is assigned to <emphasis>p</emphasis>. This pointer <emphasis>p</emphasis> is of type <emphasis>P</emphasis> and the referenced variable <emphasis>p^</emphasis> is of type <emphasis>T</emphasis>. Failure of allocation results in <emphasis>p</emphasis> obtaining the value <emphasis>NIL</emphasis>. Any pointer variable may be assigned the value <emphasis>NIL</emphasis>, which points to no variable at all.</p>
</section>
<section id="6.5"><title><p>6.5. Procedure types</p></title>
<p>Variables of a procedure type <emphasis>T</emphasis> have a procedure (or NIL) as value. If a procedure <emphasis>P</emphasis> is assigned to a procedure variable of type <emphasis>T</emphasis>, the (types of the) formal parameters of <emphasis>P</emphasis> must be the same as those indicated in the formal parameters of <emphasis>T</emphasis>. The same holds for the result type in the case of a function procedure <a l:href="#10.1">(see 10.1)</a>. <emphasis>P</emphasis> must not be declared local to another procedure, and neither can it be a standard procedure.</p>
<empty-line/>
<p><code> ProcedureType = PROCEDURE [FormalParameters].</code></p>
</section>
</section>
<section id="7"><title><p>7. Variable declarations</p></title>
<p>Variable declarations serve to introduce variables and associate them with identifiers that must be unique within the given scope. They also serve to associate fixed data types with the variables.</p>
<empty-line/>
<p><code> VariableDeclaration = IdentList ":" type.</code></p>
<empty-line/>
<p>Variables whose identifiers appear in the same list are all of the same type. Examples of variable declarations (refer to examples in <a l:href="#6">Ch. 6</a>):</p>
<empty-line/>
<p><code> i, j, k: INTEGER</code></p>
<p><code> x, y: REAL</code></p>
<p><code> p, q: BOOLEAN</code></p>
<p><code> s: SET</code></p>
<p><code> f: Function</code></p>
<p><code> a: ARRAY 100 OF REAL</code></p>
<p><code> w: ARRAY 16 OF</code></p>
<p><code> RECORD</code></p>
<p><code> ch: CHAR;</code></p>
<p><code> count: INTEGER</code></p>
<p><code> END</code></p>
<p><code> t: Tree</code></p>
</section>
<section id="8"><title><p>8. Expressions</p></title>
<p>Expressions are constructs denoting rules of computation whereby constants and current values of variables are combined to derive other values by the application of operators and function procedures. Expressions consist of operands and operators. Parentheses may be used to express specific associations of operators and operands.</p>
<section id="8.1"><title><p>8.1. Operands</p></title>
<p>With the exception of sets and literal constants, i.e. numbers and strings, operands are denoted by <emphasis>designators</emphasis>. A designator consists of an identifier referring to the constant, variable, or procedure to be designated. This identifier may possibly be qualified by module identifiers <a l:href="#4">(see Ch. 4</a> and <a l:href="#11">11)</a>, and it may be followed by selectors, if the designated object is an element of a structure.</p>
<p>If A designates an array, then <emphasis>A[E]</emphasis> denotes that element of <emphasis>A</emphasis> whose index is the current value of the expression <emphasis>E</emphasis>. The type of <emphasis>E</emphasis> must be of type INTEGER. A designator of the form <emphasis>A[E1, E2, ..., En]</emphasis> stands for <emphasis>A[E1][E2] ... [En]</emphasis>. If <emphasis>p</emphasis> designates a pointer variable, <emphasis>p^</emphasis> denotes the variable which is referenced by <emphasis>p</emphasis>. If <emphasis>r</emphasis> designates a record, then <emphasis>r.f</emphasis> denotes the field <emphasis>f</emphasis> of <emphasis>r</emphasis>. If <emphasis>p</emphasis> designates a pointer, <emphasis>p.f</emphasis> denotes the field <emphasis>f</emphasis> of the record <emphasis>p^</emphasis>, i.e. the dot implies dereferencing and <emphasis>p.f</emphasis> stands for <emphasis>p^.f</emphasis>.</p>
<p>The <emphasis>typeguard v(T0)</emphasis> asserts that <emphasis>v</emphasis> is of type <emphasis>T0</emphasis>, i.e. it aborts program execution, if it is not of type <emphasis>T0</emphasis>. The guard is applicable, if</p>
<p>1. <emphasis>T0</emphasis> is an extension of the declared type <emphasis>T</emphasis> of <emphasis>v</emphasis>, and if</p>
<p>2. <emphasis>v</emphasis> is a variable parameter of record type, or <emphasis>v</emphasis> is a pointer.</p>
<empty-line/>
<p><code> designator = qualident {selector}.</code></p>
<p><code> selector = "." ident | "[" ExpList "]" | "^" | "(" qualident ")".</code></p>
<p><code> ExpList = expression {"," expression}.</code></p>
<empty-line/>
<p>If the designated object is a variable, then the designator refers to the variable's current value. If the object is a procedure, a designator without parameter list refers to that procedure. If it is followed by a (possibly empty) parameter list, the designator implies an activation of the procedure and stands for the value resulting from its execution. The (types of the) actual parameters must correspond to the formal parameters as specified in the procedure's declaration <a l:href="#10">(see Ch. 10)</a>.</p>
<p>Examples of designators <a l:href="#7">(see examples in Ch. 7)</a>:</p>
<empty-line/>
<p><code> i (INTEGER)</code></p>
<p><code> a[i] (REAL)</code></p>
<p><code> w[3].ch (CHAR)</code></p>
<p><code> t.key (INTEGER)</code></p>
<p><code> t.left.right (Tree)</code></p>
<p><code> t(CenterNode).subnode (Tree)</code></p>
</section>
<section id="8.2"><title><p>8.2. Operators</p></title>
<p>The syntax of expressions distinguishes between four classes of operators with different precedences (binding strengths). The operator ~ has the highest precedence, followed by multiplication operators, addition operators, and relations. Operators of the same precedence associate from left to right. For example, <emphasis>x-y-z</emphasis> stands for <emphasis>(x-y)-z</emphasis>.</p>
<empty-line/>
<p><code> expression = SimpleExpression [relation SimpleExpression].</code></p>
<p><code> relation = "=" | "#" | "&lt;" | "&lt;=" | "&gt;" | "&gt;=" | IN | IS.</code></p>
<p><code> SimpleExpression = ["+"|"-"] term {AddOperator term}.</code></p>
<p><code> AddOperator = "+" | "-" | OR.</code></p>
<p><code> term = factor {MulOperator factor}.</code></p>
<p><code> MulOperator = "*" | "/" | DIV | MOD | "&amp;" .</code></p>
<p><code> factor = number | string | NIL | TRUE | FALSE |</code></p>
<p><code> set | designator [ActualParameters] | "(" expression ")" | "~" factor.</code></p>
<p><code> set = "{" [element {"," element}] "}".</code></p>
<p><code> element = expression [".." expression].</code></p>
<p><code> ActualParameters = "(" [ExpList] ")" .</code></p>
<empty-line/>
<p>The available operators are listed in the following tables. In some instances, several different operations are designated by the same operator symbol. In these cases, the actual operation is identified by the type of the operands.</p>
<section id="8.2.1"><title><p><emphasis>8.2.1. Logical operators</emphasis></p></title>
<p><code> symbol result</code></p>
<empty-line/>
<p><code> OR logical disjunction</code></p>
<p><code> &amp; logical conjunction</code></p>
<p><code> ~ negation</code></p>
<empty-line/>
<p>These operators apply to BOOLEAN operands and yield a BOOLEAN result.</p>
<empty-line/>
<p><code> p OR q stands for "if p then TRUE, else q"</code></p>
<p><code> p &amp; q stands for "if p then q, else FALSE"</code></p>
<p><code> ~ p stands for "not p"</code></p>
</section>
<section id="8.2.2"><title><p><emphasis>8.2.2. Arithmetic operators</emphasis></p></title>
<p><code> symbol result</code></p>
<empty-line/>
<p><code> + sum</code></p>
<p><code> - difference</code></p>
<p><code> * product</code></p>
<p><code> / quotient</code></p>
<p><code> DIV integer quotient</code></p>
<p><code> MOD modulus</code></p>
<empty-line/>
<p>The operators +, -, *, and / apply to operands of numeric types. Both operands must be of the same type, which is also the type of the result. When used as unary operators, - denotes sign inversion and + denotes the identity operation.</p>
<p>The operators DIV and MOD apply to integer operands only. Let q = x DIV y, and r = x MOD y. Then quotient <emphasis>q</emphasis> and remainder <emphasis>r</emphasis> are defined by the equation</p>
<empty-line/>
<p><code> x = q*y + r 0 &lt;= r &lt; y</code></p>
</section>
<section id="8.2.3"><title><p><emphasis>8.2.3. Set operators</emphasis></p></title>
<p><code> symbol result</code></p>
<empty-line/>
<p><code> + union</code></p>
<p><code> - difference</code></p>
<p><code> * intersection</code></p>
<p><code> / symmetric set difference</code></p>
<empty-line/>
<p>When used with a single operand of type SET, the minus sign denotes the set complement.</p>
</section>
<section id="8.2.4"><title><p><emphasis>8.2.4. Relations</emphasis></p></title>
<p><code> symbol relation</code></p>
<empty-line/>
<p><code> = equal</code></p>
<p><code> # unequal</code></p>
<p><code> &lt; less</code></p>
<p><code> &lt;= less or equal</code></p>
<p><code> &gt; greater</code></p>
<p><code> &gt;= greater or equal</code></p>
<p><code> IN set membership</code></p>
<p><code> IS type test</code></p>
<empty-line/>
<p>Relations are Boolean. The ordering relations &lt;, &lt;=, &gt;, &gt;= apply to the numeric types, CHAR, and character arrays. The relations = and # also apply to the types BOOLEAN and SET, and to pointer and procedure types. The relations &lt;= and &gt;= denote inclusion when applied to sets.</p>
<p><emphasis>x IN s</emphasis> stands for "x is an element of s". <emphasis>x</emphasis> must be of type INTEGER, and <emphasis>s</emphasis> of type SET.</p>
<p><emphasis>v IS T</emphasis> stands for "v is of type T" and is called a <emphasis>type test</emphasis>. It is applicable, if</p>
<p>1. T is an extension of the declared type T0 of v, and if</p>
<p>2. v is a variable parameter of record type or v is a pointer.</p>
<p>Assuming, for instance, that T is an extension of T0 and that v is a designator declared of type T0, then the test <emphasis>v IS T</emphasis> determines whether the actually designated variable is (not only a T0, but also) a T. The value of <emphasis>NIL IS T</emphasis> is undefined.</p>
<p>Examples of expressions (refer to examples in <a l:href="#7">Ch. 7</a>):</p>
<empty-line/>
<p><code> 1987 (INTEGER)</code></p>
<p><code> i DIV 3 (INTEGER)</code></p>
<p><code> ~p OR q (BOOLEAN)</code></p>
<p><code> (i+j) * (i-j) (INTEGER)</code></p>
<p><code> s - {8, 9, 13} (SET)</code></p>
<p><code> a[i+j] * a[i-j] (REAL)</code></p>
<p><code> (0&lt;=i) &amp; (i&lt;100) (BOOLEAN)</code></p>
<p><code> t.key = 0 (BOOLEAN)</code></p>
<p><code> k IN {i .. j-1} (BOOLEAN)</code></p>
<p><code> t IS CenterNode (BOOLEAN)</code></p>
</section>
</section>
</section>
<section id="9"><title><p>9. Statements</p></title>
<p>Statements denote actions. There are elementary and structured statements. Elementary statements are not composed of any parts that are themselves statements. They are the assignment and the procedure call. Structured statements are composed of parts that are themselves statements. They are used to express sequencing and conditional, selective, and repetitive execution. A statement may also be empty, in which case it denotes no action. The empty statement is included in order to relax punctuation rules in statement sequences.</p>
<empty-line/>
<p><code> statement = [assignment | ProcedureCall | IfStatement | CaseStatement |</code></p>
<p><code> WhileStatement | RepeatStatement | ForStatement].</code></p>
<section id="9.1"><title><p>9.1. Assignments</p></title>
<p>The assignment serves to replace the current value of a variable by a new value specified by an expression. The assignment operator is written as ":=" and pronounced as <emphasis>becomes</emphasis>.</p>
<empty-line/>
<p><code> assignment = designator ":=" expression.</code></p>
<empty-line/>
<p>If a value parameter is structured (of array or record type), no assignment to it or to its elements are permitted. Neither may assignments be made to imported variables.</p>
<p>The type of the expression must be the same as that of the designator. The following exceptions hold:</p>
<p>1. The constant NIL can be assigned to variables of any pointer or procedure type.</p>
<p>2. Strings can be assigned to any array of characters, provided the number of characters in the string is not greater than that of the array. If it is less, a null character (0X) is appended. Singlecharacter strings can also be assigned to variables of type CHAR.</p>
<p>3. In the case of records, the type of the source must be an extension of the type of the destination. Examples of assignments <a l:href="#7">(see examples in Ch. 7)</a>:</p>
<empty-line/>
<p><code> i := 0</code></p>
<p><code> p := i = j</code></p>
<p><code> x := FLT(i + 1)</code></p>
<p><code> k := (i + j) DIV 2</code></p>
<p><code> f := log2</code></p>
<p><code> s := {2, 3, 5, 7, 11, 13}</code></p>
<p><code> a[i] := (x+y) * (x-y)</code></p>
<p><code> t.key := i</code></p>
<p><code> w[i+1].ch := "A"</code></p>
</section>
<section id="9.2"><title><p>9.2. Procedure calls</p></title>
<p>A procedure call serves to activate a procedure. The procedure call may contain a list of actual parameters which are substituted in place of their corresponding formal parameters defined in the procedure declaration <a l:href="#10">(see Ch. 10)</a>. The correspondence is established by the positions of the parameters in the lists of actual and formal parameters respectively. There exist two kinds of parameters: <emphasis>variable</emphasis> and <emphasis>value</emphasis> parameters.</p>
<p>In the case of variable parameters, the actual parameter must be a designator denoting a variable. If it designates an element of a structured variable, the selector is evaluated when the formal/actual parameter substitution takes place, i.e. before the execution of the procedure. If the parameter is a value parameter, the corresponding actual parameter must be an expression. This expression is evaluated prior to the procedure activation, and the resulting value is assigned to the formal parameter which now constitutes a local variable <a l:href="#10.1">(see also 10.1.)</a>.</p>
<empty-line/>
<p><code> ProcedureCall = designator [ActualParameters].</code></p>
<empty-line/>
<p>Examples of procedure calls:</p>
<empty-line/>
<p><code> ReadInt(i) <a l:href="#10">(see Ch. 10)</a></code></p>
<p><code> WriteInt(2*j + 1, 6)</code></p>
<p><code> INC(w[k].count)</code></p>
</section>
<section id="9.3"><title><p>9.3. Statement sequences</p></title>
<p>Statement sequences denote the sequence of actions specified by the component statements which are separated by semicolons.</p>
<empty-line/>
<p><code> StatementSequence = statement {";" statement}.</code></p>
</section>
<section id="9.4"><title><p>9.4. If statements</p></title>
<p><code> IfStatement = IF expression THEN StatementSequence</code></p>
<p><code> {ELSIF expression THEN StatementSequence}</code></p>
<p><code> [ELSE StatementSequence]</code></p>
<p><code> END.</code></p>
<empty-line/>
<p>If statements specify the conditional execution of guarded statements. The Boolean expression preceding a statement is called its <emphasis>guard</emphasis>. The guards are evaluated in sequence of occurrence, until one evaluates to TRUE, whereafter its associated statement sequence is executed. If no guard is satisfied, the statement sequence following the symbol ELSE is executed, if there is one.</p>
<p>Example:</p>
<empty-line/>
<p><code> IF (ch &gt;= "A") &amp; (ch &lt;= "Z") THEN ReadIdentifier</code></p>
<p><code> ELSIF (ch &gt;= "0") &amp; (ch &lt;= "9") THEN ReadNumber</code></p>
<p><code> ELSIF ch = 22X THEN ReadString</code></p>
<p><code> END</code></p>
</section>
<section id="9.5"><title><p>9.5. Case statements</p></title>
<p>Case statements specify the selection and execution of a statement sequence according to the value of an expression. First the case expression is evaluated, then the statement sequence is executed whose case label list contains the obtained value. The case expression must be of type INTEGER or CHAR, and all labels must be integers or single-character strings, respectively.</p>
<empty-line/>
<p><code> CaseStatement = CASE expression OF case {"|" case} END.</code></p>
<p><code> case = [CaseLabelList ":" StatementSequence].</code></p>
<p><code> CaseLabelList = LabelRange {"," LabelRange}.</code></p>
<p><code> LabelRange = label [".." label].</code></p>
<p><code> label = integer | string | ident.</code></p>
<empty-line/>
<p>Example:</p>
<empty-line/>
<p><code> CASE k OF</code></p>
<p><code> 0: x := x + y</code></p>
<p><code> | 1: x := x - y</code></p>
<p><code> | 2: x := x * y</code></p>
<p><code> | 3: x := x / y</code></p>
<p><code> END</code></p>
</section>
<section id="9.6"><title><p>9.6. While statements</p></title>
<p>While statements specify repetition. If any of the Boolean expressions (guards) yields TRUE, the corresponding statement sequence is executed. The expression evaluation and the statement execution are repeated until none of the Boolean expressions yields TRUE.</p>
<empty-line/>
<p><code> WhileStatement = WHILE expression DO StatementSequence</code></p>
<p><code> {ELSIF expression DO StatementSequence} END.</code></p>
<empty-line/>
<p>Examples:</p>
<empty-line/>
<p><code> WHILE j &gt; 0 DO</code></p>
<p><code> j := j DIV 2; i := i+1</code></p>
<p><code> END</code></p>
<p><code> WHILE (t # NIL) &amp; (t.key # i) DO</code></p>
<p><code> t := t.left</code></p>
<p><code> END</code></p>
<p><code> WHILE m &gt; n DO m := m - n</code></p>
<p><code> ELSIF n &gt; m DO n := n - m</code></p>
<p><code> END</code></p>
</section>
<section id="9.7"><title><p>9.7. Repeat Statements</p></title>
<p>A repeat statement specifies the repeated execution of a statement sequence until a condition is satisfied. The statement sequence is executed at least once.</p>
<empty-line/>
<p><code> RepeatStatement = REPEAT StatementSequence UNTIL expression.</code></p>
</section>
<section id="9.8"><title><p>9.8. For statements</p></title>
<p>A for statement specifies the repeated execution of a statement sequence for a given number of times, while a progression of values is assigned to an integer variable called the <emphasis>control variable</emphasis> of the for statement.</p>
<empty-line/>
<p><code> ForStatement =</code></p>
<p><code> FOR ident ":=" expression TO expression [BY ConstExpression] DO</code></p>
<p><code> StatementSequence END .</code></p>
<empty-line/>
<p>The for statement</p>
<empty-line/>
<p><code> FOR v := beg TO end BY inc DO S END</code></p>
<empty-line/>
<empty-line/>is, if <emphasis>inc</emphasis> &gt; 0, equivalent to
<empty-line/>
<p><code> v := beg; lim := end;</code></p>
<p><code> WHILE v &lt;= lim DO S; v := v + inc END</code></p>
<empty-line/>
<empty-line/>and if <emphasis>inc</emphasis> &lt; 0 it is equivalent to
<empty-line/>
<p><code> v := beg; lim := end;</code></p>
<p><code> WHILE v &gt;= lim DO S; v := v + inc END</code></p>
<empty-line/>
<p>The types of <emphasis>v</emphasis>, <emphasis>beg</emphasis> and <emphasis>end</emphasis> must be INTEGER, and <emphasis>inc</emphasis> must be an integer (constant expression). If the step is not specified, it is assumed to be 1.</p>
</section>
</section>
<section id="10"><title><p>10. Procedure declarations</p></title>
<p>Procedure declarations consist of a procedure heading and a procedure body. The heading specifies the procedure identifier, the formal parameters, and the result type (if any). The body contains declarations and statements. The procedure identifier is repeated at the end of the procedure declaration.</p>
<p>There are two kinds of procedures, namely proper procedures and function procedures. The latter are activated by a function designator as a constituent of an expression, and yield a result that is an operand in the expression. Proper procedures are activated by a procedure call. A function procedure is distinguished in the declaration by indication of the type of its result following the parameter list. Its body must end with a RETURN clause which defines the result of the function procedure.</p>
<p>All constants, variables, types, and procedures declared within a procedure body are local to the procedure. The values of local variables are undefined upon entry to the procedure. Since procedures may be declared as local objects too, procedure declarations may be nested.</p>
<p>In addition to its formal parameters and locally declared objects, the objects declared in the environment of the procedure are also visible in the procedure (with the exception of variables and of those objects that have the same name as an object declared locally).</p>
<p>The use of the procedure identifier in a call within its declaration implies recursive activation of the procedure.</p>
<empty-line/>
<p><code> ProcedureDeclaration = ProcedureHeading ";" ProcedureBody ident.</code></p>
<p><code> ProcedureHeading = PROCEDURE identdef [FormalParameters].</code></p>
<p><code> ProcedureBody = DeclarationSequence [BEGIN StatementSequence]</code></p>
<p><code> [RETURN expression] END.</code></p>
<p><code> DeclarationSequence = [CONST {ConstantDeclaration ";"}]</code></p>
<p><code> [TYPE {TypeDeclaration ";"}] [VAR {VariableDeclaration ";"}]</code></p>
<p><code> {ProcedureDeclaration ";"}.</code></p>
<section id="10.1"><title><p>10.1. Formal parameters</p></title>
<p>Formal parameters are identifiers which denote actual parameters specified in the procedure call. The correspondence between formal and actual parameters is established when the procedure is called. There are two kinds of parameters, namely <emphasis>value</emphasis> and <emphasis>variable</emphasis> parameters. A variable parameter corresponds to an actual parameter that is a variable, and it stands for that variable. A value parameter corresponds to an actual parameter that is an expression, and it stands for its value, which cannot be changed by assignment. However, if a value parameter is of a scalar type, it represents a local variable to which the value of the actual expression is initially assigned.</p>
<p>The kind of a parameter is indicated in the formal parameter list: Variable parameters are denoted by the symbol VAR and value parameters by the absence of a prefix.</p>
<p>A function procedure without parameters must have an empty parameter list. It must be called by a function designator whose actual parameter list is empty too.</p>
<p>Formal parameters are local to the procedure, i.e. their scope is the program text which constitutes the procedure declaration.</p>
<empty-line/>
<p><code> FormalParameters = "(" [FPSection {";" FPSection}] ")" [":" qualident].</code></p>
<p><code> FPSection = [VAR] ident {"," ident} ":" FormalType.</code></p>
<p><code> FormalType = {ARRAY OF} qualident.</code></p>
<empty-line/>
<p>The type of each formal parameter is specified in the parameter list. For variable parameters, it must be identical to the corresponding actual parameter's type, except in the case of a record, where it must be a base type of the corresponding actual parameter's type.</p>
<p>If the formal parameter's type is specified as</p>
<empty-line/>
<p><code> ARRAY OF T</code></p>
<empty-line/>
<empty-line/>the parameter is said to be an <emphasis>open array</emphasis>, and the corresponding actual parameter may be of arbitrary length.
<p>If a formal parameter specifies a procedure type, then the corresponding actual parameter must be either a procedure declared globally, or a variable (or parameter) of that procedure type. It cannot be a predefined procedure. The result type of a procedure can be neither a record nor an array.</p>
<p>Examples of procedure declarations:</p>
<empty-line/>
<p><code> PROCEDURE ReadInt(VAR x: INTEGER);</code></p>
<p><code> VAR i : INTEGER; ch: CHAR;</code></p>
<p><code> BEGIN i := 0; Read(ch);</code></p>
<p><code> WHILE ("0" &lt;= ch) &amp; (ch &lt;= "9") DO</code></p>
<p><code> i := 10*i + (ORD(ch)-ORD("0")); Read(ch)</code></p>
<p><code> END ;</code></p>
<p><code> x := i</code></p>
<p><code> END ReadInt</code></p>
<empty-line/>
<p><code> PROCEDURE WriteInt(x: INTEGER); (* 0 &lt;= x &lt; 10^5 *)</code></p>
<p><code> VAR i: INTEGER;</code></p>
<p><code> buf: ARRAY 5 OF INTEGER;</code></p>
<p><code> BEGIN i := 0;</code></p>
<p><code> REPEAT buf[i] := x MOD 10; x := x DIV 10; INC(i) UNTIL x = 0;</code></p>
<p><code> REPEAT DEC(i); Write(CHR(buf[i] + ORD("0"))) UNTIL i = 0</code></p>
<p><code> END WriteInt</code></p>
<empty-line/>
<p><code> PROCEDURE log2(x: INTEGER): INTEGER;</code></p>
<p><code> VAR y: INTEGER; (*assume x&gt;0*)</code></p>
<p><code> BEGIN y := 0;</code></p>
<p><code> WHILE x &gt; 1 DO x := x DIV 2; INC(y) END ;</code></p>
<p><code> RETURN y</code></p>
<p><code> END log2</code></p>
</section>
<section id="10.2"><title><p>10.2. Predefined procedures</p></title>
<p>The following table lists the predefined procedures. Some are generic procedures, i.e. they apply to several types of operands. v stands for a variable, x and n for expressions, and T for a type.</p>
<empty-line/>
<p><code> <emphasis>Function procedures:</emphasis></code></p>
<empty-line/>
<p><code> Name Argument type Result type Function</code></p>
<empty-line/>
<p><code> ABS(x) numeric type type of x absolute value</code></p>
<p><code> ODD(x) INTEGER BOOLEAN x MOD 2 = 1</code></p>
<p><code> LEN(v) v: array INTEGER the length of v</code></p>
<p><code> LSL(x, n) x, n: INTEGER type of x logical shift left, x * 2<sup>n</sup></code></p>
<p><code> ASR(x, n) x, n: INTEGER type of x signed shift right, x DIV 2<sup>n</sup></code></p>
<p><code> ROR(x, n) x. n: INTEGER type of x x rotated right by n bits</code></p>
<empty-line/>
<p><code> <emphasis>Type conversion functions:</emphasis></code></p>
<empty-line/>
<p><code> Name Argument type Result type Function</code></p>
<empty-line/>
<p><code> FLOOR(x) REAL, LONGREAL INTEGER largest integer &lt;= x</code></p>
<p><code> FLT(x) INTEGER REAL identity</code></p>
<p><code> ORD(x) CHAR, BOOLEAN, SET INTEGER ordinal number of x</code></p>
<p><code> CHR(x) INTEGER CHAR character with ordinal number x</code></p>
<p><code> LONG(x) REAL LONGREAL x</code></p>
<p><code> SHORT(x) LONGREAL REAL x</code></p>
<empty-line/>
<p><code> <emphasis>Proper procedures:</emphasis></code></p>
<empty-line/>
<p><code> Name Argument types Function</code></p>
<empty-line/>
<p><code> INC(v) INTEGER v := v + 1</code></p>
<p><code> INC(v, n) INTEGER v := v + n</code></p>
<p><code> DEC(v) INTEGER v := v - 1</code></p>
<p><code> DEC(v, n) INTEGER v := v - n</code></p>
<p><code> INCL(v, x) v: SET; x: INTEGER v := v + {x}</code></p>
<p><code> EXCL(v, x) v: SET; x: INTEGER v := v - {x}</code></p>
<p><code> COPY(x, v) x: character array, string v := x</code></p>
<p><code> v: character array</code></p>
<p><code> NEW(v) pointer type allocate v^</code></p>
<p><code> ASSERT(b) BOOLEAN abort, if ~b</code></p>
<p><code> ASSERT(b, n) BOOLEAN, INTEGER</code></p>
<p><code> PACK(x, y) REAL; INTEGER pack x and y into x</code></p>
<p><code> UNPK(x, y) REAL; INTEGER unpack x into x and y</code></p>
<empty-line/>
<p>Procedures INC and DEC may have an explicit increment or decrement. It must be a constant. Also for INCL and EXCL, <emphasis>x</emphasis> must be a constant. The second parameter <emphasis>n</emphasis> of ASSERT is a value transmitted to the system as an abort parameter.</p>
<p>The parameter <emphasis>y</emphasis> of PACK represents the exponent of <emphasis>x</emphasis>. PACK(x, y) is equivalent to x := x * 2<sup>y</sup>. UNPK is the reverse operation of PACK. The resulting <emphasis>x</emphasis> is normalized, i.e. 1.0 &lt;= x &lt; 2.0.</p>
</section>
</section>
<section id="11"><title><p>11. Modules</p></title>
<p>A module is a collection of declarations of constants, types, variables, and procedures, and a sequence of statements for the purpose of assigning initial values to the variables. A module typically constitutes a text that is compilable as a unit.</p>
<empty-line/>
<p><code> module = MODULE ident ";" [ImportList ";"] DeclarationSequence</code></p>
<p><code> [BEGIN StatementSequence] END ident "." .</code></p>
<p><code> ImportList = IMPORT import {"," import} ";" .</code></p>
<p><code> Import = ident [":=" ident].</code></p>
<empty-line/>
<p>The import list specifies the modules of which the module is a client. If an identifier x is exported from a module M, and if M is listed in a module's import list, then x is referred to as M.x. If the form "M := M1" is used in the import list, an exported object x declared within M1 is referenced in the importing module as M.x .</p>
<p>Identifiers that are to be visible in client modules, i.e. which are to be exported, must be marked by an asterisk (export mark) in their declaration. Variables cannot be exported, with the exception of those of scalar types in read-only mode.</p>
<p>The statement sequence following the symbol BEGIN is executed when the module is added to a system (loaded). Individual (parameterless) procedures can thereafter be activated from the system, and these procedures serve as commands.</p>
<p>Example:</p>
<empty-line/>
<p><code> MODULE Out; (*exported procedures: Write, WriteInt, WriteLn*)</code></p>
<p><code> IMPORT Texts, Oberon;</code></p>
<p><code> VAR W: Texts.Writer;</code></p>
<empty-line/>
<p><code> PROCEDURE Write*(ch: CHAR);</code></p>
<p><code> BEGIN Texts.Write(W, ch)</code></p>
<p><code> END ;</code></p>
<empty-line/>
<p><code> PROCEDURE WriteInt*(x, n: INTEGER);</code></p>
<p><code> VAR i: INTEGER; a: ARRAY 16 OF CHAR;</code></p>
<p><code> BEGIN i := 0;</code></p>
<p><code> IF x &lt; 0 THEN Texts.Write(W, "-"); x := -x END ;</code></p>
<p><code> REPEAT a[i] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(i) UNTIL x = 0;</code></p>
<p><code> REPEAT Texts.Write(W, " "); DEC(n) UNTIL n &lt;= i;</code></p>
<p><code> REPEAT DEC(i); Texts.Write(W, a[i]) UNTIL i = 0</code></p>
<p><code> END WriteInt;</code></p>
<empty-line/>
<p><code> PROCEDURE WriteLn*;</code></p>
<p><code> BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)</code></p>
<p><code> END WriteLn;</code></p>
<empty-line/>
<p><code> BEGIN Texts.OpenWriter(W)</code></p>
<p><code> END Out.</code></p>
<section id="11.1"><title><p>11.1 The Module SYSTEM</p></title>
<p>The optional module SYSTEM contains definitions that are necessary to program low-level operations referring directly to resources particular to a given computer and/or implementation. These include for example facilities for accessing devices that are controlled by the computer, and perhaps facilities to break the data type compatibility rules otherwise imposed by the language definition. It is strongly recommended to restrict their use to specific low-level modules, as such modules are inherently non-portable and not "type-safe". However, they are easily recognized due to the identifier SYSTEM appearing in their import lists. The subsequent definitions are generally applicable. However, individual implementations may include in their module SYSTEM additional definitions that are particular to the specific, underlying computer. In the following, <emphasis>v</emphasis> stands for a variable, <emphasis>x</emphasis>, <emphasis>a</emphasis>, and <emphasis>n</emphasis> for expressions.</p>
<empty-line/>
<p><code> <emphasis>Function procedures:</emphasis></code></p>
<empty-line/>
<p><code> Name Argument types Result type Function</code></p>
<empty-line/>
<p><code> ADR(v) any INTEGER address of variable v</code></p>
<p><code> SIZE(T) any type INTEGER size in bytes</code></p>
<p><code> BIT(a, n) a, n: INTEGER BOOLEAN bit n of mem[a]</code></p>
<empty-line/>
<p><code> <emphasis>Proper procedures:</emphasis></code></p>
<empty-line/>
<p><code> Name Argument types Function</code></p>
<empty-line/>
<p><code> GET(a, v) a: INTEGER; v: any basic type v := mem[a]</code></p>
<p><code> PUT(a, x) a: INTEGER; x: any basic type mem[a] := x</code></p>
</section>
</section>
<section id="app"><title><p>Appendix</p><p>The Syntax of Oberon</p></title>
<p><code> letter = "A" | "B" | … | "Z" | "a" | "b" | … | "z".</code></p>
<p><code> digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".</code></p>
<p><code> hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".</code></p>
<p><code> ident = letter {letter | digit}.</code></p>
<p><code> qualident = [ident "."] ident.</code></p>
<p><code> identdef = ident ["*"].</code></p>
<p><code> integer = digit {digit} | digit {hexDigit} "H".</code></p>
<p><code> real = digit {digit} "." {digit} [ScaleFactor].</code></p>
<p><code> ScaleFactor = ("E" | "D") ["+" | "-"] digit {digit}.</code></p>
<p><code> number = integer | real.</code></p>
<p><code> string = """ {character} """ | digit {hexDigit} "X".</code></p>
<p><code> ConstantDeclaration = identdef "=" ConstExpression.</code></p>
<p><code> ConstExpression = expression.</code></p>
<p><code> TypeDeclaration = identdef "=" StrucType.</code></p>
<p><code> StrucType = ArrayType | RecordType | PointerType | ProcedureType.</code></p>
<p><code> type = qualident | StrucType.</code></p>
<p><code> ArrayType = ARRAY length {"," length} OF type.</code></p>
<p><code> length = ConstExpression.</code></p>
<p><code> RecordType = RECORD ["(" BaseType ")"] [FieldListSequence] END.</code></p>
<p><code> BaseType = qualident.</code></p>
<p><code> FieldListSequence = FieldList {";" FieldList}.</code></p>
<p><code> FieldList = IdentList ":" type.</code></p>
<p><code> IdentList = identdef {"," identdef}.</code></p>
<p><code> PointerType = POINTER TO type.</code></p>
<p><code> ProcedureType = PROCEDURE [FormalParameters].</code></p>
<p><code> VariableDeclaration = IdentList ":" type.</code></p>
<p><code> expression = SimpleExpression [relation SimpleExpression].</code></p>
<p><code> relation = "=" | "#" | "&lt;" | "&lt;=" | "&gt;" | "&gt;=" | IN | IS.</code></p>
<p><code> SimpleExpression = ["+" | "-"] term {AddOperator term}.</code></p>
<p><code> AddOperator = "+" | "-" | OR.</code></p>
<p><code> term = factor {MulOperator factor}.</code></p>
<p><code> MulOperator = "*" | "/" | DIV | MOD | "&amp;".</code></p>
<p><code> factor = number | string | NIL | TRUE | FALSE |</code></p>
<p><code> set | designator [ActualParameters] | "(" expression ")" | "~" factor.</code></p>
<p><code> designator = qualident {selector}.</code></p>
<p><code> selector = "." ident | "[" ExpList "]" | "^" | "(" qualident ")".</code></p>
<p><code> set = "{" [element {"," element}] "}".</code></p>
<p><code> element = expression [".." expression].</code></p>
<p><code> ExpList = expression {"," expression}.</code></p>
<p><code> ActualParameters = "(" [ExpList] ")" .</code></p>
<p><code> statement = [assignment | ProcedureCall | IfStatement | CaseStatement |</code></p>
<p><code> WhileStatement | RepeatStatement | ForStatement].</code></p>
<p><code> assignment = designator ":=" expression.</code></p>
<p><code> ProcedureCall = designator [ActualParameters].</code></p>
<p><code> StatementSequence = statement {";" statement}.</code></p>
<p><code> IfStatement = IF expression THEN StatementSequence</code></p>
<p><code> {ELSIF expression THEN StatementSequence}</code></p>
<p><code> [ELSE StatementSequence] END.</code></p>
<p><code> CaseStatement = CASE expression OF case {"|" case} END.</code></p>
<p><code> case = [CaseLabelList ":" StatementSequence].</code></p>
<p><code> CaseLabelList = LabelRange {"," LabelRange}.</code></p>
<p><code> LabelRange = label [".." label].</code></p>
<p><code> label = integer | string | ident.</code></p>
<p><code> WhileStatement = WHILE expression DO StatementSequence</code></p>
<p><code> {ELSIF expression DO StatementSequence} END.</code></p>
<p><code> RepeatStatement = REPEAT StatementSequence UNTIL expression.</code></p>
<p><code> ForStatement = FOR ident ":=" expression TO expression [BY ConstExpression]</code></p>
<p><code> DO StatementSequence END.</code></p>
<p><code> ProcedureDeclaration = ProcedureHeading ";" ProcedureBody ident.</code></p>
<p><code> ProcedureHeading = PROCEDURE identdef [FormalParameters].</code></p>
<p><code> ProcedureBody = DeclarationSequence [BEGIN StatementSequence]</code></p>
<p><code> [RETURN expression] END.</code></p>
<p><code> DeclarationSequence = [CONST {ConstDeclaration ";"}]</code></p>
<p><code> [TYPE {TypeDeclaration ";"}]</code></p>
<p><code> [VAR {VariableDeclaration ";"}]</code></p>
<p><code> {ProcedureDeclaration ";"}.</code></p>
<p><code> FormalParameters = "(" [FPSection {";" FPSection}] ")" [":" qualident].</code></p>
<p><code> FPSection = [VAR] ident {"," ident} ":" FormalType.</code></p>
<p><code> FormalType = {ARRAY OF} qualident.</code></p>
<p><code> module = MODULE ident ";" [ImportList] DeclarationSequence</code></p>
<p><code> [BEGIN StatementSequence] END ident "." .</code></p>
<p><code> ImportList = IMPORT import {"," import} ";".</code></p>
<p><code> import = ident [":=" ident].</code></p>
</section>
</section>
</body>
</FictionBook>
 
 
 
/programs/develop/oberon07/Lib/KolibriOS/API.ob07
1,13 → 1,23
(*
BSD 2-Clause License
(*
Copyright 2016, 2017, 2018 Anton Krotov
 
Copyright (c) 2018, Anton Krotov
All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
 
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE API;
 
IMPORT SYSTEM, K := KOSAPI;
IMPORT sys := SYSTEM;
 
 
CONST
31,23 → 41,10
 
CriticalSection: CRITICAL_SECTION;
 
import*, multi: BOOLEAN;
 
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
 
 
PROCEDURE [stdcall] zeromem* (dwords: INTEGER; adr: INTEGER);
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER);
BEGIN
SYSTEM.CODE(
0FCH, (* cld *)
031H, 0C0H, (* xor eax, eax *)
057H, (* push edi *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *)
0F3H, 0ABH, (* rep stosd *)
05FH (* pop edi *)
)
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
 
 
56,31 → 53,128
tmp: INTEGER;
BEGIN
FOR tmp := adr TO adr + size - 1 BY 4096 DO
SYSTEM.PUT(tmp, 0)
sys.PUT(tmp, 0)
END
END mem_commit;
 
 
PROCEDURE strncmp* (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
Res: INTEGER;
BEGIN
Res := 0;
WHILE n > 0 DO
sys.GET(a, A); INC(a);
sys.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
Res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN Res
END strncmp;
 
 
PROCEDURE [stdcall] sysfunc1* (arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
RETURN 0
END sysfunc1;
 
 
PROCEDURE [stdcall] sysfunc2* (arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END sysfunc2;
 
 
PROCEDURE [stdcall] sysfunc3* (arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
 
 
PROCEDURE [stdcall] sysfunc4* (arg1, arg2, arg3, arg4: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21000"); (* ret 10h *)
RETURN 0
END sysfunc4;
 
 
PROCEDURE [stdcall] sysfunc5* (arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
RETURN 0
END sysfunc5;
 
 
PROCEDURE switch_task;
VAR
res: INTEGER;
BEGIN
K.sysfunc2(68, 1)
res := sysfunc2(68, 1)
END switch_task;
 
 
PROCEDURE futex_create (ptr: INTEGER): INTEGER;
RETURN K.sysfunc3(77, 0, ptr)
RETURN sysfunc3(77, 0, ptr)
END futex_create;
 
 
PROCEDURE futex_wait (futex, value, timeout: INTEGER);
VAR
res: INTEGER;
BEGIN
K.sysfunc5(77, 2, futex, value, timeout)
res := sysfunc5(77, 2, futex, value, timeout)
END futex_wait;
 
 
PROCEDURE futex_wake (futex, number: INTEGER);
VAR
res: INTEGER;
BEGIN
K.sysfunc4(77, 3, futex, number)
res := sysfunc4(77, 3, futex, number)
END futex_wake;
 
 
101,7 → 195,7
 
PROCEDURE InitializeCriticalSection* (VAR CriticalSection: CRITICAL_SECTION);
BEGIN
CriticalSection[0] := futex_create(SYSTEM.ADR(CriticalSection[1]));
CriticalSection[0] := futex_create(sys.ADR(CriticalSection[1]));
CriticalSection[1] := 0
END InitializeCriticalSection;
 
114,14 → 208,14
idx := ASR(size, 5);
res := pockets[idx];
IF res # 0 THEN
SYSTEM.GET(res, pockets[idx]);
SYSTEM.PUT(res, size);
sys.GET(res, pockets[idx]);
sys.PUT(res, size);
INC(res, 4)
ELSE
temp := 0;
IF heap + size >= endheap THEN
IF K.sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
temp := K.sysfunc3(68, 12, HEAP_SIZE)
IF sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
temp := sysfunc3(68, 12, HEAP_SIZE)
ELSE
temp := 0
END;
134,7 → 228,7
END
END;
IF (heap # 0) & (temp # -1) THEN
SYSTEM.PUT(heap, size);
sys.PUT(heap, size);
res := heap + 4;
heap := heap + size
ELSE
142,11 → 236,11
END
END
ELSE
IF K.sysfunc2(18, 16) > ASR(size, 10) THEN
res := K.sysfunc3(68, 12, size);
IF sysfunc2(18, 16) > ASR(size, 10) THEN
res := sysfunc3(68, 12, size);
IF res # 0 THEN
mem_commit(res, size);
SYSTEM.PUT(res, size);
sys.PUT(res, size);
INC(res, 4)
END
ELSE
165,13 → 259,13
size, idx: INTEGER;
BEGIN
DEC(ptr, 4);
SYSTEM.GET(ptr, size);
sys.GET(ptr, size);
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
SYSTEM.PUT(ptr, pockets[idx]);
sys.PUT(ptr, pockets[idx]);
pockets[idx] := ptr
ELSE
size := K.sysfunc3(68, 13, ptr)
size := sysfunc3(68, 13, ptr)
END
RETURN 0
END __DISPOSE;
180,11 → 274,8
PROCEDURE NEW_DISPOSE (func, arg: INTEGER): INTEGER;
VAR
res: INTEGER;
 
BEGIN
IF multi THEN
EnterCriticalSection(CriticalSection)
END;
EnterCriticalSection(CriticalSection);
 
IF func = _new THEN
res := __NEW(arg)
192,10 → 283,7
res := __DISPOSE(arg)
END;
 
IF multi THEN
LeaveCriticalSection(CriticalSection)
END
 
RETURN res
END NEW_DISPOSE;
 
210,110 → 298,63
END _DISPOSE;
 
 
PROCEDURE exit* (p1: INTEGER);
PROCEDURE ExitProcess* (p1: INTEGER);
BEGIN
K.sysfunc1(-1)
END exit;
p1 := sysfunc1(-1)
END ExitProcess;
 
 
PROCEDURE exit_thread* (p1: INTEGER);
PROCEDURE ExitThread* (p1: INTEGER);
BEGIN
K.sysfunc1(-1)
END exit_thread;
p1 := sysfunc1(-1)
END ExitThread;
 
 
PROCEDURE OutChar (c: CHAR);
VAR
res: INTEGER;
BEGIN
K.sysfunc3(63, 1, ORD(c))
res := sysfunc3(63, 1, ORD(c))
END OutChar;
 
 
PROCEDURE OutLn;
BEGIN
OutChar(0DX);
OutChar(0AX)
END OutLn;
 
 
PROCEDURE OutStr (pchar: INTEGER);
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
VAR
c: CHAR;
BEGIN
IF pchar # 0 THEN
IF lpCaption # 0 THEN
OutChar(0DX);
OutChar(0AX);
REPEAT
SYSTEM.GET(pchar, c);
sys.GET(lpCaption, c);
IF c # 0X THEN
OutChar(c)
END;
INC(pchar)
UNTIL c = 0X
END
END OutStr;
 
 
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
IF lpCaption # 0 THEN
OutLn;
OutStr(lpCaption);
INC(lpCaption)
UNTIL c = 0X;
OutChar(":");
OutLn
OutChar(0DX);
OutChar(0AX)
END;
OutStr(lpText);
REPEAT
sys.GET(lpText, c);
IF c # 0X THEN
OutChar(c)
END;
INC(lpText)
UNTIL c = 0X;
IF lpCaption # 0 THEN
OutLn
OutChar(0DX);
OutChar(0AX)
END
END DebugMsg;
 
 
PROCEDURE OutString (s: ARRAY OF CHAR);
VAR
i: INTEGER;
PROCEDURE init* (p1: INTEGER);
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
OutChar(s[i]);
INC(i)
END
END OutString;
 
 
PROCEDURE imp_error;
BEGIN
OutString("import error: ");
IF K.imp_error.error = 1 THEN
OutString("can't load "); OutString(K.imp_error.lib)
ELSIF K.imp_error.error = 2 THEN
OutString("not found "); OutString(K.imp_error.proc); OutString(" in "); OutString(K.imp_error.lib)
END;
OutLn
END imp_error;
 
 
PROCEDURE init* (_import, code: INTEGER);
BEGIN
multi := FALSE;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - 36;
K.sysfunc2(68, 11);
InitializeCriticalSection(CriticalSection);
K._init;
import := (K.dll_Load(_import) = 0) & (K.imp_error.error = 0);
IF ~import THEN
imp_error
END
p1 := sysfunc2(68, 11);
InitializeCriticalSection(CriticalSection)
END init;
 
 
PROCEDURE SetMultiThr* (value: BOOLEAN);
BEGIN
multi := value
END SetMultiThr;
 
 
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9) * 10
END GetTickCount;
 
 
END API.
/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07
1,471 → 1,246
(*
BSD 2-Clause License
(*
Copyright 2016, 2017 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
 
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE HOST;
 
IMPORT SYSTEM, K := KOSAPI, API, RTL;
IMPORT sys := SYSTEM, API;
 
 
CONST
 
slash* = "/";
OS* = "KOS";
Slash* = "/";
 
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
 
MAX_PARAM = 1024;
 
 
TYPE
 
FNAME = ARRAY 520 OF CHAR;
FILENAME = ARRAY 2048 OF CHAR;
 
FS = POINTER TO rFS;
 
rFS = RECORD
subfunc, pos, hpos, bytes, buffer: INTEGER;
name: FNAME
OFSTRUCT = RECORD
subfunc, pos, hpos, bytes, buf: INTEGER;
name: FILENAME
END;
 
FD = POINTER TO rFD;
 
rFD = RECORD
attr: INTEGER;
ntyp: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create, date_create,
time_access, date_access,
time_modif, date_modif,
size, hsize: INTEGER;
name: FNAME
END;
 
 
VAR
 
con_init : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
con_exit : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
con_write_asciiz : PROCEDURE [stdcall] (string: INTEGER);
 
Console: BOOLEAN;
fsize, sec*, dsec*: INTEGER;
 
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
 
eol*: ARRAY 3 OF CHAR;
 
 
PROCEDURE [stdcall, "Console.obj", "con_init"] con_init (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
 
PROCEDURE [stdcall, "Console.obj", "con_exit"] con_exit (bCloseWindow: BOOLEAN);
 
PROCEDURE [stdcall, "Console.obj", "con_write_string"] con_write_string (string, length: INTEGER);
 
 
PROCEDURE ExitProcess* (p1: INTEGER);
PROCEDURE [stdcall] sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
BEGIN
IF Console THEN
con_exit(FALSE)
END;
K.sysfunc1(-1)
END ExitProcess;
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8919"); (* mov [ecx], ebx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc22;
 
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR cur, procname, adr: INTEGER;
 
PROCEDURE OutChar* (c: CHAR);
PROCEDURE streq(str1, str2: INTEGER): BOOLEAN;
VAR c1, c2: CHAR;
BEGIN
IF Console THEN
con_write_string(SYSTEM.ADR(c), 1)
ELSE
K.sysfunc3(63, 1, ORD(c))
END
END OutChar;
REPEAT
sys.GET(str1, c1);
sys.GET(str2, c2);
INC(str1);
INC(str2)
UNTIL (c1 # c2) OR (c1 = 0X)
RETURN c1 = c2
END streq;
 
 
PROCEDURE GetFileInfo (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR
res2: INTEGER;
fs: rFS;
 
BEGIN
fs.subfunc := 5;
fs.pos := 0;
fs.hpos := 0;
fs.bytes := 0;
fs.buffer := SYSTEM.ADR(Info);
COPY(FName, fs.name)
RETURN K.sysfunc22(70, SYSTEM.ADR(fs), res2) = 0
END GetFileInfo;
 
 
PROCEDURE Exists (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
 
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
END Exists;
 
 
PROCEDURE Close (VAR F: FS);
BEGIN
IF F # NIL THEN
DISPOSE(F)
adr := 0;
IF (lib # 0) & (name # "") THEN
cur := lib;
REPEAT
sys.GET(cur, procname);
INC(cur, 8)
UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0]));
IF procname # 0 THEN
sys.GET(cur - 4, adr)
END
END Close;
 
 
PROCEDURE Open (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
 
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 0;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name)
END
ELSE
F := NIL
END
RETURN adr
END GetProcAdr;
 
RETURN F
END Open;
 
 
PROCEDURE Read (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
 
PROCEDURE Time*(VAR sec, dsec: INTEGER);
VAR t: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 0;
F.bytes := Count;
F.buffer := Buffer;
res := K.sysfunc22(70, SYSTEM.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
t := API.sysfunc2(26, 9);
sec := t DIV 100;
dsec := t MOD 100
END Time;
 
RETURN res2
END Read;
PROCEDURE init*;
VAR Lib: INTEGER;
 
 
PROCEDURE Write (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
 
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 3;
F.bytes := Count;
F.buffer := Buffer;
res := K.sysfunc22(70, SYSTEM.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
a := GetProcAdr(name, Lib);
sys.PUT(v, a)
END GetProc;
 
RETURN res2
END Write;
 
 
PROCEDURE Create (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
res2: INTEGER;
 
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 2;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
IF K.sysfunc22(70, SYSTEM.ADR(F^), res2) # 0 THEN
DISPOSE(F)
Time(sec, dsec);
Lib := API.sysfunc3(68, 19, sys.ADR("/rd/1/lib/console.obj"));
IF Lib # 0 THEN
GetProc(sys.ADR(con_init), "con_init");
GetProc(sys.ADR(con_exit), "con_exit");
GetProc(sys.ADR(con_write_asciiz), "con_write_asciiz");
IF con_init # NIL THEN
con_init(-1, -1, -1, -1, sys.ADR("Oberon-07/11 for KolibriOS"))
END
END
END init;
 
RETURN F
END Create;
 
 
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
n: INTEGER;
fs: FS;
 
PROCEDURE ExitProcess* (n: INTEGER);
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
n := Read(fs, SYSTEM.ADR(Buffer[0]), bytes);
IF n = 0 THEN
n := -1
END
IF con_exit # NIL THEN
con_exit(FALSE)
END;
API.ExitProcess(0)
END ExitProcess;
 
RETURN n
END FileRead;
 
 
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
n: INTEGER;
fs: FS;
 
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
n := Write(fs, SYSTEM.ADR(Buffer[0]), bytes);
IF n = 0 THEN
n := -1
END
 
RETURN n
END FileWrite;
 
 
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
VAR
fs: FS;
res: INTEGER;
 
BEGIN
fs := Create(FName);
SYSTEM.GET(SYSTEM.ADR(fs), res)
RETURN res
END FileCreate;
 
 
PROCEDURE FileClose* (F: INTEGER);
VAR
fs: FS;
 
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
Close(fs)
END FileClose;
 
 
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
fs: FS;
res: INTEGER;
 
BEGIN
fs := Open(FName);
SYSTEM.GET(SYSTEM.ADR(fs), res)
RETURN res
END FileOpen;
 
 
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9)
END GetTickCount;
 
 
PROCEDURE AppAdr (): INTEGER;
VAR
buf: ARRAY 1024 OF CHAR;
a: INTEGER;
 
BEGIN
a := K.sysfunc3(9, SYSTEM.ADR(buf), -1);
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a)
a := API.sysfunc3(9, sys.ADR(buf), -1);
sys.GET(sys.ADR(buf) + 22, a)
RETURN a
END AppAdr;
 
 
PROCEDURE GetCommandLine (): INTEGER;
VAR
param: INTEGER;
 
PROCEDURE GetCommandLine*(): INTEGER;
VAR param: INTEGER;
BEGIN
SYSTEM.GET(28 + AppAdr(), param)
sys.GET(28 + AppAdr(), param)
RETURN param
END GetCommandLine;
 
 
PROCEDURE GetName (): INTEGER;
VAR
name: INTEGER;
 
PROCEDURE GetName*(): INTEGER;
VAR name: INTEGER;
BEGIN
SYSTEM.GET(32 + AppAdr(), name)
sys.GET(32 + AppAdr(), name)
RETURN name
END GetName;
 
PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN API.sysfunc3(68, 12, size)
END malloc;
 
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
 
PROCEDURE CloseFile*(hObject: INTEGER);
VAR pFS: POINTER TO OFSTRUCT;
BEGIN
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
sys.PUT(sys.ADR(pFS), hObject);
DISPOSE(pFS)
END CloseFile;
 
 
PROCEDURE ParamParse;
VAR
p, count, name, cond: INTEGER;
c: CHAR;
 
 
PROCEDURE ChangeCond (A, B, C: INTEGER; c: CHAR; VAR cond: INTEGER);
PROCEDURE _OCFile(FileName: ARRAY OF CHAR; VAR FS: OFSTRUCT; mode: INTEGER; VAR fsize: INTEGER): INTEGER;
VAR buf: ARRAY 40 OF CHAR; res: INTEGER;
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
FS.subfunc := mode;
FS.pos := 0;
FS.hpos := 0;
FS.bytes := 0;
FS.buf := sys.ADR(buf);
COPY(FileName, FS.name);
IF sysfunc22(70, sys.ADR(FS), res) = 0 THEN
res := sys.ADR(FS);
sys.GET(sys.ADR(buf) + 32, fsize)
ELSE
cond := C
res := 0
END
END ChangeCond;
RETURN res
END _OCFile;
 
 
PROCEDURE IOFile(VAR FS: OFSTRUCT; Buffer, bytes, io: INTEGER): INTEGER;
VAR res1, res: INTEGER;
BEGIN
p := GetCommandLine();
name := GetName();
Params[0, 0] := name;
WHILE GetChar(name) # 0X DO
INC(name)
FS.subfunc := io;
FS.bytes := bytes;
FS.buf := Buffer;
res1 := sysfunc22(70, sys.ADR(FS), res);
IF res = -1 THEN
res := 0
END;
Params[0, 1] := name - 1;
cond := 0;
count := 1;
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
FS.pos := FS.pos + res
RETURN res
END IOFile;
 
 
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
 
PROCEDURE OCFile(FName: ARRAY OF CHAR; mode: INTEGER): INTEGER;
VAR FS: OFSTRUCT; pFS: POINTER TO OFSTRUCT; res: INTEGER;
BEGIN
j := 0;
IF n < argc THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i);
END;
END;
s[j] := 0X
END GetArg;
IF _OCFile(FName, FS, mode, fsize) # 0 THEN
NEW(pFS);
IF pFS = NIL THEN
res := 0
ELSE
sys.GET(sys.ADR(pFS), res);
pFS^ := FS
END
ELSE
res := 0
END
RETURN res
END OCFile;
 
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN OCFile(FName, 2)
END CreateFile;
 
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN OCFile(FName, 5)
END OpenFile;
 
BEGIN
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE FileSize* (F: INTEGER): INTEGER;
RETURN fsize
END FileSize;
 
 
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
 
 
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
VAR
date, time: INTEGER;
 
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR pFS: POINTER TO OFSTRUCT; res: INTEGER;
BEGIN
date := K.sysfunc1(29);
time := K.sysfunc1(3);
IF hFile # 0 THEN
sys.PUT(sys.ADR(pFS), hFile);
res := IOFile(pFS^, Buffer, nNumberOfBytes, 3 * ORD(write))
ELSE
res := 0
END
RETURN res
END FileRW;
 
year := date MOD 16;
date := date DIV 16;
year := (date MOD 16) * 10 + year;
date := date DIV 16;
 
month := date MOD 16;
date := date DIV 16;
month := (date MOD 16) * 10 + month;
date := date DIV 16;
 
day := date MOD 16;
date := date DIV 16;
day := (date MOD 16) * 10 + day;
date := date DIV 16;
 
hour := time MOD 16;
time := time DIV 16;
hour := (time MOD 16) * 10 + hour;
time := time DIV 16;
 
min := time MOD 16;
time := time DIV 16;
min := (time MOD 16) * 10 + min;
time := time DIV 16;
 
sec := time MOD 16;
time := time DIV 16;
sec := (time MOD 16) * 10 + sec;
time := time DIV 16;
 
year := year + 2000
END now;
 
 
PROCEDURE UnixTime* (): INTEGER;
RETURN 0
END UnixTime;
 
 
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR n: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), a);
SYSTEM.GET(SYSTEM.ADR(x) + 4, b)
RETURN a
END splitf;
n := ORD(str[0] = 3X);
IF con_write_asciiz # NIL THEN
con_write_asciiz(sys.ADR(str[n]))
ELSE
API.DebugMsg(sys.ADR(str[n]), 0)
END
END OutString;
 
 
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
Console := API.import;
IF Console THEN
con_init(-1, -1, -1, -1, SYSTEM.SADR("Oberon-07 for KolibriOS"))
END;
ParamParse
END HOST.
/programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07
1,195 → 1,162
(*
BSD 2-Clause License
(*
Copyright 2016, 2018 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
 
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE KOSAPI;
 
IMPORT SYSTEM;
IMPORT sys := SYSTEM;
 
TYPE STRING = ARRAY 1024 OF CHAR;
 
TYPE
VAR DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER);
 
STRING = ARRAY 1024 OF CHAR;
 
 
VAR
 
DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER);
 
imp_error*: RECORD
 
proc*, lib*: STRING;
error*: INTEGER
 
END;
 
 
PROCEDURE [stdcall-] sysfunc1* (arg1: INTEGER): INTEGER;
PROCEDURE [stdcall] sysfunc1*(arg1: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
0CDH, 040H, (* int 64 *)
0C9H, (* leave *)
0C2H, 004H, 000H (* ret 4 *)
)
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;
PROCEDURE [stdcall] sysfunc2*(arg1, arg2: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 8 *)
)
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;
PROCEDURE [stdcall] sysfunc3*(arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
 
 
PROCEDURE [stdcall-] sysfunc4* (arg1, arg2, arg3, arg4: INTEGER): INTEGER;
PROCEDURE [stdcall] sysfunc4*(arg1, arg2, arg3, arg4: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 16 *)
)
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21000"); (* ret 10h *)
RETURN 0
END sysfunc4;
 
 
PROCEDURE [stdcall-] sysfunc5* (arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
PROCEDURE [stdcall] sysfunc5*(arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
0CDH, 040H, (* int 64 *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 014H, 000H (* ret 20 *)
)
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
RETURN 0
END sysfunc5;
 
 
PROCEDURE [stdcall-] sysfunc6* (arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER;
PROCEDURE [stdcall] sysfunc6*(arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
0CDH, 040H, (* int 64 *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 018H, 000H (* ret 24 *)
)
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("57"); (* push edi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5F"); (* pop edi *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21800"); (* ret 18h *)
RETURN 0
END sysfunc6;
 
 
PROCEDURE [stdcall-] sysfunc7* (arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER;
PROCEDURE [stdcall] sysfunc7*(arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
055H, (* push ebp *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
08BH, 06DH, 020H, (* mov ebp, dword [ebp + 32] *)
0CDH, 040H, (* int 64 *)
05DH, (* pop ebp *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 01CH, 000H (* ret 28 *)
)
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("57"); (* push edi *)
sys.CODE("55"); (* push ebp *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *)
sys.CODE("8B6D20"); (* mov ebp, [ebp + 20h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5D"); (* pop ebp *)
sys.CODE("5F"); (* pop edi *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21C00"); (* ret 1Ch *)
RETURN 0
END sysfunc7;
 
 
PROCEDURE [stdcall-] sysfunc22* (arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
PROCEDURE [stdcall] sysfunc22*(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
0CDH, 040H, (* int 64 *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 019H, (* mov dword [ecx], ebx *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8919"); (* mov [ecx], ebx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc22;
 
 
PROCEDURE mem_commit (adr, size: INTEGER);
VAR
tmp: INTEGER;
 
VAR tmp: INTEGER;
BEGIN
FOR tmp := adr TO adr + size - 1 BY 4096 DO
SYSTEM.PUT(tmp, 0)
sys.PUT(tmp, 0)
END
END mem_commit;
 
 
PROCEDURE [stdcall] malloc* (size: INTEGER): INTEGER;
VAR
ptr: INTEGER;
 
VAR ptr: INTEGER;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
sys.CODE("60"); (* pusha *)
IF sysfunc2(18, 16) > ASR(size, 10) THEN
ptr := sysfunc3(68, 12, size);
IF ptr # 0 THEN
198,122 → 165,98
ELSE
ptr := 0
END;
SYSTEM.CODE(061H) (* popa *)
sys.CODE("61") (* popa *)
RETURN ptr
END malloc;
 
 
PROCEDURE [stdcall] free* (ptr: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
sys.CODE("60"); (* pusha *)
IF ptr # 0 THEN
ptr := sysfunc3(68, 13, ptr)
END;
SYSTEM.CODE(061H) (* popa *)
sys.CODE("61") (* popa *)
RETURN 0
END free;
 
 
PROCEDURE [stdcall] realloc* (ptr, size: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(060H); (* pusha *)
sys.CODE("60"); (* pusha *)
ptr := sysfunc4(68, 20, size, ptr);
SYSTEM.CODE(061H) (* popa *)
sys.CODE("61") (* popa *)
RETURN ptr
END realloc;
 
 
PROCEDURE AppAdr (): INTEGER;
VAR
buf: ARRAY 1024 OF CHAR;
a: INTEGER;
 
BEGIN
a := sysfunc3(9, SYSTEM.ADR(buf), -1);
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a)
a := sysfunc3(9, sys.ADR(buf), -1);
sys.GET(sys.ADR(buf) + 22, a)
RETURN a
END AppAdr;
 
 
PROCEDURE GetCommandLine* (): INTEGER;
VAR
param: INTEGER;
 
VAR param: INTEGER;
BEGIN
SYSTEM.GET(28 + AppAdr(), param)
sys.GET(28 + AppAdr(), param)
RETURN param
END GetCommandLine;
 
 
PROCEDURE GetName* (): INTEGER;
VAR
name: INTEGER;
 
VAR name: INTEGER;
BEGIN
SYSTEM.GET(32 + AppAdr(), name)
sys.GET(32 + AppAdr(), name)
RETURN name
END GetName;
 
 
PROCEDURE [stdcall] dll_init2 (arg1, arg2, arg3, arg4, arg5: INTEGER);
BEGIN
SYSTEM.CODE(
060H, (* pusha *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
0FFH, 0D6H, (* call esi *)
061H, (* popa *)
0C9H, (* leave *)
0C2H, 014H, 000H (* ret 20 *)
)
sys.CODE("60"); (* pusha *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("FFD6"); (* call esi *)
sys.CODE("61"); (* popa *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
END dll_init2;
 
 
PROCEDURE GetProcAdr* (name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR
cur, procname, adr: INTEGER;
VAR cur, procname, adr: INTEGER;
 
 
PROCEDURE streq (str1, str2: INTEGER): BOOLEAN;
VAR
c1, c2: CHAR;
 
VAR c1, c2: CHAR;
BEGIN
REPEAT
SYSTEM.GET(str1, c1);
SYSTEM.GET(str2, c2);
sys.GET(str1, c1);
sys.GET(str2, c2);
INC(str1);
INC(str2)
UNTIL (c1 # c2) OR (c1 = 0X)
 
RETURN c1 = c2
END streq;
 
 
BEGIN
adr := 0;
IF (lib # 0) & (name # "") THEN
cur := lib;
REPEAT
SYSTEM.GET(cur, procname);
sys.GET(cur, procname);
INC(cur, 8)
UNTIL (procname = 0) OR streq(procname, SYSTEM.ADR(name[0]));
UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0]));
IF procname # 0 THEN
SYSTEM.GET(cur - 4, adr)
sys.GET(cur - 4, adr)
END
END
 
RETURN adr
END GetProcAdr;
 
 
PROCEDURE init (dll: INTEGER);
VAR
lib_init: INTEGER;
 
VAR lib_init: INTEGER;
BEGIN
lib_init := GetProcAdr("lib_init", dll);
IF lib_init # 0 THEN
322,62 → 265,51
lib_init := GetProcAdr("START", dll);
IF lib_init # 0 THEN
DLL_INIT(lib_init)
END
END;
END init;
 
PROCEDURE [stdcall] dll_Load(import_table: INTEGER): INTEGER;
VAR imp, lib, exp, proc, res: INTEGER;
fail, done: BOOLEAN;
procname, libname: STRING;
 
PROCEDURE GetStr (adr, i: INTEGER; VAR str: STRING);
VAR
c: CHAR;
VAR c: CHAR;
BEGIN
REPEAT
SYSTEM.GET(adr, c); INC(adr);
sys.GET(adr, c); INC(adr);
str[i] := c; INC(i)
UNTIL c = 0X
END GetStr;
 
 
PROCEDURE [stdcall] dll_Load* (import_table: INTEGER): INTEGER;
VAR
imp, lib, exp, proc, res: INTEGER;
fail, done: BOOLEAN;
procname, libname: STRING;
 
BEGIN
SYSTEM.CODE(060H); (* pusha *)
sys.CODE("60"); (* pusha *)
fail := FALSE;
done := FALSE;
res := 0;
libname := "/rd/1/lib/";
REPEAT
SYSTEM.GET(import_table, imp);
sys.GET(import_table, imp);
IF imp # 0 THEN
SYSTEM.GET(import_table + 4, lib);
sys.GET(import_table + 4, lib);
GetStr(lib, 10, libname);
exp := sysfunc3(68, 19, SYSTEM.ADR(libname[0]));
exp := sysfunc3(68, 19, sys.ADR(libname[0]));
fail := exp = 0;
ELSE
done := TRUE
END;
IF fail THEN
done := TRUE;
imp_error.proc := "";
imp_error.lib := libname;
imp_error.error := 1
done := TRUE
END;
IF (imp # 0) & ~fail THEN
REPEAT
SYSTEM.GET(imp, proc);
sys.GET(imp, proc);
IF proc # 0 THEN
GetStr(proc, 0, procname);
proc := GetProcAdr(procname, exp);
IF proc # 0 THEN
SYSTEM.PUT(imp, proc);
INC(imp, 4)
ELSE
imp_error.proc := procname;
imp_error.lib := libname;
imp_error.error := 2
sys.PUT(imp, proc);
INC(imp, 4);
END
END
UNTIL proc = 0;
389,28 → 321,24
res := 1
END;
import_table := res;
SYSTEM.CODE(061H) (* popa *)
sys.CODE("61") (* popa *)
RETURN import_table
END dll_Load;
 
 
PROCEDURE [stdcall] dll_Init (entry: INTEGER);
BEGIN
SYSTEM.CODE(060H); (* pusha *)
sys.CODE("60"); (* pusha *)
IF entry # 0 THEN
dll_init2(SYSTEM.ADR(malloc), SYSTEM.ADR(free), SYSTEM.ADR(realloc), SYSTEM.ADR(dll_Load), entry)
dll_init2(sys.ADR(malloc), sys.ADR(free), sys.ADR(realloc), sys.ADR(dll_Load), entry)
END;
SYSTEM.CODE(061H); (* popa *)
sys.CODE("61"); (* popa *)
END dll_Init;
 
 
PROCEDURE LoadLib* (name: ARRAY OF CHAR): INTEGER;
VAR
Lib: INTEGER;
 
VAR Lib: INTEGER;
BEGIN
DLL_INIT := dll_Init;
Lib := sysfunc3(68, 19, SYSTEM.ADR(name[0]));
Lib := sysfunc3(68, 19, sys.ADR(name[0]));
IF Lib # 0 THEN
init(Lib)
END
417,14 → 345,4
RETURN Lib
END LoadLib;
 
 
PROCEDURE _init*;
BEGIN
DLL_INIT := dll_Init;
imp_error.lib := "";
imp_error.proc := "";
imp_error.error := 0
END _init;
 
 
END KOSAPI.
/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07
1,441 → 1,193
(*
BSD 2-Clause License
(*
Copyright 2016, 2017 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
 
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE RTL;
 
IMPORT SYSTEM, API;
IMPORT sys := SYSTEM, API;
 
 
CONST
 
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
 
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
 
SIZE_OF_DWORD = 4;
 
 
TYPE
 
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
 
 
VAR
 
name: INTEGER;
types: INTEGER;
SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
 
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
 
 
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN
SYSTEM.CODE(
API.ExitProcess(n)
END _halt;
 
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 00CH, (* mov esi, dword [ebp + 12] *)
08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
 
 
PROCEDURE [stdcall] _move2* (bytes, dest, source: INTEGER);
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
BEGIN
SYSTEM.CODE(
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
 
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move2;
 
 
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
 
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, src, dst);
res := TRUE
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
END
END _disprec;
 
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
 
 
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
 
 
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
 
 
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
 
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
 
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
 
END _rot;
 
 
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
END;
IF a < 0 THEN
a := 0
END;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
ELSE
res := 0
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
END
 
RETURN res
END _set2;
END _saverec;
 
 
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
END _set;
 
 
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: INTEGER;
BEGIN
SYSTEM.CODE(
 
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
0F7H, 0F9H, (* idiv ecx *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 011H, (* mov dword [ecx], edx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
 
RETURN 0
END divmod;
 
 
PROCEDURE div_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
 
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
DEC(div)
m := bsize * idx;
FOR i := 4 TO Dim + 2 DO
m := m * Arr[i]
END;
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := c + m
ELSE
Arr[3] := 0
END
END _arrayidx;
 
RETURN div
END div_;
 
 
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
 
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
INC(mod, y)
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
END
END _arrayidx1;
 
RETURN mod
END mod_;
 
 
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(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)
END _mod;
 
 
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
 
 
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: INTEGER;
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, SIZE_OF_DWORD)
FOR i := 1 TO n DO
t := Arr[0];
FOR j := 0 TO m + n - 1 DO
Arr[j] := Arr[j + 1]
END;
Arr[m + n] := t
END
END _new;
END _arrayrot;
 
 
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
END
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(
 
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
 
sys.CODE("8B4508"); // mov eax, [ebp + 08h]
sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch]
sys.CODE("48"); // dec eax
// L1:
sys.CODE("40"); // inc eax
sys.CODE("803800"); // cmp byte ptr [eax], 0
sys.CODE("7403"); // jz L2
sys.CODE("E2F8"); // loop L1
sys.CODE("40"); // inc eax
// L2:
sys.CODE("2B4508"); // sub eax, [ebp + 08h]
sys.CODE("C9"); // leave
sys.CODE("C20800"); // ret 08h
RETURN 0
END _length;
 
 
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN
SYSTEM.CODE(
_savearr(MIN(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
 
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H, (* shr eax, 1 *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
 
RETURN 0
END _lengthw;
 
 
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
 
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
 
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b)));
IF i = 0 THEN
i := _length(a) - _length(b)
END;
 
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
|0: Res := i = 0
|1: Res := i # 0
|2: Res := i < 0
|3: Res := i > 0
|4: Res := i <= 0
|5: Res := i >= 0
ELSE
END
 
RETURN bRes
RETURN Res
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;
 
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
 
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
END;
 
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
 
RETURN bRes
END _strcmpw;
 
 
PROCEDURE [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;
i: INTEGER;
 
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
 
 
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
 
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
BEGIN
 
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
 
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
445,186 → 197,80
DEC(b)
END;
str[i] := 0X
END IntToStr;
END Int;
 
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER);
VAR msg, int: STRING; pos, n: INTEGER;
 
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
PROCEDURE StrAppend(s: STRING);
VAR i, n: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
 
ASSERT(n1 + n2 < LEN(s1));
 
n := LEN(s);
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
 
s1[j] := 0X
 
END append;
 
 
PROCEDURE [stdcall] _error* (module, err: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
 
BEGIN
 
s := "";
CASE err MOD 16 OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
| 4: append(s, "NIL procedure call")
| 5: append(s, "type guard error")
| 6: append(s, "index out of range")
| 7: append(s, "invalid CASE")
| 8: append(s, "array assignment error")
| 9: append(s, "CHR out of range")
|10: append(s, "WCHR out of range")
|11: append(s, "BYTE out of range")
END;
 
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);
 
API.DebugMsg(SYSTEM.ADR(s[0]), name);
 
API.exit_thread(0)
END _error;
 
 
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
BEGIN
(* r IS t0 *)
 
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
END
END StrAppend;
 
RETURN t1 = t0
END _isrec;
 
 
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: 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
pos := 0;
n := line MOD 16;
line := line DIV 16;
CASE n OF
|1: StrAppend("assertion failure")
|2: StrAppend("variable of a procedure type has NIL as value")
|3: StrAppend("typeguard error")
|4: StrAppend("inadmissible dynamic type")
|5: StrAppend("index check error")
|6: StrAppend("NIL pointer dereference")
|7: StrAppend("invalid value in case statement")
|8: StrAppend("division by zero")
ELSE
t1 := -1
END
END;
StrAppend(0DX);
StrAppend(0AX);
StrAppend("module ");
StrAppend(modname);
StrAppend(0DX);
StrAppend(0AX);
StrAppend("line ");
Int(line, int);
StrAppend(int);
IF m = 2 THEN
StrAppend(0DX);
StrAppend(0AX);
StrAppend("code ");
Int(code, int);
StrAppend(int)
END;
API.DebugMsg(sys.ADR(msg), SelfName);
API.ExitThread(0)
END _assrt;
 
RETURN t1 = t0
END _is;
 
 
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
PROCEDURE [stdcall] _close*;
BEGIN
(* r:t1 IS t0 *)
 
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
IF CloseProc # NIL THEN
CloseProc
END
END _close;
 
RETURN t1 = t0
END _guardrec;
 
 
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
 
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: 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)
IF ~init THEN
API.zeromem(gsize, gadr);
init := TRUE;
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL
END
ELSE
t1 := t0
END
END _init;
 
RETURN t1 = t0
END _guard;
 
 
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE SetClose*(proc: PROC);
BEGIN
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
res := 0;
IF dll.thread_attach # NIL THEN
dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
res := 0;
IF dll.thread_detach # NIL THEN
dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
res := 0;
IF dll.process_detach # NIL THEN
dll.process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
res := 0
END
CloseProc := proc
END SetClose;
 
RETURN res
END _dllentry;
 
 
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
dll.process_detach := process_detach;
dll.thread_detach := thread_detach;
dll.thread_attach := thread_attach
END SetDll;
 
 
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
 
 
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
 
types := _types;
name := modname;
 
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
END _init;
 
 
END RTL.
/programs/develop/oberon07/Lib/KolibriOS/Args.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
38,7 → 38,7
PROCEDURE ParamParse;
VAR p, count, name: INTEGER; c: CHAR; cond: INTEGER;
 
PROCEDURE ChangeCond(A, B, C: INTEGER; c: CHAR; VAR cond: INTEGER);
PROCEDURE ChangeCond(A, B, C: INTEGER);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
64,11 → 64,11
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
END;
INC(p)
/programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
66,7 → 66,7
PROCEDURE main;
VAR Lib: INTEGER;
 
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
77,25 → 77,25
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/Console.obj");
ASSERT(Lib # 0);
GetProc(Lib, sys.ADR(version), "version");
GetProc(Lib, sys.ADR(init), "con_init");
GetProc(Lib, sys.ADR(exit), "con_exit");
GetProc(Lib, sys.ADR(write_asciiz), "con_write_asciiz");
GetProc(Lib, sys.ADR(write_string), "con_write_string");
GetProc(Lib, sys.ADR(get_flags), "con_get_flags");
GetProc(Lib, sys.ADR(set_flags), "con_set_flags");
GetProc(Lib, sys.ADR(get_font_height), "con_get_font_height");
GetProc(Lib, sys.ADR(get_cursor_height), "con_get_cursor_height");
GetProc(Lib, sys.ADR(set_cursor_height), "con_set_cursor_height");
GetProc(Lib, sys.ADR(getch), "con_getch");
GetProc(Lib, sys.ADR(getch2), "con_getch2");
GetProc(Lib, sys.ADR(kbhit), "con_kbhit");
GetProc(Lib, sys.ADR(gets), "con_gets");
GetProc(Lib, sys.ADR(gets2), "con_gets2");
GetProc(Lib, sys.ADR(cls), "con_cls");
GetProc(Lib, sys.ADR(get_cursor_pos), "con_get_cursor_pos");
GetProc(Lib, sys.ADR(set_cursor_pos), "con_set_cursor_pos");
GetProc(Lib, sys.ADR(set_title), "con_set_title");
GetProc(sys.ADR(version), "version");
GetProc(sys.ADR(init), "con_init");
GetProc(sys.ADR(exit), "con_exit");
GetProc(sys.ADR(write_asciiz), "con_write_asciiz");
GetProc(sys.ADR(write_string), "con_write_string");
GetProc(sys.ADR(get_flags), "con_get_flags");
GetProc(sys.ADR(set_flags), "con_set_flags");
GetProc(sys.ADR(get_font_height), "con_get_font_height");
GetProc(sys.ADR(get_cursor_height), "con_get_cursor_height");
GetProc(sys.ADR(set_cursor_height), "con_set_cursor_height");
GetProc(sys.ADR(getch), "con_getch");
GetProc(sys.ADR(getch2), "con_getch2");
GetProc(sys.ADR(kbhit), "con_kbhit");
GetProc(sys.ADR(gets), "con_gets");
GetProc(sys.ADR(gets2), "con_gets2");
GetProc(sys.ADR(cls), "con_cls");
GetProc(sys.ADR(get_cursor_pos), "con_get_cursor_pos");
GetProc(sys.ADR(set_cursor_pos), "con_set_cursor_pos");
GetProc(sys.ADR(set_title), "con_set_title");
END main;
 
BEGIN
/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
21,11 → 21,11
 
CONST
 
d = 1.0 - 5.0E-12;
d = 1.0D0 - 5.0D-12;
 
VAR
 
Realp: PROCEDURE (x: REAL; width: INTEGER);
Realp: PROCEDURE (x: LONGREAL; width: INTEGER);
 
PROCEDURE Char*(c: CHAR);
VAR res: INTEGER;
72,7 → 72,7
UNTIL i = 0
END WriteInt;
 
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
80,8 → 80,8
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
 
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
PROCEDURE IsInf(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
 
PROCEDURE Int*(x, width: INTEGER);
97,15 → 97,15
END
END Int;
 
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
PROCEDURE OutInf(x: LONGREAL; width: INTEGER);
VAR s: ARRAY 4 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0) THEN
ELSIF IsInf(x) & (x > 0.0D0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
ELSIF IsInf(x) & (x < 0.0D0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
120,8 → 120,8
Char(0AX)
END Ln;
 
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
PROCEDURE _FixReal(x: LONGREAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
130,19 → 130,19
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
IF x < 0.0D0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
IF x > 9.0D0 + d THEN
INC(len)
END;
IF p > 0 THEN
158,30 → 158,30
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
WHILE (y < 1.0D0) & (y # 0.0D0) DO
y := y * 10.0D0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char("1");
x := 0.0
x := 0.0D0
ELSE
Char("0");
x := x * 10.0
x := x * 10.0D0
END
ELSE
WHILE e >= 0 DO
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x > 9.0D0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(e)
END
190,12 → 190,12
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(p)
END
202,7 → 202,7
END
END _FixReal;
 
PROCEDURE Real*(x: REAL; width: INTEGER);
PROCEDURE Real*(x: LONGREAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
217,22 → 217,22
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
IF x < 0.0D0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
WHILE (x < 1.0D0) & (x # 0.0D0) DO
x := x * 10.0D0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
IF x > 9.0D0 + d THEN
x := 1.0D0;
INC(e)
END;
FOR i := 1 TO n DO
260,7 → 260,7
END
END Real;
 
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
282,7 → 282,7
BEGIN
info.subfunc := 7;
info.flags := 0;
info.param := sys.SADR(" ");
info.param := sys.ADR(" ");
info.rsrvd1 := 0;
info.rsrvd2 := 0;
info.fname := "/rd/1/develop/board";
/programs/develop/oberon07/Lib/KolibriOS/Out.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
21,11 → 21,11
 
CONST
 
d = 1.0 - 5.0E-12;
d = 1.0D0 - 5.0D-12;
 
VAR
 
Realp: PROCEDURE (x: REAL; width: INTEGER);
Realp: PROCEDURE (x: LONGREAL; width: INTEGER);
 
PROCEDURE Char*(c: CHAR);
BEGIN
67,7 → 67,7
UNTIL i = 0
END WriteInt;
 
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
75,8 → 75,8
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
 
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
PROCEDURE IsInf(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
 
PROCEDURE Int*(x, width: INTEGER);
92,15 → 92,15
END
END Int;
 
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
PROCEDURE OutInf(x: LONGREAL; width: INTEGER);
VAR s: ARRAY 4 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0) THEN
ELSIF IsInf(x) & (x > 0.0D0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0) THEN
ELSIF IsInf(x) & (x < 0.0D0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
115,8 → 115,8
Char(0AX)
END Ln;
 
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
PROCEDURE _FixReal(x: LONGREAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
125,19 → 125,19
ELSE
len := 0;
minus := FALSE;
IF x < 0.0 THEN
IF x < 0.0D0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0 DO
x := x / 10.0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0 + d THEN
IF x > 9.0D0 + d THEN
INC(len)
END;
IF p > 0 THEN
153,30 → 153,30
Char("-")
END;
y := x;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
WHILE (y < 1.0D0) & (y # 0.0D0) DO
y := y * 10.0D0;
DEC(e)
END;
IF e < 0 THEN
IF x - FLT(FLOOR(x)) > d THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char("1");
x := 0.0
x := 0.0D0
ELSE
Char("0");
x := x * 10.0
x := x * 10.0D0
END
ELSE
WHILE e >= 0 DO
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x > 9.0D0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(e)
END
185,12 → 185,12
Char(".")
END;
WHILE p > 0 DO
IF x - FLT(FLOOR(x)) > d THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(p)
END
197,7 → 197,7
END
END _FixReal;
 
PROCEDURE Real*(x: REAL; width: INTEGER);
PROCEDURE Real*(x: LONGREAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
212,22 → 212,22
width := 9
END;
width := width - 5;
IF x < 0.0 THEN
IF x < 0.0D0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0 DO
x := x / 10.0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
WHILE (x < 1.0D0) & (x # 0.0D0) DO
x := x * 10.0D0;
DEC(e)
END;
IF x > 9.0 + d THEN
x := 1.0;
IF x > 9.0D0 + d THEN
x := 1.0D0;
INC(e)
END;
FOR i := 1 TO n DO
255,7 → 255,7
END
END Real;
 
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
/programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
51,7 → 51,7
 
PROCEDURE [stdcall] zeromem(size, adr: INTEGER);
BEGIN
sys.CODE(057H, 08BH, 07DH, 00CH, 08BH, 04DH, 008H, 033H, 0C0H, 09CH, 0FCH, 0F3H, 0ABH, 09DH, 05FH)
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
 
PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN);
97,6 → 97,7
END rgb;
 
PROCEDURE create_glyph(VAR Font: TFont_desc; VAR glyph: Glyph; xsize, ysize: INTEGER);
VAR res: INTEGER;
BEGIN
glyph.base := Font.mempos;
glyph.xsize := xsize;
/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
65,7 → 65,7
res.color_type := 0;
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.SADR("/rd/1/colrdial");
res.start_path := sys.ADR("/rd/1/colrdial");
res.draw_window := draw_window;
res.status := 0;
res.X := 0;
86,7 → 86,7
PROCEDURE Load;
VAR Lib: INTEGER;
 
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
96,8 → 96,8
 
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(Lib, sys.ADR(Dialog_init), "ColorDialog_init");
GetProc(Lib, sys.ADR(Dialog_start), "ColorDialog_start");
GetProc(sys.ADR(Dialog_init), "ColorDialog_init");
GetProc(sys.ADR(Dialog_start), "ColorDialog_start");
END Load;
 
BEGIN
/programs/develop/oberon07/Lib/KolibriOS/Console.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
17,9 → 17,8
 
MODULE Console;
 
IMPORT ConsoleLib, In, Out;
IMPORT ConsoleLib;
 
 
CONST
 
Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3;
27,29 → 26,23
DarkGray* = 8; LightBlue* = 9; LightGreen* = 10; LightCyan* = 11;
LightRed* = 12; LightMagenta* = 13; Yellow* = 14; White* = 15;
 
 
PROCEDURE SetCursor* (X, Y: INTEGER);
BEGIN
ConsoleLib.set_cursor_pos(X, Y)
END SetCursor;
 
 
PROCEDURE GetCursor* (VAR X, Y: INTEGER);
BEGIN
ConsoleLib.get_cursor_pos(X, Y)
END GetCursor;
 
 
PROCEDURE Cls*;
BEGIN
ConsoleLib.cls
END Cls;
 
 
PROCEDURE SetColor* (FColor, BColor: INTEGER);
VAR
res: INTEGER;
 
VAR res: INTEGER;
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
res := ConsoleLib.set_flags(LSL(BColor, 4) + FColor)
56,39 → 49,18
END
END SetColor;
 
 
PROCEDURE GetCursorX* (): INTEGER;
VAR
x, y: INTEGER;
 
VAR x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN x
END GetCursorX;
 
 
PROCEDURE GetCursorY* (): INTEGER;
VAR
x, y: INTEGER;
 
VAR x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN y
END GetCursorY;
 
 
PROCEDURE open*;
BEGIN
ConsoleLib.open(-1, -1, -1, -1, "");
In.Open;
Out.Open
END open;
 
 
PROCEDURE exit* (bCloseWindow: BOOLEAN);
BEGIN
ConsoleLib.exit(bCloseWindow)
END exit;
 
 
END Console.
/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
19,10 → 19,10
 
IMPORT KOSAPI;
 
CONST ERR* = -7.0E5;
CONST ERR* = -7.0D5;
 
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL;
VAR d, i: INTEGER; M: ARRAY 14 OF CHAR; Res: REAL;
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL;
VAR d, i: INTEGER; M: ARRAY 13 OF CHAR; Res: LONGREAL;
BEGIN
Res := ERR;
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) &
38,16 → 38,16
FOR i := 1 TO Month - 1 DO
d := d + ORD(M[i]) - ORD("0") + 28
END;
Res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000) / 86400000.0
Res := LONG(FLT(d)) + LONG(FLT(Hour * 3600000 + Min * 60000 + Sec * 1000)) / 86400000.0D0
END
END
RETURN Res
END Encode;
 
PROCEDURE Decode*(Date: REAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN;
VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 14 OF CHAR;
PROCEDURE Decode*(Date: LONGREAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN;
VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 13 OF CHAR;
 
PROCEDURE MonthDay(n: INTEGER; VAR d, Month: INTEGER; M: ARRAY OF CHAR): BOOLEAN;
PROCEDURE MonthDay(n: INTEGER): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
Res := FALSE;
60,9 → 60,9
END MonthDay;
 
BEGIN
IF (Date >= -693593.0) & (Date < 2958466.0) THEN
IF (Date >= -693593.0D0) & (Date < 2958466.0D0) THEN
d := FLOOR(Date);
t := FLOOR((Date - FLT(d)) * 86400000.0);
t := FLOOR((Date - LONG(FLT(d))) * 86400000.0D0);
d := d + 693593;
Year := 1;
Month := 1;
82,7 → 82,7
i := 1;
flag := TRUE;
WHILE flag & (i <= 12) DO
flag := MonthDay(i, d, Month, M);
flag := MonthDay(i);
INC(i)
END;
Day := d;
98,7 → 98,7
RETURN Res
END Decode;
 
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec, Msec: INTEGER);
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec: INTEGER);
VAR date, time: INTEGER;
BEGIN
date := KOSAPI.sysfunc1(29);
134,8 → 134,7
Sec := (time MOD 16) * 10 + Sec;
time := time DIV 16;
 
Year := Year + 2000;
Msec := 0
Year := Year + 2000
END Now;
 
END DateTime.
/programs/develop/oberon07/Lib/KolibriOS/File.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
19,12 → 19,10
 
IMPORT sys := SYSTEM, KOSAPI;
 
 
CONST
 
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
 
 
TYPE
 
FNAME* = ARRAY 520 OF CHAR;
49,36 → 47,29
name*: FNAME
END;
 
 
PROCEDURE [stdcall] f_68_27 (file_name: INTEGER; VAR size: INTEGER): INTEGER;
BEGIN
sys.CODE(
053H, (* push ebx *)
06AH, 044H, (* push 68 *)
058H, (* pop eax *)
06AH, 01BH, (* push 27 *)
05BH, (* pop ebx *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *)
0CDH, 040H, (* int 64 *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
089H, 011H, (* mov dword [ecx], edx *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 8 *)
)
sys.CODE("53"); (* push ebx *)
sys.CODE("6A44"); (* push 68 *)
sys.CODE("58"); (* pop eax *)
sys.CODE("6A1B"); (* push 27 *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("8B4D08"); (* mov ecx, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D0C"); (* mov ecx, [ebp + 0Ch] *)
sys.CODE("8911"); (* mov [ecx], edx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END f_68_27;
 
 
PROCEDURE Load* (FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
RETURN f_68_27(sys.ADR(FName[0]), size)
END Load;
 
 
PROCEDURE GetFileInfo* (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR
res2: INTEGER; fs: rFS;
 
VAR res2: INTEGER; fs: rFS;
BEGIN
fs.subfunc := 5;
fs.pos := 0;
86,19 → 77,15
fs.bytes := 0;
fs.buffer := sys.ADR(Info);
COPY(FName, fs.name)
 
RETURN KOSAPI.sysfunc22(70, sys.ADR(fs), res2) = 0
END GetFileInfo;
 
 
PROCEDURE Exists* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
VAR fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
END Exists;
 
PROCEDURE Close* (VAR F: FS);
BEGIN
IF F # NIL THEN
106,13 → 93,9
END
END Close;
 
 
PROCEDURE Open* (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
 
VAR F: FS;
BEGIN
 
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
126,18 → 109,12
ELSE
F := NIL
END
 
RETURN F
END Open;
 
 
PROCEDURE Delete* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
F: FS;
res, res2: INTEGER;
 
VAR F: FS; res, res2: INTEGER;
BEGIN
 
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
155,18 → 132,12
ELSE
res := -1
END
 
RETURN res = 0
END Delete;
 
PROCEDURE Seek* (F: FS; Offset, Origin: INTEGER): INTEGER;
VAR
res: INTEGER;
fd: rFD;
 
VAR res: INTEGER; fd: rFD;
BEGIN
 
IF (F # NIL) & GetFileInfo(F.name, fd) & (BITS(fd.attr) * {4} = {}) THEN
CASE Origin OF
|SEEK_BEG: F.pos := Offset
178,17 → 149,12
ELSE
res := -1
END
 
RETURN res
END Seek;
 
 
PROCEDURE Read* (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
 
VAR res, res2: INTEGER;
BEGIN
 
IF F # NIL THEN
F.subfunc := 0;
F.bytes := Count;
200,17 → 166,12
ELSE
res2 := 0
END
 
RETURN res2
END Read;
 
 
PROCEDURE Write* (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
 
VAR res, res2: INTEGER;
BEGIN
 
IF F # NIL THEN
F.subfunc := 3;
F.bytes := Count;
222,19 → 183,13
ELSE
res2 := 0
END
 
RETURN res2
END Write;
 
PROCEDURE Create* (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
res2: INTEGER;
 
VAR F: FS; res2: INTEGER;
BEGIN
NEW(F);
 
IF F # NIL THEN
F.subfunc := 2;
F.pos := 0;
246,27 → 201,19
DISPOSE(F)
END
END
 
RETURN F
END Create;
 
PROCEDURE DirExists* (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
VAR fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & (4 IN BITS(fd.attr))
END DirExists;
 
 
PROCEDURE CreateDir* (DirName: ARRAY OF CHAR): BOOLEAN;
VAR
F: FS;
res, res2: INTEGER;
 
VAR F: FS; res, res2: INTEGER;
BEGIN
NEW(F);
 
IF F # NIL THEN
F.subfunc := 9;
F.pos := 0;
279,18 → 226,12
ELSE
res := -1
END
 
RETURN res = 0
END CreateDir;
 
PROCEDURE DeleteDir* (DirName: ARRAY OF CHAR): BOOLEAN;
VAR
F: FS;
res, res2: INTEGER;
 
VAR F: FS; res, res2: INTEGER;
BEGIN
 
IF DirExists(DirName) THEN
NEW(F);
IF F # NIL THEN
308,9 → 249,7
ELSE
res := -1
END
 
RETURN res = 0
END DeleteDir;
 
 
END File.
/programs/develop/oberon07/Lib/KolibriOS/In.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
134,23 → 134,23
RETURN Res & (s[i] <= 20X)
END CheckReal;
 
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): REAL;
CONST maxDBL = 1.69E308; maxINT = 7FFFFFFFH;
VAR i, scale: INTEGER; res, m, d: REAL; minus, neg: BOOLEAN;
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): LONGREAL;
CONST maxDBL = 1.69D308; maxINT = 7FFFFFFFH;
VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, neg: BOOLEAN;
 
PROCEDURE part1 (str: STRING; VAR res, d: REAL; VAR i: INTEGER): BOOLEAN;
PROCEDURE part1(): BOOLEAN;
BEGIN
res := 0.0;
d := 1.0;
res := 0.0D0;
d := 1.0D0;
WHILE digit(str[i]) DO
res := res * 10.0 + FLT(ORD(str[i]) - ORD("0"));
res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0")));
INC(i)
END;
IF str[i] = "." THEN
INC(i);
WHILE digit(str[i]) DO
d := d / 10.0;
res := res + FLT(ORD(str[i]) - ORD("0")) * d;
d := d / 10.0D0;
res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d;
INC(i)
END
END
157,10 → 157,10
RETURN str[i] # 0X
END part1;
 
PROCEDURE part2 (str: STRING; VAR i, scale: INTEGER; VAR minus, err: BOOLEAN; VAR m, res: REAL): BOOLEAN;
PROCEDURE part2(): BOOLEAN;
BEGIN
INC(i);
m := 10.0;
m := 10.0D0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
167,7 → 167,7
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1
m := 0.1D0
END;
scale := 0;
err := FALSE;
174,12 → 174,12
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0
res := 0.0D0
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0
res := 0.0D0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
189,19 → 189,19
RETURN ~err
END part2;
 
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR res, m: REAL; VAR scale: INTEGER);
PROCEDURE part3;
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0
res := 0.0D0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0
res := 0.0D0
ELSE
res := res * m;
INC(i)
211,14 → 211,14
 
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1(str, res, d, i) & part2(str, i, scale, minus, err, m, res) THEN
part3(err, minus, res, m, scale)
IF part1() & part2() THEN
part3
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0;
res := 0.0D0;
err := TRUE
END
RETURN res
251,7 → 251,7
Done := TRUE
END Ln;
 
PROCEDURE Real* (VAR x: REAL);
PROCEDURE LongReal*(VAR x: LONGREAL);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
260,9 → 260,23
UNTIL ~Space(str);
x := StrToFloat(str, err);
Done := ~err
END LongReal;
 
PROCEDURE Real*(VAR x: REAL);
CONST maxREAL = 3.39E38;
VAR y: LONGREAL;
BEGIN
LongReal(y);
IF Done THEN
IF ABS(y) > LONG(maxREAL) THEN
x := 0.0;
Done := FALSE
ELSE
x := SHORT(y)
END
END
END Real;
 
 
PROCEDURE Int*(VAR x: INTEGER);
VAR str: STRING; err: BOOLEAN;
BEGIN
/programs/develop/oberon07/Lib/KolibriOS/Math.ob07
1,5 → 1,5
(*
Copyright 2013, 2014, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
17,365 → 17,238
 
MODULE Math;
 
IMPORT SYSTEM;
IMPORT sys := SYSTEM;
 
CONST pi* = 3.141592653589793D+00;
e* = 2.718281828459045D+00;
 
CONST
VAR Inf*, nInf*: LONGREAL;
 
pi* = 3.141592653589793;
e* = 2.718281828459045;
 
 
PROCEDURE IsNan* (x: REAL): BOOLEAN;
VAR
h, l: SET;
 
PROCEDURE IsNan*(x: LONGREAL): BOOLEAN;
VAR h, l: SET;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h)
sys.GET(sys.ADR(x), l);
sys.GET(sys.ADR(x) + 4, h);
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
 
 
PROCEDURE IsInf* (x: REAL): BOOLEAN;
RETURN ABS(x) = SYSTEM.INF()
PROCEDURE IsInf*(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
 
 
PROCEDURE Max (a, b: REAL): REAL;
VAR
res: REAL;
 
PROCEDURE Max(A, B: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF a > b THEN
res := a
IF A > B THEN
Res := A
ELSE
res := b
Res := B
END
RETURN res
RETURN Res
END Max;
 
 
PROCEDURE Min (a, b: REAL): REAL;
VAR
res: REAL;
 
PROCEDURE Min(A, B: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF a < b THEN
res := a
IF A < B THEN
Res := A
ELSE
res := b
Res := B
END
RETURN res
RETURN Res
END Min;
 
 
PROCEDURE SameValue (a, b: REAL): BOOLEAN;
VAR
eps: REAL;
res: BOOLEAN;
 
PROCEDURE SameValue(A, B: LONGREAL): BOOLEAN;
VAR Epsilon: LONGREAL; Res: BOOLEAN;
BEGIN
eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);
IF a > b THEN
res := (a - b) <= eps
Epsilon := Max(Min(ABS(A), ABS(B)) * 1.0D-12, 1.0D-12);
IF A > B THEN
Res := (A - B) <= Epsilon
ELSE
res := (b - a) <= eps
Res := (B - A) <= Epsilon
END
RETURN res
RETURN Res
END SameValue;
 
 
PROCEDURE IsZero (x: REAL): BOOLEAN;
RETURN ABS(x) <= 1.0E-12
PROCEDURE IsZero(x: LONGREAL): BOOLEAN;
RETURN ABS(x) <= 1.0D-12
END IsZero;
 
 
PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
PROCEDURE [stdcall] sqrt*(x: LONGREAL): LONGREAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FAH, (* fsqrt *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
sys.CODE("DD4508D9FAC9C20800")
RETURN 0.0D0
END sqrt;
 
 
PROCEDURE [stdcall] sin* (x: REAL): REAL;
PROCEDURE [stdcall] sin*(x: LONGREAL): LONGREAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FEH, (* fsin *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
sys.CODE("DD4508D9FEC9C20800")
RETURN 0.0D0
END sin;
 
 
PROCEDURE [stdcall] cos* (x: REAL): REAL;
PROCEDURE [stdcall] cos*(x: LONGREAL): LONGREAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FFH, (* fcos *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
sys.CODE("DD4508D9FFC9C20800")
RETURN 0.0D0
END cos;
 
 
PROCEDURE [stdcall] tan* (x: REAL): REAL;
PROCEDURE [stdcall] tan*(x: LONGREAL): LONGREAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FBH, (* fsincos *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
sys.CODE("DD4508D9F2DEC9C9C20800")
RETURN 0.0D0
END tan;
 
 
PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
PROCEDURE [stdcall] arctan2*(y, x: LONGREAL): LONGREAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F3H, (* fpatan *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
sys.CODE("DD4508DD4510D9F3C9C21000")
RETURN 0.0D0
END arctan2;
 
 
PROCEDURE [stdcall] ln* (x: REAL): REAL;
PROCEDURE [stdcall] ln*(x: LONGREAL): LONGREAL;
BEGIN
SYSTEM.CODE(
0D9H, 0EDH, (* fldln2 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
sys.CODE("D9EDDD4508D9F1C9C20800")
RETURN 0.0D0
END ln;
 
 
PROCEDURE [stdcall] log* (base, x: REAL): REAL;
PROCEDURE [stdcall] log*(base, x: LONGREAL): LONGREAL;
BEGIN
SYSTEM.CODE(
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F1H, (* fyl2x *)
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
sys.CODE("D9E8DD4510D9F1D9E8DD4508D9F1DEF9C9C21000")
RETURN 0.0D0
END log;
 
 
PROCEDURE [stdcall] exp* (x: REAL): REAL;
PROCEDURE [stdcall] exp*(x: LONGREAL): LONGREAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0EAH, (* fldl2e *)
0DEH, 0C9H, 0D9H, 0C0H,
0D9H, 0FCH, 0DCH, 0E9H,
0D9H, 0C9H, 0D9H, 0F0H,
0D9H, 0E8H, 0DEH, 0C1H,
0D9H, 0FDH, 0DDH, 0D9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
sys.CODE("DD4508D9EADEC9D9C0D9FCDCE9D9C9D9F0D9E8DEC1D9FDDDD9C9C20800")
RETURN 0.0D0
END exp;
 
 
PROCEDURE [stdcall] round* (x: REAL): REAL;
PROCEDURE [stdcall] round*(x: LONGREAL): LONGREAL;
BEGIN
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 07DH, 0F4H, 0D9H,
07DH, 0F6H, 066H, 081H,
04DH, 0F6H, 000H, 003H,
0D9H, 06DH, 0F6H, 0D9H,
0FCH, 0D9H, 06DH, 0F4H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
sys.CODE("DD4508D97DF4D97DF666814DF60003D96DF6D9FCD96DF4C9C20800")
RETURN 0.0D0
END round;
 
 
PROCEDURE [stdcall] frac* (x: REAL): REAL;
PROCEDURE [stdcall] frac*(x: LONGREAL): LONGREAL;
BEGIN
SYSTEM.CODE(
050H,
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0C0H, 0D9H, 03CH,
024H, 0D9H, 07CH, 024H,
002H, 066H, 081H, 04CH,
024H, 002H, 000H, 00FH,
0D9H, 06CH, 024H, 002H,
0D9H, 0FCH, 0D9H, 02CH,
024H, 0DEH, 0E9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
sys.CODE("50DD4508D9C0D93C24D97C240266814C2402000FD96C2402D9FCD92C24DEE9C9C20800")
RETURN 0.0D0
END frac;
 
 
PROCEDURE arcsin* (x: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
PROCEDURE arcsin*(x: LONGREAL): LONGREAL;
RETURN arctan2(x, sqrt(1.0D0 - x * x))
END arcsin;
 
 
PROCEDURE arccos* (x: REAL): REAL;
RETURN arctan2(sqrt(1.0 - x * x), x)
PROCEDURE arccos*(x: LONGREAL): LONGREAL;
RETURN arctan2(sqrt(1.0D0 - x * x), x)
END arccos;
 
 
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, 1.0)
PROCEDURE arctan*(x: LONGREAL): LONGREAL;
RETURN arctan2(x, 1.0D0)
END arctan;
 
 
PROCEDURE sinh* (x: REAL): REAL;
VAR
res: REAL;
 
PROCEDURE sinh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF IsZero(x) THEN
res := 0.0
Res := 0.0D0
ELSE
res := (exp(x) - exp(-x)) / 2.0
Res := (exp(x) - exp(-x)) / 2.0D0
END
RETURN res
RETURN Res
END sinh;
 
 
PROCEDURE cosh* (x: REAL): REAL;
VAR
res: REAL;
 
PROCEDURE cosh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF IsZero(x) THEN
res := 1.0
Res := 1.0D0
ELSE
res := (exp(x) + exp(-x)) / 2.0
Res := (exp(x) + exp(-x)) / 2.0D0
END
RETURN res
RETURN Res
END cosh;
 
 
PROCEDURE tanh* (x: REAL): REAL;
VAR
res: REAL;
 
PROCEDURE tanh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF IsZero(x) THEN
res := 0.0
Res := 0.0D0
ELSE
res := sinh(x) / cosh(x)
Res := sinh(x) / cosh(x)
END
RETURN res
RETURN Res
END tanh;
 
 
PROCEDURE arcsinh* (x: REAL): REAL;
RETURN ln(x + sqrt((x * x) + 1.0))
PROCEDURE arcsinh*(x: LONGREAL): LONGREAL;
RETURN ln(x + sqrt((x * x) + 1.0D0))
END arcsinh;
 
 
PROCEDURE arccosh* (x: REAL): REAL;
RETURN ln(x + sqrt((x - 1.0) / (x + 1.0)) * (x + 1.0))
PROCEDURE arccosh*(x: LONGREAL): LONGREAL;
RETURN ln(x + sqrt((x - 1.0D0) / (x + 1.0D0)) * (x + 1.0D0))
END arccosh;
 
 
PROCEDURE arctanh* (x: REAL): REAL;
VAR
res: REAL;
 
PROCEDURE arctanh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF SameValue(x, 1.0) THEN
res := SYSTEM.INF()
ELSIF SameValue(x, -1.0) THEN
res := -SYSTEM.INF()
IF SameValue(x, 1.0D0) THEN
Res := Inf
ELSIF SameValue(x, -1.0D0) THEN
Res := nInf
ELSE
res := 0.5 * ln((1.0 + x) / (1.0 - x))
Res := 0.5D0 * ln((1.0D0 + x) / (1.0D0 - x))
END
RETURN res
RETURN Res
END arctanh;
 
 
PROCEDURE floor* (x: REAL): REAL;
VAR
f: REAL;
 
PROCEDURE floor*(x: LONGREAL): LONGREAL;
VAR f: LONGREAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0 THEN
x := x - 1.0
IF f < 0.0D0 THEN
x := x - 1.0D0
END
RETURN x
END floor;
 
 
PROCEDURE ceil* (x: REAL): REAL;
VAR
f: REAL;
 
PROCEDURE ceil*(x: LONGREAL): LONGREAL;
VAR f: LONGREAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0 THEN
x := x + 1.0
IF f > 0.0D0 THEN
x := x + 1.0D0
END
RETURN x
END ceil;
 
 
PROCEDURE power* (base, exponent: REAL): REAL;
VAR
res: REAL;
 
PROCEDURE power*(base, exponent: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF exponent = 0.0 THEN
res := 1.0
ELSIF (base = 0.0) & (exponent > 0.0) THEN
res := 0.0
IF exponent = 0.0D0 THEN
Res := 1.0D0
ELSIF (base = 0.0D0) & (exponent > 0.0D0) THEN
Res := 0.0D0
ELSE
res := exp(exponent * ln(base))
Res := exp(exponent * ln(base))
END
RETURN res
RETURN Res
END power;
 
 
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE sgn*(x: LONGREAL): INTEGER;
VAR Res: INTEGER;
BEGIN
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
IF x > 0.0D0 THEN
Res := 1
ELSIF x < 0.0D0 THEN
Res := -1
ELSE
res := 0
Res := 0
END
RETURN res
RETURN Res
END sgn;
 
BEGIN
Inf := sys.INF(LONGREAL);
nInf := -sys.INF(LONGREAL)
END Math.
/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
108,7 → 108,7
res.filter_area.size := LENGTH(res.filter_area.filter);
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.SADR("/rd/1/File managers/opendial");
res.start_path := sys.ADR("/rd/1/File managers/opendial");
res.opendir_path := sys.ADR(res.s_opendir_path[0]);
res.dir_default_path := sys.ADR(res.s_dir_default_path[0]);
res.openfile_path := sys.ADR(res.FilePath[0]);
134,7 → 134,7
PROCEDURE Load;
VAR Lib: INTEGER;
 
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
144,8 → 144,8
 
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(Lib, sys.ADR(Dialog_init), "OpenDialog_init");
GetProc(Lib, sys.ADR(Dialog_start), "OpenDialog_start");
GetProc(sys.ADR(Dialog_init), "OpenDialog_init");
GetProc(sys.ADR(Dialog_start), "OpenDialog_start");
END Load;
 
BEGIN
/programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 KolibriOS team
(*
Copyright 2016 KolibriOS team
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
101,7 → 101,7
PROCEDURE main;
VAR Lib: INTEGER;
 
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
112,10 → 112,10
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/RasterWorks.obj");
ASSERT(Lib # 0);
GetProc(Lib, sys.ADR(drawText), "drawText");
GetProc(Lib, sys.ADR(cntUTF_8), "cntUTF-8");
GetProc(Lib, sys.ADR(charsFit), "charsFit");
GetProc(Lib, sys.ADR(strWidth), "strWidth");
GetProc(sys.ADR(drawText), "drawText");
GetProc(sys.ADR(cntUTF_8), "cntUTF-8");
GetProc(sys.ADR(charsFit), "charsFit");
GetProc(sys.ADR(strWidth), "strWidth");
END main;
 
 
/programs/develop/oberon07/Lib/KolibriOS/Read.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
31,6 → 31,10
RETURN File.Read(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL)
END Real;
 
PROCEDURE LongReal*(F: File.FS; VAR x: LONGREAL): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL)
END LongReal;
 
PROCEDURE Boolean*(F: File.FS; VAR x: BOOLEAN): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN)
END Boolean;
/programs/develop/oberon07/Lib/KolibriOS/Write.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 Anton Krotov
(*
Copyright 2016 Anton Krotov
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
31,6 → 31,10
RETURN File.Write(F, sys.ADR(x), sys.SIZE(REAL)) = sys.SIZE(REAL)
END Real;
 
PROCEDURE LongReal*(F: File.FS; x: LONGREAL): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(LONGREAL)) = sys.SIZE(LONGREAL)
END LongReal;
 
PROCEDURE Boolean*(F: File.FS; x: BOOLEAN): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(BOOLEAN)) = sys.SIZE(BOOLEAN)
END Boolean;
/programs/develop/oberon07/Lib/KolibriOS/libimg.ob07
1,5 → 1,5
(*
Copyright 2016, 2018 KolibriOS team
(*
Copyright 2016 KolibriOS team
 
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
398,7 → 398,7
PROCEDURE main;
VAR Lib, formats_table_ptr: INTEGER;
 
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
409,23 → 409,23
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/libimg.obj");
ASSERT(Lib # 0);
GetProc(Lib, sys.ADR(img_is_img) , "img_is_img");
GetProc(Lib, sys.ADR(img_to_rgb) , "img_to_rgb");
GetProc(Lib, sys.ADR(img_to_rgb2) , "img_to_rgb2");
GetProc(Lib, sys.ADR(img_decode) , "img_decode");
GetProc(Lib, sys.ADR(img_encode) , "img_encode");
GetProc(Lib, sys.ADR(img_create) , "img_create");
GetProc(Lib, sys.ADR(img_destroy) , "img_destroy");
GetProc(Lib, sys.ADR(img_destroy_layer) , "img_destroy_layer");
GetProc(Lib, sys.ADR(img_count) , "img_count");
GetProc(Lib, sys.ADR(img_flip) , "img_flip");
GetProc(Lib, sys.ADR(img_flip_layer) , "img_flip_layer");
GetProc(Lib, sys.ADR(img_rotate) , "img_rotate");
GetProc(Lib, sys.ADR(img_rotate_layer) , "img_rotate_layer");
GetProc(Lib, sys.ADR(img_draw) , "img_draw");
GetProc(Lib, sys.ADR(img_scale) , "img_scale");
GetProc(Lib, sys.ADR(img_convert) , "img_convert");
GetProc(Lib, sys.ADR(formats_table_ptr) , "img_formats_table");
GetProc(sys.ADR(img_is_img) , "img_is_img");
GetProc(sys.ADR(img_to_rgb) , "img_to_rgb");
GetProc(sys.ADR(img_to_rgb2) , "img_to_rgb2");
GetProc(sys.ADR(img_decode) , "img_decode");
GetProc(sys.ADR(img_encode) , "img_encode");
GetProc(sys.ADR(img_create) , "img_create");
GetProc(sys.ADR(img_destroy) , "img_destroy");
GetProc(sys.ADR(img_destroy_layer) , "img_destroy_layer");
GetProc(sys.ADR(img_count) , "img_count");
GetProc(sys.ADR(img_flip) , "img_flip");
GetProc(sys.ADR(img_flip_layer) , "img_flip_layer");
GetProc(sys.ADR(img_rotate) , "img_rotate");
GetProc(sys.ADR(img_rotate_layer) , "img_rotate_layer");
GetProc(sys.ADR(img_draw) , "img_draw");
GetProc(sys.ADR(img_scale) , "img_scale");
GetProc(sys.ADR(img_convert) , "img_convert");
GetProc(sys.ADR(formats_table_ptr) , "img_formats_table");
GetFormatsTable(formats_table_ptr)
END main;
 
/programs/develop/oberon07/Lib/Windows32/RTL.ob07
1,441 → 1,194
(*
BSD 2-Clause License
(*
Copyright 2016, 2017 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
 
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE RTL;
 
IMPORT SYSTEM, API;
IMPORT sys := SYSTEM, API;
 
 
CONST
 
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
 
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
 
SIZE_OF_DWORD = 4;
 
 
TYPE
 
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
 
 
VAR
 
name: INTEGER;
types: INTEGER;
SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
main_thread_id: INTEGER;
 
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
 
 
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN
SYSTEM.CODE(
API.ExitProcess(n)
END _halt;
 
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 00CH, (* mov esi, dword [ebp + 12] *)
08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
 
 
PROCEDURE [stdcall] _move2* (bytes, dest, source: INTEGER);
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
BEGIN
SYSTEM.CODE(
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
 
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move2;
 
 
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
 
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, src, dst);
res := TRUE
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
END
END _disprec;
 
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
 
 
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
 
 
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
 
 
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
 
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
 
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
 
END _rot;
 
 
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
END;
IF a < 0 THEN
a := 0
END;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
ELSE
res := 0
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
END
 
RETURN res
END _set2;
END _saverec;
 
 
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
END _set;
 
 
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: INTEGER;
BEGIN
SYSTEM.CODE(
 
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
0F7H, 0F9H, (* idiv ecx *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 011H, (* mov dword [ecx], edx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
 
RETURN 0
END divmod;
 
 
PROCEDURE div_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
 
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
DEC(div)
m := bsize * idx;
FOR i := 4 TO Dim + 2 DO
m := m * Arr[i]
END;
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := c + m
ELSE
Arr[3] := 0
END
END _arrayidx;
 
RETURN div
END div_;
 
 
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
 
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
INC(mod, y)
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
END
END _arrayidx1;
 
RETURN mod
END mod_;
 
 
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(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)
END _mod;
 
 
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
 
 
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: INTEGER;
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, SIZE_OF_DWORD)
FOR i := 1 TO n DO
t := Arr[0];
FOR j := 0 TO m + n - 1 DO
Arr[j] := Arr[j + 1]
END;
Arr[m + n] := t
END
END _new;
END _arrayrot;
 
 
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
END
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(
 
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
 
sys.CODE("8B4508"); // mov eax, [ebp + 08h]
sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch]
sys.CODE("48"); // dec eax
// L1:
sys.CODE("40"); // inc eax
sys.CODE("803800"); // cmp byte ptr [eax], 0
sys.CODE("7403"); // jz L2
sys.CODE("E2F8"); // loop L1
sys.CODE("40"); // inc eax
// L2:
sys.CODE("2B4508"); // sub eax, [ebp + 08h]
sys.CODE("C9"); // leave
sys.CODE("C20800"); // ret 08h
RETURN 0
END _length;
 
 
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN
SYSTEM.CODE(
_savearr(MIN(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
 
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H, (* shr eax, 1 *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
 
RETURN 0
END _lengthw;
 
 
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
 
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
 
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b)));
IF i = 0 THEN
i := _length(a) - _length(b)
END;
 
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
|0: Res := i = 0
|1: Res := i # 0
|2: Res := i < 0
|3: Res := i > 0
|4: Res := i <= 0
|5: Res := i >= 0
ELSE
END
 
RETURN bRes
RETURN Res
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;
 
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
 
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
END;
 
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
 
RETURN bRes
END _strcmpw;
 
 
PROCEDURE [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;
i: INTEGER;
 
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
 
 
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
 
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
BEGIN
 
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
 
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
445,186 → 198,85
DEC(b)
END;
str[i] := 0X
END IntToStr;
END Int;
 
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER);
VAR msg, int: STRING; pos, n: INTEGER;
 
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
PROCEDURE StrAppend(s: STRING);
VAR i, n: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
 
ASSERT(n1 + n2 < LEN(s1));
 
n := LEN(s);
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
 
s1[j] := 0X
 
END append;
 
 
PROCEDURE [stdcall] _error* (module, err: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
 
BEGIN
 
s := "";
CASE err MOD 16 OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
| 4: append(s, "NIL procedure call")
| 5: append(s, "type guard error")
| 6: append(s, "index out of range")
| 7: append(s, "invalid CASE")
| 8: append(s, "array assignment error")
| 9: append(s, "CHR out of range")
|10: append(s, "WCHR out of range")
|11: append(s, "BYTE out of range")
END;
 
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);
 
API.DebugMsg(SYSTEM.ADR(s[0]), name);
 
API.exit_thread(0)
END _error;
 
 
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
BEGIN
(* r IS t0 *)
 
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
END
END StrAppend;
 
RETURN t1 = t0
END _isrec;
 
 
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: 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
pos := 0;
n := line MOD 16;
line := line DIV 16;
CASE n OF
|1: StrAppend("assertion failure")
|2: StrAppend("variable of a procedure type has NIL as value")
|3: StrAppend("typeguard error")
|4: StrAppend("inadmissible dynamic type")
|5: StrAppend("index check error")
|6: StrAppend("NIL pointer dereference")
|7: StrAppend("invalid value in case statement")
|8: StrAppend("division by zero")
ELSE
t1 := -1
END;
StrAppend(0DX);
StrAppend(0AX);
StrAppend("module ");
StrAppend(modname);
StrAppend(0DX);
StrAppend(0AX);
StrAppend("line ");
Int(line, int);
StrAppend(int);
IF m = 2 THEN
StrAppend(0DX);
StrAppend(0AX);
StrAppend("code ");
Int(code, int);
StrAppend(int)
END;
API.DebugMsg(sys.ADR(msg), SelfName);
IF API.GetCurrentThreadId() = main_thread_id THEN
API.ExitProcess(0)
ELSE
API.ExitThread(0)
END
END _assrt;
 
RETURN t1 = t0
END _is;
 
 
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
PROCEDURE [stdcall] _close*;
BEGIN
(* r:t1 IS t0 *)
 
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
IF CloseProc # NIL THEN
CloseProc
END
END _close;
 
RETURN t1 = t0
END _guardrec;
 
 
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
 
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: 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)
IF ~init THEN
API.zeromem(gsize, gadr);
init := TRUE;
API.init(esp);
main_thread_id := API.GetCurrentThreadId();
SelfName := self;
rtab := rec;
CloseProc := NIL
END
ELSE
t1 := t0
END
END _init;
 
RETURN t1 = t0
END _guard;
 
 
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE SetClose*(proc: PROC);
BEGIN
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
res := 0;
IF dll.thread_attach # NIL THEN
dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
res := 0;
IF dll.thread_detach # NIL THEN
dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
res := 0;
IF dll.process_detach # NIL THEN
dll.process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
res := 0
END
CloseProc := proc
END SetClose;
 
RETURN res
END _dllentry;
 
 
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
dll.process_detach := process_detach;
dll.thread_detach := thread_detach;
dll.thread_attach := thread_attach
END SetDll;
 
 
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
 
 
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
 
types := _types;
name := modname;
 
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
END _init;
 
 
END RTL.
/programs/develop/oberon07/Lib/Windows32/API.ob07
1,61 → 1,79
(*
BSD 2-Clause License
Copyright 2016, 2017 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
 
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE API;
 
IMPORT SYSTEM;
IMPORT sys := SYSTEM;
 
VAR
 
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
Alloc*: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER;
Free*: PROCEDURE [winapi] (hMem: INTEGER): INTEGER;
MessageBoxA*: PROCEDURE [winapi] (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
ExitThread*: PROCEDURE [winapi] (code: INTEGER);
GetCurrentThreadId*: PROCEDURE [winapi] (): INTEGER;
strncmp*: PROCEDURE [cdecl] (a, b, n: INTEGER): INTEGER;
 
GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER;
LoadLibraryA*: PROCEDURE [winapi] (name: INTEGER): 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 zeromem*(size, adr: INTEGER);
END zeromem;
 
PROCEDURE [windows-, "user32.dll", "MessageBoxA"] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
 
 
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
MessageBoxA(0, lpText, lpCaption, 16)
END DebugMsg;
 
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
VAR H: INTEGER;
BEGIN
H := GetProcAddress(hMOD, sys.ADR(name[0]));
ASSERT(H # 0);
sys.PUT(adr, H);
END GetProc;
 
PROCEDURE _NEW* (size: INTEGER): INTEGER;
RETURN Alloc(64, size)
END _NEW;
 
 
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
RETURN Free(p)
END _DISPOSE;
 
 
PROCEDURE init* (reserved, code: INTEGER);
PROCEDURE init* (esp: INTEGER);
VAR lib: INTEGER;
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - 4096
END init;
sys.GET(esp, GetProcAddress);
sys.GET(esp + 4, LoadLibraryA);
 
lib := LoadLibraryA(sys.ADR("kernel32.dll"));
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("GlobalFree", lib, sys.ADR(Free));
 
PROCEDURE exit* (code: INTEGER);
BEGIN
ExitProcess(code)
END exit;
lib := LoadLibraryA(sys.ADR("msvcrt.dll"));
GetProc("strncmp", lib, sys.ADR(strncmp));
 
lib := LoadLibraryA(sys.ADR("user32.dll"));
GetProc("MessageBoxA", lib, sys.ADR(MessageBoxA));
END init;
 
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
ExitThread(code)
END exit_thread;
 
 
END API.
END API.
/programs/develop/oberon07/Lib/Windows32/HOST.ob07
1,331 → 1,139
(*
BSD 2-Clause License
Copyright 2016, 2017 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
 
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE HOST;
 
IMPORT SYSTEM, RTL;
IMPORT sys := SYSTEM, API;
 
 
CONST
 
slash* = "\";
OS* = "WINDOWS";
OS* = "WIN";
Slash* = "\";
 
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
 
MAX_PARAM = 1024;
 
OFS_MAXPATHNAME = 128;
 
 
TYPE
 
POverlapped = POINTER TO OVERLAPPED;
 
OVERLAPPED = RECORD
 
Internal: INTEGER;
InternalHigh: INTEGER;
Offset: INTEGER;
OffsetHigh: INTEGER;
hEvent: INTEGER
 
END;
 
OFSTRUCT = RECORD
 
cBytes: CHAR;
fFixedDisk: CHAR;
nErrCode: SYSTEM.CARD16;
Reserved1: SYSTEM.CARD16;
Reserved2: SYSTEM.CARD16;
nErrCode: sys.CARD16;
Reserved1: sys.CARD16;
Reserved2: sys.CARD16;
szPathName: ARRAY OFS_MAXPATHNAME OF CHAR
 
END;
 
PSecurityAttributes = POINTER TO TSecurityAttributes;
 
TSecurityAttributes = RECORD
 
nLength: INTEGER;
lpSecurityDescriptor: INTEGER;
bInheritHandle: INTEGER
 
END;
 
TSystemTime = RECORD
 
Year,
Month,
DayOfWeek,
Day,
Hour,
Min,
Sec,
MSec: WCHAR
 
END;
 
 
VAR
 
hConsoleOutput: INTEGER;
sec*, dsec*, hConsoleOutput: INTEGER;
 
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc: INTEGER;
GetStdHandle: PROCEDURE [winapi] (nStdHandle: INTEGER): INTEGER;
CloseFile*: PROCEDURE [winapi] (hObject: INTEGER): INTEGER;
_CreateFile*: PROCEDURE [winapi] (lpFileName, dwDesiredAccess, dwShareMode, lpSecurityAttributes,
dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: INTEGER): INTEGER;
_OpenFile*: PROCEDURE [winapi] (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
ReadFile, WriteFile: PROCEDURE [winapi] (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, lpOverlapped: INTEGER): INTEGER;
GetCommandLine*: PROCEDURE [winapi] (): INTEGER;
GetTickCount: PROCEDURE [winapi] (): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
SetFilePointer: PROCEDURE [winapi] (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
 
eol*: ARRAY 3 OF CHAR;
 
 
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
_GetTickCount (): INTEGER;
 
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
_GetStdHandle (nStdHandle: INTEGER): INTEGER;
 
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
_GetCommandLine (): INTEGER;
 
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
_ReadFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
 
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
_WriteFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
 
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
_CloseHandle (hObject: INTEGER): INTEGER;
 
PROCEDURE [windows-, "kernel32.dll", "CreateFileA"]
_CreateFile (
lpFileName, dwDesiredAccess, dwShareMode: INTEGER;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition, dwFlagsAndAttributes,
hTemplateFile: INTEGER): INTEGER;
 
PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
_OpenFile (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
 
PROCEDURE [windows-, "kernel32.dll", "GetCurrentDirectoryA"]
_GetCurrentDirectory (nBufferLength, lpBuffer: INTEGER): INTEGER;
 
PROCEDURE [windows-, "kernel32.dll", "GetSystemTime"]
_GetSystemTime (T: TSystemTime);
 
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
_ExitProcess (code: INTEGER);
 
 
PROCEDURE ExitProcess* (code: INTEGER);
PROCEDURE FileRW*(hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR res: INTEGER;
BEGIN
_ExitProcess(code)
END ExitProcess;
 
 
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
 
BEGIN
n := _GetCurrentDirectory(LEN(path), SYSTEM.ADR(path[0]));
path[n] := slash;
path[n + 1] := 0X
END GetCurrentDirectory;
 
 
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
 
BEGIN
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
 
 
PROCEDURE ParamParse;
VAR
p, count, cond: INTEGER;
c: CHAR;
 
 
PROCEDURE ChangeCond (A, B, C: INTEGER; VAR cond: INTEGER; c: CHAR);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
IF write THEN
WriteFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0)
ELSE
cond := C
ReadFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0)
END
END ChangeCond;
RETURN res
END FileRW;
 
 
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR res: INTEGER;
BEGIN
p := _GetCommandLine();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, cond, c); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, cond, c); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, cond, c); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
res := FileRW(hConsoleOutput, sys.ADR(str[0]), LENGTH(str), TRUE)
END OutString;
 
 
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
 
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
VAR res: INTEGER;
BEGIN
j := 0;
IF n < argc THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i)
res := _CreateFile(sys.ADR(FName[0]), 0C0000000H, 0, 0, 2, 80H, 0);
IF res = -1 THEN
res := 0
END
END;
s[j] := 0X
END GetArg;
RETURN res
END CreateFile;
 
 
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
 
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
VAR res: INTEGER; ofstr: OFSTRUCT;
BEGIN
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
res := -1
ELSE
res := n
res := _OpenFile(sys.ADR(FName[0]), ofstr, 0);
IF res = -1 THEN
res := 0
END
 
RETURN res
END FileRead;
END OpenFile;
 
 
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
 
PROCEDURE FileSize*(F: INTEGER): INTEGER;
VAR res: INTEGER;
BEGIN
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
res := -1
ELSE
res := n
END
 
res := SetFilePointer(F, 0, 0, 2);
SetFilePointer(F, 0, 0, 0)
RETURN res
END FileWrite;
END FileSize;
 
 
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN _CreateFile(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END FileCreate;
 
 
PROCEDURE FileClose* (F: INTEGER);
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
BEGIN
_CloseHandle(F)
END FileClose;
sys.PUT(adr, API.GetProcAddress(hMOD, sys.ADR(name[0])))
END GetProc;
 
 
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
ofstr: OFSTRUCT;
res: INTEGER;
 
PROCEDURE Time*(VAR sec, dsec: INTEGER);
VAR t: INTEGER;
BEGIN
res := _OpenFile(SYSTEM.ADR(FName[0]), ofstr, 0);
IF res = 0FFFFFFFFH THEN
res := -1
END
t := GetTickCount() DIV 10;
sec := t DIV 100;
dsec := t MOD 100
END Time;
 
RETURN res
END FileOpen;
PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN API.Alloc(64, size)
END malloc;
 
 
PROCEDURE OutChar* (c: CHAR);
VAR
count: INTEGER;
PROCEDURE init*;
VAR lib: INTEGER;
BEGIN
_WriteFile(hConsoleOutput, SYSTEM.ADR(c), 1, count, NIL)
END OutChar;
lib := API.LoadLibraryA(sys.ADR("kernel32.dll"));
GetProc("GetTickCount", lib, sys.ADR(GetTickCount));
Time(sec, dsec);
GetProc("GetStdHandle", lib, sys.ADR(GetStdHandle));
GetProc("CreateFileA", lib, sys.ADR(_CreateFile));
GetProc("CloseHandle", lib, sys.ADR(CloseFile));
GetProc("OpenFile", lib, sys.ADR(_OpenFile));
GetProc("ReadFile", lib, sys.ADR(ReadFile));
GetProc("WriteFile", lib, sys.ADR(WriteFile));
GetProc("GetCommandLineA", lib, sys.ADR(GetCommandLine));
GetProc("SetFilePointer", lib, sys.ADR(SetFilePointer));
ExitProcess := API.ExitProcess;
hConsoleOutput := GetStdHandle(-11)
END init;
 
 
PROCEDURE GetTickCount* (): INTEGER;
RETURN _GetTickCount() DIV 10
END GetTickCount;
 
 
PROCEDURE letter (c: CHAR): BOOLEAN;
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z")
END letter;
 
 
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN ~(letter(path[0]) & (path[1] = ":"))
END isRelative;
 
 
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
VAR
T: TSystemTime;
 
BEGIN
_GetSystemTime(T);
year := ORD(T.Year);
month := ORD(T.Month);
day := ORD(T.Day);
hour := ORD(T.Hour);
min := ORD(T.Min);
sec := ORD(T.Sec)
END now;
 
 
PROCEDURE UnixTime* (): INTEGER;
PROCEDURE GetName*(): INTEGER;
RETURN 0
END UnixTime;
END GetName;
 
 
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
 
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
 
 
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
hConsoleOutput := _GetStdHandle(-11);
ParamParse
END HOST.
/programs/develop/oberon07/Lib/Linux32/LINAPI.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Lib/Linux32/API.ob07
1,145 → 1,148
(*
BSD 2-Clause License
Copyright 2016 Anton Krotov
 
Copyright (c) 2019, Anton Krotov
All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
 
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE API;
 
IMPORT SYSTEM;
IMPORT sys := SYSTEM;
 
 
CONST
 
BASE_ADR = 08048000H;
 
 
TYPE
 
TP* = ARRAY 2 OF INTEGER;
 
 
VAR
 
eol*: ARRAY 2 OF CHAR;
base*, MainParam*: INTEGER;
Param*: INTEGER;
 
libc*, librt*: INTEGER;
 
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): INTEGER;
 
stdout*,
stdin*,
sec* : INTEGER;
dsec* : INTEGER;
stdin* : INTEGER;
stdout* : INTEGER;
stderr* : INTEGER;
dlopen* : PROCEDURE [cdecl] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [cdecl] (handle, symbol: INTEGER): INTEGER;
_malloc* : PROCEDURE [cdecl] (size: INTEGER): INTEGER;
free* : PROCEDURE [cdecl] (ptr: INTEGER);
fopen* : PROCEDURE [cdecl] (fname, fmode: INTEGER): INTEGER;
fclose*, ftell* : PROCEDURE [cdecl] (file: INTEGER): INTEGER;
fwrite*, fread* : PROCEDURE [cdecl] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fseek* : PROCEDURE [cdecl] (file, offset, origin: INTEGER): INTEGER;
exit* : PROCEDURE [cdecl] (code: INTEGER);
strncmp* : PROCEDURE [cdecl] (str1, str2, n: INTEGER): INTEGER;
strlen* : PROCEDURE [cdecl] (str: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [cdecl] (clock_id: INTEGER; VAR tp: TP): INTEGER;
 
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
_exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
 
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
 
 
PROCEDURE putc* (c: CHAR);
VAR
res: INTEGER;
 
PROCEDURE malloc* (Bytes: INTEGER): INTEGER;
VAR res: INTEGER;
BEGIN
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END putc;
Bytes := Align(Bytes, 4);
res := _malloc(Bytes);
IF res # 0 THEN
zeromem(ASR(Bytes, 2), res)
END
RETURN res
END malloc;
 
 
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
PROCEDURE Free* (hMem: INTEGER): INTEGER;
BEGIN
puts(lpCaption);
puts(lpText)
END DebugMsg;
free(hMem)
RETURN 0
END Free;
 
 
PROCEDURE _NEW* (size: INTEGER): INTEGER;
VAR
res, ptr, words: INTEGER;
 
BEGIN
res := malloc(size);
IF res # 0 THEN
ptr := res;
words := size DIV SYSTEM.SIZE(INTEGER);
WHILE words > 0 DO
SYSTEM.PUT(ptr, 0);
INC(ptr, SYSTEM.SIZE(INTEGER));
DEC(words)
END
END
 
RETURN res
RETURN malloc(size)
END _NEW;
 
 
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
free(p)
RETURN 0
RETURN Free(p)
END _DISPOSE;
 
PROCEDURE ConOut(str, length: INTEGER);
BEGIN
length := fwrite(str, length, 1, stdout)
END ConOut;
 
PROCEDURE GetProcAdr (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
VAR eol: ARRAY 3 OF CHAR;
BEGIN
sym := dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetProcAdr;
eol[0] := 0DX;
eol[1] := 0AX;
eol[2] := 00X;
ConOut(sys.ADR(eol), 2);
ConOut(lpCaption, strlen(lpCaption));
ConOut(sys.ADR(":"), 1);
ConOut(sys.ADR(eol), 2);
ConOut(lpText, strlen(lpText));
ConOut(sys.ADR(eol), 2);
END DebugMsg;
 
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
exit(code)
END ExitProcess;
 
PROCEDURE init* (sp, code: INTEGER);
PROCEDURE ExitThread* (code: INTEGER);
BEGIN
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
base := BASE_ADR;
eol := 0AX;
exit(code)
END ExitThread;
 
libc := dlopen(SYSTEM.SADR("libc.so.6"), 1);
GetProcAdr(libc, "malloc", SYSTEM.ADR(malloc));
GetProcAdr(libc, "free", SYSTEM.ADR(free));
GetProcAdr(libc, "exit", SYSTEM.ADR(_exit));
GetProcAdr(libc, "stdout", SYSTEM.ADR(stdout));
GetProcAdr(libc, "stdin", SYSTEM.ADR(stdin));
GetProcAdr(libc, "stderr", SYSTEM.ADR(stderr));
SYSTEM.GET(stdout - SYSTEM.SIZE(INTEGER), stdout);
SYSTEM.GET(stdin - SYSTEM.SIZE(INTEGER), stdin);
SYSTEM.GET(stderr - SYSTEM.SIZE(INTEGER), stderr);
GetProcAdr(libc, "puts", SYSTEM.ADR(puts));
GetProcAdr(libc, "fwrite", SYSTEM.ADR(fwrite));
GetProcAdr(libc, "fread", SYSTEM.ADR(fread));
GetProcAdr(libc, "fopen", SYSTEM.ADR(fopen));
GetProcAdr(libc, "fclose", SYSTEM.ADR(fclose));
GetProcAdr(libc, "time", SYSTEM.ADR(time));
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
VAR H: INTEGER;
BEGIN
H := dlsym(hMOD, sys.ADR(name[0]));
ASSERT(H # 0);
sys.PUT(adr, H);
END GetProc;
 
librt := dlopen(SYSTEM.SADR("librt.so.1"), 1);
GetProcAdr(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END init;
 
 
PROCEDURE exit* (code: INTEGER);
PROCEDURE init* (esp: INTEGER);
VAR lib, proc: INTEGER;
BEGIN
_exit(code)
END exit;
Param := esp;
sys.MOVE(Param + 12, sys.ADR(dlopen), 4);
sys.MOVE(Param + 16, sys.ADR(dlsym), 4);
sys.MOVE(Param + 20, sys.ADR(exit), 4);
sys.MOVE(Param + 24, sys.ADR(stdin), 4);
sys.MOVE(Param + 28, sys.ADR(stdout), 4);
sys.MOVE(Param + 32, sys.ADR(stderr), 4);
sys.MOVE(Param + 36, sys.ADR(_malloc), 4);
sys.MOVE(Param + 40, sys.ADR(free), 4);
sys.MOVE(Param + 44, sys.ADR(fopen), 4);
sys.MOVE(Param + 48, sys.ADR(fclose), 4);
sys.MOVE(Param + 52, sys.ADR(fwrite), 4);
sys.MOVE(Param + 56, sys.ADR(fread), 4);
sys.MOVE(Param + 60, sys.ADR(fseek), 4);
sys.MOVE(Param + 64, sys.ADR(ftell), 4);
 
lib := dlopen(sys.ADR("libc.so.6"), 1);
ASSERT(lib # 0);
GetProc("strncmp", lib, sys.ADR(strncmp));
GetProc("strlen", lib, sys.ADR(strlen));
 
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
_exit(code)
END exit_thread;
lib := dlopen(sys.ADR("librt.so.1"), 1);
ASSERT(lib # 0);
GetProc("clock_gettime", lib, sys.ADR(clock_gettime));
END init;
 
 
END API.
/programs/develop/oberon07/Lib/Linux32/RTL.ob07
1,441 → 1,193
(*
BSD 2-Clause License
Copyright 2016, 2017 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
 
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE RTL;
 
IMPORT SYSTEM, API;
IMPORT sys := SYSTEM, API;
 
 
CONST
 
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
 
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
 
SIZE_OF_DWORD = 4;
 
 
TYPE
 
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
 
 
VAR
 
name: INTEGER;
types: INTEGER;
SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
 
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
 
 
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN
SYSTEM.CODE(
API.ExitProcess(n)
END _halt;
 
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 00CH, (* mov esi, dword [ebp + 12] *)
08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
 
 
PROCEDURE [stdcall] _move2* (bytes, dest, source: INTEGER);
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
BEGIN
SYSTEM.CODE(
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
 
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move2;
 
 
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
 
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, src, dst);
res := TRUE
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
END
END _disprec;
 
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
 
 
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
 
 
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
 
 
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
 
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
 
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
 
END _rot;
 
 
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
END;
IF a < 0 THEN
a := 0
END;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
ELSE
res := 0
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
END
 
RETURN res
END _set2;
END _saverec;
 
 
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
END _set;
 
 
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: INTEGER;
BEGIN
SYSTEM.CODE(
 
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
0F7H, 0F9H, (* idiv ecx *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 011H, (* mov dword [ecx], edx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
 
RETURN 0
END divmod;
 
 
PROCEDURE div_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
 
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
DEC(div)
m := bsize * idx;
FOR i := 4 TO Dim + 2 DO
m := m * Arr[i]
END;
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := c + m
ELSE
Arr[3] := 0
END
END _arrayidx;
 
RETURN div
END div_;
 
 
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
 
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
INC(mod, y)
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
END
END _arrayidx1;
 
RETURN mod
END mod_;
 
 
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(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)
END _mod;
 
 
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
 
 
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: INTEGER;
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, SIZE_OF_DWORD)
FOR i := 1 TO n DO
t := Arr[0];
FOR j := 0 TO m + n - 1 DO
Arr[j] := Arr[j + 1]
END;
Arr[m + n] := t
END
END _new;
END _arrayrot;
 
 
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
END
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(
 
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
 
sys.CODE("8B4508"); // mov eax, [ebp + 08h]
sys.CODE("8B4D0C"); // mov ecx, [ebp + 0Ch]
sys.CODE("48"); // dec eax
// L1:
sys.CODE("40"); // inc eax
sys.CODE("803800"); // cmp byte ptr [eax], 0
sys.CODE("7403"); // jz L2
sys.CODE("E2F8"); // loop L1
sys.CODE("40"); // inc eax
// L2:
sys.CODE("2B4508"); // sub eax, [ebp + 08h]
sys.CODE("C9"); // leave
sys.CODE("C20800"); // ret 08h
RETURN 0
END _length;
 
 
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN
SYSTEM.CODE(
_savearr(MIN(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
 
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H, (* shr eax, 1 *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
 
RETURN 0
END _lengthw;
 
 
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
 
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
 
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b)));
IF i = 0 THEN
i := _length(a) - _length(b)
END;
 
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
|0: Res := i = 0
|1: Res := i # 0
|2: Res := i < 0
|3: Res := i > 0
|4: Res := i <= 0
|5: Res := i >= 0
ELSE
END
 
RETURN bRes
RETURN Res
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;
 
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
 
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
END;
 
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
 
RETURN bRes
END _strcmpw;
 
 
PROCEDURE [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;
i: INTEGER;
 
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
 
 
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
 
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
BEGIN
 
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
 
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
445,186 → 197,80
DEC(b)
END;
str[i] := 0X
END IntToStr;
END Int;
 
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER);
VAR msg, int: STRING; pos, n: INTEGER;
 
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
PROCEDURE StrAppend(s: STRING);
VAR i, n: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
 
ASSERT(n1 + n2 < LEN(s1));
 
n := LEN(s);
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
 
s1[j] := 0X
 
END append;
 
 
PROCEDURE [stdcall] _error* (module, err: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
 
BEGIN
 
s := "";
CASE err MOD 16 OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
| 4: append(s, "NIL procedure call")
| 5: append(s, "type guard error")
| 6: append(s, "index out of range")
| 7: append(s, "invalid CASE")
| 8: append(s, "array assignment error")
| 9: append(s, "CHR out of range")
|10: append(s, "WCHR out of range")
|11: append(s, "BYTE out of range")
END;
 
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);
 
API.DebugMsg(SYSTEM.ADR(s[0]), name);
 
API.exit_thread(0)
END _error;
 
 
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
BEGIN
(* r IS t0 *)
 
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
END
END StrAppend;
 
RETURN t1 = t0
END _isrec;
 
 
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: 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
pos := 0;
n := line MOD 16;
line := line DIV 16;
CASE n OF
|1: StrAppend("assertion failure")
|2: StrAppend("variable of a procedure type has NIL as value")
|3: StrAppend("typeguard error")
|4: StrAppend("inadmissible dynamic type")
|5: StrAppend("index check error")
|6: StrAppend("NIL pointer dereference")
|7: StrAppend("invalid value in case statement")
|8: StrAppend("division by zero")
ELSE
t1 := -1
END
END;
StrAppend(0DX);
StrAppend(0AX);
StrAppend("module ");
StrAppend(modname);
StrAppend(0DX);
StrAppend(0AX);
StrAppend("line ");
Int(line, int);
StrAppend(int);
IF m = 2 THEN
StrAppend(0DX);
StrAppend(0AX);
StrAppend("code ");
Int(code, int);
StrAppend(int)
END;
API.DebugMsg(sys.ADR(msg), SelfName);
API.ExitThread(0)
END _assrt;
 
RETURN t1 = t0
END _is;
 
 
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
PROCEDURE [stdcall] _close*;
BEGIN
(* r:t1 IS t0 *)
 
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
IF CloseProc # NIL THEN
CloseProc
END
END _close;
 
RETURN t1 = t0
END _guardrec;
 
 
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
 
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: 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)
IF ~init THEN
API.zeromem(gsize, gadr);
init := TRUE;
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL
END
ELSE
t1 := t0
END
END _init;
 
RETURN t1 = t0
END _guard;
 
 
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE SetClose*(proc: PROC);
BEGIN
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
res := 0;
IF dll.thread_attach # NIL THEN
dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
res := 0;
IF dll.thread_detach # NIL THEN
dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
res := 0;
IF dll.process_detach # NIL THEN
dll.process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
res := 0
END
CloseProc := proc
END SetClose;
 
RETURN res
END _dllentry;
 
 
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
dll.process_detach := process_detach;
dll.thread_detach := thread_detach;
dll.thread_attach := thread_attach
END SetDll;
 
 
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
 
 
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
 
types := _types;
name := modname;
 
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
END _init;
 
 
END RTL.
/programs/develop/oberon07/Lib/Linux32/HOST.ob07
1,178 → 1,121
(*
BSD 2-Clause License
(*
Copyright 2016 Anton Krotov
 
Copyright (c) 2019, Anton Krotov
All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
 
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE HOST;
 
IMPORT SYSTEM, API, RTL;
IMPORT sys := SYSTEM, API;
 
 
CONST
 
slash* = "/";
OS* = "LINUX";
OS* = "LNX";
Slash* = "/";
 
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
 
 
VAR
 
argc: INTEGER;
fsize : INTEGER;
 
eol*: ARRAY 2 OF CHAR;
sec* : INTEGER;
dsec* : INTEGER;
 
PROCEDURE GetCommandLine* (): INTEGER;
RETURN API.Param
END GetCommandLine;
 
PROCEDURE ExitProcess* (code: INTEGER);
PROCEDURE CloseFile* (File: INTEGER);
BEGIN
API.exit(code)
END ExitProcess;
File := API.fclose(File)
END CloseFile;
 
 
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
 
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR res: INTEGER;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (n < argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
IF write THEN
res := API.fwrite(Buffer, nNumberOfBytes, 1, hFile) * nNumberOfBytes
ELSE
res := API.fread(Buffer, nNumberOfBytes, 1, hFile) * nNumberOfBytes
END
RETURN res
END FileRW;
 
 
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
 
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR res: INTEGER;
BEGIN
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
res := FileRW(API.stdout, sys.ADR(str), LENGTH(str), TRUE)
END OutString;
 
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(sys.ADR(FName), sys.ADR("wb"))
END CreateFile;
 
PROCEDURE ReadFile (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN API.fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F)
END ReadFile;
 
 
PROCEDURE WriteFile (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN API.fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F)
END WriteFile;
 
 
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
VAR F, res: INTEGER;
BEGIN
res := ReadFile(F, Buffer, bytes);
IF res <= 0 THEN
res := -1
F := API.fopen(sys.ADR(FName), sys.ADR("rb"));
IF F # 0 THEN
res := API.fseek(F, 0, 2);
fsize := API.ftell(F);
res := API.fseek(F, 0, 0)
END
RETURN F
END OpenFile;
 
RETURN res
END FileRead;
PROCEDURE FileSize* (F: INTEGER): INTEGER;
RETURN fsize
END FileSize;
 
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
 
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE malloc* (Bytes: INTEGER): INTEGER;
VAR res: INTEGER;
BEGIN
res := WriteFile(F, Buffer, bytes);
IF res <= 0 THEN
res := -1
Bytes := Align(Bytes, 4);
res := API.malloc(Bytes);
IF res # 0 THEN
API.zeromem(ASR(Bytes, 2), res)
END
 
RETURN res
END FileWrite;
END malloc;
 
 
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
END FileCreate;
 
 
PROCEDURE FileClose* (File: INTEGER);
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
File := API.fclose(File)
END FileClose;
API.exit(code)
END ExitProcess;
 
 
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
END FileOpen;
 
 
PROCEDURE OutChar* (c: CHAR);
PROCEDURE Time* (VAR sec, dsec: INTEGER);
VAR tp: API.TP;
BEGIN
API.putc(c)
END OutChar;
 
 
PROCEDURE GetTickCount* (): INTEGER;
VAR
tp: API.TP;
res: INTEGER;
 
BEGIN
IF API.clock_gettime(0, tp) = 0 THEN
res := tp[0] * 100 + tp[1] DIV 10000000
sec := tp[0];
dsec := tp[1] DIV 10000000
ELSE
res := 0
sec := 0;
dsec := 0
END
END Time;
 
RETURN res
END GetTickCount;
 
 
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
 
 
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
END now;
 
 
PROCEDURE UnixTime* (): INTEGER;
RETURN API.time(0)
END UnixTime;
 
 
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE init*;
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
Time(sec, dsec)
END init;
 
PROCEDURE GetName*(): INTEGER;
RETURN 0
END GetName;
 
BEGIN
eol := 0AX;
SYSTEM.GET(API.MainParam, argc)
END HOST.
/programs/develop/oberon07/Source/MACHINE.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/WRITER.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/CONSOLE.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/LISTS.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/UNIXTIME.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/ARITH.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/PATHS.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/PROG.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/STATEMENTS.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/PARS.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/CHUNKLISTS.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/BIN.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/AVLTREES.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/MSCOFF.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/AMD64.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/CONSTANTS.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/TEXTDRV.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/COLLECTIONS.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/STRINGS.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/KOS.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/CODE.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/REG.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/FILES.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/PE32.ob07
File deleted
\ No newline at end of file
/programs/develop/oberon07/Source/Compiler.ob07
1,280 → 1,1958
(*
BSD 2-Clause License
(*
Copyright 2016, 2017, 2018 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This file is part of Compiler.
 
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
Compiler 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 General Public License for more details.
 
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE Compiler;
 
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, C := CONSOLE, ERRORS, STRINGS, mConst := CONSTANTS, WRITER;
IMPORT DECL, SCAN, UTILS, X86, SYSTEM;
 
CONST
 
PROCEDURE Target (s: ARRAY OF CHAR): INTEGER;
Slash = UTILS.Slash;
 
lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7;
lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8;
lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16;
lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23;
lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30;
lxUNTIL = 31; lxVAR = 32; lxWHILE = 33;
 
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58;
lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65;
lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
 
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;
 
TNUM = {TINTEGER, TREAL, TLONGREAL};
TFLOAT = {TREAL, TLONGREAL};
TOBJECT = {TRECORD, TPOINTER};
TSTRUCT = {TARRAY, TRECORD};
 
eVAR = 1; eCONST = 2; eEXP = 3; ePROC = 4; eSTPROC = 5; eSYSPROC = 6;
 
IDMOD = 1; IDCONST = 2; IDTYPE = 3; IDVAR = 4; IDPROC = 5; IDSTPROC = 6; IDGUARD = 7; IDPARAM = 8; IDSYSPROC = 9;
 
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;
stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22;
stBITS = 23; stLSR = 24; stLENGTH = 25; stMIN = 26; stMAX = 27;
 
sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; sysCOPY = 109;
 
TYPE
 
LABEL = POINTER TO RECORD (UTILS.rITEM)
a, b: INTEGER
END;
 
VAR
res: INTEGER;
 
pExpr, pFactor: PROCEDURE (VAR e: DECL.EXPRESSION);
pOpSeq: PROCEDURE;
sttypes: DECL.stTYPES;
voidtype, inttype, booltype, strtype, settype, realtype, longrealtype, chartype, niltype: DECL.pTYPE;
 
PROCEDURE Load(e: DECL.EXPRESSION);
BEGIN
IF s = mConst.Target_sConsole THEN
res := mConst.Target_iConsole
ELSIF s = mConst.Target_sGUI THEN
res := mConst.Target_iGUI
ELSIF s = mConst.Target_sDLL THEN
res := mConst.Target_iDLL
ELSIF s = mConst.Target_sKolibri THEN
res := mConst.Target_iKolibri
ELSIF s = mConst.Target_sObject THEN
res := mConst.Target_iObject
ELSIF s = mConst.Target_sConsole64 THEN
res := mConst.Target_iConsole64
ELSIF s = mConst.Target_sGUI64 THEN
res := mConst.Target_iGUI64
ELSIF s = mConst.Target_sDLL64 THEN
res := mConst.Target_iDLL64
ELSIF s = mConst.Target_sELF32 THEN
res := mConst.Target_iELF32
ELSIF s = mConst.Target_sELF64 THEN
res := mConst.Target_iELF64
ELSE
res := 0
IF e.eType = eVAR THEN
X86.Load(e.T.tType)
END
END Load;
 
RETURN res
END Target;
PROCEDURE LenString(adr: LONGREAL): INTEGER;
VAR s: UTILS.STRCONST;
BEGIN
s := DECL.GetString(adr)
RETURN s.Len
END LenString;
 
PROCEDURE Assert(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER);
BEGIN
IF ~cond THEN
DECL.Assert(FALSE, coord, code)
END
END Assert;
 
PROCEDURE keys (VAR StackSize, BaseAddress, Version: INTEGER; VAR pic: BOOLEAN; VAR checking: SET);
VAR
param: PARS.PATH;
i, j: INTEGER;
end: BOOLEAN;
value: INTEGER;
minor,
major: INTEGER;
PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER);
BEGIN
IF ~cond THEN
DECL.Assert(FALSE, SCAN.coord, code)
END
END Assert2;
 
PROCEDURE IntType(T: DECL.pTYPE; coord: SCAN.TCoord);
BEGIN
end := FALSE;
i := 4;
REPEAT
UTILS.GetArg(i, param);
Assert(T.tType = TINTEGER, coord, 52)
END IntType;
 
IF param = "-stk" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) & (1 <= value) & (value <= 32) THEN
StackSize := value
PROCEDURE Next;
BEGIN
DECL.Next
END Next;
 
PROCEDURE Coord(VAR coord: SCAN.TCoord);
BEGIN
coord := SCAN.coord
END Coord;
 
PROCEDURE NextCoord(VAR coord: SCAN.TCoord);
BEGIN
DECL.Next;
coord := SCAN.coord
END NextCoord;
 
PROCEDURE Check(key: INTEGER);
BEGIN
DECL.Check(key)
END Check;
 
PROCEDURE NextCheck(key: INTEGER);
BEGIN
DECL.Next;
DECL.Check(key)
END NextCheck;
 
PROCEDURE BaseOf(T0, T1: DECL.pTYPE): BOOLEAN;
BEGIN
IF (T0.tType = T1.tType) & (T0.tType IN TOBJECT) THEN
IF T0.tType = TPOINTER THEN
T0 := T0.Base;
T1 := T1.Base
END;
IF param[0] = "-" THEN
DEC(i)
WHILE (T1 # NIL) & (T1 # T0) DO
T1 := T1.Base
END
END
RETURN T0 = T1
END BaseOf;
 
ELSIF param = "-base" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToInt(param, value) THEN
BaseAddress := ((value DIV 64) * 64) * 1024
END;
IF param[0] = "-" THEN
DEC(i)
PROCEDURE Designator(VAR e: DECL.EXPRESSION);
VAR id, id2: DECL.IDENT; name: SCAN.NODE; e1: DECL.EXPRESSION;
coord: SCAN.TCoord; i, n, bases, glob, loc, idx: INTEGER;
imp, break, guard: BOOLEAN; f: DECL.FIELD;
T, BaseT: DECL.pTYPE; s: UTILS.STRCONST;
 
PROCEDURE LoadVar;
BEGIN
IF glob # -1 THEN
X86.GlobalAdr(glob);
glob := -1
ELSIF loc # -1 THEN
X86.LocalAdr(loc, bases);
loc := -1
END
END LoadVar;
 
ELSIF param = "-nochk" THEN
INC(i);
UTILS.GetArg(i, param);
 
IF param[0] = "-" THEN
DEC(i)
BEGIN
glob := -1;
loc := -1;
Coord(coord);
Check(lxIDENT);
name := SCAN.id;
id := DECL.GetIdent(name);
IF (id # NIL) & (id.iType = IDMOD) THEN
NextCheck(lxDot);
NextCheck(lxIDENT);
Coord(coord);
name := SCAN.id;
imp := id.Unit # DECL.unit;
id := DECL.GetQIdent(id.Unit, name)
END;
Assert(id # NIL, coord, 42);
e.vparam := FALSE;
e.deref := FALSE;
e.id := id;
Next;
CASE id.iType OF
|IDVAR:
e.eType := eVAR;
e.T := id.T;
IF id.VarKind = 0 THEN
e.Read := imp
ELSE
j := 0;
WHILE param[j] # 0X DO
e.Read := (id.VarKind = DECL.param) & (id.T.tType IN TSTRUCT);
e.vparam := id.VarKind = DECL.paramvar
END;
bases := DECL.unit.Level - id.Level;
IF id.Level = 3 THEN
glob := id.Offset
ELSIF (id.VarKind = 0) OR (id.VarKind = DECL.param) & ~(id.T.tType IN TSTRUCT) THEN
loc := id.Offset
ELSIF (id.VarKind = DECL.paramvar) OR (id.T.tType IN TSTRUCT) THEN
IF DECL.Dim(e.T) > 0 THEN
n := DECL.Dim(e.T);
FOR i := n TO 1 BY -1 DO
X86.LocalAdr(id.Offset + i * 4, bases);
X86.Load(TINTEGER)
END
END;
X86.LocalAdr(id.Offset, bases);
X86.Load(TINTEGER)
END
|IDCONST:
Assert(id.T # NIL, coord, 75);
e.eType := eCONST;
e.T := id.T;
e.Value := id.Value;
IF id.T.tType IN {TINTEGER, TSET, TBOOLEAN} THEN
X86.PushConst(FLOOR(e.Value))
ELSIF id.T.tType IN TFLOAT THEN
X86.PushFlt(e.Value)
ELSIF id.T.tType = TSTRING THEN
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
END
|IDPROC:
e.eType := ePROC;
NEW(id2);
UTILS.MemErr(id2 = NIL);
id2^ := id^;
UTILS.Push(DECL.curproc.Procs, id2);
e.T := voidtype
|IDTYPE:
Assert(FALSE, coord, 101)
|IDSTPROC:
e.eType := eSTPROC;
e.T := voidtype
|IDSYSPROC:
e.eType := eSYSPROC;
e.T := voidtype
ELSE
END;
break := FALSE;
guard := FALSE;
REPEAT
CASE SCAN.tLex OF
|lxDot:
e.deref := FALSE;
Assert2(e.T.tType IN TOBJECT, 105);
IF e.T.tType = TPOINTER THEN
e.Read := FALSE;
LoadVar;
e.T := e.T.Base;
X86.Load(TINTEGER);
IF ~guard THEN
X86.CheckNIL
END
END;
NextCheck(lxIDENT);
Coord(coord);
name := SCAN.id;
T := e.T;
REPEAT
f := DECL.GetField(T, name);
T := T.Base
UNTIL (f # NIL) OR (T = NIL);
Assert(f # NIL, coord, 99);
IF f.Unit # DECL.unit THEN
Assert(f.Export, coord, 99)
END;
IF glob # -1 THEN
glob := glob + f.Offset
ELSIF loc # -1 THEN
loc := loc + f.Offset
ELSE
X86.Field(f.Offset)
END;
e.T := f.T;
e.vparam := FALSE;
guard := FALSE;
Next
|lxLSquare:
LoadVar;
REPEAT
Assert2(e.T.tType = TARRAY, 102);
NextCoord(coord);
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e.T.Len = 0 THEN
IF e1.eType = eCONST THEN
idx := FLOOR(e1.Value);
Assert(idx >= 0, coord, 159)
END;
BaseT := DECL.OpenBase(e.T);
X86.PushConst(BaseT.Size);
X86.OpenIdx(DECL.Dim(e.T))
ELSE
IF e1.eType = eCONST THEN
idx := FLOOR(e1.Value);
Assert((idx >= 0) & (idx < e.T.Len), coord, 159);
IF e.T.Base.Size # 1 THEN
X86.Drop;
X86.PushConst(e.T.Base.Size * idx)
END;
X86.Idx
ELSE
X86.FixIdx(e.T.Len, e.T.Base.Size)
END
END;
e.T := e.T.Base
UNTIL SCAN.tLex # lxComma;
Check(lxRSquare);
e.vparam := FALSE;
guard := FALSE;
Next
|lxCaret:
LoadVar;
Assert2(e.T.tType = TPOINTER, 104);
e.Read := FALSE;
X86.Load(TINTEGER);
IF ~guard THEN
X86.CheckNIL
END;
e.T := e.T.Base;
e.vparam := FALSE;
e.deref := TRUE;
guard := FALSE;
Next
|lxLRound:
LoadVar;
IF e.T.tType IN TOBJECT THEN
IF e.T.tType = TRECORD THEN
Assert2(e.vparam, 108)
END;
NextCheck(lxIDENT);
Coord(coord);
T := DECL.IdType(coord);
Assert(T # NIL, coord, 42);
IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord, 106)
ELSE
Assert(T.tType = TPOINTER, coord, 107)
END;
Assert(BaseOf(e.T, T), coord, 108);
e.T := T;
Check(lxRRound);
Next;
IF e.T.tType = TPOINTER THEN
IF (SCAN.tLex = lxDot) OR (SCAN.tLex = lxCaret) THEN
X86.DupLoadCheck
ELSE
X86.DupLoad
END;
guard := TRUE;
T := T.Base
ELSE
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END;
X86.Guard(T.Number, FALSE)
ELSE
break := TRUE
END
ELSE
break := TRUE
END
UNTIL break;
LoadVar
END Designator;
 
IF param[j] = "p" THEN
EXCL(checking, ST.chkPTR)
ELSIF param[j] = "t" THEN
EXCL(checking, ST.chkGUARD)
ELSIF param[j] = "i" THEN
EXCL(checking, ST.chkIDX)
ELSIF param[j] = "b" THEN
EXCL(checking, ST.chkBYTE)
ELSIF param[j] = "c" THEN
EXCL(checking, ST.chkCHR)
ELSIF param[j] = "w" THEN
EXCL(checking, ST.chkWCHR)
ELSIF param[j] = "r" THEN
EXCL(checking, ST.chkCHR);
EXCL(checking, ST.chkWCHR);
EXCL(checking, ST.chkBYTE)
ELSIF param[j] = "a" THEN
checking := {}
PROCEDURE Set(VAR e: DECL.EXPRESSION);
VAR a, b: DECL.EXPRESSION; coord: SCAN.TCoord; fpu: INTEGER; s: SET; flag: BOOLEAN;
beg: X86.ASMLINE;
BEGIN
Next;
e.eType := eEXP;
e.T := settype;
e.Value := 0.0D0;
e.vparam := FALSE;
s := {};
flag := TRUE;
fpu := X86.fpu;
beg := X86.current;
X86.PushConst(0);
WHILE SCAN.tLex # lxRCurly DO
Coord(coord);
pExpr(a);
IntType(a.T, coord);
IF a.eType = eCONST THEN
Assert(ASR(FLOOR(a.Value), 5) = 0, coord, 53)
END;
Load(a);
b := a;
IF SCAN.tLex = lxDbl THEN
NextCoord(coord);
pExpr(b);
IntType(b.T, coord);
IF b.eType = eCONST THEN
Assert(ASR(FLOOR(b.Value), 5) = 0, coord, 53);
IF a.eType = eCONST THEN
Assert(a.Value <= b.Value, coord, 54)
END
END;
Load(b)
ELSE
X86.Dup
END;
X86.rset;
X86.Set(lxPlus);
flag := (a.eType = eCONST) & (b.eType = eCONST) & flag;
IF flag THEN
s := s + {FLOOR(a.Value) .. FLOOR(b.Value)}
END;
IF SCAN.tLex = lxComma THEN
Next;
Assert2(SCAN.tLex # lxRCurly, 36)
ELSE
Check(lxRCurly)
END
END;
IF flag THEN
e.Value := LONG(FLT(ORD(s)));
e.eType := eCONST;
X86.Del(beg);
X86.Setfpu(fpu);
IF ~DECL.Const THEN
X86.PushConst(ORD(s))
END
END;
Next
END Set;
 
INC(j)
PROCEDURE IsString(a: DECL.EXPRESSION): BOOLEAN;
RETURN (a.T.tType = TSTRING) OR (a.T.tType = TARRAY) & (a.T.Base.tType = TCHAR)
END IsString;
 
PROCEDURE Str(e: DECL.EXPRESSION);
VAR A: X86.TIDX;
BEGIN
IF (e.T.tType = TARRAY) & (e.T.Base.tType = TCHAR) & (e.T.Len # 0) THEN
A[0] := e.T.Len;
X86.OpenArray(A, 1)
ELSIF e.T.tType = TSTRING THEN
A[0] := LenString(e.Value) + 1;
IF A[0] # 2 THEN
X86.OpenArray(A, 1)
END
END
END Str;
 
ELSIF param = "-ver" THEN
INC(i);
UTILS.GetArg(i, param);
IF STRINGS.StrToVer(param, major, minor) THEN
Version := major * 65536 + minor
PROCEDURE StFunc(VAR e: DECL.EXPRESSION; func: INTEGER);
VAR coord, coord2: SCAN.TCoord; a, b, p: INTEGER; e1, e2: DECL.EXPRESSION;
T: DECL.pTYPE; str, str2: UTILS.STRCONST;
BEGIN
e.vparam := FALSE;
e.eType := eEXP;
Coord(coord2);
Check(lxLRound);
NextCoord(coord);
CASE func OF
|stABS:
pExpr(e1);
Assert(e1.T.tType IN TNUM, coord, 57);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := ABS(e1.Value);
e.eType := eCONST;
Assert(~((e1.T.tType = TINTEGER) & (e1.Value = LONG(FLT(SCAN.minINT)))), coord, DECL.IOVER)
END;
IF param[0] = "-" THEN
DEC(i)
IF e1.T.tType = TINTEGER THEN
X86.StFunc(X86.stABS)
ELSE
X86.StFunc(X86.stFABS)
END;
e.T := e1.T
|stODD:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := LONG(FLT(ORD(ODD(FLOOR(e1.Value)))));
e.eType := eCONST
END;
X86.StFunc(X86.stODD);
e.T := booltype
|stLEN:
Designator(e1);
Assert((e1.eType = eVAR) & (e1.T.tType = TARRAY), coord, 102);
IF e1.T.Len > 0 THEN
X86.Len(-e1.T.Len)
ELSE
X86.Len(DECL.Dim(e1.T))
END;
e.T := inttype
|stLSL, stASR, stROR, stLSR:
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
|stLSL: a := LSL(a, b)
|stASR: a := ASR(a, b)
|stROR: a := ROR(a, b)
|stLSR: a := LSR(a, b)
ELSE
END;
e.Value := LONG(FLT(a));
e.eType := eCONST
END;
CASE func OF
|stLSL: X86.StFunc(X86.stLSL)
|stASR: X86.StFunc(X86.stASR)
|stROR: X86.StFunc(X86.stROR)
|stLSR: X86.StFunc(X86.stLSR)
ELSE
END;
e.T := inttype
|stFLOOR:
pExpr(e1);
Assert(e1.T.tType IN TFLOAT, coord, 66);
Load(e1);
IF e1.eType = eCONST THEN
Assert((e1.Value - 1.0D0 < LONG(FLT(SCAN.maxINT))) & (e1.Value >= LONG(FLT(SCAN.minINT))), coord, 74);
e.Value := LONG(FLT(FLOOR(e1.Value)));
e.eType := eCONST
END;
X86.StFunc(X86.stFLOOR);
e.T := inttype
|stFLT:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
X86.StFunc(X86.stFLT);
e.T := realtype
|stORD:
pExpr(e1);
Assert(e1.T.tType IN {TCHAR, TBOOLEAN, TSET, TSTRING}, coord, 68);
IF e1.T.tType = TSTRING THEN
Assert(LenString(e1.Value) = 1, coord, 94)
END;
Load(e1);
IF e1.eType = eCONST THEN
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
e.Value := LONG(FLT(ORD(str.Str[0])))
ELSE
e.Value := e1.Value
END;
e.eType := eCONST
END;
IF e1.T.tType = TBOOLEAN THEN
X86.StFunc(X86.stORD)
END;
e.T := inttype
|stBITS:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
e.T := settype
|stCHR:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
e.T := chartype;
IF e1.eType = eCONST THEN
Assert(ASR(FLOOR(e1.Value), 8) = 0, coord, 76);
str2 := DECL.AddMono(CHR(FLOOR(e1.Value)));
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
e.T := strtype;
e.eType := eCONST
END
|stLONG:
pExpr(e1);
Assert(e1.T.tType = TREAL, coord, 71);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
Load(e1);
e.T := longrealtype
|stSHORT:
pExpr(e1);
Assert(e1.T.tType = TLONGREAL, coord, 70);
IF e1.eType = eCONST THEN
Assert(ABS(e1.Value) <= LONG(SCAN.maxREAL), coord, DECL.FOVER);
Assert(ABS(e1.Value) >= LONG(SCAN.minREAL), coord, DECL.UNDER);
e.Value := e1.Value;
e.eType := eCONST
END;
Load(e1);
e.T := realtype
|stLENGTH:
pExpr(e1);
Assert(IsString(e1), coord, 141);
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Mono(str.Number);
X86.StrMono
END;
e.Value := LONG(FLT(LENGTH(str.Str)));
e.eType := eCONST
END;
Str(e1);
e.T := inttype;
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:
Assert((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxSTRING) OR (SCAN.tLex = lxCHX), coord, 43);
IF SCAN.tLex = lxIDENT THEN
Designator(e1);
Assert((e1.eType = eVAR) OR (e1.eType = ePROC) OR (e1.T = strtype), coord, 43);
IF e1.eType = ePROC THEN
X86.PushInt(e1.id.Number)
END
ELSE
pFactor(e1)
END;
IF e1.T = strtype THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Drop;
X86.PushInt(str.Number)
END
END;
e.T := inttype;
X86.ADR(DECL.Dim(e1.T))
|sysSIZE, sysTYPEID, sysINF:
DECL.SetSizeFunc;
Check(lxIDENT);
T := DECL.IdType(coord);
Assert(T # NIL, coord, 42);
e.eType := eCONST;
IF func = sysTYPEID THEN
e.T := inttype;
Assert(T.tType IN TOBJECT, coord, 47);
IF T.tType = TPOINTER THEN
T := T.Base
END;
e.Value := LONG(FLT(T.Number));
X86.PushConst(T.Number)
ELSIF func = sysSIZE THEN
e.T := inttype;
e.Value := LONG(FLT(T.Size));
X86.PushConst(T.Size)
ELSIF func = sysINF THEN
Assert(T.tType IN TFLOAT, coord, 91);
e.T := T;
e.Value := SYSTEM.INF(LONGREAL);
X86.PushFlt(e.Value)
END
ELSE
Assert(FALSE, coord2, 73)
END;
Check(lxRRound);
Next
END StFunc;
 
ELSIF param = "-pic" THEN
pic := TRUE
PROCEDURE ProcTypeComp(T1, T2: DECL.pTYPE): BOOLEAN;
VAR sp: INTEGER; stk: ARRAY 100, 2 OF DECL.pTYPE;
 
ELSIF param = "" THEN
end := TRUE
PROCEDURE ProcTypeComp1(T1, T2: DECL.pTYPE): BOOLEAN;
VAR fp, ft: DECL.FIELD; Res: BOOLEAN;
 
PROCEDURE TypeComp(T1, T2: DECL.pTYPE): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF (T1.tType = TARRAY) & (T2.tType = TARRAY) & (T1.Len = 0) & (T2.Len = 0) THEN
Res := TypeComp(T1.Base, T2.Base)
ELSE
ERRORS.error3("bad parameter: ", param, "")
END;
Res := ProcTypeComp1(T1, T2)
END
RETURN Res
END TypeComp;
 
PROCEDURE Check(): BOOLEAN;
VAR i: INTEGER; res: BOOLEAN;
BEGIN
i := 0;
res := FALSE;
WHILE (i < sp) & ~res DO
res := ((stk[i][0] = T1) & (stk[i][1] = T2)) OR ((stk[i][0] = T2) & (stk[i][1] = T1));
INC(i)
UNTIL end
END
RETURN res
END Check;
 
END keys;
BEGIN
INC(sp);
stk[sp][0] := T1;
stk[sp][1] := T2;
IF Check() THEN
Res := TRUE
ELSE
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);
fp := T1.Fields.First(DECL.FIELD);
ft := T2.Fields.First(DECL.FIELD);
WHILE Res & (fp # NIL) DO
Res := (fp.ByRef = ft.ByRef) & TypeComp(fp.T, ft.T);
fp := fp.Next(DECL.FIELD);
ft := ft.Next(DECL.FIELD)
END
ELSE
Res := T1 = T2
END
END;
DEC(sp)
RETURN Res
END ProcTypeComp1;
 
BEGIN
sp := -1
RETURN ProcTypeComp1(T1, T2)
END ProcTypeComp;
 
PROCEDURE main;
VAR
path: PARS.PATH;
inname: PARS.PATH;
ext: PARS.PATH;
app_path: PARS.PATH;
lib_path: PARS.PATH;
modname: PARS.PATH;
outname: PARS.PATH;
param: PARS.PATH;
temp: PARS.PATH;
PROCEDURE ArrComp(Ta, Tf: DECL.pTYPE): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF (Tf.tType = TARRAY) & (Tf.Len = 0) & (Ta.tType = TARRAY) THEN
Res := ArrComp(Ta.Base, Tf.Base)
ELSE
Res := ProcTypeComp(Ta, Tf)
END
RETURN Res
END ArrComp;
 
target: INTEGER;
PROCEDURE AssComp(e: DECL.EXPRESSION; T: DECL.pTYPE; param: BOOLEAN): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
CASE T.tType OF
|TINTEGER, TREAL, TLONGREAL, TSET, TBOOLEAN, TCARD16:
Res := e.T = T
|TCHAR:
IF e.T.tType = TSTRING THEN
Res := LenString(e.Value) = 1
ELSE
Res := e.T.tType = TCHAR
END
|TARRAY:
IF param THEN
IF T.Len = 0 THEN
IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := TRUE
ELSE
Res := ArrComp(e.T, T)
END
ELSE
IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := LenString(e.Value) <= T.Len
ELSE
Res := e.T = T
END
END
ELSE
IF T.Len = 0 THEN
Res := FALSE
ELSIF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := LenString(e.Value) <= T.Len
ELSE
Res := e.T = T
END
END
|TRECORD: Res := BaseOf(T, e.T)
|TPOINTER: Res := BaseOf(T, e.T) OR (e.T.tType = TNIL)
|TPROC: Res := (e.T.tType = TNIL) OR (e.eType = ePROC) & ProcTypeComp(e.id.T, T) OR
(e.eType # ePROC) & ProcTypeComp(e.T, T)
ELSE
Res := FALSE
END
RETURN Res
END AssComp;
 
time: INTEGER;
PROCEDURE ParamComp(e: DECL.EXPRESSION; T: DECL.pTYPE; ByRef: BOOLEAN): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF ByRef THEN
IF e.eType = eVAR THEN
CASE T.tType OF
|TINTEGER, TREAL, TLONGREAL, TCHAR,
TSET, TBOOLEAN, TPOINTER, TCARD16:
Res := e.T = T
|TARRAY:
IF T.Len > 0 THEN
Res := e.T = T
ELSE
Res := ArrComp(e.T, T)
END
|TRECORD:
Res := BaseOf(T, e.T)
|TPROC:
Res := ProcTypeComp(e.T, T)
ELSE
END
ELSE
Res := FALSE
END
ELSE
Res := AssComp(e, T, TRUE)
END
RETURN Res
END ParamComp;
 
StackSize,
Version,
BaseAdr: INTEGER;
pic: BOOLEAN;
checking: SET;
PROCEDURE Call(param: DECL.FIELD);
VAR coord: SCAN.TCoord; i, n: INTEGER; e1: DECL.EXPRESSION; s: UTILS.STRCONST; A: X86.TIDX; TA: DECL.pTYPE;
BEGIN
WHILE param # NIL DO
Coord(coord);
X86.Param;
pExpr(e1);
Assert(ParamComp(e1, param.T, param.ByRef), coord, 114);
Assert(~(param.ByRef & e1.Read), coord, 115);
Assert(~((e1.eType = ePROC) & (e1.id.Level > 3)), coord, 116);
IF (e1.eType = eVAR) & ~param.ByRef THEN
X86.Load(e1.T.tType)
END;
IF param.ByRef & (e1.T.tType = TRECORD) THEN
IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER)
ELSIF e1.deref THEN
X86.DerefType(0)
ELSE
X86.PushConst(e1.T.Number)
END
END;
IF ~param.ByRef & (param.T.tType IN TFLOAT) THEN
X86.DropFpu(param.T.tType = TLONGREAL)
END;
IF (e1.T.tType = TSTRING) & (param.T.tType = TARRAY) THEN
IF param.T.Len > X86.maxstrlen THEN
X86.set_maxstrlen(param.T.Len)
END;
s := DECL.GetString(e1.Value);
IF s.Len = 1 THEN
X86.Mono(s.Number)
END;
IF param.T.Len = 0 THEN
A[0] := s.Len + 1;
X86.OpenArray(A, 1)
END
END;
IF (e1.T.tType = TARRAY) & (DECL.Dim(param.T) > DECL.Dim(e1.T)) THEN
n := DECL.Dim(param.T) - DECL.Dim(e1.T);
TA := DECL.OpenBase(e1.T);
FOR i := 0 TO n - 1 DO
A[i] := TA.Len;
TA := TA.Base
END;
IF DECL.Dim(e1.T) = 0 THEN
X86.OpenArray(A, n)
ELSE
X86.ExtArray(A, n, DECL.Dim(e1.T))
END
END;
param := param.Next(DECL.FIELD);
IF param # NIL THEN
Check(lxComma);
Next
END
END;
Check(lxRRound);
Next
END Call;
 
bits64: BOOLEAN;
PROCEDURE Factor(VAR e: DECL.EXPRESSION);
VAR coord: SCAN.TCoord; ccall, p: INTEGER; begcall: X86.ASMLINE; s, str2: UTILS.STRCONST;
BEGIN
e.eType := eCONST;
e.vparam := FALSE;
CASE SCAN.tLex OF
|lxIDENT:
begcall := X86.current;
Designator(e);
IF e.eType = ePROC THEN
IF SCAN.tLex = lxLRound THEN
Assert2(e.id.T.Base.tType # TVOID, 73);
Next;
X86.PushCall(begcall);
Call(e.id.T.Fields.First(DECL.FIELD));
X86.EndCall;
e.eType := eEXP;
e.T := e.id.T.Base;
IF e.id.Level = 3 THEN
ccall := 0
ELSIF e.id.Level > DECL.curBlock.Level THEN
ccall := 1
ELSE
ccall := 2
END;
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)
ELSE
X86.PushInt(e.id.Number)
END
ELSIF (e.eType = eVAR) & (e.T.tType = TPROC) & (SCAN.tLex = lxLRound) THEN
Assert2(e.T.Base.tType # TVOID, 73);
Next;
X86.PushCall(begcall);
Call(e.T.Fields.First(DECL.FIELD));
X86.EndCall;
e.eType := eEXP;
X86.CallVar(TRUE, e.T.Base.tType IN TFLOAT, e.T.Call, e.T.Len, DECL.curBlock.LocalSize);
e.T := e.T.Base;
ELSIF e.eType IN {eSTPROC, eSYSPROC} THEN
StFunc(e, e.id.StProc)
END
|lxNIL:
e.T := niltype;
e.Value := 0.0D0;
X86.PushConst(0);
Next
|lxTRUE:
e.T := booltype;
e.Value := 1.0D0;
X86.PushConst(1);
Next
|lxFALSE:
e.T := booltype;
e.Value := 0.0D0;
X86.PushConst(0);
Next
|lxCHX, lxSTRING:
IF SCAN.tLex = lxSTRING THEN
str2 := DECL.AddString(SCAN.Lex);
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
ELSE
str2 := DECL.AddMono(SCAN.vCHX);
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
X86.PushConst(ORD(SCAN.vCHX))
END;
e.T := strtype;
Next
|lxREAL:
e.T := realtype;
e.Value := SCAN.vFLT;
X86.PushFlt(SCAN.vFLT);
Next
|lxLONGREAL:
e.T := longrealtype;
e.Value := SCAN.vFLT;
X86.PushFlt(SCAN.vFLT);
Next
|lxINT, lxHEX:
e.T := inttype;
e.Value := LONG(FLT(SCAN.vINT));
X86.PushConst(SCAN.vINT);
Next
|lxLRound:
Next;
pExpr(e);
Check(lxRRound);
Next
|lxNot:
NextCoord(coord);
Factor(e);
Assert(e.T.tType = TBOOLEAN, coord, 37);
Load(e);
IF e.eType = eCONST THEN
e.Value := LONG(FLT(ORD(e.Value = 0.0D0)))
ELSE
e.eType := eEXP
END;
X86.Not;
e.vparam := FALSE
|lxLCurly:
Set(e)
ELSE
Assert2(FALSE, 36)
END
END Factor;
 
PROCEDURE IsChr(a: DECL.EXPRESSION): BOOLEAN;
RETURN (a.T.tType = TSTRING) & (LenString(a.Value) = 1) OR (a.T.tType = TCHAR)
END IsChr;
 
PROCEDURE StrRel(a, b: DECL.EXPRESSION; Op: INTEGER);
BEGIN
StackSize := 2;
Version := 65536;
pic := FALSE;
checking := ST.chkALL;
IF ~(IsChr(a) OR IsChr(b)) THEN
X86.strcmp(Op, 0)
ELSIF IsChr(a) & IsChr(b) THEN
X86.CmpInt(Op)
ELSIF IsChr(a) THEN
X86.strcmp(Op, 1)
ELSE
X86.strcmp(Op, -1)
END
END StrRel;
 
PATHS.GetCurrentDirectory(app_path);
lib_path := app_path;
PROCEDURE log2(n: INTEGER): INTEGER;
VAR x, i: INTEGER;
BEGIN
x := 1;
i := 0;
WHILE (x # n) & (i < 31) DO
x := LSL(x, 1);
INC(i)
END;
IF x # n THEN
i := -1
END
RETURN i
END log2;
 
UTILS.GetArg(1, inname);
PROCEDURE Operation(VAR a, b: DECL.EXPRESSION; Op: INTEGER; coord: SCAN.TCoord);
VAR n, m: INTEGER;
BEGIN
CASE Op OF
|lxPlus, lxMinus, lxMult, lxSlash:
Assert((a.T.tType IN (TNUM + {TSET})) & (a.T.tType = b.T.tType), coord, 37);
Assert(~((Op = lxSlash) & (a.T.tType = TINTEGER)), coord, 37);
CASE a.T.tType OF
|TINTEGER: X86.Int(Op)
|TSET: X86.Set(Op)
|TREAL, TLONGREAL: X86.farith(Op)
ELSE
END
|lxDIV, lxMOD:
Assert((a.T.tType = TINTEGER) & (b.T.tType = TINTEGER), coord, 37);
IF b.eType = eCONST THEN
m := FLOOR(b.Value);
Assert(m # 0, coord, 48);
n := log2(m);
IF n = -1 THEN
X86.idivmod(Op = lxMOD)
ELSE
X86.Drop;
IF Op = lxMOD THEN
n := ORD(-BITS(LSL(-1, n)));
X86.PushConst(n);
X86.Set(lxMult)
ELSE
X86.PushConst(n);
X86.StFunc(X86.stASR)
END
END
ELSE
X86.idivmod(Op = lxMOD)
END
|lxAnd, lxOR:
Assert((a.T.tType = TBOOLEAN) & (b.T.tType = TBOOLEAN), coord, 37)
|lxIN:
Assert((a.T.tType = TINTEGER) & (b.T.tType = TSET), coord, 37);
X86.inset
|lxLT, lxLE, lxGT, lxGE:
Assert(((a.T.tType IN TNUM) & (a.T.tType = b.T.tType)) OR
(IsChr(a) OR IsString(a)) & (IsChr(b) OR IsString(b)) OR
(a.T.tType = TSET) & (b.T.tType = TSET) & ((Op = lxLE) OR (Op = lxGE)), coord, 37);
IF a.T.tType IN TFLOAT THEN
X86.fcmp(Op)
ELSIF a.T.tType = TSET THEN
X86.Inclusion(Op)
ELSIF IsString(a) OR IsString(b) THEN
StrRel(a, b, Op)
ELSE
X86.CmpInt(Op)
END
|lxEQ, lxNE:
Assert(((a.T.tType IN (TNUM + {TSET, TBOOLEAN})) & (a.T.tType = b.T.tType)) OR
(IsChr(a) OR IsString(a)) & (IsChr(b) OR IsString(b)) OR
(a.T.tType IN {TPOINTER, TPROC, TNIL}) & (b.T.tType = TNIL) OR
(b.T.tType IN {TPOINTER, TPROC, TNIL}) & (a.T.tType = TNIL) OR
(a.T.tType = TPOINTER) & (b.T.tType = TPOINTER) & (BaseOf(a.T, b.T) OR BaseOf(b.T, a.T)) OR
(a.T.tType = TPROC) & ProcTypeComp(b.T, a.T) OR (a.eType = ePROC) & ProcTypeComp(b.T, a.id.T) OR
(b.eType = ePROC) & ProcTypeComp(a.T, b.id.T), coord, 37);
IF a.T.tType IN TFLOAT THEN
X86.fcmp(Op)
ELSIF IsString(a) OR IsString(b) THEN
StrRel(a, b, Op)
ELSE
X86.CmpInt(Op)
END
ELSE
END;
IF (a.eType # eCONST) OR (b.eType # eCONST) THEN
a.eType := eEXP;
IF DECL.Relation(Op) THEN
a.T := booltype
END
ELSE
DECL.Calc(a.Value, b.Value, a.T, b.T, Op, coord, a.Value, a.T)
END;
a.vparam := FALSE
END Operation;
 
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.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;
ELSIF UTILS.bit_depth = 32 THEN
C.StringLn('target = console | gui | dll | kos | obj | elfexe'); C.Ln;
PROCEDURE Term(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; Op, L: INTEGER; coord: SCAN.TCoord;
BEGIN
Factor(e);
WHILE (SCAN.tLex = lxMult) OR (SCAN.tLex = lxSlash) OR
(SCAN.tLex = lxDIV) OR (SCAN.tLex = lxMOD) OR
(SCAN.tLex = lxAnd) DO
Load(e);
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxAnd THEN
L := X86.NewLabel();
X86.IfWhile(L, FALSE)
END;
C.StringLn("optional settings:"); C.Ln;
C.StringLn(" -stk <size> set size of stack in megabytes"); C.Ln;
C.StringLn(" -base <address> set base address of image in kilobytes"); C.Ln;
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;
UTILS.Exit(0)
Factor(a);
Load(a);
IF Op = lxAnd THEN
X86.Label(L)
END;
Operation(e, a, Op, coord)
END
END Term;
 
PATHS.split(inname, path, modname, ext);
PROCEDURE Simple(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; Op, uOp, L: INTEGER; coord, ucoord: SCAN.TCoord;
BEGIN
uOp := 0;
IF (SCAN.tLex = lxPlus) OR (SCAN.tLex = lxMinus) THEN
Coord(ucoord);
uOp := SCAN.tLex;
Next
END;
Term(e);
IF uOp # 0 THEN
Assert(e.T.tType IN (TNUM + {TSET}), ucoord, 37);
Load(e);
IF uOp = lxMinus THEN
CASE e.T.tType OF
|TINTEGER: X86.NegInt
|TSET: X86.NegSet
|TREAL, TLONGREAL: X86.fneg
ELSE
END
END;
IF (uOp = lxMinus) & (e.eType = eCONST) THEN
CASE e.T.tType OF
|TINTEGER:
Assert(e.Value # LONG(FLT(SCAN.minINT)), ucoord, DECL.IOVER)
|TSET:
e.Value := -LONG(FLT(ORD(-BITS(FLOOR(e.Value)))))
ELSE
END;
e.Value := -e.Value
END;
IF e.eType # eCONST THEN
e.eType := eEXP
END;
e.vparam := FALSE
END;
WHILE (SCAN.tLex = lxPlus) OR (SCAN.tLex = lxMinus) OR (SCAN.tLex = lxOR) DO
Load(e);
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxOR THEN
L := X86.NewLabel();
X86.IfWhile(L, TRUE)
END;
Term(a);
Load(a);
IF Op = lxOR THEN
X86.Label(L)
END;
Operation(e, a, Op, coord)
END
END Simple;
 
IF ext # mConst.FILE_EXT THEN
ERRORS.error3('inputfile name extension must be "', mConst.FILE_EXT, '"')
PROCEDURE Expr(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; coord, coord2: SCAN.TCoord; Op, fpu: INTEGER; T: DECL.pTYPE; beg: X86.ASMLINE; s: UTILS.STRCONST;
BEGIN
fpu := X86.fpu;
beg := X86.current;
Simple(e);
IF DECL.Relation(SCAN.tLex) THEN
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxIS THEN
Assert(e.T.tType IN TOBJECT, coord, 37);
IF e.T.tType = TRECORD THEN
Assert(e.vparam, coord, 37)
END;
IF PATHS.isRelative(path) THEN
PATHS.RelPath(app_path, path, temp);
path := temp
Check(lxIDENT);
Coord(coord2);
T := DECL.IdType(coord2);
Assert(T # NIL, coord2, 42);
IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord2, 106)
ELSE
Assert(T.tType = TPOINTER, coord2, 107)
END;
Assert(BaseOf(e.T, T), coord, 37);
IF e.T.tType = TRECORD THEN
X86.Drop;
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END;
Load(e);
IF e.T.tType = TPOINTER THEN
T := T.Base
END;
X86.Guard(T.Number, TRUE);
e.T := booltype;
e.eType := eEXP;
e.vparam := FALSE
ELSE
Load(e);
Str(e);
Simple(a);
Load(a);
Str(a);
Operation(e, a, Op, coord)
END
END;
IF e.eType = eCONST THEN
X86.Del(beg);
X86.Setfpu(fpu);
IF ~DECL.Const THEN
CASE e.T.tType OF
|TREAL, TLONGREAL:
X86.PushFlt(e.Value)
|TINTEGER, TSET, TBOOLEAN, TNIL:
X86.PushConst(FLOOR(e.Value))
|TSTRING:
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
ELSE
END
END
END
END Expr;
 
UTILS.GetArg(2, outname);
IF outname = "" THEN
ERRORS.error1("not enough parameters")
PROCEDURE IfWhileOper(wh: BOOLEAN);
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L, L3: INTEGER;
BEGIN
L := X86.NewLabel();
IF wh THEN
X86.Label(L)
END;
IF PATHS.isRelative(outname) THEN
PATHS.RelPath(app_path, outname, temp);
outname := temp
REPEAT
NextCoord(coord);
Expr(e);
Assert(e.T.tType = TBOOLEAN, coord, 117);
Load(e);
IF wh THEN
Check(lxDO)
ELSE
Check(lxTHEN)
END;
L3 := X86.NewLabel();
X86.ifwh(L3);
Next;
pOpSeq;
X86.jmp(X86.JMP, L);
X86.Label(L3)
UNTIL SCAN.tLex # lxELSIF;
IF ~wh & (SCAN.tLex = lxELSE) THEN
Next;
pOpSeq
END;
Check(lxEND);
IF ~wh THEN
X86.Label(L)
END;
Next
END IfWhileOper;
 
UTILS.GetArg(3, param);
IF param = "" THEN
ERRORS.error1("not enough parameters")
PROCEDURE RepeatOper;
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L: INTEGER;
BEGIN
Next;
L := X86.NewLabel();
X86.Label(L);
pOpSeq;
Check(lxUNTIL);
NextCoord(coord);
Expr(e);
Assert(e.T.tType = TBOOLEAN, coord, 117);
Load(e);
X86.ifwh(L)
END RepeatOper;
 
PROCEDURE ForOper;
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; LBeg, LEnd, iValue: INTEGER; Value: LONGREAL;
T: DECL.pTYPE; name: SCAN.NODE; id: DECL.IDENT;
BEGIN
NextCheck(lxIDENT);
name := SCAN.id;
id := DECL.GetIdent(name);
Assert2(id # NIL, 42);
Assert2(id.iType = IDVAR, 126);
Assert2(id.VarKind = 0, 127);
Assert2(id.T.tType = TINTEGER, 128);
Assert2(id.Level = DECL.unit.Level, 129);
NextCheck(lxAssign);
NextCoord(coord);
IF id.Level = 3 THEN
X86.GlobalAdr(id.Offset)
ELSE
X86.LocalAdr(id.Offset, 0)
END;
X86.Dup;
Expr(e);
IntType(e.T, coord);
Load(e);
X86.Save(TINTEGER);
Check(lxTO);
NextCoord(coord);
Expr(e);
IntType(e.T, coord);
Load(e);
iValue := 1;
IF SCAN.tLex = lxBY THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(iValue # 0, coord, 122)
END;
Check(lxDO);
Next;
X86.For(iValue > 0, LBeg, LEnd);
pOpSeq;
X86.NextFor(iValue, LBeg, LEnd);
Check(lxEND);
Next
END ForOper;
 
target := Target(param);
PROCEDURE CheckLabel(a, b: INTEGER; Labels: UTILS.LIST): BOOLEAN;
VAR cur: LABEL;
BEGIN
cur := Labels.First(LABEL);
WHILE (cur # NIL) & ((b < cur.a) OR (a > cur.b)) DO
cur := cur.Next(LABEL)
END
RETURN cur = NIL
END CheckLabel;
 
IF target = 0 THEN
ERRORS.error1("bad parameter <target>")
PROCEDURE LabelVal(VAR a: INTEGER; int: BOOLEAN);
VAR Value: LONGREAL; T: DECL.pTYPE; s: UTILS.STRCONST; coord: SCAN.TCoord;
BEGIN
Coord(coord);
DECL.ConstExpr(Value, T);
IF int THEN
Assert(T.tType = TINTEGER, coord, 161);
a := FLOOR(Value)
ELSE
Assert(T.tType = TSTRING, coord, 55);
s := DECL.GetString(Value);
Assert(s.Len = 1, coord, 94);
a := ORD(s.Str[0])
END
END LabelVal;
 
PROCEDURE Label(int: BOOLEAN; Labels: UTILS.LIST; LBeg: INTEGER);
VAR a, b: INTEGER; label: LABEL; coord: SCAN.TCoord;
BEGIN
Coord(coord);
LabelVal(a, int);
b := a;
IF SCAN.tLex = lxDbl THEN
Next;
LabelVal(b, int)
END;
Assert(a <= b, coord, 54);
Assert(CheckLabel(a, b, Labels), coord, 100);
NEW(label);
DECL.MemErr(label = NIL);
label.a := a;
label.b := b;
UTILS.Push(Labels, label);
X86.CaseLabel(a, b, LBeg)
END Label;
 
bits64 := target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64, mConst.Target_iELF64};
PROCEDURE Variant(int: BOOLEAN; Labels: UTILS.LIST; EndCase: INTEGER);
VAR LBeg, LEnd: INTEGER;
BEGIN
LBeg := X86.NewLabel();
LEnd := X86.NewLabel();
IF ~((SCAN.tLex = lxStick) OR (SCAN.tLex = lxEND)) THEN
Label(int, Labels, LBeg);
WHILE SCAN.tLex = lxComma DO
Next;
Label(int, Labels, LBeg)
END;
Check(lxColon);
Next;
X86.jmp(X86.JMP, LEnd);
X86.Label(LBeg);
pOpSeq;
X86.jmp(X86.JMP, EndCase);
X86.Label(LEnd)
END
END Variant;
 
IF bits64 THEN
IF UTILS.bit_depth = 32 THEN
ERRORS.error1("bad parameter <target>")
PROCEDURE CaseOper;
VAR e: DECL.EXPRESSION; int: BOOLEAN; coord: SCAN.TCoord; EndCase: INTEGER; Labels: UTILS.LIST;
BEGIN
NextCoord(coord);
Expr(e);
Assert(e.T.tType IN {TCHAR, TSTRING, TINTEGER}, coord, 156);
Assert(~((e.T.tType = TSTRING) & (LenString(e.Value) # 1)), coord, 94);
int := e.T.tType = TINTEGER;
Check(lxOF);
Load(e);
X86.Drop;
Labels := UTILS.CreateList();
Next;
EndCase := X86.NewLabel();
Variant(int, Labels, EndCase);
WHILE SCAN.tLex = lxStick DO
Next;
Variant(int, Labels, EndCase)
END;
PARS.init(64, target)
IF SCAN.tLex = lxELSE THEN
Next;
pOpSeq
ELSE
PARS.init(32, target)
UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line);
X86.OnError(7)
END;
Check(lxEND);
X86.Label(EndCase);
Next;
UTILS.Clear(Labels)
END CaseOper;
 
PARS.program.dll := target IN {mConst.Target_iDLL, mConst.Target_iObject, mConst.Target_iDLL64};
PARS.program.obj := target = mConst.Target_iObject;
PROCEDURE CheckCode(Code: UTILS.STRING; Len: INTEGER; coord: SCAN.TCoord);
VAR i: INTEGER;
BEGIN
Assert(~ODD(Len), coord, 34);
FOR i := 0 TO Len - 1 DO
Assert(SCAN.HexDigit(Code[i]), coord, 34)
END
END CheckCode;
 
STRINGS.append(lib_path, "lib");
STRINGS.append(lib_path, UTILS.slash);
PROCEDURE StProc(proc: INTEGER);
VAR coord, coord2: SCAN.TCoord; iValue: INTEGER; e1, e2: DECL.EXPRESSION; Value: LONGREAL;
T: DECL.pTYPE; str: UTILS.STRCONST; begcall: X86.ASMLINE;
BEGIN
Coord(coord2);
Check(lxLRound);
NextCoord(coord);
CASE proc OF
|stINC, stDEC:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TINTEGER, coord, 128);
IF SCAN.tLex = lxComma THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(iValue # 0, coord, 122);
IF iValue < 0 THEN
IF proc = stINC THEN
proc := stDEC
ELSE
proc := stINC
END;
iValue := -iValue
END;
IF iValue # 1 THEN
X86.PushConst(iValue);
IF proc = stDEC THEN
X86.StProc(X86.stDEC)
ELSE
X86.StProc(X86.stINC)
END
ELSE
IF proc = stDEC THEN
X86.StProc(X86.stDEC1)
ELSE
X86.StProc(X86.stINC1)
END
END
ELSE
IF proc = stDEC THEN
X86.StProc(X86.stDEC1)
ELSE
X86.StProc(X86.stINC1)
END
END
|stINCL, stEXCL:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TSET, coord, 138);
Check(lxComma);
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(ASR(iValue, 5) = 0, coord, 53);
IF proc = stINCL THEN
X86.PushConst(ORD({iValue}));
X86.StProc(X86.stINCL)
ELSE
X86.PushConst(ORD(-{iValue}));
X86.StProc(X86.stEXCL)
END
|stCOPY:
Expr(e1);
Assert(IsString(e1), coord, 141);
Check(lxComma);
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Mono(str.Number);
X86.StrMono
END
END;
Str(e1);
NextCoord(coord);
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(IsString(e2), coord, 143);
Assert(~e2.Read, coord, 115);
Str(e2);
X86.StProc(X86.stCOPY)
|stNEW, stDISPOSE:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TPOINTER, coord, 145);
IF proc = stNEW THEN
X86.PushConst(e1.T.Base.Number);
X86.PushConst(X86.Align(e1.T.Base.Size + 8, 32));
X86.newrec
ELSE
X86.disprec
END
|stASSERT:
Expr(e1);
Assert(e1.T.tType = TBOOLEAN, coord, 117);
Load(e1);
IF SCAN.tLex = lxComma THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
Assert((Value >= 0.0D0) & (Value <= 127.0D0), coord, 95);
X86.Assert(X86.stASSERT, FLOOR(Value))
ELSE
X86.Assert(X86.stASSERT1, 0)
END
|stPACK, stUNPK:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(e1.T.tType IN TFLOAT, coord, 149);
Assert(~e1.Read, coord, 115);
Check(lxComma);
NextCoord(coord);
IF proc = stUNPK THEN
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(e2.T.tType = TINTEGER, coord, 128);
Assert(~e2.Read, coord, 115);
IF e1.T.tType = TLONGREAL THEN
X86.StProc(X86.stUNPK)
ELSE
X86.StProc(X86.stUNPK1)
END
ELSE
Expr(e2);
IntType(e2.T, coord);
Load(e2);
IF e1.T.tType = TLONGREAL THEN
X86.StProc(X86.stPACK)
ELSE
X86.StProc(X86.stPACK1)
END
END
|sysPUT, sysGET:
begcall := X86.current;
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
NextCoord(coord);
IF proc = sysGET THEN
X86.PushCall(begcall);
X86.Param;
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(~(e2.T.tType IN TSTRUCT), coord, 90);
Assert(~e2.Read, coord, 115);
X86.EndCall;
X86.Load(e2.T.tType);
X86.Save(e2.T.tType)
ELSE
Expr(e2);
Assert(~(e2.T.tType IN TSTRUCT), coord, 90);
IF e2.T.tType = TSTRING THEN
Assert(LenString(e2.Value) = 1, coord, 94)
ELSIF e2.T.tType = TVOID THEN
e2.T := inttype
END;
Load(e2);
X86.Save(e2.T.tType)
END
|sysCODE:
Assert(SCAN.tLex = lxSTRING, coord, 150);
CheckCode(SCAN.Lex, SCAN.count - 1, coord);
X86.Asm(SCAN.Lex);
Next
|sysMOVE:
begcall := X86.current;
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
X86.PushCall(begcall);
X86.Param;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
X86.EndCall;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
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
Assert(FALSE, coord2, 132)
END;
Check(lxRRound);
Next;
IF (proc = sysMOVE) OR (proc = sysCOPY) THEN
X86.StProc(X86.sysMOVE)
END
END StProc;
 
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN
IF target = mConst.Target_iDLL THEN
BaseAdr := 10000000H
PROCEDURE IdentOper;
VAR e1, e2: DECL.EXPRESSION; coord: SCAN.TCoord; ccall: INTEGER; begcall: X86.ASMLINE; s: UTILS.STRCONST;
BEGIN
Coord(coord);
begcall := X86.current;
Designator(e1);
Assert(e1.eType # eCONST, coord, 130);
IF (e1.eType = eVAR) & (e1.T.tType # TPROC) THEN
Check(lxAssign);
Assert(~e1.Read, coord, 115);
NextCoord(coord);
Expr(e2);
Assert(AssComp(e2, e1.T, FALSE), coord, 131);
Load(e2);
IF e1.T.tType = TRECORD THEN
X86.PushConst(e1.T.Size);
X86.PushConst(e1.T.Number);
IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER)
ELSIF e1.deref THEN
X86.DerefType(12)
ELSE
BaseAdr := 400000H
X86.PushConst(e1.T.Number)
END
ELSIF e2.T.tType = TARRAY THEN
X86.PushConst(e2.T.Size)
ELSIF (e2.T.tType = TSTRING) & (e1.T.tType = TARRAY) THEN
s := DECL.GetString(e2.Value);
IF s.Len = 1 THEN
X86.Mono(s.Number)
END;
STRINGS.append(lib_path, "Windows32")
X86.PushConst(MIN(s.Len + 1, e1.T.Len))
END;
X86.Save(e1.T.tType)
ELSIF e1.eType = ePROC THEN
Assert((e1.id.T.Base.tType = TVOID) OR (e1.id.T.Call = DECL.winapi), coord, 132);
IF e1.id.ParamCount > 0 THEN
Check(lxLRound);
Next;
X86.PushCall(begcall);
Call(e1.id.T.Fields.First(DECL.FIELD));
X86.EndCall
ELSIF SCAN.tLex = lxLRound THEN
NextCheck(lxRRound);
Next
END;
IF e1.id.Level = 3 THEN
ccall := 0
ELSIF e1.id.Level > DECL.curBlock.Level THEN
ccall := 1
ELSE
ccall := 2
END;
X86.Call(e1.id.Number, FALSE, FALSE, e1.id.T.Call, ccall, e1.id.Level - 3, DECL.curBlock.Level - 3, e1.id.ParamSize, DECL.curBlock.LocalSize)
ELSIF e1.eType IN {eSTPROC, eSYSPROC} THEN
StProc(e1.id.StProc)
ELSIF (e1.eType = eVAR) & (e1.T.tType = TPROC) THEN
IF SCAN.tLex = lxLRound THEN
Next;
Assert((e1.T.Base.tType = TVOID) OR (e1.T.Call = DECL.winapi), coord, 132);
X86.PushCall(begcall);
Call(e1.T.Fields.First(DECL.FIELD));
X86.EndCall;
X86.CallVar(FALSE, FALSE, e1.T.Call, e1.T.Len, DECL.curBlock.LocalSize)
ELSIF SCAN.tLex = lxAssign THEN
Assert(~e1.Read, coord, 115);
NextCoord(coord);
Expr(e2);
Assert(AssComp(e2, e1.T, FALSE), coord, 131);
Assert(~((e2.eType = ePROC) & (e2.id.Level > 3)), coord, 116);
IF e2.eType = eVAR THEN
X86.Load(TPROC)
END;
X86.Save(TPROC)
ELSE
Assert2(e1.T.Fields.Count = 0, 155);
Assert((e1.T.Base.tType = TVOID) OR (e1.T.Call = DECL.winapi), coord, 132);
X86.CallVar(FALSE, FALSE, e1.T.Call, e1.T.Len, DECL.curBlock.LocalSize)
END
END
END IdentOper;
 
ELSIF target IN {mConst.Target_iKolibri, mConst.Target_iObject} THEN
STRINGS.append(lib_path, "KolibriOS")
PROCEDURE Operator;
BEGIN
UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line);
CASE SCAN.tLex OF
|lxIDENT: IdentOper
|lxIF, lxWHILE: IfWhileOper(SCAN.tLex = lxWHILE)
|lxREPEAT: RepeatOper
|lxFOR: ForOper
|lxCASE: CaseOper
ELSE
END
END Operator;
 
ELSIF target = mConst.Target_iELF32 THEN
STRINGS.append(lib_path, "Linux32")
PROCEDURE OpSeq;
BEGIN
Operator;
WHILE SCAN.tLex = lxSemi DO
Next;
Operator
END
END OpSeq;
 
ELSIF target = mConst.Target_iELF64 THEN
STRINGS.append(lib_path, "Linux64")
PROCEDURE Start;
VAR SelfName, SelfPath, CName, CExt, FName, Path, StdPath,
Name, Ext, temp, system, stk: UTILS.STRING;
platform, stksize: INTEGER;
 
ELSIF target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN
STRINGS.append(lib_path, "Windows64")
 
PROCEDURE getstksize(): INTEGER;
VAR res, i: INTEGER;
BEGIN
res := 0;
i := 0;
WHILE SCAN.Digit(stk[i]) DO
INC(i)
END;
IF stk[i] <= 20X THEN
stk[i] := 0X;
res := SCAN.StrToInt(stk)
END;
IF res = 0 THEN
res := 1
END
RETURN res
END getstksize;
 
STRINGS.append(lib_path, UTILS.slash);
PROCEDURE getver(): INTEGER;
VAR res, i: INTEGER; err: BOOLEAN;
 
keys(StackSize, BaseAdr, Version, pic, checking);
PROCEDURE hexdgt(c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9") OR
("A" <= c) & (c <= "F") OR
("a" <= c) & (c <= "f")
END hexdgt;
 
ST.compile(path, lib_path, modname, outname, target, Version, StackSize, BaseAdr, pic, checking);
PROCEDURE hex(c: CHAR): INTEGER;
VAR res: INTEGER;
BEGIN
IF ("0" <= c) & (c <= "9") THEN
res := ORD(c) - ORD("0")
ELSIF ("A" <= c) & (c <= "F") THEN
res := ORD(c) - ORD("A") + 10
ELSIF ("a" <= c) & (c <= "f") THEN
res := ORD(c) - ORD("a") + 10
END
RETURN res
END hex;
 
time := UTILS.GetTickCount() - UTILS.time;
BEGIN
res := 0;
i := 0;
err := stk[i] # "0"; INC(i);
err := err OR (stk[i] # "x"); INC(i);
WHILE ~err & hexdgt(stk[i]) DO
INC(i)
END;
err := err OR (i = 2);
IF stk[i] <= 20X THEN
stk[i] := 0X
ELSE
err := TRUE
END;
i := 2;
WHILE ~err & (stk[i] # 0X) DO
res := LSL(res, 4) + hex(stk[i]);
INC(i)
END;
IF res = 0 THEN
res := 65536
END
RETURN res
END getver;
 
C.Int(time DIV 100); C.String("."); C.Int2(time MOD 100); C.String(" sec, ");
C.Int(WRITER.counter); C.StringLn(" bytes");
BEGIN
IF UTILS.ParamCount < 2 THEN
UTILS.ErrMsg(59);
UTILS.HALT(1)
END;
UTILS.ParamStr(SelfName, 0);
UTILS.ParamStr(FName, 1);
UTILS.ParamStr(system, 2);
UTILS.ParamStr(stk, 3);
pExpr := Expr;
pFactor := Factor;
pOpSeq := OpSeq;
UTILS.Split(FName, Path, Name, Ext);
IF Ext # UTILS.Ext THEN
UTILS.ErrMsg(121);
UTILS.HALT(1)
END;
UTILS.Split(SelfName, SelfPath, CName, CExt);
temp := Name;
IF UTILS.streq(system, "kem") THEN
X86.setkem;
platform := 4;
UTILS.concat(temp, ".kex")
ELSIF UTILS.streq(system, "obj") THEN
platform := 6;
UTILS.concat(temp, ".obj")
ELSIF UTILS.streq(system, "elf") THEN
platform := 5
ELSIF UTILS.streq(system, "kos") THEN
platform := 4;
UTILS.concat(temp, ".kex")
ELSIF UTILS.streq(system, "con") THEN
platform := 3;
UTILS.concat(temp, ".exe")
ELSIF UTILS.streq(system, "gui") THEN
platform := 2;
UTILS.concat(temp, ".exe")
ELSIF UTILS.streq(system, "dll") THEN
platform := 1;
UTILS.concat(temp, ".dll")
ELSE
UTILS.ErrMsg(60);
UTILS.HALT(1)
END;
IF platform IN {1, 2, 3, 4} THEN
stksize := getstksize()
ELSE
stksize := 1
END;
IF platform = 6 THEN
stksize := getver()
END;
UTILS.concat(SelfPath, "Lib");
UTILS.concat(SelfPath, UTILS.Slash);
IF platform = 5 THEN
UTILS.concat(SelfPath, "Linux32")
ELSIF platform IN {4, 6} THEN
UTILS.concat(SelfPath, "KolibriOS")
ELSIF platform IN {1, 2, 3} THEN
UTILS.concat(SelfPath, "Windows32")
END;
UTILS.concat(SelfPath, UTILS.Slash);
X86.set_maxstrlen(0);
X86.Init(platform);
X86.Prolog(temp);
DECL.Program(SelfPath, Path, Name, Ext, platform IN {1, 2, 3}, OpSeq, Expr, AssComp, sttypes);
voidtype := sttypes[TVOID];
inttype := sttypes[TINTEGER];
booltype := sttypes[TBOOLEAN];
strtype := sttypes[TSTRING];
settype := sttypes[TSET];
realtype := sttypes[TREAL];
longrealtype := sttypes[TLONGREAL];
chartype := sttypes[TCHAR];
niltype := sttypes[TNIL];
DECL.Compile(platform, stksize);
UTILS.OutString("success"); UTILS.Ln;
UTILS.HALT(0)
END Start;
 
UTILS.Exit(0)
END main;
 
 
BEGIN
main
Start
END Compiler.
/programs/develop/oberon07/Source/X86.ob07
1,2406 → 1,2004
(*
BSD 2-Clause License
(*
Copyright 2016, 2017, 2018 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This file is part of Compiler.
 
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
Compiler 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 General Public License for more details.
 
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE X86;
 
IMPORT CODE, REG, UTILS, LISTS, BIN, PE32, KOS, MSCOFF, ELF, mConst := CONSTANTS, MACHINE, CHL := CHUNKLISTS, PATHS;
IMPORT UTILS, sys := SYSTEM, SCAN, ELF;
 
 
CONST
 
eax = REG.R0; ecx = REG.R1; edx = REG.R2;
ADIM* = 5;
 
al = eax; cl = ecx; dl = edx; ah = 4;
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
 
ax = eax; cx = ecx; dx = edx;
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;
 
esp = 4;
ebp = 5;
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; stEXCL* = 16; stCOPY* = 17; stNEW* = 18; stASSERT* = 19;
stPACK* = 20; stUNPK* = 21; stDISPOSE* = 22; stFABS* = 23; stINC1* = 24;
stDEC1* = 25; stASSERT1* = 26; stUNPK1* = 27; stPACK1* = 28; stLSR* = 29;
stLENGTH* = 30; stMIN* = 31; stMAX* = 32;
 
sete = 94H; setne = 95H; setl = 9CH; setge = 9DH; setle = 9EH; setg = 9FH; setc = 92H; setnc = 93H;
sysMOVE* = 108;
 
je = 84H; jne = 85H; jl = 8CH; jge = 8DH; jle = 8EH; jg = 8FH; jb = 82H; jnb = 83H;
JMP* = 0E9X; CALL = 0E8X;
JE = 84X; JNE = 85X; JLE = 8EX; JGE = 8DX; JG = 8FX; JL = 8CX;
 
JCMD = 1; LCMD = 2; GCMD = 3; OCMD = 4; ECMD = 5;
PUSHEAX = 6; PUSHECX = 7; PUSHEDX = 8; POPEAX = 9; POPECX = 10; POPEDX = 11;
ICMP1 = 13; ICMP2 = 14;
 
CODECHUNK = 8;
defcall = 0; stdcall = 1; cdecl = 2; winapi = 3;
 
_rset* = 0; _inset* = 1; _saverec* = 2; _length* = 3; _checktype* = 4; _strcmp* = 5;
_lstrcmp* = 6; _rstrcmp* = 7; _savearr* = 8; _newrec* = 9; _disprec* = 10; _arrayidx* = 11;
_arrayrot* = 12; _assrt* = 13; _strcopy* = 14; _arrayidx1* = 15; _init* = 16; _close* = 17; _halt* = 18;
ASSRT = 19; hInstance = 20; SELFNAME = 21; RTABLE = 22;LoadLibrary = 23; GetProcAddress = 24;
Exports = 25; szSTART = 26; START = 27; szversion = 28; _floor = 29; HALT = 30;
 
FREGS = 8;
 
TYPE
 
COMMAND = CODE.COMMAND;
 
 
ANYCODE = POINTER TO RECORD (LISTS.ITEM)
 
offset: INTEGER
 
ASMLINE* = POINTER TO RECORD (UTILS.rITEM)
cmd, clen, varadr, adr, tcmd, codeadr: INTEGER; short: BOOLEAN
END;
 
TCODE = POINTER TO RECORD (ANYCODE)
TFLT = ARRAY 2 OF INTEGER;
 
code: ARRAY CODECHUNK OF BYTE;
length: INTEGER
TIDX* = ARRAY ADIM OF INTEGER;
 
END;
SECTIONNAME = ARRAY 8 OF CHAR;
 
LABEL = POINTER TO RECORD (ANYCODE)
 
label: INTEGER
 
SECTION = RECORD
name: SECTIONNAME;
size, adr, sizealign, OAPfile, reserved6, reserved7, reserved8, attrflags: INTEGER
END;
 
JUMP = POINTER TO RECORD (ANYCODE)
 
label, diff: INTEGER;
short: BOOLEAN
 
HEADER = RECORD
msdos: ARRAY 180 OF CHAR;
typecomp, seccount: sys.CARD16;
time, reserved1, reserved2: INTEGER;
PEoptsize, infflags, PEfile, compver: sys.CARD16;
codesize, datasize, initdatasize, startadr,
codeadr, rdataadr, loadadr, secalign, filealign,
oldestver, version, oldestverNT, reserved3,
filesize, headersize, dllcrc: INTEGER;
UI, reserved4: sys.CARD16;
stksize, stkalloc, heapsize, heapalloc, reserved5, structcount: INTEGER;
structs: ARRAY 16 OF RECORD adr, size: INTEGER END;
sections: ARRAY 3 OF SECTION
END;
 
JMP = POINTER TO RECORD (JUMP)
 
COFFHEADER = RECORD
Machine: sys.CARD16;
NumberOfSections: sys.CARD16;
TimeDateStamp,
PointerToSymbolTable,
NumberOfSymbols: INTEGER;
SizeOfOptionalHeader,
Characteristics: sys.CARD16;
text, data, bss: SECTION
END;
 
JCC = POINTER TO RECORD (JUMP)
 
jmp: INTEGER
 
KOSHEADER = RECORD
menuet01: ARRAY 8 OF CHAR;
ver, start, size, mem, sp, param, path: INTEGER
END;
 
CALL = POINTER TO RECORD (JUMP)
 
ETABLE = RECORD
reserved1, time, reserved2, dllnameoffset, firstnum, adrcount,
namecount, arradroffset, arrnameptroffset, arrnumoffset: INTEGER;
arradr, arrnameptr: ARRAY 10000H OF INTEGER;
arrnum: ARRAY 10000H OF sys.CARD16;
text: ARRAY 1000000 OF CHAR;
textlen, size: INTEGER
END;
 
RELOC = POINTER TO RECORD (ANYCODE)
 
op, value: INTEGER
 
RELOC = RECORD
Page, Size: INTEGER;
reloc: ARRAY 1024 OF sys.CARD16
END;
 
VAR asmlist: UTILS.LIST; start: ASMLINE; dll, con, gui, kos, elf, obj, kem: BOOLEAN;
Lcount, reccount, topstk: INTEGER; recarray: ARRAY 2048 OF INTEGER; current*: ASMLINE;
callstk: ARRAY 1024, 2 OF ASMLINE; OutFile: UTILS.STRING;
Code: ARRAY 4000000 OF CHAR; ccount: INTEGER; Data: ARRAY 1000000 OF CHAR; dcount: INTEGER;
Labels: ARRAY 200000 OF INTEGER; rdata: ARRAY 400H OF INTEGER; Header: HEADER; etable: ETABLE;
ExecName: UTILS.STRING; LoadAdr: INTEGER; Reloc: ARRAY 200000 OF CHAR; rcount: INTEGER;
RtlProc: ARRAY 20 OF INTEGER; OutFilePos: INTEGER; RelocSection: SECTION;
fpu*: INTEGER; isfpu: BOOLEAN; maxfpu: INTEGER; fpucmd: ASMLINE;
kosexp: ARRAY 65536 OF RECORD Name: SCAN.NODE; Adr, NameLabel: INTEGER END; kosexpcount: INTEGER;
maxstrlen*: INTEGER;
 
VAR
PROCEDURE set_maxstrlen* (value: INTEGER);
BEGIN
maxstrlen := value
END set_maxstrlen;
 
R: REG.REGS;
PROCEDURE AddRtlProc*(idx, proc: INTEGER);
BEGIN
RtlProc[idx] := proc
END AddRtlProc;
 
program: BIN.PROGRAM;
PROCEDURE IntToCard16(i: INTEGER): sys.CARD16;
VAR w: sys.CARD16;
BEGIN
sys.GET(sys.ADR(i), w)
RETURN w
END IntToCard16;
 
CodeList: LISTS.LIST;
PROCEDURE CopyStr(VAR Dest: ARRAY OF CHAR; Source: ARRAY OF CHAR; VAR di: INTEGER; si: INTEGER);
BEGIN
DEC(di);
REPEAT
INC(di);
Dest[di] := Source[si];
INC(si)
UNTIL Dest[di] = 0X
END CopyStr;
 
PROCEDURE exch(VAR a, b: INTEGER);
VAR c: INTEGER;
BEGIN
c := a;
a := b;
b := c
END exch;
 
PROCEDURE Byte (n: INTEGER): BYTE;
RETURN MACHINE.Byte(n, 0)
END Byte;
PROCEDURE Sort(VAR NamePtr, Adr: ARRAY OF INTEGER; Text: ARRAY OF CHAR; LB, RB: INTEGER);
VAR L, R: INTEGER;
 
PROCEDURE strle(s1, s2: INTEGER): BOOLEAN;
VAR S1, S2: ARRAY 256 OF CHAR; i: INTEGER;
BEGIN
i := 0;
CopyStr(S1, Text, i, s1);
i := 0;
CopyStr(S2, Text, i, s2)
RETURN S1 <= S2
END strle;
 
PROCEDURE Word (n: INTEGER): INTEGER;
RETURN MACHINE.Byte(n, 0) + MACHINE.Byte(n, 1) * 256
END Word;
 
 
PROCEDURE OutByte* (n: BYTE);
VAR
c: TCODE;
last: ANYCODE;
 
BEGIN
last := CodeList.last(ANYCODE);
 
IF (last IS TCODE) & (last(TCODE).length < CODECHUNK) THEN
c := last(TCODE);
c.code[c.length] := n;
INC(c.length)
ELSE
NEW(c);
c.code[0] := n;
c.length := 1;
LISTS.push(CodeList, c)
IF LB < RB THEN
L := LB;
R := RB;
REPEAT
WHILE (L < RB) & strle(NamePtr[L], NamePtr[LB]) DO
INC(L)
END;
WHILE (R > LB) & strle(NamePtr[LB], NamePtr[R]) DO
DEC(R)
END;
IF L < R THEN
exch(NamePtr[L], NamePtr[R]);
exch(Adr[L], Adr[R])
END
UNTIL L >= R;
IF R > LB THEN
exch(NamePtr[LB], NamePtr[R]);
exch(Adr[LB], Adr[R]);
Sort(NamePtr, Adr, Text, LB, R - 1)
END;
Sort(NamePtr, Adr, Text, R + 1, RB)
END
END Sort;
 
END OutByte;
 
 
PROCEDURE OutInt (n: INTEGER);
PROCEDURE PackExport(Name: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN
OutByte(MACHINE.Byte(n, 0));
OutByte(MACHINE.Byte(n, 1));
OutByte(MACHINE.Byte(n, 2));
OutByte(MACHINE.Byte(n, 3))
END OutInt;
Sort(etable.arrnameptr, etable.arradr, etable.text, 0, etable.namecount - 1);
FOR i := 0 TO etable.namecount - 1 DO
etable.arrnum[i] := IntToCard16(i)
END;
etable.size := 40 + etable.adrcount * 4 + etable.namecount * 6;
etable.arradroffset := 40;
etable.arrnameptroffset := 40 + etable.adrcount * 4;
etable.arrnumoffset := etable.arrnameptroffset + etable.namecount * 4;
etable.dllnameoffset := etable.size + etable.textlen;
CopyStr(etable.text, Name, etable.textlen, 0);
INC(etable.textlen);
FOR i := 0 TO etable.namecount - 1 DO
etable.arrnameptr[i] := etable.arrnameptr[i] + etable.size
END;
etable.size := etable.size + etable.textlen
END PackExport;
 
 
PROCEDURE OutByte2 (a, b: BYTE);
PROCEDURE ProcExport*(Number: INTEGER; Name: SCAN.NODE; NameLabel: INTEGER);
BEGIN
OutByte(a);
OutByte(b)
END OutByte2;
IF dll THEN
etable.arradr[etable.adrcount] := Number;
INC(etable.adrcount);
etable.arrnameptr[etable.namecount] := etable.textlen;
INC(etable.namecount);
CopyStr(etable.text, Name.Name, etable.textlen, 0);
INC(etable.textlen)
ELSIF obj THEN
kosexp[kosexpcount].Name := Name;
kosexp[kosexpcount].Adr := Number;
kosexp[kosexpcount].NameLabel := NameLabel;
INC(kosexpcount)
END
END ProcExport;
 
 
PROCEDURE OutByte3 (a, b, c: BYTE);
PROCEDURE Err(code: INTEGER);
BEGIN
OutByte(a);
OutByte(b);
OutByte(c)
END OutByte3;
CASE code OF
|1: UTILS.ErrMsg(67); UTILS.OutString(OutFile)
|2: UTILS.ErrMsg(69); UTILS.OutString(OutFile)
ELSE
END;
UTILS.Ln;
UTILS.HALT(1)
END Err;
 
PROCEDURE Align*(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
 
PROCEDURE OutWord (n: INTEGER);
PROCEDURE PutReloc(R: RELOC);
VAR i: INTEGER;
BEGIN
ASSERT((0 <= n) & (n <= 65535));
OutByte2(n MOD 256, n DIV 256)
END OutWord;
sys.PUT(sys.ADR(Reloc[rcount]), R.Page);
INC(rcount, 4);
sys.PUT(sys.ADR(Reloc[rcount]), R.Size);
INC(rcount, 4);
FOR i := 0 TO ASR(R.Size - 8, 1) - 1 DO
sys.PUT(sys.ADR(Reloc[rcount]), R.reloc[i]);
INC(rcount, 2)
END
END PutReloc;
 
 
PROCEDURE isByte (n: INTEGER): BOOLEAN;
RETURN (-128 <= n) & (n <= 127)
END isByte;
 
 
PROCEDURE short (n: INTEGER): INTEGER;
RETURN 2 * ORD(isByte(n))
END short;
 
 
PROCEDURE long (n: INTEGER): INTEGER;
RETURN 40H * ORD(~isByte(n))
END long;
 
 
PROCEDURE OutIntByte (n: INTEGER);
PROCEDURE InitArray(VAR adr: INTEGER; chars: UTILS.STRING);
VAR i, x, n: INTEGER;
BEGIN
IF isByte(n) THEN
OutByte(Byte(n))
ELSE
OutInt(n)
n := LEN(chars) - 1;
i := 0;
WHILE (i < n) & (chars[i] # 0X) DO
x := SCAN.hex(chars[i]) * 16 + SCAN.hex(chars[i + 1]);
sys.PUT(adr, CHR(x));
INC(adr);
INC(i, 2)
END
END OutIntByte;
END InitArray;
 
 
PROCEDURE shift* (op, reg: INTEGER);
PROCEDURE WriteF(F, A, N: INTEGER);
BEGIN
CASE op OF
|CODE.opASR, CODE.opASR1, CODE.opASR2: OutByte(0F8H + reg)
|CODE.opROR, CODE.opROR1, CODE.opROR2: OutByte(0C8H + reg)
|CODE.opLSL, CODE.opLSL1, CODE.opLSL2: OutByte(0E0H + reg)
|CODE.opLSR, CODE.opLSR1, CODE.opLSR2: OutByte(0E8H + reg)
IF UTILS.Write(F, A, N) # N THEN
Err(2)
END
END shift;
END WriteF;
 
 
PROCEDURE mov (reg1, reg2: INTEGER);
PROCEDURE Write(A, N: INTEGER);
BEGIN
OutByte2(89H, 0C0H + reg2 * 8 + reg1) // mov reg1, reg2
END mov;
sys.MOVE(A, OutFilePos, N);
OutFilePos := OutFilePos + N
END Write;
 
 
PROCEDURE xchg (reg1, reg2: INTEGER);
VAR
regs: SET;
 
PROCEDURE Fill(n: INTEGER; c: CHAR);
VAR i: INTEGER;
BEGIN
regs := {reg1, reg2};
IF regs = {eax, ecx} THEN
OutByte(91H) // xchg eax, ecx
ELSIF regs = {eax, edx} THEN
OutByte(92H) // xchg eax, edx
ELSIF regs = {ecx, edx} THEN
OutByte2(87H, 0D1H) // xchg ecx, edx
FOR i := 1 TO n DO
Write(sys.ADR(c), 1)
END
END xchg;
END Fill;
 
PROCEDURE SetSection(VAR Section: SECTION; name: SECTIONNAME; size, adr, sizealign, OAPfile, attrflags: INTEGER);
BEGIN
Section.name := name;
Section.size := size;
Section.adr := adr;
Section.sizealign := sizealign;
Section.OAPfile := OAPfile;
Section.attrflags := attrflags;
END SetSection;
 
PROCEDURE pop (reg: INTEGER);
PROCEDURE WritePE(FName: ARRAY OF CHAR; stksize, codesize, datasize, rdatasize, gsize: INTEGER);
CONST textattr = 60000020H; rdataattr = 40000040H; dataattr = 0C0000040H; relocattr = 42000040H;
VAR i, F, adr, acodesize, compver, version, stkalloc, heapsize, heapalloc, filesize, filebuf: INTEGER;
cur: ASMLINE;
BEGIN
OutByte(58H + reg) // pop reg
END pop;
 
compver := 0;
version := 0;
stkalloc := stksize;
heapsize := 100000H;
heapalloc := 100000H;
acodesize := Align(codesize, 1000H) + 1000H;
adr := sys.ADR(rdata);
filesize := acodesize + Align(rdatasize, 1000H) + Align(datasize, 1000H) + Align(rcount, 1000H);
 
PROCEDURE push (reg: INTEGER);
BEGIN
OutByte(50H + reg) // push reg
END push;
InitArray(adr, "5000000040000000000000003400000000000000000000006200000000000000");
InitArray(adr, "0000000000000000000000000000000000000000500000004000000000000000");
InitArray(adr, "A4014C6F61644C6962726172794100001F0147657450726F6341646472657373");
InitArray(adr, "00006B65726E656C33322E646C6C0000");
 
rdata[ 0] := acodesize + 50H;
rdata[ 1] := acodesize + 40H;
rdata[ 3] := acodesize + 34H;
rdata[ 6] := acodesize + 62H;
rdata[ 7] := acodesize;
rdata[13] := acodesize + 50H;
rdata[14] := acodesize + 40H;
 
PROCEDURE movrc (reg, n: INTEGER);
BEGIN
OutByte(0B8H + reg); // mov reg, n
OutInt(n)
END movrc;
adr := sys.ADR(Header.msdos);
InitArray(adr, "4D5A90000300000004000000FFFF0000B8000000000000004000000000000000");
InitArray(adr, "00000000000000000000000000000000000000000000000000000000B0000000");
InitArray(adr, "0E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F");
InitArray(adr, "742062652072756E20696E20444F53206D6F64652E0D0D0A2400000000000000");
InitArray(adr, "5DCF9F8719AEF1D419AEF1D419AEF1D497B1E2D413AEF1D4E58EE3D418AEF1D4");
InitArray(adr, "5269636819AEF1D4000000000000000050450000");
Header.typecomp := IntToCard16(014CH);
IF dll THEN
Header.seccount := IntToCard16(0004H);
Header.infflags := IntToCard16(210EH)
ELSE
Header.seccount := IntToCard16(0003H);
Header.infflags := IntToCard16(010FH)
END;
Header.time := UTILS.Date;
Header.PEoptsize := IntToCard16(00E0H);
Header.PEfile := IntToCard16(010BH);
Header.compver := IntToCard16(compver);
Header.codesize := Align(codesize, 200H);
Header.datasize := Align(datasize + gsize, 200H) + Align(rdatasize, 200H) + Align(rcount, 200H);
Header.startadr := 1000H;
Header.codeadr := 1000H;
Header.rdataadr := Header.codeadr + Align(codesize, 1000H);
Header.loadadr := LoadAdr;
Header.secalign := 1000H;
Header.filealign := 0200H;
Header.oldestver := 0004H;
Header.version := version;
Header.oldestverNT := 0004H;
Header.filesize := Align(codesize, 1000H) + Align(datasize + gsize, 1000H) + Align(rdatasize, 1000H) + Align(rcount, 1000H) + 1000H;
Header.headersize := 0400H;
Header.UI := IntToCard16(ORD(con) + 2);
Header.stksize := stksize;
Header.stkalloc := stkalloc;
Header.heapsize := heapsize;
Header.heapalloc := heapalloc;
Header.structcount := 10H;
IF dll THEN
Header.structs[0].adr := Header.rdataadr + 0DAH;
Header.structs[0].size := etable.size
END;
 
Header.structs[1].adr := Header.rdataadr + 0CH;
Header.structs[1].size := 28H;
Header.structs[12].adr := Header.rdataadr;
Header.structs[12].size := 0CH;
 
PROCEDURE pushc (n: INTEGER);
BEGIN
OutByte(68H + short(n)); // push n
OutIntByte(n)
END pushc;
SetSection(Header.sections[0], ".text", codesize, 1000H, Align(codesize, 200H), 400H, textattr);
SetSection(Header.sections[1], ".rdata", rdatasize, Align(codesize, 1000H) + 1000H, Align(rdatasize, 200H),
Align(codesize, 200H) + 400H, rdataattr);
SetSection(Header.sections[2], ".data", datasize + gsize, Align(codesize, 1000H) + Align(rdatasize, 1000H) + 1000H,
Align(datasize, 200H), Align(codesize, 200H) + Align(rdatasize, 200H) + 400H, dataattr);
 
IF dll THEN
SetSection(RelocSection, ".reloc", rcount, Header.sections[2].adr + Align(datasize + gsize, 1000H), Align(rcount, 200H),
Header.sections[2].OAPfile + Align(datasize, 200H), relocattr);
Header.structs[5].adr := RelocSection.adr;
Header.structs[5].size := rcount
END;
 
PROCEDURE test (reg: INTEGER);
BEGIN
OutByte2(85H, 0C0H + reg * 9) // test reg, reg
END test;
F := UTILS.CreateF(FName);
IF F = 0 THEN
Err(1)
END;
OutFilePos := UTILS.GetMem(filesize);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
 
Write(sys.ADR(Header), sys.SIZE(HEADER));
IF dll THEN
Write(sys.ADR(RelocSection), sys.SIZE(SECTION));
Fill(Align(sys.SIZE(HEADER) + sys.SIZE(SECTION), 200H) - (sys.SIZE(HEADER) + sys.SIZE(SECTION)), 0X)
ELSE
Fill(Align(sys.SIZE(HEADER), 200H) - sys.SIZE(HEADER), 0X)
END;
 
PROCEDURE neg (reg: INTEGER);
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
Fill(Align(codesize, 200H) - codesize, 0X);
Write(sys.ADR(rdata), 0DAH);
IF dll THEN
etable.time := Header.time;
Write(sys.ADR(etable), 40);
Write(sys.ADR(etable.arradr), etable.adrcount * 4);
Write(sys.ADR(etable.arrnameptr), etable.namecount * 4);
Write(sys.ADR(etable.arrnum), etable.namecount * 2);
Write(sys.ADR(etable.text), etable.textlen)
END;
Fill(Align(rdatasize, 200H) - rdatasize, 0X);
Write(sys.ADR(Data), datasize);
Fill(Align(datasize, 200H) - datasize, 0X);
IF dll THEN
Write(sys.ADR(Reloc), rcount);
Fill(Align(rcount, 200H) - rcount, 0X)
END;
WriteF(F, filebuf, OutFilePos - filebuf);
UTILS.CloseF(F)
END WritePE;
 
PROCEDURE New;
VAR nov: ASMLINE;
BEGIN
OutByte2(0F7H, 0D8H + reg) // neg reg
END neg;
NEW(nov);
UTILS.MemErr(nov = NIL);
nov.cmd := ccount;
UTILS.Insert(asmlist, nov, current);
current := current.Next(ASMLINE)
END New;
 
 
PROCEDURE not (reg: INTEGER);
PROCEDURE Empty(varadr: INTEGER);
BEGIN
OutByte2(0F7H, 0D0H + reg) // not reg
END not;
New;
current.clen := 0;
current.tcmd := ECMD;
current.varadr := varadr
END Empty;
 
 
PROCEDURE add (reg1, reg2: INTEGER);
PROCEDURE OutByte(byte: INTEGER);
BEGIN
OutByte2(01H, 0C0H + reg2 * 8 + reg1) // add reg1, reg2
END add;
New;
current.clen := 1;
Code[ccount] := CHR(byte);
INC(ccount)
END OutByte;
 
 
PROCEDURE andrc (reg, n: INTEGER);
PROCEDURE OutInt(int: INTEGER);
BEGIN
OutByte2(81H + short(n), 0E0H + reg); // and reg, n
OutIntByte(n)
END andrc;
New;
current.clen := 4;
sys.PUT(sys.ADR(Code[ccount]), int);
INC(ccount, 4)
END OutInt;
 
 
PROCEDURE orrc (reg, n: INTEGER);
PROCEDURE PushEAX;
BEGIN
OutByte2(81H + short(n), 0C8H + reg); // or reg, n
OutIntByte(n)
END orrc;
OutByte(50H);
current.tcmd := PUSHEAX
END PushEAX;
 
 
PROCEDURE addrc (reg, n: INTEGER);
PROCEDURE PushECX;
BEGIN
OutByte2(81H + short(n), 0C0H + reg); // add reg, n
OutIntByte(n)
END addrc;
OutByte(51H);
current.tcmd := PUSHECX
END PushECX;
 
 
PROCEDURE subrc (reg, n: INTEGER);
PROCEDURE PushEDX;
BEGIN
OutByte2(81H + short(n), 0E8H + reg); // sub reg, n
OutIntByte(n)
END subrc;
OutByte(52H);
current.tcmd := PUSHEDX
END PushEDX;
 
 
PROCEDURE cmprr (reg1, reg2: INTEGER);
PROCEDURE PopEAX;
BEGIN
OutByte2(39H, 0C0H + reg2 * 8 + reg1) // cmp reg1, reg2
END cmprr;
OutByte(58H);
current.tcmd := POPEAX
END PopEAX;
 
 
PROCEDURE cmprc (reg, n: INTEGER);
PROCEDURE PopECX;
BEGIN
OutByte2(81H + short(n), 0F8H + reg); // cmp reg, n
OutIntByte(n)
END cmprc;
OutByte(59H);
current.tcmd := POPECX
END PopECX;
 
 
PROCEDURE setcc (cond, reg: INTEGER);
PROCEDURE PopEDX;
BEGIN
OutByte3(0FH, cond, 0C0H + reg) // setcc reg
END setcc;
OutByte(5AH);
current.tcmd := POPEDX
END PopEDX;
 
 
PROCEDURE drop;
PROCEDURE OutCode(cmd: UTILS.STRING);
VAR a, b: INTEGER;
BEGIN
REG.Drop(R)
END drop;
New;
a := sys.ADR(Code[ccount]);
b := a;
InitArray(a, cmd);
ccount := a - b + ccount;
current.clen := a - b
END OutCode;
 
 
PROCEDURE log2* (x: INTEGER): INTEGER;
VAR
n: INTEGER;
 
PROCEDURE Del*(last: ASMLINE);
BEGIN
ASSERT(x > 0);
 
n := 0;
WHILE ~ODD(x) DO
x := x DIV 2;
INC(n)
last.Next := current.Next;
IF current = asmlist.Last THEN
asmlist.Last := last
END;
current := last
END Del;
 
IF x # 1 THEN
n := -1
END
PROCEDURE NewLabel*(): INTEGER;
BEGIN
INC(Lcount)
RETURN Lcount
END NewLabel;
 
RETURN n
END log2;
PROCEDURE PushCall*(asmline: ASMLINE);
BEGIN
New;
callstk[topstk][0] := asmline;
callstk[topstk][1] := current;
INC(topstk)
END PushCall;
 
PROCEDURE Param*;
BEGIN
current := callstk[topstk - 1][0]
END Param;
 
PROCEDURE cond* (op: INTEGER): INTEGER;
VAR
res: INTEGER;
 
PROCEDURE EndCall*;
BEGIN
CASE op OF
|CODE.opGT, CODE.opGTR, CODE.opLTL: res := jg
|CODE.opGE, CODE.opGER, CODE.opLEL: res := jge
|CODE.opLT, CODE.opLTR, CODE.opGTL: res := jl
|CODE.opLE, CODE.opLER, CODE.opGEL: res := jle
|CODE.opEQ, CODE.opEQR, CODE.opEQL: res := je
|CODE.opNE, CODE.opNER, CODE.opNEL: res := jne
END
current := callstk[topstk - 1][1];
DEC(topstk)
END EndCall;
 
RETURN res
END cond;
 
 
PROCEDURE inv1* (op: INTEGER): INTEGER;
PROCEDURE Init*(UI: INTEGER);
VAR nov: ASMLINE;
BEGIN
IF ODD(op) THEN
DEC(op)
ELSE
INC(op)
END
dcount := 4;
dll := UI = 1;
gui := UI = 2;
con := UI = 3;
kos := UI = 4;
elf := UI = 5;
obj := UI = 6;
Lcount := HALT;
asmlist := UTILS.CreateList();
NEW(nov);
UTILS.MemErr(nov = NIL);
UTILS.Push(asmlist, nov);
current := nov
END Init;
 
RETURN op
END inv1;
 
 
PROCEDURE Reloc* (op, value: INTEGER);
VAR
reloc: RELOC;
 
PROCEDURE datastr(str: UTILS.STRING);
VAR i, n: INTEGER;
BEGIN
NEW(reloc);
reloc.op := op;
reloc.value := value;
LISTS.push(CodeList, reloc)
END Reloc;
i := 0;
n := LEN(str);
WHILE (i < n) & (str[i] # 0X) DO
Data[dcount] := str[i];
INC(dcount);
INC(i)
END;
Data[dcount] := 0X;
INC(dcount)
END datastr;
 
 
PROCEDURE jcc* (cc, label: INTEGER);
VAR
j: JCC;
 
PROCEDURE dataint(n: INTEGER);
BEGIN
NEW(j);
j.label := label;
j.jmp := cc;
j.short := FALSE;
LISTS.push(CodeList, j)
END jcc;
sys.PUT(sys.ADR(Data[dcount]), n);
INC(dcount, 4)
END dataint;
 
 
PROCEDURE jmp* (label: INTEGER);
VAR
j: JMP;
 
PROCEDURE jmp*(jamp: CHAR; label: INTEGER);
VAR n: INTEGER;
BEGIN
NEW(j);
j.label := label;
j.short := FALSE;
LISTS.push(CodeList, j)
New;
CASE jamp OF
|JMP, CALL:
n := 5
|JE, JLE, JGE, JG, JL, JNE:
Code[ccount] := 0FX;
INC(ccount);
n := 6
ELSE
END;
current.clen := n;
Code[ccount] := jamp;
INC(ccount);
current.codeadr := sys.ADR(Code[ccount]);
current.varadr := sys.ADR(Labels[label]);
current.tcmd := JCMD;
current.short := TRUE;
INC(ccount, 4)
END jmp;
 
PROCEDURE jmplong(jamp: CHAR; label: INTEGER);
BEGIN
jmp(jamp, label);
current.short := FALSE
END jmplong;
 
PROCEDURE call* (label: INTEGER);
VAR
c: CALL;
 
PROCEDURE Label*(label: INTEGER);
BEGIN
NEW(c);
c.label := label;
c.short := TRUE;
LISTS.push(CodeList, c)
END call;
New;
current.varadr := sys.ADR(Labels[label]);
current.tcmd := LCMD
END Label;
 
 
PROCEDURE Pic (reg, opcode, value: INTEGER);
PROCEDURE CmdN(Number: INTEGER);
BEGIN
OutByte(0E8H); OutInt(0); // call L
// L:
pop(reg);
OutByte2(081H, 0C0H + reg); // add reg, ...
Reloc(opcode, value)
END Pic;
New;
current.clen := 4;
current.codeadr := sys.ADR(Code[ccount]);
current.varadr := sys.ADR(Labels[Number]);
current.tcmd := OCMD;
INC(ccount, 4)
END CmdN;
 
 
PROCEDURE CallRTL (pic: BOOLEAN; proc: INTEGER);
VAR
label: INTEGER;
reg1: INTEGER;
 
PROCEDURE IntByte(bytecode, intcode: UTILS.STRING; n: INTEGER);
BEGIN
label := CODE.codes.rtl[proc];
 
IF label < 0 THEN
label := -label;
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICIMP, label);
OutByte2(0FFH, 010H + reg1); // call dword[reg1]
drop
IF (n <= 127) & (n >= -128) THEN
OutCode(bytecode);
OutByte(n)
ELSE
OutByte2(0FFH, 015H); // call dword[label]
Reloc(BIN.RIMP, label)
OutCode(intcode);
OutInt(n)
END
ELSE
call(label)
END
END CallRTL;
END IntByte;
 
 
PROCEDURE SetLabel* (label: INTEGER);
VAR
L: LABEL;
 
PROCEDURE DropFpu*(long: BOOLEAN);
BEGIN
NEW(L);
L.label := label;
LISTS.push(CodeList, L)
END SetLabel;
IF long THEN
OutCode("83EC08DD1C24")
ELSE
OutCode("83EC04D91C24")
END;
DEC(fpu)
END DropFpu;
 
 
PROCEDURE fixup*;
VAR
code: ANYCODE;
count, i: INTEGER;
shorted: BOOLEAN;
jump: JUMP;
 
PROCEDURE AfterRet(func, float: BOOLEAN; callconv, parsize: INTEGER);
BEGIN
 
REPEAT
 
shorted := FALSE;
count := 0;
 
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
code.offset := count;
 
CASE code OF
|TCODE: INC(count, code.length)
|LABEL: BIN.SetLabel(program, code.label, count)
|JMP: IF code.short THEN INC(count, 2) ELSE INC(count, 5) END; code.offset := count
|JCC: IF code.short THEN INC(count, 2) ELSE INC(count, 6) END; code.offset := count
|CALL: INC(count, 5); code.offset := count
|RELOC: INC(count, 4)
IF callconv = cdecl THEN
OutCode("81C4");
OutInt(parsize)
END;
 
code := code.next(ANYCODE)
END;
 
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
 
IF code IS JUMP THEN
jump := code(JUMP);
jump.diff := BIN.GetLabel(program, jump.label) - code.offset;
IF ~jump.short & isByte(jump.diff) THEN
jump.short := TRUE;
shorted := TRUE
IF func THEN
IF float THEN
OutCode("83EC08DD1C24")
ELSE
PushEAX
END
END;
 
code := code.next(ANYCODE)
END
END AfterRet;
 
UNTIL ~shorted;
 
code := CodeList.first(ANYCODE);
WHILE code # NIL DO
 
CASE code OF
 
|TCODE:
FOR i := 0 TO code.length - 1 DO
BIN.PutCode(program, code.code[i])
PROCEDURE FpuSave(local: INTEGER);
VAR i: INTEGER;
BEGIN
IF fpu > maxfpu THEN
maxfpu := fpu
END;
FOR i := 1 TO fpu DO
IntByte("DD5D", "DD9D", -local - i * 8)
END
END FpuSave;
 
|LABEL:
BIN.SetLabel(program, code.label, code.offset)
PROCEDURE Incfpu;
BEGIN
IF fpu >= FREGS THEN
UTILS.ErrMsgPos(SCAN.coord.line, SCAN.coord.col, 97);
UTILS.HALT(1)
END;
INC(fpu);
isfpu := TRUE
END Incfpu;
 
|JMP:
IF code.short THEN
BIN.PutCode(program, 0EBH);
BIN.PutCode(program, Byte(code.diff))
ELSE
BIN.PutCode(program, 0E9H);
BIN.PutCode32LE(program, code.diff)
PROCEDURE FpuLoad(local: INTEGER; float: BOOLEAN);
VAR i: INTEGER;
BEGIN
FOR i := fpu TO 1 BY -1 DO
IntByte("DD45", "DD85", -local - i * 8)
END;
IF float THEN
Incfpu;
OutCode("DD042483C408")
END
END FpuLoad;
 
|JCC:
IF code.short THEN
BIN.PutCode(program, code.jmp - 16);
BIN.PutCode(program, Byte(code.diff))
ELSE
BIN.PutCode(program, 0FH);
BIN.PutCode(program, code.jmp);
BIN.PutCode32LE(program, code.diff)
PROCEDURE Call*(proc: INTEGER; func, float: BOOLEAN; callconv, ccall, bases, level, parsize, local: INTEGER);
VAR i: INTEGER;
BEGIN
IF ccall # 0 THEN
FOR i := level TO level - bases + ORD(ccall = 1) + 1 BY -1 DO
IntByte("FF75", "FFB5", 4 * i + 4)
END;
IF ccall = 1 THEN
OutByte(55H)
END
 
|CALL:
BIN.PutCode(program, 0E8H);
BIN.PutCode32LE(program, code.diff)
 
|RELOC:
BIN.PutReloc(program, code.op);
BIN.PutCode32LE(program, code.value)
 
END;
FpuSave(local);
jmplong(CALL, proc);
AfterRet(func, float, callconv, parsize);
FpuLoad(local, func & float)
END Call;
 
code := code.next(ANYCODE)
END
 
END fixup;
 
 
PROCEDURE UnOp (VAR reg: INTEGER);
PROCEDURE CallRTL(Proc: INTEGER);
BEGIN
REG.UnOp(R, reg)
END UnOp;
New;
current.clen := 5;
Code[ccount] := CALL;
INC(ccount);
current.codeadr := sys.ADR(Code[ccount]);
current.varadr := sys.ADR(RtlProc[Proc]);
current.tcmd := JCMD;
INC(ccount, 4)
END CallRTL;
 
 
PROCEDURE BinOp (VAR reg1, reg2: INTEGER);
PROCEDURE PushInt*(n: INTEGER);
BEGIN
REG.BinOp(R, reg1, reg2)
END BinOp;
OutByte(68H);
CmdN(n)
END PushInt;
 
 
PROCEDURE PushAll (NumberOfParameters: INTEGER);
PROCEDURE Prolog*(exename: UTILS.STRING);
BEGIN
REG.PushAll(R);
R.pushed := R.pushed - NumberOfParameters
END PushAll;
ExecName := exename;
Labels[hInstance] := -dcount;
dataint(0);
Labels[SELFNAME] := -dcount;
datastr(exename);
Label(START);
IF dll THEN
OutCode("558BEC837D0C007507");
CallRTL(_close);
OutCode("EB06837D0C017409B801000000C9C20C00")
ELSIF obj THEN
OutCode("558BEC")
END;
start := asmlist.Last(ASMLINE)
END Prolog;
 
 
PROCEDURE NewLabel (): INTEGER;
PROCEDURE AddRec*(base: INTEGER);
BEGIN
BIN.NewLabel(program)
RETURN CODE.NewLabel()
END NewLabel;
INC(reccount);
recarray[reccount] := base
END AddRec;
 
 
PROCEDURE GetRegA;
PROCEDURE CmpOpt(inv: BOOLEAN): INTEGER;
VAR cur: ASMLINE; c: INTEGER;
BEGIN
ASSERT(REG.GetReg(R, eax))
END GetRegA;
c := ORD(Code[current.Prev.Prev(ASMLINE).cmd]);
IF inv THEN
IF ODD(c) THEN
DEC(c)
ELSE
INC(c)
END
END;
cur := current;
REPEAT
cur.tcmd := 0;
cur.clen := 0;
cur := cur.Prev(ASMLINE)
UNTIL cur.tcmd = ICMP1;
cur.tcmd := 0;
cur.clen := 0
RETURN c - 16
END CmpOpt;
 
 
PROCEDURE translate (code: CODE.CODES; pic: BOOLEAN; stroffs: INTEGER);
VAR
cmd: COMMAND;
 
reg1, reg2: INTEGER;
 
n, a, b, label, cc: INTEGER;
 
param1, param2: INTEGER;
 
float: REAL;
 
PROCEDURE ifwh*(L: INTEGER);
VAR c: INTEGER;
BEGIN
cmd := code.commands.first(COMMAND);
 
WHILE cmd # NIL DO
 
param1 := cmd.param1;
param2 := cmd.param2;
 
CASE cmd.opcode OF
 
|CODE.opJMP:
jmp(param1)
 
|CODE.opCALL:
call(param1)
 
|CODE.opCALLI:
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICIMP, param1);
OutByte2(0FFH, 010H + reg1); // call dword[reg1]
drop
IF current.Prev(ASMLINE).tcmd = ICMP2 THEN
c := CmpOpt(TRUE);
OutCode("5A583BC2");
jmp(CHR(c), L)
ELSE
OutByte2(0FFH, 015H); // call dword[L]
Reloc(BIN.RIMP, param1)
PopECX;
OutCode("85C9");
jmp(JE, L)
END
END ifwh;
 
|CODE.opCALLP:
UnOp(reg1);
OutByte2(0FFH, 0D0H + reg1); // call reg1
drop;
ASSERT(R.top = -1)
PROCEDURE PushConst*(Number: INTEGER);
BEGIN
IntByte("6A", "68", Number);
current.Prev(ASMLINE).varadr := Number
END PushConst;
 
|CODE.opPRECALL:
n := param2;
IF (param1 # 0) & (n # 0) THEN
subrc(esp, 8)
PROCEDURE IfWhile*(L: INTEGER; orop: BOOLEAN);
VAR c, L1: INTEGER;
BEGIN
L1 := NewLabel();
IF current.Prev(ASMLINE).tcmd = ICMP2 THEN
c := CmpOpt(orop);
OutCode("5A583BC2");
jmp(CHR(c), L1);
PushConst(ORD(orop))
ELSE
PopECX;
OutCode("85C9");
IF orop THEN
jmp(JE, L1)
ELSE
jmp(JNE, L1)
END;
WHILE n > 0 DO
subrc(esp, 8);
OutByte3(0DDH, 01CH, 024H); // fstp qword[esp]
DEC(n)
PushECX
END;
PushAll(0)
jmp(JMP, L);
Label(L1)
END IfWhile;
 
|CODE.opALIGN16:
ASSERT(eax IN R.regs);
mov(eax, esp);
andrc(esp, -16);
n := (3 - param2 MOD 4) * 4;
IF n > 0 THEN
subrc(esp, n)
END;
push(eax)
PROCEDURE newrec*;
BEGIN
CallRTL(_newrec)
END newrec;
 
|CODE.opRES:
ASSERT(R.top = -1);
GetRegA;
n := param2;
WHILE n > 0 DO
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
addrc(esp, 8);
DEC(n)
PROCEDURE disprec*;
BEGIN
CallRTL(_disprec)
END disprec;
 
PROCEDURE String*(Number, Len: INTEGER; str: UTILS.STRING);
BEGIN
Labels[Number] := -dcount;
IF Len > 1 THEN
datastr(str)
ELSIF Len = 1 THEN
dataint(ORD(str[0]))
ELSE
dataint(0)
END
END String;
 
|CODE.opRESF:
n := param2;
IF n > 0 THEN
OutByte3(0DDH, 5CH + long(n * 8), 24H);
OutIntByte(n * 8); // fstp qword[esp + n*8]
INC(n)
PROCEDURE InsertFpuInit;
VAR t: ASMLINE;
BEGIN
IF isfpu THEN
t := current;
current := fpucmd;
IF maxfpu > 0 THEN
OutCode("83EC");
OutByte(maxfpu * 8)
END;
 
WHILE n > 0 DO
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
addrc(esp, 8);
DEC(n)
OutCode("DBE3");
current := t
END
END InsertFpuInit;
 
|CODE.opENTER:
ASSERT(R.top = -1);
 
SetLabel(param1);
 
push(ebp);
mov(ebp, esp);
 
n := param2;
IF n > 4 THEN
movrc(ecx, n);
pushc(0); // @@: push 0
OutByte2(0E2H, 0FCH) // loop @b
PROCEDURE ProcBeg*(Number, Local: INTEGER; Module: BOOLEAN);
VAR i: INTEGER;
BEGIN
IF Module THEN
OutCode("EB0C");
Label(Number + 3);
PushInt(Number + 2);
jmplong(JMP, HALT);
Label(Number + 1)
ELSE
WHILE n > 0 DO
pushc(0);
DEC(n)
Label(Number)
END;
OutCode("558BEC");
IF Local > 12 THEN
IntByte("83EC", "81EC", Local);
OutCode("8BD733C08BFCB9");
OutInt(ASR(Local, 2));
OutCode("9CFCF3AB8BFA9D")
ELSE
FOR i := 4 TO Local BY 4 DO
OutCode("6A00")
END
END
 
|CODE.opLEAVE, CODE.opLEAVER, CODE.opLEAVEF:
IF cmd.opcode = CODE.opLEAVER THEN
UnOp(reg1);
IF reg1 # eax THEN
GetRegA;
ASSERT(REG.Exchange(R, reg1, eax));
drop
END;
drop
END;
fpucmd := current;
fpu := 0;
maxfpu := 0;
isfpu := FALSE
END ProcBeg;
 
ASSERT(R.top = -1);
PROCEDURE Leave*;
BEGIN
OutByte(0C9H);
InsertFpuInit
END Leave;
 
mov(esp, ebp);
pop(ebp);
 
n := param2;
IF n > 0 THEN
n := n * 4;
OutByte(0C2H); OutWord(Word(n)) // ret n
PROCEDURE ProcEnd*(Number, Param: INTEGER; func, float: BOOLEAN);
BEGIN
IF func & ~float THEN
PopEAX
END;
OutByte(0C9H);
IF Param = 0 THEN
OutByte(0C3H)
ELSE
OutByte(0C3H) // ret
END
OutByte(0C2H);
OutByte(Param MOD 256);
OutByte(ASR(Param, 8))
END;
InsertFpuInit
END ProcEnd;
 
|CODE.opERRC:
pushc(param2)
PROCEDURE Module*(Name: UTILS.STRING; Number: INTEGER);
BEGIN
String(Number + 2, LENGTH(Name), Name);
jmplong(JMP, Number + 1)
END Module;
 
|CODE.opPARAM:
n := param2;
IF n = 1 THEN
UnOp(reg1);
push(reg1);
drop
ELSE
ASSERT(R.top + 1 <= n);
PushAll(n)
END
PROCEDURE Asm*(s: UTILS.STRING);
BEGIN
OutCode(s)
END Asm;
 
|CODE.opCLEANUP:
n := param2 * 4;
IF n # 0 THEN
addrc(esp, n)
END
PROCEDURE GlobalAdr*(offset: INTEGER);
BEGIN
OutByte(0BAH);
OutInt(offset);
current.codeadr := sys.ADR(Code[ccount - 4]);
current.tcmd := GCMD;
PushEDX
END GlobalAdr;
 
|CODE.opPOPSP:
pop(esp)
PROCEDURE Mono*(Number: INTEGER);
BEGIN
PopEDX;
PushInt(Number)
END Mono;
 
|CODE.opCONST:
reg1 := REG.GetAnyReg(R);
movrc(reg1, param2)
PROCEDURE StrMono*;
BEGIN
PopEDX;
OutCode("6A02");
PushEDX
END StrMono;
 
|CODE.opLABEL:
SetLabel(param2) // L:
PROCEDURE Not*;
BEGIN
PopECX;
OutCode("85C90F94C1");
PushECX
END Not;
 
|CODE.opNOP:
PROCEDURE NegSet*;
BEGIN
OutCode("F71424")
END NegSet;
 
|CODE.opGADR:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICBSS, param2)
PROCEDURE Int*(Op: INTEGER);
BEGIN
PopEDX;
CASE Op OF
|lxPlus: OutCode("011424")
|lxMinus: OutCode("291424")
|lxMult: OutCode("58F7EA"); PushEAX
ELSE
OutByte(0B8H + reg1); // mov reg1, _bss + param2
Reloc(BIN.RBSS, param2)
END
END Int;
 
|CODE.opLADR:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8DH, 45H + reg1 * 8 + long(n)); // lea reg1, dword[ebp + n]
OutIntByte(n)
PROCEDURE Set*(Op: INTEGER);
BEGIN
PopEDX;
OutByte(58H);
CASE Op OF
|lxPlus: OutByte(0BH)
|lxMinus: OutCode("F7D223")
|lxMult: OutByte(23H)
|lxSlash: OutByte(33H)
ELSE
END;
OutByte(0C2H);
PushEAX
END Set;
 
|CODE.opVADR:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n)
PROCEDURE Setfpu*(newfpu: INTEGER);
BEGIN
fpu := newfpu
END Setfpu;
 
|CODE.opSADR:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICDATA, stroffs + param2);
PROCEDURE PushFlt*(x: LONGREAL);
VAR f: TFLT; L: INTEGER;
BEGIN
sys.PUT(sys.ADR(f), x);
Incfpu;
IF x = 0.0D0 THEN
OutCode("D9EE")
ELSIF x = 1.0D0 THEN
OutCode("D9E8")
ELSE
OutByte(0B8H + reg1); // mov reg1, _data + stroffs + param2
Reloc(BIN.RDATA, stroffs + param2)
L := NewLabel();
Labels[L] := -dcount;
dataint(f[0]);
dataint(f[1]);
OutByte(0BAH);
CmdN(L);
OutCode("DD02")
END
END PushFlt;
 
|CODE.opSAVEC:
UnOp(reg1);
OutByte2(0C7H, reg1); OutInt(param2); // mov dword[reg1], param2
drop
 
|CODE.opSAVE8C:
UnOp(reg1);
OutByte3(0C6H, reg1, Byte(param2)); // mov byte[reg1], param2
drop
 
|CODE.opSAVE16C:
UnOp(reg1);
OutByte3(66H, 0C7H, reg1); OutWord(Word(param2)); // mov word[reg1], param2
drop
 
|CODE.opVLOAD32:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n);
OutByte2(8BH, reg1 * 9) // mov reg1, dword[reg1]
 
|CODE.opGLOAD32:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
OutByte2(8BH, reg1 * 9) // mov reg1, dword[reg1]
PROCEDURE farith*(op: INTEGER);
VAR n: INTEGER;
BEGIN
OutByte(0DEH);
CASE op OF
|lxPlus: n := 0C1H
|lxMinus: n := 0E9H
|lxMult: n := 0C9H
|lxSlash: n := 0F9H
ELSE
OutByte2(08BH, 05H + reg1 * 8); // mov reg1, dword[_bss + param2]
Reloc(BIN.RBSS, param2)
END
END;
OutByte(n);
DEC(fpu)
END farith;
 
|CODE.opLLOAD32:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n)
 
|CODE.opLOAD32:
UnOp(reg1);
OutByte2(8BH, reg1 * 9) // mov reg1, dword[reg1]
 
|CODE.opVLOAD8:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n);
OutByte3(0FH, 0B6H, reg1 * 9) // movzx reg1, byte[reg1]
 
|CODE.opGLOAD8:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
OutByte3(0FH, 0B6H, reg1 * 9) // movzx reg1, byte[reg1]
PROCEDURE fcmp*(Op: INTEGER);
VAR n: INTEGER;
BEGIN
OutCode("33C9DED9DFE09E0F");
CASE Op OF
|lxEQ: n := 94H
|lxNE: n := 95H
|lxLT: n := 97H
|lxGT: n := 92H
|lxLE: n := 93H
|lxGE: n := 96H
ELSE
OutByte3(00FH, 0B6H, 05H + reg1 * 8); // movzx reg1, byte[_bss + param2]
Reloc(BIN.RBSS, param2)
END
END;
DEC(fpu, 2);
OutByte(n);
OutByte(0C1H);
PushECX
END fcmp;
 
|CODE.opLLOAD8:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte3(0FH, 0B6H, 45H + reg1 * 8 + long(n)); // movzx reg1, byte[ebp + n]
OutIntByte(n)
PROCEDURE fneg*;
BEGIN
OutCode("D9E0")
END fneg;
 
|CODE.opLOAD8:
UnOp(reg1);
OutByte3(0FH, 0B6H, reg1 * 9) // movzx reg1, byte[reg1]
PROCEDURE OnError*(n: INTEGER);
BEGIN
OutByte(68H);
OutInt(LSL(UTILS.Line, 4) + n);
jmplong(JMP, UTILS.Unit + 3)
END OnError;
 
|CODE.opVLOAD16:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n]
OutIntByte(n);
OutByte3(0FH, 0B7H, reg1 * 9) // movzx reg1, word[reg1]
 
|CODE.opGLOAD16:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICBSS, param2);
OutByte3(0FH, 0B7H, reg1 * 9) // movzx reg1, word[reg1]
PROCEDURE idivmod*(opmod: BOOLEAN);
BEGIN
PopECX;
IF opmod THEN
OutCode("58E32E538BD833D9C1FB1F8BD0C1FA1F83F9FF750C3D0000008075055B6A00EB1AF7F985DB740685D2740203D15B52EB0A")
ELSE
OutByte3(00FH, 0B7H, 05H + reg1 * 8); // movzx reg1, word[_bss + param2]
Reloc(BIN.RBSS, param2)
END
OutCode("58E32C538BD833D9C1FB1F8BD0C1FA1F83F9FF750B3D0000008075045B50EB19F7F985DB740585D27401485B50EB0A")
END;
OnError(8)
END idivmod;
 
|CODE.opLLOAD16:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte3(0FH, 0B7H, 45H + reg1 * 8 + long(n)); // movzx reg1, word[ebp + n]
OutIntByte(n)
PROCEDURE rset*;
BEGIN
CallRTL(_rset);
PushEAX
END rset;
 
|CODE.opLOAD16:
UnOp(reg1);
OutByte3(0FH, 0B7H, reg1 * 9) // movzx reg1, word[reg1]
PROCEDURE inset*;
BEGIN
CallRTL(_inset);
PushEAX
END inset;
 
|CODE.opUMINUS:
UnOp(reg1);
neg(reg1)
PROCEDURE Dup*;
BEGIN
PopEDX;
PushEDX;
PushEDX
END Dup;
 
|CODE.opADD:
BinOp(reg1, reg2);
add(reg1, reg2);
drop
 
|CODE.opADDL, CODE.opADDR:
IF param2 # 0 THEN
UnOp(reg1);
IF param2 = 1 THEN
OutByte(40H + reg1) // inc reg1
ELSIF param2 = -1 THEN
OutByte(48H + reg1) // dec reg1
PROCEDURE Inclusion*(Op: INTEGER);
BEGIN
PopEDX;
PopEAX;
IF Op = lxLE THEN
PushEDX
ELSE
addrc(reg1, param2)
END
END
 
|CODE.opSUB:
BinOp(reg1, reg2);
OutByte2(29H, 0C0H + reg2 * 8 + reg1); // sub reg1, reg2
drop
 
|CODE.opSUBR, CODE.opSUBL:
UnOp(reg1);
n := param2;
IF n = 1 THEN
OutByte(48H + reg1) // dec reg1
ELSIF n = -1 THEN
OutByte(40H + reg1) // inc reg1
ELSIF n # 0 THEN
subrc(reg1, n)
PushEAX
END;
IF cmd.opcode = CODE.opSUBL THEN
neg(reg1)
END
OutCode("0BC25933C8E3046A00EB026A01")
END Inclusion;
 
|CODE.opMULC:
UnOp(reg1);
PROCEDURE NegInt*;
BEGIN
OutCode("F71C24")
END NegInt;
 
a := param2;
IF a > 1 THEN
n := log2(a)
ELSIF a < -1 THEN
n := log2(-a)
PROCEDURE CmpInt*(Op: INTEGER);
VAR n: INTEGER;
BEGIN
OutCode("33C95A583BC20F"); current.tcmd := ICMP1;
CASE Op OF
|lxEQ: n := 94H
|lxNE: n := 95H
|lxLT: n := 9CH
|lxGT: n := 9FH
|lxLE: n := 9EH
|lxGE: n := 9DH
ELSE
n := -1
END;
OutByte(n);
OutByte(0C1H); current.tcmd := ICMP2;
PushECX;
END CmpInt;
 
IF a = 1 THEN
PROCEDURE CallVar*(func, float: BOOLEAN; callconv, parsize, local: INTEGER);
BEGIN
PopEDX;
OutCode("8B1285D2750A");
OnError(2);
FpuSave(local);
OutCode("FFD2");
AfterRet(func, float, callconv, parsize);
FpuLoad(local, func & float)
END CallVar;
 
ELSIF a = -1 THEN
neg(reg1)
ELSIF a = 0 THEN
OutByte2(31H, 0C0H + reg1 * 9) // xor reg1, reg1
PROCEDURE LocalAdr*(offset, bases: INTEGER);
BEGIN
IF bases = 0 THEN
Empty(offset);
OutCode("8BD5")
ELSE
IF n > 0 THEN
IF a < 0 THEN
neg(reg1)
IntByte("8B55", "8B95", 4 * bases + 4)
END;
IntByte("83C2", "81C2", offset);
PushEDX;
IF bases = 0 THEN
Empty(offset)
END
END LocalAdr;
 
IF n # 1 THEN
OutByte3(0C1H, 0E0H + reg1, n) // shl reg1, n
ELSE
OutByte2(0D1H, 0E0H + reg1) // shl reg1, 1
PROCEDURE Field*(offset: INTEGER);
BEGIN
IF offset # 0 THEN
IntByte("830424", "810424", offset)
END
ELSE
OutByte2(69H + short(a), 0C0H + reg1 * 9); // imul reg1, a
OutIntByte(a)
END
END
END Field;
 
|CODE.opMUL:
BinOp(reg1, reg2);
OutByte3(0FH, 0AFH, 0C0H + reg1 * 8 + reg2); // imul reg1, reg2
drop
PROCEDURE DerefType*(n: INTEGER);
BEGIN
IntByte("8B5424", "8B9424", n);
OutCode("FF72FC")
END DerefType;
 
|CODE.opSAVE, CODE.opSAVE32:
BinOp(reg2, reg1);
OutByte2(89H, reg2 * 8 + reg1); // mov dword[reg1], reg2
drop;
drop
 
|CODE.opSAVE8:
BinOp(reg2, reg1);
OutByte2(88H, reg2 * 8 + reg1); // mov byte[reg1], reg2
drop;
drop
 
|CODE.opSAVE16:
BinOp(reg2, reg1);
OutByte3(66H, 89H, reg2 * 8 + reg1); // mov word[reg1], reg2
drop;
drop
 
|CODE.opSAVEP:
UnOp(reg1);
IF pic THEN
reg2 := REG.GetAnyReg(R);
Pic(reg2, BIN.PICCODE, param2);
OutByte2(089H, reg2 * 8 + reg1); // mov dword[reg1], reg2
drop
PROCEDURE Guard*(T: INTEGER; Check: BOOLEAN);
BEGIN
IF Check THEN
PopEAX;
OutCode("85C074");
IF T <= 127 THEN
OutByte(9)
ELSE
OutByte2(0C7H, reg1); // mov dword[reg1], L
Reloc(BIN.RCODE, param2)
OutByte(12)
END;
drop
 
|CODE.opSAVEIP:
UnOp(reg1);
IF pic THEN
reg2 := REG.GetAnyReg(R);
Pic(reg2, BIN.PICIMP, param2);
OutByte2(0FFH, 30H + reg2); // push dword[reg2]
OutByte2(08FH, reg1); // pop dword[reg1]
drop
ELSE
OutByte2(0FFH, 035H); // push dword[L]
Reloc(BIN.RIMP, param2);
OutByte2(08FH, reg1) // pop dword[reg1]
PushEAX
END;
drop
 
|CODE.opPUSHP:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICCODE, param2)
PushConst(T);
PushEAX;
CallRTL(_checktype);
IF Check THEN
PushEAX
ELSE
OutByte(0B8H + reg1); // mov reg1, L
Reloc(BIN.RCODE, param2)
OutCode("85C0750A");
OnError(3)
END
END Guard;
 
|CODE.opPUSHIP:
reg1 := REG.GetAnyReg(R);
IF pic THEN
Pic(reg1, BIN.PICIMP, param2);
OutByte2(08BH, reg1 * 9) // mov reg1, dword[reg1]
PROCEDURE StProc*(proc: INTEGER);
BEGIN
CASE proc OF
|stINC: PopEDX; OutCode("590111")
|stDEC: PopEDX; OutCode("592911")
|stINC1: PopEDX; OutCode("FF02")
|stDEC1: PopEDX; OutCode("FF0A")
|stINCL: PopEDX; OutCode("580910")
|stEXCL: PopEDX; OutCode("582110")
|stPACK: OutCode("DB04245A5ADD02D9FDDD1A"); isfpu := TRUE
|stPACK1: OutCode("DB04245A5AD902D9FDD91A"); isfpu := TRUE
|stUNPK: PopEDX; OutCode("59DD01D9F4DD19DB1A"); isfpu := TRUE
|stUNPK1: PopEDX; OutCode("59D901D9F4D919DB1A"); isfpu := TRUE
|stCOPY: CallRTL(_strcopy)
|sysMOVE: CallRTL(_savearr)
ELSE
OutByte2(08BH, 05H + reg1 * 8); // mov reg1, dword[L]
Reloc(BIN.RIMP, param2)
END
END StProc;
 
|CODE.opNOT:
UnOp(reg1);
test(reg1);
setcc(sete, reg1);
andrc(reg1, 1)
 
|CODE.opORD:
UnOp(reg1);
test(reg1);
setcc(setne, reg1);
andrc(reg1, 1)
 
|CODE.opSBOOL:
BinOp(reg2, reg1);
test(reg2);
setcc(setne, reg2);
OutByte2(88H, reg2 * 8 + reg1); // mov byte[reg1], reg2
drop;
drop
 
|CODE.opSBOOLC:
UnOp(reg1);
OutByte3(0C6H, reg1, ORD(param2 # 0)); // mov byte[reg1], 0/1
drop
 
|CODE.opODD:
UnOp(reg1);
andrc(reg1, 1)
 
|CODE.opGTR, CODE.opLTL, CODE.opGER, CODE.opLEL,
CODE.opLER, CODE.opGEL, CODE.opLTR, CODE.opGTL,
CODE.opEQR, CODE.opEQL, CODE.opNER, CODE.opNEL:
UnOp(reg1);
IF param2 = 0 THEN
test(reg1)
PROCEDURE Assert*(proc, assrt: INTEGER);
BEGIN
PopEDX;
OutCode("85D2751368");
OutInt(UTILS.Line * 16 + 1);
PushInt(UTILS.Unit + 2);
IF proc = stASSERT THEN
OutCode("6A026A")
ELSE
cmprc(reg1, param2)
OutCode("6A016A")
END;
drop;
cc := cond(cmd.opcode);
OutByte(assrt);
jmplong(JMP, ASSRT)
END Assert;
 
IF cmd.next(COMMAND).opcode = CODE.opJE THEN
label := cmd.next(COMMAND).param1;
jcc(cc, label);
cmd := cmd.next(COMMAND)
PROCEDURE StFunc*(func: INTEGER);
BEGIN
CASE func OF
|stABS: PopEDX; OutCode("85D27D02F7DA"); PushEDX
|stFABS: OutCode("D9E1")
|stFLT: OutCode("DB0424"); PopEAX; Incfpu;
|stFLOOR: jmplong(CALL, _floor); PushEAX; DEC(fpu)
|stODD: OutCode("83242401")
|stROR: PopECX; OutCode("58D3C8"); PushEAX
|stASR: PopECX; OutCode("58D3F8"); PushEAX
|stLSL: PopECX; OutCode("58D3E0"); PushEAX
|stLSR: PopECX; OutCode("58D3E8"); PushEAX
|stORD: PopEDX; OutCode("85D274036A015A"); PushEDX;
|stMIN: PopEDX; OutCode("3914247E025852");
|stMAX: PopEDX; OutCode("3B14247E025852");
|stLENGTH: CallRTL(_length); PushEAX
ELSE
END
END StFunc;
 
ELSIF cmd.next(COMMAND).opcode = CODE.opJNE THEN
label := cmd.next(COMMAND).param1;
jcc(inv1(cc), label);
cmd := cmd.next(COMMAND)
PROCEDURE Load*(T: INTEGER);
VAR lastcmd: ASMLINE; offset: INTEGER;
 
ELSE
reg1 := REG.GetAnyReg(R);
setcc(cc + 16, reg1);
andrc(reg1, 1)
PROCEDURE del;
BEGIN
lastcmd.tcmd := 0;
offset := lastcmd.varadr;
lastcmd := lastcmd.Prev(ASMLINE);
WHILE lastcmd.tcmd # ECMD DO
lastcmd.clen := 0;
lastcmd.tcmd := 0;
lastcmd := lastcmd.Prev(ASMLINE)
END;
lastcmd.tcmd := 0
END del;
 
|CODE.opGT, CODE.opGE, CODE.opLT,
CODE.opLE, CODE.opEQ, CODE.opNE:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
drop;
drop;
cc := cond(cmd.opcode);
 
IF cmd.next(COMMAND).opcode = CODE.opJE THEN
label := cmd.next(COMMAND).param1;
jcc(cc, label);
cmd := cmd.next(COMMAND)
 
ELSIF cmd.next(COMMAND).opcode = CODE.opJNE THEN
label := cmd.next(COMMAND).param1;
jcc(inv1(cc), label);
cmd := cmd.next(COMMAND)
 
BEGIN
lastcmd := current;
CASE T OF
|TINTEGER, TSET, TPOINTER, TPROC:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("8B55", "8B95", offset);
PushEDX
ELSE
reg1 := REG.GetAnyReg(R);
setcc(cc + 16, reg1);
andrc(reg1, 1)
PopEDX;
OutCode("FF32")
END
 
|CODE.opEQB, CODE.opNEB:
BinOp(reg1, reg2);
drop;
drop;
 
test(reg1);
OutByte2(74H, 5); // je @f
movrc(reg1, 1); // mov reg1, 1
// @@:
test(reg2);
OutByte2(74H, 5); // je @f
movrc(reg2, 1); // mov reg2, 1
// @@:
 
cmprr(reg1, reg2);
reg1 := REG.GetAnyReg(R);
IF cmd.opcode = CODE.opEQB THEN
setcc(sete, reg1)
|TCHAR, TBOOLEAN:
IF lastcmd.tcmd = ECMD THEN
del;
OutCode("0FB6");
IntByte("55", "95", offset);
PushEDX
ELSE
setcc(setne, reg1)
PopEDX;
OutCode("0FB60A");
PushECX
END
|TLONGREAL:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("DD45", "DD85", offset)
ELSE
PopEDX;
OutCode("DD02")
END;
andrc(reg1, 1)
 
|CODE.opDROP:
UnOp(reg1);
drop
 
|CODE.opJNZ:
UnOp(reg1);
test(reg1);
jcc(jne, param1)
 
|CODE.opJZ:
UnOp(reg1);
test(reg1);
jcc(je, param1)
 
|CODE.opJE:
UnOp(reg1);
test(reg1);
jcc(jne, param1);
drop;
 
|CODE.opJNE:
UnOp(reg1);
test(reg1);
jcc(je, param1);
drop;
 
|CODE.opSWITCH:
UnOp(reg1);
IF param2 = 0 THEN
reg2 := eax
Incfpu
|TREAL:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("D945", "D985", offset)
ELSE
reg2 := ecx
PopEDX;
OutCode("D902")
END;
IF reg1 # reg2 THEN
ASSERT(REG.GetReg(R, reg2));
ASSERT(REG.Exchange(R, reg1, reg2));
drop
END;
drop
 
|CODE.opENDSW:
 
|CODE.opCASEL:
cmprc(eax, param1);
jcc(jl, param2)
 
|CODE.opCASER:
cmprc(eax, param1);
jcc(jg, param2)
 
|CODE.opCASELR:
cmprc(eax, param1);
jcc(jl, param2);
jcc(jg, cmd.param3)
 
|CODE.opCODE:
OutByte(param2)
 
|CODE.opGET:
BinOp(reg1, reg2);
drop;
drop;
 
CASE param2 OF
|1:
OutByte2(8AH, reg1 * 9); // mov reg1, byte[reg1]
OutByte2(88H, reg1 * 8 + reg2) // mov byte[reg2], reg1
 
|2:
OutByte3(66H, 8BH, reg1 * 9); // mov reg1, word[reg1]
OutByte3(66H, 89H, reg1 * 8 + reg2) // mov word[reg2], reg1
 
|4:
OutByte2(8BH, reg1 * 9); // mov reg1, dword[reg1]
OutByte2(89H, reg1 * 8 + reg2) // mov dword[reg2], reg1
 
|8:
PushAll(0);
push(reg2);
push(reg1);
pushc(8);
CallRTL(pic, CODE._move)
 
Incfpu
|TCARD16:
IF lastcmd.tcmd = ECMD THEN
del;
OutCode("33D2668B");
IntByte("55", "95", offset);
PushEDX
ELSE
PopEDX;
OutCode("33C9668B0A");
PushECX
END
 
|CODE.opSAVES:
UnOp(reg1);
drop;
PushAll(0);
push(reg1);
 
IF pic THEN
Pic(reg1, BIN.PICDATA, stroffs + param2);
push(reg1)
ELSE
OutByte(068H); // push _data + stroffs + param2
Reloc(BIN.RDATA, stroffs + param2);
END;
END
END Load;
 
pushc(param1);
CallRTL(pic, CODE._move)
 
|CODE.opCHKBYTE:
BinOp(reg1, reg2);
cmprc(reg1, 256);
jcc(jb, param1)
 
|CODE.opCHKIDX:
UnOp(reg1);
cmprc(reg1, param2);
jcc(jb, param1)
 
|CODE.opCHKIDX2:
BinOp(reg1, reg2);
IF param2 # -1 THEN
cmprr(reg2, reg1);
mov(reg1, reg2);
drop;
jcc(jb, param1)
PROCEDURE Save*(T: INTEGER);
BEGIN
CASE T OF
|TINTEGER, TSET, TPOINTER, TPROC:
PopEDX;
OutCode("588910")
|TCHAR, TSTRING, TBOOLEAN:
PopEDX;
OutCode("588810")
|TCARD16:
PopEDX;
OutCode("58668910")
|TLONGREAL:
PopEDX;
OutCode("DD1A");
DEC(fpu)
|TREAL:
PopEDX;
OutCode("D91A");
DEC(fpu)
|TRECORD:
CallRTL(_saverec);
OutCode("85C0750A");
OnError(4)
|TARRAY:
CallRTL(_savearr)
ELSE
INCL(R.regs, reg1);
DEC(R.top);
R.stk[R.top] := reg2
END
END Save;
 
|CODE.opLEN:
n := param2;
UnOp(reg1);
drop;
EXCL(R.regs, reg1);
 
WHILE n > 0 DO
UnOp(reg2);
drop;
DEC(n)
PROCEDURE OpenArray*(A: TIDX; n: INTEGER);
VAR i: INTEGER;
BEGIN
PopEDX;
FOR i := n - 1 TO 0 BY -1 DO
PushConst(A[i])
END;
PushEDX
END OpenArray;
 
INCL(R.regs, reg1);
ASSERT(REG.GetReg(R, reg1))
 
|CODE.opINC1:
UnOp(reg1);
OutByte2(0FFH, reg1); // inc dword[reg1]
drop
 
|CODE.opDEC1:
UnOp(reg1);
OutByte2(0FFH, 8 + reg1); // dec dword[reg1]
drop
 
|CODE.opINCC:
UnOp(reg1);
n := param2;
OutByte2(81H + short(n), reg1); OutIntByte(n); // add dword[reg1], n
drop
 
|CODE.opDECC:
UnOp(reg1);
n := param2;
OutByte2(81H + short(n), 28H + reg1); OutIntByte(n); // sub dword[reg1], n
drop
 
|CODE.opINC:
BinOp(reg1, reg2);
OutByte2(01H, reg1 * 8 + reg2); // add dword[reg2], reg1
drop;
drop
 
|CODE.opDEC:
BinOp(reg1, reg2);
OutByte2(29H, reg1 * 8 + reg2); // sub dword[reg2], reg1
drop;
drop
 
|CODE.opINC1B:
UnOp(reg1);
OutByte2(0FEH, reg1); // inc byte[reg1]
drop
 
|CODE.opDEC1B:
UnOp(reg1);
OutByte2(0FEH, 08H + reg1); // dec byte[reg1]
drop
 
|CODE.opINCCB:
UnOp(reg1);
OutByte3(80H, reg1, Byte(param2)); // add byte[reg1], n
drop
 
|CODE.opDECCB:
UnOp(reg1);
OutByte3(80H, 28H + reg1, Byte(param2)); // sub byte[reg1], n
drop
 
|CODE.opINCB, CODE.opDECB:
BinOp(reg1, reg2);
IF cmd.opcode = CODE.opINCB THEN
OutByte2(00H, reg1 * 8 + reg2) // add byte[reg2], reg1
PROCEDURE OpenIdx*(n: INTEGER);
BEGIN
OutByte(54H);
IF n > 1 THEN
PushConst(n);
CallRTL(_arrayidx)
ELSE
OutByte2(28H, reg1 * 8 + reg2) // sub byte[reg2], reg1
CallRTL(_arrayidx1)
END;
drop;
drop
PopEDX;
OutCode("85D2750A");
OnError(5);
PushEDX;
END OpenIdx;
 
|CODE.opMULS:
BinOp(reg1, reg2);
OutByte2(21H, 0C0H + reg2 * 8 + reg1); // and reg1, reg2
drop
PROCEDURE FixIdx*(len, size: INTEGER);
BEGIN
PopEDX;
IntByte("5983FA", "5981FA", len);
OutCode("720A");
OnError(5);
IF size > 1 THEN
IntByte("6BD2", "69D2", size)
END;
OutCode("03D1");
PushEDX
END FixIdx;
 
|CODE.opMULSC:
UnOp(reg1);
andrc(reg1, param2)
PROCEDURE Idx*;
BEGIN
PopEDX;
PopECX;
OutCode("03D1");
PushEDX
END Idx;
 
|CODE.opDIVS:
BinOp(reg1, reg2);
OutByte2(31H, 0C0H + reg2 * 8 + reg1); // xor reg1, reg2
drop
PROCEDURE DupLoadCheck*;
BEGIN
PopEDX;
OutCode("528B125285D2750A");
OnError(6)
END DupLoadCheck;
 
|CODE.opDIVSC:
UnOp(reg1);
OutByte2(81H + short(param2), 0F0H + reg1); // xor reg1, n
OutIntByte(param2)
PROCEDURE DupLoad*;
BEGIN
PopEDX;
OutCode("528B12");
PushEDX;
END DupLoad;
 
|CODE.opADDS:
BinOp(reg1, reg2);
OutByte2(9H, 0C0H + reg2 * 8 + reg1); // or reg1, reg2
drop
PROCEDURE CheckNIL*;
BEGIN
PopEDX;
OutCode("85D2750A");
OnError(6);
PushEDX;
END CheckNIL;
 
|CODE.opSUBS:
BinOp(reg1, reg2);
not(reg2);
OutByte2(21H, 0C0H + reg2 * 8 + reg1); // and reg1, reg2
drop
 
|CODE.opADDSL, CODE.opADDSR:
UnOp(reg1);
orrc(reg1, param2)
 
|CODE.opSUBSL:
UnOp(reg1);
not(reg1);
andrc(reg1, param2)
 
|CODE.opSUBSR:
UnOp(reg1);
andrc(reg1, ORD(-BITS(param2)));
 
|CODE.opUMINS:
UnOp(reg1);
not(reg1)
 
|CODE.opLENGTH:
PushAll(2);
CallRTL(pic, CODE._length);
GetRegA
 
|CODE.opLENGTHW:
PushAll(2);
CallRTL(pic, CODE._lengthw);
GetRegA
 
|CODE.opCHR:
UnOp(reg1);
andrc(reg1, 255)
 
|CODE.opWCHR:
UnOp(reg1);
andrc(reg1, 65535)
 
|CODE.opASR, CODE.opROR, CODE.opLSL, CODE.opLSR:
UnOp(reg1);
IF reg1 # ecx THEN
ASSERT(REG.GetReg(R, ecx));
ASSERT(REG.Exchange(R, reg1, ecx));
drop
PROCEDURE ExtArray*(A: TIDX; n, m: INTEGER);
VAR i: INTEGER;
BEGIN
FOR i := n - 1 TO 0 BY -1 DO
PushConst(A[i])
END;
OutByte(54H);
PushConst(n);
PushConst(m);
CallRTL(_arrayrot)
END ExtArray;
 
BinOp(reg1, reg2);
ASSERT(reg2 = ecx);
OutByte(0D3H);
shift(cmd.opcode, reg1); // shift reg1, cl
drop
PROCEDURE ADR*(dim: INTEGER);
BEGIN
IF dim > 0 THEN
PopEDX;
OutCode("83C4");
OutByte(dim * 4);
PushEDX
END
END ADR;
 
|CODE.opASR1, CODE.opROR1, CODE.opLSL1, CODE.opLSR1:
UnOp(reg1);
IF reg1 # ecx THEN
ASSERT(REG.GetReg(R, ecx));
ASSERT(REG.Exchange(R, reg1, ecx));
drop
END;
PROCEDURE Len*(dim: INTEGER);
BEGIN
PopEDX;
IF dim < 0 THEN
PushConst(-dim)
ELSIF dim > 1 THEN
PopEDX;
OutCode("83C4");
OutByte((dim - 1) * 4);
PushEDX
END
END Len;
 
reg1 := REG.GetAnyReg(R);
movrc(reg1, param2);
BinOp(reg1, reg2);
ASSERT(reg1 = ecx);
OutByte(0D3H);
shift(cmd.opcode, reg2); // shift reg2, cl
drop;
drop;
ASSERT(REG.GetReg(R, reg2))
 
|CODE.opASR2, CODE.opROR2, CODE.opLSL2, CODE.opLSR2:
UnOp(reg1);
n := ORD(BITS(param2) * {0..4});
IF n # 1 THEN
OutByte(0C1H)
PROCEDURE For*(inc: BOOLEAN; VAR LBeg, LEnd: INTEGER);
BEGIN
LEnd := NewLabel();
LBeg := NewLabel();
Label(LBeg);
OutCode("8B14248B4424043910");
IF inc THEN
jmp(JG, LEnd)
ELSE
OutByte(0D1H)
END;
shift(cmd.opcode, reg1); // shift reg1, n
IF n # 1 THEN
OutByte(n)
jmp(JL, LEnd)
END
END For;
 
|CODE.opMIN:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(07EH, 002H); // jle @f
mov(reg1, reg2); // mov reg1, reg2
// @@:
drop
 
|CODE.opMAX:
BinOp(reg1, reg2);
cmprr(reg1, reg2);
OutByte2(07DH, 002H); // jge @f
mov(reg1, reg2); // mov reg1, reg2
// @@:
drop
 
|CODE.opMINC:
UnOp(reg1);
cmprc(reg1, param2);
OutByte2(07EH, 005H); // jle @f
movrc(reg1, param2); // mov reg1, param2
// @@:
 
|CODE.opMAXC:
UnOp(reg1);
cmprc(reg1, param2);
OutByte2(07DH, 005H); // jge @f
movrc(reg1, param2); // mov reg1, param2
// @@:
 
|CODE.opIN:
label := NewLabel();
BinOp(reg1, reg2);
cmprc(reg1, 32);
OutByte2(72H, 4); // jb L
OutByte2(31H, 0C0H + reg1 * 9); // xor reg1, reg1
jmp(label);
//L:
OutByte3(0FH, 0A3H, 0C0H + reg2 + 8 * reg1); // bt reg2, reg1
setcc(setc, reg1);
andrc(reg1, 1);
SetLabel(label);
drop
 
|CODE.opINR:
label := NewLabel();
UnOp(reg1);
reg2 := REG.GetAnyReg(R);
cmprc(reg1, 32);
OutByte2(72H, 4); // jb L
OutByte2(31H, 0C0H + reg1 * 9); // xor reg1, reg1
jmp(label);
//L:
movrc(reg2, param2);
OutByte3(0FH, 0A3H, 0C0H + reg2 + 8 * reg1); // bt reg2, reg1
setcc(setc, reg1);
andrc(reg1, 1);
SetLabel(label);
drop
 
|CODE.opINL:
UnOp(reg1);
OutByte3(0FH, 0BAH, 0E0H + reg1); OutByte(param2); // bt reg1, param2
setcc(setc, reg1);
andrc(reg1, 1)
 
|CODE.opRSET:
PushAll(2);
CallRTL(pic, CODE._set);
GetRegA
 
|CODE.opRSETR:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._set);
GetRegA
 
|CODE.opRSETL:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._set2);
GetRegA
 
|CODE.opRSET1:
UnOp(reg1);
PushAll(1);
push(reg1);
CallRTL(pic, CODE._set);
GetRegA
 
|CODE.opINCL, CODE.opEXCL:
BinOp(reg1, reg2);
cmprc(reg1, 32);
OutByte2(73H, 03H); // jnb L
OutByte(0FH);
IF cmd.opcode = CODE.opINCL THEN
OutByte(0ABH) // bts dword[reg2], reg1
PROCEDURE NextFor*(step, LBeg, LEnd: INTEGER);
BEGIN
OutCode("8B542404");
IF step = 1 THEN
OutCode("FF02")
ELSIF step = -1 THEN
OutCode("FF0A")
ELSE
OutByte(0B3H) // btr dword[reg2], reg1
IntByte("8302", "8102", step)
END;
OutByte(reg2 + 8 * reg1);
//L:
drop;
drop
jmp(JMP, LBeg);
Label(LEnd);
OutCode("83C408")
END NextFor;
 
|CODE.opINCLC:
UnOp(reg1);
OutByte3(0FH, 0BAH, 28H + reg1); OutByte(param2); //bts dword[reg1],param2
drop
 
|CODE.opEXCLC:
UnOp(reg1);
OutByte3(0FH, 0BAH, 30H + reg1); OutByte(param2); //btr dword[reg1],param2
drop
 
|CODE.opDIV:
PushAll(2);
CallRTL(pic, CODE._div);
GetRegA
 
|CODE.opDIVR:
a := param2;
IF a > 1 THEN
n := log2(a)
ELSIF a < -1 THEN
n := log2(-a)
PROCEDURE CaseLabel*(a, b, LBeg: INTEGER);
VAR L: INTEGER;
BEGIN
L := NewLabel();
IntByte("83FA", "81FA", a);
IF a = b THEN
jmp(JNE, L)
ELSE
n := -1
jmp(JL, L);
IntByte("83FA", "81FA", b);
jmp(JG, L)
END;
jmp(JMP, LBeg);
Label(L)
END CaseLabel;
 
IF a = 1 THEN
PROCEDURE Drop*;
BEGIN
PopEDX
END Drop;
 
ELSIF a = -1 THEN
UnOp(reg1);
neg(reg1)
PROCEDURE strcmp*(Op, LR: INTEGER);
BEGIN
CASE Op OF
|lxEQ: PushConst(0)
|lxNE: PushConst(1)
|lxLT: PushConst(2)
|lxGT: PushConst(3)
|lxLE: PushConst(4)
|lxGE: PushConst(5)
ELSE
IF n > 0 THEN
UnOp(reg1);
 
IF a < 0 THEN
reg2 := REG.GetAnyReg(R);
mov(reg2, reg1);
IF n # 1 THEN
OutByte3(0C1H, 0F8H + reg1, n) // sar reg1, n
END;
CASE LR OF
|-1: CallRTL(_lstrcmp)
| 0: CallRTL(_strcmp)
| 1: CallRTL(_rstrcmp)
ELSE
OutByte2(0D1H, 0F8H + reg1) // sar reg1, 1
END;
OutByte2(29H, 0C0H + reg2 * 8 + reg1); // sub reg1, reg2
drop
ELSE
IF n # 1 THEN
OutByte3(0C1H, 0F8H + reg1, n) // sar reg1, n
ELSE
OutByte2(0D1H, 0F8H + reg1) // sar reg1, 1
END
END
PushEAX
END strcmp;
 
PROCEDURE Optimization;
VAR cur: ASMLINE; flag: BOOLEAN;
BEGIN
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
flag := FALSE;
CASE cur.tcmd OF
|PUSHEAX:
flag := cur.Next(ASMLINE).tcmd = POPEAX
|PUSHECX:
flag := cur.Next(ASMLINE).tcmd = POPECX
|PUSHEDX:
flag := cur.Next(ASMLINE).tcmd = POPEDX
ELSE
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._div);
GetRegA
END;
IF flag THEN
cur.clen := 0;
cur.tcmd := 0;
cur := cur.Next(ASMLINE);
cur.clen := 0;
cur.tcmd := 0
END;
cur := cur.Next(ASMLINE)
END
END
END Optimization;
 
|CODE.opDIVL:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._div2);
GetRegA
PROCEDURE WriteKOS(FName: ARRAY OF CHAR; stk, size, datasize, gsize: INTEGER; obj: BOOLEAN);
CONST strsize = 2048;
VAR Header: KOSHEADER; F, i, filesize, filebuf, a, sec, adr, size2: INTEGER; cur: ASMLINE;
Coff: COFFHEADER; sym: ARRAY 18 * 4 OF CHAR; FileName: UTILS.STRING;
BEGIN
F := UTILS.CreateF(FName);
IF F <= 0 THEN
Err(1)
END;
OutFilePos := UTILS.GetMem(Align(size, 4) + datasize + 1000H);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
 
|CODE.opMOD:
PushAll(2);
CallRTL(pic, CODE._mod);
GetRegA
IF ~obj THEN
Header.menuet01 := "MENUET01";
Header.ver := 1;
Header.start := sys.SIZE(KOSHEADER) + ORD(kem) * 65536;
Header.size := Align(size, 4) + datasize;
Header.mem := Header.size + stk + gsize + strsize * 2 + 1000H;
Header.sp := Header.size + gsize + stk;// + ORD(kem) * 65536;
Header.param := Header.sp;
Header.path := Header.param + strsize;
 
|CODE.opMODR:
a := param2;
IF a > 1 THEN
n := log2(a)
ELSIF a < -1 THEN
n := log2(-a)
ELSE
n := -1
END;
Write(sys.ADR(Header), sys.SIZE(KOSHEADER));
 
IF ABS(a) = 1 THEN
UnOp(reg1);
OutByte2(31H, 0C0H + reg1 * 9) // xor reg1, reg1
ELSE
IF n > 0 THEN
UnOp(reg1);
andrc(reg1, ABS(a) - 1);
 
IF a < 0 THEN
test(reg1);
OutByte(74H); // je @f
IF isByte(a) THEN
OutByte(3)
ELSE
OutByte(6)
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
addrc(reg1, a)
// @@:
END
Fill(Align(size, 4) - size, 0X);
Write(sys.ADR(Data), datasize);
WriteF(F, filebuf, OutFilePos - filebuf)
 
ELSE
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._mod);
GetRegA
END
END
 
|CODE.opMODL:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._mod2);
GetRegA
size2 := size;
size := Align(size, 4) - sys.SIZE(KOSHEADER);
Coff.Machine := IntToCard16(014CH);
Coff.NumberOfSections := IntToCard16(3);
Coff.TimeDateStamp := UTILS.Date;
Coff.SizeOfOptionalHeader := IntToCard16(0);
Coff.Characteristics := IntToCard16(0184H);
 
|CODE.opERR:
CallRTL(pic, CODE._error)
Coff.text.name := ".flat";
Coff.text.size := 0;
Coff.text.adr := 0;
Coff.text.sizealign := size;
Coff.text.OAPfile := 8CH;
Coff.text.reserved6 := size + datasize + 8CH;
Coff.text.reserved7 := 0;
Coff.text.attrflags := 40300020H;
 
|CODE.opABS:
UnOp(reg1);
test(reg1);
OutByte2(07DH, 002H); // jge @f
neg(reg1); // neg reg1
// @@:
Coff.data.name := ".data";
Coff.data.size := 0;
Coff.data.adr := 0;
Coff.data.sizealign := datasize;
Coff.data.OAPfile := size + 8CH;
Coff.data.reserved6 := 0;
Coff.data.reserved7 := 0;
Coff.data.reserved8 := 0;
Coff.data.attrflags := 0C0300040H;
 
|CODE.opCOPY:
PushAll(2);
pushc(param2);
CallRTL(pic, CODE._move2)
Coff.bss.name := ".bss";
Coff.bss.size := 0;
Coff.bss.adr := 0;
Coff.bss.sizealign := gsize;
Coff.bss.OAPfile := 0;
Coff.bss.reserved6 := 0;
Coff.bss.reserved7 := 0;
Coff.bss.reserved8 := 0;
Coff.bss.attrflags := 0C03000C0H;
 
|CODE.opMOVE:
PushAll(3);
CallRTL(pic, CODE._move2)
 
|CODE.opCOPYA:
PushAll(4);
pushc(param2);
CallRTL(pic, CODE._arrcpy);
GetRegA
 
|CODE.opCOPYS:
PushAll(4);
pushc(param2);
CallRTL(pic, CODE._strcpy)
 
|CODE.opCOPYS2:
PushAll(4);
pushc(param2);
CallRTL(pic, CODE._strcpy2)
 
|CODE.opROT:
PushAll(0);
push(esp);
pushc(param2);
CallRTL(pic, CODE._rot)
 
|CODE.opNEW:
PushAll(1);
n := param2 + 8;
ASSERT(MACHINE.Align(n, 32));
pushc(n);
pushc(param1);
CallRTL(pic, CODE._new)
 
|CODE.opDISP:
PushAll(1);
CallRTL(pic, CODE._dispose)
 
|CODE.opEQS .. CODE.opGES:
PushAll(4);
pushc(cmd.opcode - CODE.opEQS);
CallRTL(pic, CODE._strcmp);
GetRegA
 
|CODE.opEQS2 .. CODE.opGES2:
PushAll(4);
pushc(cmd.opcode - CODE.opEQS2);
CallRTL(pic, CODE._strcmp2);
GetRegA
 
|CODE.opEQSW .. CODE.opGESW:
PushAll(4);
pushc(cmd.opcode - CODE.opEQSW);
CallRTL(pic, CODE._strcmpw);
GetRegA
 
|CODE.opEQSW2 .. CODE.opGESW2:
PushAll(4);
pushc(cmd.opcode - CODE.opEQSW2);
CallRTL(pic, CODE._strcmpw2);
GetRegA
 
|CODE.opEQP, CODE.opNEP, CODE.opEQIP, CODE.opNEIP:
UnOp(reg1);
CASE cmd.opcode OF
|CODE.opEQP, CODE.opNEP:
IF pic THEN
reg2 := REG.GetAnyReg(R);
Pic(reg2, BIN.PICCODE, param1);
cmprr(reg1, reg2);
drop
size := Align(size2, 4);
rcount := 0;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
IF cur.tcmd IN {OCMD, GCMD} THEN
sys.GET(sys.ADR(Code[cur.cmd]), a);
IF a < size THEN
a := a - sys.SIZE(KOSHEADER);
sec := 1
ELSIF a < size + datasize THEN
a := a - size;
sec := 2
ELSE
OutByte2(081H, 0F8H + reg1); // cmp reg1, L
Reloc(BIN.RCODE, param1)
END
 
|CODE.opEQIP, CODE.opNEIP:
IF pic THEN
reg2 := REG.GetAnyReg(R);
Pic(reg2, BIN.PICIMP, param1);
OutByte2(03BH, reg1 * 8 + reg2); //cmp reg1, dword [reg2]
drop
ELSE
OutByte2(3BH, 05H + reg1 * 8); // cmp reg1, dword[L]
Reloc(BIN.RIMP, param1)
END
 
a := a - size - datasize;
sec := 3
END;
drop;
reg1 := REG.GetAnyReg(R);
 
CASE cmd.opcode OF
|CODE.opEQP, CODE.opEQIP: setcc(sete, reg1)
|CODE.opNEP, CODE.opNEIP: setcc(setne, reg1)
sys.PUT(sys.ADR(Code[cur.cmd]), a);
sys.PUT(sys.ADR(Reloc[rcount]), cur.adr - sys.SIZE(KOSHEADER));
INC(rcount, 4);
sys.PUT(sys.ADR(Reloc[rcount]), sec);
INC(rcount, 4);
sys.PUT(sys.ADR(Reloc[rcount]), 06X); INC(rcount);
sys.PUT(sys.ADR(Reloc[rcount]), 00X); INC(rcount);
END;
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
size := size2;
Fill(Align(size, 4) - size2, 0X);
Write(sys.ADR(Data), datasize);
Coff.text.reserved8 := rcount DIV 10;
Coff.PointerToSymbolTable := Coff.text.reserved6 + rcount;
Coff.NumberOfSymbols := 4;
 
andrc(reg1, 1)
WriteF(F, sys.ADR(Coff), sys.SIZE(COFFHEADER));
WriteF(F, filebuf, OutFilePos - filebuf);
WriteF(F, sys.ADR(Reloc), rcount);
 
|CODE.opPUSHT:
UnOp(reg1);
reg2 := REG.GetAnyReg(R);
OutByte3(8BH, 40H + reg2 * 8 + reg1, 0FCH) // mov reg2, dword[reg1 - 4]
adr := sys.ADR(sym);
InitArray(adr, "4558504F52545300000000000100000002002E666C617400000000000000010000000300");
InitArray(adr, "2E64617461000000000000000200000003002E6273730000000000000000030000000300");
sys.PUT(sys.ADR(sym) + 8, Labels[Exports] - sys.SIZE(KOSHEADER));
 
|CODE.opISREC:
PushAll(2);
pushc(param2);
CallRTL(pic, CODE._isrec);
GetRegA
WriteF(F, sys.ADR(sym), LEN(sym));
i := 4;
WriteF(F, sys.ADR(i), 4)
END;
UTILS.CloseF(F)
END WriteKOS;
 
|CODE.opIS:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._is);
GetRegA
PROCEDURE WriteELF(FName: ARRAY OF CHAR; code, data, glob: INTEGER);
VAR F, delta, filebuf: INTEGER; cur: ASMLINE; bytes: ARRAY 817H + 55FH + 4900 OF CHAR;
 
|CODE.opTYPEGR:
PushAll(1);
pushc(param2);
CallRTL(pic, CODE._guardrec);
GetRegA
PROCEDURE Add(offset: INTEGER);
VAR m: INTEGER;
BEGIN
sys.GET(sys.ADR(bytes[offset]), m);
sys.PUT(sys.ADR(bytes[offset]), m + delta)
END Add;
 
|CODE.opTYPEGP:
UnOp(reg1);
PushAll(0);
push(reg1);
pushc(param2);
CallRTL(pic, CODE._guard);
GetRegA
PROCEDURE Sub(offset: INTEGER);
VAR m: INTEGER;
BEGIN
sys.GET(sys.ADR(bytes[offset]), m);
sys.PUT(sys.ADR(bytes[offset]), m - delta)
END Sub;
 
|CODE.opTYPEGD:
UnOp(reg1);
PushAll(0);
OutByte3(0FFH, 070H + reg1, 0FCH); // push dword[reg1 - 4]
pushc(param2);
CallRTL(pic, CODE._guardrec);
GetRegA
PROCEDURE Add8(a1, a2, a3, a4, a5, a6, a7, a8: INTEGER);
BEGIN
Add(a1); Add(a2); Add(a3); Add(a4);
Add(a5); Add(a6); Add(a7); Add(a8)
END Add8;
 
|CODE.opCASET:
push(ecx);
push(ecx);
pushc(param2);
CallRTL(pic, CODE._guardrec);
pop(ecx);
test(eax);
jcc(jne, param1)
BEGIN
sys.MOVE(ELF.get(), sys.ADR(bytes[0]), ELF.size);
 
|CODE.opPACK:
BinOp(reg1, reg2);
push(reg2);
OutByte3(0DBH, 004H, 024H); // fild dword[esp]
OutByte2(0DDH, reg1); // fld qword[reg1]
OutByte2(0D9H, 0FDH); // fscale
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
OutByte3(0DBH, 01CH, 024H); // fistp dword[esp]
pop(reg2);
drop;
drop
DEC(code, 13);
 
|CODE.opPACKC:
UnOp(reg1);
pushc(param2);
OutByte3(0DBH, 004H, 024H); // fild dword[esp]
OutByte2(0DDH, reg1); // fld qword[reg1]
OutByte2(0D9H, 0FDH); // fscale
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
OutByte3(0DBH, 01CH, 024H); // fistp dword[esp]
pop(reg1);
drop
delta := Align(data, 1000H) - 100000H;
Add8(0020H, 00A4H, 00A8H, 0258H, 02B8H, 0308H, 0494H, 049CH);
Add8(04A4H, 0679H, 0681H, 06A4H, 06B0H, 06BAH, 0703H, 0762H);
Add8(0774H, 0786H, 0819H, 0823H, 17C5H, 17E5H, 17E9H, 1811H);
Add8(1839H, 1861H, 1889H, 1A25H, 1A95H, 1AA5H, 1C05H, 1C55H);
Add(1CE5H); Add(1D09H); Add(1D15H); Add(1D25H); Add(1D35H); Add(1D55H);
 
|CODE.opUNPK:
BinOp(reg1, reg2);
OutByte2(0DDH, reg1); // fld qword[reg1]
OutByte2(0D9H, 0F4H); // fxtract
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
OutByte2(0DBH, 018H + reg2); // fistp dword[reg2]
drop;
drop
delta := Align(glob, 1000H) - 3200000H;
Add(00A8H); Add(17EDH); Add(1C09H); Add(1D25H);
 
|CODE.opPUSHF:
subrc(esp, 8);
OutByte3(0DDH, 01CH, 024H) // fstp qword[esp]
delta := Align(code, 1000H) - 100000H;
Add8(0020H, 0084H, 0088H, 0098H, 009CH, 00A0H, 00B8H, 00BCH);
Add8(00C0H, 0118H, 011CH, 0120H, 0258H, 0278H, 02B8H, 0308H);
Add8(048CH, 0494H, 049CH, 04A4H, 04ACH, 04B4H, 04BCH, 04C4H);
Add8(04CCH, 04D4H, 04DCH, 04E4H, 04ECH, 04F4H, 04FCH, 0504H);
Add8(050CH, 0514H, 052BH, 0544H, 054EH, 0554H, 055EH, 056EH);
Add8(057EH, 058EH, 059EH, 05AEH, 05BEH, 05CEH, 05DEH, 05EEH);
Add8(05FEH, 060EH, 061EH, 062EH, 064CH, 0651H, 0679H, 0681H);
Add8(0686H, 068CH, 06A4H, 06ABH, 06B0H, 06BAH, 06D7H, 06EBH);
Add8(0703H, 0762H, 0774H, 0786H, 0819H, 0823H, 0828H, 082DH);
Add8(1635H, 1655H, 1659H, 167DH, 1681H, 16A5H, 16A9H, 16CDH);
Add8(16D1H, 16F5H, 16F9H, 171DH, 1721H, 1745H, 1749H, 176DH);
Add8(1771H, 1795H, 1799H, 17BDH, 17C1H, 17E5H, 17E9H, 1811H);
Add8(1839H, 1861H, 1889H, 1985H, 1995H, 19A5H, 19B5H, 19C5H);
Add8(19D5H, 19E5H, 19F5H, 1A05H, 1A15H, 1A25H, 1A55H, 1A65H);
Add8(1A75H, 1A95H, 1AA5H, 1AD5H, 1AE5H, 1AF5H, 1B05H, 1B25H);
Add8(1B35H, 1B45H, 1B55H, 1B65H, 1B75H, 1BB5H, 1BC5H, 1BE5H);
Add8(1C05H, 1C15H, 1C55H, 1C75H, 1CA5H, 1CB5H, 1CE5H, 1D05H);
Add8(1D15H, 1D25H, 1D35H, 1D55H, 1D75H, 1D89H, 08DEH, 08E8H);
Sub(0845H); Sub(087BH); Sub(0916H); Add(0C52H); Add(0C8AH); Add(0D0AH);
 
|CODE.opLOADF:
UnOp(reg1);
OutByte2(0DDH, reg1); // fld qword[reg1]
drop
OutFilePos := UTILS.GetMem(code + data + 8000H);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
 
|CODE.opCONSTF:
float := cmd.float;
IF float = 0.0 THEN
OutByte2(0D9H, 0EEH) // fldz
ELSIF float = 1.0 THEN
OutByte2(0D9H, 0E8H) // fld1
ELSIF float = -1.0 THEN
OutByte2(0D9H, 0E8H); // fld1
OutByte2(0D9H, 0E0H) // fchs
ELSE
n := UTILS.splitf(float, a, b);
pushc(b);
pushc(a);
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
addrc(esp, 8)
END
Write(sys.ADR(bytes), 817H);
Fill(2DDH, 90X);
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
Fill(Align(code, 1000H) - code, 90X);
Write(sys.ADR(bytes[817H]), 55FH);
Write(sys.ADR(Data), data);
Fill(Align(data, 1000H) - data, 0X);
Write(sys.ADR(bytes[817H + 55FH + 55FH]), 0DC5H);
 
|CODE.opSAVEF:
UnOp(reg1);
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
drop
F := UTILS.CreateF(FName);
IF F <= 0 THEN
Err(1)
END;
WriteF(F, filebuf, OutFilePos - filebuf);
UTILS.CloseF(F)
END WriteELF;
 
|CODE.opADDF, CODE.opADDFI:
OutByte2(0DEH, 0C1H) // faddp st1, st
PROCEDURE DelProc*(beg, end: ASMLINE);
BEGIN
WHILE beg # end DO
beg.clen := 0;
beg.tcmd := 0;
beg := beg.Next(ASMLINE)
END;
beg.clen := 0;
beg.tcmd := 0
END DelProc;
 
|CODE.opSUBF:
OutByte2(0DEH, 0E9H) // fsubp st1, st
PROCEDURE FixLabels*(FName: ARRAY OF CHAR; stk, gsize, glob: INTEGER);
VAR size, asize, i, rdatasize, RCount, n, temp, temp2, temp3: INTEGER; cur: ASMLINE; R: RELOC; c: CHAR;
BEGIN
dcount := Align(dcount, 4);
IF dll THEN
LoadAdr := 10000000H;
PackExport(ExecName)
ELSIF con OR gui THEN
LoadAdr := 400000H
ELSIF kos OR obj THEN
LoadAdr := sys.SIZE(KOSHEADER) + ORD(kem & kos) * 65536
ELSIF elf THEN
LoadAdr := 134514420 + 1024;
INC(gsize, 1024)
END;
 
|CODE.opSUBFI:
OutByte2(0DEH, 0E1H) // fsubrp st1, st
IF dll OR con OR gui THEN
rdatasize := 0DAH + etable.size;
size := 1000H + LoadAdr;
ELSIF kos OR elf OR obj THEN
rdatasize := 0;
size := LoadAdr
END;
 
|CODE.opMULF:
OutByte2(0DEH, 0C9H) // fmulp st1, st
Optimization;
temp2 := size;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
cur.adr := size;
IF cur.tcmd = LCMD THEN
sys.PUT(cur.varadr, size)
END;
size := size + cur.clen;
cur := cur.Next(ASMLINE)
END;
 
|CODE.opDIVF:
OutByte2(0DEH, 0F9H) // fdivp st1, st
 
|CODE.opDIVFI:
OutByte2(0DEH, 0F1H) // fdivrp st1, st
 
|CODE.opUMINF:
OutByte2(0D9H, 0E0H) // fchs
 
|CODE.opFABS:
OutByte2(0D9H, 0E1H) // fabs
 
|CODE.opFLT:
UnOp(reg1);
push(reg1);
OutByte3(0DBH, 004H, 024H); // fild dword[esp]
pop(reg1);
drop
 
|CODE.opFLOOR:
reg1 := REG.GetAnyReg(R);
subrc(esp, 8);
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 004H); // fstcw word[esp+4]
OutByte2(09BH, 0D9H); OutByte3(07CH, 024H, 006H); // fstcw word[esp+6]
OutByte2(066H, 081H); OutByte3(064H, 024H, 004H); OutWord(0F3FFH); // and word[esp+4], 1111001111111111b
OutByte2(066H, 081H); OutByte3(04CH, 024H, 004H); OutWord(00400H); // or word[esp+4], 0000010000000000b
OutByte2(0D9H, 06CH); OutByte2(024H, 004H); // fldcw word[esp+4]
OutByte2(0D9H, 0FCH); // frndint
OutByte3(0DBH, 01CH, 024H); // fistp dword[esp]
pop(reg1);
OutByte2(0D9H, 06CH); OutByte2(024H, 002H); // fldcw word[esp+2]
addrc(esp, 4)
 
|CODE.opEQF, CODE.opEQFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 003H); // jp L
setcc(sete, al)
// L:
 
|CODE.opNEF, CODE.opNEFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 003H); // jp L
setcc(setne, al)
// L:
 
|CODE.opLTF, CODE.opGTFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 00EH); // jp L
setcc(setc, al);
setcc(sete, ah);
test(eax);
setcc(sete, al);
andrc(eax, 1)
// L:
 
|CODE.opGTF, CODE.opLTFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 00FH); // jp L
setcc(setc, al);
setcc(sete, ah);
cmprc(eax, 1);
setcc(sete, al);
andrc(eax, 1)
// L:
 
|CODE.opLEF, CODE.opGEFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 003H); // jp L
setcc(setnc, al)
// L:
 
|CODE.opGEF, CODE.opLEFI:
GetRegA;
OutByte2(0DAH, 0E9H); // fucompp
OutByte3(09BH, 0DFH, 0E0H); // fstsw ax
OutByte(09EH); // sahf
movrc(eax, 0);
OutByte2(07AH, 010H); // jp L
setcc(setc, al);
setcc(sete, ah);
OutByte2(000H, 0E0H); // add al,ah
OutByte2(03CH, 001H); // cmp al,1
setcc(sete, al);
andrc(eax, 1)
// L:
 
|CODE.opINF:
pushc(7FF00000H);
pushc(0);
OutByte3(0DDH, 004H, 024H); // fld qword[esp]
addrc(esp, 8)
 
|CODE.opLADR_UNPK:
n := param2 * 4;
reg1 := REG.GetAnyReg(R);
OutByte2(8DH, 45H + reg1 * 8 + long(n)); // lea reg1, dword[ebp + n]
OutIntByte(n);
BinOp(reg1, reg2);
OutByte2(0DDH, reg1); // fld qword[reg1]
OutByte2(0D9H, 0F4H); // fxtract
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1]
OutByte2(0DBH, 018H + reg2); // fistp dword[reg2]
drop;
drop
 
|CODE.opSADR_PARAM:
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICDATA, stroffs + param2);
push(reg1);
drop
ELSE
OutByte(068H); // push _data + stroffs + param2
Reloc(BIN.RDATA, stroffs + param2)
size := temp2;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
cur.adr := size;
IF cur.tcmd = LCMD THEN
sys.PUT(cur.varadr, size)
ELSIF (cur.tcmd = JCMD) & cur.short THEN
sys.GET(cur.varadr, i);
temp3 := i - cur.Next(ASMLINE).adr;
IF (-131 <= temp3) & (temp3 <= 123) THEN
sys.GET(cur(ASMLINE).codeadr - 1, c);
IF c = JMP THEN
sys.PUT(cur(ASMLINE).codeadr - 1, 0EBX)
ELSE (*JE, JNE, JLE, JGE, JG, JL*)
sys.PUT(cur(ASMLINE).codeadr - 2, ORD(c) - 16);
sys.PUT(cur(ASMLINE).codeadr - 1, temp3);
DEC(cur(ASMLINE).codeadr)
END;
cur.clen := 2
END
END;
size := size + cur.clen;
cur := cur.Next(ASMLINE)
END;
 
|CODE.opVADR_PARAM:
n := param2 * 4;
OutByte2(0FFH, 75H + long(n)); // push dword[ebp + n]
OutIntByte(n)
IF dll OR con OR gui THEN
asize := Align(size, 1000H)
ELSIF kos OR obj THEN
asize := Align(size, 4)
ELSIF elf THEN
asize := 134514420 + 6508 + Align(size - 13 - LoadAdr, 1000H)
END;
 
|CODE.opCONST_PARAM:
pushc(param2)
 
|CODE.opGLOAD32_PARAM:
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICBSS, param2);
OutByte2(0FFH, 30H + reg1); // push dword[reg1]
drop
ELSE
OutByte2(0FFH, 035H); // push dword[_bss + param2]
Reloc(BIN.RBSS, param2)
FOR i := 0 TO Lcount DO
IF Labels[i] < 0 THEN
Labels[i] := -Labels[i] + asize + Align(rdatasize, 1000H)
END
 
|CODE.opLLOAD32_PARAM:
n := param2 * 4;
OutByte2(0FFH, 75H + long(n)); // push dword[ebp + n]
OutIntByte(n)
 
|CODE.opLOAD32_PARAM:
UnOp(reg1);
OutByte2(0FFH, 30H + reg1); // push dword[reg1]
drop
 
|CODE.opGADR_SAVEC:
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICBSS, param1);
OutByte2(0C7H, reg1); // mov dword[reg1], param2
OutInt(param2);
drop
ELSE
OutByte2(0C7H, 05H); // mov dword[_bss + param2], param2
Reloc(BIN.RBSS, param1);
OutInt(param2)
END
 
|CODE.opLADR_SAVEC:
n := param1 * 4;
OutByte2(0C7H, 45H + long(n)); // mov dword[ebp + n], param2
OutIntByte(n);
OutInt(param2)
 
|CODE.opLADR_SAVE:
n := param2 * 4;
UnOp(reg1);
OutByte2(89H, 45H + reg1 * 8 + long(n)); // mov dword[ebp + n], reg1
OutIntByte(n);
drop
 
|CODE.opLADR_INC1:
n := param2 * 4;
OutByte2(0FFH, 45H + long(n)); // inc dword[ebp + n]
OutIntByte(n)
 
|CODE.opLADR_DEC1:
n := param2 * 4;
OutByte2(0FFH, 4DH + long(n)); // dec dword[ebp + n]
OutIntByte(n)
 
|CODE.opLADR_INCC:
n := param1 * 4;
OutByte2(81H + short(param2), 45H + long(n)); // add dword[ebp + n], param2
OutIntByte(n);
OutIntByte(param2)
 
|CODE.opLADR_DECC:
n := param1 * 4;
OutByte2(81H + short(param2), 6DH + long(n)); // sub dword[ebp + n], param2
OutIntByte(n);
OutIntByte(param2)
 
|CODE.opLADR_INC1B:
n := param2 * 4;
OutByte2(0FEH, 45H + long(n)); // inc byte[ebp + n]
OutIntByte(n)
 
|CODE.opLADR_DEC1B:
n := param2 * 4;
OutByte2(0FEH, 4DH + long(n)); // dec byte[ebp + n]
OutIntByte(n)
 
|CODE.opLADR_INCCB:
n := param1 * 4;
OutByte2(80H, 45H + long(n)); // add byte[ebp + n], param2
OutIntByte(n);
OutByte(param2 MOD 256)
 
|CODE.opLADR_DECCB:
n := param1 * 4;
OutByte2(80H, 6DH + long(n)); // sub byte[ebp + n], param2
OutIntByte(n);
OutByte(param2 MOD 256)
 
|CODE.opLADR_INC:
n := param2 * 4;
UnOp(reg1);
OutByte2(01H, 45H + long(n) + reg1 * 8); // add dword[ebp + n], reg1
OutIntByte(n);
drop
 
|CODE.opLADR_DEC:
n := param2 * 4;
UnOp(reg1);
OutByte2(29H, 45H + long(n) + reg1 * 8); // sub dword[ebp + n], reg1
OutIntByte(n);
drop
 
|CODE.opLADR_INCB:
n := param2 * 4;
UnOp(reg1);
OutByte2(00H, 45H + long(n) + reg1 * 8); // add byte[ebp + n], reg1
OutIntByte(n);
drop
 
|CODE.opLADR_DECB:
n := param2 * 4;
UnOp(reg1);
OutByte2(28H, 45H + long(n) + reg1 * 8); // sub byte[ebp + n], reg1
OutIntByte(n);
drop
 
|CODE.opLADR_INCL, CODE.opLADR_EXCL:
n := param2 * 4;
UnOp(reg1);
cmprc(reg1, 32);
label := NewLabel();
jcc(jnb, label);
OutByte3(0FH, 0ABH + 8 * ORD(cmd.opcode = CODE.opLADR_EXCL), 45H + long(n) + reg1 * 8); // bts(r) dword[ebp + n], reg1
OutIntByte(n);
SetLabel(label);
drop
 
|CODE.opLADR_INCLC, CODE.opLADR_EXCLC:
n := param1 * 4;
OutByte3(0FH, 0BAH, 6DH + long(n) + 8 * ORD(cmd.opcode = CODE.opLADR_EXCLC)); // bts(r) dword[ebp + n], param2
OutIntByte(n);
OutByte(param2)
 
|CODE.opLOOP, CODE.opENDLOOP:
 
END;
 
cmd := cmd.next(COMMAND)
temp := dcount;
IF elf THEN
asize := asize + Align(dcount, 1000H) + 64 + 1024;
sys.PUT(sys.ADR(Code[glob + 1]), asize - 1024);
dcount := 0
END;
 
ASSERT(R.pushed = 0);
ASSERT(R.top = -1)
 
END translate;
 
 
PROCEDURE prolog (code: CODE.CODES; pic: BOOLEAN; target, stack, dllinit, dllret: INTEGER);
VAR
reg1, entry, tcount, dcount: INTEGER;
 
BEGIN
 
entry := NewLabel();
SetLabel(entry);
 
IF target = mConst.Target_iDLL THEN
push(ebp);
mov(ebp, esp);
OutByte3(0FFH, 75H, 16); // push dword[ebp+16]
OutByte3(0FFH, 75H, 12); // push dword[ebp+12]
OutByte3(0FFH, 75H, 8); // push dword[ebp+8]
CallRTL(pic, CODE._dllentry);
test(eax);
jcc(je, dllret)
ELSIF target = mConst.Target_iObject THEN
SetLabel(dllinit)
IF dll THEN
asize := asize - LoadAdr + 0DAH;
FOR i := 0 TO etable.namecount - 1 DO
etable.arradr[i] := Labels[etable.arradr[i]] - LoadAdr;
etable.arrnameptr[i] := etable.arrnameptr[i] + asize
END;
 
IF target = mConst.Target_iKolibri THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.IMPTAB, 0);
push(reg1); // push IMPORT
drop
ELSIF target = mConst.Target_iObject THEN
OutByte(68H); // push IMPORT
Reloc(BIN.IMPTAB, 0)
ELSIF target = mConst.Target_iELF32 THEN
push(esp)
ELSE
pushc(0)
etable.arradroffset := etable.arradroffset + asize;
etable.arrnameptroffset := etable.arrnameptroffset + asize;
etable.arrnumoffset := etable.arrnumoffset + asize;
etable.dllnameoffset := etable.dllnameoffset + asize;
asize := asize + LoadAdr - 0DAH
END;
IF dll OR con OR gui THEN
Labels[LoadLibrary] := asize + 4;
Labels[GetProcAddress] := asize;
R.Page := 0;
R.Size := 0;
RCount := 0;
END;
cur := asmlist.First(ASMLINE);
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICCODE, entry);
push(reg1); // push CODE
drop
ELSE
OutByte(68H); // push CODE
Reloc(BIN.RCODE, entry)
FOR i := 0 TO LEN(RtlProc) - 1 DO
RtlProc[i] := Labels[RtlProc[i]]
END;
 
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICDATA, 0);
push(reg1); // push _data
drop
temp3 := asize + Align(rdatasize, 1000H) + dcount;
WHILE cur # NIL DO
CASE cur.tcmd OF
|JCMD:
sys.GET(cur.varadr, i);
sys.PUT(cur.codeadr, i - cur.Next(ASMLINE).adr)
|GCMD:
sys.GET(cur.codeadr, i);
sys.PUT(cur.codeadr, i + temp3)
|OCMD:
sys.MOVE(cur.varadr, cur.codeadr, 4)
ELSE
OutByte(68H); // push _data
Reloc(BIN.RDATA, 0)
END;
 
tcount := CHL.Length(code.types);
dcount := CHL.Length(code.data);
 
pushc(tcount);
 
IF pic THEN
reg1 := REG.GetAnyReg(R);
Pic(reg1, BIN.PICDATA, tcount * 4 + dcount);
push(reg1); // push _data + tcount * 4 + dcount
drop
IF dll & (cur.tcmd IN {GCMD, OCMD}) THEN
n := cur.adr - LoadAdr;
IF ASR(n, 12) = ASR(R.Page, 12) THEN
R.reloc[RCount] := IntToCard16(n MOD 1000H + 3000H);
INC(RCount);
INC(R.Size, 2)
ELSE
OutByte(68H); // push _data
Reloc(BIN.RDATA, tcount * 4 + dcount)
IF R.Size # 0 THEN
PutReloc(R)
END;
 
CallRTL(pic, CODE._init)
END prolog;
 
 
PROCEDURE epilog (code: CODE.CODES; pic: BOOLEAN; modname: ARRAY OF CHAR; target, stack, ver, dllinit, dllret: INTEGER);
VAR
i, n: INTEGER;
exp: CODE.EXPORT_PROC;
path, name, ext: PATHS.PATH;
 
tcount, dcount: INTEGER;
 
 
PROCEDURE import (imp: LISTS.LIST);
VAR
lib: CODE.IMPORT_LIB;
proc: CODE.IMPORT_PROC;
 
BEGIN
 
lib := imp.first(CODE.IMPORT_LIB);
WHILE lib # NIL DO
BIN.Import(program, lib.name, 0);
proc := lib.procs.first(CODE.IMPORT_PROC);
WHILE proc # NIL DO
BIN.Import(program, proc.name, proc.label);
proc := proc.next(CODE.IMPORT_PROC)
R.Page := ASR(n, 12) * 1000H;
R.Size := 10;
R.reloc[0] := IntToCard16(n MOD 1000H + 3000H);
RCount := 1
END
END;
lib := lib.next(CODE.IMPORT_LIB)
cur := cur.Next(ASMLINE)
END;
IF R.Size # 0 THEN
PutReloc(R)
END;
IF dll OR con OR gui THEN
WritePE(FName, stk, size - 1000H - LoadAdr, dcount, rdatasize, gsize)
ELSIF kos OR obj THEN
WriteKOS(FName, Align(stk, 4), size, dcount, gsize, obj)
ELSIF elf THEN
WriteELF(FName, size - LoadAdr, temp, gsize)
END
END FixLabels;
 
END import;
 
 
PROCEDURE OutStringZ(str: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN
 
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iKolibri, mConst.Target_iELF32} THEN
pushc(0);
CallRTL(pic, CODE._exit);
ELSIF target = mConst.Target_iDLL THEN
SetLabel(dllret);
movrc(eax, 1);
OutByte(0C9H); // leave
OutByte3(0C2H, 0CH, 0) // ret 12
ELSIF target = mConst.Target_iObject THEN
movrc(eax, 1);
OutByte(0C3H) // ret
New;
current.clen := LENGTH(str);
FOR i := 0 TO current.clen - 1 DO
Code[ccount] := str[i];
INC(ccount)
END;
Code[ccount] := 0X;
INC(ccount);
INC(current.clen)
END OutStringZ;
 
fixup;
 
tcount := CHL.Length(code.types);
dcount := CHL.Length(code.data);
 
FOR i := 0 TO tcount - 1 DO
BIN.PutData32LE(program, CHL.GetInt(code.types, i))
PROCEDURE Epilog*(gsize: INTEGER; FName: ARRAY OF CHAR; stk: INTEGER);
VAR i, glob: INTEGER;
BEGIN
glob := 0;
IF gsize < maxstrlen THEN
gsize := maxstrlen
END;
 
FOR i := 0 TO dcount - 1 DO
BIN.PutData(program, CHL.GetByte(code.data, i))
gsize := Align(gsize, 4) + 4;
COPY(FName, OutFile);
Labels[RTABLE] := -dcount;
dataint(recarray[0]);
FOR i := 1 TO reccount DO
dataint(recarray[i])
END;
 
program.modname := CHL.Length(program.data);
 
PATHS.split(modname, path, name, ext);
BIN.PutDataStr(program, name);
BIN.PutDataStr(program, ext);
BIN.PutData(program, 0);
 
IF target = mConst.Target_iObject THEN
BIN.Export(program, "lib_init", dllinit);
current := start;
IF con OR gui OR dll THEN
PushInt(LoadLibrary);
PushInt(GetProcAddress);
OutCode("5859FF31FF3054")
ELSIF elf THEN
OutCode("6800000000");
glob := current.cmd;
ELSIF kos OR obj THEN
OutByte(54H)
END;
 
exp := code.export.first(CODE.EXPORT_PROC);
WHILE exp # NIL DO
BIN.Export(program, exp.name, exp.label);
exp := exp.next(CODE.EXPORT_PROC)
GlobalAdr(0);
PushConst(ASR(gsize, 2));
PushInt(RTABLE);
PushInt(SELFNAME);
CallRTL(_init);
current := asmlist.Last(ASMLINE);
IF dll THEN
OutCode("B801000000C9C20C00")
END;
 
import(code.import);
 
n := code.dmin - CHL.Length(code.data);
IF n > 0 THEN
INC(code.bss, n)
IF obj THEN
OutCode("B801000000C9C20000")
END;
 
BIN.SetParams(program, MAX(code.bss, 4), stack * (1024 * 1024), WCHR(ver DIV 65536), WCHR(ver MOD 65536));
 
END epilog;
 
 
PROCEDURE CodeGen* (code: CODE.CODES; outname: ARRAY OF CHAR; target, stack, base, ver: INTEGER; pic: BOOLEAN);
VAR
dllret, dllinit: INTEGER;
 
BEGIN
 
CodeList := LISTS.create(NIL);
 
program := BIN.create(code.lcount);
 
dllinit := NewLabel();
dllret := NewLabel();
 
IF target = mConst.Target_iObject THEN
pic := FALSE
OutCode("EB05");
Label(ASSRT);
CallRTL(_assrt);
OutCode("EB09");
Label(HALT);
OutCode("6A006A00");
CallRTL(_assrt);
OutCode("6A00");
CallRTL(_halt);
Label(_floor);
OutCode("83EC06D93C2466812424FFF366810C24FFF7D92C2483C402D9FCDB1C2458C3");
IF obj THEN
Label(Exports);
CmdN(szSTART); CmdN(START);
CmdN(szversion); OutInt(stk);
FOR i := 0 TO kosexpcount - 1 DO
CmdN(kosexp[i].NameLabel); CmdN(kosexp[i].Adr)
END;
 
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL, mConst.Target_iELF32} THEN
pic := TRUE
OutInt(0);
Label(szSTART); OutStringZ("lib_init");
Label(szversion); OutStringZ("version");
FOR i := 0 TO kosexpcount - 1 DO
Label(kosexp[i].NameLabel);
OutStringZ(kosexp[i].Name.Name)
END
END;
FixLabels(FName, stk, gsize, glob)
END Epilog;
 
R := REG.Create(push, pop, mov, xchg, NIL, NIL, {eax, ecx, edx}, {});
PROCEDURE setkem*;
BEGIN
kem := TRUE
END setkem;
 
prolog(code, pic, target, stack, dllinit, dllret);
translate(code, pic, CHL.Length(code.types) * 4);
epilog(code, pic, outname, target, stack, ver, dllinit, dllret);
 
BIN.fixup(program);
 
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN
PE32.write(program, outname, base, target = mConst.Target_iConsole, target = mConst.Target_iDLL, FALSE)
ELSIF target = mConst.Target_iKolibri THEN
KOS.write(program, outname)
ELSIF target = mConst.Target_iObject THEN
MSCOFF.write(program, outname, ver)
ELSIF target = mConst.Target_iELF32 THEN
ELF.write(program, outname, FALSE)
END
 
END CodeGen;
 
 
PROCEDURE SetProgram* (prog: BIN.PROGRAM);
BEGIN
program := prog;
CodeList := LISTS.create(NIL)
END SetProgram;
 
 
kem := FALSE
END X86.
/programs/develop/oberon07/Source/DECL.ob07
0,0 → 1,1630
(*
Copyright 2016, 2017 Anton Krotov
 
This file is part of Compiler.
 
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
Compiler 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 General Public License for more details.
 
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE DECL;
 
IMPORT SCAN, UTILS, X86, SYSTEM;
 
CONST
 
lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7;
lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8;
lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16;
lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23;
lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30;
lxUNTIL = 31; lxVAR = 32; lxWHILE = 33;
 
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58;
lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65;
lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
 
lxERR0 = 100; lxERR1 = 101; lxERR2 = 102; lxERR3 = 103; lxERR4 = 104; lxERR5 = 105; lxERR6 = 106;
lxERR7 = 107; lxERR8 = 108; lxERR9 = 109; lxERR10 = 110; lxERR11 = 111; lxERR20 = 120;
 
IDMOD = 1; IDCONST = 2; IDTYPE = 3; IDVAR = 4; IDPROC = 5; IDSTPROC = 6; IDGUARD = 7; IDPARAM = 8; IDSYSPROC = 9;
 
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;
stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22;
stBITS = 23; stLSR = 24; stLENGTH = 25; stMIN = 26; stMAX = 27;
 
sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; sysCOPY = 109;
 
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;
 
TNUM = {TINTEGER, TREAL, TLONGREAL};
TFLOAT = {TREAL, TLONGREAL};
TSTRUCT = {TARRAY, TRECORD};
 
paramvar* = 1; param* = 2;
 
defcall = 0; stdcall = 1; cdecl = 2; winapi* = 3;
 
record = 0; union = 1; noalign = 2;
 
eVAR = 1; eCONST = 2; eEXP = 3; ePROC = 4; eSTPROC = 5; eSYSPROC = 6;
 
IOVER* = lxERR5 - lxERR0;
FOVER* = lxERR7 - lxERR0;
UNDER* = lxERR9 - lxERR0;
 
TYPE
 
pTYPE* = POINTER TO RECORD (UTILS.rITEM)
tType*, Size*, Len*, Number*, Align, Call*, Rec: INTEGER;
Base*: pTYPE;
Fields*: UTILS.LIST
END;
 
IDENT* = POINTER TO rIDENT;
 
UNIT* = POINTER TO RECORD (UTILS.rITEM)
Name: SCAN.NODE;
File: UTILS.STRING;
Idents: UTILS.LIST;
Import: UTILS.LIST;
IdentBegin: IDENT;
scanner: SCAN.SCANNER;
Level*: INTEGER;
Closed, typedecl, Std, sys: BOOLEAN
END;
 
rIDENT* = RECORD (UTILS.rITEM)
Name*: SCAN.NODE;
T*: pTYPE;
Unit*: UNIT;
Parent*: IDENT;
Proc*: UTILS.ITEM;
Value*: LONGREAL;
coord*: SCAN.TCoord;
Number*, iType*, StProc*, VarSize, ParamSize*,
LocalSize*, Offset*, VarKind*, Level*, ParamCount*: INTEGER;
Export: BOOLEAN
END;
 
PTRBASE = POINTER TO RECORD (UTILS.rITEM)
Name: SCAN.NODE;
coord: SCAN.TCoord;
Ptr: pTYPE
END;
 
STRITEM = POINTER TO RECORD (UTILS.rITEM)
Str: UTILS.STRING
END;
 
FIELD* = POINTER TO RECORD (UTILS.rITEM)
Name: SCAN.NODE;
T*: pTYPE;
Offset*: INTEGER;
ByRef*, Export*: BOOLEAN;
Unit*: UNIT
END;
 
EXPRESSION* = RECORD
id*: IDENT;
T*: pTYPE;
eType*: INTEGER;
Value*: LONGREAL;
Read*, vparam*, deref*: BOOLEAN
END;
 
opPROC = PROCEDURE;
expPROC = PROCEDURE (VAR e: EXPRESSION);
assPROC = PROCEDURE (e: EXPRESSION; T: pTYPE; param: BOOLEAN): BOOLEAN;
 
stTYPES* = ARRAY 11 OF pTYPE;
 
Proc* = POINTER TO RECORD (UTILS.rITEM)
used: BOOLEAN;
beg, end: X86.ASMLINE;
Procs*: UTILS.LIST
END;
 
VAR
 
sttypes: stTYPES; unit*, sys: UNIT; curBlock*: IDENT;
Path, Main, Std, ExtMain: UTILS.STRING;
NamePtrBase: SCAN.NODE; ProgSize*, RecCount, UnitNumber*: INTEGER;
PtrBases, Strings, types, prog, procs: UTILS.LIST; OpSeq: opPROC; Expr: expPROC;
AssComp: assPROC; main, sizefunc, winplatf, Const*: BOOLEAN;
pParseType: PROCEDURE (VAR coord: SCAN.TCoord): pTYPE;
pReadModule: PROCEDURE (Path, Name, Ext: UTILS.STRING): BOOLEAN;
Platform: INTEGER; voidtype: pTYPE; zcoord: SCAN.TCoord;
curproc*: Proc;
 
PROCEDURE SetSizeFunc*;
BEGIN
sizefunc := TRUE
END SetSizeFunc;
 
PROCEDURE MemErr*(err: BOOLEAN);
BEGIN
IF err THEN
UTILS.MemErr(TRUE)
END
END MemErr;
 
PROCEDURE GetString*(adr: LONGREAL): UTILS.STRCONST;
VAR str: UTILS.STRCONST;
BEGIN
SYSTEM.PUT(SYSTEM.ADR(str), FLOOR(adr))
RETURN str
END GetString;
 
PROCEDURE AddString*(str: UTILS.STRING): UTILS.STRCONST;
VAR nov: UTILS.STRCONST;
BEGIN
nov := UTILS.GetStr(Strings, str);
IF nov = NIL THEN
NEW(nov);
MemErr(nov = NIL);
nov.Str := str;
nov.Len := SCAN.count - 1;
nov.Number := X86.NewLabel();
UTILS.Push(Strings, nov);
X86.String(nov.Number, nov.Len, nov.Str)
END
RETURN nov
END AddString;
 
PROCEDURE AddMono*(c: CHAR): UTILS.STRCONST;
VAR nov: UTILS.STRCONST; s: UTILS.STRING;
BEGIN
s[0] := c;
s[1] := 0X;
nov := UTILS.GetStr(Strings, s);
IF nov = NIL THEN
NEW(nov);
MemErr(nov = NIL);
nov.Str := s;
nov.Len := 1;
nov.Number := X86.NewLabel();
UTILS.Push(Strings, nov);
X86.String(nov.Number, nov.Len, nov.Str)
END
RETURN nov
END AddMono;
 
PROCEDURE Coord(VAR coord: SCAN.TCoord);
BEGIN
coord := SCAN.coord
END Coord;
 
PROCEDURE GetModule(Name: SCAN.NODE): UNIT;
VAR cur, res: UNIT;
BEGIN
res := NIL;
cur := prog.First(UNIT);
WHILE (cur # NIL) & UTILS.streq(cur.Name.Name, Name.Name) DO
res := cur;
cur := NIL
ELSIF cur # NIL DO
cur := cur.Next(UNIT)
END
RETURN res
END GetModule;
 
PROCEDURE Assert*(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER);
BEGIN
IF ~cond THEN
UTILS.ErrMsgPos(coord.line, coord.col, code);
UTILS.HALT(1)
END
END Assert;
 
PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER);
BEGIN
IF ~cond THEN
Assert(FALSE, SCAN.coord, code)
END
END Assert2;
 
PROCEDURE Next*;
VAR coord: SCAN.TCoord;
BEGIN
SCAN.GetLex;
IF (SCAN.tLex > lxERR0) & (SCAN.tLex < lxERR20) THEN
coord.line := SCAN.coord.line;
coord.col := SCAN.coord.col + SCAN.count;
Assert(FALSE, coord, SCAN.tLex - lxERR0)
END;
Assert2(SCAN.tLex # lxEOF, 27)
END Next;
 
PROCEDURE NextCoord(VAR coord: SCAN.TCoord);
BEGIN
Next;
coord := SCAN.coord
END NextCoord;
 
PROCEDURE Check*(key: INTEGER);
VAR code: INTEGER;
BEGIN
IF SCAN.tLex # key THEN
CASE key OF
|lxMODULE: code := 21
|lxIDENT: code := 22
|lxSemi: code := 23
|lxEND: code := 24
|lxDot: code := 25
|lxEQ: code := 35
|lxRRound: code := 38
|lxTO: code := 40
|lxOF: code := 41
|lxRCurly: code := 51
|lxLRound: code := 56
|lxComma: code := 61
|lxTHEN: code := 98
|lxRSquare: code := 109
|lxDO: code := 118
|lxUNTIL: code := 119
|lxAssign: code := 120
|lxRETURN: code := 124
|lxColon: code := 157
ELSE
END;
Assert2(FALSE, code)
END
END Check;
 
PROCEDURE NextCheck(key: INTEGER);
BEGIN
Next;
Check(key)
END NextCheck;
 
PROCEDURE CheckIdent(Name: SCAN.NODE): BOOLEAN;
VAR cur: IDENT;
BEGIN
cur := unit.Idents.Last(IDENT);
WHILE (cur.iType # IDGUARD) & (cur.Name # Name) DO
cur := cur.Prev(IDENT)
END
RETURN cur.iType = IDGUARD
END CheckIdent;
 
PROCEDURE Guard;
VAR ident: IDENT;
BEGIN
NEW(ident);
MemErr(ident = NIL);
ident.Name := NIL;
ident.iType := IDGUARD;
ident.T := voidtype;
UTILS.Push(unit.Idents, ident);
INC(unit.Level)
END Guard;
 
PROCEDURE PushIdent(Name: SCAN.NODE; coord: SCAN.TCoord; iType: INTEGER; T: pTYPE; u: UNIT; Export: BOOLEAN; StProc: INTEGER);
VAR ident: IDENT; i: INTEGER;
BEGIN
Assert(CheckIdent(Name), coord, 30);
NEW(ident);
MemErr(ident = NIL);
ident.Name := Name;
ident.coord := coord;
IF iType IN {IDPROC, IDMOD} THEN
ident.Number := X86.NewLabel();
i := X86.NewLabel();
i := X86.NewLabel();
i := X86.NewLabel()
END;
ident.iType := iType;
ident.T := T;
ident.Unit := u;
ident.Export := Export;
ident.StProc := StProc;
ident.Level := unit.Level;
UTILS.Push(unit.Idents, ident)
END PushIdent;
 
PROCEDURE StTypes;
VAR type: pTYPE; i: INTEGER;
BEGIN
sttypes[0] := NIL;
FOR i := TINTEGER TO TSTRING DO
NEW(type);
MemErr(type = NIL);
type.tType := i;
UTILS.Push(types, type);
sttypes[i] := type
END;
sttypes[TINTEGER].Size := 4;
sttypes[TREAL].Size := 4;
sttypes[TLONGREAL].Size := 8;
sttypes[TBOOLEAN].Size := 1;
sttypes[TCHAR].Size := 1;
sttypes[TSET].Size := 4;
sttypes[TVOID].Size := 0;
sttypes[TSTRING].Size := 0;
sttypes[TNIL].Size := 4;
sttypes[TCARD16].Size := 2;
FOR i := TINTEGER TO TSTRING DO
sttypes[i].Align := sttypes[i].Size
END
END StTypes;
 
PROCEDURE PushStProc(Name: UTILS.STRING; StProc: INTEGER);
BEGIN
PushIdent(SCAN.AddNode(Name), zcoord, IDSTPROC, voidtype, NIL, FALSE, StProc)
END PushStProc;
 
PROCEDURE PushStType(Name: UTILS.STRING; T: INTEGER);
BEGIN
PushIdent(SCAN.AddNode(Name), zcoord, IDTYPE, sttypes[T], NIL, FALSE, 0)
END PushStType;
 
PROCEDURE PushSysProc(Name: UTILS.STRING; StProc: INTEGER);
BEGIN
PushIdent(SCAN.AddNode(Name), zcoord, IDSYSPROC, voidtype, NIL, TRUE, StProc)
END PushSysProc;
 
PROCEDURE PushSysType(Name: UTILS.STRING; T: INTEGER);
BEGIN
PushIdent(SCAN.AddNode(Name), zcoord, IDTYPE, sttypes[T], NIL, TRUE, 0)
END PushSysType;
 
PROCEDURE StIdent;
BEGIN
Guard;
PushStProc("ABS", stABS);
PushStProc("ASR", stASR);
PushStProc("ASSERT", stASSERT);
PushStType("BOOLEAN", TBOOLEAN);
PushStType("CHAR", TCHAR);
PushStProc("CHR", stCHR);
PushStProc("COPY", stCOPY);
PushStProc("DEC", stDEC);
PushStProc("DISPOSE", stDISPOSE);
PushStProc("EXCL", stEXCL);
PushStProc("FLOOR", stFLOOR);
PushStProc("FLT", stFLT);
PushStProc("INC", stINC);
PushStProc("INCL", stINCL);
PushStType("INTEGER", TINTEGER);
PushStProc("LEN", stLEN);
PushStProc("LSL", stLSL);
PushStProc("LONG", stLONG);
PushStType("LONGREAL", TLONGREAL);
PushStProc("NEW", stNEW);
PushStProc("ODD", stODD);
PushStProc("ORD", stORD);
PushStProc("PACK", stPACK);
PushStType("REAL", TREAL);
PushStProc("ROR", stROR);
PushStType("SET", TSET);
PushStProc("SHORT", stSHORT);
PushStProc("UNPK", stUNPK);
PushStProc("BITS", stBITS);
PushStProc("LSR", stLSR);
PushStProc("LENGTH", stLENGTH);
PushStProc("MIN", stMIN);
PushStProc("MAX", stMAX);
Guard
END StIdent;
 
PROCEDURE GetQIdent*(Unit: UNIT; Name: SCAN.NODE): IDENT;
VAR cur, res: IDENT;
BEGIN
res := NIL;
cur := Unit.IdentBegin.Next(IDENT);
WHILE (cur # NIL) & (cur.iType # IDGUARD) DO
IF cur.Name = Name THEN
IF (Unit # unit) & ~cur.Export THEN
res := NIL
ELSE
res := cur
END;
cur := NIL
ELSE
cur := cur.Next(IDENT)
END
END
RETURN res
END GetQIdent;
 
PROCEDURE GetIdent*(Name: SCAN.NODE): IDENT;
VAR cur, res: IDENT;
BEGIN
res := NIL;
cur := unit.Idents.Last(IDENT);
WHILE (cur # NIL) & (cur.Name = Name) DO
res := cur;
cur := NIL
ELSIF cur # NIL DO
cur := cur.Prev(IDENT)
END
RETURN res
END GetIdent;
 
PROCEDURE Relation*(Op: INTEGER): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
CASE Op OF
|lxEQ, lxNE, lxLT, lxGT,
lxLE, lxGE, lxIN, lxIS:
Res := TRUE
ELSE
Res := FALSE
END
RETURN Res
END Relation;
 
PROCEDURE Arith(a, b: LONGREAL; T: pTYPE; Op: INTEGER; coord: SCAN.TCoord): LONGREAL;
CONST max = SCAN.maxDBL;
VAR res: LONGREAL;
BEGIN
CASE Op OF
|lxPlus: res := a + b
|lxMinus: res := a - b
|lxMult: res := a * b
|lxSlash:
Assert(b # 0.0D0, coord, 46);
res := a / b
|lxDIV:
Assert(~((a = LONG(FLT(SCAN.minINT))) & (b = -1.0D0)), coord, IOVER);
res := LONG(FLT(FLOOR(a) DIV FLOOR(b)))
|lxMOD:
res := LONG(FLT(FLOOR(a) MOD FLOOR(b)))
ELSE
END;
Assert(~UTILS.IsInf(res), coord, FOVER);
CASE T.tType OF
|TINTEGER: Assert((res <= LONG(FLT(SCAN.maxINT))) & (res >= LONG(FLT(SCAN.minINT))), coord, IOVER)
|TREAL: Assert((res <= LONG(SCAN.maxREAL)) & (res >= -LONG(SCAN.maxREAL)), coord, FOVER)
|TLONGREAL: Assert((res <= max) & (res >= -max), coord, FOVER)
ELSE
END;
IF (res = 0.0D0) & (T.tType IN TFLOAT) OR (ABS(res) < LONG(SCAN.minREAL)) & (T.tType = TREAL) THEN
CASE Op OF
|lxPlus: Assert(a = -b, coord, UNDER)
|lxMinus: Assert(a = b, coord, UNDER)
|lxMult: Assert((a = 0.0D0) OR (b = 0.0D0), coord, UNDER)
|lxSlash: Assert((a = 0.0D0), coord, UNDER)
ELSE
END
END
RETURN res
END Arith;
 
PROCEDURE strcmp(a, b: LONGREAL; Op: INTEGER): LONGREAL;
VAR sa, sb: UTILS.STRCONST; Res: LONGREAL;
BEGIN
sa := GetString(a);
sb := GetString(b);
CASE Op OF
|lxEQ, lxNE: Res := LONG(FLT(ORD(sa.Str = sb.Str)))
|lxLT, lxGT: Res := LONG(FLT(ORD(sa.Str < sb.Str)))
|lxLE, lxGE: Res := LONG(FLT(ORD(sa.Str <= sb.Str)))
ELSE
END
RETURN Res
END strcmp;
 
PROCEDURE Calc*(a, b: LONGREAL; Ta, Tb: pTYPE; Op: INTEGER; coord: SCAN.TCoord; VAR Res: LONGREAL; VAR TRes: pTYPE);
VAR c: LONGREAL; ai, bi: INTEGER;
BEGIN
ai := FLOOR(a);
bi := FLOOR(b);
IF Op # lxIN THEN
Assert(Ta = Tb, coord, 37)
END;
CASE Op OF
|lxPlus, lxMinus, lxMult, lxSlash:
Assert(~((Op = lxSlash) & (Ta.tType = TINTEGER)), coord, 37);
IF Ta.tType IN TNUM THEN
Res := Arith(a, b, Ta, Op, coord)
ELSIF Ta.tType = TSET THEN
CASE Op OF
|lxPlus: 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))))
|lxSlash: Res := LONG(FLT(ORD(BITS(ai) / BITS(bi))))
ELSE
END
ELSE
Assert(FALSE, coord, 37)
END;
TRes := Ta
|lxDIV, lxMOD:
Assert(Ta.tType = TINTEGER, coord, 37);
Assert(bi # 0, coord, 48);
TRes := Ta;
Res := Arith(a, b, Ta, Op, coord)
|lxAnd:
Assert(Ta.tType = TBOOLEAN, coord, 37);
Res := LONG(FLT(ORD((ai # 0) & (bi # 0))))
|lxOR:
Assert(Ta.tType = TBOOLEAN, coord, 37);
Res := LONG(FLT(ORD((ai # 0) OR (bi # 0))))
|lxEQ, lxNE:
IF Ta.tType = TSTRING THEN
Res := strcmp(a, b, Op)
ELSE
Res := LONG(FLT(ORD(a = b)))
END;
IF Op = lxNE THEN
Res := LONG(FLT(ORD(Res = 0.0D0)))
END
|lxLT, lxGT:
IF Op = lxGT THEN
c := a;
a := b;
b := c
END;
Assert(Ta.tType IN (TNUM + {TSTRING}), coord, 37);
IF Ta.tType = TSTRING THEN
Res := strcmp(a, b, Op)
ELSE
Res := LONG(FLT(ORD(a < b)))
END
|lxLE, lxGE:
IF Op = lxGE THEN
c := a;
a := b;
b := c
END;
Assert(Ta.tType IN (TNUM + {TSTRING, TSET}), coord, 37);
IF Ta.tType = TSTRING THEN
Res := strcmp(a, b, Op)
ELSIF Ta.tType = TSET THEN
Res := LONG(FLT(ORD(BITS(FLOOR(a)) <= BITS(FLOOR(b)))))
ELSE
Res := LONG(FLT(ORD(a <= b)))
END
|lxIN:
Assert((Ta.tType = TINTEGER) & (Tb.tType = TSET), coord, 37);
Assert(ASR(ai, 5) = 0, coord, 49);
Res := LONG(FLT(ORD(ai IN BITS(bi))))
ELSE
END;
IF Relation(Op) OR (Op = lxAnd) OR (Op = lxOR) THEN
TRes := sttypes[TBOOLEAN]
END
END Calc;
 
PROCEDURE ConstExpr*(VAR Value: LONGREAL; VAR T: pTYPE);
VAR e: EXPRESSION; coord: SCAN.TCoord;
BEGIN
Const := TRUE;
Coord(coord);
sizefunc := FALSE;
Expr(e);
Assert(~sizefunc & (e.eType = eCONST), coord, 62);
Value := e.Value;
T := e.T;
Const := FALSE
END ConstExpr;
 
PROCEDURE IdType*(VAR coord: SCAN.TCoord): pTYPE;
VAR id: IDENT; Name: SCAN.NODE; Unit: UNIT; Res: pTYPE;
BEGIN
Res := NIL;
Name := SCAN.id;
id := GetIdent(Name);
IF id = NIL THEN
Coord(coord);
NamePtrBase := Name;
Next
ELSE
IF id.iType = IDTYPE THEN
Coord(coord);
Next;
Res := id.T
ELSIF id.iType = IDMOD THEN
Unit := id.Unit;
NextCheck(lxDot);
NextCheck(lxIDENT);
Name := SCAN.id;
NamePtrBase := Name;
id := GetQIdent(Unit, Name);
IF Unit # unit THEN
Assert2(id # NIL, 42);
Assert2(id.iType = IDTYPE, 77);
Coord(coord);
Next;
Res := id.T
ELSE
IF id = NIL THEN
Assert2((unit.Level = 3) & unit.typedecl, 42);
Coord(coord);
Next;
Res := NIL
ELSE
Assert2(id.iType = IDTYPE, 77);
Coord(coord);
Next;
Res := id.T
END
END
ELSE
Assert2(FALSE, 77)
END
END
RETURN Res
END IdType;
 
PROCEDURE FieldOffset(Align, RecSize: INTEGER): INTEGER;
BEGIN
Assert2(RecSize <= SCAN.maxINT - (Align - RecSize MOD Align) MOD Align, 83)
RETURN RecSize + (Align - RecSize MOD Align) MOD Align
END FieldOffset;
 
PROCEDURE Dim*(T: pTYPE): INTEGER;
VAR n: INTEGER;
BEGIN
n := 0;
WHILE (T.tType = TARRAY) & (T.Len = 0) DO
INC(n);
T := T.Base
END
RETURN n
END Dim;
 
PROCEDURE SetFields(Tr, Tf: pTYPE; Rec: BOOLEAN);
VAR cur: FIELD;
BEGIN
cur := Tr.Fields.First(FIELD);
WHILE cur.T # NIL DO
cur := cur.Next(FIELD)
END;
WHILE cur # NIL DO
cur.T := Tf;
IF Rec THEN
IF Tf.Align > Tr.Align THEN
Tr.Align := Tf.Align
END;
IF Tr.Rec = record THEN
cur.Offset := FieldOffset(Tf.Align, Tr.Size);
Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
Tr.Size := cur.Offset + Tf.Size
ELSIF Tr.Rec = noalign THEN
cur.Offset := FieldOffset(1, Tr.Size);
Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
Tr.Size := cur.Offset + Tf.Size
ELSIF Tr.Rec = union THEN
IF Tf.Size > Tr.Size THEN
Tr.Size := Tf.Size
END;
cur.Offset := 0
END
ELSE
Tr.Len := Tr.Len + 4 * (ORD((Tf.tType = TRECORD) & cur.ByRef) + Dim(Tf) + ORD((Tf.tType = TLONGREAL) & ~cur.ByRef) + 1)
END;
cur := cur.Next(FIELD)
END
END SetFields;
 
PROCEDURE GetField*(T: pTYPE; Name: SCAN.NODE): FIELD;
VAR cur, Res: FIELD;
BEGIN
Res := NIL;
cur := T.Fields.First(FIELD);
WHILE (cur # NIL) & (cur.Name = Name) DO
Res := cur;
cur := NIL
ELSIF cur # NIL DO
cur := cur.Next(FIELD)
END
RETURN Res
END GetField;
 
PROCEDURE Unique(T: pTYPE; Name: SCAN.NODE): BOOLEAN;
VAR field: FIELD; res: BOOLEAN;
BEGIN
res := TRUE;
WHILE (T # NIL) & res DO
field := GetField(T, Name);
IF field # NIL THEN
IF (field.Unit = unit) OR field.Export THEN
res := FALSE
END
END;
T := T.Base
END
RETURN res
END Unique;
 
PROCEDURE notrecurs(id: BOOLEAN; T: pTYPE): BOOLEAN;
RETURN ~(id & (unit.Idents.Last(IDENT).iType = IDTYPE) & (unit.Idents.Last(IDENT).T = T) &
(T.tType IN TSTRUCT))
END notrecurs;
 
PROCEDURE ReadFields(T: pTYPE);
VAR Name: SCAN.NODE; field: FIELD; Tf: pTYPE; coord: SCAN.TCoord; id_T: BOOLEAN;
BEGIN
WHILE SCAN.tLex = lxIDENT DO
Name := SCAN.id;
Assert2(Unique(T, Name), 30);
NEW(field);
MemErr(field = NIL);
UTILS.Push(T.Fields, field);
field.Name := Name;
field.T := NIL;
field.Export := FALSE;
field.Unit := unit;
Next;
IF SCAN.tLex = lxMult THEN
Assert2(unit.Level = 3, 89);
field.Export := TRUE;
Next
END;
IF SCAN.tLex = lxComma THEN
NextCheck(lxIDENT)
ELSIF SCAN.tLex = lxColon THEN
NextCoord(coord);
id_T := SCAN.tLex = lxIDENT;
Tf:= pParseType(coord);
Assert(Tf # NIL, coord, 42);
Assert(notrecurs(id_T, Tf), coord, 96);
SetFields(T, Tf, TRUE);
IF SCAN.tLex = lxSemi THEN
NextCheck(lxIDENT)
ELSE
Assert2(SCAN.tLex = lxEND, 86)
END
ELSE
Assert2(FALSE, 85)
END
END
END ReadFields;
 
PROCEDURE OpenBase*(T: pTYPE): pTYPE;
BEGIN
WHILE (T.tType = TARRAY) & (T.Len = 0) DO
T := T.Base
END
RETURN T
END OpenBase;
 
PROCEDURE SetVars(T: pTYPE);
VAR cur: IDENT; n: INTEGER;
BEGIN
cur := unit.Idents.Last(IDENT);
WHILE cur.T = NIL DO
cur := cur.Prev(IDENT)
END;
cur := cur.Next(IDENT);
WHILE cur # NIL DO
cur.T := T;
IF(cur.VarKind = paramvar) OR (cur.VarKind = param) & (T.tType IN TSTRUCT) THEN
n := 4 * (1 + Dim(T) + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
ELSE
n := T.Size;
Assert2(n <= SCAN.maxINT - UTILS.Align(n), 93);
n := n + UTILS.Align(n)
END;
IF cur.Level = 3 THEN
cur.Offset := ProgSize;
Assert2(ProgSize <= SCAN.maxINT - n, 93);
ProgSize := ProgSize + n;
Assert2(ProgSize <= SCAN.maxINT - UTILS.Align(ProgSize), 93);
ProgSize := ProgSize + UTILS.Align(ProgSize)
ELSE
IF cur.VarKind = 0 THEN
cur.Offset := curBlock.ParamSize - curBlock.VarSize - n
ELSE
cur.Offset := curBlock.VarSize - 8 + 4 * (cur.Level + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
END
END;
Assert2(curBlock.VarSize <= SCAN.maxINT - n, 93);
curBlock.VarSize := curBlock.VarSize + n;
Assert2(curBlock.VarSize <= SCAN.maxINT - UTILS.Align(curBlock.VarSize), 93);
curBlock.VarSize := curBlock.VarSize + UTILS.Align(curBlock.VarSize);
IF cur.VarKind # 0 THEN
curBlock.ParamSize := curBlock.VarSize
END;
cur := cur.Next(IDENT)
END
END SetVars;
 
PROCEDURE CreateType(tType, Len, Size, Number: INTEGER; Base: pTYPE; Fields: BOOLEAN; NewType: pTYPE): pTYPE;
VAR nov: pTYPE;
BEGIN
IF NewType = NIL THEN
NEW(nov);
MemErr(nov = NIL)
ELSE
nov := NewType
END;
UTILS.Push(types, nov);
nov.tType := tType;
nov.Len := Len;
nov.Size := Size;
nov.Base := Base;
nov.Fields := NIL;
nov.Number := Number;
IF Fields THEN
nov.Fields := UTILS.CreateList()
END
RETURN nov
END CreateType;
 
PROCEDURE FormalType(VAR coord: SCAN.TCoord): pTYPE;
VAR TA: pTYPE;
BEGIN
IF SCAN.tLex = lxARRAY THEN
NextCheck(lxOF);
Next;
TA := CreateType(TARRAY, 0, 0, 0, FormalType(coord), FALSE, NIL)
ELSE
Check(lxIDENT);
TA := IdType(coord);
Assert(TA # NIL, coord, 42);
END
RETURN TA
END FormalType;
 
PROCEDURE Section(T: pTYPE);
VAR Name: SCAN.NODE; ByRef, cont: BOOLEAN; field: FIELD;
Tf: pTYPE; fp: IDENT; coord: SCAN.TCoord; proc: BOOLEAN;
BEGIN
proc := T = NIL;
IF proc THEN
T := curBlock.T
END;
Assert2((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR), 84);
ByRef := FALSE;
IF SCAN.tLex = lxVAR THEN
ByRef := TRUE;
NextCheck(lxIDENT)
END;
cont := TRUE;
WHILE cont DO
Name := SCAN.id;
Assert2(GetField(T, Name) = NIL, 30);
NEW(field);
MemErr(field = NIL);
UTILS.Push(T.Fields, field);
field.Name := Name;
field.T := NIL;
field.ByRef := ByRef;
IF proc THEN
PushIdent(Name, coord, IDVAR, NIL, NIL, FALSE, 0);
INC(curBlock.ParamCount);
fp := unit.Idents.Last(IDENT);
IF ByRef THEN
fp.VarKind := paramvar
ELSE
fp.VarKind := param
END
END;
Next;
IF SCAN.tLex = lxComma THEN
NextCheck(lxIDENT)
ELSIF SCAN.tLex = lxColon THEN
Next;
Tf := FormalType(coord);
Assert(Dim(Tf) <= X86.ADIM, coord, 110);
SetFields(T, Tf, FALSE);
IF proc THEN
SetVars(Tf)
END;
cont := FALSE
ELSE
Assert2(FALSE, 85)
END
END
END Section;
 
PROCEDURE ParamType(T: pTYPE);
VAR break: BOOLEAN;
BEGIN
IF (SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR) THEN
break := FALSE;
REPEAT
Section(T);
IF SCAN.tLex = lxSemi THEN
Next
ELSE
break := TRUE
END
UNTIL break
END
END ParamType;
 
PROCEDURE AddPtrBase(Name: SCAN.NODE; coord: SCAN.TCoord; T: pTYPE);
VAR nov: PTRBASE;
BEGIN
NEW(nov);
MemErr(nov = NIL);
nov.Name := Name;
nov.coord := coord;
nov.Ptr := T;
UTILS.Push(PtrBases, nov)
END AddPtrBase;
 
PROCEDURE FormalList(T: pTYPE; VAR Res: pTYPE);
VAR coord: SCAN.TCoord;
BEGIN
IF SCAN.tLex = lxLRound THEN
Next;
ParamType(T);
Check(lxRRound);
Next;
IF SCAN.tLex = lxColon THEN
NextCheck(lxIDENT);
Res := IdType(coord);
Assert(Res # NIL, coord, 42);
Assert(~(Res.tType IN TSTRUCT), coord, 82)
END
END
END FormalList;
 
PROCEDURE CallFlag(VAR Call: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
res := SCAN.tLex = lxLSquare;
IF res THEN
Next;
IF SCAN.Lex = "cdecl" THEN
Call := cdecl
ELSIF SCAN.Lex = "stdcall" THEN
Call := stdcall
ELSIF SCAN.Lex = "winapi" THEN
Assert2(winplatf, 50);
Call := winapi
ELSE
Assert2(FALSE, 44)
END;
NextCheck(lxRSquare);
Next;
ELSE
Call := defcall
END
RETURN res
END CallFlag;
 
PROCEDURE RecFlag(VAR rec: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
res := SCAN.tLex = lxLSquare;
IF res THEN
Next;
IF SCAN.Lex = "union" THEN
rec := union
ELSIF SCAN.Lex = "noalign" THEN
rec := noalign
ELSE
Assert2(FALSE, 103)
END;
NextCheck(lxRSquare);
Next;
ELSE
rec := record
END
RETURN res
END RecFlag;
 
PROCEDURE StructType(Comma: BOOLEAN; NewType: pTYPE): pTYPE;
VAR v: LONGREAL; T, nov: pTYPE; coord, coord2: SCAN.TCoord; id_T: BOOLEAN;
BEGIN
CASE SCAN.tLex OF
|lxARRAY, lxComma:
IF SCAN.tLex = lxComma THEN
Assert2(Comma, 39)
END;
NextCoord(coord);
ConstExpr(v, T);
Assert(T.tType = TINTEGER, coord, 52);
Assert(v > 0.0D0, coord, 78);
nov := CreateType(TARRAY, FLOOR(v), 0, 0, NIL, FALSE, NewType);
IF SCAN.tLex = lxComma THEN
nov.Base := StructType(TRUE, NIL)
ELSIF SCAN.tLex = lxOF THEN
NextCoord(coord);
id_T := SCAN.tLex = lxIDENT;
nov.Base := pParseType(coord);
Assert(nov.Base # NIL, coord, 42);
Assert(notrecurs(id_T, nov.Base), coord, 96)
ELSE
Assert2(FALSE, 79)
END;
Assert2(nov.Base.Size <= SCAN.maxINT DIV nov.Len, 83);
nov.Size := nov.Base.Size * nov.Len;
nov.Align := nov.Base.Align
|lxRECORD:
NextCoord(coord);
INC(RecCount);
nov := CreateType(TRECORD, 0, 0, RecCount, NIL, TRUE, NewType);
nov.Align := 1;
IF RecFlag(nov.Rec) THEN
Assert(unit.sys, coord, 111)
END;
Coord(coord);
IF SCAN.tLex = lxLRound THEN
NextCoord(coord2);
Check(lxIDENT);
nov.Base := IdType(coord);
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(notrecurs(TRUE, nov.Base), coord, 96);
nov.Size := nov.Base.Size;
nov.Align := nov.Base.Align;
Check(lxRRound);
Next;
Assert(nov.Rec = record, coord, 112);
Assert(nov.Base.Rec = record, coord2, 113)
END;
ReadFields(nov);
Check(lxEND);
nov.Size := X86.Align(nov.Size, nov.Align);
IF nov.Base # NIL THEN
X86.AddRec(nov.Base.Number)
ELSE
X86.AddRec(0)
END;
Next
|lxPOINTER:
NextCheck(lxTO);
NextCoord(coord);
nov := CreateType(TPOINTER, 0, 4, 0, NIL, FALSE, NewType);
nov.Align := 4;
nov.Base := pParseType(coord);
IF nov.Base = NIL THEN
Assert(unit.typedecl, coord, 42);
AddPtrBase(NamePtrBase, coord, nov)
ELSE
Assert(nov.Base.tType = TRECORD, coord, 81)
END
|lxPROCEDURE:
NextCoord(coord);
nov := CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NewType);
IF CallFlag(nov.Call) THEN
Assert(unit.sys, coord, 111)
END;
nov.Align := 4;
FormalList(nov, nov.Base)
ELSE
Assert2(FALSE, 39)
END
RETURN nov
END StructType;
 
PROCEDURE ParseType(VAR coord: SCAN.TCoord): pTYPE;
VAR Res: pTYPE;
BEGIN
IF SCAN.tLex = lxIDENT THEN
Res := IdType(coord)
ELSE
Res := StructType(FALSE, NIL)
END
RETURN Res
END ParseType;
 
PROCEDURE PopBlock;
VAR cur: IDENT; n: INTEGER;
BEGIN
cur := unit.Idents.Last(IDENT);
n := 0;
WHILE cur.iType # IDGUARD DO
cur := cur.Prev(IDENT);
INC(n)
END;
cur := cur.Prev(IDENT);
INC(n);
unit.Idents.Count := unit.Idents.Count - n;
unit.Idents.Last := cur;
cur.Next := NIL;
DEC(unit.Level)
END PopBlock;
 
PROCEDURE LinkPtr;
VAR cur: PTRBASE; id: IDENT;
BEGIN
cur := PtrBases.First(PTRBASE);
WHILE cur # NIL DO
id := GetIdent(cur.Name);
Assert(id # NIL, cur.coord, 42);
Assert(id.T.tType = TRECORD, cur.coord, 81);
cur.Ptr.Base := id.T;
cur := cur.Next(PTRBASE)
END;
UTILS.Clear(PtrBases)
END LinkPtr;
 
PROCEDURE addproc;
VAR proc: Proc;
BEGIN
NEW(proc);
MemErr(proc = NIL);
proc.used := FALSE;
proc.Procs := UTILS.CreateList();
UTILS.Push(procs, proc);
curproc := proc
END addproc;
 
PROCEDURE DeclSeq;
VAR Value: LONGREAL; T, NewType: pTYPE; Name: SCAN.NODE; coord: SCAN.TCoord; Call: INTEGER;
Export, func: BOOLEAN; last, id: IDENT; e: EXPRESSION;
 
PROCEDURE IdentDef;
BEGIN
Name := SCAN.id;
Coord(coord);
Next;
Export := FALSE;
IF SCAN.tLex = lxMult THEN
Assert2(unit.Level = 3, 89);
Export := TRUE;
Next
END
END IdentDef;
 
BEGIN
IF SCAN.tLex = lxCONST THEN
Next;
WHILE SCAN.tLex = lxIDENT DO
IdentDef;
PushIdent(Name, coord, IDCONST, NIL, NIL, Export, 0);
last := unit.Idents.Last(IDENT);
Check(lxEQ);
Next;
ConstExpr(Value, T);
Check(lxSemi);
last.Value := Value;
last.T := T;
Next
END
END;
IF SCAN.tLex = lxTYPE THEN
UTILS.Clear(PtrBases);
unit.typedecl := TRUE;
Next;
WHILE SCAN.tLex = lxIDENT DO
IdentDef;
PushIdent(Name, coord, IDTYPE, NIL, NIL, Export, 0);
last := unit.Idents.Last(IDENT);
Check(lxEQ);
Next;
 
IF SCAN.tLex = lxIDENT THEN
last.T := ParseType(coord)
ELSE
NEW(NewType);
MemErr(NewType = NIL);
last.T := NewType;
T := StructType(FALSE, NewType)
END;
 
Check(lxSemi);
Next
END
END;
LinkPtr;
unit.typedecl := FALSE;
IF SCAN.tLex = lxVAR THEN
Next;
WHILE SCAN.tLex = lxIDENT DO
IdentDef;
PushIdent(Name, coord, IDVAR, NIL, NIL, Export, 0);
IF SCAN.tLex = lxComma THEN
NextCheck(lxIDENT)
ELSIF SCAN.tLex = lxColon THEN
NextCoord(coord);
T := ParseType(coord);
Assert(T # NIL, coord, 42);
SetVars(T);
Check(lxSemi);
Next
ELSE
Assert2(FALSE, 85)
END
END
END;
WHILE SCAN.tLex = lxPROCEDURE DO
NextCoord(coord);
IF CallFlag(Call) THEN
Assert(unit.Level = 3, coord, 45);
Assert(unit.sys, coord, 111)
END;
Check(lxIDENT);
IdentDef;
PushIdent(Name, coord, IDPROC, CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NIL), NIL, Export, 0);
id := unit.Idents.Last(IDENT);
addproc;
id.Proc := curproc;
IF id.Export & main THEN
IF Platform IN {1, 6} THEN
curproc.used := TRUE;
Assert((Name # SCAN._START) & (Name # SCAN._version), coord, 133)
END;
X86.ProcExport(id.Number, Name, X86.NewLabel())
END;
id.Parent := curBlock;
curBlock := id;
Guard;
FormalList(NIL, curBlock.T.Base);
id.T.Call := Call;
Check(lxSemi);
Next;
DeclSeq;
id.LocalSize := id.VarSize - id.ParamSize;
X86.Label(X86.NewLabel());
curproc.beg := X86.current;
X86.ProcBeg(id.Number, id.LocalSize, FALSE);
IF SCAN.tLex = lxBEGIN THEN
Next;
OpSeq
END;
func := curBlock.T.Base.tType # TVOID;
IF func THEN
Check(lxRETURN);
UTILS.UnitLine(UnitNumber, SCAN.coord.line);
NextCoord(coord);
Expr(e);
Assert(AssComp(e, curBlock.T.Base, FALSE), coord, 125);
IF e.eType = eVAR THEN
X86.Load(e.T.tType)
END
ELSE
Assert2(SCAN.tLex # lxRETURN, 123)
END;
Check(lxEND);
NextCheck(lxIDENT);
Assert2(SCAN.id = Name, 87);
NextCheck(lxSemi);
Next;
X86.ProcEnd(id.Number, (id.ParamSize + (id.Level - 3) * 4) * ORD(curBlock.T.Call IN {stdcall, winapi, defcall}), func, curBlock.T.Base.tType IN TFLOAT);
X86.Label(X86.NewLabel());
curproc.end := X86.current;
PopBlock;
curBlock := curBlock.Parent;
curproc := curBlock.Proc(Proc);
END
END DeclSeq;
 
PROCEDURE Rtl(u: UNIT);
 
PROCEDURE AddProc(name: UTILS.STRING; num: INTEGER);
VAR id: IDENT;
BEGIN
id := GetQIdent(u, SCAN.AddNode(name));
id.Proc(Proc).used := TRUE;
IF id = NIL THEN
UTILS.ErrMsg(158);
UTILS.HALT(1)
END;
X86.AddRtlProc(num, id.Number)
END AddProc;
 
BEGIN
AddProc("_newrec", X86._newrec);
AddProc("_disprec", X86._disprec);
AddProc("_rset", X86._rset);
AddProc("_inset", X86._inset);
AddProc("_saverec", X86._saverec);
AddProc("_checktype", X86._checktype);
AddProc("_strcmp", X86._strcmp);
AddProc("_lstrcmp", X86._lstrcmp);
AddProc("_rstrcmp", X86._rstrcmp);
AddProc("_savearr", X86._savearr);
AddProc("_arrayidx", X86._arrayidx);
AddProc("_arrayidx1", X86._arrayidx1);
AddProc("_arrayrot", X86._arrayrot);
AddProc("_assrt", X86._assrt);
AddProc("_strcopy", X86._strcopy);
AddProc("_init", X86._init);
AddProc("_close", X86._close);
AddProc("_halt", X86._halt);
AddProc("_length", X86._length);
END Rtl;
 
PROCEDURE ImportList;
VAR cond: INTEGER; coord, namecoord: SCAN.TCoord;
name, alias: SCAN.NODE; u, self: UNIT;
FName: UTILS.STRING;
 
PROCEDURE AddUnit(newcond: INTEGER);
VAR str: STRITEM;
BEGIN
u := GetModule(name);
IF u = NIL THEN
self := unit;
SCAN.Backup(unit.scanner);
COPY(name.Name, FName);
IF ~((~self.Std & pReadModule(Path, FName, UTILS.Ext)) OR pReadModule(Std, FName, UTILS.Ext)) THEN
IF FName = "SYSTEM" THEN
unit := sys;
self.sys := TRUE
ELSE
Assert(FALSE, namecoord, 32)
END
END;
SCAN.Recover(self.scanner);
u := unit;
unit := self;
UTILS.SetFile(unit.File)
ELSE
Assert(u.Closed, namecoord, 31)
END;
PushIdent(alias, coord, IDMOD, voidtype, u, FALSE, 0);
NEW(str);
MemErr(str = NIL);
str.Str := name.Name;
UTILS.Push(unit.Import, str);
cond := newcond
END AddUnit;
 
BEGIN
cond := 0;
WHILE cond # 4 DO
Next;
CASE cond OF
|0: Check(lxIDENT);
name := SCAN.id;
Coord(coord);
Coord(namecoord);
alias := name;
cond := 1
|1: CASE SCAN.tLex OF
|lxComma: AddUnit(0)
|lxSemi: AddUnit(4); Next
|lxAssign: cond := 2
ELSE
Assert2(FALSE, 28)
END
|2: Check(lxIDENT);
name := SCAN.id;
Coord(namecoord);
cond := 3
|3: CASE SCAN.tLex OF
|lxComma: AddUnit(0)
|lxSemi: AddUnit(4); Next
ELSE
Assert2(FALSE, 29)
END
ELSE
END
END
END ImportList;
 
PROCEDURE Header(Name: SCAN.NODE);
BEGIN
NEW(unit);
MemErr(unit = NIL);
unit.Idents := UTILS.CreateList();
unit.Level := 0;
unit.Name := Name;
Guard; Guard;
PushIdent(unit.Name, zcoord, IDMOD, voidtype, unit, FALSE, 0);
Guard;
unit.IdentBegin := unit.Idents.Last(IDENT);
unit.Closed := TRUE
END Header;
 
PROCEDURE Pseudo;
VAR temp: UNIT;
BEGIN
temp := unit;
Header(SCAN.AddNode("SYSTEM"));
PushSysProc("ADR", sysADR);
PushSysProc("SIZE", sysSIZE);
PushSysProc("TYPEID", sysTYPEID);
PushSysProc("GET", sysGET);
PushSysProc("PUT", sysPUT);
PushSysProc("CODE", sysCODE);
PushSysProc("MOVE", sysMOVE);
PushSysProc("COPY", sysCOPY);
PushSysProc("INF", sysINF);
PushSysType("CARD16", TCARD16);
sys := unit;
unit := temp
END Pseudo;
 
PROCEDURE ReadModule(Path, Name1, Ext: UTILS.STRING): BOOLEAN;
VAR FHandle: INTEGER; name, Name, b: UTILS.STRING; idmod: IDENT; Res, temp: BOOLEAN; coord: SCAN.TCoord;
BEGIN
Res := FALSE;
name := Name1;
Name := Name1;
b := Path;
UTILS.concat(b, Name);
Name := b;
UTILS.concat(Name, Ext);
 
IF SCAN.Open(Name, FHandle) THEN
NEW(unit);
MemErr(unit = NIL);
unit.sys := FALSE;
unit.Std := Path = Std;
UTILS.Push(prog, unit);
unit.Idents := UTILS.CreateList();
unit.Import := UTILS.CreateList();
NEW(unit.scanner);
MemErr(unit.scanner = NIL);
unit.Closed := FALSE;
unit.Level := 0;
unit.typedecl := FALSE;
COPY(Name, unit.File);
UTILS.SetFile(unit.File);
StIdent;
NextCheck(lxMODULE);
NextCheck(lxIDENT);
Assert2(UTILS.streq(SCAN.id.Name, name), 33);
unit.Name := SCAN.id;
coord := SCAN.coord;
PushIdent(unit.Name, coord, IDMOD, voidtype, unit, FALSE, 0);
idmod := unit.Idents.Last(IDENT);
Guard;
NextCheck(lxSemi);
Next;
IF SCAN.tLex = lxIMPORT THEN
temp := main;
main := FALSE;
ImportList;
main := temp
END;
UTILS.OutString("compiling "); UTILS.OutString(unit.Name.Name); UTILS.Ln;
X86.Module(idmod.Name.Name, idmod.Number);
UnitNumber := idmod.Number;
unit.IdentBegin := unit.Idents.Last(IDENT);
curBlock := idmod;
DeclSeq;
X86.ProcBeg(idmod.Number, 0, TRUE);
IF SCAN.tLex = lxBEGIN THEN
addproc;
curproc.used := TRUE;
Next;
OpSeq
END;
Check(lxEND);
NextCheck(lxIDENT);
Assert2(SCAN.id = unit.Name, 26);
NextCheck(lxDot);
X86.Leave;
unit.Closed := TRUE;
UTILS.Clear(unit.Import);
Res := TRUE
END
RETURN Res
END ReadModule;
 
PROCEDURE Program*(StdPath, FilePath, NameFile, ExtFile: UTILS.STRING; windows: BOOLEAN;
OpSeqProc: opPROC; ExprProc: expPROC; AssCompProc: assPROC; VAR stypes: stTYPES);
BEGIN
winplatf := windows;
Path := FilePath;
Main := NameFile;
ExtMain := ExtFile;
Std := StdPath;
OpSeq := OpSeqProc;
Expr := ExprProc;
AssComp := AssCompProc;
prog := UTILS.CreateList();
PtrBases := UTILS.CreateList();
types := UTILS.CreateList();
procs := UTILS.CreateList();
StTypes;
voidtype := sttypes[TVOID];
Strings := UTILS.CreateList();
Pseudo;
stypes := sttypes
END Program;
 
PROCEDURE delfirstchar(VAR s: UTILS.STRING);
VAR i: INTEGER;
BEGIN
FOR i := 0 TO LENGTH(s) - 1 DO
s[i] := s[i + 1]
END
END delfirstchar;
 
PROCEDURE DelProcs;
VAR cur: Proc;
 
PROCEDURE ProcHandling(proc: Proc);
VAR cur: IDENT; p: Proc;
BEGIN
proc.used := TRUE;
cur := proc.Procs.First(IDENT);
WHILE cur # NIL DO
p := cur.Proc(Proc);
IF ~p.used THEN
ProcHandling(p)
END;
cur := cur.Next(IDENT)
END;
END ProcHandling;
 
BEGIN
cur := procs.First(Proc);
WHILE cur # NIL DO
IF cur.used THEN
ProcHandling(cur)
END;
cur := cur.Next(Proc)
END;
cur := procs.First(Proc);
WHILE cur # NIL DO
IF ~cur.used THEN
X86.DelProc(cur.beg, cur.end)
END;
cur := cur.Next(Proc)
END
END DelProcs;
 
PROCEDURE Compile*(platform, stksize: INTEGER);
VAR full, path, name, ext, temp, path2: UTILS.STRING;
BEGIN
Platform := platform;
main := FALSE;
IF ReadModule(Path, "RTL", UTILS.Ext) OR ReadModule(Std, "RTL", UTILS.Ext) THEN
Rtl(unit)
ELSE
UTILS.ErrMsg(65);
UTILS.HALT(1)
END;
main := TRUE;
IF ~ReadModule(Path, Main, ExtMain) THEN
path2 := Path;
UTILS.ParamStr(full, 0);
UTILS.Split(full, path, name, ext);
IF path[0] # 0X THEN
path[LENGTH(path) - 1] := 0X
END;
IF Path[0] = UTILS.Slash THEN
delfirstchar(Path)
END;
UTILS.concat(path, UTILS.Slash);
full := path;
UTILS.concat(full, Path);
Path := full;
IF (UTILS.OS = "WIN") & (Path[0] = UTILS.Slash) THEN
delfirstchar(Path)
END;
IF ~ReadModule(Path, Main, ExtMain) THEN
UTILS.ErrMsg(64);
UTILS.OutString(path2);
UTILS.OutString(Main);
UTILS.OutString(ExtMain);
UTILS.Ln;
UTILS.HALT(1)
END
END;
temp := Path;
UTILS.concat(temp, Main);
IF platform IN {2, 3} THEN
UTILS.concat(temp, ".exe")
ELSIF platform = 1 THEN
UTILS.concat(temp, ".dll")
ELSIF platform = 4 THEN
UTILS.concat(temp, ".kex")
ELSIF platform = 6 THEN
UTILS.concat(temp, ".obj")
END;
IF platform IN {1, 2, 3, 4} THEN
stksize := stksize * 100000H
END;
DelProcs;
X86.Epilog(ProgSize, temp, stksize)
END Compile;
 
BEGIN
pParseType := ParseType;
pReadModule := ReadModule;
zcoord.line := 0;
zcoord.col := 0
END DECL.
/programs/develop/oberon07/Source/ERRORS.ob07
1,171 → 1,285
(*
BSD 2-Clause License
(*
Copyright 2016, 2017 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This file is part of Compiler.
 
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
Compiler 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 General Public License for more details.
 
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE ERRORS;
 
IMPORT C := CONSOLE, UTILS;
IMPORT H := HOST;
 
TYPE
 
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;
STRING = ARRAY 1024 OF CHAR;
 
CP = ARRAY 256 OF INTEGER;
 
PROCEDURE errormsg* (fname: ARRAY OF CHAR; line, col, errno: INTEGER);
VAR
str: ARRAY 80 OF CHAR;
 
cp: CP;
 
 
PROCEDURE utf8(code: INTEGER; VAR uchar: STRING);
BEGIN
C.Ln;
C.String(" error ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
uchar[0] := 0X;
IF code < 80H THEN
uchar[0] := CHR(code);
uchar[1] := 0X
ELSIF code < 800H THEN
uchar[1] := CHR(ROR(LSL(code, 26), 26) + 80H);
uchar[0] := CHR(ASR(code, 6) + 0C0H);
uchar[2] := 0X
ELSIF code < 10000H THEN
uchar[2] := CHR(ROR(LSL(code, 26), 26) + 80H);
code := ASR(code, 6);
uchar[1] := CHR(ROR(LSL(code, 26), 26) + 80H);
uchar[0] := CHR(ASR(code, 6) + 0E0H);
uchar[3] := 0X
(*
ELSIF code < 200000H THEN
ELSIF code < 4000000H THEN
ELSE *)
END
END utf8;
 
CASE errno OF
| 1: str := "missing 'H' or 'X'"
| 2: str := "missing scale"
| 3: str := "unclosed string"
| 4: str := "illegal character"
| 5: str := "string too long"
| 6: str := "identifier too long"
| 7: str := "number too long"
| 8..12: str := "number too large"
PROCEDURE InitCP(VAR cp: CP);
VAR i: INTEGER;
BEGIN
FOR i := 0H TO 7FH DO
cp[i] := i
END
END InitCP;
 
| 21: str := "'MODULE' expected"
| 22: str := "identifier expected"
| 23: str := "module name does not match file name"
| 24: str := "';' expected"
| 25: str := "identifier does not match module name"
| 26: str := "'.' expected"
| 27: str := "'END' expected"
| 28: str := "',', ';' or ':=' expected"
| 29: str := "module not found"
| 30: str := "multiply defined identifier"
| 31: str := "recursive import"
| 32: str := "'=' expected"
| 33: str := "')' expected"
| 34: str := "syntax error in expression"
| 35: str := "'}' expected"
| 36: str := "incompatible operand"
| 37: str := "incompatible operands"
| 38: str := "'RETURN' expected"
| 39: str := "integer overflow"
| 40: str := "floating point overflow"
| 41: str := "not enough floating point registers; simplify expression"
| 42: str := "out of range 0..255"
| 43: str := "expression is not an integer"
| 44: str := "out of range 0..MAXSET"
| 45: str := "division by zero"
| 46: str := "integer division by zero"
| 47: str := "'OF' or ',' expected"
| 48: str := "undeclared identifier"
| 49: str := "type expected"
| 50: str := "recursive type definition"
| 51: str := "illegal value of constant"
| 52: str := "not a record type"
| 53: str := "':' expected"
| 54: str := "need to import SYSTEM"
| 55: str := "pointer type not defined"
| 56: str := "out of range 0..MAXSET"
| 57: str := "'TO' expected"
| 58: str := "not a record type"
| 59: str := "this expression cannot be a procedure"
| 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"
| 64: str := "'(' expected"
| 65: str := "',' expected"
| 66: str := "incompatible parameter"
| 67: str := "'OF' expected"
| 68: str := "type expected"
| 69: str := "result type of procedure is not a basic type"
| 70: str := "import not supported"
| 71: str := "']' expected"
| 72: str := "expression is not BOOLEAN"
| 73: str := "not a record"
| 74: str := "undefined record field"
| 75: str := "not an array"
| 76: str := "expression is not an integer"
| 77: str := "not a pointer"
| 78: str := "type guard not allowed"
| 79: str := "not a type"
| 80: str := "not a record type"
| 81: str := "not a pointer type"
| 82: str := "type guard not allowed"
| 83: str := "index out of range"
| 84: str := "dimension too large"
| 85: str := "procedure must have level 0"
| 86: str := "not a procedure"
| 87: str := "incompatible expression (RETURN)"
| 88: str := "'THEN' expected"
| 89: str := "'DO' expected"
| 90: str := "'UNTIL' expected"
| 91: str := "incompatible assignment"
| 92: str := "procedure call of a function"
| 93: str := "not a variable"
| 94: str := "read only variable"
| 95: str := "invalid type of expression (CASE)"
| 96: str := "':=' expected"
| 97: str := "not INTEGER variable"
| 98: str := "illegal value of constant (0)"
| 99: str := "incompatible label"
|100: str := "multiply defined label"
|101: str := "too large parameter of WCHR"
|102: str := "label expected"
|103: str := "illegal value of constant"
|104: str := "type too large"
|105: str := "access to intermediate variables not allowed"
|106: str := "qualified identifier expected"
|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"
PROCEDURE Init8(VAR cp: CP; VAR n: INTEGER; a, b, c, d, e, f, g, h: INTEGER);
BEGIN
cp[n] := a; INC(n);
cp[n] := b; INC(n);
cp[n] := c; INC(n);
cp[n] := d; INC(n);
cp[n] := e; INC(n);
cp[n] := f; INC(n);
cp[n] := g; INC(n);
cp[n] := h; INC(n);
END Init8;
 
PROCEDURE InitCP866(VAR cp: CP);
VAR n, i: INTEGER;
BEGIN
FOR i := 0410H TO 043FH DO
cp[i - 0410H + 80H] := i
END;
C.StringLn(str);
C.String(" file: "); C.StringLn(fname);
UTILS.Exit(1)
END errormsg;
FOR i := 0440H TO 044FH DO
cp[i - 0440H + 0E0H] := i
END;
 
n := 0B0H;
Init8(cp, n, 2591H, 2592H, 2593H, 2502H, 2524H, 2561H, 2562H, 2556H);
Init8(cp, n, 2555H, 2563H, 2551H, 2557H, 255DH, 255CH, 255BH, 2510H);
Init8(cp, n, 2514H, 2534H, 252CH, 251CH, 2500H, 253CH, 255EH, 255FH);
Init8(cp, n, 255AH, 2554H, 2569H, 2566H, 2560H, 2550H, 256CH, 2567H);
Init8(cp, n, 2568H, 2564H, 2565H, 2559H, 2558H, 2552H, 2553H, 256BH);
Init8(cp, n, 256AH, 2518H, 250CH, 2588H, 2584H, 258CH, 2590H, 2580H);
 
PROCEDURE error1* (s1: ARRAY OF CHAR);
BEGIN
C.Ln;
C.StringLn(s1);
UTILS.Exit(1)
END error1;
n := 0F0H;
Init8(cp, n, 0401H, 0451H, 0404H, 0454H, 0407H, 0457H, 040EH, 045EH);
Init8(cp, n, 00B0H, 2219H, 00B7H, 221AH, 2116H, 00A4H, 25A0H, 00A0H);
 
InitCP(cp)
END InitCP866;
 
PROCEDURE error3* (s1, s2, s3: ARRAY OF CHAR);
PROCEDURE concat(VAR L: STRING; R: STRING);
VAR i, n, pos: INTEGER;
BEGIN
C.Ln;
C.String(s1); C.String(s2); C.StringLn(s3);
UTILS.Exit(1)
END error3;
n := LENGTH(R);
i := 0;
pos := LENGTH(L);
WHILE (i <= n) & (pos < LEN(L)) DO
L[pos] := R[i];
INC(pos);
INC(i)
END
END concat;
 
PROCEDURE Utf8(VAR str: STRING);
VAR i: INTEGER; in, out, u: STRING;
BEGIN
in := str;
out := "";
FOR i := 0 TO LENGTH(in) - 1 DO
utf8(cp[ORD(in[i])], u);
concat(out, u)
END;
str := out
END Utf8;
 
PROCEDURE error5* (s1, s2, s3, s4, s5: ARRAY OF CHAR);
PROCEDURE ErrorMsg*(code: INTEGER; VAR msg: ARRAY OF CHAR);
VAR str: STRING;
BEGIN
C.Ln;
C.String(s1); C.String(s2); C.String(s3); C.String(s4); C.StringLn(s5);
UTILS.Exit(1)
END error5;
CASE code OF
| 1: str := "®¦¨¤ « áì 'H' ¨«¨ 'X'"
| 2: str := "®¦¨¤ « áì æ¨äà "
| 3: str := "áâப  ­¥ ᮤ¥à¦¨â § ªà뢠î饩 ª ¢ë窨"
| 4: str := "­¥¤®¯ãáâ¨¬ë© á¨¬¢®«"
| 5: str := "楫®ç¨á«¥­­®¥ ¯¥à¥¯®«­¥­¨¥"
| 6: str := "᫨誮¬ ¡®«ì讥 §­ ç¥­¨¥ ᨬ¢®«ì­®© ª®­áâ ­âë"
| 7: str := "¢¥é¥á⢥­­®¥ ¯¥à¥¯®«­¥­¨¥"
| 8: str := "¯¥à¥¯®«­¥­¨¥ ¯®à浪  ¢¥é¥á⢥­­®£® ç¨á« "
| 9: str := "¢¥é¥á⢥­­®¥  ­â¨¯¥à¥¯®«­¥­¨¥"
| 10: str := "᫨誮¬ ¤«¨­­ë© ¨¤¥­â¨ä¨ª â®à"
| 11: str := "᫨誮¬ ¤«¨­­ ï áâப®¢ ï ª®­áâ ­â "
 
| 21: str := "®¦¨¤ «®áì 'MODULE'"
| 22: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à"
| 23: str := "®¦¨¤ « áì ';'"
| 24: str := "®¦¨¤ «®áì 'END'"
| 25: str := "®¦¨¤ « áì '.'"
| 26: str := "¨¤¥­â¨ä¨ª â®à ­¥ ᮢ¯ ¤ ¥â á ¨¬¥­¥¬ ¬®¤ã«ï"
| 27: str := "­¥®¦¨¤ ­­ë© ª®­¥æ ä ©« "
| 28: str := "®¦¨¤ « áì ',', ';' ¨«¨ ':='"
| 29: str := "®¦¨¤ « áì ',' ¨«¨ ';'"
| 30: str := "¨¤¥­â¨ä¨ª â®à ¯¥à¥®¯à¥¤¥«¥­"
| 31: str := "横«¨ç¥áª¨© ¨¬¯®àâ"
| 32: str := "¬®¤ã«ì ­¥ ­ ©¤¥­ ¨«¨ ®è¨¡ª  ¤®áâ㯠"
| 33: str := "¨¬ï ¬®¤ã«ï ­¥ ᮢ¯ ¤ ¥â á ¨¬¥­¥¬ ä ©«  ¬®¤ã«ï"
| 34: str := "­¥¯à ¢¨«ì­ë© ä®à¬ â áâப¨ ¬ è¨­­ëå ª®¤®¢"
| 35: str := "®¦¨¤ «®áì '='"
| 36: str := "ᨭ⠪á¨ç¥áª ï ®è¨¡ª  ¢ ¢ëà ¦¥­¨¨"
| 37: str := "®¯¥à æ¨ï ­¥ ¯à¨¬¥­¨¬ "
| 38: str := "®¦¨¤ « áì ')'"
| 39: str := "®¦¨¤ «oáì 'ARRAY', 'RECORD', 'POINTER' ¨«¨ 'PROCEDURE'"
| 40: str := "®¦¨¤ «oáì 'TO'"
| 41: str := "®¦¨¤ «oáì 'OF'"
| 42: str := "­¥®¯à¥¤¥«¥­­ë© ¨¤¥­â¨ä¨ª â®à"
| 43: str := "âॡã¥âáï ¯¥à¥¬¥­­ ï, ¯à®æ¥¤ãà  ¨«¨ áâப®¢ ï ª®­áâ ­â "
| 44: str := "®¦¨¤ «oáì 'cdecl', 'stdcall' ¨«¨ 'winapi'"
| 45: str := "ä« £ ¢ë§®¢  ­¥¤®¯ã᪠¥âáï ¤«ï «®ª «ì­ëå ¯à®æ¥¤ãà"
| 46: str := "¤¥«¥­¨¥ ­  ­ã«ì"
| 47: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨ ¨«¨ ⨯ -㪠§ â¥«ï"
| 48: str := "楫®ç¨á«¥­­®¥ ¤¥«¥­¨¥ ­  ­ã«ì"
| 49: str := "§­ ç¥­¨¥ «¥¢®£® ®¯¥à ­¤  ¢­¥ ¤¨ ¯ §®­  0..31"
| 50: str := "ä« £ [winapi] ¤®áâ㯥­ ⮫쪮 ¤«ï ¯« âä®à¬ë Windows"
| 51: str := "®¦¨¤ « áì '}'"
| 52: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  INTEGER"
| 53: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¢­¥ ¤¨ ¯ §®­  0..31"
| 54: str := "«¥¢ ï £à ­¨æ  ¤¨ ¯ §®­  ¡®«ìè¥ ¯à ¢®©"
| 55: str := "âॡã¥âáï ª®­áâ ­â  â¨¯  CHAR"
| 56: str := "®¦¨¤ « áì '('"
| 57: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ç¨á«®¢®£® ⨯ "
 
| 59: str := "­¥¤®áâ â®ç­® ¯ à ¬¥â஢"
| 60: str := "­¥¤®¯ãáâ¨¬ë© ¯ à ¬¥âà"
| 61: str := "®¦¨¤ « áì ','"
| 62: str := "âॡã¥âáï ª®­áâ ­â­®¥ ¢ëà ¦¥­¨¥"
| 63: str := "âॡã¥âáï ¯¥à¥¬¥­­ ï"
| 64: str := "ä ©« ­¥ ­ ©¤¥­ ¨«¨ ®è¨¡ª  ¤®áâ㯠"
| 65: str := "¬®¤ã«ì RTL ­¥ ­ ©¤¥­"
| 66: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  REAL ¨«¨ LONGREAL"
| 67: str := "­¥¢®§¬®¦­® ᮧ¤ âì ä ©«, ¢®§¬®¦­® ä ©« ®âªàëâ ¨«¨ ¤¨áª § é¨é¥­ ®â § ¯¨á¨"
| 68: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  CHAR, SET ¨«¨ BOOLEAN"
| 69: str := "­¥¢®§¬®¦­® § ¯¨á âì ä ©«"
| 70: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  LONGREAL"
| 71: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  REAL"
| 72: str := "­¥¤®áâ â®ç­® ¯ ¬ï⨠¤«ï § ¢¥à襭¨ï ª®¬¯¨«ï樨"
| 73: str := "¯à®æ¥¤ãà  ­¥ ¢®§¢à é îé ï १ã«ìâ â ­¥¤®¯ãá⨬  ¢ ¢ëà ¦¥­¨ïå"
| 74: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¢­¥ 楫®ç¨á«¥­­®£® ¤¨ ¯ §®­ "
| 75: str := "४ãàᨢ­®¥ ®¯à¥¤¥«¥­¨¥ ª®­áâ ­âë"
| 76: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¢­¥ ¤¨ ¯ §®­  0..255"
| 77: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ⨯ "
| 78: str := "¤«¨­  ⨯ -¬ áᨢ  ¤®«¦­  ¡ëâì ¡®«ìè¥ ­ã«ï"
| 79: str := "®¦¨¤ «®áì 'OF' ¨«¨ ','"
| 80: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨ ¨«¨ ⨯ -㪠§ â¥«ï"
| 81: str := "¡ §®¢ë© ⨯ ⨯ -㪠§ â¥«ï ¤®«¦¥­ ¡ëâì § ¯¨áìî"
| 82: str := "⨯ १ã«ìâ â  ¯à®æ¥¤ãàë ­¥ ¬®¦¥â ¡ëâì § ¯¨áìî ¨«¨ ¬ áᨢ®¬"
| 83: str := "à §¬¥à ⨯  ᫨誮¬ ¢¥«¨ª"
| 84: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ¨«¨ 'VAR'"
| 85: str := "®¦¨¤ « áì ',' ¨«¨ ':'"
| 86: str := "®¦¨¤ «®áì 'END' ¨«¨ ';'"
| 87: str := "¨¤¥­â¨ä¨ª â®à ­¥ ᮢ¯ ¤ ¥â á ¨¬¥­¥¬ ¯à®æ¥¤ãàë"
 
| 89: str := "íªá¯®àâ «®ª «ì­®£® ¨¤¥­â¨ä¨ª â®à  ­¥¤®¯ãá⨬"
| 90: str := "⨯ ARRAY ¨«¨ RECORD ­¥¤®¯ãá⨬"
| 91: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ¢¥é¥á⢥­­®£® ⨯ "
 
| 93: str := "à §¬¥à ¤ ­­ëå ᫨誮¬ ¢¥«¨ª"
| 94: str := "áâப  ¤«¨­ë, ®â«¨ç­®© ®â 1 ­¥¤®¯ãá⨬ "
| 95: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¤®«¦­® ¡ëâì ¢ ¤¨ ¯ §®­¥ 0..127"
| 96: str := "­¥¤®¯ãá⨬®¥ ४ãàᨢ­®¥ ®¯à¥¤¥«¥­¨¥ ⨯ "
| 97: str := "­¥¤®áâ â®ç­® ¢¥é¥á⢥­­ëå ॣ¨áâ஢, ã¯à®áâ¨â¥ ¢ëà ¦¥­¨¥"
| 98: str := "®¦¨¤ «®áì 'THEN'"
| 99: str := "¯®«¥ § ¯¨á¨ ­¥ ­ ©¤¥­®"
|100: str := "¬¥âª  ¤ã¡«¨à®¢ ­ "
|101: str := "¨¤¥­â¨ä¨ª â®à ⨯  ­¥¤®¯ãá⨬ ¢ ¢ëà ¦¥­¨ïå"
|102: str := "âॡã¥âáï ¬ áᨢ"
|103: str := "®¦¨¤ «oáì 'union' ¨«¨ 'noalign'"
|104: str := "âॡã¥âáï 㪠§ â¥«ì"
|105: str := "âॡã¥âáï § ¯¨áì"
|106: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨"
|107: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ⨯ -㪠§ â¥«ï"
|108: str := "­¥¤®¯ãá⨬ ï ®åà ­  ⨯ "
|109: str := "®¦¨¤ « áì ']'"
|110: str := "à §¬¥à­®áâì ®âªàë⮣® ¬ áᨢ  ᫨誮¬ ¢¥«¨ª "
|111: str := "á¨á⥬­ë¥ ä« £¨ âॡãîâ ¨¬¯®àâ  ¬®¤ã«ï SYSTEM"
|112: str := "à áè¨à¥­¨¥ § ¯¨á¨ ­¥ ¬®¦¥â ¡ëâì [noalign] ¨«¨ [union]"
|113: str := "¡ §®¢ë© ⨯ § ¯¨á¨ ­¥ ¬®¦¥â ¡ëâì [noalign] ¨«¨ [union]"
|114: str := "­¥á®¢¬¥áâ¨¬ë© ¯ à ¬¥âà"
|115: str := "¯¥à¥¬¥­­ ï ¤®áâ㯭  ⮫쪮 ¤«ï ç⥭¨ï"
|116: str := "­¥«ì§ï ¨á¯®«ì§®¢ âì «®ª «ì­ãî ¯à®æ¥¤ãàã"
|117: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  BOOLEAN"
|118: str := "®¦¨¤ «®áì 'DO'"
|119: str := "®¦¨¤ «®áì 'UNTIL'"
|120: str := "®¦¨¤ «®áì ':='"
|121: str := "à áè¨à¥­¨¥ ¨¬¥­¨ ä ©«  £« ¢­®£® ¬®¤ã«ï ¤®«¦­® ¡ëâì 'ob07'"
|122: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ­¥ ¬®¦¥â ¡ëâì à ¢­ë¬ ­ã«î"
|123: str := "'RETURN' ­¥¤®¯ãá⨬ ¢ ¯à®æ¥¤ãà¥, ­¥ ¢®§¢à é î饩 १ã«ìâ â"
|124: str := "®¦¨¤ «®áì 'RETURN'"
|125: str := "⨯ ¢ëà ¦¥­¨ï ­¥ ᮮ⢥âáâ¢ã¥â ⨯ã १ã«ìâ â  ¯à®æ¥¤ãàë"
|126: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ¯¥à¥¬¥­­®©"
|127: str := "áç¥â稪 横«  FOR ­¥ ¤®«¦¥­ ¡ëâì ¯ à ¬¥â஬"
|128: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì INTEGER"
|129: str := "¯¥à¥¬¥­­ ï ¤®«¦­  ¡ëâì «®ª «ì­®©"
|130: str := "­¥«ì§ï ¨á¯®«ì§®¢ âì ª®­áâ ­âã"
|131: str := "­¥á®¢¬¥á⨬®áâì ¯® ¯à¨á¢ ¨¢ ­¨î"
|132: str := "¢ë§®¢ ¯à®æ¥¤ãàë-ä㭪樨 ¤®¯ã᪠¥âáï ⮫쪮 ¢ á®áâ ¢¥ ¢ëà ¦¥­¨ï"
|133: str := "¨¤¥­â¨ä¨ª â®àë 'lib_init' ¨ 'version' § à¥§¥à¢¨à®¢ ­ë"
 
|138: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì SET"
 
|141: str := "âॡã¥âáï áâப  ¨«¨ ᨬ¢®«ì­ë© ¬ áᨢ"
 
|143: str := "âॡã¥âáï ᨬ¢®«ì­ë© ¬ áᨢ"
 
|145: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì POINTER"
 
|149: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì REAL ¨«¨ LONGREAL"
|150: str := "âॡã¥âáï áâப®¢ ï ª®­áâ ­â "
 
|155: str := "®¦¨¤ « áì '(' ¨«¨ ':='"
|156: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  INTEGER ¨«¨ CHAR"
|157: str := "®¦¨¤ « áì ':'"
|158: str := "­¥ ­ ©¤¥­  ¯à®æ¥¤ãà  ¢ ¬®¤ã«¥ RTL"
|159: str := "­ àã襭¨¥ £à ­¨æ ¬ áᨢ "
|160: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ª®­áâ ­âë"
|161: str := "âॡã¥âáï ª®­áâ ­â  â¨¯  INTEGER"
END;
IF H.OS = "LNX" THEN
Utf8(str)
END;
COPY(str, msg)
END ErrorMsg;
 
BEGIN
InitCP866(cp)
END ERRORS.
/programs/develop/oberon07/Source/UTILS.ob07
1,120 → 1,418
(*
BSD 2-Clause License
(*
Copyright 2016, 2017 Anton Krotov
 
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
This file is part of Compiler.
 
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
Compiler 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 General Public License for more details.
 
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE UTILS;
 
IMPORT HOST, UNIXTIME;
IMPORT sys := SYSTEM, H := HOST, ERRORS;
 
 
CONST
 
slash* = HOST.slash;
OS* = H.OS;
Slash* = H.Slash;
Ext* = ".ob07";
MAX_PATH = 1024;
MAX_PARAM = 1024;
Date* = 1509580800; (* 2017-11-02 *)
 
bit_depth* = HOST.bit_depth;
maxint* = HOST.maxint;
minint* = HOST.minint;
TYPE
OS = HOST.OS;
STRING* = ARRAY MAX_PATH OF CHAR;
 
ITEM* = POINTER TO rITEM;
 
rITEM* = RECORD
Next*, Prev*: ITEM
END;
 
LIST* = POINTER TO RECORD
First*, Last*: ITEM;
Count*: INTEGER
END;
 
STRCONST* = POINTER TO RECORD (rITEM)
Str*: STRING;
Len*, Number*: INTEGER
END;
 
VAR
 
time*: INTEGER;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
ParamCount*, Line*, Unit*: INTEGER;
FileName: STRING;
 
eol*: ARRAY 3 OF CHAR;
PROCEDURE SetFile*(F: STRING);
BEGIN
FileName := F
END SetFile;
 
maxreal*: REAL;
PROCEDURE IsInf*(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
 
PROCEDURE GetChar(adr: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(adr, res)
RETURN res
END GetChar;
 
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN HOST.FileRead(F, Buffer, bytes)
END FileRead;
PROCEDURE ParamParse(count: INTEGER);
VAR c: CHAR; cond, p: INTEGER;
 
PROCEDURE ChangeCond(A, B, C: INTEGER);
BEGIN
cond := C;
CASE c OF
|0X: cond := 6
|1X..20X: cond := A
|22X: cond := B
ELSE
END
END ChangeCond;
 
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN HOST.FileWrite(F, Buffer, bytes)
END FileWrite;
BEGIN
p := H.GetCommandLine();
cond := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END
|4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3, 5: ChangeCond(cond, 1, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
END;
INC(p)
END;
ParamCount := count - 1
END ParamParse;
 
PROCEDURE ParamStr*(VAR str: ARRAY OF CHAR; n: INTEGER);
VAR i, j, len: INTEGER; c: CHAR;
BEGIN
j := 0;
IF n <= ParamCount THEN
len := LEN(str) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
str[j] := c;
INC(j)
END;
INC(i)
END
END;
str[j] := 0X
END ParamStr;
 
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN HOST.FileCreate(FName)
END FileCreate;
PROCEDURE GetMem*(n: INTEGER): INTEGER;
RETURN H.malloc(n)
END GetMem;
 
PROCEDURE CloseF*(F: INTEGER);
BEGIN
H.CloseFile(F)
END CloseF;
 
PROCEDURE FileClose* (F: INTEGER);
PROCEDURE Read*(F, Buffer, Count: INTEGER): INTEGER;
RETURN H.FileRW(F, Buffer, Count, FALSE)
END Read;
 
PROCEDURE Write*(F, Buffer, Count: INTEGER): INTEGER;
RETURN H.FileRW(F, Buffer, Count, TRUE)
END Write;
 
PROCEDURE FileSize*(F: INTEGER): INTEGER;
RETURN H.FileSize(F)
END FileSize;
 
PROCEDURE CharC*(x: CHAR);
VAR str: ARRAY 2 OF CHAR;
BEGIN
HOST.FileClose(F)
END FileClose;
str[0] := x;
str[1] := 0X;
H.OutString(str)
END CharC;
 
PROCEDURE Int*(x: INTEGER);
VAR i: INTEGER; buf: ARRAY 11 OF INTEGER;
BEGIN
i := 0;
REPEAT
buf[i] := x MOD 10;
x := x DIV 10;
INC(i)
UNTIL x = 0;
REPEAT
DEC(i);
CharC(CHR(buf[i] + ORD("0")))
UNTIL i = 0
END Int;
 
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN HOST.FileOpen(FName)
END FileOpen;
PROCEDURE Ln*;
BEGIN
CharC(0DX);
CharC(0AX)
END Ln;
 
PROCEDURE OutString*(str: ARRAY OF CHAR);
BEGIN
H.OutString(str)
END OutString;
 
PROCEDURE GetArg* (i: INTEGER; VAR str: ARRAY OF CHAR);
PROCEDURE ErrMsg*(code: INTEGER);
VAR str: ARRAY 1024 OF CHAR;
BEGIN
HOST.GetArg(i, str)
END GetArg;
ERRORS.ErrorMsg(code, str);
OutString("error: ("); Int(code); OutString(") "); OutString(str); Ln
END ErrMsg;
 
PROCEDURE ErrMsgPos*(line, col, code: INTEGER);
VAR s: STRING;
BEGIN
ErrMsg(code);
OutString("file: "); OutString(FileName); Ln;
OutString("line: "); Int(line); Ln;
OutString("pos: "); Int(col); Ln;
END ErrMsgPos;
 
PROCEDURE Exit* (code: INTEGER);
PROCEDURE UnitLine*(newUnit, newLine: INTEGER);
BEGIN
HOST.ExitProcess(code)
END Exit;
Unit := newUnit;
Line := newLine
END UnitLine;
 
PROCEDURE Align*(n: INTEGER): INTEGER;
RETURN (4 - n MOD 4) MOD 4
END Align;
 
PROCEDURE GetTickCount* (): INTEGER;
RETURN HOST.GetTickCount()
END GetTickCount;
PROCEDURE CAP(x: CHAR): CHAR;
BEGIN
IF (x >= "a") & (x <= "z") THEN
x := CHR(ORD(x) - 32)
END
RETURN x
END CAP;
 
PROCEDURE streq*(a, b: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := -1;
REPEAT
INC(i)
UNTIL (CAP(a[i]) # CAP(b[i])) OR (a[i] = 0X) OR (b[i] = 0X)
RETURN a[i] = b[i]
END streq;
 
PROCEDURE OutChar* (c: CHAR);
PROCEDURE concat*(VAR L: STRING; R: STRING);
VAR i, n, pos: INTEGER;
BEGIN
HOST.OutChar(c)
END OutChar;
n := LENGTH(R);
i := 0;
pos := LENGTH(L);
WHILE (i <= n) & (pos < LEN(L)) DO
L[pos] := R[i];
INC(pos);
INC(i)
END
END concat;
 
PROCEDURE GetStr*(this: LIST; str: STRING): STRCONST;
VAR res: STRCONST;
BEGIN
res := this.First(STRCONST);
WHILE (res # NIL) & (res.Str # str) DO
res := res.Next(STRCONST)
END
RETURN res
END GetStr;
 
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
RETURN HOST.splitf(x, a, b)
END splitf;
PROCEDURE Push*(this: LIST; item: ITEM);
BEGIN
IF this.Count = 0 THEN
this.First := item;
item.Prev := NIL
ELSE
this.Last.Next := item;
item.Prev := this.Last
END;
INC(this.Count);
this.Last := item;
item.Next := NIL
END Push;
 
PROCEDURE Insert*(this: LIST; item, prev: ITEM);
BEGIN
IF prev # this.Last THEN
item.Next := prev.Next;
item.Prev := prev;
prev.Next := item;
item.Next.Prev := item;
INC(this.Count)
ELSE
Push(this, item)
END
END Insert;
 
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN HOST.isRelative(path)
END isRelative;
PROCEDURE Clear*(this: LIST);
BEGIN
this.First := NIL;
this.Last := NIL;
this.Count := 0
END Clear;
 
PROCEDURE Revers(VAR str: STRING);
VAR a, b: INTEGER; c: CHAR;
BEGIN
a := 0;
b := LENGTH(str) - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END
END Revers;
 
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
PROCEDURE Split*(FName: STRING; VAR Path, Name, Ext: STRING);
VAR i, j, k: INTEGER;
BEGIN
HOST.GetCurrentDirectory(path)
END GetCurrentDirectory;
i := LENGTH(FName) - 1;
j := 0;
WHILE (i >= 0) & (FName[i] # Slash) DO
Name[j] := FName[i];
DEC(i);
INC(j)
END;
Name[j] := 0X;
Revers(Name);
j := 0;
k := LENGTH(Name) - 1;
WHILE (k >= 0) & (Name[k] # ".") DO
Ext[j] := Name[k];
DEC(k);
INC(j)
END;
IF k >= 0 THEN
Name[k] := 0X;
Ext[j] := ".";
INC(j)
ELSE
j := 0
END;
Ext[j] := 0X;
Revers(Ext);
FOR j := 0 TO i DO
Path[j] := FName[j]
END;
Path[i + 1] := 0X
END Split;
 
PROCEDURE LinuxParam;
VAR p, i, str: INTEGER; c: CHAR;
BEGIN
p := H.GetCommandLine();
sys.GET(p, ParamCount);
sys.GET(p + 4, p);
FOR i := 0 TO ParamCount - 1 DO
sys.GET(p + i * 4, str);
Params[i, 0] := str;
REPEAT
sys.GET(str, c);
INC(str)
UNTIL c = 0X;
Params[i, 1] := str - 1
END;
DEC(ParamCount)
END LinuxParam;
 
PROCEDURE UnixTime* (): INTEGER;
VAR
year, month, day, hour, min, sec: INTEGER;
res: INTEGER;
PROCEDURE Time*;
VAR sec, dsec: INTEGER;
BEGIN
OutString("elapsed time ");
H.Time(sec, dsec);
sec := sec - H.sec;
dsec := dsec - H.dsec;
dsec := dsec + sec * 100;
Int(dsec DIV 100); CharC(".");
dsec := dsec MOD 100;
IF dsec < 10 THEN
Int(0)
END;
Int(dsec); OutString(" sec"); Ln
END Time;
 
PROCEDURE HALT*(n: INTEGER);
BEGIN
IF OS = "LINUX" THEN
res := HOST.UnixTime()
ELSE
HOST.now(year, month, day, hour, min, sec);
res := UNIXTIME.time(year, month, day, hour, min, sec)
Time;
H.ExitProcess(n)
END HALT;
 
PROCEDURE MemErr*(err: BOOLEAN);
BEGIN
IF err THEN
ErrMsg(72);
HALT(1)
END
END MemErr;
 
RETURN res
END UnixTime;
PROCEDURE CreateList*(): LIST;
VAR nov: LIST;
BEGIN
NEW(nov);
MemErr(nov = NIL)
RETURN nov
END CreateList;
 
PROCEDURE CreateF*(FName: ARRAY OF CHAR): INTEGER;
RETURN H.CreateFile(FName)
END CreateF;
 
PROCEDURE OpenF*(FName: ARRAY OF CHAR(*; Mode: INTEGER*)): INTEGER;
RETURN H.OpenFile(FName)
END OpenF;
 
PROCEDURE Init;
VAR p: INTEGER;
 
PROCEDURE last(VAR p: INTEGER);
BEGIN
time := GetTickCount();
COPY(HOST.eol, eol);
maxreal := 1.9;
PACK(maxreal, 1023)
WHILE GetChar(p) # 0X DO INC(p) END;
DEC(p)
END last;
 
BEGIN
H.init;
IF OS = "WIN" THEN
ParamParse(0)
ELSIF OS = "KOS" THEN
ParamParse(1);
Params[0, 0] := H.GetName();
Params[0, 1] := Params[0, 0];
last(Params[0, 1])
ELSIF OS = "LNX" THEN
LinuxParam
END
END Init;
 
BEGIN
Init
END UTILS.
/programs/develop/oberon07/Source/ELF.ob07
1,382 → 1,295
(*
BSD 2-Clause License
(*
Copyright 2016 Anton Krotov
 
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
This file is part of Compiler.
 
MODULE ELF;
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS;
Compiler 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 General Public License for more details.
 
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
 
CONST
MODULE ELF;
 
EI_NIDENT = 16;
ET_EXEC = 2;
ET_DYN = 3;
IMPORT SYSTEM;
 
EM_386 = 3;
EM_8664 = 3EH;
CONST size* = 8346;
 
ELFCLASS32 = 1;
ELFCLASS64 = 2;
 
ELFDATA2LSB = 1;
ELFDATA2MSB = 2;
 
PF_X = 1;
PF_W = 2;
PF_R = 4;
 
 
TYPE
 
Elf32_Ehdr = RECORD
 
e_ident: ARRAY EI_NIDENT OF BYTE;
 
e_type,
e_machine: WCHAR;
 
e_version,
e_entry,
e_phoff,
e_shoff,
e_flags: INTEGER;
 
e_ehsize,
e_phentsize,
e_phnum,
e_shentsize,
e_shnum,
e_shstrndx: WCHAR
 
END;
 
 
Elf32_Phdr = RECORD
 
p_type,
p_offset,
p_vaddr,
p_paddr,
p_filesz,
p_memsz,
p_flags,
p_align: INTEGER
 
END;
 
FILE = WR.FILE;
 
 
PROCEDURE align (n, _align: INTEGER): INTEGER;
PROCEDURE [stdcall] data;
BEGIN
IF n MOD _align # 0 THEN
n := n + _align - (n MOD _align)
END
SYSTEM.CODE("7F454C4601010100000000000000000002000300010000004086040834000000");
SYSTEM.CODE("A41120000000000034002000080028001D001A00060000003400000034800408");
SYSTEM.CODE("3480040800010000000100000500000004000000030000003401000034810408");
SYSTEM.CODE("3481040813000000130000000400000001000000010000000000000000800408");
SYSTEM.CODE("00800408240C1000240C10000500000000100000010000000C0F10000C9F1408");
SYSTEM.CODE("0C9F1408540110009401900C060000000010000002000000200F1000209F1408");
SYSTEM.CODE("209F1408D0000000D00000000600000004000000040000004801000048810408");
SYSTEM.CODE("488104084400000044000000040000000400000051E574640000000000000000");
SYSTEM.CODE("000000000000000000000000060000000400000052E574640C0F10000C9F1408");
SYSTEM.CODE("0C9F1408F4000000F400000004000000010000002F6C69622F6C642D6C696E75");
SYSTEM.CODE("782E736F2E320000040000001000000001000000474E55000000000002000000");
SYSTEM.CODE("060000000F000000040000001400000003000000474E55006D648AA1A4FF8A62");
SYSTEM.CODE("6855372198B3905D7B4527570300000005000000040000000700000092005000");
SYSTEM.CODE("126388F68400000080044030050000000800000013000000AEC44D0F281D8C1C");
SYSTEM.CODE("4701750FAC4BE3C086F0967C328E750F20CF09FD38F28B1C7C8B730F060204F9");
SYSTEM.CODE("16EA76FE3CAD390D665561103F7E967C7D1B760F000000000000000000000000");
SYSTEM.CODE("000000000C0000000000000000000000200000001B0000000000000000000000");
SYSTEM.CODE("20000000A20000000000000000000000120000006C0000000000000000000000");
SYSTEM.CODE("12000000360000008C85040800000000120000007900000080A0240804000000");
SYSTEM.CODE("110018009C0000001C8604080000000012000000460000000C8C140804000000");
SYSTEM.CODE("11000F00B40000007C8504080000000012000000730000009C85040800000000");
SYSTEM.CODE("1200000080000000AC85040800000000120000008E00000060A0240804000000");
SYSTEM.CODE("110018005A000000BC85040800000000120000002F000000CC85040800000000");
SYSTEM.CODE("1200000095000000FC8504080000000012000000870000000C86040800000000");
SYSTEM.CODE("120000006600000064A024080400000011001800550000002C86040800000000");
SYSTEM.CODE("1200000060000000DC8504080000000012000000006C6962646C2E736F2E3200");
SYSTEM.CODE("5F5F676D6F6E5F73746172745F5F005F4A765F5265676973746572436C617373");
SYSTEM.CODE("657300646C6F70656E00646C73796D006C6962632E736F2E36005F494F5F7374");
SYSTEM.CODE("64696E5F75736564006578697400666F70656E006674656C6C00737464696E00");
SYSTEM.CODE("7072696E746600667365656B007374646F75740066636C6F7365006D616C6C6F");
SYSTEM.CODE("630073746465727200667772697465006672656164005F5F6C6962635F737461");
SYSTEM.CODE("72745F6D61696E006672656500474C4942435F322E3100474C4942435F322E30");
SYSTEM.CODE("0000000000000000020002000300020002000100020002000400020004000500");
SYSTEM.CODE("020002000200020002000000010002000100000010000000300000001169690D");
SYSTEM.CODE("00000500B9000000100000001069690D00000300C30000000000000001000200");
SYSTEM.CODE("3C00000010000000000000001169690D00000400B9000000100000001069690D");
SYSTEM.CODE("00000200C300000000000000F09F14080601000060A02408050C000064A02408");
SYSTEM.CODE("0511000080A024080506000000A014080701000004A014080703000008A01408");
SYSTEM.CODE("070900000CA014080705000010A01408070A000014A01408070B000018A01408");
SYSTEM.CODE("070D00001CA01408070E000020A014080713000024A014080704000028A01408");
SYSTEM.CODE("070F00002CA014080710000030A014080707000034A01408071200005589E553");
SYSTEM.CODE("83EC04E8000000005B81C3CC1A10008B93FCFFFFFF85D27405E81E000000E88D");
SYSTEM.CODE("010000E878061000585BC9C3FF35F89F1408FF25FC9F140800000000FF2500A0");
SYSTEM.CODE("14086800000000E9E0FFFFFFFF2504A014086808000000E9D0FFFFFFFF2508A0");
SYSTEM.CODE("14086810000000E9C0FFFFFFFF250CA014086818000000E9B0FFFFFFFF2510A0");
SYSTEM.CODE("14086820000000E9A0FFFFFFFF2514A014086828000000E990FFFFFFFF2518A0");
SYSTEM.CODE("14086830000000E980FFFFFFFF251CA014086838000000E970FFFFFFFF2520A0");
SYSTEM.CODE("14086840000000E960FFFFFFFF2524A014086848000000E950FFFFFFFF2528A0");
SYSTEM.CODE("14086850000000E940FFFFFFFF252CA014086858000000E930FFFFFFFF2530A0");
SYSTEM.CODE("14086860000000E920FFFFFFFF2534A014086868000000E910FFFFFF00000000");
SYSTEM.CODE("31ED5E89E183E4F050545268B08B140868508B1408515668F4860408E80BFFFF");
SYSTEM.CODE("FFF490909090909090909090909090905589E55383EC04803D84A0240800753F");
SYSTEM.CODE("A188A02408BB189F140881EB149F1408C1FB0283EB0139D8731E8DB600000000");
SYSTEM.CODE("83C001A388A02408FF1485149F1408A188A0240839D872E8C60584A024080183");
SYSTEM.CODE("C4045B5DC38D7426008DBC27000000005589E583EC18A11C9F140885C07412B8");
SYSTEM.CODE("0000000085C07409C704241C9F1408FFD0C9C3905589E583E4F0565383EC38C7");
SYSTEM.CODE("44242CA0A024088B55088B44242C89108344242C048B550C8B44242C89108344");
SYSTEM.CODE("242C048B55108B44242C89108344242C04BACC8504088B44242C89108344242C");
SYSTEM.CODE("04BA8C8504088B44242C89108344242C04BA2C8604088B44242C89108344242C");
SYSTEM.CODE("04A164A0240889C28B44242C89108344242C04A180A0240889C28B44242C8910");
SYSTEM.CODE("8344242C04A160A0240889C28B44242C89108344242C04BA0C8604088B44242C");
SYSTEM.CODE("89108344242C04BA7C8504088B44242C89108344242C04BABC8504088B44242C");
SYSTEM.CODE("89108344242C04BAAC8504088B44242C89108344242C04BAFC8504088B44242C");
SYSTEM.CODE("89108344242C04BA1C8604088B44242C89108344242C04BA9C8504088B44242C");
SYSTEM.CODE("89108344242C04BADC8504088B44242C89108344242C048B35B8A02408BBF486");
SYSTEM.CODE("0408B9A0A02408BA60A01408B8108C140889742410895C240C894C2408895424");
SYSTEM.CODE("04890424E8B9FAEFFFB80000000083C4385B5E89EC5DC3909090909090909090");
SYSTEM.CODE("9090909090905589E5575653E85A00000081C39914000083EC1CE8B3F9EFFF8D");
SYSTEM.CODE("BB18FFFFFF8D8318FFFFFF29C7C1FF0285FF742431F68B4510894424088B450C");
SYSTEM.CODE("894424048B4508890424FF94B318FFFFFF83C60139FE72DE83C41C5B5E5F5DC3");
SYSTEM.CODE("8DB6000000005589E55DC38B1C24C3909090909090905589E55383EC04A10C9F");
SYSTEM.CODE("140883F8FF7413BB0C9F1408669083EB04FFD08B0383F8FF75F483C4045B5DC3");
SYSTEM.CODE("90905589E55383EC04E8000000005B81C3FC130000E86CFAEFFF595BC9C30300");
SYSTEM.CODE("00000100020025750A25750A25750A25750A0000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000FFFFFFFF00000000FFFFFFFF000000000000000001000000010000000100");
SYSTEM.CODE("00003C0000000C0000001C8504080D000000EC8B1408F5FEFF6F8C8104080500");
SYSTEM.CODE("00003483040806000000F48104080A000000CD0000000B000000100000001500");
SYSTEM.CODE("00000000000003000000F49F1408020000007000000014000000110000001700");
SYSTEM.CODE("0000AC840408110000008C84040812000000200000001300000008000000FEFF");
SYSTEM.CODE("FF6F2C840408FFFFFF6F02000000F0FFFF6F0284040800000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("00000000000000000000209F1408000000000000000062850408728504088285");
SYSTEM.CODE("040892850408A2850408B2850408C2850408D2850408E2850408F28504080286");
SYSTEM.CODE("0408128604082286040832860408000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000004743433A20285562756E74");
SYSTEM.CODE("752F4C696E61726F20342E352E322D387562756E7475342920342E352E320047");
SYSTEM.CODE("43433A20285562756E74752F4C696E61726F20342E352E322D387562756E7475");
SYSTEM.CODE("332920342E352E3200002E73796D746162002E737472746162002E7368737472");
SYSTEM.CODE("746162002E696E74657270002E6E6F74652E4142492D746167002E6E6F74652E");
SYSTEM.CODE("676E752E6275696C642D6964002E676E752E68617368002E64796E73796D002E");
SYSTEM.CODE("64796E737472002E676E752E76657273696F6E002E676E752E76657273696F6E");
SYSTEM.CODE("5F72002E72656C2E64796E002E72656C2E706C74002E696E6974002E74657874");
SYSTEM.CODE("002E66696E69002E726F64617461002E65685F6672616D65002E63746F727300");
SYSTEM.CODE("2E64746F7273002E6A6372002E64796E616D6963002E676F74002E676F742E70");
SYSTEM.CODE("6C74002E64617461002E627373002E636F6D6D656E7400000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("001B000000010000000200000034810408340100001300000000000000000000");
SYSTEM.CODE("0001000000000000002300000007000000020000004881040848010000200000");
SYSTEM.CODE("0000000000000000000400000000000000310000000700000002000000688104");
SYSTEM.CODE("0868010000240000000000000000000000040000000000000044000000F6FFFF");
SYSTEM.CODE("6F020000008C8104088C01000068000000050000000000000004000000040000");
SYSTEM.CODE("004E0000000B00000002000000F4810408F40100004001000006000000010000");
SYSTEM.CODE("0004000000100000005600000003000000020000003483040834030000CD0000");
SYSTEM.CODE("00000000000000000001000000000000005E000000FFFFFF6F02000000028404");
SYSTEM.CODE("080204000028000000050000000000000002000000020000006B000000FEFFFF");
SYSTEM.CODE("6F020000002C8404082C04000060000000060000000200000004000000000000");
SYSTEM.CODE("007A00000009000000020000008C8404088C0400002000000005000000000000");
SYSTEM.CODE("000400000008000000830000000900000002000000AC840408AC040000700000");
SYSTEM.CODE("00050000000C00000004000000080000008C00000001000000060000001C8504");
SYSTEM.CODE("081C050000300000000000000000000000040000000000000087000000010000");
SYSTEM.CODE("00060000004C8504084C050000F0000000000000000000000004000000040000");
SYSTEM.CODE("009200000001000000060000004086040840060000AC05100000000000000000");
SYSTEM.CODE("001000000000000000980000000100000006000000EC8B1408EC0B10001C0000");
SYSTEM.CODE("00000000000000000004000000000000009E0000000100000002000000088C14");
SYSTEM.CODE("08080C10001500000000000000000000000400000000000000A6000000010000");
SYSTEM.CODE("0002000000208C1408200C100004000000000000000000000004000000000000");
SYSTEM.CODE("00B000000001000000030000000C9F14080C0F10000800000000000000000000");
SYSTEM.CODE("000400000000000000B70000000100000003000000149F1408140F1000080000");
SYSTEM.CODE("0000000000000000000400000000000000BE00000001000000030000001C9F14");
SYSTEM.CODE("081C0F10000400000000000000000000000400000000000000C3000000060000");
SYSTEM.CODE("0003000000209F1408200F1000D0000000060000000000000004000000080000");
SYSTEM.CODE("00CC0000000100000003000000F09F1408F00F10000400000000000000000000");
SYSTEM.CODE("000400000004000000D10000000100000003000000F49F1408F40F1000440000");
SYSTEM.CODE("0000000000000000000400000004000000DA000000010000000300000040A014");
SYSTEM.CODE("08401010002000100000000000000000002000000000000000E0000000080000");
SYSTEM.CODE("000300000060A02408601020004000800C000000000000000020000000000000");
SYSTEM.CODE("00E5000000010000003000000000000000601020005400000000000000000000");
SYSTEM.CODE("00010000000100000011000000030000000000000000000000B4102000EE0000");
SYSTEM.CODE("0000000000000000000100000000000000010000000200000000000000000000");
SYSTEM.CODE("002C162000000500001C0000002C000000040000001000000009000000030000");
SYSTEM.CODE("0000000000000000002C1B2000F9020000000000000000000001000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000003481040800000000030001");
SYSTEM.CODE("0000000000488104080000000003000200000000006881040800000000030003");
SYSTEM.CODE("00000000008C810408000000000300040000000000F481040800000000030005");
SYSTEM.CODE("0000000000348304080000000003000600000000000284040800000000030007");
SYSTEM.CODE("00000000002C8404080000000003000800000000008C84040800000000030009");
SYSTEM.CODE("0000000000AC8404080000000003000A00000000001C8504080000000003000B");
SYSTEM.CODE("00000000004C8504080000000003000C0000000000408604080000000003000D");
SYSTEM.CODE("0000000000EC8B14080000000003000E0000000000088C14080000000003000F");
SYSTEM.CODE("0000000000208C14080000000003001000000000000C9F140800000000030011");
SYSTEM.CODE("0000000000149F14080000000003001200000000001C9F140800000000030013");
SYSTEM.CODE("0000000000209F1408000000000300140000000000F09F140800000000030015");
SYSTEM.CODE("0000000000F49F140800000000030016000000000040A0140800000000030017");
SYSTEM.CODE("000000000060A024080000000003001800000000000000000000000000030019");
SYSTEM.CODE("000100000000000000000000000400F1FF0C0000000C9F140800000000010011");
SYSTEM.CODE("001A000000149F14080000000001001200280000001C9F140800000000010013");
SYSTEM.CODE("0035000000708604080000000002000D004B00000084A0240801000000010018");
SYSTEM.CODE("005A00000088A02408040000000100180068000000D08604080000000002000D");
SYSTEM.CODE("000100000000000000000000000400F1FF74000000109F140800000000010011");
SYSTEM.CODE("0081000000208C140800000000010010008F0000001C9F140800000000010013");
SYSTEM.CODE("009B000000C08B14080000000002000D00B100000000000000000000000400F1");
SYSTEM.CODE("FFB8000000F49F14080000000001001600CE0000000C9F140800000000000011");
SYSTEM.CODE("00DF0000000C9F14080000000000001100F2000000209F140800000000010014");
SYSTEM.CODE("00FB00000040A01408000000002000170006010000B08B14080500000012000D");
SYSTEM.CODE("0016010000408604080000000012000D001D0100000000000000000000200000");
SYSTEM.CODE("002C01000000000000000000002000000040010000088C14080400000011000F");
SYSTEM.CODE("0047010000EC8B14080000000012000E004D0100000000000000000000120000");
SYSTEM.CODE("006A0100000C8C14080400000011000F00790100007C85040800000000120000");
SYSTEM.CODE("0089010000A0A024080000800C110018008E01000040A0140800000000100017");
SYSTEM.CODE("009B0100008C8504080000000012000000AC0100009C85040800000000120000");
SYSTEM.CODE("00BD010000AC8504080000000012000000CF01000060A0240804000000110018");
SYSTEM.CODE("00E1010000BC8504080000000012000000F201000044A0140800000000110217");
SYSTEM.CODE("00FF010000CC850408000000001200000011020000DC85040800000000120000");
SYSTEM.CODE("0022020000189F140800000000110212002F020000508B14085A00000012000D");
SYSTEM.CODE("003F02000000000000000000001200000051020000FC85040800000000120000");
SYSTEM.CODE("006302000060A02408000000001000F1FF6F0200000C86040800000000120000");
SYSTEM.CODE("008102000060A0140800001000110017008702000064A0240804000000110018");
SYSTEM.CODE("0098020000A0A0A414000000001000F1FF9D02000080A0240804000000110018");
SYSTEM.CODE("00AF0200001C8604080000000012000000C002000060A02408000000001000F1");
SYSTEM.CODE("FFC70200002C8604080000000012000000D7020000B58B14080000000012020D");
SYSTEM.CODE("00EE020000F48604084D04100012000D00F30200001C8504080000000012000B");
SYSTEM.CODE("000063727473747566662E63005F5F43544F525F4C4953545F5F005F5F44544F");
SYSTEM.CODE("525F4C4953545F5F005F5F4A43525F4C4953545F5F005F5F646F5F676C6F6261");
SYSTEM.CODE("6C5F64746F72735F61757800636F6D706C657465642E363135350064746F725F");
SYSTEM.CODE("6964782E36313537006672616D655F64756D6D79005F5F43544F525F454E445F");
SYSTEM.CODE("5F005F5F4652414D455F454E445F5F005F5F4A43525F454E445F5F005F5F646F");
SYSTEM.CODE("5F676C6F62616C5F63746F72735F6175780070726F672E63005F474C4F42414C");
SYSTEM.CODE("5F4F46465345545F5441424C455F005F5F696E69745F61727261795F656E6400");
SYSTEM.CODE("5F5F696E69745F61727261795F7374617274005F44594E414D49430064617461");
SYSTEM.CODE("5F7374617274005F5F6C6962635F6373755F66696E69005F7374617274005F5F");
SYSTEM.CODE("676D6F6E5F73746172745F5F005F4A765F5265676973746572436C6173736573");
SYSTEM.CODE("005F66705F6877005F66696E69005F5F6C6962635F73746172745F6D61696E40");
SYSTEM.CODE("40474C4942435F322E30005F494F5F737464696E5F7573656400667265654040");
SYSTEM.CODE("474C4942435F322E300064617461005F5F646174615F737461727400646C7379");
SYSTEM.CODE("6D4040474C4942435F322E3000667365656B4040474C4942435F322E30006663");
SYSTEM.CODE("6C6F73654040474C4942435F322E31007374646572724040474C4942435F322E");
SYSTEM.CODE("3000666F70656E4040474C4942435F322E31005F5F64736F5F68616E646C6500");
SYSTEM.CODE("646C6F70656E4040474C4942435F322E31006674656C6C4040474C4942435F32");
SYSTEM.CODE("2E30005F5F44544F525F454E445F5F005F5F6C6962635F6373755F696E697400");
SYSTEM.CODE("7072696E74664040474C4942435F322E30006677726974654040474C4942435F");
SYSTEM.CODE("322E30005F5F6273735F7374617274006D616C6C6F634040474C4942435F322E");
SYSTEM.CODE("3000696461746100737464696E4040474C4942435F322E30005F656E64007374");
SYSTEM.CODE("646F75744040474C4942435F322E300066726561644040474C4942435F322E30");
SYSTEM.CODE("005F656461746100657869744040474C4942435F322E30005F5F693638362E67");
SYSTEM.CODE("65745F70635F7468756E6B2E6278006D61696E005F696E697400");
END data;
 
RETURN n
END align;
PROCEDURE get*(): INTEGER;
RETURN SYSTEM.ADR(data) + 3
END get;
 
 
PROCEDURE Write16 (file: FILE; w: WCHAR);
BEGIN
WR.Write16LE(file, ORD(w))
END Write16;
 
 
PROCEDURE WritePH (file: FILE; ph: Elf32_Phdr);
BEGIN
WR.Write32LE(file, ph.p_type);
WR.Write32LE(file, ph.p_offset);
WR.Write32LE(file, ph.p_vaddr);
WR.Write32LE(file, ph.p_paddr);
WR.Write32LE(file, ph.p_filesz);
WR.Write32LE(file, ph.p_memsz);
WR.Write32LE(file, ph.p_flags);
WR.Write32LE(file, ph.p_align)
END WritePH;
 
 
PROCEDURE WritePH64 (file: FILE; ph: Elf32_Phdr);
BEGIN
WR.Write32LE(file, ph.p_type);
WR.Write32LE(file, ph.p_flags);
WR.Write64LE(file, ph.p_offset);
WR.Write64LE(file, ph.p_vaddr);
WR.Write64LE(file, ph.p_paddr);
WR.Write64LE(file, ph.p_filesz);
WR.Write64LE(file, ph.p_memsz);
WR.Write64LE(file, ph.p_align)
END WritePH64;
 
 
PROCEDURE fixup (program: BIN.PROGRAM; text, data, bss: INTEGER; amd64: BOOLEAN);
VAR
reloc: BIN.RELOC;
L, delta: INTEGER;
 
BEGIN
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
 
L := BIN.get32le(program.code, reloc.offset);
delta := 3 - reloc.offset - text - 7 * ORD(amd64);
 
CASE reloc.opcode OF
|BIN.PICDATA: BIN.put32le(program.code, reloc.offset, L + data + delta)
|BIN.PICCODE: BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + text + delta)
|BIN.PICBSS: BIN.put32le(program.code, reloc.offset, L + bss + delta)
END;
 
reloc := reloc.next(BIN.RELOC)
END;
END fixup;
 
 
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; amd64: BOOLEAN);
CONST
interp = 0;
dyn = 1;
header = 2;
text = 3;
data = 4;
bss = 5;
 
VAR
ehdr: Elf32_Ehdr;
phdr: ARRAY 16 OF Elf32_Phdr;
 
i, LoadAdr, offset, pad, VA: INTEGER;
 
SizeOf: RECORD header, code, data, bss: INTEGER END;
 
File: FILE;
 
str: ARRAY 40 OF CHAR; lstr: INTEGER;
Dyn: ARRAY 350 OF BYTE;
 
BEGIN
IF amd64 THEN
str := "/lib64/ld-linux-x86-64.so.2"
ELSE
str := "/lib/ld-linux.so.2"
END;
lstr := LENGTH(str);
 
IF amd64 THEN
LoadAdr := 400000H
ELSE
LoadAdr := 08048000H
END;
 
SizeOf.code := CHL.Length(program.code);
SizeOf.data := CHL.Length(program.data);
SizeOf.bss := program.bss;
 
ehdr.e_ident[0] := 7FH;
ehdr.e_ident[1] := ORD("E");
ehdr.e_ident[2] := ORD("L");
ehdr.e_ident[3] := ORD("F");
IF amd64 THEN
ehdr.e_ident[4] := ELFCLASS64
ELSE
ehdr.e_ident[4] := ELFCLASS32
END;
ehdr.e_ident[5] := ELFDATA2LSB;
ehdr.e_ident[6] := 1;
ehdr.e_ident[7] := 3;
FOR i := 8 TO EI_NIDENT - 1 DO
ehdr.e_ident[i] := 0
END;
 
ehdr.e_type := WCHR(ET_EXEC);
ehdr.e_version := 1;
ehdr.e_shoff := 0;
ehdr.e_flags := 0;
ehdr.e_shnum := WCHR(0);
ehdr.e_shstrndx := WCHR(0);
ehdr.e_phnum := WCHR(6);
 
IF amd64 THEN
ehdr.e_machine := WCHR(EM_8664);
ehdr.e_phoff := 40H;
ehdr.e_ehsize := WCHR(40H);
ehdr.e_phentsize := WCHR(38H);
ehdr.e_shentsize := WCHR(40H)
ELSE
ehdr.e_machine := WCHR(EM_386);
ehdr.e_phoff := 34H;
ehdr.e_ehsize := WCHR(34H);
ehdr.e_phentsize := WCHR(20H);
ehdr.e_shentsize := WCHR(28H)
END;
 
SizeOf.header := ORD(ehdr.e_ehsize) + ORD(ehdr.e_phentsize) * ORD(ehdr.e_phnum);
 
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_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
END;
phdr[dyn].p_flags := PF_R;
phdr[dyn].p_align := 1;
 
offset := 0;
 
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_flags := PF_R + PF_W;
phdr[header].p_align := 1000H;
offset := offset + phdr[header].p_filesz;
VA := LoadAdr + offset + 1000H;
 
phdr[text].p_type := 1;
phdr[text].p_offset := offset;
phdr[text].p_vaddr := VA;
phdr[text].p_paddr := VA;
phdr[text].p_filesz := SizeOf.code;
phdr[text].p_memsz := SizeOf.code;
phdr[text].p_flags := PF_X + PF_R;
phdr[text].p_align := 1000H;
 
ehdr.e_entry := phdr[text].p_vaddr;
offset := offset + phdr[text].p_filesz;
VA := LoadAdr + offset + 2000H;
pad := (16 - VA MOD 16) MOD 16;
 
phdr[data].p_type := 1;
phdr[data].p_offset := offset;
phdr[data].p_vaddr := VA;
phdr[data].p_paddr := VA;
phdr[data].p_filesz := SizeOf.data + pad;
phdr[data].p_memsz := SizeOf.data + pad;
phdr[data].p_flags := PF_R + PF_W;
phdr[data].p_align := 1000H;
offset := offset + phdr[data].p_filesz;
VA := LoadAdr + offset + 3000H;
 
phdr[bss].p_type := 1;
phdr[bss].p_offset := offset;
phdr[bss].p_vaddr := VA;
phdr[bss].p_paddr := VA;
phdr[bss].p_filesz := 0;
phdr[bss].p_memsz := SizeOf.bss + 16;
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);
 
File := WR.Create(FileName);
 
FOR i := 0 TO EI_NIDENT - 1 DO
WR.WriteByte(File, ehdr.e_ident[i])
END;
 
Write16(File, ehdr.e_type);
Write16(File, ehdr.e_machine);
 
WR.Write32LE(File, ehdr.e_version);
IF amd64 THEN
WR.Write64LE(File, ehdr.e_entry);
WR.Write64LE(File, ehdr.e_phoff);
WR.Write64LE(File, ehdr.e_shoff)
ELSE
WR.Write32LE(File, ehdr.e_entry);
WR.Write32LE(File, ehdr.e_phoff);
WR.Write32LE(File, ehdr.e_shoff)
END;
WR.Write32LE(File, ehdr.e_flags);
 
Write16(File, ehdr.e_ehsize);
Write16(File, ehdr.e_phentsize);
Write16(File, ehdr.e_phnum);
Write16(File, ehdr.e_shentsize);
Write16(File, ehdr.e_shnum);
Write16(File, ehdr.e_shstrndx);
 
IF amd64 THEN
WritePH64(File, phdr[interp]);
WritePH64(File, phdr[dyn]);
WritePH64(File, phdr[header]);
WritePH64(File, phdr[text]);
WritePH64(File, phdr[data]);
WritePH64(File, phdr[bss])
ELSE
WritePH(File, phdr[interp]);
WritePH(File, phdr[dyn]);
WritePH(File, phdr[header]);
WritePH(File, phdr[text]);
WritePH(File, phdr[data]);
WritePH(File, phdr[bss])
END;
 
FOR i := 0 TO lstr DO
WR.WriteByte(File, ORD(str[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")
END;
 
WR.Write(File, Dyn, i);
 
CHL.WriteToFile(File, program.code);
WHILE pad > 0 DO
WR.WriteByte(File, 0);
DEC(pad)
END;
CHL.WriteToFile(File, program.data);
WR.Close(File)
END write;
 
 
END ELF.
/programs/develop/oberon07/Source/SCAN.ob07
1,723 → 1,699
(*
BSD 2-Clause License
(*
Copyright 2016 Anton Krotov
 
Copyright (c) 2018, Anton Krotov
All rights reserved.
This file is part of Compiler.
 
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
 
Compiler 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 General Public License for more details.
 
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
 
MODULE SCAN;
 
IMPORT TEXTDRV, AVL := AVLTREES, ARITH, S := STRINGS, C := COLLECTIONS;
IMPORT UTILS, sys := SYSTEM;
 
 
CONST
 
LEXLEN = 1024;
Tab = 8;
maxINT* = 7FFFFFFFH;
minINT* = 80000000H;
maxREAL* = 3.39E38;
maxDBL* = 1.69D308;
minREAL* = 1.41E-45;
IDLENGTH = 255;
STRLENGTH* = 256;
 
lxUNDEF* = 0; lxIDENT* = 1; lxINTEGER* = 2; lxHEX* = 3;
lxCHAR* = 4; lxFLOAT* = 5; lxSTRING* = 6; lxCOMMENT* = 7;
lxEOF* = 8;
lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7;
lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8;
lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16;
lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23;
lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30;
lxUNTIL = 31; lxVAR = 32; lxWHILE = 33;
 
lxKW = 101;
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58;
lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65;
lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
 
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;
lxERR0 = 100; lxERR1 = 101; lxERR2 = 102; lxERR3 = 103; lxERR4 = 104; lxERR5 = 105; lxERR6 = 106;
lxERR7 = 107; lxERR8 = 108; lxERR9 = 109; lxERR10 = 110; lxERR11 = 111; lxERR20 = 120;
 
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;
 
lxERROR01 = -1; lxERROR02 = -2; lxERROR03 = -3; lxERROR04 = -4;
lxERROR05 = -5; lxERROR06 = -6; lxERROR07 = -7; lxERROR08 = -8;
lxERROR09 = -9; lxERROR10 = -10; lxERROR11 = -11; lxERROR12 = -12;
 
 
TYPE
 
LEXSTR* = ARRAY LEXLEN OF CHAR;
TCoord* = RECORD line*, col*: INTEGER END;
 
IDENT* = POINTER TO RECORD (AVL.DATA)
 
s*: LEXSTR;
offset*, offsetW*: INTEGER
 
NODE* = POINTER TO RECORD
Left, Right: NODE;
tLex: INTEGER;
Name*: UTILS.STRING
END;
 
POSITION* = RECORD
 
line*, col*: INTEGER
 
SCANNER* = POINTER TO RECORD
File, ccol, cline, count, tLex, vINT: INTEGER;
coord: TCoord;
ch, vCHX: CHAR;
Lex: UTILS.STRING;
vFLT: LONGREAL;
id: NODE;
buf, bufpos: INTEGER;
CR, UTF8: BOOLEAN
END;
 
LEX* = RECORD
 
s*: LEXSTR;
length*: INTEGER;
sym*: INTEGER;
pos*: POSITION;
ident*: IDENT;
string*: IDENT;
value*: ARITH.VALUE;
error*: INTEGER;
 
over: BOOLEAN
 
END;
 
SCANNER* = POINTER TO RECORD (C.ITEM)
 
text: TEXTDRV.TEXT;
range: BOOLEAN
 
END;
 
KEYWORD = ARRAY 10 OF CHAR;
 
 
VAR
 
vocabulary: RECORD
Lex*: UTILS.STRING; File, ccol, cline, count*, tLex*, vINT*: INTEGER;
coord*: TCoord;
vFLT*: LONGREAL; id*: NODE; ch, vCHX*: CHAR;
buf, bufpos: INTEGER; CR, UTF8: BOOLEAN;
Nodes: ARRAY 256 OF NODE;
_START*, _version*: NODE;
 
KW: ARRAY 33 OF KEYWORD;
PROCEDURE AddNode*(Name: UTILS.STRING): NODE;
VAR cur, res: NODE;
 
delimiters: ARRAY 256 OF BOOLEAN;
 
idents: AVL.NODE;
ident: IDENT
 
END;
 
scanners: C.COLLECTION;
 
 
PROCEDURE nodecmp (a, b: AVL.DATA): INTEGER;
RETURN ORD(a(IDENT).s > b(IDENT).s) - ORD(a(IDENT).s < b(IDENT).s)
END nodecmp;
 
 
PROCEDURE key (VAR lex: LEX);
VAR
L, R, M: INTEGER;
 
PROCEDURE NewNode(Right: BOOLEAN);
BEGIN
L := 0;
R := LEN(vocabulary.KW) - 1;
M := (L + R) DIV 2;
 
WHILE L # M DO
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
NEW(res);
UTILS.MemErr(res = NIL);
res.Name := Name;
res.tLex := lxIDENT;
res.Left := NIL;
res.Right := NIL;
IF Right THEN
cur.Right := res
ELSE
lex.sym := lxKW + M;
L := M;
R := M
cur.Left := res
END
END;
END NewNode;
 
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
BEGIN
res := NIL;
cur := Nodes[ORD(Name[0])];
REPEAT
IF Name > cur.Name THEN
IF cur.Right # NIL THEN
cur := cur.Right
ELSE
NewNode(TRUE)
END
ELSIF Name < cur.Name THEN
IF cur.Left # NIL THEN
cur := cur.Left
ELSE
NewNode(FALSE)
END
ELSE
res := cur
END
UNTIL res # NIL
RETURN res
END AddNode;
 
END key;
PROCEDURE Backup*(scanner: SCANNER);
BEGIN
scanner.File := File;
scanner.ccol := ccol;
scanner.cline := cline;
scanner.ch := ch;
scanner.Lex := Lex;
scanner.count := count;
scanner.coord := coord;
scanner.tLex := tLex;
scanner.vINT := vINT;
scanner.vFLT := vFLT;
scanner.vCHX := vCHX;
scanner.buf := buf;
scanner.bufpos := bufpos;
scanner.CR := CR;
scanner.UTF8 := UTF8
END Backup;
 
 
PROCEDURE enterid* (s: LEXSTR): IDENT;
VAR
newnode: BOOLEAN;
node: AVL.NODE;
 
PROCEDURE Recover*(scanner: SCANNER);
BEGIN
vocabulary.ident.s := s;
vocabulary.idents := AVL.insert(vocabulary.idents, vocabulary.ident, nodecmp, newnode, node);
File := scanner.File;
ccol := scanner.ccol;
cline := scanner.cline;
ch := scanner.ch;
Lex := scanner.Lex;
count := scanner.count;
coord := scanner.coord;
tLex := scanner.tLex;
vINT := scanner.vINT;
vFLT := scanner.vFLT;
vCHX := scanner.vCHX;
buf := scanner.buf;
bufpos := scanner.bufpos;
CR := scanner.CR;
UTF8 := scanner.UTF8
END Recover;
 
IF newnode THEN
NEW(vocabulary.ident);
vocabulary.ident.offset := -1;
vocabulary.ident.offsetW := -1
END
 
RETURN node.data(IDENT)
END enterid;
 
 
PROCEDURE putchar (VAR lex: LEX; c: CHAR);
PROCEDURE Next;
VAR cr: BOOLEAN;
BEGIN
IF lex.length < LEXLEN - 1 THEN
lex.s[lex.length] := c;
INC(lex.length);
lex.s[lex.length] := 0X
cr := FALSE;
sys.GET(bufpos, ch);
INC(ccol);
CASE ch OF
|0AX: IF ~CR THEN INC(cline) END; ccol := 0
|0DX: INC(cline); ccol := 0; cr := TRUE
|09X: DEC(ccol); ccol := (ccol DIV Tab) * Tab + Tab
|80X..0BFX: IF UTF8 THEN DEC(ccol) END
ELSE
lex.over := TRUE
END
END putchar;
END;
CR := cr;
INC(bufpos)
END Next;
 
 
PROCEDURE ident (text: TEXTDRV.TEXT; VAR lex: LEX);
VAR
c: CHAR;
 
PROCEDURE Open*(FName: ARRAY OF CHAR; VAR FHandle: INTEGER): BOOLEAN;
VAR n, size: INTEGER; c: CHAR;
BEGIN
c := text.peak(text);
ASSERT(S.letter(c));
 
WHILE S.letter(c) OR S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
File := UTILS.OpenF(FName);
FHandle := File;
IF File # 0 THEN
CR := FALSE;
UTF8 := FALSE;
ccol := 0;
cline := 1;
ch := 0X;
size := UTILS.FileSize(File);
buf := UTILS.GetMem(size + 1024);
UTILS.MemErr(buf = 0);
sys.PUT(buf + size, 0X);
n := UTILS.Read(File, buf, size);
UTILS.CloseF(File);
bufpos := buf;
sys.GET(buf, c);
IF c = 0EFX THEN
sys.GET(buf + 1, c);
IF c = 0BBX THEN
sys.GET(buf + 2, c);
IF c = 0BFX THEN
INC(bufpos, 3);
UTF8 := TRUE
END
END
END;
Next
END
RETURN (File # 0) & (n = size)
END Open;
 
IF lex.over THEN
lex.sym := lxERROR06
ELSE
lex.sym := lxIDENT;
key(lex)
END;
PROCEDURE Space(ch: CHAR): BOOLEAN;
RETURN (ch <= 20X) & (ch > 0X)
END Space;
 
IF lex.sym = lxIDENT THEN
lex.ident := enterid(lex.s)
END
PROCEDURE Letter(ch: CHAR): BOOLEAN;
RETURN (ch >= "A") & (ch <= "Z") OR (ch >= "a") & (ch <= "z") OR (ch = "_")
END Letter;
 
END ident;
PROCEDURE Digit*(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END Digit;
 
PROCEDURE HexDigit*(ch: CHAR): BOOLEAN;
RETURN (ch >= "A") & (ch <= "F") OR (ch >= "0") & (ch <= "9")
END HexDigit;
 
PROCEDURE number (text: TEXTDRV.TEXT; VAR lex: LEX; VAR range: BOOLEAN);
VAR
c: CHAR;
hex: BOOLEAN;
error: INTEGER;
PROCEDURE PutChar(ch: CHAR);
BEGIN
Lex[count] := ch;
IF ch # 0X THEN
INC(count)
END
END PutChar;
 
PROCEDURE PutNext(ch: CHAR);
BEGIN
c := text.peak(text);
ASSERT(S.digit(c));
PutChar(ch);
Next
END PutNext;
 
error := 0;
 
range := FALSE;
 
lex.sym := lxINTEGER;
hex := FALSE;
 
WHILE S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
PROCEDURE Ident;
BEGIN
tLex := lxIDENT;
WHILE Letter(ch) OR Digit(ch) DO
PutNext(ch)
END;
PutChar(0X);
IF count > IDLENGTH THEN
tLex := lxERR10
END
END Ident;
 
WHILE S.hexdigit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text);
hex := TRUE
END;
 
IF c = "H" THEN
putchar(lex, c);
text.nextc(text);
lex.sym := lxHEX
 
ELSIF c = "X" THEN
putchar(lex, c);
text.nextc(text);
lex.sym := lxCHAR
 
ELSIF c = "." THEN
 
IF hex THEN
lex.sym := lxERROR01
PROCEDURE hex*(ch: CHAR): INTEGER;
VAR Res: INTEGER;
BEGIN
Res := ORD(ch);
CASE ch OF
|"0".."9": DEC(Res, ORD("0"))
|"A".."F": DEC(Res, ORD("A") - 10)
ELSE
END
RETURN Res
END hex;
 
text.nextc(text);
c := text.peak(text);
 
IF c # "." THEN
putchar(lex, ".");
lex.sym := lxFLOAT
ELSE
lex.sym := lxINTEGER;
range := TRUE
PROCEDURE StrToInt16(str: UTILS.STRING): INTEGER;
VAR i, res, n: INTEGER; flag: BOOLEAN;
BEGIN
res := 0;
i := 0;
n := 0;
WHILE str[i] = "0" DO
INC(i)
END;
 
WHILE S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
END;
 
IF c = "E" THEN
 
putchar(lex, c);
text.nextc(text);
c := text.peak(text);
IF (c = "+") OR (c = "-") THEN
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
END;
 
IF S.digit(c) THEN
WHILE S.digit(c) DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text)
END
flag := TRUE;
WHILE flag & (str[i] # "X") & (str[i] # "H") DO
INC(n);
IF n > 8 THEN
tLex := lxERR5;
flag := FALSE
ELSE
lex.sym := lxERROR02
res := LSL(res, 4) + hex(str[i]);
INC(i)
END
 
END
RETURN res
END StrToInt16;
 
PROCEDURE StrToChx(str: UTILS.STRING): CHAR;
VAR res: INTEGER;
BEGIN
res := StrToInt16(str);
IF (res < 0) OR (res > 0FFH) THEN
tLex := lxERR6;
res := 0
END
RETURN CHR(res)
END StrToChx;
 
PROCEDURE StrToInt*(str: UTILS.STRING): INTEGER;
VAR i, res: INTEGER; flag: BOOLEAN;
BEGIN
res := 0;
i := 0;
flag := TRUE;
WHILE flag & (str[i] # 0X) DO
IF res > maxINT DIV 10 THEN
tLex := lxERR5;
flag := FALSE;
res := 0
ELSE
 
IF hex THEN
lex.sym := lxERROR01
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
tLex := lxERR5;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN res
END StrToInt;
 
END;
PROCEDURE StrToFloat(str: UTILS.STRING): LONGREAL;
VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, nez: BOOLEAN;
 
IF lex.over & (lex.sym >= 0) THEN
lex.sym := lxERROR07
END;
PROCEDURE Error(e: INTEGER; VAR cont: BOOLEAN);
BEGIN
tLex := e;
res := 0.0D0;
cont := FALSE
END Error;
 
IF lex.sym = lxINTEGER THEN
ARITH.iconv(lex.s, lex.value, error)
ELSIF (lex.sym = lxHEX) OR (lex.sym = lxCHAR) THEN
ARITH.hconv(lex.s, lex.value, error)
ELSIF lex.sym = lxFLOAT THEN
ARITH.fconv(lex.s, lex.value, error)
PROCEDURE Inf(VAR cont: BOOLEAN; VAR i: INTEGER);
BEGIN
IF UTILS.IsInf(res) THEN
Error(lxERR7, cont)
END;
INC(i)
END Inf;
 
CASE error OF
|0:
|1: lex.sym := lxERROR08
|2: lex.sym := lxERROR09
|3: lex.sym := lxERROR10
|4: lex.sym := lxERROR11
|5: lex.sym := lxERROR12
PROCEDURE part1(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
res := 0.0D0;
i := 0;
d := 1.0D0;
nez := FALSE;
cont := TRUE;
WHILE cont & Digit(str[i]) DO
nez := nez OR (str[i] # "0");
res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0")));
Inf(cont, i)
END
RETURN cont
END part1;
 
END number;
PROCEDURE part2(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
INC(i);
cont := TRUE;
WHILE cont & Digit(str[i]) DO
nez := nez OR (str[i] # "0");
d := d / 10.0D0;
res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d;
Inf(cont, i)
END
RETURN cont
END part2;
 
PROCEDURE part3(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
cont := TRUE;
IF str[i] = 0X THEN
IF res > LONG(maxREAL) THEN
Error(lxERR7, cont)
ELSIF nez & ((res = 0.0D0) OR (res < LONG(minREAL)) & (tLex = lxREAL)) THEN
Error(lxERR9, cont)
END
END
RETURN cont
END part3;
 
PROCEDURE string (text: TEXTDRV.TEXT; VAR lex: LEX);
VAR
c, c1: CHAR;
n: INTEGER;
quot: CHAR;
 
PROCEDURE part4(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
quot := text.peak(text);
 
ASSERT((quot = '"') OR (quot = "'"));
 
text.nextc(text);
c := text.peak(text);
c1 := c;
n := 0;
 
WHILE (c # quot) & (c # 0X) & ~text.eol & ~text.eof DO
putchar(lex, c);
text.nextc(text);
c := text.peak(text);
INC(n)
IF str[i] = "D" THEN
tLex := lxLONGREAL
END;
 
IF c = quot THEN
text.nextc(text);
IF lex.over THEN
lex.sym := lxERROR05
INC(i);
m := 10.0D0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1D0
END;
scale := 0;
cont := TRUE;
WHILE cont & Digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
Error(lxERR8, cont)
ELSE
IF n # 1 THEN
lex.sym := lxSTRING
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
Error(lxERR8, cont)
ELSE
lex.sym := lxCHAR;
ARITH.setChar(lex.value, ORD(c1))
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
ELSE
lex.sym := lxERROR03
END
RETURN cont
END part4;
 
PROCEDURE part5(): BOOLEAN;
VAR cont: BOOLEAN; i: INTEGER;
BEGIN
cont := TRUE;
IF scale = maxINT THEN
Error(lxERR8, cont)
END;
 
IF lex.sym = lxSTRING THEN
lex.string := enterid(lex.s);
lex.value.typ := ARITH.tSTRING;
lex.value.string := lex.string
i := 1;
WHILE cont & (i <= scale) DO
res := res * m;
Inf(cont, i)
END;
IF cont & (nez & (res = 0.0D0) OR (res > 0.0D0) & (res < LONG(minREAL)) & (tLex = lxREAL)) THEN
Error(lxERR9, cont)
ELSIF cont & (tLex = lxREAL) & (res > LONG(maxREAL)) THEN
Error(lxERR7, cont)
END
RETURN cont
END part5;
 
END string;
BEGIN
IF part1() & part2() & part3() & part4() & part5() THEN END
RETURN res
END StrToFloat;
 
 
PROCEDURE comment (text: TEXTDRV.TEXT);
VAR
c: CHAR;
cond, depth: INTEGER;
 
PROCEDURE Number;
VAR nextchr: CHAR;
BEGIN
cond := 0;
depth := 1;
 
REPEAT
 
c := text.peak(text);
text.nextc(text);
 
IF c = "*" THEN
IF cond = 1 THEN
cond := 0;
INC(depth)
tLex := lxINT;
WHILE Digit(ch) DO
PutNext(ch)
END;
IF ch = "H" THEN
tLex := lxHEX
ELSIF ch = "X" THEN
tLex := lxCHX
END;
IF tLex # lxINT THEN
PutNext(ch)
ELSE
cond := 2
END
ELSIF c = ")" THEN
IF cond = 2 THEN
DEC(depth)
WHILE HexDigit(ch) DO
tLex := lxHEX;
PutNext(ch)
END;
cond := 0
ELSIF c = "(" THEN
cond := 1
IF tLex = lxHEX THEN
IF ch = "H" THEN
PutNext(ch)
ELSIF ch = "X" THEN
tLex := lxCHX;
PutNext(ch)
ELSE
cond := 0
tLex := lxERR1
END
 
UNTIL (depth = 0) OR text.eof
 
END comment;
 
 
PROCEDURE delimiter (text: TEXTDRV.TEXT; VAR lex: LEX; VAR range: BOOLEAN);
VAR
c: CHAR;
 
BEGIN
c := text.peak(text);
 
IF range THEN
ASSERT(c = ".")
ELSIF ch = "." THEN
sys.GET(bufpos, nextchr);
IF nextchr # "." THEN
tLex := lxREAL;
PutNext(ch);
WHILE Digit(ch) DO
PutNext(ch)
END;
 
putchar(lex, c);
text.nextc(text);
 
CASE c OF
|"+":
lex.sym := lxPLUS
 
|"-":
lex.sym := lxMINUS
 
|"*":
lex.sym := lxMUL
 
|"/":
lex.sym := lxSLASH;
 
IF text.peak(text) = "/" THEN
lex.sym := lxCOMMENT;
REPEAT
text.nextc(text)
UNTIL text.eol OR text.eof
END
 
|"~":
lex.sym := lxNOT
 
|"&":
lex.sym := lxAND
 
|".":
IF range THEN
 
putchar(lex, ".");
lex.sym := lxRANGE;
range := FALSE;
DEC(lex.pos.col)
 
IF (ch = "E") OR (ch = "D") THEN
PutNext(ch);
IF (ch = "+") OR (ch = "-") THEN
PutNext(ch)
END;
IF ~Digit(ch) THEN
tLex := lxERR2
ELSE
 
lex.sym := lxPOINT;
c := text.peak(text);
 
IF c = "." THEN
lex.sym := lxRANGE;
putchar(lex, c);
text.nextc(text)
WHILE Digit(ch) DO
PutNext(ch)
END
 
END
 
|",":
lex.sym := lxCOMMA
 
|";":
lex.sym := lxSEMI
 
|"|":
lex.sym := lxBAR
 
|"(":
lex.sym := lxLROUND;
c := text.peak(text);
 
IF c = "*" THEN
lex.sym := lxCOMMENT;
putchar(lex, c);
text.nextc(text);
comment(text)
END
 
|"[":
lex.sym := lxLSQUARE
 
|"{":
lex.sym := lxLCURLY
 
|"^":
lex.sym := lxCARET
 
|"=":
lex.sym := lxEQ
 
|"#":
lex.sym := lxNE
 
|"<":
lex.sym := lxLT;
c := text.peak(text);
 
IF c = "=" THEN
lex.sym := lxLE;
putchar(lex, c);
text.nextc(text)
END
 
|">":
lex.sym := lxGT;
c := text.peak(text);
 
IF c = "=" THEN
lex.sym := lxGE;
putchar(lex, c);
text.nextc(text)
END
END;
PutChar(0X)
END Number;
 
|":":
lex.sym := lxCOLON;
c := text.peak(text);
 
IF c = "=" THEN
lex.sym := lxASSIGN;
putchar(lex, c);
text.nextc(text)
PROCEDURE Delim(ch: CHAR): INTEGER;
VAR Res: INTEGER;
BEGIN
CASE ch OF
|"+": Res := lxPlus
|"-": Res := lxMinus
|"*": Res := lxMult
|"/": Res := lxSlash
|"~": Res := lxNot
|"&": Res := lxAnd
|",": Res := lxComma
|";": Res := lxSemi
|"|": Res := lxStick
|"[": Res := lxLSquare
|"{": Res := lxLCurly
|"^": Res := lxCaret
|"=": Res := lxEQ
|"#": Res := lxNE
|")": Res := lxRRound
|"]": Res := lxRSquare
|"}": Res := lxRCurly
|">": Res := lxGT
|"<": Res := lxLT
|":": Res := lxColon
ELSE
END
RETURN Res
END Delim;
 
|")":
lex.sym := lxRROUND
 
|"]":
lex.sym := lxRSQUARE
 
|"}":
lex.sym := lxRCURLY
 
END
 
END delimiter;
 
 
PROCEDURE Next* (scanner: SCANNER; VAR lex: LEX);
VAR
c: CHAR;
text: TEXTDRV.TEXT;
 
PROCEDURE Comment;
VAR c, level: INTEGER; cont: BOOLEAN;
BEGIN
text := scanner.text;
 
REPEAT
 
c := text.peak(text);
 
WHILE S.space(c) DO
text.nextc(text);
c := text.peak(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;
lex.over := FALSE;
 
IF S.letter(c) THEN
ident(text, lex)
ELSIF S.digit(c) THEN
number(text, lex, scanner.range)
ELSIF (c = '"') OR (c = "'") THEN
string(text, lex)
ELSIF vocabulary.delimiters[ORD(c)] THEN
delimiter(text, lex, scanner.range)
ELSIF c = 0X THEN
lex.sym := lxEOF;
IF text.eof THEN
INC(lex.pos.col)
END
c := 1;
level := 1;
cont := TRUE;
WHILE cont & (level > 0) DO
Next;
CASE ch OF
|"(": c := 2
|")": IF c = 3 THEN DEC(level) END; c := 1
|"*": IF c = 2 THEN INC(level); c := 1 ELSE c := 3 END
|0X : cont := FALSE
ELSE
putchar(lex, c);
text.nextc(text);
lex.sym := lxERROR04
c := 1
END;
 
IF lex.sym < 0 THEN
lex.error := -lex.sym
ELSE
lex.error := 0
END;
IF cont THEN
Next
END
END Comment;
 
UNTIL lex.sym # lxCOMMENT
 
END Next;
 
 
PROCEDURE NewScanner (): SCANNER;
VAR
scan: SCANNER;
citem: C.ITEM;
 
PROCEDURE GetLex*;
BEGIN
citem := C.pop(scanners);
IF citem = NIL THEN
NEW(scan)
WHILE Space(ch) DO
Next
END;
coord.col := ccol;
coord.line := cline;
count := 0;
CASE ch OF
|"A".."Z", "a".."z", "_":
Ident;
id := AddNode(Lex);
tLex := id.tLex;
|"0".."9":
Number;
CASE tLex OF
|lxINT: vINT := StrToInt(Lex)
|lxHEX: vINT := StrToInt16(Lex)
|lxCHX: vCHX := StrToChx(Lex)
|lxREAL: vFLT := StrToFloat(Lex)
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
|22X:
tLex := lxSTRING;
Next;
WHILE (ch # 22X) & (ch >= 20X) DO
PutNext(ch)
END;
IF ch = 22X THEN
Next
ELSE
scanner := NIL;
TEXTDRV.destroy(text)
tLex := lxERR3
END;
PutChar(0X);
INC(count);
IF count > STRLENGTH THEN
tLex := lxERR11
END
 
RETURN scanner
END open;
 
 
PROCEDURE close* (VAR scanner: SCANNER);
BEGIN
IF scanner # NIL THEN
IF scanner.text # NIL THEN
TEXTDRV.destroy(scanner.text)
|"/":
tLex := Delim(ch);
PutNext(ch);
IF ch = "/" THEN
WHILE (ch >= 20X) OR (ch = 9X) DO
PutNext(ch)
END;
 
C.push(scanners, scanner);
scanner := NIL
GetLex
END;
PutChar(0X)
|">", "<", ":":
tLex := Delim(ch);
PutNext(ch);
IF ch = "=" THEN
CASE tLex OF
|lxLT: tLex := lxLE
|lxGT: tLex := lxGE
|lxColon: tLex := lxAssign
ELSE
END;
PutNext(ch)
END;
PutChar(0X)
|".":
tLex := lxDot;
PutNext(ch);
IF ch = "." THEN
tLex := lxDbl;
PutNext(ch)
END;
PutChar(0X)
|"(":
tLex := lxLRound;
PutNext(ch);
IF ch = "*" THEN
Comment;
GetLex
END;
PutChar(0X)
|"+", "-", "*", "~", "&", ",", ";", "|",
"[", "{", "^", "=", "#", ")", "]", "}":
tLex := Delim(ch);
PutChar(ch);
PutNext(0X)
|0X:
tLex := lxEOF;
PutChar(0X)
ELSE
tLex := lxERR4
END
END close;
END GetLex;
 
 
PROCEDURE init;
VAR
i: INTEGER;
delim: ARRAY 23 OF CHAR;
 
PROCEDURE enterkw (VAR i: INTEGER; kw: KEYWORD);
PROCEDURE AddNodeKey(Name: UTILS.STRING; key: INTEGER);
VAR node: NODE;
BEGIN
vocabulary.KW[i] := kw;
INC(i)
END enterkw;
node := AddNode(Name);
node.tLex := key
END AddNodeKey;
 
PROCEDURE Init;
VAR i: INTEGER; node: NODE;
BEGIN
scanners := C.create();
 
FOR i := 0 TO 255 DO
vocabulary.delimiters[i] := FALSE
FOR i := 0 TO LEN(Nodes) - 1 DO
NEW(node);
UTILS.MemErr(node = NIL);
sys.PUT(sys.ADR(node.Name), i);
node.Left := NIL;
node.Right := NIL;
node.tLex := lxIDENT;
Nodes[i] := node
END;
_START := AddNode("lib_init");
_version := AddNode("version");
AddNodeKey("MOD", lxMOD);
AddNodeKey("ELSE", lxELSE);
AddNodeKey("RETURN", lxRETURN);
AddNodeKey("CASE", lxCASE);
AddNodeKey("IF", lxIF);
AddNodeKey("POINTER", lxPOINTER);
AddNodeKey("TYPE", lxTYPE);
AddNodeKey("BEGIN", lxBEGIN);
AddNodeKey("DIV", lxDIV);
AddNodeKey("FALSE", lxFALSE);
AddNodeKey("IN", lxIN);
AddNodeKey("NIL", lxNIL);
AddNodeKey("RECORD", lxRECORD);
AddNodeKey("TO", lxTO);
AddNodeKey("VAR", lxVAR);
AddNodeKey("ARRAY", lxARRAY);
AddNodeKey("DO", lxDO);
AddNodeKey("END", lxEND);
AddNodeKey("IS", lxIS);
AddNodeKey("OF", lxOF);
AddNodeKey("PROCEDURE", lxPROCEDURE);
AddNodeKey("THEN", lxTHEN);
AddNodeKey("WHILE", lxWHILE);
AddNodeKey("BY", lxBY);
AddNodeKey("CONST", lxCONST);
AddNodeKey("ELSIF", lxELSIF);
AddNodeKey("IMPORT", lxIMPORT);
AddNodeKey("MODULE", lxMODULE);
AddNodeKey("OR", lxOR);
AddNodeKey("REPEAT", lxREPEAT);
AddNodeKey("TRUE", lxTRUE);
AddNodeKey("UNTIL", lxUNTIL);
AddNodeKey("FOR", lxFOR)
END Init;
 
delim := "+-*/~&.,;|([{^=#<>:)]}";
 
FOR i := 0 TO LEN(delim) - 2 DO
vocabulary.delimiters[ORD(delim[i])] := TRUE
END;
 
i := 0;
enterkw(i, "ARRAY");
enterkw(i, "BEGIN");
enterkw(i, "BY");
enterkw(i, "CASE");
enterkw(i, "CONST");
enterkw(i, "DIV");
enterkw(i, "DO");
enterkw(i, "ELSE");
enterkw(i, "ELSIF");
enterkw(i, "END");
enterkw(i, "FALSE");
enterkw(i, "FOR");
enterkw(i, "IF");
enterkw(i, "IMPORT");
enterkw(i, "IN");
enterkw(i, "IS");
enterkw(i, "MOD");
enterkw(i, "MODULE");
enterkw(i, "NIL");
enterkw(i, "OF");
enterkw(i, "OR");
enterkw(i, "POINTER");
enterkw(i, "PROCEDURE");
enterkw(i, "RECORD");
enterkw(i, "REPEAT");
enterkw(i, "RETURN");
enterkw(i, "THEN");
enterkw(i, "TO");
enterkw(i, "TRUE");
enterkw(i, "TYPE");
enterkw(i, "UNTIL");
enterkw(i, "VAR");
enterkw(i, "WHILE");
 
NEW(vocabulary.ident);
vocabulary.ident.s := "";
vocabulary.ident.offset := -1;
vocabulary.ident.offsetW := -1;
vocabulary.idents := NIL
END init;
 
 
BEGIN
init
Init
END SCAN.
/programs/develop/oberon07/Samples/vector_ex.ob07
0,0 → 1,57
MODULE vector_ex;
 
IMPORT C := ConsoleLib, Out, V := Vector;
 
 
TYPE
 
STRING = ARRAY 240 OF CHAR;
 
Item = POINTER TO RECORD (V.ANYREC) inf: STRING END;
 
 
PROCEDURE add(v: V.VECTOR; s: STRING);
VAR item: Item;
BEGIN
NEW(item);
item.inf := s;
V.push(v, item)
END add;
 
 
PROCEDURE print(v: V.VECTOR; first, last: INTEGER);
VAR any : V.ANYPTR;
i : INTEGER;
BEGIN
i := first;
WHILE i <= last DO
any := V.get(v, i);
Out.String(any(Item).inf);
Out.Ln;
INC(i)
END;
END print;
 
 
PROCEDURE main;
VAR v: V.VECTOR;
BEGIN
C.open(-1, -1, -1, -1, "vector");
 
v := V.create(1024);
 
add(v, "abc");
add(v, "def");
add(v, "123");
add(v, "qwerty");
add(v, "hello");
 
print(v, 0, V.count(v) - 1);
 
C.exit(FALSE)
END main;
 
 
BEGIN
main
END vector_ex.
/programs/develop/oberon07/Samples/Dialogs.ob07
5,13 → 5,15
VAR header: ARRAY 1024 OF CHAR; back_color: INTEGER;
 
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR aux: INTEGER;
BEGIN
KOSAPI.sysfunc2(12, p)
aux := KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
 
PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER);
VAR aux: INTEGER;
BEGIN
KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext)
aux := KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext)
END DefineAndDrawWindow;
 
PROCEDURE WaitForEvent(): INTEGER;
19,13 → 21,15
END WaitForEvent;
 
PROCEDURE ExitApp;
VAR aux: INTEGER;
BEGIN
KOSAPI.sysfunc1(-1)
aux := KOSAPI.sysfunc1(-1)
END ExitApp;
 
PROCEDURE pause(t: INTEGER);
VAR aux: INTEGER;
BEGIN
KOSAPI.sysfunc2(5, t)
aux := KOSAPI.sysfunc2(5, t)
END pause;
 
PROCEDURE Buttons;
/programs/develop/oberon07/Samples/HW.ob07
3,18 → 3,21
IMPORT sys := SYSTEM, KOSAPI;
 
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR res: INTEGER;
BEGIN
KOSAPI.sysfunc2(12, p)
res := KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
 
PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER);
VAR res: INTEGER;
BEGIN
KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext)
res := KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext)
END DefineAndDrawWindow;
 
PROCEDURE WriteTextToWindow(x, y, color: INTEGER; text: ARRAY OF CHAR);
VAR res: INTEGER;
BEGIN
KOSAPI.sysfunc6(4, x * 65536 + y, color + LSL(48, 24), sys.ADR(text[0]), LENGTH(text), 0)
res := KOSAPI.sysfunc6(4, x * 65536 + y, color + LSL(48, 24), sys.ADR(text[0]), LENGTH(text), 0)
END WriteTextToWindow;
 
PROCEDURE WaitForEvent(): INTEGER;
22,8 → 25,9
END WaitForEvent;
 
PROCEDURE ExitApp;
VAR res: INTEGER;
BEGIN
KOSAPI.sysfunc1(-1)
res := KOSAPI.sysfunc1(-1)
END ExitApp;
 
PROCEDURE draw_window(header, text: ARRAY OF CHAR);
/programs/develop/oberon07/Samples/HW_con.ob07
1,8 → 1,7
MODULE HW_con;
MODULE HW_con;
 
IMPORT Out, In, Console, DateTime;
IMPORT Out, In, Console, DateTime, ConsoleLib;
 
 
PROCEDURE OutInt2(n: INTEGER);
BEGIN
ASSERT((0 <= n) & (n <= 99));
12,13 → 11,9
Out.Int(n, 0)
END OutInt2;
 
 
PROCEDURE OutMonth(n: INTEGER);
VAR
str: ARRAY 4 OF CHAR;
 
VAR str: ARRAY 4 OF CHAR;
BEGIN
 
CASE n OF
| 1: str := "jan"
| 2: str := "feb"
33,31 → 28,26
|11: str := "nov"
|12: str := "dec"
END;
 
Out.String(str)
END OutMonth;
 
 
PROCEDURE main;
VAR
Year, Month, Day, Hour, Min, Sec, Msec: INTEGER;
 
VAR Year, Month, Day, Hour, Min, Sec: INTEGER;
BEGIN
ConsoleLib.open(-1, -1, -1, -1, "Hello!");
Out.String("Hello, world!"); Out.Ln;
Console.SetColor(Console.White, Console.Red);
DateTime.Now(Year, Month, Day, Hour, Min, Sec, Msec);
Console.SetColor(Console.Yellow, Console.Blue);
DateTime.Now(Year, Month, Day, Hour, Min, Sec);
Out.Int(Year, 0); Out.Char("-");
OutMonth(Month); Out.Char("-");
OutInt2(Day); Out.Char(" ");
OutInt2(Hour); Out.Char(":");
OutInt2(Min); Out.Char(":");
OutInt2(Sec)
OutInt2(Sec);
In.Ln;
ConsoleLib.exit(TRUE)
END main;
 
 
BEGIN
Console.open;
main;
In.Ln;
Console.exit(TRUE)
main
END HW_con.
/programs/develop/oberon07/Samples/RasterW.ob07
0,0 → 1,159
MODULE RasterW;
 
IMPORT sys := SYSTEM, RW := RasterWorks, KOSAPI;
 
 
TYPE
 
TWindow = RECORD
 
Left, Top, Width, Height: INTEGER;
Color: INTEGER;
Header: ARRAY 256 OF CHAR
 
END;
 
 
VAR
 
canvas : INTEGER;
bpp32 : BOOLEAN;
 
 
PROCEDURE CreateCanvas(width, height: INTEGER; bpp32: BOOLEAN): INTEGER;
VAR canvas: INTEGER;
BEGIN
canvas := KOSAPI.malloc(width * height * (3 + ORD(bpp32)) + 8);
sys.PUT(canvas, width);
sys.PUT(canvas + 4, height)
RETURN canvas
END CreateCanvas;
 
 
PROCEDURE ClearCanvas(canvas, color: INTEGER; bpp32: BOOLEAN);
VAR data, width, height, i: INTEGER;
BEGIN
sys.GET(canvas, width);
sys.GET(canvas + 4, height);
data := canvas + 8;
IF bpp32 THEN
FOR i := 1 TO width * height DO
sys.PUT(data, color); INC(data, 4)
END
ELSE
FOR i := 1 TO width * height - 1 DO
sys.PUT(data, color); INC(data, 3)
END;
sys.MOVE(sys.ADR(color), data, 3)
END
END ClearCanvas;
 
 
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
 
 
PROCEDURE DefineAndDrawWindow(x, y, width, height, color, style, hcolor, hstyle: INTEGER; htext: ARRAY OF CHAR);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc6(0, x * 65536 + width, y * 65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), sys.ADR(htext[0]))
END DefineAndDrawWindow;
 
 
PROCEDURE WaitForEvent(): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
 
 
PROCEDURE ExitApp;
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc1(-1)
END ExitApp;
 
 
PROCEDURE DrawCanvas(canvas: INTEGER; x, y: INTEGER; bpp32: BOOLEAN);
VAR xsize, ysize, aux: INTEGER;
BEGIN
sys.GET(canvas, xsize);
sys.GET(canvas + 4, ysize);
aux := KOSAPI.sysfunc7(65, canvas + 8, xsize * 65536 + ysize, x * 65536 + y, 24 + 8 * ORD(bpp32), 0, 0)
END DrawCanvas;
 
 
PROCEDURE TextOut(canvas, x, y: INTEGER; string: ARRAY OF CHAR; color, params: INTEGER);
VAR width: INTEGER;
BEGIN
width := RW.drawText(canvas, x, y, sys.ADR(string[0]), LENGTH(string), color + 0FF000000H, params)
END TextOut;
 
 
PROCEDURE DrawText;
VAR x, y: INTEGER;
BEGIN
ClearCanvas(canvas, 00FFFFFFH, bpp32);
 
x := 0; y := 0;
 
TextOut(canvas, x, y, "font size 16", 000000FFH, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) ) );
y := y + 16;
x := x + 20;
TextOut(canvas, x, y, "font size 12", 00FF0000H, RW.params( 12, 0, RW.cp866, RW.bpp32 * ORD(bpp32) ) );
y := y + 12;
x := x + 20;
TextOut(canvas, x, y, "italic", 00808080H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.italic ) );
y := y + 16;
x := x + 20;
TextOut(canvas, x, y, "bold", 00000000H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.bold ) );
y := y + 16;
x := x + 20;
TextOut(canvas, x, y, "underline", 00000000H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.underline ) );
y := y + 16;
x := x + 20;
TextOut(canvas, x, y, "strike-through", 00000000H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.strike_through ) );
y := y + 16;
x := x + 20;
 
DrawCanvas(canvas, 10, 10, bpp32);
END DrawText;
 
 
PROCEDURE draw_window(Window: TWindow);
BEGIN
WindowRedrawStatus(1);
DefineAndDrawWindow(Window.Left, Window.Top, Window.Width, Window.Height, Window.Color, 51, 0, 0, Window.Header);
DrawText;
WindowRedrawStatus(2);
END draw_window;
 
 
PROCEDURE main;
VAR Window: TWindow;
BEGIN
 
Window.Left := 200;
Window.Top := 200;
Window.Width := 400;
Window.Height := 300;
Window.Color := 00C0C0C0H;
Window.Header := "RasterWorks";
 
bpp32 := FALSE;
canvas := CreateCanvas(Window.Width - 30, Window.Height - 50, bpp32);
 
WHILE TRUE DO
CASE WaitForEvent() OF
|1: draw_window(Window)
|3: ExitApp
ELSE
END
END
 
END main;
 
BEGIN
main
END RasterW.
/programs/develop/oberon07/Samples/kfont.ob07
0,0 → 1,175
MODULE kfont;
 
IMPORT sys := SYSTEM, kfonts, KOSAPI;
 
 
CONST
 
FileName = "/rd/1/fonts/tahoma.kf";
 
 
TYPE
 
TWindow = RECORD
 
Left, Top, Width, Height: INTEGER;
Color: INTEGER;
Header: ARRAY 256 OF CHAR
 
END;
 
 
VAR
 
canvas : INTEGER;
bpp32 : BOOLEAN;
 
Font12, Font16: kfonts.TFont;
 
 
PROCEDURE CreateCanvas(width, height: INTEGER; bpp32: BOOLEAN): INTEGER;
VAR canvas: INTEGER;
BEGIN
canvas := KOSAPI.malloc(width * height * (3 + ORD(bpp32)) + 8);
sys.PUT(canvas, width);
sys.PUT(canvas + 4, height)
RETURN canvas
END CreateCanvas;
 
 
PROCEDURE ClearCanvas(canvas, color: INTEGER; bpp32: BOOLEAN);
VAR data, width, height, i: INTEGER;
BEGIN
sys.GET(canvas, width);
sys.GET(canvas + 4, height);
data := canvas + 8;
IF bpp32 THEN
FOR i := 1 TO width * height DO
sys.PUT(data, color); INC(data, 4)
END
ELSE
FOR i := 1 TO width * height - 1 DO
sys.PUT(data, color); INC(data, 3)
END;
sys.MOVE(sys.ADR(color), data, 3)
END
END ClearCanvas;
 
 
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
 
 
PROCEDURE DefineAndDrawWindow(x, y, width, height, color, style, hcolor, hstyle: INTEGER; htext: ARRAY OF CHAR);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc6(0, x * 65536 + width, y * 65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), sys.ADR(htext[0]))
END DefineAndDrawWindow;
 
 
PROCEDURE WaitForEvent(): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
 
 
PROCEDURE ExitApp;
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc1(-1)
END ExitApp;
 
 
PROCEDURE DrawCanvas(canvas: INTEGER; x, y: INTEGER; bpp32: BOOLEAN);
VAR xsize, ysize, aux: INTEGER;
BEGIN
sys.GET(canvas, xsize);
sys.GET(canvas + 4, ysize);
aux := KOSAPI.sysfunc7(65, canvas + 8, xsize * 65536 + ysize, x * 65536 + y, 24 + 8 * ORD(bpp32), 0, 0)
END DrawCanvas;
 
 
PROCEDURE DrawText;
VAR x, y: INTEGER;
BEGIN
ClearCanvas(canvas, 00FFFFFFH, bpp32);
 
x := 0; y := 0;
 
kfonts.TextOut(Font16, canvas, x, y, sys.ADR("font size 16"), -1, 000000FFH, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing );
y := y + kfonts.TextHeight( Font16 );
x := x + 20;
 
kfonts.TextOut(Font12, canvas, x, y, sys.ADR("font size 12"), -1, 00FF0000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing );
y := y + kfonts.TextHeight( Font12 );
x := x + 20;
 
kfonts.TextOut(Font16, canvas, x, y, sys.ADR("italic"), -1, 00808080H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.italic );
y := y + kfonts.TextHeight( Font16 );
x := x + 20;
 
kfonts.TextOut(Font16, canvas, x, y, sys.ADR("bold"), -1, 00000000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.bold );
y := y + kfonts.TextHeight( Font16 );
x := x + 20;
 
kfonts.TextOut(Font16, canvas, x, y, sys.ADR("underline"), -1, 00000000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.underline );
y := y + kfonts.TextHeight( Font16 );
x := x + 20;
 
kfonts.TextOut(Font16, canvas, x, y, sys.ADR("strike-through"), -1, 00000000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.strike_through );
y := y + kfonts.TextHeight( Font16 );
x := x + 20;
 
DrawCanvas(canvas, 10, 10, bpp32);
END DrawText;
 
 
PROCEDURE draw_window(Window: TWindow);
BEGIN
WindowRedrawStatus(1);
DefineAndDrawWindow(Window.Left, Window.Top, Window.Width, Window.Height, Window.Color, 51, 0, 0, Window.Header);
DrawText;
WindowRedrawStatus(2);
END draw_window;
 
 
PROCEDURE main;
VAR Window: TWindow;
bool: BOOLEAN;
BEGIN
 
Window.Left := 200;
Window.Top := 200;
Window.Width := 400;
Window.Height := 300;
Window.Color := 00C0C0C0H;
Window.Header := "kfonts";
 
bpp32 := TRUE;
canvas := CreateCanvas(Window.Width - 30, Window.Height - 50, bpp32);
 
Font12 := kfonts.LoadFont(FileName);
IF kfonts.Enabled(Font12, 12) THEN
bool := kfonts.SetSize(Font12, 12)
END;
 
Font16 := kfonts.LoadFont(FileName);
IF kfonts.Enabled(Font16, 16) THEN
bool := kfonts.SetSize(Font16, 16)
END;
 
WHILE TRUE DO
CASE WaitForEvent() OF
|1: draw_window(Window)
|3: ExitApp
ELSE
END
END
 
END main;
 
BEGIN
main
END kfont.
/programs/develop/oberon07/Samples/lib_img.ob07
0,0 → 1,97
MODULE lib_img;
 
IMPORT sys := SYSTEM, KOSAPI, libimg, File;
 
 
TYPE
 
TWindow = RECORD
 
Left, Top, Width, Height: INTEGER;
Color: INTEGER;
Header: ARRAY 256 OF CHAR
 
END;
 
VAR
 
img, rgb, width, height: INTEGER;
 
 
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
 
 
PROCEDURE DefineAndDrawWindow(x, y, width, height, color, style, hcolor, hstyle: INTEGER; htext: ARRAY OF CHAR);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc6(0, x * 65536 + width, y * 65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), sys.ADR(htext[0]))
END DefineAndDrawWindow;
 
 
PROCEDURE WaitForEvent(): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
 
 
PROCEDURE PutImage(x, y, rgb, width, height: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc7(65, rgb + 8, width * 65536 + height, x * 65536 + y, 24, 0, 0)
END PutImage;
 
 
PROCEDURE draw_window(Window: TWindow);
BEGIN
WindowRedrawStatus(1);
DefineAndDrawWindow(Window.Left, Window.Top, Window.Width, Window.Height, Window.Color, 51, 0, 0, Window.Header);
PutImage(10, 10, rgb, width, height);
WindowRedrawStatus(2)
END draw_window;
 
 
PROCEDURE LoadImage(FName: ARRAY OF CHAR);
VAR data, size: INTEGER;
BEGIN
data := File.Load(FName, size);
IF data # 0 THEN
img := libimg.img_decode(data, size, 0);
data := KOSAPI.free(data);
IF img # 0 THEN
rgb := libimg.img_to_rgb(img);
IF rgb # 0 THEN
sys.GET(img + 4, width);
sys.GET(img + 8, height)
END
END
END
END LoadImage;
 
 
PROCEDURE main;
VAR Window: TWindow;
exit: BOOLEAN;
BEGIN
Window.Left := 200;
Window.Top := 200;
Window.Width := 400;
Window.Height := 300;
Window.Color := 00C0C0C0H;
Window.Header := "libimg";
LoadImage("/rd/1/toolbar.png");
exit := FALSE;
REPEAT
CASE WaitForEvent() OF
|1: draw_window(Window)
|3: exit := TRUE
ELSE
END
UNTIL exit
END main;
 
BEGIN
main
END lib_img.