/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> ~ < CONST MODULE UNTIL</code></p> |
<p><code> & > DIV NIL VAR</code></p> |
<p><code> . <= DO OF WHILE</code></p> |
<p><code> , >= 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 = "=" | "#" | "<" | "<=" | ">" | ">=" | 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 | "&" .</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> & 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 & 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 <= r < 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> < less</code></p> |
<p><code> <= less or equal</code></p> |
<p><code> > greater</code></p> |
<p><code> >= 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 <, <=, >, >= 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 <= and >= 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<=i) & (i<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 >= "A") & (ch <= "Z") THEN ReadIdentifier</code></p> |
<p><code> ELSIF (ch >= "0") & (ch <= "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 > 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) & (t.key # i) DO</code></p> |
<p><code> t := t.left</code></p> |
<p><code> END</code></p> |
<p><code> WHILE m > n DO m := m - n</code></p> |
<p><code> ELSIF n > 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> > 0, equivalent to |
<empty-line/> |
<p><code> v := beg; lim := end;</code></p> |
<p><code> WHILE v <= lim DO S; v := v + inc END</code></p> |
<empty-line/> |
<empty-line/>and if <emphasis>inc</emphasis> < 0 it is equivalent to |
<empty-line/> |
<p><code> v := beg; lim := end;</code></p> |
<p><code> WHILE v >= 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" <= ch) & (ch <= "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 <= x < 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>0*)</code></p> |
<p><code> BEGIN y := 0;</code></p> |
<p><code> WHILE x > 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 <= 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 <= x < 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 < 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 <= 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 = "=" | "#" | "<" | "<=" | ">" | ">=" | 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 | "&".</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. |