BlueGreycalmElegant

Català-Valencià – Catalan中文 – Chinese (Simplified)中文 – Chinese (Traditional)Česky – CzechDansk – DanishNederlands – DutchEnglish – EnglishSuomi – FinnishFrançais – FrenchDeutsch – Germanעברית – Hebrewहिंदी – HindiMagyar – HungarianBahasa Indonesia – IndonesianItaliano – Italian日本語 – Japanese한국어 – KoreanМакедонски – Macedonianमराठी – MarathiNorsk – NorwegianPolski – PolishPortuguês – PortuguesePortuguês – Portuguese (Brazil)Русский – RussianSlovenčina – SlovakSlovenščina – SlovenianEspañol – SpanishSvenska – SwedishTürkçe – TurkishУкраїнська – UkrainianOëzbekcha – Uzbek

Compare Revisions

• This comparison shows the changes necessary to convert path

  → / @ 6612

  → / @ 6613

  ↔ Reverse comparison

• Compare Path:	Rev

  With Path:	Rev

No changes between revisions

Regard whitespace Rev 6612 → Rev 6613

/data/Tupfile.lua
162,6 → 162,10
{"kolibrios/3D/TEST_GLU2", PROGS .. "/develop/libraries/TinyGL/asm_fork/examples/test_glu2"},
{"kolibrios/3D/TEXT_2.PNG", PROGS .. "/develop/libraries/TinyGL/asm_fork/examples/text_2.png"},
{"kolibrios/3D/TEXTURES1", PROGS .. "/develop/libraries/TinyGL/asm_fork/examples/textures1"},
{"kolibrios/develop/oberon07/", PROGS .. "/develop/oberon07/*"},
{"kolibrios/develop/oberon07/Docs/", PROGS .. "/develop/oberon07/Docs/*"},
{"kolibrios/develop/oberon07/Lib/KolibriOS/", PROGS .. "/develop/oberon07/Lib/KolibriOS/*"},
{"kolibrios/develop/oberon07/Samples/", PROGS .. "/develop/oberon07/Samples/*"},
{"kolibrios/emul/dosbox/", "common/emul/DosBox/*"},
{"kolibrios/emul/e80/readme.txt", PROGS .. "/emulator/e80/trunk/readme.txt"},
{"kolibrios/emul/fceu/fceu", PROGS .. "/emulator/fceu/fceu"},

/programs/cmm/clipview/clipview
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/cmm/lib/clipboard.h
46,7 → 46,7
slot_data.type = DSDWORD[result+4];
slot_data.encoding = DSDWORD[result+8];
if (slot_data.type == SLOT_DATA_TYPE_TEXT) slot_data.content = result+12;
else slot_data.content = result+10;
else slot_data.content = result+8;
return result;
}

/programs/develop/oberon07/Compiler.kex
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/Docs/About1251.txt
0,0 → 1,856
Êîìïèëÿòîð ÿçûêà ïðîãðàììèðîâàíèÿ Oberon-07/11 äëÿ i386
Windows/Linux/KolibriOS.
------------------------------------------------------------------------------
Ñîñòàâ ïðîãðàììû
1. Compiler.kex (KolibriOS) - èñïîëíÿåìûé ôàéë êîìïèëÿòîðà.
Âõîä - òåêñòîâûå ôàéëû ìîäóëåé ñ ðàñøèðåíèåì ".ob07", êîäèðîâêà ANSI
èëè UTF-8 ñ BOM-ñèãíàòóðîé.
Âûõîä - èñïîëíÿåìûé ôàéë ôîðìàòà PE, ELF èëè MENUET01/MS COFF.
Ïàðàìåòðû:
1) èìÿ ãëàâíîãî ìîäóëÿ
2) òèï ïðèëîæåíèÿ è ïëàòôîðìà
"con" - Windows console
"gui" - Windows GUI
"dll" - Windows DLL
"elf" - Linux
"kos" - KolibriOS
"obj" - KolibriOS DLL
3) ðàçìåð ñòýêà â ìåãàáàéòàõ, íåîáÿçàòåëüíûé ïàðàìåòð, ïî óìîë÷àíèþ -
1 Ìá, äëÿ ELF èãíîðèðóåòñÿ. Åñëè 2-é ïàðàìåòð = "obj" (KolibriOS DLL),
òî 3-é ïàðàìåòð çàäàåòñÿ øåñòíàäöàòèðè÷íûì ÷èñëîì
(0x00000001 .. 0xffffffff) è îïðåäåëÿåò âåðñèþ ïðîãðàììû,
ïî óìîë÷àíèþ - 0x00010000 (v1.0).
Íàïðèìåð:
"C:\oberon-07\example.ob07" con 1
"C:\oberon-07\example.ob07" obj 0x00020005 (* v2.5 *)
 ñëó÷àå óñïåøíîé êîìïèëÿöèè, êîìïèëÿòîð ïåðåäàåò êîä çàâåðøåíèÿ 0,
èíà÷å 1. Ïðè ðàáîòå êîìïèëÿòîðà â KolibriOS, êîä çàâåðøåíèÿ íå
ïåðåäàåòñÿ. Ñîîáùåíèÿ êîìïèëÿòîðà âûâîäÿòñÿ íà êîíñîëü (Windows,
KolibriOS), â òåðìèíàë (Linux).
2. Ïàïêà Lib - áèáëèîòåêà ìîäóëåé
3. Ïàïêà Source - èñõîäíûé êîä êîìïèëÿòîðà
------------------------------------------------------------------------------
Îòëè÷èÿ îò îðèãèíàëà
1. Ðàñøèðåí ïñåâäîìîäóëü SYSTEM
2. Ðàçðåøåí ñèìâîë "_" â èäåíòèôèêàòîðàõ
3. Äîáàâëåíû ñèñòåìíûå ôëàãè
4. Îïåðàòîð CASE ðåàëèçîâàí â ñîîòâåòñòâèè ñ ñèíòàêñèñîì è ñåìàíòèêîé
äàííîãî îïåðàòîðà â ÿçûêå Oberon (Revision 1.10.90)
5. Ðàñøèðåí íàáîð ñòàíäàðòíûõ ïðîöåäóð
6. Ñåìàíòèêà îõðàíû/ïðîâåðêè òèïà óòî÷íåíà äëÿ íóëåâîãî óêàçàòåëÿ
7. Ñåìàíòèêà DIV è MOD óòî÷íåíà äëÿ îòðèöàòåëüíûõ ÷èñåë
8. Äîáàâëåíû îäíîñòðî÷íûå êîììåíòàðèè (íà÷èíàþòñÿ ñ ïàðû ñèìâîëîâ "//")
9. Ðàçðåøåí ýêñïîðò ïåðåìåííûõ òèïîâ ARRAY è RECORD (òîëüêî äëÿ ÷òåíèÿ)
------------------------------------------------------------------------------
Îñîáåííîñòè ðåàëèçàöèè
1. Îñíîâíûå òèïû
Òèï Äèàïàçîí çíà÷åíèé Ðàçìåð, áàéò
INTEGER -2147483648 .. 2147483647 4
REAL 1.40E-45 .. 3.34E+38 4
LONGREAL 4.94E-324 .. 1.70E+308 8
CHAR ñèìâîë ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET ìíîæåñòâî èç öåëûõ ÷èñåë {0 .. 31} 4
2. Ìàêñèìàëüíàÿ äëèíà èäåíòèôèêàòîðîâ - 255 ñèìâîëîâ
3. Ìàêñèìàëüíàÿ äëèíà ñòðîêîâûõ êîíñòàíò - 255 ñèìâîëîâ
4. Ìàêñèìàëüíàÿ äëèíà ñòðîê èñõîäíîãî êîäà - 511 ñèìâîëîâ
5. Ìàêñèìàëüíàÿ ðàçìåðíîñòü îòêðûòûõ ìàññèâîâ - 5
6. Ìàêñèìàëüíîå êîëè÷åñòâî îáúÿâëåííûõ òèïîâ-çàïèñåé - 2047
7. Ïðîöåäóðà NEW çàïîëíÿåò íóëÿìè âûäåëåííûé áëîê ïàìÿòè
8. Ãëîáàëüíûå è ëîêàëüíûå ïåðåìåííûå èíèöèàëèçèðóþòñÿ íóëÿìè
9.  îòëè÷èå îò ìíîãèõ Oberon-ðåàëèçàöèé, ñáîðùèê ìóñîðà è äèíàìè÷åñêàÿ
ìîäóëüíîñòü îòñóòñòâóþò
------------------------------------------------------------------------------
Ïñåâäîìîäóëü SYSTEM
Ïñåâäîìîäóëü SYSTEM ñîäåðæèò íèçêîóðîâíåâûå è íåáåçîïàñíûå ïðîöåäóðû,
îøèáêè ïðè èñïîëüçîâàíèè ïðîöåäóð ïñåâäîìîäóëÿ SYSTEM ìîãóò ïðèâåñòè ê
ïîâðåæäåíèþ äàííûõ âðåìåíè âûïîëíåíèÿ è àâàðèéíîìó çàâåðøåíèþ ïðîãðàììû.
PROCEDURE ADR(v: ëþáîé òèï): INTEGER
v - ïåðåìåííàÿ, ïðîöåäóðà èëè ñòðîêîâàÿ êîíñòàíòà;
âîçâðàùàåò àäðåñ v
PROCEDURE SIZE(T): INTEGER
âîçâðàùàåò ðàçìåð òèïà T
PROCEDURE TYPEID(T): INTEGER
T - òèï-çàïèñü èëè òèï-óêàçàòåëü,
âîçâðàùàåò íîìåð òèïà â òàáëèöå òèïîâ-çàïèñåé
PROCEDURE INF(T): T
T - REAL èëè LONGREAL,
âîçâðàùàåò ñïåöèàëüíîå âåùåñòâåííîå çíà÷åíèå "áåñêîíå÷íîñòü"
PROCEDURE GET(a: INTEGER;
VAR v: ëþáîé îñíîâíîé òèï, PROCEDURE, POINTER)
v := Ïàìÿòü[a]
PROCEDURE PUT(a: INTEGER; x: ëþáîé îñíîâíîé òèï, PROCEDURE, POINTER)
Ïàìÿòü[a] := x
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Êîïèðóåò n áàéò ïàìÿòè èç Source â Dest,
îáëàñòè Source è Dest íå äîëæíû ïåðåêðûâàòüñÿ
PROCEDURE CODE(s: ARRAY OF CHAR)
Âñòàâêà ìàøèííîãî êîäà
s - ñòðîêîâàÿ êîíñòàíòà øåñòíàäöàòèðè÷íûõ öèôð
êîëè÷åñòâî öèôð äîëæíî áûòü ÷åòíûì
íàïðèìåð: SYSTEM.CODE("B801000000") (* mov eax, 1 *)
Òàêæå â ìîäóëå SYSTEM îïðåäåëåí òèï CARD16 (2 áàéòà). Äëÿ òèïà CARD16 íå
äîïóñêàþòñÿ íèêàêèå ÿâíûå îïåðàöèè, çà èñêëþ÷åíèåì ïðèñâàèâàíèÿ.
Ïðåîáðàçîâàíèÿ CARD16 -> INTEGER è INTEGER -> CARD16 ìîãóò áûòü ðåàëèçîâàíû
òàê:
PROCEDURE Card16ToInt(w: SYSTEM.CARD16): INTEGER;
VAR i: INTEGER;
BEGIN
SYSTEM.PUT(SYSTEM.ADR(i), w)
RETURN i
END Card16ToInt;
PROCEDURE IntToCard16(i: INTEGER): SYSTEM.CARD16;
VAR w: SYSTEM.CARD16;
BEGIN
SYSTEM.GET(SYSTEM.ADR(i), w)
RETURN w
END IntToCard16;
Ôóíêöèè ïñåâäîìîäóëÿ SYSTEM íåëüçÿ èñïîëüçîâàòü â êîíñòàíòíûõ âûðàæåíèÿõ.
------------------------------------------------------------------------------
Ñèñòåìíûå ôëàãè
Ïðè îáúÿâëåíèè ïðîöåäóðíûõ òèïîâ è ãëîáàëüíûõ ïðîöåäóð, ïîñëå êëþ÷åâîãî
ñëîâà PROCEDURE ìîæåò áûòü óêàçàí ôëàã ñîãëàøåíèÿ âûçîâà: [stdcall], [cdecl]
èëè [winapi]. Íàïðèìåð:
PROCEDURE [cdecl] MyProc(x, y, z: INTEGER): INTEGER;
Åñëè óêàçàí ôëàã [winapi], òî ïðèíèìàåòñÿ ñîãëàøåíèå stdcall è
ïðîöåäóðó-ôóíêöèþ ìîæíî âûçâàòü êàê ñîáñòâåííî ïðîöåäóðó, âíå âûðàæåíèÿ.
Ôëàã [winapi] äîñòóïåí òîëüêî äëÿ ïëàòôîðìû Windows.
Ïðè îáúÿâëåíèè òèïîâ-çàïèñåé, ïîñëå êëþ÷åâîãî ñëîâà RECORD ìîæåò áûòü
óêàçàí ôëàã [noalign] èëè [union]. Ôëàã [noalign] îçíà÷àåò îòñóòñòâèå
âûðàâíèâàíèÿ ïîëåé çàïèñè, à ôëàã [union] îçíà÷àåò, ÷òî ñìåùåíèÿ âñåõ ïîëåé
çàïèñè ðàâíû íóëþ, ïðè ýòîì ðàçìåð çàïèñè ðàâåí ðàçìåðó íàèáîëüøåãî ïîëÿ.
Çàïèñè RECORD [union] ... END ñîîòâåòñòâóþò îáúåäèíåíèÿì (union) â ÿçûêå C.
Çàïèñè ñ ñèñòåìíûìè ôëàãàìè íå ìîãóò èìåòü áàçîâîãî òèïà è íå ìîãóò áûòü
áàçîâûìè òèïàìè äëÿ äðóãèõ çàïèñåé.
Äëÿ èñïîëüçîâàíèÿ ñèñòåìíûõ ôëàãîâ, òðåáóåòñÿ èìïîðòèðîâàòü SYSTEM.
------------------------------------------------------------------------------
Îïåðàòîð CASE
Ñèíòàêñèñ îïåðàòîðà CASE:
CaseStatement =
CASE Expression OF Ñase {"|" Ñase}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
Íàïðèìåð:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
 ìåòêàõ âàðèàíòîâ ìîæíî èñïîëüçîâàòü êîíñòàíòíûå âûðàæåíèÿ, âåòêà ELSE
íåîáÿçàòåëüíà. Åñëè íå âûïîëíåí íè îäèí âàðèàíò è ELSE îòñóòñòâóåò, òî
ïðîãðàììà ïðåðûâàåòñÿ ñ îøèáêîé âðåìåíè âûïîëíåíèÿ.
------------------------------------------------------------------------------
Ïðîâåðêà è îõðàíà òèïà íóëåâîãî óêàçàòåëÿ
Îðèãèíàëüíîå ñîîáùåíèå î ÿçûêå íå îïðåäåëÿåò ïîâåäåíèå ïðîãðàììû ïðè
âûïîëíåíèè îõðàíû p(T) è ïðîâåðêè òèïà p IS T ïðè p = NIL. Âî ìíîãèõ
Oberon-ðåàëèçàöèÿõ âûïîëíåíèå òàêîé îïåðàöèè ïðèâîäèò ê îøèáêå âðåìåíè
âûïîëíåíèÿ. Â äàííîé ðåàëèçàöèè îõðàíà òèïà íóëåâîãî óêàçàòåëÿ íå ïðèâîäèò ê
îøèáêå, à ïðîâåðêà òèïà äàåò ðåçóëüòàò FALSE.  ðÿäå ñëó÷àåâ ýòî ïîçâîëÿåò
çíà÷èòåëüíî ñîêðàòèòü ÷àñòîòó ïðèìåíåíèÿ îõðàíû òèïà.
------------------------------------------------------------------------------
Äîïîëíèòåëüíûå ñòàíäàðòíûå ïðîöåäóðû
DISPOSE(VAR v: ëþáîé_óêàçàòåëü)
Îñâîáîæäàåò ïàìÿòü, âûäåëåííóþ ïðîöåäóðîé NEW äëÿ
äèíàìè÷åñêîé ïåðåìåííîé v^, è ïðèñâàèâàåò ïåðåìåííîé v
çíà÷åíèå NIL.
LSR(x, n: INTEGER): INTEGER
Ëîãè÷åñêèé ñäâèã x íà n áèò âïðàâî.
BITS(x: INTEGER): SET
Èíòåðïðåòèðóåò x êàê çíà÷åíèå òèïà SET.
Âûïîëíÿåòñÿ íà ýòàïå êîìïèëÿöèè.
LENGTH(s: ARRAY OF CHAR): INTEGER
Äëèíà 0X-çàâåðøåííîé ñòðîêè s, áåç ó÷åòà ñèìâîëà 0X.
Åñëè ñèìâîë 0X îòñóòñòâóåò, ôóíêöèÿ âîçâðàùàåò äëèíó
ìàññèâà s.
------------------------------------------------------------------------------
DIV è MOD
x y x DIV y x MOD y
5 3 1 2
-5 3 -2 1
5 -3 -2 -1
-5 -3 1 -2
------------------------------------------------------------------------------
Ñêðûòûå ïàðàìåòðû ïðîöåäóð
Íåêîòîðûå ïðîöåäóðû ìîãóò èìåòü ñêðûòûå ïàðàìåòðû, îíè îòñóòñòâóþò â ñïèñêå
ôîðìàëüíûõ ïàðàìåòðîâ, íî ó÷èòûâàþòñÿ êîìïèëÿòîðîì ïðè òðàíñëÿöèè âûçîâîâ.
Ýòî âîçìîæíî â ñëåäóþùèõ ñëó÷àÿõ:
1. Ïðîöåäóðà èìååò ôîðìàëüíûé ïàðàìåòð îòêðûòûé ìàññèâ:
PROCEDURE Proc(x: ARRAY OF ARRAY OF LONGREAL);
Âûçîâ òðàíñëèðóåòñÿ òàê:
Proc(SYSTEM.ADR(x), LEN(x), LEN(x[0])
2. Ïðîöåäóðà èìååò ôîðìàëüíûé ïàðàìåòð-ïåðåìåííóþ òèïà RECORD:
PROCEDURE Proc(VAR x: Rec);
Âûçîâ òðàíñëèðóåòñÿ òàê:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
3. Ïðîöåäóðà ÿâëÿåòñÿ âëîæåííîé, ãëóáèíà âëîæåíèÿ k,
äëÿ ãëîáàëüíûõ ïðîöåäóð k = 0:
PROCEDURE Proc(p1, ..., pn);
Âûçîâ òðàíñëèðóåòñÿ òàê:
Proc(base(k - 1), base(k - 2), ..., base(0), p1, ..., pn),
ãäå base(m) - àäðåñ áàçû êàäðà ñòýêà îõâàòûâàþùåé ïðîöåäóðû ãëóáèíû
âëîæåíèÿ m (èñïîëüçóåòñÿ äëÿ äîñòóïà ê ëîêàëüíûì ïåðåìåííûì
îõâàòûâàþùåé ïðîöåäóðû)
------------------------------------------------------------------------------
Ìîäóëü RTL
Âñå ïðîãðàììû íåÿâíî èñïîëüçóþò ìîäóëü RTL. Êîìïèëÿòîð òðàíñëèðóåò
íåêîòîðûå îïåðàöèè (ïðîâåðêà è îõðàíà òèïà, ñðàâíåíèå ñòðîê, ñîîáùåíèÿ îá
îøèáêàõ âðåìåíè âûïîëíåíèÿ è äð.) êàê âûçîâû ïðîöåäóð ýòîãî ìîäóëÿ. Íå
ñëåäóåò ÿâíî âûçûâàòü ýòè ïðîöåäóðû, çà èñêëþ÷åíèåì ïðîöåäóðû SetClose:
PROCEDURE SetClose(proc: PROC), ãäå TYPE PROC = PROCEDURE
SetClose íàçíà÷àåò ïðîöåäóðó proc (áåç ïàðàìåòðîâ) âûçûâàåìîé ïðè âûãðóçêå
dll-áèáëèîòåêè (Windows), åñëè ïðèëîæåíèå êîìïèëèðóåòñÿ êàê Windows DLL. Äëÿ
ïðî÷èõ òèïîâ ïðèëîæåíèé è ïëàòôîðì âûçîâ ïðîöåäóðû SetClose íå âëèÿåò íà
ïîâåäåíèå ïðîãðàììû.
Ñîîáùåíèÿ îá îøèáêàõ âðåìåíè âûïîëíåíèÿ âûâîäÿòñÿ â äèàëîãîâûõ îêíàõ
(Windows), â òåðìèíàë (Linux), íà äîñêó îòëàäêè (KolibriOS).
------------------------------------------------------------------------------
Ìîäóëü API
Ñóùåñòâóþò òðè ðåàëèçàöèè ìîäóëÿ API: äëÿ Windows, Linux è KolibriOS. Êàê è
ìîäóëü RTL, ìîäóëü API íå ïðåäíàçíà÷åí äëÿ ïðÿìîãî èñïîëüçîâàíèÿ. Îí
îáåñïå÷èâàåò êðîññïëàòôîðìåííîñòü êîìïèëÿòîðà.
------------------------------------------------------------------------------
Ãåíåðàöèÿ èñïîëíÿåìûõ ôàéëîâ DLL
Ðàçðåøàåòñÿ ýêñïîðòèðîâàòü òîëüêî ïðîöåäóðû. Äëÿ ýòîãî, ïðîöåäóðà äîëæíà
íàõîäèòüñÿ â ãëàâíîì ìîäóëå ïðîãðàììû, è åå èìÿ äîëæíî áûòü îòìå÷åíî ñèìâîëîì
ýêñïîðòà ("*"). KolibriOS DLL âñåãäà ýêñïîðòèðóþò èäåíòèôèêàòîðû "version"
(âåðñèÿ ïðîãðàììû) è "lib_init" - àäðåñ ïðîöåäóðû èíèöèàëèçàöèè DLL:
PROCEDURE [stdcall] lib_init(): INTEGER
Ýòà ïðîöåäóðà äîëæíà áûòü âûçâàíà ïåðåä èñïîëüçîâàíèåì DLL.
Ïðîöåäóðà âñåãäà âîçâðàùàåò 1.
 íàñòîÿùåå âðåìÿ ãåíåðàöèÿ DLL äëÿ Linux íå ðåàëèçîâàíà.
==============================================================================
==============================================================================
Áèáëèîòåêà (KolibriOS)
------------------------------------------------------------------------------
MODULE Out - êîíñîëüíûé âûâîä
PROCEDURE Open
ôîðìàëüíî îòêðûâàåò êîíñîëüíûé âûâîä
PROCEDURE Int(x, width: INTEGER)
âûâîä öåëîãî ÷èñëà x;
width - êîëè÷åñòâî çíàêîìåñò, èñïîëüçóåìûõ äëÿ âûâîäà
PROCEDURE Real(x: LONGREAL; width: INTEGER)
âûâîä âåùåñòâåííîãî ÷èñëà x â ïëàâàþùåì ôîðìàòå;
width - êîëè÷åñòâî çíàêîìåñò, èñïîëüçóåìûõ äëÿ âûâîäà
PROCEDURE Char(x: CHAR)
âûâîä ñèìâîëà x
PROCEDURE FixReal(x: LONGREAL; width, p: INTEGER)
âûâîä âåùåñòâåííîãî ÷èñëà x â ôèêñèðîâàííîì ôîðìàòå;
width - êîëè÷åñòâî çíàêîìåñò, èñïîëüçóåìûõ äëÿ âûâîäà;
p - êîëè÷åñòâî çíàêîâ ïîñëå äåñÿòè÷íîé òî÷êè
PROCEDURE Ln
ïåðåõîä íà ñëåäóþùóþ ñòðîêó
PROCEDURE String(s: ARRAY OF CHAR)
âûâîä ñòðîêè s
------------------------------------------------------------------------------
MODULE In - êîíñîëüíûé ââîä
VAR Done: BOOLEAN
ïðèíèìàåò çíà÷åíèå TRUE â ñëó÷àå óñïåøíîãî âûïîëíåíèÿ
îïåðàöèè ââîäà, èíà÷å FALSE
PROCEDURE Open
ôîðìàëüíî îòêðûâàåò êîíñîëüíûé ââîä,
òàêæå ïðèñâàèâàåò ïåðåìåííîé Done çíà÷åíèå TRUE
PROCEDURE Int(VAR x: INTEGER)
ââîä ÷èñëà òèïà INTEGER
PROCEDURE Char(VAR x: CHAR)
ââîä ñèìâîëà
PROCEDURE Real(VAR x: REAL)
ââîä ÷èñëà òèïà REAL
PROCEDURE LongReal(VAR x: LONGREAL)
ââîä ÷èñëà òèïà LONGREAL
PROCEDURE String(VAR s: ARRAY OF CHAR)
ââîä ñòðîêè
PROCEDURE Ln
îæèäàíèå íàæàòèÿ ENTER
------------------------------------------------------------------------------
MODULE Console - äîïîëíèòåëüíûå ïðîöåäóðû êîíñîëüíîãî âûâîäà
CONST
Ñëåäóþùèå êîíñòàíòû îïðåäåëÿþò öâåò êîíñîëüíîãî âûâîäà
Black = 0 Blue = 1 Green = 2
Cyan = 3 Red = 4 Magenta = 5
Brown = 6 LightGray = 7 DarkGray = 8
LightBlue = 9 LightGreen = 10 LightCyan = 11
LightRed = 12 LightMagenta = 13 Yellow = 14
White = 15
PROCEDURE Cls
î÷èñòêà îêíà êîíñîëè
PROCEDURE SetColor(FColor, BColor: INTEGER)
óñòàíîâêà öâåòà êîíñîëüíîãî âûâîäà: FColor - öâåò òåêñòà,
BColor - öâåò ôîíà, âîçìîæíûå çíà÷åíèÿ - âûøåïåðå÷èñëåííûå
êîíñòàíòû
PROCEDURE SetCursor(x, y: INTEGER)
óñòàíîâêà êóðñîðà êîíñîëè â ïîçèöèþ (x, y)
PROCEDURE GetCursor(VAR x, y: INTEGER)
çàïèñûâàåò â ïàðàìåòðû òåêóùèå êîîðäèíàòû êóðñîðà êîíñîëè
PROCEDURE GetCursorX(): INTEGER
âîçâðàùàåò òåêóùóþ x-êîîðäèíàòó êóðñîðà êîíñîëè
PROCEDURE GetCursorY(): INTEGER
âîçâðàùàåò òåêóùóþ y-êîîðäèíàòó êóðñîðà êîíñîëè
------------------------------------------------------------------------------
MODULE ConsoleLib - îáåðòêà áèáëèîòåêè console.obj
------------------------------------------------------------------------------
MODULE Math - ìàòåìàòè÷åñêèå ôóíêöèè
CONST
pi = 3.141592653589793D+00
e = 2.718281828459045D+00
VAR
Inf, nInf: LONGREAL
ïîëîæèòåëüíàÿ è îòðèöàòåëüíàÿ áåñêîíå÷íîñòü
PROCEDURE IsNan(x: LONGREAL): BOOLEAN
âîçâðàùàåò TRUE, åñëè x - íå ÷èñëî
PROCEDURE IsInf(x: LONGREAL): BOOLEAN
âîçâðàùàåò TRUE, åñëè x - áåñêîíå÷íîñòü
PROCEDURE sqrt(x: LONGREAL): LONGREAL
êâàäðàòíûé êîðåíü x
PROCEDURE exp(x: LONGREAL): LONGREAL
ýêñïîíåíòà x
PROCEDURE ln(x: LONGREAL): LONGREAL
íàòóðàëüíûé ëîãàðèôì x
PROCEDURE sin(x: LONGREAL): LONGREAL
ñèíóñ x
PROCEDURE cos(x: LONGREAL): LONGREAL
êîñèíóñ x
PROCEDURE tan(x: LONGREAL): LONGREAL
òàíãåíñ x
PROCEDURE arcsin(x: LONGREAL): LONGREAL
àðêñèíóñ x
PROCEDURE arccos(x: LONGREAL): LONGREAL
àðêêîñèíóñ x
PROCEDURE arctan(x: LONGREAL): LONGREAL
àðêòàíãåíñ x
PROCEDURE arctan2(y, x: LONGREAL): LONGREAL
àðêòàíãåíñ y/x
PROCEDURE power(base, exponent: LONGREAL): LONGREAL
âîçâåäåíèå ÷èñëà base â ñòåïåíü exponent
PROCEDURE log(base, x: LONGREAL): LONGREAL
ëîãàðèôì x ïî îñíîâàíèþ base
PROCEDURE sinh(x: LONGREAL): LONGREAL
ãèïåðáîëè÷åñêèé ñèíóñ x
PROCEDURE cosh(x: LONGREAL): LONGREAL
ãèïåðáîëè÷åñêèé êîñèíóñ x
PROCEDURE tanh(x: LONGREAL): LONGREAL
ãèïåðáîëè÷åñêèé òàíãåíñ x
PROCEDURE arcsinh(x: LONGREAL): LONGREAL
îáðàòíûé ãèïåðáîëè÷åñêèé ñèíóñ x
PROCEDURE arccosh(x: LONGREAL): LONGREAL
îáðàòíûé ãèïåðáîëè÷åñêèé êîñèíóñ x
PROCEDURE arctanh(x: LONGREAL): LONGREAL
îáðàòíûé ãèïåðáîëè÷åñêèé òàíãåíñ x
PROCEDURE round(x: LONGREAL): LONGREAL
îêðóãëåíèå x äî áëèæàéøåãî öåëîãî
PROCEDURE frac(x: LONGREAL): LONGREAL;
äðîáíàÿ ÷àñòü ÷èñëà x
PROCEDURE floor(x: LONGREAL): LONGREAL
íàèáîëüøåå öåëîå ÷èñëî (ïðåäñòàâëåíèå êàê LONGREAL),
íå áîëüøå x: floor(1.2) = 1.0
PROCEDURE ceil(x: LONGREAL): LONGREAL
íàèìåíüøåå öåëîå ÷èñëî (ïðåäñòàâëåíèå êàê LONGREAL),
íå ìåíüøå x: ceil(1.2) = 2.0
PROCEDURE sgn(x: LONGREAL): INTEGER
åñëè x > 0 âîçâðàùàåò 1
åñëè x < 0 âîçâðàùàåò -1
åñëè x = 0 âîçâðàùàåò 0
------------------------------------------------------------------------------
MODULE Debug - âûâîä íà äîñêó îòëàäêè
Èíòåðôåéñ êàê ìîäóëü Out
PROCEDURE Open
îòêðûâàåò äîñêó îòëàäêè
------------------------------------------------------------------------------
MODULE File - ðàáîòà ñ ôàéëîâîé ñèñòåìîé
TYPE
FNAME = ARRAY 520 OF CHAR
FS = POINTER TO rFS
rFS = RECORD (* èíôîðìàöèîííàÿ ñòðóêòóðà ôàéëà *)
subfunc, pos, hpos, bytes, buffer: INTEGER;
name: FNAME
END
FD = POINTER TO rFD
rFD = RECORD (* ñòðóêòóðà áëîêà äàííûõ âõîäà êàòàëîãà *)
attr: INTEGER;
ntyp: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create, date_create,
time_access, date_access,
time_modif, date_modif,
size, hsize: INTEGER;
name: FNAME
END
CONST
SEEK_BEG = 0
SEEK_CUR = 1
SEEK_END = 2
PROCEDURE Load(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
Çàãðóæàåò â ïàìÿòü ôàéë ñ èìåíåì FName, çàïèñûâàåò â ïàðàìåòð
size ðàçìåð ôàéëà, âîçâðàùàåò àäðåñ çàãðóæåííîãî ôàéëà
èëè 0 (îøèáêà). Ïðè íåîáõîäèìîñòè, ðàñïàêîâûâàåò
ôàéë (kunpack).
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN
Çàïèñûâàåò ñòðóêòóðó áëîêà äàííûõ âõîäà êàòàëîãà äëÿ ôàéëà
èëè ïàïêè ñ èìåíåì FName â ïàðàìåòð Info.
Ïðè îøèáêå âîçâðàùàåò FALSE.
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN
âîçâðàùàåò TRUE, åñëè ôàéë ñ èìåíåì FName ñóùåñòâóåò
PROCEDURE Close(VAR F: FS)
îñâîáîæäàåò ïàìÿòü, âûäåëåííóþ äëÿ èíôîðìàöèîííîé ñòðóêòóðû
ôàéëà F è ïðèñâàèâàåò F çíà÷åíèå NIL
PROCEDURE Open(FName: ARRAY OF CHAR): FS
âîçâðàùàåò óêàçàòåëü íà èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà ñ
èìåíåì FName, ïðè îøèáêå âîçâðàùàåò NIL
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN
óäàëÿåò ôàéë ñ èìåíåì FName, ïðè îøèáêå âîçâðàùàåò FALSE
PROCEDURE Seek(F: FS; Offset, Origin: INTEGER): INTEGER
óñòàíàâëèâàåò ïîçèöèþ ÷òåíèÿ-çàïèñè ôàéëà F íà Offset,
îòíîñèòåëüíî Origin = (SEEK_BEG - íà÷àëî ôàéëà,
SEEK_CUR - òåêóùàÿ ïîçèöèÿ, SEEK_END - êîíåö ôàéëà),
âîçâðàùàåò ïîçèöèþ îòíîñèòåëüíî íà÷àëà ôàéëà, íàïðèìåð:
Seek(F, 0, SEEK_END)
óñòàíàâëèâàåò ïîçèöèþ íà êîíåö ôàéëà è âîçâðàùàåò äëèíó
ôàéëà; ïðè îøèáêå âîçâðàùàåò -1
PROCEDURE Read(F: FS; Buffer, Count: INTEGER): INTEGER
×èòàåò äàííûå èç ôàéëà â ïàìÿòü. F - óêàçàòåëü íà
èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà, Buffer - àäðåñ îáëàñòè
ïàìÿòè, Count - êîëè÷åñòâî áàéò, êîòîðîå òðåáóåòñÿ ïðî÷èòàòü
èç ôàéëà; âîçâðàùàåò êîëè÷åñòâî áàéò, êîòîðîå áûëî ïðî÷èòàíî
è ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿåò ïîçèöèþ ÷òåíèÿ/çàïèñè â
èíôîðìàöèîííîé ñòðóêòóðå F.
PROCEDURE Write(F: FS; Buffer, Count: INTEGER): INTEGER
Çàïèñûâàåò äàííûå èç ïàìÿòè â ôàéë. F - óêàçàòåëü íà
èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà, Buffer - àäðåñ îáëàñòè
ïàìÿòè, Count - êîëè÷åñòâî áàéò, êîòîðîå òðåáóåòñÿ çàïèñàòü
â ôàéë; âîçâðàùàåò êîëè÷åñòâî áàéò, êîòîðîå áûëî çàïèñàíî è
ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿåò ïîçèöèþ ÷òåíèÿ/çàïèñè â
èíôîðìàöèîííîé ñòðóêòóðå F.
PROCEDURE Create(FName: ARRAY OF CHAR): FS
ñîçäàåò íîâûé ôàéë ñ èìåíåì FName (ïîëíîå èìÿ), âîçâðàùàåò
óêàçàòåëü íà èíôîðìàöèîííóþ ñòðóêòóðó ôàéëà,
ïðè îøèáêå âîçâðàùàåò NIL
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN
ñîçäàåò ïàïêó ñ èìåíåì DirName, âñå ïðîìåæóòî÷íûå ïàïêè
äîëæíû ñóùåñòâîâàòü, ïðè îøèáêå âîçâðàùàåò FALSE
PROCEDURE DeleteDir(DirName: ARRAY OF CHAR): BOOLEAN
óäàëÿåò ïóñòóþ ïàïêó ñ èìåíåì DirName,
ïðè îøèáêå âîçâðàùàåò FALSE
PROCEDURE DirExists(DirName: ARRAY OF CHAR): BOOLEAN
âîçâðàùàåò TRUE, åñëè ïàïêà ñ èìåíåì DirName ñóùåñòâóåò
------------------------------------------------------------------------------
MODULE Read - ÷òåíèå îñíîâíûõ òèïîâ äàííûõ èç ôàéëà F
Ïðîöåäóðû âîçâðàùàþò TRUE â ñëó÷àå óñïåøíîé îïåðàöèè ÷òåíèÿ è
ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿþò ïîçèöèþ ÷òåíèÿ/çàïèñè â
èíôîðìàöèîííîé ñòðóêòóðå F
PROCEDURE Char(F: File.FS; VAR x: CHAR): BOOLEAN
PROCEDURE Int(F: File.FS; VAR x: INTEGER): BOOLEAN
PROCEDURE Real(F: File.FS; VAR x: REAL): BOOLEAN
PROCEDURE LongReal(F: File.FS; VAR x: LONGREAL): BOOLEAN
PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN
PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN
PROCEDURE Card16(F: File.FS; VAR x: SYSTEM.CARD16): BOOLEAN
------------------------------------------------------------------------------
MODULE Write - çàïèñü îñíîâíûõ òèïîâ äàííûõ â ôàéë F
Ïðîöåäóðû âîçâðàùàþò TRUE â ñëó÷àå óñïåøíîé îïåðàöèè çàïèñè è
ñîîòâåòñòâóþùèì îáðàçîì èçìåíÿþò ïîçèöèþ ÷òåíèÿ/çàïèñè â
èíôîðìàöèîííîé ñòðóêòóðå F
PROCEDURE Char(F: File.FS; x: CHAR): BOOLEAN
PROCEDURE Int(F: File.FS; x: INTEGER): BOOLEAN
PROCEDURE Real(F: File.FS; x: REAL): BOOLEAN
PROCEDURE LongReal(F: File.FS; x: LONGREAL): BOOLEAN
PROCEDURE Boolean(F: File.FS; x: BOOLEAN): BOOLEAN
PROCEDURE Set(F: File.FS; x: SET): BOOLEAN
PROCEDURE Card16(F: File.FS; x: SYSTEM.CARD16): BOOLEAN
------------------------------------------------------------------------------
MODULE DateTime - äàòà, âðåìÿ
CONST ERR = -7.0D5
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER)
çàïèñûâàåò â ïàðàìåòðû êîìïîíåíòû òåêóùåé ñèñòåìíîé äàòû è
âðåìåíè
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL
âîçâðàùàåò äàòó, ïîëó÷åííóþ èç êîìïîíåíòîâ
Year, Month, Day, Hour, Min, Sec;
ïðè îøèáêå âîçâðàùàåò êîíñòàíòó ERR = -7.0D5
PROCEDURE Decode(Date: LONGREAL; VAR Year, Month, Day,
Hour, Min, Sec: INTEGER): BOOLEAN
èçâëåêàåò êîìïîíåíòû
Year, Month, Day, Hour, Min, Sec èç äàòû Date;
ïðè îøèáêå âîçâðàùàåò FALSE
------------------------------------------------------------------------------
MODULE Args - ïàðàìåòðû ïðîãðàììû
VAR argc: INTEGER
êîëè÷åñòâî ïàðàìåòðîâ ïðîãðàììû, âêëþ÷àÿ èìÿ
èñïîëíÿåìîãî ôàéëà
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR)
çàïèñûâàåò â ñòðîêó s n-é ïàðàìåòð ïðîãðàììû,
íóìåðàöèÿ ïàðàìåòðîâ îò 0 äî argc - 1,
íóëåâîé ïàðàìåòð -- èìÿ èñïîëíÿåìîãî ôàéëà
------------------------------------------------------------------------------
MODULE KOSAPI
PROCEDURE sysfunc1(arg1: INTEGER): INTEGER
PROCEDURE sysfunc2(arg1, arg2: INTEGER): INTEGER
...
PROCEDURE sysfunc7(arg1, arg2, ..., arg7: INTEGER): INTEGER
Îáåðòêè äëÿ ôóíêöèé API ÿäðà KolibriOS.
arg1 .. arg7 ñîîòâåòñòâóþò ðåãèñòðàì
eax, ebx, ecx, edx, esi, edi, ebp;
âîçâðàùàþò çíà÷åíèå ðåãèñòðà eax ïîñëå ñèñòåìíîãî âûçîâà.
PROCEDURE sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER
Îáåðòêà äëÿ ôóíêöèé API ÿäðà KolibriOS.
arg1 - ðåãèñòð eax, arg2 - ðåãèñòð ebx,
res2 - çíà÷åíèå ðåãèñòðà ebx ïîñëå ñèñòåìíîãî âûçîâà;
âîçâðàùàåò çíà÷åíèå ðåãèñòðà eax ïîñëå ñèñòåìíîãî âûçîâà.
PROCEDURE malloc(size: INTEGER): INTEGER
Âûäåëÿåò áëîê ïàìÿòè.
size - ðàçìåð áëîêà â áàéòàõ,
âîçâðàùàåò àäðåñ âûäåëåííîãî áëîêà
PROCEDURE free(ptr: INTEGER): INTEGER
Îñâîáîæäàåò ðàíåå âûäåëåííûé áëîê ïàìÿòè ñ àäðåñîì ptr,
âîçâðàùàåò 0
PROCEDURE realloc(ptr, size: INTEGER): INTEGER
Ïåðåðàñïðåäåëÿåò áëîê ïàìÿòè,
ptr - àäðåñ ðàíåå âûäåëåííîãî áëîêà,
size - íîâûé ðàçìåð,
âîçâðàùàåò óêàçàòåëü íà ïåðåðàñïðåäåëåííûé áëîê,
0 ïðè îøèáêå
PROCEDURE GetCommandLine(): INTEGER
Âîçâðàùàåò àäðåñ ñòðîêè ïàðàìåòðîâ
PROCEDURE GetName(): INTEGER
Âîçâðàùàåò àäðåñ ñòðîêè ñ èìåíåì ïðîãðàììû
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER
Çàãðóæàåò DLL ñ ïîëíûì èìåíåì name. Âîçâðàùàåò àäðåñ òàáëèöû
ýêñïîðòà. Ïðè îøèáêå âîçâðàùàåò 0.
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER
name - èìÿ ïðîöåäóðû
lib - àäðåñ òàáëèöû ýêñïîðòà DLL
Âîçâðàùàåò àäðåñ ïðîöåäóðû. Ïðè îøèáêå âîçâðàùàåò 0.
------------------------------------------------------------------------------
MODULE ColorDlg - ðàáîòà ñ äèàëîãîì "Color Dialog"
TYPE
Dialog = POINTER TO RECORD (* ñòðóêòóðà äèàëîãà *)
status: INTEGER (* ñîñòîÿíèå äèàëîãà:
0 - ïîëüçîâàòåëü íàæàë Cancel
1 - ïîëüçîâàòåëü íàæàë OK
2 - äèàëîã îòêðûò *)
color: INTEGER (* âûáðàííûé öâåò *)
END
PROCEDURE Create(draw_window: DRAW_WINDOW): Dialog
ñîçäàòü äèàëîã
draw_window - ïðîöåäóðà ïåðåðèñîâêè îñíîâíîãî îêíà
(TYPE DRAW_WINDOW = PROCEDURE);
ïðîöåäóðà âîçâðàùàåò óêàçàòåëü íà ñòðóêòóðó äèàëîãà
PROCEDURE Show(cd: Dialog)
ïîêàçàòü äèàëîã
cd - óêàçàòåëü íà ñòðóêòóðó äèàëîãà, êîòîðûé áûë ñîçäàí ðàíåå
ïðîöåäóðîé Create
PROCEDURE Destroy(VAR cd: Dialog)
óíè÷òîæèòü äèàëîã
cd - óêàçàòåëü íà ñòðóêòóðó äèàëîãà
------------------------------------------------------------------------------
MODULE OpenDlg - ðàáîòà ñ äèàëîãîì "Open Dialog"
TYPE
Dialog = POINTER TO RECORD (* ñòðóêòóðà äèàëîãà *)
status: INTEGER (* ñîñòîÿíèå äèàëîãà:
0 - ïîëüçîâàòåëü íàæàë Cancel
1 - ïîëüçîâàòåëü íàæàë OK
2 - äèàëîã îòêðûò *)
FileName: ARRAY 4096 OF CHAR (* èìÿ âûáðàííîãî ôàéëà *)
FilePath: ARRAY 4096 OF CHAR (* ïîëíîå èìÿ âûáðàííîãî
ôàéëà *)
END
PROCEDURE Create(draw_window: DRAW_WINDOW; type: INTEGER; def_path,
filter: ARRAY OF CHAR): Dialog
ñîçäàòü äèàëîã
draw_window - ïðîöåäóðà ïåðåðèñîâêè îñíîâíîãî îêíà
(TYPE DRAW_WINDOW = PROCEDURE)
type - òèï äèàëîãà
0 - îòêðûòü
1 - ñîõðàíèòü
2 - âûáðàòü ïàïêó
def_path - ïóòü ïî óìîë÷àíèþ, ïàïêà def_path áóäåò îòêðûòà
ïðè ïåðâîì çàïóñêå äèàëîãà
filter - â ñòðîêå çàïèñàíî ïåðå÷èñëåíèå ðàñøèðåíèé ôàéëîâ,
êîòîðûå áóäóò ïîêàçàíû â äèàëîãîâîì îêíå, ðàñøèðåíèÿ
ðàçäåëÿþòñÿ ñèìâîëîì "|", íàïðèìåð: "ASM|TXT|INI"
ïðîöåäóðà âîçâðàùàåò óêàçàòåëü íà ñòðóêòóðó äèàëîãà
PROCEDURE Show(od: Dialog; Width, Height: INTEGER)
ïîêàçàòü äèàëîã
od - óêàçàòåëü íà ñòðóêòóðó äèàëîãà, êîòîðûé áûë ñîçäàí ðàíåå
ïðîöåäóðîé Create
Width è Height - øèðèíà è âûñîòà äèàëîãîâîãî îêíà
PROCEDURE Destroy(VAR od: Dialog)
óíè÷òîæèòü äèàëîã
od - óêàçàòåëü íà ñòðóêòóðó äèàëîãà
------------------------------------------------------------------------------
MODULE kfonts - ðàáîòà ñ kf-øðèôòàìè
CONST
bold = 1
italic = 2
underline = 4
strike_through = 8
smoothing = 16
bpp32 = 32
TYPE
TFont = POINTER TO TFont_desc (* óêàçàòåëü íà øðèôò *)
PROCEDURE LoadFont(file_name: ARRAY OF CHAR): TFont
çàãðóçèòü øðèôò èç ôàéëà
file_name èìÿ kf-ôàéëà
ðåç-ò: óêàçàòåëü íà øðèôò/NIL (îøèáêà)
PROCEDURE SetSize(Font: TFont; font_size: INTEGER): BOOLEAN
óñòàíîâèòü ðàçìåð øðèôòà
Font óêàçàòåëü íà øðèôò
font_size ðàçìåð øðèôòà
ðåç-ò: TRUE/FALSE (îøèáêà)
PROCEDURE Enabled(Font: TFont; font_size: INTEGER): BOOLEAN
ïðîâåðèòü, åñòü ëè øðèôò, çàäàííîãî ðàçìåðà
Font óêàçàòåëü íà øðèôò
font_size ðàçìåð øðèôòà
ðåç-ò: TRUE/FALSE (øðèôòà íåò)
PROCEDURE Destroy(VAR Font: TFont)
âûãðóçèòü øðèôò, îñâîáîäèòü äèíàìè÷åñêóþ ïàìÿòü
Font óêàçàòåëü íà øðèôò
Ïðèñâàèâàåò ïåðåìåííîé Font çíà÷åíèå NIL
PROCEDURE TextHeight(Font: TFont): INTEGER
ïîëó÷èòü âûñîòó ñòðîêè òåêñòà
Font óêàçàòåëü íà øðèôò
ðåç-ò: âûñîòà ñòðîêè òåêñòà â ïèêñåëÿõ
PROCEDURE TextWidth(Font: TFont;
str, length, params: INTEGER): INTEGER
ïîëó÷èòü øèðèíó ñòðîêè òåêñòà
Font óêàçàòåëü íà øðèôò
str àäðåñ ñòðîêè òåêñòà â êîäèðîâêå Win-1251
length êîëè÷åñòâî ñèìâîëîâ â ñòðîêå èëè -1, åñëè ñòðîêà
çàâåðøàåòñÿ íóëåì
params ïàðàìåòðû-ôëàãè ñì. íèæå
ðåç-ò: øèðèíà ñòðîêè òåêñòà â ïèêñåëÿõ
PROCEDURE TextOut(Font: TFont;
canvas, x, y, str, length, color, params: INTEGER)
âûâåñòè òåêñò â áóôåð
äëÿ âûâîäà áóôåðà â îêíî, èñïîëüçîâàòü ô.65 èëè
ô.7 (åñëè áóôåð 24-áèòíûé)
Font óêàçàòåëü íà øðèôò
canvas àäðåñ ãðàôè÷åñêîãî áóôåðà
ñòðóêòóðà áóôåðà:
Xsize dd
Ysize dd
picture rb Xsize * Ysize * 4 (32 áèòà)
èëè Xsize * Ysize * 3 (24 áèòà)
x, y êîîðäèíàòû òåêñòà îòíîñèòåëüíî ëåâîãî âåðõíåãî
óãëà áóôåðà
str àäðåñ ñòðîêè òåêñòà â êîäèðîâêå Win-1251
length êîëè÷åñòâî ñèìâîëîâ â ñòðîêå èëè -1, åñëè ñòðîêà
çàâåðøàåòñÿ íóëåì
color öâåò òåêñòà 0x00RRGGBB
params ïàðàìåòðû-ôëàãè:
1 æèðíûé
2 êóðñèâ
4 ïîä÷åðêíóòûé
8 ïåðå÷åðêíóòûé
16 ïðèìåíèòü ñãëàæèâàíèå
32 âûâîä â 32-áèòíûé áóôåð
âîçìîæíî èñïîëüçîâàíèå ôëàãîâ â ëþáûõ ñî÷åòàíèÿõ
------------------------------------------------------------------------------
MODULE RasterWorks - îáåðòêà áèáëèîòåêè Rasterworks.obj
------------------------------------------------------------------------------
MODULE libimg - îáåðòêà áèáëèîòåêè libimg.obj
------------------------------------------------------------------------------

/programs/develop/oberon07/Docs/About866.txt
0,0 → 1,856
Š®¬¯¨«ïâ®à ï§ëª  ¯à®£à ¬¬¨à®¢ ­¨ï Oberon-07/11 ¤«ï i386
Windows/Linux/KolibriOS.
------------------------------------------------------------------------------
‘®áâ ¢ ¯à®£à ¬¬ë
1. Compiler.kex (KolibriOS) - ¨á¯®«­ï¥¬ë© ä ©« ª®¬¯¨«ïâ®à .
‚室 - ⥪áâ®¢ë¥ ä ©«ë ¬®¤ã«¥© á à áè¨à¥­¨¥¬ ".ob07", ª®¤¨à®¢ª  ANSI
¨«¨ UTF-8 á BOM-ᨣ­ âãன.
‚ë室 - ¨á¯®«­ï¥¬ë© ä ©« ä®à¬ â  PE, ELF ¨«¨ MENUET01/MS COFF.
 à ¬¥âàë:
1) ¨¬ï £« ¢­®£® ¬®¤ã«ï
2) ⨯ ¯à¨«®¦¥­¨ï ¨ ¯« âä®à¬
"con" - Windows console
"gui" - Windows GUI
"dll" - Windows DLL
"elf" - Linux
"kos" - KolibriOS
"obj" - KolibriOS DLL
3) à §¬¥à áâíª  ¢ ¬¥£ ¡ ©â å, ­¥®¡ï§ â¥«ì­ë© ¯ à ¬¥âà, ¯® 㬮«ç ­¨î -
1 Œ¡, ¤«ï ELF ¨£­®à¨àã¥âáï. ᫨ 2-© ¯ à ¬¥âà = "obj" (KolibriOS DLL),
â® 3-© ¯ à ¬¥âà § ¤ ¥âáï è¥áâ­ ¤æ â¨à¨ç­ë¬ ç¨á«®¬
(0x00000001 .. 0xffffffff) ¨ ®¯à¥¤¥«ï¥â ¢¥àá¨î ¯à®£à ¬¬ë,
¯® 㬮«ç ­¨î - 0x00010000 (v1.0).
 ¯à¨¬¥à:
"C:\oberon-07\example.ob07" con 1
"C:\oberon-07\example.ob07" obj 0x00020005 (* v2.5 *)
‚ á«ãç ¥ ãᯥ譮© ª®¬¯¨«ï樨, ª®¬¯¨«ïâ®à ¯¥à¥¤ ¥â ª®¤ § ¢¥à襭¨ï 0,
¨­ ç¥ 1. à¨ à ¡®â¥ ª®¬¯¨«ïâ®à  ¢ KolibriOS, ª®¤ § ¢¥à襭¨ï ­¥
¯¥à¥¤ ¥âáï. ‘®®¡é¥­¨ï ª®¬¯¨«ïâ®à  ¢ë¢®¤ïâáï ­  ª®­á®«ì (Windows,
KolibriOS), ¢ â¥à¬¨­ « (Linux).
2.  ¯ª  Lib - ¡¨¡«¨®â¥ª  ¬®¤ã«¥©
3.  ¯ª  Source - ¨á室­ë© ª®¤ ª®¬¯¨«ïâ®à
------------------------------------------------------------------------------
Žâ«¨ç¨ï ®â ®à¨£¨­ «
1.  áè¨à¥­ ¯á¥¢¤®¬®¤ã«ì SYSTEM
2.  §à¥è¥­ ᨬ¢®« "_" ¢ ¨¤¥­â¨ä¨ª â®à å
3. „®¡ ¢«¥­ë á¨á⥬­ë¥ ä« £¨
4. Ž¯¥à â®à CASE ॠ«¨§®¢ ­ ¢ ᮮ⢥âá⢨¨ á ᨭ⠪á¨á®¬ ¨ ᥬ ­â¨ª®©
¤ ­­®£® ®¯¥à â®à  ¢ ï§ëª¥ Oberon (Revision 1.10.90)
5.  áè¨à¥­ ­ ¡®à áâ ­¤ àâ­ëå ¯à®æ¥¤ãà
6. ‘¥¬ ­â¨ª  ®åà ­ë/¯à®¢¥àª¨ ⨯  ãâ®ç­¥­  ¤«ï ­ã«¥¢®£® 㪠§ â¥«ï
7. ‘¥¬ ­â¨ª  DIV ¨ MOD ãâ®ç­¥­  ¤«ï ®âà¨æ â¥«ì­ëå ç¨á¥«
8. „®¡ ¢«¥­ë ®¤­®áâà®ç­ë¥ ª®¬¬¥­â à¨¨ (­ ç¨­ îâáï á ¯ àë ᨬ¢®«®¢ "//")
9.  §à¥è¥­ íªá¯®àâ ¯¥à¥¬¥­­ëå ⨯®¢ ARRAY ¨ RECORD (⮫쪮 ¤«ï ç⥭¨ï)
------------------------------------------------------------------------------
Žá®¡¥­­®á⨠ॠ«¨§ æ¨¨
1. Žá­®¢­ë¥ ⨯ë
’¨¯ „¨ ¯ §®­ §­ ç¥­¨©  §¬¥à, ¡ ©â
INTEGER -2147483648 .. 2147483647 4
REAL 1.40E-45 .. 3.34E+38 4
LONGREAL 4.94E-324 .. 1.70E+308 8
CHAR ᨬ¢®« ASCII (0X .. 0FFX) 1
BOOLEAN FALSE, TRUE 1
SET ¬­®¦¥á⢮ ¨§ 楫ëå ç¨á¥« {0 .. 31} 4
2. Œ ªá¨¬ «ì­ ï ¤«¨­  ¨¤¥­â¨ä¨ª â®à®¢ - 255 ᨬ¢®«®¢
3. Œ ªá¨¬ «ì­ ï ¤«¨­  áâப®¢ëå ª®­áâ ­â - 255 ᨬ¢®«®¢
4. Œ ªá¨¬ «ì­ ï ¤«¨­  áâப ¨á室­®£® ª®¤  - 511 ᨬ¢®«®¢
5. Œ ªá¨¬ «ì­ ï à §¬¥à­®áâì ®âªàëâëå ¬ áᨢ®¢ - 5
6. Œ ªá¨¬ «ì­®¥ ª®«¨ç¥á⢮ ®¡ê¥­­ëå ⨯®¢-§ ¯¨á¥© - 2047
7. à®æ¥¤ãà  NEW § ¯®«­ï¥â ­ã«ï¬¨ ¢ë¤¥«¥­­ë© ¡«®ª ¯ ¬ïâ¨
8. ƒ«®¡ «ì­ë¥ ¨ «®ª «ì­ë¥ ¯¥à¥¬¥­­ë¥ ¨­¨æ¨ «¨§¨àãîâáï ­ã«ï¬¨
9. ‚ ®â«¨ç¨¥ ®â ¬­®£¨å Oberon-ॠ«¨§ æ¨©, á¡®à騪 ¬ãá®à  ¨ ¤¨­ ¬¨ç¥áª ï
¬®¤ã«ì­®áâì ®âáãâáâ¢ãîâ
------------------------------------------------------------------------------
á¥¢¤®¬®¤ã«ì SYSTEM
á¥¢¤®¬®¤ã«ì SYSTEM ᮤ¥à¦¨â ­¨§ª®ã஢­¥¢ë¥ ¨ ­¥¡¥§®¯ á­ë¥ ¯à®æ¥¤ãàë,
®è¨¡ª¨ ¯à¨ ¨á¯®«ì§®¢ ­¨¨ ¯à®æ¥¤ãà ¯á¥¢¤®¬®¤ã«ï SYSTEM ¬®£ã⠯ਢ¥á⨠ª
¯®¢à¥¦¤¥­¨î ¤ ­­ëå ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¨  ¢ à¨©­®¬ã § ¢¥à襭¨î ¯à®£à ¬¬ë.
PROCEDURE ADR(v: «î¡®© ⨯): INTEGER
v - ¯¥à¥¬¥­­ ï, ¯à®æ¥¤ãà  ¨«¨ áâப®¢ ï ª®­áâ ­â ;
¢®§¢à é ¥â  ¤à¥á v
PROCEDURE SIZE(T): INTEGER
¢®§¢à é ¥â à §¬¥à ⨯  T
PROCEDURE TYPEID(T): INTEGER
T - ⨯-§ ¯¨áì ¨«¨ ⨯-㪠§ â¥«ì,
¢®§¢à é ¥â ­®¬¥à ⨯  ¢ â ¡«¨æ¥ ⨯®¢-§ ¯¨á¥©
PROCEDURE INF(T): T
T - REAL ¨«¨ LONGREAL,
¢®§¢à é ¥â ᯥ樠«ì­®¥ ¢¥é¥á⢥­­®¥ §­ ç¥­¨¥ "¡¥áª®­¥ç­®áâì"
PROCEDURE GET(a: INTEGER;
VAR v: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER)
v :=  ¬ïâì[a]
PROCEDURE PUT(a: INTEGER; x: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER)
 ¬ïâì[a] := x
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Š®¯¨àã¥â n ¡ ©â ¯ ¬ï⨠¨§ Source ¢ Dest,
®¡« á⨠Source ¨ Dest ­¥ ¤®«¦­ë ¯¥à¥ªà뢠âìáï
PROCEDURE CODE(s: ARRAY OF CHAR)
‚áâ ¢ª  ¬ è¨­­®£® ª®¤
s - áâப®¢ ï ª®­áâ ­â  è¥áâ­ ¤æ â¨à¨ç­ëå æ¨äà
ª®«¨ç¥á⢮ æ¨äà ¤®«¦­® ¡ëâì ç¥â­ë¬
­ ¯à¨¬¥à: SYSTEM.CODE("B801000000") (* mov eax, 1 *)
’ ª¦¥ ¢ ¬®¤ã«¥ SYSTEM ®¯à¥¤¥«¥­ ⨯ CARD16 (2 ¡ ©â ). „«ï ⨯  CARD16 ­¥
¤®¯ã᪠îâáï ­¨ª ª¨¥ ï¢­ë¥ ®¯¥à æ¨¨, §  ¨áª«î祭¨¥¬ ¯à¨á¢ ¨¢ ­¨ï.
à¥®¡à §®¢ ­¨ï CARD16 -> INTEGER ¨ INTEGER -> CARD16 ¬®£ãâ ¡ëâì ॠ«¨§®¢ ­ë
⠪:
PROCEDURE Card16ToInt(w: SYSTEM.CARD16): INTEGER;
VAR i: INTEGER;
BEGIN
SYSTEM.PUT(SYSTEM.ADR(i), w)
RETURN i
END Card16ToInt;
PROCEDURE IntToCard16(i: INTEGER): SYSTEM.CARD16;
VAR w: SYSTEM.CARD16;
BEGIN
SYSTEM.GET(SYSTEM.ADR(i), w)
RETURN w
END IntToCard16;
”㭪樨 ¯á¥¢¤®¬®¤ã«ï SYSTEM ­¥«ì§ï ¨á¯®«ì§®¢ âì ¢ ª®­áâ ­â­ëå ¢ëà ¦¥­¨ïå.
------------------------------------------------------------------------------
‘¨á⥬­ë¥ ä« £¨
à¨ ®¡ê¥­¨¨ ¯à®æ¥¤ãà­ëå ⨯®¢ ¨ £«®¡ «ì­ëå ¯à®æ¥¤ãà, ¯®á«¥ ª«î祢®£®
á«®¢  PROCEDURE ¬®¦¥â ¡ëâì 㪠§ ­ ä« £ ᮣ« è¥­¨ï ¢ë§®¢ : [stdcall], [cdecl]
¨«¨ [winapi].  ¯à¨¬¥à:
PROCEDURE [cdecl] MyProc(x, y, z: INTEGER): INTEGER;
᫨ 㪠§ ­ ä« £ [winapi], â® ¯à¨­¨¬ ¥âáï ᮣ« è¥­¨¥ stdcall ¨
¯à®æ¥¤ãàã-äã­ªæ¨î ¬®¦­® ¢ë§¢ âì ª ª ᮡá⢥­­® ¯à®æ¥¤ãàã, ¢­¥ ¢ëà ¦¥­¨ï.
”« £ [winapi] ¤®áâ㯥­ ⮫쪮 ¤«ï ¯« âä®à¬ë Windows.
à¨ ®¡ê¥­¨¨ ⨯®¢-§ ¯¨á¥©, ¯®á«¥ ª«î祢®£® á«®¢  RECORD ¬®¦¥â ¡ëâì
㪠§ ­ ä« £ [noalign] ¨«¨ [union]. ”« £ [noalign] ®§­ ç ¥â ®âáãâá⢨¥
¢ëà ¢­¨¢ ­¨ï ¯®«¥© § ¯¨á¨,   ä« £ [union] ®§­ ç ¥â, ç⮠ᬥ饭¨ï ¢á¥å ¯®«¥©
§ ¯¨á¨ à ¢­ë ­ã«î, ¯à¨ í⮬ à §¬¥à § ¯¨á¨ à ¢¥­ à §¬¥àã ­ ¨¡®«ì襣® ¯®«ï.
‡ ¯¨á¨ RECORD [union] ... END ᮮ⢥âáâ¢ãîâ ®¡ê¥¤¨­¥­¨ï¬ (union) ¢ ï§ëª¥ C.
‡ ¯¨á¨ á á¨á⥬­ë¬¨ ä« £ ¬¨ ­¥ ¬®£ãâ ¨¬¥âì ¡ §®¢®£® ⨯  ¨ ­¥ ¬®£ãâ ¡ëâì
¡ §®¢ë¬¨ ⨯ ¬¨ ¤«ï ¤àã£¨å § ¯¨á¥©.
„«ï ¨á¯®«ì§®¢ ­¨ï á¨á⥬­ëå ä« £®¢, âॡã¥âáï ¨¬¯®àâ¨à®¢ âì SYSTEM.
------------------------------------------------------------------------------
Ž¯¥à â®à CASE
‘¨­â ªá¨á ®¯¥à â®à  CASE:
CaseStatement =
CASE Expression OF ‘ase {"|" ‘ase}
[ELSE StatementSequence] END.
Case = [CaseLabelList ":" StatementSequence].
CaseLabelList = CaseLabels {"," CaseLabels}.
CaseLabels = ConstExpression [".." ConstExpression].
 ¯à¨¬¥à:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
‚ ¬¥âª å ¢ à¨ ­â®¢ ¬®¦­® ¨á¯®«ì§®¢ âì ª®­áâ ­â­ë¥ ¢ëà ¦¥­¨ï, ¢¥âª  ELSE
­¥®¡ï§ â¥«ì­ . ᫨ ­¥ ¢ë¯®«­¥­ ­¨ ®¤¨­ ¢ à¨ ­â ¨ ELSE ®âáãâáâ¢ã¥â, â®
¯à®£à ¬¬  ¯à¥à뢠¥âáï á ®è¨¡ª®© ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï.
------------------------------------------------------------------------------
à®¢¥àª  ¨ ®åà ­  ⨯  ­ã«¥¢®£® 㪠§ â¥«ï
Žà¨£¨­ «ì­®¥ á®®¡é¥­¨¥ ® ï§ëª¥ ­¥ ®¯à¥¤¥«ï¥â ¯®¢¥¤¥­¨¥ ¯à®£à ¬¬ë ¯à¨
¢ë¯®«­¥­¨¨ ®åà ­ë p(T) ¨ ¯à®¢¥àª¨ ⨯  p IS T ¯à¨ p = NIL. ‚® ¬­®£¨å
Oberon-ॠ«¨§ æ¨ïå ¢ë¯®«­¥­¨¥ â ª®© ®¯¥à æ¨¨ ¯à¨¢®¤¨â ª ®è¨¡ª¥ ¢à¥¬¥­¨
¢ë¯®«­¥­¨ï. ‚ ¤ ­­®© ॠ«¨§ æ¨¨ ®åà ­  ⨯  ­ã«¥¢®£® 㪠§ â¥«ï ­¥ ¯à¨¢®¤¨â ª
®è¨¡ª¥,   ¯à®¢¥àª  ⨯  ¤ ¥â १ã«ìâ â FALSE. ‚ à拉 á«ãç ¥¢ íâ® ¯®§¢®«ï¥â
§­ ç¨â¥«ì­® ᮪à â¨âì ç áâ®â㠯ਬ¥­¥­¨ï ®åà ­ë ⨯ .
------------------------------------------------------------------------------
„®¯®«­¨â¥«ì­ë¥ áâ ­¤ àâ­ë¥ ¯à®æ¥¤ãàë
DISPOSE(VAR v: «î¡®©_㪠§ â¥«ì)
Žá¢®¡®¦¤ ¥â ¯ ¬ïâì, ¢ë¤¥«¥­­ãî ¯à®æ¥¤ãன NEW ¤«ï
¤¨­ ¬¨ç¥áª®© ¯¥à¥¬¥­­®© v^, ¨ ¯à¨á¢ ¨¢ ¥â ¯¥à¥¬¥­­®© v
§­ ç¥­¨¥ NIL.
LSR(x, n: INTEGER): INTEGER
‹®£¨ç¥áª¨© ᤢ¨£ x ­  n ¡¨â ¢¯à ¢®.
BITS(x: INTEGER): SET
ˆ­â¥à¯à¥â¨àã¥â x ª ª §­ ç¥­¨¥ ⨯  SET.
‚믮«­ï¥âáï ­  íâ ¯¥ ª®¬¯¨«ï樨.
LENGTH(s: ARRAY OF CHAR): INTEGER
„«¨­  0X-§ ¢¥à襭­®© áâப¨ s, ¡¥§ ãç¥â  ᨬ¢®«  0X.
᫨ ᨬ¢®« 0X ®âáãâáâ¢ã¥â, äã­ªæ¨ï ¢®§¢à é ¥â ¤«¨­ã
¬ áᨢ  s.
------------------------------------------------------------------------------
DIV ¨ MOD
x y x DIV y x MOD y
5 3 1 2
-5 3 -2 1
5 -3 -2 -1
-5 -3 1 -2
------------------------------------------------------------------------------
‘ªàëâë¥ ¯ à ¬¥âàë ¯à®æ¥¤ãà
¥ª®â®àë¥ ¯à®æ¥¤ãàë ¬®£ãâ ¨¬¥âì áªàëâë¥ ¯ à ¬¥âàë, ®­¨ ®âáãâáâ¢ãîâ ¢ ᯨ᪥
ä®à¬ «ì­ëå ¯ à ¬¥â஢, ­® ãç¨â뢠îâáï ª®¬¯¨«ïâ®à®¬ ¯à¨ âà ­á«ï樨 ¢ë§®¢®¢.
â® ¢®§¬®¦­® ¢ á«¥¤ãîé¨å á«ãç ïå:
1. à®æ¥¤ãà  ¨¬¥¥â ä®à¬ «ì­ë© ¯ à ¬¥âà ®âªàëâë© ¬ áᨢ:
PROCEDURE Proc(x: ARRAY OF ARRAY OF LONGREAL);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(SYSTEM.ADR(x), LEN(x), LEN(x[0])
2. à®æ¥¤ãà  ¨¬¥¥â ä®à¬ «ì­ë© ¯ à ¬¥âà-¯¥à¥¬¥­­ãî ⨯  RECORD:
PROCEDURE Proc(VAR x: Rec);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
3. à®æ¥¤ãà  ï¢«ï¥âáï ¢«®¦¥­­®©, £«ã¡¨­  ¢«®¦¥­¨ï k,
¤«ï £«®¡ «ì­ëå ¯à®æ¥¤ãà k = 0:
PROCEDURE Proc(p1, ..., pn);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(base(k - 1), base(k - 2), ..., base(0), p1, ..., pn),
£¤¥ base(m) -  ¤à¥á ¡ §ë ª ¤à  áâíª  ®å¢ â뢠î饩 ¯à®æ¥¤ãàë £«ã¡¨­ë
¢«®¦¥­¨ï m (¨á¯®«ì§ã¥âáï ¤«ï ¤®áâ㯠 ª «®ª «ì­ë¬ ¯¥à¥¬¥­­ë¬
®å¢ â뢠î饩 ¯à®æ¥¤ãàë)
------------------------------------------------------------------------------
Œ®¤ã«ì RTL
‚ᥠ¯à®£à ¬¬ë ­¥ï¢­® ¨á¯®«ì§ãîâ ¬®¤ã«ì RTL. Š®¬¯¨«ïâ®à â࠭᫨àã¥â
­¥ª®â®àë¥ ®¯¥à æ¨¨ (¯à®¢¥àª  ¨ ®åà ­  ⨯ , áà ¢­¥­¨¥ áâப, á®®¡é¥­¨ï ®¡
®è¨¡ª å ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¨ ¤à.) ª ª ¢ë§®¢ë ¯à®æ¥¤ãà í⮣® ¬®¤ã«ï. ¥
á«¥¤ã¥â ® ¢ë§ë¢ âì í⨠¯à®æ¥¤ãàë, §  ¨áª«î祭¨¥¬ ¯à®æ¥¤ãàë SetClose:
PROCEDURE SetClose(proc: PROC), £¤¥ TYPE PROC = PROCEDURE
SetClose ­ §­ ç ¥â ¯à®æ¥¤ãàã proc (¡¥§ ¯ à ¬¥â஢) ¢ë§ë¢ ¥¬®© ¯à¨ ¢ë£à㧪¥
dll-¡¨¡«¨®â¥ª¨ (Windows), ¥á«¨ ¯à¨«®¦¥­¨¥ ª®¬¯¨«¨àã¥âáï ª ª Windows DLL. „«ï
¯à®ç¨å ⨯®¢ ¯à¨«®¦¥­¨© ¨ ¯« âä®à¬ ¢ë§®¢ ¯à®æ¥¤ãàë SetClose ­¥ ¢«¨ï¥â ­
¯®¢¥¤¥­¨¥ ¯à®£à ¬¬ë.
‘®®¡é¥­¨ï ®¡ ®è¨¡ª å ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¢ë¢®¤ïâáï ¢ ¤¨ «®£®¢ëå ®ª­ å
(Windows), ¢ â¥à¬¨­ « (Linux), ­  ¤®áªã ®â« ¤ª¨ (KolibriOS).
------------------------------------------------------------------------------
Œ®¤ã«ì API
‘ãé¥áâ¢ãîâ âਠॠ«¨§ æ¨¨ ¬®¤ã«ï API: ¤«ï Windows, Linux ¨ KolibriOS. Š ª ¨
¬®¤ã«ì RTL, ¬®¤ã«ì API ­¥ ¯à¥¤­ §­ ç¥­ ¤«ï ¯àאַ£® ¨á¯®«ì§®¢ ­¨ï. Ž­
®¡¥á¯¥ç¨¢ ¥â ªà®áᯫ âä®à¬¥­­®áâì ª®¬¯¨«ïâ®à .
------------------------------------------------------------------------------
ƒ¥­¥à æ¨ï ¨á¯®«­ï¥¬ëå ä ©«®¢ DLL
 §à¥è ¥âáï íªá¯®àâ¨à®¢ âì ⮫쪮 ¯à®æ¥¤ãàë. „«ï í⮣®, ¯à®æ¥¤ãà  ¤®«¦­
­ å®¤¨âìáï ¢ £« ¢­®¬ ¬®¤ã«¥ ¯à®£à ¬¬ë, ¨ ¥¥ ¨¬ï ¤®«¦­® ¡ëâì ®â¬¥ç¥­® ᨬ¢®«®¬
íªá¯®àâ  ("*"). KolibriOS DLL ¢á¥£¤  íªá¯®àâ¨àãîâ ¨¤¥­â¨ä¨ª â®àë "version"
(¢¥àá¨ï ¯à®£à ¬¬ë) ¨ "lib_init" -  ¤à¥á ¯à®æ¥¤ãàë ¨­¨æ¨ «¨§ æ¨¨ DLL:
PROCEDURE [stdcall] lib_init(): INTEGER
â  ¯à®æ¥¤ãà  ¤®«¦­  ¡ëâì ¢ë§¢ ­  ¯¥à¥¤ ¨á¯®«ì§®¢ ­¨¥¬ DLL.
à®æ¥¤ãà  ¢á¥£¤  ¢®§¢à é ¥â 1.
‚ ­ áâ®ï饥 ¢à¥¬ï £¥­¥à æ¨ï DLL ¤«ï Linux ­¥ ॠ«¨§®¢ ­ .
==============================================================================
==============================================================================
¨¡«¨®â¥ª  (KolibriOS)
------------------------------------------------------------------------------
MODULE Out - ª®­á®«ì­ë© ¢ë¢®¤
PROCEDURE Open
ä®à¬ «ì­® ®âªà뢠¥â ª®­á®«ì­ë© ¢ë¢®¤
PROCEDURE Int(x, width: INTEGER)
¢ë¢®¤ 楫®£® ç¨á«  x;
width - ª®«¨ç¥á⢮ §­ ª®¬¥áâ, ¨á¯®«ì§ã¥¬ëå ¤«ï ¢ë¢®¤
PROCEDURE Real(x: LONGREAL; width: INTEGER)
¢ë¢®¤ ¢¥é¥á⢥­­®£® ç¨á«  x ¢ ¯« ¢ î饬 ä®à¬ â¥;
width - ª®«¨ç¥á⢮ §­ ª®¬¥áâ, ¨á¯®«ì§ã¥¬ëå ¤«ï ¢ë¢®¤
PROCEDURE Char(x: CHAR)
¢ë¢®¤ ᨬ¢®«  x
PROCEDURE FixReal(x: LONGREAL; width, p: INTEGER)
¢ë¢®¤ ¢¥é¥á⢥­­®£® ç¨á«  x ¢ 䨪á¨à®¢ ­­®¬ ä®à¬ â¥;
width - ª®«¨ç¥á⢮ §­ ª®¬¥áâ, ¨á¯®«ì§ã¥¬ëå ¤«ï ¢ë¢®¤ ;
p - ª®«¨ç¥á⢮ §­ ª®¢ ¯®á«¥ ¤¥áïâ¨ç­®© â®çª¨
PROCEDURE Ln
¯¥à¥å®¤ ­  á«¥¤ãîéãî áâபã
PROCEDURE String(s: ARRAY OF CHAR)
¢ë¢®¤ áâப¨ s
------------------------------------------------------------------------------
MODULE In - ª®­á®«ì­ë© ¢¢®¤
VAR Done: BOOLEAN
¯à¨­¨¬ ¥â §­ ç¥­¨¥ TRUE ¢ á«ãç ¥ ãᯥ譮£® ¢ë¯®«­¥­¨ï
®¯¥à æ¨¨ ¢¢®¤ , ¨­ ç¥ FALSE
PROCEDURE Open
ä®à¬ «ì­® ®âªà뢠¥â ª®­á®«ì­ë© ¢¢®¤,
â ª¦¥ ¯à¨á¢ ¨¢ ¥â ¯¥à¥¬¥­­®© Done §­ ç¥­¨¥ TRUE
PROCEDURE Int(VAR x: INTEGER)
¢¢®¤ ç¨á«  ⨯  INTEGER
PROCEDURE Char(VAR x: CHAR)
¢¢®¤ ᨬ¢®«
PROCEDURE Real(VAR x: REAL)
¢¢®¤ ç¨á«  ⨯  REAL
PROCEDURE LongReal(VAR x: LONGREAL)
¢¢®¤ ç¨á«  ⨯  LONGREAL
PROCEDURE String(VAR s: ARRAY OF CHAR)
¢¢®¤ áâப¨
PROCEDURE Ln
®¦¨¤ ­¨¥ ­ ¦ â¨ï ENTER
------------------------------------------------------------------------------
MODULE Console - ¤®¯®«­¨â¥«ì­ë¥ ¯à®æ¥¤ãàë ª®­á®«ì­®£® ¢ë¢®¤
CONST
‘«¥¤ãî騥 ª®­áâ ­âë ®¯à¥¤¥«ïîâ 梥⠪®­á®«ì­®£® ¢ë¢®¤
Black = 0 Blue = 1 Green = 2
Cyan = 3 Red = 4 Magenta = 5
Brown = 6 LightGray = 7 DarkGray = 8
LightBlue = 9 LightGreen = 10 LightCyan = 11
LightRed = 12 LightMagenta = 13 Yellow = 14
White = 15
PROCEDURE Cls
®ç¨á⪠ ®ª­  ª®­á®«¨
PROCEDURE SetColor(FColor, BColor: INTEGER)
ãáâ ­®¢ª  æ¢¥â  ª®­á®«ì­®£® ¢ë¢®¤ : FColor - 梥â ⥪áâ ,
BColor - 梥â ä®­ , ¢®§¬®¦­ë¥ §­ ç¥­¨ï - ¢ë襯¥à¥ç¨á«¥­­ë¥
ª®­áâ ­âë
PROCEDURE SetCursor(x, y: INTEGER)
ãáâ ­®¢ª  ªãàá®à  ª®­á®«¨ ¢ ¯®§¨æ¨î (x, y)
PROCEDURE GetCursor(VAR x, y: INTEGER)
§ ¯¨á뢠¥â ¢ ¯ à ¬¥âàë ⥪ã騥 ª®®à¤¨­ âë ªãàá®à  ª®­á®«¨
PROCEDURE GetCursorX(): INTEGER
¢®§¢à é ¥â ⥪ãéãî x-ª®®à¤¨­ âã ªãàá®à  ª®­á®«¨
PROCEDURE GetCursorY(): INTEGER
¢®§¢à é ¥â ⥪ãéãî y-ª®®à¤¨­ âã ªãàá®à  ª®­á®«¨
------------------------------------------------------------------------------
MODULE ConsoleLib - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ console.obj
------------------------------------------------------------------------------
MODULE Math - ¬ â¥¬ â¨ç¥áª¨¥ ä㭪樨
CONST
pi = 3.141592653589793D+00
e = 2.718281828459045D+00
VAR
Inf, nInf: LONGREAL
¯®«®¦¨â¥«ì­ ï ¨ ®âà¨æ â¥«ì­ ï ¡¥áª®­¥ç­®áâì
PROCEDURE IsNan(x: LONGREAL): BOOLEAN
¢®§¢à é ¥â TRUE, ¥á«¨ x - ­¥ ç¨á«®
PROCEDURE IsInf(x: LONGREAL): BOOLEAN
¢®§¢à é ¥â TRUE, ¥á«¨ x - ¡¥áª®­¥ç­®áâì
PROCEDURE sqrt(x: LONGREAL): LONGREAL
ª¢ ¤à â­ë© ª®à¥­ì x
PROCEDURE exp(x: LONGREAL): LONGREAL
íªá¯®­¥­â  x
PROCEDURE ln(x: LONGREAL): LONGREAL
­ âãà «ì­ë© «®£ à¨ä¬ x
PROCEDURE sin(x: LONGREAL): LONGREAL
ᨭãá x
PROCEDURE cos(x: LONGREAL): LONGREAL
ª®á¨­ãá x
PROCEDURE tan(x: LONGREAL): LONGREAL
â ­£¥­á x
PROCEDURE arcsin(x: LONGREAL): LONGREAL
àªá¨­ãá x
PROCEDURE arccos(x: LONGREAL): LONGREAL
પ®á¨­ãá x
PROCEDURE arctan(x: LONGREAL): LONGREAL
àªâ ­£¥­á x
PROCEDURE arctan2(y, x: LONGREAL): LONGREAL
àªâ ­£¥­á y/x
PROCEDURE power(base, exponent: LONGREAL): LONGREAL
¢®§¢¥¤¥­¨¥ ç¨á«  base ¢ á⥯¥­ì exponent
PROCEDURE log(base, x: LONGREAL): LONGREAL
«®£ à¨ä¬ x ¯® ®á­®¢ ­¨î base
PROCEDURE sinh(x: LONGREAL): LONGREAL
£¨¯¥à¡®«¨ç¥áª¨© ᨭãá x
PROCEDURE cosh(x: LONGREAL): LONGREAL
£¨¯¥à¡®«¨ç¥áª¨© ª®á¨­ãá x
PROCEDURE tanh(x: LONGREAL): LONGREAL
£¨¯¥à¡®«¨ç¥áª¨© â ­£¥­á x
PROCEDURE arcsinh(x: LONGREAL): LONGREAL
®¡à â­ë© £¨¯¥à¡®«¨ç¥áª¨© ᨭãá x
PROCEDURE arccosh(x: LONGREAL): LONGREAL
®¡à â­ë© £¨¯¥à¡®«¨ç¥áª¨© ª®á¨­ãá x
PROCEDURE arctanh(x: LONGREAL): LONGREAL
®¡à â­ë© £¨¯¥à¡®«¨ç¥áª¨© â ­£¥­á x
PROCEDURE round(x: LONGREAL): LONGREAL
®ªà㣫¥­¨¥ x ¤® ¡«¨¦ ©è¥£® 楫®£®
PROCEDURE frac(x: LONGREAL): LONGREAL;
¤à®¡­ ï ç áâì ç¨á«  x
PROCEDURE floor(x: LONGREAL): LONGREAL
­ ¨¡®«ì襥 楫®¥ ç¨á«® (¯à¥¤áâ ¢«¥­¨¥ ª ª LONGREAL),
­¥ ¡®«ìè¥ x: floor(1.2) = 1.0
PROCEDURE ceil(x: LONGREAL): LONGREAL
­ ¨¬¥­ì襥 楫®¥ ç¨á«® (¯à¥¤áâ ¢«¥­¨¥ ª ª LONGREAL),
­¥ ¬¥­ìè¥ x: ceil(1.2) = 2.0
PROCEDURE sgn(x: LONGREAL): INTEGER
¥á«¨ x > 0 ¢®§¢à é ¥â 1
¥á«¨ x < 0 ¢®§¢à é ¥â -1
¥á«¨ x = 0 ¢®§¢à é ¥â 0
------------------------------------------------------------------------------
MODULE Debug - ¢ë¢®¤ ­  ¤®áªã ®â« ¤ª¨
ˆ­â¥àä¥©á ª ª ¬®¤ã«ì Out
PROCEDURE Open
®âªà뢠¥â ¤®áªã ®â« ¤ª¨
------------------------------------------------------------------------------
MODULE File - à ¡®â  á ä ©«®¢®© á¨á⥬®©
TYPE
FNAME = ARRAY 520 OF CHAR
FS = POINTER TO rFS
rFS = RECORD (* ¨­ä®à¬ æ¨®­­ ï áâàãªâãà  ä ©«  *)
subfunc, pos, hpos, bytes, buffer: INTEGER;
name: FNAME
END
FD = POINTER TO rFD
rFD = RECORD (* áâàãªâãà  ¡«®ª  ¤ ­­ëå ¢å®¤  ª â «®£  *)
attr: INTEGER;
ntyp: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create, date_create,
time_access, date_access,
time_modif, date_modif,
size, hsize: INTEGER;
name: FNAME
END
CONST
SEEK_BEG = 0
SEEK_CUR = 1
SEEK_END = 2
PROCEDURE Load(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
‡ £à㦠¥â ¢ ¯ ¬ïâì ä ©« á ¨¬¥­¥¬ FName, § ¯¨á뢠¥â ¢ ¯ à ¬¥âà
size à §¬¥à ä ©« , ¢®§¢à é ¥â  ¤à¥á § £à㦥­­®£® ä ©«
¨«¨ 0 (®è¨¡ª ). à¨ ­¥®¡å®¤¨¬®áâ¨, à á¯ ª®¢ë¢ ¥â
ä ©« (kunpack).
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN
‡ ¯¨á뢠¥â áâàãªâãàã ¡«®ª  ¤ ­­ëå ¢å®¤  ª â «®£  ¤«ï ä ©«
¨«¨ ¯ ¯ª¨ á ¨¬¥­¥¬ FName ¢ ¯ à ¬¥âà Info.
à¨ ®è¨¡ª¥ ¢®§¢à é ¥â FALSE.
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN
¢®§¢à é ¥â TRUE, ¥á«¨ ä ©« á ¨¬¥­¥¬ FName áãé¥áâ¢ã¥â
PROCEDURE Close(VAR F: FS)
®á¢®¡®¦¤ ¥â ¯ ¬ïâì, ¢ë¤¥«¥­­ãî ¤«ï ¨­ä®à¬ æ¨®­­®© áâàãªâãàë
ä ©«  F ¨ ¯à¨á¢ ¨¢ ¥â F §­ ç¥­¨¥ NIL
PROCEDURE Open(FName: ARRAY OF CHAR): FS
¢®§¢à é ¥â 㪠§ â¥«ì ­  ¨­ä®à¬ æ¨®­­ãî áâàãªâãàã ä ©«  á
¨¬¥­¥¬ FName, ¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â NIL
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN
㤠«ï¥â ä ©« á ¨¬¥­¥¬ FName, ¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â FALSE
PROCEDURE Seek(F: FS; Offset, Origin: INTEGER): INTEGER
ãáâ ­ ¢«¨¢ ¥â ¯®§¨æ¨î ç⥭¨ï-§ ¯¨á¨ ä ©«  F ­  Offset,
®â­®á¨â¥«ì­® Origin = (SEEK_BEG - ­ ç «® ä ©« ,
SEEK_CUR - ⥪ãé ï ¯®§¨æ¨ï, SEEK_END - ª®­¥æ ä ©« ),
¢®§¢à é ¥â ¯®§¨æ¨î ®â­®á¨â¥«ì­® ­ ç «  ä ©« , ­ ¯à¨¬¥à:
Seek(F, 0, SEEK_END)
ãáâ ­ ¢«¨¢ ¥â ¯®§¨æ¨î ­  ª®­¥æ ä ©«  ¨ ¢®§¢à é ¥â ¤«¨­ã
ä ©« ; ¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â -1
PROCEDURE Read(F: FS; Buffer, Count: INTEGER): INTEGER
—¨â ¥â ¤ ­­ë¥ ¨§ ä ©«  ¢ ¯ ¬ïâì. F - 㪠§ â¥«ì ­
¨­ä®à¬ æ¨®­­ãî áâàãªâãàã ä ©« , Buffer -  ¤à¥á ®¡« áâ¨
¯ ¬ïâ¨, Count - ª®«¨ç¥á⢮ ¡ ©â, ª®â®à®¥ âॡã¥âáï ¯à®ç¨â âì
¨§ ä ©« ; ¢®§¢à é ¥â ª®«¨ç¥á⢮ ¡ ©â, ª®â®à®¥ ¡ë«® ¯à®ç¨â ­®
¨ ᮮ⢥âáâ¢ãî騬 ®¡à §®¬ ¨§¬¥­ï¥â ¯®§¨æ¨î ç⥭¨ï/§ ¯¨á¨ ¢
¨­ä®à¬ æ¨®­­®© áâàãªâãॠF.
PROCEDURE Write(F: FS; Buffer, Count: INTEGER): INTEGER
‡ ¯¨á뢠¥â ¤ ­­ë¥ ¨§ ¯ ¬ï⨠¢ ä ©«. F - 㪠§ â¥«ì ­
¨­ä®à¬ æ¨®­­ãî áâàãªâãàã ä ©« , Buffer -  ¤à¥á ®¡« áâ¨
¯ ¬ïâ¨, Count - ª®«¨ç¥á⢮ ¡ ©â, ª®â®à®¥ âॡã¥âáï § ¯¨á âì
¢ ä ©«; ¢®§¢à é ¥â ª®«¨ç¥á⢮ ¡ ©â, ª®â®à®¥ ¡ë«® § ¯¨á ­® ¨
ᮮ⢥âáâ¢ãî騬 ®¡à §®¬ ¨§¬¥­ï¥â ¯®§¨æ¨î ç⥭¨ï/§ ¯¨á¨ ¢
¨­ä®à¬ æ¨®­­®© áâàãªâãॠF.
PROCEDURE Create(FName: ARRAY OF CHAR): FS
ᮧ¤ ¥â ­®¢ë© ä ©« á ¨¬¥­¥¬ FName (¯®«­®¥ ¨¬ï), ¢®§¢à é ¥â
㪠§ â¥«ì ­  ¨­ä®à¬ æ¨®­­ãî áâàãªâãàã ä ©« ,
¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â NIL
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN
ᮧ¤ ¥â ¯ ¯ªã á ¨¬¥­¥¬ DirName, ¢á¥ ¯à®¬¥¦ãâ®ç­ë¥ ¯ ¯ª¨
¤®«¦­ë áãé¥á⢮¢ âì, ¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â FALSE
PROCEDURE DeleteDir(DirName: ARRAY OF CHAR): BOOLEAN
㤠«ï¥â ¯ãáâãî ¯ ¯ªã á ¨¬¥­¥¬ DirName,
¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â FALSE
PROCEDURE DirExists(DirName: ARRAY OF CHAR): BOOLEAN
¢®§¢à é ¥â TRUE, ¥á«¨ ¯ ¯ª  á ¨¬¥­¥¬ DirName áãé¥áâ¢ã¥â
------------------------------------------------------------------------------
MODULE Read - ç⥭¨¥ ®á­®¢­ëå ⨯®¢ ¤ ­­ëå ¨§ ä ©«  F
à®æ¥¤ãàë ¢®§¢à é îâ TRUE ¢ á«ãç ¥ ãᯥ譮© ®¯¥à æ¨¨ ç⥭¨ï ¨
ᮮ⢥âáâ¢ãî騬 ®¡à §®¬ ¨§¬¥­ïîâ ¯®§¨æ¨î ç⥭¨ï/§ ¯¨á¨ ¢
¨­ä®à¬ æ¨®­­®© áâàãªâãॠF
PROCEDURE Char(F: File.FS; VAR x: CHAR): BOOLEAN
PROCEDURE Int(F: File.FS; VAR x: INTEGER): BOOLEAN
PROCEDURE Real(F: File.FS; VAR x: REAL): BOOLEAN
PROCEDURE LongReal(F: File.FS; VAR x: LONGREAL): BOOLEAN
PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN
PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN
PROCEDURE Card16(F: File.FS; VAR x: SYSTEM.CARD16): BOOLEAN
------------------------------------------------------------------------------
MODULE Write - § ¯¨áì ®á­®¢­ëå ⨯®¢ ¤ ­­ëå ¢ ä ©« F
à®æ¥¤ãàë ¢®§¢à é îâ TRUE ¢ á«ãç ¥ ãᯥ譮© ®¯¥à æ¨¨ § ¯¨á¨ ¨
ᮮ⢥âáâ¢ãî騬 ®¡à §®¬ ¨§¬¥­ïîâ ¯®§¨æ¨î ç⥭¨ï/§ ¯¨á¨ ¢
¨­ä®à¬ æ¨®­­®© áâàãªâãॠF
PROCEDURE Char(F: File.FS; x: CHAR): BOOLEAN
PROCEDURE Int(F: File.FS; x: INTEGER): BOOLEAN
PROCEDURE Real(F: File.FS; x: REAL): BOOLEAN
PROCEDURE LongReal(F: File.FS; x: LONGREAL): BOOLEAN
PROCEDURE Boolean(F: File.FS; x: BOOLEAN): BOOLEAN
PROCEDURE Set(F: File.FS; x: SET): BOOLEAN
PROCEDURE Card16(F: File.FS; x: SYSTEM.CARD16): BOOLEAN
------------------------------------------------------------------------------
MODULE DateTime - ¤ â , ¢à¥¬ï
CONST ERR = -7.0D5
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER)
§ ¯¨á뢠¥â ¢ ¯ à ¬¥âàë ª®¬¯®­¥­âë ⥪ã饩 á¨á⥬­®© ¤ âë ¨
¢à¥¬¥­¨
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL
¢®§¢à é ¥â ¤ âã, ¯®«ã祭­ãî ¨§ ª®¬¯®­¥­â®¢
Year, Month, Day, Hour, Min, Sec;
¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â ª®­áâ ­âã ERR = -7.0D5
PROCEDURE Decode(Date: LONGREAL; VAR Year, Month, Day,
Hour, Min, Sec: INTEGER): BOOLEAN
¨§¢«¥ª ¥â ª®¬¯®­¥­âë
Year, Month, Day, Hour, Min, Sec ¨§ ¤ âë Date;
¯à¨ ®è¨¡ª¥ ¢®§¢à é ¥â FALSE
------------------------------------------------------------------------------
MODULE Args - ¯ à ¬¥âàë ¯à®£à ¬¬ë
VAR argc: INTEGER
ª®«¨ç¥á⢮ ¯ à ¬¥â஢ ¯à®£à ¬¬ë, ¢ª«îç ï ¨¬ï
¨á¯®«­ï¥¬®£® ä ©«
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR)
§ ¯¨á뢠¥â ¢ áâபã s n-© ¯ à ¬¥âà ¯à®£à ¬¬ë,
­ã¬¥à æ¨ï ¯ à ¬¥â஢ ®â 0 ¤® argc - 1,
­ã«¥¢®© ¯ à ¬¥âà -- ¨¬ï ¨á¯®«­ï¥¬®£® ä ©«
------------------------------------------------------------------------------
MODULE KOSAPI
PROCEDURE sysfunc1(arg1: INTEGER): INTEGER
PROCEDURE sysfunc2(arg1, arg2: INTEGER): INTEGER
...
PROCEDURE sysfunc7(arg1, arg2, ..., arg7: INTEGER): INTEGER
Ž¡¥à⪨ ¤«ï ä㭪権 API ï¤à  KolibriOS.
arg1 .. arg7 ᮮ⢥âáâ¢ãîâ ॣ¨áâà ¬
eax, ebx, ecx, edx, esi, edi, ebp;
¢®§¢à é îâ §­ ç¥­¨¥ ॣ¨áâà  eax ¯®á«¥ á¨á⥬­®£® ¢ë§®¢ .
PROCEDURE sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER
Ž¡¥à⪠ ¤«ï ä㭪権 API ï¤à  KolibriOS.
arg1 - ॣ¨áâà eax, arg2 - ॣ¨áâà ebx,
res2 - §­ ç¥­¨¥ ॣ¨áâà  ebx ¯®á«¥ á¨á⥬­®£® ¢ë§®¢ ;
¢®§¢à é ¥â §­ ç¥­¨¥ ॣ¨áâà  eax ¯®á«¥ á¨á⥬­®£® ¢ë§®¢ .
PROCEDURE malloc(size: INTEGER): INTEGER
‚뤥«ï¥â ¡«®ª ¯ ¬ïâ¨.
size - à §¬¥à ¡«®ª  ¢ ¡ ©â å,
¢®§¢à é ¥â  ¤à¥á ¢ë¤¥«¥­­®£® ¡«®ª
PROCEDURE free(ptr: INTEGER): INTEGER
Žá¢®¡®¦¤ ¥â à ­¥¥ ¢ë¤¥«¥­­ë© ¡«®ª ¯ ¬ïâ¨ á  ¤à¥á®¬ ptr,
¢®§¢à é ¥â 0
PROCEDURE realloc(ptr, size: INTEGER): INTEGER
¥à¥à á¯à¥¤¥«ï¥â ¡«®ª ¯ ¬ïâ¨,
ptr -  ¤à¥á à ­¥¥ ¢ë¤¥«¥­­®£® ¡«®ª ,
size - ­®¢ë© à §¬¥à,
¢®§¢à é ¥â 㪠§ â¥«ì ­  ¯¥à¥à á¯à¥¤¥«¥­­ë© ¡«®ª,
0 ¯à¨ ®è¨¡ª¥
PROCEDURE GetCommandLine(): INTEGER
‚®§¢à é ¥â  ¤à¥á áâப¨ ¯ à ¬¥â஢
PROCEDURE GetName(): INTEGER
‚®§¢à é ¥â  ¤à¥á áâப¨ á ¨¬¥­¥¬ ¯à®£à ¬¬ë
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER
‡ £à㦠¥â DLL á ¯®«­ë¬ ¨¬¥­¥¬ name. ‚®§¢à é ¥â  ¤à¥á â ¡«¨æë
íªá¯®àâ . à¨ ®è¨¡ª¥ ¢®§¢à é ¥â 0.
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER
name - ¨¬ï ¯à®æ¥¤ãàë
lib -  ¤à¥á â ¡«¨æë íªá¯®àâ  DLL
‚®§¢à é ¥â  ¤à¥á ¯à®æ¥¤ãàë. à¨ ®è¨¡ª¥ ¢®§¢à é ¥â 0.
------------------------------------------------------------------------------
MODULE ColorDlg - à ¡®â  á ¤¨ «®£®¬ "Color Dialog"
TYPE
Dialog = POINTER TO RECORD (* áâàãªâãà  ¤¨ «®£  *)
status: INTEGER (* á®áâ®ï­¨¥ ¤¨ «®£ :
0 - ¯®«ì§®¢ â¥«ì ­ ¦ « Cancel
1 - ¯®«ì§®¢ â¥«ì ­ ¦ « OK
2 - ¤¨ «®£ ®âªàëâ *)
color: INTEGER (* ¢ë¡à ­­ë© 梥â *)
END
PROCEDURE Create(draw_window: DRAW_WINDOW): Dialog
ᮧ¤ âì ¤¨ «®£
draw_window - ¯à®æ¥¤ãà  ¯¥à¥à¨á®¢ª¨ ®á­®¢­®£® ®ª­
(TYPE DRAW_WINDOW = PROCEDURE);
¯à®æ¥¤ãà  ¢®§¢à é ¥â 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£
PROCEDURE Show(cd: Dialog)
¯®ª § âì ¤¨ «®£
cd - 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£ , ª®â®àë© ¡ë« ᮧ¤ ­ à ­¥¥
¯à®æ¥¤ãன Create
PROCEDURE Destroy(VAR cd: Dialog)
ã­¨ç⮦¨âì ¤¨ «®£
cd - 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£
------------------------------------------------------------------------------
MODULE OpenDlg - à ¡®â  á ¤¨ «®£®¬ "Open Dialog"
TYPE
Dialog = POINTER TO RECORD (* áâàãªâãà  ¤¨ «®£  *)
status: INTEGER (* á®áâ®ï­¨¥ ¤¨ «®£ :
0 - ¯®«ì§®¢ â¥«ì ­ ¦ « Cancel
1 - ¯®«ì§®¢ â¥«ì ­ ¦ « OK
2 - ¤¨ «®£ ®âªàëâ *)
FileName: ARRAY 4096 OF CHAR (* ¨¬ï ¢ë¡à ­­®£® ä ©«  *)
FilePath: ARRAY 4096 OF CHAR (* ¯®«­®¥ ¨¬ï ¢ë¡à ­­®£®
ä ©«  *)
END
PROCEDURE Create(draw_window: DRAW_WINDOW; type: INTEGER; def_path,
filter: ARRAY OF CHAR): Dialog
ᮧ¤ âì ¤¨ «®£
draw_window - ¯à®æ¥¤ãà  ¯¥à¥à¨á®¢ª¨ ®á­®¢­®£® ®ª­
(TYPE DRAW_WINDOW = PROCEDURE)
type - ⨯ ¤¨ «®£
0 - ®âªàëâì
1 - á®åà ­¨âì
2 - ¢ë¡à âì ¯ ¯ªã
def_path - ¯ãâì ¯® 㬮«ç ­¨î, ¯ ¯ª  def_path ¡ã¤¥â ®âªàëâ
¯à¨ ¯¥à¢®¬ § ¯ã᪥ ¤¨ «®£
filter - ¢ áâப¥ § ¯¨á ­® ¯¥à¥ç¨á«¥­¨¥ à áè¨à¥­¨© ä ©«®¢,
ª®â®àë¥ ¡ã¤ãâ ¯®ª § ­ë ¢ ¤¨ «®£®¢®¬ ®ª­¥, à áè¨à¥­¨ï
à §¤¥«ïîâáï ᨬ¢®«®¬ "|", ­ ¯à¨¬¥à: "ASM|TXT|INI"
¯à®æ¥¤ãà  ¢®§¢à é ¥â 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£
PROCEDURE Show(od: Dialog; Width, Height: INTEGER)
¯®ª § âì ¤¨ «®£
od - 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£ , ª®â®àë© ¡ë« ᮧ¤ ­ à ­¥¥
¯à®æ¥¤ãன Create
Width ¨ Height - è¨à¨­  ¨ ¢ëá®â  ¤¨ «®£®¢®£® ®ª­
PROCEDURE Destroy(VAR od: Dialog)
ã­¨ç⮦¨âì ¤¨ «®£
od - 㪠§ â¥«ì ­  áâàãªâãàã ¤¨ «®£
------------------------------------------------------------------------------
MODULE kfonts - à ¡®â  á kf-èà¨äâ ¬¨
CONST
bold = 1
italic = 2
underline = 4
strike_through = 8
smoothing = 16
bpp32 = 32
TYPE
TFont = POINTER TO TFont_desc (* 㪠§ â¥«ì ­  èà¨äâ *)
PROCEDURE LoadFont(file_name: ARRAY OF CHAR): TFont
§ £à㧨âì èà¨äâ ¨§ ä ©«
file_name ¨¬ï kf-ä ©«
१-â: 㪠§ â¥«ì ­  èà¨äâ/NIL (®è¨¡ª )
PROCEDURE SetSize(Font: TFont; font_size: INTEGER): BOOLEAN
ãáâ ­®¢¨âì à §¬¥à èà¨äâ
Font 㪠§ â¥«ì ­  èà¨äâ
font_size à §¬¥à èà¨äâ
१-â: TRUE/FALSE (®è¨¡ª )
PROCEDURE Enabled(Font: TFont; font_size: INTEGER): BOOLEAN
¯à®¢¥à¨âì, ¥áâì «¨ èà¨äâ, § ¤ ­­®£® à §¬¥à
Font 㪠§ â¥«ì ­  èà¨äâ
font_size à §¬¥à èà¨äâ
१-â: TRUE/FALSE (èà¨äâ  ­¥â)
PROCEDURE Destroy(VAR Font: TFont)
¢ë£à㧨âì èà¨äâ, ®á¢®¡®¤¨âì ¤¨­ ¬¨ç¥áªãî ¯ ¬ïâì
Font 㪠§ â¥«ì ­  èà¨äâ
à¨á¢ ¨¢ ¥â ¯¥à¥¬¥­­®© Font §­ ç¥­¨¥ NIL
PROCEDURE TextHeight(Font: TFont): INTEGER
¯®«ãç¨âì ¢ëá®âã áâப¨ ⥪áâ
Font 㪠§ â¥«ì ­  èà¨äâ
१-â: ¢ëá®â  áâப¨ ⥪áâ  ¢ ¯¨ªá¥«ïå
PROCEDURE TextWidth(Font: TFont;
str, length, params: INTEGER): INTEGER
¯®«ãç¨âì è¨à¨­ã áâப¨ ⥪áâ
Font 㪠§ â¥«ì ­  èà¨äâ
str  ¤à¥á áâப¨ ⥪áâ  ¢ ª®¤¨à®¢ª¥ Win-1251
length ª®«¨ç¥á⢮ ᨬ¢®«®¢ ¢ áâப¥ ¨«¨ -1, ¥á«¨ áâப
§ ¢¥àè ¥âáï ­ã«¥¬
params ¯ à ¬¥âàë-ä« £¨ á¬. ­¨¦¥
१-â: è¨à¨­  áâப¨ ⥪áâ  ¢ ¯¨ªá¥«ïå
PROCEDURE TextOut(Font: TFont;
canvas, x, y, str, length, color, params: INTEGER)
¢ë¢¥á⨠⥪áâ ¢ ¡ãä¥à
¤«ï ¢ë¢®¤  ¡ãä¥à  ¢ ®ª­®, ¨á¯®«ì§®¢ âì ä.65 ¨«¨
ä.7 (¥á«¨ ¡ãä¥à 24-¡¨â­ë©)
Font 㪠§ â¥«ì ­  èà¨äâ
canvas  ¤à¥á £à ä¨ç¥áª®£® ¡ãä¥à
áâàãªâãà  ¡ãä¥à :
Xsize dd
Ysize dd
picture rb Xsize * Ysize * 4 (32 ¡¨â )
¨«¨ Xsize * Ysize * 3 (24 ¡¨â )
x, y ª®®à¤¨­ âë ⥪áâ  ®â­®á¨â¥«ì­® «¥¢®£® ¢¥àå­¥£®
㣫  ¡ãä¥à
str  ¤à¥á áâப¨ ⥪áâ  ¢ ª®¤¨à®¢ª¥ Win-1251
length ª®«¨ç¥á⢮ ᨬ¢®«®¢ ¢ áâப¥ ¨«¨ -1, ¥á«¨ áâப
§ ¢¥àè ¥âáï ­ã«¥¬
color 梥â ⥪áâ  0x00RRGGBB
params ¯ à ¬¥âàë-ä« £¨:
1 ¦¨à­ë©
2 ªãàᨢ
4 ¯®¤ç¥àª­ãâë©
8 ¯¥à¥ç¥àª­ãâë©
16 ¯à¨¬¥­¨âì ᣫ ¦¨¢ ­¨¥
32 ¢ë¢®¤ ¢ 32-¡¨â­ë© ¡ãä¥à
¢®§¬®¦­® ¨á¯®«ì§®¢ ­¨¥ ä« £®¢ ¢ «î¡ëå á®ç¥â ­¨ïå
------------------------------------------------------------------------------
MODULE RasterWorks - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ Rasterworks.obj
------------------------------------------------------------------------------
MODULE libimg - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ libimg.obj
------------------------------------------------------------------------------

/programs/develop/oberon07/Docs/Oberon07.report.fb2
0,0 → 1,693
<?xml encoding = "windows-1252"?>
<FictionBook xmlns:l="http://www.w3.org/1999/xlink" xmlns="http://www.gribuser.ru/xml/fictionbook/2.0">
<description></description>
<body>
<section><title><p>The Programming Language Oberon</p><p>Revision 22.9.2011</p><p>Niklaus Wirth</p></title>
<epigraph><p>Make it as simple as possible, but not simpler.</p><text-author>(A. Einstein)</text-author></epigraph>
<p>Table of Contents</p>
<empty-line/>
<p><a l:href="#1">1. Introduction</a></p>
<p><a l:href="#2">2. Syntax</a></p>
<p><a l:href="#3">3. Vocabulary</a></p>
<p><a l:href="#4">4. Declarations and scope rules</a></p>
<p><a l:href="#5">5. Constant declarations</a></p>
<p><a l:href="#6">6. Type declarations</a></p>
<p><a l:href="#7">7. Variable declarations</a></p>
<p><a l:href="#8">8. Expressions</a></p>
<p><a l:href="#9">9. Statements</a></p>
<p><a l:href="#10">10. Procedure declarations</a></p>
<p><a l:href="#11">11. Modules</a></p>
<p><a l:href="#app">Appendix: The Syntax of Oberon</a></p>
<section id="1"><title><p>1. Introduction</p></title>
<p>Oberon is a general-purpose programming language that evolved from Modula-2. Its principal new feature is the concept of type extension. It permits the construction of new data types on the basis of existing ones and to relate them.</p>
<p>This report is not intended as a programmer's tutorial. It is intentionally kept concise. Its function is to serve as a reference for programmers, implementors, and manual writers. What remains unsaid is mostly left so intentionally, either because it is derivable from stated rules of the language, or because it would unnecessarily restrict the freedom of implementors.</p>
<p>This document describes the language defined in 1988/90 as revised in 2007/11.</p>
</section>
<section id="2"><title><p>2. Syntax</p></title>
<p>A language is an infinite set of sentences, namely the sentences well formed according to its syntax. In Oberon, these sentences are called compilation units. Each unit is a finite sequence of <emphasis>symbols</emphasis> from a finite vocabulary. The vocabulary of Oberon consists of identifiers, numbers, strings, operators, delimiters, and comments. They are called <emphasis>lexical symbols</emphasis> and are composed of sequences of <emphasis>characters</emphasis>. (Note the distinction between symbols and characters.)</p>
<p>To describe the syntax, an extended Backus-Naur Formalism called EBNF is used. Brackets [ and ] denote optionality of the enclosed sentential form, and braces { and } denote its repetition (possibly 0 times). Syntactic entities (non-terminal symbols) are denoted by English words expressing their intuitive meaning. Symbols of the language vocabulary (terminal symbols) are denoted by strings enclosed in quote marks or by words in capital letters.</p>
</section>
<section id="3"><title><p>3. Vocabulary</p></title>
<p>The following lexical rules must be observed when composing symbols. Blanks and line breaks must not occur within symbols (except in comments, and blanks in strings). They are ignored unless they are essential to separate two consecutive symbols. Capital and lower-case letters are considered as being distinct.</p>
<p><emphasis>Identifiers</emphasis> are sequences of letters and digits. The first character must be a letter.</p>
<empty-line/>
<p><code> ident = letter {letter | digit}.</code></p>
<empty-line/>
<p>Examples:</p>
<empty-line/>
<p><code> x scan Oberon GetSymbol firstLetter</code></p>
<empty-line/>
<p><emphasis>Numbers</emphasis> are (unsigned) integers or real numbers. Integers are sequences of digits and may be followed by a suffix letter. If no suffix is specified, the representation is decimal. The suffix H indicates hexadecimal representation.</p>
<p>A <emphasis>real number</emphasis> always contains a decimal point. Optionally it may also contain a decimal scale factor. The letter E is pronounced as "times ten to the power of". A real number is of type REAL, unless it contains a scale factor with the letter D, in which case it is of type LONGREAL.</p>
<empty-line/>
<p><code> number = integer | real.</code></p>
<p><code> integer = digit {digit} | digit {hexDigit} "H".</code></p>
<p><code> real = digit {digit} "." {digit} [ScaleFactor].</code></p>
<p><code> ScaleFactor = ("E" | "D") ["+" | "-"] digit {digit}.</code></p>
<p><code> hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".</code></p>
<p><code> digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".</code></p>
<empty-line/>
<p>Examples:</p>
<empty-line/>
<p><code> 1987</code></p>
<p><code> 100H = 256</code></p>
<p><code> 12.3</code></p>
<p><code> 4.567E8 = 456700000</code></p>
<empty-line/>
<p><emphasis>Strings</emphasis> are sequences of characters enclosed in quote marks ("). A string cannot contain the delimiting quote mark. Alternatively, a single-character string may be specified by the ordinal number of the character in hexadecimal notation followed by an "X". The number of characters in a string is called the <emphasis>length</emphasis> of the string.</p>
<empty-line/>
<p><code> string = """ {character} """ | digit {hexdigit} "X" .</code></p>
<empty-line/>
<p>Examples:</p>
<empty-line/>
<p><code> "OBERON" "Don't worry!" 22X</code></p>
<empty-line/>
<p><emphasis>Operators</emphasis> and <emphasis>delimiters</emphasis> are the special characters, character pairs, or reserved words listed below. These reserved words consist exclusively of capital letters and cannot be used in the role of identifiers.</p>
<empty-line/>
<p><code> + := ARRAY IMPORT THEN</code></p>
<p><code> - ^ BEGIN IN TO</code></p>
<p><code> * = BY IS TRUE</code></p>
<p><code> / # CASE MOD TYPE</code></p>
<p><code> ~ &lt; CONST MODULE UNTIL</code></p>
<p><code> &amp; &gt; DIV NIL VAR</code></p>
<p><code> . &lt;= DO OF WHILE</code></p>
<p><code> , &gt;= ELSE OR</code></p>
<p><code> ; .. ELSIF POINTER</code></p>
<p><code> | : END PROCEDURE</code></p>
<p><code> ( ) FALSE RECORD</code></p>
<p><code> [ ] FOR REPEAT</code></p>
<p><code> { } IF RETURN</code></p>
<empty-line/>
<p><emphasis>Comments</emphasis> may be inserted between any two symbols in a program. They are arbitrary character sequences opened by the bracket (* and closed by *). Comments do not affect the meaning of a program. They may be nested.</p>
</section>
<section id="4"><title><p>4. Declarations and scope rules</p></title>
<p>Every identifier occurring in a program must be introduced by a declaration, unless it is a predefined identifier. Declarations also serve to specify certain permanent properties of an object, such as whether it is a constant, a type, a variable, or a procedure.</p>
<p>The identifier is then used to refer to the associated object. This is possible in those parts of a program only which are within the <emphasis>scope</emphasis> of the declaration. No identifier may denote more than one object within a given scope. The scope extends textually from the point of the declaration to the end of the block (procedure or module) to which the declaration belongs and hence to which the object is local. The scope rule has the following amendments:</p>
<p>1. If a type <emphasis>T</emphasis> is defined as POINTER TO T1 <a l:href="#6.4">(see 6.4)</a>, the identifier <emphasis>T1</emphasis> can be declared textually following the declaration of <emphasis>T</emphasis>, but it must lie within the same scope.</p>
<p>2. Field identifiers of a record declaration <a l:href="#6.3">(see 6.3)</a> are valid in field designators only.</p>
<p>In its declaration, an identifier in the global scope may be followed by an export mark (*) to indicate that it be <emphasis>exported</emphasis> from its declaring module. In this case, the identifier may be used in other modules, if they import the declaring module. The identifier is then prefixed by the identifier designating its module <a l:href="#11">(see Ch. 11)</a>. The prefix and the identifier are separated by a period and together are called a <emphasis>qualified identifier</emphasis>.</p>
<empty-line/>
<p><code> qualident = [ident "."] ident.</code></p>
<p><code> identdef = ident ["*"].</code></p>
<empty-line/>
<p>The following identifiers are predefined; their meaning is defined in section <a l:href="#6.1">6.1</a> (types) or <a l:href="#10.2">10.2</a> (procedures):</p>
<empty-line/>
<p><code> ABS ASR ASSERT BOOLEAN CHAR</code></p>
<p><code> CHR COPY DEC EXCL FLOOR</code></p>
<p><code> FLT INC INCL INTEGER LEN</code></p>
<p><code> LSL LONG LONGREAL NEW ODD</code></p>
<p><code> ORD PACK REAL ROR SET</code></p>
<p><code> SHORT UNPK</code></p>
</section>
<section id="5"><title><p>5. Constant declarations</p></title>
<p>A constant declaration associates an identifier with a constant value.</p>
<empty-line/>
<p><code> ConstantDeclaration = identdef "=" ConstExpression.</code></p>
<p><code> ConstExpression = expression.</code></p>
<empty-line/>
<p>A constant expression can be evaluated by a mere textual scan without actually executing the program. Its operands are constants <a l:href="#8">(see Ch. 8)</a>. Examples of constant declarations are:</p>
<empty-line/>
<p><code> N = 100</code></p>
<p><code> limit = 2*N - 1</code></p>
<p><code> all = {0 .. WordSize-1}</code></p>
<p><code> name = "Oberon"</code></p>
</section>
<section id="6"><title><p>6. Type declarations</p></title>
<p>A data type determines the set of values which variables of that type may assume, and the operators that are applicable. A type declaration is used to associate an identifier with a type. The types define the structure of variables of this type and, by implication, the operators that are applicable to components. There are two different structures, namely arrays and records, with different component selectors.</p>
<empty-line/>
<p><code> TypeDeclaration = identdef "=" StrucType.</code></p>
<p><code> StrucType = ArrayType | RecordType | PointerType | ProcedureType.</code></p>
<p><code> type = qualident | StrucType.</code></p>
<empty-line/>
<p>Examples:</p>
<empty-line/>
<p><code> Table = ARRAY N OF REAL</code></p>
<p><code> Tree = POINTER TO Node</code></p>
<p><code> Node = RECORD</code></p>
<p><code> key: INTEGER;</code></p>
<p><code> left, right: Tree</code></p>
<p><code> END</code></p>
<p><code> CenterNode = RECORD (Node)</code></p>
<p><code> name: ARRAY 32 OF CHAR;</code></p>
<p><code> subnode: Tree</code></p>
<p><code> END</code></p>
<p><code> Function = PROCEDURE (x: INTEGER): INTEGER</code></p>
<section id="6.1"><title><p>6.1. Basic types</p></title>
<p>The following basic types are denoted by predeclared identifiers. The associated operators are defined in <a l:href="#8.2">8.2</a>, and the predeclared function procedures in <a l:href="#10.2">10.2</a>. The values of a given basic type are the following:</p>
<empty-line/>
<p><code> BOOLEAN the truth values TRUE and FALSE</code></p>
<p><code> CHAR the characters of a standard character set</code></p>
<p><code> INTEGER the integers</code></p>
<p><code> REAL real numbers</code></p>
<p><code> LONGREAL real numbers</code></p>
<p><code> SET the sets of integers between 0 and 31</code></p>
<empty-line/>
<p>The type LONGREAL is intended to represent real numbers with a higher number of digits than REAL. However, the two types may be identical.</p>
</section>
<section id="6.2"><title><p>6.2. Array types</p></title>
<p>An array is a structure consisting of a fixed number of elements which are all of the same type, called the <emphasis>element type</emphasis>. The number of elements of an array is called its <emphasis>length</emphasis>. The elements of the array are designated by indices, which are integers between 0 and the length minus 1.</p>
<empty-line/>
<p><code> ArrayType = ARRAY length {"," length} OF type.</code></p>
<p><code> length = ConstExpression.</code></p>
<empty-line/>
<p>A declaration of the form</p>
<empty-line/>
<p><code> ARRAY N0, N1, ... , Nk OF T</code></p>
<p></p><empty-line/>is understood as an abbreviation of the declaration<empty-line/>
<p><code> ARRAY N0 OF</code></p>
<p><code> ARRAY N1 OF</code></p>
<p><code> ...</code></p>
<p><code> ARRAY Nk OF T</code></p>
<empty-line/>
<p>Examples of array types:</p>
<empty-line/>
<p><code> ARRAY N OF INTEGER</code></p>
<p><code> ARRAY 10, 20 OF REAL</code></p>
</section>
<section id="6.3"><title><p>6.3. Record types</p></title>
<p>A record type is a structure consisting of a fixed number of elements of possibly different types. The record type declaration specifies for each element, called <emphasis>field</emphasis>, its type and an identifier which denotes the field. The scope of these field identifiers is the record definition itself, but they are also visible within field designators <a l:href="#8.1">(see 8.1)</a> referring to elements of record variables.</p>
<empty-line/>
<p><code> RecordType = RECORD ["(" BaseType ")"] [FieldListSequence] END.</code></p>
<p><code> BaseType = qualident.</code></p>
<p><code> FieldListSequence = FieldList {";" FieldList}.</code></p>
<p><code> FieldList = IdentList ":" type.</code></p>
<p><code> IdentList = identdef {"," identdef}.</code></p>
<empty-line/>
<p>If a record type is exported, field identifiers that are to be visible outside the declaring module must be marked. They are called <emphasis>public fields</emphasis>; unmarked fields are called <emphasis>private fields</emphasis>.</p>
<p>Record types are extensible, i.e. a record type can be defined as an extension of another record type. In the examples above, <emphasis>CenterNode</emphasis> (directly) extends <emphasis>Node</emphasis>, which is the (direct) base type of <emphasis>CenterNode</emphasis>. More specifically, <emphasis>CenterNode</emphasis> extends <emphasis>Node</emphasis> with the fields <emphasis>name</emphasis> and <emphasis>subnode</emphasis>.</p>
<p><emphasis>Definition</emphasis>: A type <emphasis>T</emphasis> extends a type <emphasis>T0</emphasis>, if it equals <emphasis>T0</emphasis>, or if it directly extends an extension of <emphasis>T0</emphasis>. Conversely, a type <emphasis>T0</emphasis> is a base type of <emphasis>T</emphasis>, if it equals <emphasis>T</emphasis>, or if it is the direct base type of a base type of <emphasis>T</emphasis>.</p>
<p>Examples of record types:</p>
<empty-line/>
<p><code> RECORD day, month, year: INTEGER</code></p>
<p><code> END</code></p>
<p><code> RECORD</code></p>
<p><code> name, firstname: ARRAY 32 OF CHAR;</code></p>
<p><code> age: INTEGER;</code></p>
<p><code> salary: REAL</code></p>
<p><code> END</code></p>
</section>
<section id="6.4"><title><p>6.4. Pointer types</p></title>
<p>Variables of a pointer type <emphasis>P</emphasis> assume as values pointers to variables of some type <emphasis>T</emphasis>. It must be a record type. The pointer type <emphasis>P</emphasis> is said to be <emphasis>bound to T</emphasis>, and <emphasis>T</emphasis> is the <emphasis>pointer base type of P</emphasis>. Pointer types inherit the extension relation of their base types, if there is any. If a type <emphasis>T</emphasis> is an extension of <emphasis>T0</emphasis> and <emphasis>P</emphasis> is a pointer type bound to <emphasis>T</emphasis>, then <emphasis>P</emphasis> is also an extension of <emphasis>P0, the pointer type bound to T0</emphasis>.</p>
<empty-line/>
<p><code> PointerType = POINTER TO type.</code></p>
<empty-line/>
<p>If <emphasis>p</emphasis> is a variable of type P = POINTER TO T, then a call of the predefined procedure NEW(p) has the following effect <a l:href="#10.2">(see 10.2)</a>: A variable of type <emphasis>T</emphasis> is allocated in free storage, and a pointer to it is assigned to <emphasis>p</emphasis>. This pointer <emphasis>p</emphasis> is of type <emphasis>P</emphasis> and the referenced variable <emphasis>p^</emphasis> is of type <emphasis>T</emphasis>. Failure of allocation results in <emphasis>p</emphasis> obtaining the value <emphasis>NIL</emphasis>. Any pointer variable may be assigned the value <emphasis>NIL</emphasis>, which points to no variable at all.</p>
</section>
<section id="6.5"><title><p>6.5. Procedure types</p></title>
<p>Variables of a procedure type <emphasis>T</emphasis> have a procedure (or NIL) as value. If a procedure <emphasis>P</emphasis> is assigned to a procedure variable of type <emphasis>T</emphasis>, the (types of the) formal parameters of <emphasis>P</emphasis> must be the same as those indicated in the formal parameters of <emphasis>T</emphasis>. The same holds for the result type in the case of a function procedure <a l:href="#10.1">(see 10.1)</a>. <emphasis>P</emphasis> must not be declared local to another procedure, and neither can it be a standard procedure.</p>
<empty-line/>
<p><code> ProcedureType = PROCEDURE [FormalParameters].</code></p>
</section>
</section>
<section id="7"><title><p>7. Variable declarations</p></title>
<p>Variable declarations serve to introduce variables and associate them with identifiers that must be unique within the given scope. They also serve to associate fixed data types with the variables.</p>
<empty-line/>
<p><code> VariableDeclaration = IdentList ":" type.</code></p>
<empty-line/>
<p>Variables whose identifiers appear in the same list are all of the same type. Examples of variable declarations (refer to examples in <a l:href="#6">Ch. 6</a>):</p>
<empty-line/>
<p><code> i, j, k: INTEGER</code></p>
<p><code> x, y: REAL</code></p>
<p><code> p, q: BOOLEAN</code></p>
<p><code> s: SET</code></p>
<p><code> f: Function</code></p>
<p><code> a: ARRAY 100 OF REAL</code></p>
<p><code> w: ARRAY 16 OF</code></p>
<p><code> RECORD</code></p>
<p><code> ch: CHAR;</code></p>
<p><code> count: INTEGER</code></p>
<p><code> END</code></p>
<p><code> t: Tree</code></p>
</section>
<section id="8"><title><p>8. Expressions</p></title>
<p>Expressions are constructs denoting rules of computation whereby constants and current values of variables are combined to derive other values by the application of operators and function procedures. Expressions consist of operands and operators. Parentheses may be used to express specific associations of operators and operands.</p>
<section id="8.1"><title><p>8.1. Operands</p></title>
<p>With the exception of sets and literal constants, i.e. numbers and strings, operands are denoted by <emphasis>designators</emphasis>. A designator consists of an identifier referring to the constant, variable, or procedure to be designated. This identifier may possibly be qualified by module identifiers <a l:href="#4">(see Ch. 4</a> and <a l:href="#11">11)</a>, and it may be followed by selectors, if the designated object is an element of a structure.</p>
<p>If A designates an array, then <emphasis>A[E]</emphasis> denotes that element of <emphasis>A</emphasis> whose index is the current value of the expression <emphasis>E</emphasis>. The type of <emphasis>E</emphasis> must be of type INTEGER. A designator of the form <emphasis>A[E1, E2, ..., En]</emphasis> stands for <emphasis>A[E1][E2] ... [En]</emphasis>. If <emphasis>p</emphasis> designates a pointer variable, <emphasis>p^</emphasis> denotes the variable which is referenced by <emphasis>p</emphasis>. If <emphasis>r</emphasis> designates a record, then <emphasis>r.f</emphasis> denotes the field <emphasis>f</emphasis> of <emphasis>r</emphasis>. If <emphasis>p</emphasis> designates a pointer, <emphasis>p.f</emphasis> denotes the field <emphasis>f</emphasis> of the record <emphasis>p^</emphasis>, i.e. the dot implies dereferencing and <emphasis>p.f</emphasis> stands for <emphasis>p^.f</emphasis>.</p>
<p>The <emphasis>typeguard v(T0)</emphasis> asserts that <emphasis>v</emphasis> is of type <emphasis>T0</emphasis>, i.e. it aborts program execution, if it is not of type <emphasis>T0</emphasis>. The guard is applicable, if</p>
<p>1. <emphasis>T0</emphasis> is an extension of the declared type <emphasis>T</emphasis> of <emphasis>v</emphasis>, and if</p>
<p>2. <emphasis>v</emphasis> is a variable parameter of record type, or <emphasis>v</emphasis> is a pointer.</p>
<empty-line/>
<p><code> designator = qualident {selector}.</code></p>
<p><code> selector = "." ident | "[" ExpList "]" | "^" | "(" qualident ")".</code></p>
<p><code> ExpList = expression {"," expression}.</code></p>
<empty-line/>
<p>If the designated object is a variable, then the designator refers to the variable's current value. If the object is a procedure, a designator without parameter list refers to that procedure. If it is followed by a (possibly empty) parameter list, the designator implies an activation of the procedure and stands for the value resulting from its execution. The (types of the) actual parameters must correspond to the formal parameters as specified in the procedure's declaration <a l:href="#10">(see Ch. 10)</a>.</p>
<p>Examples of designators <a l:href="#7">(see examples in Ch. 7)</a>:</p>
<empty-line/>
<p><code> i (INTEGER)</code></p>
<p><code> a[i] (REAL)</code></p>
<p><code> w[3].ch (CHAR)</code></p>
<p><code> t.key (INTEGER)</code></p>
<p><code> t.left.right (Tree)</code></p>
<p><code> t(CenterNode).subnode (Tree)</code></p>
</section>
<section id="8.2"><title><p>8.2. Operators</p></title>
<p>The syntax of expressions distinguishes between four classes of operators with different precedences (binding strengths). The operator ~ has the highest precedence, followed by multiplication operators, addition operators, and relations. Operators of the same precedence associate from left to right. For example, <emphasis>x-y-z</emphasis> stands for <emphasis>(x-y)-z</emphasis>.</p>
<empty-line/>
<p><code> expression = SimpleExpression [relation SimpleExpression].</code></p>
<p><code> relation = "=" | "#" | "&lt;" | "&lt;=" | "&gt;" | "&gt;=" | IN | IS.</code></p>
<p><code> SimpleExpression = ["+"|"-"] term {AddOperator term}.</code></p>
<p><code> AddOperator = "+" | "-" | OR.</code></p>
<p><code> term = factor {MulOperator factor}.</code></p>
<p><code> MulOperator = "*" | "/" | DIV | MOD | "&amp;" .</code></p>
<p><code> factor = number | string | NIL | TRUE | FALSE |</code></p>
<p><code> set | designator [ActualParameters] | "(" expression ")" | "~" factor.</code></p>
<p><code> set = "{" [element {"," element}] "}".</code></p>
<p><code> element = expression [".." expression].</code></p>
<p><code> ActualParameters = "(" [ExpList] ")" .</code></p>
<empty-line/>
<p>The available operators are listed in the following tables. In some instances, several different operations are designated by the same operator symbol. In these cases, the actual operation is identified by the type of the operands.</p>
<section id="8.2.1"><title><p><emphasis>8.2.1. Logical operators</emphasis></p></title>
<p><code> symbol result</code></p>
<empty-line/>
<p><code> OR logical disjunction</code></p>
<p><code> &amp; logical conjunction</code></p>
<p><code> ~ negation</code></p>
<empty-line/>
<p>These operators apply to BOOLEAN operands and yield a BOOLEAN result.</p>
<empty-line/>
<p><code> p OR q stands for "if p then TRUE, else q"</code></p>
<p><code> p &amp; q stands for "if p then q, else FALSE"</code></p>
<p><code> ~ p stands for "not p"</code></p>
</section>
<section id="8.2.2"><title><p><emphasis>8.2.2. Arithmetic operators</emphasis></p></title>
<p><code> symbol result</code></p>
<empty-line/>
<p><code> + sum</code></p>
<p><code> - difference</code></p>
<p><code> * product</code></p>
<p><code> / quotient</code></p>
<p><code> DIV integer quotient</code></p>
<p><code> MOD modulus</code></p>
<empty-line/>
<p>The operators +, -, *, and / apply to operands of numeric types. Both operands must be of the same type, which is also the type of the result. When used as unary operators, - denotes sign inversion and + denotes the identity operation.</p>
<p>The operators DIV and MOD apply to integer operands only. Let q = x DIV y, and r = x MOD y. Then quotient <emphasis>q</emphasis> and remainder <emphasis>r</emphasis> are defined by the equation</p>
<empty-line/>
<p><code> x = q*y + r 0 &lt;= r &lt; y</code></p>
</section>
<section id="8.2.3"><title><p><emphasis>8.2.3. Set operators</emphasis></p></title>
<p><code> symbol result</code></p>
<empty-line/>
<p><code> + union</code></p>
<p><code> - difference</code></p>
<p><code> * intersection</code></p>
<p><code> / symmetric set difference</code></p>
<empty-line/>
<p>When used with a single operand of type SET, the minus sign denotes the set complement.</p>
</section>
<section id="8.2.4"><title><p><emphasis>8.2.4. Relations</emphasis></p></title>
<p><code> symbol relation</code></p>
<empty-line/>
<p><code> = equal</code></p>
<p><code> # unequal</code></p>
<p><code> &lt; less</code></p>
<p><code> &lt;= less or equal</code></p>
<p><code> &gt; greater</code></p>
<p><code> &gt;= greater or equal</code></p>
<p><code> IN set membership</code></p>
<p><code> IS type test</code></p>
<empty-line/>
<p>Relations are Boolean. The ordering relations &lt;, &lt;=, &gt;, &gt;= apply to the numeric types, CHAR, and character arrays. The relations = and # also apply to the types BOOLEAN and SET, and to pointer and procedure types. The relations &lt;= and &gt;= denote inclusion when applied to sets.</p>
<p><emphasis>x IN s</emphasis> stands for "x is an element of s". <emphasis>x</emphasis> must be of type INTEGER, and <emphasis>s</emphasis> of type SET.</p>
<p><emphasis>v IS T</emphasis> stands for "v is of type T" and is called a <emphasis>type test</emphasis>. It is applicable, if</p>
<p>1. T is an extension of the declared type T0 of v, and if</p>
<p>2. v is a variable parameter of record type or v is a pointer.</p>
<p>Assuming, for instance, that T is an extension of T0 and that v is a designator declared of type T0, then the test <emphasis>v IS T</emphasis> determines whether the actually designated variable is (not only a T0, but also) a T. The value of <emphasis>NIL IS T</emphasis> is undefined.</p>
<p>Examples of expressions (refer to examples in <a l:href="#7">Ch. 7</a>):</p>
<empty-line/>
<p><code> 1987 (INTEGER)</code></p>
<p><code> i DIV 3 (INTEGER)</code></p>
<p><code> ~p OR q (BOOLEAN)</code></p>
<p><code> (i+j) * (i-j) (INTEGER)</code></p>
<p><code> s - {8, 9, 13} (SET)</code></p>
<p><code> a[i+j] * a[i-j] (REAL)</code></p>
<p><code> (0&lt;=i) &amp; (i&lt;100) (BOOLEAN)</code></p>
<p><code> t.key = 0 (BOOLEAN)</code></p>
<p><code> k IN {i .. j-1} (BOOLEAN)</code></p>
<p><code> t IS CenterNode (BOOLEAN)</code></p>
</section>
</section>
</section>
<section id="9"><title><p>9. Statements</p></title>
<p>Statements denote actions. There are elementary and structured statements. Elementary statements are not composed of any parts that are themselves statements. They are the assignment and the procedure call. Structured statements are composed of parts that are themselves statements. They are used to express sequencing and conditional, selective, and repetitive execution. A statement may also be empty, in which case it denotes no action. The empty statement is included in order to relax punctuation rules in statement sequences.</p>
<empty-line/>
<p><code> statement = [assignment | ProcedureCall | IfStatement | CaseStatement |</code></p>
<p><code> WhileStatement | RepeatStatement | ForStatement].</code></p>
<section id="9.1"><title><p>9.1. Assignments</p></title>
<p>The assignment serves to replace the current value of a variable by a new value specified by an expression. The assignment operator is written as ":=" and pronounced as <emphasis>becomes</emphasis>.</p>
<empty-line/>
<p><code> assignment = designator ":=" expression.</code></p>
<empty-line/>
<p>If a value parameter is structured (of array or record type), no assignment to it or to its elements are permitted. Neither may assignments be made to imported variables.</p>
<p>The type of the expression must be the same as that of the designator. The following exceptions hold:</p>
<p>1. The constant NIL can be assigned to variables of any pointer or procedure type.</p>
<p>2. Strings can be assigned to any array of characters, provided the number of characters in the string is not greater than that of the array. If it is less, a null character (0X) is appended. Singlecharacter strings can also be assigned to variables of type CHAR.</p>
<p>3. In the case of records, the type of the source must be an extension of the type of the destination. Examples of assignments <a l:href="#7">(see examples in Ch. 7)</a>:</p>
<empty-line/>
<p><code> i := 0</code></p>
<p><code> p := i = j</code></p>
<p><code> x := FLT(i + 1)</code></p>
<p><code> k := (i + j) DIV 2</code></p>
<p><code> f := log2</code></p>
<p><code> s := {2, 3, 5, 7, 11, 13}</code></p>
<p><code> a[i] := (x+y) * (x-y)</code></p>
<p><code> t.key := i</code></p>
<p><code> w[i+1].ch := "A"</code></p>
</section>
<section id="9.2"><title><p>9.2. Procedure calls</p></title>
<p>A procedure call serves to activate a procedure. The procedure call may contain a list of actual parameters which are substituted in place of their corresponding formal parameters defined in the procedure declaration <a l:href="#10">(see Ch. 10)</a>. The correspondence is established by the positions of the parameters in the lists of actual and formal parameters respectively. There exist two kinds of parameters: <emphasis>variable</emphasis> and <emphasis>value</emphasis> parameters.</p>
<p>In the case of variable parameters, the actual parameter must be a designator denoting a variable. If it designates an element of a structured variable, the selector is evaluated when the formal/actual parameter substitution takes place, i.e. before the execution of the procedure. If the parameter is a value parameter, the corresponding actual parameter must be an expression. This expression is evaluated prior to the procedure activation, and the resulting value is assigned to the formal parameter which now constitutes a local variable <a l:href="#10.1">(see also 10.1.)</a>.</p>
<empty-line/>
<p><code> ProcedureCall = designator [ActualParameters].</code></p>
<empty-line/>
<p>Examples of procedure calls:</p>
<empty-line/>
<p><code> ReadInt(i) <a l:href="#10">(see Ch. 10)</a></code></p>
<p><code> WriteInt(2*j + 1, 6)</code></p>
<p><code> INC(w[k].count)</code></p>
</section>
<section id="9.3"><title><p>9.3. Statement sequences</p></title>
<p>Statement sequences denote the sequence of actions specified by the component statements which are separated by semicolons.</p>
<empty-line/>
<p><code> StatementSequence = statement {";" statement}.</code></p>
</section>
<section id="9.4"><title><p>9.4. If statements</p></title>
<p><code> IfStatement = IF expression THEN StatementSequence</code></p>
<p><code> {ELSIF expression THEN StatementSequence}</code></p>
<p><code> [ELSE StatementSequence]</code></p>
<p><code> END.</code></p>
<empty-line/>
<p>If statements specify the conditional execution of guarded statements. The Boolean expression preceding a statement is called its <emphasis>guard</emphasis>. The guards are evaluated in sequence of occurrence, until one evaluates to TRUE, whereafter its associated statement sequence is executed. If no guard is satisfied, the statement sequence following the symbol ELSE is executed, if there is one.</p>
<p>Example:</p>
<empty-line/>
<p><code> IF (ch &gt;= "A") &amp; (ch &lt;= "Z") THEN ReadIdentifier</code></p>
<p><code> ELSIF (ch &gt;= "0") &amp; (ch &lt;= "9") THEN ReadNumber</code></p>
<p><code> ELSIF ch = 22X THEN ReadString</code></p>
<p><code> END</code></p>
</section>
<section id="9.5"><title><p>9.5. Case statements</p></title>
<p>Case statements specify the selection and execution of a statement sequence according to the value of an expression. First the case expression is evaluated, then the statement sequence is executed whose case label list contains the obtained value. The case expression must be of type INTEGER or CHAR, and all labels must be integers or single-character strings, respectively.</p>
<empty-line/>
<p><code> CaseStatement = CASE expression OF case {"|" case} END.</code></p>
<p><code> case = [CaseLabelList ":" StatementSequence].</code></p>
<p><code> CaseLabelList = LabelRange {"," LabelRange}.</code></p>
<p><code> LabelRange = label [".." label].</code></p>
<p><code> label = integer | string | ident.</code></p>
<empty-line/>
<p>Example:</p>
<empty-line/>
<p><code> CASE k OF</code></p>
<p><code> 0: x := x + y</code></p>
<p><code> | 1: x := x - y</code></p>
<p><code> | 2: x := x * y</code></p>
<p><code> | 3: x := x / y</code></p>
<p><code> END</code></p>
</section>
<section id="9.6"><title><p>9.6. While statements</p></title>
<p>While statements specify repetition. If any of the Boolean expressions (guards) yields TRUE, the corresponding statement sequence is executed. The expression evaluation and the statement execution are repeated until none of the Boolean expressions yields TRUE.</p>
<empty-line/>
<p><code> WhileStatement = WHILE expression DO StatementSequence</code></p>
<p><code> {ELSIF expression DO StatementSequence} END.</code></p>
<empty-line/>
<p>Examples:</p>
<empty-line/>
<p><code> WHILE j &gt; 0 DO</code></p>
<p><code> j := j DIV 2; i := i+1</code></p>
<p><code> END</code></p>
<p><code> WHILE (t # NIL) &amp; (t.key # i) DO</code></p>
<p><code> t := t.left</code></p>
<p><code> END</code></p>
<p><code> WHILE m &gt; n DO m := m - n</code></p>
<p><code> ELSIF n &gt; m DO n := n - m</code></p>
<p><code> END</code></p>
</section>
<section id="9.7"><title><p>9.7. Repeat Statements</p></title>
<p>A repeat statement specifies the repeated execution of a statement sequence until a condition is satisfied. The statement sequence is executed at least once.</p>
<empty-line/>
<p><code> RepeatStatement = REPEAT StatementSequence UNTIL expression.</code></p>
</section>
<section id="9.8"><title><p>9.8. For statements</p></title>
<p>A for statement specifies the repeated execution of a statement sequence for a given number of times, while a progression of values is assigned to an integer variable called the <emphasis>control variable</emphasis> of the for statement.</p>
<empty-line/>
<p><code> ForStatement =</code></p>
<p><code> FOR ident ":=" expression TO expression [BY ConstExpression] DO</code></p>
<p><code> StatementSequence END .</code></p>
<empty-line/>
<p>The for statement</p>
<empty-line/>
<p><code> FOR v := beg TO end BY inc DO S END</code></p>
<empty-line/>
<empty-line/>is, if <emphasis>inc</emphasis> &gt; 0, equivalent to
<empty-line/>
<p><code> v := beg; lim := end;</code></p>
<p><code> WHILE v &lt;= lim DO S; v := v + inc END</code></p>
<empty-line/>
<empty-line/>and if <emphasis>inc</emphasis> &lt; 0 it is equivalent to
<empty-line/>
<p><code> v := beg; lim := end;</code></p>
<p><code> WHILE v &gt;= lim DO S; v := v + inc END</code></p>
<empty-line/>
<p>The types of <emphasis>v</emphasis>, <emphasis>beg</emphasis> and <emphasis>end</emphasis> must be INTEGER, and <emphasis>inc</emphasis> must be an integer (constant expression). If the step is not specified, it is assumed to be 1.</p>
</section>
</section>
<section id="10"><title><p>10. Procedure declarations</p></title>
<p>Procedure declarations consist of a procedure heading and a procedure body. The heading specifies the procedure identifier, the formal parameters, and the result type (if any). The body contains declarations and statements. The procedure identifier is repeated at the end of the procedure declaration.</p>
<p>There are two kinds of procedures, namely proper procedures and function procedures. The latter are activated by a function designator as a constituent of an expression, and yield a result that is an operand in the expression. Proper procedures are activated by a procedure call. A function procedure is distinguished in the declaration by indication of the type of its result following the parameter list. Its body must end with a RETURN clause which defines the result of the function procedure.</p>
<p>All constants, variables, types, and procedures declared within a procedure body are local to the procedure. The values of local variables are undefined upon entry to the procedure. Since procedures may be declared as local objects too, procedure declarations may be nested.</p>
<p>In addition to its formal parameters and locally declared objects, the objects declared in the environment of the procedure are also visible in the procedure (with the exception of variables and of those objects that have the same name as an object declared locally).</p>
<p>The use of the procedure identifier in a call within its declaration implies recursive activation of the procedure.</p>
<empty-line/>
<p><code> ProcedureDeclaration = ProcedureHeading ";" ProcedureBody ident.</code></p>
<p><code> ProcedureHeading = PROCEDURE identdef [FormalParameters].</code></p>
<p><code> ProcedureBody = DeclarationSequence [BEGIN StatementSequence]</code></p>
<p><code> [RETURN expression] END.</code></p>
<p><code> DeclarationSequence = [CONST {ConstantDeclaration ";"}]</code></p>
<p><code> [TYPE {TypeDeclaration ";"}] [VAR {VariableDeclaration ";"}]</code></p>
<p><code> {ProcedureDeclaration ";"}.</code></p>
<section id="10.1"><title><p>10.1. Formal parameters</p></title>
<p>Formal parameters are identifiers which denote actual parameters specified in the procedure call. The correspondence between formal and actual parameters is established when the procedure is called. There are two kinds of parameters, namely <emphasis>value</emphasis> and <emphasis>variable</emphasis> parameters. A variable parameter corresponds to an actual parameter that is a variable, and it stands for that variable. A value parameter corresponds to an actual parameter that is an expression, and it stands for its value, which cannot be changed by assignment. However, if a value parameter is of a scalar type, it represents a local variable to which the value of the actual expression is initially assigned.</p>
<p>The kind of a parameter is indicated in the formal parameter list: Variable parameters are denoted by the symbol VAR and value parameters by the absence of a prefix.</p>
<p>A function procedure without parameters must have an empty parameter list. It must be called by a function designator whose actual parameter list is empty too.</p>
<p>Formal parameters are local to the procedure, i.e. their scope is the program text which constitutes the procedure declaration.</p>
<empty-line/>
<p><code> FormalParameters = "(" [FPSection {";" FPSection}] ")" [":" qualident].</code></p>
<p><code> FPSection = [VAR] ident {"," ident} ":" FormalType.</code></p>
<p><code> FormalType = {ARRAY OF} qualident.</code></p>
<empty-line/>
<p>The type of each formal parameter is specified in the parameter list. For variable parameters, it must be identical to the corresponding actual parameter's type, except in the case of a record, where it must be a base type of the corresponding actual parameter's type.</p>
<p>If the formal parameter's type is specified as</p>
<empty-line/>
<p><code> ARRAY OF T</code></p>
<empty-line/>
<empty-line/>the parameter is said to be an <emphasis>open array</emphasis>, and the corresponding actual parameter may be of arbitrary length.
<p>If a formal parameter specifies a procedure type, then the corresponding actual parameter must be either a procedure declared globally, or a variable (or parameter) of that procedure type. It cannot be a predefined procedure. The result type of a procedure can be neither a record nor an array.</p>
<p>Examples of procedure declarations:</p>
<empty-line/>
<p><code> PROCEDURE ReadInt(VAR x: INTEGER);</code></p>
<p><code> VAR i : INTEGER; ch: CHAR;</code></p>
<p><code> BEGIN i := 0; Read(ch);</code></p>
<p><code> WHILE ("0" &lt;= ch) &amp; (ch &lt;= "9") DO</code></p>
<p><code> i := 10*i + (ORD(ch)-ORD("0")); Read(ch)</code></p>
<p><code> END ;</code></p>
<p><code> x := i</code></p>
<p><code> END ReadInt</code></p>
<empty-line/>
<p><code> PROCEDURE WriteInt(x: INTEGER); (* 0 &lt;= x &lt; 10^5 *)</code></p>
<p><code> VAR i: INTEGER;</code></p>
<p><code> buf: ARRAY 5 OF INTEGER;</code></p>
<p><code> BEGIN i := 0;</code></p>
<p><code> REPEAT buf[i] := x MOD 10; x := x DIV 10; INC(i) UNTIL x = 0;</code></p>
<p><code> REPEAT DEC(i); Write(CHR(buf[i] + ORD("0"))) UNTIL i = 0</code></p>
<p><code> END WriteInt</code></p>
<empty-line/>
<p><code> PROCEDURE log2(x: INTEGER): INTEGER;</code></p>
<p><code> VAR y: INTEGER; (*assume x&gt;0*)</code></p>
<p><code> BEGIN y := 0;</code></p>
<p><code> WHILE x &gt; 1 DO x := x DIV 2; INC(y) END ;</code></p>
<p><code> RETURN y</code></p>
<p><code> END log2</code></p>
</section>
<section id="10.2"><title><p>10.2. Predefined procedures</p></title>
<p>The following table lists the predefined procedures. Some are generic procedures, i.e. they apply to several types of operands. v stands for a variable, x and n for expressions, and T for a type.</p>
<empty-line/>
<p><code> <emphasis>Function procedures:</emphasis></code></p>
<empty-line/>
<p><code> Name Argument type Result type Function</code></p>
<empty-line/>
<p><code> ABS(x) numeric type type of x absolute value</code></p>
<p><code> ODD(x) INTEGER BOOLEAN x MOD 2 = 1</code></p>
<p><code> LEN(v) v: array INTEGER the length of v</code></p>
<p><code> LSL(x, n) x, n: INTEGER type of x logical shift left, x * 2<sup>n</sup></code></p>
<p><code> ASR(x, n) x, n: INTEGER type of x signed shift right, x DIV 2<sup>n</sup></code></p>
<p><code> ROR(x, n) x. n: INTEGER type of x x rotated right by n bits</code></p>
<empty-line/>
<p><code> <emphasis>Type conversion functions:</emphasis></code></p>
<empty-line/>
<p><code> Name Argument type Result type Function</code></p>
<empty-line/>
<p><code> FLOOR(x) REAL, LONGREAL INTEGER largest integer &lt;= x</code></p>
<p><code> FLT(x) INTEGER REAL identity</code></p>
<p><code> ORD(x) CHAR, BOOLEAN, SET INTEGER ordinal number of x</code></p>
<p><code> CHR(x) INTEGER CHAR character with ordinal number x</code></p>
<p><code> LONG(x) REAL LONGREAL x</code></p>
<p><code> SHORT(x) LONGREAL REAL x</code></p>
<empty-line/>
<p><code> <emphasis>Proper procedures:</emphasis></code></p>
<empty-line/>
<p><code> Name Argument types Function</code></p>
<empty-line/>
<p><code> INC(v) INTEGER v := v + 1</code></p>
<p><code> INC(v, n) INTEGER v := v + n</code></p>
<p><code> DEC(v) INTEGER v := v - 1</code></p>
<p><code> DEC(v, n) INTEGER v := v - n</code></p>
<p><code> INCL(v, x) v: SET; x: INTEGER v := v + {x}</code></p>
<p><code> EXCL(v, x) v: SET; x: INTEGER v := v - {x}</code></p>
<p><code> COPY(x, v) x: character array, string v := x</code></p>
<p><code> v: character array</code></p>
<p><code> NEW(v) pointer type allocate v^</code></p>
<p><code> ASSERT(b) BOOLEAN abort, if ~b</code></p>
<p><code> ASSERT(b, n) BOOLEAN, INTEGER</code></p>
<p><code> PACK(x, y) REAL; INTEGER pack x and y into x</code></p>
<p><code> UNPK(x, y) REAL; INTEGER unpack x into x and y</code></p>
<empty-line/>
<p>Procedures INC and DEC may have an explicit increment or decrement. It must be a constant. Also for INCL and EXCL, <emphasis>x</emphasis> must be a constant. The second parameter <emphasis>n</emphasis> of ASSERT is a value transmitted to the system as an abort parameter.</p>
<p>The parameter <emphasis>y</emphasis> of PACK represents the exponent of <emphasis>x</emphasis>. PACK(x, y) is equivalent to x := x * 2<sup>y</sup>. UNPK is the reverse operation of PACK. The resulting <emphasis>x</emphasis> is normalized, i.e. 1.0 &lt;= x &lt; 2.0.</p>
</section>
</section>
<section id="11"><title><p>11. Modules</p></title>
<p>A module is a collection of declarations of constants, types, variables, and procedures, and a sequence of statements for the purpose of assigning initial values to the variables. A module typically constitutes a text that is compilable as a unit.</p>
<empty-line/>
<p><code> module = MODULE ident ";" [ImportList ";"] DeclarationSequence</code></p>
<p><code> [BEGIN StatementSequence] END ident "." .</code></p>
<p><code> ImportList = IMPORT import {"," import} ";" .</code></p>
<p><code> Import = ident [":=" ident].</code></p>
<empty-line/>
<p>The import list specifies the modules of which the module is a client. If an identifier x is exported from a module M, and if M is listed in a module's import list, then x is referred to as M.x. If the form "M := M1" is used in the import list, an exported object x declared within M1 is referenced in the importing module as M.x .</p>
<p>Identifiers that are to be visible in client modules, i.e. which are to be exported, must be marked by an asterisk (export mark) in their declaration. Variables cannot be exported, with the exception of those of scalar types in read-only mode.</p>
<p>The statement sequence following the symbol BEGIN is executed when the module is added to a system (loaded). Individual (parameterless) procedures can thereafter be activated from the system, and these procedures serve as commands.</p>
<p>Example:</p>
<empty-line/>
<p><code> MODULE Out; (*exported procedures: Write, WriteInt, WriteLn*)</code></p>
<p><code> IMPORT Texts, Oberon;</code></p>
<p><code> VAR W: Texts.Writer;</code></p>
<empty-line/>
<p><code> PROCEDURE Write*(ch: CHAR);</code></p>
<p><code> BEGIN Texts.Write(W, ch)</code></p>
<p><code> END ;</code></p>
<empty-line/>
<p><code> PROCEDURE WriteInt*(x, n: INTEGER);</code></p>
<p><code> VAR i: INTEGER; a: ARRAY 16 OF CHAR;</code></p>
<p><code> BEGIN i := 0;</code></p>
<p><code> IF x &lt; 0 THEN Texts.Write(W, "-"); x := -x END ;</code></p>
<p><code> REPEAT a[i] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(i) UNTIL x = 0;</code></p>
<p><code> REPEAT Texts.Write(W, " "); DEC(n) UNTIL n &lt;= i;</code></p>
<p><code> REPEAT DEC(i); Texts.Write(W, a[i]) UNTIL i = 0</code></p>
<p><code> END WriteInt;</code></p>
<empty-line/>
<p><code> PROCEDURE WriteLn*;</code></p>
<p><code> BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)</code></p>
<p><code> END WriteLn;</code></p>
<empty-line/>
<p><code> BEGIN Texts.OpenWriter(W)</code></p>
<p><code> END Out.</code></p>
<section id="11.1"><title><p>11.1 The Module SYSTEM</p></title>
<p>The optional module SYSTEM contains definitions that are necessary to program low-level operations referring directly to resources particular to a given computer and/or implementation. These include for example facilities for accessing devices that are controlled by the computer, and perhaps facilities to break the data type compatibility rules otherwise imposed by the language definition. It is strongly recommended to restrict their use to specific low-level modules, as such modules are inherently non-portable and not "type-safe". However, they are easily recognized due to the identifier SYSTEM appearing in their import lists. The subsequent definitions are generally applicable. However, individual implementations may include in their module SYSTEM additional definitions that are particular to the specific, underlying computer. In the following, <emphasis>v</emphasis> stands for a variable, <emphasis>x</emphasis>, <emphasis>a</emphasis>, and <emphasis>n</emphasis> for expressions.</p>
<empty-line/>
<p><code> <emphasis>Function procedures:</emphasis></code></p>
<empty-line/>
<p><code> Name Argument types Result type Function</code></p>
<empty-line/>
<p><code> ADR(v) any INTEGER address of variable v</code></p>
<p><code> SIZE(T) any type INTEGER size in bytes</code></p>
<p><code> BIT(a, n) a, n: INTEGER BOOLEAN bit n of mem[a]</code></p>
<empty-line/>
<p><code> <emphasis>Proper procedures:</emphasis></code></p>
<empty-line/>
<p><code> Name Argument types Function</code></p>
<empty-line/>
<p><code> GET(a, v) a: INTEGER; v: any basic type v := mem[a]</code></p>
<p><code> PUT(a, x) a: INTEGER; x: any basic type mem[a] := x</code></p>
</section>
</section>
<section id="app"><title><p>Appendix</p><p>The Syntax of Oberon</p></title>
<p><code> letter = "A" | "B" | | "Z" | "a" | "b" | | "z".</code></p>
<p><code> digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".</code></p>
<p><code> hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".</code></p>
<p><code> ident = letter {letter | digit}.</code></p>
<p><code> qualident = [ident "."] ident.</code></p>
<p><code> identdef = ident ["*"].</code></p>
<p><code> integer = digit {digit} | digit {hexDigit} "H".</code></p>
<p><code> real = digit {digit} "." {digit} [ScaleFactor].</code></p>
<p><code> ScaleFactor = ("E" | "D") ["+" | "-"] digit {digit}.</code></p>
<p><code> number = integer | real.</code></p>
<p><code> string = """ {character} """ | digit {hexDigit} "X".</code></p>
<p><code> ConstantDeclaration = identdef "=" ConstExpression.</code></p>
<p><code> ConstExpression = expression.</code></p>
<p><code> TypeDeclaration = identdef "=" StrucType.</code></p>
<p><code> StrucType = ArrayType | RecordType | PointerType | ProcedureType.</code></p>
<p><code> type = qualident | StrucType.</code></p>
<p><code> ArrayType = ARRAY length {"," length} OF type.</code></p>
<p><code> length = ConstExpression.</code></p>
<p><code> RecordType = RECORD ["(" BaseType ")"] [FieldListSequence] END.</code></p>
<p><code> BaseType = qualident.</code></p>
<p><code> FieldListSequence = FieldList {";" FieldList}.</code></p>
<p><code> FieldList = IdentList ":" type.</code></p>
<p><code> IdentList = identdef {"," identdef}.</code></p>
<p><code> PointerType = POINTER TO type.</code></p>
<p><code> ProcedureType = PROCEDURE [FormalParameters].</code></p>
<p><code> VariableDeclaration = IdentList ":" type.</code></p>
<p><code> expression = SimpleExpression [relation SimpleExpression].</code></p>
<p><code> relation = "=" | "#" | "&lt;" | "&lt;=" | "&gt;" | "&gt;=" | IN | IS.</code></p>
<p><code> SimpleExpression = ["+" | "-"] term {AddOperator term}.</code></p>
<p><code> AddOperator = "+" | "-" | OR.</code></p>
<p><code> term = factor {MulOperator factor}.</code></p>
<p><code> MulOperator = "*" | "/" | DIV | MOD | "&amp;".</code></p>
<p><code> factor = number | string | NIL | TRUE | FALSE |</code></p>
<p><code> set | designator [ActualParameters] | "(" expression ")" | "~" factor.</code></p>
<p><code> designator = qualident {selector}.</code></p>
<p><code> selector = "." ident | "[" ExpList "]" | "^" | "(" qualident ")".</code></p>
<p><code> set = "{" [element {"," element}] "}".</code></p>
<p><code> element = expression [".." expression].</code></p>
<p><code> ExpList = expression {"," expression}.</code></p>
<p><code> ActualParameters = "(" [ExpList] ")" .</code></p>
<p><code> statement = [assignment | ProcedureCall | IfStatement | CaseStatement |</code></p>
<p><code> WhileStatement | RepeatStatement | ForStatement].</code></p>
<p><code> assignment = designator ":=" expression.</code></p>
<p><code> ProcedureCall = designator [ActualParameters].</code></p>
<p><code> StatementSequence = statement {";" statement}.</code></p>
<p><code> IfStatement = IF expression THEN StatementSequence</code></p>
<p><code> {ELSIF expression THEN StatementSequence}</code></p>
<p><code> [ELSE StatementSequence] END.</code></p>
<p><code> CaseStatement = CASE expression OF case {"|" case} END.</code></p>
<p><code> case = [CaseLabelList ":" StatementSequence].</code></p>
<p><code> CaseLabelList = LabelRange {"," LabelRange}.</code></p>
<p><code> LabelRange = label [".." label].</code></p>
<p><code> label = integer | string | ident.</code></p>
<p><code> WhileStatement = WHILE expression DO StatementSequence</code></p>
<p><code> {ELSIF expression DO StatementSequence} END.</code></p>
<p><code> RepeatStatement = REPEAT StatementSequence UNTIL expression.</code></p>
<p><code> ForStatement = FOR ident ":=" expression TO expression [BY ConstExpression]</code></p>
<p><code> DO StatementSequence END.</code></p>
<p><code> ProcedureDeclaration = ProcedureHeading ";" ProcedureBody ident.</code></p>
<p><code> ProcedureHeading = PROCEDURE identdef [FormalParameters].</code></p>
<p><code> ProcedureBody = DeclarationSequence [BEGIN StatementSequence]</code></p>
<p><code> [RETURN expression] END.</code></p>
<p><code> DeclarationSequence = [CONST {ConstDeclaration ";"}]</code></p>
<p><code> [TYPE {TypeDeclaration ";"}]</code></p>
<p><code> [VAR {VariableDeclaration ";"}]</code></p>
<p><code> {ProcedureDeclaration ";"}.</code></p>
<p><code> FormalParameters = "(" [FPSection {";" FPSection}] ")" [":" qualident].</code></p>
<p><code> FPSection = [VAR] ident {"," ident} ":" FormalType.</code></p>
<p><code> FormalType = {ARRAY OF} qualident.</code></p>
<p><code> module = MODULE ident ";" [ImportList] DeclarationSequence</code></p>
<p><code> [BEGIN StatementSequence] END ident "." .</code></p>
<p><code> ImportList = IMPORT import {"," import} ";".</code></p>
<p><code> import = ident [":=" ident].</code></p>
</section>
</section>
</body>
</FictionBook>

/programs/develop/oberon07/Lib/KolibriOS/API.ob07
0,0 → 1,193
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE API;
IMPORT sys := SYSTEM;
CONST
MAX_SIZE = 16 * 400H;
HEAP_SIZE = 1 * 100000H;
VAR
heap, endheap: INTEGER;
pockets: ARRAY MAX_SIZE DIV 32 + 1 OF INTEGER;
PROCEDURE [stdcall] zeromem*(size, adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
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 _NEW*(size: INTEGER): INTEGER;
VAR res, idx, temp: INTEGER;
BEGIN
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
res := pockets[idx];
IF res # 0 THEN
sys.GET(res, pockets[idx]);
sys.PUT(res, size);
INC(res, 4)
ELSE
IF heap + size >= endheap THEN
IF sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
heap := sysfunc3(68, 12, HEAP_SIZE);
endheap := heap + HEAP_SIZE
ELSE
heap := 0
END
END;
IF heap # 0 THEN
sys.PUT(heap, size);
res := heap + 4;
heap := heap + size
ELSE
endheap := 0;
res := 0
END
END
ELSE
IF sysfunc2(18, 16) > ASR(size, 10) THEN
res := sysfunc3(68, 12, size);
sys.PUT(res, size);
INC(res, 4)
ELSE
res := 0
END
END;
IF res # 0 THEN
zeromem(ASR(size, 2) - 1, res)
END
RETURN res
END _NEW;
PROCEDURE _DISPOSE*(ptr: INTEGER): INTEGER;
VAR size, idx: INTEGER;
BEGIN
DEC(ptr, 4);
sys.GET(ptr, size);
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
sys.PUT(ptr, pockets[idx]);
pockets[idx] := ptr
ELSE
size := sysfunc3(68, 13, ptr)
END
RETURN 0
END _DISPOSE;
PROCEDURE ExitProcess*(p1: INTEGER);
BEGIN
p1 := sysfunc1(-1)
END ExitProcess;
PROCEDURE OutChar(c: CHAR);
VAR res: INTEGER;
BEGIN
res := sysfunc3(63, 1, ORD(c))
END OutChar;
PROCEDURE DebugMsg*(lpText, lpCaption: INTEGER);
VAR c: CHAR;
BEGIN
IF lpCaption # 0 THEN
OutChar(0DX);
OutChar(0AX);
REPEAT
sys.GET(lpCaption, c);
IF c # 0X THEN
OutChar(c)
END;
INC(lpCaption)
UNTIL c = 0X;
OutChar(":");
OutChar(0DX);
OutChar(0AX)
END;
REPEAT
sys.GET(lpText, c);
IF c # 0X THEN
OutChar(c)
END;
INC(lpText)
UNTIL c = 0X;
IF lpCaption # 0 THEN
OutChar(0DX);
OutChar(0AX)
END
END DebugMsg;
PROCEDURE init* (p1: INTEGER);
BEGIN
p1 := sysfunc2(68, 11)
END init;
END API.

/programs/develop/oberon07/Lib/KolibriOS/Args.ob07
0,0 → 1,100
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Args;
IMPORT sys := SYSTEM, KOSAPI;
CONST
MAX_PARAM = 1024;
VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
PROCEDURE GetChar(adr: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR p, count, name: INTEGER; c: CHAR; cond: INTEGER;
PROCEDURE ChangeCond(A, B, C: INTEGER);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
cond := C
END
END ChangeCond;
BEGIN
p := KOSAPI.GetCommandLine();
name := KOSAPI.GetName();
Params[0, 0] := name;
WHILE GetChar(name) # 0X DO
INC(name)
END;
Params[0, 1] := name - 1;
cond := 0;
count := 1;
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE GetArg*(n: INTEGER; VAR s: ARRAY OF CHAR);
VAR i, j, len: INTEGER; c: CHAR;
BEGIN
j := 0;
IF n < argc + 1 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;
BEGIN
ParamParse
END Args.

/programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07
0,0 → 1,105
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE ColorDlg;
IMPORT sys := SYSTEM, KOSAPI;
TYPE
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
type,
procinfo,
com_area_name,
com_area,
start_path: INTEGER;
draw_window: DRAW_WINDOW;
status*,
X, Y,
color_type,
color*: INTEGER;
procinf: ARRAY 1024 OF CHAR;
s_com_area_name: ARRAY 32 OF CHAR
END;
Dialog* = POINTER TO TDialog;
VAR
Dialog_start, Dialog_init: PROCEDURE [stdcall] (cd: Dialog);
PROCEDURE Show*(cd: Dialog);
BEGIN
IF cd # NIL THEN
cd.X := 0;
cd.Y := 0;
Dialog_start(cd)
END
END Show;
PROCEDURE Create*(draw_window: DRAW_WINDOW): Dialog;
VAR res: Dialog;
BEGIN
NEW(res);
IF res # NIL THEN
res.s_com_area_name := "FFFFFFFF_color_dlg";
res.com_area := 0;
res.type := 0;
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.draw_window := draw_window;
res.status := 0;
res.X := 0;
res.Y := 0;
res.color := 0;
Dialog_init(res)
END
RETURN res
END Create;
PROCEDURE Destroy*(VAR cd: Dialog);
BEGIN
IF cd # NIL THEN
DISPOSE(cd)
END
END Destroy;
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(sys.ADR(Dialog_init), "ColorDialog_init");
GetProc(sys.ADR(Dialog_start), "ColorDialog_start");
END Load;
BEGIN
Load
END ColorDlg.

/programs/develop/oberon07/Lib/KolibriOS/Console.ob07
0,0 → 1,66
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Console;
IMPORT ConsoleLib;
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 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;
BEGIN
IF (FColor IN {0..15}) & (BColor IN {0..15}) THEN
res := ConsoleLib.set_flags(LSL(BColor, 4) + FColor)
END
END SetColor;
PROCEDURE GetCursorX*(): INTEGER;
VAR x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN x
END GetCursorX;
PROCEDURE GetCursorY*(): INTEGER;
VAR x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN y
END GetCursorY;
END Console.

/programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07
0,0 → 1,101
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE ConsoleLib;
IMPORT sys := SYSTEM, KOSAPI;
CONST
COLOR_BLUE* = 001H;
COLOR_GREEN* = 002H;
COLOR_RED* = 004H;
COLOR_BRIGHT* = 008H;
BGR_BLUE* = 010H;
BGR_GREEN* = 020H;
BGR_RED* = 040H;
BGR_BRIGHT* = 080H;
IGNORE_SPECIALS* = 100H;
WINDOW_CLOSED* = 200H;
TYPE
gets2_callback* = PROCEDURE [stdcall] (keycode: INTEGER; pstr: INTEGER; VAR n, pos: INTEGER);
VAR
version* : INTEGER;
init* : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
exit* : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
write_asciiz* : PROCEDURE [stdcall] (string: INTEGER);
write_string* : PROCEDURE [stdcall] (string, length: INTEGER);
get_flags* : PROCEDURE [stdcall] (): INTEGER;
set_flags* : PROCEDURE [stdcall] (new_flags: INTEGER): INTEGER;
get_font_height* : PROCEDURE [stdcall] (): INTEGER;
get_cursor_height* : PROCEDURE [stdcall] (): INTEGER;
set_cursor_height* : PROCEDURE [stdcall] (new_height: INTEGER): INTEGER;
getch* : PROCEDURE [stdcall] (): INTEGER;
getch2* : PROCEDURE [stdcall] (): INTEGER;
kbhit* : PROCEDURE [stdcall] (): INTEGER;
gets* : PROCEDURE [stdcall] (str, n: INTEGER): INTEGER;
gets2* : PROCEDURE [stdcall] (callback: gets2_callback; str, n: INTEGER): INTEGER;
cls* : PROCEDURE [stdcall] ();
get_cursor_pos* : PROCEDURE [stdcall] (VAR x, y: INTEGER);
set_cursor_pos* : PROCEDURE [stdcall] (x, y: INTEGER);
PROCEDURE open*(wnd_width, wnd_height, scr_width, scr_height: INTEGER; title: ARRAY OF CHAR);
BEGIN
init(wnd_width, wnd_height, scr_width, scr_height, sys.ADR(title[0]))
END open;
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
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");
END main;
BEGIN
main
END ConsoleLib.

/programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07
0,0 → 1,140
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE DateTime;
IMPORT KOSAPI;
CONST ERR* = -7.0D5;
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL;
VAR d, i: INTEGER; M: ARRAY 13 OF CHAR; Res: LONGREAL;
BEGIN
Res := ERR;
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) &
(Day >= 1) & (Day <= 31) & (Hour >= 0) & (Hour <= 23) &
(Min >= 0) & (Min <= 59) & (Sec >= 0) & (Sec <= 59) THEN
M := "_303232332323";
IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN
M[2] := "1"
END;
IF Day <= ORD(M[Month]) - ORD("0") + 28 THEN
DEC(Year);
d := Year * 365 + (Year DIV 4) - (Year DIV 100) + (Year DIV 400) + Day - 693594;
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
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 MonthDay(n: INTEGER): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
Res := FALSE;
IF d > ORD(M[n]) - ORD("0") + 28 THEN
d := d - ORD(M[n]) + ORD("0") - 28;
INC(Month);
Res := TRUE
END
RETURN Res
END MonthDay;
BEGIN
IF (Date >= -693593.0D0) & (Date < 2958466.0D0) THEN
d := FLOOR(Date);
t := FLOOR((Date - LONG(FLT(d))) * 86400000.0D0);
d := d + 693593;
Year := 1;
Month := 1;
WHILE d > 0 DO
d := d - 365 - ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0));
INC(Year)
END;
IF d < 0 THEN
DEC(Year);
d := d + 365 + ORD((Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0))
END;
INC(d);
M := "_303232332323";
IF (Year MOD 4 = 0) & (Year MOD 100 # 0) OR (Year MOD 400 = 0) THEN
M[2] := "1"
END;
i := 1;
flag := TRUE;
WHILE flag & (i <= 12) DO
flag := MonthDay(i);
INC(i)
END;
Day := d;
Hour := t DIV 3600000;
t := t MOD 3600000;
Min := t DIV 60000;
t := t MOD 60000;
Sec := t DIV 1000;
Res := TRUE
ELSE
Res := FALSE
END
RETURN Res
END Decode;
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec: INTEGER);
VAR date, time: INTEGER;
BEGIN
date := KOSAPI.sysfunc1(29);
time := KOSAPI.sysfunc1(3);
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;
END DateTime.

/programs/develop/oberon07/Lib/KolibriOS/Debug.ob07
0,0 → 1,287
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Debug;
IMPORT KOSAPI, sys := SYSTEM;
CONST
d = 1.0D0 - 5.0D-12;
VAR
Realp: PROCEDURE (x: LONGREAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
VAR res: INTEGER;
BEGIN
res := KOSAPI.sysfunc3(63, 1, ORD(c))
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR n, i: INTEGER;
BEGIN
n := LENGTH(s);
FOR i := 0 TO n - 1 DO
Char(s[i])
END
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
sys.GET(sys.ADR(AValue) + 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)
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
PROCEDURE OutInf(x: LONGREAL; width: INTEGER);
VAR s: ARRAY 4 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0D0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0D0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0D0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0D0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0D0) & (y # 0.0D0) DO
y := y * 10.0D0;
DEC(e)
END;
IF e < 0 THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char("1");
x := 0.0D0
ELSE
Char("0");
x := x * 10.0D0
END
ELSE
WHILE e >= 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x > 9.0D0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(p)
END
END
END FixReal;
PROCEDURE Real*(x: LONGREAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0D0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
WHILE (x < 1.0D0) & (x # 0.0D0) DO
x := x * 10.0D0;
DEC(e)
END;
IF x > 9.0D0 + d THEN
x := 1.0D0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE Open*;
TYPE
info_struct = RECORD
subfunc: INTEGER;
flags: INTEGER;
param: INTEGER;
rsrvd1: INTEGER;
rsrvd2: INTEGER;
fname: ARRAY 1024 OF CHAR
END;
VAR info: info_struct; res: INTEGER;
BEGIN
info.subfunc := 7;
info.flags := 0;
info.param := sys.ADR(" ");
info.rsrvd1 := 0;
info.rsrvd2 := 0;
info.fname := "/rd/1/develop/board";
res := KOSAPI.sysfunc2(70, sys.ADR(info))
END Open;
BEGIN
Realp := Real
END Debug.

/programs/develop/oberon07/Lib/KolibriOS/File.ob07
0,0 → 1,255
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE File;
IMPORT sys := SYSTEM, KOSAPI;
CONST
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
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;
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 *)
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;
BEGIN
fs.subfunc := 5;
fs.pos := 0;
fs.hpos := 0;
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;
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
ELSE
F := NIL
END
RETURN F
END Open;
PROCEDURE Delete*(FName: ARRAY OF CHAR): BOOLEAN;
VAR F: FS; res, res2: INTEGER;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 8;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
ELSE
res := -1
END
RETURN res = 0
END Delete;
PROCEDURE Seek*(F: FS; Offset, Origin: INTEGER): INTEGER;
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
|SEEK_CUR: F.pos := F.pos + Offset
|SEEK_END: F.pos := fd.size + Offset
ELSE
END;
res := F.pos
ELSE
res := -1
END
RETURN res
END Seek;
PROCEDURE Read*(F: FS; Buffer, Count: INTEGER): INTEGER;
VAR res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 0;
F.bytes := Count;
F.buffer := Buffer;
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Read;
PROCEDURE Write*(F: FS; Buffer, Count: INTEGER): INTEGER;
VAR res, res2: INTEGER;
BEGIN
IF F # NIL THEN
F.subfunc := 3;
F.bytes := Count;
F.buffer := Buffer;
res := KOSAPI.sysfunc22(70, sys.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
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 KOSAPI.sysfunc22(70, sys.ADR(F^), res2) # 0 THEN
DISPOSE(F)
END
END
RETURN F
END Create;
PROCEDURE DirExists*(FName: ARRAY OF CHAR): BOOLEAN;
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;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 9;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(DirName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
RETURN res = 0
END CreateDir;
PROCEDURE DeleteDir*(DirName: ARRAY OF CHAR): BOOLEAN;
VAR F: FS; res, res2: INTEGER;
BEGIN
IF DirExists(DirName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 8;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(DirName, F.name);
res := KOSAPI.sysfunc22(70, sys.ADR(F^), res2);
DISPOSE(F)
ELSE
res := -1
END
ELSE
res := -1
END
RETURN res = 0
END DeleteDir;
END File.

/programs/develop/oberon07/Lib/KolibriOS/HOST.ob07
0,0 → 1,270
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
CONST
OS* = "KOS";
Slash* = "/";
TYPE
FILENAME = ARRAY 2048 OF CHAR;
OFSTRUCT = RECORD
subfunc, pos, hpos, bytes, buf: INTEGER;
name: FILENAME
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;
PROCEDURE [stdcall] sysfunc1(arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall] sysfunc2(arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall] sysfunc3(arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall] sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
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;
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR cur, procname, adr: INTEGER;
PROCEDURE streq(str1, str2: INTEGER): BOOLEAN;
VAR c1, c2: 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;
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)
END
END
RETURN adr
END GetProcAdr;
PROCEDURE Time*(VAR sec, dsec: INTEGER);
VAR t: INTEGER;
BEGIN
t := sysfunc2(26, 9);
sec := t DIV 100;
dsec := t MOD 100
END Time;
PROCEDURE init*;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := GetProcAdr(name, Lib);
sys.PUT(v, a)
END GetProc;
BEGIN
Time(sec, dsec);
Lib := sysfunc3(68, 19, sys.ADR("/rd/1/lib/console.obj"));
IF Lib # 0 THEN
GetProc(sys.ADR(con_init), "con_init");
GetProc(sys.ADR(con_exit), "con_exit");
GetProc(sys.ADR(con_write_asciiz), "con_write_asciiz");
IF con_init # NIL THEN
con_init(-1, -1, -1, -1, sys.ADR("Oberon-07/11 for KolibriOS"))
END
END
END init;
PROCEDURE ExitProcess* (n: INTEGER);
BEGIN
IF con_exit # NIL THEN
con_exit(FALSE)
END;
n := sysfunc1(-1)
END ExitProcess;
PROCEDURE GetCommandLine*(): INTEGER;
VAR param: INTEGER;
BEGIN
sys.GET(28, param)
RETURN param
END GetCommandLine;
PROCEDURE GetName*(): INTEGER;
VAR name: INTEGER;
BEGIN
sys.GET(32, name)
RETURN name
END GetName;
PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN sysfunc3(68, 12, size)
END malloc;
PROCEDURE CloseFile*(hObject: INTEGER);
VAR pFS: POINTER TO OFSTRUCT;
BEGIN
sys.PUT(sys.ADR(pFS), hObject);
DISPOSE(pFS)
END CloseFile;
PROCEDURE _OCFile(FileName: ARRAY OF CHAR; VAR FS: OFSTRUCT; mode: INTEGER; VAR fsize: INTEGER): INTEGER;
VAR buf: ARRAY 40 OF CHAR; res: 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)
ELSE
res := 0
END
RETURN res
END _OCFile;
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
END;
FS.pos := FS.pos + res
RETURN res
END IOFile;
PROCEDURE OCFile(FName: ARRAY OF CHAR; mode: INTEGER): INTEGER;
VAR FS: OFSTRUCT; pFS: POINTER TO OFSTRUCT; res: INTEGER;
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;
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 FileSize* (F: INTEGER): INTEGER;
RETURN fsize
END FileSize;
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR pFS: POINTER TO OFSTRUCT; res: 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;
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR n: 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;
END HOST.

/programs/develop/oberon07/Lib/KolibriOS/In.ob07
0,0 → 1,296
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE In;
IMPORT sys := SYSTEM, ConsoleLib;
TYPE
STRING = ARRAY 260 OF CHAR;
VAR
Done* : BOOLEAN;
PROCEDURE digit(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END digit;
PROCEDURE CheckInt(s: STRING; VAR first, last: INTEGER; VAR neg: BOOLEAN; Point: BOOLEAN): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
neg := FALSE;
WHILE (s[i] <= 20X) & (s[i] # 0X) DO
INC(i)
END;
IF s[i] = "-" THEN
neg := TRUE;
INC(i)
ELSIF s[i] = "+" THEN
INC(i)
END;
first := i;
WHILE digit(s[i]) DO
INC(i)
END;
last := i
RETURN ((s[i] <= 20X) OR (Point & (s[i] = "."))) & digit(s[first])
END CheckInt;
PROCEDURE IsMinInt(str: STRING; pos: INTEGER): BOOLEAN;
VAR i: INTEGER; min: STRING;
BEGIN
i := 0;
min := "2147483648";
WHILE (min[i] # 0X) & (str[i] # 0X) & (min[i] = str[i + pos]) DO
INC(i)
END
RETURN i = 10
END IsMinInt;
PROCEDURE StrToInt(str: STRING; VAR err: BOOLEAN): INTEGER;
CONST maxINT = 7FFFFFFFH;
VAR i, n, res: INTEGER; flag, neg: BOOLEAN;
BEGIN
res := 0;
flag := CheckInt(str, i, n, neg, FALSE);
err := ~flag;
IF flag & neg & IsMinInt(str, i) THEN
flag := FALSE;
neg := FALSE;
res := 80000000H
END;
WHILE flag & digit(str[i]) DO
IF res > maxINT DIV 10 THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END;
IF neg THEN
res := -res
END
RETURN res
END StrToInt;
PROCEDURE Space(s: STRING): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) & (s[i] <= 20X) DO
INC(i)
END
RETURN s[i] = 0X
END Space;
PROCEDURE CheckReal(s: STRING; VAR n: INTEGER; VAR neg: BOOLEAN): BOOLEAN;
VAR i: INTEGER; Res: BOOLEAN;
BEGIN
Res := CheckInt(s, n, i, neg, TRUE);
IF Res THEN
IF s[i] = "." THEN
INC(i);
WHILE digit(s[i]) DO
INC(i)
END;
IF (s[i] = "D") OR (s[i] = "E") OR (s[i] = "d") OR (s[i] = "e") THEN
INC(i);
IF (s[i] = "+") OR (s[i] = "-") THEN
INC(i)
END;
Res := digit(s[i]);
WHILE digit(s[i]) DO
INC(i)
END
END
END
END
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 part1(): BOOLEAN;
BEGIN
res := 0.0D0;
d := 1.0D0;
WHILE digit(str[i]) DO
res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0")));
INC(i)
END;
IF str[i] = "." THEN
INC(i);
WHILE digit(str[i]) DO
d := d / 10.0D0;
res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d;
INC(i)
END
END
RETURN str[i] # 0X
END part1;
PROCEDURE part2(): BOOLEAN;
BEGIN
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;
err := FALSE;
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0D0
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0D0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN ~err
END part2;
PROCEDURE part3;
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0D0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0D0
ELSE
res := res * m;
INC(i)
END
END
END part3;
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1() & part2() THEN
part3
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0D0;
err := TRUE
END
RETURN res
END StrToFloat;
PROCEDURE String*(VAR s: ARRAY OF CHAR);
VAR res, length: INTEGER; str: STRING;
BEGIN
res := ConsoleLib.gets(sys.ADR(str[0]), LEN(str));
length := LENGTH(str);
IF length > 0 THEN
str[length - 1] := 0X
END;
COPY(str, s);
Done := TRUE
END String;
PROCEDURE Char*(VAR x: CHAR);
VAR str: STRING;
BEGIN
String(str);
x := str[0];
Done := TRUE
END Char;
PROCEDURE Ln*;
VAR str: STRING;
BEGIN
String(str);
Done := TRUE
END Ln;
PROCEDURE LongReal*(VAR x: LONGREAL);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
REPEAT
String(str)
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
err := FALSE;
REPEAT
String(str)
UNTIL ~Space(str);
x := StrToInt(str, err);
Done := ~err
END Int;
PROCEDURE Open*;
BEGIN
Done := TRUE
END Open;
END In.

/programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07
0,0 → 1,323
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE KOSAPI;
IMPORT sys := SYSTEM;
TYPE STRING = ARRAY 1024 OF CHAR;
VAR DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER);
PROCEDURE [stdcall] sysfunc1*(arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall] sysfunc2*(arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall] sysfunc3*(arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall] 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 [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 *)
RETURN 0
END sysfunc6;
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 *)
RETURN 0
END sysfunc7;
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 *)
RETURN 0
END sysfunc22;
PROCEDURE [stdcall] malloc*(size: INTEGER): INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
size := sysfunc3(68, 12, size);
sys.CODE("61") (* popa *)
RETURN size
END malloc;
PROCEDURE [stdcall] free*(ptr: INTEGER): INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
IF ptr # 0 THEN
ptr := sysfunc3(68, 13, ptr)
END;
sys.CODE("61") (* popa *)
RETURN 0
END free;
PROCEDURE [stdcall] realloc*(ptr, size: INTEGER): INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
ptr := sysfunc4(68, 20, size, ptr);
sys.CODE("61") (* popa *)
RETURN ptr
END realloc;
PROCEDURE GetCommandLine*(): INTEGER;
VAR param: INTEGER;
BEGIN
sys.GET(28, param)
RETURN param
END GetCommandLine;
PROCEDURE GetName*(): INTEGER;
VAR name: INTEGER;
BEGIN
sys.GET(32, 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 *)
END dll_init2;
PROCEDURE GetProcAdr*(name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR cur, procname, adr: INTEGER;
PROCEDURE streq(str1, str2: INTEGER): BOOLEAN;
VAR c1, c2: 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;
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)
END
END
RETURN adr
END GetProcAdr;
PROCEDURE init(dll: INTEGER);
VAR lib_init: INTEGER;
BEGIN
lib_init := GetProcAdr("lib_init", dll);
IF lib_init # 0 THEN
DLL_INIT(lib_init)
END;
lib_init := GetProcAdr("START", dll);
IF lib_init # 0 THEN
DLL_INIT(lib_init)
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;
BEGIN
REPEAT
sys.GET(adr, c); INC(adr);
str[i] := c; INC(i)
UNTIL c = 0X
END GetStr;
BEGIN
sys.CODE("60"); (* pusha *)
fail := FALSE;
done := FALSE;
res := 0;
libname := "/rd/1/lib/";
REPEAT
sys.GET(import_table, imp);
IF imp # 0 THEN
sys.GET(import_table + 4, lib);
GetStr(lib, 10, libname);
exp := sysfunc3(68, 19, sys.ADR(libname[0]));
fail := exp = 0;
ELSE
done := TRUE
END;
IF fail THEN
done := TRUE
END;
IF (imp # 0) & ~fail THEN
REPEAT
sys.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);
END
END
UNTIL proc = 0;
init(exp);
INC(import_table, 8)
END
UNTIL done;
IF fail THEN
res := 1
END;
import_table := res;
sys.CODE("61") (* popa *)
RETURN import_table
END dll_Load;
PROCEDURE [stdcall] dll_Init(entry: INTEGER);
BEGIN
sys.CODE("60"); (* pusha *)
IF entry # 0 THEN
dll_init2(sys.ADR(malloc), sys.ADR(free), sys.ADR(realloc), sys.ADR(dll_Load), entry)
END;
sys.CODE("61"); (* popa *)
END dll_Init;
PROCEDURE LoadLib*(name: ARRAY OF CHAR): INTEGER;
VAR Lib: INTEGER;
BEGIN
Lib := sysfunc3(68, 19, sys.ADR(name[0]));
IF Lib # 0 THEN
init(Lib)
END
RETURN Lib
END LoadLib;
BEGIN
DLL_INIT := dll_Init
END KOSAPI.

/programs/develop/oberon07/Lib/KolibriOS/Math.ob07
0,0 → 1,254
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Math;
IMPORT sys := SYSTEM;
CONST pi* = 3.141592653589793D+00;
e* = 2.718281828459045D+00;
VAR Inf*, nInf*: LONGREAL;
PROCEDURE IsNan*(x: LONGREAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(x), l);
sys.GET(sys.ADR(x) + 4, h);
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf*(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
PROCEDURE Max(A, B: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF A > B THEN
Res := A
ELSE
Res := B
END
RETURN Res
END Max;
PROCEDURE Min(A, B: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF A < B THEN
Res := A
ELSE
Res := B
END
RETURN Res
END Min;
PROCEDURE SameValue(A, B: LONGREAL): BOOLEAN;
VAR Epsilon: LONGREAL; Res: BOOLEAN;
BEGIN
Epsilon := Max(Min(ABS(A), ABS(B)) * 1.0D-12, 1.0D-12);
IF A > B THEN
Res := (A - B) <= Epsilon
ELSE
Res := (B - A) <= Epsilon
END
RETURN Res
END SameValue;
PROCEDURE IsZero(x: LONGREAL): BOOLEAN;
RETURN ABS(x) <= 1.0D-12
END IsZero;
PROCEDURE [stdcall] sqrt*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D9FAC9C20800")
RETURN 0.0D0
END sqrt;
PROCEDURE [stdcall] sin*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D9FEC9C20800")
RETURN 0.0D0
END sin;
PROCEDURE [stdcall] cos*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D9FFC9C20800")
RETURN 0.0D0
END cos;
PROCEDURE [stdcall] tan*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D9F2DEC9C9C20800")
RETURN 0.0D0
END tan;
PROCEDURE [stdcall] arctan2*(y, x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508DD4510D9F3C9C21000")
RETURN 0.0D0
END arctan2;
PROCEDURE [stdcall] ln*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("D9EDDD4508D9F1C9C20800")
RETURN 0.0D0
END ln;
PROCEDURE [stdcall] log*(base, x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("D9E8DD4510D9F1D9E8DD4508D9F1DEF9C9C21000")
RETURN 0.0D0
END log;
PROCEDURE [stdcall] exp*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D9EADEC9D9C0D9FCDCE9D9C9D9F0D9E8DEC1D9FDDDD9C9C20800")
RETURN 0.0D0
END exp;
PROCEDURE [stdcall] round*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("DD4508D97DF4D97DF666814DF60003D96DF6D9FCD96DF4C9C20800")
RETURN 0.0D0
END round;
PROCEDURE [stdcall] frac*(x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("50DD4508D9C0D93C24D97C240266814C2402000FD96C2402D9FCD92C24DEE9C9C20800")
RETURN 0.0D0
END frac;
PROCEDURE arcsin*(x: LONGREAL): LONGREAL;
RETURN arctan2(x, sqrt(1.0D0 - x * x))
END arcsin;
PROCEDURE arccos*(x: LONGREAL): LONGREAL;
RETURN arctan2(sqrt(1.0D0 - x * x), x)
END arccos;
PROCEDURE arctan*(x: LONGREAL): LONGREAL;
RETURN arctan2(x, 1.0D0)
END arctan;
PROCEDURE sinh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF IsZero(x) THEN
Res := 0.0D0
ELSE
Res := (exp(x) - exp(-x)) / 2.0D0
END
RETURN Res
END sinh;
PROCEDURE cosh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF IsZero(x) THEN
Res := 1.0D0
ELSE
Res := (exp(x) + exp(-x)) / 2.0D0
END
RETURN Res
END cosh;
PROCEDURE tanh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF IsZero(x) THEN
Res := 0.0D0
ELSE
Res := sinh(x) / cosh(x)
END
RETURN Res
END tanh;
PROCEDURE arcsinh*(x: LONGREAL): LONGREAL;
RETURN ln(x + sqrt((x * x) + 1.0D0))
END arcsinh;
PROCEDURE arccosh*(x: LONGREAL): LONGREAL;
RETURN ln(x + sqrt((x - 1.0D0) / (x + 1.0D0)) * (x + 1.0D0))
END arccosh;
PROCEDURE arctanh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF SameValue(x, 1.0D0) THEN
Res := Inf
ELSIF SameValue(x, -1.0D0) THEN
Res := nInf
ELSE
Res := 0.5D0 * ln((1.0D0 + x) / (1.0D0 - x))
END
RETURN Res
END arctanh;
PROCEDURE floor*(x: LONGREAL): LONGREAL;
VAR f: LONGREAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0D0 THEN
x := x - 1.0D0
END
RETURN x
END floor;
PROCEDURE ceil*(x: LONGREAL): LONGREAL;
VAR f: LONGREAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0D0 THEN
x := x + 1.0D0
END
RETURN x
END ceil;
PROCEDURE power*(base, exponent: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
BEGIN
IF exponent = 0.0D0 THEN
Res := 1.0D0
ELSIF (base = 0.0D0) & (exponent > 0.0D0) THEN
Res := 0.0D0
ELSE
Res := exp(exponent * ln(base))
END
RETURN Res
END power;
PROCEDURE sgn*(x: LONGREAL): INTEGER;
VAR Res: INTEGER;
BEGIN
IF x > 0.0D0 THEN
Res := 1
ELSIF x < 0.0D0 THEN
Res := -1
ELSE
Res := 0
END
RETURN Res
END sgn;
BEGIN
Inf := sys.INF(LONGREAL);
nInf := -sys.INF(LONGREAL)
END Math.

/programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07
0,0 → 1,153
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE OpenDlg;
IMPORT sys := SYSTEM, KOSAPI;
TYPE
DRAW_WINDOW = PROCEDURE;
TDialog = RECORD
type,
procinfo,
com_area_name,
com_area,
opendir_path,
dir_default_path,
start_path: INTEGER;
draw_window: DRAW_WINDOW;
status*,
openfile_path,
filename_area: INTEGER;
filter_area:
POINTER TO RECORD
size: INTEGER;
filter: ARRAY 4096 OF CHAR
END;
X, Y: INTEGER;
procinf: ARRAY 1024 OF CHAR;
s_com_area_name: ARRAY 32 OF CHAR;
s_opendir_path,
s_dir_default_path,
FilePath*,
FileName*: ARRAY 4096 OF CHAR
END;
Dialog* = POINTER TO TDialog;
VAR
Dialog_start, Dialog_init: PROCEDURE [stdcall] (od: Dialog);
PROCEDURE Show*(od: Dialog; Width, Height: INTEGER);
BEGIN
IF od # NIL THEN
od.X := Width;
od.Y := Height;
Dialog_start(od)
END
END Show;
PROCEDURE Create*(draw_window: DRAW_WINDOW; type: INTEGER; def_path, filter: ARRAY OF CHAR): Dialog;
VAR res: Dialog; n, i: INTEGER;
PROCEDURE replace(VAR str: ARRAY OF CHAR; c1, c2: CHAR);
VAR i: INTEGER;
BEGIN
i := LENGTH(str) - 1;
WHILE i >= 0 DO
IF str[i] = c1 THEN
str[i] := c2
END;
DEC(i)
END
END replace;
BEGIN
NEW(res);
IF res # NIL THEN
NEW(res.filter_area);
IF res.filter_area # NIL THEN
res.s_com_area_name := "FFFFFFFF_open_dialog";
res.com_area := 0;
res.type := type;
res.draw_window := draw_window;
COPY(def_path, res.s_dir_default_path);
COPY(filter, res.filter_area.filter);
n := LENGTH(res.filter_area.filter);
FOR i := 0 TO 3 DO
res.filter_area.filter[n + i] := "|"
END;
res.filter_area.filter[n + 4] := 0X;
res.X := 0;
res.Y := 0;
res.s_opendir_path := res.s_dir_default_path;
res.FilePath := "";
res.FileName := "";
res.status := 0;
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.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]);
res.filename_area := sys.ADR(res.FileName[0]);
replace(res.filter_area.filter, "|", 0X);
Dialog_init(res)
ELSE
DISPOSE(res)
END
END
RETURN res
END Create;
PROCEDURE Destroy*(VAR od: Dialog);
BEGIN
IF od # NIL THEN
DISPOSE(od.filter_area);
DISPOSE(od)
END
END Destroy;
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(sys.ADR(Dialog_init), "OpenDialog_init");
GetProc(sys.ADR(Dialog_start), "OpenDialog_start");
END Load;
BEGIN
Load
END OpenDlg.

/programs/develop/oberon07/Lib/KolibriOS/Out.ob07
0,0 → 1,262
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Out;
IMPORT ConsoleLib, sys := SYSTEM;
CONST
d = 1.0D0 - 5.0D-12;
VAR
Realp: PROCEDURE (x: LONGREAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
BEGIN
ConsoleLib.write_string(sys.ADR(c), 1)
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
BEGIN
ConsoleLib.write_string(sys.ADR(s[0]), LENGTH(s))
END String;
PROCEDURE WriteInt(x, n: INTEGER);
VAR i: INTEGER; a: ARRAY 16 OF CHAR; neg: BOOLEAN;
BEGIN
i := 0;
IF n < 1 THEN
n := 1
END;
IF x < 0 THEN
x := -x;
DEC(n);
neg := TRUE
END;
REPEAT
a[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
WHILE n > i DO
Char(" ");
DEC(n)
END;
IF neg THEN
Char("-")
END;
REPEAT
DEC(i);
Char(a[i])
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
sys.GET(sys.ADR(AValue) + 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)
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
VAR i: INTEGER;
BEGIN
IF x # 80000000H THEN
WriteInt(x, width)
ELSE
FOR i := 12 TO width DO
Char(20X)
END;
String("-2147483648")
END
END Int;
PROCEDURE OutInf(x: LONGREAL; width: INTEGER);
VAR s: ARRAY 4 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0D0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0D0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
Char(" ")
END;
String(s)
END OutInf;
PROCEDURE Ln*;
BEGIN
Char(0DX);
Char(0AX)
END Ln;
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSIF p < 0 THEN
Realp(x, width)
ELSE
len := 0;
minus := FALSE;
IF x < 0.0D0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0D0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
END
ELSE
len := len + p + 2
END;
FOR i := 1 TO width - len DO
Char(" ")
END;
IF minus THEN
Char("-")
END;
y := x;
WHILE (y < 1.0D0) & (y # 0.0D0) DO
y := y * 10.0D0;
DEC(e)
END;
IF e < 0 THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char("1");
x := 0.0D0
ELSE
Char("0");
x := x * 10.0D0
END
ELSE
WHILE e >= 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
IF x > 9.0D0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(e)
END
END;
IF p > 0 THEN
Char(".")
END;
WHILE p > 0 DO
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0D0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
END;
DEC(p)
END
END
END FixReal;
PROCEDURE Real*(x: LONGREAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
ELSE
e := 0;
n := 0;
IF width > 23 THEN
n := width - 23;
width := 23
ELSIF width < 9 THEN
width := 9
END;
width := width - 5;
IF x < 0.0D0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
INC(e)
END;
WHILE (x < 1.0D0) & (x # 0.0D0) DO
x := x * 10.0D0;
DEC(e)
END;
IF x > 9.0D0 + d THEN
x := 1.0D0;
INC(e)
END;
FOR i := 1 TO n DO
Char(" ")
END;
IF minus THEN
x := -x
END;
FixReal(x, width, width - 3);
Char("E");
IF e >= 0 THEN
Char("+")
ELSE
Char("-");
e := ABS(e)
END;
IF e < 100 THEN
Char("0")
END;
IF e < 10 THEN
Char("0")
END;
Int(e, 0)
END
END Real;
PROCEDURE Open*;
END Open;
BEGIN
Realp := Real
END Out.

/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07
0,0 → 1,279
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN
API.ExitProcess(n)
END _halt;
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
END
END _disprec;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
BEGIN
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
END
RETURN res
END _saverec;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: 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
END
END _arrayidx;
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
BEGIN
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
END
END _arrayidx1;
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: 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
END
END _arrayrot;
PROCEDURE Min(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END Min;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
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
RETURN 0
END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN
_savearr(Min(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: 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)
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
END
RETURN Res
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
BEGIN
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END Int;
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;
BEGIN
n := LEN(s);
i := 0;
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
END
END StrAppend;
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")
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)
END _assrt;
PROCEDURE [stdcall] _close*;
BEGIN
IF CloseProc # NIL THEN
CloseProc
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
BEGIN
API.zeromem(gsize, gadr);
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL
END _init;
PROCEDURE SetClose*(proc: PROC);
BEGIN
CloseProc := proc
END SetClose;
END RTL.

/programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07
0,0 → 1,124
(*
Copyright 2016 KolibriOS team
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE RasterWorks;
IMPORT sys := SYSTEM, KOSAPI;
CONST
(* flags *)
bold *= 1;
italic *= 2;
underline *= 4;
strike_through *= 8;
align_right *= 16;
align_center *= 32;
bpp32 *= 128;
(* encoding *)
cp866 *= 1;
utf16le *= 2;
utf8 *= 3;
VAR
// draw text on 24bpp or 32bpp image
// autofits text between 'x' and 'xSize'
drawText *: PROCEDURE (canvas, x, y, string, charQuantity, fontColor, params: INTEGER): INTEGER;
(*
[canvas]:
xSize dd ?
ySize dd ?
picture rb xSize * ySize * bpp
fontColor dd AARRGGBB
AA = alpha channel ; 0 = transparent, FF = non transparent
params dd ffeewwhh
hh = char height
ww = char width ; 0 = auto (proportional)
ee = encoding ; 1 = cp866, 2 = UTF-16LE, 3 = UTF-8
ff = flags ; 0001 = bold, 0010 = italic
; 0100 = underline, 1000 = strike-through
00010000 = align right, 00100000 = align center
01000000 = set text area between higher and lower halfs of 'x'
10000000 = 32bpp canvas insted of 24bpp
all flags combinable, except align right + align center
returns: char width (0 = error)
*)
// calculate amount of valid chars in UTF-8 string
// supports zero terminated string (set byteQuantity = -1)
cntUTF_8 *: PROCEDURE (string, byteQuantity: INTEGER): INTEGER;
// calculate amount of chars that fits given width
charsFit *: PROCEDURE (areaWidth, charHeight: INTEGER): INTEGER;
// calculate string width in pixels
strWidth *: PROCEDURE (charQuantity, charHeight: INTEGER): INTEGER;
PROCEDURE params* (charHeight, charWidth, encoding, flags: INTEGER): INTEGER;
(*
hh = char height
ww = char width ; 0 = auto (proportional)
ee = encoding ; 1 = cp866, 2 = UTF-16LE, 3 = UTF-8
ff = flags ; 0001 = bold, 0010 = italic
; 0100 = underline, 1000 = strike-through
00010000 = align right, 00100000 = align center
01000000 = set text area between higher and lower halfs of 'x'
10000000 = 32bpp canvas insted of 24bpp
all flags combinable, except align right + align center
*)
RETURN charHeight + LSL(charWidth, 8) + LSL(encoding, 16) + LSL(flags, 24)
END params;
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
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");
END main;
BEGIN
main
END RasterWorks.

/programs/develop/oberon07/Lib/KolibriOS/Read.ob07
0,0 → 1,50
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Read;
IMPORT File, sys := SYSTEM;
PROCEDURE Char*(F: File.FS; VAR x: CHAR): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR)
END Char;
PROCEDURE Int*(F: File.FS; VAR x: INTEGER): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER)
END Int;
PROCEDURE Real*(F: File.FS; VAR x: REAL): BOOLEAN;
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;
PROCEDURE Set*(F: File.FS; VAR x: SET): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET)
END Set;
PROCEDURE Card16*(F: File.FS; VAR x: sys.CARD16): BOOLEAN;
RETURN File.Read(F, sys.ADR(x), sys.SIZE(sys.CARD16)) = sys.SIZE(sys.CARD16)
END Card16;
END Read.

/programs/develop/oberon07/Lib/KolibriOS/Write.ob07
0,0 → 1,50
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Write;
IMPORT File, sys := SYSTEM;
PROCEDURE Char*(F: File.FS; x: CHAR): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(CHAR)) = sys.SIZE(CHAR)
END Char;
PROCEDURE Int*(F: File.FS; x: INTEGER): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(INTEGER)) = sys.SIZE(INTEGER)
END Int;
PROCEDURE Real*(F: File.FS; x: REAL): BOOLEAN;
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;
PROCEDURE Set*(F: File.FS; x: SET): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(SET)) = sys.SIZE(SET)
END Set;
PROCEDURE Card16*(F: File.FS; x: sys.CARD16): BOOLEAN;
RETURN File.Write(F, sys.ADR(x), sys.SIZE(sys.CARD16)) = sys.SIZE(sys.CARD16)
END Card16;
END Write.

/programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07
0,0 → 1,478
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE kfonts;
IMPORT sys := SYSTEM;
CONST
MIN_FONT_SIZE = 8;
MAX_FONT_SIZE = 46;
bold *= 1;
italic *= 2;
underline *= 4;
strike_through *= 8;
smoothing *= 16;
bpp32 *= 32;
TYPE
Glyph = RECORD
base: INTEGER;
xsize, ysize: INTEGER;
width: INTEGER
END;
TFont_desc = RECORD
data, size, font, char_size, width, height, font_size, mem, mempos: INTEGER;
glyphs: ARRAY 4, 256 OF Glyph
END;
TFont* = POINTER TO TFont_desc;
PROCEDURE [stdcall] LoadFile(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 *)
RETURN 0
END LoadFile;
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] zeromem(size, adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN);
VAR xsize, ysize: INTEGER;
BEGIN
sys.GET(buf, xsize);
sys.GET(buf + 4, ysize);
INC(buf, 8);
IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN
IF bpp32 THEN
sys.PUT(buf + 4 * (xsize * y + x), color)
ELSE
sys.MOVE(sys.ADR(color), buf + 3 * (xsize * y + x), 3)
END
END
END pset;
PROCEDURE pget(buf, x, y: INTEGER; bpp32: BOOLEAN): INTEGER;
VAR xsize, ysize, color: INTEGER;
BEGIN
sys.GET(buf, xsize);
sys.GET(buf + 4, ysize);
INC(buf, 8);
IF (0 <= x) & (x < xsize) & (0 <= y) & (y < ysize) THEN
IF bpp32 THEN
sys.GET(buf + 4 * (xsize * y + x), color)
ELSE
sys.MOVE(buf + 3 * (xsize * y + x), sys.ADR(color), 3)
END
END
RETURN color
END pget;
PROCEDURE getrgb(color: INTEGER; VAR r, g, b: INTEGER);
BEGIN
b := LSR(LSL(color, 24), 24);
g := LSR(LSL(color, 16), 24);
r := LSR(LSL(color, 8), 24);
END getrgb;
PROCEDURE rgb(r, g, b: INTEGER): INTEGER;
RETURN b + LSL(g, 8) + LSL(r, 16)
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;
glyph.ysize := ysize;
Font.mempos := Font.mempos + xsize * ysize
END create_glyph;
PROCEDURE getpix(Font: TFont_desc; n, x, y, xsize: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(Font.mem + n + x + y * xsize, res)
RETURN res
END getpix;
PROCEDURE setpix(VAR Font: TFont_desc; n, x, y, xsize: INTEGER; c: CHAR);
BEGIN
sys.PUT(Font.mem + n + x + y * xsize, c)
END setpix;
PROCEDURE smooth(VAR Font: TFont_desc; n, xsize, ysize: INTEGER);
VAR x, y: INTEGER;
BEGIN
FOR y := 1 TO ysize - 1 DO
FOR x := 1 TO xsize - 1 DO
IF (getpix(Font, n, x, y, xsize) = 1X) & (getpix(Font, n, x - 1, y - 1, xsize) = 1X) &
(getpix(Font, n, x - 1, y, xsize) = 0X) & (getpix(Font, n, x, y - 1, xsize) = 0X) THEN
setpix(Font, n, x - 1, y, xsize, 2X);
setpix(Font, n, x, y - 1, xsize, 2X)
END;
IF (getpix(Font, n, x, y, xsize) = 0X) & (getpix(Font, n, x - 1, y - 1, xsize) = 0X) &
(getpix(Font, n, x - 1, y, xsize) = 1X) & (getpix(Font, n, x, y - 1, xsize) = 1X) THEN
setpix(Font, n, x, y, xsize, 2X);
setpix(Font, n, x - 1, y - 1, xsize, 2X)
END
END
END
END smooth;
PROCEDURE _bold(VAR Font: TFont_desc; src, dst, src_xsize, dst_xsize, n: INTEGER);
VAR i, j, k: INTEGER; pix: CHAR;
BEGIN
FOR i := 0 TO src_xsize - 1 DO
FOR j := 0 TO Font.height - 1 DO
pix := getpix(Font, src, i, j, src_xsize);
IF pix = 1X THEN
FOR k := 0 TO n DO
setpix(Font, dst, i + k, j, dst_xsize, pix)
END
END
END
END
END _bold;
PROCEDURE make_glyph(VAR Font: TFont_desc; c: INTEGER);
VAR ptr, i, j, max, x, y: INTEGER; s: SET; eoc: BOOLEAN;
glyph: Glyph; pix: CHAR; bold_width: INTEGER;
BEGIN
create_glyph(Font, glyph, Font.width, Font.height);
x := 0;
y := 0;
max := 0;
ptr := Font.font + Font.char_size * c;
eoc := FALSE;
REPEAT
sys.GET(ptr, s);
INC(ptr, 4);
FOR i := 0 TO 31 DO
IF ~eoc THEN
IF i IN s THEN
setpix(Font, glyph.base, x, y, Font.width, 1X);
IF x > max THEN
max := x
END
ELSE
setpix(Font, glyph.base, x, y, Font.width, 0X)
END
END;
INC(x);
IF x = Font.width THEN
x := 0;
INC(y);
eoc := eoc OR (y = Font.height)
END
END
UNTIL eoc;
IF max = 0 THEN
max := Font.width DIV 3
END;
glyph.width := max;
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
Font.glyphs[0, c] := glyph;
bold_width := 1;
create_glyph(Font, glyph, Font.width + bold_width, Font.height);
_bold(Font, Font.glyphs[0, c].base, glyph.base, Font.glyphs[0, c].xsize, glyph.xsize, bold_width);
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max + bold_width;
Font.glyphs[1, c] := glyph;
create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3, Font.height);
FOR i := 0 TO Font.glyphs[0, c].xsize - 1 DO
FOR j := 0 TO Font.height - 1 DO
pix := getpix(Font, Font.glyphs[0, c].base, i, j, Font.glyphs[0, c].xsize);
IF pix = 1X THEN
setpix(Font, glyph.base, i + (Font.height - 1 - j) DIV 3, j, glyph.xsize, pix)
END
END
END;
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max;
Font.glyphs[2, c] := glyph;
create_glyph(Font, glyph, Font.width + (Font.height - 1) DIV 3 + bold_width, Font.height);
_bold(Font, Font.glyphs[2, c].base, glyph.base, Font.glyphs[2, c].xsize, glyph.xsize, bold_width);
smooth(Font, glyph.base, glyph.xsize, glyph.ysize);
glyph.width := max + bold_width;
Font.glyphs[3, c] := glyph;
END make_glyph;
PROCEDURE OutChar(Font: TFont_desc; c: INTEGER; x, y: INTEGER; buf: INTEGER; bpp32, smoothing: BOOLEAN; color, style: INTEGER): INTEGER;
VAR i, x0, y0, xsize, mem, xmax: INTEGER; r, g, b, r0, g0, b0: INTEGER; ch: CHAR; glyph: Glyph;
BEGIN
x0 := x;
y0 := y;
style := style MOD 4;
glyph := Font.glyphs[style, c];
xsize := glyph.xsize;
xmax := x0 + xsize;
mem := Font.mem + glyph.base;
FOR i := mem TO mem + xsize * Font.height - 1 DO
sys.GET(i, ch);
IF ch = 1X THEN
pset(buf, x, y, color, bpp32)
ELSIF (ch = 2X) & smoothing THEN
getrgb(pget(buf, x, y, bpp32), r, g, b);
getrgb(color, r0, g0, b0);
r := (r * 3 + r0) DIV 4;
g := (g * 3 + g0) DIV 4;
b := (b * 3 + b0) DIV 4;
pset(buf, x, y, rgb(r, g, b), bpp32)
END;
INC(x);
IF x = xmax THEN
x := x0;
INC(y)
END
END
RETURN glyph.width
END OutChar;
PROCEDURE hline(buf, x, y, width, color: INTEGER; bpp32: BOOLEAN);
VAR i: INTEGER;
BEGIN
FOR i := x TO x + width - 1 DO
pset(buf, i, y, color, bpp32)
END
END hline;
PROCEDURE TextOut*(Font: TFont; canvas, x, y, str, length, color, params: INTEGER);
VAR width: INTEGER; c: CHAR; bpp32, smoothing: BOOLEAN;
BEGIN
IF Font # NIL THEN
smoothing := 4 IN BITS(params);
bpp32 := 5 IN BITS(params);
sys.GET(str, c);
WHILE (length > 0) OR (length = -1) & (c # 0X) DO
INC(str);
width := OutChar(Font^, ORD(c), x, y, canvas, bpp32, smoothing, color, params);
IF 3 IN BITS(params) THEN
hline(canvas, x + ORD(1 IN BITS(params)) * ((Font.height DIV 2) DIV 3), y + Font.height DIV 2, width, color, bpp32)
END;
IF 2 IN BITS(params) THEN
hline(canvas, x, y + Font.height - 1, width, color, bpp32)
END;
x := x + width;
IF length > 0 THEN
DEC(length)
END;
sys.GET(str, c)
END
END
END TextOut;
PROCEDURE TextWidth*(Font: TFont; str, length, params: INTEGER): INTEGER;
VAR res: INTEGER; c: CHAR;
BEGIN
res := 0;
params := params MOD 4;
IF Font # NIL THEN
sys.GET(str, c);
WHILE (length > 0) OR (length = -1) & (c # 0X) DO
INC(str);
res := res + Font.glyphs[params, ORD(c)].width;
IF length > 0 THEN
DEC(length)
END;
sys.GET(str, c)
END
END
RETURN res
END TextWidth;
PROCEDURE TextHeight*(Font: TFont): INTEGER;
VAR res: INTEGER;
BEGIN
IF Font # NIL THEN
res := Font.height
ELSE
res := 0
END
RETURN res
END TextHeight;
PROCEDURE SetSize*(_Font: TFont; font_size: INTEGER): BOOLEAN;
VAR temp, offset, fsize, i, memsize, mem: INTEGER;
c: CHAR; Font, Font2: TFont_desc;
BEGIN
offset := -1;
IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (_Font # NIL) THEN
Font := _Font^;
Font2 := Font;
temp := Font.data + (font_size - 8) * 4;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN
sys.GET(temp, offset);
IF offset # -1 THEN
Font.font_size := font_size;
INC(offset, 156);
offset := offset + Font.data;
IF (Font.data <= offset) & (offset <= Font.size + Font.data - 4) THEN
sys.GET(offset, fsize);
IF fsize > 256 + 6 THEN
temp := offset + fsize - 1;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 1) THEN
sys.GET(temp, c);
IF c # 0X THEN
Font.height := ORD(c);
DEC(temp);
sys.GET(temp, c);
IF c # 0X THEN
Font.width := ORD(c);
DEC(fsize, 6);
Font.char_size := fsize DIV 256;
IF fsize MOD 256 # 0 THEN
INC(Font.char_size)
END;
IF Font.char_size > 0 THEN
Font.font := offset + 4;
Font.mempos := 0;
memsize := (Font.width + 10) * Font.height * 1024;
mem := Font.mem;
Font.mem := sysfunc3(68, 12, memsize);
IF Font.mem # 0 THEN
IF mem # 0 THEN
mem := sysfunc3(68, 13, mem)
END;
zeromem(memsize DIV 4, Font.mem);
FOR i := 0 TO 255 DO
make_glyph(Font, i)
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
ELSE
offset := -1
END
END;
ELSE
offset := -1
END;
IF offset # -1 THEN
_Font^ := Font
ELSE
_Font^ := Font2
END
END
RETURN offset # -1
END SetSize;
PROCEDURE Enabled*(Font: TFont; font_size: INTEGER): BOOLEAN;
VAR offset, temp: INTEGER;
BEGIN
offset := -1;
IF (MIN_FONT_SIZE <= font_size) & (font_size <= MAX_FONT_SIZE) & (Font # NIL) THEN
temp := Font.data + (font_size - 8) * 4;
IF (Font.data <= temp) & (temp <= Font.size + Font.data - 4) THEN
sys.GET(temp, offset)
END
END
RETURN offset # -1
END Enabled;
PROCEDURE Destroy*(VAR Font: TFont);
BEGIN
IF Font # NIL THEN
IF Font.mem # 0 THEN
Font.mem := sysfunc3(68, 13, Font.mem)
END;
IF Font.data # 0 THEN
Font.data := sysfunc3(68, 13, Font.data)
END;
DISPOSE(Font)
END
END Destroy;
PROCEDURE LoadFont*(file_name: ARRAY OF CHAR): TFont;
VAR Font: TFont; data, size, n: INTEGER;
BEGIN
data := LoadFile(sys.ADR(file_name[0]), size);
IF (data # 0) & (size > 156) THEN
NEW(Font);
Font.data := data;
Font.size := size;
Font.font_size := 0;
n := MIN_FONT_SIZE;
WHILE ~SetSize(Font, n) & (n <= MAX_FONT_SIZE) DO
INC(n)
END;
IF Font.font_size = 0 THEN
Destroy(Font)
END
ELSE
IF data # 0 THEN
data := sysfunc3(68, 13, data)
END;
Font := NIL
END
RETURN Font
END LoadFont;
END kfonts.

/programs/develop/oberon07/Lib/KolibriOS/libimg.ob07
0,0 → 1,435
(*
Copyright 2016 KolibriOS team
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE libimg;
IMPORT sys := SYSTEM, KOSAPI;
CONST
FLIP_VERTICAL *= 1;
FLIP_HORIZONTAL *= 2;
ROTATE_90_CW *= 1;
ROTATE_180 *= 2;
ROTATE_270_CW *= 3;
ROTATE_90_CCW *= ROTATE_270_CW;
ROTATE_270_CCW *= ROTATE_90_CW;
// scale type corresponding img_scale params
LIBIMG_SCALE_INTEGER *= 1; // scale factor ; reserved 0
LIBIMG_SCALE_TILE *= 2; // new width ; new height
LIBIMG_SCALE_STRETCH *= 3; // new width ; new height
LIBIMG_SCALE_FIT_RECT *= 4; // new width ; new height
LIBIMG_SCALE_FIT_WIDTH *= 5; // new width ; new height
LIBIMG_SCALE_FIT_HEIGHT *= 6; // new width ; new height
LIBIMG_SCALE_FIT_MAX *= 7; // new width ; new height
// interpolation algorithm
LIBIMG_INTER_NONE *= 0; // use it with LIBIMG_SCALE_INTEGER, LIBIMG_SCALE_TILE, etc
LIBIMG_INTER_BILINEAR *= 1;
LIBIMG_INTER_DEFAULT *= LIBIMG_INTER_BILINEAR;
// list of format id's
LIBIMG_FORMAT_BMP *= 1;
LIBIMG_FORMAT_ICO *= 2;
LIBIMG_FORMAT_CUR *= 3;
LIBIMG_FORMAT_GIF *= 4;
LIBIMG_FORMAT_PNG *= 5;
LIBIMG_FORMAT_JPEG *= 6;
LIBIMG_FORMAT_TGA *= 7;
LIBIMG_FORMAT_PCX *= 8;
LIBIMG_FORMAT_XCF *= 9;
LIBIMG_FORMAT_TIFF *= 10;
LIBIMG_FORMAT_PNM *= 11;
LIBIMG_FORMAT_WBMP *= 12;
LIBIMG_FORMAT_XBM *= 13;
LIBIMG_FORMAT_Z80 *= 14;
// encode flags (byte 0x02 of common option)
LIBIMG_ENCODE_STRICT_SPECIFIC *= 01H;
LIBIMG_ENCODE_STRICT_BIT_DEPTH *= 02H;
LIBIMG_ENCODE_DELETE_ALPHA *= 08H;
LIBIMG_ENCODE_FLUSH_ALPHA *= 10H;
// values for Image.Type
// must be consecutive to allow fast switch on Image.Type in support functions
bpp8i *= 1; // indexed
bpp24 *= 2;
bpp32 *= 3;
bpp15 *= 4;
bpp16 *= 5;
bpp1 *= 6;
bpp8g *= 7; // grayscale
bpp2i *= 8;
bpp4i *= 9;
bpp8a *= 10; // grayscale with alpha channel; application layer only!!! kernel doesn't handle this image type, libimg can only create and destroy such images
// bits in Image.Flags
IsAnimated *= 1;
TYPE
Image* = RECORD
Checksum *: INTEGER;
Width *: INTEGER;
Height *: INTEGER;
Next *: INTEGER;
Previous *: INTEGER;
Type *: INTEGER; // one of bppN
Data *: INTEGER;
Palette *: INTEGER; // used iff Type eq bpp1, bpp2, bpp4 or bpp8i
Extended *: INTEGER;
Flags *: INTEGER; // bitfield
Delay *: INTEGER // used iff IsAnimated is set in Flags
END;
ImageDecodeOptions* = RECORD
UsedSize *: INTEGER; // if >=8, the field BackgroundColor is valid, and so on
BackgroundColor *: INTEGER // used for transparent images as background
END;
FormatsTableEntry* = RECORD
Format_id *: INTEGER;
Is *: INTEGER;
Decode *: INTEGER;
Encode *: INTEGER;
Capabilities *: INTEGER
END;
VAR
img_is_img *: PROCEDURE (data, length: INTEGER): INTEGER;
img_to_rgb2 *: PROCEDURE (img: INTEGER; out: INTEGER);
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes image data into RGB triplets and stores them where out points to ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to source image ;;
;> out = where to store RGB triplets ;;
;;================================================================================================;;
*)
img_to_rgb *: PROCEDURE (img: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes image data into RGB triplets and returns pointer to memory area containing them ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to source image ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to rgb_data (array of [rgb] triplets) ;;
;;================================================================================================;;
*)
img_decode *: PROCEDURE (data, length, options: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes loaded into memory graphic file ;;
;;------------------------------------------------------------------------------------------------;;
;> data = pointer to file in memory ;;
;> length = size in bytes of memory area pointed to by data ;;
;> options = 0 / pointer to the structure of additional options ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to image ;;
;;================================================================================================;;
*)
img_encode *: PROCEDURE (img: INTEGER; common, specific: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? encode image to some format ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to input image ;;
;> common = some most important options ;;
; 0x00 : byte : format id ;;
; 0x01 : byte : fast encoding (0) / best compression ratio (255) ;;
; 0 : store uncompressed data (if supported both by the format and libimg) ;;
; 1 - 255 : use compression, if supported ;;
; this option may be ignored if any format specific options are defined ;;
; i.e. the 0 here will be ignored if some compression algorithm is specified ;;
; 0x02 : byte : flags (bitfield) ;;
; 0x01 : return an error if format specific conditions cannot be met ;;
; 0x02 : preserve current bit depth. means 8bpp/16bpp/24bpp and so on ;;
; 0x04 : delete alpha channel, if any ;;
; 0x08 : flush alpha channel with 0xff, if any; add it if none ;;
; 0x03 : byte : reserved, must be 0 ;;
;> specific = 0 / pointer to the structure of format specific options ;;
; see <format_name>.inc for description ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to encoded data ;;
;;================================================================================================;;
*)
img_create *: PROCEDURE (width, height, type: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? creates an Image structure and initializes some its fields ;;
;;------------------------------------------------------------------------------------------------;;
;> width = width of an image in pixels ;;
;> height = height of an image in pixels ;;
;> type = one of the bppN constants ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to image ;;
;;================================================================================================;;
*)
img_destroy *: PROCEDURE (img: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? frees memory occupied by an image and all the memory regions its fields point to ;;
;? follows Previous/Next pointers and deletes all the images in sequence ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE (fail) / TRUE (success) ;;
;;================================================================================================;;
*)
img_destroy_layer *: PROCEDURE (img: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? frees memory occupied by an image and all the memory regions its fields point to ;;
;? for image sequences deletes only one frame and fixes Previous/Next pointers ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE (fail) / TRUE (success) ;;
;;================================================================================================;;
*)
img_count *: PROCEDURE (img: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? Get number of images in the list (e.g. in animated GIF file) ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;;------------------------------------------------------------------------------------------------;;
;< -1 (fail) / >0 (ok) ;;
;;================================================================================================;;
*)
img_flip *: PROCEDURE (img: INTEGER; flip_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Flip all layers of image ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> flip_kind = one of FLIP_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_flip_layer *: PROCEDURE (img: INTEGER; flip_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Flip image layer ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> flip_kind = one of FLIP_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_rotate *: PROCEDURE (img: INTEGER; rotate_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Rotate all layers of image ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> rotate_kind = one of ROTATE_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_rotate_layer *: PROCEDURE (img: INTEGER; rotate_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Rotate image layer ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> rotate_kind = one of ROTATE_* constants ;;
;;------------------------------------------------------------------------------------------------;;
;< FALSE / TRUE ;;
;;================================================================================================;;
*)
img_draw *: PROCEDURE (img: INTEGER; x, y, width, height, xpos, ypos: INTEGER);
(*
;;------------------------------------------------------------------------------------------------;;
;? Draw image in the window ;;
;;------------------------------------------------------------------------------------------------;;
;> img = pointer to image ;;
;> x = x-coordinate in the window ;;
;> y = y-coordinate in the window ;;
;> width = maximum width to draw ;;
;> height = maximum height to draw ;;
;> xpos = offset in image by x-axis ;;
;> ypos = offset in image by y-axis ;;
;;================================================================================================;;
*)
img_scale *: PROCEDURE (src: INTEGER; crop_x, crop_y, crop_width, crop_height: INTEGER; dst: INTEGER; scale, inter, param1, param2: INTEGER ): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? scale _image ;;
;;------------------------------------------------------------------------------------------------;;
;> src = pointer to source image ;;
;> crop_x = left coord of cropping rect ;;
;> crop_y = top coord of cropping rect ;;
;> crop_width = width of cropping rect ;;
;> crop_height = height of cropping rect ;;
;> dst = pointer to resulting image / 0 ;;
;> scale = how to change width and height. see libimg.inc ;;
;> inter = interpolation algorithm ;;
;> param1 = see libimg.inc ;;
;> param2 = see libimg.inc ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to scaled image ;;
;;================================================================================================;;
*)
img_convert *: PROCEDURE (src, dst: INTEGER; dst_type, flags, param: INTEGER);
(*
;;------------------------------------------------------------------------------------------------;;
;? scale _image ;;
;;------------------------------------------------------------------------------------------------;;
;> src = pointer to source image ;;
;> flags = see libimg.inc ;;
;> dst_type = the Image.Type of converted image ;;
;> dst = pointer to destination image, if any ;;
;;------------------------------------------------------------------------------------------------;;
;< 0 / pointer to converted image ;;
;;================================================================================================;;
*)
img_formats_table *: ARRAY 20 OF FormatsTableEntry;
PROCEDURE GetImageStruct* (img: INTEGER; VAR ImageStruct: Image): BOOLEAN;
BEGIN
IF img # 0 THEN
sys.MOVE(img, sys.ADR(ImageStruct), sys.SIZE(Image))
END
RETURN img # 0
END GetImageStruct;
PROCEDURE GetFormatsTable(ptr: INTEGER);
VAR i: INTEGER; eot: BOOLEAN;
BEGIN
i := 0;
REPEAT
sys.MOVE(ptr, sys.ADR(img_formats_table[i]), sys.SIZE(FormatsTableEntry));
ptr := ptr + sys.SIZE(FormatsTableEntry);
eot := img_formats_table[i].Format_id = 0;
INC(i)
UNTIL eot OR (i = LEN(img_formats_table))
END GetFormatsTable;
PROCEDURE main;
VAR Lib, formats_table_ptr: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
ASSERT(a # 0);
sys.PUT(v, a)
END GetProc;
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");
GetFormatsTable(formats_table_ptr)
END main;
BEGIN
main
END libimg.

/programs/develop/oberon07/Lib/Linux32/API.ob07
0,0 → 1,143
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE API;
IMPORT sys := SYSTEM;
TYPE
TP* = ARRAY 2 OF INTEGER;
VAR
Param*: INTEGER;
sec* : INTEGER;
dsec* : INTEGER;
stdin* : INTEGER;
stdout* : INTEGER;
stderr* : INTEGER;
dlopen* : PROCEDURE [cdecl] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [cdecl] (handle, symbol: INTEGER): INTEGER;
_malloc* : PROCEDURE [cdecl] (size: INTEGER): INTEGER;
free* : PROCEDURE [cdecl] (ptr: INTEGER);
fopen* : PROCEDURE [cdecl] (fname, fmode: INTEGER): INTEGER;
fclose*, ftell* : PROCEDURE [cdecl] (file: INTEGER): INTEGER;
fwrite*, fread* : PROCEDURE [cdecl] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fseek* : PROCEDURE [cdecl] (file, offset, origin: INTEGER): INTEGER;
exit* : PROCEDURE [cdecl] (code: INTEGER);
strncmp* : PROCEDURE [cdecl] (str1, str2, n: INTEGER): INTEGER;
strlen* : PROCEDURE [cdecl] (str: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [cdecl] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
PROCEDURE malloc* (Bytes: INTEGER): INTEGER;
VAR res: INTEGER;
BEGIN
Bytes := Align(Bytes, 4);
res := _malloc(Bytes);
IF res # 0 THEN
zeromem(ASR(Bytes, 2), res)
END
RETURN res
END malloc;
PROCEDURE Free* (hMem: INTEGER): INTEGER;
BEGIN
free(hMem)
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;
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;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
exit(code)
END ExitProcess;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
VAR H: INTEGER;
BEGIN
H := dlsym(hMOD, sys.ADR(name[0]));
ASSERT(H # 0);
sys.PUT(adr, H);
END GetProc;
PROCEDURE init* (esp: INTEGER);
VAR lib, proc: 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);
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
0,0 → 1,121
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
CONST
OS* = "LNX";
Slash* = "/";
VAR
fsize : INTEGER;
sec* : INTEGER;
dsec* : INTEGER;
PROCEDURE GetCommandLine* (): INTEGER;
RETURN API.Param
END GetCommandLine;
PROCEDURE CloseFile* (File: INTEGER);
BEGIN
File := API.fclose(File)
END CloseFile;
PROCEDURE FileRW* (hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR res: INTEGER;
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;
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR res: INTEGER;
BEGIN
res := FileRW(API.stdout, sys.ADR(str), LENGTH(str), TRUE)
END OutString;
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(sys.ADR(FName), sys.ADR("wb"))
END CreateFile;
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
VAR F, 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)
END
RETURN F
END OpenFile;
PROCEDURE FileSize* (F: INTEGER): INTEGER;
RETURN fsize
END FileSize;
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
PROCEDURE malloc* (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)
END
RETURN res
END malloc;
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
API.exit(code)
END ExitProcess;
PROCEDURE Time* (VAR sec, dsec: INTEGER);
VAR tp: API.TP;
BEGIN
IF API.clock_gettime(0, tp) = 0 THEN
sec := tp[0];
dsec := tp[1] DIV 10000000
ELSE
sec := 0;
dsec := 0
END
END Time;
PROCEDURE init*;
BEGIN
Time(sec, dsec)
END init;
PROCEDURE GetName*(): INTEGER;
RETURN 0
END GetName;
END HOST.

/programs/develop/oberon07/Lib/Linux32/RTL.ob07
0,0 → 1,279
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN
API.ExitProcess(n)
END _halt;
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
END
END _disprec;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
BEGIN
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
END
RETURN res
END _saverec;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: 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
END
END _arrayidx;
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
BEGIN
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
END
END _arrayidx1;
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: 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
END
END _arrayrot;
PROCEDURE Min(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END Min;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
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
RETURN 0
END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN
_savearr(Min(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: 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)
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
END
RETURN Res
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
BEGIN
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END Int;
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;
BEGIN
n := LEN(s);
i := 0;
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
END
END StrAppend;
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")
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)
END _assrt;
PROCEDURE [stdcall] _close*;
BEGIN
IF CloseProc # NIL THEN
CloseProc
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
BEGIN
API.zeromem(gsize, gadr);
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL;
END _init;
PROCEDURE SetClose*(proc: PROC);
BEGIN
CloseProc := proc
END SetClose;
END RTL.

/programs/develop/oberon07/Lib/Windows32/API.ob07
0,0 → 1,75
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE API;
IMPORT sys := 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);
strncmp*: PROCEDURE [cdecl] (a, b, n: INTEGER): INTEGER;
GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER;
LoadLibraryA*: PROCEDURE [winapi] (name: INTEGER): INTEGER;
PROCEDURE zeromem*(size, adr: INTEGER);
END zeromem;
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;
BEGIN
sys.GET(esp, GetProcAddress);
sys.GET(esp + 4, LoadLibraryA);
lib := LoadLibraryA(sys.ADR("kernel32.dll"));
GetProc("ExitProcess", lib, sys.ADR(ExitProcess));
GetProc("GlobalAlloc", lib, sys.ADR(Alloc));
GetProc("GlobalFree", lib, sys.ADR(Free));
lib := LoadLibraryA(sys.ADR("msvcrt.dll"));
GetProc("strncmp", lib, sys.ADR(strncmp));
lib := LoadLibraryA(sys.ADR("user32.dll"));
GetProc("MessageBoxA", lib, sys.ADR(MessageBoxA));
END init;
END API.

/programs/develop/oberon07/Lib/Windows32/HOST.ob07
0,0 → 1,141
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
CONST
OS* = "WIN";
Slash* = "\";
OFS_MAXPATHNAME = 128;
TYPE
OFSTRUCT = RECORD
cBytes: CHAR;
fFixedDisk: CHAR;
nErrCode: sys.CARD16;
Reserved1: sys.CARD16;
Reserved2: sys.CARD16;
szPathName: ARRAY OFS_MAXPATHNAME OF CHAR
END;
VAR
sec*, dsec*, 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;
Alloc: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
SetFilePointer: PROCEDURE [winapi] (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
PROCEDURE FileRW*(hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR res: INTEGER;
BEGIN
IF write THEN
WriteFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0)
ELSE
ReadFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0)
END
RETURN res
END FileRW;
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR res: INTEGER;
BEGIN
res := FileRW(hConsoleOutput, sys.ADR(str[0]), LENGTH(str), TRUE)
END OutString;
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
VAR res: INTEGER;
BEGIN
res := _CreateFile(sys.ADR(FName[0]), 0C0000000H, 0, 0, 2, 80H, 0);
IF res = -1 THEN
res := 0
END
RETURN res
END CreateFile;
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
VAR res: INTEGER; ofstr: OFSTRUCT;
BEGIN
res := _OpenFile(sys.ADR(FName[0]), ofstr, 0);
IF res = -1 THEN
res := 0
END
RETURN res
END OpenFile;
PROCEDURE FileSize*(F: INTEGER): INTEGER;
VAR res: INTEGER;
BEGIN
res := SetFilePointer(F, 0, 0, 2);
SetFilePointer(F, 0, 0, 0)
RETURN res
END FileSize;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
BEGIN
sys.PUT(adr, API.GetProcAddress(hMOD, sys.ADR(name[0])))
END GetProc;
PROCEDURE Time*(VAR sec, dsec: INTEGER);
VAR t: INTEGER;
BEGIN
t := GetTickCount() DIV 10;
sec := t DIV 100;
dsec := t MOD 100
END Time;
PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN Alloc(64, size)
END malloc;
PROCEDURE init*;
VAR lib: 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("ExitProcess", lib, sys.ADR(ExitProcess));
GetProc("GlobalAlloc", lib, sys.ADR(Alloc));
GetProc("SetFilePointer", lib, sys.ADR(SetFilePointer));
hConsoleOutput := GetStdHandle(-11)
END init;
PROCEDURE GetName*(): INTEGER;
RETURN 0
END GetName;
END HOST.

/programs/develop/oberon07/Lib/Windows32/RTL.ob07
0,0 → 1,279
(*
Copyright 2016 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
PROCEDURE [stdcall] _halt*(n: INTEGER);
BEGIN
API.ExitProcess(n)
END _halt;
PROCEDURE [stdcall] _newrec*(size, t: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
sys.PUT(ptr, t);
INC(ptr, 4)
END
END _newrec;
PROCEDURE [stdcall] _disprec*(VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - 4)
END
END _disprec;
PROCEDURE [stdcall] _rset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C3BC87F0A83F91F760B83F81F760633C0C9C2080083F9007D0233C983F81F7E05B81F000000BA000000802BC8F7D9D3FA83E81F8BC8F7D9D3EA8BC2C9C20800")
END _rset;
PROCEDURE [stdcall] _inset*(y, x: INTEGER);
BEGIN
sys.CODE("8B45088B4D0C83F91F7709D3E883E001C9C20800C933C0C20800")
END _inset;
PROCEDURE [stdcall] _checktype*(table, t, r: INTEGER);
BEGIN
table := rtab;
sys.CODE("8B450C8B4D1085C975076A0158C9C20C008B51FC8B4D083BD0740D85D27409C1E20203D18B12EBEF33C93BC20F94C18BC1C9C20C00")
END _checktype;
PROCEDURE [stdcall] _savearr*(size, source, dest: INTEGER);
BEGIN
sys.CODE("9CFC8BD78BC68B7D108B750C8B4D08F3A48BFA8BF09D")
END _savearr;
PROCEDURE [stdcall] _saverec*(dyn, stat, size, source, dest: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
res := dyn = stat;
IF res THEN
_savearr(size, source, dest)
END
RETURN res
END _saverec;
PROCEDURE [stdcall] _arrayidx*(Dim: INTEGER; VAR Arr: IntArray; bsize, idx, c: INTEGER);
VAR i, m: 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
END
END _arrayidx;
PROCEDURE [stdcall] _arrayidx1*(VAR Arr: IntArray; bsize, idx, c: INTEGER);
BEGIN
IF (Arr[3] > idx) & (idx >= 0) THEN
Arr[3] := bsize * idx + c
ELSE
Arr[3] := 0
END
END _arrayidx1;
PROCEDURE [stdcall] _arrayrot*(m, n: INTEGER; VAR Arr: IntArray);
VAR i, j, t: 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
END
END _arrayrot;
PROCEDURE Min(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END Min;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
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
RETURN 0
END _length;
PROCEDURE [stdcall] _strcopy*(b, blen, a, alen: INTEGER);
BEGIN
_savearr(Min(alen, blen), a, b);
IF blen > alen THEN
sys.PUT(b + alen, 0X)
END
END _strcopy;
PROCEDURE [stdcall] _strcmp*(op: INTEGER; b, a: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; Res: 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)
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
END
RETURN Res
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
PROCEDURE Int(x: INTEGER; VAR str: STRING);
VAR i, a, b: INTEGER; c: CHAR;
BEGIN
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END Int;
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;
BEGIN
n := LEN(s);
i := 0;
WHILE (i < n) & (s[i] # 0X) DO
msg[pos] := s[i];
INC(pos);
INC(i)
END
END StrAppend;
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")
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)
END _assrt;
PROCEDURE [stdcall] _close*;
BEGIN
IF CloseProc # NIL THEN
CloseProc
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
BEGIN
API.zeromem(gsize, gadr);
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL;
END _init;
PROCEDURE SetClose*(proc: PROC);
BEGIN
CloseProc := proc
END SetClose;
END RTL.

/programs/develop/oberon07/Samples/Dialogs.ob07
0,0 → 1,114
MODULE Dialogs;
IMPORT KOSAPI, sys := SYSTEM, OpenDlg, ColorDlg;
VAR header: ARRAY 1024 OF CHAR; back_color: INTEGER;
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := 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)
END DefineAndDrawWindow;
PROCEDURE WaitForEvent(): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
PROCEDURE ExitApp;
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc1(-1)
END ExitApp;
PROCEDURE pause(t: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc2(5, t)
END pause;
PROCEDURE Buttons;
PROCEDURE Button(id, X, Y, W, H: INTEGER; Caption: ARRAY OF CHAR);
VAR n, aux: INTEGER;
BEGIN
n := LENGTH(Caption);
aux := KOSAPI.sysfunc5(8, X * 65536 + W, Y * 65536 + H, id, 00C0C0C0H);
X := X + (W - 8 * n) DIV 2;
Y := Y + (H - 14) DIV 2;
aux := KOSAPI.sysfunc6(4, X * 65536 + Y, LSL(48, 24), sys.ADR(Caption[0]), n, 0)
END Button;
BEGIN
Button(17, 5, 5, 70, 25, "open");
Button(18, 85, 5, 70, 25, "color");
END Buttons;
PROCEDURE draw_window;
BEGIN
WindowRedrawStatus(1);
DefineAndDrawWindow(200, 200, 500, 100, back_color, 51, 0, 0, sys.ADR(header[0]));
Buttons;
WindowRedrawStatus(2);
END draw_window;
PROCEDURE OpenFile(Open: OpenDlg.Dialog);
BEGIN
IF Open # NIL THEN
OpenDlg.Show(Open, 500, 450);
WHILE Open.status = 2 DO
pause(30)
END;
IF Open.status = 1 THEN
COPY(Open.FilePath, header)
END
END
END OpenFile;
PROCEDURE SelColor(Color: ColorDlg.Dialog);
BEGIN
IF Color # NIL THEN
ColorDlg.Show(Color);
WHILE Color.status = 2 DO
pause(30)
END;
IF Color.status = 1 THEN
back_color := Color.color
END
END
END SelColor;
PROCEDURE main;
VAR Open: OpenDlg.Dialog; Color: ColorDlg.Dialog; res, al: INTEGER;
BEGIN
back_color := 00FFFFFFH;
header := "Dialogs";
draw_window;
Open := OpenDlg.Create(draw_window, 0, "/rd/1", "ASM|TXT|INI");
Color := ColorDlg.Create(draw_window);
WHILE TRUE DO
CASE WaitForEvent() OF
|1: draw_window
|3: res := KOSAPI.sysfunc1(17);
al := LSR(LSL(res, 24), 24);
res := LSR(res, 8);
IF al = 0 THEN
CASE res OF
| 1: ExitApp
|17: OpenFile(Open)
|18: SelColor(Color)
END
END
ELSE
END
END
END main;
BEGIN
main
END Dialogs.

/programs/develop/oberon07/Samples/HW.ob07
0,0 → 1,54
MODULE HW;
IMPORT sys := SYSTEM, KOSAPI;
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR res: INTEGER;
BEGIN
res := 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)
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)
END WriteTextToWindow;
PROCEDURE WaitForEvent(): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
PROCEDURE ExitApp;
VAR res: INTEGER;
BEGIN
res := KOSAPI.sysfunc1(-1)
END ExitApp;
PROCEDURE draw_window(header, text: ARRAY OF CHAR);
BEGIN
WindowRedrawStatus(1);
DefineAndDrawWindow(200, 200, 200, 100, 0FFFFFFH, 51, 0, 0, sys.ADR(header));
WriteTextToWindow(10, 10, 0FF0000H, text);
WindowRedrawStatus(2);
END draw_window;
PROCEDURE Main(header, text: ARRAY OF CHAR);
BEGIN
WHILE TRUE DO
CASE WaitForEvent() OF
|1: draw_window(header, text)
|3: ExitApp
ELSE
END
END
END Main;
BEGIN
Main("HW", "Hello, world!")
END HW.

/programs/develop/oberon07/Samples/HW_con.ob07
0,0 → 1,53
MODULE HW_con;
IMPORT Out, In, Console, DateTime, ConsoleLib;
PROCEDURE OutInt2(n: INTEGER);
BEGIN
ASSERT((0 <= n) & (n <= 99));
IF n < 10 THEN
Out.Char("0")
END;
Out.Int(n, 0)
END OutInt2;
PROCEDURE OutMonth(n: INTEGER);
VAR str: ARRAY 4 OF CHAR;
BEGIN
CASE n OF
| 1: str := "jan"
| 2: str := "feb"
| 3: str := "mar"
| 4: str := "apr"
| 5: str := "may"
| 6: str := "jun"
| 7: str := "jul"
| 8: str := "aug"
| 9: str := "sep"
|10: str := "oct"
|11: str := "nov"
|12: str := "dec"
END;
Out.String(str)
END OutMonth;
PROCEDURE main;
VAR Year, Month, Day, Hour, Min, Sec: INTEGER;
BEGIN
ConsoleLib.open(-1, -1, -1, -1, "Hello!");
Out.String("Hello, world!"); Out.Ln;
Console.SetColor(Console.Yellow, Console.Blue);
DateTime.Now(Year, Month, Day, Hour, Min, Sec);
Out.Int(Year, 0); Out.Char("-");
OutMonth(Month); Out.Char("-");
OutInt2(Day); Out.Char(" ");
OutInt2(Hour); Out.Char(":");
OutInt2(Min); Out.Char(":");
OutInt2(Sec);
In.Ln;
ConsoleLib.exit(TRUE)
END main;
BEGIN
main
END HW_con.

/programs/develop/oberon07/Samples/RasterW.ob07
0,0 → 1,159
MODULE RasterW;
IMPORT sys := SYSTEM, RW := RasterWorks, KOSAPI;
TYPE
TWindow = RECORD
Left, Top, Width, Height: INTEGER;
Color: INTEGER;
Header: ARRAY 256 OF CHAR
END;
VAR
canvas : INTEGER;
bpp32 : BOOLEAN;
PROCEDURE CreateCanvas(width, height: INTEGER; bpp32: BOOLEAN): INTEGER;
VAR canvas: INTEGER;
BEGIN
canvas := KOSAPI.malloc(width * height * (3 + ORD(bpp32)) + 8);
sys.PUT(canvas, width);
sys.PUT(canvas + 4, height)
RETURN canvas
END CreateCanvas;
PROCEDURE ClearCanvas(canvas, color: INTEGER; bpp32: BOOLEAN);
VAR data, width, height, i: INTEGER;
BEGIN
sys.GET(canvas, width);
sys.GET(canvas + 4, height);
data := canvas + 8;
IF bpp32 THEN
FOR i := 1 TO width * height DO
sys.PUT(data, color); INC(data, 4)
END
ELSE
FOR i := 1 TO width * height - 1 DO
sys.PUT(data, color); INC(data, 3)
END;
sys.MOVE(sys.ADR(color), data, 3)
END
END ClearCanvas;
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
PROCEDURE DefineAndDrawWindow(x, y, width, height, color, style, hcolor, hstyle: INTEGER; htext: ARRAY OF CHAR);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc6(0, x * 65536 + width, y * 65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), sys.ADR(htext[0]))
END DefineAndDrawWindow;
PROCEDURE WaitForEvent(): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
PROCEDURE ExitApp;
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc1(-1)
END ExitApp;
PROCEDURE DrawCanvas(canvas: INTEGER; x, y: INTEGER; bpp32: BOOLEAN);
VAR xsize, ysize, aux: INTEGER;
BEGIN
sys.GET(canvas, xsize);
sys.GET(canvas + 4, ysize);
aux := KOSAPI.sysfunc7(65, canvas + 8, xsize * 65536 + ysize, x * 65536 + y, 24 + 8 * ORD(bpp32), 0, 0)
END DrawCanvas;
PROCEDURE TextOut(canvas, x, y: INTEGER; string: ARRAY OF CHAR; color, params: INTEGER);
VAR width: INTEGER;
BEGIN
width := RW.drawText(canvas, x, y, sys.ADR(string[0]), LENGTH(string), color + 0FF000000H, params)
END TextOut;
PROCEDURE DrawText;
VAR x, y: INTEGER;
BEGIN
ClearCanvas(canvas, 00FFFFFFH, bpp32);
x := 0; y := 0;
TextOut(canvas, x, y, "font size 16", 000000FFH, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) ) );
y := y + 16;
x := x + 20;
TextOut(canvas, x, y, "font size 12", 00FF0000H, RW.params( 12, 0, RW.cp866, RW.bpp32 * ORD(bpp32) ) );
y := y + 12;
x := x + 20;
TextOut(canvas, x, y, "italic", 00808080H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.italic ) );
y := y + 16;
x := x + 20;
TextOut(canvas, x, y, "bold", 00000000H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.bold ) );
y := y + 16;
x := x + 20;
TextOut(canvas, x, y, "underline", 00000000H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.underline ) );
y := y + 16;
x := x + 20;
TextOut(canvas, x, y, "strike-through", 00000000H, RW.params( 16, 0, RW.cp866, RW.bpp32 * ORD(bpp32) + RW.strike_through ) );
y := y + 16;
x := x + 20;
DrawCanvas(canvas, 10, 10, bpp32);
END DrawText;
PROCEDURE draw_window(Window: TWindow);
BEGIN
WindowRedrawStatus(1);
DefineAndDrawWindow(Window.Left, Window.Top, Window.Width, Window.Height, Window.Color, 51, 0, 0, Window.Header);
DrawText;
WindowRedrawStatus(2);
END draw_window;
PROCEDURE main;
VAR Window: TWindow;
BEGIN
Window.Left := 200;
Window.Top := 200;
Window.Width := 400;
Window.Height := 300;
Window.Color := 00C0C0C0H;
Window.Header := "RasterWorks";
bpp32 := FALSE;
canvas := CreateCanvas(Window.Width - 30, Window.Height - 50, bpp32);
WHILE TRUE DO
CASE WaitForEvent() OF
|1: draw_window(Window)
|3: ExitApp
ELSE
END
END
END main;
BEGIN
main
END RasterW.

/programs/develop/oberon07/Samples/kfont.ob07
0,0 → 1,175
MODULE kfont;
IMPORT sys := SYSTEM, kfonts, KOSAPI;
CONST
FileName = "/rd/1/fonts/tahoma.kf";
TYPE
TWindow = RECORD
Left, Top, Width, Height: INTEGER;
Color: INTEGER;
Header: ARRAY 256 OF CHAR
END;
VAR
canvas : INTEGER;
bpp32 : BOOLEAN;
Font12, Font16: kfonts.TFont;
PROCEDURE CreateCanvas(width, height: INTEGER; bpp32: BOOLEAN): INTEGER;
VAR canvas: INTEGER;
BEGIN
canvas := KOSAPI.malloc(width * height * (3 + ORD(bpp32)) + 8);
sys.PUT(canvas, width);
sys.PUT(canvas + 4, height)
RETURN canvas
END CreateCanvas;
PROCEDURE ClearCanvas(canvas, color: INTEGER; bpp32: BOOLEAN);
VAR data, width, height, i: INTEGER;
BEGIN
sys.GET(canvas, width);
sys.GET(canvas + 4, height);
data := canvas + 8;
IF bpp32 THEN
FOR i := 1 TO width * height DO
sys.PUT(data, color); INC(data, 4)
END
ELSE
FOR i := 1 TO width * height - 1 DO
sys.PUT(data, color); INC(data, 3)
END;
sys.MOVE(sys.ADR(color), data, 3)
END
END ClearCanvas;
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
PROCEDURE DefineAndDrawWindow(x, y, width, height, color, style, hcolor, hstyle: INTEGER; htext: ARRAY OF CHAR);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc6(0, x * 65536 + width, y * 65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), sys.ADR(htext[0]))
END DefineAndDrawWindow;
PROCEDURE WaitForEvent(): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
PROCEDURE ExitApp;
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc1(-1)
END ExitApp;
PROCEDURE DrawCanvas(canvas: INTEGER; x, y: INTEGER; bpp32: BOOLEAN);
VAR xsize, ysize, aux: INTEGER;
BEGIN
sys.GET(canvas, xsize);
sys.GET(canvas + 4, ysize);
aux := KOSAPI.sysfunc7(65, canvas + 8, xsize * 65536 + ysize, x * 65536 + y, 24 + 8 * ORD(bpp32), 0, 0)
END DrawCanvas;
PROCEDURE DrawText;
VAR x, y: INTEGER;
BEGIN
ClearCanvas(canvas, 00FFFFFFH, bpp32);
x := 0; y := 0;
kfonts.TextOut(Font16, canvas, x, y, sys.ADR("font size 16"), -1, 000000FFH, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing );
y := y + kfonts.TextHeight( Font16 );
x := x + 20;
kfonts.TextOut(Font12, canvas, x, y, sys.ADR("font size 12"), -1, 00FF0000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing );
y := y + kfonts.TextHeight( Font12 );
x := x + 20;
kfonts.TextOut(Font16, canvas, x, y, sys.ADR("italic"), -1, 00808080H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.italic );
y := y + kfonts.TextHeight( Font16 );
x := x + 20;
kfonts.TextOut(Font16, canvas, x, y, sys.ADR("bold"), -1, 00000000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.bold );
y := y + kfonts.TextHeight( Font16 );
x := x + 20;
kfonts.TextOut(Font16, canvas, x, y, sys.ADR("underline"), -1, 00000000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.underline );
y := y + kfonts.TextHeight( Font16 );
x := x + 20;
kfonts.TextOut(Font16, canvas, x, y, sys.ADR("strike-through"), -1, 00000000H, kfonts.bpp32 * ORD(bpp32) + kfonts.smoothing + kfonts.strike_through );
y := y + kfonts.TextHeight( Font16 );
x := x + 20;
DrawCanvas(canvas, 10, 10, bpp32);
END DrawText;
PROCEDURE draw_window(Window: TWindow);
BEGIN
WindowRedrawStatus(1);
DefineAndDrawWindow(Window.Left, Window.Top, Window.Width, Window.Height, Window.Color, 51, 0, 0, Window.Header);
DrawText;
WindowRedrawStatus(2);
END draw_window;
PROCEDURE main;
VAR Window: TWindow;
bool: BOOLEAN;
BEGIN
Window.Left := 200;
Window.Top := 200;
Window.Width := 400;
Window.Height := 300;
Window.Color := 00C0C0C0H;
Window.Header := "kfonts";
bpp32 := TRUE;
canvas := CreateCanvas(Window.Width - 30, Window.Height - 50, bpp32);
Font12 := kfonts.LoadFont(FileName);
IF kfonts.Enabled(Font12, 12) THEN
bool := kfonts.SetSize(Font12, 12)
END;
Font16 := kfonts.LoadFont(FileName);
IF kfonts.Enabled(Font16, 16) THEN
bool := kfonts.SetSize(Font16, 16)
END;
WHILE TRUE DO
CASE WaitForEvent() OF
|1: draw_window(Window)
|3: ExitApp
ELSE
END
END
END main;
BEGIN
main
END kfont.

/programs/develop/oberon07/Samples/lib_img.ob07
0,0 → 1,97
MODULE lib_img;
IMPORT sys := SYSTEM, KOSAPI, libimg, File;
TYPE
TWindow = RECORD
Left, Top, Width, Height: INTEGER;
Color: INTEGER;
Header: ARRAY 256 OF CHAR
END;
VAR
img, rgb, width, height: INTEGER;
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
PROCEDURE DefineAndDrawWindow(x, y, width, height, color, style, hcolor, hstyle: INTEGER; htext: ARRAY OF CHAR);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc6(0, x * 65536 + width, y * 65536 + height, color + LSL(style, 24), hcolor + LSL(hstyle, 24), sys.ADR(htext[0]))
END DefineAndDrawWindow;
PROCEDURE WaitForEvent(): INTEGER;
RETURN KOSAPI.sysfunc1(10)
END WaitForEvent;
PROCEDURE PutImage(x, y, rgb, width, height: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc7(65, rgb + 8, width * 65536 + height, x * 65536 + y, 24, 0, 0)
END PutImage;
PROCEDURE draw_window(Window: TWindow);
BEGIN
WindowRedrawStatus(1);
DefineAndDrawWindow(Window.Left, Window.Top, Window.Width, Window.Height, Window.Color, 51, 0, 0, Window.Header);
PutImage(10, 10, rgb, width, height);
WindowRedrawStatus(2)
END draw_window;
PROCEDURE LoadImage(FName: ARRAY OF CHAR);
VAR data, size: INTEGER;
BEGIN
data := File.Load(FName, size);
IF data # 0 THEN
img := libimg.img_decode(data, size, 0);
data := KOSAPI.free(data);
IF img # 0 THEN
rgb := libimg.img_to_rgb(img);
IF rgb # 0 THEN
sys.GET(img + 4, width);
sys.GET(img + 8, height)
END
END
END
END LoadImage;
PROCEDURE main;
VAR Window: TWindow;
exit: BOOLEAN;
BEGIN
Window.Left := 200;
Window.Top := 200;
Window.Width := 400;
Window.Height := 300;
Window.Color := 00C0C0C0H;
Window.Header := "libimg";
LoadImage("/rd/1/toolbar.png");
exit := FALSE;
REPEAT
CASE WaitForEvent() OF
|1: draw_window(Window)
|3: exit := TRUE
ELSE
END
UNTIL exit
END main;
BEGIN
main
END lib_img.

/programs/develop/oberon07/Source/Compiler.ob07
0,0 → 1,1901
(*
Copyright 2016 Anton Krotov
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Compiler;
IMPORT DECL, SCAN, UTILS, X86, SYSTEM;
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;
sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
sysCODE = 106; sysTYPEID = 107; sysMOVE = 108;
TYPE
LABEL = POINTER TO RECORD (UTILS.rITEM)
a, b: INTEGER
END;
VAR
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)
END
END Load;
PROCEDURE LenString(adr: LONGREAL): INTEGER;
VAR s: UTILS.STRCONST;
BEGIN
s := DECL.GetString(adr)
RETURN s.Len
END LenString;
PROCEDURE Assert(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER);
BEGIN
IF ~cond THEN
DECL.Assert(FALSE, coord, code)
END
END Assert;
PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER);
BEGIN
IF ~cond THEN
DECL.Assert(FALSE, SCAN.coord, code)
END
END Assert2;
PROCEDURE IntType(T: DECL.pTYPE; coord: SCAN.TCoord);
BEGIN
Assert(T.tType = TINTEGER, coord, 52)
END IntType;
PROCEDURE Next;
BEGIN
DECL.Next
END Next;
PROCEDURE Coord(VAR coord: SCAN.TCoord);
BEGIN
coord := SCAN.coord
END Coord;
PROCEDURE NextCoord(VAR coord: SCAN.TCoord);
BEGIN
DECL.Next;
coord := SCAN.coord
END NextCoord;
PROCEDURE Check(key: INTEGER);
BEGIN
DECL.Check(key)
END Check;
PROCEDURE NextCheck(key: INTEGER);
BEGIN
DECL.Next;
DECL.Check(key)
END NextCheck;
PROCEDURE BaseOf(T0, T1: DECL.pTYPE): BOOLEAN;
BEGIN
IF (T0.tType = T1.tType) & (T0.tType IN TOBJECT) THEN
IF T0.tType = TPOINTER THEN
T0 := T0.Base;
T1 := T1.Base
END;
WHILE (T1 # NIL) & (T1 # T0) DO
T1 := T1.Base
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;
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
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
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;
PROCEDURE Set(VAR e: DECL.EXPRESSION);
VAR a, b: DECL.EXPRESSION; coord: SCAN.TCoord; fpu: INTEGER; s: SET; flag: BOOLEAN;
beg: X86.ASMLINE;
BEGIN
Next;
e.eType := eEXP;
e.T := settype;
e.Value := 0.0D0;
e.vparam := FALSE;
s := {};
flag := TRUE;
fpu := X86.fpu;
beg := X86.current;
X86.PushConst(0);
WHILE SCAN.tLex # lxRCurly DO
Coord(coord);
pExpr(a);
IntType(a.T, coord);
IF a.eType = eCONST THEN
Assert(ASR(FLOOR(a.Value), 5) = 0, coord, 53)
END;
Load(a);
b := a;
IF SCAN.tLex = lxDbl THEN
NextCoord(coord);
pExpr(b);
IntType(b.T, coord);
IF b.eType = eCONST THEN
Assert(ASR(FLOOR(b.Value), 5) = 0, coord, 53);
Assert(a.Value <= b.Value, coord, 54)
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)
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)
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
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)
|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;
PROCEDURE ProcTypeComp1(T1, T2: DECL.pTYPE): BOOLEAN;
VAR fp, ft: DECL.FIELD; Res: BOOLEAN;
PROCEDURE TypeComp(T1, T2: DECL.pTYPE): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF (T1.tType = TARRAY) & (T2.tType = TARRAY) & (T1.Len = 0) & (T2.Len = 0) THEN
Res := TypeComp(T1.Base, T2.Base)
ELSE
Res := ProcTypeComp1(T1, T2)
END
RETURN Res
END TypeComp;
PROCEDURE Check(): BOOLEAN;
VAR i: INTEGER; res: BOOLEAN;
BEGIN
i := 0;
res := FALSE;
WHILE (i < sp) & ~res DO
res := ((stk[i][0] = T1) & (stk[i][1] = T2)) OR ((stk[i][0] = T2) & (stk[i][1] = T1));
INC(i)
END
RETURN res
END Check;
BEGIN
INC(sp);
stk[sp][0] := T1;
stk[sp][1] := T2;
IF Check() THEN
Res := TRUE
ELSE
IF (T1.tType = TPROC) & (T2.tType = TPROC) & (T1 # T2) THEN
Res := (T1.Call = T2.Call) & (T1.Fields.Count = T2.Fields.Count) & ProcTypeComp1(T1.Base, T2.Base);
fp := T1.Fields.First(DECL.FIELD);
ft := T2.Fields.First(DECL.FIELD);
WHILE Res & (fp # NIL) DO
Res := (fp.ByRef = ft.ByRef) & TypeComp(fp.T, ft.T);
fp := fp.Next(DECL.FIELD);
ft := ft.Next(DECL.FIELD)
END
ELSE
Res := T1 = T2
END
END;
DEC(sp)
RETURN Res
END ProcTypeComp1;
BEGIN
sp := -1
RETURN ProcTypeComp1(T1, T2)
END ProcTypeComp;
PROCEDURE 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 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;
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;
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
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;
PROCEDURE Factor(VAR e: DECL.EXPRESSION);
VAR coord: SCAN.TCoord; ccall, p: INTEGER; begcall: X86.ASMLINE; s, str2: UTILS.STRCONST;
BEGIN
e.eType := eCONST;
e.vparam := FALSE;
CASE SCAN.tLex OF
|lxIDENT:
begcall := X86.current;
Designator(e);
IF e.eType = ePROC THEN
IF SCAN.tLex = lxLRound THEN
Assert2(e.id.T.Base.tType # TVOID, 73);
Next;
X86.PushCall(begcall);
Call(e.id.T.Fields.First(DECL.FIELD));
X86.EndCall;
e.eType := eEXP;
e.T := e.id.T.Base;
IF e.id.Level = 3 THEN
ccall := 0
ELSIF e.id.Level > DECL.curBlock.Level THEN
ccall := 1
ELSE
ccall := 2
END;
X86.Call(e.id.Number, TRUE, e.T.tType IN TFLOAT, e.id.T.Call, ccall, e.id.Level - 3,
DECL.curBlock.Level - 3, e.id.ParamSize, DECL.curBlock.LocalSize)
ELSE
X86.PushInt(e.id.Number)
END
ELSIF (e.eType = eVAR) & (e.T.tType = TPROC) & (SCAN.tLex = lxLRound) THEN
Assert2(e.T.Base.tType # TVOID, 73);
Next;
X86.PushCall(begcall);
Call(e.T.Fields.First(DECL.FIELD));
X86.EndCall;
e.eType := eEXP;
X86.CallVar(TRUE, e.T.Base.tType IN TFLOAT, e.T.Call, e.T.Len, DECL.curBlock.LocalSize);
e.T := e.T.Base;
ELSIF e.eType IN {eSTPROC, eSYSPROC} THEN
StFunc(e, e.id.StProc)
END
|lxNIL:
e.T := niltype;
e.Value := 0.0D0;
X86.PushConst(0);
Next
|lxTRUE:
e.T := booltype;
e.Value := 1.0D0;
X86.PushConst(1);
Next
|lxFALSE:
e.T := booltype;
e.Value := 0.0D0;
X86.PushConst(0);
Next
|lxCHX, lxSTRING:
IF SCAN.tLex = lxSTRING THEN
str2 := DECL.AddString(SCAN.Lex);
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
ELSE
str2 := DECL.AddMono(SCAN.vCHX);
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
X86.PushConst(ORD(SCAN.vCHX))
END;
e.T := strtype;
Next
|lxREAL:
e.T := realtype;
e.Value := SCAN.vFLT;
X86.PushFlt(SCAN.vFLT);
Next
|lxLONGREAL:
e.T := longrealtype;
e.Value := SCAN.vFLT;
X86.PushFlt(SCAN.vFLT);
Next
|lxINT, lxHEX:
e.T := inttype;
e.Value := LONG(FLT(SCAN.vINT));
X86.PushConst(SCAN.vINT);
Next
|lxLRound:
Next;
pExpr(e);
Check(lxRRound);
Next
|lxNot:
NextCoord(coord);
Factor(e);
Assert(e.T.tType = TBOOLEAN, coord, 37);
Load(e);
IF e.eType = eCONST THEN
e.Value := LONG(FLT(ORD(e.Value = 0.0D0)))
ELSE
e.eType := eEXP
END;
X86.Not;
e.vparam := FALSE
|lxLCurly:
Set(e)
ELSE
Assert2(FALSE, 36)
END
END Factor;
PROCEDURE IsChr(a: DECL.EXPRESSION): BOOLEAN;
RETURN (a.T.tType = TSTRING) & (LenString(a.Value) = 1) OR (a.T.tType = TCHAR)
END IsChr;
PROCEDURE StrRel(a, b: DECL.EXPRESSION; Op: INTEGER);
BEGIN
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;
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;
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;
PROCEDURE Term(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; Op, L: INTEGER; coord: SCAN.TCoord;
BEGIN
Factor(e);
WHILE (SCAN.tLex = lxMult) OR (SCAN.tLex = lxSlash) OR
(SCAN.tLex = lxDIV) OR (SCAN.tLex = lxMOD) OR
(SCAN.tLex = lxAnd) DO
Load(e);
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxAnd THEN
L := X86.NewLabel();
X86.IfWhile(L, FALSE)
END;
Factor(a);
Load(a);
IF Op = lxAnd THEN
X86.Label(L)
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;
PROCEDURE Expr(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; coord, coord2: SCAN.TCoord; Op, fpu: INTEGER; T: DECL.pTYPE; beg: X86.ASMLINE; s: UTILS.STRCONST;
BEGIN
fpu := X86.fpu;
beg := X86.current;
Simple(e);
IF DECL.Relation(SCAN.tLex) THEN
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxIS THEN
Assert(e.T.tType IN TOBJECT, coord, 37);
IF e.T.tType = TRECORD THEN
Assert(e.vparam, coord, 37)
END;
Check(lxIDENT);
Coord(coord2);
T := DECL.IdType(coord2);
Assert(T # NIL, coord2, 42);
IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord2, 106)
ELSE
Assert(T.tType = TPOINTER, coord2, 107)
END;
Assert(BaseOf(e.T, T), coord, 37);
IF e.T.tType = TRECORD THEN
X86.Drop;
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END;
Load(e);
IF e.T.tType = TPOINTER THEN
T := T.Base
END;
X86.Guard(T.Number, TRUE);
e.T := booltype;
e.eType := eEXP;
e.vparam := FALSE
ELSE
Load(e);
Str(e);
Simple(a);
Load(a);
Str(a);
Operation(e, a, Op, coord)
END
END;
IF e.eType = eCONST THEN
X86.Del(beg);
X86.Setfpu(fpu);
IF ~DECL.Const THEN
CASE e.T.tType OF
|TREAL, TLONGREAL:
X86.PushFlt(e.Value)
|TINTEGER, TSET, TBOOLEAN, TNIL:
X86.PushConst(FLOOR(e.Value))
|TSTRING:
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
ELSE
END
END
END
END Expr;
PROCEDURE IfWhileOper(wh: BOOLEAN);
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L, L3: INTEGER;
BEGIN
L := X86.NewLabel();
IF wh THEN
X86.Label(L)
END;
REPEAT
NextCoord(coord);
Expr(e);
Assert(e.T.tType = TBOOLEAN, coord, 117);
Load(e);
IF wh THEN
Check(lxDO)
ELSE
Check(lxTHEN)
END;
L3 := X86.NewLabel();
X86.ifwh(L3);
Next;
pOpSeq;
X86.jmp(X86.JMP, L);
X86.Label(L3)
UNTIL SCAN.tLex # lxELSIF;
IF ~wh & (SCAN.tLex = lxELSE) THEN
Next;
pOpSeq
END;
Check(lxEND);
IF ~wh THEN
X86.Label(L)
END;
Next
END IfWhileOper;
PROCEDURE RepeatOper;
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L: INTEGER;
BEGIN
Next;
L := X86.NewLabel();
X86.Label(L);
pOpSeq;
Check(lxUNTIL);
NextCoord(coord);
Expr(e);
Assert(e.T.tType = TBOOLEAN, coord, 117);
Load(e);
X86.ifwh(L)
END RepeatOper;
PROCEDURE ForOper;
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; LBeg, LEnd, iValue: INTEGER; Value: LONGREAL;
T: DECL.pTYPE; name: SCAN.NODE; id: DECL.IDENT;
BEGIN
NextCheck(lxIDENT);
name := SCAN.id;
id := DECL.GetIdent(name);
Assert2(id # NIL, 42);
Assert2(id.iType = IDVAR, 126);
Assert2(id.VarKind = 0, 127);
Assert2(id.T.tType = TINTEGER, 128);
Assert2(id.Level = DECL.unit.Level, 129);
NextCheck(lxAssign);
NextCoord(coord);
IF id.Level = 3 THEN
X86.GlobalAdr(id.Offset)
ELSE
X86.LocalAdr(id.Offset, 0)
END;
X86.Dup;
Expr(e);
IntType(e.T, coord);
Load(e);
X86.Save(TINTEGER);
Check(lxTO);
NextCoord(coord);
Expr(e);
IntType(e.T, coord);
Load(e);
iValue := 1;
IF SCAN.tLex = lxBY THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(iValue # 0, coord, 122)
END;
Check(lxDO);
Next;
X86.For(iValue > 0, LBeg, LEnd);
pOpSeq;
X86.NextFor(iValue, LBeg, LEnd);
Check(lxEND);
Next
END ForOper;
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;
PROCEDURE LabelVal(VAR a: INTEGER; int: BOOLEAN);
VAR Value: LONGREAL; T: DECL.pTYPE; s: UTILS.STRCONST; coord: SCAN.TCoord;
BEGIN
Coord(coord);
DECL.ConstExpr(Value, T);
IF int THEN
Assert(T.tType = TINTEGER, coord, 161);
a := FLOOR(Value)
ELSE
Assert(T.tType = TSTRING, coord, 55);
s := DECL.GetString(Value);
Assert(s.Len = 1, coord, 94);
a := ORD(s.Str[0])
END
END LabelVal;
PROCEDURE Label(int: BOOLEAN; Labels: UTILS.LIST; LBeg: INTEGER);
VAR a, b: INTEGER; label: LABEL; coord: SCAN.TCoord;
BEGIN
Coord(coord);
LabelVal(a, int);
b := a;
IF SCAN.tLex = lxDbl THEN
Next;
LabelVal(b, int)
END;
Assert(a <= b, coord, 54);
Assert(CheckLabel(a, b, Labels), coord, 100);
NEW(label);
DECL.MemErr(label = NIL);
label.a := a;
label.b := b;
UTILS.Push(Labels, label);
X86.CaseLabel(a, b, LBeg)
END Label;
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;
PROCEDURE CaseOper;
VAR e: DECL.EXPRESSION; int: BOOLEAN; coord: SCAN.TCoord; EndCase: INTEGER; Labels: UTILS.LIST;
BEGIN
NextCoord(coord);
Expr(e);
Assert(e.T.tType IN {TCHAR, TSTRING, TINTEGER}, coord, 156);
Assert(~((e.T.tType = TSTRING) & (LenString(e.Value) # 1)), coord, 94);
int := e.T.tType = TINTEGER;
Check(lxOF);
Load(e);
X86.Drop;
Labels := UTILS.CreateList();
Next;
EndCase := X86.NewLabel();
Variant(int, Labels, EndCase);
WHILE SCAN.tLex = lxStick DO
Next;
Variant(int, Labels, EndCase)
END;
IF SCAN.tLex = lxELSE THEN
Next;
pOpSeq
ELSE
UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line);
X86.OnError(7)
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;
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);
ELSE
Assert(FALSE, coord2, 132)
END;
Check(lxRRound);
Next;
IF proc = sysMOVE THEN
X86.StProc(X86.sysMOVE)
END
END StProc;
PROCEDURE IdentOper;
VAR e1, e2: DECL.EXPRESSION; coord: SCAN.TCoord; ccall: INTEGER; begcall: X86.ASMLINE; s: UTILS.STRCONST;
BEGIN
Coord(coord);
begcall := X86.current;
Designator(e1);
Assert(e1.eType # eCONST, coord, 130);
IF (e1.eType = eVAR) & (e1.T.tType # TPROC) THEN
Check(lxAssign);
Assert(~e1.Read, coord, 115);
NextCoord(coord);
Expr(e2);
Assert(AssComp(e2, e1.T, FALSE), coord, 131);
Load(e2);
IF e1.T.tType = TRECORD THEN
X86.PushConst(e1.T.Size);
X86.PushConst(e1.T.Number);
IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER)
ELSIF e1.deref THEN
X86.DerefType(12)
ELSE
X86.PushConst(e1.T.Number)
END
ELSIF e2.T.tType = TARRAY THEN
X86.PushConst(e2.T.Size)
ELSIF (e2.T.tType = TSTRING) & (e1.T.tType = TARRAY) THEN
s := DECL.GetString(e2.Value);
IF s.Len = 1 THEN
X86.Mono(s.Number)
END;
X86.PushConst(UTILS.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;
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;
PROCEDURE OpSeq;
BEGIN
Operator;
WHILE SCAN.tLex = lxSemi DO
Next;
Operator
END
END OpSeq;
PROCEDURE Start;
VAR SelfName, SelfPath, CName, CExt, FName, Path, StdPath,
Name, Ext, temp, system, stk: UTILS.STRING;
platform, stksize: INTEGER;
PROCEDURE getstksize(): INTEGER;
VAR res, i: INTEGER;
BEGIN
res := 0;
i := 0;
WHILE SCAN.Digit(stk[i]) DO
INC(i)
END;
IF stk[i] <= 20X THEN
stk[i] := 0X;
res := SCAN.StrToInt(stk)
END;
IF res = 0 THEN
res := 1
END
RETURN res
END getstksize;
PROCEDURE getver(): INTEGER;
VAR res, i: INTEGER; err: BOOLEAN;
PROCEDURE hexdgt(c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9") OR
("A" <= c) & (c <= "F") OR
("a" <= c) & (c <= "f")
END hexdgt;
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;
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;
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, "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.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;
BEGIN
Start
END Compiler.

/programs/develop/oberon07/Source/DECL.ob07
0,0 → 1,1618
(*
Copyright 2016 Anton Krotov
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE DECL;
IMPORT SCAN, UTILS, X86, SYSTEM;
CONST
lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7;
lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8;
lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16;
lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23;
lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30;
lxUNTIL = 31; lxVAR = 32; lxWHILE = 33;
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58;
lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65;
lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
lxERR0 = 100; lxERR1 = 101; lxERR2 = 102; lxERR3 = 103; lxERR4 = 104; lxERR5 = 105; lxERR6 = 106;
lxERR7 = 107; lxERR8 = 108; lxERR9 = 109; lxERR10 = 110; lxERR11 = 111; lxERR20 = 120;
IDMOD = 1; IDCONST = 2; IDTYPE = 3; IDVAR = 4; IDPROC = 5; IDSTPROC = 6; IDGUARD = 7; IDPARAM = 8; IDSYSPROC = 9;
stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8;
stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15;
stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22;
stBITS = 23; stLSR = 24; stLENGTH = 25;
sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
sysCODE = 106; sysTYPEID = 107; sysMOVE = 108;
TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7; TNIL = 8;
TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14;
TNUM = {TINTEGER, TREAL, TLONGREAL};
TFLOAT = {TREAL, TLONGREAL};
TSTRUCT = {TARRAY, TRECORD};
paramvar* = 1; param* = 2;
defcall = 0; stdcall = 1; cdecl = 2; winapi* = 3;
record = 0; union = 1; noalign = 2;
eVAR = 1; eCONST = 2; eEXP = 3; ePROC = 4; eSTPROC = 5; eSYSPROC = 6;
IOVER* = lxERR5 - lxERR0;
FOVER* = lxERR7 - lxERR0;
UNDER* = lxERR9 - lxERR0;
TYPE
pTYPE* = POINTER TO RECORD (UTILS.rITEM)
tType*, Size*, Len*, Number*, Align, Call*, Rec: INTEGER;
Base*: pTYPE;
Fields*: UTILS.LIST
END;
IDENT* = POINTER TO rIDENT;
UNIT* = POINTER TO RECORD (UTILS.rITEM)
Name: SCAN.NODE;
File: UTILS.STRING;
Idents: UTILS.LIST;
Import: UTILS.LIST;
IdentBegin: IDENT;
scanner: SCAN.SCANNER;
Level*: INTEGER;
Closed, typedecl, Std, sys: BOOLEAN
END;
rIDENT* = RECORD (UTILS.rITEM)
Name*: SCAN.NODE;
T*: pTYPE;
Unit*: UNIT;
Parent*: IDENT;
Proc*: UTILS.ITEM;
Value*: LONGREAL;
coord*: SCAN.TCoord;
Number*, iType*, StProc*, VarSize, ParamSize*,
LocalSize*, Offset*, VarKind*, Level*, ParamCount*: INTEGER;
Export: BOOLEAN
END;
PTRBASE = POINTER TO RECORD (UTILS.rITEM)
Name: SCAN.NODE;
coord: SCAN.TCoord;
Ptr: pTYPE
END;
STRITEM = POINTER TO RECORD (UTILS.rITEM)
Str: UTILS.STRING
END;
FIELD* = POINTER TO RECORD (UTILS.rITEM)
Name: SCAN.NODE;
T*: pTYPE;
Offset*: INTEGER;
ByRef*, Export*: BOOLEAN;
Unit*: UNIT
END;
EXPRESSION* = RECORD
id*: IDENT;
T*: pTYPE;
eType*: INTEGER;
Value*: LONGREAL;
Read*, vparam*, deref*: BOOLEAN
END;
opPROC = PROCEDURE;
expPROC = PROCEDURE (VAR e: EXPRESSION);
assPROC = PROCEDURE (e: EXPRESSION; T: pTYPE; param: BOOLEAN): BOOLEAN;
stTYPES* = ARRAY 11 OF pTYPE;
Proc* = POINTER TO RECORD (UTILS.rITEM)
used: BOOLEAN;
beg, end: X86.ASMLINE;
Procs*: UTILS.LIST
END;
VAR
sttypes: stTYPES; unit*, sys: UNIT; curBlock*: IDENT;
Path, Main, Std, ExtMain: UTILS.STRING;
NamePtrBase: SCAN.NODE; ProgSize*, RecCount, UnitNumber*: INTEGER;
PtrBases, Strings, types, prog, procs: UTILS.LIST; OpSeq: opPROC; Expr: expPROC;
AssComp: assPROC; main, sizefunc, winplatf, Const*: BOOLEAN;
pParseType: PROCEDURE (VAR coord: SCAN.TCoord): pTYPE;
pReadModule: PROCEDURE (Path, Name, Ext: UTILS.STRING): BOOLEAN;
Platform: INTEGER; voidtype: pTYPE; zcoord: SCAN.TCoord;
curproc*: Proc;
PROCEDURE SetSizeFunc*;
BEGIN
sizefunc := TRUE
END SetSizeFunc;
PROCEDURE MemErr*(err: BOOLEAN);
BEGIN
IF err THEN
UTILS.MemErr(TRUE)
END
END MemErr;
PROCEDURE GetString*(adr: LONGREAL): UTILS.STRCONST;
VAR str: UTILS.STRCONST;
BEGIN
SYSTEM.PUT(SYSTEM.ADR(str), FLOOR(adr))
RETURN str
END GetString;
PROCEDURE AddString*(str: UTILS.STRING): UTILS.STRCONST;
VAR nov: UTILS.STRCONST;
BEGIN
nov := UTILS.GetStr(Strings, str);
IF nov = NIL THEN
NEW(nov);
MemErr(nov = NIL);
nov.Str := str;
nov.Len := SCAN.count - 1;
nov.Number := X86.NewLabel();
UTILS.Push(Strings, nov);
X86.String(nov.Number, nov.Len, nov.Str)
END
RETURN nov
END AddString;
PROCEDURE AddMono*(c: CHAR): UTILS.STRCONST;
VAR nov: UTILS.STRCONST; s: UTILS.STRING;
BEGIN
s[0] := c;
s[1] := 0X;
nov := UTILS.GetStr(Strings, s);
IF nov = NIL THEN
NEW(nov);
MemErr(nov = NIL);
nov.Str := s;
nov.Len := 1;
nov.Number := X86.NewLabel();
UTILS.Push(Strings, nov);
X86.String(nov.Number, nov.Len, nov.Str)
END
RETURN nov
END AddMono;
PROCEDURE Coord(VAR coord: SCAN.TCoord);
BEGIN
coord := SCAN.coord
END Coord;
PROCEDURE GetModule(Name: SCAN.NODE): UNIT;
VAR cur, res: UNIT;
BEGIN
res := NIL;
cur := prog.First(UNIT);
WHILE (cur # NIL) & UTILS.streq(cur.Name.Name, Name.Name) DO
res := cur;
cur := NIL
ELSIF cur # NIL DO
cur := cur.Next(UNIT)
END
RETURN res
END GetModule;
PROCEDURE Assert*(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER);
BEGIN
IF ~cond THEN
UTILS.ErrMsgPos(coord.line, coord.col, code);
UTILS.HALT(1)
END
END Assert;
PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER);
BEGIN
IF ~cond THEN
Assert(FALSE, SCAN.coord, code)
END
END Assert2;
PROCEDURE Next*;
VAR coord: SCAN.TCoord;
BEGIN
SCAN.GetLex;
IF (SCAN.tLex > lxERR0) & (SCAN.tLex < lxERR20) THEN
coord.line := SCAN.coord.line;
coord.col := SCAN.coord.col + SCAN.count;
Assert(FALSE, coord, SCAN.tLex - lxERR0)
END;
Assert2(SCAN.tLex # lxEOF, 27)
END Next;
PROCEDURE NextCoord(VAR coord: SCAN.TCoord);
BEGIN
Next;
coord := SCAN.coord
END NextCoord;
PROCEDURE Check*(key: INTEGER);
VAR code: INTEGER;
BEGIN
IF SCAN.tLex # key THEN
CASE key OF
|lxMODULE: code := 21
|lxIDENT: code := 22
|lxSemi: code := 23
|lxEND: code := 24
|lxDot: code := 25
|lxEQ: code := 35
|lxRRound: code := 38
|lxTO: code := 40
|lxOF: code := 41
|lxRCurly: code := 51
|lxLRound: code := 56
|lxComma: code := 61
|lxTHEN: code := 98
|lxRSquare: code := 109
|lxDO: code := 118
|lxUNTIL: code := 119
|lxAssign: code := 120
|lxRETURN: code := 124
|lxColon: code := 157
ELSE
END;
Assert2(FALSE, code)
END
END Check;
PROCEDURE NextCheck(key: INTEGER);
BEGIN
Next;
Check(key)
END NextCheck;
PROCEDURE CheckIdent(Name: SCAN.NODE): BOOLEAN;
VAR cur: IDENT;
BEGIN
cur := unit.Idents.Last(IDENT);
WHILE (cur.iType # IDGUARD) & (cur.Name # Name) DO
cur := cur.Prev(IDENT)
END
RETURN cur.iType = IDGUARD
END CheckIdent;
PROCEDURE Guard;
VAR ident: IDENT;
BEGIN
NEW(ident);
MemErr(ident = NIL);
ident.Name := NIL;
ident.iType := IDGUARD;
ident.T := voidtype;
UTILS.Push(unit.Idents, ident);
INC(unit.Level)
END Guard;
PROCEDURE PushIdent(Name: SCAN.NODE; coord: SCAN.TCoord; iType: INTEGER; T: pTYPE; u: UNIT; Export: BOOLEAN; StProc: INTEGER);
VAR ident: IDENT; i: INTEGER;
BEGIN
Assert(CheckIdent(Name), coord, 30);
NEW(ident);
MemErr(ident = NIL);
ident.Name := Name;
ident.coord := coord;
IF iType IN {IDPROC, IDMOD} THEN
ident.Number := X86.NewLabel();
i := X86.NewLabel();
i := X86.NewLabel();
i := X86.NewLabel()
END;
ident.iType := iType;
ident.T := T;
ident.Unit := u;
ident.Export := Export;
ident.StProc := StProc;
ident.Level := unit.Level;
UTILS.Push(unit.Idents, ident)
END PushIdent;
PROCEDURE StTypes;
VAR type: pTYPE; i: INTEGER;
BEGIN
sttypes[0] := NIL;
FOR i := TINTEGER TO TSTRING DO
NEW(type);
MemErr(type = NIL);
type.tType := i;
UTILS.Push(types, type);
sttypes[i] := type
END;
sttypes[TINTEGER].Size := 4;
sttypes[TREAL].Size := 4;
sttypes[TLONGREAL].Size := 8;
sttypes[TBOOLEAN].Size := 1;
sttypes[TCHAR].Size := 1;
sttypes[TSET].Size := 4;
sttypes[TVOID].Size := 0;
sttypes[TSTRING].Size := 0;
sttypes[TNIL].Size := 4;
sttypes[TCARD16].Size := 2;
FOR i := TINTEGER TO TSTRING DO
sttypes[i].Align := sttypes[i].Size
END
END StTypes;
PROCEDURE PushStProc(Name: UTILS.STRING; StProc: INTEGER);
BEGIN
PushIdent(SCAN.AddNode(Name), zcoord, IDSTPROC, voidtype, NIL, FALSE, StProc)
END PushStProc;
PROCEDURE PushStType(Name: UTILS.STRING; T: INTEGER);
BEGIN
PushIdent(SCAN.AddNode(Name), zcoord, IDTYPE, sttypes[T], NIL, FALSE, 0)
END PushStType;
PROCEDURE PushSysProc(Name: UTILS.STRING; StProc: INTEGER);
BEGIN
PushIdent(SCAN.AddNode(Name), zcoord, IDSYSPROC, voidtype, NIL, TRUE, StProc)
END PushSysProc;
PROCEDURE PushSysType(Name: UTILS.STRING; T: INTEGER);
BEGIN
PushIdent(SCAN.AddNode(Name), zcoord, IDTYPE, sttypes[T], NIL, TRUE, 0)
END PushSysType;
PROCEDURE StIdent;
BEGIN
Guard;
PushStProc("ABS", stABS);
PushStProc("ASR", stASR);
PushStProc("ASSERT", stASSERT);
PushStType("BOOLEAN", TBOOLEAN);
PushStType("CHAR", TCHAR);
PushStProc("CHR", stCHR);
PushStProc("COPY", stCOPY);
PushStProc("DEC", stDEC);
PushStProc("DISPOSE", stDISPOSE);
PushStProc("EXCL", stEXCL);
PushStProc("FLOOR", stFLOOR);
PushStProc("FLT", stFLT);
PushStProc("INC", stINC);
PushStProc("INCL", stINCL);
PushStType("INTEGER", TINTEGER);
PushStProc("LEN", stLEN);
PushStProc("LSL", stLSL);
PushStProc("LONG", stLONG);
PushStType("LONGREAL", TLONGREAL);
PushStProc("NEW", stNEW);
PushStProc("ODD", stODD);
PushStProc("ORD", stORD);
PushStProc("PACK", stPACK);
PushStType("REAL", TREAL);
PushStProc("ROR", stROR);
PushStType("SET", TSET);
PushStProc("SHORT", stSHORT);
PushStProc("UNPK", stUNPK);
PushStProc("BITS", stBITS);
PushStProc("LSR", stLSR);
PushStProc("LENGTH", stLENGTH);
Guard
END StIdent;
PROCEDURE GetQIdent*(Unit: UNIT; Name: SCAN.NODE): IDENT;
VAR cur, res: IDENT;
BEGIN
res := NIL;
cur := Unit.IdentBegin.Next(IDENT);
WHILE (cur # NIL) & (cur.iType # IDGUARD) DO
IF cur.Name = Name THEN
IF (Unit # unit) & ~cur.Export THEN
res := NIL
ELSE
res := cur
END;
cur := NIL
ELSE
cur := cur.Next(IDENT)
END
END
RETURN res
END GetQIdent;
PROCEDURE GetIdent*(Name: SCAN.NODE): IDENT;
VAR cur, res: IDENT;
BEGIN
res := NIL;
cur := unit.Idents.Last(IDENT);
WHILE (cur # NIL) & (cur.Name = Name) DO
res := cur;
cur := NIL
ELSIF cur # NIL DO
cur := cur.Prev(IDENT)
END
RETURN res
END GetIdent;
PROCEDURE Relation*(Op: INTEGER): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
CASE Op OF
|lxEQ, lxNE, lxLT, lxGT,
lxLE, lxGE, lxIN, lxIS:
Res := TRUE
ELSE
Res := FALSE
END
RETURN Res
END Relation;
PROCEDURE Arith(a, b: LONGREAL; T: pTYPE; Op: INTEGER; coord: SCAN.TCoord): LONGREAL;
CONST max = SCAN.maxDBL;
VAR res: LONGREAL;
BEGIN
CASE Op OF
|lxPlus: res := a + b
|lxMinus: res := a - b
|lxMult: res := a * b
|lxSlash:
Assert(b # 0.0D0, coord, 46);
res := a / b
|lxDIV:
Assert(~((a = LONG(FLT(SCAN.minINT))) & (b = -1.0D0)), coord, IOVER);
res := LONG(FLT(FLOOR(a) DIV FLOOR(b)))
|lxMOD:
res := LONG(FLT(FLOOR(a) MOD FLOOR(b)))
ELSE
END;
Assert(~UTILS.IsInf(res), coord, FOVER);
CASE T.tType OF
|TINTEGER: Assert((res <= LONG(FLT(SCAN.maxINT))) & (res >= LONG(FLT(SCAN.minINT))), coord, IOVER)
|TREAL: Assert((res <= LONG(SCAN.maxREAL)) & (res >= -LONG(SCAN.maxREAL)), coord, FOVER)
|TLONGREAL: Assert((res <= max) & (res >= -max), coord, FOVER)
ELSE
END;
IF (res = 0.0D0) & (T.tType IN TFLOAT) OR (ABS(res) < LONG(SCAN.minREAL)) & (T.tType = TREAL) THEN
CASE Op OF
|lxPlus: Assert(a = -b, coord, UNDER)
|lxMinus: Assert(a = b, coord, UNDER)
|lxMult: Assert((a = 0.0D0) OR (b = 0.0D0), coord, UNDER)
|lxSlash: Assert((a = 0.0D0), coord, UNDER)
ELSE
END
END
RETURN res
END Arith;
PROCEDURE strcmp(a, b: LONGREAL; Op: INTEGER): LONGREAL;
VAR sa, sb: UTILS.STRCONST; Res: LONGREAL;
BEGIN
sa := GetString(a);
sb := GetString(b);
CASE Op OF
|lxEQ, lxNE: Res := LONG(FLT(ORD(sa.Str = sb.Str)))
|lxLT, lxGT: Res := LONG(FLT(ORD(sa.Str < sb.Str)))
|lxLE, lxGE: Res := LONG(FLT(ORD(sa.Str <= sb.Str)))
ELSE
END
RETURN Res
END strcmp;
PROCEDURE Calc*(a, b: LONGREAL; Ta, Tb: pTYPE; Op: INTEGER; coord: SCAN.TCoord; VAR Res: LONGREAL; VAR TRes: pTYPE);
VAR c: LONGREAL; ai, bi: INTEGER;
BEGIN
ai := FLOOR(a);
bi := FLOOR(b);
IF Op # lxIN THEN
Assert(Ta = Tb, coord, 37)
END;
CASE Op OF
|lxPlus, lxMinus, lxMult, lxSlash:
Assert(~((Op = lxSlash) & (Ta.tType = TINTEGER)), coord, 37);
IF Ta.tType IN TNUM THEN
Res := Arith(a, b, Ta, Op, coord)
ELSIF Ta.tType = TSET THEN
CASE Op OF
|lxPlus: Res := LONG(FLT(ORD(BITS(ai) + BITS(bi))))
|lxMinus: Res := LONG(FLT(ORD(BITS(ai) - BITS(bi))))
|lxMult: Res := LONG(FLT(ORD(BITS(ai) * BITS(bi))))
|lxSlash: Res := LONG(FLT(ORD(BITS(ai) / BITS(bi))))
ELSE
END
ELSE
Assert(FALSE, coord, 37)
END;
TRes := Ta
|lxDIV, lxMOD:
Assert(Ta.tType = TINTEGER, coord, 37);
Assert(bi # 0, coord, 48);
TRes := Ta;
Res := Arith(a, b, Ta, Op, coord)
|lxAnd:
Assert(Ta.tType = TBOOLEAN, coord, 37);
Res := LONG(FLT(ORD((ai # 0) & (bi # 0))))
|lxOR:
Assert(Ta.tType = TBOOLEAN, coord, 37);
Res := LONG(FLT(ORD((ai # 0) OR (bi # 0))))
|lxEQ, lxNE:
IF Ta.tType = TSTRING THEN
Res := strcmp(a, b, Op)
ELSE
Res := LONG(FLT(ORD(a = b)))
END;
IF Op = lxNE THEN
Res := LONG(FLT(ORD(Res = 0.0D0)))
END
|lxLT, lxGT:
IF Op = lxGT THEN
c := a;
a := b;
b := c
END;
Assert(Ta.tType IN (TNUM + {TSTRING}), coord, 37);
IF Ta.tType = TSTRING THEN
Res := strcmp(a, b, Op)
ELSE
Res := LONG(FLT(ORD(a < b)))
END
|lxLE, lxGE:
IF Op = lxGE THEN
c := a;
a := b;
b := c
END;
Assert(Ta.tType IN (TNUM + {TSTRING, TSET}), coord, 37);
IF Ta.tType = TSTRING THEN
Res := strcmp(a, b, Op)
ELSIF Ta.tType = TSET THEN
Res := LONG(FLT(ORD(BITS(FLOOR(a)) <= BITS(FLOOR(b)))))
ELSE
Res := LONG(FLT(ORD(a <= b)))
END
|lxIN:
Assert((Ta.tType = TINTEGER) & (Tb.tType = TSET), coord, 37);
Assert(ASR(ai, 5) = 0, coord, 49);
Res := LONG(FLT(ORD(ai IN BITS(bi))))
ELSE
END;
IF Relation(Op) OR (Op = lxAnd) OR (Op = lxOR) THEN
TRes := sttypes[TBOOLEAN]
END
END Calc;
PROCEDURE ConstExpr*(VAR Value: LONGREAL; VAR T: pTYPE);
VAR e: EXPRESSION; coord: SCAN.TCoord;
BEGIN
Const := TRUE;
Coord(coord);
sizefunc := FALSE;
Expr(e);
Assert(~sizefunc & (e.eType = eCONST), coord, 62);
Value := e.Value;
T := e.T;
Const := FALSE
END ConstExpr;
PROCEDURE IdType*(VAR coord: SCAN.TCoord): pTYPE;
VAR id: IDENT; Name: SCAN.NODE; Unit: UNIT; Res: pTYPE;
BEGIN
Res := NIL;
Name := SCAN.id;
id := GetIdent(Name);
IF id = NIL THEN
Coord(coord);
NamePtrBase := Name;
Next
ELSE
IF id.iType = IDTYPE THEN
Coord(coord);
Next;
Res := id.T
ELSIF id.iType = IDMOD THEN
Unit := id.Unit;
NextCheck(lxDot);
NextCheck(lxIDENT);
Name := SCAN.id;
NamePtrBase := Name;
id := GetQIdent(Unit, Name);
IF Unit # unit THEN
Assert2(id # NIL, 42);
Assert2(id.iType = IDTYPE, 77);
Coord(coord);
Next;
Res := id.T
ELSE
IF id = NIL THEN
Assert2((unit.Level = 3) & unit.typedecl, 42);
Coord(coord);
Next;
Res := NIL
ELSE
Assert2(id.iType = IDTYPE, 77);
Coord(coord);
Next;
Res := id.T
END
END
ELSE
Assert2(FALSE, 77)
END
END
RETURN Res
END IdType;
PROCEDURE FieldOffset(Align, RecSize: INTEGER): INTEGER;
BEGIN
Assert2(RecSize <= SCAN.maxINT - (Align - RecSize MOD Align) MOD Align, 83)
RETURN RecSize + (Align - RecSize MOD Align) MOD Align
END FieldOffset;
PROCEDURE Dim*(T: pTYPE): INTEGER;
VAR n: INTEGER;
BEGIN
n := 0;
WHILE (T.tType = TARRAY) & (T.Len = 0) DO
INC(n);
T := T.Base
END
RETURN n
END Dim;
PROCEDURE SetFields(Tr, Tf: pTYPE; Rec: BOOLEAN);
VAR cur: FIELD;
BEGIN
cur := Tr.Fields.First(FIELD);
WHILE cur.T # NIL DO
cur := cur.Next(FIELD)
END;
WHILE cur # NIL DO
cur.T := Tf;
IF Rec THEN
IF Tf.Align > Tr.Align THEN
Tr.Align := Tf.Align
END;
IF Tr.Rec = record THEN
cur.Offset := FieldOffset(Tf.Align, Tr.Size);
Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
Tr.Size := cur.Offset + Tf.Size
ELSIF Tr.Rec = noalign THEN
cur.Offset := FieldOffset(1, Tr.Size);
Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
Tr.Size := cur.Offset + Tf.Size
ELSIF Tr.Rec = union THEN
IF Tf.Size > Tr.Size THEN
Tr.Size := Tf.Size
END;
cur.Offset := 0
END
ELSE
Tr.Len := Tr.Len + 4 * (ORD((Tf.tType = TRECORD) & cur.ByRef) + Dim(Tf) + ORD((Tf.tType = TLONGREAL) & ~cur.ByRef) + 1)
END;
cur := cur.Next(FIELD)
END
END SetFields;
PROCEDURE GetField*(T: pTYPE; Name: SCAN.NODE): FIELD;
VAR cur, Res: FIELD;
BEGIN
Res := NIL;
cur := T.Fields.First(FIELD);
WHILE (cur # NIL) & (cur.Name = Name) DO
Res := cur;
cur := NIL
ELSIF cur # NIL DO
cur := cur.Next(FIELD)
END
RETURN Res
END GetField;
PROCEDURE Unique(T: pTYPE; Name: SCAN.NODE): BOOLEAN;
VAR field: FIELD; res: BOOLEAN;
BEGIN
res := TRUE;
WHILE (T # NIL) & res DO
field := GetField(T, Name);
IF field # NIL THEN
IF (field.Unit = unit) OR field.Export THEN
res := FALSE
END
END;
T := T.Base
END
RETURN res
END Unique;
PROCEDURE notrecurs(id: BOOLEAN; T: pTYPE): BOOLEAN;
RETURN ~(id & (unit.Idents.Last(IDENT).iType = IDTYPE) & (unit.Idents.Last(IDENT).T = T) &
(T.tType IN TSTRUCT))
END notrecurs;
PROCEDURE ReadFields(T: pTYPE);
VAR Name: SCAN.NODE; field: FIELD; Tf: pTYPE; coord: SCAN.TCoord; id_T: BOOLEAN;
BEGIN
WHILE SCAN.tLex = lxIDENT DO
Name := SCAN.id;
Assert2(Unique(T, Name), 30);
NEW(field);
MemErr(field = NIL);
UTILS.Push(T.Fields, field);
field.Name := Name;
field.T := NIL;
field.Export := FALSE;
field.Unit := unit;
Next;
IF SCAN.tLex = lxMult THEN
Assert2(unit.Level = 3, 89);
field.Export := TRUE;
Next
END;
IF SCAN.tLex = lxComma THEN
NextCheck(lxIDENT)
ELSIF SCAN.tLex = lxColon THEN
NextCoord(coord);
id_T := SCAN.tLex = lxIDENT;
Tf:= pParseType(coord);
Assert(Tf # NIL, coord, 42);
Assert(notrecurs(id_T, Tf), coord, 96);
SetFields(T, Tf, TRUE);
IF SCAN.tLex = lxSemi THEN
NextCheck(lxIDENT)
ELSE
Assert2(SCAN.tLex = lxEND, 86)
END
ELSE
Assert2(FALSE, 85)
END
END
END ReadFields;
PROCEDURE OpenBase*(T: pTYPE): pTYPE;
BEGIN
WHILE (T.tType = TARRAY) & (T.Len = 0) DO
T := T.Base
END
RETURN T
END OpenBase;
PROCEDURE SetVars(T: pTYPE);
VAR cur: IDENT; n: INTEGER;
BEGIN
cur := unit.Idents.Last(IDENT);
WHILE cur.T = NIL DO
cur := cur.Prev(IDENT)
END;
cur := cur.Next(IDENT);
WHILE cur # NIL DO
cur.T := T;
IF(cur.VarKind = paramvar) OR (cur.VarKind = param) & (T.tType IN TSTRUCT) THEN
n := 4 * (1 + Dim(T) + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
ELSE
n := T.Size;
Assert2(n <= SCAN.maxINT - UTILS.Align(n), 93);
n := n + UTILS.Align(n)
END;
IF cur.Level = 3 THEN
cur.Offset := ProgSize;
Assert2(ProgSize <= SCAN.maxINT - n, 93);
ProgSize := ProgSize + n;
Assert2(ProgSize <= SCAN.maxINT - UTILS.Align(ProgSize), 93);
ProgSize := ProgSize + UTILS.Align(ProgSize)
ELSE
IF cur.VarKind = 0 THEN
cur.Offset := curBlock.ParamSize - curBlock.VarSize - n
ELSE
cur.Offset := curBlock.VarSize - 8 + 4 * (cur.Level + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
END
END;
Assert2(curBlock.VarSize <= SCAN.maxINT - n, 93);
curBlock.VarSize := curBlock.VarSize + n;
Assert2(curBlock.VarSize <= SCAN.maxINT - UTILS.Align(curBlock.VarSize), 93);
curBlock.VarSize := curBlock.VarSize + UTILS.Align(curBlock.VarSize);
IF cur.VarKind # 0 THEN
curBlock.ParamSize := curBlock.VarSize
END;
cur := cur.Next(IDENT)
END
END SetVars;
PROCEDURE CreateType(tType, Len, Size, Number: INTEGER; Base: pTYPE; Fields: BOOLEAN; NewType: pTYPE): pTYPE;
VAR nov: pTYPE;
BEGIN
IF NewType = NIL THEN
NEW(nov);
MemErr(nov = NIL)
ELSE
nov := NewType
END;
UTILS.Push(types, nov);
nov.tType := tType;
nov.Len := Len;
nov.Size := Size;
nov.Base := Base;
nov.Fields := NIL;
nov.Number := Number;
IF Fields THEN
nov.Fields := UTILS.CreateList()
END
RETURN nov
END CreateType;
PROCEDURE FormalType(VAR coord: SCAN.TCoord): pTYPE;
VAR TA: pTYPE;
BEGIN
IF SCAN.tLex = lxARRAY THEN
NextCheck(lxOF);
Next;
TA := CreateType(TARRAY, 0, 0, 0, FormalType(coord), FALSE, NIL)
ELSE
Check(lxIDENT);
TA := IdType(coord);
Assert(TA # NIL, coord, 42);
END
RETURN TA
END FormalType;
PROCEDURE Section(T: pTYPE);
VAR Name: SCAN.NODE; ByRef, cont: BOOLEAN; field: FIELD;
Tf: pTYPE; fp: IDENT; coord: SCAN.TCoord; proc: BOOLEAN;
BEGIN
proc := T = NIL;
IF proc THEN
T := curBlock.T
END;
Assert2((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR), 84);
ByRef := FALSE;
IF SCAN.tLex = lxVAR THEN
ByRef := TRUE;
NextCheck(lxIDENT)
END;
cont := TRUE;
WHILE cont DO
Name := SCAN.id;
Assert2(GetField(T, Name) = NIL, 30);
NEW(field);
MemErr(field = NIL);
UTILS.Push(T.Fields, field);
field.Name := Name;
field.T := NIL;
field.ByRef := ByRef;
IF proc THEN
PushIdent(Name, coord, IDVAR, NIL, NIL, FALSE, 0);
INC(curBlock.ParamCount);
fp := unit.Idents.Last(IDENT);
IF ByRef THEN
fp.VarKind := paramvar
ELSE
fp.VarKind := param
END
END;
Next;
IF SCAN.tLex = lxComma THEN
NextCheck(lxIDENT)
ELSIF SCAN.tLex = lxColon THEN
Next;
Tf := FormalType(coord);
Assert(Dim(Tf) <= X86.ADIM, coord, 110);
SetFields(T, Tf, FALSE);
IF proc THEN
SetVars(Tf)
END;
cont := FALSE
ELSE
Assert2(FALSE, 85)
END
END
END Section;
PROCEDURE ParamType(T: pTYPE);
VAR break: BOOLEAN;
BEGIN
IF (SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR) THEN
break := FALSE;
REPEAT
Section(T);
IF SCAN.tLex = lxSemi THEN
Next
ELSE
break := TRUE
END
UNTIL break
END
END ParamType;
PROCEDURE AddPtrBase(Name: SCAN.NODE; coord: SCAN.TCoord; T: pTYPE);
VAR nov: PTRBASE;
BEGIN
NEW(nov);
MemErr(nov = NIL);
nov.Name := Name;
nov.coord := coord;
nov.Ptr := T;
UTILS.Push(PtrBases, nov)
END AddPtrBase;
PROCEDURE FormalList(T: pTYPE; VAR Res: pTYPE);
VAR coord: SCAN.TCoord;
BEGIN
IF SCAN.tLex = lxLRound THEN
Next;
ParamType(T);
Check(lxRRound);
Next;
IF SCAN.tLex = lxColon THEN
NextCheck(lxIDENT);
Res := IdType(coord);
Assert(Res # NIL, coord, 42);
Assert(~(Res.tType IN TSTRUCT), coord, 82)
END
END
END FormalList;
PROCEDURE CallFlag(VAR Call: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
res := SCAN.tLex = lxLSquare;
IF res THEN
Next;
IF SCAN.Lex = "cdecl" THEN
Call := cdecl
ELSIF SCAN.Lex = "stdcall" THEN
Call := stdcall
ELSIF SCAN.Lex = "winapi" THEN
Assert2(winplatf, 50);
Call := winapi
ELSE
Assert2(FALSE, 44)
END;
NextCheck(lxRSquare);
Next;
ELSE
Call := defcall
END
RETURN res
END CallFlag;
PROCEDURE RecFlag(VAR rec: INTEGER): BOOLEAN;
VAR res: BOOLEAN;
BEGIN
res := SCAN.tLex = lxLSquare;
IF res THEN
Next;
IF SCAN.Lex = "union" THEN
rec := union
ELSIF SCAN.Lex = "noalign" THEN
rec := noalign
ELSE
Assert2(FALSE, 103)
END;
NextCheck(lxRSquare);
Next;
ELSE
rec := record
END
RETURN res
END RecFlag;
PROCEDURE StructType(Comma: BOOLEAN; NewType: pTYPE): pTYPE;
VAR v: LONGREAL; T, nov: pTYPE; coord, coord2: SCAN.TCoord; id_T: BOOLEAN;
BEGIN
CASE SCAN.tLex OF
|lxARRAY, lxComma:
IF SCAN.tLex = lxComma THEN
Assert2(Comma, 39)
END;
NextCoord(coord);
ConstExpr(v, T);
Assert(T.tType = TINTEGER, coord, 52);
Assert(v > 0.0D0, coord, 78);
nov := CreateType(TARRAY, FLOOR(v), 0, 0, NIL, FALSE, NewType);
IF SCAN.tLex = lxComma THEN
nov.Base := StructType(TRUE, NIL)
ELSIF SCAN.tLex = lxOF THEN
NextCoord(coord);
id_T := SCAN.tLex = lxIDENT;
nov.Base := pParseType(coord);
Assert(nov.Base # NIL, coord, 42);
Assert(notrecurs(id_T, nov.Base), coord, 96)
ELSE
Assert2(FALSE, 79)
END;
Assert2(nov.Base.Size <= SCAN.maxINT DIV nov.Len, 83);
nov.Size := nov.Base.Size * nov.Len;
nov.Align := nov.Base.Align
|lxRECORD:
NextCoord(coord);
INC(RecCount);
nov := CreateType(TRECORD, 0, 0, RecCount, NIL, TRUE, NewType);
nov.Align := 1;
IF RecFlag(nov.Rec) THEN
Assert(unit.sys, coord, 111)
END;
Coord(coord);
IF SCAN.tLex = lxLRound THEN
NextCoord(coord2);
Check(lxIDENT);
nov.Base := IdType(coord);
Assert(nov.Base # NIL, coord, 42);
Assert(nov.Base.tType = TRECORD, coord, 80);
Assert(notrecurs(TRUE, nov.Base), coord, 96);
nov.Size := nov.Base.Size;
nov.Align := nov.Base.Align;
Check(lxRRound);
Next;
Assert(nov.Rec = record, coord, 112);
Assert(nov.Base.Rec = record, coord2, 113)
END;
ReadFields(nov);
Check(lxEND);
nov.Size := X86.Align(nov.Size, nov.Align);
IF nov.Base # NIL THEN
X86.AddRec(nov.Base.Number)
ELSE
X86.AddRec(0)
END;
Next
|lxPOINTER:
NextCheck(lxTO);
NextCoord(coord);
nov := CreateType(TPOINTER, 0, 4, 0, NIL, FALSE, NewType);
nov.Align := 4;
nov.Base := pParseType(coord);
IF nov.Base = NIL THEN
Assert(unit.typedecl, coord, 42);
AddPtrBase(NamePtrBase, coord, nov)
ELSE
Assert(nov.Base.tType = TRECORD, coord, 81)
END
|lxPROCEDURE:
NextCoord(coord);
nov := CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NewType);
IF CallFlag(nov.Call) THEN
Assert(unit.sys, coord, 111)
END;
nov.Align := 4;
FormalList(nov, nov.Base)
ELSE
Assert2(FALSE, 39)
END
RETURN nov
END StructType;
PROCEDURE ParseType(VAR coord: SCAN.TCoord): pTYPE;
VAR Res: pTYPE;
BEGIN
IF SCAN.tLex = lxIDENT THEN
Res := IdType(coord)
ELSE
Res := StructType(FALSE, NIL)
END
RETURN Res
END ParseType;
PROCEDURE PopBlock;
VAR cur: IDENT; n: INTEGER;
BEGIN
cur := unit.Idents.Last(IDENT);
n := 0;
WHILE cur.iType # IDGUARD DO
cur := cur.Prev(IDENT);
INC(n)
END;
cur := cur.Prev(IDENT);
INC(n);
unit.Idents.Count := unit.Idents.Count - n;
unit.Idents.Last := cur;
cur.Next := NIL;
DEC(unit.Level)
END PopBlock;
PROCEDURE LinkPtr;
VAR cur: PTRBASE; id: IDENT;
BEGIN
cur := PtrBases.First(PTRBASE);
WHILE cur # NIL DO
id := GetIdent(cur.Name);
Assert(id # NIL, cur.coord, 42);
Assert(id.T.tType = TRECORD, cur.coord, 81);
cur.Ptr.Base := id.T;
cur := cur.Next(PTRBASE)
END;
UTILS.Clear(PtrBases)
END LinkPtr;
PROCEDURE addproc;
VAR proc: Proc;
BEGIN
NEW(proc);
MemErr(proc = NIL);
proc.used := FALSE;
proc.Procs := UTILS.CreateList();
UTILS.Push(procs, proc);
curproc := proc
END addproc;
PROCEDURE DeclSeq;
VAR Value: LONGREAL; T, NewType: pTYPE; Name: SCAN.NODE; coord: SCAN.TCoord; Call: INTEGER;
Export, func: BOOLEAN; last, id: IDENT; e: EXPRESSION;
PROCEDURE IdentDef;
BEGIN
Name := SCAN.id;
Coord(coord);
Next;
Export := FALSE;
IF SCAN.tLex = lxMult THEN
Assert2(unit.Level = 3, 89);
Export := TRUE;
Next
END
END IdentDef;
BEGIN
IF SCAN.tLex = lxCONST THEN
Next;
WHILE SCAN.tLex = lxIDENT DO
IdentDef;
PushIdent(Name, coord, IDCONST, NIL, NIL, Export, 0);
last := unit.Idents.Last(IDENT);
Check(lxEQ);
Next;
ConstExpr(Value, T);
Check(lxSemi);
last.Value := Value;
last.T := T;
Next
END
END;
IF SCAN.tLex = lxTYPE THEN
UTILS.Clear(PtrBases);
unit.typedecl := TRUE;
Next;
WHILE SCAN.tLex = lxIDENT DO
IdentDef;
PushIdent(Name, coord, IDTYPE, NIL, NIL, Export, 0);
last := unit.Idents.Last(IDENT);
Check(lxEQ);
Next;
NEW(NewType);
MemErr(NewType = NIL);
last.T := NewType;
T := StructType(FALSE, NewType);
Check(lxSemi);
Next
END
END;
LinkPtr;
unit.typedecl := FALSE;
IF SCAN.tLex = lxVAR THEN
Next;
WHILE SCAN.tLex = lxIDENT DO
IdentDef;
PushIdent(Name, coord, IDVAR, NIL, NIL, Export, 0);
IF SCAN.tLex = lxComma THEN
NextCheck(lxIDENT)
ELSIF SCAN.tLex = lxColon THEN
NextCoord(coord);
T := ParseType(coord);
Assert(T # NIL, coord, 42);
SetVars(T);
Check(lxSemi);
Next
ELSE
Assert2(FALSE, 85)
END
END
END;
WHILE SCAN.tLex = lxPROCEDURE DO
NextCoord(coord);
IF CallFlag(Call) THEN
Assert(unit.Level = 3, coord, 45);
Assert(unit.sys, coord, 111)
END;
Check(lxIDENT);
IdentDef;
PushIdent(Name, coord, IDPROC, CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NIL), NIL, Export, 0);
id := unit.Idents.Last(IDENT);
addproc;
id.Proc := curproc;
IF id.Export & main THEN
IF Platform IN {1, 6} THEN
curproc.used := TRUE;
Assert((Name # SCAN._START) & (Name # SCAN._version), coord, 133)
END;
X86.ProcExport(id.Number, Name, X86.NewLabel())
END;
id.Parent := curBlock;
curBlock := id;
Guard;
FormalList(NIL, curBlock.T.Base);
id.T.Call := Call;
Check(lxSemi);
Next;
DeclSeq;
id.LocalSize := id.VarSize - id.ParamSize;
X86.Label(X86.NewLabel());
curproc.beg := X86.current;
X86.ProcBeg(id.Number, id.LocalSize, FALSE);
IF SCAN.tLex = lxBEGIN THEN
Next;
OpSeq
END;
func := curBlock.T.Base.tType # TVOID;
IF func THEN
Check(lxRETURN);
UTILS.UnitLine(UnitNumber, SCAN.coord.line);
NextCoord(coord);
Expr(e);
Assert(AssComp(e, curBlock.T.Base, FALSE), coord, 125);
IF e.eType = eVAR THEN
X86.Load(e.T.tType)
END
ELSE
Assert2(SCAN.tLex # lxRETURN, 123)
END;
Check(lxEND);
NextCheck(lxIDENT);
Assert2(SCAN.id = Name, 87);
NextCheck(lxSemi);
Next;
X86.ProcEnd(id.Number, (id.ParamSize + (id.Level - 3) * 4) * ORD(curBlock.T.Call IN {stdcall, winapi, defcall}), func, curBlock.T.Base.tType IN TFLOAT);
X86.Label(X86.NewLabel());
curproc.end := X86.current;
PopBlock;
curBlock := curBlock.Parent;
curproc := curBlock.Proc(Proc);
END
END DeclSeq;
PROCEDURE Rtl(u: UNIT);
PROCEDURE AddProc(name: UTILS.STRING; num: INTEGER);
VAR id: IDENT;
BEGIN
id := GetQIdent(u, SCAN.AddNode(name));
id.Proc(Proc).used := TRUE;
IF id = NIL THEN
UTILS.ErrMsg(158);
UTILS.HALT(1)
END;
X86.AddRtlProc(num, id.Number)
END AddProc;
BEGIN
AddProc("_newrec", X86._newrec);
AddProc("_disprec", X86._disprec);
AddProc("_rset", X86._rset);
AddProc("_inset", X86._inset);
AddProc("_saverec", X86._saverec);
AddProc("_checktype", X86._checktype);
AddProc("_strcmp", X86._strcmp);
AddProc("_lstrcmp", X86._lstrcmp);
AddProc("_rstrcmp", X86._rstrcmp);
AddProc("_savearr", X86._savearr);
AddProc("_arrayidx", X86._arrayidx);
AddProc("_arrayidx1", X86._arrayidx1);
AddProc("_arrayrot", X86._arrayrot);
AddProc("_assrt", X86._assrt);
AddProc("_strcopy", X86._strcopy);
AddProc("_init", X86._init);
AddProc("_close", X86._close);
AddProc("_halt", X86._halt);
AddProc("_length", X86._length);
END Rtl;
PROCEDURE ImportList;
VAR cond: INTEGER; coord, namecoord: SCAN.TCoord;
name, alias: SCAN.NODE; u, self: UNIT;
FName: UTILS.STRING;
PROCEDURE AddUnit(newcond: INTEGER);
VAR str: STRITEM;
BEGIN
u := GetModule(name);
IF u = NIL THEN
self := unit;
SCAN.Backup(unit.scanner);
COPY(name.Name, FName);
IF ~((~self.Std & pReadModule(Path, FName, UTILS.Ext)) OR pReadModule(Std, FName, UTILS.Ext)) THEN
IF FName = "SYSTEM" THEN
unit := sys;
self.sys := TRUE
ELSE
Assert(FALSE, namecoord, 32)
END
END;
SCAN.Recover(self.scanner);
u := unit;
unit := self;
UTILS.SetFile(unit.File)
ELSE
Assert(u.Closed, namecoord, 31)
END;
PushIdent(alias, coord, IDMOD, voidtype, u, FALSE, 0);
NEW(str);
MemErr(str = NIL);
str.Str := name.Name;
UTILS.Push(unit.Import, str);
cond := newcond
END AddUnit;
BEGIN
cond := 0;
WHILE cond # 4 DO
Next;
CASE cond OF
|0: Check(lxIDENT);
name := SCAN.id;
Coord(coord);
Coord(namecoord);
alias := name;
cond := 1
|1: CASE SCAN.tLex OF
|lxComma: AddUnit(0)
|lxSemi: AddUnit(4); Next
|lxAssign: cond := 2
ELSE
Assert2(FALSE, 28)
END
|2: Check(lxIDENT);
name := SCAN.id;
Coord(namecoord);
cond := 3
|3: CASE SCAN.tLex OF
|lxComma: AddUnit(0)
|lxSemi: AddUnit(4); Next
ELSE
Assert2(FALSE, 29)
END
ELSE
END
END
END ImportList;
PROCEDURE Header(Name: SCAN.NODE);
BEGIN
NEW(unit);
MemErr(unit = NIL);
unit.Idents := UTILS.CreateList();
unit.Level := 0;
unit.Name := Name;
Guard; Guard;
PushIdent(unit.Name, zcoord, IDMOD, voidtype, unit, FALSE, 0);
Guard;
unit.IdentBegin := unit.Idents.Last(IDENT);
unit.Closed := TRUE
END Header;
PROCEDURE Pseudo;
VAR temp: UNIT;
BEGIN
temp := unit;
Header(SCAN.AddNode("SYSTEM"));
PushSysProc("ADR", sysADR);
PushSysProc("SIZE", sysSIZE);
PushSysProc("TYPEID", sysTYPEID);
PushSysProc("GET", sysGET);
PushSysProc("PUT", sysPUT);
PushSysProc("CODE", sysCODE);
PushSysProc("MOVE", sysMOVE);
PushSysProc("INF", sysINF);
PushSysType("CARD16", TCARD16);
sys := unit;
unit := temp
END Pseudo;
PROCEDURE ReadModule(Path, Name1, Ext: UTILS.STRING): BOOLEAN;
VAR FHandle: INTEGER; name, Name, b: UTILS.STRING; idmod: IDENT; Res, temp: BOOLEAN; coord: SCAN.TCoord;
BEGIN
Res := FALSE;
name := Name1;
Name := Name1;
b := Path;
UTILS.concat(b, Name);
Name := b;
UTILS.concat(Name, Ext);
IF SCAN.Open(Name, FHandle) THEN
NEW(unit);
MemErr(unit = NIL);
unit.sys := FALSE;
unit.Std := Path = Std;
UTILS.Push(prog, unit);
unit.Idents := UTILS.CreateList();
unit.Import := UTILS.CreateList();
NEW(unit.scanner);
MemErr(unit.scanner = NIL);
unit.Closed := FALSE;
unit.Level := 0;
unit.typedecl := FALSE;
COPY(Name, unit.File);
UTILS.SetFile(unit.File);
StIdent;
NextCheck(lxMODULE);
NextCheck(lxIDENT);
Assert2(UTILS.streq(SCAN.id.Name, name), 33);
unit.Name := SCAN.id;
coord := SCAN.coord;
PushIdent(unit.Name, coord, IDMOD, voidtype, unit, FALSE, 0);
idmod := unit.Idents.Last(IDENT);
Guard;
NextCheck(lxSemi);
Next;
IF SCAN.tLex = lxIMPORT THEN
temp := main;
main := FALSE;
ImportList;
main := temp
END;
UTILS.OutString("compiling "); UTILS.OutString(unit.Name.Name); UTILS.Ln;
X86.Module(idmod.Name.Name, idmod.Number);
UnitNumber := idmod.Number;
unit.IdentBegin := unit.Idents.Last(IDENT);
curBlock := idmod;
DeclSeq;
X86.ProcBeg(idmod.Number, 0, TRUE);
IF SCAN.tLex = lxBEGIN THEN
addproc;
curproc.used := TRUE;
Next;
OpSeq
END;
Check(lxEND);
NextCheck(lxIDENT);
Assert2(SCAN.id = unit.Name, 26);
NextCheck(lxDot);
X86.Leave;
unit.Closed := TRUE;
UTILS.Clear(unit.Import);
Res := TRUE
END
RETURN Res
END ReadModule;
PROCEDURE Program*(StdPath, FilePath, NameFile, ExtFile: UTILS.STRING; windows: BOOLEAN;
OpSeqProc: opPROC; ExprProc: expPROC; AssCompProc: assPROC; VAR stypes: stTYPES);
BEGIN
winplatf := windows;
Path := FilePath;
Main := NameFile;
ExtMain := ExtFile;
Std := StdPath;
OpSeq := OpSeqProc;
Expr := ExprProc;
AssComp := AssCompProc;
prog := UTILS.CreateList();
PtrBases := UTILS.CreateList();
types := UTILS.CreateList();
procs := UTILS.CreateList();
StTypes;
voidtype := sttypes[TVOID];
Strings := UTILS.CreateList();
Pseudo;
stypes := sttypes
END Program;
PROCEDURE delfirstchar(VAR s: UTILS.STRING);
VAR i: INTEGER;
BEGIN
FOR i := 0 TO LENGTH(s) - 1 DO
s[i] := s[i + 1]
END
END delfirstchar;
PROCEDURE DelProcs;
VAR cur: Proc;
PROCEDURE ProcHandling(proc: Proc);
VAR cur: IDENT; p: Proc;
BEGIN
proc.used := TRUE;
cur := proc.Procs.First(IDENT);
WHILE cur # NIL DO
p := cur.Proc(Proc);
IF ~p.used THEN
ProcHandling(p)
END;
cur := cur.Next(IDENT)
END;
END ProcHandling;
BEGIN
cur := procs.First(Proc);
WHILE cur # NIL DO
IF cur.used THEN
ProcHandling(cur)
END;
cur := cur.Next(Proc)
END;
cur := procs.First(Proc);
WHILE cur # NIL DO
IF ~cur.used THEN
X86.DelProc(cur.beg, cur.end)
END;
cur := cur.Next(Proc)
END
END DelProcs;
PROCEDURE Compile*(platform, stksize: INTEGER);
VAR full, path, name, ext, temp, path2: UTILS.STRING;
BEGIN
Platform := platform;
main := FALSE;
IF ReadModule(Path, "RTL", UTILS.Ext) OR ReadModule(Std, "RTL", UTILS.Ext) THEN
Rtl(unit)
ELSE
UTILS.ErrMsg(65);
UTILS.HALT(1)
END;
main := TRUE;
IF ~ReadModule(Path, Main, ExtMain) THEN
path2 := Path;
UTILS.ParamStr(full, 0);
UTILS.Split(full, path, name, ext);
IF path[0] # 0X THEN
path[LENGTH(path) - 1] := 0X
END;
IF Path[0] = UTILS.Slash THEN
delfirstchar(Path)
END;
UTILS.concat(path, UTILS.Slash);
full := path;
UTILS.concat(full, Path);
Path := full;
IF (UTILS.OS = "WIN") & (Path[0] = UTILS.Slash) THEN
delfirstchar(Path)
END;
IF ~ReadModule(Path, Main, ExtMain) THEN
UTILS.ErrMsg(64);
UTILS.OutString(path2);
UTILS.OutString(Main);
UTILS.OutString(ExtMain);
UTILS.Ln;
UTILS.HALT(1)
END
END;
temp := Path;
UTILS.concat(temp, Main);
IF platform IN {2, 3} THEN
UTILS.concat(temp, ".exe")
ELSIF platform = 1 THEN
UTILS.concat(temp, ".dll")
ELSIF platform = 4 THEN
UTILS.concat(temp, ".kex")
ELSIF platform = 6 THEN
UTILS.concat(temp, ".obj")
END;
IF platform IN {1, 2, 3, 4} THEN
stksize := stksize * 100000H
END;
DelProcs;
X86.Epilog(ProgSize, temp, stksize)
END Compile;
BEGIN
pParseType := ParseType;
pReadModule := ReadModule;
zcoord.line := 0;
zcoord.col := 0
END DECL.

/programs/develop/oberon07/Source/ELF.ob07
0,0 → 1,295
(*
Copyright 2016 Anton Krotov
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE ELF;
IMPORT SYSTEM;
CONST size* = 8346;
PROCEDURE [stdcall] data;
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;
PROCEDURE get*(): INTEGER;
RETURN SYSTEM.ADR(data) + 3
END get;
END ELF.

/programs/develop/oberon07/Source/ERRORS.ob07
0,0 → 1,285
(*
Copyright 2016 Anton Krotov
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE ERRORS;
IMPORT H := HOST;
TYPE
STRING = ARRAY 1024 OF CHAR;
CP = ARRAY 256 OF INTEGER;
VAR
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;
PROCEDURE InitCP(VAR cp: CP);
VAR i: INTEGER;
BEGIN
FOR i := 0H TO 7FH DO
cp[i] := i
END
END InitCP;
PROCEDURE Init8(VAR cp: CP; VAR n: INTEGER; a, b, c, d, e, f, g, h: INTEGER);
BEGIN
cp[n] := a; INC(n);
cp[n] := b; INC(n);
cp[n] := c; INC(n);
cp[n] := d; INC(n);
cp[n] := e; INC(n);
cp[n] := f; INC(n);
cp[n] := g; INC(n);
cp[n] := h; INC(n);
END Init8;
PROCEDURE InitCP866(VAR cp: CP);
VAR n, i: INTEGER;
BEGIN
FOR i := 0410H TO 043FH DO
cp[i - 0410H + 80H] := i
END;
FOR i := 0440H TO 044FH DO
cp[i - 0440H + 0E0H] := i
END;
n := 0B0H;
Init8(cp, n, 2591H, 2592H, 2593H, 2502H, 2524H, 2561H, 2562H, 2556H);
Init8(cp, n, 2555H, 2563H, 2551H, 2557H, 255DH, 255CH, 255BH, 2510H);
Init8(cp, n, 2514H, 2534H, 252CH, 251CH, 2500H, 253CH, 255EH, 255FH);
Init8(cp, n, 255AH, 2554H, 2569H, 2566H, 2560H, 2550H, 256CH, 2567H);
Init8(cp, n, 2568H, 2564H, 2565H, 2559H, 2558H, 2552H, 2553H, 256BH);
Init8(cp, n, 256AH, 2518H, 250CH, 2588H, 2584H, 258CH, 2590H, 2580H);
n := 0F0H;
Init8(cp, n, 0401H, 0451H, 0404H, 0454H, 0407H, 0457H, 040EH, 045EH);
Init8(cp, n, 00B0H, 2219H, 00B7H, 221AH, 2116H, 00A4H, 25A0H, 00A0H);
InitCP(cp)
END InitCP866;
PROCEDURE 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 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;
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 := "᫨誮¬ ¤«¨­­ ï áâப®¢ ï ª®­áâ ­â "
| 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/SCAN.ob07
0,0 → 1,699
(*
Copyright 2016 Anton Krotov
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE SCAN;
IMPORT UTILS, sys := SYSTEM;
CONST
Tab = 8;
maxINT* = 7FFFFFFFH;
minINT* = 80000000H;
maxREAL* = 3.39E38;
maxDBL* = 1.69D308;
minREAL* = 1.41E-45;
IDLENGTH = 255;
STRLENGTH* = 256;
lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7;
lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8;
lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16;
lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23;
lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30;
lxUNTIL = 31; lxVAR = 32; lxWHILE = 33;
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58;
lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65;
lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
lxERR0 = 100; lxERR1 = 101; lxERR2 = 102; lxERR3 = 103; lxERR4 = 104; lxERR5 = 105; lxERR6 = 106;
lxERR7 = 107; lxERR8 = 108; lxERR9 = 109; lxERR10 = 110; lxERR11 = 111; lxERR20 = 120;
TYPE
TCoord* = RECORD line*, col*: INTEGER END;
NODE* = POINTER TO RECORD
Left, Right: NODE;
tLex: INTEGER;
Name*: UTILS.STRING
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
END;
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;
PROCEDURE AddNode*(Name: UTILS.STRING): NODE;
VAR cur, res: NODE;
PROCEDURE NewNode(Right: BOOLEAN);
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
ELSE
cur.Left := res
END
END NewNode;
BEGIN
res := NIL;
cur := Nodes[ORD(Name[0])];
REPEAT
IF Name > cur.Name THEN
IF cur.Right # NIL THEN
cur := cur.Right
ELSE
NewNode(TRUE)
END
ELSIF Name < cur.Name THEN
IF cur.Left # NIL THEN
cur := cur.Left
ELSE
NewNode(FALSE)
END
ELSE
res := cur
END
UNTIL res # NIL
RETURN res
END AddNode;
PROCEDURE Backup*(scanner: SCANNER);
BEGIN
scanner.File := File;
scanner.ccol := ccol;
scanner.cline := cline;
scanner.ch := ch;
scanner.Lex := Lex;
scanner.count := count;
scanner.coord := coord;
scanner.tLex := tLex;
scanner.vINT := vINT;
scanner.vFLT := vFLT;
scanner.vCHX := vCHX;
scanner.buf := buf;
scanner.bufpos := bufpos;
scanner.CR := CR;
scanner.UTF8 := UTF8
END Backup;
PROCEDURE Recover*(scanner: SCANNER);
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;
PROCEDURE Next;
VAR cr: BOOLEAN;
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
ELSE
END;
CR := cr;
INC(bufpos)
END Next;
PROCEDURE Open*(FName: ARRAY OF CHAR; VAR FHandle: INTEGER): BOOLEAN;
VAR n, size: INTEGER; 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
END;
Next
END
RETURN (File # 0) & (n = size)
END Open;
PROCEDURE Space(ch: CHAR): BOOLEAN;
RETURN (ch <= 20X) & (ch > 0X)
END Space;
PROCEDURE Letter(ch: CHAR): BOOLEAN;
RETURN (ch >= "A") & (ch <= "Z") OR (ch >= "a") & (ch <= "z") OR (ch = "_")
END Letter;
PROCEDURE Digit*(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END Digit;
PROCEDURE HexDigit*(ch: CHAR): BOOLEAN;
RETURN (ch >= "A") & (ch <= "F") OR (ch >= "0") & (ch <= "9")
END HexDigit;
PROCEDURE PutChar(ch: CHAR);
BEGIN
Lex[count] := ch;
IF ch # 0X THEN
INC(count)
END
END PutChar;
PROCEDURE PutNext(ch: CHAR);
BEGIN
PutChar(ch);
Next
END PutNext;
PROCEDURE Ident;
BEGIN
tLex := lxIDENT;
WHILE Letter(ch) OR Digit(ch) DO
PutNext(ch)
END;
PutChar(0X);
IF count > IDLENGTH THEN
tLex := lxERR10
END
END Ident;
PROCEDURE hex*(ch: CHAR): INTEGER;
VAR Res: INTEGER;
BEGIN
Res := ORD(ch);
CASE ch OF
|"0".."9": DEC(Res, ORD("0"))
|"A".."F": DEC(Res, ORD("A") - 10)
ELSE
END
RETURN Res
END hex;
PROCEDURE StrToInt16(str: UTILS.STRING): INTEGER;
VAR i, res, n: INTEGER; flag: BOOLEAN;
BEGIN
res := 0;
i := 0;
n := 0;
WHILE str[i] = "0" DO
INC(i)
END;
flag := TRUE;
WHILE flag & (str[i] # "X") & (str[i] # "H") DO
INC(n);
IF n > 8 THEN
tLex := lxERR5;
flag := FALSE
ELSE
res := LSL(res, 4) + hex(str[i]);
INC(i)
END
END
RETURN res
END StrToInt16;
PROCEDURE StrToChx(str: UTILS.STRING): CHAR;
VAR res: INTEGER;
BEGIN
res := StrToInt16(str);
IF (res < 0) OR (res > 0FFH) THEN
tLex := lxERR6;
res := 0
END
RETURN CHR(res)
END StrToChx;
PROCEDURE StrToInt*(str: UTILS.STRING): INTEGER;
VAR i, res: INTEGER; flag: BOOLEAN;
BEGIN
res := 0;
i := 0;
flag := TRUE;
WHILE flag & (str[i] # 0X) DO
IF res > maxINT DIV 10 THEN
tLex := lxERR5;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
tLex := lxERR5;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN res
END StrToInt;
PROCEDURE StrToFloat(str: UTILS.STRING): LONGREAL;
VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, nez: BOOLEAN;
PROCEDURE Error(e: INTEGER; VAR cont: BOOLEAN);
BEGIN
tLex := e;
res := 0.0D0;
cont := FALSE
END Error;
PROCEDURE Inf(VAR cont: BOOLEAN; VAR i: INTEGER);
BEGIN
IF UTILS.IsInf(res) THEN
Error(lxERR7, cont)
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)
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;
PROCEDURE part3(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
cont := TRUE;
IF str[i] = 0X THEN
IF res > LONG(maxREAL) THEN
Error(lxERR7, cont)
ELSIF nez & ((res = 0.0D0) OR (res < LONG(minREAL)) & (tLex = lxREAL)) THEN
Error(lxERR9, cont)
END
END
RETURN cont
END part3;
PROCEDURE part4(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
IF str[i] = "D" THEN
tLex := lxLONGREAL
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)
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
Error(lxERR8, cont)
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN cont
END part4;
PROCEDURE part5(): BOOLEAN;
VAR cont: BOOLEAN; i: INTEGER;
BEGIN
cont := TRUE;
IF scale = maxINT THEN
Error(lxERR8, cont)
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)
END
RETURN cont
END part5;
BEGIN
IF part1() & part2() & part3() & part4() & part5() THEN END
RETURN res
END StrToFloat;
PROCEDURE Number;
VAR nextchr: CHAR;
BEGIN
tLex := lxINT;
WHILE Digit(ch) DO
PutNext(ch)
END;
IF ch = "H" THEN
tLex := lxHEX
ELSIF ch = "X" THEN
tLex := lxCHX
END;
IF tLex # lxINT THEN
PutNext(ch)
ELSE
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
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
ELSE
WHILE Digit(ch) DO
PutNext(ch)
END
END
END
END
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
END
RETURN Res
END Delim;
PROCEDURE Comment;
VAR c, level: INTEGER; cont: BOOLEAN;
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
ELSE
c := 1
END;
END;
IF cont THEN
Next
END
END Comment;
PROCEDURE GetLex*;
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)
ELSE
END
|22X:
tLex := lxSTRING;
Next;
WHILE (ch # 22X) & (ch >= 20X) DO
PutNext(ch)
END;
IF ch = 22X THEN
Next
ELSE
tLex := lxERR3
END;
PutChar(0X);
INC(count);
IF count > STRLENGTH THEN
tLex := lxERR11
END
|"/":
tLex := Delim(ch);
PutNext(ch);
IF ch = "/" THEN
WHILE (ch >= 20X) OR (ch = 9X) DO
PutNext(ch)
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
END
END GetLex;
PROCEDURE AddNodeKey(Name: UTILS.STRING; key: INTEGER);
VAR node: NODE;
BEGIN
node := AddNode(Name);
node.tLex := key
END AddNodeKey;
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
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;
BEGIN
Init
END SCAN.

/programs/develop/oberon07/Source/UTILS.ob07
0,0 → 1,426
(*
Copyright 2016 Anton Krotov
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE UTILS;
IMPORT sys := SYSTEM, H := HOST, ERRORS;
CONST
OS* = H.OS;
Slash* = H.Slash;
Ext* = ".ob07";
MAX_PATH = 1024;
MAX_PARAM = 1024;
Date* = 1451606400; (* 2016-01-01 *)
TYPE
STRING* = ARRAY MAX_PATH OF CHAR;
ITEM* = POINTER TO rITEM;
rITEM* = RECORD
Next*, Prev*: ITEM
END;
LIST* = POINTER TO RECORD
First*, Last*: ITEM;
Count*: INTEGER
END;
STRCONST* = POINTER TO RECORD (rITEM)
Str*: STRING;
Len*, Number*: INTEGER
END;
VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
ParamCount*, Line*, Unit*: INTEGER;
FileName: STRING;
PROCEDURE SetFile*(F: STRING);
BEGIN
FileName := F
END SetFile;
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 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;
BEGIN
p := H.GetCommandLine();
cond := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END
|4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3, 5: ChangeCond(cond, 1, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
END;
INC(p)
END;
ParamCount := count - 1
END ParamParse;
PROCEDURE ParamStr*(VAR str: ARRAY OF CHAR; n: INTEGER);
VAR i, j, len: INTEGER; c: CHAR;
BEGIN
j := 0;
IF n <= ParamCount THEN
len := LEN(str) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
str[j] := c;
INC(j)
END;
INC(i)
END
END;
str[j] := 0X
END ParamStr;
PROCEDURE GetMem*(n: INTEGER): INTEGER;
RETURN H.malloc(n)
END GetMem;
PROCEDURE CloseF*(F: INTEGER);
BEGIN
H.CloseFile(F)
END CloseF;
PROCEDURE Read*(F, Buffer, Count: INTEGER): INTEGER;
RETURN H.FileRW(F, Buffer, Count, FALSE)
END Read;
PROCEDURE Write*(F, Buffer, Count: INTEGER): INTEGER;
RETURN H.FileRW(F, Buffer, Count, TRUE)
END Write;
PROCEDURE FileSize*(F: INTEGER): INTEGER;
RETURN H.FileSize(F)
END FileSize;
PROCEDURE CharC*(x: CHAR);
VAR str: ARRAY 2 OF CHAR;
BEGIN
str[0] := x;
str[1] := 0X;
H.OutString(str)
END CharC;
PROCEDURE Int*(x: INTEGER);
VAR i: INTEGER; buf: ARRAY 11 OF INTEGER;
BEGIN
i := 0;
REPEAT
buf[i] := x MOD 10;
x := x DIV 10;
INC(i)
UNTIL x = 0;
REPEAT
DEC(i);
CharC(CHR(buf[i] + ORD("0")))
UNTIL i = 0
END Int;
PROCEDURE Ln*;
BEGIN
CharC(0DX);
CharC(0AX)
END Ln;
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 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);
BEGIN
Unit := newUnit;
Line := newLine
END UnitLine;
PROCEDURE min*(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END min;
PROCEDURE Align*(n: INTEGER): INTEGER;
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 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 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);
BEGIN
IF this.Count = 0 THEN
this.First := item;
item.Prev := NIL
ELSE
this.Last.Next := item;
item.Prev := this.Last
END;
INC(this.Count);
this.Last := item;
item.Next := NIL
END Push;
PROCEDURE Insert*(this: LIST; item, prev: ITEM);
BEGIN
IF prev # this.Last THEN
item.Next := prev.Next;
item.Prev := prev;
prev.Next := item;
item.Next.Prev := item;
INC(this.Count)
ELSE
Push(this, item)
END
END Insert;
PROCEDURE Clear*(this: LIST);
BEGIN
this.First := NIL;
this.Last := NIL;
this.Count := 0
END Clear;
PROCEDURE Revers(VAR str: STRING);
VAR a, b: INTEGER; c: CHAR;
BEGIN
a := 0;
b := LENGTH(str) - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END
END Revers;
PROCEDURE 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)
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)
END
END MemErr;
PROCEDURE CreateList*(): LIST;
VAR nov: LIST;
BEGIN
NEW(nov);
MemErr(nov = NIL)
RETURN nov
END CreateList;
PROCEDURE CreateF*(FName: ARRAY OF CHAR): INTEGER;
RETURN H.CreateFile(FName)
END CreateF;
PROCEDURE OpenF*(FName: ARRAY OF CHAR(*; Mode: INTEGER*)): INTEGER;
RETURN H.OpenFile(FName)
END OpenF;
PROCEDURE Init;
VAR p: INTEGER;
PROCEDURE last(VAR p: INTEGER);
BEGIN
WHILE GetChar(p) # 0X DO INC(p) END;
DEC(p)
END last;
BEGIN
H.init;
IF OS = "WIN" THEN
ParamParse(0)
ELSIF OS = "KOS" THEN
ParamParse(1);
Params[0, 0] := H.GetName();
Params[0, 1] := Params[0, 0];
last(Params[0, 1])
ELSIF OS = "LNX" THEN
LinuxParam
END
END Init;
BEGIN
Init
END UTILS.

/programs/develop/oberon07/Source/X86.ob07
0,0 → 1,1986
(*
Copyright 2016 Anton Krotov
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE X86;
IMPORT UTILS, sys := SYSTEM, SCAN, ELF;
CONST
ADIM* = 5;
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54;
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;
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;
sysMOVE* = 108;
JMP* = 0E9X; CALL = 0E8X;
JE = 84X; JNE = 85X; JLE = 8EX; JGE = 8DX; JG = 8FX; JL = 8CX;
JCMD = 1; LCMD = 2; GCMD = 3; OCMD = 4; ECMD = 5;
PUSHEAX = 6; PUSHECX = 7; PUSHEDX = 8; POPEAX = 9; POPECX = 10; POPEDX = 11;
ICMP1 = 13; ICMP2 = 14;
defcall = 0; stdcall = 1; cdecl = 2; winapi = 3;
_rset* = 0; _inset* = 1; _saverec* = 2; _length* = 3; _checktype* = 4; _strcmp* = 5;
_lstrcmp* = 6; _rstrcmp* = 7; _savearr* = 8; _newrec* = 9; _disprec* = 10; _arrayidx* = 11;
_arrayrot* = 12; _assrt* = 13; _strcopy* = 14; _arrayidx1* = 15; _init* = 16; _close* = 17; _halt* = 18;
ASSRT = 19; hInstance = 20; SELFNAME = 21; RTABLE = 22;LoadLibrary = 23; GetProcAddress = 24;
Exports = 25; szSTART = 26; START = 27; szversion = 28; _floor = 29; HALT = 30;
FREGS = 8;
TYPE
ASMLINE* = POINTER TO RECORD (UTILS.rITEM)
cmd, clen, varadr, adr, tcmd, codeadr: INTEGER; short: BOOLEAN
END;
TFLT = ARRAY 2 OF INTEGER;
TIDX* = ARRAY ADIM OF INTEGER;
SECTIONNAME = ARRAY 8 OF CHAR;
SECTION = RECORD
name: SECTIONNAME;
size, adr, sizealign, OAPfile, reserved6, reserved7, reserved8, attrflags: 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
END;
COFFHEADER = RECORD
Machine: sys.CARD16;
NumberOfSections: sys.CARD16;
TimeDateStamp,
PointerToSymbolTable,
NumberOfSymbols: INTEGER;
SizeOfOptionalHeader,
Characteristics: sys.CARD16;
text, data, bss: SECTION
END;
KOSHEADER = RECORD
menuet01: ARRAY 8 OF CHAR;
ver, start, size, mem, sp, param, path: 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
END;
RELOC = RECORD
Page, Size: INTEGER;
reloc: ARRAY 1024 OF sys.CARD16
END;
VAR asmlist: UTILS.LIST; start: ASMLINE; dll, con, gui, kos, elf, obj: 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;
PROCEDURE AddRtlProc*(idx, proc: INTEGER);
BEGIN
RtlProc[idx] := proc
END AddRtlProc;
PROCEDURE IntToCard16(i: INTEGER): sys.CARD16;
VAR w: sys.CARD16;
BEGIN
sys.GET(sys.ADR(i), w)
RETURN w
END IntToCard16;
PROCEDURE CopyStr(VAR Dest: ARRAY OF CHAR; Source: ARRAY OF CHAR; VAR di: INTEGER; si: INTEGER);
BEGIN
DEC(di);
REPEAT
INC(di);
Dest[di] := Source[si];
INC(si)
UNTIL Dest[di] = 0X
END CopyStr;
PROCEDURE exch(VAR a, b: INTEGER);
VAR c: INTEGER;
BEGIN
c := a;
a := b;
b := c
END exch;
PROCEDURE Sort(VAR NamePtr, Adr: ARRAY OF INTEGER; Text: ARRAY OF CHAR; LB, RB: INTEGER);
VAR L, R: INTEGER;
PROCEDURE strle(s1, s2: INTEGER): BOOLEAN;
VAR S1, S2: ARRAY 256 OF CHAR; i: INTEGER;
BEGIN
i := 0;
CopyStr(S1, Text, i, s1);
i := 0;
CopyStr(S2, Text, i, s2)
RETURN S1 <= S2
END strle;
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])
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;
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;
PROCEDURE ProcExport*(Number: INTEGER; Name: SCAN.NODE; NameLabel: INTEGER);
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;
PROCEDURE Err(code: INTEGER);
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;
PROCEDURE Align*(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
PROCEDURE PutReloc(R: RELOC);
VAR i: 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;
PROCEDURE InitArray(VAR adr: INTEGER; chars: UTILS.STRING);
VAR i, x, 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)
END
END InitArray;
PROCEDURE WriteF(F, A, N: INTEGER);
BEGIN
IF UTILS.Write(F, A, N) # N THEN
Err(2)
END
END WriteF;
PROCEDURE Write(A, N: INTEGER);
BEGIN
sys.MOVE(A, OutFilePos, N);
OutFilePos := OutFilePos + N
END Write;
PROCEDURE Fill(n: INTEGER; c: CHAR);
VAR i: INTEGER;
BEGIN
FOR i := 1 TO n DO
Write(sys.ADR(c), 1)
END
END Fill;
PROCEDURE SetSection(VAR Section: SECTION; name: SECTIONNAME; size, adr, sizealign, OAPfile, attrflags: INTEGER);
BEGIN
Section.name := name;
Section.size := size;
Section.adr := adr;
Section.sizealign := sizealign;
Section.OAPfile := OAPfile;
Section.attrflags := attrflags;
END SetSection;
PROCEDURE WritePE(FName: ARRAY OF CHAR; stksize, codesize, datasize, rdatasize, gsize: INTEGER);
CONST textattr = 60000020H; rdataattr = 40000040H; dataattr = 0C0000040H; relocattr = 42000040H;
VAR i, F, adr, acodesize, compver, version, stkalloc, heapsize, heapalloc, filesize, filebuf: INTEGER;
cur: ASMLINE;
BEGIN
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");
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;
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);
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);
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;
BEGIN
NEW(nov);
UTILS.MemErr(nov = NIL);
nov.cmd := ccount;
UTILS.Insert(asmlist, nov, current);
current := current.Next(ASMLINE)
END New;
PROCEDURE Empty(varadr: INTEGER);
BEGIN
New;
current.clen := 0;
current.tcmd := ECMD;
current.varadr := varadr
END Empty;
PROCEDURE OutByte(byte: INTEGER);
BEGIN
New;
current.clen := 1;
Code[ccount] := CHR(byte);
INC(ccount)
END OutByte;
PROCEDURE OutInt(int: INTEGER);
BEGIN
New;
current.clen := 4;
sys.PUT(sys.ADR(Code[ccount]), int);
INC(ccount, 4)
END OutInt;
PROCEDURE PushEAX;
BEGIN
OutByte(50H);
current.tcmd := PUSHEAX
END PushEAX;
PROCEDURE PushECX;
BEGIN
OutByte(51H);
current.tcmd := PUSHECX
END PushECX;
PROCEDURE PushEDX;
BEGIN
OutByte(52H);
current.tcmd := PUSHEDX
END PushEDX;
PROCEDURE PopEAX;
BEGIN
OutByte(58H);
current.tcmd := POPEAX
END PopEAX;
PROCEDURE PopECX;
BEGIN
OutByte(59H);
current.tcmd := POPECX
END PopECX;
PROCEDURE PopEDX;
BEGIN
OutByte(5AH);
current.tcmd := POPEDX
END PopEDX;
PROCEDURE OutCode(cmd: UTILS.STRING);
VAR a, b: INTEGER;
BEGIN
New;
a := sys.ADR(Code[ccount]);
b := a;
InitArray(a, cmd);
ccount := a - b + ccount;
current.clen := a - b
END OutCode;
PROCEDURE Del*(last: ASMLINE);
BEGIN
last.Next := current.Next;
IF current = asmlist.Last THEN
asmlist.Last := last
END;
current := last
END Del;
PROCEDURE NewLabel*(): INTEGER;
BEGIN
INC(Lcount)
RETURN Lcount
END NewLabel;
PROCEDURE PushCall*(asmline: ASMLINE);
BEGIN
New;
callstk[topstk][0] := asmline;
callstk[topstk][1] := current;
INC(topstk)
END PushCall;
PROCEDURE Param*;
BEGIN
current := callstk[topstk - 1][0]
END Param;
PROCEDURE EndCall*;
BEGIN
current := callstk[topstk - 1][1];
DEC(topstk)
END EndCall;
PROCEDURE Init*(UI: INTEGER);
VAR nov: ASMLINE;
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;
PROCEDURE datastr(str: UTILS.STRING);
VAR i, n: INTEGER;
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;
PROCEDURE dataint(n: INTEGER);
BEGIN
sys.PUT(sys.ADR(Data[dcount]), n);
INC(dcount, 4)
END dataint;
PROCEDURE jmp*(jamp: CHAR; label: INTEGER);
VAR n: INTEGER;
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)
END jmp;
PROCEDURE jmplong(jamp: CHAR; label: INTEGER);
BEGIN
jmp(jamp, label);
current.short := FALSE
END jmplong;
PROCEDURE Label*(label: INTEGER);
BEGIN
New;
current.varadr := sys.ADR(Labels[label]);
current.tcmd := LCMD
END Label;
PROCEDURE CmdN(Number: 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;
PROCEDURE IntByte(bytecode, intcode: UTILS.STRING; n: INTEGER);
BEGIN
IF (n <= 127) & (n >= -128) THEN
OutCode(bytecode);
OutByte(n)
ELSE
OutCode(intcode);
OutInt(n)
END
END IntByte;
PROCEDURE DropFpu*(long: BOOLEAN);
BEGIN
IF long THEN
OutCode("83EC08DD1C24")
ELSE
OutCode("83EC04D91C24")
END;
DEC(fpu)
END DropFpu;
PROCEDURE AfterRet(func, float: BOOLEAN; callconv, parsize: INTEGER);
BEGIN
IF callconv = cdecl THEN
OutCode("81C4");
OutInt(parsize)
END;
IF func THEN
IF float THEN
OutCode("83EC08DD1C24")
ELSE
PushEAX
END
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)
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;
PROCEDURE FpuLoad(local: INTEGER; float: BOOLEAN);
VAR i: INTEGER;
BEGIN
FOR i := fpu TO 1 BY -1 DO
IntByte("DD45", "DD85", -local - i * 8)
END;
IF float THEN
Incfpu;
OutCode("DD042483C408")
END
END FpuLoad;
PROCEDURE Call*(proc: INTEGER; func, float: BOOLEAN; callconv, ccall, bases, level, parsize, local: INTEGER);
VAR i: INTEGER;
BEGIN
IF ccall # 0 THEN
FOR i := level TO level - bases + ORD(ccall = 1) + 1 BY -1 DO
IntByte("FF75", "FFB5", 4 * i + 4)
END;
IF ccall = 1 THEN
OutByte(55H)
END
END;
FpuSave(local);
jmplong(CALL, proc);
AfterRet(func, float, callconv, parsize);
FpuLoad(local, func & float)
END Call;
PROCEDURE CallRTL(Proc: 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;
PROCEDURE PushInt*(n: INTEGER);
BEGIN
OutByte(68H);
CmdN(n)
END PushInt;
PROCEDURE Prolog*(exename: UTILS.STRING);
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;
PROCEDURE AddRec*(base: INTEGER);
BEGIN
INC(reccount);
recarray[reccount] := base
END AddRec;
PROCEDURE CmpOpt(inv: BOOLEAN): INTEGER;
VAR cur: ASMLINE; c: INTEGER;
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;
PROCEDURE ifwh*(L: INTEGER);
VAR c: INTEGER;
BEGIN
IF current.Prev(ASMLINE).tcmd = ICMP2 THEN
c := CmpOpt(TRUE);
OutCode("5A583BC2");
jmp(CHR(c), L)
ELSE
PopECX;
OutCode("85C9");
jmp(JE, L)
END
END ifwh;
PROCEDURE PushConst*(Number: INTEGER);
BEGIN
IntByte("6A", "68", Number);
current.Prev(ASMLINE).varadr := Number
END PushConst;
PROCEDURE IfWhile*(L: INTEGER; orop: BOOLEAN);
VAR c, L1: INTEGER;
BEGIN
L1 := NewLabel();
IF current.Prev(ASMLINE).tcmd = ICMP2 THEN
c := CmpOpt(orop);
OutCode("5A583BC2");
jmp(CHR(c), L1);
PushConst(ORD(orop))
ELSE
PopECX;
OutCode("85C9");
IF orop THEN
jmp(JE, L1)
ELSE
jmp(JNE, L1)
END;
PushECX
END;
jmp(JMP, L);
Label(L1)
END IfWhile;
PROCEDURE newrec*;
BEGIN
CallRTL(_newrec)
END newrec;
PROCEDURE disprec*;
BEGIN
CallRTL(_disprec)
END disprec;
PROCEDURE String*(Number, Len: INTEGER; str: UTILS.STRING);
BEGIN
Labels[Number] := -dcount;
IF Len > 1 THEN
datastr(str)
ELSIF Len = 1 THEN
dataint(ORD(str[0]))
ELSE
dataint(0)
END
END String;
PROCEDURE InsertFpuInit;
VAR t: ASMLINE;
BEGIN
IF isfpu THEN
t := current;
current := fpucmd;
IF maxfpu > 0 THEN
OutCode("83EC");
OutByte(maxfpu * 8)
END;
OutCode("DBE3");
current := t
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)
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")
END
END;
fpucmd := current;
fpu := 0;
maxfpu := 0;
isfpu := FALSE
END ProcBeg;
PROCEDURE Leave*;
BEGIN
OutByte(0C9H);
InsertFpuInit
END Leave;
PROCEDURE ProcEnd*(Number, Param: INTEGER; func, float: BOOLEAN);
BEGIN
IF func & ~float THEN
PopEAX
END;
OutByte(0C9H);
IF Param = 0 THEN
OutByte(0C3H)
ELSE
OutByte(0C2H);
OutByte(Param MOD 256);
OutByte(ASR(Param, 8))
END;
InsertFpuInit
END ProcEnd;
PROCEDURE Module*(Name: UTILS.STRING; Number: INTEGER);
BEGIN
String(Number + 2, LENGTH(Name), Name);
jmplong(JMP, Number + 1)
END Module;
PROCEDURE Asm*(s: UTILS.STRING);
BEGIN
OutCode(s)
END Asm;
PROCEDURE GlobalAdr*(offset: INTEGER);
BEGIN
OutByte(0BAH);
OutInt(offset);
current.codeadr := sys.ADR(Code[ccount - 4]);
current.tcmd := GCMD;
PushEDX
END GlobalAdr;
PROCEDURE Mono*(Number: INTEGER);
BEGIN
PopEDX;
PushInt(Number)
END Mono;
PROCEDURE StrMono*;
BEGIN
PopEDX;
OutCode("6A02");
PushEDX
END StrMono;
PROCEDURE Not*;
BEGIN
PopECX;
OutCode("85C90F94C1");
PushECX
END Not;
PROCEDURE NegSet*;
BEGIN
OutCode("F71424")
END NegSet;
PROCEDURE Int*(Op: INTEGER);
BEGIN
PopEDX;
CASE Op OF
|lxPlus: OutCode("011424")
|lxMinus: OutCode("291424")
|lxMult: OutCode("58F7EA"); PushEAX
ELSE
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;
PROCEDURE Setfpu*(newfpu: INTEGER);
BEGIN
fpu := newfpu
END Setfpu;
PROCEDURE PushFlt*(x: LONGREAL);
VAR f: TFLT; L: INTEGER;
BEGIN
sys.PUT(sys.ADR(f), x);
Incfpu;
IF x = 0.0D0 THEN
OutCode("D9EE")
ELSIF x = 1.0D0 THEN
OutCode("D9E8")
ELSE
L := NewLabel();
Labels[L] := -dcount;
dataint(f[0]);
dataint(f[1]);
OutByte(0BAH);
CmdN(L);
OutCode("DD02")
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
ELSE
END;
OutByte(n);
DEC(fpu)
END farith;
PROCEDURE fcmp*(Op: INTEGER);
VAR n: INTEGER;
BEGIN
OutCode("33C9DED9DFE09E0F");
CASE Op OF
|lxEQ: n := 94H
|lxNE: n := 95H
|lxLT: n := 97H
|lxGT: n := 92H
|lxLE: n := 93H
|lxGE: n := 96H
ELSE
END;
DEC(fpu, 2);
OutByte(n);
OutByte(0C1H);
PushECX
END fcmp;
PROCEDURE fneg*;
BEGIN
OutCode("D9E0")
END fneg;
PROCEDURE OnError*(n: INTEGER);
BEGIN
OutByte(68H);
OutInt(LSL(UTILS.Line, 4) + n);
jmplong(JMP, UTILS.Unit + 3)
END OnError;
PROCEDURE idivmod*(opmod: BOOLEAN);
BEGIN
PopECX;
IF opmod THEN
OutCode("58E32E538BD833D9C1FB1F8BD0C1FA1F83F9FF750C3D0000008075055B6A00EB1AF7F985DB740685D2740203D15B52EB0A")
ELSE
OutCode("58E32C538BD833D9C1FB1F8BD0C1FA1F83F9FF750B3D0000008075045B50EB19F7F985DB740585D27401485B50EB0A")
END;
OnError(8)
END idivmod;
PROCEDURE rset*;
BEGIN
CallRTL(_rset);
PushEAX
END rset;
PROCEDURE inset*;
BEGIN
CallRTL(_inset);
PushEAX
END inset;
PROCEDURE Dup*;
BEGIN
PopEDX;
PushEDX;
PushEDX
END Dup;
PROCEDURE Inclusion*(Op: INTEGER);
BEGIN
PopEDX;
PopEAX;
IF Op = lxLE THEN
PushEDX
ELSE
PushEAX
END;
OutCode("0BC25933C8E3046A00EB026A01")
END Inclusion;
PROCEDURE NegInt*;
BEGIN
OutCode("F71C24")
END NegInt;
PROCEDURE CmpInt*(Op: INTEGER);
VAR n: INTEGER;
BEGIN
OutCode("33C95A583BC20F"); current.tcmd := ICMP1;
CASE Op OF
|lxEQ: n := 94H
|lxNE: n := 95H
|lxLT: n := 9CH
|lxGT: n := 9FH
|lxLE: n := 9EH
|lxGE: n := 9DH
ELSE
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;
PROCEDURE LocalAdr*(offset, bases: INTEGER);
BEGIN
IF bases = 0 THEN
Empty(offset);
OutCode("8BD5")
ELSE
IntByte("8B55", "8B95", 4 * bases + 4)
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)
END
END Field;
PROCEDURE DerefType*(n: INTEGER);
BEGIN
IntByte("8B5424", "8B9424", n);
OutCode("FF72FC")
END DerefType;
PROCEDURE Guard*(T: INTEGER; Check: BOOLEAN);
BEGIN
IF Check THEN
PopEAX;
OutCode("85C074");
IF T <= 127 THEN
OutByte(9)
ELSE
OutByte(12)
END;
PushEAX
END;
PushConst(T);
PushEAX;
CallRTL(_checktype);
IF Check THEN
PushEAX
ELSE
OutCode("85C0750A");
OnError(3)
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)
ELSE
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")
ELSE
OutCode("6A016A")
END;
OutByte(assrt);
jmplong(JMP, ASSRT)
END Assert;
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
|stLENGTH: CallRTL(_length); PushEAX
ELSE
END
END StFunc;
PROCEDURE Load*(T: INTEGER);
VAR lastcmd: ASMLINE; offset: INTEGER;
PROCEDURE del;
BEGIN
lastcmd.tcmd := 0;
offset := lastcmd.varadr;
lastcmd := lastcmd.Prev(ASMLINE);
WHILE lastcmd.tcmd # ECMD DO
lastcmd.clen := 0;
lastcmd.tcmd := 0;
lastcmd := lastcmd.Prev(ASMLINE)
END;
lastcmd.tcmd := 0
END del;
BEGIN
lastcmd := current;
CASE T OF
|TINTEGER, TSET, TPOINTER, TPROC:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("8B55", "8B95", offset);
PushEDX
ELSE
PopEDX;
OutCode("FF32")
END
|TCHAR, TBOOLEAN:
IF lastcmd.tcmd = ECMD THEN
del;
OutCode("33D28A");
IntByte("55", "95", offset);
PushEDX
ELSE
PopEDX;
OutCode("33C98A0A");
PushECX
END
|TLONGREAL:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("DD45", "DD85", offset)
ELSE
PopEDX;
OutCode("DD02")
END;
Incfpu
|TREAL:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("D945", "D985", offset)
ELSE
PopEDX;
OutCode("D902")
END;
Incfpu
|TCARD16:
IF lastcmd.tcmd = ECMD THEN
del;
OutCode("33D2668B");
IntByte("55", "95", offset);
PushEDX
ELSE
PopEDX;
OutCode("33C9668B0A");
PushECX
END
ELSE
END
END Load;
PROCEDURE Save*(T: INTEGER);
BEGIN
CASE T OF
|TINTEGER, TSET, TPOINTER, TPROC:
PopEDX;
OutCode("588910")
|TCHAR, TSTRING, TBOOLEAN:
PopEDX;
OutCode("588810")
|TCARD16:
PopEDX;
OutCode("58668910")
|TLONGREAL:
PopEDX;
OutCode("DD1A");
DEC(fpu)
|TREAL:
PopEDX;
OutCode("D91A");
DEC(fpu)
|TRECORD:
CallRTL(_saverec);
OutCode("85C0750A");
OnError(4)
|TARRAY:
CallRTL(_savearr)
ELSE
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])
END;
PushEDX
END OpenArray;
PROCEDURE OpenIdx*(n: INTEGER);
BEGIN
OutByte(54H);
IF n > 1 THEN
PushConst(n);
CallRTL(_arrayidx)
ELSE
CallRTL(_arrayidx1)
END;
PopEDX;
OutCode("85D2750A");
OnError(5);
PushEDX;
END OpenIdx;
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;
PROCEDURE Idx*;
BEGIN
PopEDX;
PopECX;
OutCode("03D1");
PushEDX
END Idx;
PROCEDURE DupLoadCheck*;
BEGIN
PopEDX;
OutCode("528B125285D2750A");
OnError(6)
END DupLoadCheck;
PROCEDURE DupLoad*;
BEGIN
PopEDX;
OutCode("528B12");
PushEDX;
END DupLoad;
PROCEDURE CheckNIL*;
BEGIN
PopEDX;
OutCode("85D2750A");
OnError(6);
PushEDX;
END CheckNIL;
PROCEDURE ExtArray*(A: TIDX; n, m: INTEGER);
VAR i: INTEGER;
BEGIN
FOR i := n - 1 TO 0 BY -1 DO
PushConst(A[i])
END;
OutByte(54H);
PushConst(n);
PushConst(m);
CallRTL(_arrayrot)
END ExtArray;
PROCEDURE ADR*(dim: INTEGER);
BEGIN
IF dim > 0 THEN
PopEDX;
OutCode("83C4");
OutByte(dim * 4);
PushEDX
END
END ADR;
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;
PROCEDURE For*(inc: BOOLEAN; VAR LBeg, LEnd: INTEGER);
BEGIN
LEnd := NewLabel();
LBeg := NewLabel();
Label(LBeg);
OutCode("8B14248B4424043910");
IF inc THEN
jmp(JG, LEnd)
ELSE
jmp(JL, LEnd)
END
END For;
PROCEDURE NextFor*(step, LBeg, LEnd: INTEGER);
BEGIN
OutCode("8B542404");
IF step = 1 THEN
OutCode("FF02")
ELSIF step = -1 THEN
OutCode("FF0A")
ELSE
IntByte("8302", "8102", step)
END;
jmp(JMP, LBeg);
Label(LEnd);
OutCode("83C408")
END NextFor;
PROCEDURE CaseLabel*(a, b, LBeg: INTEGER);
VAR L: INTEGER;
BEGIN
L := NewLabel();
IntByte("83FA", "81FA", a);
IF a = b THEN
jmp(JNE, L)
ELSE
jmp(JL, L);
IntByte("83FA", "81FA", b);
jmp(JG, L)
END;
jmp(JMP, LBeg);
Label(L)
END CaseLabel;
PROCEDURE Drop*;
BEGIN
PopEDX
END Drop;
PROCEDURE strcmp*(Op, LR: INTEGER);
BEGIN
CASE Op OF
|lxEQ: PushConst(0)
|lxNE: PushConst(1)
|lxLT: PushConst(2)
|lxGT: PushConst(3)
|lxLE: PushConst(4)
|lxGE: PushConst(5)
ELSE
END;
CASE LR OF
|-1: CallRTL(_lstrcmp)
| 0: CallRTL(_strcmp)
| 1: CallRTL(_rstrcmp)
ELSE
END;
PushEAX
END strcmp;
PROCEDURE Optimization;
VAR cur: ASMLINE; flag: BOOLEAN;
BEGIN
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
flag := FALSE;
CASE cur.tcmd OF
|PUSHEAX:
flag := cur.Next(ASMLINE).tcmd = POPEAX
|PUSHECX:
flag := cur.Next(ASMLINE).tcmd = POPECX
|PUSHEDX:
flag := cur.Next(ASMLINE).tcmd = POPEDX
ELSE
END;
IF flag THEN
cur.clen := 0;
cur.tcmd := 0;
cur := cur.Next(ASMLINE);
cur.clen := 0;
cur.tcmd := 0
END;
cur := cur.Next(ASMLINE)
END
END Optimization;
PROCEDURE WriteKOS(FName: ARRAY OF CHAR; stk, size, datasize, gsize: INTEGER; obj: BOOLEAN);
CONST strsize = 2048;
VAR Header: KOSHEADER; F, i, filesize, filebuf, a, sec, adr, size2: INTEGER; cur: ASMLINE;
Coff: COFFHEADER; sym: ARRAY 18 * 4 OF CHAR; FileName: UTILS.STRING;
BEGIN
F := UTILS.CreateF(FName);
IF F <= 0 THEN
Err(1)
END;
OutFilePos := UTILS.GetMem(Align(size, 4) + datasize + 1000H);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
IF ~obj THEN
Header.menuet01 := "MENUET01";
Header.ver := 1;
Header.start := sys.SIZE(KOSHEADER);
Header.size := Align(size, 4) + datasize;
Header.mem := Header.size + stk + gsize + strsize * 2 + 1000H;
Header.sp := Header.size + gsize + stk;
Header.param := Header.sp;
Header.path := Header.param + strsize;
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)
END;
Fill(Align(size, 4) - size, 0X);
Write(sys.ADR(Data), datasize);
WriteF(F, filebuf, OutFilePos - filebuf)
ELSE
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);
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;
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;
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;
size := Align(size2, 4);
rcount := 0;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
IF cur.tcmd IN {OCMD, GCMD} THEN
sys.GET(sys.ADR(Code[cur.cmd]), a);
IF a < size THEN
a := a - sys.SIZE(KOSHEADER);
sec := 1
ELSIF a < size + datasize THEN
a := a - size;
sec := 2
ELSE
a := a - size - datasize;
sec := 3
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);
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);
adr := sys.ADR(sym);
InitArray(adr, "4558504F52545300000000000100000002002E666C617400000000000000010000000300");
InitArray(adr, "2E64617461000000000000000200000003002E6273730000000000000000030000000300");
sys.PUT(sys.ADR(sym) + 8, Labels[Exports] - sys.SIZE(KOSHEADER));
WriteF(F, sys.ADR(sym), LEN(sym));
i := 4;
WriteF(F, sys.ADR(i), 4)
END;
UTILS.CloseF(F)
END WriteKOS;
PROCEDURE WriteELF(FName: ARRAY OF CHAR; code, data, glob: INTEGER);
VAR F, delta, filebuf: INTEGER; cur: ASMLINE; bytes: ARRAY 817H + 55FH + 4900 OF CHAR;
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;
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;
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;
BEGIN
sys.MOVE(ELF.get(), sys.ADR(bytes[0]), ELF.size);
DEC(code, 13);
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);
delta := Align(glob, 1000H) - 3200000H;
Add(00A8H); Add(17EDH); Add(1C09H); Add(1D25H);
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);
OutFilePos := UTILS.GetMem(code + data + 8000H);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
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);
F := UTILS.CreateF(FName);
IF F <= 0 THEN
Err(1)
END;
WriteF(F, filebuf, OutFilePos - filebuf);
UTILS.CloseF(F)
END WriteELF;
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;
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)
ELSIF elf THEN
LoadAdr := 134514420 + 1024;
INC(gsize, 1024)
END;
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;
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;
size := temp2;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
cur.adr := size;
IF cur.tcmd = LCMD THEN
sys.PUT(cur.varadr, size)
ELSIF (cur.tcmd = JCMD) & cur.short THEN
sys.GET(cur.varadr, i);
temp3 := i - cur.Next(ASMLINE).adr;
IF (-131 <= temp3) & (temp3 <= 123) THEN
sys.GET(cur(ASMLINE).codeadr - 1, c);
IF c = JMP THEN
sys.PUT(cur(ASMLINE).codeadr - 1, 0EBX)
ELSE (*JE, JNE, JLE, JGE, JG, JL*)
sys.PUT(cur(ASMLINE).codeadr - 2, ORD(c) - 16);
sys.PUT(cur(ASMLINE).codeadr - 1, temp3);
DEC(cur(ASMLINE).codeadr)
END;
cur.clen := 2
END
END;
size := size + cur.clen;
cur := cur.Next(ASMLINE)
END;
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;
FOR i := 0 TO Lcount DO
IF Labels[i] < 0 THEN
Labels[i] := -Labels[i] + asize + Align(rdatasize, 1000H)
END
END;
temp := dcount;
IF elf THEN
asize := asize + Align(dcount, 1000H) + 64 + 1024;
sys.PUT(sys.ADR(Code[glob + 1]), asize - 1024);
dcount := 0
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
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
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]]
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)
ELSE
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)
ELSE
IF R.Size # 0 THEN
PutReloc(R)
END;
R.Page := ASR(n, 12) * 1000H;
R.Size := 10;
R.reloc[0] := IntToCard16(n MOD 1000H + 3000H);
RCount := 1
END
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)
END
END FixLabels;
PROCEDURE OutStringZ(str: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN
New;
current.clen := LENGTH(str);
FOR i := 0 TO current.clen - 1 DO
Code[ccount] := str[i];
INC(ccount)
END;
Code[ccount] := 0X;
INC(ccount);
INC(current.clen)
END OutStringZ;
PROCEDURE Epilog*(gsize: INTEGER; FName: ARRAY OF CHAR; stk: INTEGER);
VAR i, glob: INTEGER;
BEGIN
glob := 0;
gsize := Align(gsize, 4) + 4;
COPY(FName, OutFile);
Labels[RTABLE] := -dcount;
dataint(recarray[0]);
FOR i := 1 TO reccount DO
dataint(recarray[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)
END;
GlobalAdr(0);
PushConst(ASR(gsize, 2));
PushInt(RTABLE);
PushInt(SELFNAME);
CallRTL(_init);
current := asmlist.Last(ASMLINE);
IF dll THEN
OutCode("B801000000C9C20C00")
END;
IF obj THEN
OutCode("B801000000C9C20000")
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)
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
END;
FixLabels(FName, stk, gsize, glob)
END Epilog;
END X86.