/programs/develop/oberon07/Compiler.kex |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
/programs/develop/oberon07/Docs/About866.txt |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Docs/Oberon07.report.fb2 |
---|
File deleted |
/programs/develop/oberon07/Docs/About1251.txt |
---|
1,53 → 1,73 |
Êîìïèëÿòîð ÿçûêà ïðîãðàììèðîâàíèÿ Oberon-07/11 äëÿ i386 |
Êîìïèëÿòîð ÿçûêà ïðîãðàììèðîâàíèÿ Oberon-07/16 äëÿ i486 |
Windows/Linux/KolibriOS. |
------------------------------------------------------------------------------ |
Ñîñòàâ ïðîãðàììû |
Ïàðàìåòðû êîìàíäíîé ñòðîêè |
1. Compiler.kex (KolibriOS) - èñïîëíÿåìûé ôàéë êîìïèëÿòîðà. |
Âõîä - òåêñòîâûå ôàéëû ìîäóëåé ñ ðàñøèðåíèåì ".ob07", êîäèðîâêà ANSI |
èëè UTF-8 ñ BOM-ñèãíàòóðîé. |
Âûõîä - èñïîëíÿåìûé ôàéë ôîðìàòà PE, ELF èëè MENUET01/MS COFF. |
Âõîä - òåêñòîâûå ôàéëû ìîäóëåé ñ ðàñøèðåíèåì ".ob07", êîäèðîâêà ANSI èëè |
UTF-8 ñ BOM-ñèãíàòóðîé. |
Âûõîä - èñïîíÿåìûé ôàéë ôîðìàòà PE32, ELF èëè MENUET01/MSCOFF. |
Ïàðàìåòðû: |
1) èìÿ ãëàâíîãî ìîäóëÿ |
2) òèï ïðèëîæåíèÿ è ïëàòôîðìà |
"con" - Windows console |
2) èìÿ ðåçóëüòèðóþùåãî ôàéëà |
3) òèï ïðèëîæåíèÿ è ïëàòôîðìà |
"console" - 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). |
"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 - îòêëþ÷èòü âñå îòêëþ÷àåìûå ïðîâåðêè. |
Íàïðèìåð: |
"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 ðåàëèçîâàí â ñîîòâåòñòâèè ñ ñèíòàêñèñîì è ñåìàíòèêîé |
äàííîãî îïåðàòîðà â ÿçûêå Oberon (Revision 1.10.90) |
4. Óñîâåðøåíñòâîâàí îïåðàòîð CASE (äîáàâëåíû êîíñòàíòíûå âûðàæåíèÿ â |
ìåòêàõ âàðèàíòîâ è íåîáÿçàòåëüíàÿ âåòêà ELSE) |
5. Ðàñøèðåí íàáîð ñòàíäàðòíûõ ïðîöåäóð |
6. Ñåìàíòèêà îõðàíû/ïðîâåðêè òèïà óòî÷íåíà äëÿ íóëåâîãî óêàçàòåëÿ |
7. Ñåìàíòèêà DIV è MOD óòî÷íåíà äëÿ îòðèöàòåëüíûõ ÷èñåë |
8. Äîáàâëåíû îäíîñòðî÷íûå êîììåíòàðèè (íà÷èíàþòñÿ ñ ïàðû ñèìâîëîâ "//") |
9. Ðàçðåøåí ýêñïîðò ïåðåìåííûõ òèïîâ ARRAY è RECORD (òîëüêî äëÿ ÷òåíèÿ) |
10. Ðàçðåøåíî íàñëåäîâàíèå îò òèïà-óêàçàòåëÿ |
11. Äîáàâëåíû ïñåâäîíèìû òèïîâ (TYPE A = B) |
9. Ðàçðåøåíî íàñëåäîâàíèå îò òèïà-óêàçàòåëÿ |
10. Äîáàâëåí ñèíòàêñèñ äëÿ èìïîðòà ïðîöåäóð èç âíåøíèõ áèáëèîòåê |
11. "Ñòðîêè" ìîæíî çàêëþ÷àòü òàêæå â îäèíî÷íûå êàâû÷êè: 'ñòðîêà' |
12. Äîáàâëåí òèï WCHAR |
------------------------------------------------------------------------------ |
Îñîáåííîñòè ðåàëèçàöèè |
57,22 → 77,36 |
Òèï Äèàïàçîí çíà÷åíèé Ðàçìåð, áàéò |
INTEGER -2147483648 .. 2147483647 4 |
REAL 1.40E-45 .. 3.34E+38 4 |
LONGREAL 4.94E-324 .. 1.70E+308 8 |
REAL 4.94E-324 .. 1.70E+308 8 |
CHAR ñèìâîë ASCII (0X .. 0FFX) 1 |
BOOLEAN FALSE, TRUE 1 |
SET ìíîæåñòâî èç öåëûõ ÷èñåë {0 .. 31} 4 |
BYTE 0 .. 255 1 |
WCHAR ñèìâîë þíèêîäà (0X .. 0FFFFX) 2 |
2. Ìàêñèìàëüíàÿ äëèíà èäåíòèôèêàòîðîâ - 255 ñèìâîëîâ |
3. Ìàêñèìàëüíàÿ äëèíà ñòðîêîâûõ êîíñòàíò - 255 ñèìâîëîâ |
4. Ìàêñèìàëüíàÿ äëèíà ñòðîê èñõîäíîãî êîäà - 511 ñèìâîëîâ |
5. Ìàêñèìàëüíàÿ ðàçìåðíîñòü îòêðûòûõ ìàññèâîâ - 5 |
6. Ìàêñèìàëüíîå êîëè÷åñòâî îáúÿâëåííûõ òèïîâ-çàïèñåé - 2047 |
7. Ïðîöåäóðà NEW çàïîëíÿåò íóëÿìè âûäåëåííûé áëîê ïàìÿòè |
8. Ãëîáàëüíûå è ëîêàëüíûå ïåðåìåííûå èíèöèàëèçèðóþòñÿ íóëÿìè |
9.  îòëè÷èå îò ìíîãèõ Oberon-ðåàëèçàöèé, ñáîðùèê ìóñîðà è äèíàìè÷åñêàÿ |
2. Ìàêñèìàëüíàÿ äëèíà èäåíòèôèêàòîðîâ - 1024 ñèìâîëîâ |
3. Ìàêñèìàëüíàÿ äëèíà ñòðîêîâûõ êîíñòàíò - 1024 ñèìâîëîâ (UTF-8) |
4. Ìàêñèìàëüíàÿ ðàçìåðíîñòü îòêðûòûõ ìàññèâîâ - 5 |
5. Ïðîöåäóðà NEW çàïîëíÿåò íóëÿìè âûäåëåííûé áëîê ïàìÿòè |
6. Ãëîáàëüíûå è ëîêàëüíûå ïåðåìåííûå èíèöèàëèçèðóþòñÿ íóëÿìè |
7.  îòëè÷èå îò ìíîãèõ 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 |
81,9 → 115,15 |
ïîâðåæäåíèþ äàííûõ âðåìåíè âûïîëíåíèÿ è àâàðèéíîìó çàâåðøåíèþ ïðîãðàììû. |
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 |
91,8 → 131,7 |
T - òèï-çàïèñü èëè òèï-óêàçàòåëü, |
âîçâðàùàåò íîìåð òèïà â òàáëèöå òèïîâ-çàïèñåé |
PROCEDURE INF(T): T |
T - REAL èëè LONGREAL, |
PROCEDURE INF(): REAL |
âîçâðàùàåò ñïåöèàëüíîå âåùåñòâåííîå çíà÷åíèå "áåñêîíå÷íîñòü" |
PROCEDURE GET(a: INTEGER; |
100,11 → 139,20 |
v := Ïàìÿòü[a] |
PROCEDURE PUT(a: INTEGER; x: ëþáîé îñíîâíîé òèï, PROCEDURE, POINTER) |
Ïàìÿòü[a] := x |
Ïàìÿòü[a] := x; |
Åñëè x: BYTE èëè x: WCHAR, òî çíà÷åíèå x áóäåò ðàñøèðåíî |
äî 32 áèò, äëÿ çàïèñè áàéòîâ èñïîëüçîâàòü SYSTEM.PUT8, |
äëÿ WCHAR -- SYSTEM.PUT16 |
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. |
111,11 → 159,11 |
Ýêâèâàëåíòíî |
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n) |
PROCEDURE CODE(s: ARRAY OF CHAR) |
Âñòàâêà ìàøèííîãî êîäà |
s - ñòðîêîâàÿ êîíñòàíòà øåñòíàäöàòèðè÷íûõ öèôð |
êîëè÷åñòâî öèôð äîëæíî áûòü ÷åòíûì |
íàïðèìåð: SYSTEM.CODE("B801000000") (* mov eax, 1 *) |
PROCEDURE CODE(byte1, byte2,... : INTEGER) |
Âñòàâêà ìàøèííîãî êîäà, |
byte1, byte2 ... - êîíñòàíòû â äèàïàçîíå 0..255, |
íàïðèìåð: |
SYSTEM.CODE(08BH, 045H, 008H) (* mov eax, dword [ebp + 08h] *) |
Òàêæå â ìîäóëå SYSTEM îïðåäåëåí òèï CARD16 (2 áàéòà). Äëÿ òèïà CARD16 íå |
äîïóñêàþòñÿ íèêàêèå ÿâíûå îïåðàöèè, çà èñêëþ÷åíèåì ïðèñâàèâàíèÿ. |
142,20 → 190,20 |
Ñèñòåìíûå ôëàãè |
Ïðè îáúÿâëåíèè ïðîöåäóðíûõ òèïîâ è ãëîáàëüíûõ ïðîöåäóð, ïîñëå êëþ÷åâîãî |
ñëîâà PROCEDURE ìîæåò áûòü óêàçàí ôëàã ñîãëàøåíèÿ âûçîâà: [stdcall], [cdecl] |
èëè [winapi]. Íàïðèìåð: |
ñëîâà PROCEDURE ìîæåò áûòü óêàçàí ôëàã ñîãëàøåíèÿ î âûçîâå: [stdcall], |
[ccall], [ccall16], [windows], [linux]. Íàïðèìåð: |
PROCEDURE [cdecl] MyProc(x, y, z: INTEGER): INTEGER; |
PROCEDURE [ccall] MyProc (x, y, z: INTEGER): INTEGER; |
Åñëè óêàçàí ôëàã [winapi], òî ïðèíèìàåòñÿ ñîãëàøåíèå stdcall è |
ïðîöåäóðó-ôóíêöèþ ìîæíî âûçâàòü êàê ñîáñòâåííî ïðîöåäóðó, âíå âûðàæåíèÿ. |
Ôëàã [winapi] äîñòóïåí òîëüêî äëÿ ïëàòôîðìû Windows. |
Åñëè óêàçàí ôëàã [ccall16], òî ïðèíèìàåòñÿ ñîãëàøåíèå ccall, íî ïåðåä |
âûçîâîì óêàçàòåëü ñòýêà áóäåò âûðàâíåí ïî ãðàíèöå 16 áàéò. |
Ôëàã [windows] - ñèíîíèì äëÿ [stdcall], [linux] - ñèíîíèì äëÿ [ccall16]. |
Çíàê "-" ïîñëå èìåíè ôëàãà ([stdcall-], [linux-], ...) îçíà÷àåò, ÷òî |
ðåçóëüòàò ïðîöåäóðû ìîæíî èãíîðèðîâàòü (íå äîïóñêàåòñÿ äëÿ òèïà REAL). |
Ïðè îáúÿâëåíèè òèïîâ-çàïèñåé, ïîñëå êëþ÷åâîãî ñëîâà RECORD ìîæåò áûòü |
óêàçàí ôëàã [noalign] èëè [union]. Ôëàã [noalign] îçíà÷àåò îòñóòñòâèå |
âûðàâíèâàíèÿ ïîëåé çàïèñè, à ôëàã [union] îçíà÷àåò, ÷òî ñìåùåíèÿ âñåõ ïîëåé |
çàïèñè ðàâíû íóëþ, ïðè ýòîì ðàçìåð çàïèñè ðàâåí ðàçìåðó íàèáîëüøåãî ïîëÿ. |
Çàïèñè RECORD [union] ... END ñîîòâåòñòâóþò îáúåäèíåíèÿì (union) â ÿçûêå C. |
Çàïèñè ñ ñèñòåìíûìè ôëàãàìè íå ìîãóò èìåòü áàçîâîãî òèïà è íå ìîãóò áûòü |
óêàçàí ôëàã [noalign]. Ôëàã [noalign] îçíà÷àåò îòñóòñòâèå âûðàâíèâàíèÿ ïîëåé |
çàïèñè. Çàïèñè ñ ñèñòåìíûì ôëàãîì íå ìîãóò èìåòü áàçîâûé òèï è íå ìîãóò áûòü |
áàçîâûìè òèïàìè äëÿ äðóãèõ çàïèñåé. |
Äëÿ èñïîëüçîâàíèÿ ñèñòåìíûõ ôëàãîâ, òðåáóåòñÿ èìïîðòèðîâàòü SYSTEM. |
182,10 → 230,20 |
END |
 ìåòêàõ âàðèàíòîâ ìîæíî èñïîëüçîâàòü êîíñòàíòíûå âûðàæåíèÿ, âåòêà ELSE |
íåîáÿçàòåëüíà. Åñëè íå âûïîëíåí íè îäèí âàðèàíò è ELSE îòñóòñòâóåò, òî |
ïðîãðàììà ïðåðûâàåòñÿ ñ îøèáêîé âðåìåíè âûïîëíåíèÿ. |
íåîáÿçàòåëüíà. Åñëè çíà÷åíèå x íå ñîîòâåòñòâóåò íè îäíîìó âàðèàíòó è ELSE |
îòñóòñòâóåò, òî ïðîãðàììà ïðåðûâàåòñÿ ñ îøèáêîé âðåìåíè âûïîëíåíèÿ. |
------------------------------------------------------------------------------ |
Òèï WCHAR |
Òèï WCHAR äîáàâëåí â ÿçûê äëÿ óäîáíîé ïîääåæêè þíèêîäà. Äëÿ òèïîâ WCHAR è |
ARRAY OF WCHAR äîïóñêàþòñÿ âñå òå æå îïåðàöèè, êàê äëÿ òèïîâ CHAR è |
ARRAY OF CHAR, çà èñêëþ÷åíèåì âñòðîåííîé ïðîöåäóðû CHR, êîòîðàÿ âîçâðàùàåò |
òîëüêî òèï CHAR. Äëÿ ïîëó÷åíèÿ çíà÷åíèÿ òèïà WCHAR, ñëåäóåò èñïîëüçîâàòü |
ïðîöåäóðó WCHR âìåñòî CHR. Äëÿ ïðàâèëüíîé ðàáîòû ñ òèïîì, íåîáõîäèìî ñîõðàíÿòü |
èñõîäíûé êîä â êîäèðîâêå UTF-8 c BOM. |
------------------------------------------------------------------------------ |
Ïðîâåðêà è îõðàíà òèïà íóëåâîãî óêàçàòåëÿ |
Îðèãèíàëüíîå ñîîáùåíèå î ÿçûêå íå îïðåäåëÿåò ïîâåäåíèå ïðîãðàììû ïðè |
203,6 → 261,11 |
äèíàìè÷åñêîé ïåðåìåííîé 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 áèò âïðàâî. |
216,11 → 279,14 |
Èíòåðïðåòèðóåò x êàê çíà÷åíèå òèïà SET. |
Âûïîëíÿåòñÿ íà ýòàïå êîìïèëÿöèè. |
LENGTH(s: ARRAY OF CHAR): INTEGER |
LENGTH (s: ARRAY OF CHAR/WCHAR): INTEGER |
Äëèíà 0X-çàâåðøåííîé ñòðîêè s, áåç ó÷åòà ñèìâîëà 0X. |
Åñëè ñèìâîë 0X îòñóòñòâóåò, ôóíêöèÿ âîçâðàùàåò äëèíó |
ìàññèâà s. |
ìàññèâà s. s íå ìîæåò áûòü êîíñòàíòîé. |
WCHR (n: INTEGER): WCHAR |
Ïðåîáðàçîâàíèå òèïà, àíàëîãè÷íî CHR(n: INTEGER): CHAR |
------------------------------------------------------------------------------ |
DIV è MOD |
232,6 → 298,45 |
-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, èìïîðòèðîâàííûå ïðîöåäóðû íå ðåàëèçîâàíû. |
------------------------------------------------------------------------------ |
Ñêðûòûå ïàðàìåòðû ïðîöåäóð |
Íåêîòîðûå ïðîöåäóðû ìîãóò èìåòü ñêðûòûå ïàðàìåòðû, îíè îòñóòñòâóþò â ñïèñêå |
239,21 → 344,13 |
Ýòî âîçìîæíî â ñëåäóþùèõ ñëó÷àÿõ: |
1. Ïðîöåäóðà èìååò ôîðìàëüíûé ïàðàìåòð îòêðûòûé ìàññèâ: |
PROCEDURE Proc(x: ARRAY OF ARRAY OF LONGREAL); |
PROCEDURE Proc (x: ARRAY OF ARRAY OF REAL); |
Âûçîâ òðàíñëèðóåòñÿ òàê: |
Proc(SYSTEM.ADR(x), LEN(x), LEN(x[0]) |
Proc(LEN(x), LEN(x[0]), SYSTEM.ADR(x)) |
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 |
261,13 → 358,21 |
Âñå ïðîãðàììû íåÿâíî èñïîëüçóþò ìîäóëü RTL. Êîìïèëÿòîð òðàíñëèðóåò |
íåêîòîðûå îïåðàöèè (ïðîâåðêà è îõðàíà òèïà, ñðàâíåíèå ñòðîê, ñîîáùåíèÿ îá |
îøèáêàõ âðåìåíè âûïîëíåíèÿ è äð.) êàê âûçîâû ïðîöåäóð ýòîãî ìîäóëÿ. Íå |
ñëåäóåò ÿâíî âûçûâàòü ýòè ïðîöåäóðû, çà èñêëþ÷åíèåì ïðîöåäóðû SetClose: |
ñëåäóåò ÿâíî âûçûâàòü ýòè ïðîöåäóðû, çà èñêëþ÷åíèåì ïðîöåäóðû SetDll, |
åñëè ïðèëîæåíèå êîìïèëèðóåòñÿ êàê Windows DLL: |
PROCEDURE SetClose(proc: PROC), ãäå TYPE PROC = PROCEDURE |
PROCEDURE SetDll |
(process_detach, thread_detach, thread_attach: DLL_ENTRY); |
ãäå TYPE DLL_ENTRY = |
PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER); |
SetClose íàçíà÷àåò ïðîöåäóðó proc (áåç ïàðàìåòðîâ) âûçûâàåìîé ïðè âûãðóçêå |
dll-áèáëèîòåêè (Windows), åñëè ïðèëîæåíèå êîìïèëèðóåòñÿ êàê Windows DLL. Äëÿ |
ïðî÷èõ òèïîâ ïðèëîæåíèé è ïëàòôîðì âûçîâ ïðîöåäóðû SetClose íå âëèÿåò íà |
SetDll íàçíà÷àåò ïðîöåäóðû process_detach, thread_detach, thread_attach |
âûçûâàåìûìè ïðè |
- âûãðóçêå dll-áèáëèîòåêè (process_detach) |
- ñîçäàíèè íîâîãî ïîòîêà (thread_attach) |
- óíè÷òîæåíèè ïîòîêà (thread_detach) |
Äëÿ ïðî÷èõ òèïîâ ïðèëîæåíèé, âûçîâ ïðîöåäóðû SetDll íå âëèÿåò íà |
ïîâåäåíèå ïðîãðàììû. |
Ñîîáùåíèÿ îá îøèáêàõ âðåìåíè âûïîëíåíèÿ âûâîäÿòñÿ â äèàëîãîâûõ îêíàõ |
(Windows), â òåðìèíàë (Linux), íà äîñêó îòëàäêè (KolibriOS). |
275,9 → 380,9 |
------------------------------------------------------------------------------ |
Ìîäóëü API |
Ñóùåñòâóþò òðè ðåàëèçàöèè ìîäóëÿ API: äëÿ Windows, Linux è KolibriOS. Êàê è |
ìîäóëü RTL, ìîäóëü API íå ïðåäíàçíà÷åí äëÿ ïðÿìîãî èñïîëüçîâàíèÿ. Îí |
îáåñïå÷èâàåò êðîññïëàòôîðìåííîñòü êîìïèëÿòîðà. |
Ñóùåñòâóþò íåñêîëüêî ðåàëèçàöèé ìîäóëÿ API (äëÿ ðàçëè÷íûõ ÎÑ). |
Êàê è ìîäóëü RTL, ìîäóëü API íå ïðåäíàçíà÷åí äëÿ ïðÿìîãî èñïîëüçîâàíèÿ. |
Îí îáåñïå÷èâàåò ñâÿçü RTL ñ ÎÑ. |
------------------------------------------------------------------------------ |
Ãåíåðàöèÿ èñïîëíÿåìûõ ôàéëîâ DLL |
291,582 → 396,5 |
Ýòà ïðîöåäóðà äîëæíà áûòü âûçâàíà ïåðåä èñïîëüçîâàíèåì 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 (ðàáîòà ñ ñåòåâûìè óñòðîéñòâàìè) |
------------------------------------------------------------------------------ |
Äëÿ Linux, ãåíåðàöèÿ äèíàìè÷åñêèõ áèáëèîòåê íå ðåàëèçîâàíà. |
/programs/develop/oberon07/Docs/KOSLib1251.txt |
---|
0,0 → 1,563 |
============================================================================== |
Áèáëèîòåêà (KolibriOS) |
------------------------------------------------------------------------------ |
MODULE Out - êîíñîëüíûé âûâîä |
PROCEDURE Open |
ôîðìàëüíî îòêðûâàåò êîíñîëüíûé âûâîä |
PROCEDURE Int(x, width: INTEGER) |
âûâîä öåëîãî ÷èñëà x; |
width - êîëè÷åñòâî çíàêîìåñò, èñïîëüçóåìûõ äëÿ âûâîäà |
PROCEDURE Real(x: REAL; width: INTEGER) |
âûâîä âåùåñòâåííîãî ÷èñëà x â ïëàâàþùåì ôîðìàòå; |
width - êîëè÷åñòâî çíàêîìåñò, èñïîëüçóåìûõ äëÿ âûâîäà |
PROCEDURE Char(x: CHAR) |
âûâîä ñèìâîëà x |
PROCEDURE FixReal(x: REAL; width, p: INTEGER) |
âûâîä âåùåñòâåííîãî ÷èñëà x â ôèêñèðîâàííîì ôîðìàòå; |
width - êîëè÷åñòâî çíàêîìåñò, èñïîëüçóåìûõ äëÿ âûâîäà; |
p - êîëè÷åñòâî çíàêîâ ïîñëå äåñÿòè÷íîé òî÷êè |
PROCEDURE Ln |
ïåðåõîä íà ñëåäóþùóþ ñòðîêó |
PROCEDURE String(s: ARRAY OF CHAR) |
âûâîä ñòðîêè s |
------------------------------------------------------------------------------ |
MODULE In - êîíñîëüíûé ââîä |
VAR Done: BOOLEAN |
ïðèíèìàåò çíà÷åíèå TRUE â ñëó÷àå óñïåøíîãî âûïîëíåíèÿ |
îïåðàöèè ââîäà, èíà÷å FALSE |
PROCEDURE Open |
ôîðìàëüíî îòêðûâàåò êîíñîëüíûé ââîä, |
òàêæå ïðèñâàèâàåò ïåðåìåííîé Done çíà÷åíèå TRUE |
PROCEDURE Int(VAR x: INTEGER) |
ââîä ÷èñëà òèïà INTEGER |
PROCEDURE Char(VAR x: CHAR) |
ââîä ñèìâîëà |
PROCEDURE Real(VAR x: REAL) |
ââîä ÷èñëà òèïà REAL |
PROCEDURE String(VAR s: ARRAY OF CHAR) |
ââîä ñòðîêè |
PROCEDURE Ln |
îæèäàíèå íàæàòèÿ ENTER |
------------------------------------------------------------------------------ |
MODULE Console - äîïîëíèòåëüíûå ïðîöåäóðû êîíñîëüíîãî âûâîäà |
CONST |
Ñëåäóþùèå êîíñòàíòû îïðåäåëÿþò öâåò êîíñîëüíîãî âûâîäà |
Black = 0 Blue = 1 Green = 2 |
Cyan = 3 Red = 4 Magenta = 5 |
Brown = 6 LightGray = 7 DarkGray = 8 |
LightBlue = 9 LightGreen = 10 LightCyan = 11 |
LightRed = 12 LightMagenta = 13 Yellow = 14 |
White = 15 |
PROCEDURE Cls |
î÷èñòêà îêíà êîíñîëè |
PROCEDURE SetColor(FColor, BColor: INTEGER) |
óñòàíîâêà öâåòà êîíñîëüíîãî âûâîäà: FColor - öâåò òåêñòà, |
BColor - öâåò ôîíà, âîçìîæíûå çíà÷åíèÿ - âûøåïåðå÷èñëåííûå |
êîíñòàíòû |
PROCEDURE SetCursor(x, y: INTEGER) |
óñòàíîâêà êóðñîðà êîíñîëè â ïîçèöèþ (x, y) |
PROCEDURE GetCursor(VAR x, y: INTEGER) |
çàïèñûâàåò â ïàðàìåòðû òåêóùèå êîîðäèíàòû êóðñîðà êîíñîëè |
PROCEDURE GetCursorX(): INTEGER |
âîçâðàùàåò òåêóùóþ x-êîîðäèíàòó êóðñîðà êîíñîëè |
PROCEDURE GetCursorY(): INTEGER |
âîçâðàùàåò òåêóùóþ y-êîîðäèíàòó êóðñîðà êîíñîëè |
------------------------------------------------------------------------------ |
MODULE ConsoleLib - îáåðòêà áèáëèîòåêè console.obj |
------------------------------------------------------------------------------ |
MODULE Math - ìàòåìàòè÷åñêèå ôóíêöèè |
CONST |
pi = 3.141592653589793D+00 |
e = 2.718281828459045D+00 |
PROCEDURE IsNan(x: REAL): BOOLEAN |
âîçâðàùàåò TRUE, åñëè x - íå ÷èñëî |
PROCEDURE IsInf(x: REAL): BOOLEAN |
âîçâðàùàåò TRUE, åñëè x - áåñêîíå÷íîñòü |
PROCEDURE sqrt(x: REAL): REAL |
êâàäðàòíûé êîðåíü x |
PROCEDURE exp(x: REAL): REAL |
ýêñïîíåíòà x |
PROCEDURE ln(x: REAL): REAL |
íàòóðàëüíûé ëîãàðèôì x |
PROCEDURE sin(x: REAL): REAL |
ñèíóñ x |
PROCEDURE cos(x: REAL): REAL |
êîñèíóñ x |
PROCEDURE tan(x: REAL): REAL |
òàíãåíñ x |
PROCEDURE arcsin(x: REAL): REAL |
àðêñèíóñ x |
PROCEDURE arccos(x: REAL): REAL |
àðêêîñèíóñ x |
PROCEDURE arctan(x: REAL): REAL |
àðêòàíãåíñ x |
PROCEDURE arctan2(y, x: REAL): REAL |
àðêòàíãåíñ y/x |
PROCEDURE power(base, exponent: REAL): REAL |
âîçâåäåíèå ÷èñëà base â ñòåïåíü exponent |
PROCEDURE log(base, x: REAL): REAL |
ëîãàðèôì x ïî îñíîâàíèþ base |
PROCEDURE sinh(x: REAL): REAL |
ãèïåðáîëè÷åñêèé ñèíóñ x |
PROCEDURE cosh(x: REAL): REAL |
ãèïåðáîëè÷åñêèé êîñèíóñ x |
PROCEDURE tanh(x: REAL): REAL |
ãèïåðáîëè÷åñêèé òàíãåíñ x |
PROCEDURE arcsinh(x: REAL): REAL |
îáðàòíûé ãèïåðáîëè÷åñêèé ñèíóñ x |
PROCEDURE arccosh(x: REAL): REAL |
îáðàòíûé ãèïåðáîëè÷åñêèé êîñèíóñ x |
PROCEDURE arctanh(x: REAL): REAL |
îáðàòíûé ãèïåðáîëè÷åñêèé òàíãåíñ x |
PROCEDURE round(x: REAL): REAL |
îêðóãëåíèå x äî áëèæàéøåãî öåëîãî |
PROCEDURE frac(x: REAL): REAL; |
äðîáíàÿ ÷àñòü ÷èñëà x |
PROCEDURE floor(x: REAL): REAL |
íàèáîëüøåå öåëîå ÷èñëî (ïðåäñòàâëåíèå êàê REAL), |
íå áîëüøå x: floor(1.2) = 1.0 |
PROCEDURE ceil(x: REAL): REAL |
íàèìåíüøåå öåëîå ÷èñëî (ïðåäñòàâëåíèå êàê REAL), |
íå ìåíüøå x: ceil(1.2) = 2.0 |
PROCEDURE sgn(x: REAL): INTEGER |
åñëè x > 0 âîçâðàùàåò 1 |
åñëè x < 0 âîçâðàùàåò -1 |
åñëè x = 0 âîçâðàùàåò 0 |
------------------------------------------------------------------------------ |
MODULE Debug - âûâîä íà äîñêó îòëàäêè |
Èíòåðôåéñ êàê ìîäóëü Out |
PROCEDURE Open |
îòêðûâàåò äîñêó îòëàäêè |
------------------------------------------------------------------------------ |
MODULE File - ðàáîòà ñ ôàéëîâîé ñèñòåìîé |
TYPE |
FNAME = ARRAY 520 OF CHAR |
FS = POINTER TO rFS |
rFS = RECORD (* èíôîðìàöèîííàÿ ñòðóêòóðà ôàéëà *) |
subfunc, pos, hpos, bytes, buffer: INTEGER; |
name: FNAME |
END |
FD = POINTER TO rFD |
rFD = RECORD (* ñòðóêòóðà áëîêà äàííûõ âõîäà êàòàëîãà *) |
attr: INTEGER; |
ntyp: CHAR; |
reserved: ARRAY 3 OF CHAR; |
time_create, date_create, |
time_access, date_access, |
time_modif, date_modif, |
size, hsize: INTEGER; |
name: FNAME |
END |
CONST |
SEEK_BEG = 0 |
SEEK_CUR = 1 |
SEEK_END = 2 |
PROCEDURE Load(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER; |
Çàãðóæàåò â ïàìÿòü ôàéë ñ èìåíåì FName, çàïèñûâàåò â ïàðàìåòð |
size ðàçìåð ôàéëà, âîçâðàùàåò àäðåñ çàãðóæåííîãî ôàéëà |
èëè 0 (îøèáêà). Ïðè íåîáõîäèìîñòè, ðàñïàêîâûâàåò |
ôàéë (kunpack). |
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN |
Çàïèñûâàåò ñòðóêòóðó áëîêà äàííûõ âõîäà êàòàëîãà äëÿ ôàéëà |
èëè ïàïêè ñ èìåíåì FName â ïàðàìåòð Info. |
Ïðè îøèáêå âîçâðàùàåò FALSE. |
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN |
âîçâðàùàåò TRUE, åñëè ôàéë ñ èìåíåì FName ñóùåñòâóåò |
PROCEDURE Close(VAR F: FS) |
îñâîáîæäàåò ïàìÿòü, âûäåëåííóþ äëÿ èíôîðìàöèîííîé ñòðóêòóðû |
ôàéëà F è ïðèñâàèâàåò F çíà÷åíèå NIL |
PROCEDURE Open(FName: ARRAY OF CHAR): FS |
âîçâðàùàåò óêàçàòåëü íà èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà ñ |
èìåíåì FName, ïðè îøèáêå âîçâðàùàåò NIL |
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN |
óäàëÿåò ôàéë ñ èìåíåì FName, ïðè îøèáêå âîçâðàùàåò FALSE |
PROCEDURE Seek(F: FS; Offset, Origin: INTEGER): INTEGER |
óñòàíàâëèâàåò ïîçèöèþ ÷òåíèÿ-çàïèñè ôàéëà F íà Offset, |
îòíîñèòåëüíî Origin = (SEEK_BEG - íà÷àëî ôàéëà, |
SEEK_CUR - òåêóùàÿ ïîçèöèÿ, SEEK_END - êîíåö ôàéëà), |
âîçâðàùàåò ïîçèöèþ îòíîñèòåëüíî íà÷àëà ôàéëà, íàïðèìåð: |
Seek(F, 0, SEEK_END) |
óñòàíàâëèâàåò ïîçèöèþ íà êîíåö ôàéëà è âîçâðàùàåò äëèíó |
ôàéëà; ïðè îøèáêå âîçâðàùàåò -1 |
PROCEDURE Read(F: FS; Buffer, Count: INTEGER): INTEGER |
×èòàåò äàííûå èç ôàéëà â ïàìÿòü. F - óêàçàòåëü íà |
èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà, Buffer - àäðåñ îáëàñòè |
ïàìÿòè, Count - êîëè÷åñòâî áàéò, êîòîðîå òðåáóåòñÿ ïðî÷èòàòü |
èç ôàéëà; âîçâðàùàåò êîëè÷åñòâî áàéò, êîòîðîå áûëî ïðî÷èòàíî |
è ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿåò ïîçèöèþ ÷òåíèÿ/çàïèñè â |
èíôîðìàöèîííîé ñòðóêòóðå F. |
PROCEDURE Write(F: FS; Buffer, Count: INTEGER): INTEGER |
Çàïèñûâàåò äàííûå èç ïàìÿòè â ôàéë. F - óêàçàòåëü íà |
èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà, Buffer - àäðåñ îáëàñòè |
ïàìÿòè, Count - êîëè÷åñòâî áàéò, êîòîðîå òðåáóåòñÿ çàïèñàòü |
â ôàéë; âîçâðàùàåò êîëè÷åñòâî áàéò, êîòîðîå áûëî çàïèñàíî è |
ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿåò ïîçèöèþ ÷òåíèÿ/çàïèñè â |
èíôîðìàöèîííîé ñòðóêòóðå F. |
PROCEDURE Create(FName: ARRAY OF CHAR): FS |
ñîçäàåò íîâûé ôàéë ñ èìåíåì FName (ïîëíîå èìÿ), âîçâðàùàåò |
óêàçàòåëü íà èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà, |
ïðè îøèáêå âîçâðàùàåò NIL |
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN |
ñîçäàåò ïàïêó ñ èìåíåì DirName, âñå ïðîìåæóòî÷íûå ïàïêè |
äîëæíû ñóùåñòâîâàòü, ïðè îøèáêå âîçâðàùàåò FALSE |
PROCEDURE DeleteDir(DirName: ARRAY OF CHAR): BOOLEAN |
óäàëÿåò ïóñòóþ ïàïêó ñ èìåíåì DirName, |
ïðè îøèáêå âîçâðàùàåò FALSE |
PROCEDURE DirExists(DirName: ARRAY OF CHAR): BOOLEAN |
âîçâðàùàåò TRUE, åñëè ïàïêà ñ èìåíåì DirName ñóùåñòâóåò |
------------------------------------------------------------------------------ |
MODULE Read - ÷òåíèå îñíîâíûõ òèïîâ äàííûõ èç ôàéëà F |
Ïðîöåäóðû âîçâðàùàþò TRUE â ñëó÷àå óñïåøíîé îïåðàöèè ÷òåíèÿ è |
ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿþò ïîçèöèþ ÷òåíèÿ/çàïèñè â |
èíôîðìàöèîííîé ñòðóêòóðå F |
PROCEDURE Char(F: File.FS; VAR x: CHAR): BOOLEAN |
PROCEDURE Int(F: File.FS; VAR x: INTEGER): BOOLEAN |
PROCEDURE Real(F: File.FS; VAR x: REAL): BOOLEAN |
PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN |
PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN |
PROCEDURE 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 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.0E5 |
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER) |
çàïèñûâàåò â ïàðàìåòðû êîìïîíåíòû òåêóùåé ñèñòåìíîé äàòû è |
âðåìåíè |
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL |
âîçâðàùàåò äàòó, ïîëó÷åííóþ èç êîìïîíåíòîâ |
Year, Month, Day, Hour, Min, Sec; |
ïðè îøèáêå âîçâðàùàåò êîíñòàíòó ERR = -7.0D5 |
PROCEDURE Decode(Date: REAL; VAR Year, Month, Day, |
Hour, Min, Sec: INTEGER): BOOLEAN |
èçâëåêàåò êîìïîíåíòû |
Year, Month, Day, Hour, Min, Sec èç äàòû Date; |
ïðè îøèáêå âîçâðàùàåò FALSE |
------------------------------------------------------------------------------ |
MODULE Args - ïàðàìåòðû ïðîãðàììû |
VAR argc: INTEGER |
êîëè÷åñòâî ïàðàìåòðîâ ïðîãðàììû, âêëþ÷àÿ èìÿ |
èñïîëíÿåìîãî ôàéëà |
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR) |
çàïèñûâàåò â ñòðîêó s n-é ïàðàìåòð ïðîãðàììû, |
íóìåðàöèÿ ïàðàìåòðîâ îò 0 äî argc - 1, |
íóëåâîé ïàðàìåòð -- èìÿ èñïîëíÿåìîãî ôàéëà |
------------------------------------------------------------------------------ |
MODULE KOSAPI |
PROCEDURE sysfunc1(arg1: INTEGER): INTEGER |
PROCEDURE sysfunc2(arg1, arg2: INTEGER): INTEGER |
... |
PROCEDURE sysfunc7(arg1, arg2, ..., arg7: INTEGER): INTEGER |
Îáåðòêè äëÿ ôóíêöèé API ÿäðà KolibriOS. |
arg1 .. arg7 ñîîòâåòñòâóþò ðåãèñòðàì |
eax, ebx, ecx, edx, esi, edi, ebp; |
âîçâðàùàþò çíà÷åíèå ðåãèñòðà eax ïîñëå ñèñòåìíîãî âûçîâà. |
PROCEDURE sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER |
Îáåðòêà äëÿ ôóíêöèé API ÿäðà KolibriOS. |
arg1 - ðåãèñòð eax, arg2 - ðåãèñòð ebx, |
res2 - çíà÷åíèå ðåãèñòðà ebx ïîñëå ñèñòåìíîãî âûçîâà; |
âîçâðàùàåò çíà÷åíèå ðåãèñòðà eax ïîñëå ñèñòåìíîãî âûçîâà. |
PROCEDURE malloc(size: INTEGER): INTEGER |
Âûäåëÿåò áëîê ïàìÿòè. |
size - ðàçìåð áëîêà â áàéòàõ, |
âîçâðàùàåò àäðåñ âûäåëåííîãî áëîêà |
PROCEDURE free(ptr: INTEGER): INTEGER |
Îñâîáîæäàåò ðàíåå âûäåëåííûé áëîê ïàìÿòè ñ àäðåñîì ptr, |
âîçâðàùàåò 0 |
PROCEDURE realloc(ptr, size: INTEGER): INTEGER |
Ïåðåðàñïðåäåëÿåò áëîê ïàìÿòè, |
ptr - àäðåñ ðàíåå âûäåëåííîãî áëîêà, |
size - íîâûé ðàçìåð, |
âîçâðàùàåò óêàçàòåëü íà ïåðåðàñïðåäåëåííûé áëîê, |
0 ïðè îøèáêå |
PROCEDURE GetCommandLine(): INTEGER |
Âîçâðàùàåò àäðåñ ñòðîêè ïàðàìåòðîâ |
PROCEDURE GetName(): INTEGER |
Âîçâðàùàåò àäðåñ ñòðîêè ñ èìåíåì ïðîãðàììû |
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER |
Çàãðóæàåò DLL ñ ïîëíûì èìåíåì name. Âîçâðàùàåò àäðåñ òàáëèöû |
ýêñïîðòà. Ïðè îøèáêå âîçâðàùàåò 0. |
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER |
name - èìÿ ïðîöåäóðû |
lib - àäðåñ òàáëèöû ýêñïîðòà DLL |
Âîçâðàùàåò àäðåñ ïðîöåäóðû. Ïðè îøèáêå âîçâðàùàåò 0. |
------------------------------------------------------------------------------ |
MODULE ColorDlg - ðàáîòà ñ äèàëîãîì "Color Dialog" |
TYPE |
Dialog = POINTER TO RECORD (* ñòðóêòóðà äèàëîãà *) |
status: INTEGER (* ñîñòîÿíèå äèàëîãà: |
0 - ïîëüçîâàòåëü íàæàë Cancel |
1 - ïîëüçîâàòåëü íàæàë OK |
2 - äèàëîã îòêðûò *) |
color: INTEGER (* âûáðàííûé öâåò *) |
END |
PROCEDURE Create(draw_window: DRAW_WINDOW): Dialog |
ñîçäàòü äèàëîã |
draw_window - ïðîöåäóðà ïåðåðèñîâêè îñíîâíîãî îêíà |
(TYPE DRAW_WINDOW = PROCEDURE); |
ïðîöåäóðà âîçâðàùàåò óêàçàòåëü íà ñòðóêòóðó äèàëîãà |
PROCEDURE Show(cd: Dialog) |
ïîêàçàòü äèàëîã |
cd - óêàçàòåëü íà ñòðóêòóðó äèàëîãà, êîòîðûé áûë ñîçäàí ðàíåå |
ïðîöåäóðîé Create |
PROCEDURE Destroy(VAR cd: Dialog) |
óíè÷òîæèòü äèàëîã |
cd - óêàçàòåëü íà ñòðóêòóðó äèàëîãà |
------------------------------------------------------------------------------ |
MODULE OpenDlg - ðàáîòà ñ äèàëîãîì "Open Dialog" |
TYPE |
Dialog = POINTER TO RECORD (* ñòðóêòóðà äèàëîãà *) |
status: INTEGER (* ñîñòîÿíèå äèàëîãà: |
0 - ïîëüçîâàòåëü íàæàë Cancel |
1 - ïîëüçîâàòåëü íàæàë OK |
2 - äèàëîã îòêðûò *) |
FileName: ARRAY 4096 OF CHAR (* èìÿ âûáðàííîãî ôàéëà *) |
FilePath: ARRAY 4096 OF CHAR (* ïîëíîå èìÿ âûáðàííîãî |
ôàéëà *) |
END |
PROCEDURE Create(draw_window: DRAW_WINDOW; type: INTEGER; def_path, |
filter: ARRAY OF CHAR): Dialog |
ñîçäàòü äèàëîã |
draw_window - ïðîöåäóðà ïåðåðèñîâêè îñíîâíîãî îêíà |
(TYPE DRAW_WINDOW = PROCEDURE) |
type - òèï äèàëîãà |
0 - îòêðûòü |
1 - ñîõðàíèòü |
2 - âûáðàòü ïàïêó |
def_path - ïóòü ïî óìîë÷àíèþ, ïàïêà def_path áóäåò îòêðûòà |
ïðè ïåðâîì çàïóñêå äèàëîãà |
filter - â ñòðîêå çàïèñàíî ïåðå÷èñëåíèå ðàñøèðåíèé ôàéëîâ, |
êîòîðûå áóäóò ïîêàçàíû â äèàëîãîâîì îêíå, ðàñøèðåíèÿ |
ðàçäåëÿþòñÿ ñèìâîëîì "|", íàïðèìåð: "ASM|TXT|INI" |
ïðîöåäóðà âîçâðàùàåò óêàçàòåëü íà ñòðóêòóðó äèàëîãà |
PROCEDURE Show(od: Dialog; Width, Height: INTEGER) |
ïîêàçàòü äèàëîã |
od - óêàçàòåëü íà ñòðóêòóðó äèàëîãà, êîòîðûé áûë ñîçäàí ðàíåå |
ïðîöåäóðîé Create |
Width è Height - øèðèíà è âûñîòà äèàëîãîâîãî îêíà |
PROCEDURE Destroy(VAR od: Dialog) |
óíè÷òîæèòü äèàëîã |
od - óêàçàòåëü íà ñòðóêòóðó äèàëîãà |
------------------------------------------------------------------------------ |
MODULE kfonts - ðàáîòà ñ kf-øðèôòàìè |
CONST |
bold = 1 |
italic = 2 |
underline = 4 |
strike_through = 8 |
smoothing = 16 |
bpp32 = 32 |
TYPE |
TFont = POINTER TO TFont_desc (* óêàçàòåëü íà øðèôò *) |
PROCEDURE LoadFont(file_name: ARRAY OF CHAR): TFont |
çàãðóçèòü øðèôò èç ôàéëà |
file_name èìÿ kf-ôàéëà |
ðåç-ò: óêàçàòåëü íà øðèôò/NIL (îøèáêà) |
PROCEDURE SetSize(Font: TFont; font_size: INTEGER): BOOLEAN |
óñòàíîâèòü ðàçìåð øðèôòà |
Font óêàçàòåëü íà øðèôò |
font_size ðàçìåð øðèôòà |
ðåç-ò: TRUE/FALSE (îøèáêà) |
PROCEDURE Enabled(Font: TFont; font_size: INTEGER): BOOLEAN |
ïðîâåðèòü, åñòü ëè øðèôò, çàäàííîãî ðàçìåðà |
Font óêàçàòåëü íà øðèôò |
font_size ðàçìåð øðèôòà |
ðåç-ò: TRUE/FALSE (øðèôòà íåò) |
PROCEDURE Destroy(VAR Font: TFont) |
âûãðóçèòü øðèôò, îñâîáîäèòü äèíàìè÷åñêóþ ïàìÿòü |
Font óêàçàòåëü íà øðèôò |
Ïðèñâàèâàåò ïåðåìåííîé Font çíà÷åíèå NIL |
PROCEDURE TextHeight(Font: TFont): INTEGER |
ïîëó÷èòü âûñîòó ñòðîêè òåêñòà |
Font óêàçàòåëü íà øðèôò |
ðåç-ò: âûñîòà ñòðîêè òåêñòà â ïèêñåëÿõ |
PROCEDURE TextWidth(Font: TFont; |
str, length, params: INTEGER): INTEGER |
ïîëó÷èòü øèðèíó ñòðîêè òåêñòà |
Font óêàçàòåëü íà øðèôò |
str àäðåñ ñòðîêè òåêñòà â êîäèðîâêå Win-1251 |
length êîëè÷åñòâî ñèìâîëîâ â ñòðîêå èëè -1, åñëè ñòðîêà |
çàâåðøàåòñÿ íóëåì |
params ïàðàìåòðû-ôëàãè ñì. íèæå |
ðåç-ò: øèðèíà ñòðîêè òåêñòà â ïèêñåëÿõ |
PROCEDURE TextOut(Font: TFont; |
canvas, x, y, str, length, color, params: INTEGER) |
âûâåñòè òåêñò â áóôåð |
äëÿ âûâîäà áóôåðà â îêíî, èñïîëüçîâàòü ô.65 èëè |
ô.7 (åñëè áóôåð 24-áèòíûé) |
Font óêàçàòåëü íà øðèôò |
canvas àäðåñ ãðàôè÷åñêîãî áóôåðà |
ñòðóêòóðà áóôåðà: |
Xsize dd |
Ysize dd |
picture rb Xsize * Ysize * 4 (32 áèòà) |
èëè Xsize * Ysize * 3 (24 áèòà) |
x, y êîîðäèíàòû òåêñòà îòíîñèòåëüíî ëåâîãî âåðõíåãî |
óãëà áóôåðà |
str àäðåñ ñòðîêè òåêñòà â êîäèðîâêå Win-1251 |
length êîëè÷åñòâî ñèìâîëîâ â ñòðîêå èëè -1, åñëè ñòðîêà |
çàâåðøàåòñÿ íóëåì |
color öâåò òåêñòà 0x00RRGGBB |
params ïàðàìåòðû-ôëàãè: |
1 æèðíûé |
2 êóðñèâ |
4 ïîä÷åðêíóòûé |
8 ïåðå÷åðêíóòûé |
16 ïðèìåíèòü ñãëàæèâàíèå |
32 âûâîä â 32-áèòíûé áóôåð |
âîçìîæíî èñïîëüçîâàíèå ôëàãîâ â ëþáûõ ñî÷åòàíèÿõ |
------------------------------------------------------------------------------ |
MODULE RasterWorks - îáåðòêà áèáëèîòåêè Rasterworks.obj |
------------------------------------------------------------------------------ |
MODULE libimg - îáåðòêà áèáëèîòåêè libimg.obj |
------------------------------------------------------------------------------ |
/programs/develop/oberon07/Docs/Oberon07.Report_2016_05_03.pdf |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/programs/develop/oberon07/Lib/KolibriOS/API.ob07 |
---|
1,23 → 1,13 |
(* |
Copyright 2016, 2017, 2018 Anton Krotov |
(* |
BSD 2-Clause License |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE API; |
IMPORT sys := SYSTEM; |
IMPORT SYSTEM, K := KOSAPI; |
CONST |
41,10 → 31,23 |
CriticalSection: CRITICAL_SECTION; |
import*, multi: BOOLEAN; |
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER); |
eol*: ARRAY 3 OF CHAR; |
base*: INTEGER; |
PROCEDURE [stdcall] zeromem* (dwords: INTEGER; adr: INTEGER); |
BEGIN |
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F") |
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 *) |
) |
END zeromem; |
53,128 → 56,31 |
tmp: INTEGER; |
BEGIN |
FOR tmp := adr TO adr + size - 1 BY 4096 DO |
sys.PUT(tmp, 0) |
SYSTEM.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 |
res := sysfunc2(68, 1) |
K.sysfunc2(68, 1) |
END switch_task; |
PROCEDURE futex_create (ptr: INTEGER): INTEGER; |
RETURN sysfunc3(77, 0, ptr) |
RETURN K.sysfunc3(77, 0, ptr) |
END futex_create; |
PROCEDURE futex_wait (futex, value, timeout: INTEGER); |
VAR |
res: INTEGER; |
BEGIN |
res := sysfunc5(77, 2, futex, value, timeout) |
K.sysfunc5(77, 2, futex, value, timeout) |
END futex_wait; |
PROCEDURE futex_wake (futex, number: INTEGER); |
VAR |
res: INTEGER; |
BEGIN |
res := sysfunc4(77, 3, futex, number) |
K.sysfunc4(77, 3, futex, number) |
END futex_wake; |
195,7 → 101,7 |
PROCEDURE InitializeCriticalSection* (VAR CriticalSection: CRITICAL_SECTION); |
BEGIN |
CriticalSection[0] := futex_create(sys.ADR(CriticalSection[1])); |
CriticalSection[0] := futex_create(SYSTEM.ADR(CriticalSection[1])); |
CriticalSection[1] := 0 |
END InitializeCriticalSection; |
208,14 → 114,14 |
idx := ASR(size, 5); |
res := pockets[idx]; |
IF res # 0 THEN |
sys.GET(res, pockets[idx]); |
sys.PUT(res, size); |
SYSTEM.GET(res, pockets[idx]); |
SYSTEM.PUT(res, size); |
INC(res, 4) |
ELSE |
temp := 0; |
IF heap + size >= endheap THEN |
IF sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN |
temp := sysfunc3(68, 12, HEAP_SIZE) |
IF K.sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN |
temp := K.sysfunc3(68, 12, HEAP_SIZE) |
ELSE |
temp := 0 |
END; |
228,7 → 134,7 |
END |
END; |
IF (heap # 0) & (temp # -1) THEN |
sys.PUT(heap, size); |
SYSTEM.PUT(heap, size); |
res := heap + 4; |
heap := heap + size |
ELSE |
236,11 → 142,11 |
END |
END |
ELSE |
IF sysfunc2(18, 16) > ASR(size, 10) THEN |
res := sysfunc3(68, 12, size); |
IF K.sysfunc2(18, 16) > ASR(size, 10) THEN |
res := K.sysfunc3(68, 12, size); |
IF res # 0 THEN |
mem_commit(res, size); |
sys.PUT(res, size); |
SYSTEM.PUT(res, size); |
INC(res, 4) |
END |
ELSE |
259,13 → 165,13 |
size, idx: INTEGER; |
BEGIN |
DEC(ptr, 4); |
sys.GET(ptr, size); |
SYSTEM.GET(ptr, size); |
IF size <= MAX_SIZE THEN |
idx := ASR(size, 5); |
sys.PUT(ptr, pockets[idx]); |
SYSTEM.PUT(ptr, pockets[idx]); |
pockets[idx] := ptr |
ELSE |
size := sysfunc3(68, 13, ptr) |
size := K.sysfunc3(68, 13, ptr) |
END |
RETURN 0 |
END __DISPOSE; |
274,8 → 180,11 |
PROCEDURE NEW_DISPOSE (func, arg: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
EnterCriticalSection(CriticalSection); |
IF multi THEN |
EnterCriticalSection(CriticalSection) |
END; |
IF func = _new THEN |
res := __NEW(arg) |
283,7 → 192,10 |
res := __DISPOSE(arg) |
END; |
IF multi THEN |
LeaveCriticalSection(CriticalSection) |
END |
RETURN res |
END NEW_DISPOSE; |
298,63 → 210,110 |
END _DISPOSE; |
PROCEDURE ExitProcess* (p1: INTEGER); |
PROCEDURE exit* (p1: INTEGER); |
BEGIN |
p1 := sysfunc1(-1) |
END ExitProcess; |
K.sysfunc1(-1) |
END exit; |
PROCEDURE ExitThread* (p1: INTEGER); |
PROCEDURE exit_thread* (p1: INTEGER); |
BEGIN |
p1 := sysfunc1(-1) |
END ExitThread; |
K.sysfunc1(-1) |
END exit_thread; |
PROCEDURE OutChar (c: CHAR); |
VAR |
res: INTEGER; |
BEGIN |
res := sysfunc3(63, 1, ORD(c)) |
K.sysfunc3(63, 1, ORD(c)) |
END OutChar; |
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER); |
PROCEDURE OutLn; |
BEGIN |
OutChar(0DX); |
OutChar(0AX) |
END OutLn; |
PROCEDURE OutStr (pchar: INTEGER); |
VAR |
c: CHAR; |
BEGIN |
IF lpCaption # 0 THEN |
OutChar(0DX); |
OutChar(0AX); |
IF pchar # 0 THEN |
REPEAT |
sys.GET(lpCaption, c); |
SYSTEM.GET(pchar, c); |
IF c # 0X THEN |
OutChar(c) |
END; |
INC(lpCaption) |
UNTIL c = 0X; |
INC(pchar) |
UNTIL c = 0X |
END |
END OutStr; |
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER); |
BEGIN |
IF lpCaption # 0 THEN |
OutLn; |
OutStr(lpCaption); |
OutChar(":"); |
OutChar(0DX); |
OutChar(0AX) |
OutLn |
END; |
REPEAT |
sys.GET(lpText, c); |
IF c # 0X THEN |
OutChar(c) |
END; |
INC(lpText) |
UNTIL c = 0X; |
OutStr(lpText); |
IF lpCaption # 0 THEN |
OutChar(0DX); |
OutChar(0AX) |
OutLn |
END |
END DebugMsg; |
PROCEDURE init* (p1: INTEGER); |
PROCEDURE OutString (s: ARRAY OF CHAR); |
VAR |
i: INTEGER; |
BEGIN |
p1 := sysfunc2(68, 11); |
InitializeCriticalSection(CriticalSection) |
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 |
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/Args.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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); |
PROCEDURE ChangeCond(A, B, C: INTEGER; c: CHAR; VAR cond: 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); 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 |
|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 |
ELSE |
END; |
INC(p) |
/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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.ADR("/rd/1/colrdial"); |
res.start_path := sys.SADR("/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(v: INTEGER; name: ARRAY OF CHAR); |
PROCEDURE GetProc(Lib, 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(sys.ADR(Dialog_init), "ColorDialog_init"); |
GetProc(sys.ADR(Dialog_start), "ColorDialog_start"); |
GetProc(Lib, sys.ADR(Dialog_init), "ColorDialog_init"); |
GetProc(Lib, sys.ADR(Dialog_start), "ColorDialog_start"); |
END Load; |
BEGIN |
/programs/develop/oberon07/Lib/KolibriOS/Console.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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,8 → 17,9 |
MODULE Console; |
IMPORT ConsoleLib; |
IMPORT ConsoleLib, In, Out; |
CONST |
Black* = 0; Blue* = 1; Green* = 2; Cyan* = 3; |
26,23 → 27,29 |
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) |
49,18 → 56,39 |
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/ConsoleLib.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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(v: INTEGER; name: ARRAY OF CHAR); |
PROCEDURE GetProc(Lib, 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(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"); |
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"); |
END main; |
BEGIN |
/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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.0D5; |
CONST ERR* = -7.0E5; |
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL; |
VAR d, i: INTEGER; M: ARRAY 13 OF CHAR; Res: LONGREAL; |
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL; |
VAR d, i: INTEGER; M: ARRAY 14 OF CHAR; Res: REAL; |
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 := LONG(FLT(d)) + LONG(FLT(Hour * 3600000 + Min * 60000 + Sec * 1000)) / 86400000.0D0 |
Res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000) / 86400000.0 |
END |
END |
RETURN Res |
END Encode; |
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 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 MonthDay(n: INTEGER): BOOLEAN; |
PROCEDURE MonthDay(n: INTEGER; VAR d, Month: INTEGER; M: ARRAY OF CHAR): BOOLEAN; |
VAR Res: BOOLEAN; |
BEGIN |
Res := FALSE; |
60,9 → 60,9 |
END MonthDay; |
BEGIN |
IF (Date >= -693593.0D0) & (Date < 2958466.0D0) THEN |
IF (Date >= -693593.0) & (Date < 2958466.0) THEN |
d := FLOOR(Date); |
t := FLOOR((Date - LONG(FLT(d))) * 86400000.0D0); |
t := FLOOR((Date - FLT(d)) * 86400000.0); |
d := d + 693593; |
Year := 1; |
Month := 1; |
82,7 → 82,7 |
i := 1; |
flag := TRUE; |
WHILE flag & (i <= 12) DO |
flag := MonthDay(i); |
flag := MonthDay(i, d, Month, M); |
INC(i) |
END; |
Day := d; |
98,7 → 98,7 |
RETURN Res |
END Decode; |
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec: INTEGER); |
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec, Msec: INTEGER); |
VAR date, time: INTEGER; |
BEGIN |
date := KOSAPI.sysfunc1(29); |
134,7 → 134,8 |
Sec := (time MOD 16) * 10 + Sec; |
time := time DIV 16; |
Year := Year + 2000 |
Year := Year + 2000; |
Msec := 0 |
END Now; |
END DateTime. |
/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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.0D0 - 5.0D-12; |
d = 1.0 - 5.0E-12; |
VAR |
Realp: PROCEDURE (x: LONGREAL; width: INTEGER); |
Realp: PROCEDURE (x: REAL; width: INTEGER); |
PROCEDURE Char*(c: CHAR); |
VAR res: INTEGER; |
72,7 → 72,7 |
UNTIL i = 0 |
END WriteInt; |
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN; |
PROCEDURE IsNan(AValue: REAL): 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: LONGREAL): BOOLEAN; |
RETURN ABS(x) = sys.INF(LONGREAL) |
PROCEDURE IsInf(x: REAL): BOOLEAN; |
RETURN ABS(x) = sys.INF() |
END IsInf; |
PROCEDURE Int*(x, width: INTEGER); |
97,15 → 97,15 |
END |
END Int; |
PROCEDURE OutInf(x: LONGREAL; width: INTEGER); |
VAR s: ARRAY 4 OF CHAR; i: INTEGER; |
PROCEDURE OutInf(x: REAL; width: INTEGER); |
VAR s: ARRAY 5 OF CHAR; i: INTEGER; |
BEGIN |
IF IsNan(x) THEN |
s := "Nan"; |
INC(width) |
ELSIF IsInf(x) & (x > 0.0D0) THEN |
ELSIF IsInf(x) & (x > 0.0) THEN |
s := "+Inf" |
ELSIF IsInf(x) & (x < 0.0D0) THEN |
ELSIF IsInf(x) & (x < 0.0) THEN |
s := "-Inf" |
END; |
FOR i := 1 TO width - 4 DO |
120,8 → 120,8 |
Char(0AX) |
END Ln; |
PROCEDURE _FixReal(x: LONGREAL; width, p: INTEGER); |
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN; |
PROCEDURE _FixReal(x: REAL; width, p: INTEGER); |
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN; |
BEGIN |
IF IsNan(x) OR IsInf(x) THEN |
OutInf(x, width) |
130,19 → 130,19 |
ELSE |
len := 0; |
minus := FALSE; |
IF x < 0.0D0 THEN |
IF x < 0.0 THEN |
minus := TRUE; |
INC(len); |
x := ABS(x) |
END; |
e := 0; |
WHILE x >= 10.0D0 DO |
x := x / 10.0D0; |
WHILE x >= 10.0 DO |
x := x / 10.0; |
INC(e) |
END; |
IF e >= 0 THEN |
len := len + e + p + 1; |
IF x > 9.0D0 + d THEN |
IF x > 9.0 + d THEN |
INC(len) |
END; |
IF p > 0 THEN |
158,30 → 158,30 |
Char("-") |
END; |
y := x; |
WHILE (y < 1.0D0) & (y # 0.0D0) DO |
y := y * 10.0D0; |
WHILE (y < 1.0) & (y # 0.0) DO |
y := y * 10.0; |
DEC(e) |
END; |
IF e < 0 THEN |
IF x - LONG(FLT(FLOOR(x))) > d THEN |
IF x - FLT(FLOOR(x)) > d THEN |
Char("1"); |
x := 0.0D0 |
x := 0.0 |
ELSE |
Char("0"); |
x := x * 10.0D0 |
x := x * 10.0 |
END |
ELSE |
WHILE e >= 0 DO |
IF x - LONG(FLT(FLOOR(x))) > d THEN |
IF x > 9.0D0 THEN |
IF x - FLT(FLOOR(x)) > d THEN |
IF x > 9.0 THEN |
String("10") |
ELSE |
Char(CHR(FLOOR(x) + ORD("0") + 1)) |
END; |
x := 0.0D0 |
x := 0.0 |
ELSE |
Char(CHR(FLOOR(x) + ORD("0"))); |
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 |
x := (x - FLT(FLOOR(x))) * 10.0 |
END; |
DEC(e) |
END |
190,12 → 190,12 |
Char(".") |
END; |
WHILE p > 0 DO |
IF x - LONG(FLT(FLOOR(x))) > d THEN |
IF x - FLT(FLOOR(x)) > d THEN |
Char(CHR(FLOOR(x) + ORD("0") + 1)); |
x := 0.0D0 |
x := 0.0 |
ELSE |
Char(CHR(FLOOR(x) + ORD("0"))); |
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 |
x := (x - FLT(FLOOR(x))) * 10.0 |
END; |
DEC(p) |
END |
202,7 → 202,7 |
END |
END _FixReal; |
PROCEDURE Real*(x: LONGREAL; width: INTEGER); |
PROCEDURE Real*(x: REAL; 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.0D0 THEN |
IF x < 0.0 THEN |
x := -x; |
minus := TRUE |
ELSE |
minus := FALSE |
END; |
WHILE x >= 10.0D0 DO |
x := x / 10.0D0; |
WHILE x >= 10.0 DO |
x := x / 10.0; |
INC(e) |
END; |
WHILE (x < 1.0D0) & (x # 0.0D0) DO |
x := x * 10.0D0; |
WHILE (x < 1.0) & (x # 0.0) DO |
x := x * 10.0; |
DEC(e) |
END; |
IF x > 9.0D0 + d THEN |
x := 1.0D0; |
IF x > 9.0 + d THEN |
x := 1.0; |
INC(e) |
END; |
FOR i := 1 TO n DO |
260,7 → 260,7 |
END |
END Real; |
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER); |
PROCEDURE FixReal*(x: REAL; width, p: INTEGER); |
BEGIN |
Realp := Real; |
_FixReal(x, width, p) |
282,7 → 282,7 |
BEGIN |
info.subfunc := 7; |
info.flags := 0; |
info.param := sys.ADR(" "); |
info.param := sys.SADR(" "); |
info.rsrvd1 := 0; |
info.rsrvd2 := 0; |
info.fname := "/rd/1/develop/board"; |
/programs/develop/oberon07/Lib/KolibriOS/File.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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,12 |
IMPORT sys := SYSTEM, KOSAPI; |
CONST |
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2; |
TYPE |
FNAME* = ARRAY 520 OF CHAR; |
47,29 → 49,36 |
name*: FNAME |
END; |
PROCEDURE [stdcall] f_68_27(file_name: INTEGER; VAR size: INTEGER): INTEGER; |
BEGIN |
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 *) |
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 *) |
) |
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; |
77,15 → 86,19 |
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 |
93,9 → 106,13 |
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 |
109,12 → 126,18 |
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 |
132,12 → 155,18 |
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 |
149,12 → 178,17 |
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; |
166,12 → 200,17 |
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; |
183,13 → 222,19 |
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; |
201,19 → 246,27 |
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; |
226,12 → 279,18 |
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 |
249,7 → 308,9 |
ELSE |
res := -1 |
END |
RETURN res = 0 |
END DeleteDir; |
END File. |
/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07 |
---|
1,246 → 1,471 |
(* |
Copyright 2016, 2017 Anton Krotov |
(* |
BSD 2-Clause License |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE HOST; |
IMPORT sys := SYSTEM, API; |
IMPORT SYSTEM, K := KOSAPI, API, RTL; |
CONST |
slash* = "/"; |
OS* = "KOS"; |
Slash* = "/"; |
bit_depth* = RTL.bit_depth; |
maxint* = RTL.maxint; |
minint* = RTL.minint; |
MAX_PARAM = 1024; |
TYPE |
FILENAME = ARRAY 2048 OF CHAR; |
FNAME = ARRAY 520 OF CHAR; |
OFSTRUCT = RECORD |
subfunc, pos, hpos, bytes, buf: INTEGER; |
name: FILENAME |
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; |
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); |
fsize, sec*, dsec*: INTEGER; |
Console: BOOLEAN; |
PROCEDURE [stdcall] sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): 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); |
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("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; |
IF Console THEN |
con_exit(FALSE) |
END; |
K.sysfunc1(-1) |
END ExitProcess; |
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER; |
VAR cur, procname, adr: INTEGER; |
PROCEDURE streq(str1, str2: INTEGER): BOOLEAN; |
VAR c1, c2: CHAR; |
PROCEDURE OutChar* (c: CHAR); |
BEGIN |
REPEAT |
sys.GET(str1, c1); |
sys.GET(str2, c2); |
INC(str1); |
INC(str2) |
UNTIL (c1 # c2) OR (c1 = 0X) |
RETURN c1 = c2 |
END streq; |
IF Console THEN |
con_write_string(SYSTEM.ADR(c), 1) |
ELSE |
K.sysfunc3(63, 1, ORD(c)) |
END |
END OutChar; |
PROCEDURE GetFileInfo (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN; |
VAR |
res2: INTEGER; |
fs: rFS; |
BEGIN |
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) |
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) |
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 |
RETURN adr |
END GetProcAdr; |
ELSE |
F := NIL |
END |
PROCEDURE Time*(VAR sec, dsec: INTEGER); |
VAR t: INTEGER; |
RETURN F |
END Open; |
PROCEDURE Read (F: FS; Buffer, Count: INTEGER): INTEGER; |
VAR |
res, res2: INTEGER; |
BEGIN |
t := API.sysfunc2(26, 9); |
sec := t DIV 100; |
dsec := t MOD 100 |
END Time; |
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 |
PROCEDURE init*; |
VAR Lib: INTEGER; |
RETURN res2 |
END Read; |
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR); |
VAR a: INTEGER; |
PROCEDURE Write (F: FS; Buffer, Count: INTEGER): INTEGER; |
VAR |
res, res2: INTEGER; |
BEGIN |
a := GetProcAdr(name, Lib); |
sys.PUT(v, a) |
END GetProc; |
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 |
RETURN res2 |
END Write; |
PROCEDURE Create (FName: ARRAY OF CHAR): FS; |
VAR |
F: FS; |
res2: INTEGER; |
BEGIN |
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")) |
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) |
END |
END |
END init; |
PROCEDURE ExitProcess* (n: INTEGER); |
RETURN F |
END Create; |
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
VAR |
n: INTEGER; |
fs: FS; |
BEGIN |
IF con_exit # NIL THEN |
con_exit(FALSE) |
END; |
API.ExitProcess(0) |
END ExitProcess; |
SYSTEM.GET(SYSTEM.ADR(F), fs); |
n := Read(fs, SYSTEM.ADR(Buffer[0]), bytes); |
IF n = 0 THEN |
n := -1 |
END |
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 := API.sysfunc3(9, sys.ADR(buf), -1); |
sys.GET(sys.ADR(buf) + 22, a) |
a := K.sysfunc3(9, SYSTEM.ADR(buf), -1); |
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a) |
RETURN a |
END AppAdr; |
PROCEDURE GetCommandLine*(): INTEGER; |
VAR param: INTEGER; |
PROCEDURE GetCommandLine (): INTEGER; |
VAR |
param: INTEGER; |
BEGIN |
sys.GET(28 + AppAdr(), param) |
SYSTEM.GET(28 + AppAdr(), param) |
RETURN param |
END GetCommandLine; |
PROCEDURE GetName*(): INTEGER; |
VAR name: INTEGER; |
PROCEDURE GetName (): INTEGER; |
VAR |
name: INTEGER; |
BEGIN |
sys.GET(32 + AppAdr(), name) |
SYSTEM.GET(32 + AppAdr(), name) |
RETURN name |
END GetName; |
PROCEDURE malloc*(size: INTEGER): INTEGER; |
RETURN API.sysfunc3(68, 12, size) |
END malloc; |
PROCEDURE CloseFile*(hObject: INTEGER); |
VAR pFS: POINTER TO OFSTRUCT; |
PROCEDURE GetChar (adr: INTEGER): CHAR; |
VAR |
res: CHAR; |
BEGIN |
sys.PUT(sys.ADR(pFS), hObject); |
DISPOSE(pFS) |
END CloseFile; |
SYSTEM.GET(adr, res) |
RETURN res |
END GetChar; |
PROCEDURE _OCFile(FileName: ARRAY OF CHAR; VAR FS: OFSTRUCT; mode: INTEGER; VAR fsize: INTEGER): INTEGER; |
VAR buf: ARRAY 40 OF CHAR; res: INTEGER; |
PROCEDURE ParamParse; |
VAR |
p, count, name, cond: INTEGER; |
c: CHAR; |
PROCEDURE ChangeCond (A, B, C: INTEGER; c: CHAR; VAR cond: INTEGER); |
BEGIN |
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) |
IF (c <= 20X) & (c # 0X) THEN |
cond := A |
ELSIF c = 22X THEN |
cond := B |
ELSIF c = 0X THEN |
cond := 6 |
ELSE |
res := 0 |
cond := C |
END |
RETURN res |
END _OCFile; |
END ChangeCond; |
PROCEDURE IOFile(VAR FS: OFSTRUCT; Buffer, bytes, io: INTEGER): INTEGER; |
VAR res1, res: INTEGER; |
BEGIN |
FS.subfunc := io; |
FS.bytes := bytes; |
FS.buf := Buffer; |
res1 := sysfunc22(70, sys.ADR(FS), res); |
IF res = -1 THEN |
res := 0 |
p := GetCommandLine(); |
name := GetName(); |
Params[0, 0] := name; |
WHILE GetChar(name) # 0X DO |
INC(name) |
END; |
FS.pos := FS.pos + res |
RETURN res |
END IOFile; |
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; |
PROCEDURE OCFile(FName: ARRAY OF CHAR; mode: INTEGER): INTEGER; |
VAR FS: OFSTRUCT; pFS: POINTER TO OFSTRUCT; res: INTEGER; |
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR); |
VAR |
i, j, len: INTEGER; |
c: CHAR; |
BEGIN |
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; |
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; |
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER; |
RETURN OCFile(FName, 2) |
END CreateFile; |
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER; |
RETURN OCFile(FName, 5) |
END OpenFile; |
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR); |
VAR |
n: INTEGER; |
PROCEDURE FileSize* (F: INTEGER): INTEGER; |
RETURN fsize |
END FileSize; |
BEGIN |
GetArg(0, path); |
n := LENGTH(path) - 1; |
WHILE path[n] # slash DO |
DEC(n) |
END; |
path[n + 1] := 0X |
END GetCurrentDirectory; |
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER; |
VAR pFS: POINTER TO OFSTRUCT; res: INTEGER; |
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; |
BEGIN |
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; |
date := K.sysfunc1(29); |
time := K.sysfunc1(3); |
PROCEDURE OutString* (str: ARRAY OF CHAR); |
VAR n: INTEGER; |
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; |
BEGIN |
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; |
SYSTEM.GET(SYSTEM.ADR(x), a); |
SYSTEM.GET(SYSTEM.ADR(x) + 4, b) |
RETURN a |
END splitf; |
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/In.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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): LONGREAL; |
CONST maxDBL = 1.69D308; maxINT = 7FFFFFFFH; |
VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, neg: BOOLEAN; |
PROCEDURE StrToFloat(str: STRING; VAR err: BOOLEAN): REAL; |
CONST maxDBL = 1.69E308; maxINT = 7FFFFFFFH; |
VAR i, scale: INTEGER; res, m, d: REAL; minus, neg: BOOLEAN; |
PROCEDURE part1(): BOOLEAN; |
PROCEDURE part1 (str: STRING; VAR res, d: REAL; VAR i: INTEGER): BOOLEAN; |
BEGIN |
res := 0.0D0; |
d := 1.0D0; |
res := 0.0; |
d := 1.0; |
WHILE digit(str[i]) DO |
res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0"))); |
res := res * 10.0 + FLT(ORD(str[i]) - ORD("0")); |
INC(i) |
END; |
IF str[i] = "." THEN |
INC(i); |
WHILE digit(str[i]) DO |
d := d / 10.0D0; |
res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d; |
d := d / 10.0; |
res := res + FLT(ORD(str[i]) - ORD("0")) * d; |
INC(i) |
END |
END |
157,10 → 157,10 |
RETURN str[i] # 0X |
END part1; |
PROCEDURE part2(): BOOLEAN; |
PROCEDURE part2 (str: STRING; VAR i, scale: INTEGER; VAR minus, err: BOOLEAN; VAR m, res: REAL): BOOLEAN; |
BEGIN |
INC(i); |
m := 10.0D0; |
m := 10.0; |
minus := FALSE; |
IF str[i] = "+" THEN |
INC(i) |
167,7 → 167,7 |
ELSIF str[i] = "-" THEN |
minus := TRUE; |
INC(i); |
m := 0.1D0 |
m := 0.1 |
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.0D0 |
res := 0.0 |
ELSE |
scale := scale * 10; |
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN |
err := TRUE; |
res := 0.0D0 |
res := 0.0 |
ELSE |
scale := scale + (ORD(str[i]) - ORD("0")); |
INC(i) |
189,19 → 189,19 |
RETURN ~err |
END part2; |
PROCEDURE part3; |
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR res, m: REAL; VAR scale: INTEGER); |
VAR i: INTEGER; |
BEGIN |
err := FALSE; |
IF scale = maxINT THEN |
err := TRUE; |
res := 0.0D0 |
res := 0.0 |
END; |
i := 1; |
WHILE ~err & (i <= scale) DO |
IF ~minus & (res > maxDBL / m) THEN |
err := TRUE; |
res := 0.0D0 |
res := 0.0 |
ELSE |
res := res * m; |
INC(i) |
211,14 → 211,14 |
BEGIN |
IF CheckReal(str, i, neg) THEN |
IF part1() & part2() THEN |
part3 |
IF part1(str, res, d, i) & part2(str, i, scale, minus, err, m, res) THEN |
part3(err, minus, res, m, scale) |
END; |
IF neg THEN |
res := -res |
END |
ELSE |
res := 0.0D0; |
res := 0.0; |
err := TRUE |
END |
RETURN res |
251,7 → 251,7 |
Done := TRUE |
END Ln; |
PROCEDURE LongReal*(VAR x: LONGREAL); |
PROCEDURE Real* (VAR x: REAL); |
VAR str: STRING; err: BOOLEAN; |
BEGIN |
err := FALSE; |
260,23 → 260,9 |
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/KOSAPI.ob07 |
---|
1,162 → 1,195 |
(* |
Copyright 2016, 2018 Anton Krotov |
(* |
BSD 2-Clause License |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE KOSAPI; |
IMPORT sys := SYSTEM; |
IMPORT SYSTEM; |
TYPE STRING = ARRAY 1024 OF CHAR; |
VAR DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER); |
TYPE |
PROCEDURE [stdcall] sysfunc1*(arg1: INTEGER): 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; |
BEGIN |
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *) |
sys.CODE("CD40"); (* int 40h *) |
sys.CODE("C9"); (* leave *) |
sys.CODE("C20400"); (* ret 04h *) |
SYSTEM.CODE( |
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *) |
0CDH, 040H, (* int 64 *) |
0C9H, (* leave *) |
0C2H, 004H, 000H (* ret 4 *) |
) |
RETURN 0 |
END sysfunc1; |
PROCEDURE [stdcall] sysfunc2*(arg1, arg2: INTEGER): INTEGER; |
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 *) |
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 *) |
) |
RETURN 0 |
END sysfunc2; |
PROCEDURE [stdcall] sysfunc3*(arg1, arg2, arg3: INTEGER): INTEGER; |
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 *) |
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 *) |
) |
RETURN 0 |
END sysfunc3; |
PROCEDURE [stdcall] sysfunc4*(arg1, arg2, arg3, arg4: INTEGER): INTEGER; |
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 *) |
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 *) |
) |
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 |
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 *) |
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 *) |
) |
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 |
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 *) |
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 *) |
) |
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 |
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 *) |
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 *) |
) |
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 |
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 *) |
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 *) |
) |
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 |
sys.PUT(tmp, 0) |
SYSTEM.PUT(tmp, 0) |
END |
END mem_commit; |
PROCEDURE [stdcall] malloc*(size: INTEGER): INTEGER; |
VAR ptr: INTEGER; |
VAR |
ptr: INTEGER; |
BEGIN |
sys.CODE("60"); (* pusha *) |
SYSTEM.CODE(060H); (* pusha *) |
IF sysfunc2(18, 16) > ASR(size, 10) THEN |
ptr := sysfunc3(68, 12, size); |
IF ptr # 0 THEN |
165,98 → 198,122 |
ELSE |
ptr := 0 |
END; |
sys.CODE("61") (* popa *) |
SYSTEM.CODE(061H) (* popa *) |
RETURN ptr |
END malloc; |
PROCEDURE [stdcall] free*(ptr: INTEGER): INTEGER; |
BEGIN |
sys.CODE("60"); (* pusha *) |
SYSTEM.CODE(060H); (* pusha *) |
IF ptr # 0 THEN |
ptr := sysfunc3(68, 13, ptr) |
END; |
sys.CODE("61") (* popa *) |
SYSTEM.CODE(061H) (* popa *) |
RETURN 0 |
END free; |
PROCEDURE [stdcall] realloc*(ptr, size: INTEGER): INTEGER; |
BEGIN |
sys.CODE("60"); (* pusha *) |
SYSTEM.CODE(060H); (* pusha *) |
ptr := sysfunc4(68, 20, size, ptr); |
sys.CODE("61") (* popa *) |
SYSTEM.CODE(061H) (* popa *) |
RETURN ptr |
END realloc; |
PROCEDURE AppAdr(): INTEGER; |
VAR |
buf: ARRAY 1024 OF CHAR; |
a: INTEGER; |
BEGIN |
a := sysfunc3(9, sys.ADR(buf), -1); |
sys.GET(sys.ADR(buf) + 22, a) |
a := sysfunc3(9, SYSTEM.ADR(buf), -1); |
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a) |
RETURN a |
END AppAdr; |
PROCEDURE GetCommandLine*(): INTEGER; |
VAR param: INTEGER; |
VAR |
param: INTEGER; |
BEGIN |
sys.GET(28 + AppAdr(), param) |
SYSTEM.GET(28 + AppAdr(), param) |
RETURN param |
END GetCommandLine; |
PROCEDURE GetName*(): INTEGER; |
VAR name: INTEGER; |
VAR |
name: INTEGER; |
BEGIN |
sys.GET(32 + AppAdr(), name) |
SYSTEM.GET(32 + AppAdr(), name) |
RETURN name |
END GetName; |
PROCEDURE [stdcall] dll_init2(arg1, arg2, arg3, arg4, arg5: INTEGER); |
BEGIN |
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 *) |
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 *) |
) |
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 |
sys.GET(str1, c1); |
sys.GET(str2, c2); |
SYSTEM.GET(str1, c1); |
SYSTEM.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 |
sys.GET(cur, procname); |
SYSTEM.GET(cur, procname); |
INC(cur, 8) |
UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0])); |
UNTIL (procname = 0) OR streq(procname, SYSTEM.ADR(name[0])); |
IF procname # 0 THEN |
sys.GET(cur - 4, adr) |
SYSTEM.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 |
265,51 → 322,62 |
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 |
sys.GET(adr, c); INC(adr); |
SYSTEM.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 |
sys.CODE("60"); (* pusha *) |
SYSTEM.CODE(060H); (* pusha *) |
fail := FALSE; |
done := FALSE; |
res := 0; |
libname := "/rd/1/lib/"; |
REPEAT |
sys.GET(import_table, imp); |
SYSTEM.GET(import_table, imp); |
IF imp # 0 THEN |
sys.GET(import_table + 4, lib); |
SYSTEM.GET(import_table + 4, lib); |
GetStr(lib, 10, libname); |
exp := sysfunc3(68, 19, sys.ADR(libname[0])); |
exp := sysfunc3(68, 19, SYSTEM.ADR(libname[0])); |
fail := exp = 0; |
ELSE |
done := TRUE |
END; |
IF fail THEN |
done := TRUE |
done := TRUE; |
imp_error.proc := ""; |
imp_error.lib := libname; |
imp_error.error := 1 |
END; |
IF (imp # 0) & ~fail THEN |
REPEAT |
sys.GET(imp, proc); |
SYSTEM.GET(imp, proc); |
IF proc # 0 THEN |
GetStr(proc, 0, procname); |
proc := GetProcAdr(procname, exp); |
IF proc # 0 THEN |
sys.PUT(imp, proc); |
INC(imp, 4); |
SYSTEM.PUT(imp, proc); |
INC(imp, 4) |
ELSE |
imp_error.proc := procname; |
imp_error.lib := libname; |
imp_error.error := 2 |
END |
END |
UNTIL proc = 0; |
321,24 → 389,28 |
res := 1 |
END; |
import_table := res; |
sys.CODE("61") (* popa *) |
SYSTEM.CODE(061H) (* popa *) |
RETURN import_table |
END dll_Load; |
PROCEDURE [stdcall] dll_Init(entry: INTEGER); |
BEGIN |
sys.CODE("60"); (* pusha *) |
SYSTEM.CODE(060H); (* pusha *) |
IF entry # 0 THEN |
dll_init2(sys.ADR(malloc), sys.ADR(free), sys.ADR(realloc), sys.ADR(dll_Load), entry) |
dll_init2(SYSTEM.ADR(malloc), SYSTEM.ADR(free), SYSTEM.ADR(realloc), SYSTEM.ADR(dll_Load), entry) |
END; |
sys.CODE("61"); (* popa *) |
SYSTEM.CODE(061H); (* 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, sys.ADR(name[0])); |
Lib := sysfunc3(68, 19, SYSTEM.ADR(name[0])); |
IF Lib # 0 THEN |
init(Lib) |
END |
345,4 → 417,14 |
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/Math.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2013, 2014, 2018 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,238 → 17,365 |
MODULE Math; |
IMPORT sys := SYSTEM; |
IMPORT SYSTEM; |
CONST pi* = 3.141592653589793D+00; |
e* = 2.718281828459045D+00; |
VAR Inf*, nInf*: LONGREAL; |
CONST |
PROCEDURE IsNan*(x: LONGREAL): BOOLEAN; |
VAR h, l: SET; |
pi* = 3.141592653589793; |
e* = 2.718281828459045; |
PROCEDURE IsNan* (x: REAL): BOOLEAN; |
VAR |
h, l: SET; |
BEGIN |
sys.GET(sys.ADR(x), l); |
sys.GET(sys.ADR(x) + 4, h); |
SYSTEM.GET(SYSTEM.ADR(x), l); |
SYSTEM.GET(SYSTEM.ADR(x) + 4, h) |
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {})) |
END IsNan; |
PROCEDURE IsInf*(x: LONGREAL): BOOLEAN; |
RETURN ABS(x) = sys.INF(LONGREAL) |
PROCEDURE IsInf* (x: REAL): BOOLEAN; |
RETURN ABS(x) = SYSTEM.INF() |
END IsInf; |
PROCEDURE Max(A, B: LONGREAL): LONGREAL; |
VAR Res: LONGREAL; |
PROCEDURE Max (a, b: REAL): REAL; |
VAR |
res: REAL; |
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: LONGREAL): LONGREAL; |
VAR Res: LONGREAL; |
PROCEDURE Min (a, b: REAL): REAL; |
VAR |
res: REAL; |
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: LONGREAL): BOOLEAN; |
VAR Epsilon: LONGREAL; Res: BOOLEAN; |
PROCEDURE SameValue (a, b: REAL): BOOLEAN; |
VAR |
eps: REAL; |
res: BOOLEAN; |
BEGIN |
Epsilon := Max(Min(ABS(A), ABS(B)) * 1.0D-12, 1.0D-12); |
IF A > B THEN |
Res := (A - B) <= Epsilon |
eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12); |
IF a > b THEN |
res := (a - b) <= eps |
ELSE |
Res := (B - A) <= Epsilon |
res := (b - a) <= eps |
END |
RETURN Res |
RETURN res |
END SameValue; |
PROCEDURE IsZero(x: LONGREAL): BOOLEAN; |
RETURN ABS(x) <= 1.0D-12 |
PROCEDURE IsZero (x: REAL): BOOLEAN; |
RETURN ABS(x) <= 1.0E-12 |
END IsZero; |
PROCEDURE [stdcall] sqrt*(x: LONGREAL): LONGREAL; |
PROCEDURE [stdcall] sqrt* (x: REAL): REAL; |
BEGIN |
sys.CODE("DD4508D9FAC9C20800") |
RETURN 0.0D0 |
SYSTEM.CODE( |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0FAH, (* fsqrt *) |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END sqrt; |
PROCEDURE [stdcall] sin*(x: LONGREAL): LONGREAL; |
PROCEDURE [stdcall] sin* (x: REAL): REAL; |
BEGIN |
sys.CODE("DD4508D9FEC9C20800") |
RETURN 0.0D0 |
SYSTEM.CODE( |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0FEH, (* fsin *) |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END sin; |
PROCEDURE [stdcall] cos*(x: LONGREAL): LONGREAL; |
PROCEDURE [stdcall] cos* (x: REAL): REAL; |
BEGIN |
sys.CODE("DD4508D9FFC9C20800") |
RETURN 0.0D0 |
SYSTEM.CODE( |
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *) |
0D9H, 0FFH, (* fcos *) |
0C9H, (* leave *) |
0C2H, 008H, 000H (* ret 08h *) |
) |
RETURN 0.0 |
END cos; |
PROCEDURE [stdcall] tan*(x: LONGREAL): LONGREAL; |
PROCEDURE [stdcall] tan* (x: REAL): REAL; |
BEGIN |
sys.CODE("DD4508D9F2DEC9C9C20800") |
RETURN 0.0D0 |
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 |
END tan; |
PROCEDURE [stdcall] arctan2*(y, x: LONGREAL): LONGREAL; |
PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL; |
BEGIN |
sys.CODE("DD4508DD4510D9F3C9C21000") |
RETURN 0.0D0 |
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 |
END arctan2; |
PROCEDURE [stdcall] ln*(x: LONGREAL): LONGREAL; |
PROCEDURE [stdcall] ln* (x: REAL): REAL; |
BEGIN |
sys.CODE("D9EDDD4508D9F1C9C20800") |
RETURN 0.0D0 |
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 |
END ln; |
PROCEDURE [stdcall] log*(base, x: LONGREAL): LONGREAL; |
PROCEDURE [stdcall] log* (base, x: REAL): REAL; |
BEGIN |
sys.CODE("D9E8DD4510D9F1D9E8DD4508D9F1DEF9C9C21000") |
RETURN 0.0D0 |
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 |
END log; |
PROCEDURE [stdcall] exp*(x: LONGREAL): LONGREAL; |
PROCEDURE [stdcall] exp* (x: REAL): REAL; |
BEGIN |
sys.CODE("DD4508D9EADEC9D9C0D9FCDCE9D9C9D9F0D9E8DEC1D9FDDDD9C9C20800") |
RETURN 0.0D0 |
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 |
END exp; |
PROCEDURE [stdcall] round*(x: LONGREAL): LONGREAL; |
PROCEDURE [stdcall] round* (x: REAL): REAL; |
BEGIN |
sys.CODE("DD4508D97DF4D97DF666814DF60003D96DF6D9FCD96DF4C9C20800") |
RETURN 0.0D0 |
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 |
END round; |
PROCEDURE [stdcall] frac*(x: LONGREAL): LONGREAL; |
PROCEDURE [stdcall] frac* (x: REAL): REAL; |
BEGIN |
sys.CODE("50DD4508D9C0D93C24D97C240266814C2402000FD96C2402D9FCD92C24DEE9C9C20800") |
RETURN 0.0D0 |
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 |
END frac; |
PROCEDURE arcsin*(x: LONGREAL): LONGREAL; |
RETURN arctan2(x, sqrt(1.0D0 - x * x)) |
PROCEDURE arcsin* (x: REAL): REAL; |
RETURN arctan2(x, sqrt(1.0 - x * x)) |
END arcsin; |
PROCEDURE arccos*(x: LONGREAL): LONGREAL; |
RETURN arctan2(sqrt(1.0D0 - x * x), x) |
PROCEDURE arccos* (x: REAL): REAL; |
RETURN arctan2(sqrt(1.0 - x * x), x) |
END arccos; |
PROCEDURE arctan*(x: LONGREAL): LONGREAL; |
RETURN arctan2(x, 1.0D0) |
PROCEDURE arctan* (x: REAL): REAL; |
RETURN arctan2(x, 1.0) |
END arctan; |
PROCEDURE sinh*(x: LONGREAL): LONGREAL; |
VAR Res: LONGREAL; |
PROCEDURE sinh* (x: REAL): REAL; |
VAR |
res: REAL; |
BEGIN |
IF IsZero(x) THEN |
Res := 0.0D0 |
res := 0.0 |
ELSE |
Res := (exp(x) - exp(-x)) / 2.0D0 |
res := (exp(x) - exp(-x)) / 2.0 |
END |
RETURN Res |
RETURN res |
END sinh; |
PROCEDURE cosh*(x: LONGREAL): LONGREAL; |
VAR Res: LONGREAL; |
PROCEDURE cosh* (x: REAL): REAL; |
VAR |
res: REAL; |
BEGIN |
IF IsZero(x) THEN |
Res := 1.0D0 |
res := 1.0 |
ELSE |
Res := (exp(x) + exp(-x)) / 2.0D0 |
res := (exp(x) + exp(-x)) / 2.0 |
END |
RETURN Res |
RETURN res |
END cosh; |
PROCEDURE tanh*(x: LONGREAL): LONGREAL; |
VAR Res: LONGREAL; |
PROCEDURE tanh* (x: REAL): REAL; |
VAR |
res: REAL; |
BEGIN |
IF IsZero(x) THEN |
Res := 0.0D0 |
res := 0.0 |
ELSE |
Res := sinh(x) / cosh(x) |
res := sinh(x) / cosh(x) |
END |
RETURN Res |
RETURN res |
END tanh; |
PROCEDURE arcsinh*(x: LONGREAL): LONGREAL; |
RETURN ln(x + sqrt((x * x) + 1.0D0)) |
PROCEDURE arcsinh* (x: REAL): REAL; |
RETURN ln(x + sqrt((x * x) + 1.0)) |
END arcsinh; |
PROCEDURE arccosh*(x: LONGREAL): LONGREAL; |
RETURN ln(x + sqrt((x - 1.0D0) / (x + 1.0D0)) * (x + 1.0D0)) |
PROCEDURE arccosh* (x: REAL): REAL; |
RETURN ln(x + sqrt((x - 1.0) / (x + 1.0)) * (x + 1.0)) |
END arccosh; |
PROCEDURE arctanh*(x: LONGREAL): LONGREAL; |
VAR Res: LONGREAL; |
PROCEDURE arctanh* (x: REAL): REAL; |
VAR |
res: REAL; |
BEGIN |
IF SameValue(x, 1.0D0) THEN |
Res := Inf |
ELSIF SameValue(x, -1.0D0) THEN |
Res := nInf |
IF SameValue(x, 1.0) THEN |
res := SYSTEM.INF() |
ELSIF SameValue(x, -1.0) THEN |
res := -SYSTEM.INF() |
ELSE |
Res := 0.5D0 * ln((1.0D0 + x) / (1.0D0 - x)) |
res := 0.5 * ln((1.0 + x) / (1.0 - x)) |
END |
RETURN Res |
RETURN res |
END arctanh; |
PROCEDURE floor*(x: LONGREAL): LONGREAL; |
VAR f: LONGREAL; |
PROCEDURE floor* (x: REAL): REAL; |
VAR |
f: REAL; |
BEGIN |
f := frac(x); |
x := x - f; |
IF f < 0.0D0 THEN |
x := x - 1.0D0 |
IF f < 0.0 THEN |
x := x - 1.0 |
END |
RETURN x |
END floor; |
PROCEDURE ceil*(x: LONGREAL): LONGREAL; |
VAR f: LONGREAL; |
PROCEDURE ceil* (x: REAL): REAL; |
VAR |
f: REAL; |
BEGIN |
f := frac(x); |
x := x - f; |
IF f > 0.0D0 THEN |
x := x + 1.0D0 |
IF f > 0.0 THEN |
x := x + 1.0 |
END |
RETURN x |
END ceil; |
PROCEDURE power*(base, exponent: LONGREAL): LONGREAL; |
VAR Res: LONGREAL; |
PROCEDURE power* (base, exponent: REAL): REAL; |
VAR |
res: REAL; |
BEGIN |
IF exponent = 0.0D0 THEN |
Res := 1.0D0 |
ELSIF (base = 0.0D0) & (exponent > 0.0D0) THEN |
Res := 0.0D0 |
IF exponent = 0.0 THEN |
res := 1.0 |
ELSIF (base = 0.0) & (exponent > 0.0) THEN |
res := 0.0 |
ELSE |
Res := exp(exponent * ln(base)) |
res := exp(exponent * ln(base)) |
END |
RETURN Res |
RETURN res |
END power; |
PROCEDURE sgn*(x: LONGREAL): INTEGER; |
VAR Res: INTEGER; |
PROCEDURE sgn* (x: REAL): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF x > 0.0D0 THEN |
Res := 1 |
ELSIF x < 0.0D0 THEN |
Res := -1 |
IF x > 0.0 THEN |
res := 1 |
ELSIF x < 0.0 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 Anton Krotov |
(* |
Copyright 2016, 2018 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.ADR("/rd/1/File managers/opendial"); |
res.start_path := sys.SADR("/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(v: INTEGER; name: ARRAY OF CHAR); |
PROCEDURE GetProc(Lib, 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(sys.ADR(Dialog_init), "OpenDialog_init"); |
GetProc(sys.ADR(Dialog_start), "OpenDialog_start"); |
GetProc(Lib, sys.ADR(Dialog_init), "OpenDialog_init"); |
GetProc(Lib, sys.ADR(Dialog_start), "OpenDialog_start"); |
END Load; |
BEGIN |
/programs/develop/oberon07/Lib/KolibriOS/Out.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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.0D0 - 5.0D-12; |
d = 1.0 - 5.0E-12; |
VAR |
Realp: PROCEDURE (x: LONGREAL; width: INTEGER); |
Realp: PROCEDURE (x: REAL; width: INTEGER); |
PROCEDURE Char*(c: CHAR); |
BEGIN |
67,7 → 67,7 |
UNTIL i = 0 |
END WriteInt; |
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN; |
PROCEDURE IsNan(AValue: REAL): 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: LONGREAL): BOOLEAN; |
RETURN ABS(x) = sys.INF(LONGREAL) |
PROCEDURE IsInf(x: REAL): BOOLEAN; |
RETURN ABS(x) = sys.INF() |
END IsInf; |
PROCEDURE Int*(x, width: INTEGER); |
92,15 → 92,15 |
END |
END Int; |
PROCEDURE OutInf(x: LONGREAL; width: INTEGER); |
VAR s: ARRAY 4 OF CHAR; i: INTEGER; |
PROCEDURE OutInf(x: REAL; width: INTEGER); |
VAR s: ARRAY 5 OF CHAR; i: INTEGER; |
BEGIN |
IF IsNan(x) THEN |
s := "Nan"; |
INC(width) |
ELSIF IsInf(x) & (x > 0.0D0) THEN |
ELSIF IsInf(x) & (x > 0.0) THEN |
s := "+Inf" |
ELSIF IsInf(x) & (x < 0.0D0) THEN |
ELSIF IsInf(x) & (x < 0.0) THEN |
s := "-Inf" |
END; |
FOR i := 1 TO width - 4 DO |
115,8 → 115,8 |
Char(0AX) |
END Ln; |
PROCEDURE _FixReal(x: LONGREAL; width, p: INTEGER); |
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN; |
PROCEDURE _FixReal(x: REAL; width, p: INTEGER); |
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN; |
BEGIN |
IF IsNan(x) OR IsInf(x) THEN |
OutInf(x, width) |
125,19 → 125,19 |
ELSE |
len := 0; |
minus := FALSE; |
IF x < 0.0D0 THEN |
IF x < 0.0 THEN |
minus := TRUE; |
INC(len); |
x := ABS(x) |
END; |
e := 0; |
WHILE x >= 10.0D0 DO |
x := x / 10.0D0; |
WHILE x >= 10.0 DO |
x := x / 10.0; |
INC(e) |
END; |
IF e >= 0 THEN |
len := len + e + p + 1; |
IF x > 9.0D0 + d THEN |
IF x > 9.0 + d THEN |
INC(len) |
END; |
IF p > 0 THEN |
153,30 → 153,30 |
Char("-") |
END; |
y := x; |
WHILE (y < 1.0D0) & (y # 0.0D0) DO |
y := y * 10.0D0; |
WHILE (y < 1.0) & (y # 0.0) DO |
y := y * 10.0; |
DEC(e) |
END; |
IF e < 0 THEN |
IF x - LONG(FLT(FLOOR(x))) > d THEN |
IF x - FLT(FLOOR(x)) > d THEN |
Char("1"); |
x := 0.0D0 |
x := 0.0 |
ELSE |
Char("0"); |
x := x * 10.0D0 |
x := x * 10.0 |
END |
ELSE |
WHILE e >= 0 DO |
IF x - LONG(FLT(FLOOR(x))) > d THEN |
IF x > 9.0D0 THEN |
IF x - FLT(FLOOR(x)) > d THEN |
IF x > 9.0 THEN |
String("10") |
ELSE |
Char(CHR(FLOOR(x) + ORD("0") + 1)) |
END; |
x := 0.0D0 |
x := 0.0 |
ELSE |
Char(CHR(FLOOR(x) + ORD("0"))); |
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 |
x := (x - FLT(FLOOR(x))) * 10.0 |
END; |
DEC(e) |
END |
185,12 → 185,12 |
Char(".") |
END; |
WHILE p > 0 DO |
IF x - LONG(FLT(FLOOR(x))) > d THEN |
IF x - FLT(FLOOR(x)) > d THEN |
Char(CHR(FLOOR(x) + ORD("0") + 1)); |
x := 0.0D0 |
x := 0.0 |
ELSE |
Char(CHR(FLOOR(x) + ORD("0"))); |
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0 |
x := (x - FLT(FLOOR(x))) * 10.0 |
END; |
DEC(p) |
END |
197,7 → 197,7 |
END |
END _FixReal; |
PROCEDURE Real*(x: LONGREAL; width: INTEGER); |
PROCEDURE Real*(x: REAL; 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.0D0 THEN |
IF x < 0.0 THEN |
x := -x; |
minus := TRUE |
ELSE |
minus := FALSE |
END; |
WHILE x >= 10.0D0 DO |
x := x / 10.0D0; |
WHILE x >= 10.0 DO |
x := x / 10.0; |
INC(e) |
END; |
WHILE (x < 1.0D0) & (x # 0.0D0) DO |
x := x * 10.0D0; |
WHILE (x < 1.0) & (x # 0.0) DO |
x := x * 10.0; |
DEC(e) |
END; |
IF x > 9.0D0 + d THEN |
x := 1.0D0; |
IF x > 9.0 + d THEN |
x := 1.0; |
INC(e) |
END; |
FOR i := 1 TO n DO |
255,7 → 255,7 |
END |
END Real; |
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER); |
PROCEDURE FixReal*(x: REAL; width, p: INTEGER); |
BEGIN |
Realp := Real; |
_FixReal(x, width, p) |
/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07 |
---|
1,193 → 1,441 |
(* |
Copyright 2016, 2017 Anton Krotov |
(* |
BSD 2-Clause License |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE RTL; |
IMPORT sys := SYSTEM, API; |
IMPORT 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 |
IntArray = ARRAY 2048 OF INTEGER; |
STRING = ARRAY 2048 OF CHAR; |
PROC = PROCEDURE; |
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER); |
VAR |
SelfName, rtab: INTEGER; CloseProc: PROC; |
init: BOOLEAN; |
name: INTEGER; |
types: INTEGER; |
PROCEDURE [stdcall] _halt*(n: INTEGER); |
dll: RECORD |
process_detach, |
thread_detach, |
thread_attach: DLL_ENTRY |
END; |
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER); |
BEGIN |
API.ExitProcess(n) |
END _halt; |
SYSTEM.CODE( |
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER); |
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); |
BEGIN |
ptr := API._NEW(size); |
IF ptr # 0 THEN |
sys.PUT(ptr, t); |
INC(ptr, 4) |
END |
END _newrec; |
SYSTEM.CODE( |
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER); |
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; |
BEGIN |
IF ptr # 0 THEN |
ptr := API._DISPOSE(ptr - 4) |
IF len_src > len_dst THEN |
res := FALSE |
ELSE |
_move(len_src * base_size, src, dst); |
res := TRUE |
END |
END _disprec; |
PROCEDURE [stdcall] _rset*(y, x: INTEGER); |
BEGIN |
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800") |
END _rset; |
RETURN res |
END _arrcpy; |
PROCEDURE [stdcall] _inset*(y, x: INTEGER); |
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER); |
BEGIN |
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800") |
END _inset; |
_move(MIN(len_dst, len_src) * chr_size, src, dst) |
END _strcpy; |
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER); |
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER); |
BEGIN |
table := rtab; |
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00") |
END _checktype; |
_move(MIN(len_dst, len_src) * chr_size, src, dst) |
END _strcpy2; |
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER); |
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER); |
VAR |
i, n, k: INTEGER; |
BEGIN |
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D") |
END _savearr; |
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN; |
VAR res: BOOLEAN; |
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; |
BEGIN |
res := dyn = stat; |
IF res THEN |
_savearr(size, source, dest) |
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 |
END |
RETURN res |
END _saverec; |
END _set2; |
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER); |
VAR i, m: INTEGER; |
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER; |
RETURN _set2(a, b) |
END _set; |
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER; |
BEGIN |
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 |
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) |
END |
END _arrayidx; |
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER); |
RETURN div |
END div_; |
PROCEDURE mod_ (x, y: INTEGER): INTEGER; |
VAR |
div, mod: INTEGER; |
BEGIN |
IF (Arr[3] > idx) & (idx >= 0) THEN |
Arr[3] := bsize * idx + c |
ELSE |
Arr[3] := 0 |
div := divmod(x, y, mod); |
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN |
INC(mod, y) |
END |
END _arrayidx1; |
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray); |
VAR i, j, t: INTEGER; |
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); |
BEGIN |
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 |
ptr := API._NEW(size); |
IF ptr # 0 THEN |
SYSTEM.PUT(ptr, t); |
INC(ptr, SIZE_OF_DWORD) |
END |
END _arrayrot; |
END _new; |
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; |
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER); |
BEGIN |
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 |
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 *) |
) |
RETURN 0 |
END _length; |
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); |
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER; |
BEGIN |
_savearr(MIN(alen, blen), a, b); |
IF blen > alen THEN |
sys.PUT(b + alen, 0X) |
END |
END _strcopy; |
SYSTEM.CODE( |
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; |
VAR i: INTEGER; Res: BOOLEAN; |
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; |
BEGIN |
i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b))); |
IF i = 0 THEN |
i := _length(a) - _length(b) |
res := strncmp(str1, str2, MIN(len1, len2)); |
IF res = 0 THEN |
res := _length(len1, str1) - _length(len2, str2) |
END; |
CASE op OF |
|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 |
|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 Res |
RETURN bRes |
END _strcmp; |
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN; |
VAR s: ARRAY 2 OF CHAR; |
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; |
BEGIN |
s[0] := b; |
s[1] := 0X; |
RETURN _strcmp(op, s, a) |
END _lstrcmp; |
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN; |
VAR s: ARRAY 2 OF CHAR; |
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; |
BEGIN |
s[0] := a; |
s[1] := 0X; |
RETURN _strcmp(op, b, s) |
END _rstrcmp; |
i := 0; |
REPEAT |
SYSTEM.GET(pchar, c); |
s[i] := c; |
INC(pchar); |
INC(i) |
UNTIL c = 0X |
END PCharToStr; |
PROCEDURE Int(x: INTEGER; VAR str: STRING); |
VAR i, a, b: INTEGER; c: CHAR; |
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR); |
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]; |
197,80 → 445,186 |
DEC(b) |
END; |
str[i] := 0X |
END Int; |
END IntToStr; |
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER); |
VAR msg, int: STRING; pos, n: INTEGER; |
PROCEDURE StrAppend(s: STRING); |
VAR i, n: INTEGER; |
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR); |
VAR |
n1, n2, i, j: INTEGER; |
BEGIN |
n := LEN(s); |
n1 := LENGTH(s1); |
n2 := LENGTH(s2); |
ASSERT(n1 + n2 < LEN(s1)); |
i := 0; |
WHILE (i < n) & (s[i] # 0X) DO |
msg[pos] := s[i]; |
INC(pos); |
INC(i) |
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) |
END |
END StrAppend; |
RETURN t1 = t0 |
END _isrec; |
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN; |
VAR |
t1: INTEGER; |
BEGIN |
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") |
(* p IS t0 *) |
IF p # 0 THEN |
DEC(p, SIZE_OF_DWORD); |
SYSTEM.GET(p, t1); |
WHILE (t1 # 0) & (t1 # t0) DO |
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1) |
END |
ELSE |
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; |
t1 := -1 |
END |
PROCEDURE [stdcall] _close*; |
RETURN t1 = t0 |
END _is; |
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN; |
BEGIN |
IF CloseProc # NIL THEN |
CloseProc |
(* r:t1 IS t0 *) |
WHILE (t1 # 0) & (t1 # t0) DO |
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1) |
END |
END _close; |
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); |
RETURN t1 = t0 |
END _guardrec; |
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN; |
VAR |
t1: INTEGER; |
BEGIN |
IF ~init THEN |
API.zeromem(gsize, gadr); |
init := TRUE; |
API.init(esp); |
SelfName := self; |
rtab := rec; |
CloseProc := NIL |
(* p IS t0 *) |
SYSTEM.GET(p, p); |
IF p # 0 THEN |
DEC(p, SIZE_OF_DWORD); |
SYSTEM.GET(p, t1); |
WHILE (t1 # t0) & (t1 # 0) DO |
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1) |
END |
END _init; |
ELSE |
t1 := t0 |
END |
PROCEDURE SetClose*(proc: PROC); |
RETURN t1 = t0 |
END _guard; |
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CloseProc := proc |
END SetClose; |
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 |
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/RasterWorks.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 KolibriOS team |
(* |
Copyright 2016, 2018 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(v: INTEGER; name: ARRAY OF CHAR); |
PROCEDURE GetProc(Lib, 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(sys.ADR(drawText), "drawText"); |
GetProc(sys.ADR(cntUTF_8), "cntUTF-8"); |
GetProc(sys.ADR(charsFit), "charsFit"); |
GetProc(sys.ADR(strWidth), "strWidth"); |
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"); |
END main; |
/programs/develop/oberon07/Lib/KolibriOS/Read.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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,10 → 31,6 |
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 Anton Krotov |
(* |
Copyright 2016, 2018 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,10 → 31,6 |
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/kfonts.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 Anton Krotov |
(* |
Copyright 2016, 2018 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("578B7D0C8B4D0833C09CFCF3AB9D5F") |
sys.CODE(057H, 08BH, 07DH, 00CH, 08BH, 04DH, 008H, 033H, 0C0H, 09CH, 0FCH, 0F3H, 0ABH, 09DH, 05FH) |
END zeromem; |
PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN); |
97,7 → 97,6 |
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/libimg.ob07 |
---|
1,5 → 1,5 |
(* |
Copyright 2016 KolibriOS team |
(* |
Copyright 2016, 2018 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(v: INTEGER; name: ARRAY OF CHAR); |
PROCEDURE GetProc(Lib, 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(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"); |
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"); |
GetFormatsTable(formats_table_ptr) |
END main; |
/programs/develop/oberon07/Lib/Linux32/API.ob07 |
---|
1,148 → 1,145 |
(* |
Copyright 2016 Anton Krotov |
BSD 2-Clause License |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
Copyright (c) 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE API; |
IMPORT sys := SYSTEM; |
IMPORT SYSTEM; |
CONST |
BASE_ADR = 08048000H; |
TYPE |
TP* = ARRAY 2 OF INTEGER; |
VAR |
Param*: INTEGER; |
eol*: ARRAY 2 OF CHAR; |
base*, MainParam*: INTEGER; |
sec* : INTEGER; |
dsec* : INTEGER; |
stdin* : INTEGER; |
stdout* : INTEGER; |
libc*, librt*: INTEGER; |
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER; |
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): INTEGER; |
stdout*, |
stdin*, |
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; |
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER); |
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER; |
free* : PROCEDURE [linux] (ptr: INTEGER); |
_exit* : PROCEDURE [linux] (code: INTEGER); |
puts* : PROCEDURE [linux] (pStr: INTEGER); |
fwrite*, |
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER; |
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER; |
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER; |
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER; |
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER; |
PROCEDURE putc* (c: CHAR); |
VAR |
res: INTEGER; |
BEGIN |
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F") |
END zeromem; |
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout) |
END putc; |
PROCEDURE Align(n, m: INTEGER): INTEGER; |
RETURN n + (m - n MOD m) MOD m |
END Align; |
PROCEDURE malloc* (Bytes: INTEGER): INTEGER; |
VAR res: INTEGER; |
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER); |
BEGIN |
Bytes := Align(Bytes, 4); |
res := _malloc(Bytes); |
puts(lpCaption); |
puts(lpText) |
END DebugMsg; |
PROCEDURE _NEW* (size: INTEGER): INTEGER; |
VAR |
res, ptr, words: INTEGER; |
BEGIN |
res := malloc(size); |
IF res # 0 THEN |
zeromem(ASR(Bytes, 2), res) |
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 |
END malloc; |
END _NEW; |
PROCEDURE Free* (hMem: INTEGER): INTEGER; |
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER; |
BEGIN |
free(hMem) |
free(p) |
RETURN 0 |
END Free; |
PROCEDURE _NEW*(size: INTEGER): INTEGER; |
RETURN malloc(size) |
END _NEW; |
PROCEDURE _DISPOSE*(p: INTEGER): INTEGER; |
RETURN Free(p) |
END _DISPOSE; |
PROCEDURE ConOut(str, length: INTEGER); |
BEGIN |
length := fwrite(str, length, 1, stdout) |
END ConOut; |
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER); |
VAR eol: ARRAY 3 OF CHAR; |
PROCEDURE GetProcAdr (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER); |
VAR |
sym: INTEGER; |
BEGIN |
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; |
sym := dlsym(lib, SYSTEM.ADR(name[0])); |
ASSERT(sym # 0); |
SYSTEM.PUT(VarAdr, sym) |
END GetProcAdr; |
PROCEDURE ExitProcess* (code: INTEGER); |
BEGIN |
exit(code) |
END ExitProcess; |
PROCEDURE ExitThread* (code: INTEGER); |
PROCEDURE init* (sp, code: INTEGER); |
BEGIN |
exit(code) |
END ExitThread; |
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen); |
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym); |
MainParam := sp; |
base := BASE_ADR; |
eol := 0AX; |
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER); |
VAR H: INTEGER; |
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)); |
librt := dlopen(SYSTEM.SADR("librt.so.1"), 1); |
GetProcAdr(librt, "clock_gettime", SYSTEM.ADR(clock_gettime)) |
END init; |
PROCEDURE exit* (code: INTEGER); |
BEGIN |
H := dlsym(hMOD, sys.ADR(name[0])); |
ASSERT(H # 0); |
sys.PUT(adr, H); |
END GetProc; |
_exit(code) |
END exit; |
PROCEDURE init* (esp: INTEGER); |
VAR lib, proc: INTEGER; |
PROCEDURE exit_thread* (code: INTEGER); |
BEGIN |
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); |
_exit(code) |
END exit_thread; |
lib := dlopen(sys.ADR("libc.so.6"), 1); |
ASSERT(lib # 0); |
GetProc("strncmp", lib, sys.ADR(strncmp)); |
GetProc("strlen", lib, sys.ADR(strlen)); |
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/HOST.ob07 |
---|
1,121 → 1,178 |
(* |
Copyright 2016 Anton Krotov |
(* |
BSD 2-Clause License |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
Copyright (c) 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE HOST; |
IMPORT sys := SYSTEM, API; |
IMPORT SYSTEM, API, RTL; |
CONST |
OS* = "LNX"; |
Slash* = "/"; |
slash* = "/"; |
OS* = "LINUX"; |
bit_depth* = RTL.bit_depth; |
maxint* = RTL.maxint; |
minint* = RTL.minint; |
VAR |
fsize : INTEGER; |
argc: INTEGER; |
sec* : INTEGER; |
dsec* : INTEGER; |
eol*: ARRAY 2 OF CHAR; |
PROCEDURE GetCommandLine* (): INTEGER; |
RETURN API.Param |
END GetCommandLine; |
PROCEDURE CloseFile* (File: INTEGER); |
PROCEDURE ExitProcess* (code: INTEGER); |
BEGIN |
File := API.fclose(File) |
END CloseFile; |
API.exit(code) |
END ExitProcess; |
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER; |
VAR res: INTEGER; |
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR); |
VAR |
i, len, ptr: INTEGER; |
c: CHAR; |
BEGIN |
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; |
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; |
PROCEDURE OutString* (str: ARRAY OF CHAR); |
VAR res: INTEGER; |
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR); |
VAR |
n: INTEGER; |
BEGIN |
res := FileRW(API.stdout, sys.ADR(str), LENGTH(str), TRUE) |
END OutString; |
GetArg(0, path); |
n := LENGTH(path) - 1; |
WHILE path[n] # slash DO |
DEC(n) |
END; |
path[n + 1] := 0X |
END GetCurrentDirectory; |
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER; |
RETURN API.fopen(sys.ADR(FName), sys.ADR("wb")) |
END CreateFile; |
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER; |
VAR F, res: INTEGER; |
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; |
BEGIN |
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) |
res := ReadFile(F, Buffer, bytes); |
IF res <= 0 THEN |
res := -1 |
END |
RETURN F |
END OpenFile; |
PROCEDURE FileSize* (F: INTEGER): INTEGER; |
RETURN fsize |
END FileSize; |
RETURN res |
END FileRead; |
PROCEDURE Align(n, m: INTEGER): INTEGER; |
RETURN n + (m - n MOD m) MOD m |
END Align; |
PROCEDURE malloc* (Bytes: INTEGER): INTEGER; |
VAR res: INTEGER; |
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
Bytes := Align(Bytes, 4); |
res := API.malloc(Bytes); |
IF res # 0 THEN |
API.zeromem(ASR(Bytes, 2), res) |
res := WriteFile(F, Buffer, bytes); |
IF res <= 0 THEN |
res := -1 |
END |
RETURN res |
END malloc; |
END FileWrite; |
PROCEDURE ExitProcess* (code: INTEGER); |
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER; |
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb")) |
END FileCreate; |
PROCEDURE FileClose* (File: INTEGER); |
BEGIN |
API.exit(code) |
END ExitProcess; |
File := API.fclose(File) |
END FileClose; |
PROCEDURE Time* (VAR sec, dsec: INTEGER); |
VAR tp: API.TP; |
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER; |
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb")) |
END FileOpen; |
PROCEDURE OutChar* (c: CHAR); |
BEGIN |
API.putc(c) |
END OutChar; |
PROCEDURE GetTickCount* (): INTEGER; |
VAR |
tp: API.TP; |
res: INTEGER; |
BEGIN |
IF API.clock_gettime(0, tp) = 0 THEN |
sec := tp[0]; |
dsec := tp[1] DIV 10000000 |
res := tp[0] * 100 + tp[1] DIV 10000000 |
ELSE |
sec := 0; |
dsec := 0 |
res := 0 |
END |
END Time; |
PROCEDURE init*; |
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; |
BEGIN |
Time(sec, dsec) |
END init; |
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; |
PROCEDURE GetName*(): INTEGER; |
RETURN 0 |
END GetName; |
BEGIN |
eol := 0AX; |
SYSTEM.GET(API.MainParam, argc) |
END HOST. |
/programs/develop/oberon07/Lib/Linux32/LINAPI.ob07 |
---|
0,0 → 1,141 |
(* |
BSD 2-Clause License |
Copyright (c) 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE LINAPI; |
IMPORT SYSTEM, API; |
TYPE |
TP* = API.TP; |
VAR |
argc*, envc*: INTEGER; |
libc*, librt*: INTEGER; |
stdout*, |
stdin*, |
stderr* : 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; |
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER; |
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER; |
PROCEDURE dlopen* (filename: ARRAY OF CHAR): INTEGER; |
RETURN API.dlopen(SYSTEM.ADR(filename[0]), 1) |
END dlopen; |
PROCEDURE dlsym* (handle: INTEGER; symbol: ARRAY OF CHAR): INTEGER; |
RETURN API.dlsym(handle, SYSTEM.ADR(symbol[0])) |
END dlsym; |
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR); |
VAR |
i, len, ptr: INTEGER; |
c: CHAR; |
BEGIN |
i := 0; |
len := LEN(s) - 1; |
IF (0 <= n) & (n <= argc + envc) & (n # argc) & (len > 0) THEN |
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr); |
REPEAT |
SYSTEM.GET(ptr, c); |
s[i] := c; |
INC(i); |
INC(ptr) |
UNTIL (c = 0X) OR (i = len) |
END; |
s[i] := 0X |
END GetArg; |
PROCEDURE GetEnv* (n: INTEGER; VAR s: ARRAY OF CHAR); |
BEGIN |
IF (0 <= n) & (n < envc) THEN |
GetArg(n + argc + 1, s) |
ELSE |
s[0] := 0X |
END |
END GetEnv; |
PROCEDURE init; |
VAR |
ptr: INTEGER; |
BEGIN |
envc := -1; |
SYSTEM.GET(API.MainParam, argc); |
REPEAT |
SYSTEM.GET(API.MainParam + (envc + argc + 3) * SYSTEM.SIZE(INTEGER), ptr); |
INC(envc) |
UNTIL ptr = 0; |
libc := API.libc; |
stdout := API.stdout; |
stdin := API.stdin; |
stderr := API.stderr; |
malloc := API.malloc; |
free := API.free; |
exit := API._exit; |
puts := API.puts; |
fwrite := API.fwrite; |
fread := API.fread; |
fopen := API.fopen; |
fclose := API.fclose; |
time := API.time; |
librt := API.librt; |
clock_gettime := API.clock_gettime |
END init; |
PROCEDURE [stdcall-] syscall* (eax, ebx, ecx, edx, esi, edi: 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, 080H, (* int 128 *) |
05FH, (* pop edi *) |
05EH, (* pop esi *) |
05BH, (* pop ebx *) |
0C9H, (* leave *) |
0C2H, 018H, 000H (* ret 24 *) |
) |
RETURN 0 |
END syscall; |
BEGIN |
init |
END LINAPI. |
/programs/develop/oberon07/Lib/Linux32/RTL.ob07 |
---|
1,193 → 1,441 |
(* |
Copyright 2016, 2017 Anton Krotov |
BSD 2-Clause License |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE RTL; |
IMPORT sys := SYSTEM, API; |
IMPORT 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 |
IntArray = ARRAY 2048 OF INTEGER; |
STRING = ARRAY 2048 OF CHAR; |
PROC = PROCEDURE; |
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER); |
VAR |
SelfName, rtab: INTEGER; CloseProc: PROC; |
init: BOOLEAN; |
name: INTEGER; |
types: INTEGER; |
PROCEDURE [stdcall] _halt*(n: INTEGER); |
dll: RECORD |
process_detach, |
thread_detach, |
thread_attach: DLL_ENTRY |
END; |
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER); |
BEGIN |
API.ExitProcess(n) |
END _halt; |
SYSTEM.CODE( |
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER); |
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); |
BEGIN |
ptr := API._NEW(size); |
IF ptr # 0 THEN |
sys.PUT(ptr, t); |
INC(ptr, 4) |
END |
END _newrec; |
SYSTEM.CODE( |
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER); |
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; |
BEGIN |
IF ptr # 0 THEN |
ptr := API._DISPOSE(ptr - 4) |
IF len_src > len_dst THEN |
res := FALSE |
ELSE |
_move(len_src * base_size, src, dst); |
res := TRUE |
END |
END _disprec; |
PROCEDURE [stdcall] _rset*(y, x: INTEGER); |
BEGIN |
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800") |
END _rset; |
RETURN res |
END _arrcpy; |
PROCEDURE [stdcall] _inset*(y, x: INTEGER); |
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER); |
BEGIN |
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800") |
END _inset; |
_move(MIN(len_dst, len_src) * chr_size, src, dst) |
END _strcpy; |
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER); |
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER); |
BEGIN |
table := rtab; |
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00") |
END _checktype; |
_move(MIN(len_dst, len_src) * chr_size, src, dst) |
END _strcpy2; |
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER); |
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER); |
VAR |
i, n, k: INTEGER; |
BEGIN |
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D") |
END _savearr; |
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN; |
VAR res: BOOLEAN; |
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; |
BEGIN |
res := dyn = stat; |
IF res THEN |
_savearr(size, source, dest) |
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 |
END |
RETURN res |
END _saverec; |
END _set2; |
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER); |
VAR i, m: INTEGER; |
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER; |
RETURN _set2(a, b) |
END _set; |
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER; |
BEGIN |
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 |
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) |
END |
END _arrayidx; |
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER); |
RETURN div |
END div_; |
PROCEDURE mod_ (x, y: INTEGER): INTEGER; |
VAR |
div, mod: INTEGER; |
BEGIN |
IF (Arr[3] > idx) & (idx >= 0) THEN |
Arr[3] := bsize * idx + c |
ELSE |
Arr[3] := 0 |
div := divmod(x, y, mod); |
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN |
INC(mod, y) |
END |
END _arrayidx1; |
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray); |
VAR i, j, t: INTEGER; |
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); |
BEGIN |
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 |
ptr := API._NEW(size); |
IF ptr # 0 THEN |
SYSTEM.PUT(ptr, t); |
INC(ptr, SIZE_OF_DWORD) |
END |
END _arrayrot; |
END _new; |
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; |
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER); |
BEGIN |
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 |
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 *) |
) |
RETURN 0 |
END _length; |
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); |
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER; |
BEGIN |
_savearr(MIN(alen, blen), a, b); |
IF blen > alen THEN |
sys.PUT(b + alen, 0X) |
END |
END _strcopy; |
SYSTEM.CODE( |
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; |
VAR i: INTEGER; Res: BOOLEAN; |
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; |
BEGIN |
i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b))); |
IF i = 0 THEN |
i := _length(a) - _length(b) |
res := strncmp(str1, str2, MIN(len1, len2)); |
IF res = 0 THEN |
res := _length(len1, str1) - _length(len2, str2) |
END; |
CASE op OF |
|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 |
|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 Res |
RETURN bRes |
END _strcmp; |
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN; |
VAR s: ARRAY 2 OF CHAR; |
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; |
BEGIN |
s[0] := b; |
s[1] := 0X; |
RETURN _strcmp(op, s, a) |
END _lstrcmp; |
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN; |
VAR s: ARRAY 2 OF CHAR; |
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; |
BEGIN |
s[0] := a; |
s[1] := 0X; |
RETURN _strcmp(op, b, s) |
END _rstrcmp; |
i := 0; |
REPEAT |
SYSTEM.GET(pchar, c); |
s[i] := c; |
INC(pchar); |
INC(i) |
UNTIL c = 0X |
END PCharToStr; |
PROCEDURE Int(x: INTEGER; VAR str: STRING); |
VAR i, a, b: INTEGER; c: CHAR; |
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR); |
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]; |
197,80 → 445,186 |
DEC(b) |
END; |
str[i] := 0X |
END Int; |
END IntToStr; |
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER); |
VAR msg, int: STRING; pos, n: INTEGER; |
PROCEDURE StrAppend(s: STRING); |
VAR i, n: INTEGER; |
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR); |
VAR |
n1, n2, i, j: INTEGER; |
BEGIN |
n := LEN(s); |
n1 := LENGTH(s1); |
n2 := LENGTH(s2); |
ASSERT(n1 + n2 < LEN(s1)); |
i := 0; |
WHILE (i < n) & (s[i] # 0X) DO |
msg[pos] := s[i]; |
INC(pos); |
INC(i) |
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) |
END |
END StrAppend; |
RETURN t1 = t0 |
END _isrec; |
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN; |
VAR |
t1: INTEGER; |
BEGIN |
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") |
(* p IS t0 *) |
IF p # 0 THEN |
DEC(p, SIZE_OF_DWORD); |
SYSTEM.GET(p, t1); |
WHILE (t1 # 0) & (t1 # t0) DO |
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1) |
END |
ELSE |
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; |
t1 := -1 |
END |
PROCEDURE [stdcall] _close*; |
RETURN t1 = t0 |
END _is; |
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN; |
BEGIN |
IF CloseProc # NIL THEN |
CloseProc |
(* r:t1 IS t0 *) |
WHILE (t1 # 0) & (t1 # t0) DO |
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1) |
END |
END _close; |
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); |
RETURN t1 = t0 |
END _guardrec; |
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN; |
VAR |
t1: INTEGER; |
BEGIN |
IF ~init THEN |
API.zeromem(gsize, gadr); |
init := TRUE; |
API.init(esp); |
SelfName := self; |
rtab := rec; |
CloseProc := NIL |
(* p IS t0 *) |
SYSTEM.GET(p, p); |
IF p # 0 THEN |
DEC(p, SIZE_OF_DWORD); |
SYSTEM.GET(p, t1); |
WHILE (t1 # t0) & (t1 # 0) DO |
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1) |
END |
END _init; |
ELSE |
t1 := t0 |
END |
PROCEDURE SetClose*(proc: PROC); |
RETURN t1 = t0 |
END _guard; |
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CloseProc := proc |
END SetClose; |
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 |
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,79 → 1,61 |
(* |
Copyright 2016, 2017 Anton Krotov |
BSD 2-Clause License |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE API; |
IMPORT sys := SYSTEM; |
IMPORT SYSTEM; |
VAR |
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; |
eol*: ARRAY 3 OF CHAR; |
base*: INTEGER; |
GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER; |
LoadLibraryA*: PROCEDURE [winapi] (name: INTEGER): INTEGER; |
PROCEDURE zeromem*(size, adr: INTEGER); |
END zeromem; |
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER); |
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER); |
PROCEDURE [windows-, "kernel32.dll", "GlobalAlloc"] Alloc (uFlags, dwBytes: INTEGER): INTEGER; |
PROCEDURE [windows-, "kernel32.dll", "GlobalFree"] Free (hMem: INTEGER): INTEGER; |
PROCEDURE [windows-, "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* (esp: INTEGER); |
VAR lib: INTEGER; |
PROCEDURE init* (reserved, code: INTEGER); |
BEGIN |
sys.GET(esp, GetProcAddress); |
sys.GET(esp + 4, LoadLibraryA); |
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X; |
base := code - 4096 |
END init; |
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)); |
lib := LoadLibraryA(sys.ADR("msvcrt.dll")); |
GetProc("strncmp", lib, sys.ADR(strncmp)); |
PROCEDURE exit* (code: INTEGER); |
BEGIN |
ExitProcess(code) |
END exit; |
lib := LoadLibraryA(sys.ADR("user32.dll")); |
GetProc("MessageBoxA", lib, sys.ADR(MessageBoxA)); |
END init; |
END API. |
PROCEDURE exit_thread* (code: INTEGER); |
BEGIN |
ExitThread(code) |
END exit_thread; |
END API. |
/programs/develop/oberon07/Lib/Windows32/HOST.ob07 |
---|
1,139 → 1,331 |
(* |
Copyright 2016, 2017 Anton Krotov |
BSD 2-Clause License |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE HOST; |
IMPORT sys := SYSTEM, API; |
IMPORT SYSTEM, RTL; |
CONST |
OS* = "WIN"; |
Slash* = "\"; |
slash* = "\"; |
OS* = "WINDOWS"; |
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: sys.CARD16; |
Reserved1: sys.CARD16; |
Reserved2: sys.CARD16; |
nErrCode: SYSTEM.CARD16; |
Reserved1: SYSTEM.CARD16; |
Reserved2: SYSTEM.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 |
sec*, dsec*, hConsoleOutput: INTEGER; |
hConsoleOutput: 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; |
Params: ARRAY MAX_PARAM, 2 OF INTEGER; |
argc: INTEGER; |
PROCEDURE FileRW*(hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER; |
VAR res: 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); |
BEGIN |
IF write THEN |
WriteFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0) |
_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 |
ELSE |
ReadFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0) |
cond := C |
END |
RETURN res |
END FileRW; |
END ChangeCond; |
PROCEDURE OutString* (str: ARRAY OF CHAR); |
VAR res: INTEGER; |
BEGIN |
res := FileRW(hConsoleOutput, sys.ADR(str[0]), LENGTH(str), TRUE) |
END OutString; |
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; |
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER; |
VAR res: INTEGER; |
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR); |
VAR |
i, j, len: INTEGER; |
c: CHAR; |
BEGIN |
res := _CreateFile(sys.ADR(FName[0]), 0C0000000H, 0, 0, 2, 80H, 0); |
IF res = -1 THEN |
res := 0 |
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 |
RETURN res |
END CreateFile; |
END; |
s[j] := 0X |
END GetArg; |
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER; |
VAR res: INTEGER; ofstr: OFSTRUCT; |
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
VAR |
res, n: INTEGER; |
BEGIN |
res := _OpenFile(sys.ADR(FName[0]), ofstr, 0); |
IF res = -1 THEN |
res := 0 |
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN |
res := -1 |
ELSE |
res := n |
END |
RETURN res |
END OpenFile; |
END FileRead; |
PROCEDURE FileSize*(F: INTEGER): INTEGER; |
VAR res: INTEGER; |
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
VAR |
res, n: INTEGER; |
BEGIN |
res := SetFilePointer(F, 0, 0, 2); |
SetFilePointer(F, 0, 0, 0) |
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN |
res := -1 |
ELSE |
res := n |
END |
RETURN res |
END FileSize; |
END FileWrite; |
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER); |
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); |
BEGIN |
sys.PUT(adr, API.GetProcAddress(hMOD, sys.ADR(name[0]))) |
END GetProc; |
_CloseHandle(F) |
END FileClose; |
PROCEDURE Time*(VAR sec, dsec: INTEGER); |
VAR t: INTEGER; |
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER; |
VAR |
ofstr: OFSTRUCT; |
res: INTEGER; |
BEGIN |
t := GetTickCount() DIV 10; |
sec := t DIV 100; |
dsec := t MOD 100 |
END Time; |
res := _OpenFile(SYSTEM.ADR(FName[0]), ofstr, 0); |
IF res = 0FFFFFFFFH THEN |
res := -1 |
END |
PROCEDURE malloc*(size: INTEGER): INTEGER; |
RETURN API.Alloc(64, size) |
END malloc; |
RETURN res |
END FileOpen; |
PROCEDURE init*; |
VAR lib: INTEGER; |
PROCEDURE OutChar* (c: CHAR); |
VAR |
count: INTEGER; |
BEGIN |
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; |
_WriteFile(hConsoleOutput, SYSTEM.ADR(c), 1, count, NIL) |
END OutChar; |
PROCEDURE GetName*(): INTEGER; |
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; |
RETURN 0 |
END GetName; |
END UnixTime; |
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/Windows32/RTL.ob07 |
---|
1,194 → 1,441 |
(* |
Copyright 2016, 2017 Anton Krotov |
(* |
BSD 2-Clause License |
This program is free software: you can redistribute it and/or modify |
it under the terms of the GNU Lesser General Public License as published by |
the Free Software Foundation, either version 3 of the License, or |
(at your option) any later version. |
This program is distributed in the hope that it will be useful, |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
GNU Lesser General Public License for more details. |
You should have received a copy of the GNU Lesser General Public License |
along with this program. If not, see <http://www.gnu.org/licenses/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE RTL; |
IMPORT sys := SYSTEM, API; |
IMPORT 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 |
IntArray = ARRAY 2048 OF INTEGER; |
STRING = ARRAY 2048 OF CHAR; |
PROC = PROCEDURE; |
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER); |
VAR |
SelfName, rtab: INTEGER; CloseProc: PROC; |
init: BOOLEAN; |
main_thread_id: INTEGER; |
name: INTEGER; |
types: INTEGER; |
PROCEDURE [stdcall] _halt*(n: INTEGER); |
dll: RECORD |
process_detach, |
thread_detach, |
thread_attach: DLL_ENTRY |
END; |
PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER); |
BEGIN |
API.ExitProcess(n) |
END _halt; |
SYSTEM.CODE( |
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER); |
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); |
BEGIN |
ptr := API._NEW(size); |
IF ptr # 0 THEN |
sys.PUT(ptr, t); |
INC(ptr, 4) |
END |
END _newrec; |
SYSTEM.CODE( |
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER); |
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; |
BEGIN |
IF ptr # 0 THEN |
ptr := API._DISPOSE(ptr - 4) |
IF len_src > len_dst THEN |
res := FALSE |
ELSE |
_move(len_src * base_size, src, dst); |
res := TRUE |
END |
END _disprec; |
PROCEDURE [stdcall] _rset*(y, x: INTEGER); |
BEGIN |
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800") |
END _rset; |
RETURN res |
END _arrcpy; |
PROCEDURE [stdcall] _inset*(y, x: INTEGER); |
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER); |
BEGIN |
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800") |
END _inset; |
_move(MIN(len_dst, len_src) * chr_size, src, dst) |
END _strcpy; |
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER); |
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER); |
BEGIN |
table := rtab; |
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00") |
END _checktype; |
_move(MIN(len_dst, len_src) * chr_size, src, dst) |
END _strcpy2; |
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER); |
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER); |
VAR |
i, n, k: INTEGER; |
BEGIN |
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D") |
END _savearr; |
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN; |
VAR res: BOOLEAN; |
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; |
BEGIN |
res := dyn = stat; |
IF res THEN |
_savearr(size, source, dest) |
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 |
END |
RETURN res |
END _saverec; |
END _set2; |
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER); |
VAR i, m: INTEGER; |
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER; |
RETURN _set2(a, b) |
END _set; |
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER; |
BEGIN |
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 |
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) |
END |
END _arrayidx; |
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER); |
RETURN div |
END div_; |
PROCEDURE mod_ (x, y: INTEGER): INTEGER; |
VAR |
div, mod: INTEGER; |
BEGIN |
IF (Arr[3] > idx) & (idx >= 0) THEN |
Arr[3] := bsize * idx + c |
ELSE |
Arr[3] := 0 |
div := divmod(x, y, mod); |
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN |
INC(mod, y) |
END |
END _arrayidx1; |
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray); |
VAR i, j, t: INTEGER; |
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); |
BEGIN |
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 |
ptr := API._NEW(size); |
IF ptr # 0 THEN |
SYSTEM.PUT(ptr, t); |
INC(ptr, SIZE_OF_DWORD) |
END |
END _arrayrot; |
END _new; |
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER; |
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER); |
BEGIN |
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 |
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 *) |
) |
RETURN 0 |
END _length; |
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER); |
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER; |
BEGIN |
_savearr(MIN(alen, blen), a, b); |
IF blen > alen THEN |
sys.PUT(b + alen, 0X) |
END |
END _strcopy; |
SYSTEM.CODE( |
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN; |
VAR i: INTEGER; Res: BOOLEAN; |
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; |
BEGIN |
i := API.strncmp(sys.ADR(a), sys.ADR(b), MIN(LEN(a), LEN(b))); |
IF i = 0 THEN |
i := _length(a) - _length(b) |
res := strncmp(str1, str2, MIN(len1, len2)); |
IF res = 0 THEN |
res := _length(len1, str1) - _length(len2, str2) |
END; |
CASE op OF |
|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 |
|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 Res |
RETURN bRes |
END _strcmp; |
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN; |
VAR s: ARRAY 2 OF CHAR; |
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; |
BEGIN |
s[0] := b; |
s[1] := 0X; |
RETURN _strcmp(op, s, a) |
END _lstrcmp; |
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN; |
VAR s: ARRAY 2 OF CHAR; |
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; |
BEGIN |
s[0] := a; |
s[1] := 0X; |
RETURN _strcmp(op, b, s) |
END _rstrcmp; |
i := 0; |
REPEAT |
SYSTEM.GET(pchar, c); |
s[i] := c; |
INC(pchar); |
INC(i) |
UNTIL c = 0X |
END PCharToStr; |
PROCEDURE Int(x: INTEGER; VAR str: STRING); |
VAR i, a, b: INTEGER; c: CHAR; |
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR); |
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]; |
198,85 → 445,186 |
DEC(b) |
END; |
str[i] := 0X |
END Int; |
END IntToStr; |
PROCEDURE [stdcall] _assrt*(code, m: INTEGER; modname: STRING; line: INTEGER); |
VAR msg, int: STRING; pos, n: INTEGER; |
PROCEDURE StrAppend(s: STRING); |
VAR i, n: INTEGER; |
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR); |
VAR |
n1, n2, i, j: INTEGER; |
BEGIN |
n := LEN(s); |
n1 := LENGTH(s1); |
n2 := LENGTH(s2); |
ASSERT(n1 + n2 < LEN(s1)); |
i := 0; |
WHILE (i < n) & (s[i] # 0X) DO |
msg[pos] := s[i]; |
INC(pos); |
INC(i) |
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) |
END |
END StrAppend; |
RETURN t1 = t0 |
END _isrec; |
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN; |
VAR |
t1: INTEGER; |
BEGIN |
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") |
(* p IS t0 *) |
IF p # 0 THEN |
DEC(p, SIZE_OF_DWORD); |
SYSTEM.GET(p, t1); |
WHILE (t1 # 0) & (t1 # t0) DO |
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1) |
END |
ELSE |
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) |
t1 := -1 |
END |
END _assrt; |
PROCEDURE [stdcall] _close*; |
RETURN t1 = t0 |
END _is; |
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN; |
BEGIN |
IF CloseProc # NIL THEN |
CloseProc |
(* r:t1 IS t0 *) |
WHILE (t1 # 0) & (t1 # t0) DO |
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1) |
END |
END _close; |
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER); |
RETURN t1 = t0 |
END _guardrec; |
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN; |
VAR |
t1: INTEGER; |
BEGIN |
IF ~init THEN |
API.zeromem(gsize, gadr); |
init := TRUE; |
API.init(esp); |
main_thread_id := API.GetCurrentThreadId(); |
SelfName := self; |
rtab := rec; |
CloseProc := NIL |
(* p IS t0 *) |
SYSTEM.GET(p, p); |
IF p # 0 THEN |
DEC(p, SIZE_OF_DWORD); |
SYSTEM.GET(p, t1); |
WHILE (t1 # t0) & (t1 # 0) DO |
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1) |
END |
END _init; |
ELSE |
t1 := t0 |
END |
PROCEDURE SetClose*(proc: PROC); |
RETURN t1 = t0 |
END _guard; |
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CloseProc := proc |
END SetClose; |
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 |
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/Samples/lib_img.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/RasterW.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/kfont.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/vector_ex.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Samples/Dialogs.ob07 |
---|
5,15 → 5,13 |
VAR header: ARRAY 1024 OF CHAR; back_color: INTEGER; |
PROCEDURE WindowRedrawStatus(p: INTEGER); |
VAR aux: INTEGER; |
BEGIN |
aux := KOSAPI.sysfunc2(12, p) |
KOSAPI.sysfunc2(12, p) |
END WindowRedrawStatus; |
PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER); |
VAR aux: INTEGER; |
BEGIN |
aux := KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext) |
KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext) |
END DefineAndDrawWindow; |
PROCEDURE WaitForEvent(): INTEGER; |
21,15 → 19,13 |
END WaitForEvent; |
PROCEDURE ExitApp; |
VAR aux: INTEGER; |
BEGIN |
aux := KOSAPI.sysfunc1(-1) |
KOSAPI.sysfunc1(-1) |
END ExitApp; |
PROCEDURE pause(t: INTEGER); |
VAR aux: INTEGER; |
BEGIN |
aux := KOSAPI.sysfunc2(5, t) |
KOSAPI.sysfunc2(5, t) |
END pause; |
PROCEDURE Buttons; |
/programs/develop/oberon07/Samples/HW.ob07 |
---|
3,21 → 3,18 |
IMPORT sys := SYSTEM, KOSAPI; |
PROCEDURE WindowRedrawStatus(p: INTEGER); |
VAR res: INTEGER; |
BEGIN |
res := KOSAPI.sysfunc2(12, p) |
KOSAPI.sysfunc2(12, p) |
END WindowRedrawStatus; |
PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER); |
VAR res: INTEGER; |
BEGIN |
res := KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext) |
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 |
res := KOSAPI.sysfunc6(4, x * 65536 + y, color + LSL(48, 24), sys.ADR(text[0]), LENGTH(text), 0) |
KOSAPI.sysfunc6(4, x * 65536 + y, color + LSL(48, 24), sys.ADR(text[0]), LENGTH(text), 0) |
END WriteTextToWindow; |
PROCEDURE WaitForEvent(): INTEGER; |
25,9 → 22,8 |
END WaitForEvent; |
PROCEDURE ExitApp; |
VAR res: INTEGER; |
BEGIN |
res := KOSAPI.sysfunc1(-1) |
KOSAPI.sysfunc1(-1) |
END ExitApp; |
PROCEDURE draw_window(header, text: ARRAY OF CHAR); |
/programs/develop/oberon07/Samples/HW_con.ob07 |
---|
1,7 → 1,8 |
MODULE HW_con; |
MODULE HW_con; |
IMPORT Out, In, Console, DateTime, ConsoleLib; |
IMPORT Out, In, Console, DateTime; |
PROCEDURE OutInt2(n: INTEGER); |
BEGIN |
ASSERT((0 <= n) & (n <= 99)); |
11,9 → 12,13 |
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" |
28,26 → 33,31 |
|11: str := "nov" |
|12: str := "dec" |
END; |
Out.String(str) |
END OutMonth; |
PROCEDURE main; |
VAR Year, Month, Day, Hour, Min, Sec: INTEGER; |
VAR |
Year, Month, Day, Hour, Min, Sec, Msec: INTEGER; |
BEGIN |
ConsoleLib.open(-1, -1, -1, -1, "Hello!"); |
Out.String("Hello, world!"); Out.Ln; |
Console.SetColor(Console.Yellow, Console.Blue); |
DateTime.Now(Year, Month, Day, Hour, Min, Sec); |
Console.SetColor(Console.White, Console.Red); |
DateTime.Now(Year, Month, Day, Hour, Min, Sec, Msec); |
Out.Int(Year, 0); Out.Char("-"); |
OutMonth(Month); Out.Char("-"); |
OutInt2(Day); Out.Char(" "); |
OutInt2(Hour); Out.Char(":"); |
OutInt2(Min); Out.Char(":"); |
OutInt2(Sec); |
In.Ln; |
ConsoleLib.exit(TRUE) |
OutInt2(Sec) |
END main; |
BEGIN |
main |
Console.open; |
main; |
In.Ln; |
Console.exit(TRUE) |
END HW_con. |
/programs/develop/oberon07/Source/DECL.ob07 |
---|
File deleted |
\ No newline at end of file |
/programs/develop/oberon07/Source/AMD64.ob07 |
---|
0,0 → 1,2782 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE AMD64; |
IMPORT CODE, BIN, WR := WRITER, CHL := CHUNKLISTS, MACHINE, LISTS, PATHS, |
REG, C := CONSOLE, UTILS, mConst := CONSTANTS, S := STRINGS, PE32, ELF, X86; |
CONST |
rax = REG.R0; |
r10 = REG.R10; |
r11 = REG.R11; |
rcx = REG.R1; |
rdx = REG.R2; |
r8 = REG.R8; |
r9 = REG.R9; |
rsp = 4; |
rbp = 5; |
rsi = 6; |
rdi = 7; |
je = 84H; jne = 85H; jl = 8CH; jge = 8DH; jle = 8EH; jg = 8FH; jb = 82H; |
sete = 94H; setne = 95H; setl = 9CH; setge = 9DH; setle = 9EH; setg = 9FH; setc = 92H; setnc = 93H; |
shl = CODE.opLSL2; shr = CODE.opLSR2; sar = CODE.opASR2; ror = CODE.opROR2; |
sCODE = BIN.PICCODE; |
sDATA = BIN.PICDATA; |
sBSS = BIN.PICBSS; |
sIMP = BIN.PICIMP; |
TYPE |
COMMAND = CODE.COMMAND; |
Number = POINTER TO RECORD (LISTS.ITEM) value: INTEGER END; |
OPRR = PROCEDURE (reg1, reg2: INTEGER); |
VAR |
R: REG.REGS; |
Numbers: LISTS.LIST; |
Numbers_Count: INTEGER; |
Numbers_Offs: INTEGER; |
prog: BIN.PROGRAM; |
dllret: INTEGER; |
Win64RegPar: ARRAY 4 OF INTEGER; |
SystemVRegPar: ARRAY 6 OF INTEGER; |
PROCEDURE OutByte (b: BYTE); |
BEGIN |
X86.OutByte(b) |
END OutByte; |
PROCEDURE OutByte2 (a, b: BYTE); |
BEGIN |
OutByte(a); |
OutByte(b) |
END OutByte2; |
PROCEDURE OutByte3 (a, b, c: BYTE); |
BEGIN |
OutByte(a); |
OutByte(b); |
OutByte(c) |
END OutByte3; |
PROCEDURE OutInt (n: INTEGER); |
BEGIN |
OutByte(MACHINE.Byte(n, 0)); |
OutByte(MACHINE.Byte(n, 1)); |
OutByte(MACHINE.Byte(n, 2)); |
OutByte(MACHINE.Byte(n, 3)) |
END OutInt; |
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); |
BEGIN |
IF isByte(n) THEN |
OutByte(MACHINE.Byte(n, 0)) |
ELSE |
OutInt(n) |
END |
END OutIntByte; |
PROCEDURE isLong (n: INTEGER): BOOLEAN; |
RETURN (n > MACHINE.max32) OR (n < MACHINE.min32) |
END isLong; |
PROCEDURE NewNumber (value: INTEGER); |
VAR |
number: Number; |
BEGIN |
NEW(number); |
number.value := value; |
LISTS.push(Numbers, number); |
INC(Numbers_Count) |
END NewNumber; |
PROCEDURE NewLabel (): INTEGER; |
BEGIN |
BIN.NewLabel(prog) |
RETURN CODE.NewLabel() |
END NewLabel; |
PROCEDURE Rex (reg1, reg2: INTEGER); |
BEGIN |
OutByte(48H + reg1 DIV 8 + 4 * (reg2 DIV 8)) |
END Rex; |
PROCEDURE lea (reg, offset, section: INTEGER); |
BEGIN |
Rex(0, reg); |
OutByte2(8DH, 05H + 8 * (reg MOD 8)); // lea reg, [rip + offset] |
X86.Reloc(section, offset) |
END lea; |
PROCEDURE oprr (op: BYTE; reg1, reg2: INTEGER); // op reg1, reg2 |
BEGIN |
Rex(reg1, reg2); |
OutByte2(op, 0C0H + 8 * (reg2 MOD 8) + reg1 MOD 8) |
END oprr; |
PROCEDURE oprr2 (op1, op2: BYTE; reg1, reg2: INTEGER); // op reg1, reg2 |
BEGIN |
Rex(reg1, reg2); |
OutByte3(op1, op2, 0C0H + 8 * (reg2 MOD 8) + reg1 MOD 8) |
END oprr2; |
PROCEDURE mov (reg1, reg2: INTEGER); // mov reg1, reg2 |
BEGIN |
oprr(89H, reg1, reg2) |
END mov; |
PROCEDURE xor (reg1, reg2: INTEGER); // xor reg1, reg2 |
BEGIN |
oprr(31H, reg1, reg2) |
END xor; |
PROCEDURE and (reg1, reg2: INTEGER); // and reg1, reg2 |
BEGIN |
oprr(21H, reg1, reg2) |
END and; |
PROCEDURE or (reg1, reg2: INTEGER); // and reg1, reg2 |
BEGIN |
oprr(09H, reg1, reg2) |
END or; |
PROCEDURE add (reg1, reg2: INTEGER); // add reg1, reg2 |
BEGIN |
oprr(01H, reg1, reg2) |
END add; |
PROCEDURE sub (reg1, reg2: INTEGER); // sub reg1, reg2 |
BEGIN |
oprr(29H, reg1, reg2) |
END sub; |
PROCEDURE xchg (reg1, reg2: INTEGER); // xchg reg1, reg2 |
BEGIN |
oprr(87H, reg1, reg2) |
END xchg; |
PROCEDURE cmprr (reg1, reg2: INTEGER); // cmp reg1, reg2 |
BEGIN |
oprr(39H, reg1, reg2) |
END cmprr; |
PROCEDURE pop (reg: INTEGER); // pop reg |
BEGIN |
IF reg >= 8 THEN |
OutByte(41H) |
END; |
OutByte(58H + reg MOD 8) |
END pop; |
PROCEDURE push (reg: INTEGER); // push reg |
BEGIN |
IF reg >= 8 THEN |
OutByte(41H) |
END; |
OutByte(50H + reg MOD 8) |
END push; |
PROCEDURE decr (reg: INTEGER); |
BEGIN |
Rex(reg, 0); |
OutByte2(0FFH, 0C8H + reg MOD 8) // dec reg1 |
END decr; |
PROCEDURE incr (reg: INTEGER); |
BEGIN |
Rex(reg, 0); |
OutByte2(0FFH, 0C0H + reg MOD 8) // inc reg1 |
END incr; |
PROCEDURE drop; |
BEGIN |
REG.Drop(R) |
END drop; |
PROCEDURE callimp (label: INTEGER); |
VAR |
reg: INTEGER; |
BEGIN |
reg := REG.GetAnyReg(R); |
lea(reg, label, sIMP); |
IF reg >= 8 THEN // call qword[reg] |
OutByte(41H) |
END; |
OutByte2(0FFH, 10H + reg MOD 8); |
drop |
END callimp; |
PROCEDURE pushDA (offs: INTEGER); |
VAR |
reg: INTEGER; |
BEGIN |
reg := REG.GetAnyReg(R); |
lea(reg, offs, sDATA); |
push(reg); |
drop |
END pushDA; |
PROCEDURE CallRTL (proc: INTEGER); |
VAR |
label: INTEGER; |
BEGIN |
REG.Store(R); |
label := CODE.codes.rtl[proc]; |
IF label < 0 THEN |
callimp(-label) |
ELSE |
X86.call(label) |
END; |
REG.Restore(R) |
END CallRTL; |
PROCEDURE UnOp (VAR reg: INTEGER); |
BEGIN |
REG.UnOp(R, reg) |
END UnOp; |
PROCEDURE BinOp (VAR reg1, reg2: INTEGER); |
BEGIN |
REG.BinOp(R, reg1, reg2) |
END BinOp; |
PROCEDURE PushAll (NumberOfParameters: INTEGER); |
BEGIN |
REG.PushAll(R); |
R.pushed := R.pushed - NumberOfParameters |
END PushAll; |
PROCEDURE movabs (reg, n: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
Rex(reg, 0); |
OutByte(0B8H + reg MOD 8); // movabs reg, n |
FOR i := 0 TO 7 DO |
OutByte(MACHINE.Byte(n, i)) |
END |
END movabs; |
PROCEDURE movrc (reg, n: INTEGER); // mov reg, n |
BEGIN |
IF isLong(n) THEN |
movabs(reg, n) |
ELSE |
Rex(reg, 0); |
OutByte2(0C7H, 0C0H + reg MOD 8); |
OutInt(n) |
END |
END movrc; |
PROCEDURE test (reg: INTEGER); // test reg, reg |
BEGIN |
oprr(85H, reg, reg) |
END test; |
PROCEDURE oprlongc (reg, n: INTEGER; oprr: OPRR); |
VAR |
reg2: INTEGER; |
BEGIN |
reg2 := REG.GetAnyReg(R); |
movabs(reg2, n); |
oprr(reg, reg2); |
drop |
END oprlongc; |
PROCEDURE oprc (op, reg, n: INTEGER; oprr: OPRR); |
BEGIN |
IF isLong(n) THEN |
oprlongc(reg, n, oprr) |
ELSE |
Rex(reg, 0); |
OutByte2(81H + short(n), op + reg MOD 8); |
OutIntByte(n) |
END |
END oprc; |
PROCEDURE cmprc (reg, n: INTEGER); // cmp reg, n |
BEGIN |
oprc(0F8H, reg, n, cmprr) |
END cmprc; |
PROCEDURE addrc (reg, n: INTEGER); // add reg, n |
BEGIN |
oprc(0C0H, reg, n, add) |
END addrc; |
PROCEDURE subrc (reg, n: INTEGER); // sub reg, n |
BEGIN |
oprc(0E8H, reg, n, sub) |
END subrc; |
PROCEDURE andrc (reg, n: INTEGER); // and reg, n |
BEGIN |
oprc(0E0H, reg, n, and) |
END andrc; |
PROCEDURE pushc (n: INTEGER); |
VAR |
reg2: INTEGER; |
BEGIN |
IF isLong(n) THEN |
reg2 := REG.GetAnyReg(R); |
movabs(reg2, n); |
push(reg2); |
drop |
ELSE |
OutByte(68H + short(n)); OutIntByte(n) // push n |
END |
END pushc; |
PROCEDURE not (reg: INTEGER); // not reg |
BEGIN |
Rex(reg, 0); |
OutByte2(0F7H, 0D0H + reg MOD 8) |
END not; |
PROCEDURE neg (reg: INTEGER); // neg reg |
BEGIN |
Rex(reg, 0); |
OutByte2(0F7H, 0D8H + reg MOD 8) |
END neg; |
PROCEDURE movzx (reg1, reg2, offs: INTEGER; word: BOOLEAN); // movzx reg1, byte/word[reg2 + offs] |
VAR |
b: BYTE; |
BEGIN |
Rex(reg2, reg1); |
OutByte2(0FH, 0B6H + ORD(word)); |
IF (offs = 0) & (reg2 # rbp) THEN |
b := 0 |
ELSE |
b := 40H + long(offs) |
END; |
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8); |
IF reg2 = rsp THEN |
OutByte(24H) |
END; |
IF b # 0 THEN |
OutIntByte(offs) |
END |
END movzx; |
PROCEDURE _movrm (reg1, reg2, offs, size: INTEGER; mr: BOOLEAN); |
VAR |
b: BYTE; |
BEGIN |
IF size = 16 THEN |
OutByte(66H) |
END; |
IF (reg1 >= 8) OR (reg2 >= 8) OR (size = 64) THEN |
OutByte(40H + reg2 DIV 8 + 4 * (reg1 DIV 8) + 8 * ORD(size = 64)) |
END; |
OutByte(8BH - 2 * ORD(mr) - ORD(size = 8)); |
IF (offs = 0) & (reg2 # rbp) THEN |
b := 0 |
ELSE |
b := 40H + long(offs) |
END; |
OutByte(b + (reg1 MOD 8) * 8 + reg2 MOD 8); |
IF reg2 = rsp THEN |
OutByte(24H) |
END; |
IF b # 0 THEN |
OutIntByte(offs) |
END |
END _movrm; |
PROCEDURE movmr32 (reg1, offs, reg2: INTEGER); // mov dword[reg1+offs], reg2_32 |
BEGIN |
_movrm(reg2, reg1, offs, 32, TRUE) |
END movmr32; |
PROCEDURE movrm32 (reg1, reg2, offs: INTEGER); // mov reg1_32, dword[reg2+offs] |
BEGIN |
_movrm(reg1, reg2, offs, 32, FALSE) |
END movrm32; |
PROCEDURE movmr8 (reg1, offs, reg2: INTEGER); // mov byte[reg1+offs], reg2_8 |
BEGIN |
_movrm(reg2, reg1, offs, 8, TRUE) |
END movmr8; |
PROCEDURE movrm8 (reg1, reg2, offs: INTEGER); // mov reg1_8, byte[reg2+offs] |
BEGIN |
_movrm(reg1, reg2, offs, 8, FALSE) |
END movrm8; |
PROCEDURE movmr16 (reg1, offs, reg2: INTEGER); // mov word[reg1+offs], reg2_16 |
BEGIN |
_movrm(reg2, reg1, offs, 16, TRUE) |
END movmr16; |
PROCEDURE movrm16 (reg1, reg2, offs: INTEGER); // mov reg1_16, word[reg2+offs] |
BEGIN |
_movrm(reg1, reg2, offs, 16, FALSE) |
END movrm16; |
PROCEDURE movmr (reg1, offs, reg2: INTEGER); // mov qword[reg1+offs], reg2 |
BEGIN |
_movrm(reg2, reg1, offs, 64, TRUE) |
END movmr; |
PROCEDURE movrm (reg1, reg2, offs: INTEGER); // mov reg1, qword[reg2+offs] |
BEGIN |
_movrm(reg1, reg2, offs, 64, FALSE) |
END movrm; |
PROCEDURE pushm (reg, offs: INTEGER); // push qword[reg+offs] |
VAR |
b: BYTE; |
BEGIN |
IF reg >= 8 THEN |
OutByte(41H) |
END; |
OutByte(0FFH); |
IF (offs = 0) & (reg # rbp) THEN |
b := 30H |
ELSE |
b := 70H + long(offs) |
END; |
OutByte(b + reg MOD 8); |
IF reg = rsp THEN |
OutByte(24H) |
END; |
IF b # 30H THEN |
OutIntByte(offs) |
END |
END pushm; |
PROCEDURE comisd (xmm1, xmm2: INTEGER); // comisd xmm1, xmm2 |
BEGIN |
OutByte(66H); |
IF (xmm1 >= 8) OR (xmm2 >= 8) THEN |
OutByte(40H + (xmm1 DIV 8) * 4 + xmm2 DIV 8) |
END; |
OutByte3(0FH, 2FH, 0C0H + (xmm1 MOD 8) * 8 + xmm2 MOD 8) |
END comisd; |
PROCEDURE _movsdrm (xmm, reg, offs: INTEGER; mr: BOOLEAN); |
VAR |
b: BYTE; |
BEGIN |
OutByte(0F2H); |
IF (xmm >= 8) OR (reg >= 8) THEN |
OutByte(40H + (xmm DIV 8) * 4 + reg DIV 8) |
END; |
OutByte2(0FH, 10H + ORD(mr)); |
IF (offs = 0) & (reg # rbp) THEN |
b := 0 |
ELSE |
b := 40H + long(offs) |
END; |
OutByte(b + (xmm MOD 8) * 8 + reg MOD 8); |
IF reg = rsp THEN |
OutByte(24H) |
END; |
IF b # 0 THEN |
OutIntByte(offs) |
END |
END _movsdrm; |
PROCEDURE movsdrm (xmm, reg, offs: INTEGER); // movsd xmm, qword[reg+offs] |
BEGIN |
_movsdrm(xmm, reg, offs, FALSE) |
END movsdrm; |
PROCEDURE movsdmr (reg, offs, xmm: INTEGER); // movsd qword[reg+offs], xmm |
BEGIN |
_movsdrm(xmm, reg, offs, TRUE) |
END movsdmr; |
PROCEDURE opxx (op, xmm1, xmm2: INTEGER); |
BEGIN |
OutByte(0F2H); |
IF (xmm1 >= 8) OR (xmm2 >= 8) THEN |
OutByte(40H + (xmm1 DIV 8) * 4 + xmm2 DIV 8) |
END; |
OutByte3(0FH, op, 0C0H + (xmm1 MOD 8) * 8 + xmm2 MOD 8) |
END opxx; |
PROCEDURE jcc (cc, label: INTEGER); // jcc label |
BEGIN |
X86.jcc(cc, label) |
END jcc; |
PROCEDURE jmp (label: INTEGER); // jmp label |
BEGIN |
X86.jmp(label) |
END jmp; |
PROCEDURE setcc (cc, reg: INTEGER); //setcc reg8 |
BEGIN |
IF reg >= 8 THEN |
OutByte(41H) |
END; |
OutByte3(0FH, cc, 0C0H + reg MOD 8) |
END setcc; |
PROCEDURE shiftrc (op, reg, n: INTEGER); |
BEGIN |
Rex(reg, 0); |
IF n = 1 THEN |
OutByte(0D1H) |
ELSE |
OutByte(0C1H) |
END; |
X86.shift(op, reg MOD 8); |
IF n # 1 THEN |
OutByte(n) |
END |
END shiftrc; |
PROCEDURE getVar (variables: LISTS.LIST; offset: INTEGER): CODE.LOCALVAR; |
VAR |
cur: CODE.LOCALVAR; |
BEGIN |
cur := variables.first(CODE.LOCALVAR); |
WHILE (cur # NIL) & (cur.offset # offset) DO |
cur := cur.next(CODE.LOCALVAR) |
END |
RETURN cur |
END getVar; |
PROCEDURE allocReg (cmd: COMMAND); |
VAR |
leave: BOOLEAN; |
leaf: BOOLEAN; |
cur: COMMAND; |
variables: LISTS.LIST; |
lvar, rvar: CODE.LOCALVAR; |
reg: INTEGER; |
max: INTEGER; |
loop: INTEGER; |
BEGIN |
loop := 1; |
variables := cmd.variables; |
leave := FALSE; |
leaf := TRUE; |
cur := cmd.next(COMMAND); |
REPEAT |
CASE cur.opcode OF |
|CODE.opLLOAD64, |
CODE.opLLOAD8, |
CODE.opLLOAD16, |
CODE.opLLOAD32, |
CODE.opLLOAD64_PARAM, |
CODE.opLLOAD32_PARAM, |
CODE.opLADR_SAVE, |
CODE.opLADR_INC1, |
CODE.opLADR_DEC1, |
CODE.opLADR_INC, |
CODE.opLADR_DEC, |
CODE.opLADR_INC1B, |
CODE.opLADR_DEC1B, |
CODE.opLADR_INCB, |
CODE.opLADR_DECB, |
CODE.opLADR_INCL, |
CODE.opLADR_EXCL, |
CODE.opLADR_UNPK: |
lvar := getVar(variables, cur.param2); |
IF (lvar # NIL) & (lvar.count # -1) THEN |
INC(lvar.count, loop) |
END |
|CODE.opLADR_SAVEC, |
CODE.opLADR_INCC, |
CODE.opLADR_DECC, |
CODE.opLADR_INCCB, |
CODE.opLADR_DECCB, |
CODE.opLADR_INCLC, |
CODE.opLADR_EXCLC: |
lvar := getVar(variables, cur.param1); |
IF (lvar # NIL) & (lvar.count # -1) THEN |
INC(lvar.count, loop) |
END |
|CODE.opLADR: |
lvar := getVar(variables, cur.param2); |
IF (lvar # NIL) & (lvar.count # -1) THEN |
lvar.count := -1 |
END |
|CODE.opLOOP: |
INC(loop, 10) |
|CODE.opENDLOOP: |
DEC(loop, 10) |
|CODE.opLEAVE, |
CODE.opLEAVER, |
CODE.opLEAVEF: |
leave := TRUE |
|CODE.opCALL, CODE.opCALLP, CODE.opCALLI, |
CODE.opWIN64CALL, CODE.opWIN64CALLP, CODE.opWIN64CALLI, |
CODE.opSYSVCALL, CODE.opSYSVCALLP, CODE.opSYSVCALLI: |
leaf := FALSE |
ELSE |
END; |
cur := cur.next(COMMAND) |
UNTIL leave OR ~leaf; |
IF leaf THEN |
REPEAT |
reg := -1; |
max := -1; |
rvar := NIL; |
lvar := variables.first(CODE.LOCALVAR); |
WHILE lvar # NIL DO |
IF lvar.count > max THEN |
max := lvar.count; |
rvar := lvar |
END; |
lvar := lvar.next(CODE.LOCALVAR) |
END; |
IF rvar # NIL THEN |
reg := REG.GetAnyVarReg(R); |
IF reg # -1 THEN |
REG.Lock(R, reg, rvar.offset, rvar.size); |
REG.Load(R, reg); |
rvar.count := -1 |
END |
END |
UNTIL (rvar = NIL) OR (reg = -1) |
END |
END allocReg; |
PROCEDURE GetRegA; |
BEGIN |
ASSERT(REG.GetReg(R, rax)) |
END GetRegA; |
PROCEDURE Win64Passing (params: INTEGER); |
VAR |
n, i: INTEGER; |
BEGIN |
n := params MOD 32; |
params := params DIV 32; |
FOR i := 0 TO n - 1 DO |
IF i IN BITS(params) THEN |
movsdrm(i, rsp, i * 8) |
ELSE |
movrm(Win64RegPar[i], rsp, i * 8) |
END |
END |
END Win64Passing; |
PROCEDURE SysVPassing (params: INTEGER); |
VAR |
n, i, s, p, ofs: INTEGER; |
i_count, f_count: INTEGER; |
reg: BOOLEAN; |
BEGIN |
ASSERT(r10 IN R.regs); |
n := params MOD 32; |
params := params DIV 32; |
s := 0; |
i_count := 0; |
f_count := 0; |
FOR i := 0 TO n - 1 DO |
IF i IN BITS(params) THEN |
INC(f_count) |
ELSE |
INC(i_count) |
END |
END; |
s := MAX(0, f_count - 8) + MAX(0, i_count - 6); |
p := 0; |
subrc(rsp, s * 8); |
i_count := 0; |
f_count := 0; |
FOR i := 0 TO n - 1 DO |
ofs := (i + s) * 8; |
IF i IN BITS(params) THEN |
reg := f_count <= 7; |
IF reg THEN |
movsdrm(f_count, rsp, ofs); |
INC(f_count) |
END |
ELSE |
reg := i_count <= 5; |
IF reg THEN |
movrm(SystemVRegPar[i_count], rsp, ofs); |
INC(i_count) |
END |
END; |
IF ~reg THEN |
movrm(r10, rsp, ofs); |
movmr(rsp, p, r10); |
INC(p, 8) |
END |
END |
END SysVPassing; |
PROCEDURE fcmp (op: INTEGER; xmm: INTEGER); |
VAR |
cc, reg: INTEGER; |
BEGIN |
reg := REG.GetAnyReg(R); |
xor(reg, reg); |
CASE op OF |
|CODE.opEQF, CODE.opEQFI: |
comisd(xmm - 1, xmm); |
cc := sete |
|CODE.opNEF, CODE.opNEFI: |
comisd(xmm - 1, xmm); |
cc := setne |
|CODE.opLTF, CODE.opGTFI: |
comisd(xmm - 1, xmm); |
cc := setc |
|CODE.opGTF, CODE.opLTFI: |
comisd(xmm, xmm - 1); |
cc := setc |
|CODE.opLEF, CODE.opGEFI: |
comisd(xmm, xmm - 1); |
cc := setnc |
|CODE.opGEF, CODE.opLEFI: |
comisd(xmm - 1, xmm); |
cc := setnc |
END; |
OutByte2(7AH, 3 + reg DIV 8); // jp L |
setcc(cc, reg); |
//L: |
END fcmp; |
PROCEDURE translate (commands: LISTS.LIST; stroffs: INTEGER); |
VAR |
cmd, next: COMMAND; |
param1, param2, param3, a, b, c, n, label, L, i, cc: INTEGER; |
reg1, reg2, xmm: INTEGER; |
float: REAL; |
regVar: BOOLEAN; |
BEGIN |
xmm := -1; |
cmd := commands.first(COMMAND); |
WHILE cmd # NIL DO |
param1 := cmd.param1; |
param2 := cmd.param2; |
CASE cmd.opcode OF |
|CODE.opJMP: |
jmp(param1) |
|CODE.opCALL, CODE.opWIN64CALL, CODE.opSYSVCALL: |
REG.Store(R); |
CASE cmd.opcode OF |
|CODE.opCALL: |
|CODE.opWIN64CALL: Win64Passing(param2) |
|CODE.opSYSVCALL: SysVPassing(param2) |
END; |
X86.call(param1); |
REG.Restore(R) |
|CODE.opCALLP, CODE.opWIN64CALLP, CODE.opSYSVCALLP: |
UnOp(reg1); |
IF reg1 # rax THEN |
GetRegA; |
ASSERT(REG.Exchange(R, reg1, rax)); |
drop |
END; |
drop; |
REG.Store(R); |
CASE cmd.opcode OF |
|CODE.opCALLP: |
|CODE.opWIN64CALLP: Win64Passing(param2) |
|CODE.opSYSVCALLP: SysVPassing(param2) |
END; |
OutByte2(0FFH, 0D0H); // call rax |
REG.Restore(R); |
ASSERT(R.top = -1) |
|CODE.opCALLI, CODE.opWIN64CALLI, CODE.opSYSVCALLI: |
REG.Store(R); |
CASE cmd.opcode OF |
|CODE.opCALLI: |
|CODE.opWIN64CALLI: Win64Passing(param2) |
|CODE.opSYSVCALLI: SysVPassing(param2) |
END; |
callimp(param1); |
REG.Restore(R) |
|CODE.opLABEL: |
X86.SetLabel(param2) |
|CODE.opERR: |
CallRTL(CODE._error) |
|CODE.opERRC: |
pushc(param2) |
|CODE.opPRECALL: |
n := param2; |
IF (param1 # 0) & (n # 0) THEN |
subrc(rsp, 8) |
END; |
WHILE n > 0 DO |
subrc(rsp, 8); |
movsdmr(rsp, 0, xmm); |
DEC(xmm); |
DEC(n) |
END; |
ASSERT(xmm = -1); |
PushAll(0) |
|CODE.opWIN64ALIGN16: |
ASSERT(rax IN R.regs); |
mov(rax, rsp); |
andrc(rsp, -16); |
push(rax); |
subrc(rsp, (MAX(param2 - 4, 0) MOD 2 + MAX(4 - param2, 0) + 1) * 8) |
|CODE.opSYSVALIGN16: |
ASSERT(rax IN R.regs); |
mov(rax, rsp); |
andrc(rsp, -16); |
push(rax); |
IF ~ODD(param2) THEN |
push(rax) |
END |
|CODE.opRESF: |
ASSERT(xmm = -1); |
INC(xmm); |
n := param2; |
IF n > 0 THEN |
movsdmr(rsp, n * 8, xmm); |
DEC(xmm); |
INC(n) |
END; |
WHILE n > 0 DO |
INC(xmm); |
movsdrm(xmm, rsp, 0); |
addrc(rsp, 8); |
DEC(n) |
END |
|CODE.opRES: |
ASSERT(R.top = -1); |
GetRegA; |
n := param2; |
WHILE n > 0 DO |
INC(xmm); |
movsdrm(xmm, rsp, 0); |
addrc(rsp, 8); |
DEC(n) |
END |
|CODE.opENTER: |
ASSERT(R.top = -1); |
X86.SetLabel(param1); |
param3 := cmd.param3; |
IF param3 > 0 THEN |
push(rbp); |
mov(rbp, rsp); |
n := param3 MOD 32; |
param3 := param3 DIV 32; |
FOR i := 0 TO n - 1 DO |
IF i IN BITS(param3) THEN |
movsdmr(rbp, i * 8 + 16, i) |
ELSE |
movmr(rbp, i * 8 + 16, Win64RegPar[i]) |
END |
END |
ELSIF param3 < 0 THEN |
param3 := -param3; |
n := (param3 MOD 32) * 8; |
param3 := param3 DIV 32; |
pop(r10); |
subrc(rsp, n); |
push(r10); |
push(rbp); |
mov(rbp, rsp); |
a := 0; |
b := 0; |
c := 0; |
INC(n, 16); |
FOR i := 16 TO n - 8 BY 8 DO |
IF ODD(param3) THEN |
IF b <= 7 THEN |
movsdmr(rbp, i, b); |
INC(b) |
ELSE |
movrm(r10, rbp, n + c); |
movmr(rbp, i, r10); |
INC(c, 8) |
END |
ELSE |
IF a <= 5 THEN |
movmr(rbp, i, SystemVRegPar[a]); |
INC(a) |
ELSE |
movrm(r10, rbp, n + c); |
movmr(rbp, i, r10); |
INC(c, 8) |
END |
END; |
param3 := param3 DIV 2 |
END |
ELSE |
push(rbp); |
mov(rbp, rsp) |
END; |
n := param2; |
IF n > 4 THEN |
movrc(rcx, n); |
// L: |
pushc(0); |
OutByte2(0E2H, 0FCH) // loop L |
ELSE |
WHILE n > 0 DO |
pushc(0); |
DEC(n) |
END |
END; |
IF cmd.allocReg THEN |
allocReg(cmd) |
END |
|CODE.opLEAVE, CODE.opLEAVER, CODE.opLEAVEF: |
IF cmd.opcode = CODE.opLEAVER THEN |
UnOp(reg1); |
IF reg1 # rax THEN |
GetRegA; |
ASSERT(REG.Exchange(R, reg1, rax)); |
drop |
END; |
drop |
END; |
ASSERT(R.top = -1); |
IF cmd.opcode = CODE.opLEAVEF THEN |
DEC(xmm) |
END; |
ASSERT(xmm = -1); |
mov(rsp, rbp); |
pop(rbp); |
IF param2 > 0 THEN |
OutByte3(0C2H, (param2 * 8) MOD 256, (param2 * 8) DIV 256) // ret param2 |
ELSE |
OutByte(0C3H) // ret |
END; |
REG.Reset(R) |
|CODE.opSAVES: |
UnOp(reg1); |
drop; |
PushAll(0); |
push(reg1); |
pushDA(stroffs + param2); |
pushc(param1); |
CallRTL(CODE._move) |
|CODE.opSADR: |
reg1 := REG.GetAnyReg(R); |
lea(reg1, stroffs + param2, sDATA) |
|CODE.opLOAD8: |
UnOp(reg1); |
movzx(reg1, reg1, 0, FALSE) |
|CODE.opLOAD16: |
UnOp(reg1); |
movzx(reg1, reg1, 0, TRUE) |
|CODE.opLOAD32: |
UnOp(reg1); |
movrm32(reg1, reg1, 0); |
shiftrc(shl, reg1, 32); |
shiftrc(shr, reg1, 32) |
|CODE.opLOAD64: |
UnOp(reg1); |
movrm(reg1, reg1, 0) |
|CODE.opLLOAD64: |
reg1 := REG.GetAnyReg(R); |
reg2 := REG.GetVarReg(R, param2); |
IF reg2 # -1 THEN |
mov(reg1, reg2) |
ELSE |
movrm(reg1, rbp, param2 * 8) |
END |
|CODE.opLLOAD8, |
CODE.opLLOAD16: |
reg1 := REG.GetAnyReg(R); |
reg2 := REG.GetVarReg(R, param2); |
IF reg2 # -1 THEN |
mov(reg1, reg2) |
ELSE |
movzx(reg1, rbp, param2 * 8, cmd.opcode = CODE.opLLOAD16) |
END |
|CODE.opLLOAD32: |
reg1 := REG.GetAnyReg(R); |
reg2 := REG.GetVarReg(R, param2); |
IF reg2 # -1 THEN |
mov(reg1, reg2) |
ELSE |
n := param2 * 8; |
xor(reg1, reg1); |
movrm32(reg1, rbp, n) |
END |
|CODE.opGLOAD64: |
reg1 := REG.GetAnyReg(R); |
lea(reg1, param2, sBSS); |
movrm(reg1, reg1, 0) |
|CODE.opGLOAD8: |
reg1 := REG.GetAnyReg(R); |
lea(reg1, param2, sBSS); |
movzx(reg1, reg1, 0, FALSE) |
|CODE.opGLOAD16: |
reg1 := REG.GetAnyReg(R); |
lea(reg1, param2, sBSS); |
movzx(reg1, reg1, 0, TRUE) |
|CODE.opGLOAD32: |
reg1 := REG.GetAnyReg(R); |
xor(reg1, reg1); |
lea(reg1, param2, sBSS); |
movrm32(reg1, reg1, 0) |
|CODE.opVLOAD64: |
reg1 := REG.GetAnyReg(R); |
movrm(reg1, rbp, param2 * 8); |
movrm(reg1, reg1, 0) |
|CODE.opVLOAD8, |
CODE.opVLOAD16: |
reg1 := REG.GetAnyReg(R); |
movrm(reg1, rbp, param2 * 8); |
movzx(reg1, reg1, 0, cmd.opcode = CODE.opVLOAD16) |
|CODE.opVLOAD32: |
reg1 := REG.GetAnyReg(R); |
reg2 := REG.GetAnyReg(R); |
xor(reg1, reg1); |
movrm(reg2, rbp, param2 * 8); |
movrm32(reg1, reg2, 0); |
drop |
|CODE.opLADR: |
n := param2 * 8; |
next := cmd.next(COMMAND); |
IF next.opcode = CODE.opSAVEF THEN |
movsdmr(rbp, n, xmm); |
DEC(xmm); |
cmd := next |
ELSIF next.opcode = CODE.opLOADF THEN |
INC(xmm); |
movsdrm(xmm, rbp, n); |
cmd := next |
ELSE |
reg1 := REG.GetAnyReg(R); |
Rex(0, reg1); |
OutByte2(8DH, 45H + long(n) + (reg1 MOD 8) * 8); // lea reg1, qword[rbp+n] |
OutIntByte(n) |
END |
|CODE.opGADR: |
reg1 := REG.GetAnyReg(R); |
lea(reg1, param2, sBSS) |
|CODE.opVADR: |
reg1 := REG.GetAnyReg(R); |
movrm(reg1, rbp, param2 * 8) |
|CODE.opSAVE8C: |
UnOp(reg1); |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte3(0C6H, reg1 MOD 8, param2); // mov byte[reg1], param2 |
drop |
|CODE.opSAVE16C: |
UnOp(reg1); |
OutByte(66H); |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte2(0C7H, reg1 MOD 8); |
OutByte2(param2 MOD 256, param2 DIV 256); // mov word[reg1], param2 |
drop |
|CODE.opSAVEC: |
UnOp(reg1); |
IF isLong(param2) THEN |
reg2 := REG.GetAnyReg(R); |
movrc(reg2, param2); |
movmr(reg1, 0, reg2); |
drop |
ELSE |
Rex(reg1, 0); |
OutByte2(0C7H, reg1 MOD 8); // mov qword[reg1], param2 |
OutInt(param2) |
END; |
drop |
|CODE.opRSET: |
PushAll(2); |
CallRTL(CODE._set); |
GetRegA |
|CODE.opRSETR: |
PushAll(1); |
pushc(param2); |
CallRTL(CODE._set); |
GetRegA |
|CODE.opRSETL: |
PushAll(1); |
pushc(param2); |
CallRTL(CODE._set2); |
GetRegA |
|CODE.opRSET1: |
UnOp(reg1); |
PushAll(1); |
push(reg1); |
CallRTL(CODE._set); |
GetRegA |
|CODE.opINCL, CODE.opEXCL: |
BinOp(reg1, reg2); |
cmprc(reg1, 64); |
OutByte2(73H, 04H); // jnb L |
Rex(reg2, reg1); |
OutByte3(0FH, 0ABH + 8 * ORD(cmd.opcode = CODE.opEXCL), 8 * (reg1 MOD 8) + reg2 MOD 8); // bts/btr qword[reg2], reg1 |
// L: |
drop; |
drop |
|CODE.opINCLC, CODE.opEXCLC: |
UnOp(reg1); |
Rex(reg1, 0); |
OutByte2(0FH, 0BAH); // bts/btr qword[reg1], param2 |
OutByte2(28H + 8 * ORD(cmd.opcode = CODE.opEXCLC) + reg1 MOD 8, param2); |
drop |
|CODE.opEQS .. CODE.opGES: |
PushAll(4); |
pushc(cmd.opcode - CODE.opEQS); |
CallRTL(CODE._strcmp); |
GetRegA |
|CODE.opEQS2 .. CODE.opGES2: |
PushAll(4); |
pushc(cmd.opcode - CODE.opEQS2); |
CallRTL(CODE._strcmp2); |
GetRegA |
|CODE.opEQSW .. CODE.opGESW: |
PushAll(4); |
pushc(cmd.opcode - CODE.opEQSW); |
CallRTL(CODE._strcmpw); |
GetRegA |
|CODE.opEQSW2 .. CODE.opGESW2: |
PushAll(4); |
pushc(cmd.opcode - CODE.opEQSW2); |
CallRTL(CODE._strcmpw2); |
GetRegA |
|CODE.opINC1, CODE.opDEC1: |
UnOp(reg1); |
Rex(reg1, 0); |
OutByte2(0FFH, reg1 MOD 8 + 8 * ORD(cmd.opcode = CODE.opDEC1)); |
drop |
|CODE.opCONST: |
reg1 := REG.GetAnyReg(R); |
movrc(reg1, param2) |
|CODE.opGT, CODE.opGE, CODE.opLT, |
CODE.opLE, CODE.opEQ, CODE.opNE: |
BinOp(reg1, reg2); |
cmprr(reg1, reg2); |
drop; |
drop; |
cc := X86.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(X86.inv1(cc), label); |
cmd := cmd.next(COMMAND) |
ELSE |
reg1 := REG.GetAnyReg(R); |
setcc(cc + 16, reg1); |
andrc(reg1, 1) |
END |
|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) |
ELSE |
cmprc(reg1, param2) |
END; |
drop; |
cc := X86.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(X86.inv1(cc), label); |
cmd := cmd.next(COMMAND) |
ELSE |
reg1 := REG.GetAnyReg(R); |
setcc(cc + 16, reg1); |
andrc(reg1, 1) |
END |
|CODE.opCODE: |
OutByte(param2) |
|CODE.opPUSHIP: |
reg1 := REG.GetAnyReg(R); |
lea(reg1, param2, sIMP); |
movrm(reg1, reg1, 0) |
|CODE.opPARAM: |
n := param2; |
IF n = 1 THEN |
UnOp(reg1); |
push(reg1); |
drop |
ELSE |
ASSERT(R.top + 1 <= n); |
PushAll(n) |
END |
|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.opIN: |
label := NewLabel(); |
L := NewLabel(); |
BinOp(reg1, reg2); |
cmprc(reg1, 64); |
jcc(jb, L); |
xor(reg1, reg1); |
jmp(label); |
X86.SetLabel(L); |
Rex(reg2, reg1); |
OutByte3(0FH, 0A3H, 0C0H + 8 * (reg1 MOD 8) + reg2 MOD 8); // bt reg2, reg1 |
setcc(setc, reg1); |
andrc(reg1, 1); |
X86.SetLabel(label); |
drop |
|CODE.opINR: |
label := NewLabel(); |
L := NewLabel(); |
UnOp(reg1); |
reg2 := REG.GetAnyReg(R); |
cmprc(reg1, 64); |
jcc(jb, L); |
xor(reg1, reg1); |
jmp(label); |
X86.SetLabel(L); |
movrc(reg2, param2); |
Rex(reg2, reg1); |
OutByte3(0FH, 0A3H, 0C0H + 8 * (reg1 MOD 8) + reg2 MOD 8); // bt reg2, reg1 |
setcc(setc, reg1); |
andrc(reg1, 1); |
X86.SetLabel(label); |
drop |
|CODE.opINL: |
UnOp(reg1); |
Rex(reg1, 0); |
OutByte2(0FH, 0BAH); // bt reg1, param2 |
OutByte2(0E0H + reg1 MOD 8, param2); |
setcc(setc, reg1); |
andrc(reg1, 1) |
|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.opABS: |
UnOp(reg1); |
test(reg1); |
OutByte2(7DH, 03H); // jge L |
neg(reg1) |
// L: |
|CODE.opEQB, CODE.opNEB: |
BinOp(reg1, reg2); |
drop; |
drop; |
test(reg1); |
OutByte2(74H, 07H); // je L1 |
movrc(reg1, 1); |
// L1: |
test(reg2); |
OutByte2(74H, 07H); // je L2 |
movrc(reg2, 1); |
// L2: |
cmprr(reg1, reg2); |
reg1 := REG.GetAnyReg(R); |
IF cmd.opcode = CODE.opEQB THEN |
setcc(sete, reg1) |
ELSE |
setcc(setne, reg1) |
END; |
andrc(reg1, 1) |
|CODE.opMULSC: |
UnOp(reg1); |
andrc(reg1, param2) |
|CODE.opDIVSC, CODE.opADDSL, CODE.opADDSR: |
UnOp(reg1); |
Rex(reg1, 0); |
OutByte2(81H + short(param2), 0C8H + 28H * ORD(cmd.opcode = CODE.opDIVSC) + reg1 MOD 8); // or/xor reg1, param2 |
OutIntByte(param2) |
|CODE.opSUBSL: |
UnOp(reg1); |
not(reg1); |
andrc(reg1, param2) |
|CODE.opSUBSR: |
UnOp(reg1); |
andrc(reg1, ORD(-BITS(param2))) |
|CODE.opMULS: |
BinOp(reg1, reg2); |
and(reg1, reg2); |
drop |
|CODE.opDIVS: |
BinOp(reg1, reg2); |
xor(reg1, reg2); |
drop |
|CODE.opUMINS: |
UnOp(reg1); |
not(reg1) |
|CODE.opCOPY: |
PushAll(2); |
pushc(param2); |
CallRTL(CODE._move2) |
|CODE.opMOVE: |
PushAll(3); |
CallRTL(CODE._move2) |
|CODE.opCOPYA: |
PushAll(4); |
pushc(param2); |
CallRTL(CODE._arrcpy); |
GetRegA |
|CODE.opCOPYS: |
PushAll(4); |
pushc(param2); |
CallRTL(CODE._strcpy) |
|CODE.opCOPYS2: |
PushAll(4); |
pushc(param2); |
CallRTL(CODE._strcpy2) |
|CODE.opROT: |
PushAll(0); |
push(rsp); |
pushc(param2); |
CallRTL(CODE._rot) |
|CODE.opNEW: |
PushAll(1); |
n := param2 + 16; |
ASSERT(MACHINE.Align(n, 64)); |
pushc(n); |
pushc(param1); |
CallRTL(CODE._new) |
|CODE.opDISP: |
PushAll(1); |
CallRTL(CODE._dispose) |
|CODE.opPUSHT: |
UnOp(reg1); |
reg2 := REG.GetAnyReg(R); |
movrm(reg2, reg1, -8) |
|CODE.opISREC: |
PushAll(2); |
pushc(param2); |
CallRTL(CODE._isrec); |
GetRegA |
|CODE.opIS: |
PushAll(1); |
pushc(param2); |
CallRTL(CODE._is); |
GetRegA |
|CODE.opTYPEGR: |
PushAll(1); |
pushc(param2); |
CallRTL(CODE._guardrec); |
GetRegA |
|CODE.opTYPEGP: |
UnOp(reg1); |
PushAll(0); |
push(reg1); |
pushc(param2); |
CallRTL(CODE._guard); |
GetRegA |
|CODE.opTYPEGD: |
UnOp(reg1); |
PushAll(0); |
pushm(reg1, -8); |
pushc(param2); |
CallRTL(CODE._guardrec); |
GetRegA |
|CODE.opCASET: |
push(r10); |
push(r10); |
pushc(param2); |
CallRTL(CODE._guardrec); |
pop(r10); |
test(rax); |
jcc(jne, param1) |
|CODE.opSAVEP: |
UnOp(reg1); |
reg2 := REG.GetAnyReg(R); |
lea(reg2, param2, sCODE); |
movmr(reg1, 0, reg2); |
drop; |
drop |
|CODE.opPUSHP: |
reg1 := REG.GetAnyReg(R); |
lea(reg1, param2, sCODE) |
|CODE.opINC, CODE.opDEC: |
BinOp(reg1, reg2); |
// add/sub qword[reg2], reg1 |
Rex(reg2, reg1); |
OutByte2(01H + 28H * ORD(cmd.opcode = CODE.opDEC), reg2 MOD 8 + (reg1 MOD 8) * 8); |
drop; |
drop |
|CODE.opINCC, CODE.opDECC: |
UnOp(reg1); |
IF isLong(param2) THEN |
reg2 := REG.GetAnyReg(R); |
movrc(reg2, param2); |
// add/sub qword[reg1], reg2 |
Rex(reg1, reg2); |
OutByte2(01H + 28H * ORD(cmd.opcode = CODE.opDECC), reg1 MOD 8 + (reg2 MOD 8) * 8); |
drop |
ELSE |
// add/sub qword[reg1], param2 |
Rex(reg1, 0); |
OutByte2(81H + short(param2), 28H * ORD(cmd.opcode = CODE.opDECC) + reg1 MOD 8); |
OutIntByte(param2) |
END; |
drop |
|CODE.opDROP: |
UnOp(reg1); |
drop |
|CODE.opSAVE, CODE.opSAVE64: |
BinOp(reg2, reg1); |
movmr(reg1, 0, reg2); |
drop; |
drop |
|CODE.opSAVE8: |
BinOp(reg2, reg1); |
movmr8(reg1, 0, reg2); |
drop; |
drop |
|CODE.opSAVE16: |
BinOp(reg2, reg1); |
movmr16(reg1, 0, reg2); |
drop; |
drop |
|CODE.opSAVE32: |
BinOp(reg2, reg1); |
movmr32(reg1, 0, reg2); |
drop; |
drop |
|CODE.opMIN: |
BinOp(reg1, reg2); |
cmprr(reg1, reg2); |
OutByte2(7EH, 3); // jle L |
mov(reg1, reg2); |
// L: |
drop |
|CODE.opMAX: |
BinOp(reg1, reg2); |
cmprr(reg1, reg2); |
OutByte2(7DH, 3); // jge L |
mov(reg1, reg2); |
// L: |
drop |
|CODE.opMINC: |
UnOp(reg1); |
cmprc(reg1, param2); |
label := NewLabel(); |
jcc(jle, label); |
movrc(reg1, param2); |
X86.SetLabel(label) |
|CODE.opMAXC: |
UnOp(reg1); |
cmprc(reg1, param2); |
label := NewLabel(); |
jcc(jge, label); |
movrc(reg1, param2); |
X86.SetLabel(label) |
|CODE.opSBOOL: |
BinOp(reg2, reg1); |
test(reg2); |
setcc(setne, reg2); |
movmr8(reg1, 0, reg2); |
drop; |
drop |
|CODE.opSBOOLC: |
UnOp(reg1); |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte3(0C6H, reg1 MOD 8, ORD(param2 # 0)); |
drop |
|CODE.opODD: |
UnOp(reg1); |
andrc(reg1, 1) |
|CODE.opUMINUS: |
UnOp(reg1); |
neg(reg1) |
|CODE.opADD: |
BinOp(reg1, reg2); |
add(reg1, reg2); |
drop |
|CODE.opSUB: |
BinOp(reg1, reg2); |
sub(reg1, reg2); |
drop |
|CODE.opSUBR, CODE.opSUBL: |
UnOp(reg1); |
n := param2; |
IF n = 1 THEN |
decr(reg1) |
ELSIF n = -1 THEN |
incr(reg1) |
ELSIF n # 0 THEN |
subrc(reg1, n) |
END; |
IF cmd.opcode = CODE.opSUBL THEN |
neg(reg1) |
END |
|CODE.opADDL, CODE.opADDR: |
IF param2 # 0 THEN |
UnOp(reg1); |
IF param2 = 1 THEN |
incr(reg1) |
ELSIF param2 = -1 THEN |
decr(reg1) |
ELSE |
addrc(reg1, param2) |
END |
END |
|CODE.opDIV: |
PushAll(2); |
CallRTL(CODE._div); |
GetRegA |
|CODE.opDIVR: |
a := param2; |
IF a > 1 THEN |
n := X86.log2(a) |
ELSIF a < -1 THEN |
n := X86.log2(-a) |
ELSE |
n := -1 |
END; |
IF a = 1 THEN |
ELSIF a = -1 THEN |
UnOp(reg1); |
neg(reg1) |
ELSE |
IF n > 0 THEN |
UnOp(reg1); |
IF a < 0 THEN |
reg2 := REG.GetAnyReg(R); |
mov(reg2, reg1); |
shiftrc(sar, reg1, n); |
sub(reg1, reg2); |
drop |
ELSE |
shiftrc(sar, reg1, n) |
END |
ELSE |
PushAll(1); |
pushc(param2); |
CallRTL(CODE._div); |
GetRegA |
END |
END |
|CODE.opDIVL: |
PushAll(1); |
pushc(param2); |
CallRTL(CODE._div2); |
GetRegA |
|CODE.opMOD: |
PushAll(2); |
CallRTL(CODE._mod); |
GetRegA |
|CODE.opMODR: |
a := param2; |
IF a > 1 THEN |
n := X86.log2(a) |
ELSIF a < -1 THEN |
n := X86.log2(-a) |
ELSE |
n := -1 |
END; |
IF ABS(a) = 1 THEN |
UnOp(reg1); |
xor(reg1, reg1) |
ELSE |
IF n > 0 THEN |
UnOp(reg1); |
andrc(reg1, ABS(a) - 1); |
IF a < 0 THEN |
test(reg1); |
label := NewLabel(); |
jcc(je, label); |
addrc(reg1, a); |
X86.SetLabel(label) |
END |
ELSE |
PushAll(1); |
pushc(param2); |
CallRTL(CODE._mod); |
GetRegA |
END |
END |
|CODE.opMODL: |
PushAll(1); |
pushc(param2); |
CallRTL(CODE._mod2); |
GetRegA |
|CODE.opMUL: |
BinOp(reg1, reg2); |
oprr2(0FH, 0AFH, reg2, reg1); // imul reg1, reg2 |
drop |
|CODE.opMULC: |
UnOp(reg1); |
a := param2; |
IF a > 1 THEN |
n := X86.log2(a) |
ELSIF a < -1 THEN |
n := X86.log2(-a) |
ELSE |
n := -1 |
END; |
IF a = 1 THEN |
ELSIF a = -1 THEN |
neg(reg1) |
ELSIF a = 0 THEN |
xor(reg1, reg1) |
ELSE |
IF n > 0 THEN |
IF a < 0 THEN |
neg(reg1) |
END; |
shiftrc(shl, reg1, n) |
ELSE |
// imul reg1, a |
Rex(reg1, reg1); |
OutByte2(69H + short(a), 0C0H + (reg1 MOD 8) * 9); |
OutIntByte(a) |
END |
END |
|CODE.opADDS: |
BinOp(reg1, reg2); |
or(reg1, reg2); |
drop |
|CODE.opSUBS: |
BinOp(reg1, reg2); |
not(reg2); |
and(reg1, reg2); |
drop |
|CODE.opNOP: |
|CODE.opSWITCH: |
UnOp(reg1); |
IF param2 = 0 THEN |
reg2 := rax |
ELSE |
reg2 := r10 |
END; |
IF reg1 # reg2 THEN |
ASSERT(REG.GetReg(R, reg2)); |
ASSERT(REG.Exchange(R, reg1, reg2)); |
drop |
END; |
drop |
|CODE.opENDSW: |
|CODE.opCASEL: |
cmprc(rax, param1); |
jcc(jl, param2) |
|CODE.opCASER: |
cmprc(rax, param1); |
jcc(jg, param2) |
|CODE.opCASELR: |
cmprc(rax, param1); |
jcc(jl, param2); |
jcc(jg, cmd.param3) |
|CODE.opASR, CODE.opROR, CODE.opLSL, CODE.opLSR: |
BinOp(reg1, reg2); |
xchg(reg2, rcx); |
Rex(reg1, 0); |
OutByte(0D3H); |
X86.shift(cmd.opcode, reg1 MOD 8); // shift reg1, cl |
xchg(reg2, rcx); |
drop |
|CODE.opASR1, CODE.opROR1, CODE.opLSL1, CODE.opLSR1: |
reg1 := REG.GetAnyReg(R); |
movrc(reg1, param2); |
BinOp(reg1, reg2); |
xchg(reg1, rcx); |
Rex(reg2, 0); |
OutByte(0D3H); |
X86.shift(cmd.opcode, reg2 MOD 8); // shift reg2, cl |
xchg(reg1, rcx); |
drop; |
drop; |
ASSERT(REG.GetReg(R, reg2)) |
|CODE.opASR2, CODE.opROR2, CODE.opLSL2, CODE.opLSR2: |
UnOp(reg1); |
shiftrc(cmd.opcode, reg1, ORD(BITS(param2) * {0..5})) |
|CODE.opGET: |
BinOp(reg1, reg2); |
drop; |
drop; |
_movrm(reg1, reg1, 0, param2 * 8, FALSE); |
_movrm(reg1, reg2, 0, param2 * 8, TRUE) |
|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) |
ELSE |
INCL(R.regs, reg1); |
DEC(R.top); |
R.stk[R.top] := reg2 |
END |
|CODE.opLENGTH: |
PushAll(2); |
CallRTL(CODE._length); |
GetRegA |
|CODE.opLENGTHW: |
PushAll(2); |
CallRTL(CODE._lengthw); |
GetRegA |
|CODE.opLEN: |
n := param2; |
UnOp(reg1); |
drop; |
EXCL(R.regs, reg1); |
WHILE n > 0 DO |
UnOp(reg2); |
drop; |
DEC(n) |
END; |
INCL(R.regs, reg1); |
ASSERT(REG.GetReg(R, reg1)) |
|CODE.opCHR: |
UnOp(reg1); |
andrc(reg1, 255) |
|CODE.opWCHR: |
UnOp(reg1); |
andrc(reg1, 65535) |
|CODE.opEQP, CODE.opNEP, CODE.opEQIP, CODE.opNEIP: |
UnOp(reg1); |
reg2 := REG.GetAnyReg(R); |
CASE cmd.opcode OF |
|CODE.opEQP, CODE.opNEP: |
lea(reg2, param1, sCODE) |
|CODE.opEQIP, CODE.opNEIP: |
lea(reg2, param1, sIMP); |
movrm(reg2, reg2, 0) |
END; |
cmprr(reg1, reg2); |
drop; |
drop; |
reg1 := REG.GetAnyReg(R); |
CASE cmd.opcode OF |
|CODE.opEQP, CODE.opEQIP: setcc(sete, reg1) |
|CODE.opNEP, CODE.opNEIP: setcc(setne, reg1) |
END; |
andrc(reg1, 1) |
|CODE.opINC1B, CODE.opDEC1B: |
UnOp(reg1); |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte2(0FEH, 8 * ORD(cmd.opcode = CODE.opDEC1B) + reg1 MOD 8); // inc/dec byte[reg1] |
drop |
|CODE.opINCCB, CODE.opDECCB: |
UnOp(reg1); |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte3(80H, 28H * ORD(cmd.opcode = CODE.opDECCB) + reg1 MOD 8, param2 MOD 256); // add/sub byte[reg1], param2 MOD 256 |
drop |
|CODE.opINCB, CODE.opDECB: |
BinOp(reg1, reg2); |
IF (reg1 >= 8) OR (reg2 >= 8) THEN |
OutByte(40H + reg2 DIV 8 + 4 * (reg1 DIV 8)) |
END; |
OutByte2(28H * ORD(cmd.opcode = CODE.opDECB), reg2 MOD 8 + 8 * (reg1 MOD 8)); // add/sub byte[reg2], reg1_8 |
drop; |
drop |
|CODE.opSAVEIP: |
UnOp(reg1); |
reg2 := REG.GetAnyReg(R); |
lea(reg2, param2, sIMP); |
movrm(reg2, reg2, 0); |
push(reg2); |
drop; |
IF reg1 >= 8 THEN |
OutByte(41H) |
END; |
OutByte2(8FH, reg1 MOD 8); // pop qword[reg1] |
drop |
|CODE.opCLEANUP: |
n := param2 * 8; |
IF n # 0 THEN |
addrc(rsp, n) |
END |
|CODE.opPOPSP: |
pop(rsp) |
|CODE.opLOADF: |
UnOp(reg1); |
INC(xmm); |
movsdrm(xmm, reg1, 0); |
drop |
|CODE.opPUSHF: |
subrc(rsp, 8); |
movsdmr(rsp, 0, xmm); |
DEC(xmm) |
|CODE.opCONSTF: |
float := cmd.float; |
INC(xmm); |
reg1 := REG.GetAnyReg(R); |
lea(reg1, Numbers_Offs + Numbers_Count * 8, sDATA); |
movsdrm(xmm, reg1, 0); |
drop; |
NewNumber(UTILS.splitf(float, a, b)) |
|CODE.opSAVEF: |
UnOp(reg1); |
movsdmr(reg1, 0, xmm); |
DEC(xmm); |
drop |
|CODE.opADDF, CODE.opADDFI: |
opxx(58H, xmm - 1, xmm); |
DEC(xmm) |
|CODE.opSUBF: |
opxx(5CH, xmm - 1, xmm); |
DEC(xmm) |
|CODE.opSUBFI: |
opxx(5CH, xmm, xmm - 1); |
opxx(10H, xmm - 1, xmm); |
DEC(xmm) |
|CODE.opMULF: |
opxx(59H, xmm - 1, xmm); |
DEC(xmm) |
|CODE.opDIVF: |
opxx(5EH, xmm - 1, xmm); |
DEC(xmm) |
|CODE.opDIVFI: |
opxx(5EH, xmm, xmm - 1); |
opxx(10H, xmm - 1, xmm); |
DEC(xmm) |
|CODE.opUMINF: |
reg1 := REG.GetAnyReg(R); |
lea(reg1, Numbers_Offs, sDATA); |
OutByte3(66H, 40H + reg1 DIV 8 + (xmm DIV 8) * 4, 0FH); // xorpd xmm, xmmword[reg1] |
OutByte2(57H, reg1 MOD 8 + (xmm MOD 8) * 8); |
drop |
|CODE.opFABS: |
reg1 := REG.GetAnyReg(R); |
lea(reg1, Numbers_Offs + 16, sDATA); |
OutByte3(66H, 40H + reg1 DIV 8 + (xmm DIV 8) * 4, 0FH); // andpd xmm, xmmword[reg1] |
OutByte2(54H, reg1 MOD 8 + (xmm MOD 8) * 8); |
drop |
|CODE.opFLT: |
UnOp(reg1); |
INC(xmm); |
OutByte(0F2H); Rex(reg1, xmm); OutByte(0FH); // cvtsi2sd xmm, reg1 |
OutByte2(2AH, 0C0H + (xmm MOD 8) * 8 + reg1 MOD 8); |
drop |
|CODE.opFLOOR: |
reg1 := REG.GetAnyReg(R); |
subrc(rsp, 8); |
OutByte3(00FH, 0AEH, 05CH); OutByte2(024H, 004H); // stmxcsr dword[rsp+4]; |
OutByte2(00FH, 0AEH); OutByte2(01CH, 024H); // stmxcsr dword[rsp]; |
OutByte3(081H, 024H, 024H); OutByte2(0FFH, 09FH); OutByte2(0FFH, 0FFH); // and dword[rsp],11111111111111111001111111111111b; |
OutByte3(081H, 00CH, 024H); OutByte2(000H, 020H); OutByte2(000H, 000H); // or dword[rsp],00000000000000000010000000000000b; |
OutByte2(00FH, 0AEH); OutByte2(014H, 024H); // ldmxcsr dword[rsp]; |
OutByte(0F2H); Rex(xmm, reg1); OutByte(0FH); // cvtsd2si reg1, xmm |
OutByte2(2DH, 0C0H + xmm MOD 8 + (reg1 MOD 8) * 8); |
OutByte3(00FH, 0AEH, 054H); OutByte2(024H, 004H); // ldmxcsr dword[rsp+4]; |
addrc(rsp, 8); |
DEC(xmm) |
|CODE.opEQF .. CODE.opGEFI: |
fcmp(cmd.opcode, xmm); |
DEC(xmm, 2) |
|CODE.opINF: |
INC(xmm); |
reg1 := REG.GetAnyReg(R); |
lea(reg1, Numbers_Offs + 32, sDATA); |
movsdrm(xmm, reg1, 0); |
drop |
|CODE.opPACK, CODE.opPACKC: |
IF cmd.opcode = CODE.opPACK THEN |
BinOp(reg1, reg2) |
ELSE |
UnOp(reg1); |
reg2 := REG.GetAnyReg(R); |
movrc(reg2, param2) |
END; |
push(reg1); |
movrm(reg1, reg1, 0); |
shiftrc(shl, reg1, 1); |
shiftrc(shr, reg1, 53); |
add(reg1, reg2); |
andrc(reg1, ORD({0..10})); |
shiftrc(shl, reg1, 52); |
movrm(reg2, rsp, 0); |
movrm(reg2, reg2, 0); |
push(reg1); |
lea(reg1, Numbers_Offs + 40, sDATA); // {0..51, 63} |
movrm(reg1, reg1, 0); |
and(reg2, reg1); |
pop(reg1); |
or(reg2, reg1); |
pop(reg1); |
movmr(reg1, 0, reg2); |
drop; |
drop |
|CODE.opUNPK, CODE.opLADR_UNPK: |
IF cmd.opcode = CODE.opLADR_UNPK THEN |
n := param2 * 8; |
UnOp(reg1); |
reg2 := REG.GetVarReg(R, param2); |
regVar := reg2 # -1; |
IF ~regVar THEN |
reg2 := REG.GetAnyReg(R); |
Rex(0, reg2); |
OutByte2(8DH, 45H + long(n) + (reg2 MOD 8) * 8); // lea reg2, qword[rbp+n] |
OutIntByte(n) |
END |
ELSE |
BinOp(reg1, reg2); |
regVar := FALSE |
END; |
push(reg1); |
movrm(reg1, reg1, 0); |
shiftrc(shl, reg1, 1); |
shiftrc(shr, reg1, 53); |
subrc(reg1, 1023); |
IF regVar THEN |
mov(reg2, reg1); |
reg2 := REG.GetAnyReg(R) |
ELSE |
movmr(reg2, 0, reg1) |
END; |
pop(reg2); |
movrm(reg1, reg2, 0); |
push(reg2); |
lea(reg2, Numbers_Offs + 48, sDATA); // {52..61} |
movrm(reg2, reg2, 0); |
or(reg1, reg2); |
pop(reg2); |
Rex(reg1, 0); |
OutByte2(0FH, 0BAH); |
OutByte2(0F0H + reg1 MOD 8, 3EH); // btr reg1, 62 |
movmr(reg2, 0, reg1); |
drop; |
drop |
|CODE.opSADR_PARAM: |
pushDA(stroffs + param2) |
|CODE.opVADR_PARAM: |
pushm(rbp, param2 * 8) |
|CODE.opLOAD64_PARAM: |
UnOp(reg1); |
pushm(reg1, 0); |
drop |
|CODE.opLLOAD64_PARAM: |
reg1 := REG.GetVarReg(R, param2); |
IF reg1 # -1 THEN |
push(reg1) |
ELSE |
pushm(rbp, param2 * 8) |
END |
|CODE.opGLOAD64_PARAM: |
reg2 := REG.GetAnyReg(R); |
lea(reg2, param2, sBSS); |
movrm(reg2, reg2, 0); |
push(reg2); |
drop |
|CODE.opCONST_PARAM: |
pushc(param2) |
|CODE.opGLOAD32_PARAM: |
reg1 := REG.GetAnyReg(R); |
xor(reg1, reg1); |
lea(reg1, param2, sBSS); |
movrm32(reg1, reg1, 0); |
push(reg1); |
drop |
|CODE.opLOAD32_PARAM: |
UnOp(reg1); |
movrm32(reg1, reg1, 0); |
shiftrc(shl, reg1, 32); |
shiftrc(shr, reg1, 32); |
push(reg1); |
drop |
|CODE.opLLOAD32_PARAM: |
reg1 := REG.GetAnyReg(R); |
xor(reg1, reg1); |
reg2 := REG.GetVarReg(R, param2); |
IF reg2 # -1 THEN |
mov(reg1, reg2) |
ELSE |
movrm32(reg1, rbp, param2 * 8) |
END; |
push(reg1); |
drop |
|CODE.opLADR_SAVEC: |
n := param1 * 8; |
reg1 := REG.GetVarReg(R, param1); |
IF reg1 # -1 THEN |
movrc(reg1, param2) |
ELSE |
IF isLong(param2) THEN |
reg2 := REG.GetAnyReg(R); |
movrc(reg2, param2); |
movmr(rbp, n, reg2); |
drop |
ELSE |
OutByte3(48H, 0C7H, 45H + long(n)); // mov qword[rbp+n],param2 |
OutIntByte(n); |
OutInt(param2) |
END |
END |
|CODE.opGADR_SAVEC: |
IF isLong(param2) THEN |
reg1 := REG.GetAnyReg(R); |
movrc(reg1, param2); |
reg2 := REG.GetAnyReg(R); |
lea(reg2, param1, sBSS); |
movmr(reg2, 0, reg1); |
drop; |
drop |
ELSE |
reg2 := REG.GetAnyReg(R); |
lea(reg2, param1, sBSS); |
Rex(reg2, 0); |
OutByte2(0C7H, reg2 MOD 8); // mov qword[reg2], param2 |
OutInt(param2); |
drop |
END |
|CODE.opLADR_SAVE: |
UnOp(reg1); |
reg2 := REG.GetVarReg(R, param2); |
IF reg2 # -1 THEN |
mov(reg2, reg1) |
ELSE |
movmr(rbp, param2 * 8, reg1) |
END; |
drop |
|CODE.opLADR_INC1: |
reg1 := REG.GetVarReg(R, param2); |
IF reg1 # -1 THEN |
incr(reg1) |
ELSE |
n := param2 * 8; |
OutByte3(48H, 0FFH, 45H + long(n)); // inc qword[rbp+n] |
OutIntByte(n) |
END |
|CODE.opLADR_DEC1: |
reg1 := REG.GetVarReg(R, param2); |
IF reg1 # -1 THEN |
decr(reg1) |
ELSE |
n := param2 * 8; |
OutByte3(48H, 0FFH, 4DH + long(n)); // dec qword[rbp+n] |
OutIntByte(n) |
END |
|CODE.opLADR_INCC, CODE.opLADR_DECC: |
reg1 := REG.GetVarReg(R, param1); |
IF isLong(param2) THEN |
reg2 := REG.GetAnyReg(R); |
movrc(reg2, param2); |
IF reg1 # -1 THEN |
IF cmd.opcode = CODE.opLADR_DECC THEN |
sub(reg1, reg2) |
ELSE |
add(reg1, reg2) |
END |
ELSE |
n := param1 * 8; |
Rex(0, reg2); |
OutByte2(01H + 28H * ORD(cmd.opcode = CODE.opLADR_DECC), 45H + long(n) + (reg2 MOD 8) * 8); |
OutIntByte(n) // add/sub qword[rbp+n],reg2 |
END; |
drop |
ELSE |
IF reg1 # -1 THEN |
IF cmd.opcode = CODE.opLADR_DECC THEN |
subrc(reg1, param2) |
ELSE |
addrc(reg1, param2) |
END |
ELSE |
n := param1 * 8; |
OutByte3(48H, 81H + short(param2), 45H + long(n) + 28H * ORD(cmd.opcode = CODE.opLADR_DECC)); |
OutIntByte(n); |
OutIntByte(param2) // add/sub qword[rbp+n],param2 |
END |
END |
|CODE.opLADR_INC1B, CODE.opLADR_DEC1B: |
reg1 := REG.GetVarReg(R, param2); |
IF reg1 # -1 THEN |
IF cmd.opcode = CODE.opLADR_DEC1B THEN |
decr(reg1) |
ELSE |
incr(reg1) |
END; |
andrc(reg1, 255) |
ELSE |
n := param2 * 8; |
OutByte2(0FEH, 45H + long(n) + 8 * ORD(cmd.opcode = CODE.opLADR_DEC1B)); |
OutIntByte(n) // inc/dec byte[rbp+n] |
END |
|CODE.opLADR_INCCB, CODE.opLADR_DECCB: |
reg1 := REG.GetVarReg(R, param1); |
param2 := param2 MOD 256; |
IF reg1 # -1 THEN |
IF cmd.opcode = CODE.opLADR_DECCB THEN |
subrc(reg1, param2) |
ELSE |
addrc(reg1, param2) |
END; |
andrc(reg1, 255) |
ELSE |
n := param1 * 8; |
OutByte2(80H, 45H + long(n) + 28H * ORD(cmd.opcode = CODE.opLADR_DECCB)); |
OutIntByte(n); |
OutByte(param2) // add/sub byte[rbp+n],param2 |
END |
|CODE.opLADR_INC, CODE.opLADR_DEC: |
UnOp(reg1); |
reg2 := REG.GetVarReg(R, param2); |
IF reg2 # -1 THEN |
IF cmd.opcode = CODE.opLADR_DEC THEN |
sub(reg2, reg1) |
ELSE |
add(reg2, reg1) |
END |
ELSE |
n := param2 * 8; |
Rex(0, reg1); |
OutByte2(01H + 28H * ORD(cmd.opcode = CODE.opLADR_DEC), 45H + long(n) + (reg1 MOD 8) * 8); |
OutIntByte(n) // add/sub qword[rbp+n],reg1 |
END; |
drop |
|CODE.opLADR_INCB, CODE.opLADR_DECB: |
UnOp(reg1); |
reg2 := REG.GetVarReg(R, param2); |
IF reg2 # -1 THEN |
IF cmd.opcode = CODE.opLADR_DECB THEN |
sub(reg2, reg1) |
ELSE |
add(reg2, reg1) |
END; |
andrc(reg2, 255) |
ELSE |
n := param2 * 8; |
IF reg1 >= 8 THEN |
OutByte(44H) |
END; |
OutByte2(28H * ORD(cmd.opcode = CODE.opLADR_DECB), 45H + long(n) + 8 * (reg1 MOD 8)); |
OutIntByte(n) // add/sub byte[rbp+n], reg1_8 |
END; |
drop |
|CODE.opLADR_INCL, CODE.opLADR_EXCL: |
UnOp(reg1); |
cmprc(reg1, 64); |
reg2 := REG.GetVarReg(R, param2); |
IF reg2 # -1 THEN |
OutByte2(73H, 4); // jnb L |
oprr2(0FH, 0ABH + 8 * ORD(cmd.opcode = CODE.opLADR_EXCL), reg2, reg1) // bts/btr reg2, reg1 |
ELSE |
n := param2 * 8; |
OutByte2(73H, 5 + 3 * ORD(~isByte(n))); // jnb L |
Rex(0, reg1); |
OutByte3(0FH, 0ABH + 8 * ORD(cmd.opcode = CODE.opLADR_EXCL), 45H + long(n) + 8 * (reg1 MOD 8)); |
OutIntByte(n) // bts/btr qword[rbp+n], reg1 |
END; |
// L: |
drop |
|CODE.opLADR_INCLC, CODE.opLADR_EXCLC: |
reg1 := REG.GetVarReg(R, param1); |
IF reg1 # -1 THEN |
Rex(reg1, 0); |
OutByte3(0FH, 0BAH, 0E8H); // bts/btr reg1, param2 |
OutByte2(reg1 MOD 8 + 8 * ORD(cmd.opcode = CODE.opLADR_EXCLC), param2) |
ELSE |
n := param1 * 8; |
OutByte3(48H, 0FH, 0BAH); // bts/btr qword[rbp+n], param2 |
OutByte(6DH + long(n) + 8 * ORD(cmd.opcode = CODE.opLADR_EXCLC)); |
OutIntByte(n); |
OutByte(param2) |
END |
|CODE.opLOOP, CODE.opENDLOOP: |
END; |
cmd := cmd.next(COMMAND) |
END; |
ASSERT(R.pushed = 0); |
ASSERT(R.top = -1); |
ASSERT(xmm = -1) |
END translate; |
PROCEDURE prolog (code: CODE.CODES; modname: ARRAY OF CHAR; target, stack_size: INTEGER); |
VAR |
ModName_Offs, entry: INTEGER; |
BEGIN |
ModName_Offs := CHL.Length(code.types) * 8 + CHL.Length(code.data); |
Numbers_Offs := ModName_Offs + LENGTH(modname) + 1; |
ASSERT(MACHINE.Align(Numbers_Offs, 16)); |
entry := NewLabel(); |
X86.SetLabel(entry); |
IF target = mConst.Target_iDLL64 THEN |
dllret := NewLabel(); |
push(r8); |
push(rdx); |
push(rcx); |
CallRTL(CODE._dllentry); |
test(rax); |
jcc(je, dllret) |
END; |
push(rsp); |
lea(rax, entry, sCODE); |
push(rax); |
pushDA(0); //TYPES |
pushc(CHL.Length(code.types)); |
pushDA(ModName_Offs); //MODNAME |
CallRTL(CODE._init) |
END prolog; |
PROCEDURE epilog (code: CODE.CODES; modname: ARRAY OF CHAR; target: INTEGER); |
VAR |
i, n: INTEGER; |
number: Number; |
exp: CODE.EXPORT_PROC; |
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(prog, lib.name, 0); |
proc := lib.procs.first(CODE.IMPORT_PROC); |
WHILE proc # NIL DO |
BIN.Import(prog, proc.name, proc.label); |
proc := proc.next(CODE.IMPORT_PROC) |
END; |
lib := lib.next(CODE.IMPORT_LIB) |
END |
END import; |
BEGIN |
IF target = mConst.Target_iDLL64 THEN |
X86.SetLabel(dllret); |
OutByte(0C3H) // ret |
ELSE |
pushc(0); |
CallRTL(CODE._exit) |
END; |
X86.fixup; |
i := 0; |
WHILE i < CHL.Length(code.types) DO |
BIN.PutData64LE(prog, CHL.GetInt(code.types, i)); |
INC(i) |
END; |
i := 0; |
WHILE i < CHL.Length(code.data) DO |
BIN.PutData(prog, CHL.GetByte(code.data, i)); |
INC(i) |
END; |
BIN.PutDataStr(prog, modname); |
BIN.PutData(prog, 0); |
n := CHL.Length(prog.data); |
ASSERT(MACHINE.Align(n, 16)); |
i := n - CHL.Length(prog.data); |
WHILE i > 0 DO |
BIN.PutData(prog, 0); |
DEC(i) |
END; |
number := Numbers.first(Number); |
FOR i := 0 TO Numbers_Count - 1 DO |
BIN.PutData64LE(prog, number.value); |
number := number.next(Number) |
END; |
exp := code.export.first(CODE.EXPORT_PROC); |
WHILE exp # NIL DO |
BIN.Export(prog, exp.name, exp.label); |
exp := exp.next(CODE.EXPORT_PROC) |
END; |
import(code.import) |
END epilog; |
PROCEDURE rload (reg, offs, size: INTEGER); |
BEGIN |
offs := offs * 8; |
CASE size OF |
|1: movzx(reg, rbp, offs, FALSE) |
|2: movzx(reg, rbp, offs, TRUE) |
|4: xor(reg, reg); movrm32(reg, rbp, offs) |
|8: movrm(reg, rbp, offs) |
END |
END rload; |
PROCEDURE rsave (reg, offs, size: INTEGER); |
BEGIN |
offs := offs * 8; |
CASE size OF |
|1: movmr8(rbp, offs, reg) |
|2: movmr16(rbp, offs, reg) |
|4: movmr32(rbp, offs, reg) |
|8: movmr(rbp, offs, reg) |
END |
END rsave; |
PROCEDURE CodeGen* (code: CODE.CODES; outname: ARRAY OF CHAR; target, stack, base: INTEGER); |
VAR |
path, modname, ext: PATHS.PATH; |
n: INTEGER; |
BEGIN |
Win64RegPar[0] := rcx; |
Win64RegPar[1] := rdx; |
Win64RegPar[2] := r8; |
Win64RegPar[3] := r9; |
SystemVRegPar[0] := rdi; |
SystemVRegPar[1] := rsi; |
SystemVRegPar[2] := rdx; |
SystemVRegPar[3] := rcx; |
SystemVRegPar[4] := r8; |
SystemVRegPar[5] := r9; |
PATHS.split(outname, path, modname, ext); |
S.append(modname, ext); |
R := REG.Create(push, pop, mov, xchg, rload, rsave, {rax, r10, r11}, {rcx, rdx, r8, r9}); |
n := code.dmin - CHL.Length(code.data); |
IF n > 0 THEN |
INC(code.bss, n) |
END; |
code.bss := MAX(code.bss, 8); |
Numbers := LISTS.create(NIL); |
Numbers_Count := 0; |
NewNumber(ROR(1, 1)); (* 8000000000000000H *) |
NewNumber(0); |
NewNumber(ROR(-2, 1)); (* 7FFFFFFFFFFFFFFFH *) |
NewNumber(-1); |
NewNumber(ROR(7FFH, 12)); (* +Infinity *) |
NewNumber(ORD(-BITS(LSR(ASR(ROR(1, 1), 10), 1)))); (* {0..51, 63} *) |
NewNumber(LSR(ASR(ROR(1, 1), 9), 2)); (* {52..61} *) |
prog := BIN.create(code.lcount); |
BIN.SetParams(prog, code.bss, stack, WCHR(1), WCHR(0)); |
X86.SetProgram(prog); |
prolog(code, modname, target, stack); |
translate(code.commands, CHL.Length(code.types) * 8); |
epilog(code, modname, target); |
BIN.fixup(prog); |
IF target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN |
PE32.write(prog, outname, base, target = mConst.Target_iConsole64, target = mConst.Target_iDLL64, TRUE) |
ELSIF target = mConst.Target_iELF64 THEN |
ELF.write(prog, outname, TRUE) |
END |
END CodeGen; |
END AMD64. |
/programs/develop/oberon07/Source/ARITH.ob07 |
---|
0,0 → 1,861 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE ARITH; |
IMPORT AVLTREES, STRINGS, MACHINE, UTILS; |
CONST |
tINTEGER* = 1; tREAL* = 2; tSET* = 3; |
tBOOLEAN* = 4; tCHAR* = 5; tWCHAR* = 6; |
tSTRING* = 7; |
TYPE |
RELATION* = ARRAY 3 OF CHAR; |
VALUE* = RECORD |
typ*: INTEGER; |
int: INTEGER; |
float: REAL; |
set: SET; |
bool: BOOLEAN; |
string*: AVLTREES.DATA |
END; |
VAR |
digit: ARRAY 256 OF INTEGER; |
PROCEDURE Int* (v: VALUE): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF v.typ = tINTEGER THEN |
res := v.int |
ELSIF v.typ = tCHAR THEN |
res := v.int |
ELSIF v.typ = tWCHAR THEN |
res := v.int |
ELSIF v.typ = tSET THEN |
res := ORD(v.set); |
IF MACHINE._64to32 THEN |
res := MACHINE.Int32To64(res) |
END |
ELSIF v.typ = tBOOLEAN THEN |
res := ORD(v.bool) |
END |
RETURN res |
END Int; |
PROCEDURE getBool* (v: VALUE): BOOLEAN; |
BEGIN |
ASSERT(v.typ = tBOOLEAN); |
RETURN v.bool |
END getBool; |
PROCEDURE Float* (v: VALUE): REAL; |
BEGIN |
ASSERT(v.typ = tREAL); |
RETURN v.float |
END Float; |
PROCEDURE check* (v: VALUE): BOOLEAN; |
VAR |
error: BOOLEAN; |
BEGIN |
error := FALSE; |
IF (v.typ = tINTEGER) & ((v.int < MACHINE.target.minInt) OR (v.int > MACHINE.target.maxInt)) THEN |
error := TRUE |
ELSIF (v.typ = tCHAR) & ((v.int < 0) OR (v.int > 255)) THEN |
error := TRUE |
ELSIF (v.typ = tWCHAR) & ((v.int < 0) OR (v.int > 65535)) THEN |
error := TRUE |
ELSIF (v.typ = tREAL) & ((v.float < -MACHINE.target.maxReal) OR (v.float > MACHINE.target.maxReal)) THEN |
error := TRUE |
END |
RETURN ~error |
END check; |
PROCEDURE isZero* (v: VALUE): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
ASSERT(v.typ IN {tINTEGER, tREAL}); |
IF v.typ = tINTEGER THEN |
res := v.int = 0 |
ELSIF v.typ = tREAL THEN |
res := v.float = 0.0 |
END |
RETURN res |
END isZero; |
PROCEDURE iconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER); |
VAR |
value: INTEGER; |
i: INTEGER; |
d: INTEGER; |
BEGIN |
error := 0; |
value := 0; |
i := 0; |
WHILE STRINGS.digit(s[i]) & (error = 0) DO |
d := digit[ORD(s[i])]; |
IF value <= (UTILS.maxint - d) DIV 10 THEN |
value := value * 10 + d; |
INC(i) |
ELSE |
error := 1 |
END |
END; |
IF error = 0 THEN |
v.int := value; |
v.typ := tINTEGER; |
IF ~check(v) THEN |
error := 1 |
END |
END |
END iconv; |
PROCEDURE hconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER); |
VAR |
value: INTEGER; |
i: INTEGER; |
n: INTEGER; |
d: INTEGER; |
BEGIN |
ASSERT(STRINGS.digit(s[0])); |
error := 0; |
value := 0; |
n := -1; |
i := 0; |
WHILE (s[i] # "H") & (s[i] # "X") & (error = 0) DO |
d := digit[ORD(s[i])]; |
IF (n = -1) & (d # 0) THEN |
n := i |
END; |
IF (n # -1) & (i - n + 1 > MACHINE.target.maxHex) THEN |
error := 2 |
ELSE |
value := value * 16 + d; |
INC(i) |
END |
END; |
IF MACHINE._64to32 THEN |
value := MACHINE.Int32To64(value); |
END; |
IF (s[i] = "X") & (n # -1) & (i - n > 4) THEN |
error := 3 |
END; |
IF error = 0 THEN |
v.int := value; |
IF s[i] = "X" THEN |
v.typ := tCHAR; |
IF ~check(v) THEN |
v.typ := tWCHAR; |
IF ~check(v) THEN |
error := 3 |
END |
END |
ELSE |
v.typ := tINTEGER; |
IF ~check(v) THEN |
error := 2 |
END |
END |
END |
END hconv; |
PROCEDURE opFloat2 (VAR a: REAL; b: REAL; op: CHAR): BOOLEAN; |
VAR |
max: REAL; |
res: BOOLEAN; |
BEGIN |
max := UTILS.maxreal; |
CASE op OF |
|"+": |
IF (a < 0.0) & (b < 0.0) THEN |
res := a > -max - b |
ELSIF (a > 0.0) & (b > 0.0) THEN |
res := a < max - b |
ELSE |
res := TRUE |
END; |
IF res THEN |
a := a + b |
END |
|"-": |
IF (a < 0.0) & (b > 0.0) THEN |
res := a > b - max |
ELSIF (a > 0.0) & (b < 0.0) THEN |
res := a < b + max |
ELSE |
res := TRUE |
END; |
IF res THEN |
a := a - b |
END |
|"*": |
IF (ABS(a) > 1.0) & (ABS(b) > 1.0) THEN |
res := ABS(a) < max / ABS(b) |
ELSE |
res := TRUE |
END; |
IF res THEN |
a := a * b |
END |
|"/": |
IF ABS(b) < 1.0 THEN |
res := ABS(a) < max * ABS(b) |
ELSE |
res := TRUE |
END; |
IF res THEN |
a := a / b |
END |
END |
RETURN res |
END opFloat2; |
PROCEDURE fconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER); |
VAR |
value: REAL; |
exp10: REAL; |
i, n, d: INTEGER; |
minus: BOOLEAN; |
BEGIN |
error := 0; |
value := 0.0; |
exp10 := 10.0; |
minus := FALSE; |
n := 0; |
i := 0; |
WHILE (error = 0) & STRINGS.digit(s[i]) DO |
IF opFloat2(value, 10.0, "*") & opFloat2(value, FLT(digit[ORD(s[i])]), "+") THEN |
INC(i) |
ELSE |
error := 4 |
END |
END; |
INC(i); |
WHILE (error = 0) & STRINGS.digit(s[i]) DO |
IF opFloat2(value, FLT(digit[ORD(s[i])]) / exp10, "+") & opFloat2(exp10, 10.0, "*") THEN |
INC(i) |
ELSE |
error := 4 |
END |
END; |
IF s[i] = "E" THEN |
INC(i) |
END; |
IF (s[i] = "-") OR (s[i] = "+") THEN |
minus := s[i] = "-"; |
INC(i) |
END; |
WHILE (error = 0) & STRINGS.digit(s[i]) DO |
d := digit[ORD(s[i])]; |
IF n <= (UTILS.maxint - d) DIV 10 THEN |
n := n * 10 + d; |
INC(i) |
ELSE |
error := 5 |
END |
END; |
exp10 := 1.0; |
WHILE (error = 0) & (n > 0) DO |
IF opFloat2(exp10, 10.0, "*") THEN |
DEC(n) |
ELSE |
error := 4 |
END |
END; |
IF error = 0 THEN |
IF minus THEN |
IF ~opFloat2(value, exp10, "/") THEN |
error := 4 |
END |
ELSE |
IF ~opFloat2(value, exp10, "*") THEN |
error := 4 |
END |
END |
END; |
IF error = 0 THEN |
v.float := value; |
v.typ := tREAL; |
IF ~check(v) THEN |
error := 4 |
END |
END |
END fconv; |
PROCEDURE setChar* (VAR v: VALUE; ord: INTEGER); |
BEGIN |
v.typ := tCHAR; |
v.int := ord |
END setChar; |
PROCEDURE setWChar* (VAR v: VALUE; ord: INTEGER); |
BEGIN |
v.typ := tWCHAR; |
v.int := ord |
END setWChar; |
PROCEDURE addInt (VAR a: INTEGER; b: INTEGER): BOOLEAN; |
VAR |
error: BOOLEAN; |
BEGIN |
IF (a > 0) & (b > 0) THEN |
error := a > UTILS.maxint - b |
ELSIF (a < 0) & (b < 0) THEN |
error := a < UTILS.minint - b |
ELSE |
error := FALSE |
END; |
IF ~error THEN |
a := a + b |
ELSE |
a := 0 |
END |
RETURN ~error |
END addInt; |
PROCEDURE subInt (VAR a: INTEGER; b: INTEGER): BOOLEAN; |
VAR |
error: BOOLEAN; |
BEGIN |
IF (a > 0) & (b < 0) THEN |
error := a > UTILS.maxint + b |
ELSIF (a < 0) & (b > 0) THEN |
error := a < UTILS.minint + b |
ELSIF (a = 0) & (b < 0) THEN |
error := b = UTILS.minint |
ELSE |
error := FALSE |
END; |
IF ~error THEN |
a := a - b |
ELSE |
a := 0 |
END |
RETURN ~error |
END subInt; |
PROCEDURE lg2 (x: INTEGER): INTEGER; |
VAR |
n: INTEGER; |
BEGIN |
ASSERT(x > 0); |
n := 0; |
WHILE ~ODD(x) DO |
x := x DIV 2; |
INC(n) |
END; |
IF x # 1 THEN |
n := 255 |
END |
RETURN n |
END lg2; |
PROCEDURE mulInt* (VAR a: INTEGER; b: INTEGER): BOOLEAN; |
VAR |
error: BOOLEAN; |
min, max: INTEGER; |
BEGIN |
min := UTILS.minint; |
max := UTILS.maxint; |
IF ((a > 1) & (b > 1)) OR ((a < 0) & (b < 0)) THEN |
error := (a = min) OR (b = min) OR (ABS(a) > max DIV ABS(b)) |
ELSIF ((a > 1) & (b < 0)) OR ((a < 0) & (b > 1)) THEN |
error := (a = min) OR (b = min); |
IF ~error THEN |
IF lg2(ABS(a)) + lg2(ABS(b)) >= UTILS.bit_depth THEN |
error := ABS(a) > max DIV ABS(b) |
END |
END |
ELSE |
error := FALSE |
END; |
IF ~error THEN |
a := a * b |
ELSE |
a := 0 |
END |
RETURN ~error |
END mulInt; |
PROCEDURE _ASR (x, n: INTEGER): INTEGER; |
BEGIN |
IF MACHINE._64to32 THEN |
x := MACHINE.Int32To64(x) |
END |
RETURN ASR(x, n) |
END _ASR; |
PROCEDURE _LSR (x, n: INTEGER): INTEGER; |
BEGIN |
IF MACHINE._64to32 THEN |
x := MACHINE.Int64To32(x); |
x := LSR(x, n); |
x := MACHINE.Int32To64(x) |
ELSE |
x := LSR(x, n) |
END |
RETURN x |
END _LSR; |
PROCEDURE _LSL (x, n: INTEGER): INTEGER; |
BEGIN |
x := LSL(x, n); |
IF MACHINE._64to32 THEN |
x := MACHINE.Int32To64(x) |
END |
RETURN x |
END _LSL; |
PROCEDURE _ROR1_32 (x: INTEGER): INTEGER; |
BEGIN |
x := MACHINE.Int64To32(x); |
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 31))) |
RETURN MACHINE.Int32To64(x) |
END _ROR1_32; |
PROCEDURE _ROR (x, n: INTEGER): INTEGER; |
BEGIN |
IF MACHINE._64to32 THEN |
n := n MOD 32; |
WHILE n > 0 DO |
x := _ROR1_32(x); |
DEC(n) |
END |
ELSE |
x := ROR(x, n) |
END |
RETURN x |
END _ROR; |
PROCEDURE opInt* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN; |
VAR |
success: BOOLEAN; |
BEGIN |
success := TRUE; |
CASE op OF |
|"+": success := addInt(a.int, b.int) |
|"-": success := subInt(a.int, b.int) |
|"*": success := mulInt(a.int, b.int) |
|"/": success := FALSE |
|"D": IF (b.int # -1) OR (a.int # UTILS.minint) THEN a.int := a.int DIV b.int ELSE success := FALSE END |
|"M": a.int := a.int MOD b.int |
|"L": a.int := _LSL(a.int, b.int) |
|"A": a.int := _ASR(a.int, b.int) |
|"O": a.int := _ROR(a.int, b.int) |
|"R": a.int := _LSR(a.int, b.int) |
|"m": a.int := MIN(a.int, b.int) |
|"x": a.int := MAX(a.int, b.int) |
END; |
a.typ := tINTEGER |
RETURN success & check(a) |
END opInt; |
PROCEDURE charToStr* (c: VALUE; VAR s: ARRAY OF CHAR); |
BEGIN |
s[0] := CHR(c.int); |
s[1] := 0X |
END charToStr; |
PROCEDURE opSet* (VAR a: VALUE; b: VALUE; op: CHAR); |
BEGIN |
CASE op OF |
|"+": a.set := a.set + b.set |
|"-": a.set := a.set - b.set |
|"*": a.set := a.set * b.set |
|"/": a.set := a.set / b.set |
END; |
a.typ := tSET |
END opSet; |
PROCEDURE opFloat* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN; |
BEGIN |
a.typ := tREAL |
RETURN opFloat2(a.float, b.float, op) & check(a) |
END opFloat; |
PROCEDURE ord* (VAR v: VALUE); |
BEGIN |
CASE v.typ OF |
|tCHAR, tWCHAR: |
|tBOOLEAN: v.int := ORD(v.bool) |
|tSET: |
v.int := ORD(v.set); |
IF MACHINE._64to32 THEN |
v.int := MACHINE.Int32To64(v.int) |
END |
END; |
v.typ := tINTEGER |
END ord; |
PROCEDURE odd* (VAR v: VALUE); |
BEGIN |
v.typ := tBOOLEAN; |
v.bool := ODD(v.int) |
END odd; |
PROCEDURE bits* (VAR v: VALUE); |
BEGIN |
v.typ := tSET; |
v.set := BITS(v.int) |
END bits; |
PROCEDURE abs* (VAR v: VALUE): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := FALSE; |
CASE v.typ OF |
|tREAL: |
v.float := ABS(v.float); |
res := TRUE |
|tINTEGER: |
IF v.int # UTILS.minint THEN |
v.int := ABS(v.int); |
res := TRUE |
END |
END |
RETURN res |
END abs; |
PROCEDURE floor* (VAR v: VALUE): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
v.typ := tINTEGER; |
res := (FLT(UTILS.minint) <= v.float) & (v.float <= FLT(UTILS.maxint)); |
IF res THEN |
v.int := FLOOR(v.float) |
END |
RETURN res |
END floor; |
PROCEDURE flt* (VAR v: VALUE); |
BEGIN |
v.typ := tREAL; |
v.float := FLT(v.int) |
END flt; |
PROCEDURE neg* (VAR v: VALUE): BOOLEAN; |
VAR |
z: VALUE; |
res: BOOLEAN; |
BEGIN |
res := TRUE; |
z.typ := tINTEGER; |
z.int := 0; |
CASE v.typ OF |
|tREAL: v.float := -v.float |
|tSET: v.set := -v.set |
|tINTEGER: res := opInt(z, v, "-"); v := z |
|tBOOLEAN: v.bool := ~v.bool |
END |
RETURN res |
END neg; |
PROCEDURE setbool* (VAR v: VALUE; b: BOOLEAN); |
BEGIN |
v.bool := b; |
v.typ := tBOOLEAN |
END setbool; |
PROCEDURE opBoolean* (VAR a: VALUE; b: VALUE; op: CHAR); |
BEGIN |
CASE op OF |
|"&": a.bool := a.bool & b.bool |
|"|": a.bool := a.bool OR b.bool |
END; |
a.typ := tBOOLEAN |
END opBoolean; |
PROCEDURE range* (i: VALUE; a, b: INTEGER): BOOLEAN; |
RETURN (a <= i.int) & (i.int <= b) |
END range; |
PROCEDURE less (v, v2: VALUE; VAR error: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := FALSE; |
IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN |
CASE v.typ OF |
|tINTEGER, |
tWCHAR, |
tCHAR: res := v.int < v2.int |
|tREAL: res := v.float < v2.float |
|tBOOLEAN, |
tSET: error := 1 |
END |
ELSE |
error := 1 |
END |
RETURN res |
END less; |
PROCEDURE equal (v, v2: VALUE; VAR error: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := FALSE; |
IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN |
CASE v.typ OF |
|tINTEGER, |
tWCHAR, |
tCHAR: res := v.int = v2.int |
|tREAL: res := v.float = v2.float |
|tBOOLEAN: res := v.bool = v2.bool |
|tSET: res := v.set = v2.set |
END |
ELSE |
error := 1 |
END |
RETURN res |
END equal; |
PROCEDURE relation* (VAR v: VALUE; v2: VALUE; operator: RELATION; VAR error: INTEGER); |
VAR |
res: BOOLEAN; |
BEGIN |
error := 0; |
res := FALSE; |
CASE operator[0] OF |
|"=": |
res := equal(v, v2, error) |
|"#": |
res := ~equal(v, v2, error) |
|"<": |
IF operator[1] = "=" THEN |
res := less(v, v2, error); |
IF error = 0 THEN |
res := equal(v, v2, error) OR res |
END |
ELSE |
res := less(v, v2, error) |
END |
|">": |
IF operator[1] = "=" THEN |
res := ~less(v, v2, error) |
ELSE |
res := less(v, v2, error); |
IF error = 0 THEN |
res := equal(v, v2, error) OR res |
END; |
res := ~res |
END |
|"I": |
IF (v.typ = tINTEGER) & (v2.typ = tSET) THEN |
IF range(v, 0, MACHINE.target.maxSet) THEN |
res := v.int IN v2.set |
ELSE |
error := 2 |
END |
ELSE |
error := 1 |
END |
END; |
IF error = 0 THEN |
v.bool := res; |
v.typ := tBOOLEAN |
END |
END relation; |
PROCEDURE emptySet* (VAR v: VALUE); |
BEGIN |
v.typ := tSET; |
v.set := {} |
END emptySet; |
PROCEDURE constrSet* (VAR v: VALUE; a, b: VALUE); |
BEGIN |
v.typ := tSET; |
v.set := {a.int .. b.int} |
END constrSet; |
PROCEDURE getInt* (v: VALUE): INTEGER; |
BEGIN |
ASSERT(check(v)) |
RETURN v.int |
END getInt; |
PROCEDURE setInt* (VAR v: VALUE; i: INTEGER): BOOLEAN; |
BEGIN |
v.int := i; |
v.typ := tINTEGER |
RETURN check(v) |
END setInt; |
PROCEDURE init; |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO LEN(digit) - 1 DO |
digit[i] := -1 |
END; |
FOR i := ORD("0") TO ORD("9") DO |
digit[i] := i - ORD("0") |
END; |
FOR i := ORD("A") TO ORD("F") DO |
digit[i] := i - ORD("A") + 10 |
END |
END init; |
BEGIN |
init |
END ARITH. |
/programs/develop/oberon07/Source/AVLTREES.ob07 |
---|
0,0 → 1,197 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE AVLTREES; |
IMPORT C := COLLECTIONS; |
TYPE |
DATA* = POINTER TO RECORD (C.ITEM) END; |
NODE* = POINTER TO RECORD (C.ITEM) |
data*: DATA; |
height: INTEGER; |
left*, right*: NODE |
END; |
CMP* = PROCEDURE (a, b: DATA): INTEGER; |
DESTRUCTOR* = PROCEDURE (VAR data: DATA); |
VAR |
nodes: C.COLLECTION; |
PROCEDURE NewNode (data: DATA): NODE; |
VAR |
node: NODE; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(nodes); |
IF citem = NIL THEN |
NEW(node) |
ELSE |
node := citem(NODE) |
END; |
node.data := data; |
node.left := NIL; |
node.right := NIL; |
node.height := 1 |
RETURN node |
END NewNode; |
PROCEDURE height (p: NODE): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF p = NIL THEN |
res := 0 |
ELSE |
res := p.height |
END |
RETURN res |
END height; |
PROCEDURE bfactor (p: NODE): INTEGER; |
RETURN height(p.right) - height(p.left) |
END bfactor; |
PROCEDURE fixheight (p: NODE); |
BEGIN |
p.height := MAX(height(p.left), height(p.right)) + 1 |
END fixheight; |
PROCEDURE rotateright (p: NODE): NODE; |
VAR |
q: NODE; |
BEGIN |
q := p.left; |
p.left := q.right; |
q.right := p; |
fixheight(p); |
fixheight(q) |
RETURN q |
END rotateright; |
PROCEDURE rotateleft (q: NODE): NODE; |
VAR |
p: NODE; |
BEGIN |
p := q.right; |
q.right := p.left; |
p.left := q; |
fixheight(q); |
fixheight(p) |
RETURN p |
END rotateleft; |
PROCEDURE balance (p: NODE): NODE; |
VAR |
res: NODE; |
BEGIN |
fixheight(p); |
IF bfactor(p) = 2 THEN |
IF bfactor(p.right) < 0 THEN |
p.right := rotateright(p.right) |
END; |
res := rotateleft(p) |
ELSIF bfactor(p) = -2 THEN |
IF bfactor(p.left) > 0 THEN |
p.left := rotateleft(p.left) |
END; |
res := rotateright(p) |
ELSE |
res := p |
END |
RETURN res |
END balance; |
PROCEDURE insert* (p: NODE; data: DATA; cmp: CMP; VAR newnode: BOOLEAN; VAR node: NODE): NODE; |
VAR |
res: NODE; |
rescmp: INTEGER; |
BEGIN |
IF p = NIL THEN |
res := NewNode(data); |
node := res; |
newnode := TRUE |
ELSE |
rescmp := cmp(data, p.data); |
IF rescmp < 0 THEN |
p.left := insert(p.left, data, cmp, newnode, node); |
res := balance(p) |
ELSIF rescmp > 0 THEN |
p.right := insert(p.right, data, cmp, newnode, node); |
res := balance(p) |
ELSE |
res := p; |
node := res; |
newnode := FALSE |
END |
END |
RETURN res |
END insert; |
PROCEDURE destroy* (VAR node: NODE; destructor: DESTRUCTOR); |
VAR |
left, right: NODE; |
BEGIN |
IF node # NIL THEN |
left := node.left; |
right := node.right; |
IF destructor # NIL THEN |
destructor(node.data) |
END; |
C.push(nodes, node); |
node := NIL; |
destroy(left, destructor); |
destroy(right, destructor) |
END |
END destroy; |
BEGIN |
nodes := C.create() |
END AVLTREES. |
/programs/develop/oberon07/Source/BIN.ob07 |
---|
0,0 → 1,396 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE BIN; |
IMPORT LISTS, MACHINE, CHL := CHUNKLISTS, ARITH, UTILS; |
CONST |
RCODE* = 1; |
RDATA* = 2; |
RBSS* = 3; |
RIMP* = 4; |
PICCODE* = 5; |
PICDATA* = 6; |
PICBSS* = 7; |
PICIMP* = 8; |
IMPTAB* = 9; |
TYPE |
RELOC* = POINTER TO RECORD (LISTS.ITEM) |
opcode*: INTEGER; |
offset*: INTEGER |
END; |
IMPRT* = POINTER TO RECORD (LISTS.ITEM) |
nameoffs*: INTEGER; |
label*: INTEGER; |
OriginalFirstThunk*, |
FirstThunk*: INTEGER |
END; |
EXPRT* = POINTER TO RECORD (LISTS.ITEM) |
nameoffs*: INTEGER; |
label*: INTEGER |
END; |
PROGRAM* = POINTER TO RECORD |
code*: CHL.BYTELIST; |
data*: CHL.BYTELIST; |
labels: CHL.INTLIST; |
bss*: INTEGER; |
stack*: INTEGER; |
vmajor*, |
vminor*: WCHAR; |
modname*: INTEGER; |
import*: CHL.BYTELIST; |
export*: CHL.BYTELIST; |
rel_list*: LISTS.LIST; |
imp_list*: LISTS.LIST; |
exp_list*: LISTS.LIST |
END; |
PROCEDURE create* (NumberOfLabels: INTEGER): PROGRAM; |
VAR |
program: PROGRAM; |
i: INTEGER; |
BEGIN |
NEW(program); |
program.bss := 0; |
program.labels := CHL.CreateIntList(); |
FOR i := 0 TO NumberOfLabels - 1 DO |
CHL.PushInt(program.labels, 0) |
END; |
program.rel_list := LISTS.create(NIL); |
program.imp_list := LISTS.create(NIL); |
program.exp_list := LISTS.create(NIL); |
program.data := CHL.CreateByteList(); |
program.code := CHL.CreateByteList(); |
program.import := CHL.CreateByteList(); |
program.export := CHL.CreateByteList() |
RETURN program |
END create; |
PROCEDURE SetParams* (program: PROGRAM; bss, stack: INTEGER; vmajor, vminor: WCHAR); |
BEGIN |
program.bss := bss; |
program.stack := stack; |
program.vmajor := vmajor; |
program.vminor := vminor |
END SetParams; |
PROCEDURE PutReloc* (program: PROGRAM; opcode: INTEGER); |
VAR |
cmd: RELOC; |
BEGIN |
NEW(cmd); |
cmd.opcode := opcode; |
cmd.offset := CHL.Length(program.code); |
LISTS.push(program.rel_list, cmd) |
END PutReloc; |
PROCEDURE PutData* (program: PROGRAM; b: BYTE); |
BEGIN |
CHL.PushByte(program.data, b) |
END PutData; |
PROCEDURE get32le* (array: CHL.BYTELIST; idx: INTEGER): INTEGER; |
VAR |
i: INTEGER; |
x: INTEGER; |
BEGIN |
x := 0; |
FOR i := 3 TO 0 BY -1 DO |
x := LSL(x, 8) + CHL.GetByte(array, idx + i) |
END; |
IF UTILS.bit_depth = 64 THEN |
x := MACHINE.Int32To64(x) |
END |
RETURN x |
END get32le; |
PROCEDURE put32le* (array: CHL.BYTELIST; idx: INTEGER; x: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 3 DO |
CHL.SetByte(array, idx + i, MACHINE.Byte(x, i)) |
END |
END put32le; |
PROCEDURE PutData32LE* (program: PROGRAM; x: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 3 DO |
CHL.PushByte(program.data, MACHINE.Byte(x, i)) |
END |
END PutData32LE; |
PROCEDURE PutData64LE* (program: PROGRAM; x: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 7 DO |
CHL.PushByte(program.data, MACHINE.Byte(x, i)) |
END |
END PutData64LE; |
PROCEDURE PutDataStr* (program: PROGRAM; s: ARRAY OF CHAR); |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE s[i] # 0X DO |
PutData(program, ORD(s[i])); |
INC(i) |
END |
END PutDataStr; |
PROCEDURE PutCode* (program: PROGRAM; b: BYTE); |
BEGIN |
CHL.PushByte(program.code, b) |
END PutCode; |
PROCEDURE PutCode32LE* (program: PROGRAM; x: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 3 DO |
CHL.PushByte(program.code, MACHINE.Byte(x, i)) |
END |
END PutCode32LE; |
PROCEDURE SetLabel* (program: PROGRAM; label, offset: INTEGER); |
BEGIN |
CHL.SetInt(program.labels, label, offset) |
END SetLabel; |
PROCEDURE Import* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER); |
VAR |
imp: IMPRT; |
i: INTEGER; |
BEGIN |
CHL.PushByte(program.import, 0); |
CHL.PushByte(program.import, 0); |
IF ODD(CHL.Length(program.import)) THEN |
CHL.PushByte(program.import, 0) |
END; |
NEW(imp); |
imp.nameoffs := CHL.Length(program.import); |
imp.label := label; |
LISTS.push(program.imp_list, imp); |
i := 0; |
WHILE name[i] # 0X DO |
CHL.PushByte(program.import, ORD(name[i])); |
INC(i) |
END; |
CHL.PushByte(program.import, 0) |
END Import; |
PROCEDURE less (bytes: CHL.BYTELIST; a, b: EXPRT): BOOLEAN; |
VAR |
i, j: INTEGER; |
BEGIN |
i := a.nameoffs; |
j := b.nameoffs; |
WHILE (CHL.GetByte(bytes, i) # 0) & (CHL.GetByte(bytes, j) # 0) & |
(CHL.GetByte(bytes, i) = CHL.GetByte(bytes, j)) DO |
INC(i); |
INC(j) |
END |
RETURN CHL.GetByte(bytes, i) < CHL.GetByte(bytes, j) |
END less; |
PROCEDURE Export* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER); |
VAR |
exp, cur: EXPRT; |
i: INTEGER; |
BEGIN |
NEW(exp); |
exp.nameoffs := CHL.Length(program.export); |
exp.label := CHL.GetInt(program.labels, label); |
i := 0; |
WHILE name[i] # 0X DO |
CHL.PushByte(program.export, ORD(name[i])); |
INC(i) |
END; |
CHL.PushByte(program.export, 0); |
cur := program.exp_list.first(EXPRT); |
WHILE (cur # NIL) & less(program.export, cur, exp) DO |
cur := cur.next(EXPRT) |
END; |
IF cur # NIL THEN |
IF cur.prev # NIL THEN |
LISTS.insert(program.exp_list, cur.prev, exp) |
ELSE |
LISTS.insertL(program.exp_list, cur, exp) |
END |
ELSE |
LISTS.push(program.exp_list, exp) |
END |
END Export; |
PROCEDURE GetIProc* (program: PROGRAM; n: INTEGER): IMPRT; |
VAR |
import: IMPRT; |
res: IMPRT; |
BEGIN |
import := program.imp_list.first(IMPRT); |
res := NIL; |
WHILE (import # NIL) & (n >= 0) DO |
IF import.label # 0 THEN |
res := import; |
DEC(n) |
END; |
import := import.next(IMPRT) |
END; |
ASSERT(n = -1) |
RETURN res |
END GetIProc; |
PROCEDURE GetLabel* (program: PROGRAM; label: INTEGER): INTEGER; |
RETURN CHL.GetInt(program.labels, label) |
END GetLabel; |
PROCEDURE NewLabel* (program: PROGRAM); |
BEGIN |
CHL.PushInt(program.labels, 0) |
END NewLabel; |
PROCEDURE fixup* (program: PROGRAM); |
VAR |
rel: RELOC; |
imp: IMPRT; |
nproc: INTEGER; |
L: INTEGER; |
BEGIN |
nproc := 0; |
imp := program.imp_list.first(IMPRT); |
WHILE imp # NIL DO |
IF imp.label # 0 THEN |
CHL.SetInt(program.labels, imp.label, nproc); |
INC(nproc) |
END; |
imp := imp.next(IMPRT) |
END; |
rel := program.rel_list.first(RELOC); |
WHILE rel # NIL DO |
IF rel.opcode IN {RIMP, PICIMP} THEN |
L := get32le(program.code, rel.offset); |
put32le(program.code, rel.offset, GetLabel(program, L)) |
END; |
rel := rel.next(RELOC) |
END |
END fixup; |
PROCEDURE InitArray* (VAR array: ARRAY OF BYTE; VAR idx: INTEGER; hex: ARRAY OF CHAR); |
VAR |
i, k: INTEGER; |
PROCEDURE hexdgt (dgt: CHAR): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF dgt < "A" THEN |
res := ORD(dgt) - ORD("0") |
ELSE |
res := ORD(dgt) - ORD("A") + 10 |
END |
RETURN res |
END hexdgt; |
BEGIN |
k := LENGTH(hex); |
ASSERT(~ODD(k)); |
k := k DIV 2; |
FOR i := 0 TO k - 1 DO |
array[i + idx] := hexdgt(hex[2 * i]) * 16 + hexdgt(hex[2 * i + 1]) |
END; |
idx := idx + k |
END InitArray; |
END BIN. |
/programs/develop/oberon07/Source/CHUNKLISTS.ob07 |
---|
0,0 → 1,251 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE CHUNKLISTS; |
IMPORT LISTS, WR := WRITER; |
CONST |
LENOFBYTECHUNK = 64000; |
LENOFINTCHUNK = 16000; |
TYPE |
ANYLIST = POINTER TO RECORD (LISTS.LIST) |
length: INTEGER |
END; |
BYTELIST* = POINTER TO RECORD (ANYLIST) END; |
BYTECHUNK = POINTER TO RECORD (LISTS.ITEM) |
data: ARRAY LENOFBYTECHUNK OF BYTE; |
count: INTEGER |
END; |
INTLIST* = POINTER TO RECORD (ANYLIST) END; |
INTCHUNK = POINTER TO RECORD (LISTS.ITEM) |
data: ARRAY LENOFINTCHUNK OF INTEGER; |
count: INTEGER |
END; |
PROCEDURE SetByte* (list: BYTELIST; idx: INTEGER; byte: BYTE); |
VAR |
ChunkNum: INTEGER; |
chunk: BYTECHUNK; |
BEGIN |
ASSERT(idx >= 0); |
ASSERT(list # NIL); |
ChunkNum := idx DIV LENOFBYTECHUNK; |
idx := idx MOD LENOFBYTECHUNK; |
chunk := list.first(BYTECHUNK); |
WHILE (chunk # NIL) & (ChunkNum > 0) DO |
chunk := chunk.next(BYTECHUNK); |
DEC(ChunkNum) |
END; |
ASSERT(chunk # NIL); |
ASSERT(idx < chunk.count); |
chunk.data[idx] := byte |
END SetByte; |
PROCEDURE GetByte* (list: BYTELIST; idx: INTEGER): BYTE; |
VAR |
ChunkNum: INTEGER; |
chunk: BYTECHUNK; |
BEGIN |
ASSERT(idx >= 0); |
ASSERT(list # NIL); |
ChunkNum := idx DIV LENOFBYTECHUNK; |
idx := idx MOD LENOFBYTECHUNK; |
chunk := list.first(BYTECHUNK); |
WHILE (chunk # NIL) & (ChunkNum > 0) DO |
chunk := chunk.next(BYTECHUNK); |
DEC(ChunkNum) |
END; |
ASSERT(chunk # NIL); |
ASSERT(idx < chunk.count) |
RETURN chunk.data[idx] |
END GetByte; |
PROCEDURE PushByte* (list: BYTELIST; byte: BYTE); |
VAR |
chunk: BYTECHUNK; |
BEGIN |
ASSERT(list # NIL); |
chunk := list.last(BYTECHUNK); |
IF chunk.count = LENOFBYTECHUNK THEN |
NEW(chunk); |
chunk.count := 0; |
LISTS.push(list, chunk) |
END; |
chunk.data[chunk.count] := byte; |
INC(chunk.count); |
INC(list.length) |
END PushByte; |
PROCEDURE WriteToFile* (file: WR.FILE; list: BYTELIST); |
VAR |
chunk: BYTECHUNK; |
BEGIN |
chunk := list.first(BYTECHUNK); |
WHILE chunk # NIL DO |
WR.Write(file, chunk.data, chunk.count); |
chunk := chunk.next(BYTECHUNK) |
END |
END WriteToFile; |
PROCEDURE CreateByteList* (): BYTELIST; |
VAR |
bytelist: BYTELIST; |
list: LISTS.LIST; |
chunk: BYTECHUNK; |
BEGIN |
NEW(bytelist); |
list := LISTS.create(bytelist); |
bytelist.length := 0; |
NEW(chunk); |
chunk.count := 0; |
LISTS.push(list, chunk) |
RETURN list(BYTELIST) |
END CreateByteList; |
PROCEDURE SetInt* (list: INTLIST; idx: INTEGER; int: INTEGER); |
VAR |
ChunkNum: INTEGER; |
chunk: INTCHUNK; |
BEGIN |
ASSERT(idx >= 0); |
ASSERT(list # NIL); |
ChunkNum := idx DIV LENOFINTCHUNK; |
idx := idx MOD LENOFINTCHUNK; |
chunk := list.first(INTCHUNK); |
WHILE (chunk # NIL) & (ChunkNum > 0) DO |
chunk := chunk.next(INTCHUNK); |
DEC(ChunkNum) |
END; |
ASSERT(chunk # NIL); |
ASSERT(idx < chunk.count); |
chunk.data[idx] := int |
END SetInt; |
PROCEDURE GetInt* (list: INTLIST; idx: INTEGER): INTEGER; |
VAR |
ChunkNum: INTEGER; |
chunk: INTCHUNK; |
BEGIN |
ASSERT(idx >= 0); |
ASSERT(list # NIL); |
ChunkNum := idx DIV LENOFINTCHUNK; |
idx := idx MOD LENOFINTCHUNK; |
chunk := list.first(INTCHUNK); |
WHILE (chunk # NIL) & (ChunkNum > 0) DO |
chunk := chunk.next(INTCHUNK); |
DEC(ChunkNum) |
END; |
ASSERT(chunk # NIL); |
ASSERT(idx < chunk.count) |
RETURN chunk.data[idx] |
END GetInt; |
PROCEDURE PushInt* (list: INTLIST; int: INTEGER); |
VAR |
chunk: INTCHUNK; |
BEGIN |
ASSERT(list # NIL); |
chunk := list.last(INTCHUNK); |
IF chunk.count = LENOFINTCHUNK THEN |
NEW(chunk); |
chunk.count := 0; |
LISTS.push(list, chunk) |
END; |
chunk.data[chunk.count] := int; |
INC(chunk.count); |
INC(list.length) |
END PushInt; |
PROCEDURE CreateIntList* (): INTLIST; |
VAR |
intlist: INTLIST; |
list: LISTS.LIST; |
chunk: INTCHUNK; |
BEGIN |
NEW(intlist); |
list := LISTS.create(intlist); |
intlist.length := 0; |
NEW(chunk); |
chunk.count := 0; |
LISTS.push(list, chunk) |
RETURN list(INTLIST) |
END CreateIntList; |
PROCEDURE Length* (list: ANYLIST): INTEGER; |
RETURN list.length |
END Length; |
END CHUNKLISTS. |
/programs/develop/oberon07/Source/CODE.ob07 |
---|
0,0 → 1,1179 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE CODE; |
IMPORT LISTS, SCAN, STRINGS, CHL := CHUNKLISTS, C := COLLECTIONS; |
CONST |
little_endian* = 0; |
big_endian* = 1; |
call_stack* = 0; |
call_win64* = 1; |
call_sysv* = 2; |
opJMP* = 0; opLABEL* = 1; opCOPYS* = 2; opGADR* = 3; opCONST* = 4; opLLOAD32* = 5; |
opCOPYA* = 6; opCASET* = 7; opMULC* = 8; opMUL* = 9; |
opDIV* = 10; opMOD* = 11; opDIVL* = 12; opMODL* = 13; opDIVR* = 14; opMODR* = 15; |
opUMINUS* = 16; |
opADD* = 17; opSUB* = 18; opADDL* = 19; opSUBL* = 20; opADDR* = 21; opSUBR* = 22; |
opSAVE* = 23; opSAVEC* = 24; opSAVE8* = 25; opSAVE8C* = 26; opCHKBYTE* = 27; opDROP* = 28; |
opNOT* = 29; |
opEQ* = 30; opNE* = 31; opLT* = 32; opLE* = 33; opGT* = 34; opGE* = 35; |
opEQL* = 36; opNEL* = 37; opLTL* = 38; opLEL* = 39; opGTL* = 40; opGEL* = 41; |
opEQR* = 42; opNER* = 43; opLTR* = 44; opLER* = 45; opGTR* = 46; opGER* = 47; |
opVLOAD32* = 48; opGLOAD32* = 49; |
opJNE* = 50; opJE* = 51; |
opEQS* = 52; opNES* = opEQS + 1; opLTS* = opEQS + 2; opLES* = opEQS + 3; opGTS* = opEQS + 4; opGES* = opEQS + 5 (* 58 *); |
opSAVE32* = 58; opLLOAD8* = 59; |
opCONSTF* = 60; opLOADF* = 61; opSAVEF* = 62; opMULF* = 63; opDIVF* = 64; opDIVFI* = 65; |
opUMINF* = 66; opADDFI* = 67; opSUBFI* = 68; opADDF* = 69; opSUBF* = 70; |
opINC1B* = 71; opDEC1B* = 72; opINCCB* = 73; opDECCB* = 74; opINCB* = 75; opDECB* = 76; |
opCASEL* = 77; opCASER* = 78; opCASELR* = 79; |
opEQF* = 80; opNEF* = opEQF + 1; opLTF* = opEQF + 2; opLEF* = opEQF + 3; opGTF* = opEQF + 4; opGEF* = opEQF + 5; |
opEQFI* = opEQF + 6; opNEFI* = opEQF + 7; opLTFI* = opEQF + 8; opLEFI* = opEQF + 9; opGTFI* = opEQF + 10; opGEFI* = opEQF + 11; (* 91 *) |
opLOAD8* = 92; opLOAD16* = 93; opLOAD32* = 94; opPRECALL* = 95; opRES* = 96; opRESF* = 97; |
opERRC* = 98; opSWITCH* = 99; |
opSBOOL* = 100; opSBOOLC* = 101; opNOP* = 102; |
opMULS* = 103; opMULSC* = 104; opDIVS* = 105; opDIVSC* = 106; |
opADDS* = 107; opSUBS* = 108; opADDSL* = 109; opSUBSL* = 110; opADDSR* = 111; opSUBSR* = 112; |
opUMINS* = 113; opIN* = 114; opINL* = 115; opINR* = 116; |
opRSET* = 117; opRSETL* = 118; opRSETR* = 119; opRSET1* = 120; opLENGTH* = 121; |
opINC1* = 122; opDEC1* = 123; opINCC* = 124; opDECC* = 125; opINC* = 126; opDEC* = 127; |
opINCL* = 128; opEXCL* = 129; opINCLC* = 130; opEXCLC* = 131; opNEW* = 132; opDISP* = 133; |
opPACK* = 134; opPACKC* = 135; opUNPK* = 136; opCOPY* = 137; opENTER* = 138; opLEAVE* = 139; |
opCALL* = 140; opSAVEP* = 141; opCALLP* = 142; opEQP* = 143; opNEP* = 144; opLEAVER* = 145; |
opGET* = 146; opSAVE16* = 147; opABS* = 148; opFABS* = 149; opFLOOR* = 150; opFLT* = 151; |
opODD* = 152; opORD* = 153; opASR* = 154; opLSL* = 155; opROR* = 156; |
opASR1* = 157; opLSL1* = 158; opROR1* = 159; opASR2* = 160; opLSL2* = 161; opROR2* = 162; |
opPUSHP* = 163; opLADR* = 164; opTYPEGP* = 165; opIS* = 166; opPUSHF* = 167; opVADR* = 168; |
opPUSHT* = 169; opTYPEGR* = 170; opISREC* = 171; opCHKIDX* = 172; opPARAM* = 173; |
opCHKIDX2* = 174; opLEN* = 175; opROT* = 176; opSAVES* = 177; opSADR* = 178; opERR* = 179; |
opCHR* = 180; opENDSW* = 181; opLEAVEF* = 182; opCLEANUP* = 183; opMOVE* = 184; |
opLSR* = 185; opLSR1* = 186; opLSR2* = 187; |
opMIN* = 188; opMINC* = 189; opMAX* = 190; opMAXC* = 191; opJNZ* = 192; |
opEQB* = 193; opNEB* = 194; opINF* = 195; opJZ* = 196; opVLOAD8* = 197; opGLOAD8* = 198; |
opLLOAD16* = 199; opVLOAD16* = 200; opGLOAD16* = 201; |
opLOAD64* = 202; opLLOAD64* = 203; opVLOAD64* = 204; opGLOAD64* = 205; opSAVE64* = 206; |
opTYPEGD* = 207; opCALLI* = 208; opPUSHIP* = 209; opSAVEIP* = 210; opEQIP* = 211; opNEIP* = 212; |
opSAVE16C* = 213; opWCHR* = 214; opCOPYS2* = 215; opLENGTHW* = 216; |
opEQS2* = 217; opNES2* = opEQS2 + 1; opLTS2* = opEQS2 + 2; opLES2* = opEQS2 + 3; opGTS2* = opEQS2 + 4; opGES2* = opEQS2 + 5 (* 222 *); |
opEQSW* = 223; opNESW* = opEQSW + 1; opLTSW* = opEQSW + 2; opLESW* = opEQSW + 3; opGTSW* = opEQSW + 4; opGESW* = opEQSW + 5 (* 228 *); |
opEQSW2* = 229; opNESW2* = opEQSW2 + 1; opLTSW2* = opEQSW2 + 2; opLESW2* = opEQSW2 + 3; opGTSW2* = opEQSW2 + 4; opGESW2* = opEQSW2 + 5 (* 234 *); |
opCODE* = 235; |
opALIGN16* = 236; opPOPSP* = 237; |
opWIN64CALL* = 238; opWIN64CALLI* = 239; opWIN64CALLP* = 240; opLOOP* = 241; opENDLOOP* = 242; |
opSYSVCALL* = 243; opSYSVCALLI* = 244; opSYSVCALLP* = 245; opSYSVALIGN16* = 246; opWIN64ALIGN16* = 247; |
opSADR_PARAM* = 1000; opLOAD64_PARAM* = 1001; opLLOAD64_PARAM* = 1002; opGLOAD64_PARAM* = 1003; |
opVADR_PARAM* = 1004; opCONST_PARAM* = 1005; opGLOAD32_PARAM* = 1006; opLLOAD32_PARAM* = 1007; |
opLOAD32_PARAM* = 1008; |
opLADR_SAVEC* = 1009; opGADR_SAVEC* = 1010; opLADR_SAVE* = 1011; |
opLADR_INC1* = 1012; opLADR_DEC1* = 1013; opLADR_INCC* = 1014; opLADR_DECC* = 1015; |
opLADR_INC1B* = 1016; opLADR_DEC1B* = 1017; opLADR_INCCB* = 1018; opLADR_DECCB* = 1019; |
opLADR_INC* = 1020; opLADR_DEC* = 1021; opLADR_INCB* = 1022; opLADR_DECB* = 1023; |
opLADR_INCL* = 1024; opLADR_EXCL* = 1025; opLADR_INCLC* = 1026; opLADR_EXCLC* = 1027; |
opLADR_UNPK* = 1028; |
_move *= 0; |
_move2 *= 1; |
_strcmpw *= 2; |
_strcmpw2 *= 3; |
_set *= 4; |
_set2 *= 5; |
_lengthw *= 6; |
_strcmp2 *= 7; |
_div *= 8; |
_mod *= 9; |
_div2 *= 10; |
_mod2 *= 11; |
_arrcpy *= 12; |
_rot *= 13; |
_new *= 14; |
_dispose *= 15; |
_strcmp *= 16; |
_error *= 17; |
_is *= 18; |
_isrec *= 19; |
_guard *= 20; |
_guardrec *= 21; |
_length *= 22; |
_init *= 23; |
_dllentry *= 24; |
_strcpy *= 25; |
_exit *= 26; |
_strcpy2 *= 27; |
TYPE |
LOCALVAR* = POINTER TO RECORD (LISTS.ITEM) |
offset*, size*, count*: INTEGER |
END; |
COMMAND* = POINTER TO RECORD (LISTS.ITEM) |
opcode*: INTEGER; |
param1*: INTEGER; |
param2*: INTEGER; |
param3*: INTEGER; |
float*: REAL; |
variables*: LISTS.LIST; |
allocReg*: BOOLEAN |
END; |
CMDSTACK = POINTER TO RECORD |
data: ARRAY 1000 OF COMMAND; |
top: INTEGER |
END; |
EXPORT_PROC* = POINTER TO RECORD (LISTS.ITEM) |
label*: INTEGER; |
name*: SCAN.LEXSTR |
END; |
IMPORT_LIB* = POINTER TO RECORD (LISTS.ITEM) |
name*: SCAN.LEXSTR; |
procs*: LISTS.LIST |
END; |
IMPORT_PROC* = POINTER TO RECORD (LISTS.ITEM) |
label*: INTEGER; |
lib*: IMPORT_LIB; |
name*: SCAN.LEXSTR; |
count: INTEGER |
END; |
CODES* = POINTER TO RECORD |
last: COMMAND; |
begcall: CMDSTACK; |
endcall: CMDSTACK; |
commands*: LISTS.LIST; |
export*: LISTS.LIST; |
import*: LISTS.LIST; |
types*: CHL.INTLIST; |
data*: CHL.BYTELIST; |
dmin*: INTEGER; |
lcount*: INTEGER; |
bss*: INTEGER; |
rtl*: ARRAY 28 OF INTEGER; |
charoffs: ARRAY 256 OF INTEGER; |
wcharoffs: ARRAY 65536 OF INTEGER; |
fregs: INTEGER; |
wstr: ARRAY 4*1024 OF WCHAR; |
errlabel*: INTEGER |
END; |
VAR |
codes*: CODES; |
endianness: INTEGER; |
numRegsFloat: INTEGER; |
commands, variables: C.COLLECTION; |
PROCEDURE NewCmd (): COMMAND; |
VAR |
cmd: COMMAND; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(commands); |
IF citem = NIL THEN |
NEW(cmd) |
ELSE |
cmd := citem(COMMAND) |
END; |
cmd.allocReg := FALSE |
RETURN cmd |
END NewCmd; |
PROCEDURE NewVar* (): LOCALVAR; |
VAR |
lvar: LOCALVAR; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(variables); |
IF citem = NIL THEN |
NEW(lvar) |
ELSE |
lvar := citem(LOCALVAR) |
END; |
lvar.count := 0 |
RETURN lvar |
END NewVar; |
PROCEDURE setlast* (cmd: COMMAND); |
BEGIN |
codes.last := cmd |
END setlast; |
PROCEDURE getlast* (): COMMAND; |
RETURN codes.last |
END getlast; |
PROCEDURE PutByte (codes: CODES; b: BYTE); |
BEGIN |
CHL.PushByte(codes.data, b) |
END PutByte; |
PROCEDURE putstr* (s: ARRAY OF CHAR): INTEGER; |
VAR |
i, n, res: INTEGER; |
BEGIN |
res := CHL.Length(codes.data); |
i := 0; |
n := LENGTH(s); |
WHILE i < n DO |
PutByte(codes, ORD(s[i])); |
INC(i) |
END; |
PutByte(codes, 0) |
RETURN res |
END putstr; |
PROCEDURE putstr1* (c: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF codes.charoffs[c] = -1 THEN |
res := CHL.Length(codes.data); |
PutByte(codes, c); |
PutByte(codes, 0); |
codes.charoffs[c] := res |
ELSE |
res := codes.charoffs[c] |
END |
RETURN res |
END putstr1; |
PROCEDURE putstrW* (s: ARRAY OF CHAR): INTEGER; |
VAR |
i, n, res: INTEGER; |
BEGIN |
res := CHL.Length(codes.data); |
IF ODD(res) THEN |
PutByte(codes, 0); |
INC(res) |
END; |
n := STRINGS.Utf8To16(s, codes.wstr); |
i := 0; |
WHILE i < n DO |
IF endianness = little_endian THEN |
PutByte(codes, ORD(codes.wstr[i]) MOD 256); |
PutByte(codes, ORD(codes.wstr[i]) DIV 256) |
ELSIF endianness = big_endian THEN |
PutByte(codes, ORD(codes.wstr[i]) DIV 256); |
PutByte(codes, ORD(codes.wstr[i]) MOD 256) |
END; |
INC(i) |
END; |
PutByte(codes, 0); |
PutByte(codes, 0) |
RETURN res |
END putstrW; |
PROCEDURE putstrW1* (c: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF codes.wcharoffs[c] = -1 THEN |
res := CHL.Length(codes.data); |
IF ODD(res) THEN |
PutByte(codes, 0); |
INC(res) |
END; |
IF endianness = little_endian THEN |
PutByte(codes, c MOD 256); |
PutByte(codes, c DIV 256) |
ELSIF endianness = big_endian THEN |
PutByte(codes, c DIV 256); |
PutByte(codes, c MOD 256) |
END; |
PutByte(codes, 0); |
PutByte(codes, 0); |
codes.wcharoffs[c] := res |
ELSE |
res := codes.wcharoffs[c] |
END |
RETURN res |
END putstrW1; |
PROCEDURE SetMinDataSize* (size: INTEGER); |
BEGIN |
codes.dmin := CHL.Length(codes.data) + size |
END SetMinDataSize; |
PROCEDURE push (stk: CMDSTACK; cmd: COMMAND); |
BEGIN |
INC(stk.top); |
stk.data[stk.top] := cmd |
END push; |
PROCEDURE pop (stk: CMDSTACK): COMMAND; |
VAR |
res: COMMAND; |
BEGIN |
res := stk.data[stk.top]; |
DEC(stk.top) |
RETURN res |
END pop; |
PROCEDURE pushBegEnd* (VAR beg, end: COMMAND); |
BEGIN |
push(codes.begcall, beg); |
push(codes.endcall, end); |
beg := codes.last; |
end := beg.next(COMMAND) |
END pushBegEnd; |
PROCEDURE popBegEnd* (VAR beg, end: COMMAND); |
BEGIN |
beg := pop(codes.begcall); |
end := pop(codes.endcall) |
END popBegEnd; |
PROCEDURE AddRec* (base: INTEGER); |
BEGIN |
CHL.PushInt(codes.types, base) |
END AddRec; |
PROCEDURE insert (cur, nov: COMMAND); |
VAR |
old_opcode, param2: INTEGER; |
PROCEDURE set (cur: COMMAND; opcode, param2: INTEGER); |
BEGIN |
cur.opcode := opcode; |
cur.param1 := cur.param2; |
cur.param2 := param2 |
END set; |
BEGIN |
old_opcode := cur.opcode; |
param2 := nov.param2; |
IF (nov.opcode = opPARAM) & (param2 = 1) THEN |
CASE old_opcode OF |
|opGLOAD64: cur.opcode := opGLOAD64_PARAM |
|opLLOAD64: cur.opcode := opLLOAD64_PARAM |
|opLOAD64: cur.opcode := opLOAD64_PARAM |
|opGLOAD32: cur.opcode := opGLOAD32_PARAM |
|opLLOAD32: cur.opcode := opLLOAD32_PARAM |
|opLOAD32: cur.opcode := opLOAD32_PARAM |
|opSADR: cur.opcode := opSADR_PARAM |
|opVADR: cur.opcode := opVADR_PARAM |
|opCONST: cur.opcode := opCONST_PARAM |
ELSE |
old_opcode := -1 |
END |
ELSIF old_opcode = opLADR THEN |
CASE nov.opcode OF |
|opSAVEC: set(cur, opLADR_SAVEC, param2) |
|opSAVE: cur.opcode := opLADR_SAVE |
|opINC1: cur.opcode := opLADR_INC1 |
|opDEC1: cur.opcode := opLADR_DEC1 |
|opINC: cur.opcode := opLADR_INC |
|opDEC: cur.opcode := opLADR_DEC |
|opINC1B: cur.opcode := opLADR_INC1B |
|opDEC1B: cur.opcode := opLADR_DEC1B |
|opINCB: cur.opcode := opLADR_INCB |
|opDECB: cur.opcode := opLADR_DECB |
|opINCL: cur.opcode := opLADR_INCL |
|opEXCL: cur.opcode := opLADR_EXCL |
|opUNPK: cur.opcode := opLADR_UNPK |
|opINCC: set(cur, opLADR_INCC, param2) |
|opDECC: set(cur, opLADR_DECC, param2) |
|opINCCB: set(cur, opLADR_INCCB, param2) |
|opDECCB: set(cur, opLADR_DECCB, param2) |
|opINCLC: set(cur, opLADR_INCLC, param2) |
|opEXCLC: set(cur, opLADR_EXCLC, param2) |
ELSE |
old_opcode := -1 |
END |
ELSIF (nov.opcode = opSAVEC) & (old_opcode = opGADR) THEN |
set(cur, opGADR_SAVEC, param2) |
ELSIF (nov.opcode = opMULC) & (old_opcode = opMULC) THEN |
cur.param2 := param2 * cur.param2 |
ELSE |
old_opcode := -1 |
END; |
IF old_opcode = -1 THEN |
LISTS.insert(codes.commands, cur, nov); |
codes.last := nov |
ELSE |
C.push(commands, nov); |
codes.last := cur |
END |
END insert; |
PROCEDURE AddCmd* (opcode: INTEGER; param: INTEGER); |
VAR |
cmd: COMMAND; |
BEGIN |
cmd := NewCmd(); |
cmd.opcode := opcode; |
cmd.param1 := 0; |
cmd.param2 := param; |
insert(codes.last, cmd) |
END AddCmd; |
PROCEDURE AddCmd2* (opcode: INTEGER; param1, param2: INTEGER); |
VAR |
cmd: COMMAND; |
BEGIN |
cmd := NewCmd(); |
cmd.opcode := opcode; |
cmd.param1 := param1; |
cmd.param2 := param2; |
insert(codes.last, cmd) |
END AddCmd2; |
PROCEDURE NewLabel* (): INTEGER; |
BEGIN |
INC(codes.lcount) |
RETURN codes.lcount - 1 |
END NewLabel; |
PROCEDURE SetLabel* (label: INTEGER); |
BEGIN |
AddCmd(opLABEL, label) |
END SetLabel; |
PROCEDURE SetErrLabel*; |
BEGIN |
codes.errlabel := NewLabel(); |
SetLabel(codes.errlabel) |
END SetErrLabel; |
PROCEDURE AddCmd0* (opcode: INTEGER); |
BEGIN |
AddCmd(opcode, 0) |
END AddCmd0; |
PROCEDURE deleteVarList (list: LISTS.LIST); |
VAR |
last: LISTS.ITEM; |
BEGIN |
WHILE list.last # NIL DO |
last := LISTS.pop(list); |
C.push(variables, last) |
END |
END deleteVarList; |
PROCEDURE delete (cmd: COMMAND); |
BEGIN |
IF cmd.variables # NIL THEN |
deleteVarList(cmd.variables) |
END; |
LISTS.delete(codes.commands, cmd); |
C.push(commands, cmd) |
END delete; |
PROCEDURE delete2* (first, last: LISTS.ITEM); |
VAR |
cur, next: LISTS.ITEM; |
BEGIN |
cur := first; |
IF first # last THEN |
REPEAT |
next := cur.next; |
LISTS.delete(codes.commands, cur); |
C.push(commands, cur); |
cur := next |
UNTIL cur = last |
END; |
LISTS.delete(codes.commands, cur); |
C.push(commands, cur) |
END delete2; |
PROCEDURE AddJmpCmd* (opcode: INTEGER; label: INTEGER); |
VAR |
prev: COMMAND; |
not: BOOLEAN; |
BEGIN |
prev := codes.last; |
not := prev.opcode = opNOT; |
IF not THEN |
IF opcode = opJE THEN |
opcode := opJNE |
ELSIF opcode = opJNE THEN |
opcode := opJE |
ELSE |
not := FALSE |
END |
END; |
AddCmd2(opcode, label, label); |
IF not THEN |
delete(prev) |
END |
END AddJmpCmd; |
PROCEDURE OnError* (line, error: INTEGER); |
BEGIN |
AddCmd(opERRC, LSL(line, 4) + error); |
AddJmpCmd(opJMP, codes.errlabel) |
END OnError; |
PROCEDURE TypeGuard* (op, t: INTEGER; line, error: INTEGER); |
VAR |
label: INTEGER; |
BEGIN |
AddCmd(op, t); |
label := NewLabel(); |
AddJmpCmd(opJE, label); |
OnError(line, error); |
SetLabel(label) |
END TypeGuard; |
PROCEDURE TypeCheck* (t: INTEGER); |
BEGIN |
AddCmd(opIS, t) |
END TypeCheck; |
PROCEDURE TypeCheckRec* (t: INTEGER); |
BEGIN |
AddCmd(opISREC, t) |
END TypeCheckRec; |
PROCEDURE New* (size, typenum: INTEGER); |
BEGIN |
AddCmd2(opNEW, typenum, size) |
END New; |
PROCEDURE fcmp* (opcode: INTEGER); |
BEGIN |
AddCmd(opcode, 0); |
DEC(codes.fregs, 2); |
ASSERT(codes.fregs >= 0) |
END fcmp; |
PROCEDURE not*; |
VAR |
prev: COMMAND; |
BEGIN |
prev := codes.last; |
IF prev.opcode = opNOT THEN |
codes.last := prev.prev(COMMAND); |
delete(prev) |
ELSE |
AddCmd0(opNOT) |
END |
END not; |
PROCEDURE Enter* (label, params: INTEGER): COMMAND; |
VAR |
cmd: COMMAND; |
BEGIN |
cmd := NewCmd(); |
cmd.opcode := opENTER; |
cmd.param1 := label; |
cmd.param3 := params; |
cmd.allocReg := TRUE; |
insert(codes.last, cmd) |
RETURN codes.last |
END Enter; |
PROCEDURE Leave* (result, float: BOOLEAN; paramsize: INTEGER): COMMAND; |
BEGIN |
IF result THEN |
IF float THEN |
AddCmd(opLEAVEF, paramsize) |
ELSE |
AddCmd(opLEAVER, paramsize) |
END |
ELSE |
AddCmd(opLEAVE, paramsize) |
END |
RETURN codes.last |
END Leave; |
PROCEDURE Call* (proc, callconv, fparams: INTEGER); |
BEGIN |
CASE callconv OF |
|call_stack: AddJmpCmd(opCALL, proc) |
|call_win64: AddJmpCmd(opWIN64CALL, proc) |
|call_sysv: AddJmpCmd(opSYSVCALL, proc) |
END; |
codes.last(COMMAND).param2 := fparams |
END Call; |
PROCEDURE CallImp* (proc: LISTS.ITEM; callconv, fparams: INTEGER); |
BEGIN |
CASE callconv OF |
|call_stack: AddJmpCmd(opCALLI, proc(IMPORT_PROC).label) |
|call_win64: AddJmpCmd(opWIN64CALLI, proc(IMPORT_PROC).label) |
|call_sysv: AddJmpCmd(opSYSVCALLI, proc(IMPORT_PROC).label) |
END; |
codes.last(COMMAND).param2 := fparams |
END CallImp; |
PROCEDURE CallP* (callconv, fparams: INTEGER); |
BEGIN |
CASE callconv OF |
|call_stack: AddCmd0(opCALLP) |
|call_win64: AddCmd(opWIN64CALLP, fparams) |
|call_sysv: AddCmd(opSYSVCALLP, fparams) |
END |
END CallP; |
PROCEDURE AssignProc* (proc: INTEGER); |
BEGIN |
AddJmpCmd(opSAVEP, proc) |
END AssignProc; |
PROCEDURE AssignImpProc* (proc: LISTS.ITEM); |
BEGIN |
AddJmpCmd(opSAVEIP, proc(IMPORT_PROC).label) |
END AssignImpProc; |
PROCEDURE PushProc* (proc: INTEGER); |
BEGIN |
AddJmpCmd(opPUSHP, proc) |
END PushProc; |
PROCEDURE PushImpProc* (proc: LISTS.ITEM); |
BEGIN |
AddJmpCmd(opPUSHIP, proc(IMPORT_PROC).label) |
END PushImpProc; |
PROCEDURE ProcCmp* (proc: INTEGER; eq: BOOLEAN); |
BEGIN |
IF eq THEN |
AddJmpCmd(opEQP, proc) |
ELSE |
AddJmpCmd(opNEP, proc) |
END |
END ProcCmp; |
PROCEDURE ProcImpCmp* (proc: LISTS.ITEM; eq: BOOLEAN); |
BEGIN |
IF eq THEN |
AddJmpCmd(opEQIP, proc(IMPORT_PROC).label) |
ELSE |
AddJmpCmd(opNEIP, proc(IMPORT_PROC).label) |
END |
END ProcImpCmp; |
PROCEDURE SysGet* (size: INTEGER); |
BEGIN |
AddCmd(opGET, size) |
END SysGet; |
PROCEDURE load* (size: INTEGER); |
VAR |
last: COMMAND; |
BEGIN |
last := codes.last; |
CASE size OF |
|1: |
IF last.opcode = opLADR THEN |
last.opcode := opLLOAD8 |
ELSIF last.opcode = opVADR THEN |
last.opcode := opVLOAD8 |
ELSIF last.opcode = opGADR THEN |
last.opcode := opGLOAD8 |
ELSE |
AddCmd0(opLOAD8) |
END |
|2: |
IF last.opcode = opLADR THEN |
last.opcode := opLLOAD16 |
ELSIF last.opcode = opVADR THEN |
last.opcode := opVLOAD16 |
ELSIF last.opcode = opGADR THEN |
last.opcode := opGLOAD16 |
ELSE |
AddCmd0(opLOAD16) |
END |
|4: |
IF last.opcode = opLADR THEN |
last.opcode := opLLOAD32 |
ELSIF last.opcode = opVADR THEN |
last.opcode := opVLOAD32 |
ELSIF last.opcode = opGADR THEN |
last.opcode := opGLOAD32 |
ELSE |
AddCmd0(opLOAD32) |
END |
|8: |
IF last.opcode = opLADR THEN |
last.opcode := opLLOAD64 |
ELSIF last.opcode = opVADR THEN |
last.opcode := opVLOAD64 |
ELSIF last.opcode = opGADR THEN |
last.opcode := opGLOAD64 |
ELSE |
AddCmd0(opLOAD64) |
END |
END |
END load; |
PROCEDURE SysPut* (size: INTEGER); |
BEGIN |
CASE size OF |
|1: AddCmd0(opSAVE8) |
|2: AddCmd0(opSAVE16) |
|4: AddCmd0(opSAVE32) |
|8: AddCmd0(opSAVE64) |
END |
END SysPut; |
PROCEDURE savef*; |
BEGIN |
AddCmd0(opSAVEF); |
DEC(codes.fregs); |
ASSERT(codes.fregs >= 0) |
END savef; |
PROCEDURE pushf*; |
BEGIN |
AddCmd0(opPUSHF); |
DEC(codes.fregs); |
ASSERT(codes.fregs >= 0) |
END pushf; |
PROCEDURE loadf* (): BOOLEAN; |
BEGIN |
AddCmd0(opLOADF); |
INC(codes.fregs) |
RETURN codes.fregs < numRegsFloat |
END loadf; |
PROCEDURE inf* (): BOOLEAN; |
BEGIN |
AddCmd0(opINF); |
INC(codes.fregs) |
RETURN codes.fregs < numRegsFloat |
END inf; |
PROCEDURE fbinop* (opcode: INTEGER); |
BEGIN |
AddCmd0(opcode); |
DEC(codes.fregs); |
ASSERT(codes.fregs > 0) |
END fbinop; |
PROCEDURE saves* (offset, length: INTEGER); |
BEGIN |
AddCmd2(opSAVES, length, offset) |
END saves; |
PROCEDURE abs* (real: BOOLEAN); |
BEGIN |
IF real THEN |
AddCmd0(opFABS) |
ELSE |
AddCmd0(opABS) |
END |
END abs; |
PROCEDURE floor*; |
BEGIN |
AddCmd0(opFLOOR); |
DEC(codes.fregs); |
ASSERT(codes.fregs >= 0) |
END floor; |
PROCEDURE flt* (): BOOLEAN; |
BEGIN |
AddCmd0(opFLT); |
INC(codes.fregs) |
RETURN codes.fregs < numRegsFloat |
END flt; |
PROCEDURE odd*; |
BEGIN |
AddCmd0(opODD) |
END odd; |
PROCEDURE ord*; |
BEGIN |
AddCmd0(opORD) |
END ord; |
PROCEDURE shift_minmax* (op: CHAR); |
BEGIN |
CASE op OF |
|"A": AddCmd0(opASR) |
|"L": AddCmd0(opLSL) |
|"O": AddCmd0(opROR) |
|"R": AddCmd0(opLSR) |
|"m": AddCmd0(opMIN) |
|"x": AddCmd0(opMAX) |
END |
END shift_minmax; |
PROCEDURE shift_minmax1* (op: CHAR; x: INTEGER); |
BEGIN |
CASE op OF |
|"A": AddCmd(opASR1, x) |
|"L": AddCmd(opLSL1, x) |
|"O": AddCmd(opROR1, x) |
|"R": AddCmd(opLSR1, x) |
|"m": AddCmd(opMINC, x) |
|"x": AddCmd(opMAXC, x) |
END |
END shift_minmax1; |
PROCEDURE shift_minmax2* (op: CHAR; x: INTEGER); |
BEGIN |
CASE op OF |
|"A": AddCmd(opASR2, x) |
|"L": AddCmd(opLSL2, x) |
|"O": AddCmd(opROR2, x) |
|"R": AddCmd(opLSR2, x) |
|"m": AddCmd(opMINC, x) |
|"x": AddCmd(opMAXC, x) |
END |
END shift_minmax2; |
PROCEDURE len* (dim: INTEGER); |
BEGIN |
AddCmd(opLEN, dim) |
END len; |
PROCEDURE Float* (r: REAL); |
VAR |
cmd: COMMAND; |
BEGIN |
cmd := NewCmd(); |
cmd.opcode := opCONSTF; |
cmd.float := r; |
insert(codes.last, cmd); |
INC(codes.fregs); |
ASSERT(codes.fregs <= numRegsFloat) |
END Float; |
PROCEDURE precall* (flt: BOOLEAN): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
res := codes.fregs; |
AddCmd2(opPRECALL, ORD(flt), res); |
codes.fregs := 0 |
RETURN res |
END precall; |
PROCEDURE resf* (fregs: INTEGER): BOOLEAN; |
BEGIN |
AddCmd(opRESF, fregs); |
codes.fregs := fregs + 1 |
RETURN codes.fregs < numRegsFloat |
END resf; |
PROCEDURE res* (fregs: INTEGER); |
BEGIN |
AddCmd(opRES, fregs); |
codes.fregs := fregs |
END res; |
PROCEDURE retf*; |
BEGIN |
DEC(codes.fregs); |
ASSERT(codes.fregs = 0) |
END retf; |
PROCEDURE drop*; |
BEGIN |
AddCmd0(opDROP) |
END drop; |
PROCEDURE case* (a, b, L, R: INTEGER); |
VAR |
cmd: COMMAND; |
BEGIN |
IF a = b THEN |
cmd := NewCmd(); |
cmd.opcode := opCASELR; |
cmd.param1 := a; |
cmd.param2 := L; |
cmd.param3 := R; |
insert(codes.last, cmd) |
ELSE |
AddCmd2(opCASEL, a, L); |
AddCmd2(opCASER, b, R) |
END |
END case; |
PROCEDURE caset* (a, label: INTEGER); |
BEGIN |
AddCmd2(opCASET, label, a) |
END caset; |
PROCEDURE AddExp* (label: INTEGER; name: SCAN.LEXSTR); |
VAR |
exp: EXPORT_PROC; |
BEGIN |
NEW(exp); |
exp.label := label; |
exp.name := name; |
LISTS.push(codes.export, exp) |
END AddExp; |
PROCEDURE AddImp* (dll, proc: SCAN.LEXSTR): IMPORT_PROC; |
VAR |
lib: IMPORT_LIB; |
p: IMPORT_PROC; |
BEGIN |
lib := codes.import.first(IMPORT_LIB); |
WHILE (lib # NIL) & (lib.name # dll) DO |
lib := lib.next(IMPORT_LIB) |
END; |
IF lib = NIL THEN |
NEW(lib); |
lib.name := dll; |
lib.procs := LISTS.create(NIL); |
LISTS.push(codes.import, lib) |
END; |
p := lib.procs.first(IMPORT_PROC); |
WHILE (p # NIL) & (p.name # proc) DO |
p := p.next(IMPORT_PROC) |
END; |
IF p = NIL THEN |
NEW(p); |
p.name := proc; |
p.label := NewLabel(); |
p.lib := lib; |
p.count := 1; |
LISTS.push(lib.procs, p) |
ELSE |
INC(p.count) |
END |
RETURN p |
END AddImp; |
PROCEDURE DelImport* (imp: LISTS.ITEM); |
VAR |
lib: IMPORT_LIB; |
BEGIN |
DEC(imp(IMPORT_PROC).count); |
IF imp(IMPORT_PROC).count = 0 THEN |
lib := imp(IMPORT_PROC).lib; |
LISTS.delete(lib.procs, imp); |
IF lib.procs.first = NIL THEN |
LISTS.delete(codes.import, lib) |
END |
END |
END DelImport; |
PROCEDURE init* (pNumRegsFloat, pEndianness: INTEGER); |
VAR |
cmd: COMMAND; |
i: INTEGER; |
BEGIN |
commands := C.create(); |
variables := C.create(); |
numRegsFloat := pNumRegsFloat; |
endianness := pEndianness; |
NEW(codes); |
NEW(codes.begcall); |
codes.begcall.top := -1; |
NEW(codes.endcall); |
codes.endcall.top := -1; |
codes.commands := LISTS.create(NIL); |
codes.export := LISTS.create(NIL); |
codes.import := LISTS.create(NIL); |
codes.types := CHL.CreateIntList(); |
codes.data := CHL.CreateByteList(); |
NEW(cmd); cmd.opcode := opNOP; LISTS.push(codes.commands, cmd); |
codes.last := cmd; |
NEW(cmd); cmd.opcode := opNOP; LISTS.push(codes.commands, cmd); |
AddRec(0); |
codes.lcount := 0; |
codes.fregs := 0; |
FOR i := 0 TO LEN(codes.charoffs) - 1 DO |
codes.charoffs[i] := -1 |
END; |
FOR i := 0 TO LEN(codes.wcharoffs) - 1 DO |
codes.wcharoffs[i] := -1 |
END |
END init; |
END CODE. |
/programs/develop/oberon07/Source/COLLECTIONS.ob07 |
---|
0,0 → 1,59 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE COLLECTIONS; |
TYPE |
ITEM* = POINTER TO RECORD |
link: ITEM |
END; |
COLLECTION* = POINTER TO RECORD |
last: ITEM |
END; |
PROCEDURE push* (collection: COLLECTION; item: ITEM); |
BEGIN |
item.link := collection.last; |
collection.last := item |
END push; |
PROCEDURE pop* (collection: COLLECTION): ITEM; |
VAR |
item: ITEM; |
BEGIN |
item := collection.last; |
IF item # NIL THEN |
collection.last := item.link |
END |
RETURN item |
END pop; |
PROCEDURE create* (): COLLECTION; |
VAR |
collection: COLLECTION; |
BEGIN |
NEW(collection); |
collection.last := NIL |
RETURN collection |
END create; |
END COLLECTIONS. |
/programs/develop/oberon07/Source/CONSOLE.ob07 |
---|
0,0 → 1,72 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE CONSOLE; |
IMPORT UTILS, STRINGS; |
PROCEDURE String* (s: ARRAY OF CHAR); |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE (i < LEN(s)) & (s[i] # 0X) DO |
UTILS.OutChar(s[i]); |
INC(i) |
END |
END String; |
PROCEDURE Int* (n: INTEGER); |
VAR |
s: ARRAY 32 OF CHAR; |
BEGIN |
STRINGS.IntToStr(n, s); |
String(s) |
END Int; |
PROCEDURE Int2* (n: INTEGER); |
BEGIN |
IF n < 10 THEN |
String("0") |
END; |
Int(n) |
END Int2; |
PROCEDURE Ln*; |
BEGIN |
String(UTILS.eol) |
END Ln; |
PROCEDURE StringLn* (s: ARRAY OF CHAR); |
BEGIN |
String(s); |
Ln |
END StringLn; |
PROCEDURE IntLn* (n: INTEGER); |
BEGIN |
Int(n); |
Ln |
END IntLn; |
PROCEDURE Int2Ln* (n: INTEGER); |
BEGIN |
Int2(n); |
Ln |
END Int2Ln; |
END CONSOLE. |
/programs/develop/oberon07/Source/CONSTANTS.ob07 |
---|
0,0 → 1,43 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE CONSTANTS; |
CONST |
vMajor* = 0; |
vMinor* = 98; |
FILE_EXT* = ".ob07"; |
RTL_NAME* = "RTL"; |
MAX_GLOBAL_SIZE* = 1600000000; |
Target_iConsole* = 1; |
Target_iGUI* = 2; |
Target_iDLL* = 3; |
Target_iKolibri* = 4; |
Target_iObject* = 5; |
Target_iConsole64* = 6; |
Target_iGUI64* = 7; |
Target_iDLL64* = 8; |
Target_iELF32* = 9; |
Target_iELF64* = 10; |
Target_sConsole* = "console"; |
Target_sGUI* = "gui"; |
Target_sDLL* = "dll"; |
Target_sKolibri* = "kos"; |
Target_sObject* = "obj"; |
Target_sConsole64* = "console64"; |
Target_sGUI64* = "gui64"; |
Target_sDLL64* = "dll64"; |
Target_sELF32* = "elfexe"; |
Target_sELF64* = "elfexe64"; |
END CONSTANTS. |
/programs/develop/oberon07/Source/Compiler.ob07 |
---|
1,1958 → 1,280 |
(* |
Copyright 2016, 2017, 2018 Anton Krotov |
(* |
BSD 2-Clause License |
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/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE Compiler; |
IMPORT DECL, SCAN, UTILS, X86, SYSTEM; |
IMPORT ST := STATEMENTS, PARS, UTILS, PATHS, C := CONSOLE, ERRORS, STRINGS, mConst := CONSTANTS, WRITER; |
CONST |
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; |
PROCEDURE Target (s: ARRAY OF CHAR): INTEGER; |
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 e.eType = eVAR THEN |
X86.Load(e.T.tType) |
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 |
END |
END Load; |
PROCEDURE LenString(adr: LONGREAL): INTEGER; |
VAR s: UTILS.STRCONST; |
BEGIN |
s := DECL.GetString(adr) |
RETURN s.Len |
END LenString; |
RETURN res |
END Target; |
PROCEDURE Assert(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER); |
BEGIN |
IF ~cond THEN |
DECL.Assert(FALSE, coord, code) |
END |
END Assert; |
PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER); |
BEGIN |
IF ~cond THEN |
DECL.Assert(FALSE, SCAN.coord, code) |
END |
END Assert2; |
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 IntType(T: DECL.pTYPE; coord: SCAN.TCoord); |
BEGIN |
Assert(T.tType = TINTEGER, coord, 52) |
END IntType; |
end := FALSE; |
i := 4; |
REPEAT |
UTILS.GetArg(i, param); |
PROCEDURE Next; |
BEGIN |
DECL.Next |
END Next; |
IF param = "-stk" THEN |
INC(i); |
UTILS.GetArg(i, param); |
IF STRINGS.StrToInt(param, value) & (1 <= value) & (value <= 32) THEN |
StackSize := value |
END; |
IF param[0] = "-" THEN |
DEC(i) |
END |
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 |
ELSIF param = "-base" THEN |
INC(i); |
UTILS.GetArg(i, param); |
IF STRINGS.StrToInt(param, value) THEN |
BaseAddress := ((value DIV 64) * 64) * 1024 |
END; |
WHILE (T1 # NIL) & (T1 # T0) DO |
T1 := T1.Base |
IF param[0] = "-" THEN |
DEC(i) |
END |
END |
RETURN T0 = T1 |
END BaseOf; |
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; |
ELSIF param = "-nochk" THEN |
INC(i); |
UTILS.GetArg(i, param); |
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; |
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 |
IF param[0] = "-" THEN |
DEC(i) |
ELSE |
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; |
j := 0; |
WHILE param[j] # 0X DO |
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) |
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 := {} |
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; |
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) |
INC(j) |
END |
END |
END Str; |
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) |
ELSIF param = "-ver" THEN |
INC(i); |
UTILS.GetArg(i, param); |
IF STRINGS.StrToVer(param, major, minor) THEN |
Version := major * 65536 + minor |
END; |
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 |
IF param[0] = "-" THEN |
DEC(i) |
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; |
PROCEDURE ProcTypeComp(T1, T2: DECL.pTYPE): BOOLEAN; |
VAR sp: INTEGER; stk: ARRAY 100, 2 OF DECL.pTYPE; |
ELSIF param = "-pic" THEN |
pic := TRUE |
PROCEDURE ProcTypeComp1(T1, T2: DECL.pTYPE): BOOLEAN; |
VAR fp, ft: DECL.FIELD; Res: BOOLEAN; |
ELSIF param = "" THEN |
end := TRUE |
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 |
Res := ProcTypeComp1(T1, T2) |
END |
RETURN Res |
END TypeComp; |
ERRORS.error3("bad parameter: ", param, "") |
END; |
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) |
END |
RETURN res |
END Check; |
UNTIL end |
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; |
END keys; |
BEGIN |
sp := -1 |
RETURN ProcTypeComp1(T1, T2) |
END ProcTypeComp; |
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; |
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 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; |
target: 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; |
time: INTEGER; |
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; |
StackSize, |
Version, |
BaseAdr: INTEGER; |
pic: BOOLEAN; |
checking: SET; |
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; |
bits64: BOOLEAN; |
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 |
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; |
StackSize := 2; |
Version := 65536; |
pic := FALSE; |
checking := ST.chkALL; |
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; |
PATHS.GetCurrentDirectory(app_path); |
lib_path := app_path; |
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; |
UTILS.GetArg(1, inname); |
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) |
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; |
END; |
Factor(a); |
Load(a); |
IF Op = lxAnd THEN |
X86.Label(L) |
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) |
END; |
Operation(e, a, Op, coord) |
END |
END Term; |
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; |
PATHS.split(inname, path, modname, 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) |
IF ext # mConst.FILE_EXT THEN |
ERRORS.error3('inputfile name extension must be "', mConst.FILE_EXT, '"') |
END; |
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) |
IF PATHS.isRelative(path) THEN |
PATHS.RelPath(app_path, path, temp); |
path := temp |
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; |
PROCEDURE IfWhileOper(wh: BOOLEAN); |
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L, L3: INTEGER; |
BEGIN |
L := X86.NewLabel(); |
IF wh THEN |
X86.Label(L) |
UTILS.GetArg(2, outname); |
IF outname = "" THEN |
ERRORS.error1("not enough parameters") |
END; |
REPEAT |
NextCoord(coord); |
Expr(e); |
Assert(e.T.tType = TBOOLEAN, coord, 117); |
Load(e); |
IF wh THEN |
Check(lxDO) |
ELSE |
Check(lxTHEN) |
IF PATHS.isRelative(outname) THEN |
PATHS.RelPath(app_path, outname, temp); |
outname := temp |
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; |
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) |
UTILS.GetArg(3, param); |
IF param = "" THEN |
ERRORS.error1("not enough parameters") |
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; |
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; |
target := Target(param); |
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) |
IF target = 0 THEN |
ERRORS.error1("bad parameter <target>") |
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; |
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; |
bits64 := target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64, mConst.Target_iELF64}; |
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) |
IF bits64 THEN |
IF UTILS.bit_depth = 32 THEN |
ERRORS.error1("bad parameter <target>") |
END; |
IF SCAN.tLex = lxELSE THEN |
Next; |
pOpSeq |
PARS.init(64, target) |
ELSE |
UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line); |
X86.OnError(7) |
PARS.init(32, target) |
END; |
Check(lxEND); |
X86.Label(EndCase); |
Next; |
UTILS.Clear(Labels) |
END CaseOper; |
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; |
PARS.program.dll := target IN {mConst.Target_iDLL, mConst.Target_iObject, mConst.Target_iDLL64}; |
PARS.program.obj := target = mConst.Target_iObject; |
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; |
STRINGS.append(lib_path, "lib"); |
STRINGS.append(lib_path, UTILS.slash); |
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) |
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN |
IF target = mConst.Target_iDLL THEN |
BaseAdr := 10000000H |
ELSE |
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) |
BaseAdr := 400000H |
END; |
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; |
STRINGS.append(lib_path, "Windows32") |
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 IN {mConst.Target_iKolibri, mConst.Target_iObject} THEN |
STRINGS.append(lib_path, "KolibriOS") |
PROCEDURE OpSeq; |
BEGIN |
Operator; |
WHILE SCAN.tLex = lxSemi DO |
Next; |
Operator |
END |
END OpSeq; |
ELSIF target = mConst.Target_iELF32 THEN |
STRINGS.append(lib_path, "Linux32") |
PROCEDURE Start; |
VAR SelfName, SelfPath, CName, CExt, FName, Path, StdPath, |
Name, Ext, temp, system, stk: UTILS.STRING; |
platform, stksize: INTEGER; |
ELSIF target = mConst.Target_iELF64 THEN |
STRINGS.append(lib_path, "Linux64") |
PROCEDURE getstksize(): INTEGER; |
VAR res, i: INTEGER; |
BEGIN |
res := 0; |
i := 0; |
WHILE SCAN.Digit(stk[i]) DO |
INC(i) |
ELSIF target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN |
STRINGS.append(lib_path, "Windows64") |
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; |
PROCEDURE getver(): INTEGER; |
VAR res, i: INTEGER; err: BOOLEAN; |
STRINGS.append(lib_path, UTILS.slash); |
PROCEDURE hexdgt(c: CHAR): BOOLEAN; |
RETURN ("0" <= c) & (c <= "9") OR |
("A" <= c) & (c <= "F") OR |
("a" <= c) & (c <= "f") |
END hexdgt; |
keys(StackSize, BaseAdr, Version, 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; |
ST.compile(path, lib_path, modname, outname, target, Version, StackSize, BaseAdr, pic, checking); |
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; |
time := UTILS.GetTickCount() - UTILS.time; |
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; |
C.Int(time DIV 100); C.String("."); C.Int2(time MOD 100); C.String(" sec, "); |
C.Int(WRITER.counter); C.StringLn(" bytes"); |
UTILS.Exit(0) |
END main; |
BEGIN |
Start |
main |
END Compiler. |
/programs/develop/oberon07/Source/ELF.ob07 |
---|
1,295 → 1,382 |
(* |
Copyright 2016 Anton Krotov |
(* |
BSD 2-Clause License |
This file is part of Compiler. |
Copyright (c) 2019, Anton Krotov |
All rights reserved. |
*) |
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. |
MODULE ELF; |
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. |
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS; |
You should have received a copy of the GNU General Public License |
along with Compiler. If not, see <http://www.gnu.org/licenses/>. |
*) |
MODULE ELF; |
CONST |
IMPORT SYSTEM; |
EI_NIDENT = 16; |
ET_EXEC = 2; |
ET_DYN = 3; |
CONST size* = 8346; |
EM_386 = 3; |
EM_8664 = 3EH; |
PROCEDURE [stdcall] data; |
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; |
BEGIN |
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; |
IF n MOD _align # 0 THEN |
n := n + _align - (n MOD _align) |
END |
PROCEDURE get*(): INTEGER; |
RETURN SYSTEM.ADR(data) + 3 |
END get; |
RETURN n |
END align; |
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/ERRORS.ob07 |
---|
1,285 → 1,171 |
(* |
Copyright 2016, 2017 Anton Krotov |
(* |
BSD 2-Clause License |
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/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE ERRORS; |
IMPORT H := HOST; |
IMPORT C := CONSOLE, UTILS; |
TYPE |
STRING = ARRAY 1024 OF CHAR; |
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; |
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 |
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; |
C.Ln; |
C.String(" error ("); C.Int(line); C.String(":"); C.Int(col); C.String(") "); |
PROCEDURE InitCP(VAR cp: CP); |
VAR i: INTEGER; |
BEGIN |
FOR i := 0H TO 7FH DO |
cp[i] := i |
END |
END InitCP; |
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 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 |
| 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" |
END; |
FOR i := 0440H TO 044FH DO |
cp[i - 0440H + 0E0H] := i |
END; |
C.StringLn(str); |
C.String(" file: "); C.StringLn(fname); |
UTILS.Exit(1) |
END errormsg; |
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); |
n := 0F0H; |
Init8(cp, n, 0401H, 0451H, 0404H, 0454H, 0407H, 0457H, 040EH, 045EH); |
Init8(cp, n, 00B0H, 2219H, 00B7H, 221AH, 2116H, 00A4H, 25A0H, 00A0H); |
PROCEDURE error1* (s1: ARRAY OF CHAR); |
BEGIN |
C.Ln; |
C.StringLn(s1); |
UTILS.Exit(1) |
END error1; |
InitCP(cp) |
END InitCP866; |
PROCEDURE concat(VAR L: STRING; R: STRING); |
VAR i, n, pos: INTEGER; |
PROCEDURE error3* (s1, s2, s3: ARRAY OF CHAR); |
BEGIN |
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; |
C.Ln; |
C.String(s1); C.String(s2); C.StringLn(s3); |
UTILS.Exit(1) |
END error3; |
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 ErrorMsg*(code: INTEGER; VAR msg: ARRAY OF CHAR); |
VAR str: STRING; |
PROCEDURE error5* (s1, s2, s3, s4, s5: ARRAY OF CHAR); |
BEGIN |
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 := "᫨誮¬ ¤«¨ ï áâப®¢ ï ª®áâ â " |
C.Ln; |
C.String(s1); C.String(s2); C.String(s3); C.String(s4); C.StringLn(s5); |
UTILS.Exit(1) |
END error5; |
| 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/FILES.ob07 |
---|
0,0 → 1,219 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE FILES; |
IMPORT UTILS, C := COLLECTIONS, CONSOLE; |
TYPE |
FILE* = POINTER TO RECORD (C.ITEM) |
ptr: INTEGER; |
buffer: ARRAY 64*1024 OF BYTE; |
count: INTEGER |
END; |
VAR |
files: C.COLLECTION; |
PROCEDURE copy (src: ARRAY OF BYTE; src_idx: INTEGER; VAR dst: ARRAY OF BYTE; dst_idx: INTEGER; bytes: INTEGER); |
BEGIN |
WHILE bytes > 0 DO |
dst[dst_idx] := src[src_idx]; |
INC(dst_idx); |
INC(src_idx); |
DEC(bytes) |
END |
END copy; |
PROCEDURE flush (file: FILE): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF file # NIL THEN |
res := UTILS.FileWrite(file.ptr, file.buffer, file.count); |
IF res < 0 THEN |
res := 0 |
END |
ELSE |
res := 0 |
END |
RETURN res |
END flush; |
PROCEDURE NewFile (): FILE; |
VAR |
file: FILE; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(files); |
IF citem = NIL THEN |
NEW(file) |
ELSE |
file := citem(FILE) |
END |
RETURN file |
END NewFile; |
PROCEDURE create* (name: ARRAY OF CHAR): FILE; |
VAR |
file: FILE; |
ptr: INTEGER; |
BEGIN |
ptr := UTILS.FileCreate(name); |
IF ptr > 0 THEN |
file := NewFile(); |
file.ptr := ptr; |
file.count := 0 |
ELSE |
file := NIL |
END |
RETURN file |
END create; |
PROCEDURE open* (name: ARRAY OF CHAR): FILE; |
VAR |
file: FILE; |
ptr: INTEGER; |
BEGIN |
ptr := UTILS.FileOpen(name); |
IF ptr > 0 THEN |
file := NewFile(); |
file.ptr := ptr; |
file.count := -1 |
ELSE |
file := NIL |
END |
RETURN file |
END open; |
PROCEDURE close* (VAR file: FILE); |
VAR |
n: INTEGER; |
BEGIN |
IF file # NIL THEN |
IF file.count > 0 THEN |
n := flush(file) |
END; |
file.count := -1; |
UTILS.FileClose(file.ptr); |
file.ptr := 0; |
C.push(files, file); |
file := NIL |
END |
END close; |
PROCEDURE read* (file: FILE; VAR chunk: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF file # NIL THEN |
res := UTILS.FileRead(file.ptr, chunk, MAX(MIN(bytes, LEN(chunk)), 0)); |
IF res < 0 THEN |
res := 0 |
END |
ELSE |
res := 0 |
END |
RETURN res |
END read; |
PROCEDURE write* (file: FILE; chunk: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
VAR |
free, n, k, res, idx: INTEGER; |
BEGIN |
idx := 0; |
res := 0; |
IF (file # NIL) & (file.count >= 0) THEN |
free := LEN(file.buffer) - file.count; |
WHILE bytes > 0 DO |
n := MIN(free, bytes); |
copy(chunk, idx, file.buffer, file.count, n); |
INC(res, n); |
DEC(free, n); |
DEC(bytes, n); |
INC(idx, n); |
INC(file.count, n); |
IF free = 0 THEN |
k := flush(file); |
IF k # LEN(file.buffer) THEN |
bytes := 0; |
DEC(res, n) |
ELSE |
file.count := 0; |
free := LEN(file.buffer) |
END |
END |
END |
END |
RETURN res |
END write; |
PROCEDURE WriteByte* (file: FILE; byte: BYTE): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := TRUE; |
IF (file # NIL) & (file.count >= 0) THEN |
IF file.count = LEN(file.buffer) THEN |
IF flush(file) # LEN(file.buffer) THEN |
res := FALSE |
ELSE |
file.buffer[0] := byte; |
file.count := 1 |
END |
ELSE |
file.buffer[file.count] := byte; |
INC(file.count) |
END |
ELSE |
res := FALSE |
END |
RETURN res |
END WriteByte; |
BEGIN |
files := C.create() |
END FILES. |
/programs/develop/oberon07/Source/KOS.ob07 |
---|
0,0 → 1,218 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE KOS; |
IMPORT BIN, WR := WRITER, LISTS, CHL := CHUNKLISTS; |
CONST |
HEADER_SIZE = 36; |
SIZE_OF_DWORD = 4; |
TYPE |
FILE = WR.FILE; |
HEADER = RECORD |
menuet01: ARRAY 9 OF CHAR; |
ver, start, size, mem, sp, param, path: INTEGER |
END; |
PROCEDURE align (n, _align: INTEGER): INTEGER; |
BEGIN |
IF n MOD _align # 0 THEN |
n := n + _align - (n MOD _align) |
END |
RETURN n |
END align; |
PROCEDURE Import* (program: BIN.PROGRAM; idata: INTEGER; VAR ImportTable: CHL.INTLIST; VAR len, libcount, size: INTEGER); |
VAR |
i: INTEGER; |
import: BIN.IMPRT; |
BEGIN |
libcount := 0; |
import := program.imp_list.first(BIN.IMPRT); |
WHILE import # NIL DO |
IF import.label = 0 THEN |
INC(libcount) |
END; |
import := import.next(BIN.IMPRT) |
END; |
len := libcount * 2 + 2; |
size := (LISTS.count(program.imp_list) + len + 1) * SIZE_OF_DWORD; |
ImportTable := CHL.CreateIntList(); |
FOR i := 0 TO size DIV SIZE_OF_DWORD - 1 DO |
CHL.PushInt(ImportTable, 0) |
END; |
i := 0; |
import := program.imp_list.first(BIN.IMPRT); |
WHILE import # NIL DO |
IF import.label = 0 THEN |
CHL.SetInt(ImportTable, len, 0); |
INC(len); |
CHL.SetInt(ImportTable, i, idata + len * SIZE_OF_DWORD); |
INC(i); |
CHL.SetInt(ImportTable, i, import.nameoffs + size + idata); |
INC(i) |
ELSE |
CHL.SetInt(ImportTable, len, import.nameoffs + size + idata); |
import.label := len * SIZE_OF_DWORD; |
INC(len) |
END; |
import := import.next(BIN.IMPRT) |
END; |
CHL.SetInt(ImportTable, len, 0); |
CHL.SetInt(ImportTable, i, 0); |
CHL.SetInt(ImportTable, i + 1, 0); |
INC(len); |
size := size + CHL.Length(program.import) |
END Import; |
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR); |
CONST |
PARAM_SIZE = 2048; |
FileAlignment = 16; |
VAR |
header: HEADER; |
base, text, data, idata, bss: INTEGER; |
reloc: BIN.RELOC; |
iproc: BIN.IMPRT; |
L: INTEGER; |
delta: INTEGER; |
i: INTEGER; |
File: FILE; |
ImportTable: CHL.INTLIST; |
ILen, libcount, isize: INTEGER; |
icount, dcount, ccount: INTEGER; |
BEGIN |
base := 0; |
icount := CHL.Length(program.import); |
dcount := CHL.Length(program.data); |
ccount := CHL.Length(program.code); |
text := base + HEADER_SIZE; |
data := align(text + ccount, FileAlignment); |
idata := align(data + dcount, FileAlignment); |
Import(program, idata, ImportTable, ILen, libcount, isize); |
bss := align(idata + isize, FileAlignment); |
header.menuet01 := "MENUET01"; |
header.ver := 1; |
header.start := text; |
header.size := idata + isize - base; |
header.mem := align(header.size + program.stack + program.bss + PARAM_SIZE * 2 + 4096, FileAlignment); |
header.sp := base + header.mem - PARAM_SIZE * 2; |
header.param := header.sp; |
header.path := header.param + PARAM_SIZE; |
reloc := program.rel_list.first(BIN.RELOC); |
WHILE reloc # NIL DO |
L := BIN.get32le(program.code, reloc.offset); |
delta := 3 - reloc.offset - text; |
CASE reloc.opcode OF |
|BIN.RIMP: |
iproc := BIN.GetIProc(program, L); |
BIN.put32le(program.code, reloc.offset, idata + iproc.label) |
|BIN.RBSS: |
BIN.put32le(program.code, reloc.offset, L + bss) |
|BIN.RDATA: |
BIN.put32le(program.code, reloc.offset, L + data) |
|BIN.RCODE: |
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + text) |
|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) |
|BIN.PICIMP: |
iproc := BIN.GetIProc(program, L); |
BIN.put32le(program.code, reloc.offset, idata + iproc.label + delta) |
|BIN.IMPTAB: |
BIN.put32le(program.code, reloc.offset, idata + delta) |
END; |
reloc := reloc.next(BIN.RELOC) |
END; |
File := WR.Create(FileName); |
FOR i := 0 TO 7 DO |
WR.WriteByte(File, ORD(header.menuet01[i])) |
END; |
WR.Write32LE(File, header.ver); |
WR.Write32LE(File, header.start); |
WR.Write32LE(File, header.size); |
WR.Write32LE(File, header.mem); |
WR.Write32LE(File, header.sp); |
WR.Write32LE(File, header.param); |
WR.Write32LE(File, header.path); |
CHL.WriteToFile(File, program.code); |
WR.Padding(File, FileAlignment); |
CHL.WriteToFile(File, program.data); |
WR.Padding(File, FileAlignment); |
FOR i := 0 TO ILen - 1 DO |
WR.Write32LE(File, CHL.GetInt(ImportTable, i)) |
END; |
CHL.WriteToFile(File, program.import); |
WR.Close(File) |
END write; |
END KOS. |
/programs/develop/oberon07/Source/LISTS.ob07 |
---|
0,0 → 1,184 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE LISTS; |
IMPORT C := COLLECTIONS; |
TYPE |
ITEM* = POINTER TO RECORD (C.ITEM) |
prev*, next*: ITEM |
END; |
LIST* = POINTER TO RECORD |
first*, last*: ITEM |
END; |
PROCEDURE push* (list: LIST; item: ITEM); |
BEGIN |
ASSERT(list # NIL); |
ASSERT(item # NIL); |
IF list.first = NIL THEN |
list.first := item; |
list.last := item; |
item.prev := NIL; |
item.next := NIL |
ELSE |
ASSERT(list.last # NIL); |
item.prev := list.last; |
list.last.next := item; |
item.next := NIL; |
list.last := item |
END |
END push; |
PROCEDURE pop* (list: LIST): ITEM; |
VAR |
last: ITEM; |
BEGIN |
ASSERT(list # NIL); |
last := list.last; |
IF last # NIL THEN |
IF last = list.first THEN |
list.first := NIL; |
list.last := NIL |
ELSE |
list.last := last.prev; |
list.last.next := NIL |
END; |
last.next := NIL; |
last.prev := NIL |
END |
RETURN last |
END pop; |
PROCEDURE insert* (list: LIST; cur, nov: ITEM); |
VAR |
next: ITEM; |
BEGIN |
ASSERT(list # NIL); |
ASSERT(nov # NIL); |
ASSERT(cur # NIL); |
next := cur.next; |
IF next # NIL THEN |
next.prev := nov; |
nov.next := next; |
cur.next := nov; |
nov.prev := cur |
ELSE |
push(list, nov) |
END |
END insert; |
PROCEDURE insertL* (list: LIST; cur, nov: ITEM); |
VAR |
prev: ITEM; |
BEGIN |
ASSERT(list # NIL); |
ASSERT(nov # NIL); |
ASSERT(cur # NIL); |
prev := cur.prev; |
IF prev # NIL THEN |
prev.next := nov; |
nov.prev := prev; |
cur.prev := nov; |
nov.next := cur |
ELSE |
nov.prev := NIL; |
cur.prev := nov; |
nov.next := cur; |
list.first := nov |
END |
END insertL; |
PROCEDURE delete* (list: LIST; item: ITEM); |
VAR |
prev, next: ITEM; |
BEGIN |
ASSERT(list # NIL); |
ASSERT(item # NIL); |
prev := item.prev; |
next := item.next; |
IF (next # NIL) & (prev # NIL) THEN |
prev.next := next; |
next.prev := prev |
ELSIF (next = NIL) & (prev = NIL) THEN |
list.first := NIL; |
list.last := NIL |
ELSIF (next = NIL) & (prev # NIL) THEN |
prev.next := NIL; |
list.last := prev |
ELSIF (next # NIL) & (prev = NIL) THEN |
next.prev := NIL; |
list.first := next |
END |
END delete; |
PROCEDURE count* (list: LIST): INTEGER; |
VAR |
item: ITEM; |
res: INTEGER; |
BEGIN |
ASSERT(list # NIL); |
res := 0; |
item := list.first; |
WHILE item # NIL DO |
INC(res); |
item := item.next |
END |
RETURN res |
END count; |
PROCEDURE create* (list: LIST): LIST; |
BEGIN |
IF list = NIL THEN |
NEW(list) |
END; |
list.first := NIL; |
list.last := NIL |
RETURN list |
END create; |
END LISTS. |
/programs/develop/oberon07/Source/MACHINE.ob07 |
---|
0,0 → 1,110 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE MACHINE; |
IMPORT UTILS; |
CONST |
min32* = -2147483647-1; |
max32* = 2147483647; |
VAR |
target*: |
RECORD |
bit_depth*, |
maxInt*, |
minInt*, |
maxSet*, |
maxHex*: INTEGER; |
maxReal*: REAL |
END; |
_64to32*: BOOLEAN; |
PROCEDURE SetBitDepth* (pBitDepth: INTEGER); |
BEGIN |
ASSERT(pBitDepth <= UTILS.bit_depth); |
ASSERT((pBitDepth = 32) OR (pBitDepth = 64)); |
_64to32 := (UTILS.bit_depth = 64) & (pBitDepth = 32); |
target.bit_depth := pBitDepth; |
target.maxSet := pBitDepth - 1; |
target.maxHex := pBitDepth DIV 4; |
target.minInt := ASR(UTILS.minint, UTILS.bit_depth - pBitDepth); |
target.maxInt := ASR(UTILS.maxint, UTILS.bit_depth - pBitDepth); |
target.maxReal := 1.9; |
PACK(target.maxReal, 1023); |
END SetBitDepth; |
PROCEDURE Byte* (n: INTEGER; idx: INTEGER): BYTE; |
BEGIN |
WHILE idx > 0 DO |
n := ASR(n, 8); |
DEC(idx) |
END |
RETURN ORD(BITS(n) * {0..7}) |
END Byte; |
PROCEDURE Align* (VAR bytes: INTEGER; align: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
IF bytes MOD align # 0 THEN |
res := UTILS.maxint - bytes >= align - (bytes MOD align); |
IF res THEN |
bytes := bytes + align - (bytes MOD align) |
END |
ELSE |
res := TRUE |
END |
RETURN res |
END Align; |
PROCEDURE Int32To64* (value: INTEGER): INTEGER; |
BEGIN |
IF UTILS.bit_depth = 64 THEN |
value := LSL(value, 16); |
value := LSL(value, 16); |
value := ASR(value, 16); |
value := ASR(value, 16) |
END |
RETURN value |
END Int32To64; |
PROCEDURE Int64To32* (value: INTEGER): INTEGER; |
BEGIN |
IF UTILS.bit_depth = 64 THEN |
value := LSL(value, 16); |
value := LSL(value, 16); |
value := LSR(value, 16); |
value := LSR(value, 16) |
END |
RETURN value |
END Int64To32; |
END MACHINE. |
/programs/develop/oberon07/Source/MSCOFF.ob07 |
---|
0,0 → 1,316 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE MSCOFF; |
IMPORT BIN, PE32, KOS, WR := WRITER, UTILS, ERRORS, LISTS, CHL := CHUNKLISTS; |
CONST |
SIZE_OF_DWORD = 4; |
(* SectionHeader.Characteristics *) |
SHC_flat = 040500020H; |
SHC_data = 0C0500040H; |
SHC_bss = 0C03000C0H; |
TYPE |
FH = PE32.IMAGE_FILE_HEADER; |
SH = PE32.IMAGE_SECTION_HEADER; |
PROCEDURE WriteReloc (File: WR.FILE; VirtualAddress, SymbolTableIndex, Type: INTEGER); |
BEGIN |
WR.Write32LE(File, VirtualAddress); |
WR.Write32LE(File, SymbolTableIndex); |
WR.Write16LE(File, Type) |
END WriteReloc; |
PROCEDURE Reloc (program: BIN.PROGRAM; File: WR.FILE); |
VAR |
reloc: BIN.RELOC; |
BEGIN |
reloc := program.rel_list.first(BIN.RELOC); |
WHILE reloc # NIL DO |
CASE reloc.opcode OF |
|BIN.RIMP, BIN.IMPTAB: |
WriteReloc(File, reloc.offset, 4, 6) |
|BIN.RBSS: |
WriteReloc(File, reloc.offset, 5, 6) |
|BIN.RDATA: |
WriteReloc(File, reloc.offset, 2, 6) |
|BIN.RCODE: |
WriteReloc(File, reloc.offset, 1, 6) |
END; |
reloc := reloc.next(BIN.RELOC) |
END; |
END Reloc; |
PROCEDURE RelocCount (program: BIN.PROGRAM): INTEGER; |
VAR |
reloc: BIN.RELOC; |
iproc: BIN.IMPRT; |
res, L: INTEGER; |
BEGIN |
res := 0; |
reloc := program.rel_list.first(BIN.RELOC); |
WHILE reloc # NIL DO |
INC(res); |
IF reloc.opcode = BIN.RIMP THEN |
L := BIN.get32le(program.code, reloc.offset); |
iproc := BIN.GetIProc(program, L); |
BIN.put32le(program.code, reloc.offset, iproc.label) |
END; |
IF reloc.opcode = BIN.RCODE THEN |
L := BIN.get32le(program.code, reloc.offset); |
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L)) |
END; |
reloc := reloc.next(BIN.RELOC) |
END |
RETURN res |
END RelocCount; |
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; ver: INTEGER); |
VAR |
File: WR.FILE; |
exp: BIN.EXPRT; |
n, i: INTEGER; |
szversion: PE32.NAME; |
ImportTable: CHL.INTLIST; |
ILen, LibCount, isize: INTEGER; |
ExpCount: INTEGER; |
icount, ecount, dcount, ccount: INTEGER; |
FileHeader: FH; |
flat, data, edata, idata, bss: SH; |
PROCEDURE ICount (ImportTable: CHL.INTLIST; ILen: INTEGER): INTEGER; |
VAR |
i, res: INTEGER; |
BEGIN |
res := 0; |
FOR i := 0 TO ILen - 1 DO |
IF CHL.GetInt(ImportTable, i) # 0 THEN |
INC(res) |
END |
END |
RETURN res |
END ICount; |
PROCEDURE SetNumberOfRelocations (VAR section: SH; NumberOfRelocations: INTEGER); |
BEGIN |
IF NumberOfRelocations >= 65536 THEN |
ERRORS.error1("too many relocations") |
END; |
section.NumberOfRelocations := WCHR(NumberOfRelocations) |
END SetNumberOfRelocations; |
BEGIN |
szversion := "version"; |
ASSERT(LENGTH(szversion) = 7); |
KOS.Import(program, 0, ImportTable, ILen, LibCount, isize); |
ExpCount := LISTS.count(program.exp_list); |
icount := CHL.Length(program.import); |
dcount := CHL.Length(program.data); |
ccount := CHL.Length(program.code); |
ecount := CHL.Length(program.export); |
FileHeader.Machine := 014CX; |
FileHeader.NumberOfSections := 5X; |
FileHeader.TimeDateStamp := UTILS.UnixTime(); |
//FileHeader.PointerToSymbolTable := 0; |
FileHeader.NumberOfSymbols := 6; |
FileHeader.SizeOfOptionalHeader := 0X; |
FileHeader.Characteristics := 0184X; |
flat.Name := ".flat"; |
flat.VirtualSize := 0; |
flat.VirtualAddress := 0; |
flat.SizeOfRawData := ccount; |
flat.PointerToRawData := ORD(FileHeader.NumberOfSections) * PE32.SIZE_OF_IMAGE_SECTION_HEADER + PE32.SIZE_OF_IMAGE_FILE_HEADER; |
//flat.PointerToRelocations := 0; |
flat.PointerToLinenumbers := 0; |
SetNumberOfRelocations(flat, RelocCount(program)); |
flat.NumberOfLinenumbers := 0X; |
flat.Characteristics := SHC_flat; |
data.Name := ".data"; |
data.VirtualSize := 0; |
data.VirtualAddress := 0; |
data.SizeOfRawData := dcount; |
data.PointerToRawData := flat.PointerToRawData + flat.SizeOfRawData; |
data.PointerToRelocations := 0; |
data.PointerToLinenumbers := 0; |
data.NumberOfRelocations := 0X; |
data.NumberOfLinenumbers := 0X; |
data.Characteristics := SHC_data; |
edata.Name := ".edata"; |
edata.VirtualSize := 0; |
edata.VirtualAddress := 0; |
edata.SizeOfRawData := ((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD + LENGTH(szversion) + 1 + ecount; |
edata.PointerToRawData := data.PointerToRawData + data.SizeOfRawData; |
//edata.PointerToRelocations := 0; |
edata.PointerToLinenumbers := 0; |
SetNumberOfRelocations(edata, ExpCount * 2 + 1); |
edata.NumberOfLinenumbers := 0X; |
edata.Characteristics := SHC_data; |
idata.Name := ".idata"; |
idata.VirtualSize := 0; |
idata.VirtualAddress := 0; |
idata.SizeOfRawData := isize; |
idata.PointerToRawData := edata.PointerToRawData + edata.SizeOfRawData; |
//idata.PointerToRelocations := 0; |
idata.PointerToLinenumbers := 0; |
SetNumberOfRelocations(idata, ICount(ImportTable, ILen)); |
idata.NumberOfLinenumbers := 0X; |
idata.Characteristics := SHC_data; |
bss.Name := ".bss"; |
bss.VirtualSize := 0; |
bss.VirtualAddress := 0; |
bss.SizeOfRawData := program.bss; |
bss.PointerToRawData := 0; |
bss.PointerToRelocations := 0; |
bss.PointerToLinenumbers := 0; |
bss.NumberOfRelocations := 0X; |
bss.NumberOfLinenumbers := 0X; |
bss.Characteristics := SHC_bss; |
flat.PointerToRelocations := idata.PointerToRawData + idata.SizeOfRawData; |
edata.PointerToRelocations := flat.PointerToRelocations + ORD(flat.NumberOfRelocations) * 10; |
idata.PointerToRelocations := edata.PointerToRelocations + ORD(edata.NumberOfRelocations) * 10; |
FileHeader.PointerToSymbolTable := idata.PointerToRelocations + ORD(idata.NumberOfRelocations) * 10; |
File := WR.Create(FileName); |
PE32.WriteFileHeader(File, FileHeader); |
PE32.WriteSectionHeader(File, flat); |
PE32.WriteSectionHeader(File, data); |
PE32.WriteSectionHeader(File, edata); |
PE32.WriteSectionHeader(File, idata); |
PE32.WriteSectionHeader(File, bss); |
CHL.WriteToFile(File, program.code); |
CHL.WriteToFile(File, program.data); |
exp := program.exp_list.first(BIN.EXPRT); |
WHILE exp # NIL DO |
WR.Write32LE(File, exp.nameoffs + edata.SizeOfRawData - ecount); |
WR.Write32LE(File, exp.label); |
exp := exp.next(BIN.EXPRT) |
END; |
WR.Write32LE(File, ((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD); |
WR.Write32LE(File, ver); |
WR.Write32LE(File, 0); |
PE32.WriteName(File, szversion); |
CHL.WriteToFile(File, program.export); |
FOR i := 0 TO ILen - 1 DO |
WR.Write32LE(File, CHL.GetInt(ImportTable, i)) |
END; |
CHL.WriteToFile(File, program.import); |
Reloc(program, File); |
n := 0; |
exp := program.exp_list.first(BIN.EXPRT); |
WHILE exp # NIL DO |
WriteReloc(File, n, 3, 6); |
INC(n, 4); |
WriteReloc(File, n, 1, 6); |
INC(n, 4); |
exp := exp.next(BIN.EXPRT) |
END; |
WriteReloc(File, n, 3, 6); |
i := 0; |
WHILE i < LibCount * 2 DO |
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6); |
INC(i); |
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6); |
INC(i) |
END; |
FOR i := LibCount * 2 TO ILen - 1 DO |
IF CHL.GetInt(ImportTable, i) # 0 THEN |
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6) |
END |
END; |
PE32.WriteName(File, "EXPORTS"); |
WriteReloc(File, 0, 3, 2); |
PE32.WriteName(File, ".flat"); |
WriteReloc(File, 0, 1, 3); |
PE32.WriteName(File, ".data"); |
WriteReloc(File, 0, 2, 3); |
PE32.WriteName(File, ".edata"); |
WriteReloc(File, 0, 3, 3); |
PE32.WriteName(File, ".idata"); |
WriteReloc(File, 0, 4, 3); |
PE32.WriteName(File, ".bss"); |
WriteReloc(File, 0, 5, 3); |
WR.Write32LE(File, 4); |
WR.Close(File) |
END write; |
END MSCOFF. |
/programs/develop/oberon07/Source/PARS.ob07 |
---|
0,0 → 1,1166 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE PARS; |
IMPORT PROG, SCAN, ARITH, STRINGS, ERRORS, LISTS, CODE, CONSOLE, PATHS, MACHINE, C := COLLECTIONS, mConst := CONSTANTS; |
CONST |
eCONST* = 1; eTYPE* = 2; eVAR* = 3; eEXPR* = 4; |
eVREC* = 5; ePROC* = 6; eVPAR* = 7; ePARAM* = 8; |
eSTPROC* = 9; eSTFUNC* = 10; eSYSFUNC* = 11; eSYSPROC* = 12; |
eIMP* = 13; |
TYPE |
PATH* = PATHS.PATH; |
PARSER* = POINTER TO rPARSER; |
EXPR* = RECORD |
obj*: INTEGER; |
type*: PROG.TYPE_; |
value*: ARITH.VALUE; |
stproc*: INTEGER; |
readOnly*: BOOLEAN; |
ident*: PROG.IDENT |
END; |
STATPROC = PROCEDURE (parser: PARSER); |
EXPRPROC = PROCEDURE (parser: PARSER; VAR e: EXPR); |
RETPROC = PROCEDURE (parser: PARSER; e: EXPR; t: PROG.TYPE_; pos: SCAN.POSITION): BOOLEAN; |
rPARSER = RECORD (C.ITEM) |
fname*: PATH; |
path: PATH; |
lib_path: PATH; |
ext: PATH; |
modname: PATH; |
scanner: SCAN.SCANNER; |
lex*: SCAN.LEX; |
sym*: INTEGER; |
unit*: PROG.UNIT; |
constexp*: BOOLEAN; |
main*: BOOLEAN; |
open*: PROCEDURE (parser: PARSER; modname: ARRAY OF CHAR): BOOLEAN; |
parse*: PROCEDURE (parser: PARSER); |
StatSeq*: STATPROC; |
expression*: EXPRPROC; |
designator*: EXPRPROC; |
chkreturn: RETPROC; |
create*: PROCEDURE (path, lib_path: PATH; StatSeq: STATPROC; expression, designator: EXPRPROC; chkreturn: RETPROC): PARSER |
END; |
VAR |
program*: PROG.PROGRAM; |
parsers: C.COLLECTION; |
PROCEDURE destroy* (VAR parser: PARSER); |
BEGIN |
IF parser.scanner # NIL THEN |
SCAN.close(parser.scanner) |
END; |
C.push(parsers, parser); |
parser := NIL |
END destroy; |
PROCEDURE error* (parser: PARSER; pos: SCAN.POSITION; errno: INTEGER); |
BEGIN |
ERRORS.errormsg(parser.fname, pos.line, pos.col, errno) |
END error; |
PROCEDURE check* (condition: BOOLEAN; parser: PARSER; pos: SCAN.POSITION; errno: INTEGER); |
BEGIN |
IF ~condition THEN |
error(parser, pos, errno) |
END |
END check; |
PROCEDURE check1* (condition: BOOLEAN; parser: PARSER; errno: INTEGER); |
BEGIN |
IF ~condition THEN |
error(parser, parser.lex.pos, errno) |
END |
END check1; |
PROCEDURE getpos (parser: PARSER; VAR pos: SCAN.POSITION); |
BEGIN |
pos := parser.lex.pos |
END getpos; |
PROCEDURE Next* (parser: PARSER); |
VAR |
errno: INTEGER; |
BEGIN |
SCAN.Next(parser.scanner, parser.lex); |
errno := parser.lex.error; |
IF errno # 0 THEN |
check1(FALSE, parser, errno) |
END; |
parser.sym := parser.lex.sym |
END Next; |
PROCEDURE NextPos* (parser: PARSER; VAR pos: SCAN.POSITION); |
BEGIN |
Next(parser); |
pos := parser.lex.pos |
END NextPos; |
PROCEDURE checklex* (parser: PARSER; sym: INTEGER); |
VAR |
err: INTEGER; |
BEGIN |
IF parser.sym # sym THEN |
CASE sym OF |
|SCAN.lxCOMMA: err := 65 |
|SCAN.lxRROUND: err := 33 |
|SCAN.lxPOINT: err := 26 |
|SCAN.lxIDENT: err := 22 |
|SCAN.lxRSQUARE: err := 71 |
|SCAN.lxRCURLY: err := 35 |
|SCAN.lxUNDEF: err := 34 |
|SCAN.lxTHEN: err := 88 |
|SCAN.lxEND: err := 27 |
|SCAN.lxDO: err := 89 |
|SCAN.lxUNTIL: err := 90 |
|SCAN.lxCOLON: err := 53 |
|SCAN.lxOF: err := 67 |
|SCAN.lxASSIGN: err := 96 |
|SCAN.lxTO: err := 57 |
|SCAN.lxLROUND: err := 64 |
|SCAN.lxEQ: err := 32 |
|SCAN.lxSEMI: err := 24 |
|SCAN.lxRETURN: err := 38 |
|SCAN.lxMODULE: err := 21 |
|SCAN.lxSTRING: err := 66 |
END; |
check1(FALSE, parser, err) |
END |
END checklex; |
PROCEDURE ExpectSym* (parser: PARSER; sym: INTEGER); |
BEGIN |
Next(parser); |
checklex(parser, sym) |
END ExpectSym; |
PROCEDURE ImportList (parser: PARSER); |
VAR |
name: SCAN.IDENT; |
parser2: PARSER; |
pos: SCAN.POSITION; |
alias: BOOLEAN; |
unit: PROG.UNIT; |
ident: PROG.IDENT; |
units: PROG.UNITS; |
BEGIN |
units := program.units; |
alias := FALSE; |
REPEAT |
ExpectSym(parser, SCAN.lxIDENT); |
name := parser.lex.ident; |
getpos(parser, pos); |
IF ~alias THEN |
ident := parser.unit.idents.add(parser.unit, name, PROG.idMODULE); |
check(ident # NIL, parser, pos, 30) |
END; |
Next(parser); |
IF (parser.sym = SCAN.lxCOMMA) OR (parser.sym = SCAN.lxSEMI) THEN |
alias := FALSE; |
unit := units.get(units, name); |
IF unit # NIL THEN |
check(unit.closed, parser, pos, 31) |
ELSE |
parser2 := parser.create(parser.path, parser.lib_path, |
parser.StatSeq, parser.expression, parser.designator, parser.chkreturn); |
IF ~parser2.open(parser2, name.s) THEN |
IF parser.path # parser.lib_path THEN |
destroy(parser2); |
parser2 := parser.create(parser.lib_path, parser.lib_path, |
parser.StatSeq, parser.expression, parser.designator, parser.chkreturn); |
check(parser2.open(parser2, name.s), parser, pos, 29) |
ELSE |
check(FALSE, parser, pos, 29) |
END |
END; |
parser2.parse(parser2); |
unit := parser2.unit; |
destroy(parser2) |
END; |
IF unit = program.sysunit THEN |
parser.unit.sysimport := TRUE |
END; |
ident.unit := unit |
ELSIF parser.sym = SCAN.lxASSIGN THEN |
alias := TRUE |
ELSE |
check1(FALSE, parser, 28) |
END |
UNTIL parser.sym = SCAN.lxSEMI; |
Next(parser) |
END ImportList; |
PROCEDURE QIdent (parser: PARSER; forward: BOOLEAN): PROG.IDENT; |
VAR |
ident: PROG.IDENT; |
unit: PROG.UNIT; |
BEGIN |
ASSERT(parser.sym = SCAN.lxIDENT); |
ident := parser.unit.idents.get(parser.unit, parser.lex.ident, FALSE); |
IF ~forward THEN |
check1(ident # NIL, parser, 48) |
END; |
IF (ident # NIL) & (ident.typ = PROG.idMODULE) THEN |
unit := ident.unit; |
ExpectSym(parser, SCAN.lxPOINT); |
ExpectSym(parser, SCAN.lxIDENT); |
ident := unit.idents.get(unit, parser.lex.ident, FALSE); |
check1((ident # NIL) & ident.export, parser, 48) |
END |
RETURN ident |
END QIdent; |
PROCEDURE strcmp* (VAR v: ARITH.VALUE; v2: ARITH.VALUE; operator: INTEGER); |
VAR |
str: SCAN.LEXSTR; |
string1, string2: SCAN.IDENT; |
bool: BOOLEAN; |
BEGIN |
IF v.typ = ARITH.tCHAR THEN |
ASSERT(v2.typ = ARITH.tSTRING); |
ARITH.charToStr(v, str); |
string1 := SCAN.enterid(str); |
string2 := v2.string(SCAN.IDENT) |
END; |
IF v2.typ = ARITH.tCHAR THEN |
ASSERT(v.typ = ARITH.tSTRING); |
ARITH.charToStr(v2, str); |
string2 := SCAN.enterid(str); |
string1 := v.string(SCAN.IDENT) |
END; |
IF v.typ = v2.typ THEN |
string1 := v.string(SCAN.IDENT); |
string2 := v2.string(SCAN.IDENT) |
END; |
CASE operator OF |
|SCAN.lxEQ: bool := string1.s = string2.s |
|SCAN.lxNE: bool := string1.s # string2.s |
|SCAN.lxLT: bool := string1.s < string2.s |
|SCAN.lxGT: bool := string1.s > string2.s |
|SCAN.lxLE: bool := string1.s <= string2.s |
|SCAN.lxGE: bool := string1.s >= string2.s |
END; |
ARITH.setbool(v, bool) |
END strcmp; |
PROCEDURE ConstExpression* (parser: PARSER; VAR v: ARITH.VALUE); |
VAR |
e: EXPR; |
pos: SCAN.POSITION; |
BEGIN |
getpos(parser, pos); |
parser.constexp := TRUE; |
parser.expression(parser, e); |
parser.constexp := FALSE; |
check(e.obj = eCONST, parser, pos, 62); |
v := e.value |
END ConstExpression; |
PROCEDURE FieldList (parser: PARSER; rec: PROG.TYPE_); |
VAR |
name: SCAN.IDENT; |
export: BOOLEAN; |
pos: SCAN.POSITION; |
BEGIN |
ASSERT(parser.sym = SCAN.lxIDENT); |
WHILE parser.sym = SCAN.lxIDENT DO |
getpos(parser, pos); |
name := parser.lex.ident; |
Next(parser); |
export := parser.sym = SCAN.lxMUL; |
IF export THEN |
check1(parser.unit.scopeLvl = 0, parser, 61); |
Next(parser) |
END; |
check(rec.fields.add(rec, name, export), parser, pos, 30); |
IF parser.sym = SCAN.lxCOMMA THEN |
ExpectSym(parser, SCAN.lxIDENT) |
ELSE |
checklex(parser, SCAN.lxCOLON) |
END |
END |
END FieldList; |
PROCEDURE FormalParameters (parser: PARSER; type: PROG.TYPE_); |
VAR |
ident: PROG.IDENT; |
PROCEDURE FPSection (parser: PARSER; type: PROG.TYPE_); |
VAR |
ident: PROG.IDENT; |
exit: BOOLEAN; |
vPar: BOOLEAN; |
dim: INTEGER; |
t0, t1: PROG.TYPE_; |
BEGIN |
vPar := parser.sym = SCAN.lxVAR; |
IF vPar THEN |
Next(parser) |
END; |
checklex(parser, SCAN.lxIDENT); |
exit := FALSE; |
WHILE (parser.sym = SCAN.lxIDENT) & ~exit DO |
check1(type.params.add(type, parser.lex.ident, vPar), parser, 30); |
Next(parser); |
IF parser.sym = SCAN.lxCOMMA THEN |
ExpectSym(parser, SCAN.lxIDENT) |
ELSIF parser.sym = SCAN.lxCOLON THEN |
Next(parser); |
dim := 0; |
WHILE parser.sym = SCAN.lxARRAY DO |
INC(dim); |
check1(dim <= PROG.MAXARRDIM, parser, 84); |
ExpectSym(parser, SCAN.lxOF); |
Next(parser) |
END; |
checklex(parser, SCAN.lxIDENT); |
ident := QIdent(parser, FALSE); |
check1(ident.typ = PROG.idTYPE, parser, 68); |
t0 := ident.type; |
t1 := t0; |
WHILE dim > 0 DO |
t1 := program.enterType(program, PROG.tARRAY, -1, 0, parser.unit); |
t1.base := t0; |
t0 := t1; |
DEC(dim) |
END; |
type.params.set(type, t1); |
Next(parser); |
exit := TRUE |
ELSE |
checklex(parser, SCAN.lxCOLON) |
END |
END |
END FPSection; |
BEGIN |
IF parser.sym = SCAN.lxLROUND THEN |
Next(parser); |
IF (parser.sym = SCAN.lxVAR) OR (parser.sym = SCAN.lxIDENT) THEN |
FPSection(parser, type); |
WHILE parser.sym = SCAN.lxSEMI DO |
Next(parser); |
FPSection(parser, type) |
END |
END; |
checklex(parser, SCAN.lxRROUND); |
Next(parser); |
IF parser.sym = SCAN.lxCOLON THEN |
ExpectSym(parser, SCAN.lxIDENT); |
ident := QIdent(parser, FALSE); |
check1(ident.typ = PROG.idTYPE, parser, 68); |
check1((ident.type.typ # PROG.tRECORD) & (ident.type.typ # PROG.tARRAY), parser, 69); |
check1( ~(ODD(type.call) & (ident.type.typ = PROG.tREAL)), parser, 113); |
type.base := ident.type; |
Next(parser) |
ELSE |
type.base := NIL |
END |
END |
END FormalParameters; |
PROCEDURE sysflag (parser: PARSER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
IF parser.lex.s = "stdcall" THEN |
res := PROG.stdcall |
ELSIF parser.lex.s = "stdcall64" THEN |
res := PROG.stdcall64 |
ELSIF parser.lex.s = "ccall" THEN |
res := PROG.ccall |
ELSIF parser.lex.s = "ccall16" THEN |
res := PROG.ccall16 |
ELSIF parser.lex.s = "win64" THEN |
res := PROG.win64 |
ELSIF parser.lex.s = "systemv" THEN |
res := PROG.systemv |
ELSIF parser.lex.s = "windows" THEN |
IF program.target.sys IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL} THEN |
res := PROG.stdcall |
ELSIF program.target.sys IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64} THEN |
res := PROG.win64 |
ELSE |
check1(FALSE, parser, 118) |
END |
ELSIF parser.lex.s = "linux" THEN |
IF program.target.sys = mConst.Target_iELF32 THEN |
res := PROG.ccall16 |
ELSIF program.target.sys = mConst.Target_iELF64 THEN |
res := PROG.systemv |
ELSE |
check1(FALSE, parser, 119) |
END |
ELSIF parser.lex.s = "noalign" THEN |
res := PROG.noalign |
ELSE |
res := 0 |
END |
RETURN res |
END sysflag; |
PROCEDURE procflag (parser: PARSER; VAR import: CODE.IMPORT_PROC; isProc: BOOLEAN): INTEGER; |
VAR |
call: INTEGER; |
dll, proc: SCAN.LEXSTR; |
pos: SCAN.POSITION; |
BEGIN |
import := NIL; |
IF parser.sym = SCAN.lxLSQUARE THEN |
getpos(parser, pos); |
check1(parser.unit.sysimport, parser, 54); |
Next(parser); |
call := sysflag(parser); |
IF program.target.bit_depth = 64 THEN |
check1(call IN PROG.callconv64, parser, 117) |
ELSIF program.target.bit_depth = 32 THEN |
check1(call IN PROG.callconv32, parser, 63) |
END; |
Next(parser); |
IF parser.sym = SCAN.lxMINUS THEN |
Next(parser); |
INC(call) |
END; |
IF ~isProc THEN |
checklex(parser, SCAN.lxRSQUARE) |
END; |
IF parser.sym = SCAN.lxCOMMA THEN |
ExpectSym(parser, SCAN.lxSTRING); |
dll := parser.lex.s; |
ExpectSym(parser, SCAN.lxCOMMA); |
ExpectSym(parser, SCAN.lxSTRING); |
proc := parser.lex.s; |
Next(parser); |
import := CODE.AddImp(dll, proc) |
END; |
checklex(parser, SCAN.lxRSQUARE); |
Next(parser) |
ELSE |
IF program.target.bit_depth = 32 THEN |
call := PROG.default |
ELSIF program.target.bit_depth = 64 THEN |
call := PROG.default64 |
END |
END; |
IF import # NIL THEN |
check(~(program.target.sys IN {mConst.Target_iELF32, mConst.Target_iELF64}), parser, pos, 70) |
END |
RETURN call |
END procflag; |
PROCEDURE type (parser: PARSER; VAR t: PROG.TYPE_; flags: SET); |
CONST |
comma = 0; |
closed = 1; |
forward = 2; |
VAR |
arrLen: ARITH.VALUE; |
typeSize: ARITH.VALUE; |
ident: PROG.IDENT; |
unit: PROG.UNIT; |
pos, pos2: SCAN.POSITION; |
fieldType: PROG.TYPE_; |
baseIdent: SCAN.IDENT; |
a, b: INTEGER; |
RecFlag: INTEGER; |
import: CODE.IMPORT_PROC; |
BEGIN |
unit := parser.unit; |
t := NIL; |
IF parser.sym = SCAN.lxIDENT THEN |
ident := QIdent(parser, forward IN flags); |
IF ident # NIL THEN |
check1(ident.typ = PROG.idTYPE, parser, 49); |
t := ident.type; |
check1(t # NIL, parser, 50); |
IF closed IN flags THEN |
check1(t.closed, parser, 50) |
END |
END; |
Next(parser) |
ELSIF (parser.sym = SCAN.lxARRAY) OR ((parser.sym = SCAN.lxCOMMA) & (comma IN flags)) THEN |
IF parser.sym = SCAN.lxARRAY THEN |
getpos(parser, pos2) |
END; |
NextPos(parser, pos); |
ConstExpression(parser, arrLen); |
check(arrLen.typ = ARITH.tINTEGER, parser, pos, 43); |
check(ARITH.check(arrLen), parser, pos, 39); |
check(ARITH.getInt(arrLen) > 0, parser, pos, 51); |
t := program.enterType(program, PROG.tARRAY, -1, ARITH.getInt(arrLen), unit); |
IF parser.sym = SCAN.lxCOMMA THEN |
type(parser, t.base, {comma, closed}) |
ELSIF parser.sym = SCAN.lxOF THEN |
Next(parser); |
type(parser, t.base, {closed}) |
ELSE |
check1(FALSE, parser, 47) |
END; |
t.align := t.base.align; |
a := t.length; |
b := t.base.size; |
check(ARITH.mulInt(a, b), parser, pos2, 104); |
check(ARITH.setInt(typeSize, a), parser, pos2, 104); |
t.size := a; |
t.closed := TRUE |
ELSIF parser.sym = SCAN.lxRECORD THEN |
getpos(parser, pos2); |
Next(parser); |
t := program.enterType(program, PROG.tRECORD, 0, 0, unit); |
t.align := 1; |
IF parser.sym = SCAN.lxLSQUARE THEN |
check1(parser.unit.sysimport, parser, 54); |
Next(parser); |
RecFlag := sysflag(parser); |
IF RecFlag = PROG.noalign THEN |
t.noalign := TRUE |
ELSE |
check1(FALSE, parser, 110) |
END; |
ExpectSym(parser, SCAN.lxRSQUARE); |
Next(parser) |
END; |
IF parser.sym = SCAN.lxLROUND THEN |
check1(~t.noalign, parser, 111); |
ExpectSym(parser, SCAN.lxIDENT); |
getpos(parser, pos); |
type(parser, t.base, {closed}); |
check(t.base.typ IN {PROG.tRECORD, PROG.tPOINTER}, parser, pos, 52); |
IF t.base.typ = PROG.tPOINTER THEN |
t.base := t.base.base; |
check(t.base # NIL, parser, pos, 55) |
END; |
check(~t.base.noalign, parser, pos, 112); |
checklex(parser, SCAN.lxRROUND); |
Next(parser); |
t.size := t.base.size; |
IF t.base.align > t.align THEN |
t.align := t.base.align |
END |
ELSE |
t.base := program.stTypes.tANYREC |
END; |
WHILE parser.sym = SCAN.lxIDENT DO |
FieldList(parser, t); |
ASSERT(parser.sym = SCAN.lxCOLON); |
Next(parser); |
type(parser, fieldType, {closed}); |
check(t.fields.set(t, fieldType), parser, pos2, 104); |
IF (fieldType.align > t.align) & ~t.noalign THEN |
t.align := fieldType.align |
END; |
IF parser.sym = SCAN.lxSEMI THEN |
ExpectSym(parser, SCAN.lxIDENT) |
ELSE |
checklex(parser, SCAN.lxEND) |
END |
END; |
t.closed := TRUE; |
CODE.AddRec(t.base.num); |
IF ~t.noalign THEN |
check(MACHINE.Align(t.size, t.align), parser, pos2, 104); |
check(ARITH.setInt(typeSize, t.size), parser, pos2, 104) |
END; |
checklex(parser, SCAN.lxEND); |
Next(parser) |
ELSIF parser.sym = SCAN.lxPOINTER THEN |
ExpectSym(parser, SCAN.lxTO); |
Next(parser); |
t := program.enterType(program, PROG.tPOINTER, program.target.adr, 0, unit); |
t.align := program.target.adr; |
getpos(parser, pos); |
IF parser.sym = SCAN.lxIDENT THEN |
baseIdent := parser.lex.ident |
END; |
type(parser, t.base, {forward}); |
IF t.base # NIL THEN |
check(t.base.typ = PROG.tRECORD, parser, pos, 58) |
ELSE |
unit.pointers.add(unit, t, baseIdent, pos) |
END |
ELSIF parser.sym = SCAN.lxPROCEDURE THEN |
NextPos(parser, pos); |
t := program.enterType(program, PROG.tPROCEDURE, program.target.adr, 0, unit); |
t.align := program.target.adr; |
t.call := procflag(parser, import, FALSE); |
FormalParameters(parser, t) |
ELSE |
check1(FALSE, parser, 49) |
END |
END type; |
PROCEDURE IdentDef (parser: PARSER; typ: INTEGER; VAR name: SCAN.IDENT): PROG.IDENT; |
VAR |
ident: PROG.IDENT; |
pos: SCAN.POSITION; |
BEGIN |
ASSERT(parser.sym = SCAN.lxIDENT); |
name := parser.lex.ident; |
getpos(parser, pos); |
ident := parser.unit.idents.add(parser.unit, name, typ); |
check(ident # NIL, parser, pos, 30); |
ident.pos := pos; |
Next(parser); |
IF parser.sym = SCAN.lxMUL THEN |
check1(ident.global, parser, 61); |
ident.export := TRUE; |
Next(parser) |
END |
RETURN ident |
END IdentDef; |
PROCEDURE ConstTypeDeclaration (parser: PARSER; const: BOOLEAN); |
VAR |
ident: PROG.IDENT; |
name: SCAN.IDENT; |
pos: SCAN.POSITION; |
BEGIN |
IF const THEN |
ident := IdentDef(parser, PROG.idNONE, name) |
ELSE |
ident := IdentDef(parser, PROG.idTYPE, name) |
END; |
checklex(parser, SCAN.lxEQ); |
NextPos(parser, pos); |
IF const THEN |
ConstExpression(parser, ident.value); |
IF ident.value.typ = ARITH.tINTEGER THEN |
check(ARITH.check(ident.value), parser, pos, 39) |
ELSIF ident.value.typ = ARITH.tREAL THEN |
check(ARITH.check(ident.value), parser, pos, 40) |
END; |
ident.typ := PROG.idCONST; |
ident.type := program.getType(program, ident.value.typ) |
ELSE |
type(parser, ident.type, {}) |
END; |
checklex(parser, SCAN.lxSEMI); |
Next(parser) |
END ConstTypeDeclaration; |
PROCEDURE VarDeclaration (parser: PARSER); |
VAR |
ident: PROG.IDENT; |
name: SCAN.IDENT; |
t: PROG.TYPE_; |
BEGIN |
REPEAT |
ident := IdentDef(parser, PROG.idVAR, name); |
IF parser.sym = SCAN.lxCOMMA THEN |
ExpectSym(parser, SCAN.lxIDENT) |
ELSIF parser.sym = SCAN.lxCOLON THEN |
Next(parser); |
type(parser, t, {}); |
parser.unit.setvars(parser.unit, t); |
checklex(parser, SCAN.lxSEMI); |
Next(parser) |
ELSE |
checklex(parser, SCAN.lxCOLON) |
END |
UNTIL parser.sym # SCAN.lxIDENT |
END VarDeclaration; |
PROCEDURE DeclarationSequence (parser: PARSER): BOOLEAN; |
VAR |
ptr: PROG.FRWPTR; |
endmod: BOOLEAN; |
PROCEDURE ProcDeclaration (parser: PARSER): BOOLEAN; |
VAR |
proc: PROG.IDENT; |
endname, |
name: SCAN.IDENT; |
param: LISTS.ITEM; |
unit: PROG.UNIT; |
ident: PROG.IDENT; |
e: EXPR; |
pos: SCAN.POSITION; |
label: INTEGER; |
enter: CODE.COMMAND; |
call: INTEGER; |
t: PROG.TYPE_; |
import: CODE.IMPORT_PROC; |
endmod, b: BOOLEAN; |
fparams: SET; |
variables: LISTS.LIST; |
int, flt: INTEGER; |
BEGIN |
endmod := FALSE; |
unit := parser.unit; |
call := procflag(parser, import, TRUE); |
getpos(parser, pos); |
checklex(parser, SCAN.lxIDENT); |
IF import # NIL THEN |
proc := IdentDef(parser, PROG.idIMP, name); |
proc.import := import; |
program.procs.last(PROG.PROC).import := import |
ELSE |
proc := IdentDef(parser, PROG.idPROC, name) |
END; |
check(unit.scope.open(unit, proc.proc), parser, pos, 116); |
proc.type := program.enterType(program, PROG.tPROCEDURE, program.target.adr, 0, unit); |
t := proc.type; |
t.align := program.target.adr; |
t.call := call; |
FormalParameters(parser, t); |
IF call IN {PROG.systemv, PROG._systemv} THEN |
check(t.params.size <= PROG.MAXSYSVPARAM, parser, pos, 120) |
END; |
param := t.params.first; |
WHILE param # NIL DO |
ident := unit.idents.add(unit, param(PROG.PARAM).name, PROG.idPARAM); |
ASSERT(ident # NIL); |
ident.type := param(PROG.PARAM).type; |
ident.offset := param(PROG.PARAM).offset; |
IF param(PROG.PARAM).vPar THEN |
ident.typ := PROG.idVPAR |
END; |
param := param.next |
END; |
checklex(parser, SCAN.lxSEMI); |
Next(parser); |
IF import = NIL THEN |
label := CODE.NewLabel(); |
proc.proc.label := label; |
IF parser.main & proc.export & program.dll THEN |
IF program.obj THEN |
check((proc.name.s # "lib_init") & (proc.name.s # "version"), parser, pos, 114) |
END; |
CODE.AddExp(label, proc.name.s); |
proc.proc.used := TRUE |
END; |
b := DeclarationSequence(parser); |
program.locsize := 0; |
IF call IN {PROG._win64, PROG.win64} THEN |
fparams := proc.type.params.getfparams(proc.type, 3, int, flt); |
enter := CODE.Enter(label, LSL(ORD(fparams), 5) + MIN(proc.type.params.size, 4)) |
ELSIF call IN {PROG._systemv, PROG.systemv} THEN |
fparams := proc.type.params.getfparams(proc.type, PROG.MAXSYSVPARAM - 1, int, flt); |
enter := CODE.Enter(label, -(LSL(ORD(fparams), 5) + proc.type.params.size)) |
ELSE |
enter := CODE.Enter(label, 0) |
END; |
proc.proc.enter := enter; |
IF parser.sym = SCAN.lxBEGIN THEN |
Next(parser); |
parser.StatSeq(parser) |
END; |
IF t.base # NIL THEN |
checklex(parser, SCAN.lxRETURN); |
NextPos(parser, pos); |
parser.expression(parser, e); |
check(parser.chkreturn(parser, e, t.base, pos), parser, pos, 87) |
END; |
proc.proc.leave := CODE.Leave(t.base # NIL, (t.base # NIL) & (t.base.typ = PROG.tREAL), |
t.params.size * ORD((t.call IN PROG.callee_clean_up) OR (t.call IN {PROG.systemv, PROG._systemv}))); |
enter.param2 := program.locsize; |
checklex(parser, SCAN.lxEND) |
END; |
IF parser.sym = SCAN.lxEND THEN |
ExpectSym(parser, SCAN.lxIDENT); |
getpos(parser, pos); |
endname := parser.lex.ident; |
IF import = NIL THEN |
check(endname = name, parser, pos, 60); |
ExpectSym(parser, SCAN.lxSEMI); |
Next(parser) |
ELSE |
IF endname = parser.unit.name THEN |
ExpectSym(parser, SCAN.lxPOINT); |
Next(parser); |
endmod := TRUE |
ELSIF endname = name THEN |
ExpectSym(parser, SCAN.lxSEMI); |
Next(parser) |
ELSE |
check(FALSE, parser, pos, 60) |
END |
END |
END; |
IF import = NIL THEN |
variables := LISTS.create(NIL); |
ELSE |
variables := NIL |
END; |
unit.scope.close(unit, variables); |
IF import = NIL THEN |
enter.variables := variables |
END |
RETURN endmod |
END ProcDeclaration; |
BEGIN |
IF parser.sym = SCAN.lxCONST THEN |
Next(parser); |
WHILE parser.sym = SCAN.lxIDENT DO |
ConstTypeDeclaration(parser, TRUE) |
END |
END; |
IF parser.sym = SCAN.lxTYPE THEN |
Next(parser); |
WHILE parser.sym = SCAN.lxIDENT DO |
ConstTypeDeclaration(parser, FALSE) |
END |
END; |
ptr := parser.unit.pointers.link(parser.unit); |
IF ptr # NIL THEN |
IF ptr.notRecord THEN |
error(parser, ptr.pos, 58) |
ELSE |
error(parser, ptr.pos, 48) |
END |
END; |
IF parser.sym = SCAN.lxVAR THEN |
Next(parser); |
IF parser.sym = SCAN.lxIDENT THEN |
VarDeclaration(parser) |
END |
END; |
endmod := FALSE; |
WHILE ~endmod & (parser.sym = SCAN.lxPROCEDURE) DO |
Next(parser); |
endmod := ProcDeclaration(parser) |
END |
RETURN endmod |
END DeclarationSequence; |
PROCEDURE parse (parser: PARSER); |
VAR |
unit: PROG.UNIT; |
label: INTEGER; |
name: INTEGER; |
endmod: BOOLEAN; |
BEGIN |
ASSERT(parser # NIL); |
ASSERT(parser.scanner # NIL); |
ExpectSym(parser, SCAN.lxMODULE); |
ExpectSym(parser, SCAN.lxIDENT); |
IF ~parser.main THEN |
check1(parser.lex.s = parser.modname, parser, 23) |
END; |
unit := program.units.create(program.units, parser.lex.ident); |
parser.unit := unit; |
ExpectSym(parser, SCAN.lxSEMI); |
Next(parser); |
IF parser.sym = SCAN.lxIMPORT THEN |
ImportList(parser) |
END; |
CONSOLE.String("compiling "); CONSOLE.String(unit.name.s); |
IF parser.unit.sysimport THEN |
CONSOLE.String(" (SYSTEM)") |
END; |
CONSOLE.Ln; |
label := CODE.NewLabel(); |
CODE.AddJmpCmd(CODE.opJMP, label); |
name := CODE.putstr(unit.name.s); |
CODE.SetErrLabel; |
CODE.AddCmd(CODE.opSADR, name); |
CODE.AddCmd(CODE.opPARAM, 1); |
CODE.AddCmd0(CODE.opERR); |
endmod := DeclarationSequence(parser); |
CODE.SetLabel(label); |
IF ~endmod THEN |
IF parser.sym = SCAN.lxBEGIN THEN |
Next(parser); |
parser.StatSeq(parser) |
END; |
checklex(parser, SCAN.lxEND); |
ExpectSym(parser, SCAN.lxIDENT); |
check1(parser.lex.s = unit.name.s, parser, 25); |
ExpectSym(parser, SCAN.lxPOINT) |
END; |
unit.close(unit) |
END parse; |
PROCEDURE open (parser: PARSER; modname: ARRAY OF CHAR): BOOLEAN; |
BEGIN |
ASSERT(parser # NIL); |
STRINGS.append(parser.fname, modname); |
STRINGS.append(parser.fname, parser.ext); |
STRINGS.append(parser.modname, modname); |
parser.scanner := SCAN.open(parser.fname) |
RETURN parser.scanner # NIL |
END open; |
PROCEDURE NewParser (): PARSER; |
VAR |
pars: PARSER; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(parsers); |
IF citem = NIL THEN |
NEW(pars) |
ELSE |
pars := citem(PARSER) |
END |
RETURN pars |
END NewParser; |
PROCEDURE create* (path, lib_path: PATH; StatSeq: STATPROC; expression, designator: EXPRPROC; chkreturn: RETPROC): PARSER; |
VAR |
parser: PARSER; |
BEGIN |
parser := NewParser(); |
parser.path := path; |
parser.lib_path := lib_path; |
parser.ext := mConst.FILE_EXT; |
parser.fname := path; |
parser.modname := ""; |
parser.scanner := NIL; |
parser.unit := NIL; |
parser.constexp := FALSE; |
parser.main := FALSE; |
parser.open := open; |
parser.parse := parse; |
parser.StatSeq := StatSeq; |
parser.expression := expression; |
parser.designator := designator; |
parser.chkreturn := chkreturn; |
parser.create := create |
RETURN parser |
END create; |
PROCEDURE init* (bit_depth, sys: INTEGER); |
BEGIN |
program := PROG.create(bit_depth, sys); |
parsers := C.create() |
END init; |
END PARS. |
/programs/develop/oberon07/Source/PATHS.ob07 |
---|
0,0 → 1,109 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE PATHS; |
IMPORT STRINGS, UTILS; |
CONST |
slash = UTILS.slash; |
PATHLEN = 2048; |
TYPE |
PATH* = ARRAY PATHLEN OF CHAR; |
PROCEDURE split* (fname: ARRAY OF CHAR; VAR path, name, ext: ARRAY OF CHAR); |
VAR |
pos1, pos2, len: INTEGER; |
BEGIN |
len := LENGTH(fname); |
pos1 := len - 1; |
pos2 := len - 1; |
STRINGS.search(fname, pos1, slash, FALSE); |
STRINGS.search(fname, pos2, ".", FALSE); |
path := fname; |
path[pos1 + 1] := 0X; |
IF (pos2 = -1) OR (pos2 < pos1) THEN |
pos2 := len |
END; |
INC(pos1); |
STRINGS.copy(fname, name, pos1, 0, pos2 - pos1); |
name[pos2 - pos1] := 0X; |
STRINGS.copy(fname, ext, pos2, 0, len - pos2); |
ext[len - pos2] := 0X; |
END split; |
PROCEDURE RelPath* (absolute, relative: ARRAY OF CHAR; VAR res: ARRAY OF CHAR); |
VAR |
i, j: INTEGER; |
error: BOOLEAN; |
BEGIN |
COPY(absolute, res); |
i := LENGTH(res) - 1; |
WHILE (i >= 0) & (res[i] # slash) DO |
DEC(i) |
END; |
INC(i); |
res[i] := 0X; |
error := FALSE; |
j := 0; |
WHILE ~error & (relative[j] # 0X) DO |
IF (relative[j] = ".") & (relative[j + 1] = ".") & (relative[j + 2] = slash) & (i > 0) & (res[i - 1] = slash) THEN |
DEC(i, 2); |
WHILE (i >= 0) & (res[i] # slash) DO |
DEC(i) |
END; |
IF i < 0 THEN |
error := TRUE |
ELSE |
INC(i); |
INC(j, 3) |
END |
ELSE |
res[i] := relative[j]; |
INC(i); |
INC(j) |
END |
END; |
IF error THEN |
COPY(relative, res) |
ELSE |
res[i] := 0X |
END |
END RelPath; |
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN; |
RETURN UTILS.isRelative(path) |
END isRelative; |
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR); |
BEGIN |
UTILS.GetCurrentDirectory(path) |
END GetCurrentDirectory; |
END PATHS. |
/programs/develop/oberon07/Source/PE32.ob07 |
---|
0,0 → 1,733 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE PE32; |
IMPORT BIN, LISTS, UTILS, WR := WRITER, mConst := CONSTANTS, CHL := CHUNKLISTS; |
CONST |
SIZE_OF_DWORD = 4; |
SIZE_OF_WORD = 2; |
SIZE_OF_IMAGE_EXPORT_DIRECTORY = 40; |
IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16; |
IMAGE_SIZEOF_SHORT_NAME = 8; |
SIZE_OF_IMAGE_FILE_HEADER* = 20; |
SIZE_OF_IMAGE_SECTION_HEADER* = 40; |
(* SectionHeader.Characteristics *) |
SHC_text = 060000020H; |
SHC_data = 0C0000040H; |
SHC_bss = 0C00000C0H; |
SectionAlignment = 1000H; |
FileAlignment = 200H; |
TYPE |
WORD = WCHAR; |
DWORD = INTEGER; |
NAME* = ARRAY IMAGE_SIZEOF_SHORT_NAME OF CHAR; |
IMAGE_DATA_DIRECTORY = RECORD |
VirtualAddress: DWORD; |
Size: DWORD |
END; |
IMAGE_OPTIONAL_HEADER = RECORD |
Magic: WORD; |
MajorLinkerVersion: BYTE; |
MinorLinkerVersion: BYTE; |
SizeOfCode: DWORD; |
SizeOfInitializedData: DWORD; |
SizeOfUninitializedData: DWORD; |
AddressOfEntryPoint: DWORD; |
BaseOfCode: DWORD; |
BaseOfData: DWORD; |
ImageBase: DWORD; |
SectionAlignment: DWORD; |
FileAlignment: DWORD; |
MajorOperatingSystemVersion: WORD; |
MinorOperatingSystemVersion: WORD; |
MajorImageVersion: WORD; |
MinorImageVersion: WORD; |
MajorSubsystemVersion: WORD; |
MinorSubsystemVersion: WORD; |
Win32VersionValue: DWORD; |
SizeOfImage: DWORD; |
SizeOfHeaders: DWORD; |
CheckSum: DWORD; |
Subsystem: WORD; |
DllCharacteristics: WORD; |
SizeOfStackReserve: DWORD; |
SizeOfStackCommit: DWORD; |
SizeOfHeapReserve: DWORD; |
SizeOfHeapCommit: DWORD; |
LoaderFlags: DWORD; |
NumberOfRvaAndSizes: DWORD; |
DataDirectory: ARRAY IMAGE_NUMBEROF_DIRECTORY_ENTRIES OF IMAGE_DATA_DIRECTORY |
END; |
IMAGE_FILE_HEADER* = RECORD |
Machine*: WORD; |
NumberOfSections*: WORD; |
TimeDateStamp*: DWORD; |
PointerToSymbolTable*: DWORD; |
NumberOfSymbols*: DWORD; |
SizeOfOptionalHeader*: WORD; |
Characteristics*: WORD |
END; |
IMAGE_NT_HEADERS = RECORD |
Signature: ARRAY 4 OF BYTE; |
FileHeader: IMAGE_FILE_HEADER; |
OptionalHeader: IMAGE_OPTIONAL_HEADER |
END; |
IMAGE_SECTION_HEADER* = RECORD |
Name*: NAME; |
VirtualSize*, |
VirtualAddress*, |
SizeOfRawData*, |
PointerToRawData*, |
PointerToRelocations*, |
PointerToLinenumbers*: DWORD; |
NumberOfRelocations*, |
NumberOfLinenumbers*: WORD; |
Characteristics*: DWORD |
END; |
IMAGE_EXPORT_DIRECTORY = RECORD |
Characteristics: DWORD; |
TimeDateStamp: DWORD; |
MajorVersion: WORD; |
MinorVersion: WORD; |
Name, |
Base, |
NumberOfFunctions, |
NumberOfNames, |
AddressOfFunctions, |
AddressOfNames, |
AddressOfNameOrdinals: DWORD |
END; |
VIRTUAL_ADDR = RECORD |
Code, Data, Bss, Import: INTEGER |
END; |
FILE = WR.FILE; |
VAR |
msdos: ARRAY 128 OF BYTE; |
PEHeader: IMAGE_NT_HEADERS; |
SectionHeaders: ARRAY 16 OF IMAGE_SECTION_HEADER; |
Relocations: LISTS.LIST; |
bit64: BOOLEAN; |
libcnt: INTEGER; |
PROCEDURE SIZE (): INTEGER; |
RETURN SIZE_OF_DWORD * (ORD(bit64) + 1) |
END SIZE; |
PROCEDURE Export (program: BIN.PROGRAM; DataRVA: INTEGER; VAR ExportDir: IMAGE_EXPORT_DIRECTORY): INTEGER; |
BEGIN |
ExportDir.Characteristics := 0; |
ExportDir.TimeDateStamp := PEHeader.FileHeader.TimeDateStamp; |
ExportDir.MajorVersion := 0X; |
ExportDir.MinorVersion := 0X; |
ExportDir.Name := program.modname + DataRVA; |
ExportDir.Base := 0; |
ExportDir.NumberOfFunctions := LISTS.count(program.exp_list); |
ExportDir.NumberOfNames := ExportDir.NumberOfFunctions; |
ExportDir.AddressOfFunctions := SIZE_OF_IMAGE_EXPORT_DIRECTORY; |
ExportDir.AddressOfNames := ExportDir.AddressOfFunctions + ExportDir.NumberOfFunctions * SIZE_OF_DWORD; |
ExportDir.AddressOfNameOrdinals := ExportDir.AddressOfNames + ExportDir.NumberOfFunctions * SIZE_OF_DWORD |
RETURN SIZE_OF_IMAGE_EXPORT_DIRECTORY + ExportDir.NumberOfFunctions * (2 * SIZE_OF_DWORD + SIZE_OF_WORD) |
END Export; |
PROCEDURE align (n, _align: INTEGER): INTEGER; |
BEGIN |
IF n MOD _align # 0 THEN |
n := n + _align - (n MOD _align) |
END |
RETURN n |
END align; |
PROCEDURE GetProcCount (lib: BIN.IMPRT): INTEGER; |
VAR |
import: BIN.IMPRT; |
res: INTEGER; |
BEGIN |
res := 0; |
import := lib.next(BIN.IMPRT); |
WHILE (import # NIL) & (import.label # 0) DO |
INC(res); |
import := import.next(BIN.IMPRT) |
END |
RETURN res |
END GetProcCount; |
PROCEDURE GetImportSize (imp_list: LISTS.LIST): INTEGER; |
VAR |
import: BIN.IMPRT; |
proccnt: INTEGER; |
procoffs: INTEGER; |
OriginalCurrentThunk, |
CurrentThunk: INTEGER; |
BEGIN |
libcnt := 0; |
proccnt := 0; |
import := imp_list.first(BIN.IMPRT); |
WHILE import # NIL DO |
IF import.label = 0 THEN |
INC(libcnt) |
ELSE |
INC(proccnt) |
END; |
import := import.next(BIN.IMPRT) |
END; |
procoffs := 0; |
import := imp_list.first(BIN.IMPRT); |
WHILE import # NIL DO |
IF import.label = 0 THEN |
import.OriginalFirstThunk := procoffs; |
import.FirstThunk := procoffs + (GetProcCount(import) + 1); |
OriginalCurrentThunk := import.OriginalFirstThunk; |
CurrentThunk := import.FirstThunk; |
procoffs := procoffs + (GetProcCount(import) + 1) * 2 |
ELSE |
import.OriginalFirstThunk := OriginalCurrentThunk; |
import.FirstThunk := CurrentThunk; |
INC(OriginalCurrentThunk); |
INC(CurrentThunk) |
END; |
import := import.next(BIN.IMPRT) |
END |
RETURN (libcnt + 1) * 5 * SIZE_OF_DWORD + (proccnt + libcnt) * 2 * SIZE() |
END GetImportSize; |
PROCEDURE fixup (program: BIN.PROGRAM; Address: VIRTUAL_ADDR); |
VAR |
reloc: BIN.RELOC; |
iproc: BIN.IMPRT; |
L: INTEGER; |
delta: INTEGER; |
AdrImp: INTEGER; |
BEGIN |
AdrImp := Address.Import + (libcnt + 1) * 5 * SIZE_OF_DWORD; |
reloc := program.rel_list.first(BIN.RELOC); |
WHILE reloc # NIL DO |
L := BIN.get32le(program.code, reloc.offset); |
delta := 3 - reloc.offset - Address.Code - 7 * ORD(bit64); |
CASE reloc.opcode OF |
|BIN.PICDATA: |
BIN.put32le(program.code, reloc.offset, L + Address.Data + delta) |
|BIN.PICCODE: |
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + Address.Code + delta) |
|BIN.PICBSS: |
BIN.put32le(program.code, reloc.offset, L + Address.Bss + delta) |
|BIN.PICIMP: |
iproc := BIN.GetIProc(program, L); |
BIN.put32le(program.code, reloc.offset, iproc.FirstThunk * SIZE() + AdrImp + delta) |
END; |
reloc := reloc.next(BIN.RELOC) |
END |
END fixup; |
PROCEDURE WriteWord (file: FILE; w: WORD); |
BEGIN |
WR.Write16LE(file, ORD(w)) |
END WriteWord; |
PROCEDURE WriteName* (File: FILE; name: NAME); |
VAR |
i, nameLen: INTEGER; |
BEGIN |
nameLen := LENGTH(name); |
FOR i := 0 TO nameLen - 1 DO |
WR.WriteByte(File, ORD(name[i])) |
END; |
i := LEN(name) - nameLen; |
WHILE i > 0 DO |
WR.WriteByte(File, 0); |
DEC(i) |
END |
END WriteName; |
PROCEDURE WriteSectionHeader* (file: FILE; h: IMAGE_SECTION_HEADER); |
VAR |
i, nameLen: INTEGER; |
BEGIN |
nameLen := LENGTH(h.Name); |
FOR i := 0 TO nameLen - 1 DO |
WR.WriteByte(file, ORD(h.Name[i])) |
END; |
i := LEN(h.Name) - nameLen; |
WHILE i > 0 DO |
WR.WriteByte(file, 0); |
DEC(i) |
END; |
WR.Write32LE(file, h.VirtualSize); |
WR.Write32LE(file, h.VirtualAddress); |
WR.Write32LE(file, h.SizeOfRawData); |
WR.Write32LE(file, h.PointerToRawData); |
WR.Write32LE(file, h.PointerToRelocations); |
WR.Write32LE(file, h.PointerToLinenumbers); |
WriteWord(file, h.NumberOfRelocations); |
WriteWord(file, h.NumberOfLinenumbers); |
WR.Write32LE(file, h.Characteristics) |
END WriteSectionHeader; |
PROCEDURE WriteFileHeader* (file: FILE; h: IMAGE_FILE_HEADER); |
BEGIN |
WriteWord(file, h.Machine); |
WriteWord(file, h.NumberOfSections); |
WR.Write32LE(file, h.TimeDateStamp); |
WR.Write32LE(file, h.PointerToSymbolTable); |
WR.Write32LE(file, h.NumberOfSymbols); |
WriteWord(file, h.SizeOfOptionalHeader); |
WriteWord(file, h.Characteristics) |
END WriteFileHeader; |
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; BaseAddress: INTEGER; console, dll, amd64: BOOLEAN); |
VAR |
i, n: INTEGER; |
Size: RECORD |
Code, Data, Bss, Stack, Import, Reloc, Export: INTEGER |
END; |
Address: VIRTUAL_ADDR; |
File: FILE; |
import: BIN.IMPRT; |
ImportTable: CHL.INTLIST; |
ExportDir: IMAGE_EXPORT_DIRECTORY; |
export: BIN.EXPRT; |
PROCEDURE WriteExportDir (file: FILE; e: IMAGE_EXPORT_DIRECTORY); |
BEGIN |
WR.Write32LE(file, e.Characteristics); |
WR.Write32LE(file, e.TimeDateStamp); |
WriteWord(file, e.MajorVersion); |
WriteWord(file, e.MinorVersion); |
WR.Write32LE(file, e.Name); |
WR.Write32LE(file, e.Base); |
WR.Write32LE(file, e.NumberOfFunctions); |
WR.Write32LE(file, e.NumberOfNames); |
WR.Write32LE(file, e.AddressOfFunctions); |
WR.Write32LE(file, e.AddressOfNames); |
WR.Write32LE(file, e.AddressOfNameOrdinals) |
END WriteExportDir; |
PROCEDURE WriteOptHeader (file: FILE; h: IMAGE_OPTIONAL_HEADER); |
VAR |
i: INTEGER; |
BEGIN |
WriteWord(file, h.Magic); |
WR.WriteByte(file, h.MajorLinkerVersion); |
WR.WriteByte(file, h.MinorLinkerVersion); |
WR.Write32LE(file, h.SizeOfCode); |
WR.Write32LE(file, h.SizeOfInitializedData); |
WR.Write32LE(file, h.SizeOfUninitializedData); |
WR.Write32LE(file, h.AddressOfEntryPoint); |
WR.Write32LE(file, h.BaseOfCode); |
IF bit64 THEN |
WR.Write64LE(file, h.ImageBase) |
ELSE |
WR.Write32LE(file, h.BaseOfData); |
WR.Write32LE(file, h.ImageBase) |
END; |
WR.Write32LE(file, h.SectionAlignment); |
WR.Write32LE(file, h.FileAlignment); |
WriteWord(file, h.MajorOperatingSystemVersion); |
WriteWord(file, h.MinorOperatingSystemVersion); |
WriteWord(file, h.MajorImageVersion); |
WriteWord(file, h.MinorImageVersion); |
WriteWord(file, h.MajorSubsystemVersion); |
WriteWord(file, h.MinorSubsystemVersion); |
WR.Write32LE(file, h.Win32VersionValue); |
WR.Write32LE(file, h.SizeOfImage); |
WR.Write32LE(file, h.SizeOfHeaders); |
WR.Write32LE(file, h.CheckSum); |
WriteWord(file, h.Subsystem); |
WriteWord(file, h.DllCharacteristics); |
IF bit64 THEN |
WR.Write64LE(file, h.SizeOfStackReserve); |
WR.Write64LE(file, h.SizeOfStackCommit); |
WR.Write64LE(file, h.SizeOfHeapReserve); |
WR.Write64LE(file, h.SizeOfHeapCommit) |
ELSE |
WR.Write32LE(file, h.SizeOfStackReserve); |
WR.Write32LE(file, h.SizeOfStackCommit); |
WR.Write32LE(file, h.SizeOfHeapReserve); |
WR.Write32LE(file, h.SizeOfHeapCommit) |
END; |
WR.Write32LE(file, h.LoaderFlags); |
WR.Write32LE(file, h.NumberOfRvaAndSizes); |
FOR i := 0 TO LEN(h.DataDirectory) - 1 DO |
WR.Write32LE(file, h.DataDirectory[i].VirtualAddress); |
WR.Write32LE(file, h.DataDirectory[i].Size) |
END |
END WriteOptHeader; |
PROCEDURE WritePEHeader (file: FILE; h: IMAGE_NT_HEADERS); |
BEGIN |
WR.Write(file, h.Signature, LEN(h.Signature)); |
WriteFileHeader(file, h.FileHeader); |
WriteOptHeader(file, h.OptionalHeader) |
END WritePEHeader; |
PROCEDURE InitSection (VAR section: IMAGE_SECTION_HEADER; Name: NAME; Characteristics: DWORD); |
BEGIN |
section.Name := Name; |
section.PointerToRelocations := 0; |
section.PointerToLinenumbers := 0; |
section.NumberOfRelocations := 0X; |
section.NumberOfLinenumbers := 0X; |
section.Characteristics := Characteristics |
END InitSection; |
BEGIN |
bit64 := amd64; |
Relocations := LISTS.create(NIL); |
Size.Code := CHL.Length(program.code); |
Size.Data := CHL.Length(program.data); |
Size.Bss := program.bss; |
Size.Stack := program.stack; |
PEHeader.Signature[0] := 50H; |
PEHeader.Signature[1] := 45H; |
PEHeader.Signature[2] := 0; |
PEHeader.Signature[3] := 0; |
IF amd64 THEN |
PEHeader.FileHeader.Machine := 08664X |
ELSE |
PEHeader.FileHeader.Machine := 014CX |
END; |
PEHeader.FileHeader.NumberOfSections := WCHR(4 + ORD(dll)); |
PEHeader.FileHeader.TimeDateStamp := UTILS.UnixTime(); |
PEHeader.FileHeader.PointerToSymbolTable := 0H; |
PEHeader.FileHeader.NumberOfSymbols := 0H; |
PEHeader.FileHeader.SizeOfOptionalHeader := WCHR(0E0H + 10H * ORD(amd64)); |
PEHeader.FileHeader.Characteristics := WCHR(010EH + (20H - 100H) * ORD(amd64) + 2000H * ORD(dll)); |
PEHeader.OptionalHeader.Magic := WCHR(010BH + 100H * ORD(amd64)); |
PEHeader.OptionalHeader.MajorLinkerVersion := mConst.vMajor; |
PEHeader.OptionalHeader.MinorLinkerVersion := mConst.vMinor; |
PEHeader.OptionalHeader.SizeOfCode := align(Size.Code, FileAlignment); |
PEHeader.OptionalHeader.SizeOfInitializedData := 0; |
PEHeader.OptionalHeader.SizeOfUninitializedData := 0; |
PEHeader.OptionalHeader.AddressOfEntryPoint := SectionAlignment; |
PEHeader.OptionalHeader.BaseOfCode := SectionAlignment; |
PEHeader.OptionalHeader.BaseOfData := PEHeader.OptionalHeader.BaseOfCode + align(Size.Code, SectionAlignment); |
PEHeader.OptionalHeader.ImageBase := BaseAddress; |
PEHeader.OptionalHeader.SectionAlignment := SectionAlignment; |
PEHeader.OptionalHeader.FileAlignment := FileAlignment; |
PEHeader.OptionalHeader.MajorOperatingSystemVersion := 1X; |
PEHeader.OptionalHeader.MinorOperatingSystemVersion := 0X; |
PEHeader.OptionalHeader.MajorImageVersion := 0X; |
PEHeader.OptionalHeader.MinorImageVersion := 0X; |
PEHeader.OptionalHeader.MajorSubsystemVersion := 4X; |
PEHeader.OptionalHeader.MinorSubsystemVersion := 0X; |
PEHeader.OptionalHeader.Win32VersionValue := 0H; |
PEHeader.OptionalHeader.SizeOfImage := SectionAlignment; |
PEHeader.OptionalHeader.SizeOfHeaders := 400H; |
PEHeader.OptionalHeader.CheckSum := 0; |
PEHeader.OptionalHeader.Subsystem := WCHR((2 + ORD(console)) * ORD(~dll)); |
PEHeader.OptionalHeader.DllCharacteristics := 0040X; |
PEHeader.OptionalHeader.SizeOfStackReserve := Size.Stack; |
PEHeader.OptionalHeader.SizeOfStackCommit := Size.Stack DIV 16; |
PEHeader.OptionalHeader.SizeOfHeapReserve := 100000H; |
PEHeader.OptionalHeader.SizeOfHeapCommit := 10000H; |
PEHeader.OptionalHeader.LoaderFlags := 0; |
PEHeader.OptionalHeader.NumberOfRvaAndSizes := IMAGE_NUMBEROF_DIRECTORY_ENTRIES; |
InitSection(SectionHeaders[0], ".text", SHC_text); |
SectionHeaders[0].VirtualSize := Size.Code; |
SectionHeaders[0].VirtualAddress := 1000H; |
SectionHeaders[0].SizeOfRawData := align(Size.Code, FileAlignment); |
SectionHeaders[0].PointerToRawData := PEHeader.OptionalHeader.SizeOfHeaders; |
InitSection(SectionHeaders[1], ".data", SHC_data); |
SectionHeaders[1].VirtualSize := Size.Data; |
SectionHeaders[1].VirtualAddress := align(SectionHeaders[0].VirtualAddress + SectionHeaders[0].VirtualSize, SectionAlignment); |
SectionHeaders[1].SizeOfRawData := align(Size.Data, FileAlignment); |
SectionHeaders[1].PointerToRawData := SectionHeaders[0].PointerToRawData + SectionHeaders[0].SizeOfRawData; |
InitSection(SectionHeaders[2], ".bss", SHC_bss); |
SectionHeaders[2].VirtualSize := Size.Bss; |
SectionHeaders[2].VirtualAddress := align(SectionHeaders[1].VirtualAddress + SectionHeaders[1].VirtualSize, SectionAlignment); |
SectionHeaders[2].SizeOfRawData := 0; |
SectionHeaders[2].PointerToRawData := SectionHeaders[1].PointerToRawData + SectionHeaders[1].SizeOfRawData; |
Size.Import := GetImportSize(program.imp_list); |
InitSection(SectionHeaders[3], ".idata", SHC_data); |
SectionHeaders[3].VirtualSize := Size.Import + CHL.Length(program.import); |
SectionHeaders[3].VirtualAddress := align(SectionHeaders[2].VirtualAddress + SectionHeaders[2].VirtualSize, SectionAlignment); |
SectionHeaders[3].SizeOfRawData := align(SectionHeaders[3].VirtualSize, FileAlignment); |
SectionHeaders[3].PointerToRawData := SectionHeaders[2].PointerToRawData + SectionHeaders[2].SizeOfRawData; |
Address.Code := SectionHeaders[0].VirtualAddress + PEHeader.OptionalHeader.ImageBase; |
Address.Data := SectionHeaders[1].VirtualAddress + PEHeader.OptionalHeader.ImageBase; |
Address.Bss := SectionHeaders[2].VirtualAddress + PEHeader.OptionalHeader.ImageBase; |
Address.Import := SectionHeaders[3].VirtualAddress + PEHeader.OptionalHeader.ImageBase; |
fixup(program, Address); |
IF dll THEN |
Size.Export := Export(program, SectionHeaders[1].VirtualAddress, ExportDir); |
InitSection(SectionHeaders[4], ".edata", SHC_data); |
SectionHeaders[4].VirtualSize := Size.Export + CHL.Length(program.export); |
SectionHeaders[4].VirtualAddress := align(SectionHeaders[3].VirtualAddress + SectionHeaders[3].VirtualSize, SectionAlignment); |
SectionHeaders[4].SizeOfRawData := align(SectionHeaders[4].VirtualSize, FileAlignment); |
SectionHeaders[4].PointerToRawData := SectionHeaders[3].PointerToRawData + SectionHeaders[3].SizeOfRawData; |
END; |
FOR i := 0 TO IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1 DO |
PEHeader.OptionalHeader.DataDirectory[i].VirtualAddress := 0; |
PEHeader.OptionalHeader.DataDirectory[i].Size := 0 |
END; |
IF dll THEN |
PEHeader.OptionalHeader.DataDirectory[0].VirtualAddress := SectionHeaders[4].VirtualAddress; |
PEHeader.OptionalHeader.DataDirectory[0].Size := SectionHeaders[4].VirtualSize |
END; |
PEHeader.OptionalHeader.DataDirectory[1].VirtualAddress := SectionHeaders[3].VirtualAddress; |
PEHeader.OptionalHeader.DataDirectory[1].Size := SectionHeaders[3].VirtualSize; |
FOR i := 0 TO ORD(PEHeader.FileHeader.NumberOfSections) - 1 DO |
INC(PEHeader.OptionalHeader.SizeOfInitializedData, SectionHeaders[i].SizeOfRawData) |
END; |
DEC(PEHeader.OptionalHeader.SizeOfInitializedData, SectionHeaders[0].SizeOfRawData); |
DEC(PEHeader.OptionalHeader.SizeOfInitializedData, SectionHeaders[2].SizeOfRawData); |
PEHeader.OptionalHeader.SizeOfUninitializedData := align(SectionHeaders[2].VirtualSize, FileAlignment); |
FOR i := 0 TO ORD(PEHeader.FileHeader.NumberOfSections) - 1 DO |
INC(PEHeader.OptionalHeader.SizeOfImage, align(SectionHeaders[i].VirtualSize, SectionAlignment)) |
END; |
n := 0; |
BIN.InitArray(msdos, n, "4D5A80000100000004001000FFFF000040010000000000004000000000000000"); |
BIN.InitArray(msdos, n, "0000000000000000000000000000000000000000000000000000000080000000"); |
BIN.InitArray(msdos, n, "0E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F"); |
BIN.InitArray(msdos, n, "742062652072756E20696E20444F53206D6F64652E0D0A240000000000000000"); |
File := WR.Create(FileName); |
WR.Write(File, msdos, LEN(msdos)); |
WritePEHeader(File, PEHeader); |
FOR i := 0 TO ORD(PEHeader.FileHeader.NumberOfSections) - 1 DO |
WriteSectionHeader(File, SectionHeaders[i]) |
END; |
WR.Padding(File, FileAlignment); |
CHL.WriteToFile(File, program.code); |
WR.Padding(File, FileAlignment); |
CHL.WriteToFile(File, program.data); |
WR.Padding(File, FileAlignment); |
n := (libcnt + 1) * 5; |
ImportTable := CHL.CreateIntList(); |
FOR i := 0 TO (Size.Import - n * SIZE_OF_DWORD) DIV SIZE() + n - 1 DO |
CHL.PushInt(ImportTable, 0) |
END; |
i := 0; |
import := program.imp_list.first(BIN.IMPRT); |
WHILE import # NIL DO |
IF import.label = 0 THEN |
CHL.SetInt(ImportTable, i + 0, import.OriginalFirstThunk * SIZE() + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD); |
CHL.SetInt(ImportTable, i + 1, 0); |
CHL.SetInt(ImportTable, i + 2, 0); |
CHL.SetInt(ImportTable, i + 3, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress); |
CHL.SetInt(ImportTable, i + 4, import.FirstThunk * SIZE() + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD); |
i := i + 5 |
END; |
import := import.next(BIN.IMPRT) |
END; |
CHL.SetInt(ImportTable, i + 0, 0); |
CHL.SetInt(ImportTable, i + 1, 0); |
CHL.SetInt(ImportTable, i + 2, 0); |
CHL.SetInt(ImportTable, i + 3, 0); |
CHL.SetInt(ImportTable, i + 4, 0); |
import := program.imp_list.first(BIN.IMPRT); |
WHILE import # NIL DO |
IF import.label # 0 THEN |
CHL.SetInt(ImportTable, import.OriginalFirstThunk + n, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress - 2); |
CHL.SetInt(ImportTable, import.FirstThunk + n, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress - 2) |
END; |
import := import.next(BIN.IMPRT) |
END; |
FOR i := 0 TO n - 1 DO |
WR.Write32LE(File, CHL.GetInt(ImportTable, i)) |
END; |
FOR i := n TO CHL.Length(ImportTable) - 1 DO |
IF amd64 THEN |
WR.Write64LE(File, CHL.GetInt(ImportTable, i)) |
ELSE |
WR.Write32LE(File, CHL.GetInt(ImportTable, i)) |
END |
END; |
CHL.WriteToFile(File, program.import); |
WR.Padding(File, FileAlignment); |
IF dll THEN |
INC(ExportDir.AddressOfFunctions, SectionHeaders[4].VirtualAddress); |
INC(ExportDir.AddressOfNames, SectionHeaders[4].VirtualAddress); |
INC(ExportDir.AddressOfNameOrdinals, SectionHeaders[4].VirtualAddress); |
WriteExportDir(File, ExportDir); |
export := program.exp_list.first(BIN.EXPRT); |
WHILE export # NIL DO |
WR.Write32LE(File, export.label + SectionHeaders[0].VirtualAddress); |
export := export.next(BIN.EXPRT) |
END; |
export := program.exp_list.first(BIN.EXPRT); |
WHILE export # NIL DO |
WR.Write32LE(File, export.nameoffs + Size.Export + SectionHeaders[4].VirtualAddress); |
export := export.next(BIN.EXPRT) |
END; |
FOR i := 0 TO ExportDir.NumberOfFunctions - 1 DO |
WriteWord(File, WCHR(i)) |
END; |
CHL.WriteToFile(File, program.export); |
WR.Padding(File, FileAlignment) |
END; |
WR.Close(File) |
END write; |
END PE32. |
/programs/develop/oberon07/Source/PROG.ob07 |
---|
0,0 → 1,1311 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE PROG; |
IMPORT SCAN, LISTS, ARITH, ERRORS, MACHINE, C := COLLECTIONS, mConst := CONSTANTS, CODE, UTILS; |
CONST |
MAXARRDIM* = 5; |
MAXSCOPE = 16; |
MAXSYSVPARAM* = 26; |
idNONE* = 0; idGUARD = 1; idMODULE* = 2; idCONST* = 3; |
idTYPE* = 4; idSTFUNC* = 5; idSTPROC* = 6; idVAR* = 7; |
idPROC* = 8; idVPAR* = 9; idPARAM* = 10; idSYSFUNC* = 11; |
idSYSPROC* = 12; idIMP* = 13; |
tINTEGER* = 1; tBYTE* = 2; tCHAR* = 3; tSET* = 4; |
tBOOLEAN* = 5; tREAL* = 6; tARRAY* = 7; tRECORD* = 8; |
tPOINTER* = 9; tPROCEDURE* = 10; tSTRING* = 11; tNIL* = 12; |
tCARD16* = 13; tCARD32* = 14; tANYREC* = 15; tWCHAR* = 16; |
BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD16, tCARD32, tWCHAR}; |
stABS* = 1; stASR* = 2; stCHR* = 3; stFLOOR* = 4; |
stFLT* = 5; stLEN* = 6; stLSL* = 7; stODD* = 8; |
stORD* = 9; stROR* = 10; stASSERT* = 11; stDEC* = 12; |
stEXCL* = 13; stINC* = 14; stINCL* = 15; stNEW* = 16; |
stPACK* = 17; stUNPK* = 18; sysADR* = 19; sysSIZE* = 20; |
sysGET* = 21; sysPUT* = 22; |
stDISPOSE* = 23; stLSR* = 24; stBITS* = 25; sysCODE* = 26; |
sysMOVE* = 27; stLENGTH* = 28; stMIN* = 29; stMAX* = 30; |
sysSADR* = 31; sysTYPEID* = 32; sysCOPY* = 33; sysINF* = 34; |
sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38; |
sysWSADR* = 39; sysPUT32* = 40; |
default* = 2; |
stdcall* = 4; _stdcall* = stdcall + 1; |
ccall* = 6; _ccall* = ccall + 1; |
ccall16* = 8; _ccall16* = ccall16 + 1; |
win64* = 10; _win64* = win64 + 1; |
stdcall64* = 12; _stdcall64* = stdcall64 + 1; |
default64* = 14; |
systemv* = 16; _systemv* = systemv + 1; |
noalign* = 20; |
callee_clean_up* = {default, stdcall, _stdcall, default64, stdcall64, _stdcall64}; |
caller_clean_up* = {ccall, ccall16, win64, systemv, _ccall, _ccall16, _win64, _systemv}; |
callconv32* = {default, stdcall, ccall, ccall16, _stdcall, _ccall, _ccall16}; |
callconv64* = {default64, win64, stdcall64, systemv, _win64, _stdcall64, _systemv}; |
STACK_FRAME = 2; |
TYPE |
IDENT* = POINTER TO rIDENT; |
UNIT* = POINTER TO rUNIT; |
PROGRAM* = POINTER TO rPROGRAM; |
TYPE_* = POINTER TO rTYPE_; |
FRWPTR* = POINTER TO RECORD (LISTS.ITEM) |
type: TYPE_; |
baseIdent: SCAN.IDENT; |
linked: BOOLEAN; |
pos*: SCAN.POSITION; |
notRecord*: BOOLEAN |
END; |
IDENTS = POINTER TO RECORD (LISTS.LIST) |
add*: PROCEDURE (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT; |
get*: PROCEDURE (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT |
END; |
PROC* = POINTER TO RECORD (LISTS.ITEM) |
label*: INTEGER; |
used*: BOOLEAN; |
processed*: BOOLEAN; |
import*: LISTS.ITEM; |
using*: LISTS.LIST; |
enter*, |
leave*: LISTS.ITEM |
END; |
USED_PROC = POINTER TO RECORD (LISTS.ITEM) |
proc: PROC |
END; |
rUNIT = RECORD (LISTS.ITEM) |
program*: PROGRAM; |
name*: SCAN.IDENT; |
idents*: IDENTS; |
frwPointers: LISTS.LIST; |
gscope: IDENT; |
closed*: BOOLEAN; |
scopeLvl*: INTEGER; |
sysimport*: BOOLEAN; |
scopes*: ARRAY MAXSCOPE OF PROC; |
scope*: RECORD |
open*: PROCEDURE (unit: UNIT; proc: PROC): BOOLEAN; |
close*: PROCEDURE (unit: UNIT; variables: LISTS.LIST) |
END; |
close*: PROCEDURE (unit: UNIT); |
setvars*: PROCEDURE (unit: UNIT; type: TYPE_); |
pointers*: RECORD |
add*: PROCEDURE (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION); |
link*: PROCEDURE (unit: UNIT): FRWPTR |
END |
END; |
FIELD* = POINTER TO rFIELD; |
PARAM* = POINTER TO rPARAM; |
FIELDS = POINTER TO RECORD (LISTS.LIST) |
add*: PROCEDURE (rec: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN; |
get*: PROCEDURE (rec: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD; |
set*: PROCEDURE (rec: TYPE_; type: TYPE_): BOOLEAN |
END; |
PARAMS = POINTER TO RECORD (LISTS.LIST) |
size*: INTEGER; |
add*: PROCEDURE (proc: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN; |
get*: PROCEDURE (proc: TYPE_; name: SCAN.IDENT): PARAM; |
set*: PROCEDURE (proc: TYPE_; type: TYPE_); |
getfparams*: PROCEDURE (proc: TYPE_; maxparam: INTEGER; VAR int, flt: INTEGER): SET |
END; |
rTYPE_ = RECORD (LISTS.ITEM) |
typ*: INTEGER; |
size*: INTEGER; |
length*: INTEGER; |
align*: INTEGER; |
base*: TYPE_; |
fields*: FIELDS; |
params*: PARAMS; |
unit*: UNIT; |
closed*: BOOLEAN; |
num*: INTEGER; |
call*: INTEGER; |
import*: BOOLEAN; |
noalign*: BOOLEAN |
END; |
rFIELD = RECORD (LISTS.ITEM) |
type*: TYPE_; |
name*: SCAN.IDENT; |
export*: BOOLEAN; |
offset*: INTEGER |
END; |
rPARAM = RECORD (LISTS.ITEM) |
name*: SCAN.IDENT; |
type*: TYPE_; |
vPar*: BOOLEAN; |
offset*: INTEGER |
END; |
rIDENT = RECORD (LISTS.ITEM) |
name*: SCAN.IDENT; |
typ*: INTEGER; |
export*: BOOLEAN; |
import*: LISTS.ITEM; |
unit*: UNIT; |
value*: ARITH.VALUE; |
type*: TYPE_; |
stproc*: INTEGER; |
global*: BOOLEAN; |
scopeLvl*: INTEGER; |
offset*: INTEGER; |
proc*: PROC; |
pos*: SCAN.POSITION |
END; |
UNITS* = POINTER TO RECORD (LISTS.LIST) |
program: PROGRAM; |
create*: PROCEDURE (units: UNITS; name: SCAN.IDENT): UNIT; |
get*: PROCEDURE (units: UNITS; name: SCAN.IDENT): UNIT |
END; |
rPROGRAM = RECORD |
recCount: INTEGER; |
units*: UNITS; |
types*: LISTS.LIST; |
sysunit*: UNIT; |
rtl*: UNIT; |
bss*: INTEGER; |
locsize*: INTEGER; |
procs*: LISTS.LIST; |
dll*: BOOLEAN; |
obj*: BOOLEAN; |
stTypes*: RECORD |
tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*, tSTRING*, tNIL*, |
tCARD16*, tCARD32*, tANYREC*: TYPE_ |
END; |
target*: RECORD |
bit_depth*: INTEGER; |
word*: INTEGER; |
adr*: INTEGER; |
sys*: INTEGER |
END; |
enterType*: PROCEDURE (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_; |
getType*: PROCEDURE (program: PROGRAM; typ: INTEGER): TYPE_ |
END; |
DELIMPORT = PROCEDURE (import: LISTS.ITEM); |
VAR |
idents: C.COLLECTION; |
PROCEDURE NewIdent (): IDENT; |
VAR |
ident: IDENT; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(idents); |
IF citem = NIL THEN |
NEW(ident) |
ELSE |
ident := citem(IDENT) |
END |
RETURN ident |
END NewIdent; |
PROCEDURE getOffset* (program: PROGRAM; varIdent: IDENT): INTEGER; |
VAR |
word: INTEGER; |
size: INTEGER; |
BEGIN |
IF varIdent.offset = -1 THEN |
IF varIdent.global THEN |
IF MACHINE.Align(program.bss, varIdent.type.align) THEN |
IF UTILS.maxint - program.bss >= varIdent.type.size THEN |
varIdent.offset := program.bss; |
INC(program.bss, varIdent.type.size) |
END |
END |
ELSE |
word := program.target.word; |
size := varIdent.type.size; |
IF MACHINE.Align(size, word) THEN |
size := size DIV word; |
IF UTILS.maxint - program.locsize >= size THEN |
INC(program.locsize, size); |
varIdent.offset := program.locsize; |
END |
END |
END |
END |
RETURN varIdent.offset |
END getOffset; |
PROCEDURE close (unit: UNIT); |
VAR |
ident, prev: IDENT; |
offset: INTEGER; |
BEGIN |
ident := unit.idents.last(IDENT); |
WHILE (ident # NIL) & (ident.typ # idGUARD) DO |
IF (ident.typ = idVAR) & (ident.offset = -1) THEN |
ERRORS.hintmsg(ident.name.s, ident.pos.line, ident.pos.col, 0); |
IF ident.export THEN |
offset := getOffset(unit.program, ident) |
END |
END; |
ident := ident.prev(IDENT) |
END; |
ident := unit.idents.last(IDENT); |
WHILE ident # NIL DO |
prev := ident.prev(IDENT); |
IF ~ident.export THEN |
LISTS.delete(unit.idents, ident); |
C.push(idents, ident) |
END; |
ident := prev |
END; |
unit.closed := TRUE |
END close; |
PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN; |
VAR |
item: IDENT; |
BEGIN |
ASSERT(ident # NIL); |
item := unit.idents.last(IDENT); |
WHILE (item.typ # idGUARD) & (item.name # ident) DO |
item := item.prev(IDENT) |
END |
RETURN item.typ = idGUARD |
END unique; |
PROCEDURE addIdent (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT; |
VAR |
item: IDENT; |
res: BOOLEAN; |
proc: PROC; |
procs: LISTS.LIST; |
BEGIN |
ASSERT(unit # NIL); |
ASSERT(ident # NIL); |
res := unique(unit, ident); |
IF res THEN |
item := NewIdent(); |
item.name := ident; |
item.typ := typ; |
item.unit := NIL; |
item.export := FALSE; |
item.import := NIL; |
item.type := NIL; |
item.value.typ := 0; |
item.stproc := 0; |
item.global := unit.scopeLvl = 0; |
item.scopeLvl := unit.scopeLvl; |
item.offset := -1; |
IF item.typ IN {idPROC, idIMP} THEN |
NEW(proc); |
proc.import := NIL; |
proc.label := 0; |
proc.used := FALSE; |
proc.processed := FALSE; |
proc.using := LISTS.create(NIL); |
procs := unit.program.procs; |
LISTS.push(procs, proc); |
item.proc := proc |
END; |
LISTS.push(unit.idents, item) |
ELSE |
item := NIL |
END |
RETURN item |
END addIdent; |
PROCEDURE UseProc* (unit: UNIT; call_proc: PROC); |
VAR |
procs: LISTS.LIST; |
cur: LISTS.ITEM; |
proc: USED_PROC; |
BEGIN |
IF unit.scopeLvl = 0 THEN |
call_proc.used := TRUE |
ELSE |
procs := unit.scopes[unit.scopeLvl].using; |
cur := procs.first; |
WHILE (cur # NIL) & (cur(USED_PROC).proc # call_proc) DO |
cur := cur.next |
END; |
IF cur = NIL THEN |
NEW(proc); |
proc.proc := call_proc; |
LISTS.push(procs, proc) |
END |
END |
END UseProc; |
PROCEDURE setvars (unit: UNIT; type: TYPE_); |
VAR |
item: IDENT; |
BEGIN |
ASSERT(type # NIL); |
item := unit.idents.last(IDENT); |
WHILE (item # NIL) & (item.typ = idVAR) & (item.type = NIL) DO |
item.type := type; |
item := item.prev(IDENT) |
END |
END setvars; |
PROCEDURE getIdent (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT; |
VAR |
item: IDENT; |
BEGIN |
ASSERT(ident # NIL); |
item := unit.idents.last(IDENT); |
ASSERT(item # NIL); |
IF currentScope THEN |
WHILE (item.name # ident) & (item.typ # idGUARD) DO |
item := item.prev(IDENT) |
END; |
IF item.name # ident THEN |
item := NIL |
END |
ELSE |
WHILE (item # NIL) & (item.name # ident) DO |
item := item.prev(IDENT) |
END |
END |
RETURN item |
END getIdent; |
PROCEDURE openScope (unit: UNIT; proc: PROC): BOOLEAN; |
VAR |
item: IDENT; |
res: BOOLEAN; |
BEGIN |
INC(unit.scopeLvl); |
res := unit.scopeLvl < MAXSCOPE; |
IF res THEN |
unit.scopes[unit.scopeLvl] := proc; |
NEW(item); |
item := NewIdent(); |
item.name := NIL; |
item.typ := idGUARD; |
LISTS.push(unit.idents, item) |
END |
RETURN res |
END openScope; |
PROCEDURE closeScope (unit: UNIT; variables: LISTS.LIST); |
VAR |
item: IDENT; |
del: IDENT; |
lvar: CODE.LOCALVAR; |
BEGIN |
item := unit.idents.last(IDENT); |
WHILE (item # NIL) & (item.typ # idGUARD) DO |
del := item; |
item := item.prev(IDENT); |
IF (del.typ = idVAR) & (del.offset = -1) THEN |
ERRORS.hintmsg(del.name.s, del.pos.line, del.pos.col, 0) |
END; |
IF (variables # NIL) & (del.typ IN {idVAR, idPARAM}) & (del.offset # -1) THEN |
IF del.type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN |
lvar := CODE.NewVar(); |
lvar.offset := del.offset; |
lvar.size := del.type.size; |
IF del.typ = idVAR THEN |
lvar.offset := -lvar.offset |
END; |
LISTS.push(variables, lvar) |
END |
END; |
LISTS.delete(unit.idents, del); |
C.push(idents, del) |
END; |
IF (item # NIL) & (item.typ = idGUARD) THEN |
LISTS.delete(unit.idents, item); |
C.push(idents, item) |
END; |
DEC(unit.scopeLvl) |
END closeScope; |
PROCEDURE frwptr (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION); |
VAR |
newptr: FRWPTR; |
BEGIN |
ASSERT(unit # NIL); |
ASSERT(type # NIL); |
ASSERT(baseIdent # NIL); |
NEW(newptr); |
newptr.type := type; |
newptr.baseIdent := baseIdent; |
newptr.pos := pos; |
newptr.linked := FALSE; |
newptr.notRecord := FALSE; |
LISTS.push(unit.frwPointers, newptr) |
END frwptr; |
PROCEDURE linkptr (unit: UNIT): FRWPTR; |
VAR |
item: FRWPTR; |
ident: IDENT; |
res: FRWPTR; |
BEGIN |
res := NIL; |
item := unit.frwPointers.last(FRWPTR); |
WHILE (item # NIL) & ~item.linked & (res = NIL) DO |
ident := unit.idents.get(unit, item.baseIdent, TRUE); |
IF (ident # NIL) THEN |
IF (ident.typ = idTYPE) & (ident.type.typ = tRECORD) THEN |
item.type.base := ident.type; |
item.linked := TRUE |
ELSE |
item.notRecord := TRUE; |
res := item |
END |
ELSE |
item.notRecord := FALSE; |
res := item |
END; |
item := item.prev(FRWPTR) |
END |
RETURN res |
END linkptr; |
PROCEDURE isTypeEq* (t1, t2: TYPE_): BOOLEAN; |
VAR |
res: BOOLEAN; |
param1, param2: LISTS.ITEM; |
BEGIN |
IF t1 = t2 THEN |
res := TRUE |
ELSIF (t1 = NIL) OR (t2 = NIL) THEN |
res := FALSE |
ELSIF (t1.typ = tPROCEDURE) & (t2.typ = tPROCEDURE) THEN |
param1 := t1.params.first; |
param2 := t2.params.first; |
res := (t1.call = t2.call) & ((param1 # NIL) = (param2 # NIL)); |
WHILE res & (param1 # NIL) & (param2 # NIL) DO |
res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM).type, param2(PARAM).type); |
param1 := param1.next; |
param2 := param2.next; |
res := res & ((param1 # NIL) = (param2 # NIL)) |
END; |
res := res & isTypeEq(t1.base, t2.base) |
ELSIF (t1.typ = tARRAY) & (t2.typ = tARRAY) THEN |
res := (t1.length = 0) & (t2.length = 0) & isTypeEq(t1.base, t2.base) |
ELSE |
res := FALSE |
END |
RETURN res |
END isTypeEq; |
PROCEDURE isBaseOf* (t0, t1: TYPE_): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := ((t0.typ = tPOINTER) & (t1.typ = tPOINTER)) OR ((t0.typ = tRECORD) & (t1.typ = tRECORD)); |
IF (t0.typ = tPOINTER) & (t1.typ = tPOINTER) THEN |
t0 := t0.base; |
t1 := t1.base |
END; |
WHILE res & (t1 # NIL) & (t1 # t0) DO |
t1 := t1.base |
END |
RETURN res & (t1 = t0) |
END isBaseOf; |
PROCEDURE isOpenArray* (t: TYPE_): BOOLEAN; |
RETURN (t.typ = tARRAY) & (t.length = 0) |
END isOpenArray; |
PROCEDURE getunit (units: UNITS; name: SCAN.IDENT): UNIT; |
VAR |
item: UNIT; |
BEGIN |
ASSERT(name # NIL); |
item := units.first(UNIT); |
WHILE (item # NIL) & (item.name # name) DO |
item := item.next(UNIT) |
END; |
IF (item = NIL) & (name.s = "SYSTEM") THEN |
item := units.program.sysunit |
END |
RETURN item |
END getunit; |
PROCEDURE enterStTypes (unit: UNIT; program: PROGRAM); |
VAR |
ident: IDENT; |
stName: SCAN.IDENT; |
BEGIN |
stName := SCAN.enterid("INTEGER"); |
ident := addIdent(unit, stName, idTYPE); |
ident.type := program.stTypes.tINTEGER; |
stName := SCAN.enterid("BYTE"); |
ident := addIdent(unit, stName, idTYPE); |
ident.type := program.stTypes.tBYTE; |
stName := SCAN.enterid("CHAR"); |
ident := addIdent(unit, stName, idTYPE); |
ident.type := program.stTypes.tCHAR; |
stName := SCAN.enterid("WCHAR"); |
ident := addIdent(unit, stName, idTYPE); |
ident.type := program.stTypes.tWCHAR; |
stName := SCAN.enterid("SET"); |
ident := addIdent(unit, stName, idTYPE); |
ident.type := program.stTypes.tSET; |
stName := SCAN.enterid("BOOLEAN"); |
ident := addIdent(unit, stName, idTYPE); |
ident.type := program.stTypes.tBOOLEAN; |
stName := SCAN.enterid("REAL"); |
ident := addIdent(unit, stName, idTYPE); |
ident.type := program.stTypes.tREAL; |
END enterStTypes; |
PROCEDURE enterStProcs (unit: UNIT); |
PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER); |
VAR |
ident: IDENT; |
BEGIN |
ident := addIdent(unit, SCAN.enterid(name), idtyp); |
ident.stproc := proc |
END EnterProc; |
BEGIN |
EnterProc(unit, "ASSERT", idSTPROC, stASSERT); |
EnterProc(unit, "DEC", idSTPROC, stDEC); |
EnterProc(unit, "EXCL", idSTPROC, stEXCL); |
EnterProc(unit, "INC", idSTPROC, stINC); |
EnterProc(unit, "INCL", idSTPROC, stINCL); |
EnterProc(unit, "NEW", idSTPROC, stNEW); |
EnterProc(unit, "PACK", idSTPROC, stPACK); |
EnterProc(unit, "UNPK", idSTPROC, stUNPK); |
EnterProc(unit, "DISPOSE", idSTPROC, stDISPOSE); |
EnterProc(unit, "COPY", idSTPROC, stCOPY); |
EnterProc(unit, "ABS", idSTFUNC, stABS); |
EnterProc(unit, "ASR", idSTFUNC, stASR); |
EnterProc(unit, "CHR", idSTFUNC, stCHR); |
EnterProc(unit, "WCHR", idSTFUNC, stWCHR); |
EnterProc(unit, "FLOOR", idSTFUNC, stFLOOR); |
EnterProc(unit, "FLT", idSTFUNC, stFLT); |
EnterProc(unit, "LEN", idSTFUNC, stLEN); |
EnterProc(unit, "LSL", idSTFUNC, stLSL); |
EnterProc(unit, "ODD", idSTFUNC, stODD); |
EnterProc(unit, "ORD", idSTFUNC, stORD); |
EnterProc(unit, "ROR", idSTFUNC, stROR); |
EnterProc(unit, "BITS", idSTFUNC, stBITS); |
EnterProc(unit, "LSR", idSTFUNC, stLSR); |
EnterProc(unit, "LENGTH", idSTFUNC, stLENGTH); |
EnterProc(unit, "MIN", idSTFUNC, stMIN); |
EnterProc(unit, "MAX", idSTFUNC, stMAX); |
END enterStProcs; |
PROCEDURE newunit (units: UNITS; name: SCAN.IDENT): UNIT; |
VAR |
unit: UNIT; |
idents: IDENTS; |
BEGIN |
ASSERT(units # NIL); |
ASSERT(name # NIL); |
NEW(unit); |
NEW(idents); |
ASSERT(LISTS.create(idents) = idents); |
idents.add := addIdent; |
idents.get := getIdent; |
unit.program := units.program; |
unit.name := name; |
unit.closed := FALSE; |
unit.idents := idents; |
unit.frwPointers := LISTS.create(NIL); |
unit.scope.open := openScope; |
unit.scope.close := closeScope; |
unit.close := close; |
unit.setvars := setvars; |
unit.pointers.add := frwptr; |
unit.pointers.link := linkptr; |
ASSERT(unit.scope.open(unit, NIL)); |
enterStTypes(unit, units.program); |
enterStProcs(unit); |
ASSERT(unit.scope.open(unit, NIL)); |
unit.gscope := unit.idents.last(IDENT); |
LISTS.push(units, unit); |
unit.scopeLvl := 0; |
unit.scopes[0] := NIL; |
unit.sysimport := FALSE; |
IF unit.name.s = mConst.RTL_NAME THEN |
unit.program.rtl := unit |
END |
RETURN unit |
END newunit; |
PROCEDURE getField (self: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD; |
VAR |
field: FIELD; |
BEGIN |
ASSERT(self # NIL); |
ASSERT(name # NIL); |
ASSERT(unit # NIL); |
field := NIL; |
WHILE (self # NIL) & (field = NIL) DO |
field := self.fields.first(FIELD); |
WHILE (field # NIL) & (field.name # name) DO |
field := field.next(FIELD) |
END; |
IF field = NIL THEN |
self := self.base |
END |
END; |
IF (field # NIL) & (self.unit # unit) & ~field.export THEN |
field := NIL |
END |
RETURN field |
END getField; |
PROCEDURE addField (self: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN; |
VAR |
field: FIELD; |
res: BOOLEAN; |
BEGIN |
ASSERT(name # NIL); |
res := getField(self, name, self.unit) = NIL; |
IF res THEN |
NEW(field); |
field.name := name; |
field.export := export; |
field.type := NIL; |
field.offset := self.size; |
LISTS.push(self.fields, field) |
END |
RETURN res |
END addField; |
PROCEDURE setFields (self: TYPE_; type: TYPE_): BOOLEAN; |
VAR |
item: FIELD; |
res: BOOLEAN; |
BEGIN |
ASSERT(type # NIL); |
item := self.fields.first(FIELD); |
WHILE (item # NIL) & (item.type # NIL) DO |
item := item.next(FIELD) |
END; |
res := TRUE; |
WHILE res & (item # NIL) & (item.type = NIL) DO |
item.type := type; |
IF ~self.noalign THEN |
res := MACHINE.Align(self.size, type.align) |
ELSE |
res := TRUE |
END; |
item.offset := self.size; |
res := res & (UTILS.maxint - self.size >= type.size); |
IF res THEN |
INC(self.size, type.size) |
END; |
item := item.next(FIELD) |
END |
RETURN res |
END setFields; |
PROCEDURE getParam (self: TYPE_; name: SCAN.IDENT): PARAM; |
VAR |
item: PARAM; |
BEGIN |
ASSERT(name # NIL); |
item := self.params.first(PARAM); |
WHILE (item # NIL) & (item.name # name) DO |
item := item.next(PARAM) |
END |
RETURN item |
END getParam; |
PROCEDURE addParam (self: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN; |
VAR |
param: PARAM; |
res: BOOLEAN; |
BEGIN |
ASSERT(name # NIL); |
res := self.params.get(self, name) = NIL; |
IF res THEN |
NEW(param); |
param.name := name; |
param.type := NIL; |
param.vPar := vPar; |
LISTS.push(self.params, param) |
END |
RETURN res |
END addParam; |
PROCEDURE Dim* (t: TYPE_): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
res := 0; |
WHILE isOpenArray(t) DO |
t := t.base; |
INC(res) |
END |
RETURN res |
END Dim; |
PROCEDURE OpenBase* (t: TYPE_): TYPE_; |
BEGIN |
WHILE isOpenArray(t) DO t := t.base END |
RETURN t |
END OpenBase; |
PROCEDURE getFloatParamsPos (self: TYPE_; maxoffs: INTEGER; VAR int, flt: INTEGER): SET; |
VAR |
res: SET; |
param: PARAM; |
BEGIN |
res := {}; |
int := 0; |
flt := 0; |
param := self.params.first(PARAM); |
WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO |
IF ~param.vPar & (param.type.typ = tREAL) THEN |
INCL(res, param.offset - STACK_FRAME); |
INC(flt) |
END; |
param := param.next(PARAM) |
END; |
int := self.params.size - flt |
RETURN res |
END getFloatParamsPos; |
PROCEDURE setParams (self: TYPE_; type: TYPE_); |
VAR |
item: LISTS.ITEM; |
param: PARAM; |
word, size: INTEGER; |
BEGIN |
ASSERT(type # NIL); |
word := MACHINE.target.bit_depth DIV 8; |
item := self.params.first; |
WHILE (item # NIL) & (item(PARAM).type # NIL) DO |
item := item.next |
END; |
WHILE (item # NIL) & (item(PARAM).type = NIL) DO |
param := item(PARAM); |
param.type := type; |
IF param.vPar THEN |
IF type.typ = tRECORD THEN |
size := 2 |
ELSIF isOpenArray(type) THEN |
size := Dim(type) + 1 |
ELSE |
size := 1 |
END; |
param.offset := self.params.size + ORD(type.typ = tRECORD) + Dim(type) + STACK_FRAME; |
INC(self.params.size, size) |
ELSE |
IF type.typ IN {tRECORD, tARRAY} THEN |
IF isOpenArray(type) THEN |
size := Dim(type) + 1 |
ELSE |
size := 1 |
END |
ELSE |
size := type.size; |
ASSERT(MACHINE.Align(size, word)); |
size := size DIV word |
END; |
param.offset := self.params.size + Dim(type) + STACK_FRAME; |
INC(self.params.size, size) |
END; |
item := item.next |
END |
END setParams; |
PROCEDURE enterType (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_; |
VAR |
t: TYPE_; |
fields: FIELDS; |
params: PARAMS; |
BEGIN |
NEW(t); |
NEW(fields); |
ASSERT(LISTS.create(fields) = fields); |
NEW(params); |
ASSERT(LISTS.create(params) = params); |
t.typ := typ; |
t.size := size; |
t.length := length; |
t.align := 0; |
t.base := NIL; |
t.fields := fields; |
t.params := params; |
t.unit := unit; |
t.num := 0; |
IF program.target.bit_depth = 32 THEN |
t.call := default |
ELSIF program.target.bit_depth = 64 THEN |
t.call := default64 |
END; |
t.import := FALSE; |
t.noalign := FALSE; |
t.fields.add := addField; |
t.fields.get := getField; |
t.fields.set := setFields; |
t.params.add := addParam; |
t.params.get := getParam; |
t.params.getfparams := getFloatParamsPos; |
t.params.set := setParams; |
t.params.size := 0; |
IF typ IN {tARRAY, tRECORD} THEN |
t.closed := FALSE; |
IF typ = tRECORD THEN |
INC(program.recCount); |
t.num := program.recCount |
END |
ELSE |
t.closed := TRUE |
END; |
LISTS.push(program.types, t) |
RETURN t |
END enterType; |
PROCEDURE getType (program: PROGRAM; typ: INTEGER): TYPE_; |
VAR |
res: TYPE_; |
BEGIN |
IF typ = ARITH.tINTEGER THEN |
res := program.stTypes.tINTEGER |
ELSIF typ = ARITH.tREAL THEN |
res := program.stTypes.tREAL |
ELSIF typ = ARITH.tSET THEN |
res := program.stTypes.tSET |
ELSIF typ = ARITH.tBOOLEAN THEN |
res := program.stTypes.tBOOLEAN |
ELSIF typ = ARITH.tCHAR THEN |
res := program.stTypes.tCHAR |
ELSIF typ = ARITH.tWCHAR THEN |
res := program.stTypes.tWCHAR |
ELSIF typ = ARITH.tSTRING THEN |
res := program.stTypes.tSTRING |
ELSE |
res := NIL |
END; |
ASSERT(res # NIL) |
RETURN res |
END getType; |
PROCEDURE createSysUnit (program: PROGRAM); |
VAR |
ident: IDENT; |
unit: UNIT; |
PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER); |
VAR |
ident: IDENT; |
BEGIN |
ident := addIdent(sys, SCAN.enterid(name), idtyp); |
ident.stproc := proc; |
ident.export := TRUE |
END EnterProc; |
BEGIN |
unit := program.units.create(program.units, SCAN.enterid("$SYSTEM")); |
EnterProc(unit, "ADR", idSYSFUNC, sysADR); |
EnterProc(unit, "SIZE", idSYSFUNC, sysSIZE); |
EnterProc(unit, "SADR", idSYSFUNC, sysSADR); |
EnterProc(unit, "WSADR", idSYSFUNC, sysWSADR); |
EnterProc(unit, "TYPEID", idSYSFUNC, sysTYPEID); |
EnterProc(unit, "INF", idSYSFUNC, sysINF); |
EnterProc(unit, "GET", idSYSPROC, sysGET); |
EnterProc(unit, "PUT", idSYSPROC, sysPUT); |
EnterProc(unit, "PUT8", idSYSPROC, sysPUT8); |
EnterProc(unit, "PUT16", idSYSPROC, sysPUT16); |
EnterProc(unit, "PUT32", idSYSPROC, sysPUT32); |
EnterProc(unit, "CODE", idSYSPROC, sysCODE); |
EnterProc(unit, "MOVE", idSYSPROC, sysMOVE); |
EnterProc(unit, "COPY", idSYSPROC, sysCOPY); |
ident := addIdent(unit, SCAN.enterid("CARD16"), idTYPE); |
ident.type := program.stTypes.tCARD16; |
ident.export := TRUE; |
ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE); |
ident.type := program.stTypes.tCARD32; |
ident.export := TRUE; |
unit.close(unit); |
program.sysunit := unit |
END createSysUnit; |
PROCEDURE DelUnused* (program: PROGRAM; DelImport: DELIMPORT); |
VAR |
proc: PROC; |
flag: BOOLEAN; |
PROCEDURE process (proc: PROC); |
VAR |
used_proc: LISTS.ITEM; |
BEGIN |
proc.processed := TRUE; |
used_proc := proc.using.first; |
WHILE used_proc # NIL DO |
used_proc(USED_PROC).proc.used := TRUE; |
used_proc := used_proc.next |
END |
END process; |
BEGIN |
REPEAT |
flag := FALSE; |
proc := program.procs.first(PROC); |
WHILE proc # NIL DO |
IF proc.used & ~proc.processed THEN |
process(proc); |
flag := TRUE |
END; |
proc := proc.next(PROC) |
END |
UNTIL ~flag; |
proc := program.procs.first(PROC); |
WHILE proc # NIL DO |
IF ~proc.used THEN |
IF proc.import = NIL THEN |
CODE.delete2(proc.enter, proc.leave) |
ELSE |
DelImport(proc.import) |
END |
END; |
proc := proc.next(PROC) |
END |
END DelUnused; |
PROCEDURE create* (bit_depth, sys: INTEGER): PROGRAM; |
VAR |
program: PROGRAM; |
units: UNITS; |
BEGIN |
idents := C.create(); |
MACHINE.SetBitDepth(bit_depth); |
NEW(program); |
NEW(units); |
ASSERT(LISTS.create(units) = units); |
program.target.bit_depth := bit_depth; |
program.target.word := bit_depth DIV 8; |
program.target.adr := bit_depth DIV 8; |
program.target.sys := sys; |
program.recCount := -1; |
program.bss := 0; |
program.units := units; |
program.types := LISTS.create(NIL); |
program.procs := LISTS.create(NIL); |
program.enterType := enterType; |
program.getType := getType; |
program.stTypes.tINTEGER := enterType(program, tINTEGER, program.target.word, 0, NIL); |
program.stTypes.tBYTE := enterType(program, tBYTE, 1, 0, NIL); |
program.stTypes.tCHAR := enterType(program, tCHAR, 1, 0, NIL); |
program.stTypes.tWCHAR := enterType(program, tWCHAR, 2, 0, NIL); |
program.stTypes.tSET := enterType(program, tSET, program.target.word, 0, NIL); |
program.stTypes.tBOOLEAN := enterType(program, tBOOLEAN, 1, 0, NIL); |
program.stTypes.tREAL := enterType(program, tREAL, 8, 0, NIL); |
program.stTypes.tSTRING := enterType(program, tSTRING, program.target.word, 0, NIL); |
program.stTypes.tNIL := enterType(program, tNIL, program.target.word, 0, NIL); |
program.stTypes.tCARD16 := enterType(program, tCARD16, 2, 0, NIL); |
program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL); |
program.stTypes.tANYREC := enterType(program, tRECORD, 0, 0, NIL); |
program.stTypes.tANYREC.closed := TRUE; |
program.stTypes.tINTEGER.align := program.stTypes.tINTEGER.size; |
program.stTypes.tBYTE.align := 1; |
program.stTypes.tCHAR.align := program.stTypes.tCHAR.size; |
program.stTypes.tWCHAR.align := program.stTypes.tWCHAR.size; |
program.stTypes.tSET.align := program.stTypes.tSET.size; |
program.stTypes.tBOOLEAN.align := program.stTypes.tBOOLEAN.size; |
program.stTypes.tREAL.align := program.stTypes.tREAL.size; |
program.stTypes.tCARD16.align := program.stTypes.tCARD16.size; |
program.stTypes.tCARD32.align := program.stTypes.tCARD32.size; |
units.program := program; |
units.create := newunit; |
units.get := getunit; |
program.dll := FALSE; |
program.obj := FALSE; |
createSysUnit(program) |
RETURN program |
END create; |
END PROG. |
/programs/develop/oberon07/Source/REG.ob07 |
---|
0,0 → 1,434 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE REG; |
CONST |
N = 16; |
R0* = 0; R1* = 1; R2* = 2; |
R8* = 8; R9* = 9; R10* = 10; R11* = 11; |
NVR = 32; |
TYPE |
OP1 = PROCEDURE (arg: INTEGER); |
OP2 = PROCEDURE (arg1, arg2: INTEGER); |
OP3 = PROCEDURE (arg1, arg2, arg3: INTEGER); |
REGS* = POINTER TO RECORD |
regs*: SET; |
stk*: ARRAY N OF INTEGER; |
top*: INTEGER; |
pushed*: INTEGER; |
vregs*: SET; |
offs: ARRAY NVR OF INTEGER; |
size: ARRAY NVR OF INTEGER; |
push, pop: OP1; |
mov, xch: OP2; |
load, save: OP3 |
END; |
PROCEDURE push (R: REGS); |
VAR |
i, reg: INTEGER; |
BEGIN |
reg := R.stk[0]; |
INCL(R.regs, reg); |
R.push(reg); |
FOR i := 0 TO R.top - 1 DO |
R.stk[i] := R.stk[i + 1] |
END; |
DEC(R.top); |
INC(R.pushed) |
END push; |
PROCEDURE pop (R: REGS; reg: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := R.top + 1 TO 1 BY -1 DO |
R.stk[i] := R.stk[i - 1] |
END; |
R.stk[0] := reg; |
EXCL(R.regs, reg); |
R.pop(reg); |
INC(R.top); |
DEC(R.pushed) |
END pop; |
PROCEDURE InStk (R: REGS; reg: INTEGER): INTEGER; |
VAR |
i, n: INTEGER; |
BEGIN |
i := 0; |
n := R.top; |
WHILE (i <= n) & (R.stk[i] # reg) DO |
INC(i) |
END; |
IF i > n THEN |
i := -1 |
END |
RETURN i |
END InStk; |
PROCEDURE GetFreeReg (R: REGS): INTEGER; |
VAR |
i: INTEGER; |
BEGIN |
i := 0; |
WHILE (i < N) & ~(i IN R.regs) DO |
INC(i) |
END; |
IF i = N THEN |
i := -1 |
END |
RETURN i |
END GetFreeReg; |
PROCEDURE Put (R: REGS; reg: INTEGER); |
BEGIN |
EXCL(R.regs, reg); |
INC(R.top); |
R.stk[R.top] := reg |
END Put; |
PROCEDURE PopAnyReg (R: REGS): INTEGER; |
VAR |
reg: INTEGER; |
BEGIN |
reg := GetFreeReg(R); |
ASSERT(reg # -1); |
ASSERT(R.top < LEN(R.stk) - 1); |
ASSERT(R.pushed > 0); |
pop(R, reg) |
RETURN reg |
END PopAnyReg; |
PROCEDURE GetAnyReg* (R: REGS): INTEGER; |
VAR |
reg: INTEGER; |
BEGIN |
reg := GetFreeReg(R); |
IF reg = -1 THEN |
ASSERT(R.top >= 0); |
reg := R.stk[0]; |
push(R) |
END; |
Put(R, reg) |
RETURN reg |
END GetAnyReg; |
PROCEDURE GetReg* (R: REGS; reg: INTEGER): BOOLEAN; |
VAR |
free, n: INTEGER; |
res: BOOLEAN; |
PROCEDURE exch (R: REGS; reg1, reg2: INTEGER); |
VAR |
n1, n2: INTEGER; |
BEGIN |
n1 := InStk(R, reg1); |
n2 := InStk(R, reg2); |
R.stk[n1] := reg2; |
R.stk[n2] := reg1; |
R.xch(reg1, reg2) |
END exch; |
BEGIN |
IF reg IN R.regs THEN |
Put(R, reg); |
res := TRUE |
ELSE |
n := InStk(R, reg); |
IF n # -1 THEN |
free := GetFreeReg(R); |
IF free # -1 THEN |
Put(R, free); |
exch(R, reg, free) |
ELSE |
push(R); |
free := GetFreeReg(R); |
ASSERT(free # -1); |
Put(R, free); |
IF free # reg THEN |
exch(R, reg, free) |
END |
END; |
res := TRUE |
ELSE |
res := FALSE |
END |
END |
RETURN res |
END GetReg; |
PROCEDURE Exchange* (R: REGS; reg1, reg2: INTEGER): BOOLEAN; |
VAR |
n1, n2: INTEGER; |
res: BOOLEAN; |
BEGIN |
res := FALSE; |
IF reg1 # reg2 THEN |
n1 := InStk(R, reg1); |
n2 := InStk(R, reg2); |
IF (n1 # -1) & (n2 # -1) THEN |
R.stk[n1] := reg2; |
R.stk[n2] := reg1; |
R.xch(reg2, reg1); |
res := TRUE |
ELSIF (n1 # -1) & (reg2 IN R.regs) THEN |
R.stk[n1] := reg2; |
INCL(R.regs, reg1); |
EXCL(R.regs, reg2); |
R.mov(reg2, reg1); |
res := TRUE |
ELSIF (n2 # -1) & (reg1 IN R.regs) THEN |
R.stk[n2] := reg1; |
EXCL(R.regs, reg1); |
INCL(R.regs, reg2); |
R.mov(reg1, reg2); |
res := TRUE |
END |
ELSE |
res := TRUE |
END |
RETURN res |
END Exchange; |
PROCEDURE Drop* (R: REGS); |
BEGIN |
INCL(R.regs, R.stk[R.top]); |
DEC(R.top) |
END Drop; |
PROCEDURE BinOp* (R: REGS; VAR reg1, reg2: INTEGER); |
BEGIN |
IF R.top > 0 THEN |
reg1 := R.stk[R.top - 1]; |
reg2 := R.stk[R.top] |
ELSIF R.top = 0 THEN |
reg1 := PopAnyReg(R); |
reg2 := R.stk[R.top] |
ELSIF R.top < 0 THEN |
reg2 := PopAnyReg(R); |
reg1 := PopAnyReg(R) |
END |
END BinOp; |
PROCEDURE UnOp* (R: REGS; VAR reg: INTEGER); |
BEGIN |
IF R.top >= 0 THEN |
reg := R.stk[R.top] |
ELSE |
reg := PopAnyReg(R) |
END |
END UnOp; |
PROCEDURE PushAll* (R: REGS); |
BEGIN |
WHILE R.top >= 0 DO |
push(R) |
END |
END PushAll; |
PROCEDURE Lock* (R: REGS; reg, offs, size: INTEGER); |
BEGIN |
ASSERT(reg IN R.vregs); |
ASSERT(offs # 0); |
R.offs[reg] := offs; |
IF size = 0 THEN |
size := 8 |
END; |
R.size[reg] := size |
END Lock; |
PROCEDURE Release* (R: REGS; reg: INTEGER); |
BEGIN |
ASSERT(reg IN R.vregs); |
R.offs[reg] := 0 |
END Release; |
PROCEDURE Load* (R: REGS; reg: INTEGER); |
VAR |
offs: INTEGER; |
BEGIN |
ASSERT(reg IN R.vregs); |
offs := R.offs[reg]; |
IF offs # 0 THEN |
R.load(reg, offs, R.size[reg]) |
END |
END Load; |
PROCEDURE Save* (R: REGS; reg: INTEGER); |
VAR |
offs: INTEGER; |
BEGIN |
ASSERT(reg IN R.vregs); |
offs := R.offs[reg]; |
IF offs # 0 THEN |
R.save(reg, offs, R.size[reg]) |
END |
END Save; |
PROCEDURE Store* (R: REGS); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO NVR - 1 DO |
IF i IN R.vregs THEN |
Save(R, i) |
END |
END |
END Store; |
PROCEDURE Restore* (R: REGS); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO NVR - 1 DO |
IF i IN R.vregs THEN |
Load(R, i) |
END |
END |
END Restore; |
PROCEDURE Reset* (R: REGS); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO NVR - 1 DO |
IF i IN R.vregs THEN |
R.offs[i] := 0 |
END |
END |
END Reset; |
PROCEDURE GetVarReg* (R: REGS; offs: INTEGER): INTEGER; |
VAR |
i, res: INTEGER; |
BEGIN |
res := -1; |
i := 0; |
WHILE i < NVR DO |
IF (i IN R.vregs) & (R.offs[i] = offs) THEN |
res := i; |
i := NVR |
END; |
INC(i) |
END |
RETURN res |
END GetVarReg; |
PROCEDURE GetAnyVarReg* (R: REGS): INTEGER; |
VAR |
i, res: INTEGER; |
BEGIN |
res := -1; |
i := 0; |
WHILE i < NVR DO |
IF (i IN R.vregs) & (R.offs[i] = 0) THEN |
res := i; |
i := NVR |
END; |
INC(i) |
END |
RETURN res |
END GetAnyVarReg; |
PROCEDURE Create* (push, pop: OP1; mov, xch: OP2; load, save: OP3; regs, vregs: SET): REGS; |
VAR |
R: REGS; |
i: INTEGER; |
BEGIN |
NEW(R); |
R.regs := regs; |
R.pushed := 0; |
R.top := -1; |
R.push := push; |
R.pop := pop; |
R.mov := mov; |
R.xch := xch; |
R.load := load; |
R.save := save; |
R.vregs := vregs; |
FOR i := 0 TO NVR - 1 DO |
R.offs[i] := 0; |
R.size[i] := 0 |
END |
RETURN R |
END Create; |
END REG. |
/programs/develop/oberon07/Source/SCAN.ob07 |
---|
1,699 → 1,723 |
(* |
Copyright 2016 Anton Krotov |
(* |
BSD 2-Clause License |
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/>. |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE SCAN; |
IMPORT UTILS, sys := SYSTEM; |
IMPORT TEXTDRV, AVL := AVLTREES, ARITH, S := STRINGS, C := COLLECTIONS; |
CONST |
Tab = 8; |
maxINT* = 7FFFFFFFH; |
minINT* = 80000000H; |
maxREAL* = 3.39E38; |
maxDBL* = 1.69D308; |
minREAL* = 1.41E-45; |
IDLENGTH = 255; |
STRLENGTH* = 256; |
LEXLEN = 1024; |
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; |
lxUNDEF* = 0; lxIDENT* = 1; lxINTEGER* = 2; lxHEX* = 3; |
lxCHAR* = 4; lxFLOAT* = 5; lxSTRING* = 6; lxCOMMENT* = 7; |
lxEOF* = 8; |
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; |
lxKW = 101; |
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; |
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; |
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 |
TCoord* = RECORD line*, col*: INTEGER END; |
LEXSTR* = ARRAY LEXLEN OF CHAR; |
NODE* = POINTER TO RECORD |
Left, Right: NODE; |
tLex: INTEGER; |
Name*: UTILS.STRING |
IDENT* = POINTER TO RECORD (AVL.DATA) |
s*: LEXSTR; |
offset*, offsetW*: INTEGER |
END; |
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 |
POSITION* = RECORD |
line*, col*: INTEGER |
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 |
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; |
vocabulary: RECORD |
PROCEDURE AddNode*(Name: UTILS.STRING): NODE; |
VAR cur, res: NODE; |
KW: ARRAY 33 OF KEYWORD; |
PROCEDURE NewNode(Right: BOOLEAN); |
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; |
BEGIN |
NEW(res); |
UTILS.MemErr(res = NIL); |
res.Name := Name; |
res.tLex := lxIDENT; |
res.Left := NIL; |
res.Right := NIL; |
IF Right THEN |
cur.Right := res |
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 |
ELSE |
cur.Left := res |
lex.sym := lxKW + M; |
L := M; |
R := M |
END |
END NewNode; |
END; |
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) |
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 |
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; |
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; |
END key; |
PROCEDURE Recover*(scanner: SCANNER); |
PROCEDURE enterid* (s: LEXSTR): IDENT; |
VAR |
newnode: BOOLEAN; |
node: AVL.NODE; |
BEGIN |
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; |
vocabulary.ident.s := s; |
vocabulary.idents := AVL.insert(vocabulary.idents, vocabulary.ident, nodecmp, newnode, node); |
PROCEDURE Next; |
VAR cr: BOOLEAN; |
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); |
BEGIN |
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 |
IF lex.length < LEXLEN - 1 THEN |
lex.s[lex.length] := c; |
INC(lex.length); |
lex.s[lex.length] := 0X |
ELSE |
END; |
CR := cr; |
INC(bufpos) |
END Next; |
lex.over := TRUE |
END |
END putchar; |
PROCEDURE Open*(FName: ARRAY OF CHAR; VAR FHandle: INTEGER): BOOLEAN; |
VAR n, size: INTEGER; c: CHAR; |
PROCEDURE ident (text: TEXTDRV.TEXT; VAR lex: LEX); |
VAR |
c: CHAR; |
BEGIN |
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 |
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) |
END; |
Next |
END |
RETURN (File # 0) & (n = size) |
END Open; |
PROCEDURE Space(ch: CHAR): BOOLEAN; |
RETURN (ch <= 20X) & (ch > 0X) |
END Space; |
IF lex.over THEN |
lex.sym := lxERROR06 |
ELSE |
lex.sym := lxIDENT; |
key(lex) |
END; |
PROCEDURE Letter(ch: CHAR): BOOLEAN; |
RETURN (ch >= "A") & (ch <= "Z") OR (ch >= "a") & (ch <= "z") OR (ch = "_") |
END Letter; |
IF lex.sym = lxIDENT THEN |
lex.ident := enterid(lex.s) |
END |
PROCEDURE Digit*(ch: CHAR): BOOLEAN; |
RETURN (ch >= "0") & (ch <= "9") |
END Digit; |
END ident; |
PROCEDURE HexDigit*(ch: CHAR): BOOLEAN; |
RETURN (ch >= "A") & (ch <= "F") OR (ch >= "0") & (ch <= "9") |
END HexDigit; |
PROCEDURE PutChar(ch: CHAR); |
BEGIN |
Lex[count] := ch; |
IF ch # 0X THEN |
INC(count) |
END |
END PutChar; |
PROCEDURE number (text: TEXTDRV.TEXT; VAR lex: LEX; VAR range: BOOLEAN); |
VAR |
c: CHAR; |
hex: BOOLEAN; |
error: INTEGER; |
PROCEDURE PutNext(ch: CHAR); |
BEGIN |
PutChar(ch); |
Next |
END PutNext; |
c := text.peak(text); |
ASSERT(S.digit(c)); |
PROCEDURE Ident; |
BEGIN |
tLex := lxIDENT; |
WHILE Letter(ch) OR Digit(ch) DO |
PutNext(ch) |
error := 0; |
range := FALSE; |
lex.sym := lxINTEGER; |
hex := FALSE; |
WHILE S.digit(c) DO |
putchar(lex, c); |
text.nextc(text); |
c := text.peak(text) |
END; |
PutChar(0X); |
IF count > IDLENGTH THEN |
tLex := lxERR10 |
END |
END Ident; |
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) |
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 |
ELSE |
END |
RETURN Res |
END hex; |
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) |
text.nextc(text); |
c := text.peak(text); |
IF c # "." THEN |
putchar(lex, "."); |
lex.sym := lxFLOAT |
ELSE |
lex.sym := lxINTEGER; |
range := TRUE |
END; |
flag := TRUE; |
WHILE flag & (str[i] # "X") & (str[i] # "H") DO |
INC(n); |
IF n > 8 THEN |
tLex := lxERR5; |
flag := FALSE |
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 |
ELSE |
res := LSL(res, 4) + hex(str[i]); |
INC(i) |
lex.sym := lxERROR02 |
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 |
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) |
IF hex THEN |
lex.sym := lxERROR01 |
END |
END |
END |
RETURN res |
END StrToInt; |
PROCEDURE StrToFloat(str: UTILS.STRING): LONGREAL; |
VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, nez: BOOLEAN; |
END; |
PROCEDURE Error(e: INTEGER; VAR cont: BOOLEAN); |
BEGIN |
tLex := e; |
res := 0.0D0; |
cont := FALSE |
END Error; |
IF lex.over & (lex.sym >= 0) THEN |
lex.sym := lxERROR07 |
END; |
PROCEDURE Inf(VAR cont: BOOLEAN; VAR i: INTEGER); |
BEGIN |
IF UTILS.IsInf(res) THEN |
Error(lxERR7, cont) |
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) |
END; |
INC(i) |
END Inf; |
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) |
CASE error OF |
|0: |
|1: lex.sym := lxERROR08 |
|2: lex.sym := lxERROR09 |
|3: lex.sym := lxERROR10 |
|4: lex.sym := lxERROR11 |
|5: lex.sym := lxERROR12 |
END |
RETURN cont |
END part1; |
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; |
END number; |
PROCEDURE part3(): BOOLEAN; |
VAR cont: BOOLEAN; |
PROCEDURE string (text: TEXTDRV.TEXT; VAR lex: LEX); |
VAR |
c, c1: CHAR; |
n: INTEGER; |
quot: CHAR; |
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; |
quot := text.peak(text); |
PROCEDURE part4(): BOOLEAN; |
VAR cont: BOOLEAN; |
BEGIN |
IF str[i] = "D" THEN |
tLex := lxLONGREAL |
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) |
END; |
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) |
IF c = quot THEN |
text.nextc(text); |
IF lex.over THEN |
lex.sym := lxERROR05 |
ELSE |
scale := scale * 10; |
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN |
Error(lxERR8, cont) |
IF n # 1 THEN |
lex.sym := lxSTRING |
ELSE |
scale := scale + (ORD(str[i]) - ORD("0")); |
INC(i) |
lex.sym := lxCHAR; |
ARITH.setChar(lex.value, ORD(c1)) |
END |
END |
ELSE |
lex.sym := lxERROR03 |
END; |
IF lex.sym = lxSTRING THEN |
lex.string := enterid(lex.s); |
lex.value.typ := ARITH.tSTRING; |
lex.value.string := lex.string |
END |
RETURN cont |
END part4; |
PROCEDURE part5(): BOOLEAN; |
VAR cont: BOOLEAN; i: INTEGER; |
END string; |
PROCEDURE comment (text: TEXTDRV.TEXT); |
VAR |
c: CHAR; |
cond, depth: INTEGER; |
BEGIN |
cont := TRUE; |
IF scale = maxINT THEN |
Error(lxERR8, cont) |
cond := 0; |
depth := 1; |
REPEAT |
c := text.peak(text); |
text.nextc(text); |
IF c = "*" THEN |
IF cond = 1 THEN |
cond := 0; |
INC(depth) |
ELSE |
cond := 2 |
END |
ELSIF c = ")" THEN |
IF cond = 2 THEN |
DEC(depth) |
END; |
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) |
cond := 0 |
ELSIF c = "(" THEN |
cond := 1 |
ELSE |
cond := 0 |
END |
RETURN cont |
END part5; |
UNTIL (depth = 0) OR text.eof |
END comment; |
PROCEDURE delimiter (text: TEXTDRV.TEXT; VAR lex: LEX; VAR range: BOOLEAN); |
VAR |
c: CHAR; |
BEGIN |
IF part1() & part2() & part3() & part4() & part5() THEN END |
RETURN res |
END StrToFloat; |
c := text.peak(text); |
PROCEDURE Number; |
VAR nextchr: CHAR; |
BEGIN |
tLex := lxINT; |
WHILE Digit(ch) DO |
PutNext(ch) |
IF range THEN |
ASSERT(c = ".") |
END; |
IF ch = "H" THEN |
tLex := lxHEX |
ELSIF ch = "X" THEN |
tLex := lxCHX |
END; |
IF tLex # lxINT THEN |
PutNext(ch) |
ELSE |
WHILE HexDigit(ch) DO |
tLex := lxHEX; |
PutNext(ch) |
END; |
IF tLex = lxHEX THEN |
IF ch = "H" THEN |
PutNext(ch) |
ELSIF ch = "X" THEN |
tLex := lxCHX; |
PutNext(ch) |
ELSE |
tLex := lxERR1 |
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 |
ELSIF ch = "." THEN |
sys.GET(bufpos, nextchr); |
IF nextchr # "." THEN |
tLex := lxREAL; |
PutNext(ch); |
WHILE Digit(ch) DO |
PutNext(ch) |
END; |
IF (ch = "E") OR (ch = "D") THEN |
PutNext(ch); |
IF (ch = "+") OR (ch = "-") THEN |
PutNext(ch) |
END; |
IF ~Digit(ch) THEN |
tLex := lxERR2 |
|"~": |
lex.sym := lxNOT |
|"&": |
lex.sym := lxAND |
|".": |
IF range THEN |
putchar(lex, "."); |
lex.sym := lxRANGE; |
range := FALSE; |
DEC(lex.pos.col) |
ELSE |
WHILE Digit(ch) DO |
PutNext(ch) |
lex.sym := lxPOINT; |
c := text.peak(text); |
IF c = "." THEN |
lex.sym := lxRANGE; |
putchar(lex, c); |
text.nextc(text) |
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; |
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 |
|":": |
lex.sym := lxCOLON; |
c := text.peak(text); |
IF c = "=" THEN |
lex.sym := lxASSIGN; |
putchar(lex, c); |
text.nextc(text) |
END |
RETURN Res |
END Delim; |
PROCEDURE Comment; |
VAR c, level: INTEGER; cont: BOOLEAN; |
|")": |
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; |
BEGIN |
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 |
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 |
ELSE |
c := 1 |
putchar(lex, c); |
text.nextc(text); |
lex.sym := lxERROR04 |
END; |
END; |
IF cont THEN |
Next |
IF lex.sym < 0 THEN |
lex.error := -lex.sym |
ELSE |
lex.error := 0 |
END |
END Comment; |
PROCEDURE GetLex*; |
UNTIL lex.sym # lxCOMMENT |
END Next; |
PROCEDURE NewScanner (): SCANNER; |
VAR |
scan: SCANNER; |
citem: C.ITEM; |
BEGIN |
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) |
citem := C.pop(scanners); |
IF citem = NIL THEN |
NEW(scan) |
ELSE |
scan := citem(SCANNER) |
END |
|22X: |
tLex := lxSTRING; |
Next; |
WHILE (ch # 22X) & (ch >= 20X) DO |
PutNext(ch) |
END; |
IF ch = 22X THEN |
Next |
RETURN scan |
END NewScanner; |
PROCEDURE open* (name: ARRAY OF CHAR): SCANNER; |
VAR |
scanner: SCANNER; |
text: TEXTDRV.TEXT; |
BEGIN |
text := TEXTDRV.create(); |
IF text.open(text, name) THEN |
scanner := NewScanner(); |
scanner.text := text; |
scanner.range := FALSE |
ELSE |
tLex := lxERR3 |
END; |
PutChar(0X); |
INC(count); |
IF count > STRLENGTH THEN |
tLex := lxERR11 |
scanner := NIL; |
TEXTDRV.destroy(text) |
END |
|"/": |
tLex := Delim(ch); |
PutNext(ch); |
IF ch = "/" THEN |
WHILE (ch >= 20X) OR (ch = 9X) DO |
PutNext(ch) |
RETURN scanner |
END open; |
PROCEDURE close* (VAR scanner: SCANNER); |
BEGIN |
IF scanner # NIL THEN |
IF scanner.text # NIL THEN |
TEXTDRV.destroy(scanner.text) |
END; |
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 |
C.push(scanners, scanner); |
scanner := NIL |
END |
END GetLex; |
END close; |
PROCEDURE AddNodeKey(Name: UTILS.STRING; key: INTEGER); |
VAR node: NODE; |
PROCEDURE init; |
VAR |
i: INTEGER; |
delim: ARRAY 23 OF CHAR; |
PROCEDURE enterkw (VAR i: INTEGER; kw: KEYWORD); |
BEGIN |
node := AddNode(Name); |
node.tLex := key |
END AddNodeKey; |
vocabulary.KW[i] := kw; |
INC(i) |
END enterkw; |
PROCEDURE Init; |
VAR i: INTEGER; node: NODE; |
BEGIN |
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 |
scanners := C.create(); |
FOR i := 0 TO 255 DO |
vocabulary.delimiters[i] := FALSE |
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/Source/STATEMENTS.ob07 |
---|
0,0 → 1,3297 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE STATEMENTS; |
IMPORT |
PARS, PROG, SCAN, ARITH, STRINGS, LISTS, CODE, X86, AMD64, |
ERRORS, MACHINE, AVL := AVLTREES, CONSOLE, C := COLLECTIONS, mConst := CONSTANTS; |
CONST |
eCONST = PARS.eCONST; eTYPE = PARS.eTYPE; eVAR = PARS.eVAR; |
eEXPR = PARS.eEXPR; eVREC = PARS.eVREC; ePROC = PARS.ePROC; |
eVPAR = PARS.eVPAR; ePARAM = PARS.ePARAM; eSTPROC = PARS.eSTPROC; |
eSTFUNC = PARS.eSTFUNC; eSYSFUNC = PARS.eSYSFUNC; eSYSPROC = PARS.eSYSPROC; |
eIMP = PARS.eIMP; |
errASSERT = 1; errPTR = 2; errDIV = 3; errPROC = 4; |
errGUARD = 5; errIDX = 6; errCASE = 7; errCOPY = 8; |
errCHR = 9; errWCHR = 10; errBYTE = 11; |
chkIDX* = 0; chkGUARD* = 1; chkPTR* = 2; chkCHR* = 3; chkWCHR* = 4; chkBYTE* = 5; |
chkALL* = {chkIDX, chkGUARD, chkPTR, chkCHR, chkWCHR, chkBYTE}; |
TYPE |
isXXX = PROCEDURE (e: PARS.EXPR): BOOLEAN; |
RANGE = RECORD |
a, b: INTEGER |
END; |
CASE_LABEL = POINTER TO rCASE_LABEL; |
rCASE_LABEL = RECORD (AVL.DATA) |
range: RANGE; |
variant, self: INTEGER; |
type: PROG.TYPE_; |
prev: CASE_LABEL |
END; |
CASE_VARIANT = POINTER TO RECORD (LISTS.ITEM) |
label: INTEGER; |
cmd: CODE.COMMAND; |
processed: BOOLEAN |
END; |
VAR |
begcall, endcall: CODE.COMMAND; |
checking: SET; |
CaseLabels, CaseVar: C.COLLECTION; |
CaseVariants: LISTS.LIST; |
PROCEDURE isExpr (e: PARS.EXPR): BOOLEAN; |
RETURN e.obj IN {eCONST, eVAR, eEXPR, eVPAR, ePARAM, eVREC} |
END isExpr; |
PROCEDURE isVar (e: PARS.EXPR): BOOLEAN; |
RETURN e.obj IN {eVAR, eVPAR, ePARAM, eVREC} |
END isVar; |
PROCEDURE isBoolean (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tBOOLEAN) |
END isBoolean; |
PROCEDURE isInteger (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tINTEGER) |
END isInteger; |
PROCEDURE isByte (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tBYTE) |
END isByte; |
PROCEDURE isInt (e: PARS.EXPR): BOOLEAN; |
RETURN isByte(e) OR isInteger(e) |
END isInt; |
PROCEDURE isReal (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tREAL) |
END isReal; |
PROCEDURE isSet (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tSET) |
END isSet; |
PROCEDURE isString (e: PARS.EXPR): BOOLEAN; |
RETURN (e.obj = eCONST) & (e.type.typ IN {PROG.tSTRING, PROG.tCHAR}) |
END isString; |
PROCEDURE isStringW (e: PARS.EXPR): BOOLEAN; |
RETURN (e.obj = eCONST) & (e.type.typ IN {PROG.tSTRING, PROG.tCHAR, PROG.tWCHAR}) |
END isStringW; |
PROCEDURE isChar (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tCHAR) |
END isChar; |
PROCEDURE isCharArray (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tARRAY) & (e.type.base.typ = PROG.tCHAR) |
END isCharArray; |
PROCEDURE isCharW (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tWCHAR) |
END isCharW; |
PROCEDURE isCharArrayW (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tARRAY) & (e.type.base.typ = PROG.tWCHAR) |
END isCharArrayW; |
PROCEDURE isCharArrayX (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tARRAY) & (e.type.base.typ IN {PROG.tCHAR, PROG.tWCHAR}) |
END isCharArrayX; |
PROCEDURE isPtr (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tPOINTER) |
END isPtr; |
PROCEDURE isRec (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tRECORD) |
END isRec; |
PROCEDURE isArr (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tARRAY) |
END isArr; |
PROCEDURE isProc (e: PARS.EXPR): BOOLEAN; |
RETURN isExpr(e) & (e.type.typ = PROG.tPROCEDURE) OR (e.obj IN {ePROC, eIMP}) |
END isProc; |
PROCEDURE isNil (e: PARS.EXPR): BOOLEAN; |
RETURN e.type.typ = PROG.tNIL |
END isNil; |
PROCEDURE getpos (parser: PARS.PARSER; VAR pos: SCAN.POSITION); |
BEGIN |
pos := parser.lex.pos |
END getpos; |
PROCEDURE NextPos (parser: PARS.PARSER; VAR pos: SCAN.POSITION); |
BEGIN |
PARS.NextPos(parser, pos) |
END NextPos; |
PROCEDURE strlen (e: PARS.EXPR): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
ASSERT(isString(e)); |
IF e.type.typ = PROG.tCHAR THEN |
res := 1 |
ELSE |
res := LENGTH(e.value.string(SCAN.IDENT).s) |
END |
RETURN res |
END strlen; |
PROCEDURE _length (s: ARRAY OF CHAR): INTEGER; |
VAR |
i, res: INTEGER; |
BEGIN |
i := 0; |
res := 0; |
WHILE (i < LEN(s)) & (s[i] # 0X) DO |
IF (s[i] <= CHR(127)) OR (s[i] >= CHR(192)) THEN |
INC(res) |
END; |
INC(i) |
END |
RETURN res |
END _length; |
PROCEDURE utf8strlen (e: PARS.EXPR): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
ASSERT(isStringW(e)); |
IF e.type.typ IN {PROG.tCHAR, PROG.tWCHAR} THEN |
res := 1 |
ELSE |
res := _length(e.value.string(SCAN.IDENT).s) |
END |
RETURN res |
END utf8strlen; |
PROCEDURE StrToWChar (s: ARRAY OF CHAR): INTEGER; |
VAR |
res: ARRAY 2 OF WCHAR; |
BEGIN |
ASSERT(STRINGS.Utf8To16(s, res) = 1) |
RETURN ORD(res[0]) |
END StrToWChar; |
PROCEDURE isStringW1 (e: PARS.EXPR): BOOLEAN; |
RETURN (e.obj = eCONST) & isString(e) & (utf8strlen(e) = 1) & (strlen(e) > 1) |
END isStringW1; |
PROCEDURE assigncomp (e: PARS.EXPR; t: PROG.TYPE_): BOOLEAN; |
VAR |
res: BOOLEAN; |
PROCEDURE arrcomp (src, dst: PROG.TYPE_): BOOLEAN; |
RETURN (dst.typ = PROG.tARRAY) & PROG.isOpenArray(src) & |
~PROG.isOpenArray(src.base) & ~PROG.isOpenArray(dst.base) & |
PROG.isTypeEq(src.base, dst.base) |
END arrcomp; |
BEGIN |
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN |
IF arrcomp(e.type, t) THEN |
res := TRUE |
ELSIF isInt(e) & (t.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN |
IF (e.obj = eCONST) & (t.typ = PROG.tBYTE) THEN |
res := ARITH.range(e.value, 0, 255) |
ELSE |
res := TRUE |
END |
ELSIF isSet(e) & (t.typ = PROG.tSET) THEN |
res := TRUE |
ELSIF isBoolean(e) & (t.typ = PROG.tBOOLEAN) THEN |
res := TRUE |
ELSIF isReal(e) & (t.typ = PROG.tREAL) THEN |
res := TRUE |
ELSIF isChar(e) & (t.typ = PROG.tCHAR) THEN |
res := TRUE |
ELSIF (e.obj = eCONST) & isChar(e) & (t.typ = PROG.tWCHAR) THEN |
res := TRUE |
ELSIF isStringW1(e) & (t.typ = PROG.tWCHAR) THEN |
res := TRUE |
ELSIF isCharW(e) & (t.typ = PROG.tWCHAR) THEN |
res := TRUE |
ELSIF PROG.isBaseOf(t, e.type) THEN |
res := TRUE |
ELSIF ~PROG.isOpenArray(t) & ~PROG.isOpenArray(e.type) & PROG.isTypeEq(t, e.type) THEN |
res := TRUE |
ELSIF isNil(e) & (t.typ IN {PROG.tPOINTER, PROG.tPROCEDURE}) THEN |
res := TRUE |
ELSIF isString(e) & ((t.typ = PROG.tARRAY) & (t.base.typ = PROG.tCHAR) & (t.length > strlen(e))) THEN |
res := TRUE |
ELSIF isStringW(e) & ((t.typ = PROG.tARRAY) & (t.base.typ = PROG.tWCHAR) & (t.length > utf8strlen(e))) THEN |
res := TRUE |
ELSE |
res := FALSE |
END |
ELSE |
res := FALSE |
END |
RETURN res |
END assigncomp; |
PROCEDURE String (e: PARS.EXPR): INTEGER; |
VAR |
offset: INTEGER; |
string: SCAN.IDENT; |
BEGIN |
IF strlen(e) # 1 THEN |
string := e.value.string(SCAN.IDENT); |
IF string.offset = -1 THEN |
string.offset := CODE.putstr(string.s); |
END; |
offset := string.offset |
ELSE |
offset := CODE.putstr1(ARITH.Int(e.value)) |
END |
RETURN offset |
END String; |
PROCEDURE StringW (e: PARS.EXPR): INTEGER; |
VAR |
offset: INTEGER; |
string: SCAN.IDENT; |
BEGIN |
IF utf8strlen(e) # 1 THEN |
string := e.value.string(SCAN.IDENT); |
IF string.offsetW = -1 THEN |
string.offsetW := CODE.putstrW(string.s); |
END; |
offset := string.offsetW |
ELSE |
IF e.type.typ IN {PROG.tWCHAR, PROG.tCHAR} THEN |
offset := CODE.putstrW1(ARITH.Int(e.value)) |
ELSE (* e.type.typ = PROG.tSTRING *) |
string := e.value.string(SCAN.IDENT); |
IF string.offsetW = -1 THEN |
string.offsetW := CODE.putstrW(string.s); |
END; |
offset := string.offsetW |
END |
END |
RETURN offset |
END StringW; |
PROCEDURE CheckRange (range, line, errno: INTEGER); |
VAR |
label: INTEGER; |
BEGIN |
label := CODE.NewLabel(); |
CODE.AddCmd2(CODE.opCHKIDX, label, range); |
CODE.OnError(line, errno); |
CODE.SetLabel(label) |
END CheckRange; |
PROCEDURE assign (e: PARS.EXPR; VarType: PROG.TYPE_; line: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
label: INTEGER; |
PROCEDURE arrcomp (src, dst: PROG.TYPE_): BOOLEAN; |
RETURN (dst.typ = PROG.tARRAY) & PROG.isOpenArray(src) & |
~PROG.isOpenArray(src.base) & ~PROG.isOpenArray(dst.base) & |
PROG.isTypeEq(src.base, dst.base) |
END arrcomp; |
BEGIN |
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN |
res := TRUE; |
IF arrcomp(e.type, VarType) THEN |
IF ~PROG.isOpenArray(VarType) THEN |
CODE.AddCmd(CODE.opCONST, VarType.length) |
END; |
CODE.AddCmd(CODE.opCOPYA, VarType.base.size); |
label := CODE.NewLabel(); |
CODE.AddJmpCmd(CODE.opJE, label); |
CODE.OnError(line, errCOPY); |
CODE.SetLabel(label) |
ELSIF isInt(e) & (VarType.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN |
IF VarType.typ = PROG.tINTEGER THEN |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opSAVEC, ARITH.Int(e.value)) |
ELSE |
CODE.AddCmd0(CODE.opSAVE) |
END |
ELSE |
IF e.obj = eCONST THEN |
res := ARITH.range(e.value, 0, 255); |
IF res THEN |
CODE.AddCmd(CODE.opSAVE8C, ARITH.Int(e.value)) |
END |
ELSE |
IF chkBYTE IN checking THEN |
label := CODE.NewLabel(); |
CODE.AddCmd2(CODE.opCHKBYTE, label, 0); |
CODE.OnError(line, errBYTE); |
CODE.SetLabel(label) |
END; |
CODE.AddCmd0(CODE.opSAVE8) |
END |
END |
ELSIF isSet(e) & (VarType.typ = PROG.tSET) THEN |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opSAVEC, ARITH.Int(e.value)) |
ELSE |
CODE.AddCmd0(CODE.opSAVE) |
END |
ELSIF isBoolean(e) & (VarType.typ = PROG.tBOOLEAN) THEN |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opSBOOLC, ARITH.Int(e.value)) |
ELSE |
CODE.AddCmd0(CODE.opSBOOL) |
END |
ELSIF isReal(e) & (VarType.typ = PROG.tREAL) THEN |
IF e.obj = eCONST THEN |
CODE.Float(ARITH.Float(e.value)) |
END; |
CODE.savef |
ELSIF isChar(e) & (VarType.typ = PROG.tCHAR) THEN |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opSAVE8C, ARITH.Int(e.value)) |
ELSE |
CODE.AddCmd0(CODE.opSAVE8) |
END |
ELSIF (e.obj = eCONST) & isChar(e) & (VarType.typ = PROG.tWCHAR) THEN |
CODE.AddCmd(CODE.opSAVE16C, ARITH.Int(e.value)) |
ELSIF isStringW1(e) & (VarType.typ = PROG.tWCHAR) THEN |
CODE.AddCmd(CODE.opSAVE16C, StrToWChar(e.value.string(SCAN.IDENT).s)) |
ELSIF isCharW(e) & (VarType.typ = PROG.tWCHAR) THEN |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opSAVE16C, ARITH.Int(e.value)) |
ELSE |
CODE.AddCmd0(CODE.opSAVE16) |
END |
ELSIF PROG.isBaseOf(VarType, e.type) THEN |
IF VarType.typ = PROG.tPOINTER THEN |
CODE.AddCmd0(CODE.opSAVE) |
ELSE |
CODE.AddCmd(CODE.opCOPY, VarType.size) |
END |
ELSIF (e.type.typ = PROG.tCARD32) & (VarType.typ = PROG.tCARD32) THEN |
CODE.AddCmd0(CODE.opSAVE32) |
ELSIF (e.type.typ = PROG.tCARD16) & (VarType.typ = PROG.tCARD16) THEN |
CODE.AddCmd0(CODE.opSAVE16) |
ELSIF ~PROG.isOpenArray(VarType) & ~PROG.isOpenArray(e.type) & PROG.isTypeEq(VarType, e.type) THEN |
IF e.obj = ePROC THEN |
CODE.AssignProc(e.ident.proc.label) |
ELSIF e.obj = eIMP THEN |
CODE.AssignImpProc(e.ident.import) |
ELSE |
IF VarType.typ = PROG.tPROCEDURE THEN |
CODE.AddCmd0(CODE.opSAVE) |
ELSE |
CODE.AddCmd(CODE.opCOPY, VarType.size) |
END |
END |
ELSIF isNil(e) & (VarType.typ IN {PROG.tPOINTER, PROG.tPROCEDURE}) THEN |
CODE.AddCmd(CODE.opSAVEC, 0) |
ELSIF isString(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base.typ = PROG.tCHAR) & (VarType.length > strlen(e))) THEN |
CODE.saves(String(e), strlen(e) + 1) |
ELSIF isStringW(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base.typ = PROG.tWCHAR) & (VarType.length > utf8strlen(e))) THEN |
CODE.saves(StringW(e), (utf8strlen(e) + 1) * 2) |
ELSE |
res := FALSE |
END |
ELSE |
res := FALSE |
END |
RETURN res |
END assign; |
PROCEDURE LoadConst (e: PARS.EXPR); |
BEGIN |
CODE.AddCmd(CODE.opCONST, ARITH.Int(e.value)) |
END LoadConst; |
PROCEDURE paramcomp (parser: PARS.PARSER; pos: SCAN.POSITION; e: PARS.EXPR; p: PROG.PARAM); |
PROCEDURE arrcomp (e: PARS.EXPR; p: PROG.PARAM): BOOLEAN; |
VAR |
t1, t2: PROG.TYPE_; |
BEGIN |
t1 := p.type; |
t2 := e.type; |
WHILE (t2.typ = PROG.tARRAY) & PROG.isOpenArray(t1) DO |
t1 := t1.base; |
t2 := t2.base |
END |
RETURN PROG.isTypeEq(t1, t2) |
END arrcomp; |
PROCEDURE ArrLen (t: PROG.TYPE_; n: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
REPEAT |
res := t.length; |
t := t.base; |
DEC(n) |
UNTIL (n < 0) OR (t.typ # PROG.tARRAY); |
ASSERT(n < 0) |
RETURN res |
END ArrLen; |
PROCEDURE OpenArray (t, t2: PROG.TYPE_); |
VAR |
n: INTEGER; |
d1, d2: INTEGER; |
BEGIN |
IF t.length # 0 THEN |
CODE.AddCmd(CODE.opPARAM, 1); |
n := PROG.Dim(t2) - 1; |
WHILE n >= 0 DO |
CODE.AddCmd(CODE.opCONST, ArrLen(t, n)); |
CODE.AddCmd(CODE.opPARAM, 1); |
DEC(n) |
END |
ELSE |
d1 := PROG.Dim(t); |
d2 := PROG.Dim(t2); |
IF d1 # d2 THEN |
n := d2 - d1; |
WHILE d2 > d1 DO |
CODE.AddCmd(CODE.opCONST, ArrLen(t, d2 - 1)); |
DEC(d2) |
END; |
d2 := PROG.Dim(t2); |
WHILE n > 0 DO |
CODE.AddCmd(CODE.opROT, d2); |
DEC(n) |
END |
END; |
CODE.AddCmd(CODE.opPARAM, PROG.Dim(t2) + 1) |
END |
END OpenArray; |
BEGIN |
IF p.vPar THEN |
PARS.check(isVar(e), parser, pos, 93); |
IF p.type.typ = PROG.tRECORD THEN |
PARS.check(PROG.isBaseOf(p.type, e.type), parser, pos, 66); |
IF e.obj = eVREC THEN |
IF e.ident # NIL THEN |
CODE.AddCmd(CODE.opVADR, e.ident.offset - 1) |
ELSE |
CODE.AddCmd0(CODE.opPUSHT) |
END |
ELSE |
CODE.AddCmd(CODE.opCONST, e.type.num) |
END; |
CODE.AddCmd(CODE.opPARAM, 2) |
ELSIF PROG.isOpenArray(p.type) THEN |
PARS.check(arrcomp(e, p), parser, pos, 66); |
OpenArray(e.type, p.type) |
ELSE |
PARS.check(PROG.isTypeEq(e.type, p.type), parser, pos, 66); |
CODE.AddCmd(CODE.opPARAM, 1) |
END; |
PARS.check(~e.readOnly, parser, pos, 94) |
ELSE |
PARS.check(isExpr(e) OR isProc(e), parser, pos, 66); |
IF PROG.isOpenArray(p.type) THEN |
IF e.type.typ = PROG.tARRAY THEN |
PARS.check(arrcomp(e, p), parser, pos, 66); |
OpenArray(e.type, p.type) |
ELSIF isString(e) & (p.type.typ = PROG.tARRAY) & (p.type.base.typ = PROG.tCHAR) THEN |
CODE.AddCmd(CODE.opSADR, String(e)); |
CODE.AddCmd(CODE.opPARAM, 1); |
CODE.AddCmd(CODE.opCONST, strlen(e) + 1); |
CODE.AddCmd(CODE.opPARAM, 1) |
ELSIF isStringW(e) & (p.type.typ = PROG.tARRAY) & (p.type.base.typ = PROG.tWCHAR) THEN |
CODE.AddCmd(CODE.opSADR, StringW(e)); |
CODE.AddCmd(CODE.opPARAM, 1); |
CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1); |
CODE.AddCmd(CODE.opPARAM, 1) |
ELSE |
PARS.error(parser, pos, 66) |
END |
ELSE |
PARS.check(~PROG.isOpenArray(e.type), parser, pos, 66); |
PARS.check(assigncomp(e, p.type), parser, pos, 66); |
IF e.obj = eCONST THEN |
IF e.type.typ = PROG.tREAL THEN |
CODE.Float(ARITH.Float(e.value)); |
CODE.pushf |
ELSIF e.type.typ = PROG.tNIL THEN |
CODE.AddCmd(CODE.opCONST, 0); |
CODE.AddCmd(CODE.opPARAM, 1) |
ELSIF isStringW1(e) & (p.type.typ = PROG.tWCHAR) THEN |
CODE.AddCmd(CODE.opCONST, StrToWChar(e.value.string(SCAN.IDENT).s)); |
CODE.AddCmd(CODE.opPARAM, 1) |
ELSIF (e.type.typ = PROG.tSTRING) OR |
(e.type.typ IN {PROG.tCHAR, PROG.tWCHAR}) & (p.type.typ = PROG.tARRAY) & (p.type.base.typ IN {PROG.tCHAR, PROG.tWCHAR}) THEN |
CODE.SetMinDataSize(p.type.size); |
IF p.type.base.typ = PROG.tCHAR THEN |
CODE.AddCmd(CODE.opSADR, String(e)) |
ELSE (* WCHAR *) |
CODE.AddCmd(CODE.opSADR, StringW(e)) |
END; |
CODE.AddCmd(CODE.opPARAM, 1) |
ELSE |
LoadConst(e); |
CODE.AddCmd(CODE.opPARAM, 1) |
END |
ELSIF e.obj = ePROC THEN |
PARS.check(e.ident.global, parser, pos, 85); |
CODE.PushProc(e.ident.proc.label); |
CODE.AddCmd(CODE.opPARAM, 1) |
ELSIF e.obj = eIMP THEN |
CODE.PushImpProc(e.ident.import); |
CODE.AddCmd(CODE.opPARAM, 1) |
ELSIF isExpr(e) & (e.type.typ = PROG.tREAL) THEN |
CODE.pushf |
ELSE |
IF (p.type.typ = PROG.tBYTE) & (e.type.typ = PROG.tINTEGER) & (chkBYTE IN checking) THEN |
CheckRange(256, pos.line, errBYTE) |
END; |
CODE.AddCmd(CODE.opPARAM, 1) |
END |
END |
END |
END paramcomp; |
PROCEDURE stProc (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
e2: PARS.EXPR; |
pos: SCAN.POSITION; |
proc: INTEGER; |
label: INTEGER; |
n, i: INTEGER; |
code: ARITH.VALUE; |
e1: PARS.EXPR; |
wchar: BOOLEAN; |
cmd1, |
cmd2: CODE.COMMAND; |
PROCEDURE varparam (parser: PARS.PARSER; pos: SCAN.POSITION; isfunc: isXXX; readOnly: BOOLEAN; VAR e: PARS.EXPR); |
BEGIN |
parser.designator(parser, e); |
PARS.check(isVar(e), parser, pos, 93); |
PARS.check(isfunc(e), parser, pos, 66); |
IF readOnly THEN |
PARS.check(~e.readOnly, parser, pos, 94) |
END |
END varparam; |
PROCEDURE shift_minmax (proc: INTEGER): CHAR; |
VAR |
res: CHAR; |
BEGIN |
CASE proc OF |
|PROG.stASR: res := "A" |
|PROG.stLSL: res := "L" |
|PROG.stROR: res := "O" |
|PROG.stLSR: res := "R" |
|PROG.stMIN: res := "m" |
|PROG.stMAX: res := "x" |
END |
RETURN res |
END shift_minmax; |
BEGIN |
ASSERT(e.obj IN {eSTPROC, eSTFUNC, eSYSPROC, eSYSFUNC}); |
getpos(parser, pos); |
proc := e.stproc; |
IF e.obj IN {eSYSPROC, eSYSFUNC} THEN |
IF parser.unit.scopeLvl > 0 THEN |
parser.unit.scopes[parser.unit.scopeLvl].enter(CODE.COMMAND).allocReg := FALSE |
END |
END; |
IF e.obj IN {eSTPROC, eSYSPROC} THEN |
CASE proc OF |
|PROG.stASSERT: |
parser.expression(parser, e); |
PARS.check(isBoolean(e), parser, pos, 66); |
IF e.obj = eCONST THEN |
IF ~ARITH.getBool(e.value) THEN |
CODE.OnError(pos.line, errASSERT) |
END |
ELSE |
label := CODE.NewLabel(); |
CODE.AddJmpCmd(CODE.opJE, label); |
CODE.OnError(pos.line, errASSERT); |
CODE.SetLabel(label) |
END |
|PROG.stINC, PROG.stDEC: |
CODE.pushBegEnd(begcall, endcall); |
varparam(parser, pos, isInt, TRUE, e); |
IF e.type.typ = PROG.tINTEGER THEN |
IF parser.sym = SCAN.lxCOMMA THEN |
NextPos(parser, pos); |
CODE.setlast(begcall); |
parser.expression(parser, e2); |
CODE.setlast(endcall.prev(CODE.COMMAND)); |
PARS.check(isInt(e2), parser, pos, 66); |
IF e2.obj = eCONST THEN |
CODE.AddCmd(CODE.opINCC + ORD(proc = PROG.stDEC), ARITH.Int(e2.value)) |
ELSE |
CODE.AddCmd0(CODE.opINC + ORD(proc = PROG.stDEC)) |
END |
ELSE |
CODE.AddCmd0(CODE.opINC1 + ORD(proc = PROG.stDEC)) |
END |
ELSE (* e.type.typ = PROG.tBYTE *) |
IF parser.sym = SCAN.lxCOMMA THEN |
NextPos(parser, pos); |
CODE.setlast(begcall); |
parser.expression(parser, e2); |
CODE.setlast(endcall.prev(CODE.COMMAND)); |
PARS.check(isInt(e2), parser, pos, 66); |
IF e2.obj = eCONST THEN |
CODE.AddCmd(CODE.opINCCB + ORD(proc = PROG.stDEC), ARITH.Int(e2.value)) |
ELSE |
CODE.AddCmd0(CODE.opINCB + ORD(proc = PROG.stDEC)) |
END |
ELSE |
CODE.AddCmd0(CODE.opINC1B + ORD(proc = PROG.stDEC)) |
END |
END; |
CODE.popBegEnd(begcall, endcall) |
|PROG.stINCL, PROG.stEXCL: |
CODE.pushBegEnd(begcall, endcall); |
varparam(parser, pos, isSet, TRUE, e); |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
CODE.setlast(begcall); |
parser.expression(parser, e2); |
CODE.setlast(endcall.prev(CODE.COMMAND)); |
PARS.check(isInt(e2), parser, pos, 66); |
IF e2.obj = eCONST THEN |
PARS.check(ARITH.range(e2.value, 0, MACHINE.target.maxSet), parser, pos, 56); |
CODE.AddCmd(CODE.opINCLC + ORD(proc = PROG.stEXCL), ARITH.Int(e2.value)) |
ELSE |
CODE.AddCmd0(CODE.opINCL + ORD(proc = PROG.stEXCL)) |
END; |
CODE.popBegEnd(begcall, endcall) |
|PROG.stNEW: |
varparam(parser, pos, isPtr, TRUE, e); |
CODE.New(e.type.base.size, e.type.base.num) |
|PROG.stDISPOSE: |
varparam(parser, pos, isPtr, TRUE, e); |
CODE.AddCmd0(CODE.opDISP) |
|PROG.stPACK: |
varparam(parser, pos, isReal, TRUE, e); |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
parser.expression(parser, e2); |
PARS.check(isInt(e2), parser, pos, 66); |
IF e2.obj = eCONST THEN |
CODE.AddCmd(CODE.opPACKC, ARITH.Int(e2.value)) |
ELSE |
CODE.AddCmd0(CODE.opPACK) |
END |
|PROG.stUNPK: |
varparam(parser, pos, isReal, TRUE, e); |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
varparam(parser, pos, isInteger, TRUE, e2); |
CODE.AddCmd0(CODE.opUNPK) |
|PROG.stCOPY: |
parser.expression(parser, e); |
IF isString(e) OR isCharArray(e) THEN |
wchar := FALSE |
ELSIF isStringW(e) OR isCharArrayW(e) THEN |
wchar := TRUE |
ELSE |
PARS.check(FALSE, parser, pos, 66) |
END; |
IF isCharArrayX(e) & ~PROG.isOpenArray(e.type) THEN |
CODE.AddCmd(CODE.opCONST, e.type.length) |
END; |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
IF wchar THEN |
varparam(parser, pos, isCharArrayW, TRUE, e1) |
ELSE |
IF e.obj = eCONST THEN |
varparam(parser, pos, isCharArrayX, TRUE, e1) |
ELSE |
varparam(parser, pos, isCharArray, TRUE, e1) |
END; |
wchar := e1.type.base.typ = PROG.tWCHAR |
END; |
IF ~PROG.isOpenArray(e1.type) THEN |
CODE.AddCmd(CODE.opCONST, e1.type.length) |
END; |
IF e.obj = eCONST THEN |
IF wchar THEN |
CODE.AddCmd(CODE.opSADR, StringW(e)); |
CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1) |
ELSE |
CODE.AddCmd(CODE.opSADR, String(e)); |
CODE.AddCmd(CODE.opCONST, strlen(e) + 1) |
END; |
CODE.AddCmd(CODE.opCOPYS2, e1.type.base.size) |
ELSE |
CODE.AddCmd(CODE.opCOPYS, e1.type.base.size) |
END |
|PROG.sysGET: |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
IF e.obj = eCONST THEN |
LoadConst(e) |
END; |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
parser.designator(parser, e2); |
PARS.check(isVar(e2), parser, pos, 93); |
PARS.check((e2.type.typ IN PROG.BASICTYPES) OR (e2.type.typ = PROG.tPOINTER) OR (e2.type.typ = PROG.tPROCEDURE), parser, pos, 66); |
CODE.SysGet(e2.type.size) |
|PROG.sysPUT, PROG.sysPUT8, PROG.sysPUT16, PROG.sysPUT32: |
CODE.pushBegEnd(begcall, endcall); |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
IF e.obj = eCONST THEN |
LoadConst(e) |
END; |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
CODE.setlast(begcall); |
parser.expression(parser, e2); |
PARS.check(isExpr(e2), parser, pos, 66); |
IF proc = PROG.sysPUT THEN |
PARS.check((e2.type.typ IN PROG.BASICTYPES) OR (e2.type.typ = PROG.tPOINTER) OR (e2.type.typ = PROG.tPROCEDURE), parser, pos, 66); |
IF e2.obj = eCONST THEN |
IF e2.type.typ = PROG.tREAL THEN |
CODE.setlast(endcall.prev(CODE.COMMAND)); |
CODE.Float(ARITH.Float(e2.value)); |
CODE.savef |
ELSE |
LoadConst(e2); |
CODE.setlast(endcall.prev(CODE.COMMAND)); |
CODE.SysPut(e2.type.size) |
END |
ELSE |
CODE.setlast(endcall.prev(CODE.COMMAND)); |
IF e2.type.typ = PROG.tREAL THEN |
CODE.savef |
ELSIF e2.type.typ = PROG.tBYTE THEN |
CODE.SysPut(PARS.program.stTypes.tINTEGER.size) |
ELSE |
CODE.SysPut(e2.type.size) |
END |
END |
ELSIF (proc = PROG.sysPUT8) OR (proc = PROG.sysPUT16) OR (proc = PROG.sysPUT32) THEN |
PARS.check(e2.type.typ IN {PROG.tINTEGER, PROG.tBYTE, PROG.tCHAR, PROG.tWCHAR, PROG.tCARD16, PROG.tCARD32}, parser, pos, 66); |
IF e2.obj = eCONST THEN |
LoadConst(e2) |
END; |
CODE.setlast(endcall.prev(CODE.COMMAND)); |
IF proc = PROG.sysPUT8 THEN |
CODE.SysPut(1) |
ELSIF proc = PROG.sysPUT16 THEN |
CODE.SysPut(2) |
ELSIF proc = PROG.sysPUT32 THEN |
CODE.SysPut(4) |
END |
END; |
CODE.popBegEnd(begcall, endcall) |
|PROG.sysMOVE: |
FOR i := 1 TO 2 DO |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
IF e.obj = eCONST THEN |
LoadConst(e) |
END; |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos) |
END; |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
IF e.obj = eCONST THEN |
LoadConst(e) |
END; |
CODE.AddCmd0(CODE.opMOVE) |
|PROG.sysCOPY: |
FOR i := 1 TO 2 DO |
parser.designator(parser, e); |
PARS.check(isVar(e), parser, pos, 93); |
n := PROG.Dim(e.type); |
WHILE n > 0 DO |
CODE.drop; |
DEC(n) |
END; |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos) |
END; |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
IF e.obj = eCONST THEN |
LoadConst(e) |
END; |
CODE.AddCmd0(CODE.opMOVE) |
|PROG.sysCODE: |
REPEAT |
getpos(parser, pos); |
PARS.ConstExpression(parser, code); |
PARS.check(code.typ = ARITH.tINTEGER, parser, pos, 43); |
PARS.check(ARITH.range(code, 0, 255), parser, pos, 42); |
IF parser.sym = SCAN.lxCOMMA THEN |
PARS.Next(parser) |
ELSE |
PARS.checklex(parser, SCAN.lxRROUND) |
END; |
CODE.AddCmd(CODE.opCODE, ARITH.getInt(code)) |
UNTIL parser.sym = SCAN.lxRROUND |
END; |
e.obj := eEXPR; |
e.type := NIL |
ELSIF e.obj IN {eSTFUNC, eSYSFUNC} THEN |
CASE e.stproc OF |
|PROG.stABS: |
parser.expression(parser, e); |
PARS.check(isInt(e) OR isReal(e), parser, pos, 66); |
IF e.obj = eCONST THEN |
PARS.check(ARITH.abs(e.value), parser, pos, 39) |
ELSE |
CODE.abs(isReal(e)) |
END |
|PROG.stASR, PROG.stLSL, PROG.stROR, PROG.stLSR, PROG.stMIN, PROG.stMAX: |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
PARS.checklex(parser, SCAN.lxCOMMA); |
NextPos(parser, pos); |
parser.expression(parser, e2); |
PARS.check(isInt(e2), parser, pos, 66); |
e.type := PARS.program.stTypes.tINTEGER; |
IF (e.obj = eCONST) & (e2.obj = eCONST) THEN |
ASSERT(ARITH.opInt(e.value, e2.value, shift_minmax(proc))) |
ELSE |
IF e.obj = eCONST THEN |
CODE.shift_minmax1(shift_minmax(proc), ARITH.Int(e.value)) |
ELSIF e2.obj = eCONST THEN |
CODE.shift_minmax2(shift_minmax(proc), ARITH.Int(e2.value)) |
ELSE |
CODE.shift_minmax(shift_minmax(proc)) |
END; |
e.obj := eEXPR |
END |
|PROG.stCHR: |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
e.type := PARS.program.stTypes.tCHAR; |
IF e.obj = eCONST THEN |
ARITH.setChar(e.value, ARITH.getInt(e.value)); |
PARS.check(ARITH.check(e.value), parser, pos, 107) |
ELSE |
IF chkCHR IN checking THEN |
CheckRange(256, pos.line, errCHR) |
ELSE |
CODE.AddCmd0(CODE.opCHR) |
END |
END |
|PROG.stWCHR: |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
e.type := PARS.program.stTypes.tWCHAR; |
IF e.obj = eCONST THEN |
ARITH.setWChar(e.value, ARITH.getInt(e.value)); |
PARS.check(ARITH.check(e.value), parser, pos, 101) |
ELSE |
IF chkWCHR IN checking THEN |
CheckRange(65536, pos.line, errWCHR) |
ELSE |
CODE.AddCmd0(CODE.opWCHR) |
END |
END |
|PROG.stFLOOR: |
parser.expression(parser, e); |
PARS.check(isReal(e), parser, pos, 66); |
e.type := PARS.program.stTypes.tINTEGER; |
IF e.obj = eCONST THEN |
PARS.check(ARITH.floor(e.value), parser, pos, 39) |
ELSE |
CODE.floor |
END |
|PROG.stFLT: |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
e.type := PARS.program.stTypes.tREAL; |
IF e.obj = eCONST THEN |
ARITH.flt(e.value) |
ELSE |
PARS.check(CODE.flt(), parser, pos, 41) |
END |
|PROG.stLEN: |
cmd1 := CODE.getlast(); |
varparam(parser, pos, isArr, FALSE, e); |
IF e.type.length > 0 THEN |
cmd2 := CODE.getlast(); |
CODE.delete2(cmd1.next, cmd2); |
CODE.setlast(cmd1); |
ASSERT(ARITH.setInt(e.value, e.type.length)); |
e.obj := eCONST |
ELSE |
CODE.len(PROG.Dim(e.type)) |
END; |
e.type := PARS.program.stTypes.tINTEGER |
|PROG.stLENGTH: |
parser.expression(parser, e); |
IF isCharArray(e) THEN |
IF e.type.length > 0 THEN |
CODE.AddCmd(CODE.opCONST, e.type.length) |
END; |
CODE.AddCmd0(CODE.opLENGTH) |
ELSIF isCharArrayW(e) THEN |
IF e.type.length > 0 THEN |
CODE.AddCmd(CODE.opCONST, e.type.length) |
END; |
CODE.AddCmd0(CODE.opLENGTHW) |
ELSE |
PARS.check(FALSE, parser, pos, 66); |
END; |
e.type := PARS.program.stTypes.tINTEGER |
|PROG.stODD: |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
e.type := PARS.program.stTypes.tBOOLEAN; |
IF e.obj = eCONST THEN |
ARITH.odd(e.value) |
ELSE |
CODE.odd |
END |
|PROG.stORD: |
parser.expression(parser, e); |
PARS.check(isChar(e) OR isBoolean(e) OR isSet(e) OR isCharW(e) OR isStringW1(e), parser, pos, 66); |
IF e.obj = eCONST THEN |
IF isStringW1(e) THEN |
ASSERT(ARITH.setInt(e.value, StrToWChar(e.value.string(SCAN.IDENT).s))) |
ELSE |
ARITH.ord(e.value) |
END |
ELSE |
IF isBoolean(e) THEN |
CODE.ord |
END |
END; |
e.type := PARS.program.stTypes.tINTEGER |
|PROG.stBITS: |
parser.expression(parser, e); |
PARS.check(isInt(e), parser, pos, 66); |
IF e.obj = eCONST THEN |
ARITH.bits(e.value) |
END; |
e.type := PARS.program.stTypes.tSET |
|PROG.sysADR: |
parser.designator(parser, e); |
IF isVar(e) THEN |
n := PROG.Dim(e.type); |
WHILE n > 0 DO |
CODE.drop; |
DEC(n) |
END |
ELSIF e.obj = ePROC THEN |
CODE.PushProc(e.ident.proc.label) |
ELSIF e.obj = eIMP THEN |
CODE.PushImpProc(e.ident.import) |
ELSE |
PARS.check(FALSE, parser, pos, 108) |
END; |
e.type := PARS.program.stTypes.tINTEGER |
|PROG.sysSADR: |
parser.expression(parser, e); |
PARS.check(isString(e), parser, pos, 66); |
CODE.AddCmd(CODE.opSADR, String(e)); |
e.type := PARS.program.stTypes.tINTEGER; |
e.obj := eEXPR |
|PROG.sysWSADR: |
parser.expression(parser, e); |
PARS.check(isStringW(e), parser, pos, 66); |
CODE.AddCmd(CODE.opSADR, StringW(e)); |
e.type := PARS.program.stTypes.tINTEGER; |
e.obj := eEXPR |
|PROG.sysTYPEID: |
parser.expression(parser, e); |
PARS.check(e.obj = eTYPE, parser, pos, 68); |
IF e.type.typ = PROG.tRECORD THEN |
ASSERT(ARITH.setInt(e.value, e.type.num)) |
ELSIF e.type.typ = PROG.tPOINTER THEN |
ASSERT(ARITH.setInt(e.value, e.type.base.num)) |
ELSE |
PARS.check(FALSE, parser, pos, 52) |
END; |
e.obj := eCONST; |
e.type := PARS.program.stTypes.tINTEGER |
|PROG.sysINF: |
PARS.check(CODE.inf(), parser, pos, 41); |
e.obj := eEXPR; |
e.type := PARS.program.stTypes.tREAL |
|PROG.sysSIZE: |
parser.expression(parser, e); |
PARS.check(e.obj = eTYPE, parser, pos, 68); |
ASSERT(ARITH.setInt(e.value, e.type.size)); |
e.obj := eCONST; |
e.type := PARS.program.stTypes.tINTEGER |
END |
END; |
PARS.checklex(parser, SCAN.lxRROUND); |
PARS.Next(parser); |
IF e.obj # eCONST THEN |
e.obj := eEXPR |
END |
END stProc; |
PROCEDURE ActualParameters (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
proc: PROG.TYPE_; |
param: LISTS.ITEM; |
e1: PARS.EXPR; |
pos: SCAN.POSITION; |
BEGIN |
ASSERT(parser.sym = SCAN.lxLROUND); |
IF (e.obj IN {ePROC, eIMP}) OR isExpr(e) THEN |
proc := e.type; |
PARS.check1(proc.typ = PROG.tPROCEDURE, parser, 86); |
PARS.Next(parser); |
param := proc.params.first; |
WHILE param # NIL DO |
getpos(parser, pos); |
CODE.setlast(begcall); |
IF param(PROG.PARAM).vPar THEN |
parser.designator(parser, e1) |
ELSE |
parser.expression(parser, e1) |
END; |
paramcomp(parser, pos, e1, param(PROG.PARAM)); |
param := param.next; |
IF param # NIL THEN |
PARS.checklex(parser, SCAN.lxCOMMA); |
PARS.Next(parser) |
END |
END; |
PARS.checklex(parser, SCAN.lxRROUND); |
PARS.Next(parser); |
e.obj := eEXPR; |
e.type := proc.base |
ELSIF e.obj IN {eSTPROC, eSTFUNC, eSYSPROC, eSYSFUNC} THEN |
PARS.Next(parser); |
stProc(parser, e) |
ELSE |
PARS.check1(FALSE, parser, 86) |
END |
END ActualParameters; |
PROCEDURE qualident (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
ident: PROG.IDENT; |
import: BOOLEAN; |
pos: SCAN.POSITION; |
BEGIN |
PARS.checklex(parser, SCAN.lxIDENT); |
getpos(parser, pos); |
import := FALSE; |
ident := parser.unit.idents.get(parser.unit, parser.lex.ident, FALSE); |
PARS.check1(ident # NIL, parser, 48); |
IF ident.typ = PROG.idMODULE THEN |
PARS.ExpectSym(parser, SCAN.lxPOINT); |
PARS.ExpectSym(parser, SCAN.lxIDENT); |
ident := ident.unit.idents.get(ident.unit, parser.lex.ident, FALSE); |
PARS.check1((ident # NIL) & ident.export, parser, 48); |
import := TRUE |
END; |
PARS.Next(parser); |
e.readOnly := FALSE; |
e.ident := ident; |
CASE ident.typ OF |
|PROG.idCONST: |
e.obj := eCONST; |
e.type := ident.type; |
e.value := ident.value |
|PROG.idTYPE: |
e.obj := eTYPE; |
e.type := ident.type |
|PROG.idVAR: |
e.obj := eVAR; |
e.type := ident.type; |
e.readOnly := import |
|PROG.idPROC: |
e.obj := ePROC; |
e.type := ident.type |
|PROG.idIMP: |
e.obj := eIMP; |
e.type := ident.type |
|PROG.idVPAR: |
e.type := ident.type; |
IF e.type.typ = PROG.tRECORD THEN |
e.obj := eVREC |
ELSE |
e.obj := eVPAR |
END |
|PROG.idPARAM: |
e.obj := ePARAM; |
e.type := ident.type; |
e.readOnly := (e.type.typ IN {PROG.tRECORD, PROG.tARRAY}) |
|PROG.idSTPROC: |
e.obj := eSTPROC; |
e.stproc := ident.stproc |
|PROG.idSTFUNC: |
e.obj := eSTFUNC; |
e.stproc := ident.stproc |
|PROG.idSYSPROC: |
e.obj := eSYSPROC; |
e.stproc := ident.stproc |
|PROG.idSYSFUNC: |
PARS.check(~parser.constexp, parser, pos, 109); |
e.obj := eSYSFUNC; |
e.stproc := ident.stproc |
|PROG.idNONE: |
PARS.check(FALSE, parser, pos, 115) |
END; |
IF isVar(e) THEN |
PARS.check(e.ident.global OR (e.ident.scopeLvl = parser.unit.scopeLvl), parser, pos, 105) |
END |
END qualident; |
PROCEDURE deref (pos: SCAN.POSITION; e: PARS.EXPR; load: BOOLEAN; error: INTEGER); |
VAR |
label: INTEGER; |
BEGIN |
IF load THEN |
CODE.load(e.type.size) |
END; |
IF chkPTR IN checking THEN |
label := CODE.NewLabel(); |
CODE.AddJmpCmd(CODE.opJNZ, label); |
CODE.OnError(pos.line, error); |
CODE.SetLabel(label) |
END |
END deref; |
PROCEDURE designator (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
field: PROG.FIELD; |
pos: SCAN.POSITION; |
t, idx: PARS.EXPR; |
PROCEDURE LoadAdr (e: PARS.EXPR); |
VAR |
offset: INTEGER; |
PROCEDURE OpenArray (e: PARS.EXPR); |
VAR |
offset, n: INTEGER; |
BEGIN |
offset := e.ident.offset; |
n := PROG.Dim(e.type); |
WHILE n >= 0 DO |
CODE.AddCmd(CODE.opVADR, offset); |
DEC(offset); |
DEC(n) |
END |
END OpenArray; |
BEGIN |
IF e.obj = eVAR THEN |
offset := PROG.getOffset(PARS.program, e.ident); |
IF e.ident.global THEN |
CODE.AddCmd(CODE.opGADR, offset) |
ELSE |
CODE.AddCmd(CODE.opLADR, -offset) |
END |
ELSIF e.obj = ePARAM THEN |
IF (e.type.typ = PROG.tRECORD) OR ((e.type.typ = PROG.tARRAY) & (e.type.length > 0)) THEN |
CODE.AddCmd(CODE.opVADR, e.ident.offset) |
ELSIF PROG.isOpenArray(e.type) THEN |
OpenArray(e) |
ELSE |
CODE.AddCmd(CODE.opLADR, e.ident.offset) |
END |
ELSIF e.obj IN {eVPAR, eVREC} THEN |
IF PROG.isOpenArray(e.type) THEN |
OpenArray(e) |
ELSE |
CODE.AddCmd(CODE.opVADR, e.ident.offset) |
END |
END |
END LoadAdr; |
PROCEDURE OpenIdx (parser: PARS.PARSER; pos: SCAN.POSITION; e: PARS.EXPR); |
VAR |
label: INTEGER; |
type: PROG.TYPE_; |
n, offset, k: INTEGER; |
BEGIN |
IF chkIDX IN checking THEN |
label := CODE.NewLabel(); |
CODE.AddCmd2(CODE.opCHKIDX2, label, 0); |
CODE.OnError(pos.line, errIDX); |
CODE.SetLabel(label) |
ELSE |
CODE.AddCmd(CODE.opCHKIDX2, -1) |
END; |
type := PROG.OpenBase(e.type); |
IF type.size # 1 THEN |
CODE.AddCmd(CODE.opMULC, type.size) |
END; |
n := PROG.Dim(e.type) - 1; |
k := n; |
WHILE n > 0 DO |
CODE.AddCmd0(CODE.opMUL); |
DEC(n) |
END; |
CODE.AddCmd0(CODE.opADD); |
offset := e.ident.offset - 1; |
n := k; |
WHILE n > 0 DO |
CODE.AddCmd(CODE.opVADR, offset); |
DEC(offset); |
DEC(n) |
END |
END OpenIdx; |
BEGIN |
qualident(parser, e); |
IF e.obj IN {ePROC, eIMP} THEN |
PROG.UseProc(parser.unit, e.ident.proc) |
END; |
IF isVar(e) THEN |
LoadAdr(e) |
END; |
WHILE parser.sym = SCAN.lxPOINT DO |
getpos(parser, pos); |
PARS.check1(isExpr(e) & (e.type.typ IN {PROG.tRECORD, PROG.tPOINTER}), parser, 73); |
IF e.type.typ = PROG.tPOINTER THEN |
deref(pos, e, TRUE, errPTR) |
END; |
PARS.ExpectSym(parser, SCAN.lxIDENT); |
IF e.type.typ = PROG.tPOINTER THEN |
e.type := e.type.base; |
e.readOnly := FALSE |
END; |
field := e.type.fields.get(e.type, parser.lex.ident, parser.unit); |
PARS.check1(field # NIL, parser, 74); |
e.type := field.type; |
IF e.obj = eVREC THEN |
e.obj := eVPAR |
END; |
IF field.offset # 0 THEN |
CODE.AddCmd(CODE.opADDR, field.offset) |
END; |
PARS.Next(parser); |
e.ident := NIL |
ELSIF parser.sym = SCAN.lxLSQUARE DO |
REPEAT |
PARS.check1(isArr(e), parser, 75); |
NextPos(parser, pos); |
parser.expression(parser, idx); |
PARS.check(isInt(idx), parser, pos, 76); |
IF idx.obj = eCONST THEN |
IF e.type.length > 0 THEN |
PARS.check(ARITH.range(idx.value, 0, e.type.length - 1), parser, pos, 83); |
IF ARITH.Int(idx.value) > 0 THEN |
CODE.AddCmd(CODE.opADDR, ARITH.Int(idx.value) * e.type.base.size) |
END |
ELSE |
PARS.check(ARITH.range(idx.value, 0, MACHINE.target.maxInt), parser, pos, 83); |
LoadConst(idx); |
OpenIdx(parser, pos, e) |
END |
ELSE |
IF e.type.length > 0 THEN |
IF chkIDX IN checking THEN |
CheckRange(e.type.length, pos.line, errIDX) |
END; |
IF e.type.base.size # 1 THEN |
CODE.AddCmd(CODE.opMULC, e.type.base.size) |
END; |
CODE.AddCmd0(CODE.opADD) |
ELSE |
OpenIdx(parser, pos, e) |
END |
END; |
e.type := e.type.base |
UNTIL parser.sym # SCAN.lxCOMMA; |
PARS.checklex(parser, SCAN.lxRSQUARE); |
PARS.Next(parser); |
e.ident := NIL |
ELSIF parser.sym = SCAN.lxCARET DO |
getpos(parser, pos); |
PARS.check1(isPtr(e), parser, 77); |
deref(pos, e, TRUE, errPTR); |
e.type := e.type.base; |
e.readOnly := FALSE; |
PARS.Next(parser); |
e.ident := NIL; |
e.obj := eVREC |
ELSIF (parser.sym = SCAN.lxLROUND) & isExpr(e) & (e.type.typ IN {PROG.tRECORD, PROG.tPOINTER}) DO |
IF e.type.typ = PROG.tRECORD THEN |
PARS.check1(e.obj = eVREC, parser, 78) |
END; |
NextPos(parser, pos); |
qualident(parser, t); |
PARS.check(t.obj = eTYPE, parser, pos, 79); |
IF e.type.typ = PROG.tRECORD THEN |
PARS.check(t.type.typ = PROG.tRECORD, parser, pos, 80); |
IF chkGUARD IN checking THEN |
IF e.ident = NIL THEN |
CODE.TypeGuard(CODE.opTYPEGD, t.type.num, pos.line, errGUARD) |
ELSE |
CODE.AddCmd(CODE.opVADR, e.ident.offset - 1); |
CODE.TypeGuard(CODE.opTYPEGR, t.type.num, pos.line, errGUARD) |
END |
END; |
ELSE |
PARS.check(t.type.typ = PROG.tPOINTER, parser, pos, 81); |
IF chkGUARD IN checking THEN |
CODE.TypeGuard(CODE.opTYPEGP, t.type.base.num, pos.line, errGUARD) |
END |
END; |
PARS.check(PROG.isBaseOf(e.type, t.type), parser, pos, 82); |
e.type := t.type; |
PARS.checklex(parser, SCAN.lxRROUND); |
PARS.Next(parser) |
END |
END designator; |
PROCEDURE ProcCall (e: PARS.EXPR; procType: PROG.TYPE_; isfloat: BOOLEAN; VAR fregs: INTEGER; parser: PARS.PARSER; pos: SCAN.POSITION; CallStat: BOOLEAN); |
VAR |
cconv: INTEGER; |
params: INTEGER; |
callconv: INTEGER; |
fparams: INTEGER; |
int, flt: INTEGER; |
stk_par: INTEGER; |
BEGIN |
cconv := procType.call; |
params := procType.params.size; |
IF cconv IN {PROG._win64, PROG.win64} THEN |
callconv := CODE.call_win64; |
fparams := LSL(ORD(procType.params.getfparams(procType, 3, int, flt)), 5) + MIN(params, 4) |
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN |
callconv := CODE.call_sysv; |
fparams := LSL(ORD(procType.params.getfparams(procType, PROG.MAXSYSVPARAM - 1, int, flt)), 5) + params; |
stk_par := MAX(0, int - 6) + MAX(0, flt - 8) |
ELSE |
callconv := CODE.call_stack; |
fparams := 0 |
END; |
CODE.setlast(begcall); |
fregs := CODE.precall(isfloat); |
IF cconv IN {PROG._ccall16, PROG.ccall16} THEN |
CODE.AddCmd(CODE.opALIGN16, params) |
ELSIF cconv IN {PROG._win64, PROG.win64} THEN |
CODE.AddCmd(CODE.opWIN64ALIGN16, params) |
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN |
CODE.AddCmd(CODE.opSYSVALIGN16, params + stk_par) |
END; |
CODE.setlast(endcall.prev(CODE.COMMAND)); |
IF e.obj = eIMP THEN |
CODE.CallImp(e.ident.import, callconv, fparams) |
ELSIF e.obj = ePROC THEN |
CODE.Call(e.ident.proc.label, callconv, fparams) |
ELSIF isExpr(e) THEN |
deref(pos, e, CallStat, errPROC); |
CODE.CallP(callconv, fparams) |
END; |
IF cconv IN {PROG._ccall16, PROG.ccall16} THEN |
CODE.AddCmd(CODE.opCLEANUP, params); |
CODE.AddCmd0(CODE.opPOPSP) |
ELSIF cconv IN {PROG._win64, PROG.win64} THEN |
CODE.AddCmd(CODE.opCLEANUP, MAX(params + params MOD 2, 4) + 1); |
CODE.AddCmd0(CODE.opPOPSP) |
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN |
CODE.AddCmd(CODE.opCLEANUP, params + stk_par); |
CODE.AddCmd0(CODE.opPOPSP) |
ELSIF cconv IN {PROG._ccall, PROG.ccall} THEN |
CODE.AddCmd(CODE.opCLEANUP, params) |
END; |
IF ~CallStat THEN |
IF isfloat THEN |
PARS.check(CODE.resf(fregs), parser, pos, 41) |
ELSE |
CODE.res(fregs) |
END |
END |
END ProcCall; |
PROCEDURE expression (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
pos, pos0, pos1: SCAN.POSITION; |
op: INTEGER; |
e1: PARS.EXPR; |
constant: BOOLEAN; |
operator: ARITH.RELATION; |
error: INTEGER; |
PROCEDURE relation (sym: INTEGER): BOOLEAN; |
RETURN (sym = SCAN.lxEQ) OR (sym = SCAN.lxNE) OR |
(sym = SCAN.lxLT) OR (sym = SCAN.lxLE) OR |
(sym = SCAN.lxGT) OR (sym = SCAN.lxGE) OR |
(sym = SCAN.lxIN) OR (sym = SCAN.lxIS) |
END relation; |
PROCEDURE AddOperator (sym: INTEGER): BOOLEAN; |
RETURN (sym = SCAN.lxPLUS) OR (sym = SCAN.lxMINUS) OR |
(sym = SCAN.lxOR) |
END AddOperator; |
PROCEDURE MulOperator (sym: INTEGER): BOOLEAN; |
RETURN (sym = SCAN.lxMUL) OR (sym = SCAN.lxSLASH) OR |
(sym = SCAN.lxDIV) OR (sym = SCAN.lxMOD) OR |
(sym = SCAN.lxAND) |
END MulOperator; |
PROCEDURE element (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
e1, e2: PARS.EXPR; |
pos: SCAN.POSITION; |
range: BOOLEAN; |
BEGIN |
range := FALSE; |
getpos(parser, pos); |
expression(parser, e1); |
PARS.check(isInt(e1), parser, pos, 76); |
IF e1.obj = eCONST THEN |
PARS.check(ARITH.range(e1.value, 0, MACHINE.target.maxSet), parser, pos, 44) |
END; |
range := parser.sym = SCAN.lxRANGE; |
IF range THEN |
NextPos(parser, pos); |
expression(parser, e2); |
PARS.check(isInt(e2), parser, pos, 76); |
IF e2.obj = eCONST THEN |
PARS.check(ARITH.range(e2.value, 0, MACHINE.target.maxSet), parser, pos, 44) |
END |
ELSE |
IF e1.obj = eCONST THEN |
e2 := e1 |
END |
END; |
e.type := PARS.program.stTypes.tSET; |
IF (e1.obj = eCONST) & (e2.obj = eCONST) THEN |
ARITH.constrSet(e.value, e1.value, e2.value); |
e.obj := eCONST |
ELSE |
IF range THEN |
IF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opRSETL, ARITH.Int(e1.value)) |
ELSIF e2.obj = eCONST THEN |
CODE.AddCmd(CODE.opRSETR, ARITH.Int(e2.value)) |
ELSE |
CODE.AddCmd0(CODE.opRSET) |
END |
ELSE |
CODE.AddCmd0(CODE.opRSET1) |
END; |
e.obj := eEXPR |
END |
END element; |
PROCEDURE set (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
e1: PARS.EXPR; |
BEGIN |
ASSERT(parser.sym = SCAN.lxLCURLY); |
e.obj := eCONST; |
e.type := PARS.program.stTypes.tSET; |
ARITH.emptySet(e.value); |
PARS.Next(parser); |
IF parser.sym # SCAN.lxRCURLY THEN |
element(parser, e1); |
IF e1.obj = eCONST THEN |
ARITH.opSet(e.value, e1.value, "+") |
ELSE |
e.obj := eEXPR |
END; |
WHILE parser.sym = SCAN.lxCOMMA DO |
PARS.Next(parser); |
element(parser, e1); |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
ARITH.opSet(e.value, e1.value, "+") |
ELSE |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opADDSL, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opADDSR, ARITH.Int(e1.value)) |
ELSE |
CODE.AddCmd0(CODE.opADDS) |
END; |
e.obj := eEXPR |
END |
END; |
PARS.checklex(parser, SCAN.lxRCURLY) |
END; |
PARS.Next(parser); |
END set; |
PROCEDURE factor (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
sym: INTEGER; |
pos: SCAN.POSITION; |
e1: PARS.EXPR; |
isfloat: BOOLEAN; |
fregs: INTEGER; |
PROCEDURE LoadVar (e: PARS.EXPR; parser: PARS.PARSER; pos: SCAN.POSITION); |
BEGIN |
IF ~(e.type.typ IN {PROG.tRECORD, PROG.tARRAY}) THEN |
IF e.type.typ = PROG.tREAL THEN |
PARS.check(CODE.loadf(), parser, pos, 41) |
ELSE |
CODE.load(e.type.size) |
END |
END |
END LoadVar; |
BEGIN |
sym := parser.sym; |
IF (sym = SCAN.lxINTEGER) OR (sym = SCAN.lxHEX) OR (sym = SCAN.lxFLOAT) OR (sym = SCAN.lxCHAR) OR (sym = SCAN.lxSTRING) THEN |
e.obj := eCONST; |
e.value := parser.lex.value; |
e.type := PARS.program.getType(PARS.program, e.value.typ); |
PARS.Next(parser) |
ELSIF sym = SCAN.lxNIL THEN |
e.obj := eCONST; |
e.type := PARS.program.stTypes.tNIL; |
PARS.Next(parser) |
ELSIF (sym = SCAN.lxTRUE) OR (sym = SCAN.lxFALSE) THEN |
e.obj := eCONST; |
ARITH.setbool(e.value, sym = SCAN.lxTRUE); |
e.type := PARS.program.stTypes.tBOOLEAN; |
PARS.Next(parser) |
ELSIF sym = SCAN.lxLCURLY THEN |
set(parser, e) |
ELSIF sym = SCAN.lxIDENT THEN |
getpos(parser, pos); |
CODE.pushBegEnd(begcall, endcall); |
designator(parser, e); |
IF isVar(e) THEN |
LoadVar(e, parser, pos) |
END; |
IF parser.sym = SCAN.lxLROUND THEN |
e1 := e; |
ActualParameters(parser, e); |
PARS.check(e.type # NIL, parser, pos, 59); |
isfloat := e.type.typ = PROG.tREAL; |
IF e1.obj IN {ePROC, eIMP} THEN |
ProcCall(e1, e1.ident.type, isfloat, fregs, parser, pos, FALSE) |
ELSIF isExpr(e1) THEN |
ProcCall(e1, e1.type, isfloat, fregs, parser, pos, FALSE) |
END |
END; |
CODE.popBegEnd(begcall, endcall) |
ELSIF sym = SCAN.lxLROUND THEN |
PARS.Next(parser); |
expression(parser, e); |
PARS.checklex(parser, SCAN.lxRROUND); |
PARS.Next(parser); |
IF isExpr(e) & (e.obj # eCONST) THEN |
e.obj := eEXPR |
END |
ELSIF sym = SCAN.lxNOT THEN |
NextPos(parser, pos); |
factor(parser, e); |
PARS.check(isBoolean(e), parser, pos, 72); |
IF e.obj # eCONST THEN |
CODE.not; |
e.obj := eEXPR |
ELSE |
ASSERT(ARITH.neg(e.value)) |
END |
ELSE |
PARS.check1(FALSE, parser, 34) |
END |
END factor; |
PROCEDURE term (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
pos: SCAN.POSITION; |
op: INTEGER; |
e1: PARS.EXPR; |
label: INTEGER; |
label1: INTEGER; |
BEGIN |
factor(parser, e); |
label := -1; |
WHILE MulOperator(parser.sym) DO |
op := parser.sym; |
getpos(parser, pos); |
PARS.Next(parser); |
IF op = SCAN.lxAND THEN |
IF ~parser.constexp THEN |
IF label = -1 THEN |
label := CODE.NewLabel() |
END; |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e.value))) |
END; |
CODE.AddJmpCmd(CODE.opJZ, label); |
CODE.drop |
END |
END; |
factor(parser, e1); |
CASE op OF |
|SCAN.lxMUL: |
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), parser, pos, 37); |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
CASE e.value.typ OF |
|ARITH.tINTEGER: PARS.check(ARITH.opInt(e.value, e1.value, "*"), parser, pos, 39) |
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, "*"), parser, pos, 40) |
|ARITH.tSET: ARITH.opSet(e.value, e1.value, "*") |
END |
ELSE |
IF isInt(e) THEN |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opMULC, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opMULC, ARITH.Int(e1.value)) |
ELSE |
CODE.AddCmd0(CODE.opMUL) |
END |
ELSIF isReal(e) THEN |
IF e.obj = eCONST THEN |
CODE.Float(ARITH.Float(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.Float(ARITH.Float(e1.value)) |
END; |
CODE.fbinop(CODE.opMULF) |
ELSIF isSet(e) THEN |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opMULSC, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opMULSC, ARITH.Int(e1.value)) |
ELSE |
CODE.AddCmd0(CODE.opMULS) |
END |
END; |
e.obj := eEXPR |
END |
|SCAN.lxSLASH: |
PARS.check(isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), parser, pos, 37); |
IF (e1.obj = eCONST) & isReal(e1) THEN |
PARS.check(~ARITH.isZero(e1.value), parser, pos, 45) |
END; |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
CASE e.value.typ OF |
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, "/"), parser, pos, 40) |
|ARITH.tSET: ARITH.opSet(e.value, e1.value, "/") |
END |
ELSE |
IF isReal(e) THEN |
IF e.obj = eCONST THEN |
CODE.Float(ARITH.Float(e.value)); |
CODE.fbinop(CODE.opDIVFI) |
ELSIF e1.obj = eCONST THEN |
CODE.Float(ARITH.Float(e1.value)); |
CODE.fbinop(CODE.opDIVF) |
ELSE |
CODE.fbinop(CODE.opDIVF) |
END |
ELSIF isSet(e) THEN |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opDIVSC, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opDIVSC, ARITH.Int(e1.value)) |
ELSE |
CODE.AddCmd0(CODE.opDIVS) |
END |
END; |
e.obj := eEXPR |
END |
|SCAN.lxDIV, SCAN.lxMOD: |
PARS.check(isInt(e) & isInt(e1), parser, pos, 37); |
IF e1.obj = eCONST THEN |
PARS.check(~ARITH.isZero(e1.value), parser, pos, 46) |
END; |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
IF op = SCAN.lxDIV THEN |
PARS.check(ARITH.opInt(e.value, e1.value, "D"), parser, pos, 39) |
ELSE |
ASSERT(ARITH.opInt(e.value, e1.value, "M")) |
END |
ELSE |
IF e1.obj # eCONST THEN |
label1 := CODE.NewLabel(); |
CODE.AddJmpCmd(CODE.opJNZ, label1) |
END; |
IF e.obj = eCONST THEN |
CODE.OnError(pos.line, errDIV); |
CODE.SetLabel(label1); |
CODE.AddCmd(CODE.opDIVL + ORD(op = SCAN.lxMOD), ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opDIVR + ORD(op = SCAN.lxMOD), ARITH.Int(e1.value)) |
ELSE |
CODE.OnError(pos.line, errDIV); |
CODE.SetLabel(label1); |
CODE.AddCmd0(CODE.opDIV + ORD(op = SCAN.lxMOD)) |
END; |
e.obj := eEXPR |
END |
|SCAN.lxAND: |
PARS.check(isBoolean(e) & isBoolean(e1), parser, pos, 37); |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
ARITH.opBoolean(e.value, e1.value, "&") |
ELSE |
e.obj := eEXPR; |
IF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e1.value))) |
END |
END |
END |
END; |
IF label # -1 THEN |
CODE.SetLabel(label) |
END |
END term; |
PROCEDURE SimpleExpression (parser: PARS.PARSER; VAR e: PARS.EXPR); |
VAR |
pos: SCAN.POSITION; |
op: INTEGER; |
e1: PARS.EXPR; |
plus, minus: BOOLEAN; |
label: INTEGER; |
BEGIN |
plus := parser.sym = SCAN.lxPLUS; |
minus := parser.sym = SCAN.lxMINUS; |
IF plus OR minus THEN |
getpos(parser, pos); |
PARS.Next(parser) |
END; |
term(parser, e); |
IF plus OR minus THEN |
PARS.check(isInt(e) OR isReal(e) OR isSet(e), parser, pos, 36); |
IF minus & (e.obj = eCONST) THEN |
PARS.check(ARITH.neg(e.value), parser, pos, 39) |
END; |
IF e.obj # eCONST THEN |
IF minus THEN |
IF isInt(e) THEN |
CODE.AddCmd0(CODE.opUMINUS) |
ELSIF isReal(e) THEN |
CODE.AddCmd0(CODE.opUMINF) |
ELSIF isSet(e) THEN |
CODE.AddCmd0(CODE.opUMINS) |
END |
END; |
e.obj := eEXPR |
END |
END; |
label := -1; |
WHILE AddOperator(parser.sym) DO |
op := parser.sym; |
getpos(parser, pos); |
PARS.Next(parser); |
IF op = SCAN.lxOR THEN |
IF ~parser.constexp THEN |
IF label = -1 THEN |
label := CODE.NewLabel() |
END; |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e.value))) |
END; |
CODE.AddJmpCmd(CODE.opJNZ, label); |
CODE.drop |
END |
END; |
term(parser, e1); |
CASE op OF |
|SCAN.lxPLUS, SCAN.lxMINUS: |
IF op = SCAN.lxPLUS THEN |
op := ORD("+") |
ELSE |
op := ORD("-") |
END; |
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), parser, pos, 37); |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
CASE e.value.typ OF |
|ARITH.tINTEGER: PARS.check(ARITH.opInt(e.value, e1.value, CHR(op)), parser, pos, 39) |
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, CHR(op)), parser, pos, 40) |
|ARITH.tSET: ARITH.opSet(e.value, e1.value, CHR(op)) |
END |
ELSE |
IF isInt(e) THEN |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opADDL + ORD(op = ORD("-")), ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opADDR + ORD(op = ORD("-")), ARITH.Int(e1.value)) |
ELSE |
CODE.AddCmd0(CODE.opADD + ORD(op = ORD("-"))) |
END |
ELSIF isReal(e) THEN |
IF e.obj = eCONST THEN |
CODE.Float(ARITH.Float(e.value)); |
CODE.fbinop(CODE.opADDFI + ORD(op = ORD("-"))) |
ELSIF e1.obj = eCONST THEN |
CODE.Float(ARITH.Float(e1.value)); |
CODE.fbinop(CODE.opADDF + ORD(op = ORD("-"))) |
ELSE |
CODE.fbinop(CODE.opADDF + ORD(op = ORD("-"))) |
END |
ELSIF isSet(e) THEN |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opADDSL + ORD(op = ORD("-")), ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opADDSR + ORD(op = ORD("-")), ARITH.Int(e1.value)) |
ELSE |
CODE.AddCmd0(CODE.opADDS + ORD(op = ORD("-"))) |
END |
END; |
e.obj := eEXPR |
END |
|SCAN.lxOR: |
PARS.check(isBoolean(e) & isBoolean(e1), parser, pos, 37); |
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN |
ARITH.opBoolean(e.value, e1.value, "|") |
ELSE |
e.obj := eEXPR; |
IF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e1.value))) |
END |
END |
END |
END; |
IF label # -1 THEN |
CODE.SetLabel(label) |
END |
END SimpleExpression; |
PROCEDURE cmpcode (op: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
CASE op OF |
|SCAN.lxEQ: res := 0 |
|SCAN.lxNE: res := 1 |
|SCAN.lxLT: res := 2 |
|SCAN.lxLE: res := 3 |
|SCAN.lxGT: res := 4 |
|SCAN.lxGE: res := 5 |
END |
RETURN res |
END cmpcode; |
PROCEDURE BoolCmp (eq, val: BOOLEAN); |
BEGIN |
IF eq = val THEN |
CODE.AddCmd0(CODE.opNER) |
ELSE |
CODE.AddCmd0(CODE.opEQR) |
END |
END BoolCmp; |
PROCEDURE strcmp (VAR e, e1: PARS.EXPR; op: INTEGER): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := TRUE; |
IF isString(e) & isCharArray(e1) THEN |
CODE.AddCmd(CODE.opSADR, String(e)); |
CODE.AddCmd(CODE.opCONST, strlen(e) + 1); |
CODE.AddCmd0(CODE.opEQS2 + cmpcode(op)) |
ELSIF isString(e) & isCharArrayW(e1) THEN |
CODE.AddCmd(CODE.opSADR, StringW(e)); |
CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1); |
CODE.AddCmd0(CODE.opEQSW2 + cmpcode(op)) |
ELSIF isStringW(e) & isCharArrayW(e1) THEN |
CODE.AddCmd(CODE.opSADR, StringW(e)); |
CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1); |
CODE.AddCmd0(CODE.opEQSW2 + cmpcode(op)) |
ELSIF isCharArray(e) & isString(e1) THEN |
CODE.AddCmd(CODE.opSADR, String(e1)); |
CODE.AddCmd(CODE.opCONST, strlen(e1) + 1); |
CODE.AddCmd0(CODE.opEQS + cmpcode(op)) |
ELSIF isCharArrayW(e) & isString(e1) THEN |
CODE.AddCmd(CODE.opSADR, StringW(e1)); |
CODE.AddCmd(CODE.opCONST, utf8strlen(e1) + 1); |
CODE.AddCmd0(CODE.opEQSW + cmpcode(op)) |
ELSIF isCharArrayW(e) & isStringW(e1) THEN |
CODE.AddCmd(CODE.opSADR, StringW(e1)); |
CODE.AddCmd(CODE.opCONST, utf8strlen(e1) + 1); |
CODE.AddCmd0(CODE.opEQSW + cmpcode(op)) |
ELSIF isCharArrayW(e) & isCharArrayW(e1) THEN |
CODE.AddCmd0(CODE.opEQSW + cmpcode(op)) |
ELSIF isCharArray(e) & isCharArray(e1) THEN |
CODE.AddCmd0(CODE.opEQS + cmpcode(op)) |
ELSIF isString(e) & isString(e1) THEN |
PARS.strcmp(e.value, e1.value, op) |
ELSE |
res := FALSE |
END |
RETURN res |
END strcmp; |
BEGIN |
getpos(parser, pos0); |
SimpleExpression(parser, e); |
IF relation(parser.sym) THEN |
IF (isCharArray(e) OR isCharArrayW(e)) & (e.type.length # 0) THEN |
CODE.AddCmd(CODE.opCONST, e.type.length) |
END; |
op := parser.sym; |
getpos(parser, pos); |
PARS.Next(parser); |
pos1 := parser.lex.pos; |
SimpleExpression(parser, e1); |
IF (isCharArray(e1) OR isCharArrayW(e1)) & (e1.type.length # 0) THEN |
CODE.AddCmd(CODE.opCONST, e1.type.length) |
END; |
constant := (e.obj = eCONST) & (e1.obj = eCONST); |
CASE op OF |
|SCAN.lxEQ: operator := "=" |
|SCAN.lxNE: operator := "#" |
|SCAN.lxLT: operator := "<" |
|SCAN.lxLE: operator := "<=" |
|SCAN.lxGT: operator := ">" |
|SCAN.lxGE: operator := ">=" |
|SCAN.lxIN: operator := "IN" |
|SCAN.lxIS: operator := "" |
END; |
error := 0; |
CASE op OF |
|SCAN.lxEQ, SCAN.lxNE: |
IF isInt(e) & isInt(e1) OR isSet(e) & isSet(e1) OR isChar(e) & isChar(e1) OR isCharW(e) & isCharW(e1) OR |
isCharW(e) & isChar(e1) & (e1.obj = eCONST) OR isCharW(e1) & isChar(e) & (e.obj = eCONST) OR |
isCharW(e1) & (e1.obj = eCONST) & isChar(e) & (e.obj = eCONST) OR |
isCharW(e) & (e.obj = eCONST) & isChar(e1) & (e1.obj = eCONST) OR |
isPtr(e) & isPtr(e1) & (PROG.isBaseOf(e.type, e1.type) OR PROG.isBaseOf(e1.type, e.type)) THEN |
IF constant THEN |
ARITH.relation(e.value, e1.value, operator, error) |
ELSE |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, ARITH.Int(e1.value)) |
ELSE |
CODE.AddCmd0(CODE.opEQ + cmpcode(op)) |
END |
END |
ELSIF isStringW1(e) & isCharW(e1) THEN |
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, StrToWChar(e.value.string(SCAN.IDENT).s)) |
ELSIF isStringW1(e1) & isCharW(e) THEN |
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, StrToWChar(e1.value.string(SCAN.IDENT).s)) |
ELSIF isBoolean(e) & isBoolean(e1) THEN |
IF constant THEN |
ARITH.relation(e.value, e1.value, operator, error) |
ELSE |
IF e.obj = eCONST THEN |
BoolCmp(op = SCAN.lxEQ, ARITH.Int(e.value) # 0) |
ELSIF e1.obj = eCONST THEN |
BoolCmp(op = SCAN.lxEQ, ARITH.Int(e1.value) # 0) |
ELSE |
IF op = SCAN.lxEQ THEN |
CODE.AddCmd0(CODE.opEQB) |
ELSE |
CODE.AddCmd0(CODE.opNEB) |
END |
END |
END |
ELSIF isReal(e) & isReal(e1) THEN |
IF constant THEN |
ARITH.relation(e.value, e1.value, operator, error) |
ELSE |
IF e.obj = eCONST THEN |
CODE.Float(ARITH.Float(e.value)); |
CODE.fcmp(CODE.opEQF + cmpcode(op) + 6) |
ELSIF e1.obj = eCONST THEN |
CODE.Float(ARITH.Float(e1.value)); |
CODE.fcmp(CODE.opEQF + cmpcode(op)) |
ELSE |
CODE.fcmp(CODE.opEQF + cmpcode(op)) |
END |
END |
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN |
IF ~strcmp(e, e1, op) THEN |
PARS.error(parser, pos, 37) |
END |
ELSIF isPtr(e) & isNil(e1) OR isNil(e) & isPtr(e1) THEN |
CODE.AddCmd0(CODE.opEQ + cmpcode(op) + 6) |
ELSIF isProc(e) & isNil(e1) THEN |
IF e.obj IN {ePROC, eIMP} THEN |
PARS.check(e.ident.global, parser, pos0, 85); |
constant := TRUE; |
e.obj := eCONST; |
ARITH.setbool(e.value, op = SCAN.lxNE) |
ELSE |
CODE.AddCmd0(CODE.opEQ + cmpcode(op) + 6) |
END |
ELSIF isNil(e) & isProc(e1) THEN |
IF e1.obj IN {ePROC, eIMP} THEN |
PARS.check(e1.ident.global, parser, pos1, 85); |
constant := TRUE; |
e.obj := eCONST; |
ARITH.setbool(e.value, op = SCAN.lxNE) |
ELSE |
CODE.AddCmd0(CODE.opEQ + cmpcode(op) + 6) |
END |
ELSIF isProc(e) & isProc(e1) & PROG.isTypeEq(e.type, e1.type) THEN |
IF e.obj = ePROC THEN |
PARS.check(e.ident.global, parser, pos0, 85) |
END; |
IF e1.obj = ePROC THEN |
PARS.check(e1.ident.global, parser, pos1, 85) |
END; |
IF (e.obj IN {ePROC, eIMP}) & (e1.obj IN {ePROC, eIMP}) THEN |
constant := TRUE; |
e.obj := eCONST; |
IF op = SCAN.lxEQ THEN |
ARITH.setbool(e.value, e.ident = e1.ident) |
ELSE |
ARITH.setbool(e.value, e.ident # e1.ident) |
END |
ELSIF e.obj = ePROC THEN |
CODE.ProcCmp(e.ident.proc.label, cmpcode(op) = 0) |
ELSIF e1.obj = ePROC THEN |
CODE.ProcCmp(e1.ident.proc.label, cmpcode(op) = 0) |
ELSIF e.obj = eIMP THEN |
CODE.ProcImpCmp(e.ident.import, cmpcode(op) = 0) |
ELSIF e1.obj = eIMP THEN |
CODE.ProcImpCmp(e1.ident.import, cmpcode(op) = 0) |
ELSE |
CODE.AddCmd0(CODE.opEQ + cmpcode(op)) |
END |
ELSIF isNil(e) & isNil(e1) THEN |
constant := TRUE; |
e.obj := eCONST; |
ARITH.setbool(e.value, op = SCAN.lxEQ) |
ELSE |
PARS.error(parser, pos, 37) |
END |
|SCAN.lxLT, SCAN.lxLE, SCAN.lxGT, SCAN.lxGE: |
IF isInt(e) & isInt(e1) OR isChar(e) & isChar(e1) OR isCharW(e) & isCharW(e1) OR |
isCharW(e) & isChar(e1) & (e1.obj = eCONST) OR isCharW(e1) & isChar(e) & (e.obj = eCONST) OR |
isCharW(e1) & (e1.obj = eCONST) & isChar(e) & (e.obj = eCONST) OR |
isCharW(e) & (e.obj = eCONST) & isChar(e1) & (e1.obj = eCONST) THEN |
IF constant THEN |
ARITH.relation(e.value, e1.value, operator, error) |
ELSE |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, ARITH.Int(e1.value)) |
ELSE |
CODE.AddCmd0(CODE.opEQ + cmpcode(op)) |
END |
END |
ELSIF isStringW1(e) & isCharW(e1) THEN |
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, StrToWChar(e.value.string(SCAN.IDENT).s)) |
ELSIF isStringW1(e1) & isCharW(e) THEN |
CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, StrToWChar(e1.value.string(SCAN.IDENT).s)) |
ELSIF isReal(e) & isReal(e1) THEN |
IF constant THEN |
ARITH.relation(e.value, e1.value, operator, error) |
ELSE |
IF e.obj = eCONST THEN |
CODE.Float(ARITH.Float(e.value)); |
CODE.fcmp(CODE.opEQF + cmpcode(op) + 6) |
ELSIF e1.obj = eCONST THEN |
CODE.Float(ARITH.Float(e1.value)); |
CODE.fcmp(CODE.opEQF + cmpcode(op)) |
ELSE |
CODE.fcmp(CODE.opEQF + cmpcode(op)) |
END |
END |
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN |
IF ~strcmp(e, e1, op) THEN |
PARS.error(parser, pos, 37) |
END |
ELSE |
PARS.error(parser, pos, 37) |
END |
|SCAN.lxIN: |
PARS.check(isInt(e) & isSet(e1), parser, pos, 37); |
IF e.obj = eCONST THEN |
PARS.check(ARITH.range(e.value, 0, MACHINE.target.maxSet), parser, pos0, 56) |
END; |
IF constant THEN |
ARITH.relation(e.value, e1.value, operator, error) |
ELSE |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opINL, ARITH.Int(e.value)) |
ELSIF e1.obj = eCONST THEN |
CODE.AddCmd(CODE.opINR, ARITH.Int(e1.value)) |
ELSE |
CODE.AddCmd0(CODE.opIN) |
END |
END |
|SCAN.lxIS: |
PARS.check(isExpr(e) & (e.type.typ IN {PROG.tRECORD, PROG.tPOINTER}), parser, pos, 73); |
IF e.type.typ = PROG.tRECORD THEN |
PARS.check(e.obj = eVREC, parser, pos0, 78) |
END; |
PARS.check(e1.obj = eTYPE, parser, pos1, 79); |
IF e.type.typ = PROG.tRECORD THEN |
PARS.check(e1.type.typ = PROG.tRECORD, parser, pos1, 80); |
IF e.ident = NIL THEN |
CODE.TypeCheck(e1.type.num) |
ELSE |
CODE.AddCmd(CODE.opVADR, e.ident.offset - 1); |
CODE.TypeCheckRec(e1.type.num) |
END |
ELSE |
PARS.check(e1.type.typ = PROG.tPOINTER, parser, pos1, 81); |
CODE.TypeCheck(e1.type.base.num) |
END; |
PARS.check(PROG.isBaseOf(e.type, e1.type), parser, pos1, 82) |
END; |
ASSERT(error = 0); |
e.type := PARS.program.stTypes.tBOOLEAN; |
IF ~constant THEN |
e.obj := eEXPR |
END |
END |
END expression; |
PROCEDURE ElementaryStatement (parser: PARS.PARSER); |
VAR |
e, e1: PARS.EXPR; |
pos: SCAN.POSITION; |
line: INTEGER; |
call: BOOLEAN; |
fregs: INTEGER; |
BEGIN |
getpos(parser, pos); |
CODE.pushBegEnd(begcall, endcall); |
designator(parser, e); |
IF parser.sym = SCAN.lxASSIGN THEN |
line := parser.lex.pos.line; |
PARS.check(isVar(e), parser, pos, 93); |
PARS.check(~e.readOnly, parser, pos, 94); |
CODE.setlast(begcall); |
NextPos(parser, pos); |
expression(parser, e1); |
CODE.setlast(endcall.prev(CODE.COMMAND)); |
PARS.check(assign(e1, e.type, line), parser, pos, 91); |
IF e1.obj = ePROC THEN |
PARS.check(e1.ident.global, parser, pos, 85) |
END; |
call := FALSE |
ELSIF parser.sym = SCAN.lxEQ THEN |
PARS.check1(FALSE, parser, 96) |
ELSIF parser.sym = SCAN.lxLROUND THEN |
e1 := e; |
ActualParameters(parser, e1); |
PARS.check((e1.type = NIL) OR ODD(e.type.call), parser, pos, 92); |
call := TRUE |
ELSE |
PARS.check(isProc(e), parser, pos, 86); |
PARS.check((e.type.base = NIL) OR ODD(e.type.call), parser, pos, 92); |
PARS.check1(e.type.params.first = NIL, parser, 64); |
call := TRUE |
END; |
IF call THEN |
IF e.obj IN {ePROC, eIMP} THEN |
ProcCall(e, e.ident.type, FALSE, fregs, parser, pos, TRUE) |
ELSIF isExpr(e) THEN |
ProcCall(e, e.type, FALSE, fregs, parser, pos, TRUE) |
END |
END; |
CODE.popBegEnd(begcall, endcall) |
END ElementaryStatement; |
PROCEDURE IfStatement (parser: PARS.PARSER; if: BOOLEAN); |
VAR |
e: PARS.EXPR; |
pos: SCAN.POSITION; |
label, L: INTEGER; |
BEGIN |
L := CODE.NewLabel(); |
IF ~if THEN |
CODE.AddCmd0(CODE.opLOOP); |
CODE.SetLabel(L) |
END; |
REPEAT |
NextPos(parser, pos); |
label := CODE.NewLabel(); |
expression(parser, e); |
PARS.check(isBoolean(e), parser, pos, 72); |
IF e.obj = eCONST THEN |
IF ~ARITH.getBool(e.value) THEN |
CODE.AddJmpCmd(CODE.opJMP, label) |
END |
ELSE |
CODE.AddJmpCmd(CODE.opJNE, label) |
END; |
IF if THEN |
PARS.checklex(parser, SCAN.lxTHEN) |
ELSE |
PARS.checklex(parser, SCAN.lxDO) |
END; |
PARS.Next(parser); |
parser.StatSeq(parser); |
CODE.AddJmpCmd(CODE.opJMP, L); |
CODE.SetLabel(label) |
UNTIL parser.sym # SCAN.lxELSIF; |
IF if THEN |
IF parser.sym = SCAN.lxELSE THEN |
PARS.Next(parser); |
parser.StatSeq(parser) |
END; |
CODE.SetLabel(L) |
END; |
PARS.checklex(parser, SCAN.lxEND); |
IF ~if THEN |
CODE.AddCmd0(CODE.opENDLOOP) |
END; |
PARS.Next(parser) |
END IfStatement; |
PROCEDURE RepeatStatement (parser: PARS.PARSER); |
VAR |
e: PARS.EXPR; |
pos: SCAN.POSITION; |
label: INTEGER; |
BEGIN |
CODE.AddCmd0(CODE.opLOOP); |
label := CODE.NewLabel(); |
CODE.SetLabel(label); |
PARS.Next(parser); |
parser.StatSeq(parser); |
PARS.checklex(parser, SCAN.lxUNTIL); |
NextPos(parser, pos); |
expression(parser, e); |
PARS.check(isBoolean(e), parser, pos, 72); |
IF e.obj = eCONST THEN |
IF ~ARITH.getBool(e.value) THEN |
CODE.AddJmpCmd(CODE.opJMP, label) |
END |
ELSE |
CODE.AddJmpCmd(CODE.opJNE, label) |
END; |
CODE.AddCmd0(CODE.opENDLOOP) |
END RepeatStatement; |
PROCEDURE LabelCmp (a, b: AVL.DATA): INTEGER; |
VAR |
La, Ra, Lb, Rb, res: INTEGER; |
BEGIN |
La := a(CASE_LABEL).range.a; |
Ra := a(CASE_LABEL).range.b; |
Lb := b(CASE_LABEL).range.a; |
Rb := b(CASE_LABEL).range.b; |
IF (Ra < Lb) OR (La > Rb) THEN |
res := ORD(La > Lb) - ORD(La < Lb) |
ELSE |
res := 0 |
END |
RETURN res |
END LabelCmp; |
PROCEDURE DestroyLabel (VAR label: AVL.DATA); |
BEGIN |
C.push(CaseLabels, label); |
label := NIL |
END DestroyLabel; |
PROCEDURE NewVariant (label: INTEGER; cmd: CODE.COMMAND): CASE_VARIANT; |
VAR |
res: CASE_VARIANT; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(CaseVar); |
IF citem = NIL THEN |
NEW(res) |
ELSE |
res := citem(CASE_VARIANT) |
END; |
res.label := label; |
res.cmd := cmd; |
res.processed := FALSE |
RETURN res |
END NewVariant; |
PROCEDURE CaseStatement (parser: PARS.PARSER); |
VAR |
e: PARS.EXPR; |
pos: SCAN.POSITION; |
PROCEDURE isRecPtr (caseExpr: PARS.EXPR): BOOLEAN; |
RETURN isRec(caseExpr) OR isPtr(caseExpr) |
END isRecPtr; |
PROCEDURE Label (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR type: PROG.TYPE_): INTEGER; |
VAR |
a: INTEGER; |
label: PARS.EXPR; |
pos: SCAN.POSITION; |
value: ARITH.VALUE; |
BEGIN |
getpos(parser, pos); |
type := NIL; |
IF isChar(caseExpr) THEN |
PARS.ConstExpression(parser, value); |
PARS.check(value.typ = ARITH.tCHAR, parser, pos, 99); |
a := ARITH.getInt(value) |
ELSIF isCharW(caseExpr) THEN |
PARS.ConstExpression(parser, value); |
IF (value.typ = ARITH.tSTRING) & (_length(value.string(SCAN.IDENT).s) = 1) & (LENGTH(value.string(SCAN.IDENT).s) > 1) THEN |
ASSERT(ARITH.setInt(value, StrToWChar(value.string(SCAN.IDENT).s))) |
ELSE |
PARS.check(value.typ IN {ARITH.tWCHAR, ARITH.tCHAR}, parser, pos, 99) |
END; |
a := ARITH.getInt(value) |
ELSIF isInt(caseExpr) THEN |
PARS.ConstExpression(parser, value); |
PARS.check(value.typ = ARITH.tINTEGER, parser, pos, 99); |
a := ARITH.getInt(value) |
ELSIF isRecPtr(caseExpr) THEN |
qualident(parser, label); |
PARS.check(label.obj = eTYPE, parser, pos, 79); |
PARS.check(PROG.isBaseOf(caseExpr.type, label.type), parser, pos, 99); |
IF isRec(caseExpr) THEN |
a := label.type.num |
ELSE |
a := label.type.base.num |
END; |
type := label.type |
END |
RETURN a |
END Label; |
PROCEDURE CheckType (node: AVL.NODE; type: PROG.TYPE_; parser: PARS.PARSER; pos: SCAN.POSITION); |
BEGIN |
IF node # NIL THEN |
PARS.check(~(PROG.isBaseOf(node.data(CASE_LABEL).type, type) OR PROG.isBaseOf(type, node.data(CASE_LABEL).type)), parser, pos, 100); |
CheckType(node.left, type, parser, pos); |
CheckType(node.right, type, parser, pos) |
END |
END CheckType; |
PROCEDURE LabelRange (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; variant: INTEGER): AVL.NODE; |
VAR |
label: CASE_LABEL; |
citem: C.ITEM; |
pos, pos1: SCAN.POSITION; |
node: AVL.NODE; |
newnode: BOOLEAN; |
range: RANGE; |
BEGIN |
citem := C.pop(CaseLabels); |
IF citem = NIL THEN |
NEW(label) |
ELSE |
label := citem(CASE_LABEL) |
END; |
label.variant := variant; |
label.self := CODE.NewLabel(); |
getpos(parser, pos1); |
range.a := Label(parser, caseExpr, label.type); |
IF parser.sym = SCAN.lxRANGE THEN |
PARS.check1(~isRecPtr(caseExpr), parser, 53); |
NextPos(parser, pos); |
range.b := Label(parser, caseExpr, label.type); |
PARS.check(range.a <= range.b, parser, pos, 103) |
ELSE |
range.b := range.a |
END; |
label.range := range; |
IF isRecPtr(caseExpr) THEN |
CheckType(tree, label.type, parser, pos1) |
END; |
tree := AVL.insert(tree, label, LabelCmp, newnode, node); |
PARS.check(newnode, parser, pos1, 100) |
RETURN node |
END LabelRange; |
PROCEDURE CaseLabelList (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; variant: INTEGER): AVL.NODE; |
VAR |
exit: BOOLEAN; |
res: AVL.NODE; |
BEGIN |
exit := FALSE; |
REPEAT |
res := LabelRange(parser, caseExpr, tree, variant); |
IF parser.sym = SCAN.lxCOMMA THEN |
PARS.check1(~isRecPtr(caseExpr), parser, 53); |
PARS.Next(parser) |
ELSE |
exit := TRUE |
END |
UNTIL exit |
RETURN res |
END CaseLabelList; |
PROCEDURE case (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; end: INTEGER); |
VAR |
sym: INTEGER; |
t: PROG.TYPE_; |
variant: INTEGER; |
node: AVL.NODE; |
last: CODE.COMMAND; |
BEGIN |
sym := parser.sym; |
IF sym # SCAN.lxBAR THEN |
variant := CODE.NewLabel(); |
node := CaseLabelList(parser, caseExpr, tree, variant); |
PARS.checklex(parser, SCAN.lxCOLON); |
PARS.Next(parser); |
IF isRecPtr(caseExpr) THEN |
t := caseExpr.type; |
caseExpr.ident.type := node.data(CASE_LABEL).type |
END; |
last := CODE.getlast(); |
CODE.SetLabel(variant); |
IF ~isRecPtr(caseExpr) THEN |
LISTS.push(CaseVariants, NewVariant(variant, last)) |
END; |
parser.StatSeq(parser); |
CODE.AddJmpCmd(CODE.opJMP, end); |
IF isRecPtr(caseExpr) THEN |
caseExpr.ident.type := t |
END |
END |
END case; |
PROCEDURE Table (node: AVL.NODE; else: INTEGER); |
VAR |
L, R: INTEGER; |
range: RANGE; |
left, right: AVL.NODE; |
last: CODE.COMMAND; |
v: CASE_VARIANT; |
BEGIN |
IF node # NIL THEN |
range := node.data(CASE_LABEL).range; |
left := node.left; |
IF left # NIL THEN |
L := left.data(CASE_LABEL).self |
ELSE |
L := else |
END; |
right := node.right; |
IF right # NIL THEN |
R := right.data(CASE_LABEL).self |
ELSE |
R := else |
END; |
last := CODE.getlast(); |
v := CaseVariants.last(CASE_VARIANT); |
WHILE (v # NIL) & (v.label # 0) & (v.label # node.data(CASE_LABEL).variant) DO |
v := v.prev(CASE_VARIANT) |
END; |
ASSERT((v # NIL) & (v.label # 0)); |
CODE.setlast(v.cmd); |
CODE.SetLabel(node.data(CASE_LABEL).self); |
CODE.case(range.a, range.b, L, R); |
IF v.processed THEN |
CODE.AddJmpCmd(CODE.opJMP, node.data(CASE_LABEL).variant) |
END; |
v.processed := TRUE; |
CODE.setlast(last); |
Table(left, else); |
Table(right, else) |
END |
END Table; |
PROCEDURE TableT (node: AVL.NODE); |
BEGIN |
IF node # NIL THEN |
CODE.caset(node.data(CASE_LABEL).range.a, node.data(CASE_LABEL).variant); |
TableT(node.left); |
TableT(node.right) |
END |
END TableT; |
PROCEDURE ParseCase (parser: PARS.PARSER; e: PARS.EXPR; pos: SCAN.POSITION); |
VAR |
table, end, else: INTEGER; |
tree: AVL.NODE; |
item: LISTS.ITEM; |
BEGIN |
LISTS.push(CaseVariants, NewVariant(0, NIL)); |
end := CODE.NewLabel(); |
else := CODE.NewLabel(); |
table := CODE.NewLabel(); |
CODE.AddCmd(CODE.opSWITCH, ORD(isRecPtr(e))); |
CODE.AddJmpCmd(CODE.opJMP, table); |
tree := NIL; |
case(parser, e, tree, end); |
WHILE parser.sym = SCAN.lxBAR DO |
PARS.Next(parser); |
case(parser, e, tree, end) |
END; |
CODE.SetLabel(else); |
IF parser.sym = SCAN.lxELSE THEN |
PARS.Next(parser); |
parser.StatSeq(parser); |
CODE.AddJmpCmd(CODE.opJMP, end) |
ELSE |
CODE.OnError(pos.line, errCASE) |
END; |
PARS.checklex(parser, SCAN.lxEND); |
PARS.Next(parser); |
IF isRecPtr(e) THEN |
CODE.SetLabel(table); |
TableT(tree); |
CODE.AddJmpCmd(CODE.opJMP, else) |
ELSE |
tree.data(CASE_LABEL).self := table; |
Table(tree, else) |
END; |
AVL.destroy(tree, DestroyLabel); |
CODE.SetLabel(end); |
CODE.AddCmd0(CODE.opENDSW); |
REPEAT |
item := LISTS.pop(CaseVariants); |
C.push(CaseVar, item) |
UNTIL item(CASE_VARIANT).cmd = NIL |
END ParseCase; |
BEGIN |
NextPos(parser, pos); |
expression(parser, e); |
PARS.check(isInt(e) OR isChar(e) OR isCharW(e) OR isPtr(e) OR isRec(e), parser, pos, 95); |
IF isRecPtr(e) THEN |
PARS.check(isVar(e), parser, pos, 93); |
PARS.check(e.ident # NIL, parser, pos, 106) |
END; |
IF isRec(e) THEN |
PARS.check(e.obj = eVREC, parser, pos, 78) |
END; |
IF e.obj = eCONST THEN |
LoadConst(e) |
ELSIF isRec(e) THEN |
CODE.drop; |
CODE.AddCmd(CODE.opLADR, e.ident.offset - 1); |
CODE.load(PARS.program.target.word) |
ELSIF isPtr(e) THEN |
deref(pos, e, FALSE, errPTR); |
CODE.AddCmd(CODE.opSUBR, PARS.program.target.word); |
CODE.load(PARS.program.target.word) |
END; |
PARS.checklex(parser, SCAN.lxOF); |
PARS.Next(parser); |
ParseCase(parser, e, pos) |
END CaseStatement; |
PROCEDURE ForStatement (parser: PARS.PARSER); |
VAR |
e: PARS.EXPR; |
pos: SCAN.POSITION; |
step: ARITH.VALUE; |
st: INTEGER; |
ident: PROG.IDENT; |
offset: INTEGER; |
L1, L2: INTEGER; |
BEGIN |
CODE.AddCmd0(CODE.opLOOP); |
L1 := CODE.NewLabel(); |
L2 := CODE.NewLabel(); |
PARS.ExpectSym(parser, SCAN.lxIDENT); |
ident := parser.unit.idents.get(parser.unit, parser.lex.ident, TRUE); |
PARS.check1(ident # NIL, parser, 48); |
PARS.check1(ident.typ = PROG.idVAR, parser, 93); |
PARS.check1(ident.type.typ = PROG.tINTEGER, parser, 97); |
PARS.ExpectSym(parser, SCAN.lxASSIGN); |
NextPos(parser, pos); |
expression(parser, e); |
PARS.check(isInt(e), parser, pos, 76); |
offset := PROG.getOffset(PARS.program, ident); |
IF ident.global THEN |
CODE.AddCmd(CODE.opGADR, offset) |
ELSE |
CODE.AddCmd(CODE.opLADR, -offset) |
END; |
IF e.obj = eCONST THEN |
CODE.AddCmd(CODE.opSAVEC, ARITH.Int(e.value)) |
ELSE |
CODE.AddCmd0(CODE.opSAVE) |
END; |
CODE.SetLabel(L1); |
IF ident.global THEN |
CODE.AddCmd(CODE.opGADR, offset) |
ELSE |
CODE.AddCmd(CODE.opLADR, -offset) |
END; |
CODE.load(ident.type.size); |
PARS.checklex(parser, SCAN.lxTO); |
NextPos(parser, pos); |
expression(parser, e); |
PARS.check(isInt(e), parser, pos, 76); |
IF parser.sym = SCAN.lxBY THEN |
NextPos(parser, pos); |
PARS.ConstExpression(parser, step); |
PARS.check(step.typ = ARITH.tINTEGER, parser, pos, 76); |
st := ARITH.getInt(step); |
PARS.check(st # 0, parser, pos, 98) |
ELSE |
st := 1 |
END; |
IF e.obj = eCONST THEN |
IF st > 0 THEN |
CODE.AddCmd(CODE.opLER, ARITH.Int(e.value)) |
ELSE |
CODE.AddCmd(CODE.opGER, ARITH.Int(e.value)) |
END |
ELSE |
IF st > 0 THEN |
CODE.AddCmd0(CODE.opLE) |
ELSE |
CODE.AddCmd0(CODE.opGE) |
END |
END; |
CODE.AddJmpCmd(CODE.opJNE, L2); |
PARS.checklex(parser, SCAN.lxDO); |
PARS.Next(parser); |
parser.StatSeq(parser); |
IF ident.global THEN |
CODE.AddCmd(CODE.opGADR, offset) |
ELSE |
CODE.AddCmd(CODE.opLADR, -offset) |
END; |
IF st = 1 THEN |
CODE.AddCmd0(CODE.opINC1) |
ELSIF st = -1 THEN |
CODE.AddCmd0(CODE.opDEC1) |
ELSE |
IF st > 0 THEN |
CODE.AddCmd(CODE.opINCC, st) |
ELSE |
CODE.AddCmd(CODE.opDECC, -st) |
END |
END; |
CODE.AddJmpCmd(CODE.opJMP, L1); |
PARS.checklex(parser, SCAN.lxEND); |
PARS.Next(parser); |
CODE.SetLabel(L2); |
CODE.AddCmd0(CODE.opENDLOOP) |
END ForStatement; |
PROCEDURE statement (parser: PARS.PARSER); |
VAR |
sym: INTEGER; |
BEGIN |
sym := parser.sym; |
IF sym = SCAN.lxIDENT THEN |
ElementaryStatement(parser) |
ELSIF sym = SCAN.lxIF THEN |
IfStatement(parser, TRUE) |
ELSIF sym = SCAN.lxWHILE THEN |
IfStatement(parser, FALSE) |
ELSIF sym = SCAN.lxREPEAT THEN |
RepeatStatement(parser) |
ELSIF sym = SCAN.lxCASE THEN |
CaseStatement(parser) |
ELSIF sym = SCAN.lxFOR THEN |
ForStatement(parser) |
END |
END statement; |
PROCEDURE StatSeq (parser: PARS.PARSER); |
BEGIN |
statement(parser); |
WHILE parser.sym = SCAN.lxSEMI DO |
PARS.Next(parser); |
statement(parser) |
END |
END StatSeq; |
PROCEDURE chkreturn (parser: PARS.PARSER; e: PARS.EXPR; t: PROG.TYPE_; pos: SCAN.POSITION): BOOLEAN; |
VAR |
res: BOOLEAN; |
BEGIN |
res := assigncomp(e, t); |
IF res THEN |
IF e.obj = eCONST THEN |
IF e.type.typ = PROG.tREAL THEN |
CODE.Float(ARITH.Float(e.value)) |
ELSIF e.type.typ = PROG.tNIL THEN |
CODE.AddCmd(CODE.opCONST, 0) |
ELSE |
LoadConst(e) |
END |
ELSIF (e.type.typ = PROG.tINTEGER) & (t.typ = PROG.tBYTE) & (chkBYTE IN checking) THEN |
CheckRange(256, pos.line, errBYTE) |
ELSIF e.obj = ePROC THEN |
PARS.check(e.ident.global, parser, pos, 85); |
CODE.PushProc(e.ident.proc.label) |
ELSIF e.obj = eIMP THEN |
CODE.PushImpProc(e.ident.import) |
END; |
IF e.type.typ = PROG.tREAL THEN |
CODE.retf |
END |
END |
RETURN res |
END chkreturn; |
PROCEDURE setrtl; |
VAR |
rtl: PROG.UNIT; |
PROCEDURE getproc (rtl: PROG.UNIT; name: SCAN.LEXSTR; idx: INTEGER); |
VAR |
id: PROG.IDENT; |
BEGIN |
id := rtl.idents.get(rtl, SCAN.enterid(name), FALSE); |
IF (id # NIL) & (id.import # NIL) THEN |
CODE.codes.rtl[idx] := -id.import(CODE.IMPORT_PROC).label; |
id.proc.used := TRUE |
ELSIF (id # NIL) & (id.proc # NIL) THEN |
CODE.codes.rtl[idx] := id.proc.label; |
id.proc.used := TRUE |
ELSE |
ERRORS.error5("procedure ", mConst.RTL_NAME, ".", name, " not found") |
END |
END getproc; |
BEGIN |
rtl := PARS.program.rtl; |
ASSERT(rtl # NIL); |
getproc(rtl, "_move", CODE._move); |
getproc(rtl, "_move2", CODE._move2); |
getproc(rtl, "_set", CODE._set); |
getproc(rtl, "_set2", CODE._set2); |
getproc(rtl, "_div", CODE._div); |
getproc(rtl, "_mod", CODE._mod); |
getproc(rtl, "_div2", CODE._div2); |
getproc(rtl, "_mod2", CODE._mod2); |
getproc(rtl, "_arrcpy", CODE._arrcpy); |
getproc(rtl, "_rot", CODE._rot); |
getproc(rtl, "_new", CODE._new); |
getproc(rtl, "_dispose", CODE._dispose); |
getproc(rtl, "_strcmp", CODE._strcmp); |
getproc(rtl, "_error", CODE._error); |
getproc(rtl, "_is", CODE._is); |
getproc(rtl, "_isrec", CODE._isrec); |
getproc(rtl, "_guard", CODE._guard); |
getproc(rtl, "_guardrec", CODE._guardrec); |
getproc(rtl, "_length", CODE._length); |
getproc(rtl, "_init", CODE._init); |
getproc(rtl, "_dllentry", CODE._dllentry); |
getproc(rtl, "_strcpy", CODE._strcpy); |
getproc(rtl, "_exit", CODE._exit); |
getproc(rtl, "_strcpy2", CODE._strcpy2); |
getproc(rtl, "_lengthw", CODE._lengthw); |
getproc(rtl, "_strcmp2", CODE._strcmp2); |
getproc(rtl, "_strcmpw", CODE._strcmpw); |
getproc(rtl, "_strcmpw2", CODE._strcmpw2); |
END setrtl; |
PROCEDURE compile* (path, lib_path, modname, outname: PARS.PATH; target, version, stack, base: INTEGER; pic: BOOLEAN; chk: SET); |
VAR |
parser: PARS.PARSER; |
ext: PARS.PATH; |
amd64: BOOLEAN; |
BEGIN |
amd64 := target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64, mConst.Target_iELF64}; |
ext := mConst.FILE_EXT; |
CaseLabels := C.create(); |
CaseVar := C.create(); |
CaseVariants := LISTS.create(NIL); |
LISTS.push(CaseVariants, NewVariant(0, NIL)); |
checking := chk; |
IF amd64 THEN |
CODE.init(6, CODE.little_endian) |
ELSE |
CODE.init(8, CODE.little_endian) |
END; |
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn); |
IF parser.open(parser, mConst.RTL_NAME) THEN |
parser.parse(parser); |
PARS.destroy(parser) |
ELSE |
PARS.destroy(parser); |
parser := PARS.create(lib_path, lib_path, StatSeq, expression, designator, chkreturn); |
IF parser.open(parser, mConst.RTL_NAME) THEN |
parser.parse(parser); |
PARS.destroy(parser) |
ELSE |
ERRORS.error5("file ", lib_path, mConst.RTL_NAME, mConst.FILE_EXT, " not found") |
END |
END; |
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn); |
parser.main := TRUE; |
IF parser.open(parser, modname) THEN |
parser.parse(parser) |
ELSE |
ERRORS.error5("file ", path, modname, mConst.FILE_EXT, " not found") |
END; |
PARS.destroy(parser); |
IF PARS.program.bss > mConst.MAX_GLOBAL_SIZE THEN |
ERRORS.error1("size of global variables is too large") |
END; |
setrtl; |
PROG.DelUnused(PARS.program, CODE.DelImport); |
CODE.codes.bss := PARS.program.bss; |
IF amd64 THEN |
AMD64.CodeGen(CODE.codes, outname, target, stack, base) |
ELSE |
X86.CodeGen(CODE.codes, outname, target, stack, base, version, pic) |
END |
END compile; |
END STATEMENTS. |
/programs/develop/oberon07/Source/STRINGS.ob07 |
---|
0,0 → 1,291 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE STRINGS; |
IMPORT UTILS; |
PROCEDURE append* (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR); |
VAR |
n1, n2, i, j: INTEGER; |
BEGIN |
n1 := LENGTH(s1); |
n2 := LENGTH(s2); |
ASSERT(n1 + n2 < LEN(s1)); |
i := 0; |
j := n1; |
WHILE i < n2 DO |
s1[j] := s2[i]; |
INC(i); |
INC(j) |
END; |
s1[j] := 0X |
END append; |
PROCEDURE reverse* (VAR s: ARRAY OF CHAR); |
VAR |
i, j: INTEGER; |
a, b: CHAR; |
BEGIN |
i := 0; |
j := LENGTH(s) - 1; |
WHILE i < j DO |
a := s[i]; |
b := s[j]; |
s[i] := b; |
s[j] := a; |
INC(i); |
DEC(j) |
END |
END reverse; |
PROCEDURE IntToStr* (x: INTEGER; VAR str: ARRAY OF CHAR); |
VAR |
i, a: INTEGER; |
minus: BOOLEAN; |
BEGIN |
IF x = UTILS.minint THEN |
IF UTILS.bit_depth = 32 THEN |
COPY("-2147483648", str) |
ELSIF UTILS.bit_depth = 64 THEN |
COPY("-9223372036854775808", str) |
END |
ELSE |
minus := x < 0; |
IF minus THEN |
x := -x |
END; |
i := 0; |
a := 0; |
REPEAT |
str[i] := CHR(x MOD 10 + ORD("0")); |
x := x DIV 10; |
INC(i) |
UNTIL x = 0; |
IF minus THEN |
str[i] := "-"; |
INC(i) |
END; |
str[i] := 0X; |
reverse(str) |
END |
END IntToStr; |
PROCEDURE copy* (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR; spos, dpos, count: INTEGER); |
BEGIN |
WHILE count > 0 DO |
dst[dpos] := src[spos]; |
INC(spos); |
INC(dpos); |
DEC(count) |
END |
END copy; |
PROCEDURE search* (s: ARRAY OF CHAR; VAR pos: INTEGER; c: CHAR; forward: BOOLEAN); |
VAR |
length: INTEGER; |
BEGIN |
length := LENGTH(s); |
IF (0 <= pos) & (pos < length) THEN |
IF forward THEN |
WHILE (pos < length) & (s[pos] # c) DO |
INC(pos) |
END; |
IF pos = length THEN |
pos := -1 |
END |
ELSE |
WHILE (pos >= 0) & (s[pos] # c) DO |
DEC(pos) |
END |
END |
ELSE |
pos := -1 |
END |
END search; |
PROCEDURE letter* (c: CHAR): BOOLEAN; |
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z") OR (c = "_") |
END letter; |
PROCEDURE digit* (c: CHAR): BOOLEAN; |
RETURN ("0" <= c) & (c <= "9") |
END digit; |
PROCEDURE hexdigit* (c: CHAR): BOOLEAN; |
RETURN ("0" <= c) & (c <= "9") OR ("A" <= c) & (c <= "F") |
END hexdigit; |
PROCEDURE space* (c: CHAR): BOOLEAN; |
RETURN (0X < c) & (c <= 20X) |
END space; |
PROCEDURE StrToInt* (str: ARRAY OF CHAR; VAR x: INTEGER): BOOLEAN; |
VAR |
i, k: INTEGER; |
res: BOOLEAN; |
BEGIN |
res := TRUE; |
i := 0; |
x := 0; |
k := LENGTH(str); |
WHILE i < k DO |
IF digit(str[i]) THEN |
x := x * 10 + ORD(str[i]) - ORD("0") |
ELSE |
i := k; |
res := FALSE |
END; |
INC(i) |
END |
RETURN res |
END StrToInt; |
PROCEDURE CheckVer (str: ARRAY OF CHAR): BOOLEAN; |
VAR |
i, k: INTEGER; |
res: BOOLEAN; |
BEGIN |
k := LENGTH(str); |
res := k < LEN(str); |
IF res & digit(str[0]) THEN |
i := 0; |
WHILE (i < k) & digit(str[i]) DO |
INC(i) |
END; |
IF (i < k) & (str[i] = ".") THEN |
INC(i); |
IF i < k THEN |
WHILE (i < k) & digit(str[i]) DO |
INC(i) |
END |
ELSE |
res := FALSE |
END |
ELSE |
res := FALSE |
END; |
res := res & (i = k) |
ELSE |
res := FALSE |
END |
RETURN res |
END CheckVer; |
PROCEDURE StrToVer* (str: ARRAY OF CHAR; VAR major, minor: INTEGER): BOOLEAN; |
VAR |
i: INTEGER; |
res: BOOLEAN; |
BEGIN |
res := CheckVer(str); |
IF res THEN |
i := 0; |
minor := 0; |
major := 0; |
WHILE digit(str[i]) DO |
major := major * 10 + ORD(str[i]) - ORD("0"); |
INC(i) |
END; |
INC(i); |
WHILE digit(str[i]) DO |
minor := minor * 10 + ORD(str[i]) - ORD("0"); |
INC(i) |
END |
END |
RETURN res |
END StrToVer; |
PROCEDURE Utf8To16* (src: ARRAY OF CHAR; VAR dst: ARRAY OF WCHAR): INTEGER; |
VAR |
i, j, u, srclen, dstlen: INTEGER; |
c: CHAR; |
BEGIN |
srclen := LEN(src); |
dstlen := LEN(dst); |
i := 0; |
j := 0; |
WHILE (i < srclen) & (j < dstlen) & (src[i] # 0X) DO |
c := src[i]; |
CASE c OF |
|00X..7FX: |
u := ORD(c) |
|0C1X..0DFX: |
u := LSL(ORD(c) - 0C0H, 6); |
IF i + 1 < srclen THEN |
u := u + ROR(LSL(ORD(src[i + 1]), 26), 26); |
INC(i) |
END |
|0E1X..0EFX: |
u := LSL(ORD(c) - 0E0H, 12); |
IF i + 1 < srclen THEN |
u := u + ROR(LSL(ORD(src[i + 1]), 26), 20); |
INC(i) |
END; |
IF i + 1 < srclen THEN |
u := u + ROR(LSL(ORD(src[i + 1]), 26), 26); |
INC(i) |
END |
(* |
|0F1X..0F7X: |
|0F9X..0FBX: |
|0FDX: |
*) |
ELSE |
END; |
INC(i); |
dst[j] := WCHR(u); |
INC(j) |
END; |
IF j < dstlen THEN |
dst[j] := WCHR(0) |
END |
RETURN j |
END Utf8To16; |
END STRINGS. |
/programs/develop/oberon07/Source/TEXTDRV.ob07 |
---|
0,0 → 1,209 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE TEXTDRV; |
IMPORT FILES, C := COLLECTIONS; |
CONST |
CR = 0DX; LF = 0AX; |
CHUNK = 1024 * 256; |
TYPE |
TEXT* = POINTER TO RECORD (C.ITEM) |
chunk: ARRAY CHUNK OF BYTE; |
pos, size: INTEGER; |
file: FILES.FILE; |
utf8: BOOLEAN; |
CR: BOOLEAN; |
line*, col*: INTEGER; |
eof*: BOOLEAN; |
eol*: BOOLEAN; |
open*: PROCEDURE (text: TEXT; name: ARRAY OF CHAR): BOOLEAN; |
peak*: PROCEDURE (text: TEXT): CHAR; |
nextc*: PROCEDURE (text: TEXT) |
END; |
VAR |
texts: C.COLLECTION; |
PROCEDURE reset (text: TEXT); |
BEGIN |
text.chunk[0] := 0; |
text.pos := 0; |
text.size := 0; |
text.file := NIL; |
text.utf8 := FALSE; |
text.CR := FALSE; |
text.line := 1; |
text.col := 1; |
text.eof := FALSE; |
text.eol := FALSE |
END reset; |
PROCEDURE peak (text: TEXT): CHAR; |
RETURN CHR(text.chunk[text.pos]) |
END peak; |
PROCEDURE load (text: TEXT); |
BEGIN |
IF ~text.eof THEN |
text.size := FILES.read(text.file, text.chunk, LEN(text.chunk)); |
text.pos := 0; |
IF text.size = 0 THEN |
text.eof := TRUE; |
text.chunk[0] := 0 |
END |
END |
END load; |
PROCEDURE next (text: TEXT); |
VAR |
c: CHAR; |
BEGIN |
IF text.pos < text.size - 1 THEN |
INC(text.pos) |
ELSE |
load(text) |
END; |
IF ~text.eof THEN |
c := peak(text); |
IF c = CR THEN |
INC(text.line); |
text.col := 0; |
text.eol := TRUE; |
text.CR := TRUE |
ELSIF c = LF THEN |
IF ~text.CR THEN |
INC(text.line); |
text.col := 0; |
text.eol := TRUE |
ELSE |
text.eol := FALSE |
END; |
text.CR := FALSE |
ELSE |
text.eol := FALSE; |
IF text.utf8 THEN |
IF (c < 80X) OR (c > 0BFX) THEN |
INC(text.col) |
END |
ELSE |
INC(text.col) |
END; |
text.CR := FALSE |
END |
END |
END next; |
PROCEDURE init (text: TEXT); |
BEGIN |
IF (text.pos = 0) & (text.size >= 3) THEN |
IF (text.chunk[0] = 0EFH) & |
(text.chunk[1] = 0BBH) & |
(text.chunk[2] = 0BFH) THEN |
text.pos := 3; |
text.utf8 := TRUE |
END |
END; |
IF text.size = 0 THEN |
text.chunk[0] := 0; |
text.size := 1; |
text.eof := FALSE |
END; |
text.line := 1; |
text.col := 1 |
END init; |
PROCEDURE open (text: TEXT; name: ARRAY OF CHAR): BOOLEAN; |
BEGIN |
ASSERT(text # NIL); |
reset(text); |
text.file := FILES.open(name); |
IF text.file # NIL THEN |
load(text); |
init(text) |
END |
RETURN text.file # NIL |
END open; |
PROCEDURE NewText (): TEXT; |
VAR |
text: TEXT; |
citem: C.ITEM; |
BEGIN |
citem := C.pop(texts); |
IF citem = NIL THEN |
NEW(text) |
ELSE |
text := citem(TEXT) |
END |
RETURN text |
END NewText; |
PROCEDURE create* (): TEXT; |
VAR |
text: TEXT; |
BEGIN |
text := NewText(); |
reset(text); |
text.open := open; |
text.peak := peak; |
text.nextc := next |
RETURN text |
END create; |
PROCEDURE destroy* (VAR text: TEXT); |
BEGIN |
IF text # NIL THEN |
IF text.file # NIL THEN |
FILES.close(text.file) |
END; |
C.push(texts, text); |
text := NIL |
END |
END destroy; |
BEGIN |
texts := C.create() |
END TEXTDRV. |
/programs/develop/oberon07/Source/UNIXTIME.ob07 |
---|
0,0 → 1,69 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE UNIXTIME; |
VAR |
days: ARRAY 12, 31, 2 OF INTEGER; |
PROCEDURE init; |
VAR |
i, j, k, n0, n1: INTEGER; |
BEGIN |
FOR i := 0 TO 11 DO |
FOR j := 0 TO 30 DO |
days[i, j, 0] := 0; |
days[i, j, 1] := 0; |
END |
END; |
days[ 1, 28, 0] := -1; |
FOR k := 0 TO 1 DO |
days[ 1, 29, k] := -1; |
days[ 1, 30, k] := -1; |
days[ 3, 30, k] := -1; |
days[ 5, 30, k] := -1; |
days[ 8, 30, k] := -1; |
days[10, 30, k] := -1; |
END; |
n0 := 0; |
n1 := 0; |
FOR i := 0 TO 11 DO |
FOR j := 0 TO 30 DO |
IF days[i, j, 0] = 0 THEN |
days[i, j, 0] := n0; |
INC(n0) |
END; |
IF days[i, j, 1] = 0 THEN |
days[i, j, 1] := n1; |
INC(n1) |
END |
END |
END |
END init; |
PROCEDURE time* (year, month, day, hour, min, sec: INTEGER): INTEGER; |
VAR |
d, s: INTEGER; |
BEGIN |
d := (year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4; |
s := d * 86400 + hour * 3600 + min * 60 + sec |
RETURN s |
END time; |
BEGIN |
init |
END UNIXTIME. |
/programs/develop/oberon07/Source/UTILS.ob07 |
---|
1,418 → 1,120 |
(* |
Copyright 2016, 2017 Anton Krotov |
(* |
BSD 2-Clause License |
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/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE UTILS; |
IMPORT sys := SYSTEM, H := HOST, ERRORS; |
IMPORT HOST, UNIXTIME; |
CONST |
OS* = H.OS; |
Slash* = H.Slash; |
Ext* = ".ob07"; |
MAX_PATH = 1024; |
MAX_PARAM = 1024; |
Date* = 1509580800; (* 2017-11-02 *) |
slash* = HOST.slash; |
TYPE |
bit_depth* = HOST.bit_depth; |
maxint* = HOST.maxint; |
minint* = HOST.minint; |
STRING* = ARRAY MAX_PATH OF CHAR; |
OS = HOST.OS; |
ITEM* = POINTER TO rITEM; |
rITEM* = RECORD |
Next*, Prev*: ITEM |
END; |
VAR |
LIST* = POINTER TO RECORD |
First*, Last*: ITEM; |
Count*: INTEGER |
END; |
time*: INTEGER; |
STRCONST* = POINTER TO RECORD (rITEM) |
Str*: STRING; |
Len*, Number*: INTEGER |
END; |
eol*: ARRAY 3 OF CHAR; |
VAR |
maxreal*: REAL; |
Params: ARRAY MAX_PARAM, 2 OF INTEGER; |
ParamCount*, Line*, Unit*: INTEGER; |
FileName: STRING; |
PROCEDURE SetFile*(F: STRING); |
BEGIN |
FileName := F |
END SetFile; |
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
RETURN HOST.FileRead(F, Buffer, bytes) |
END FileRead; |
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 FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER; |
RETURN HOST.FileWrite(F, Buffer, bytes) |
END FileWrite; |
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 FileCreate* (FName: ARRAY OF CHAR): INTEGER; |
RETURN HOST.FileCreate(FName) |
END FileCreate; |
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; |
PROCEDURE FileClose* (F: INTEGER); |
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; |
HOST.FileClose(F) |
END FileClose; |
PROCEDURE GetMem*(n: INTEGER): INTEGER; |
RETURN H.malloc(n) |
END GetMem; |
PROCEDURE CloseF*(F: INTEGER); |
BEGIN |
H.CloseFile(F) |
END CloseF; |
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER; |
RETURN HOST.FileOpen(FName) |
END FileOpen; |
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; |
PROCEDURE GetArg* (i: INTEGER; VAR str: ARRAY OF CHAR); |
BEGIN |
str[0] := x; |
str[1] := 0X; |
H.OutString(str) |
END CharC; |
HOST.GetArg(i, str) |
END GetArg; |
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 Ln*; |
PROCEDURE Exit* (code: INTEGER); |
BEGIN |
CharC(0DX); |
CharC(0AX) |
END Ln; |
HOST.ExitProcess(code) |
END Exit; |
PROCEDURE OutString*(str: ARRAY OF CHAR); |
BEGIN |
H.OutString(str) |
END OutString; |
PROCEDURE ErrMsg*(code: INTEGER); |
VAR str: ARRAY 1024 OF CHAR; |
BEGIN |
ERRORS.ErrorMsg(code, str); |
OutString("error: ("); Int(code); OutString(") "); OutString(str); Ln |
END ErrMsg; |
PROCEDURE GetTickCount* (): INTEGER; |
RETURN HOST.GetTickCount() |
END GetTickCount; |
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 UnitLine*(newUnit, newLine: INTEGER); |
PROCEDURE OutChar* (c: CHAR); |
BEGIN |
Unit := newUnit; |
Line := newLine |
END UnitLine; |
HOST.OutChar(c) |
END OutChar; |
PROCEDURE Align*(n: INTEGER): INTEGER; |
RETURN (4 - n MOD 4) MOD 4 |
END Align; |
PROCEDURE CAP(x: CHAR): CHAR; |
BEGIN |
IF (x >= "a") & (x <= "z") THEN |
x := CHR(ORD(x) - 32) |
END |
RETURN x |
END CAP; |
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER; |
RETURN HOST.splitf(x, a, b) |
END splitf; |
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 concat*(VAR L: STRING; R: STRING); |
VAR i, n, pos: INTEGER; |
BEGIN |
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 isRelative* (path: ARRAY OF CHAR): BOOLEAN; |
RETURN HOST.isRelative(path) |
END isRelative; |
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 Push*(this: LIST; item: ITEM); |
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR); |
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; |
HOST.GetCurrentDirectory(path) |
END GetCurrentDirectory; |
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 Clear*(this: LIST); |
BEGIN |
this.First := NIL; |
this.Last := NIL; |
this.Count := 0 |
END Clear; |
PROCEDURE UnixTime* (): INTEGER; |
VAR |
year, month, day, hour, min, sec: INTEGER; |
res: INTEGER; |
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 Split*(FName: STRING; VAR Path, Name, Ext: STRING); |
VAR i, j, k: INTEGER; |
BEGIN |
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) |
IF OS = "LINUX" THEN |
res := HOST.UnixTime() |
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 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 |
Time; |
H.ExitProcess(n) |
END HALT; |
PROCEDURE MemErr*(err: BOOLEAN); |
BEGIN |
IF err THEN |
ErrMsg(72); |
HALT(1) |
HOST.now(year, month, day, hour, min, sec); |
res := UNIXTIME.time(year, month, day, hour, min, sec) |
END |
END MemErr; |
PROCEDURE CreateList*(): LIST; |
VAR nov: LIST; |
BEGIN |
NEW(nov); |
MemErr(nov = NIL) |
RETURN nov |
END CreateList; |
RETURN res |
END UnixTime; |
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 |
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 |
time := GetTickCount(); |
COPY(HOST.eol, eol); |
maxreal := 1.9; |
PACK(maxreal, 1023) |
END UTILS. |
/programs/develop/oberon07/Source/WRITER.ob07 |
---|
0,0 → 1,111 |
(* |
BSD 2-Clause License |
Copyright (c) 2018, Anton Krotov |
All rights reserved. |
*) |
MODULE WRITER; |
IMPORT FILES, ERRORS, MACHINE; |
TYPE |
FILE* = FILES.FILE; |
VAR |
counter*: INTEGER; |
PROCEDURE align (n, _align: INTEGER): INTEGER; |
BEGIN |
IF n MOD _align # 0 THEN |
n := n + _align - (n MOD _align) |
END |
RETURN n |
END align; |
PROCEDURE WriteByte* (file: FILE; n: BYTE); |
BEGIN |
IF FILES.WriteByte(file, n) THEN |
INC(counter) |
ELSE |
ERRORS.error1("writing file error") |
END |
END WriteByte; |
PROCEDURE Write* (file: FILE; chunk: ARRAY OF BYTE; bytes: INTEGER); |
VAR |
n: INTEGER; |
BEGIN |
n := FILES.write(file, chunk, bytes); |
IF n # bytes THEN |
ERRORS.error1("writing file error") |
END; |
INC(counter, n) |
END Write; |
PROCEDURE Write64LE* (file: FILE; n: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 7 DO |
WriteByte(file, MACHINE.Byte(n, i)) |
END |
END Write64LE; |
PROCEDURE Write32LE* (file: FILE; n: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
FOR i := 0 TO 3 DO |
WriteByte(file, MACHINE.Byte(n, i)) |
END |
END Write32LE; |
PROCEDURE Write16LE* (file: FILE; n: INTEGER); |
BEGIN |
WriteByte(file, MACHINE.Byte(n, 0)); |
WriteByte(file, MACHINE.Byte(n, 1)) |
END Write16LE; |
PROCEDURE Padding* (file: FILE; FileAlignment: INTEGER); |
VAR |
i: INTEGER; |
BEGIN |
i := align(counter, FileAlignment) - counter; |
WHILE i > 0 DO |
WriteByte(file, 0); |
DEC(i) |
END |
END Padding; |
PROCEDURE Create* (FileName: ARRAY OF CHAR): FILE; |
BEGIN |
counter := 0 |
RETURN FILES.create(FileName) |
END Create; |
PROCEDURE Close* (VAR file: FILE); |
BEGIN |
FILES.close(file) |
END Close; |
END WRITER. |
/programs/develop/oberon07/Source/X86.ob07 |
---|
1,2004 → 1,2406 |
(* |
Copyright 2016, 2017, 2018 Anton Krotov |
(* |
BSD 2-Clause License |
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/>. |
Copyright (c) 2018, 2019, Anton Krotov |
All rights reserved. |
*) |
MODULE X86; |
IMPORT UTILS, sys := SYSTEM, SCAN, ELF; |
IMPORT CODE, REG, UTILS, LISTS, BIN, PE32, KOS, MSCOFF, ELF, mConst := CONSTANTS, MACHINE, CHL := CHUNKLISTS, PATHS; |
CONST |
ADIM* = 5; |
eax = REG.R0; ecx = REG.R1; edx = REG.R2; |
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; |
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76; |
al = eax; cl = ecx; dl = edx; ah = 4; |
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; |
ax = eax; cx = ecx; dx = edx; |
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; |
esp = 4; |
ebp = 5; |
sysMOVE* = 108; |
sete = 94H; setne = 95H; setl = 9CH; setge = 9DH; setle = 9EH; setg = 9FH; setc = 92H; setnc = 93H; |
JMP* = 0E9X; CALL = 0E8X; |
JE = 84X; JNE = 85X; JLE = 8EX; JGE = 8DX; JG = 8FX; JL = 8CX; |
je = 84H; jne = 85H; jl = 8CH; jge = 8DH; jle = 8EH; jg = 8FH; jb = 82H; jnb = 83H; |
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; |
defcall = 0; stdcall = 1; cdecl = 2; winapi = 3; |
CODECHUNK = 8; |
_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 |
ASMLINE* = POINTER TO RECORD (UTILS.rITEM) |
cmd, clen, varadr, adr, tcmd, codeadr: INTEGER; short: BOOLEAN |
COMMAND = CODE.COMMAND; |
ANYCODE = POINTER TO RECORD (LISTS.ITEM) |
offset: INTEGER |
END; |
TFLT = ARRAY 2 OF INTEGER; |
TCODE = POINTER TO RECORD (ANYCODE) |
TIDX* = ARRAY ADIM OF INTEGER; |
code: ARRAY CODECHUNK OF BYTE; |
length: INTEGER |
SECTIONNAME = ARRAY 8 OF CHAR; |
END; |
SECTION = RECORD |
name: SECTIONNAME; |
size, adr, sizealign, OAPfile, reserved6, reserved7, reserved8, attrflags: INTEGER |
LABEL = POINTER TO RECORD (ANYCODE) |
label: INTEGER |
END; |
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 |
JUMP = POINTER TO RECORD (ANYCODE) |
label, diff: INTEGER; |
short: BOOLEAN |
END; |
COFFHEADER = RECORD |
Machine: sys.CARD16; |
NumberOfSections: sys.CARD16; |
TimeDateStamp, |
PointerToSymbolTable, |
NumberOfSymbols: INTEGER; |
SizeOfOptionalHeader, |
Characteristics: sys.CARD16; |
text, data, bss: SECTION |
JMP = POINTER TO RECORD (JUMP) |
END; |
KOSHEADER = RECORD |
menuet01: ARRAY 8 OF CHAR; |
ver, start, size, mem, sp, param, path: INTEGER |
JCC = POINTER TO RECORD (JUMP) |
jmp: INTEGER |
END; |
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 |
CALL = POINTER TO RECORD (JUMP) |
END; |
RELOC = RECORD |
Page, Size: INTEGER; |
reloc: ARRAY 1024 OF sys.CARD16 |
RELOC = POINTER TO RECORD (ANYCODE) |
op, value: INTEGER |
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; |
PROCEDURE set_maxstrlen* (value: INTEGER); |
BEGIN |
maxstrlen := value |
END set_maxstrlen; |
VAR |
PROCEDURE AddRtlProc*(idx, proc: INTEGER); |
BEGIN |
RtlProc[idx] := proc |
END AddRtlProc; |
R: REG.REGS; |
PROCEDURE IntToCard16(i: INTEGER): sys.CARD16; |
VAR w: sys.CARD16; |
BEGIN |
sys.GET(sys.ADR(i), w) |
RETURN w |
END IntToCard16; |
program: BIN.PROGRAM; |
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; |
CodeList: LISTS.LIST; |
PROCEDURE exch(VAR a, b: INTEGER); |
VAR c: INTEGER; |
BEGIN |
c := a; |
a := b; |
b := c |
END exch; |
PROCEDURE Sort(VAR NamePtr, Adr: ARRAY OF INTEGER; Text: ARRAY OF CHAR; LB, RB: INTEGER); |
VAR L, R: INTEGER; |
PROCEDURE Byte (n: INTEGER): BYTE; |
RETURN MACHINE.Byte(n, 0) |
END Byte; |
PROCEDURE strle(s1, s2: INTEGER): BOOLEAN; |
VAR S1, S2: ARRAY 256 OF CHAR; i: INTEGER; |
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 |
i := 0; |
CopyStr(S1, Text, i, s1); |
i := 0; |
CopyStr(S2, Text, i, s2) |
RETURN S1 <= S2 |
END strle; |
last := CodeList.last(ANYCODE); |
BEGIN |
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]) |
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) |
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; |
PROCEDURE PackExport(Name: ARRAY OF CHAR); |
VAR i: INTEGER; |
END OutByte; |
PROCEDURE OutInt (n: INTEGER); |
BEGIN |
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; |
OutByte(MACHINE.Byte(n, 0)); |
OutByte(MACHINE.Byte(n, 1)); |
OutByte(MACHINE.Byte(n, 2)); |
OutByte(MACHINE.Byte(n, 3)) |
END OutInt; |
PROCEDURE ProcExport*(Number: INTEGER; Name: SCAN.NODE; NameLabel: INTEGER); |
PROCEDURE OutByte2 (a, b: BYTE); |
BEGIN |
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; |
OutByte(a); |
OutByte(b) |
END OutByte2; |
PROCEDURE Err(code: INTEGER); |
PROCEDURE OutByte3 (a, b, c: BYTE); |
BEGIN |
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; |
OutByte(a); |
OutByte(b); |
OutByte(c) |
END OutByte3; |
PROCEDURE Align*(n, m: INTEGER): INTEGER; |
RETURN n + (m - n MOD m) MOD m |
END Align; |
PROCEDURE PutReloc(R: RELOC); |
VAR i: INTEGER; |
PROCEDURE OutWord (n: INTEGER); |
BEGIN |
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; |
ASSERT((0 <= n) & (n <= 65535)); |
OutByte2(n MOD 256, n DIV 256) |
END OutWord; |
PROCEDURE InitArray(VAR adr: INTEGER; chars: UTILS.STRING); |
VAR i, x, n: INTEGER; |
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); |
BEGIN |
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) |
IF isByte(n) THEN |
OutByte(Byte(n)) |
ELSE |
OutInt(n) |
END |
END InitArray; |
END OutIntByte; |
PROCEDURE WriteF(F, A, N: INTEGER); |
PROCEDURE shift* (op, reg: INTEGER); |
BEGIN |
IF UTILS.Write(F, A, N) # N THEN |
Err(2) |
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) |
END |
END WriteF; |
END shift; |
PROCEDURE Write(A, N: INTEGER); |
PROCEDURE mov (reg1, reg2: INTEGER); |
BEGIN |
sys.MOVE(A, OutFilePos, N); |
OutFilePos := OutFilePos + N |
END Write; |
OutByte2(89H, 0C0H + reg2 * 8 + reg1) // mov reg1, reg2 |
END mov; |
PROCEDURE Fill(n: INTEGER; c: CHAR); |
VAR i: INTEGER; |
PROCEDURE xchg (reg1, reg2: INTEGER); |
VAR |
regs: SET; |
BEGIN |
FOR i := 1 TO n DO |
Write(sys.ADR(c), 1) |
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 |
END |
END Fill; |
END xchg; |
PROCEDURE SetSection(VAR Section: SECTION; name: SECTIONNAME; size, adr, sizealign, OAPfile, attrflags: INTEGER); |
PROCEDURE pop (reg: INTEGER); |
BEGIN |
Section.name := name; |
Section.size := size; |
Section.adr := adr; |
Section.sizealign := sizealign; |
Section.OAPfile := OAPfile; |
Section.attrflags := attrflags; |
END SetSection; |
OutByte(58H + reg) // pop reg |
END pop; |
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; |
PROCEDURE push (reg: INTEGER); |
BEGIN |
OutByte(50H + reg) // push reg |
END push; |
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); |
InitArray(adr, "5000000040000000000000003400000000000000000000006200000000000000"); |
InitArray(adr, "0000000000000000000000000000000000000000500000004000000000000000"); |
InitArray(adr, "A4014C6F61644C6962726172794100001F0147657450726F6341646472657373"); |
InitArray(adr, "00006B65726E656C33322E646C6C0000"); |
PROCEDURE movrc (reg, n: INTEGER); |
BEGIN |
OutByte(0B8H + reg); // mov reg, n |
OutInt(n) |
END movrc; |
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; |
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; |
PROCEDURE pushc (n: INTEGER); |
BEGIN |
OutByte(68H + short(n)); // push n |
OutIntByte(n) |
END pushc; |
Header.structs[1].adr := Header.rdataadr + 0CH; |
Header.structs[1].size := 28H; |
Header.structs[12].adr := Header.rdataadr; |
Header.structs[12].size := 0CH; |
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); |
PROCEDURE test (reg: INTEGER); |
BEGIN |
OutByte2(85H, 0C0H + reg * 9) // test reg, reg |
END test; |
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; |
F := UTILS.CreateF(FName); |
IF F = 0 THEN |
Err(1) |
END; |
OutFilePos := UTILS.GetMem(filesize); |
filebuf := OutFilePos; |
UTILS.MemErr(OutFilePos = 0); |
PROCEDURE neg (reg: INTEGER); |
BEGIN |
OutByte2(0F7H, 0D8H + reg) // neg reg |
END neg; |
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; |
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; |
PROCEDURE not (reg: INTEGER); |
BEGIN |
NEW(nov); |
UTILS.MemErr(nov = NIL); |
nov.cmd := ccount; |
UTILS.Insert(asmlist, nov, current); |
current := current.Next(ASMLINE) |
END New; |
OutByte2(0F7H, 0D0H + reg) // not reg |
END not; |
PROCEDURE Empty(varadr: INTEGER); |
PROCEDURE add (reg1, reg2: INTEGER); |
BEGIN |
New; |
current.clen := 0; |
current.tcmd := ECMD; |
current.varadr := varadr |
END Empty; |
OutByte2(01H, 0C0H + reg2 * 8 + reg1) // add reg1, reg2 |
END add; |
PROCEDURE OutByte(byte: INTEGER); |
PROCEDURE andrc (reg, n: INTEGER); |
BEGIN |
New; |
current.clen := 1; |
Code[ccount] := CHR(byte); |
INC(ccount) |
END OutByte; |
OutByte2(81H + short(n), 0E0H + reg); // and reg, n |
OutIntByte(n) |
END andrc; |
PROCEDURE OutInt(int: INTEGER); |
PROCEDURE orrc (reg, n: INTEGER); |
BEGIN |
New; |
current.clen := 4; |
sys.PUT(sys.ADR(Code[ccount]), int); |
INC(ccount, 4) |
END OutInt; |
OutByte2(81H + short(n), 0C8H + reg); // or reg, n |
OutIntByte(n) |
END orrc; |
PROCEDURE PushEAX; |
PROCEDURE addrc (reg, n: INTEGER); |
BEGIN |
OutByte(50H); |
current.tcmd := PUSHEAX |
END PushEAX; |
OutByte2(81H + short(n), 0C0H + reg); // add reg, n |
OutIntByte(n) |
END addrc; |
PROCEDURE PushECX; |
PROCEDURE subrc (reg, n: INTEGER); |
BEGIN |
OutByte(51H); |
current.tcmd := PUSHECX |
END PushECX; |
OutByte2(81H + short(n), 0E8H + reg); // sub reg, n |
OutIntByte(n) |
END subrc; |
PROCEDURE PushEDX; |
PROCEDURE cmprr (reg1, reg2: INTEGER); |
BEGIN |
OutByte(52H); |
current.tcmd := PUSHEDX |
END PushEDX; |
OutByte2(39H, 0C0H + reg2 * 8 + reg1) // cmp reg1, reg2 |
END cmprr; |
PROCEDURE PopEAX; |
PROCEDURE cmprc (reg, n: INTEGER); |
BEGIN |
OutByte(58H); |
current.tcmd := POPEAX |
END PopEAX; |
OutByte2(81H + short(n), 0F8H + reg); // cmp reg, n |
OutIntByte(n) |
END cmprc; |
PROCEDURE PopECX; |
PROCEDURE setcc (cond, reg: INTEGER); |
BEGIN |
OutByte(59H); |
current.tcmd := POPECX |
END PopECX; |
OutByte3(0FH, cond, 0C0H + reg) // setcc reg |
END setcc; |
PROCEDURE PopEDX; |
PROCEDURE drop; |
BEGIN |
OutByte(5AH); |
current.tcmd := POPEDX |
END PopEDX; |
REG.Drop(R) |
END drop; |
PROCEDURE OutCode(cmd: UTILS.STRING); |
VAR a, b: INTEGER; |
PROCEDURE log2* (x: INTEGER): INTEGER; |
VAR |
n: INTEGER; |
BEGIN |
New; |
a := sys.ADR(Code[ccount]); |
b := a; |
InitArray(a, cmd); |
ccount := a - b + ccount; |
current.clen := a - b |
END OutCode; |
ASSERT(x > 0); |
PROCEDURE Del*(last: ASMLINE); |
BEGIN |
last.Next := current.Next; |
IF current = asmlist.Last THEN |
asmlist.Last := last |
n := 0; |
WHILE ~ODD(x) DO |
x := x DIV 2; |
INC(n) |
END; |
current := last |
END Del; |
PROCEDURE NewLabel*(): INTEGER; |
BEGIN |
INC(Lcount) |
RETURN Lcount |
END NewLabel; |
IF x # 1 THEN |
n := -1 |
END |
PROCEDURE PushCall*(asmline: ASMLINE); |
BEGIN |
New; |
callstk[topstk][0] := asmline; |
callstk[topstk][1] := current; |
INC(topstk) |
END PushCall; |
RETURN n |
END log2; |
PROCEDURE Param*; |
BEGIN |
current := callstk[topstk - 1][0] |
END Param; |
PROCEDURE EndCall*; |
PROCEDURE cond* (op: INTEGER): INTEGER; |
VAR |
res: INTEGER; |
BEGIN |
current := callstk[topstk - 1][1]; |
DEC(topstk) |
END EndCall; |
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 |
PROCEDURE Init*(UI: INTEGER); |
VAR nov: ASMLINE; |
RETURN res |
END cond; |
PROCEDURE inv1* (op: INTEGER): INTEGER; |
BEGIN |
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; |
IF ODD(op) THEN |
DEC(op) |
ELSE |
INC(op) |
END |
PROCEDURE datastr(str: UTILS.STRING); |
VAR i, n: INTEGER; |
RETURN op |
END inv1; |
PROCEDURE Reloc* (op, value: INTEGER); |
VAR |
reloc: RELOC; |
BEGIN |
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; |
NEW(reloc); |
reloc.op := op; |
reloc.value := value; |
LISTS.push(CodeList, reloc) |
END Reloc; |
PROCEDURE dataint(n: INTEGER); |
PROCEDURE jcc* (cc, label: INTEGER); |
VAR |
j: JCC; |
BEGIN |
sys.PUT(sys.ADR(Data[dcount]), n); |
INC(dcount, 4) |
END dataint; |
NEW(j); |
j.label := label; |
j.jmp := cc; |
j.short := FALSE; |
LISTS.push(CodeList, j) |
END jcc; |
PROCEDURE jmp*(jamp: CHAR; label: INTEGER); |
VAR n: INTEGER; |
PROCEDURE jmp* (label: INTEGER); |
VAR |
j: JMP; |
BEGIN |
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) |
NEW(j); |
j.label := label; |
j.short := FALSE; |
LISTS.push(CodeList, j) |
END jmp; |
PROCEDURE jmplong(jamp: CHAR; label: INTEGER); |
PROCEDURE call* (label: INTEGER); |
VAR |
c: CALL; |
BEGIN |
jmp(jamp, label); |
current.short := FALSE |
END jmplong; |
NEW(c); |
c.label := label; |
c.short := TRUE; |
LISTS.push(CodeList, c) |
END call; |
PROCEDURE Label*(label: INTEGER); |
PROCEDURE Pic (reg, opcode, value: INTEGER); |
BEGIN |
New; |
current.varadr := sys.ADR(Labels[label]); |
current.tcmd := LCMD |
END Label; |
OutByte(0E8H); OutInt(0); // call L |
// L: |
pop(reg); |
OutByte2(081H, 0C0H + reg); // add reg, ... |
Reloc(opcode, value) |
END Pic; |
PROCEDURE CmdN(Number: INTEGER); |
PROCEDURE CallRTL (pic: BOOLEAN; proc: INTEGER); |
VAR |
label: INTEGER; |
reg1: INTEGER; |
BEGIN |
New; |
current.clen := 4; |
current.codeadr := sys.ADR(Code[ccount]); |
current.varadr := sys.ADR(Labels[Number]); |
current.tcmd := OCMD; |
INC(ccount, 4) |
END CmdN; |
label := CODE.codes.rtl[proc]; |
PROCEDURE IntByte(bytecode, intcode: UTILS.STRING; n: INTEGER); |
BEGIN |
IF (n <= 127) & (n >= -128) THEN |
OutCode(bytecode); |
OutByte(n) |
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 |
ELSE |
OutCode(intcode); |
OutInt(n) |
OutByte2(0FFH, 015H); // call dword[label] |
Reloc(BIN.RIMP, label) |
END |
END IntByte; |
ELSE |
call(label) |
END |
END CallRTL; |
PROCEDURE DropFpu*(long: BOOLEAN); |
PROCEDURE SetLabel* (label: INTEGER); |
VAR |
L: LABEL; |
BEGIN |
IF long THEN |
OutCode("83EC08DD1C24") |
ELSE |
OutCode("83EC04D91C24") |
END; |
DEC(fpu) |
END DropFpu; |
NEW(L); |
L.label := label; |
LISTS.push(CodeList, L) |
END SetLabel; |
PROCEDURE AfterRet(func, float: BOOLEAN; callconv, parsize: INTEGER); |
PROCEDURE fixup*; |
VAR |
code: ANYCODE; |
count, i: INTEGER; |
shorted: BOOLEAN; |
jump: JUMP; |
BEGIN |
IF callconv = cdecl THEN |
OutCode("81C4"); |
OutInt(parsize) |
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) |
END; |
IF func THEN |
IF float THEN |
OutCode("83EC08DD1C24") |
ELSE |
PushEAX |
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 |
END |
END; |
code := code.next(ANYCODE) |
END |
END AfterRet; |
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) |
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]) |
END |
END FpuSave; |
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; |
|LABEL: |
BIN.SetLabel(program, code.label, code.offset) |
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") |
|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) |
END |
END FpuLoad; |
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) |
|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) |
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; |
PROCEDURE CallRTL(Proc: INTEGER); |
code := code.next(ANYCODE) |
END |
END fixup; |
PROCEDURE UnOp (VAR reg: INTEGER); |
BEGIN |
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; |
REG.UnOp(R, reg) |
END UnOp; |
PROCEDURE PushInt*(n: INTEGER); |
PROCEDURE BinOp (VAR reg1, reg2: INTEGER); |
BEGIN |
OutByte(68H); |
CmdN(n) |
END PushInt; |
REG.BinOp(R, reg1, reg2) |
END BinOp; |
PROCEDURE Prolog*(exename: UTILS.STRING); |
PROCEDURE PushAll (NumberOfParameters: INTEGER); |
BEGIN |
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; |
REG.PushAll(R); |
R.pushed := R.pushed - NumberOfParameters |
END PushAll; |
PROCEDURE AddRec*(base: INTEGER); |
PROCEDURE NewLabel (): INTEGER; |
BEGIN |
INC(reccount); |
recarray[reccount] := base |
END AddRec; |
BIN.NewLabel(program) |
RETURN CODE.NewLabel() |
END NewLabel; |
PROCEDURE CmpOpt(inv: BOOLEAN): INTEGER; |
VAR cur: ASMLINE; c: INTEGER; |
PROCEDURE GetRegA; |
BEGIN |
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; |
ASSERT(REG.GetReg(R, eax)) |
END GetRegA; |
PROCEDURE ifwh*(L: INTEGER); |
VAR c: INTEGER; |
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; |
BEGIN |
IF current.Prev(ASMLINE).tcmd = ICMP2 THEN |
c := CmpOpt(TRUE); |
OutCode("5A583BC2"); |
jmp(CHR(c), L) |
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 |
ELSE |
PopECX; |
OutCode("85C9"); |
jmp(JE, L) |
OutByte2(0FFH, 015H); // call dword[L] |
Reloc(BIN.RIMP, param1) |
END |
END ifwh; |
PROCEDURE PushConst*(Number: INTEGER); |
BEGIN |
IntByte("6A", "68", Number); |
current.Prev(ASMLINE).varadr := Number |
END PushConst; |
|CODE.opCALLP: |
UnOp(reg1); |
OutByte2(0FFH, 0D0H + reg1); // call reg1 |
drop; |
ASSERT(R.top = -1) |
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) |
|CODE.opPRECALL: |
n := param2; |
IF (param1 # 0) & (n # 0) THEN |
subrc(esp, 8) |
END; |
PushECX |
WHILE n > 0 DO |
subrc(esp, 8); |
OutByte3(0DDH, 01CH, 024H); // fstp qword[esp] |
DEC(n) |
END; |
jmp(JMP, L); |
Label(L1) |
END IfWhile; |
PushAll(0) |
PROCEDURE newrec*; |
BEGIN |
CallRTL(_newrec) |
END newrec; |
|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 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) |
|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) |
END |
END String; |
PROCEDURE InsertFpuInit; |
VAR t: ASMLINE; |
BEGIN |
IF isfpu THEN |
t := current; |
current := fpucmd; |
IF maxfpu > 0 THEN |
OutCode("83EC"); |
OutByte(maxfpu * 8) |
|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) |
END; |
OutCode("DBE3"); |
current := t |
WHILE n > 0 DO |
OutByte3(0DDH, 004H, 024H); // fld qword[esp] |
addrc(esp, 8); |
DEC(n) |
END |
END InsertFpuInit; |
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) |
|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 |
ELSE |
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") |
WHILE n > 0 DO |
pushc(0); |
DEC(n) |
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; |
fpucmd := current; |
fpu := 0; |
maxfpu := 0; |
isfpu := FALSE |
END ProcBeg; |
drop |
END; |
PROCEDURE Leave*; |
BEGIN |
OutByte(0C9H); |
InsertFpuInit |
END Leave; |
ASSERT(R.top = -1); |
PROCEDURE ProcEnd*(Number, Param: INTEGER; func, float: BOOLEAN); |
BEGIN |
IF func & ~float THEN |
PopEAX |
END; |
OutByte(0C9H); |
IF Param = 0 THEN |
OutByte(0C3H) |
mov(esp, ebp); |
pop(ebp); |
n := param2; |
IF n > 0 THEN |
n := n * 4; |
OutByte(0C2H); OutWord(Word(n)) // ret n |
ELSE |
OutByte(0C2H); |
OutByte(Param MOD 256); |
OutByte(ASR(Param, 8)) |
END; |
InsertFpuInit |
END ProcEnd; |
OutByte(0C3H) // ret |
END |
PROCEDURE Module*(Name: UTILS.STRING; Number: INTEGER); |
BEGIN |
String(Number + 2, LENGTH(Name), Name); |
jmplong(JMP, Number + 1) |
END Module; |
|CODE.opERRC: |
pushc(param2) |
PROCEDURE Asm*(s: UTILS.STRING); |
BEGIN |
OutCode(s) |
END Asm; |
|CODE.opPARAM: |
n := param2; |
IF n = 1 THEN |
UnOp(reg1); |
push(reg1); |
drop |
ELSE |
ASSERT(R.top + 1 <= n); |
PushAll(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.opCLEANUP: |
n := param2 * 4; |
IF n # 0 THEN |
addrc(esp, n) |
END |
PROCEDURE Mono*(Number: INTEGER); |
BEGIN |
PopEDX; |
PushInt(Number) |
END Mono; |
|CODE.opPOPSP: |
pop(esp) |
PROCEDURE StrMono*; |
BEGIN |
PopEDX; |
OutCode("6A02"); |
PushEDX |
END StrMono; |
|CODE.opCONST: |
reg1 := REG.GetAnyReg(R); |
movrc(reg1, param2) |
PROCEDURE Not*; |
BEGIN |
PopECX; |
OutCode("85C90F94C1"); |
PushECX |
END Not; |
|CODE.opLABEL: |
SetLabel(param2) // L: |
PROCEDURE NegSet*; |
BEGIN |
OutCode("F71424") |
END NegSet; |
|CODE.opNOP: |
PROCEDURE Int*(Op: INTEGER); |
BEGIN |
PopEDX; |
CASE Op OF |
|lxPlus: OutCode("011424") |
|lxMinus: OutCode("291424") |
|lxMult: OutCode("58F7EA"); PushEAX |
|CODE.opGADR: |
reg1 := REG.GetAnyReg(R); |
IF pic THEN |
Pic(reg1, BIN.PICBSS, param2) |
ELSE |
OutByte(0B8H + reg1); // mov reg1, _bss + param2 |
Reloc(BIN.RBSS, param2) |
END |
END Int; |
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.opLADR: |
n := param2 * 4; |
reg1 := REG.GetAnyReg(R); |
OutByte2(8DH, 45H + reg1 * 8 + long(n)); // lea reg1, dword[ebp + n] |
OutIntByte(n) |
PROCEDURE Setfpu*(newfpu: INTEGER); |
BEGIN |
fpu := newfpu |
END Setfpu; |
|CODE.opVADR: |
n := param2 * 4; |
reg1 := REG.GetAnyReg(R); |
OutByte2(8BH, 45H + reg1 * 8 + long(n)); // mov reg1, dword[ebp + n] |
OutIntByte(n) |
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") |
|CODE.opSADR: |
reg1 := REG.GetAnyReg(R); |
IF pic THEN |
Pic(reg1, BIN.PICDATA, stroffs + param2); |
ELSE |
L := NewLabel(); |
Labels[L] := -dcount; |
dataint(f[0]); |
dataint(f[1]); |
OutByte(0BAH); |
CmdN(L); |
OutCode("DD02") |
OutByte(0B8H + reg1); // mov reg1, _data + stroffs + param2 |
Reloc(BIN.RDATA, stroffs + param2) |
END |
END PushFlt; |
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 |
|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] |
ELSE |
END; |
OutByte(n); |
DEC(fpu) |
END farith; |
OutByte2(08BH, 05H + reg1 * 8); // mov reg1, dword[_bss + param2] |
Reloc(BIN.RBSS, param2) |
END |
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 |
|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] |
ELSE |
END; |
DEC(fpu, 2); |
OutByte(n); |
OutByte(0C1H); |
PushECX |
END fcmp; |
OutByte3(00FH, 0B6H, 05H + reg1 * 8); // movzx reg1, byte[_bss + param2] |
Reloc(BIN.RBSS, param2) |
END |
PROCEDURE fneg*; |
BEGIN |
OutCode("D9E0") |
END fneg; |
|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 OnError*(n: INTEGER); |
BEGIN |
OutByte(68H); |
OutInt(LSL(UTILS.Line, 4) + n); |
jmplong(JMP, UTILS.Unit + 3) |
END OnError; |
|CODE.opLOAD8: |
UnOp(reg1); |
OutByte3(0FH, 0B6H, reg1 * 9) // movzx reg1, byte[reg1] |
PROCEDURE idivmod*(opmod: BOOLEAN); |
BEGIN |
PopECX; |
IF opmod THEN |
OutCode("58E32E538BD833D9C1FB1F8BD0C1FA1F83F9FF750C3D0000008075055B6A00EB1AF7F985DB740685D2740203D15B52EB0A") |
|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] |
ELSE |
OutCode("58E32C538BD833D9C1FB1F8BD0C1FA1F83F9FF750B3D0000008075045B50EB19F7F985DB740585D27401485B50EB0A") |
END; |
OnError(8) |
END idivmod; |
OutByte3(00FH, 0B7H, 05H + reg1 * 8); // movzx reg1, word[_bss + param2] |
Reloc(BIN.RBSS, param2) |
END |
PROCEDURE rset*; |
BEGIN |
CallRTL(_rset); |
PushEAX |
END rset; |
|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 inset*; |
BEGIN |
CallRTL(_inset); |
PushEAX |
END inset; |
|CODE.opLOAD16: |
UnOp(reg1); |
OutByte3(0FH, 0B7H, reg1 * 9) // movzx reg1, word[reg1] |
PROCEDURE Dup*; |
BEGIN |
PopEDX; |
PushEDX; |
PushEDX |
END Dup; |
|CODE.opUMINUS: |
UnOp(reg1); |
neg(reg1) |
PROCEDURE Inclusion*(Op: INTEGER); |
BEGIN |
PopEDX; |
PopEAX; |
IF Op = lxLE THEN |
PushEDX |
|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 |
ELSE |
PushEAX |
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) |
END; |
OutCode("0BC25933C8E3046A00EB026A01") |
END Inclusion; |
IF cmd.opcode = CODE.opSUBL THEN |
neg(reg1) |
END |
PROCEDURE NegInt*; |
BEGIN |
OutCode("F71C24") |
END NegInt; |
|CODE.opMULC: |
UnOp(reg1); |
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 |
a := param2; |
IF a > 1 THEN |
n := log2(a) |
ELSIF a < -1 THEN |
n := log2(-a) |
ELSE |
n := -1 |
END; |
OutByte(n); |
OutByte(0C1H); current.tcmd := ICMP2; |
PushECX; |
END CmpInt; |
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; |
IF a = 1 THEN |
PROCEDURE LocalAdr*(offset, bases: INTEGER); |
BEGIN |
IF bases = 0 THEN |
Empty(offset); |
OutCode("8BD5") |
ELSIF a = -1 THEN |
neg(reg1) |
ELSIF a = 0 THEN |
OutByte2(31H, 0C0H + reg1 * 9) // xor reg1, reg1 |
ELSE |
IntByte("8B55", "8B95", 4 * bases + 4) |
IF n > 0 THEN |
IF a < 0 THEN |
neg(reg1) |
END; |
IntByte("83C2", "81C2", offset); |
PushEDX; |
IF bases = 0 THEN |
Empty(offset) |
END |
END LocalAdr; |
PROCEDURE Field*(offset: INTEGER); |
BEGIN |
IF offset # 0 THEN |
IntByte("830424", "810424", offset) |
IF n # 1 THEN |
OutByte3(0C1H, 0E0H + reg1, n) // shl reg1, n |
ELSE |
OutByte2(0D1H, 0E0H + reg1) // shl reg1, 1 |
END |
END Field; |
ELSE |
OutByte2(69H + short(a), 0C0H + reg1 * 9); // imul reg1, a |
OutIntByte(a) |
END |
END |
PROCEDURE DerefType*(n: INTEGER); |
BEGIN |
IntByte("8B5424", "8B9424", n); |
OutCode("FF72FC") |
END DerefType; |
|CODE.opMUL: |
BinOp(reg1, reg2); |
OutByte3(0FH, 0AFH, 0C0H + reg1 * 8 + reg2); // imul reg1, reg2 |
drop |
PROCEDURE Guard*(T: INTEGER; Check: BOOLEAN); |
BEGIN |
IF Check THEN |
PopEAX; |
OutCode("85C074"); |
IF T <= 127 THEN |
OutByte(9) |
|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 |
ELSE |
OutByte(12) |
OutByte2(0C7H, reg1); // mov dword[reg1], L |
Reloc(BIN.RCODE, param2) |
END; |
PushEAX |
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] |
END; |
PushConst(T); |
PushEAX; |
CallRTL(_checktype); |
IF Check THEN |
PushEAX |
drop |
|CODE.opPUSHP: |
reg1 := REG.GetAnyReg(R); |
IF pic THEN |
Pic(reg1, BIN.PICCODE, param2) |
ELSE |
OutCode("85C0750A"); |
OnError(3) |
OutByte(0B8H + reg1); // mov reg1, L |
Reloc(BIN.RCODE, param2) |
END |
END Guard; |
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) |
|CODE.opPUSHIP: |
reg1 := REG.GetAnyReg(R); |
IF pic THEN |
Pic(reg1, BIN.PICIMP, param2); |
OutByte2(08BH, reg1 * 9) // mov reg1, dword[reg1] |
ELSE |
OutByte2(08BH, 05H + reg1 * 8); // mov reg1, dword[L] |
Reloc(BIN.RIMP, param2) |
END |
END StProc; |
PROCEDURE Assert*(proc, assrt: INTEGER); |
BEGIN |
PopEDX; |
OutCode("85D2751368"); |
OutInt(UTILS.Line * 16 + 1); |
PushInt(UTILS.Unit + 2); |
IF proc = stASSERT THEN |
OutCode("6A026A") |
|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) |
ELSE |
OutCode("6A016A") |
cmprc(reg1, param2) |
END; |
OutByte(assrt); |
jmplong(JMP, ASSRT) |
END Assert; |
drop; |
cc := cond(cmd.opcode); |
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; |
IF cmd.next(COMMAND).opcode = CODE.opJE THEN |
label := cmd.next(COMMAND).param1; |
jcc(cc, label); |
cmd := cmd.next(COMMAND) |
PROCEDURE Load*(T: INTEGER); |
VAR lastcmd: ASMLINE; offset: INTEGER; |
ELSIF cmd.next(COMMAND).opcode = CODE.opJNE THEN |
label := cmd.next(COMMAND).param1; |
jcc(inv1(cc), label); |
cmd := cmd.next(COMMAND) |
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) |
ELSE |
reg1 := REG.GetAnyReg(R); |
setcc(cc + 16, reg1); |
andrc(reg1, 1) |
END; |
lastcmd.tcmd := 0 |
END del; |
BEGIN |
lastcmd := current; |
CASE T OF |
|TINTEGER, TSET, TPOINTER, TPROC: |
IF lastcmd.tcmd = ECMD THEN |
del; |
IntByte("8B55", "8B95", offset); |
PushEDX |
|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) |
ELSE |
PopEDX; |
OutCode("FF32") |
reg1 := REG.GetAnyReg(R); |
setcc(cc + 16, reg1); |
andrc(reg1, 1) |
END |
|TCHAR, TBOOLEAN: |
IF lastcmd.tcmd = ECMD THEN |
del; |
OutCode("0FB6"); |
IntByte("55", "95", offset); |
PushEDX |
|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) |
ELSE |
PopEDX; |
OutCode("0FB60A"); |
PushECX |
END |
|TLONGREAL: |
IF lastcmd.tcmd = ECMD THEN |
del; |
IntByte("DD45", "DD85", offset) |
ELSE |
PopEDX; |
OutCode("DD02") |
setcc(setne, reg1) |
END; |
Incfpu |
|TREAL: |
IF lastcmd.tcmd = ECMD THEN |
del; |
IntByte("D945", "D985", offset) |
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 |
ELSE |
PopEDX; |
OutCode("D902") |
reg2 := ecx |
END; |
Incfpu |
|TCARD16: |
IF lastcmd.tcmd = ECMD THEN |
del; |
OutCode("33D2668B"); |
IntByte("55", "95", offset); |
PushEDX |
ELSE |
PopEDX; |
OutCode("33C9668B0A"); |
PushECX |
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) |
END |
|CODE.opSAVES: |
UnOp(reg1); |
drop; |
PushAll(0); |
push(reg1); |
IF pic THEN |
Pic(reg1, BIN.PICDATA, stroffs + param2); |
push(reg1) |
ELSE |
END |
END Load; |
OutByte(068H); // push _data + stroffs + param2 |
Reloc(BIN.RDATA, stroffs + param2); |
END; |
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) |
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) |
ELSE |
INCL(R.regs, reg1); |
DEC(R.top); |
R.stk[R.top] := reg2 |
END |
END Save; |
PROCEDURE OpenArray*(A: TIDX; n: INTEGER); |
VAR i: INTEGER; |
BEGIN |
PopEDX; |
FOR i := n - 1 TO 0 BY -1 DO |
PushConst(A[i]) |
|CODE.opLEN: |
n := param2; |
UnOp(reg1); |
drop; |
EXCL(R.regs, reg1); |
WHILE n > 0 DO |
UnOp(reg2); |
drop; |
DEC(n) |
END; |
PushEDX |
END OpenArray; |
PROCEDURE OpenIdx*(n: INTEGER); |
BEGIN |
OutByte(54H); |
IF n > 1 THEN |
PushConst(n); |
CallRTL(_arrayidx) |
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 |
ELSE |
CallRTL(_arrayidx1) |
OutByte2(28H, reg1 * 8 + reg2) // sub byte[reg2], reg1 |
END; |
PopEDX; |
OutCode("85D2750A"); |
OnError(5); |
PushEDX; |
END OpenIdx; |
drop; |
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.opMULS: |
BinOp(reg1, reg2); |
OutByte2(21H, 0C0H + reg2 * 8 + reg1); // and reg1, reg2 |
drop |
PROCEDURE Idx*; |
BEGIN |
PopEDX; |
PopECX; |
OutCode("03D1"); |
PushEDX |
END Idx; |
|CODE.opMULSC: |
UnOp(reg1); |
andrc(reg1, param2) |
PROCEDURE DupLoadCheck*; |
BEGIN |
PopEDX; |
OutCode("528B125285D2750A"); |
OnError(6) |
END DupLoadCheck; |
|CODE.opDIVS: |
BinOp(reg1, reg2); |
OutByte2(31H, 0C0H + reg2 * 8 + reg1); // xor reg1, reg2 |
drop |
PROCEDURE DupLoad*; |
BEGIN |
PopEDX; |
OutCode("528B12"); |
PushEDX; |
END DupLoad; |
|CODE.opDIVSC: |
UnOp(reg1); |
OutByte2(81H + short(param2), 0F0H + reg1); // xor reg1, n |
OutIntByte(param2) |
PROCEDURE CheckNIL*; |
BEGIN |
PopEDX; |
OutCode("85D2750A"); |
OnError(6); |
PushEDX; |
END CheckNIL; |
|CODE.opADDS: |
BinOp(reg1, reg2); |
OutByte2(9H, 0C0H + reg2 * 8 + reg1); // or reg1, reg2 |
drop |
PROCEDURE ExtArray*(A: TIDX; n, m: INTEGER); |
VAR i: INTEGER; |
BEGIN |
FOR i := n - 1 TO 0 BY -1 DO |
PushConst(A[i]) |
|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 |
END; |
OutByte(54H); |
PushConst(n); |
PushConst(m); |
CallRTL(_arrayrot) |
END ExtArray; |
PROCEDURE ADR*(dim: INTEGER); |
BEGIN |
IF dim > 0 THEN |
PopEDX; |
OutCode("83C4"); |
OutByte(dim * 4); |
PushEDX |
END |
END ADR; |
BinOp(reg1, reg2); |
ASSERT(reg2 = ecx); |
OutByte(0D3H); |
shift(cmd.opcode, reg1); // shift reg1, cl |
drop |
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; |
|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 For*(inc: BOOLEAN; VAR LBeg, LEnd: INTEGER); |
BEGIN |
LEnd := NewLabel(); |
LBeg := NewLabel(); |
Label(LBeg); |
OutCode("8B14248B4424043910"); |
IF inc THEN |
jmp(JG, LEnd) |
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) |
ELSE |
jmp(JL, LEnd) |
OutByte(0D1H) |
END; |
shift(cmd.opcode, reg1); // shift reg1, n |
IF n # 1 THEN |
OutByte(n) |
END |
END For; |
PROCEDURE NextFor*(step, LBeg, LEnd: INTEGER); |
BEGIN |
OutCode("8B542404"); |
IF step = 1 THEN |
OutCode("FF02") |
ELSIF step = -1 THEN |
OutCode("FF0A") |
|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 |
ELSE |
IntByte("8302", "8102", step) |
OutByte(0B3H) // btr dword[reg2], reg1 |
END; |
jmp(JMP, LBeg); |
Label(LEnd); |
OutCode("83C408") |
END NextFor; |
OutByte(reg2 + 8 * reg1); |
//L: |
drop; |
drop |
PROCEDURE CaseLabel*(a, b, LBeg: INTEGER); |
VAR L: INTEGER; |
BEGIN |
L := NewLabel(); |
IntByte("83FA", "81FA", a); |
IF a = b THEN |
jmp(JNE, L) |
|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) |
ELSE |
jmp(JL, L); |
IntByte("83FA", "81FA", b); |
jmp(JG, L) |
n := -1 |
END; |
jmp(JMP, LBeg); |
Label(L) |
END CaseLabel; |
PROCEDURE Drop*; |
BEGIN |
PopEDX |
END Drop; |
IF a = 1 THEN |
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) |
ELSIF a = -1 THEN |
UnOp(reg1); |
neg(reg1) |
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 |
ELSE |
OutByte2(0D1H, 0F8H + reg1) // sar reg1, 1 |
END; |
CASE LR OF |
|-1: CallRTL(_lstrcmp) |
| 0: CallRTL(_strcmp) |
| 1: CallRTL(_rstrcmp) |
OutByte2(29H, 0C0H + reg2 * 8 + reg1); // sub reg1, reg2 |
drop |
ELSE |
END; |
PushEAX |
END strcmp; |
IF n # 1 THEN |
OutByte3(0C1H, 0F8H + reg1, n) // sar reg1, n |
ELSE |
OutByte2(0D1H, 0F8H + reg1) // sar reg1, 1 |
END |
END |
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 |
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) |
PushAll(1); |
pushc(param2); |
CallRTL(pic, CODE._div); |
GetRegA |
END |
END Optimization; |
END |
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) |
|CODE.opDIVL: |
PushAll(1); |
pushc(param2); |
CallRTL(pic, CODE._div2); |
GetRegA |
|CODE.opMOD: |
PushAll(2); |
CallRTL(pic, CODE._mod); |
GetRegA |
|CODE.opMODR: |
a := param2; |
IF a > 1 THEN |
n := log2(a) |
ELSIF a < -1 THEN |
n := log2(-a) |
ELSE |
n := -1 |
END; |
OutFilePos := UTILS.GetMem(Align(size, 4) + datasize + 1000H); |
filebuf := OutFilePos; |
UTILS.MemErr(OutFilePos = 0); |
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; |
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); |
Write(sys.ADR(Header), sys.SIZE(KOSHEADER)); |
cur := asmlist.First(ASMLINE); |
WHILE cur # NIL DO |
Write(sys.ADR(Code[cur.cmd]), cur.clen); |
cur := cur.Next(ASMLINE) |
IF a < 0 THEN |
test(reg1); |
OutByte(74H); // je @f |
IF isByte(a) THEN |
OutByte(3) |
ELSE |
OutByte(6) |
END; |
Fill(Align(size, 4) - size, 0X); |
Write(sys.ADR(Data), datasize); |
WriteF(F, filebuf, OutFilePos - filebuf) |
addrc(reg1, a) |
// @@: |
END |
ELSE |
PushAll(1); |
pushc(param2); |
CallRTL(pic, CODE._mod); |
GetRegA |
END |
END |
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.opMODL: |
PushAll(1); |
pushc(param2); |
CallRTL(pic, CODE._mod2); |
GetRegA |
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.opERR: |
CallRTL(pic, CODE._error) |
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.opABS: |
UnOp(reg1); |
test(reg1); |
OutByte2(07DH, 002H); // jge @f |
neg(reg1); // neg reg1 |
// @@: |
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.opCOPY: |
PushAll(2); |
pushc(param2); |
CallRTL(pic, CODE._move2) |
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 |
|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 |
ELSE |
a := a - size - datasize; |
sec := 3 |
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 |
END; |
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); |
drop; |
reg1 := REG.GetAnyReg(R); |
CASE cmd.opcode OF |
|CODE.opEQP, CODE.opEQIP: setcc(sete, reg1) |
|CODE.opNEP, CODE.opNEIP: setcc(setne, reg1) |
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; |
WriteF(F, sys.ADR(Coff), sys.SIZE(COFFHEADER)); |
WriteF(F, filebuf, OutFilePos - filebuf); |
WriteF(F, sys.ADR(Reloc), rcount); |
andrc(reg1, 1) |
adr := sys.ADR(sym); |
InitArray(adr, "4558504F52545300000000000100000002002E666C617400000000000000010000000300"); |
InitArray(adr, "2E64617461000000000000000200000003002E6273730000000000000000030000000300"); |
sys.PUT(sys.ADR(sym) + 8, Labels[Exports] - sys.SIZE(KOSHEADER)); |
|CODE.opPUSHT: |
UnOp(reg1); |
reg2 := REG.GetAnyReg(R); |
OutByte3(8BH, 40H + reg2 * 8 + reg1, 0FCH) // mov reg2, dword[reg1 - 4] |
WriteF(F, sys.ADR(sym), LEN(sym)); |
i := 4; |
WriteF(F, sys.ADR(i), 4) |
END; |
UTILS.CloseF(F) |
END WriteKOS; |
|CODE.opISREC: |
PushAll(2); |
pushc(param2); |
CallRTL(pic, CODE._isrec); |
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.opIS: |
PushAll(1); |
pushc(param2); |
CallRTL(pic, CODE._is); |
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.opTYPEGR: |
PushAll(1); |
pushc(param2); |
CallRTL(pic, CODE._guardrec); |
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.opTYPEGP: |
UnOp(reg1); |
PushAll(0); |
push(reg1); |
pushc(param2); |
CallRTL(pic, CODE._guard); |
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.opTYPEGD: |
UnOp(reg1); |
PushAll(0); |
OutByte3(0FFH, 070H + reg1, 0FCH); // push dword[reg1 - 4] |
pushc(param2); |
CallRTL(pic, CODE._guardrec); |
GetRegA |
BEGIN |
sys.MOVE(ELF.get(), sys.ADR(bytes[0]), ELF.size); |
|CODE.opCASET: |
push(ecx); |
push(ecx); |
pushc(param2); |
CallRTL(pic, CODE._guardrec); |
pop(ecx); |
test(eax); |
jcc(jne, param1) |
DEC(code, 13); |
|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 |
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.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(glob, 1000H) - 3200000H; |
Add(00A8H); Add(17EDH); Add(1C09H); Add(1D25H); |
|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(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.opPUSHF: |
subrc(esp, 8); |
OutByte3(0DDH, 01CH, 024H) // fstp qword[esp] |
OutFilePos := UTILS.GetMem(code + data + 8000H); |
filebuf := OutFilePos; |
UTILS.MemErr(OutFilePos = 0); |
|CODE.opLOADF: |
UnOp(reg1); |
OutByte2(0DDH, reg1); // fld qword[reg1] |
drop |
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.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 |
F := UTILS.CreateF(FName); |
IF F <= 0 THEN |
Err(1) |
END; |
WriteF(F, filebuf, OutFilePos - filebuf); |
UTILS.CloseF(F) |
END WriteELF; |
|CODE.opSAVEF: |
UnOp(reg1); |
OutByte2(0DDH, 018H + reg1); // fstp qword[reg1] |
drop |
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.opADDF, CODE.opADDFI: |
OutByte2(0DEH, 0C1H) // faddp 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.opSUBF: |
OutByte2(0DEH, 0E9H) // fsubp 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.opSUBFI: |
OutByte2(0DEH, 0E1H) // fsubrp 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.opMULF: |
OutByte2(0DEH, 0C9H) // fmulp st1, st |
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 |
|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) |
END |
END; |
size := size + cur.clen; |
cur := cur.Next(ASMLINE) |
END; |
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.opVADR_PARAM: |
n := param2 * 4; |
OutByte2(0FFH, 75H + long(n)); // push dword[ebp + n] |
OutIntByte(n) |
FOR i := 0 TO Lcount DO |
IF Labels[i] < 0 THEN |
Labels[i] := -Labels[i] + asize + Align(rdatasize, 1000H) |
|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) |
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; |
temp := dcount; |
IF elf THEN |
asize := asize + Align(dcount, 1000H) + 64 + 1024; |
sys.PUT(sys.ADR(Code[glob + 1]), asize - 1024); |
dcount := 0 |
cmd := cmd.next(COMMAND) |
END; |
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 |
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) |
END; |
etable.arradroffset := etable.arradroffset + asize; |
etable.arrnameptroffset := etable.arrnameptroffset + asize; |
etable.arrnumoffset := etable.arrnumoffset + asize; |
etable.dllnameoffset := etable.dllnameoffset + asize; |
asize := asize + LoadAdr - 0DAH |
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) |
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); |
FOR i := 0 TO LEN(RtlProc) - 1 DO |
RtlProc[i] := Labels[RtlProc[i]] |
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) |
END; |
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) |
IF pic THEN |
reg1 := REG.GetAnyReg(R); |
Pic(reg1, BIN.PICDATA, 0); |
push(reg1); // push _data |
drop |
ELSE |
OutByte(68H); // push _data |
Reloc(BIN.RDATA, 0) |
END; |
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) |
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 |
ELSE |
IF R.Size # 0 THEN |
PutReloc(R) |
OutByte(68H); // push _data |
Reloc(BIN.RDATA, tcount * 4 + dcount) |
END; |
R.Page := ASR(n, 12) * 1000H; |
R.Size := 10; |
R.reloc[0] := IntToCard16(n MOD 1000H + 3000H); |
RCount := 1 |
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) |
END; |
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) |
lib := lib.next(CODE.IMPORT_LIB) |
END |
END FixLabels; |
PROCEDURE OutStringZ(str: ARRAY OF CHAR); |
VAR i: INTEGER; |
END import; |
BEGIN |
New; |
current.clen := LENGTH(str); |
FOR i := 0 TO current.clen - 1 DO |
Code[ccount] := str[i]; |
INC(ccount) |
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 |
END; |
Code[ccount] := 0X; |
INC(ccount); |
INC(current.clen) |
END OutStringZ; |
PROCEDURE Epilog*(gsize: INTEGER; FName: ARRAY OF CHAR; stk: INTEGER); |
VAR i, glob: INTEGER; |
BEGIN |
glob := 0; |
IF gsize < maxstrlen THEN |
gsize := maxstrlen |
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)) |
END; |
gsize := Align(gsize, 4) + 4; |
COPY(FName, OutFile); |
Labels[RTABLE] := -dcount; |
dataint(recarray[0]); |
FOR i := 1 TO reccount DO |
dataint(recarray[i]) |
FOR i := 0 TO dcount - 1 DO |
BIN.PutData(program, CHL.GetByte(code.data, i)) |
END; |
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) |
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); |
END; |
GlobalAdr(0); |
PushConst(ASR(gsize, 2)); |
PushInt(RTABLE); |
PushInt(SELFNAME); |
CallRTL(_init); |
current := asmlist.Last(ASMLINE); |
IF dll THEN |
OutCode("B801000000C9C20C00") |
exp := code.export.first(CODE.EXPORT_PROC); |
WHILE exp # NIL DO |
BIN.Export(program, exp.name, exp.label); |
exp := exp.next(CODE.EXPORT_PROC) |
END; |
IF obj THEN |
OutCode("B801000000C9C20000") |
import(code.import); |
n := code.dmin - CHL.Length(code.data); |
IF n > 0 THEN |
INC(code.bss, n) |
END; |
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) |
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 |
END; |
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 |
IF target IN {mConst.Target_iConsole, mConst.Target_iGUI, mConst.Target_iDLL, mConst.Target_iELF32} THEN |
pic := TRUE |
END; |
FixLabels(FName, stk, gsize, glob) |
END Epilog; |
PROCEDURE setkem*; |
R := REG.Create(push, pop, mov, xchg, NIL, NIL, {eax, ecx, edx}, {}); |
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 |
kem := TRUE |
END setkem; |
program := prog; |
CodeList := LISTS.create(NIL) |
END SetProgram; |
BEGIN |
kem := FALSE |
END X86. |