XenOn/kolibrios-fun
1
1
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Wiki Activity

Oberon07: upload new compiler

Browse Source 
git-svn-id: svn://kolibrios.org@7597 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
Anton Krotov 2019-03-11 08:59:55 +00:00
parent 169c7e0639
commit 82d72daa76
71 changed files with 23804 additions and 12469 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
programs/develop/oberon07/Compiler.kex
View File

Binary file not shown.

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

File diff suppressed because it is too large Load Diff

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

@ -1,872 +0,0 @@
Š®¬¯¨«ïâ®à ï§ëª  ¯à®£à ¬¬¨à®¢ ­¨ï Oberon-07/11 ¤«ï i386
Windows/Linux/KolibriOS.
------------------------------------------------------------------------------
‘®áâ ¢ ¯à®£à ¬¬ë
1. Compiler.kex (KolibriOS) - ¨á¯®«­ï¥¬ë© ä ©« ª®¬¯¨«ïâ®à .
‚室 - ⥪áâ®¢ë¥ ä ©«ë ¬®¤ã«¥© á à áè¨à¥­¨¥¬ ".ob07", ª®¤¨à®¢ª  ANSI
¨«¨ UTF-8 á BOM-ᨣ­ âãன.
‚ë室 - ¨á¯®«­ï¥¬ë© ä ©« ä®à¬ â  PE, ELF ¨«¨ MENUET01/MS COFF.
<09> à ¬¥âàë:
1) ¨¬ï £« ¢­®£® ¬®¤ã«ï
2) ⨯ ¯à¨«®¦¥­¨ï ¨ ¯« âä®à¬ 
"con" - Windows console
"gui" - Windows GUI
"dll" - Windows DLL
"elf" - Linux
"kos" - KolibriOS
"obj" - KolibriOS DLL
"kem" - KolibriOS á  ¤à¥á®¬ § £à㧪¨ 0x10000 ¤«ï ¢®§¬®¦­®£®
¨á¯®«­¥­¨ï ¢ í¬ã«ïâ®à¥
3) à §¬¥à áâíª  ¢ ¬¥£ ¡ ©â å, ­¥®¡ï§ â¥«ì­ë© ¯ à ¬¥âà, ¯® 㬮«ç ­¨î -
1 Œ¡, ¤«ï ELF ¨£­®à¨àã¥âáï. …᫨ 2-© ¯ à ¬¥âà = "obj" (KolibriOS DLL),
â® 3-© ¯ à ¬¥âà § ¤ ¥âáï è¥áâ­ ¤æ â¨à¨ç­ë¬ ç¨á«®¬
(0x00000001 .. 0xffffffff) ¨ ®¯à¥¤¥«ï¥â ¢¥àá¨î ¯à®£à ¬¬ë,
¯® 㬮«ç ­¨î - 0x00010000 (v1.0).
<09> ¯à¨¬¥à:
"C:\oberon-07\example.ob07" con 1
"C:\oberon-07\example.ob07" obj 0x00020005 (* v2.5 *)
‚ á«ãç ¥ ãᯥ譮© ª®¬¯¨«ï樨, ª®¬¯¨«ïâ®à ¯¥à¥¤ ¥â ª®¤ § ¢¥à襭¨ï 0,
¨­ ç¥ 1. <20>ਠࠡ®â¥ ª®¬¯¨«ïâ®à  ¢ KolibriOS, ª®¤ § ¢¥à襭¨ï ­¥
¯¥à¥¤ ¥âáï. ‘®®¡é¥­¨ï ª®¬¯¨«ïâ®à  ¢ë¢®¤ïâáï ­  ª®­á®«ì (Windows,
KolibriOS), ¢ â¥à¬¨­ « (Linux).
2. <09> ¯ª  Lib - ¡¨¡«¨®â¥ª  ¬®¤ã«¥©
------------------------------------------------------------------------------
Žâ«¨ç¨ï ®â ®à¨£¨­ « 
1. <09> áè¨à¥­ ¯á¥¢¤®¬®¤ã«ì SYSTEM
2. <09> §à¥è¥­ ᨬ¢®« "_" ¢ ¨¤¥­â¨ä¨ª â®à å
3. „®¡ ¢«¥­ë á¨á⥬­ë¥ ä« £¨
4. Ž¯¥à â®à CASE ॠ«¨§®¢ ­ ¢ ᮮ⢥âá⢨¨ á ᨭ⠪á¨á®¬ ¨ ᥬ ­â¨ª®©
¤ ­­®£® ®¯¥à â®à  ¢ ï§ëª¥ Oberon (Revision 1.10.90)
5. <09> áè¨à¥­ ­ ¡®à áâ ­¤ àâ­ëå ¯à®æ¥¤ãà
6. ‘¥¬ ­â¨ª  ®åà ­ë/¯à®¢¥àª¨ ⨯  ãâ®ç­¥­  ¤«ï ­ã«¥¢®£® 㪠§ â¥«ï
7. ‘¥¬ ­â¨ª  DIV ¨ MOD ãâ®ç­¥­  ¤«ï ®âà¨æ â¥«ì­ëå ç¨á¥«
8. „®¡ ¢«¥­ë ®¤­®áâà®ç­ë¥ ª®¬¬¥­â à¨¨ (­ ç¨­ îâáï á ¯ àë ᨬ¢®«®¢ "//")
9. <09> §à¥è¥­ íªá¯®àâ ¯¥à¥¬¥­­ëå ⨯®¢ ARRAY ¨ RECORD (⮫쪮 ¤«ï ç⥭¨ï)
10. <09> §à¥è¥­® ­ á«¥¤®¢ ­¨¥ ®â ⨯ -㪠§ â¥«ï
11. „®¡ ¢«¥­ë ¯á¥¢¤®­¨¬ë ⨯®¢ (TYPE A = B)
------------------------------------------------------------------------------
Žá®¡¥­­®á⨠ॠ«¨§ æ¨¨
1. Žá­®¢­ë¥ ⨯ë
’¨¯ „¨ ¯ §®­ §­ ç¥­¨© <20> §¬¥à, ¡ ©â
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. <09>à®æ¥¤ãà  NEW § ¯®«­ï¥â ­ã«ï¬¨ ¢ë¤¥«¥­­ë© ¡«®ª ¯ ¬ïâ¨
8. ƒ«®¡ «ì­ë¥ ¨ «®ª «ì­ë¥ ¯¥à¥¬¥­­ë¥ ¨­¨æ¨ «¨§¨àãîâáï ­ã«ï¬¨
9. ‚ ®â«¨ç¨¥ ®â ¬­®£¨å Oberon-ॠ«¨§ æ¨©, á¡®à騪 ¬ãá®à  ¨ ¤¨­ ¬¨ç¥áª ï
¬®¤ã«ì­®áâì ®âáãâáâ¢ãîâ
------------------------------------------------------------------------------
<09>ᥢ¤®¬®¤ã«ì SYSTEM
<20>ᥢ¤®¬®¤ã«ì 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 := <20> ¬ïâì[a]
PROCEDURE PUT(a: INTEGER; x: «î¡®© ®á­®¢­®© ⨯, PROCEDURE, POINTER)
<09> ¬ïâì[a] := x
PROCEDURE MOVE(Source, Dest, n: INTEGER)
Š®¯¨àã¥â n ¡ ©â ¯ ¬ï⨠¨§ Source ¢ Dest,
®¡« á⨠Source ¨ Dest ­¥ ¤®«¦­ë ¯¥à¥ªà뢠âìáï
PROCEDURE COPY(VAR Source: «î¡®© ⨯; VAR Dest: «î¡®© ⨯; n: INTEGER)
Š®¯¨àã¥â n ¡ ©â ¯ ¬ï⨠¨§ Source ¢ Dest.
<09>ª¢¨¢ «¥­â­®
SYSTEM.MOVE(SYSTEM.ADR(Source), SYSTEM.ADR(Dest), n)
PROCEDURE CODE(s: ARRAY OF CHAR)
‚áâ ¢ª  ¬ è¨­­®£® ª®¤ 
s - áâப®¢ ï ª®­áâ ­â  è¥áâ­ ¤æ â¨à¨ç­ëå æ¨äà
ª®«¨ç¥á⢮ æ¨äà ¤®«¦­® ¡ëâì ç¥â­ë¬
­ ¯à¨¬¥à: SYSTEM.CODE("B801000000") (* mov eax, 1 *)
’ ª¦¥ ¢ ¬®¤ã«¥ SYSTEM ®¯à¥¤¥«¥­ ⨯ CARD16 (2 ¡ ©â ). „«ï ⨯  CARD16 ­¥
¤®¯ã᪠îâáï ­¨ª ª¨¥ ï¢­ë¥ ®¯¥à æ¨¨, §  ¨áª«î祭¨¥¬ ¯à¨á¢ ¨¢ ­¨ï.
<EFBFBD>८¡à §®¢ ­¨ï 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 ­¥«ì§ï ¨á¯®«ì§®¢ âì ¢ ª®­áâ ­â­ëå ¢ëà ¦¥­¨ïå.
------------------------------------------------------------------------------
‘¨á⥬­ë¥ ä« £¨
<20>ਠ®¡ê¥­¨¨ ¯à®æ¥¤ãà­ëå ⨯®¢ ¨ £«®¡ «ì­ëå ¯à®æ¥¤ãà, ¯®á«¥ ª«î祢®£®
á«®¢  PROCEDURE ¬®¦¥â ¡ëâì 㪠§ ­ ä« £ ᮣ« è¥­¨ï ¢ë§®¢ : [stdcall], [cdecl]
¨«¨ [winapi]. <20> ¯à¨¬¥à:
PROCEDURE [cdecl] MyProc(x, y, z: INTEGER): INTEGER;
…᫨ 㪠§ ­ ä« £ [winapi], â® ¯à¨­¨¬ ¥âáï ᮣ« è¥­¨¥ stdcall ¨
¯à®æ¥¤ãàã-äã­ªæ¨î ¬®¦­® ¢ë§¢ âì ª ª ᮡá⢥­­® ¯à®æ¥¤ãàã, ¢­¥ ¢ëà ¦¥­¨ï.
”« £ [winapi] ¤®áâ㯥­ ⮫쪮 ¤«ï ¯« âä®à¬ë Windows.
<20>ਠ®¡ê¥­¨¨ ⨯®¢-§ ¯¨á¥©, ¯®á«¥ ª«î祢®£® á«®¢  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].
<20> ¯à¨¬¥à:
CASE x OF
|-1: DoSomething1
| 1: DoSomething2
| 0: DoSomething3
ELSE
DoSomething4
END
‚ ¬¥âª å ¢ à¨ ­â®¢ ¬®¦­® ¨á¯®«ì§®¢ âì ª®­áâ ­â­ë¥ ¢ëà ¦¥­¨ï, ¢¥âª  ELSE
­¥®¡ï§ â¥«ì­ . …᫨ ­¥ ¢ë¯®«­¥­ ­¨ ®¤¨­ ¢ à¨ ­â ¨ ELSE ®âáãâáâ¢ã¥â, â®
¯à®£à ¬¬  ¯à¥à뢠¥âáï á ®è¨¡ª®© ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï.
------------------------------------------------------------------------------
<09>஢¥àª  ¨ ®åà ­  ⨯  ­ã«¥¢®£® 㪠§ â¥«ï
Žà¨£¨­ «ì­®¥ á®®¡é¥­¨¥ ® ï§ëª¥ ­¥ ®¯à¥¤¥«ï¥â ¯®¢¥¤¥­¨¥ ¯à®£à ¬¬ë ¯à¨
¢ë¯®«­¥­¨¨ ®åà ­ë p(T) ¨ ¯à®¢¥àª¨ ⨯  p IS T ¯à¨ p = NIL. ‚® ¬­®£¨å
Oberon-ॠ«¨§ æ¨ïå ¢ë¯®«­¥­¨¥ â ª®© ®¯¥à æ¨¨ ¯à¨¢®¤¨â ª ®è¨¡ª¥ ¢à¥¬¥­¨
¢ë¯®«­¥­¨ï. ‚ ¤ ­­®© ॠ«¨§ æ¨¨ ®åà ­  ⨯  ­ã«¥¢®£® 㪠§ â¥«ï ­¥ ¯à¨¢®¤¨â ª
®è¨¡ª¥,   ¯à®¢¥àª  ⨯  ¤ ¥â १ã«ìâ â FALSE. ‚ à拉 á«ãç ¥¢ íâ® ¯®§¢®«ï¥â
§­ ç¨â¥«ì­® ᮪à â¨âì ç áâ®â㠯ਬ¥­¥­¨ï ®åà ­ë ⨯ .
------------------------------------------------------------------------------
„®¯®«­¨â¥«ì­ë¥ áâ ­¤ àâ­ë¥ ¯à®æ¥¤ãàë
DISPOSE(VAR v: «î¡®©_㪠§ â¥«ì)
Žá¢®¡®¦¤ ¥â ¯ ¬ïâì, ¢ë¤¥«¥­­ãî ¯à®æ¥¤ãன NEW ¤«ï
¤¨­ ¬¨ç¥áª®© ¯¥à¥¬¥­­®© v^, ¨ ¯à¨á¢ ¨¢ ¥â ¯¥à¥¬¥­­®© v
§­ ç¥­¨¥ NIL.
LSR(x, n: INTEGER): INTEGER
‹®£¨ç¥áª¨© ᤢ¨£ x ­  n ¡¨â ¢¯à ¢®.
MIN(a, b: INTEGER): INTEGER
Œ¨­¨¬ã¬ ¨§ ¤¢ãå §­ ç¥­¨©.
MAX(a, b: INTEGER): INTEGER
Œ ªá¨¬ã¬ ¨§ ¤¢ãå §­ ç¥­¨©.
BITS(x: INTEGER): SET
ˆ­â¥à¯à¥â¨àã¥â x ª ª §­ ç¥­¨¥ ⨯  SET.
‚믮«­ï¥âáï ­  íâ ¯¥ ª®¬¯¨«ï樨.
LENGTH(s: ARRAY OF CHAR): INTEGER
„«¨­  0X-§ ¢¥à襭­®© áâப¨ s, ¡¥§ ãç¥â  ᨬ¢®«  0X.
…᫨ ᨬ¢®« 0X ®âáãâáâ¢ã¥â, äã­ªæ¨ï ¢®§¢à é ¥â ¤«¨­ã
¬ áᨢ  s.
------------------------------------------------------------------------------
DIV ¨ MOD
x y x DIV y x MOD y
5 3 1 2
-5 3 -2 1
5 -3 -2 -1
-5 -3 1 -2
------------------------------------------------------------------------------
‘ªàëâë¥ ¯ à ¬¥âàë ¯à®æ¥¤ãà
<20>¥ª®â®àë¥ ¯à®æ¥¤ãàë ¬®£ãâ ¨¬¥âì áªàëâë¥ ¯ à ¬¥âàë, ®­¨ ®âáãâáâ¢ãîâ ¢ ᯨ᪥
ä®à¬ «ì­ëå ¯ à ¬¥â஢, ­® ãç¨â뢠îâáï ª®¬¯¨«ïâ®à®¬ ¯à¨ âà ­á«ï樨 ¢ë§®¢®¢.
<EFBFBD>â® ¢®§¬®¦­® ¢ á«¥¤ãîé¨å á«ãç ïå:
1. <09>à®æ¥¤ãà  ¨¬¥¥â ä®à¬ «ì­ë© ¯ à ¬¥âà ®âªàëâë© ¬ áᨢ:
PROCEDURE Proc(x: ARRAY OF ARRAY OF LONGREAL);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(SYSTEM.ADR(x), LEN(x), LEN(x[0])
2. <09>à®æ¥¤ãà  ¨¬¥¥â ä®à¬ «ì­ë© ¯ à ¬¥âà-¯¥à¥¬¥­­ãî ⨯  RECORD:
PROCEDURE Proc(VAR x: Rec);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(SYSTEM.TYPEID(Rec), SYSTEM.ADR(x))
3. <09>à®æ¥¤ãà  ï¢«ï¥âáï ¢«®¦¥­­®©, £«ã¡¨­  ¢«®¦¥­¨ï k,
¤«ï £«®¡ «ì­ëå ¯à®æ¥¤ãà k = 0:
PROCEDURE Proc(p1, ..., pn);
‚맮¢ â࠭᫨àã¥âáï â ª:
Proc(base(k - 1), base(k - 2), ..., base(0), p1, ..., pn),
£¤¥ base(m) -  ¤à¥á ¡ §ë ª ¤à  áâíª  ®å¢ â뢠î饩 ¯à®æ¥¤ãàë £«ã¡¨­ë
¢«®¦¥­¨ï m (¨á¯®«ì§ã¥âáï ¤«ï ¤®áâ㯠 ª «®ª «ì­ë¬ ¯¥à¥¬¥­­ë¬
®å¢ â뢠î饩 ¯à®æ¥¤ãàë)
------------------------------------------------------------------------------
Œ®¤ã«ì RTL
‚ᥠ¯à®£à ¬¬ë ­¥ï¢­® ¨á¯®«ì§ãîâ ¬®¤ã«ì RTL. Š®¬¯¨«ïâ®à â࠭᫨àã¥â
­¥ª®â®àë¥ ®¯¥à æ¨¨ (¯à®¢¥àª  ¨ ®åà ­  ⨯ , áà ¢­¥­¨¥ áâப, á®®¡é¥­¨ï ®¡
®è¨¡ª å ¢à¥¬¥­¨ ¢ë¯®«­¥­¨ï ¨ ¤à.) ª ª ¢ë§®¢ë ¯à®æ¥¤ãà í⮣® ¬®¤ã«ï. <20>¥
á«¥¤ã¥â ® ¢ë§ë¢ âì í⨠¯à®æ¥¤ãàë, §  ¨áª«î祭¨¥¬ ¯à®æ¥¤ãàë 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
<20> §à¥è ¥âáï íªá¯®àâ¨à®¢ âì ⮫쪮 ¯à®æ¥¤ãàë. „«ï í⮣®, ¯à®æ¥¤ãà  ¤®«¦­ 
­ å®¤¨âìáï ¢ £« ¢­®¬ ¬®¤ã«¥ ¯à®£à ¬¬ë, ¨ ¥¥ ¨¬ï ¤®«¦­® ¡ëâì ®â¬¥ç¥­® ᨬ¢®«®¬
íªá¯®àâ  ("*"). KolibriOS DLL ¢á¥£¤  íªá¯®àâ¨àãîâ ¨¤¥­â¨ä¨ª â®àë "version"
(¢¥àá¨ï ¯à®£à ¬¬ë) ¨ "lib_init" -  ¤à¥á ¯à®æ¥¤ãàë ¨­¨æ¨ «¨§ æ¨¨ DLL:
PROCEDURE [stdcall] lib_init(): INTEGER
<EFBFBD>â  ¯à®æ¥¤ãà  ¤®«¦­  ¡ëâì ¢ë§¢ ­  ¯¥à¥¤ ¨á¯®«ì§®¢ ­¨¥¬ DLL.
<EFBFBD>à®æ¥¤ãà  ¢á¥£¤  ¢®§¢à é ¥â 1.
‚ ­ áâ®ï饥 ¢à¥¬ï £¥­¥à æ¨ï DLL ¤«ï Linux ­¥ ॠ«¨§®¢ ­ .
==============================================================================
==============================================================================
<09>¨¡«¨®â¥ª  (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 (®è¨¡ª ). <20>ਠ­¥®¡å®¤¨¬®áâ¨, à á¯ ª®¢ë¢ ¥â
ä ©« (kunpack).
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN
‡ ¯¨á뢠¥â áâàãªâãàã ¡«®ª  ¤ ­­ëå ¢å®¤  ª â «®£  ¤«ï ä ©« 
¨«¨ ¯ ¯ª¨ á ¨¬¥­¥¬ FName ¢ ¯ à ¬¥âà Info.
<09>ਠ®è¨¡ª¥ ¢®§¢à é ¥â 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
<09>à®æ¥¤ãàë ¢®§¢à é îâ 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
<09>à®æ¥¤ãàë ¢®§¢à é îâ 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
<09>¥à¥à á¯à¥¤¥«ï¥â ¡«®ª ¯ ¬ïâ¨,
ptr -  ¤à¥á à ­¥¥ ¢ë¤¥«¥­­®£® ¡«®ª ,
size - ­®¢ë© à §¬¥à,
¢®§¢à é ¥â 㪠§ â¥«ì ­  ¯¥à¥à á¯à¥¤¥«¥­­ë© ¡«®ª,
0 ¯à¨ ®è¨¡ª¥
PROCEDURE GetCommandLine(): INTEGER
‚®§¢à é ¥â  ¤à¥á áâப¨ ¯ à ¬¥â஢
PROCEDURE GetName(): INTEGER
‚®§¢à é ¥â  ¤à¥á áâப¨ á ¨¬¥­¥¬ ¯à®£à ¬¬ë
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER
‡ £à㦠¥â DLL á ¯®«­ë¬ ¨¬¥­¥¬ name. ‚®§¢à é ¥â  ¤à¥á â ¡«¨æë
íªá¯®àâ . <20>ਠ®è¨¡ª¥ ¢®§¢à é ¥â 0.
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER
name - ¨¬ï ¯à®æ¥¤ãàë
lib -  ¤à¥á â ¡«¨æë íªá¯®àâ  DLL
‚®§¢à é ¥â  ¤à¥á ¯à®æ¥¤ãàë. <20>ਠ®è¨¡ª¥ ¢®§¢à é ¥â 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 㪠§ â¥«ì ­  èà¨äâ
<09>à¨á¢ ¨¢ ¥â ¯¥à¥¬¥­­®© Font §­ ç¥­¨¥ NIL
PROCEDURE TextHeight(Font: TFont): INTEGER
¯®«ãç¨âì ¢ëá®âã áâப¨ ⥪áâ 
Font 㪠§ â¥«ì ­  èà¨äâ
१-â: ¢ëá®â  áâப¨ ⥪áâ  ¢ ¯¨ªá¥«ïå
PROCEDURE TextWidth(Font: TFont;
str, length, params: INTEGER): INTEGER
¯®«ãç¨âì è¨à¨­ã áâப¨ ⥪áâ 
Font 㪠§ â¥«ì ­  èà¨äâ
str  ¤à¥á áâப¨ ⥪áâ  ¢ ª®¤¨à®¢ª¥ Win-1251
length ª®«¨ç¥á⢮ ᨬ¢®«®¢ ¢ áâப¥ ¨«¨ -1, ¥á«¨ áâப 
§ ¢¥àè ¥âáï ­ã«¥¬
params ¯ à ¬¥âàë-ä« £¨ á¬. ­¨¦¥
१-â: è¨à¨­  áâப¨ ⥪áâ  ¢ ¯¨ªá¥«ïå
PROCEDURE TextOut(Font: TFont;
canvas, x, y, str, length, color, params: INTEGER)
¢ë¢¥á⨠⥪áâ ¢ ¡ãä¥à
¤«ï ¢ë¢®¤  ¡ãä¥à  ¢ ®ª­®, ¨á¯®«ì§®¢ âì ä.65 ¨«¨
ä.7 (¥á«¨ ¡ãä¥à 24-¡¨â­ë©)
Font 㪠§ â¥«ì ­  èà¨äâ
canvas  ¤à¥á £à ä¨ç¥áª®£® ¡ãä¥à 
áâàãªâãà  ¡ãä¥à :
Xsize dd
Ysize dd
picture rb Xsize * Ysize * 4 (32 ¡¨â )
¨«¨ Xsize * Ysize * 3 (24 ¡¨â )
x, y ª®®à¤¨­ âë ⥪áâ  ®â­®á¨â¥«ì­® «¥¢®£® ¢¥àå­¥£®
㣫  ¡ãä¥à 
str  ¤à¥á áâப¨ ⥪áâ  ¢ ª®¤¨à®¢ª¥ Win-1251
length ª®«¨ç¥á⢮ ᨬ¢®«®¢ ¢ áâப¥ ¨«¨ -1, ¥á«¨ áâப 
§ ¢¥àè ¥âáï ­ã«¥¬
color 梥â ⥪áâ  0x00RRGGBB
params ¯ à ¬¥âàë-ä« £¨:
1 ¦¨à­ë©
2 ªãàᨢ
4 ¯®¤ç¥àª­ãâë©
8 ¯¥à¥ç¥àª­ãâë©
16 ¯à¨¬¥­¨âì ᣫ ¦¨¢ ­¨¥
32 ¢ë¢®¤ ¢ 32-¡¨â­ë© ¡ãä¥à
¢®§¬®¦­® ¨á¯®«ì§®¢ ­¨¥ ä« £®¢ ¢ «î¡ëå á®ç¥â ­¨ïå
------------------------------------------------------------------------------
MODULE RasterWorks - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ Rasterworks.obj
------------------------------------------------------------------------------
MODULE libimg - ®¡¥à⪠ ¡¨¡«¨®â¥ª¨ libimg.obj
------------------------------------------------------------------------------
MODULE NetDevices - ®¡¥à⪠ ¤«ï ä.74 (à ¡®â  á á¥â¥¢ë¬¨ ãáâனá⢠¬¨)
------------------------------------------------------------------------------

563
programs/develop/oberon07/Docs/KOSLib1251.txt Normal file
View File

@ -0,0 +1,563 @@
==============================================================================
Библиотека (KolibriOS)
------------------------------------------------------------------------------
MODULE Out - консольный вывод
PROCEDURE Open
формально открывает консольный вывод
PROCEDURE Int(x, width: INTEGER)
вывод целого числа x;
width - количество знакомест, используемых для вывода
PROCEDURE Real(x: REAL; width: INTEGER)
вывод вещественного числа x в плавающем формате;
width - количество знакомест, используемых для вывода
PROCEDURE Char(x: CHAR)
вывод символа x
PROCEDURE FixReal(x: REAL; width, p: INTEGER)
вывод вещественного числа x в фиксированном формате;
width - количество знакомест, используемых для вывода;
p - количество знаков после десятичной точки
PROCEDURE Ln
переход на следующую строку
PROCEDURE String(s: ARRAY OF CHAR)
вывод строки s
------------------------------------------------------------------------------
MODULE In - консольный ввод
VAR Done: BOOLEAN
принимает значение TRUE в случае успешного выполнения
операции ввода, иначе FALSE
PROCEDURE Open
формально открывает консольный ввод,
также присваивает переменной Done значение TRUE
PROCEDURE Int(VAR x: INTEGER)
ввод числа типа INTEGER
PROCEDURE Char(VAR x: CHAR)
ввод символа
PROCEDURE Real(VAR x: REAL)
ввод числа типа REAL
PROCEDURE String(VAR s: ARRAY OF CHAR)
ввод строки
PROCEDURE Ln
ожидание нажатия ENTER
------------------------------------------------------------------------------
MODULE Console - дополнительные процедуры консольного вывода
CONST
Следующие константы определяют цвет консольного вывода
Black = 0 Blue = 1 Green = 2
Cyan = 3 Red = 4 Magenta = 5
Brown = 6 LightGray = 7 DarkGray = 8
LightBlue = 9 LightGreen = 10 LightCyan = 11
LightRed = 12 LightMagenta = 13 Yellow = 14
White = 15
PROCEDURE Cls
очистка окна консоли
PROCEDURE SetColor(FColor, BColor: INTEGER)
установка цвета консольного вывода: FColor - цвет текста,
BColor - цвет фона, возможные значения - вышеперечисленные
константы
PROCEDURE SetCursor(x, y: INTEGER)
установка курсора консоли в позицию (x, y)
PROCEDURE GetCursor(VAR x, y: INTEGER)
записывает в параметры текущие координаты курсора консоли
PROCEDURE GetCursorX(): INTEGER
возвращает текущую x-координату курсора консоли
PROCEDURE GetCursorY(): INTEGER
возвращает текущую y-координату курсора консоли
------------------------------------------------------------------------------
MODULE ConsoleLib - обертка библиотеки console.obj
------------------------------------------------------------------------------
MODULE Math - математические функции
CONST
pi = 3.141592653589793D+00
e = 2.718281828459045D+00
PROCEDURE IsNan(x: REAL): BOOLEAN
возвращает TRUE, если x - не число
PROCEDURE IsInf(x: REAL): BOOLEAN
возвращает TRUE, если x - бесконечность
PROCEDURE sqrt(x: REAL): REAL
квадратный корень x
PROCEDURE exp(x: REAL): REAL
экспонента x
PROCEDURE ln(x: REAL): REAL
натуральный логарифм x
PROCEDURE sin(x: REAL): REAL
синус x
PROCEDURE cos(x: REAL): REAL
косинус x
PROCEDURE tan(x: REAL): REAL
тангенс x
PROCEDURE arcsin(x: REAL): REAL
арксинус x
PROCEDURE arccos(x: REAL): REAL
арккосинус x
PROCEDURE arctan(x: REAL): REAL
арктангенс x
PROCEDURE arctan2(y, x: REAL): REAL
арктангенс y/x
PROCEDURE power(base, exponent: REAL): REAL
возведение числа base в степень exponent
PROCEDURE log(base, x: REAL): REAL
логарифм x по основанию base
PROCEDURE sinh(x: REAL): REAL
гиперболический синус x
PROCEDURE cosh(x: REAL): REAL
гиперболический косинус x
PROCEDURE tanh(x: REAL): REAL
гиперболический тангенс x
PROCEDURE arcsinh(x: REAL): REAL
обратный гиперболический синус x
PROCEDURE arccosh(x: REAL): REAL
обратный гиперболический косинус x
PROCEDURE arctanh(x: REAL): REAL
обратный гиперболический тангенс x
PROCEDURE round(x: REAL): REAL
округление x до ближайшего целого
PROCEDURE frac(x: REAL): REAL;
дробная часть числа x
PROCEDURE floor(x: REAL): REAL
наибольшее целое число (представление как REAL),
не больше x: floor(1.2) = 1.0
PROCEDURE ceil(x: REAL): REAL
наименьшее целое число (представление как REAL),
не меньше x: ceil(1.2) = 2.0
PROCEDURE sgn(x: REAL): INTEGER
если x > 0 возвращает 1
если x < 0 возвращает -1
если x = 0 возвращает 0
------------------------------------------------------------------------------
MODULE Debug - вывод на доску отладки
Интерфейс как модуль Out
PROCEDURE Open
открывает доску отладки
------------------------------------------------------------------------------
MODULE File - работа с файловой системой
TYPE
FNAME = ARRAY 520 OF CHAR
FS = POINTER TO rFS
rFS = RECORD (* информационная структура файла *)
subfunc, pos, hpos, bytes, buffer: INTEGER;
name: FNAME
END
FD = POINTER TO rFD
rFD = RECORD (* структура блока данных входа каталога *)
attr: INTEGER;
ntyp: CHAR;
reserved: ARRAY 3 OF CHAR;
time_create, date_create,
time_access, date_access,
time_modif, date_modif,
size, hsize: INTEGER;
name: FNAME
END
CONST
SEEK_BEG = 0
SEEK_CUR = 1
SEEK_END = 2
PROCEDURE Load(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
Загружает в память файл с именем FName, записывает в параметр
size размер файла, возвращает адрес загруженного файла
или 0 (ошибка). При необходимости, распаковывает
файл (kunpack).
PROCEDURE GetFileInfo(FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN
Записывает структуру блока данных входа каталога для файла
или папки с именем FName в параметр Info.
При ошибке возвращает FALSE.
PROCEDURE Exists(FName: ARRAY OF CHAR): BOOLEAN
возвращает TRUE, если файл с именем FName существует
PROCEDURE Close(VAR F: FS)
освобождает память, выделенную для информационной структуры
файла F и присваивает F значение NIL
PROCEDURE Open(FName: ARRAY OF CHAR): FS
возвращает указатель на информационную структуру файла с
именем FName, при ошибке возвращает NIL
PROCEDURE Delete(FName: ARRAY OF CHAR): BOOLEAN
удаляет файл с именем FName, при ошибке возвращает FALSE
PROCEDURE Seek(F: FS; Offset, Origin: INTEGER): INTEGER
устанавливает позицию чтения-записи файла F на Offset,
относительно Origin = (SEEK_BEG - начало файла,
SEEK_CUR - текущая позиция, SEEK_END - конец файла),
возвращает позицию относительно начала файла, например:
Seek(F, 0, SEEK_END)
устанавливает позицию на конец файла и возвращает длину
файла; при ошибке возвращает -1
PROCEDURE Read(F: FS; Buffer, Count: INTEGER): INTEGER
Читает данные из файла в память. F - указатель на
информационную структуру файла, Buffer - адрес области
памяти, Count - количество байт, которое требуется прочитать
из файла; возвращает количество байт, которое было прочитано
и соответствующим образом изменяет позицию чтения/записи в
информационной структуре F.
PROCEDURE Write(F: FS; Buffer, Count: INTEGER): INTEGER
Записывает данные из памяти в файл. F - указатель на
информационную структуру файла, Buffer - адрес области
памяти, Count - количество байт, которое требуется записать
в файл; возвращает количество байт, которое было записано и
соответствующим образом изменяет позицию чтения/записи в
информационной структуре F.
PROCEDURE Create(FName: ARRAY OF CHAR): FS
создает новый файл с именем FName (полное имя), возвращает
указатель на информационную структуру файла,
при ошибке возвращает NIL
PROCEDURE CreateDir(DirName: ARRAY OF CHAR): BOOLEAN
создает папку с именем DirName, все промежуточные папки
должны существовать, при ошибке возвращает FALSE
PROCEDURE DeleteDir(DirName: ARRAY OF CHAR): BOOLEAN
удаляет пустую папку с именем DirName,
при ошибке возвращает FALSE
PROCEDURE DirExists(DirName: ARRAY OF CHAR): BOOLEAN
возвращает TRUE, если папка с именем DirName существует
------------------------------------------------------------------------------
MODULE Read - чтение основных типов данных из файла F
Процедуры возвращают TRUE в случае успешной операции чтения и
соответствующим образом изменяют позицию чтения/записи в
информационной структуре F
PROCEDURE Char(F: File.FS; VAR x: CHAR): BOOLEAN
PROCEDURE Int(F: File.FS; VAR x: INTEGER): BOOLEAN
PROCEDURE Real(F: File.FS; VAR x: REAL): BOOLEAN
PROCEDURE Boolean(F: File.FS; VAR x: BOOLEAN): BOOLEAN
PROCEDURE Set(F: File.FS; VAR x: SET): BOOLEAN
PROCEDURE Card16(F: File.FS; VAR x: SYSTEM.CARD16): BOOLEAN
------------------------------------------------------------------------------
MODULE Write - запись основных типов данных в файл F
Процедуры возвращают TRUE в случае успешной операции записи и
соответствующим образом изменяют позицию чтения/записи в
информационной структуре F
PROCEDURE Char(F: File.FS; x: CHAR): BOOLEAN
PROCEDURE Int(F: File.FS; x: INTEGER): BOOLEAN
PROCEDURE Real(F: File.FS; x: REAL): BOOLEAN
PROCEDURE Boolean(F: File.FS; x: BOOLEAN): BOOLEAN
PROCEDURE Set(F: File.FS; x: SET): BOOLEAN
PROCEDURE Card16(F: File.FS; x: SYSTEM.CARD16): BOOLEAN
------------------------------------------------------------------------------
MODULE DateTime - дата, время
CONST ERR = -7.0E5
PROCEDURE Now(VAR Year, Month, Day, Hour, Min, Sec: INTEGER)
записывает в параметры компоненты текущей системной даты и
времени
PROCEDURE Encode(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL
возвращает дату, полученную из компонентов
Year, Month, Day, Hour, Min, Sec;
при ошибке возвращает константу ERR = -7.0D5
PROCEDURE Decode(Date: REAL; VAR Year, Month, Day,
Hour, Min, Sec: INTEGER): BOOLEAN
извлекает компоненты
Year, Month, Day, Hour, Min, Sec из даты Date;
при ошибке возвращает FALSE
------------------------------------------------------------------------------
MODULE Args - параметры программы
VAR argc: INTEGER
количество параметров программы, включая имя
исполняемого файла
PROCEDURE GetArg(n: INTEGER; VAR s: ARRAY OF CHAR)
записывает в строку s n-й параметр программы,
нумерация параметров от 0 до argc - 1,
нулевой параметр -- имя исполняемого файла
------------------------------------------------------------------------------
MODULE KOSAPI
PROCEDURE sysfunc1(arg1: INTEGER): INTEGER
PROCEDURE sysfunc2(arg1, arg2: INTEGER): INTEGER
...
PROCEDURE sysfunc7(arg1, arg2, ..., arg7: INTEGER): INTEGER
Обертки для функций API ядра KolibriOS.
arg1 .. arg7 соответствуют регистрам
eax, ebx, ecx, edx, esi, edi, ebp;
возвращают значение регистра eax после системного вызова.
PROCEDURE sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER
Обертка для функций API ядра KolibriOS.
arg1 - регистр eax, arg2 - регистр ebx,
res2 - значение регистра ebx после системного вызова;
возвращает значение регистра eax после системного вызова.
PROCEDURE malloc(size: INTEGER): INTEGER
Выделяет блок памяти.
size - размер блока в байтах,
возвращает адрес выделенного блока
PROCEDURE free(ptr: INTEGER): INTEGER
Освобождает ранее выделенный блок памяти с адресом ptr,
возвращает 0
PROCEDURE realloc(ptr, size: INTEGER): INTEGER
Перераспределяет блок памяти,
ptr - адрес ранее выделенного блока,
size - новый размер,
возвращает указатель на перераспределенный блок,
0 при ошибке
PROCEDURE GetCommandLine(): INTEGER
Возвращает адрес строки параметров
PROCEDURE GetName(): INTEGER
Возвращает адрес строки с именем программы
PROCEDURE LoadLib(name: ARRAY OF CHAR): INTEGER
Загружает DLL с полным именем name. Возвращает адрес таблицы
экспорта. При ошибке возвращает 0.
PROCEDURE GetProcAdr(name: ARRAY OF CHAR; lib: INTEGER): INTEGER
name - имя процедуры
lib - адрес таблицы экспорта DLL
Возвращает адрес процедуры. При ошибке возвращает 0.
------------------------------------------------------------------------------
MODULE ColorDlg - работа с диалогом "Color Dialog"
TYPE
Dialog = POINTER TO RECORD (* структура диалога *)
status: INTEGER (* состояние диалога:
0 - пользователь нажал Cancel
1 - пользователь нажал OK
2 - диалог открыт *)
color: INTEGER (* выбранный цвет *)
END
PROCEDURE Create(draw_window: DRAW_WINDOW): Dialog
создать диалог
draw_window - процедура перерисовки основного окна
(TYPE DRAW_WINDOW = PROCEDURE);
процедура возвращает указатель на структуру диалога
PROCEDURE Show(cd: Dialog)
показать диалог
cd - указатель на структуру диалога, который был создан ранее
процедурой Create
PROCEDURE Destroy(VAR cd: Dialog)
уничтожить диалог
cd - указатель на структуру диалога
------------------------------------------------------------------------------
MODULE OpenDlg - работа с диалогом "Open Dialog"
TYPE
Dialog = POINTER TO RECORD (* структура диалога *)
status: INTEGER (* состояние диалога:
0 - пользователь нажал Cancel
1 - пользователь нажал OK
2 - диалог открыт *)
FileName: ARRAY 4096 OF CHAR (* имя выбранного файла *)
FilePath: ARRAY 4096 OF CHAR (* полное имя выбранного
файла *)
END
PROCEDURE Create(draw_window: DRAW_WINDOW; type: INTEGER; def_path,
filter: ARRAY OF CHAR): Dialog
создать диалог
draw_window - процедура перерисовки основного окна
(TYPE DRAW_WINDOW = PROCEDURE)
type - тип диалога
0 - открыть
1 - сохранить
2 - выбрать папку
def_path - путь по умолчанию, папка def_path будет открыта
при первом запуске диалога
filter - в строке записано перечисление расширений файлов,
которые будут показаны в диалоговом окне, расширения
разделяются символом "|", например: "ASM|TXT|INI"
процедура возвращает указатель на структуру диалога
PROCEDURE Show(od: Dialog; Width, Height: INTEGER)
показать диалог
od - указатель на структуру диалога, который был создан ранее
процедурой Create
Width и Height - ширина и высота диалогового окна
PROCEDURE Destroy(VAR od: Dialog)
уничтожить диалог
od - указатель на структуру диалога
------------------------------------------------------------------------------
MODULE kfonts - работа с kf-шрифтами
CONST
bold = 1
italic = 2
underline = 4
strike_through = 8
smoothing = 16
bpp32 = 32
TYPE
TFont = POINTER TO TFont_desc (* указатель на шрифт *)
PROCEDURE LoadFont(file_name: ARRAY OF CHAR): TFont
загрузить шрифт из файла
file_name имя kf-файла
рез-т: указатель на шрифт/NIL (ошибка)
PROCEDURE SetSize(Font: TFont; font_size: INTEGER): BOOLEAN
установить размер шрифта
Font указатель на шрифт
font_size размер шрифта
рез-т: TRUE/FALSE (ошибка)
PROCEDURE Enabled(Font: TFont; font_size: INTEGER): BOOLEAN
проверить, есть ли шрифт, заданного размера
Font указатель на шрифт
font_size размер шрифта
рез-т: TRUE/FALSE (шрифта нет)
PROCEDURE Destroy(VAR Font: TFont)
выгрузить шрифт, освободить динамическую память
Font указатель на шрифт
Присваивает переменной Font значение NIL
PROCEDURE TextHeight(Font: TFont): INTEGER
получить высоту строки текста
Font указатель на шрифт
рез-т: высота строки текста в пикселях
PROCEDURE TextWidth(Font: TFont;
str, length, params: INTEGER): INTEGER
получить ширину строки текста
Font указатель на шрифт
str адрес строки текста в кодировке Win-1251
length количество символов в строке или -1, если строка
завершается нулем
params параметры-флаги см. ниже
рез-т: ширина строки текста в пикселях
PROCEDURE TextOut(Font: TFont;
canvas, x, y, str, length, color, params: INTEGER)
вывести текст в буфер
для вывода буфера в окно, использовать ф.65 или
ф.7 (если буфер 24-битный)
Font указатель на шрифт
canvas адрес графического буфера
структура буфера:
Xsize dd
Ysize dd
picture rb Xsize * Ysize * 4 (32 бита)
или Xsize * Ysize * 3 (24 бита)
x, y координаты текста относительно левого верхнего
угла буфера
str адрес строки текста в кодировке Win-1251
length количество символов в строке или -1, если строка
завершается нулем
color цвет текста 0x00RRGGBB
params параметры-флаги:
1 жирный
2 курсив
4 подчеркнутый
8 перечеркнутый
16 применить сглаживание
32 вывод в 32-битный буфер
возможно использование флагов в любых сочетаниях
------------------------------------------------------------------------------
MODULE RasterWorks - обертка библиотеки Rasterworks.obj
------------------------------------------------------------------------------
MODULE libimg - обертка библиотеки libimg.obj
------------------------------------------------------------------------------

BIN
programs/develop/oberon07/Docs/Oberon07.Report_2016_05_03.pdf Normal file
View File

Binary file not shown.

693
programs/develop/oberon07/Docs/Oberon07.report.fb2
View File

@ -1,693 +0,0 @@
<?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>

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

@ -1,23 +1,13 @@
(*
Copyright 2016, 2017, 2018 Anton Krotov
(*
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT sys := SYSTEM;
IMPORT SYSTEM, K := KOSAPI;
CONST
@ -41,10 +31,23 @@ VAR
CriticalSection: CRITICAL_SECTION;
import*, multi: BOOLEAN;
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER);
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
PROCEDURE [stdcall] zeromem* (dwords: INTEGER; adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
SYSTEM.CODE(
0FCH, (* cld *)
031H, 0C0H, (* xor eax, eax *)
057H, (* push edi *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *)
0F3H, 0ABH, (* rep stosd *)
05FH (* pop edi *)
)
END zeromem;
@ -53,128 +56,31 @@ VAR
tmp: INTEGER;
BEGIN
FOR tmp := adr TO adr + size - 1 BY 4096 DO
sys.PUT(tmp, 0)
SYSTEM.PUT(tmp, 0)
END
END mem_commit;
PROCEDURE strncmp* (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
Res: INTEGER;
BEGIN
Res := 0;
WHILE n > 0 DO
sys.GET(a, A); INC(a);
sys.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
Res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN Res
END strncmp;
PROCEDURE [stdcall] sysfunc1* (arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall] sysfunc2* (arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall] sysfunc3* (arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall] sysfunc4* (arg1, arg2, arg3, arg4: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21000"); (* ret 10h *)
RETURN 0
END sysfunc4;
PROCEDURE [stdcall] sysfunc5* (arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
RETURN 0
END sysfunc5;
PROCEDURE switch_task;
VAR
res: INTEGER;
BEGIN
res := sysfunc2(68, 1)
K.sysfunc2(68, 1)
END switch_task;
PROCEDURE futex_create (ptr: INTEGER): INTEGER;
RETURN sysfunc3(77, 0, ptr)
RETURN K.sysfunc3(77, 0, ptr)
END futex_create;
PROCEDURE futex_wait (futex, value, timeout: INTEGER);
VAR
res: INTEGER;
BEGIN
res := sysfunc5(77, 2, futex, value, timeout)
K.sysfunc5(77, 2, futex, value, timeout)
END futex_wait;
PROCEDURE futex_wake (futex, number: INTEGER);
VAR
res: INTEGER;
BEGIN
res := sysfunc4(77, 3, futex, number)
K.sysfunc4(77, 3, futex, number)
END futex_wake;
@ -195,7 +101,7 @@ END LeaveCriticalSection;
PROCEDURE InitializeCriticalSection* (VAR CriticalSection: CRITICAL_SECTION);
BEGIN
CriticalSection[0] := futex_create(sys.ADR(CriticalSection[1]));
CriticalSection[0] := futex_create(SYSTEM.ADR(CriticalSection[1]));
CriticalSection[1] := 0
END InitializeCriticalSection;
@ -208,14 +114,14 @@ BEGIN
idx := ASR(size, 5);
res := pockets[idx];
IF res # 0 THEN
sys.GET(res, pockets[idx]);
sys.PUT(res, size);
SYSTEM.GET(res, pockets[idx]);
SYSTEM.PUT(res, size);
INC(res, 4)
ELSE
temp := 0;
IF heap + size >= endheap THEN
IF sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
temp := sysfunc3(68, 12, HEAP_SIZE)
IF K.sysfunc2(18, 16) > ASR(HEAP_SIZE, 10) THEN
temp := K.sysfunc3(68, 12, HEAP_SIZE)
ELSE
temp := 0
END;
@ -228,7 +134,7 @@ BEGIN
END
END;
IF (heap # 0) & (temp # -1) THEN
sys.PUT(heap, size);
SYSTEM.PUT(heap, size);
res := heap + 4;
heap := heap + size
ELSE
@ -236,11 +142,11 @@ BEGIN
END
END
ELSE
IF sysfunc2(18, 16) > ASR(size, 10) THEN
res := sysfunc3(68, 12, size);
IF K.sysfunc2(18, 16) > ASR(size, 10) THEN
res := K.sysfunc3(68, 12, size);
IF res # 0 THEN
mem_commit(res, size);
sys.PUT(res, size);
SYSTEM.PUT(res, size);
INC(res, 4)
END
ELSE
@ -259,13 +165,13 @@ VAR
size, idx: INTEGER;
BEGIN
DEC(ptr, 4);
sys.GET(ptr, size);
SYSTEM.GET(ptr, size);
IF size <= MAX_SIZE THEN
idx := ASR(size, 5);
sys.PUT(ptr, pockets[idx]);
SYSTEM.PUT(ptr, pockets[idx]);
pockets[idx] := ptr
ELSE
size := sysfunc3(68, 13, ptr)
size := K.sysfunc3(68, 13, ptr)
END
RETURN 0
END __DISPOSE;
@ -274,8 +180,11 @@ END __DISPOSE;
PROCEDURE NEW_DISPOSE (func, arg: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
EnterCriticalSection(CriticalSection);
IF multi THEN
EnterCriticalSection(CriticalSection)
END;
IF func = _new THEN
res := __NEW(arg)
@ -283,7 +192,10 @@ BEGIN
res := __DISPOSE(arg)
END;
LeaveCriticalSection(CriticalSection)
IF multi THEN
LeaveCriticalSection(CriticalSection)
END
RETURN res
END NEW_DISPOSE;
@ -298,63 +210,110 @@ PROCEDURE _DISPOSE* (ptr: INTEGER): INTEGER;
END _DISPOSE;
PROCEDURE ExitProcess* (p1: INTEGER);
PROCEDURE exit* (p1: INTEGER);
BEGIN
p1 := sysfunc1(-1)
END ExitProcess;
K.sysfunc1(-1)
END exit;
PROCEDURE ExitThread* (p1: INTEGER);
PROCEDURE exit_thread* (p1: INTEGER);
BEGIN
p1 := sysfunc1(-1)
END ExitThread;
K.sysfunc1(-1)
END exit_thread;
PROCEDURE OutChar (c: CHAR);
VAR
res: INTEGER;
BEGIN
res := sysfunc3(63, 1, ORD(c))
K.sysfunc3(63, 1, ORD(c))
END OutChar;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
PROCEDURE OutLn;
BEGIN
OutChar(0DX);
OutChar(0AX)
END OutLn;
PROCEDURE OutStr (pchar: INTEGER);
VAR
c: CHAR;
BEGIN
IF lpCaption # 0 THEN
OutChar(0DX);
OutChar(0AX);
IF pchar # 0 THEN
REPEAT
sys.GET(lpCaption, c);
SYSTEM.GET(pchar, c);
IF c # 0X THEN
OutChar(c)
END;
INC(lpCaption)
UNTIL c = 0X;
OutChar(":");
OutChar(0DX);
OutChar(0AX)
END;
REPEAT
sys.GET(lpText, c);
IF c # 0X THEN
OutChar(c)
END;
INC(lpText)
UNTIL c = 0X;
INC(pchar)
UNTIL c = 0X
END
END OutStr;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
IF lpCaption # 0 THEN
OutChar(0DX);
OutChar(0AX)
OutLn;
OutStr(lpCaption);
OutChar(":");
OutLn
END;
OutStr(lpText);
IF lpCaption # 0 THEN
OutLn
END
END DebugMsg;
PROCEDURE init* (p1: INTEGER);
PROCEDURE OutString (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
p1 := sysfunc2(68, 11);
InitializeCriticalSection(CriticalSection)
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
OutChar(s[i]);
INC(i)
END
END OutString;
PROCEDURE imp_error;
BEGIN
OutString("import error: ");
IF K.imp_error.error = 1 THEN
OutString("can't load "); OutString(K.imp_error.lib)
ELSIF K.imp_error.error = 2 THEN
OutString("not found "); OutString(K.imp_error.proc); OutString(" in "); OutString(K.imp_error.lib)
END;
OutLn
END imp_error;
PROCEDURE init* (_import, code: INTEGER);
BEGIN
multi := FALSE;
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - 36;
K.sysfunc2(68, 11);
InitializeCriticalSection(CriticalSection);
K._init;
import := (K.dll_Load(_import) = 0) & (K.imp_error.error = 0);
IF ~import THEN
imp_error
END
END init;
PROCEDURE SetMultiThr* (value: BOOLEAN);
BEGIN
multi := value
END SetMultiThr;
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9) * 10
END GetTickCount;
END API.

20
programs/develop/oberon07/Lib/KolibriOS/Args.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -38,7 +38,7 @@ END GetChar;
PROCEDURE ParamParse;
VAR p, count, name: INTEGER; c: CHAR; cond: INTEGER;
PROCEDURE ChangeCond(A, B, C: INTEGER);
PROCEDURE ChangeCond(A, B, C: INTEGER; c: CHAR; VAR cond: INTEGER);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
@ -64,11 +64,11 @@ BEGIN
WHILE (argc < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|0: ChangeCond(0, 4, 1, c, cond); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
END;
INC(p)
@ -86,8 +86,8 @@ BEGIN
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
s[j] := c;
INC(j)
END;
INC(i);
END;

12
programs/develop/oberon07/Lib/KolibriOS/ColorDlg.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -65,7 +65,7 @@ BEGIN
res.color_type := 0;
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.ADR("/rd/1/colrdial");
res.start_path := sys.SADR("/rd/1/colrdial");
res.draw_window := draw_window;
res.status := 0;
res.X := 0;
@ -86,7 +86,7 @@ END Destroy;
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
@ -96,8 +96,8 @@ VAR Lib: INTEGER;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(sys.ADR(Dialog_init), "ColorDialog_init");
GetProc(sys.ADR(Dialog_start), "ColorDialog_start");
GetProc(Lib, sys.ADR(Dialog_init), "ColorDialog_init");
GetProc(Lib, sys.ADR(Dialog_start), "ColorDialog_start");
END Load;
BEGIN

78
programs/develop/oberon07/Lib/KolibriOS/Console.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -17,50 +17,78 @@
MODULE Console;
IMPORT ConsoleLib;
IMPORT ConsoleLib, In, Out;
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;
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);
PROCEDURE SetCursor* (X, Y: INTEGER);
BEGIN
ConsoleLib.set_cursor_pos(X, Y)
ConsoleLib.set_cursor_pos(X, Y)
END SetCursor;
PROCEDURE GetCursor*(VAR X, Y: INTEGER);
PROCEDURE GetCursor* (VAR X, Y: INTEGER);
BEGIN
ConsoleLib.get_cursor_pos(X, Y)
ConsoleLib.get_cursor_pos(X, Y)
END GetCursor;
PROCEDURE Cls*;
BEGIN
ConsoleLib.cls
ConsoleLib.cls
END Cls;
PROCEDURE SetColor*(FColor, BColor: INTEGER);
VAR res: INTEGER;
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
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;
PROCEDURE GetCursorX* (): INTEGER;
VAR
x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN x
ConsoleLib.get_cursor_pos(x, y)
RETURN x
END GetCursorX;
PROCEDURE GetCursorY*(): INTEGER;
VAR x, y: INTEGER;
PROCEDURE GetCursorY* (): INTEGER;
VAR
x, y: INTEGER;
BEGIN
ConsoleLib.get_cursor_pos(x, y)
RETURN y
ConsoleLib.get_cursor_pos(x, y)
RETURN y
END GetCursorY;
PROCEDURE open*;
BEGIN
ConsoleLib.open(-1, -1, -1, -1, "");
In.Open;
Out.Open
END open;
PROCEDURE exit* (bCloseWindow: BOOLEAN);
BEGIN
ConsoleLib.exit(bCloseWindow)
END exit;
END Console.

76
programs/develop/oberon07/Lib/KolibriOS/ConsoleLib.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -23,11 +23,11 @@ CONST
COLOR_BLUE* = 001H;
COLOR_GREEN* = 002H;
COLOR_RED* = 004H;
COLOR_RED* = 004H;
COLOR_BRIGHT* = 008H;
BGR_BLUE* = 010H;
BGR_GREEN* = 020H;
BGR_RED* = 040H;
BGR_BLUE* = 010H;
BGR_GREEN* = 020H;
BGR_RED* = 040H;
BGR_BRIGHT* = 080H;
IGNORE_SPECIALS* = 100H;
WINDOW_CLOSED* = 200H;
@ -38,25 +38,25 @@ TYPE
VAR
version* : INTEGER;
init* : PROCEDURE [stdcall] (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
exit* : PROCEDURE [stdcall] (bCloseWindow: BOOLEAN);
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_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] ();
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);
set_title* : PROCEDURE [stdcall] (title: INTEGER);
set_title* : PROCEDURE [stdcall] (title: INTEGER);
PROCEDURE open*(wnd_width, wnd_height, scr_width, scr_height: INTEGER; title: ARRAY OF CHAR);
BEGIN
@ -66,7 +66,7 @@ END open;
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
@ -77,25 +77,25 @@ VAR Lib: INTEGER;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/Console.obj");
ASSERT(Lib # 0);
GetProc(sys.ADR(version), "version");
GetProc(sys.ADR(init), "con_init");
GetProc(sys.ADR(exit), "con_exit");
GetProc(sys.ADR(write_asciiz), "con_write_asciiz");
GetProc(sys.ADR(write_string), "con_write_string");
GetProc(sys.ADR(get_flags), "con_get_flags");
GetProc(sys.ADR(set_flags), "con_set_flags");
GetProc(sys.ADR(get_font_height), "con_get_font_height");
GetProc(sys.ADR(get_cursor_height), "con_get_cursor_height");
GetProc(sys.ADR(set_cursor_height), "con_set_cursor_height");
GetProc(sys.ADR(getch), "con_getch");
GetProc(sys.ADR(getch2), "con_getch2");
GetProc(sys.ADR(kbhit), "con_kbhit");
GetProc(sys.ADR(gets), "con_gets");
GetProc(sys.ADR(gets2), "con_gets2");
GetProc(sys.ADR(cls), "con_cls");
GetProc(sys.ADR(get_cursor_pos), "con_get_cursor_pos");
GetProc(sys.ADR(set_cursor_pos), "con_set_cursor_pos");
GetProc(sys.ADR(set_title), "con_set_title");
GetProc(Lib, sys.ADR(version), "version");
GetProc(Lib, sys.ADR(init), "con_init");
GetProc(Lib, sys.ADR(exit), "con_exit");
GetProc(Lib, sys.ADR(write_asciiz), "con_write_asciiz");
GetProc(Lib, sys.ADR(write_string), "con_write_string");
GetProc(Lib, sys.ADR(get_flags), "con_get_flags");
GetProc(Lib, sys.ADR(set_flags), "con_set_flags");
GetProc(Lib, sys.ADR(get_font_height), "con_get_font_height");
GetProc(Lib, sys.ADR(get_cursor_height), "con_get_cursor_height");
GetProc(Lib, sys.ADR(set_cursor_height), "con_set_cursor_height");
GetProc(Lib, sys.ADR(getch), "con_getch");
GetProc(Lib, sys.ADR(getch2), "con_getch2");
GetProc(Lib, sys.ADR(kbhit), "con_kbhit");
GetProc(Lib, sys.ADR(gets), "con_gets");
GetProc(Lib, sys.ADR(gets2), "con_gets2");
GetProc(Lib, sys.ADR(cls), "con_cls");
GetProc(Lib, sys.ADR(get_cursor_pos), "con_get_cursor_pos");
GetProc(Lib, sys.ADR(set_cursor_pos), "con_set_cursor_pos");
GetProc(Lib, sys.ADR(set_title), "con_set_title");
END main;
BEGIN

67
programs/develop/oberon07/Lib/KolibriOS/DateTime.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -19,10 +19,10 @@ MODULE DateTime;
IMPORT KOSAPI;
CONST ERR* = -7.0D5;
CONST ERR* = -7.0E5;
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): LONGREAL;
VAR d, i: INTEGER; M: ARRAY 13 OF CHAR; Res: LONGREAL;
PROCEDURE Encode*(Year, Month, Day, Hour, Min, Sec: INTEGER): REAL;
VAR d, i: INTEGER; M: ARRAY 14 OF CHAR; Res: REAL;
BEGIN
Res := ERR;
IF (Year >= 1) & (Year <= 9999) & (Month >= 1) & (Month <= 12) &
@ -36,18 +36,18 @@ BEGIN
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
d := d + ORD(M[i]) - ORD("0") + 28
END;
Res := LONG(FLT(d)) + LONG(FLT(Hour * 3600000 + Min * 60000 + Sec * 1000)) / 86400000.0D0
Res := FLT(d) + FLT(Hour * 3600000 + Min * 60000 + Sec * 1000) / 86400000.0
END
END
RETURN Res
END Encode;
PROCEDURE Decode*(Date: LONGREAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN;
VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 13 OF CHAR;
PROCEDURE Decode*(Date: REAL; VAR Year, Month, Day, Hour, Min, Sec: INTEGER): BOOLEAN;
VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 14 OF CHAR;
PROCEDURE MonthDay(n: INTEGER): BOOLEAN;
PROCEDURE MonthDay(n: INTEGER; VAR d, Month: INTEGER; M: ARRAY OF CHAR): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
Res := FALSE;
@ -60,9 +60,9 @@ VAR Res, flag: BOOLEAN; d, t, i: INTEGER; M: ARRAY 13 OF CHAR;
END MonthDay;
BEGIN
IF (Date >= -693593.0D0) & (Date < 2958466.0D0) THEN
IF (Date >= -693593.0) & (Date < 2958466.0) THEN
d := FLOOR(Date);
t := FLOOR((Date - LONG(FLT(d))) * 86400000.0D0);
t := FLOOR((Date - FLT(d)) * 86400000.0);
d := d + 693593;
Year := 1;
Month := 1;
@ -82,7 +82,7 @@ BEGIN
i := 1;
flag := TRUE;
WHILE flag & (i <= 12) DO
flag := MonthDay(i);
flag := MonthDay(i, d, Month, M);
INC(i)
END;
Day := d;
@ -98,43 +98,44 @@ BEGIN
RETURN Res
END Decode;
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec: INTEGER);
PROCEDURE Now*(VAR Year, Month, Day, Hour, Min, Sec, Msec: INTEGER);
VAR date, time: INTEGER;
BEGIN
date := KOSAPI.sysfunc1(29);
time := KOSAPI.sysfunc1(3);
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;
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;
date := date DIV 16;
Month := (date MOD 16) * 10 + Month;
date := date DIV 16;
date := date DIV 16;
Day := date MOD 16;
date := date DIV 16;
date := date DIV 16;
Day := (date MOD 16) * 10 + Day;
date := date DIV 16;
date := date DIV 16;
Hour := time MOD 16;
time := time DIV 16;
Hour := (time MOD 16) * 10 + Hour;
time := time 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;
time := time DIV 16;
Min := (time MOD 16) * 10 + Min;
time := time DIV 16;
time := time DIV 16;
Sec := time MOD 16;
time := time DIV 16;
time := time DIV 16;
Sec := (time MOD 16) * 10 + Sec;
time := time DIV 16;
time := time DIV 16;
Year := Year + 2000
Year := Year + 2000;
Msec := 0
END Now;
END DateTime.

106
programs/develop/oberon07/Lib/KolibriOS/Debug.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -21,11 +21,11 @@ IMPORT KOSAPI, sys := SYSTEM;
CONST
d = 1.0D0 - 5.0D-12;
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: LONGREAL; width: INTEGER);
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
VAR res: INTEGER;
@ -72,7 +72,7 @@ BEGIN
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
@ -80,8 +80,8 @@ BEGIN
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
@ -97,15 +97,15 @@ BEGIN
END
END Int;
PROCEDURE OutInf(x: LONGREAL; width: INTEGER);
VAR s: ARRAY 4 OF CHAR; i: INTEGER;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0D0) THEN
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0D0) THEN
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
@ -120,8 +120,8 @@ BEGIN
Char(0AX)
END Ln;
PROCEDURE _FixReal(x: LONGREAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN;
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
@ -130,23 +130,23 @@ BEGIN
ELSE
len := 0;
minus := FALSE;
IF x < 0.0D0 THEN
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0D0 + d THEN
INC(len)
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
INC(len)
END
ELSE
len := len + p + 2
@ -158,51 +158,51 @@ BEGIN
Char("-")
END;
y := x;
WHILE (y < 1.0D0) & (y # 0.0D0) DO
y := y * 10.0D0;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char("1");
x := 0.0D0
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0D0
Char("0");
x := x * 10.0
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)
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
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
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: LONGREAL; width: INTEGER);
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
@ -217,22 +217,22 @@ BEGIN
width := 9
END;
width := width - 5;
IF x < 0.0D0 THEN
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0D0) & (x # 0.0D0) DO
x := x * 10.0D0;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0D0 + d THEN
x := 1.0D0;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
@ -260,7 +260,7 @@ BEGIN
END
END Real;
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER);
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)
@ -282,7 +282,7 @@ VAR info: info_struct; res: INTEGER;
BEGIN
info.subfunc := 7;
info.flags := 0;
info.param := sys.ADR(" ");
info.param := sys.SADR(" ");
info.rsrvd1 := 0;
info.rsrvd2 := 0;
info.fname := "/rd/1/develop/board";

455
programs/develop/oberon07/Lib/KolibriOS/File.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -17,239 +17,300 @@
MODULE File;
IMPORT sys := SYSTEM, KOSAPI;
IMPORT sys := SYSTEM, KOSAPI;
CONST
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
SEEK_BEG* = 0; SEEK_CUR* = 1; SEEK_END* = 2;
TYPE
FNAME* = ARRAY 520 OF CHAR;
FNAME* = ARRAY 520 OF CHAR;
FS* = POINTER TO rFS;
FS* = POINTER TO rFS;
rFS* = RECORD
subfunc*, pos*, hpos*, bytes*, buffer*: INTEGER;
name*: FNAME
END;
rFS* = RECORD
subfunc*, pos*, hpos*, bytes*, buffer*: INTEGER;
name*: FNAME
END;
FD* = POINTER TO rFD;
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;
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;
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;
sys.CODE(
053H, (* push ebx *)
06AH, 044H, (* push 68 *)
058H, (* pop eax *)
06AH, 01BH, (* push 27 *)
05BH, (* pop ebx *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 8] *)
0CDH, 040H, (* int 64 *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
089H, 011H, (* mov dword [ecx], edx *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 8 *)
)
RETURN 0
END f_68_27;
PROCEDURE Load*(FName: ARRAY OF CHAR; VAR size: INTEGER): INTEGER;
RETURN f_68_27(sys.ADR(FName[0]), size)
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;
PROCEDURE GetFileInfo* (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR
res2: INTEGER; fs: rFS;
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
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);
PROCEDURE Close* (VAR F: FS);
BEGIN
IF F # NIL THEN
DISPOSE(F)
END
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)
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
res := -1
F := NIL
END
ELSE
res := -1
END
RETURN res = 0
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;
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
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
END;
res := F.pos
ELSE
res := -1
END
RETURN res
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 Read* (F: FS; Buffer, Count: INTEGER): INTEGER;
VAR
res, res2: INTEGER;
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)
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
res := -1
res2 := 0
END
ELSE
res := -1
END
RETURN res = 0
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.

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

@ -1,246 +1,471 @@
(*
Copyright 2016, 2017 Anton Krotov
(*
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, K := KOSAPI, API, RTL;
CONST
OS* = "KOS";
Slash* = "/";
slash* = "/";
OS* = "KOS";
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
MAX_PARAM = 1024;
TYPE
FILENAME = ARRAY 2048 OF CHAR;
FNAME = ARRAY 520 OF CHAR;
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;
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;
Console: BOOLEAN;
PROCEDURE [stdcall] sysfunc22(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc*: INTEGER;
eol*: ARRAY 3 OF CHAR;
PROCEDURE [stdcall, "Console.obj", "con_init"] con_init (wnd_width, wnd_height, scr_width, scr_height, title: INTEGER);
PROCEDURE [stdcall, "Console.obj", "con_exit"] con_exit (bCloseWindow: BOOLEAN);
PROCEDURE [stdcall, "Console.obj", "con_write_string"] con_write_string (string, length: INTEGER);
PROCEDURE ExitProcess* (p1: INTEGER);
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8919"); (* mov [ecx], ebx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
END sysfunc22;
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 := API.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 := API.sysfunc3(68, 19, sys.ADR("/rd/1/lib/console.obj"));
IF Lib # 0 THEN
GetProc(sys.ADR(con_init), "con_init");
GetProc(sys.ADR(con_exit), "con_exit");
GetProc(sys.ADR(con_write_asciiz), "con_write_asciiz");
IF con_init # NIL THEN
con_init(-1, -1, -1, -1, sys.ADR("Oberon-07/11 for KolibriOS"))
END
END
END init;
PROCEDURE ExitProcess* (n: INTEGER);
BEGIN
IF con_exit # NIL THEN
con_exit(FALSE)
END;
API.ExitProcess(0)
IF Console THEN
con_exit(FALSE)
END;
K.sysfunc1(-1)
END ExitProcess;
PROCEDURE AppAdr(): INTEGER;
PROCEDURE OutChar* (c: CHAR);
BEGIN
IF Console THEN
con_write_string(SYSTEM.ADR(c), 1)
ELSE
K.sysfunc3(63, 1, ORD(c))
END
END OutChar;
PROCEDURE GetFileInfo (FName: ARRAY OF CHAR; VAR Info: rFD): BOOLEAN;
VAR
res2: INTEGER;
fs: rFS;
BEGIN
fs.subfunc := 5;
fs.pos := 0;
fs.hpos := 0;
fs.bytes := 0;
fs.buffer := SYSTEM.ADR(Info);
COPY(FName, fs.name)
RETURN K.sysfunc22(70, SYSTEM.ADR(fs), res2) = 0
END GetFileInfo;
PROCEDURE Exists (FName: ARRAY OF CHAR): BOOLEAN;
VAR
fd: rFD;
BEGIN
RETURN GetFileInfo(FName, fd) & ~(4 IN BITS(fd.attr))
END Exists;
PROCEDURE Close (VAR F: FS);
BEGIN
IF F # NIL THEN
DISPOSE(F)
END
END Close;
PROCEDURE Open (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
BEGIN
IF Exists(FName) THEN
NEW(F);
IF F # NIL THEN
F.subfunc := 0;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name)
END
ELSE
F := NIL
END
RETURN F
END Open;
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 := K.sysfunc22(70, SYSTEM.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 := K.sysfunc22(70, SYSTEM.ADR(F^), res2);
IF res2 > 0 THEN
F.pos := F.pos + res2
END
ELSE
res2 := 0
END
RETURN res2
END Write;
PROCEDURE Create (FName: ARRAY OF CHAR): FS;
VAR
F: FS;
res2: INTEGER;
BEGIN
NEW(F);
IF F # NIL THEN
F.subfunc := 2;
F.pos := 0;
F.hpos := 0;
F.bytes := 0;
F.buffer := 0;
COPY(FName, F.name);
IF K.sysfunc22(70, SYSTEM.ADR(F^), res2) # 0 THEN
DISPOSE(F)
END
END
RETURN F
END Create;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
n: INTEGER;
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
n := Read(fs, SYSTEM.ADR(Buffer[0]), bytes);
IF n = 0 THEN
n := -1
END
RETURN n
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
n: INTEGER;
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
n := Write(fs, SYSTEM.ADR(Buffer[0]), bytes);
IF n = 0 THEN
n := -1
END
RETURN n
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
VAR
fs: FS;
res: INTEGER;
BEGIN
fs := Create(FName);
SYSTEM.GET(SYSTEM.ADR(fs), res)
RETURN res
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
VAR
fs: FS;
BEGIN
SYSTEM.GET(SYSTEM.ADR(F), fs);
Close(fs)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
fs: FS;
res: INTEGER;
BEGIN
fs := Open(FName);
SYSTEM.GET(SYSTEM.ADR(fs), res)
RETURN res
END FileOpen;
PROCEDURE GetTickCount* (): INTEGER;
RETURN K.sysfunc2(26, 9)
END GetTickCount;
PROCEDURE AppAdr (): INTEGER;
VAR
buf: ARRAY 1024 OF CHAR;
a: INTEGER;
BEGIN
a := API.sysfunc3(9, sys.ADR(buf), -1);
sys.GET(sys.ADR(buf) + 22, a)
a := K.sysfunc3(9, SYSTEM.ADR(buf), -1);
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a)
RETURN a
END AppAdr;
PROCEDURE GetCommandLine*(): INTEGER;
VAR param: INTEGER;
PROCEDURE GetCommandLine (): INTEGER;
VAR
param: INTEGER;
BEGIN
sys.GET(28 + AppAdr(), param)
RETURN param
SYSTEM.GET(28 + AppAdr(), param)
RETURN param
END GetCommandLine;
PROCEDURE GetName*(): INTEGER;
VAR name: INTEGER;
PROCEDURE GetName (): INTEGER;
VAR
name: INTEGER;
BEGIN
sys.GET(32 + AppAdr(), name)
RETURN name
SYSTEM.GET(32 + AppAdr(), name)
RETURN name
END GetName;
PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN API.sysfunc3(68, 12, size)
END malloc;
PROCEDURE CloseFile*(hObject: INTEGER);
VAR pFS: POINTER TO OFSTRUCT;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
sys.PUT(sys.ADR(pFS), hObject);
DISPOSE(pFS)
END CloseFile;
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR
p, count, name, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; c: CHAR; VAR cond: 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;
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;
p := GetCommandLine();
name := 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, c, cond); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, c, cond); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, c, cond); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, c, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
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;
j := 0;
IF n < argc THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i);
END;
END;
s[j] := 0X
END GetArg;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
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;
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE CreateFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN OCFile(FName, 2)
END CreateFile;
PROCEDURE OpenFile* (FName: ARRAY OF CHAR): INTEGER;
RETURN OCFile(FName, 5)
END OpenFile;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
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;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
VAR
date, time: INTEGER;
BEGIN
IF hFile # 0 THEN
sys.PUT(sys.ADR(pFS), hFile);
res := IOFile(pFS^, Buffer, nNumberOfBytes, 3 * ORD(write))
ELSE
res := 0
END
RETURN res
END FileRW;
date := K.sysfunc1(29);
time := K.sysfunc1(3);
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR n: INTEGER;
year := date MOD 16;
date := date DIV 16;
year := (date MOD 16) * 10 + year;
date := date DIV 16;
month := date MOD 16;
date := date DIV 16;
month := (date MOD 16) * 10 + month;
date := date DIV 16;
day := date MOD 16;
date := date DIV 16;
day := (date MOD 16) * 10 + day;
date := date DIV 16;
hour := time MOD 16;
time := time DIV 16;
hour := (time MOD 16) * 10 + hour;
time := time DIV 16;
min := time MOD 16;
time := time DIV 16;
min := (time MOD 16) * 10 + min;
time := time DIV 16;
sec := time MOD 16;
time := time DIV 16;
sec := (time MOD 16) * 10 + sec;
time := time DIV 16;
year := year + 2000
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN 0
END UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
BEGIN
n := ORD(str[0] = 3X);
IF con_write_asciiz # NIL THEN
con_write_asciiz(sys.ADR(str[n]))
ELSE
API.DebugMsg(sys.ADR(str[n]), 0)
END
END OutString;
SYSTEM.GET(SYSTEM.ADR(x), a);
SYSTEM.GET(SYSTEM.ADR(x) + 4, b)
RETURN a
END splitf;
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
Console := API.import;
IF Console THEN
con_init(-1, -1, -1, -1, SYSTEM.SADR("Oberon-07 for KolibriOS"))
END;
ParamParse
END HOST.

114
programs/develop/oberon07/Lib/KolibriOS/In.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -84,12 +84,12 @@ BEGIN
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
flag := FALSE;
res := 0
err := TRUE;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END;
@ -117,108 +117,108 @@ BEGIN
IF s[i] = "." THEN
INC(i);
WHILE digit(s[i]) DO
INC(i)
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
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 StrToFloat(str: STRING; VAR err: BOOLEAN): REAL;
CONST maxDBL = 1.69E308; maxINT = 7FFFFFFFH;
VAR i, scale: INTEGER; res, m, d: REAL; minus, neg: BOOLEAN;
PROCEDURE part1(): BOOLEAN;
PROCEDURE part1 (str: STRING; VAR res, d: REAL; VAR i: INTEGER): BOOLEAN;
BEGIN
res := 0.0D0;
d := 1.0D0;
res := 0.0;
d := 1.0;
WHILE digit(str[i]) DO
res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0")));
res := res * 10.0 + FLT(ORD(str[i]) - ORD("0"));
INC(i)
END;
IF str[i] = "." THEN
INC(i);
WHILE digit(str[i]) DO
d := d / 10.0D0;
res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d;
INC(i)
d := d / 10.0;
res := res + FLT(ORD(str[i]) - ORD("0")) * d;
INC(i)
END
END
RETURN str[i] # 0X
END part1;
PROCEDURE part2(): BOOLEAN;
PROCEDURE part2 (str: STRING; VAR i, scale: INTEGER; VAR minus, err: BOOLEAN; VAR m, res: REAL): BOOLEAN;
BEGIN
INC(i);
m := 10.0D0;
m := 10.0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1D0
m := 0.1
END;
scale := 0;
err := FALSE;
WHILE ~err & digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
err := TRUE;
res := 0.0D0
err := TRUE;
res := 0.0
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
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
err := TRUE;
res := 0.0
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN ~err
END part2;
PROCEDURE part3;
PROCEDURE part3 (VAR err, minus: BOOLEAN; VAR res, m: REAL; VAR scale: INTEGER);
VAR i: INTEGER;
BEGIN
err := FALSE;
IF scale = maxINT THEN
err := TRUE;
res := 0.0D0
res := 0.0
END;
i := 1;
WHILE ~err & (i <= scale) DO
IF ~minus & (res > maxDBL / m) THEN
err := TRUE;
res := 0.0D0
err := TRUE;
res := 0.0
ELSE
res := res * m;
INC(i)
res := res * m;
INC(i)
END
END
END part3;
BEGIN
IF CheckReal(str, i, neg) THEN
IF part1() & part2() THEN
part3
IF part1(str, res, d, i) & part2(str, i, scale, minus, err, m, res) THEN
part3(err, minus, res, m, scale)
END;
IF neg THEN
res := -res
END
ELSE
res := 0.0D0;
res := 0.0;
err := TRUE
END
RETURN res
@ -251,7 +251,7 @@ BEGIN
Done := TRUE
END Ln;
PROCEDURE LongReal*(VAR x: LONGREAL);
PROCEDURE Real* (VAR x: REAL);
VAR str: STRING; err: BOOLEAN;
BEGIN
err := FALSE;
@ -260,23 +260,9 @@ BEGIN
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

610
programs/develop/oberon07/Lib/KolibriOS/KOSAPI.ob07
View File

@ -1,348 +1,430 @@
(*
Copyright 2016, 2018 Anton Krotov
(*
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE KOSAPI;
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
TYPE STRING = ARRAY 1024 OF CHAR;
VAR DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER);
TYPE
PROCEDURE [stdcall] sysfunc1*(arg1: INTEGER): INTEGER;
STRING = ARRAY 1024 OF CHAR;
VAR
DLL_INIT: PROCEDURE [stdcall] (entry: INTEGER);
imp_error*: RECORD
proc*, lib*: STRING;
error*: INTEGER
END;
PROCEDURE [stdcall-] sysfunc1* (arg1: INTEGER): INTEGER;
BEGIN
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20400"); (* ret 04h *)
RETURN 0
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
0CDH, 040H, (* int 64 *)
0C9H, (* leave *)
0C2H, 004H, 000H (* ret 4 *)
)
RETURN 0
END sysfunc1;
PROCEDURE [stdcall] sysfunc2*(arg1, arg2: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc2* (arg1, arg2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20800"); (* ret 08h *)
RETURN 0
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 8 *)
)
RETURN 0
END sysfunc2;
PROCEDURE [stdcall] sysfunc3*(arg1, arg2, arg3: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc3* (arg1, arg2, arg3: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END sysfunc3;
PROCEDURE [stdcall] sysfunc4*(arg1, arg2, arg3, arg4: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc4* (arg1, arg2, arg3, arg4: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21000"); (* ret 10h *)
RETURN 0
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
0CDH, 040H, (* int 64 *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 16 *)
)
RETURN 0
END sysfunc4;
PROCEDURE [stdcall] sysfunc5*(arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc5* (arg1, arg2, arg3, arg4, arg5: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
RETURN 0
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
0CDH, 040H, (* int 64 *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 014H, 000H (* ret 20 *)
)
RETURN 0
END sysfunc5;
PROCEDURE [stdcall] sysfunc6*(arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc6* (arg1, arg2, arg3, arg4, arg5, arg6: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("57"); (* push edi *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5F"); (* pop edi *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21800"); (* ret 18h *)
RETURN 0
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
0CDH, 040H, (* int 64 *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END sysfunc6;
PROCEDURE [stdcall] sysfunc7*(arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc7* (arg1, arg2, arg3, arg4, arg5, arg6, arg7: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("56"); (* push esi *)
sys.CODE("57"); (* push edi *)
sys.CODE("55"); (* push ebp *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("8B7D1C"); (* mov edi, [ebp + 1Ch] *)
sys.CODE("8B6D20"); (* mov ebp, [ebp + 20h] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("5D"); (* pop ebp *)
sys.CODE("5F"); (* pop edi *)
sys.CODE("5E"); (* pop esi *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21C00"); (* ret 1Ch *)
RETURN 0
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
055H, (* push ebp *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
08BH, 06DH, 020H, (* mov ebp, dword [ebp + 32] *)
0CDH, 040H, (* int 64 *)
05DH, (* pop ebp *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 01CH, 000H (* ret 28 *)
)
RETURN 0
END sysfunc7;
PROCEDURE [stdcall] sysfunc22*(arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
PROCEDURE [stdcall-] sysfunc22* (arg1, arg2: INTEGER; VAR res2: INTEGER): INTEGER;
BEGIN
sys.CODE("53"); (* push ebx *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("CD40"); (* int 40h *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8919"); (* mov [ecx], ebx *)
sys.CODE("5B"); (* pop ebx *)
sys.CODE("C9"); (* leave *)
sys.CODE("C20C00"); (* ret 0Ch *)
RETURN 0
SYSTEM.CODE(
053H, (* push ebx *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
0CDH, 040H, (* int 64 *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 019H, (* mov dword [ecx], ebx *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END sysfunc22;
PROCEDURE mem_commit(adr, size: INTEGER);
VAR tmp: INTEGER;
PROCEDURE mem_commit (adr, size: INTEGER);
VAR
tmp: INTEGER;
BEGIN
FOR tmp := adr TO adr + size - 1 BY 4096 DO
sys.PUT(tmp, 0)
END
FOR tmp := adr TO adr + size - 1 BY 4096 DO
SYSTEM.PUT(tmp, 0)
END
END mem_commit;
PROCEDURE [stdcall] malloc*(size: INTEGER): INTEGER;
VAR ptr: INTEGER;
PROCEDURE [stdcall] malloc* (size: INTEGER): INTEGER;
VAR
ptr: INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
IF sysfunc2(18, 16) > ASR(size, 10) THEN
ptr := sysfunc3(68, 12, size);
IF ptr # 0 THEN
mem_commit(ptr, size)
END
ELSE
ptr := 0
END;
sys.CODE("61") (* popa *)
RETURN ptr
SYSTEM.CODE(060H); (* pusha *)
IF sysfunc2(18, 16) > ASR(size, 10) THEN
ptr := sysfunc3(68, 12, size);
IF ptr # 0 THEN
mem_commit(ptr, size)
END
ELSE
ptr := 0
END;
SYSTEM.CODE(061H) (* popa *)
RETURN ptr
END malloc;
PROCEDURE [stdcall] free*(ptr: INTEGER): INTEGER;
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
SYSTEM.CODE(060H); (* pusha *)
IF ptr # 0 THEN
ptr := sysfunc3(68, 13, ptr)
END;
SYSTEM.CODE(061H) (* popa *)
RETURN 0
END free;
PROCEDURE [stdcall] realloc*(ptr, size: INTEGER): INTEGER;
PROCEDURE [stdcall] realloc* (ptr, size: INTEGER): INTEGER;
BEGIN
sys.CODE("60"); (* pusha *)
ptr := sysfunc4(68, 20, size, ptr);
sys.CODE("61") (* popa *)
RETURN ptr
SYSTEM.CODE(060H); (* pusha *)
ptr := sysfunc4(68, 20, size, ptr);
SYSTEM.CODE(061H) (* popa *)
RETURN ptr
END realloc;
PROCEDURE AppAdr(): INTEGER;
PROCEDURE AppAdr (): INTEGER;
VAR
buf: ARRAY 1024 OF CHAR;
a: INTEGER;
BEGIN
a := sysfunc3(9, sys.ADR(buf), -1);
sys.GET(sys.ADR(buf) + 22, a)
a := sysfunc3(9, SYSTEM.ADR(buf), -1);
SYSTEM.GET(SYSTEM.ADR(buf) + 22, a)
RETURN a
END AppAdr;
PROCEDURE GetCommandLine*(): INTEGER;
VAR param: INTEGER;
PROCEDURE GetCommandLine* (): INTEGER;
VAR
param: INTEGER;
BEGIN
sys.GET(28 + AppAdr(), param)
RETURN param
SYSTEM.GET(28 + AppAdr(), param)
RETURN param
END GetCommandLine;
PROCEDURE GetName*(): INTEGER;
VAR name: INTEGER;
PROCEDURE GetName* (): INTEGER;
VAR
name: INTEGER;
BEGIN
sys.GET(32 + AppAdr(), name)
RETURN name
SYSTEM.GET(32 + AppAdr(), name)
RETURN name
END GetName;
PROCEDURE [stdcall] dll_init2(arg1, arg2, arg3, arg4, arg5: INTEGER);
PROCEDURE [stdcall] dll_init2 (arg1, arg2, arg3, arg4, arg5: INTEGER);
BEGIN
sys.CODE("60"); (* pusha *)
sys.CODE("8B4508"); (* mov eax, [ebp + 08h] *)
sys.CODE("8B5D0C"); (* mov ebx, [ebp + 0Ch] *)
sys.CODE("8B4D10"); (* mov ecx, [ebp + 10h] *)
sys.CODE("8B5514"); (* mov edx, [ebp + 14h] *)
sys.CODE("8B7518"); (* mov esi, [ebp + 18h] *)
sys.CODE("FFD6"); (* call esi *)
sys.CODE("61"); (* popa *)
sys.CODE("C9"); (* leave *)
sys.CODE("C21400"); (* ret 14h *)
SYSTEM.CODE(
060H, (* pusha *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
0FFH, 0D6H, (* call esi *)
061H, (* popa *)
0C9H, (* leave *)
0C2H, 014H, 000H (* ret 20 *)
)
END dll_init2;
PROCEDURE GetProcAdr*(name: ARRAY OF CHAR; lib: INTEGER): INTEGER;
VAR cur, procname, adr: INTEGER;
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;
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
SYSTEM.GET(str1, c1);
SYSTEM.GET(str2, c2);
INC(str1);
INC(str2)
UNTIL (c1 # c2) OR (c1 = 0X)
RETURN c1 = c2
END streq;
BEGIN
adr := 0;
IF (lib # 0) & (name # "") THEN
cur := lib;
REPEAT
sys.GET(cur, procname);
INC(cur, 8)
UNTIL (procname = 0) OR streq(procname, sys.ADR(name[0]));
IF procname # 0 THEN
sys.GET(cur - 4, adr)
adr := 0;
IF (lib # 0) & (name # "") THEN
cur := lib;
REPEAT
SYSTEM.GET(cur, procname);
INC(cur, 8)
UNTIL (procname = 0) OR streq(procname, SYSTEM.ADR(name[0]));
IF procname # 0 THEN
SYSTEM.GET(cur - 4, adr)
END
END
END
RETURN adr
RETURN adr
END GetProcAdr;
PROCEDURE init(dll: INTEGER);
VAR lib_init: INTEGER;
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;
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;
PROCEDURE GetStr (adr, i: INTEGER; VAR str: STRING);
VAR
c: CHAR;
BEGIN
REPEAT
SYSTEM.GET(adr, c); INC(adr);
str[i] := c; INC(i)
UNTIL c = 0X
END GetStr;
PROCEDURE [stdcall] dll_Load* (import_table: INTEGER): INTEGER;
VAR
imp, lib, exp, proc, res: INTEGER;
fail, done: BOOLEAN;
procname, libname: STRING;
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;
SYSTEM.CODE(060H); (* pusha *)
fail := FALSE;
done := FALSE;
res := 0;
libname := "/rd/1/lib/";
REPEAT
SYSTEM.GET(import_table, imp);
IF imp # 0 THEN
SYSTEM.GET(import_table + 4, lib);
GetStr(lib, 10, libname);
exp := sysfunc3(68, 19, SYSTEM.ADR(libname[0]));
fail := exp = 0;
ELSE
done := TRUE
END;
IF fail THEN
done := TRUE;
imp_error.proc := "";
imp_error.lib := libname;
imp_error.error := 1
END;
IF (imp # 0) & ~fail THEN
REPEAT
SYSTEM.GET(imp, proc);
IF proc # 0 THEN
GetStr(proc, 0, procname);
proc := GetProcAdr(procname, exp);
IF proc # 0 THEN
SYSTEM.PUT(imp, proc);
INC(imp, 4)
ELSE
imp_error.proc := procname;
imp_error.lib := libname;
imp_error.error := 2
END
END
UNTIL proc = 0;
init(exp);
INC(import_table, 8)
END
UNTIL done;
IF fail THEN
done := TRUE
res := 1
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
import_table := res;
SYSTEM.CODE(061H) (* popa *)
RETURN import_table
END dll_Load;
PROCEDURE [stdcall] dll_Init(entry: INTEGER);
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 *)
SYSTEM.CODE(060H); (* pusha *)
IF entry # 0 THEN
dll_init2(SYSTEM.ADR(malloc), SYSTEM.ADR(free), SYSTEM.ADR(realloc), SYSTEM.ADR(dll_Load), entry)
END;
SYSTEM.CODE(061H); (* popa *)
END dll_Init;
PROCEDURE LoadLib*(name: ARRAY OF CHAR): INTEGER;
VAR Lib: INTEGER;
PROCEDURE LoadLib* (name: ARRAY OF CHAR): INTEGER;
VAR
Lib: INTEGER;
BEGIN
DLL_INIT := dll_Init;
Lib := sysfunc3(68, 19, sys.ADR(name[0]));
IF Lib # 0 THEN
init(Lib)
END
RETURN Lib
DLL_INIT := dll_Init;
Lib := sysfunc3(68, 19, SYSTEM.ADR(name[0]));
IF Lib # 0 THEN
init(Lib)
END
RETURN Lib
END LoadLib;
PROCEDURE _init*;
BEGIN
DLL_INIT := dll_Init;
imp_error.lib := "";
imp_error.proc := "";
imp_error.error := 0
END _init;
END KOSAPI.

437
programs/develop/oberon07/Lib/KolibriOS/Math.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2013, 2014, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -17,238 +17,365 @@
MODULE Math;
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
CONST pi* = 3.141592653589793D+00;
e* = 2.718281828459045D+00;
VAR Inf*, nInf*: LONGREAL;
CONST
pi* = 3.141592653589793;
e* = 2.718281828459045;
PROCEDURE IsNan* (x: REAL): BOOLEAN;
VAR
h, l: SET;
PROCEDURE IsNan*(x: LONGREAL): BOOLEAN;
VAR h, l: SET;
BEGIN
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} # {}))
SYSTEM.GET(SYSTEM.ADR(x), l);
SYSTEM.GET(SYSTEM.ADR(x) + 4, h)
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf*(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
PROCEDURE IsInf* (x: REAL): BOOLEAN;
RETURN ABS(x) = SYSTEM.INF()
END IsInf;
PROCEDURE Max(A, B: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE Max (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF A > B THEN
Res := A
ELSE
Res := B
END
RETURN Res
IF a > b THEN
res := a
ELSE
res := b
END
RETURN res
END Max;
PROCEDURE Min(A, B: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE Min (a, b: REAL): REAL;
VAR
res: REAL;
BEGIN
IF A < B THEN
Res := A
ELSE
Res := B
END
RETURN Res
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;
PROCEDURE SameValue (a, b: REAL): BOOLEAN;
VAR
eps: REAL;
res: BOOLEAN;
BEGIN
Epsilon := Max(Min(ABS(A), ABS(B)) * 1.0D-12, 1.0D-12);
IF A > B THEN
Res := (A - B) <= Epsilon
ELSE
Res := (B - A) <= Epsilon
END
RETURN Res
eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);
IF a > b THEN
res := (a - b) <= eps
ELSE
res := (b - a) <= eps
END
RETURN res
END SameValue;
PROCEDURE IsZero(x: LONGREAL): BOOLEAN;
RETURN ABS(x) <= 1.0D-12
PROCEDURE IsZero (x: REAL): BOOLEAN;
RETURN ABS(x) <= 1.0E-12
END IsZero;
PROCEDURE [stdcall] sqrt*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D9FAC9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FAH, (* fsqrt *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sqrt;
PROCEDURE [stdcall] sin*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] sin* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D9FEC9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FEH, (* fsin *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END sin;
PROCEDURE [stdcall] cos*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] cos* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D9FFC9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FFH, (* fcos *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END cos;
PROCEDURE [stdcall] tan*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] tan* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D9F2DEC9C9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0FBH, (* fsincos *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END tan;
PROCEDURE [stdcall] arctan2*(y, x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
BEGIN
sys.CODE("DD4508DD4510D9F3C9C21000")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F3H, (* fpatan *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END arctan2;
PROCEDURE [stdcall] ln*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] ln* (x: REAL): REAL;
BEGIN
sys.CODE("D9EDDD4508D9F1C9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0D9H, 0EDH, (* fldln2 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END ln;
PROCEDURE [stdcall] log*(base, x: LONGREAL): LONGREAL;
BEGIN
sys.CODE("D9E8DD4510D9F1D9E8DD4508D9F1DEF9C9C21000")
RETURN 0.0D0
PROCEDURE [stdcall] log* (base, x: REAL): REAL;
BEGIN
SYSTEM.CODE(
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
0D9H, 0F1H, (* fyl2x *)
0D9H, 0E8H, (* fld1 *)
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0F1H, (* fyl2x *)
0DEH, 0F9H, (* fdivp st1, st *)
0C9H, (* leave *)
0C2H, 010H, 000H (* ret 10h *)
)
RETURN 0.0
END log;
PROCEDURE [stdcall] exp*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] exp* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D9EADEC9D9C0D9FCDCE9D9C9D9F0D9E8DEC1D9FDDDD9C9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0EAH, (* fldl2e *)
0DEH, 0C9H, 0D9H, 0C0H,
0D9H, 0FCH, 0DCH, 0E9H,
0D9H, 0C9H, 0D9H, 0F0H,
0D9H, 0E8H, 0DEH, 0C1H,
0D9H, 0FDH, 0DDH, 0D9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END exp;
PROCEDURE [stdcall] round*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] round* (x: REAL): REAL;
BEGIN
sys.CODE("DD4508D97DF4D97DF666814DF60003D96DF6D9FCD96DF4C9C20800")
RETURN 0.0D0
SYSTEM.CODE(
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 07DH, 0F4H, 0D9H,
07DH, 0F6H, 066H, 081H,
04DH, 0F6H, 000H, 003H,
0D9H, 06DH, 0F6H, 0D9H,
0FCH, 0D9H, 06DH, 0F4H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END round;
PROCEDURE [stdcall] frac*(x: LONGREAL): LONGREAL;
PROCEDURE [stdcall] frac* (x: REAL): REAL;
BEGIN
sys.CODE("50DD4508D9C0D93C24D97C240266814C2402000FD96C2402D9FCD92C24DEE9C9C20800")
RETURN 0.0D0
SYSTEM.CODE(
050H,
0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
0D9H, 0C0H, 0D9H, 03CH,
024H, 0D9H, 07CH, 024H,
002H, 066H, 081H, 04CH,
024H, 002H, 000H, 00FH,
0D9H, 06CH, 024H, 002H,
0D9H, 0FCH, 0D9H, 02CH,
024H, 0DEH, 0E9H,
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0.0
END frac;
PROCEDURE arcsin*(x: LONGREAL): LONGREAL;
RETURN arctan2(x, sqrt(1.0D0 - x * x))
PROCEDURE arcsin* (x: REAL): REAL;
RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
PROCEDURE arccos*(x: LONGREAL): LONGREAL;
RETURN arctan2(sqrt(1.0D0 - x * x), x)
PROCEDURE arccos* (x: REAL): REAL;
RETURN arctan2(sqrt(1.0 - x * x), x)
END arccos;
PROCEDURE arctan*(x: LONGREAL): LONGREAL;
RETURN arctan2(x, 1.0D0)
PROCEDURE arctan* (x: REAL): REAL;
RETURN arctan2(x, 1.0)
END arctan;
PROCEDURE sinh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE sinh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF IsZero(x) THEN
Res := 0.0D0
ELSE
Res := (exp(x) - exp(-x)) / 2.0D0
END
RETURN Res
IF IsZero(x) THEN
res := 0.0
ELSE
res := (exp(x) - exp(-x)) / 2.0
END
RETURN res
END sinh;
PROCEDURE cosh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE cosh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF IsZero(x) THEN
Res := 1.0D0
ELSE
Res := (exp(x) + exp(-x)) / 2.0D0
END
RETURN Res
IF IsZero(x) THEN
res := 1.0
ELSE
res := (exp(x) + exp(-x)) / 2.0
END
RETURN res
END cosh;
PROCEDURE tanh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE tanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF IsZero(x) THEN
Res := 0.0D0
ELSE
Res := sinh(x) / cosh(x)
END
RETURN Res
IF IsZero(x) THEN
res := 0.0
ELSE
res := sinh(x) / cosh(x)
END
RETURN res
END tanh;
PROCEDURE arcsinh*(x: LONGREAL): LONGREAL;
RETURN ln(x + sqrt((x * x) + 1.0D0))
PROCEDURE arcsinh* (x: REAL): REAL;
RETURN ln(x + sqrt((x * x) + 1.0))
END arcsinh;
PROCEDURE arccosh*(x: LONGREAL): LONGREAL;
RETURN ln(x + sqrt((x - 1.0D0) / (x + 1.0D0)) * (x + 1.0D0))
PROCEDURE arccosh* (x: REAL): REAL;
RETURN ln(x + sqrt((x - 1.0) / (x + 1.0)) * (x + 1.0))
END arccosh;
PROCEDURE arctanh*(x: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE arctanh* (x: REAL): REAL;
VAR
res: REAL;
BEGIN
IF SameValue(x, 1.0D0) THEN
Res := Inf
ELSIF SameValue(x, -1.0D0) THEN
Res := nInf
ELSE
Res := 0.5D0 * ln((1.0D0 + x) / (1.0D0 - x))
END
RETURN Res
IF SameValue(x, 1.0) THEN
res := SYSTEM.INF()
ELSIF SameValue(x, -1.0) THEN
res := -SYSTEM.INF()
ELSE
res := 0.5 * ln((1.0 + x) / (1.0 - x))
END
RETURN res
END arctanh;
PROCEDURE floor*(x: LONGREAL): LONGREAL;
VAR f: LONGREAL;
PROCEDURE floor* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f < 0.0D0 THEN
x := x - 1.0D0
END
RETURN x
f := frac(x);
x := x - f;
IF f < 0.0 THEN
x := x - 1.0
END
RETURN x
END floor;
PROCEDURE ceil*(x: LONGREAL): LONGREAL;
VAR f: LONGREAL;
PROCEDURE ceil* (x: REAL): REAL;
VAR
f: REAL;
BEGIN
f := frac(x);
x := x - f;
IF f > 0.0D0 THEN
x := x + 1.0D0
END
RETURN x
f := frac(x);
x := x - f;
IF f > 0.0 THEN
x := x + 1.0
END
RETURN x
END ceil;
PROCEDURE power*(base, exponent: LONGREAL): LONGREAL;
VAR Res: LONGREAL;
PROCEDURE power* (base, exponent: REAL): REAL;
VAR
res: REAL;
BEGIN
IF exponent = 0.0D0 THEN
Res := 1.0D0
ELSIF (base = 0.0D0) & (exponent > 0.0D0) THEN
Res := 0.0D0
ELSE
Res := exp(exponent * ln(base))
END
RETURN Res
IF exponent = 0.0 THEN
res := 1.0
ELSIF (base = 0.0) & (exponent > 0.0) THEN
res := 0.0
ELSE
res := exp(exponent * ln(base))
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;
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
res: INTEGER;
BEGIN
Inf := sys.INF(LONGREAL);
nInf := -sys.INF(LONGREAL)
IF x > 0.0 THEN
res := 1
ELSIF x < 0.0 THEN
res := -1
ELSE
res := 0
END
RETURN res
END sgn;
END Math.

12
programs/develop/oberon07/Lib/KolibriOS/OpenDlg.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -108,7 +108,7 @@ BEGIN
res.filter_area.size := LENGTH(res.filter_area.filter);
res.procinfo := sys.ADR(res.procinf[0]);
res.com_area_name := sys.ADR(res.s_com_area_name[0]);
res.start_path := sys.ADR("/rd/1/File managers/opendial");
res.start_path := sys.SADR("/rd/1/File managers/opendial");
res.opendir_path := sys.ADR(res.s_opendir_path[0]);
res.dir_default_path := sys.ADR(res.s_dir_default_path[0]);
res.openfile_path := sys.ADR(res.FilePath[0]);
@ -134,7 +134,7 @@ END Destroy;
PROCEDURE Load;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
@ -144,8 +144,8 @@ VAR Lib: INTEGER;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/Lib/Proc_lib.obj");
GetProc(sys.ADR(Dialog_init), "OpenDialog_init");
GetProc(sys.ADR(Dialog_start), "OpenDialog_start");
GetProc(Lib, sys.ADR(Dialog_init), "OpenDialog_init");
GetProc(Lib, sys.ADR(Dialog_start), "OpenDialog_start");
END Load;
BEGIN

104
programs/develop/oberon07/Lib/KolibriOS/Out.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -21,11 +21,11 @@ IMPORT ConsoleLib, sys := SYSTEM;
CONST
d = 1.0D0 - 5.0D-12;
d = 1.0 - 5.0E-12;
VAR
Realp: PROCEDURE (x: LONGREAL; width: INTEGER);
Realp: PROCEDURE (x: REAL; width: INTEGER);
PROCEDURE Char*(c: CHAR);
BEGIN
@ -67,7 +67,7 @@ BEGIN
UNTIL i = 0
END WriteInt;
PROCEDURE IsNan(AValue: LONGREAL): BOOLEAN;
PROCEDURE IsNan(AValue: REAL): BOOLEAN;
VAR h, l: SET;
BEGIN
sys.GET(sys.ADR(AValue), l);
@ -75,8 +75,8 @@ BEGIN
RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
PROCEDURE IsInf(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
PROCEDURE IsInf(x: REAL): BOOLEAN;
RETURN ABS(x) = sys.INF()
END IsInf;
PROCEDURE Int*(x, width: INTEGER);
@ -92,15 +92,15 @@ BEGIN
END
END Int;
PROCEDURE OutInf(x: LONGREAL; width: INTEGER);
VAR s: ARRAY 4 OF CHAR; i: INTEGER;
PROCEDURE OutInf(x: REAL; width: INTEGER);
VAR s: ARRAY 5 OF CHAR; i: INTEGER;
BEGIN
IF IsNan(x) THEN
s := "Nan";
INC(width)
ELSIF IsInf(x) & (x > 0.0D0) THEN
ELSIF IsInf(x) & (x > 0.0) THEN
s := "+Inf"
ELSIF IsInf(x) & (x < 0.0D0) THEN
ELSIF IsInf(x) & (x < 0.0) THEN
s := "-Inf"
END;
FOR i := 1 TO width - 4 DO
@ -115,8 +115,8 @@ BEGIN
Char(0AX)
END Ln;
PROCEDURE _FixReal(x: LONGREAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: LONGREAL; minus: BOOLEAN;
PROCEDURE _FixReal(x: REAL; width, p: INTEGER);
VAR e, len, i: INTEGER; y: REAL; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
OutInf(x, width)
@ -125,23 +125,23 @@ BEGIN
ELSE
len := 0;
minus := FALSE;
IF x < 0.0D0 THEN
IF x < 0.0 THEN
minus := TRUE;
INC(len);
x := ABS(x)
END;
e := 0;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
IF e >= 0 THEN
len := len + e + p + 1;
IF x > 9.0D0 + d THEN
INC(len)
IF x > 9.0 + d THEN
INC(len)
END;
IF p > 0 THEN
INC(len)
INC(len)
END
ELSE
len := len + p + 2
@ -153,51 +153,51 @@ BEGIN
Char("-")
END;
y := x;
WHILE (y < 1.0D0) & (y # 0.0D0) DO
y := y * 10.0D0;
WHILE (y < 1.0) & (y # 0.0) DO
y := y * 10.0;
DEC(e)
END;
IF e < 0 THEN
IF x - LONG(FLT(FLOOR(x))) > d THEN
Char("1");
x := 0.0D0
IF x - FLT(FLOOR(x)) > d THEN
Char("1");
x := 0.0
ELSE
Char("0");
x := x * 10.0D0
Char("0");
x := x * 10.0
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)
IF x - FLT(FLOOR(x)) > d THEN
IF x > 9.0 THEN
String("10")
ELSE
Char(CHR(FLOOR(x) + ORD("0") + 1))
END;
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
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
IF x - FLT(FLOOR(x)) > d THEN
Char(CHR(FLOOR(x) + ORD("0") + 1));
x := 0.0
ELSE
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - LONG(FLT(FLOOR(x)))) * 10.0D0
Char(CHR(FLOOR(x) + ORD("0")));
x := (x - FLT(FLOOR(x))) * 10.0
END;
DEC(p)
END
END
END _FixReal;
PROCEDURE Real*(x: LONGREAL; width: INTEGER);
PROCEDURE Real*(x: REAL; width: INTEGER);
VAR e, n, i: INTEGER; minus: BOOLEAN;
BEGIN
IF IsNan(x) OR IsInf(x) THEN
@ -212,22 +212,22 @@ BEGIN
width := 9
END;
width := width - 5;
IF x < 0.0D0 THEN
IF x < 0.0 THEN
x := -x;
minus := TRUE
ELSE
minus := FALSE
END;
WHILE x >= 10.0D0 DO
x := x / 10.0D0;
WHILE x >= 10.0 DO
x := x / 10.0;
INC(e)
END;
WHILE (x < 1.0D0) & (x # 0.0D0) DO
x := x * 10.0D0;
WHILE (x < 1.0) & (x # 0.0) DO
x := x * 10.0;
DEC(e)
END;
IF x > 9.0D0 + d THEN
x := 1.0D0;
IF x > 9.0 + d THEN
x := 1.0;
INC(e)
END;
FOR i := 1 TO n DO
@ -255,7 +255,7 @@ BEGIN
END
END Real;
PROCEDURE FixReal*(x: LONGREAL; width, p: INTEGER);
PROCEDURE FixReal*(x: REAL; width, p: INTEGER);
BEGIN
Realp := Real;
_FixReal(x, width, p)

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

@ -1,276 +1,630 @@
(*
Copyright 2016, 2017 Anton Krotov
(*
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, API;
CONST
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
SIZE_OF_DWORD = 4;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
name: INTEGER;
types: INTEGER;
PROCEDURE [stdcall] _halt*(n: INTEGER);
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]
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
Arr[m + n] := t
END
END _arrayrot;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
PROCEDURE [stdcall] _move* (bytes, source, dest: 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
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 00CH, (* mov esi, dword [ebp + 12] *)
08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall] _move2* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move2;
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, src, dst);
res := TRUE
END
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
BEGIN
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
END _rot;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
END;
IF a < 0 THEN
a := 0
END;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
ELSE
res := 0
END
RETURN res
END _set2;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
END _set;
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
0F7H, 0F9H, (* idiv ecx *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 011H, (* mov dword [ecx], edx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END divmod;
PROCEDURE div_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
DEC(div)
END
RETURN div
END div_;
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
INC(mod, y)
END
RETURN mod
END mod_;
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(a, b)
END _div;
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
RETURN div_(a, b)
END _div2;
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod;
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, SIZE_OF_DWORD)
END
END _new;
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
END
END _dispose;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a);
SYSTEM.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a, 2);
SYSTEM.GET(b, B); INC(b, 2);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _length* (len, str: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
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;
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
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
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H, (* shr eax, 1 *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0
END _lengthw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmp(op, len2, str2, len1, str1)
END _strcmp2;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
END;
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)
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
END StrAppend;
RETURN bRes
END _strcmpw;
PROCEDURE [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmpw(op, len2, str2, len1, str1)
END _strcmpw2;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
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);
API.ExitThread(0)
END _assrt;
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE [stdcall] _close*;
BEGIN
IF CloseProc # NIL THEN
CloseProc
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
BEGIN
IF ~init THEN
API.zeromem(gsize, gadr);
init := TRUE;
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL
END
i := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE [stdcall] _error* (module, err: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err MOD 16 OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
| 4: append(s, "NIL procedure call")
| 5: append(s, "type guard error")
| 6: append(s, "index out of range")
| 7: append(s, "invalid CASE")
| 8: append(s, "array assignment error")
| 9: append(s, "CHR out of range")
|10: append(s, "WCHR out of range")
|11: append(s, "BYTE out of range")
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
BEGIN
(* r IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
BEGIN
(* p IS t0 *)
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
ELSE
t1 := -1
END
RETURN t1 = t0
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
BEGIN
(* r:t1 IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
BEGIN
(* p IS t0 *)
SYSTEM.GET(p, p);
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
ELSE
t1 := t0
END
RETURN t1 = t0
END _guard;
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
res := 0;
IF dll.thread_attach # NIL THEN
dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
res := 0;
IF dll.thread_detach # NIL THEN
dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
res := 0;
IF dll.process_detach # NIL THEN
dll.process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
res := 0
END
RETURN res
END _dllentry;
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
dll.process_detach := process_detach;
dll.thread_detach := thread_detach;
dll.thread_attach := thread_attach
END SetDll;
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := _types;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
END _init;
PROCEDURE SetClose*(proc: PROC);
BEGIN
CloseProc := proc
END SetClose;
END RTL.

60
programs/develop/oberon07/Lib/KolibriOS/RasterWorks.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 KolibriOS team
(*
Copyright 2016, 2018 KolibriOS team
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -24,21 +24,21 @@ CONST
(* flags *)
bold *= 1;
italic *= 2;
underline *= 4;
bold *= 1;
italic *= 2;
underline *= 4;
strike_through *= 8;
align_right *= 16;
align_center *= 32;
align_right *= 16;
align_center *= 32;
bpp32 *= 128;
bpp32 *= 128;
(* encoding *)
cp866 *= 1;
utf16le *= 2;
utf8 *= 3;
cp866 *= 1;
utf16le *= 2;
utf8 *= 3;
VAR
@ -48,19 +48,19 @@ VAR
drawText *: PROCEDURE (canvas, x, y, string, charQuantity, fontColor, params: INTEGER): INTEGER;
(*
[canvas]:
xSize dd ?
ySize dd ?
picture rb xSize * ySize * bpp
xSize dd ?
ySize dd ?
picture rb xSize * ySize * bpp
fontColor dd AARRGGBB
AA = alpha channel ; 0 = transparent, FF = non transparent
fontColor dd AARRGGBB
AA = alpha channel ; 0 = transparent, FF = non transparent
params dd ffeewwhh
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
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
@ -85,10 +85,10 @@ VAR
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
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
@ -101,7 +101,7 @@ END params;
PROCEDURE main;
VAR Lib: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
@ -112,10 +112,10 @@ VAR Lib: INTEGER;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/RasterWorks.obj");
ASSERT(Lib # 0);
GetProc(sys.ADR(drawText), "drawText");
GetProc(sys.ADR(cntUTF_8), "cntUTF-8");
GetProc(sys.ADR(charsFit), "charsFit");
GetProc(sys.ADR(strWidth), "strWidth");
GetProc(Lib, sys.ADR(drawText), "drawText");
GetProc(Lib, sys.ADR(cntUTF_8), "cntUTF-8");
GetProc(Lib, sys.ADR(charsFit), "charsFit");
GetProc(Lib, sys.ADR(strWidth), "strWidth");
END main;

8
programs/develop/oberon07/Lib/KolibriOS/Read.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -31,10 +31,6 @@ 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;

8
programs/develop/oberon07/Lib/KolibriOS/Write.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -31,10 +31,6 @@ 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;

187
programs/develop/oberon07/Lib/KolibriOS/kfonts.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 Anton Krotov
(*
Copyright 2016, 2018 Anton Krotov
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -24,12 +24,12 @@ CONST
MIN_FONT_SIZE = 8;
MAX_FONT_SIZE = 46;
bold *= 1;
italic *= 2;
underline *= 4;
bold *= 1;
italic *= 2;
underline *= 4;
strike_through *= 8;
smoothing *= 16;
bpp32 *= 32;
smoothing *= 16;
bpp32 *= 32;
TYPE
@ -51,7 +51,7 @@ TYPE
PROCEDURE [stdcall] zeromem(size, adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
sys.CODE(057H, 08BH, 07DH, 00CH, 08BH, 04DH, 008H, 033H, 0C0H, 09CH, 0FCH, 0F3H, 0ABH, 09DH, 05FH)
END zeromem;
PROCEDURE pset(buf, x, y, color: INTEGER; bpp32: BOOLEAN);
@ -97,7 +97,6 @@ PROCEDURE rgb(r, g, b: INTEGER): INTEGER;
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;
@ -123,14 +122,14 @@ 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)
(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)
(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
@ -143,9 +142,9 @@ BEGIN
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
FOR k := 0 TO n DO
setpix(Font, dst, i + k, j, dst_xsize, pix)
END
END
END
END
@ -166,20 +165,20 @@ BEGIN
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
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)
x := 0;
INC(y);
eoc := eoc OR (y = Font.height)
END
END
UNTIL eoc;
@ -204,7 +203,7 @@ BEGIN
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)
setpix(Font, glyph.base, i + (Font.height - 1 - j) DIV 3, j, glyph.xsize, pix)
END
END
END;
@ -270,10 +269,10 @@ BEGIN
INC(str);
res := res + Font.glyphs[params, ORD(c)].width;
IF length > 0 THEN
DEC(length)
DEC(length)
END;
IF length # 0 THEN
sys.GET(str, c)
sys.GET(str, c)
END
END
END
@ -318,7 +317,7 @@ PROCEDURE TextOut*(Font: TFont; canvas, x, y, str, length, color, params: INTEGE
VAR width, xsize, ysize, str1, n: INTEGER; c: CHAR; bpp32, smoothing, underline, strike: BOOLEAN;
BEGIN
IF Font # NIL THEN
sys.GET(canvas, xsize);
sys.GET(canvas, xsize);
sys.GET(canvas + 4, ysize);
IF (y <= -TextHeight(Font)) OR (y >= ysize) THEN
length := 0
@ -332,7 +331,7 @@ BEGIN
n := str1 - str;
str := str1;
IF length >= n THEN
length := length - n
length := length - n
END;
sys.GET(str, c)
END;
@ -340,20 +339,20 @@ BEGIN
INC(str);
width := OutChar(Font^, ORD(c), x, y, canvas, bpp32, smoothing, color, params);
IF strike THEN
hline(canvas, x + ORD(1 IN BITS(params)) * ((Font.height DIV 2) DIV 3), y + Font.height DIV 2, width + 2, color, bpp32)
hline(canvas, x + ORD(1 IN BITS(params)) * ((Font.height DIV 2) DIV 3), y + Font.height DIV 2, width + 2, color, bpp32)
END;
IF underline THEN
hline(canvas, x, y + Font.height - 1, width + 2, color, bpp32)
hline(canvas, x, y + Font.height - 1, width + 2, color, bpp32)
END;
x := x + width;
IF x > xsize THEN
length := 0
length := 0
END;
IF length > 0 THEN
DEC(length)
DEC(length)
END;
IF length # 0 THEN
sys.GET(str, c)
sys.GET(str, c)
END
END
END
@ -371,61 +370,61 @@ BEGIN
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 := KOSAPI.sysfunc3(68, 12, memsize);
IF Font.mem # 0 THEN
IF mem # 0 THEN
mem := KOSAPI.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
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 := KOSAPI.sysfunc3(68, 12, memsize);
IF Font.mem # 0 THEN
IF mem # 0 THEN
mem := KOSAPI.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

122
programs/develop/oberon07/Lib/KolibriOS/libimg.ob07
View File

@ -1,5 +1,5 @@
(*
Copyright 2016 KolibriOS team
(*
Copyright 2016, 2018 KolibriOS team
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@ -26,51 +26,51 @@ CONST
FLIP_HORIZONTAL *= 2;
ROTATE_90_CW *= 1;
ROTATE_180 *= 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
// 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
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_NONE *= 0; // use it with LIBIMG_SCALE_INTEGER, LIBIMG_SCALE_TILE, etc
LIBIMG_INTER_BILINEAR *= 1;
LIBIMG_INTER_DEFAULT *= LIBIMG_INTER_BILINEAR;
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;
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;
LIBIMG_ENCODE_DELETE_ALPHA *= 08H;
LIBIMG_ENCODE_FLUSH_ALPHA *= 10H;
// values for Image.Type
@ -80,7 +80,7 @@ CONST
bpp32 *= 3;
bpp15 *= 4;
bpp16 *= 5;
bpp1 *= 6;
bpp1 *= 6;
bpp8g *= 7; // grayscale
bpp2i *= 8;
bpp4i *= 9;
@ -112,7 +112,7 @@ TYPE
ImageDecodeOptions* = RECORD
UsedSize *: INTEGER; // if >=8, the field BackgroundColor is valid, and so on
UsedSize *: INTEGER; // if >=8, the field BackgroundColor is valid, and so on
BackgroundColor *: INTEGER // used for transparent images as background
END;
@ -120,10 +120,10 @@ TYPE
FormatsTableEntry* = RECORD
Format_id *: INTEGER;
Is *: INTEGER;
Decode *: INTEGER;
Encode *: INTEGER;
Format_id *: INTEGER;
Is *: INTEGER;
Decode *: INTEGER;
Encode *: INTEGER;
Capabilities *: INTEGER
END;
@ -131,7 +131,7 @@ TYPE
VAR
img_is_img *: PROCEDURE (data, length: INTEGER): INTEGER;
img_is_img *: PROCEDURE (data, length: INTEGER): INTEGER;
@ -147,7 +147,7 @@ VAR
img_to_rgb *: PROCEDURE (img: INTEGER): INTEGER;
img_to_rgb *: PROCEDURE (img: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes image data into RGB triplets and returns pointer to memory area containing them ;;
@ -160,7 +160,7 @@ VAR
img_decode *: PROCEDURE (data, length, options: INTEGER): INTEGER;
img_decode *: PROCEDURE (data, length, options: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? decodes loaded into memory graphic file ;;
@ -175,7 +175,7 @@ VAR
img_encode *: PROCEDURE (img: INTEGER; common, specific: INTEGER): INTEGER;
img_encode *: PROCEDURE (img: INTEGER; common, specific: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? encode image to some format ;;
@ -203,7 +203,7 @@ VAR
img_create *: PROCEDURE (width, height, type: INTEGER): INTEGER;
img_create *: PROCEDURE (width, height, type: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? creates an Image structure and initializes some its fields ;;
@ -246,7 +246,7 @@ VAR
img_count *: PROCEDURE (img: INTEGER): INTEGER;
img_count *: PROCEDURE (img: INTEGER): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? Get number of images in the list (e.g. in animated GIF file) ;;
@ -259,7 +259,7 @@ VAR
img_flip *: PROCEDURE (img: INTEGER; flip_kind: INTEGER): BOOLEAN;
img_flip *: PROCEDURE (img: INTEGER; flip_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Flip all layers of image ;;
@ -287,7 +287,7 @@ VAR
img_rotate *: PROCEDURE (img: INTEGER; rotate_kind: INTEGER): BOOLEAN;
img_rotate *: PROCEDURE (img: INTEGER; rotate_kind: INTEGER): BOOLEAN;
(*
;;------------------------------------------------------------------------------------------------;;
;? Rotate all layers of image ;;
@ -315,7 +315,7 @@ VAR
img_draw *: PROCEDURE (img: INTEGER; x, y, width, height, xpos, ypos: INTEGER);
img_draw *: PROCEDURE (img: INTEGER; x, y, width, height, xpos, ypos: INTEGER);
(*
;;------------------------------------------------------------------------------------------------;;
;? Draw image in the window ;;
@ -332,7 +332,7 @@ VAR
img_scale *: PROCEDURE (src: INTEGER; crop_x, crop_y, crop_width, crop_height: INTEGER; dst: INTEGER; scale, inter, param1, param2: INTEGER ): INTEGER;
img_scale *: PROCEDURE (src: INTEGER; crop_x, crop_y, crop_width, crop_height: INTEGER; dst: INTEGER; scale, inter, param1, param2: INTEGER ): INTEGER;
(*
;;------------------------------------------------------------------------------------------------;;
;? scale _image ;;
@ -398,7 +398,7 @@ END GetFormatsTable;
PROCEDURE main;
VAR Lib, formats_table_ptr: INTEGER;
PROCEDURE GetProc(v: INTEGER; name: ARRAY OF CHAR);
PROCEDURE GetProc(Lib, v: INTEGER; name: ARRAY OF CHAR);
VAR a: INTEGER;
BEGIN
a := KOSAPI.GetProcAdr(name, Lib);
@ -409,23 +409,23 @@ VAR Lib, formats_table_ptr: INTEGER;
BEGIN
Lib := KOSAPI.LoadLib("/rd/1/lib/libimg.obj");
ASSERT(Lib # 0);
GetProc(sys.ADR(img_is_img) , "img_is_img");
GetProc(sys.ADR(img_to_rgb) , "img_to_rgb");
GetProc(sys.ADR(img_to_rgb2) , "img_to_rgb2");
GetProc(sys.ADR(img_decode) , "img_decode");
GetProc(sys.ADR(img_encode) , "img_encode");
GetProc(sys.ADR(img_create) , "img_create");
GetProc(sys.ADR(img_destroy) , "img_destroy");
GetProc(sys.ADR(img_destroy_layer) , "img_destroy_layer");
GetProc(sys.ADR(img_count) , "img_count");
GetProc(sys.ADR(img_flip) , "img_flip");
GetProc(sys.ADR(img_flip_layer) , "img_flip_layer");
GetProc(sys.ADR(img_rotate) , "img_rotate");
GetProc(sys.ADR(img_rotate_layer) , "img_rotate_layer");
GetProc(sys.ADR(img_draw) , "img_draw");
GetProc(sys.ADR(img_scale) , "img_scale");
GetProc(sys.ADR(img_convert) , "img_convert");
GetProc(sys.ADR(formats_table_ptr) , "img_formats_table");
GetProc(Lib, sys.ADR(img_is_img) , "img_is_img");
GetProc(Lib, sys.ADR(img_to_rgb) , "img_to_rgb");
GetProc(Lib, sys.ADR(img_to_rgb2) , "img_to_rgb2");
GetProc(Lib, sys.ADR(img_decode) , "img_decode");
GetProc(Lib, sys.ADR(img_encode) , "img_encode");
GetProc(Lib, sys.ADR(img_create) , "img_create");
GetProc(Lib, sys.ADR(img_destroy) , "img_destroy");
GetProc(Lib, sys.ADR(img_destroy_layer) , "img_destroy_layer");
GetProc(Lib, sys.ADR(img_count) , "img_count");
GetProc(Lib, sys.ADR(img_flip) , "img_flip");
GetProc(Lib, sys.ADR(img_flip_layer) , "img_flip_layer");
GetProc(Lib, sys.ADR(img_rotate) , "img_rotate");
GetProc(Lib, sys.ADR(img_rotate_layer) , "img_rotate_layer");
GetProc(Lib, sys.ADR(img_draw) , "img_draw");
GetProc(Lib, sys.ADR(img_scale) , "img_scale");
GetProc(Lib, sys.ADR(img_convert) , "img_convert");
GetProc(Lib, sys.ADR(formats_table_ptr) , "img_formats_table");
GetFormatsTable(formats_table_ptr)
END main;

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

@ -1,148 +1,145 @@
(*
Copyright 2016 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
CONST
BASE_ADR = 08048000H;
TYPE
TP* = ARRAY 2 OF INTEGER;
TP* = ARRAY 2 OF INTEGER;
VAR
Param*: INTEGER;
eol*: ARRAY 2 OF CHAR;
base*, MainParam*: 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;
libc*, librt*: INTEGER;
dlopen* : PROCEDURE [linux] (filename, flag: INTEGER): INTEGER;
dlsym* : PROCEDURE [linux] (handle, symbol: INTEGER): INTEGER;
stdout*,
stdin*,
stderr* : INTEGER;
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
_exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
PROCEDURE putc* (c: CHAR);
VAR
res: INTEGER;
PROCEDURE [stdcall] zeromem* (size, adr: INTEGER);
BEGIN
sys.CODE("578B7D0C8B4D0833C09CFCF3AB9D5F")
END zeromem;
res := fwrite(SYSTEM.ADR(c), 1, 1, stdout)
END putc;
PROCEDURE Align(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
PROCEDURE malloc* (Bytes: INTEGER): INTEGER;
VAR res: INTEGER;
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);
puts(lpCaption);
puts(lpText)
END DebugMsg;
PROCEDURE ExitProcess* (code: INTEGER);
PROCEDURE _NEW* (size: INTEGER): INTEGER;
VAR
res, ptr, words: INTEGER;
BEGIN
exit(code)
END ExitProcess;
res := malloc(size);
IF res # 0 THEN
ptr := res;
words := size DIV SYSTEM.SIZE(INTEGER);
WHILE words > 0 DO
SYSTEM.PUT(ptr, 0);
INC(ptr, SYSTEM.SIZE(INTEGER));
DEC(words)
END
END
PROCEDURE ExitThread* (code: INTEGER);
RETURN res
END _NEW;
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
BEGIN
exit(code)
END ExitThread;
free(p)
RETURN 0
END _DISPOSE;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
VAR H: INTEGER;
PROCEDURE GetProcAdr (lib: INTEGER; name: ARRAY OF CHAR; VarAdr: INTEGER);
VAR
sym: INTEGER;
BEGIN
H := dlsym(hMOD, sys.ADR(name[0]));
ASSERT(H # 0);
sys.PUT(adr, H);
END GetProc;
sym := dlsym(lib, SYSTEM.ADR(name[0]));
ASSERT(sym # 0);
SYSTEM.PUT(VarAdr, sym)
END GetProcAdr;
PROCEDURE init* (esp: INTEGER);
VAR lib, proc: INTEGER;
PROCEDURE init* (sp, code: INTEGER);
BEGIN
Param := esp;
sys.MOVE(Param + 12, sys.ADR(dlopen), 4);
sys.MOVE(Param + 16, sys.ADR(dlsym), 4);
sys.MOVE(Param + 20, sys.ADR(exit), 4);
sys.MOVE(Param + 24, sys.ADR(stdin), 4);
sys.MOVE(Param + 28, sys.ADR(stdout), 4);
sys.MOVE(Param + 32, sys.ADR(stderr), 4);
sys.MOVE(Param + 36, sys.ADR(_malloc), 4);
sys.MOVE(Param + 40, sys.ADR(free), 4);
sys.MOVE(Param + 44, sys.ADR(fopen), 4);
sys.MOVE(Param + 48, sys.ADR(fclose), 4);
sys.MOVE(Param + 52, sys.ADR(fwrite), 4);
sys.MOVE(Param + 56, sys.ADR(fread), 4);
sys.MOVE(Param + 60, sys.ADR(fseek), 4);
sys.MOVE(Param + 64, sys.ADR(ftell), 4);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER) * 2, dlopen);
SYSTEM.GET(code - 1000H - SYSTEM.SIZE(INTEGER), dlsym);
MainParam := sp;
base := BASE_ADR;
eol := 0AX;
lib := dlopen(sys.ADR("libc.so.6"), 1);
ASSERT(lib # 0);
GetProc("strncmp", lib, sys.ADR(strncmp));
GetProc("strlen", lib, sys.ADR(strlen));
libc := dlopen(SYSTEM.SADR("libc.so.6"), 1);
GetProcAdr(libc, "malloc", SYSTEM.ADR(malloc));
GetProcAdr(libc, "free", SYSTEM.ADR(free));
GetProcAdr(libc, "exit", SYSTEM.ADR(_exit));
GetProcAdr(libc, "stdout", SYSTEM.ADR(stdout));
GetProcAdr(libc, "stdin", SYSTEM.ADR(stdin));
GetProcAdr(libc, "stderr", SYSTEM.ADR(stderr));
SYSTEM.GET(stdout - SYSTEM.SIZE(INTEGER), stdout);
SYSTEM.GET(stdin - SYSTEM.SIZE(INTEGER), stdin);
SYSTEM.GET(stderr - SYSTEM.SIZE(INTEGER), stderr);
GetProcAdr(libc, "puts", SYSTEM.ADR(puts));
GetProcAdr(libc, "fwrite", SYSTEM.ADR(fwrite));
GetProcAdr(libc, "fread", SYSTEM.ADR(fread));
GetProcAdr(libc, "fopen", SYSTEM.ADR(fopen));
GetProcAdr(libc, "fclose", SYSTEM.ADR(fclose));
GetProcAdr(libc, "time", SYSTEM.ADR(time));
lib := dlopen(sys.ADR("librt.so.1"), 1);
ASSERT(lib # 0);
GetProc("clock_gettime", lib, sys.ADR(clock_gettime));
librt := dlopen(SYSTEM.SADR("librt.so.1"), 1);
GetProcAdr(librt, "clock_gettime", SYSTEM.ADR(clock_gettime))
END init;
PROCEDURE exit* (code: INTEGER);
BEGIN
_exit(code)
END exit;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
_exit(code)
END exit_thread;
END API.

251
programs/develop/oberon07/Lib/Linux32/HOST.ob07
View File

@ -1,121 +1,178 @@
(*
Copyright 2016 Anton Krotov
(*
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, API, RTL;
CONST
OS* = "LNX";
Slash* = "/";
slash* = "/";
OS* = "LINUX";
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
VAR
fsize : INTEGER;
argc: INTEGER;
sec* : INTEGER;
dsec* : INTEGER;
eol*: ARRAY 2 OF CHAR;
PROCEDURE GetCommandLine* (): INTEGER;
RETURN API.Param
END GetCommandLine;
PROCEDURE CloseFile* (File: INTEGER);
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)
API.exit(code)
END ExitProcess;
PROCEDURE Time* (VAR sec, dsec: INTEGER);
VAR tp: API.TP;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
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;
i := 0;
len := LEN(s) - 1;
IF (n < argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
PROCEDURE init*;
BEGIN
Time(sec, dsec)
END init;
GetArg(0, path);
n := LENGTH(path) - 1;
WHILE path[n] # slash DO
DEC(n)
END;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE GetName*(): INTEGER;
RETURN 0
END GetName;
PROCEDURE ReadFile (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN API.fread(SYSTEM.ADR(Buffer[0]), 1, bytes, F)
END ReadFile;
PROCEDURE WriteFile (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN API.fwrite(SYSTEM.ADR(Buffer[0]), 1, bytes, F)
END WriteFile;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := ReadFile(F, Buffer, bytes);
IF res <= 0 THEN
res := -1
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
res := WriteFile(F, Buffer, bytes);
IF res <= 0 THEN
res := -1
END
RETURN res
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("wb"))
END FileCreate;
PROCEDURE FileClose* (File: INTEGER);
BEGIN
File := API.fclose(File)
END FileClose;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN API.fopen(SYSTEM.ADR(FName[0]), SYSTEM.SADR("rb"))
END FileOpen;
PROCEDURE OutChar* (c: CHAR);
BEGIN
API.putc(c)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
VAR
tp: API.TP;
res: INTEGER;
BEGIN
IF API.clock_gettime(0, tp) = 0 THEN
res := tp[0] * 100 + tp[1] DIV 10000000
ELSE
res := 0
END
RETURN res
END GetTickCount;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN path[0] # slash
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN API.time(0)
END UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
BEGIN
eol := 0AX;
SYSTEM.GET(API.MainParam, argc)
END HOST.

141
programs/develop/oberon07/Lib/Linux32/LINAPI.ob07 Normal file
View File

@ -0,0 +1,141 @@
(*
BSD 2-Clause License
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE LINAPI;
IMPORT SYSTEM, API;
TYPE
TP* = API.TP;
VAR
argc*, envc*: INTEGER;
libc*, librt*: INTEGER;
stdout*,
stdin*,
stderr* : INTEGER;
malloc* : PROCEDURE [linux] (size: INTEGER): INTEGER;
free* : PROCEDURE [linux] (ptr: INTEGER);
exit* : PROCEDURE [linux] (code: INTEGER);
puts* : PROCEDURE [linux] (pStr: INTEGER);
fwrite*,
fread* : PROCEDURE [linux] (buffer, bytes, blocks, file: INTEGER): INTEGER;
fopen* : PROCEDURE [linux] (fname, fmode: INTEGER): INTEGER;
fclose* : PROCEDURE [linux] (file: INTEGER): INTEGER;
time* : PROCEDURE [linux] (ptr: INTEGER): INTEGER;
clock_gettime* : PROCEDURE [linux] (clock_id: INTEGER; VAR tp: TP): INTEGER;
PROCEDURE dlopen* (filename: ARRAY OF CHAR): INTEGER;
RETURN API.dlopen(SYSTEM.ADR(filename[0]), 1)
END dlopen;
PROCEDURE dlsym* (handle: INTEGER; symbol: ARRAY OF CHAR): INTEGER;
RETURN API.dlsym(handle, SYSTEM.ADR(symbol[0]))
END dlsym;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, len, ptr: INTEGER;
c: CHAR;
BEGIN
i := 0;
len := LEN(s) - 1;
IF (0 <= n) & (n <= argc + envc) & (n # argc) & (len > 0) THEN
SYSTEM.GET(API.MainParam + (n + 1) * SYSTEM.SIZE(INTEGER), ptr);
REPEAT
SYSTEM.GET(ptr, c);
s[i] := c;
INC(i);
INC(ptr)
UNTIL (c = 0X) OR (i = len)
END;
s[i] := 0X
END GetArg;
PROCEDURE GetEnv* (n: INTEGER; VAR s: ARRAY OF CHAR);
BEGIN
IF (0 <= n) & (n < envc) THEN
GetArg(n + argc + 1, s)
ELSE
s[0] := 0X
END
END GetEnv;
PROCEDURE init;
VAR
ptr: INTEGER;
BEGIN
envc := -1;
SYSTEM.GET(API.MainParam, argc);
REPEAT
SYSTEM.GET(API.MainParam + (envc + argc + 3) * SYSTEM.SIZE(INTEGER), ptr);
INC(envc)
UNTIL ptr = 0;
libc := API.libc;
stdout := API.stdout;
stdin := API.stdin;
stderr := API.stderr;
malloc := API.malloc;
free := API.free;
exit := API._exit;
puts := API.puts;
fwrite := API.fwrite;
fread := API.fread;
fopen := API.fopen;
fclose := API.fclose;
time := API.time;
librt := API.librt;
clock_gettime := API.clock_gettime
END init;
PROCEDURE [stdcall-] syscall* (eax, ebx, ecx, edx, esi, edi: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
053H, (* push ebx *)
056H, (* push esi *)
057H, (* push edi *)
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 05DH, 00CH, (* mov ebx, dword [ebp + 12] *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
08BH, 055H, 014H, (* mov edx, dword [ebp + 20] *)
08BH, 075H, 018H, (* mov esi, dword [ebp + 24] *)
08BH, 07DH, 01CH, (* mov edi, dword [ebp + 28] *)
0CDH, 080H, (* int 128 *)
05FH, (* pop edi *)
05EH, (* pop esi *)
05BH, (* pop ebx *)
0C9H, (* leave *)
0C2H, 018H, 000H (* ret 24 *)
)
RETURN 0
END syscall;
BEGIN
init
END LINAPI.

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

@ -1,276 +1,630 @@
(*
Copyright 2016, 2017 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, API;
CONST
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
SIZE_OF_DWORD = 4;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
name: INTEGER;
types: INTEGER;
PROCEDURE [stdcall] _halt*(n: INTEGER);
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]
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
Arr[m + n] := t
END
END _arrayrot;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
PROCEDURE [stdcall] _move* (bytes, source, dest: 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
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 00CH, (* mov esi, dword [ebp + 12] *)
08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall] _move2* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move2;
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, src, dst);
res := TRUE
END
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
BEGIN
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
END _rot;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
END;
IF a < 0 THEN
a := 0
END;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
ELSE
res := 0
END
RETURN res
END _set2;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
END _set;
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
0F7H, 0F9H, (* idiv ecx *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 011H, (* mov dword [ecx], edx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END divmod;
PROCEDURE div_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
DEC(div)
END
RETURN div
END div_;
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
INC(mod, y)
END
RETURN mod
END mod_;
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(a, b)
END _div;
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
RETURN div_(a, b)
END _div2;
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod;
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, SIZE_OF_DWORD)
END
END _new;
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
END
END _dispose;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a);
SYSTEM.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a, 2);
SYSTEM.GET(b, B); INC(b, 2);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _length* (len, str: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
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;
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
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
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H, (* shr eax, 1 *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0
END _lengthw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmp(op, len2, str2, len1, str1)
END _strcmp2;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
END;
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)
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
END StrAppend;
RETURN bRes
END _strcmpw;
PROCEDURE [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmpw(op, len2, str2, len1, str1)
END _strcmpw2;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
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);
API.ExitThread(0)
END _assrt;
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE [stdcall] _close*;
BEGIN
IF CloseProc # NIL THEN
CloseProc
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
BEGIN
IF ~init THEN
API.zeromem(gsize, gadr);
init := TRUE;
API.init(esp);
SelfName := self;
rtab := rec;
CloseProc := NIL
END
i := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE [stdcall] _error* (module, err: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err MOD 16 OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
| 4: append(s, "NIL procedure call")
| 5: append(s, "type guard error")
| 6: append(s, "index out of range")
| 7: append(s, "invalid CASE")
| 8: append(s, "array assignment error")
| 9: append(s, "CHR out of range")
|10: append(s, "WCHR out of range")
|11: append(s, "BYTE out of range")
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
BEGIN
(* r IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
BEGIN
(* p IS t0 *)
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
ELSE
t1 := -1
END
RETURN t1 = t0
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
BEGIN
(* r:t1 IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
BEGIN
(* p IS t0 *)
SYSTEM.GET(p, p);
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
ELSE
t1 := t0
END
RETURN t1 = t0
END _guard;
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
res := 0;
IF dll.thread_attach # NIL THEN
dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
res := 0;
IF dll.thread_detach # NIL THEN
dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
res := 0;
IF dll.process_detach # NIL THEN
dll.process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
res := 0
END
RETURN res
END _dllentry;
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
dll.process_detach := process_detach;
dll.thread_detach := thread_detach;
dll.thread_attach := thread_attach
END SetDll;
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := _types;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
END _init;
PROCEDURE SetClose*(proc: PROC);
BEGIN
CloseProc := proc
END SetClose;
END RTL.

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

@ -1,79 +1,61 @@
(*
Copyright 2016, 2017 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE API;
IMPORT sys := SYSTEM;
IMPORT SYSTEM;
VAR
Alloc*: PROCEDURE [winapi] (uFlags, dwBytes: INTEGER): INTEGER;
Free*: PROCEDURE [winapi] (hMem: INTEGER): INTEGER;
MessageBoxA*: PROCEDURE [winapi] (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
ExitThread*: PROCEDURE [winapi] (code: INTEGER);
GetCurrentThreadId*: PROCEDURE [winapi] (): INTEGER;
strncmp*: PROCEDURE [cdecl] (a, b, n: INTEGER): INTEGER;
eol*: ARRAY 3 OF CHAR;
base*: INTEGER;
GetProcAddress*: PROCEDURE [winapi] (hModule, name: INTEGER): INTEGER;
LoadLibraryA*: PROCEDURE [winapi] (name: INTEGER): INTEGER;
PROCEDURE zeromem*(size, adr: INTEGER);
END zeromem;
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"] ExitProcess (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "ExitThread"] ExitThread (code: INTEGER);
PROCEDURE [windows-, "kernel32.dll", "GlobalAlloc"] Alloc (uFlags, dwBytes: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GlobalFree"] Free (hMem: INTEGER): INTEGER;
PROCEDURE DebugMsg*(lpText, lpCaption: INTEGER);
PROCEDURE [windows-, "user32.dll", "MessageBoxA"] MessageBoxA (hWnd, lpText, lpCaption, uType: INTEGER): INTEGER;
PROCEDURE DebugMsg* (lpText, lpCaption: INTEGER);
BEGIN
MessageBoxA(0, lpText, lpCaption, 16)
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)
PROCEDURE _NEW* (size: INTEGER): INTEGER;
RETURN Alloc(64, size)
END _NEW;
PROCEDURE _DISPOSE*(p: INTEGER): INTEGER;
RETURN Free(p)
PROCEDURE _DISPOSE* (p: INTEGER): INTEGER;
RETURN Free(p)
END _DISPOSE;
PROCEDURE init* (esp: INTEGER);
VAR lib: INTEGER;
PROCEDURE init* (reserved, code: INTEGER);
BEGIN
sys.GET(esp, GetProcAddress);
sys.GET(esp + 4, LoadLibraryA);
lib := LoadLibraryA(sys.ADR("kernel32.dll"));
GetProc("ExitProcess", lib, sys.ADR(ExitProcess));
GetProc("ExitThread", lib, sys.ADR(ExitThread));
GetProc("GetCurrentThreadId", lib, sys.ADR(GetCurrentThreadId));
GetProc("GlobalAlloc", lib, sys.ADR(Alloc));
GetProc("GlobalFree", lib, sys.ADR(Free));
lib := LoadLibraryA(sys.ADR("msvcrt.dll"));
GetProc("strncmp", lib, sys.ADR(strncmp));
lib := LoadLibraryA(sys.ADR("user32.dll"));
GetProc("MessageBoxA", lib, sys.ADR(MessageBoxA));
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
base := code - 4096
END init;
END API.
PROCEDURE exit* (code: INTEGER);
BEGIN
ExitProcess(code)
END exit;
PROCEDURE exit_thread* (code: INTEGER);
BEGIN
ExitThread(code)
END exit_thread;
END API.

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

@ -1,139 +1,331 @@
(*
Copyright 2016, 2017 Anton Krotov
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE HOST;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, RTL;
CONST
OS* = "WIN";
Slash* = "\";
slash* = "\";
OS* = "WINDOWS";
bit_depth* = RTL.bit_depth;
maxint* = RTL.maxint;
minint* = RTL.minint;
MAX_PARAM = 1024;
OFS_MAXPATHNAME = 128;
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;
POverlapped = POINTER TO OVERLAPPED;
OVERLAPPED = RECORD
Internal: INTEGER;
InternalHigh: INTEGER;
Offset: INTEGER;
OffsetHigh: INTEGER;
hEvent: INTEGER
END;
OFSTRUCT = RECORD
cBytes: CHAR;
fFixedDisk: CHAR;
nErrCode: SYSTEM.CARD16;
Reserved1: SYSTEM.CARD16;
Reserved2: SYSTEM.CARD16;
szPathName: ARRAY OFS_MAXPATHNAME OF CHAR
END;
PSecurityAttributes = POINTER TO TSecurityAttributes;
TSecurityAttributes = RECORD
nLength: INTEGER;
lpSecurityDescriptor: INTEGER;
bInheritHandle: INTEGER
END;
TSystemTime = RECORD
Year,
Month,
DayOfWeek,
Day,
Hour,
Min,
Sec,
MSec: WCHAR
END;
VAR
sec*, dsec*, hConsoleOutput: INTEGER;
hConsoleOutput: INTEGER;
GetStdHandle: PROCEDURE [winapi] (nStdHandle: INTEGER): INTEGER;
CloseFile*: PROCEDURE [winapi] (hObject: INTEGER): INTEGER;
_CreateFile*: PROCEDURE [winapi] (lpFileName, dwDesiredAccess, dwShareMode, lpSecurityAttributes,
dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: INTEGER): INTEGER;
_OpenFile*: PROCEDURE [winapi] (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
ReadFile, WriteFile: PROCEDURE [winapi] (hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, lpOverlapped: INTEGER): INTEGER;
GetCommandLine*: PROCEDURE [winapi] (): INTEGER;
GetTickCount: PROCEDURE [winapi] (): INTEGER;
ExitProcess*: PROCEDURE [winapi] (code: INTEGER);
SetFilePointer: PROCEDURE [winapi] (hFile, lDistanceToMove, lpDistanceToMoveHigh, dwMoveMethod: INTEGER): INTEGER;
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
argc: INTEGER;
PROCEDURE FileRW*(hFile, Buffer, nNumberOfBytes: INTEGER; write: BOOLEAN): INTEGER;
VAR res: INTEGER;
eol*: ARRAY 3 OF CHAR;
PROCEDURE [windows-, "kernel32.dll", "GetTickCount"]
_GetTickCount (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetStdHandle"]
_GetStdHandle (nStdHandle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCommandLineA"]
_GetCommandLine (): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "ReadFile"]
_ReadFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "WriteFile"]
_WriteFile (hFile, Buffer, nNumberOfBytesToRW: INTEGER; VAR NumberOfBytesRW: INTEGER; lpOverlapped: POverlapped): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CloseHandle"]
_CloseHandle (hObject: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "CreateFileA"]
_CreateFile (
lpFileName, dwDesiredAccess, dwShareMode: INTEGER;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition, dwFlagsAndAttributes,
hTemplateFile: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "OpenFile"]
_OpenFile (lpFileName: INTEGER; lpReOpenBuff: OFSTRUCT; uStyle: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetCurrentDirectoryA"]
_GetCurrentDirectory (nBufferLength, lpBuffer: INTEGER): INTEGER;
PROCEDURE [windows-, "kernel32.dll", "GetSystemTime"]
_GetSystemTime (T: TSystemTime);
PROCEDURE [windows-, "kernel32.dll", "ExitProcess"]
_ExitProcess (code: INTEGER);
PROCEDURE ExitProcess* (code: INTEGER);
BEGIN
IF write THEN
WriteFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0)
ELSE
ReadFile(hFile, Buffer, nNumberOfBytes, sys.ADR(res), 0)
END
RETURN res
END FileRW;
_ExitProcess(code)
END ExitProcess;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
VAR
n: INTEGER;
PROCEDURE OutString* (str: ARRAY OF CHAR);
VAR res: INTEGER;
BEGIN
res := FileRW(hConsoleOutput, sys.ADR(str[0]), LENGTH(str), TRUE)
END OutString;
n := _GetCurrentDirectory(LEN(path), SYSTEM.ADR(path[0]));
path[n] := slash;
path[n + 1] := 0X
END GetCurrentDirectory;
PROCEDURE GetChar (adr: INTEGER): CHAR;
VAR
res: CHAR;
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;
SYSTEM.GET(adr, res)
RETURN res
END GetChar;
PROCEDURE ParamParse;
VAR
p, count, cond: INTEGER;
c: CHAR;
PROCEDURE ChangeCond (A, B, C: INTEGER; VAR cond: INTEGER; c: CHAR);
BEGIN
IF (c <= 20X) & (c # 0X) THEN
cond := A
ELSIF c = 22X THEN
cond := B
ELSIF c = 0X THEN
cond := 6
ELSE
cond := C
END
END ChangeCond;
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;
p := _GetCommandLine();
cond := 0;
count := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1, cond, c); IF cond = 1 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1, cond, c); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3: ChangeCond(3, 1, 3, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|4: ChangeCond(5, 0, 5, cond, c); IF cond = 5 THEN Params[count, 0] := p END
|5: ChangeCond(5, 1, 5, cond, c); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
|6:
END;
INC(p)
END;
argc := count
END ParamParse;
PROCEDURE GetArg* (n: INTEGER; VAR s: ARRAY OF CHAR);
VAR
i, j, len: INTEGER;
c: CHAR;
PROCEDURE FileSize*(F: INTEGER): INTEGER;
VAR res: INTEGER;
BEGIN
res := SetFilePointer(F, 0, 0, 2);
SetFilePointer(F, 0, 0, 0)
RETURN res
END FileSize;
j := 0;
IF n < argc THEN
len := LEN(s) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
s[j] := c;
INC(j)
END;
INC(i)
END
END;
s[j] := 0X
END GetArg;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
PROCEDURE GetProc(name: ARRAY OF CHAR; hMOD, adr: INTEGER);
BEGIN
sys.PUT(adr, API.GetProcAddress(hMOD, sys.ADR(name[0])))
END GetProc;
IF _ReadFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
res := -1
ELSE
res := n
END
RETURN res
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res, n: INTEGER;
PROCEDURE Time*(VAR sec, dsec: INTEGER);
VAR t: INTEGER;
BEGIN
t := GetTickCount() DIV 10;
sec := t DIV 100;
dsec := t MOD 100
END Time;
IF _WriteFile(F, SYSTEM.ADR(Buffer[0]), bytes, n, NIL) = 0 THEN
res := -1
ELSE
res := n
END
PROCEDURE malloc*(size: INTEGER): INTEGER;
RETURN API.Alloc(64, size)
END malloc;
RETURN res
END FileWrite;
PROCEDURE init*;
VAR lib: INTEGER;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN _CreateFile(SYSTEM.ADR(FName[0]), 0C0000000H, 0, NIL, 2, 80H, 0)
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
lib := API.LoadLibraryA(sys.ADR("kernel32.dll"));
GetProc("GetTickCount", lib, sys.ADR(GetTickCount));
Time(sec, dsec);
GetProc("GetStdHandle", lib, sys.ADR(GetStdHandle));
GetProc("CreateFileA", lib, sys.ADR(_CreateFile));
GetProc("CloseHandle", lib, sys.ADR(CloseFile));
GetProc("OpenFile", lib, sys.ADR(_OpenFile));
GetProc("ReadFile", lib, sys.ADR(ReadFile));
GetProc("WriteFile", lib, sys.ADR(WriteFile));
GetProc("GetCommandLineA", lib, sys.ADR(GetCommandLine));
GetProc("SetFilePointer", lib, sys.ADR(SetFilePointer));
ExitProcess := API.ExitProcess;
hConsoleOutput := GetStdHandle(-11)
END init;
_CloseHandle(F)
END FileClose;
PROCEDURE GetName*(): INTEGER;
RETURN 0
END GetName;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
VAR
ofstr: OFSTRUCT;
res: INTEGER;
BEGIN
res := _OpenFile(SYSTEM.ADR(FName[0]), ofstr, 0);
IF res = 0FFFFFFFFH THEN
res := -1
END
RETURN res
END FileOpen;
PROCEDURE OutChar* (c: CHAR);
VAR
count: INTEGER;
BEGIN
_WriteFile(hConsoleOutput, SYSTEM.ADR(c), 1, count, NIL)
END OutChar;
PROCEDURE GetTickCount* (): INTEGER;
RETURN _GetTickCount() DIV 10
END GetTickCount;
PROCEDURE letter (c: CHAR): BOOLEAN;
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z")
END letter;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN ~(letter(path[0]) & (path[1] = ":"))
END isRelative;
PROCEDURE now* (VAR year, month, day, hour, min, sec: INTEGER);
VAR
T: TSystemTime;
BEGIN
_GetSystemTime(T);
year := ORD(T.Year);
month := ORD(T.Month);
day := ORD(T.Day);
hour := ORD(T.Hour);
min := ORD(T.Min);
sec := ORD(T.Sec)
END now;
PROCEDURE UnixTime* (): INTEGER;
RETURN 0
END UnixTime;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
a := 0;
b := 0;
SYSTEM.MOVE(SYSTEM.ADR(x), SYSTEM.ADR(a), 4);
SYSTEM.MOVE(SYSTEM.ADR(x) + 4, SYSTEM.ADR(b), 4);
SYSTEM.GET(SYSTEM.ADR(x), res)
RETURN res
END splitf;
BEGIN
eol[0] := 0DX; eol[1] := 0AX; eol[2] := 0X;
hConsoleOutput := _GetStdHandle(-11);
ParamParse
END HOST.

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

@ -1,282 +1,630 @@
(*
Copyright 2016, 2017 Anton Krotov
(*
BSD 2-Clause License
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE RTL;
IMPORT sys := SYSTEM, API;
IMPORT SYSTEM, API;
CONST
bit_depth* = 32;
maxint* = 7FFFFFFFH;
minint* = 80000000H;
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_THREAD_DETACH = 3;
DLL_PROCESS_DETACH = 0;
SIZE_OF_DWORD = 4;
TYPE
IntArray = ARRAY 2048 OF INTEGER;
STRING = ARRAY 2048 OF CHAR;
PROC = PROCEDURE;
DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
VAR
SelfName, rtab: INTEGER; CloseProc: PROC;
init: BOOLEAN;
main_thread_id: INTEGER;
name: INTEGER;
types: INTEGER;
PROCEDURE [stdcall] _halt*(n: INTEGER);
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]
dll: RECORD
process_detach,
thread_detach,
thread_attach: DLL_ENTRY
END;
Arr[m + n] := t
END
END _arrayrot;
PROCEDURE [stdcall] _length*(s: ARRAY OF CHAR): INTEGER;
PROCEDURE [stdcall] _move* (bytes, source, dest: 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
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 00CH, (* mov esi, dword [ebp + 12] *)
08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move;
PROCEDURE [stdcall] _move2* (bytes, dest, source: INTEGER);
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
085H, 0C0H, (* test eax, eax *)
07EH, 019H, (* jle L *)
0FCH, (* cld *)
057H, (* push edi *)
056H, (* push esi *)
08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
089H, 0C1H, (* mov ecx, eax *)
0C1H, 0E9H, 002H, (* shr ecx, 2 *)
0F3H, 0A5H, (* rep movsd *)
089H, 0C1H, (* mov ecx, eax *)
083H, 0E1H, 003H, (* and ecx, 3 *)
0F3H, 0A4H, (* rep movsb *)
05EH, (* pop esi *)
05FH (* pop edi *)
(* L: *)
)
END _move2;
PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF len_src > len_dst THEN
res := FALSE
ELSE
_move(len_src * base_size, src, dst);
res := TRUE
END
RETURN res
END _arrcpy;
PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy;
PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
BEGIN
_move(MIN(len_dst, len_src) * chr_size, src, dst)
END _strcpy2;
PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
VAR
i, n, k: INTEGER;
BEGIN
k := LEN(A) - 1;
n := A[0];
i := 0;
WHILE i < k DO
A[i] := A[i + 1];
INC(i)
END;
A[k] := n
END _rot;
PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF (a <= b) & (a <= 31) & (b >= 0) THEN
IF b > 31 THEN
b := 31
END;
IF a < 0 THEN
a := 0
END;
res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
ELSE
res := 0
END
RETURN res
END _set2;
PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
RETURN _set2(a, b)
END _set;
PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
031H, 0D2H, (* xor edx, edx *)
085H, 0C0H, (* test eax, eax *)
07DH, 002H, (* jge L1 *)
0F7H, 0D2H, (* not edx *)
(* L1: *)
0F7H, 0F9H, (* idiv ecx *)
08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
089H, 011H, (* mov dword [ecx], edx *)
0C9H, (* leave *)
0C2H, 00CH, 000H (* ret 12 *)
)
RETURN 0
END divmod;
PROCEDURE div_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
DEC(div)
END
RETURN div
END div_;
PROCEDURE mod_ (x, y: INTEGER): INTEGER;
VAR
div, mod: INTEGER;
BEGIN
div := divmod(x, y, mod);
IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
INC(mod, y)
END
RETURN mod
END mod_;
PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
RETURN div_(a, b)
END _div;
PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
RETURN div_(a, b)
END _div2;
PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod;
PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
RETURN mod_(a, b)
END _mod2;
PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
BEGIN
ptr := API._NEW(size);
IF ptr # 0 THEN
SYSTEM.PUT(ptr, t);
INC(ptr, SIZE_OF_DWORD)
END
END _new;
PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
BEGIN
IF ptr # 0 THEN
ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
END
END _dispose;
PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
VAR
A, B: CHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a);
SYSTEM.GET(b, B); INC(b);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmp;
PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
VAR
A, B: WCHAR;
res: INTEGER;
BEGIN
res := 0;
WHILE n > 0 DO
SYSTEM.GET(a, A); INC(a, 2);
SYSTEM.GET(b, B); INC(b, 2);
DEC(n);
IF A # B THEN
res := ORD(A) - ORD(B);
n := 0
ELSIF A = 0X THEN
n := 0
END
END
RETURN res
END strncmpw;
PROCEDURE [stdcall] _length* (len, str: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
080H, 038H, 000H, (* cmp byte [eax], 0 *)
074H, 003H, (* jz L2 *)
0E2H, 0F8H, (* loop L1 *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
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;
PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
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
SYSTEM.CODE(
08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
048H, (* dec eax *)
048H, (* dec eax *)
(* L1: *)
040H, (* inc eax *)
040H, (* inc eax *)
066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
074H, 004H, (* jz L2 *)
0E2H, 0F6H, (* loop L1 *)
040H, (* inc eax *)
040H, (* inc eax *)
(* L2: *)
02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
0D1H, 0E8H, (* shr eax, 1 *)
0C9H, (* leave *)
0C2H, 008H, 000H (* ret 08h *)
)
RETURN 0
END _lengthw;
PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
BEGIN
res := strncmp(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _length(len1, str1) - _length(len2, str2)
END;
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
RETURN bRes
END _strcmp;
PROCEDURE [stdcall] _lstrcmp*(op: INTEGER; b: CHAR; a: ARRAY OF CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmp(op, len2, str2, len1, str1)
END _strcmp2;
PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
VAR
res: INTEGER;
bRes: BOOLEAN;
BEGIN
s[0] := b;
s[1] := 0X;
RETURN _strcmp(op, s, a)
END _lstrcmp;
PROCEDURE [stdcall] _rstrcmp*(op: INTEGER; b: ARRAY OF CHAR; a: CHAR): BOOLEAN;
VAR s: ARRAY 2 OF CHAR;
BEGIN
s[0] := a;
s[1] := 0X;
RETURN _strcmp(op, b, s)
END _rstrcmp;
res := strncmpw(str1, str2, MIN(len1, len2));
IF res = 0 THEN
res := _lengthw(len1, str1) - _lengthw(len2, str2)
END;
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)
CASE op OF
|0: bRes := res = 0
|1: bRes := res # 0
|2: bRes := res < 0
|3: bRes := res <= 0
|4: bRes := res > 0
|5: bRes := res >= 0
END
END StrAppend;
RETURN bRes
END _strcmpw;
PROCEDURE [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
RETURN _strcmpw(op, len2, str2, len1, str1)
END _strcmpw2;
PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
VAR
c: CHAR;
i: INTEGER;
BEGIN
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);
IF API.GetCurrentThreadId() = main_thread_id THEN
API.ExitProcess(0)
ELSE
API.ExitThread(0)
END
END _assrt;
i := 0;
REPEAT
SYSTEM.GET(pchar, c);
s[i] := c;
INC(pchar);
INC(i)
UNTIL c = 0X
END PCharToStr;
PROCEDURE [stdcall] _close*;
BEGIN
IF CloseProc # NIL THEN
CloseProc
END
END _close;
PROCEDURE [stdcall] _init*(self, rec, gsize, gadr, esp: INTEGER);
PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a, b: INTEGER;
c: CHAR;
BEGIN
IF ~init THEN
API.zeromem(gsize, gadr);
init := TRUE;
API.init(esp);
main_thread_id := API.GetCurrentThreadId();
SelfName := self;
rtab := rec;
CloseProc := NIL
END
i := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
a := 0;
b := i - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END;
str[i] := 0X
END IntToStr;
PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE [stdcall] _error* (module, err: INTEGER);
VAR
s, temp: ARRAY 1024 OF CHAR;
BEGIN
s := "";
CASE err MOD 16 OF
| 1: append(s, "assertion failure")
| 2: append(s, "NIL dereference")
| 3: append(s, "division by zero")
| 4: append(s, "NIL procedure call")
| 5: append(s, "type guard error")
| 6: append(s, "index out of range")
| 7: append(s, "invalid CASE")
| 8: append(s, "array assignment error")
| 9: append(s, "CHR out of range")
|10: append(s, "WCHR out of range")
|11: append(s, "BYTE out of range")
END;
append(s, API.eol);
append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
API.DebugMsg(SYSTEM.ADR(s[0]), name);
API.exit_thread(0)
END _error;
PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
BEGIN
(* r IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
END _isrec;
PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
BEGIN
(* p IS t0 *)
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
ELSE
t1 := -1
END
RETURN t1 = t0
END _is;
PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
BEGIN
(* r:t1 IS t0 *)
WHILE (t1 # 0) & (t1 # t0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
RETURN t1 = t0
END _guardrec;
PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
VAR
t1: INTEGER;
BEGIN
(* p IS t0 *)
SYSTEM.GET(p, p);
IF p # 0 THEN
DEC(p, SIZE_OF_DWORD);
SYSTEM.GET(p, t1);
WHILE (t1 # t0) & (t1 # 0) DO
SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
END
ELSE
t1 := t0
END
RETURN t1 = t0
END _guard;
PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE fdwReason OF
|DLL_PROCESS_ATTACH:
res := 1
|DLL_THREAD_ATTACH:
res := 0;
IF dll.thread_attach # NIL THEN
dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_THREAD_DETACH:
res := 0;
IF dll.thread_detach # NIL THEN
dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
END
|DLL_PROCESS_DETACH:
res := 0;
IF dll.process_detach # NIL THEN
dll.process_detach(hinstDLL, fdwReason, lpvReserved)
END
ELSE
res := 0
END
RETURN res
END _dllentry;
PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
BEGIN
dll.process_detach := process_detach;
dll.thread_detach := thread_detach;
dll.thread_attach := thread_attach
END SetDll;
PROCEDURE [stdcall] _exit* (code: INTEGER);
BEGIN
API.exit(code)
END _exit;
PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
BEGIN
SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
API.init(param, code);
types := _types;
name := modname;
dll.process_detach := NIL;
dll.thread_detach := NIL;
dll.thread_attach := NIL;
END _init;
PROCEDURE SetClose*(proc: PROC);
BEGIN
CloseProc := proc
END SetClose;
END RTL.

12
programs/develop/oberon07/Samples/Dialogs.ob07
View File

@ -5,15 +5,13 @@ 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)
KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext)
KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext)
END DefineAndDrawWindow;
PROCEDURE WaitForEvent(): INTEGER;
@ -21,15 +19,13 @@ PROCEDURE WaitForEvent(): INTEGER;
END WaitForEvent;
PROCEDURE ExitApp;
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc1(-1)
KOSAPI.sysfunc1(-1)
END ExitApp;
PROCEDURE pause(t: INTEGER);
VAR aux: INTEGER;
BEGIN
aux := KOSAPI.sysfunc2(5, t)
KOSAPI.sysfunc2(5, t)
END pause;
PROCEDURE Buttons;

12
programs/develop/oberon07/Samples/HW.ob07
View File

@ -3,21 +3,18 @@ MODULE HW;
IMPORT sys := SYSTEM, KOSAPI;
PROCEDURE WindowRedrawStatus(p: INTEGER);
VAR res: INTEGER;
BEGIN
res := KOSAPI.sysfunc2(12, p)
KOSAPI.sysfunc2(12, p)
END WindowRedrawStatus;
PROCEDURE DefineAndDrawWindow(x, y, w, h, color, style, hcolor, hstyle, htext: INTEGER);
VAR res: INTEGER;
BEGIN
res := KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext)
KOSAPI.sysfunc6(0, x * 65536 + w, y * 65536 + h, color + LSL(style, 24), hcolor + LSL(hstyle, 24), htext)
END DefineAndDrawWindow;
PROCEDURE WriteTextToWindow(x, y, color: INTEGER; text: ARRAY OF CHAR);
VAR res: INTEGER;
BEGIN
res := KOSAPI.sysfunc6(4, x * 65536 + y, color + LSL(48, 24), sys.ADR(text[0]), LENGTH(text), 0)
KOSAPI.sysfunc6(4, x * 65536 + y, color + LSL(48, 24), sys.ADR(text[0]), LENGTH(text), 0)
END WriteTextToWindow;
PROCEDURE WaitForEvent(): INTEGER;
@ -25,9 +22,8 @@ PROCEDURE WaitForEvent(): INTEGER;
END WaitForEvent;
PROCEDURE ExitApp;
VAR res: INTEGER;
BEGIN
res := KOSAPI.sysfunc1(-1)
KOSAPI.sysfunc1(-1)
END ExitApp;
PROCEDURE draw_window(header, text: ARRAY OF CHAR);

94
programs/develop/oberon07/Samples/HW_con.ob07
View File

@ -1,53 +1,63 @@
MODULE HW_con;
MODULE HW_con;
IMPORT Out, In, Console, DateTime;
IMPORT Out, In, Console, DateTime, ConsoleLib;
PROCEDURE OutInt2(n: INTEGER);
BEGIN
ASSERT((0 <= n) & (n <= 99));
IF n < 10 THEN
Out.Char("0")
END;
Out.Int(n, 0)
END OutInt2;
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;
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;
VAR
Year, Month, Day, Hour, Min, Sec, Msec: INTEGER;
BEGIN
main
Out.String("Hello, world!"); Out.Ln;
Console.SetColor(Console.White, Console.Red);
DateTime.Now(Year, Month, Day, Hour, Min, Sec, Msec);
Out.Int(Year, 0); Out.Char("-");
OutMonth(Month); Out.Char("-");
OutInt2(Day); Out.Char(" ");
OutInt2(Hour); Out.Char(":");
OutInt2(Min); Out.Char(":");
OutInt2(Sec)
END main;
BEGIN
Console.open;
main;
In.Ln;
Console.exit(TRUE)
END HW_con.

159
programs/develop/oberon07/Samples/RasterW.ob07
View File

@ -1,159 +0,0 @@
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.

175
programs/develop/oberon07/Samples/kfont.ob07
View File

@ -1,175 +0,0 @@
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.

97
programs/develop/oberon07/Samples/lib_img.ob07
View File

@ -1,97 +0,0 @@
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.

57
programs/develop/oberon07/Samples/vector_ex.ob07
View File

@ -1,57 +0,0 @@
MODULE vector_ex;
IMPORT C := ConsoleLib, Out, V := Vector;
TYPE
STRING = ARRAY 240 OF CHAR;
Item = POINTER TO RECORD (V.ANYREC) inf: STRING END;
PROCEDURE add(v: V.VECTOR; s: STRING);
VAR item: Item;
BEGIN
NEW(item);
item.inf := s;
V.push(v, item)
END add;
PROCEDURE print(v: V.VECTOR; first, last: INTEGER);
VAR any : V.ANYPTR;
i : INTEGER;
BEGIN
i := first;
WHILE i <= last DO
any := V.get(v, i);
Out.String(any(Item).inf);
Out.Ln;
INC(i)
END;
END print;
PROCEDURE main;
VAR v: V.VECTOR;
BEGIN
C.open(-1, -1, -1, -1, "vector");
v := V.create(1024);
add(v, "abc");
add(v, "def");
add(v, "123");
add(v, "qwerty");
add(v, "hello");
print(v, 0, V.count(v) - 1);
C.exit(FALSE)
END main;
BEGIN
main
END vector_ex.

2782
programs/develop/oberon07/Source/AMD64.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

861
programs/develop/oberon07/Source/ARITH.ob07 Normal file
View File

@ -0,0 +1,861 @@
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE ARITH;
IMPORT AVLTREES, STRINGS, MACHINE, UTILS;
CONST
tINTEGER* = 1; tREAL* = 2; tSET* = 3;
tBOOLEAN* = 4; tCHAR* = 5; tWCHAR* = 6;
tSTRING* = 7;
TYPE
RELATION* = ARRAY 3 OF CHAR;
VALUE* = RECORD
typ*: INTEGER;
int: INTEGER;
float: REAL;
set: SET;
bool: BOOLEAN;
string*: AVLTREES.DATA
END;
VAR
digit: ARRAY 256 OF INTEGER;
PROCEDURE Int* (v: VALUE): INTEGER;
VAR
res: INTEGER;
BEGIN
IF v.typ = tINTEGER THEN
res := v.int
ELSIF v.typ = tCHAR THEN
res := v.int
ELSIF v.typ = tWCHAR THEN
res := v.int
ELSIF v.typ = tSET THEN
res := ORD(v.set);
IF MACHINE._64to32 THEN
res := MACHINE.Int32To64(res)
END
ELSIF v.typ = tBOOLEAN THEN
res := ORD(v.bool)
END
RETURN res
END Int;
PROCEDURE getBool* (v: VALUE): BOOLEAN;
BEGIN
ASSERT(v.typ = tBOOLEAN);
RETURN v.bool
END getBool;
PROCEDURE Float* (v: VALUE): REAL;
BEGIN
ASSERT(v.typ = tREAL);
RETURN v.float
END Float;
PROCEDURE check* (v: VALUE): BOOLEAN;
VAR
error: BOOLEAN;
BEGIN
error := FALSE;
IF (v.typ = tINTEGER) & ((v.int < MACHINE.target.minInt) OR (v.int > MACHINE.target.maxInt)) THEN
error := TRUE
ELSIF (v.typ = tCHAR) & ((v.int < 0) OR (v.int > 255)) THEN
error := TRUE
ELSIF (v.typ = tWCHAR) & ((v.int < 0) OR (v.int > 65535)) THEN
error := TRUE
ELSIF (v.typ = tREAL) & ((v.float < -MACHINE.target.maxReal) OR (v.float > MACHINE.target.maxReal)) THEN
error := TRUE
END
RETURN ~error
END check;
PROCEDURE isZero* (v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
ASSERT(v.typ IN {tINTEGER, tREAL});
IF v.typ = tINTEGER THEN
res := v.int = 0
ELSIF v.typ = tREAL THEN
res := v.float = 0.0
END
RETURN res
END isZero;
PROCEDURE iconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
value: INTEGER;
i: INTEGER;
d: INTEGER;
BEGIN
error := 0;
value := 0;
i := 0;
WHILE STRINGS.digit(s[i]) & (error = 0) DO
d := digit[ORD(s[i])];
IF value <= (UTILS.maxint - d) DIV 10 THEN
value := value * 10 + d;
INC(i)
ELSE
error := 1
END
END;
IF error = 0 THEN
v.int := value;
v.typ := tINTEGER;
IF ~check(v) THEN
error := 1
END
END
END iconv;
PROCEDURE hconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
value: INTEGER;
i: INTEGER;
n: INTEGER;
d: INTEGER;
BEGIN
ASSERT(STRINGS.digit(s[0]));
error := 0;
value := 0;
n := -1;
i := 0;
WHILE (s[i] # "H") & (s[i] # "X") & (error = 0) DO
d := digit[ORD(s[i])];
IF (n = -1) & (d # 0) THEN
n := i
END;
IF (n # -1) & (i - n + 1 > MACHINE.target.maxHex) THEN
error := 2
ELSE
value := value * 16 + d;
INC(i)
END
END;
IF MACHINE._64to32 THEN
value := MACHINE.Int32To64(value);
END;
IF (s[i] = "X") & (n # -1) & (i - n > 4) THEN
error := 3
END;
IF error = 0 THEN
v.int := value;
IF s[i] = "X" THEN
v.typ := tCHAR;
IF ~check(v) THEN
v.typ := tWCHAR;
IF ~check(v) THEN
error := 3
END
END
ELSE
v.typ := tINTEGER;
IF ~check(v) THEN
error := 2
END
END
END
END hconv;
PROCEDURE opFloat2 (VAR a: REAL; b: REAL; op: CHAR): BOOLEAN;
VAR
max: REAL;
res: BOOLEAN;
BEGIN
max := UTILS.maxreal;
CASE op OF
|"+":
IF (a < 0.0) & (b < 0.0) THEN
res := a > -max - b
ELSIF (a > 0.0) & (b > 0.0) THEN
res := a < max - b
ELSE
res := TRUE
END;
IF res THEN
a := a + b
END
|"-":
IF (a < 0.0) & (b > 0.0) THEN
res := a > b - max
ELSIF (a > 0.0) & (b < 0.0) THEN
res := a < b + max
ELSE
res := TRUE
END;
IF res THEN
a := a - b
END
|"*":
IF (ABS(a) > 1.0) & (ABS(b) > 1.0) THEN
res := ABS(a) < max / ABS(b)
ELSE
res := TRUE
END;
IF res THEN
a := a * b
END
|"/":
IF ABS(b) < 1.0 THEN
res := ABS(a) < max * ABS(b)
ELSE
res := TRUE
END;
IF res THEN
a := a / b
END
END
RETURN res
END opFloat2;
PROCEDURE fconv* (s: ARRAY OF CHAR; VAR v: VALUE; VAR error: INTEGER);
VAR
value: REAL;
exp10: REAL;
i, n, d: INTEGER;
minus: BOOLEAN;
BEGIN
error := 0;
value := 0.0;
exp10 := 10.0;
minus := FALSE;
n := 0;
i := 0;
WHILE (error = 0) & STRINGS.digit(s[i]) DO
IF opFloat2(value, 10.0, "*") & opFloat2(value, FLT(digit[ORD(s[i])]), "+") THEN
INC(i)
ELSE
error := 4
END
END;
INC(i);
WHILE (error = 0) & STRINGS.digit(s[i]) DO
IF opFloat2(value, FLT(digit[ORD(s[i])]) / exp10, "+") & opFloat2(exp10, 10.0, "*") THEN
INC(i)
ELSE
error := 4
END
END;
IF s[i] = "E" THEN
INC(i)
END;
IF (s[i] = "-") OR (s[i] = "+") THEN
minus := s[i] = "-";
INC(i)
END;
WHILE (error = 0) & STRINGS.digit(s[i]) DO
d := digit[ORD(s[i])];
IF n <= (UTILS.maxint - d) DIV 10 THEN
n := n * 10 + d;
INC(i)
ELSE
error := 5
END
END;
exp10 := 1.0;
WHILE (error = 0) & (n > 0) DO
IF opFloat2(exp10, 10.0, "*") THEN
DEC(n)
ELSE
error := 4
END
END;
IF error = 0 THEN
IF minus THEN
IF ~opFloat2(value, exp10, "/") THEN
error := 4
END
ELSE
IF ~opFloat2(value, exp10, "*") THEN
error := 4
END
END
END;
IF error = 0 THEN
v.float := value;
v.typ := tREAL;
IF ~check(v) THEN
error := 4
END
END
END fconv;
PROCEDURE setChar* (VAR v: VALUE; ord: INTEGER);
BEGIN
v.typ := tCHAR;
v.int := ord
END setChar;
PROCEDURE setWChar* (VAR v: VALUE; ord: INTEGER);
BEGIN
v.typ := tWCHAR;
v.int := ord
END setWChar;
PROCEDURE addInt (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
error: BOOLEAN;
BEGIN
IF (a > 0) & (b > 0) THEN
error := a > UTILS.maxint - b
ELSIF (a < 0) & (b < 0) THEN
error := a < UTILS.minint - b
ELSE
error := FALSE
END;
IF ~error THEN
a := a + b
ELSE
a := 0
END
RETURN ~error
END addInt;
PROCEDURE subInt (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
error: BOOLEAN;
BEGIN
IF (a > 0) & (b < 0) THEN
error := a > UTILS.maxint + b
ELSIF (a < 0) & (b > 0) THEN
error := a < UTILS.minint + b
ELSIF (a = 0) & (b < 0) THEN
error := b = UTILS.minint
ELSE
error := FALSE
END;
IF ~error THEN
a := a - b
ELSE
a := 0
END
RETURN ~error
END subInt;
PROCEDURE lg2 (x: INTEGER): INTEGER;
VAR
n: INTEGER;
BEGIN
ASSERT(x > 0);
n := 0;
WHILE ~ODD(x) DO
x := x DIV 2;
INC(n)
END;
IF x # 1 THEN
n := 255
END
RETURN n
END lg2;
PROCEDURE mulInt* (VAR a: INTEGER; b: INTEGER): BOOLEAN;
VAR
error: BOOLEAN;
min, max: INTEGER;
BEGIN
min := UTILS.minint;
max := UTILS.maxint;
IF ((a > 1) & (b > 1)) OR ((a < 0) & (b < 0)) THEN
error := (a = min) OR (b = min) OR (ABS(a) > max DIV ABS(b))
ELSIF ((a > 1) & (b < 0)) OR ((a < 0) & (b > 1)) THEN
error := (a = min) OR (b = min);
IF ~error THEN
IF lg2(ABS(a)) + lg2(ABS(b)) >= UTILS.bit_depth THEN
error := ABS(a) > max DIV ABS(b)
END
END
ELSE
error := FALSE
END;
IF ~error THEN
a := a * b
ELSE
a := 0
END
RETURN ~error
END mulInt;
PROCEDURE _ASR (x, n: INTEGER): INTEGER;
BEGIN
IF MACHINE._64to32 THEN
x := MACHINE.Int32To64(x)
END
RETURN ASR(x, n)
END _ASR;
PROCEDURE _LSR (x, n: INTEGER): INTEGER;
BEGIN
IF MACHINE._64to32 THEN
x := MACHINE.Int64To32(x);
x := LSR(x, n);
x := MACHINE.Int32To64(x)
ELSE
x := LSR(x, n)
END
RETURN x
END _LSR;
PROCEDURE _LSL (x, n: INTEGER): INTEGER;
BEGIN
x := LSL(x, n);
IF MACHINE._64to32 THEN
x := MACHINE.Int32To64(x)
END
RETURN x
END _LSL;
PROCEDURE _ROR1_32 (x: INTEGER): INTEGER;
BEGIN
x := MACHINE.Int64To32(x);
x := ORD(BITS(LSR(x, 1)) + BITS(LSL(x, 31)))
RETURN MACHINE.Int32To64(x)
END _ROR1_32;
PROCEDURE _ROR (x, n: INTEGER): INTEGER;
BEGIN
IF MACHINE._64to32 THEN
n := n MOD 32;
WHILE n > 0 DO
x := _ROR1_32(x);
DEC(n)
END
ELSE
x := ROR(x, n)
END
RETURN x
END _ROR;
PROCEDURE opInt* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN;
VAR
success: BOOLEAN;
BEGIN
success := TRUE;
CASE op OF
|"+": success := addInt(a.int, b.int)
|"-": success := subInt(a.int, b.int)
|"*": success := mulInt(a.int, b.int)
|"/": success := FALSE
|"D": IF (b.int # -1) OR (a.int # UTILS.minint) THEN a.int := a.int DIV b.int ELSE success := FALSE END
|"M": a.int := a.int MOD b.int
|"L": a.int := _LSL(a.int, b.int)
|"A": a.int := _ASR(a.int, b.int)
|"O": a.int := _ROR(a.int, b.int)
|"R": a.int := _LSR(a.int, b.int)
|"m": a.int := MIN(a.int, b.int)
|"x": a.int := MAX(a.int, b.int)
END;
a.typ := tINTEGER
RETURN success & check(a)
END opInt;
PROCEDURE charToStr* (c: VALUE; VAR s: ARRAY OF CHAR);
BEGIN
s[0] := CHR(c.int);
s[1] := 0X
END charToStr;
PROCEDURE opSet* (VAR a: VALUE; b: VALUE; op: CHAR);
BEGIN
CASE op OF
|"+": a.set := a.set + b.set
|"-": a.set := a.set - b.set
|"*": a.set := a.set * b.set
|"/": a.set := a.set / b.set
END;
a.typ := tSET
END opSet;
PROCEDURE opFloat* (VAR a: VALUE; b: VALUE; op: CHAR): BOOLEAN;
BEGIN
a.typ := tREAL
RETURN opFloat2(a.float, b.float, op) & check(a)
END opFloat;
PROCEDURE ord* (VAR v: VALUE);
BEGIN
CASE v.typ OF
|tCHAR, tWCHAR:
|tBOOLEAN: v.int := ORD(v.bool)
|tSET:
v.int := ORD(v.set);
IF MACHINE._64to32 THEN
v.int := MACHINE.Int32To64(v.int)
END
END;
v.typ := tINTEGER
END ord;
PROCEDURE odd* (VAR v: VALUE);
BEGIN
v.typ := tBOOLEAN;
v.bool := ODD(v.int)
END odd;
PROCEDURE bits* (VAR v: VALUE);
BEGIN
v.typ := tSET;
v.set := BITS(v.int)
END bits;
PROCEDURE abs* (VAR v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := FALSE;
CASE v.typ OF
|tREAL:
v.float := ABS(v.float);
res := TRUE
|tINTEGER:
IF v.int # UTILS.minint THEN
v.int := ABS(v.int);
res := TRUE
END
END
RETURN res
END abs;
PROCEDURE floor* (VAR v: VALUE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
v.typ := tINTEGER;
res := (FLT(UTILS.minint) <= v.float) & (v.float <= FLT(UTILS.maxint));
IF res THEN
v.int := FLOOR(v.float)
END
RETURN res
END floor;
PROCEDURE flt* (VAR v: VALUE);
BEGIN
v.typ := tREAL;
v.float := FLT(v.int)
END flt;
PROCEDURE neg* (VAR v: VALUE): BOOLEAN;
VAR
z: VALUE;
res: BOOLEAN;
BEGIN
res := TRUE;
z.typ := tINTEGER;
z.int := 0;
CASE v.typ OF
|tREAL: v.float := -v.float
|tSET: v.set := -v.set
|tINTEGER: res := opInt(z, v, "-"); v := z
|tBOOLEAN: v.bool := ~v.bool
END
RETURN res
END neg;
PROCEDURE setbool* (VAR v: VALUE; b: BOOLEAN);
BEGIN
v.bool := b;
v.typ := tBOOLEAN
END setbool;
PROCEDURE opBoolean* (VAR a: VALUE; b: VALUE; op: CHAR);
BEGIN
CASE op OF
|"&": a.bool := a.bool & b.bool
|"|": a.bool := a.bool OR b.bool
END;
a.typ := tBOOLEAN
END opBoolean;
PROCEDURE range* (i: VALUE; a, b: INTEGER): BOOLEAN;
RETURN (a <= i.int) & (i.int <= b)
END range;
PROCEDURE less (v, v2: VALUE; VAR error: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := FALSE;
IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN
CASE v.typ OF
|tINTEGER,
tWCHAR,
tCHAR: res := v.int < v2.int
|tREAL: res := v.float < v2.float
|tBOOLEAN,
tSET: error := 1
END
ELSE
error := 1
END
RETURN res
END less;
PROCEDURE equal (v, v2: VALUE; VAR error: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := FALSE;
IF (v.typ = v2.typ) OR (v.typ IN {tCHAR, tWCHAR}) & (v2.typ IN {tCHAR, tWCHAR}) THEN
CASE v.typ OF
|tINTEGER,
tWCHAR,
tCHAR: res := v.int = v2.int
|tREAL: res := v.float = v2.float
|tBOOLEAN: res := v.bool = v2.bool
|tSET: res := v.set = v2.set
END
ELSE
error := 1
END
RETURN res
END equal;
PROCEDURE relation* (VAR v: VALUE; v2: VALUE; operator: RELATION; VAR error: INTEGER);
VAR
res: BOOLEAN;
BEGIN
error := 0;
res := FALSE;
CASE operator[0] OF
|"=":
res := equal(v, v2, error)
|"#":
res := ~equal(v, v2, error)
|"<":
IF operator[1] = "=" THEN
res := less(v, v2, error);
IF error = 0 THEN
res := equal(v, v2, error) OR res
END
ELSE
res := less(v, v2, error)
END
|">":
IF operator[1] = "=" THEN
res := ~less(v, v2, error)
ELSE
res := less(v, v2, error);
IF error = 0 THEN
res := equal(v, v2, error) OR res
END;
res := ~res
END
|"I":
IF (v.typ = tINTEGER) & (v2.typ = tSET) THEN
IF range(v, 0, MACHINE.target.maxSet) THEN
res := v.int IN v2.set
ELSE
error := 2
END
ELSE
error := 1
END
END;
IF error = 0 THEN
v.bool := res;
v.typ := tBOOLEAN
END
END relation;
PROCEDURE emptySet* (VAR v: VALUE);
BEGIN
v.typ := tSET;
v.set := {}
END emptySet;
PROCEDURE constrSet* (VAR v: VALUE; a, b: VALUE);
BEGIN
v.typ := tSET;
v.set := {a.int .. b.int}
END constrSet;
PROCEDURE getInt* (v: VALUE): INTEGER;
BEGIN
ASSERT(check(v))
RETURN v.int
END getInt;
PROCEDURE setInt* (VAR v: VALUE; i: INTEGER): BOOLEAN;
BEGIN
v.int := i;
v.typ := tINTEGER
RETURN check(v)
END setInt;
PROCEDURE init;
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO LEN(digit) - 1 DO
digit[i] := -1
END;
FOR i := ORD("0") TO ORD("9") DO
digit[i] := i - ORD("0")
END;
FOR i := ORD("A") TO ORD("F") DO
digit[i] := i - ORD("A") + 10
END
END init;
BEGIN
init
END ARITH.

197
programs/develop/oberon07/Source/AVLTREES.ob07 Normal file
View File

@ -0,0 +1,197 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE AVLTREES;
IMPORT C := COLLECTIONS;
TYPE
DATA* = POINTER TO RECORD (C.ITEM) END;
NODE* = POINTER TO RECORD (C.ITEM)
data*: DATA;
height: INTEGER;
left*, right*: NODE
END;
CMP* = PROCEDURE (a, b: DATA): INTEGER;
DESTRUCTOR* = PROCEDURE (VAR data: DATA);
VAR
nodes: C.COLLECTION;
PROCEDURE NewNode (data: DATA): NODE;
VAR
node: NODE;
citem: C.ITEM;
BEGIN
citem := C.pop(nodes);
IF citem = NIL THEN
NEW(node)
ELSE
node := citem(NODE)
END;
node.data := data;
node.left := NIL;
node.right := NIL;
node.height := 1
RETURN node
END NewNode;
PROCEDURE height (p: NODE): INTEGER;
VAR
res: INTEGER;
BEGIN
IF p = NIL THEN
res := 0
ELSE
res := p.height
END
RETURN res
END height;
PROCEDURE bfactor (p: NODE): INTEGER;
RETURN height(p.right) - height(p.left)
END bfactor;
PROCEDURE fixheight (p: NODE);
BEGIN
p.height := MAX(height(p.left), height(p.right)) + 1
END fixheight;
PROCEDURE rotateright (p: NODE): NODE;
VAR
q: NODE;
BEGIN
q := p.left;
p.left := q.right;
q.right := p;
fixheight(p);
fixheight(q)
RETURN q
END rotateright;
PROCEDURE rotateleft (q: NODE): NODE;
VAR
p: NODE;
BEGIN
p := q.right;
q.right := p.left;
p.left := q;
fixheight(q);
fixheight(p)
RETURN p
END rotateleft;
PROCEDURE balance (p: NODE): NODE;
VAR
res: NODE;
BEGIN
fixheight(p);
IF bfactor(p) = 2 THEN
IF bfactor(p.right) < 0 THEN
p.right := rotateright(p.right)
END;
res := rotateleft(p)
ELSIF bfactor(p) = -2 THEN
IF bfactor(p.left) > 0 THEN
p.left := rotateleft(p.left)
END;
res := rotateright(p)
ELSE
res := p
END
RETURN res
END balance;
PROCEDURE insert* (p: NODE; data: DATA; cmp: CMP; VAR newnode: BOOLEAN; VAR node: NODE): NODE;
VAR
res: NODE;
rescmp: INTEGER;
BEGIN
IF p = NIL THEN
res := NewNode(data);
node := res;
newnode := TRUE
ELSE
rescmp := cmp(data, p.data);
IF rescmp < 0 THEN
p.left := insert(p.left, data, cmp, newnode, node);
res := balance(p)
ELSIF rescmp > 0 THEN
p.right := insert(p.right, data, cmp, newnode, node);
res := balance(p)
ELSE
res := p;
node := res;
newnode := FALSE
END
END
RETURN res
END insert;
PROCEDURE destroy* (VAR node: NODE; destructor: DESTRUCTOR);
VAR
left, right: NODE;
BEGIN
IF node # NIL THEN
left := node.left;
right := node.right;
IF destructor # NIL THEN
destructor(node.data)
END;
C.push(nodes, node);
node := NIL;
destroy(left, destructor);
destroy(right, destructor)
END
END destroy;
BEGIN
nodes := C.create()
END AVLTREES.

396
programs/develop/oberon07/Source/BIN.ob07 Normal file
View File

@ -0,0 +1,396 @@
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE BIN;
IMPORT LISTS, MACHINE, CHL := CHUNKLISTS, ARITH, UTILS;
CONST
RCODE* = 1;
RDATA* = 2;
RBSS* = 3;
RIMP* = 4;
PICCODE* = 5;
PICDATA* = 6;
PICBSS* = 7;
PICIMP* = 8;
IMPTAB* = 9;
TYPE
RELOC* = POINTER TO RECORD (LISTS.ITEM)
opcode*: INTEGER;
offset*: INTEGER
END;
IMPRT* = POINTER TO RECORD (LISTS.ITEM)
nameoffs*: INTEGER;
label*: INTEGER;
OriginalFirstThunk*,
FirstThunk*: INTEGER
END;
EXPRT* = POINTER TO RECORD (LISTS.ITEM)
nameoffs*: INTEGER;
label*: INTEGER
END;
PROGRAM* = POINTER TO RECORD
code*: CHL.BYTELIST;
data*: CHL.BYTELIST;
labels: CHL.INTLIST;
bss*: INTEGER;
stack*: INTEGER;
vmajor*,
vminor*: WCHAR;
modname*: INTEGER;
import*: CHL.BYTELIST;
export*: CHL.BYTELIST;
rel_list*: LISTS.LIST;
imp_list*: LISTS.LIST;
exp_list*: LISTS.LIST
END;
PROCEDURE create* (NumberOfLabels: INTEGER): PROGRAM;
VAR
program: PROGRAM;
i: INTEGER;
BEGIN
NEW(program);
program.bss := 0;
program.labels := CHL.CreateIntList();
FOR i := 0 TO NumberOfLabels - 1 DO
CHL.PushInt(program.labels, 0)
END;
program.rel_list := LISTS.create(NIL);
program.imp_list := LISTS.create(NIL);
program.exp_list := LISTS.create(NIL);
program.data := CHL.CreateByteList();
program.code := CHL.CreateByteList();
program.import := CHL.CreateByteList();
program.export := CHL.CreateByteList()
RETURN program
END create;
PROCEDURE SetParams* (program: PROGRAM; bss, stack: INTEGER; vmajor, vminor: WCHAR);
BEGIN
program.bss := bss;
program.stack := stack;
program.vmajor := vmajor;
program.vminor := vminor
END SetParams;
PROCEDURE PutReloc* (program: PROGRAM; opcode: INTEGER);
VAR
cmd: RELOC;
BEGIN
NEW(cmd);
cmd.opcode := opcode;
cmd.offset := CHL.Length(program.code);
LISTS.push(program.rel_list, cmd)
END PutReloc;
PROCEDURE PutData* (program: PROGRAM; b: BYTE);
BEGIN
CHL.PushByte(program.data, b)
END PutData;
PROCEDURE get32le* (array: CHL.BYTELIST; idx: INTEGER): INTEGER;
VAR
i: INTEGER;
x: INTEGER;
BEGIN
x := 0;
FOR i := 3 TO 0 BY -1 DO
x := LSL(x, 8) + CHL.GetByte(array, idx + i)
END;
IF UTILS.bit_depth = 64 THEN
x := MACHINE.Int32To64(x)
END
RETURN x
END get32le;
PROCEDURE put32le* (array: CHL.BYTELIST; idx: INTEGER; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
CHL.SetByte(array, idx + i, MACHINE.Byte(x, i))
END
END put32le;
PROCEDURE PutData32LE* (program: PROGRAM; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
CHL.PushByte(program.data, MACHINE.Byte(x, i))
END
END PutData32LE;
PROCEDURE PutData64LE* (program: PROGRAM; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 7 DO
CHL.PushByte(program.data, MACHINE.Byte(x, i))
END
END PutData64LE;
PROCEDURE PutDataStr* (program: PROGRAM; s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE s[i] # 0X DO
PutData(program, ORD(s[i]));
INC(i)
END
END PutDataStr;
PROCEDURE PutCode* (program: PROGRAM; b: BYTE);
BEGIN
CHL.PushByte(program.code, b)
END PutCode;
PROCEDURE PutCode32LE* (program: PROGRAM; x: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
CHL.PushByte(program.code, MACHINE.Byte(x, i))
END
END PutCode32LE;
PROCEDURE SetLabel* (program: PROGRAM; label, offset: INTEGER);
BEGIN
CHL.SetInt(program.labels, label, offset)
END SetLabel;
PROCEDURE Import* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER);
VAR
imp: IMPRT;
i: INTEGER;
BEGIN
CHL.PushByte(program.import, 0);
CHL.PushByte(program.import, 0);
IF ODD(CHL.Length(program.import)) THEN
CHL.PushByte(program.import, 0)
END;
NEW(imp);
imp.nameoffs := CHL.Length(program.import);
imp.label := label;
LISTS.push(program.imp_list, imp);
i := 0;
WHILE name[i] # 0X DO
CHL.PushByte(program.import, ORD(name[i]));
INC(i)
END;
CHL.PushByte(program.import, 0)
END Import;
PROCEDURE less (bytes: CHL.BYTELIST; a, b: EXPRT): BOOLEAN;
VAR
i, j: INTEGER;
BEGIN
i := a.nameoffs;
j := b.nameoffs;
WHILE (CHL.GetByte(bytes, i) # 0) & (CHL.GetByte(bytes, j) # 0) &
(CHL.GetByte(bytes, i) = CHL.GetByte(bytes, j)) DO
INC(i);
INC(j)
END
RETURN CHL.GetByte(bytes, i) < CHL.GetByte(bytes, j)
END less;
PROCEDURE Export* (program: PROGRAM; name: ARRAY OF CHAR; label: INTEGER);
VAR
exp, cur: EXPRT;
i: INTEGER;
BEGIN
NEW(exp);
exp.nameoffs := CHL.Length(program.export);
exp.label := CHL.GetInt(program.labels, label);
i := 0;
WHILE name[i] # 0X DO
CHL.PushByte(program.export, ORD(name[i]));
INC(i)
END;
CHL.PushByte(program.export, 0);
cur := program.exp_list.first(EXPRT);
WHILE (cur # NIL) & less(program.export, cur, exp) DO
cur := cur.next(EXPRT)
END;
IF cur # NIL THEN
IF cur.prev # NIL THEN
LISTS.insert(program.exp_list, cur.prev, exp)
ELSE
LISTS.insertL(program.exp_list, cur, exp)
END
ELSE
LISTS.push(program.exp_list, exp)
END
END Export;
PROCEDURE GetIProc* (program: PROGRAM; n: INTEGER): IMPRT;
VAR
import: IMPRT;
res: IMPRT;
BEGIN
import := program.imp_list.first(IMPRT);
res := NIL;
WHILE (import # NIL) & (n >= 0) DO
IF import.label # 0 THEN
res := import;
DEC(n)
END;
import := import.next(IMPRT)
END;
ASSERT(n = -1)
RETURN res
END GetIProc;
PROCEDURE GetLabel* (program: PROGRAM; label: INTEGER): INTEGER;
RETURN CHL.GetInt(program.labels, label)
END GetLabel;
PROCEDURE NewLabel* (program: PROGRAM);
BEGIN
CHL.PushInt(program.labels, 0)
END NewLabel;
PROCEDURE fixup* (program: PROGRAM);
VAR
rel: RELOC;
imp: IMPRT;
nproc: INTEGER;
L: INTEGER;
BEGIN
nproc := 0;
imp := program.imp_list.first(IMPRT);
WHILE imp # NIL DO
IF imp.label # 0 THEN
CHL.SetInt(program.labels, imp.label, nproc);
INC(nproc)
END;
imp := imp.next(IMPRT)
END;
rel := program.rel_list.first(RELOC);
WHILE rel # NIL DO
IF rel.opcode IN {RIMP, PICIMP} THEN
L := get32le(program.code, rel.offset);
put32le(program.code, rel.offset, GetLabel(program, L))
END;
rel := rel.next(RELOC)
END
END fixup;
PROCEDURE InitArray* (VAR array: ARRAY OF BYTE; VAR idx: INTEGER; hex: ARRAY OF CHAR);
VAR
i, k: INTEGER;
PROCEDURE hexdgt (dgt: CHAR): INTEGER;
VAR
res: INTEGER;
BEGIN
IF dgt < "A" THEN
res := ORD(dgt) - ORD("0")
ELSE
res := ORD(dgt) - ORD("A") + 10
END
RETURN res
END hexdgt;
BEGIN
k := LENGTH(hex);
ASSERT(~ODD(k));
k := k DIV 2;
FOR i := 0 TO k - 1 DO
array[i + idx] := hexdgt(hex[2 * i]) * 16 + hexdgt(hex[2 * i + 1])
END;
idx := idx + k
END InitArray;
END BIN.

251
programs/develop/oberon07/Source/CHUNKLISTS.ob07 Normal file
View File

@ -0,0 +1,251 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE CHUNKLISTS;
IMPORT LISTS, WR := WRITER;
CONST
LENOFBYTECHUNK = 64000;
LENOFINTCHUNK = 16000;
TYPE
ANYLIST = POINTER TO RECORD (LISTS.LIST)
length: INTEGER
END;
BYTELIST* = POINTER TO RECORD (ANYLIST) END;
BYTECHUNK = POINTER TO RECORD (LISTS.ITEM)
data: ARRAY LENOFBYTECHUNK OF BYTE;
count: INTEGER
END;
INTLIST* = POINTER TO RECORD (ANYLIST) END;
INTCHUNK = POINTER TO RECORD (LISTS.ITEM)
data: ARRAY LENOFINTCHUNK OF INTEGER;
count: INTEGER
END;
PROCEDURE SetByte* (list: BYTELIST; idx: INTEGER; byte: BYTE);
VAR
ChunkNum: INTEGER;
chunk: BYTECHUNK;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
ChunkNum := idx DIV LENOFBYTECHUNK;
idx := idx MOD LENOFBYTECHUNK;
chunk := list.first(BYTECHUNK);
WHILE (chunk # NIL) & (ChunkNum > 0) DO
chunk := chunk.next(BYTECHUNK);
DEC(ChunkNum)
END;
ASSERT(chunk # NIL);
ASSERT(idx < chunk.count);
chunk.data[idx] := byte
END SetByte;
PROCEDURE GetByte* (list: BYTELIST; idx: INTEGER): BYTE;
VAR
ChunkNum: INTEGER;
chunk: BYTECHUNK;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
ChunkNum := idx DIV LENOFBYTECHUNK;
idx := idx MOD LENOFBYTECHUNK;
chunk := list.first(BYTECHUNK);
WHILE (chunk # NIL) & (ChunkNum > 0) DO
chunk := chunk.next(BYTECHUNK);
DEC(ChunkNum)
END;
ASSERT(chunk # NIL);
ASSERT(idx < chunk.count)
RETURN chunk.data[idx]
END GetByte;
PROCEDURE PushByte* (list: BYTELIST; byte: BYTE);
VAR
chunk: BYTECHUNK;
BEGIN
ASSERT(list # NIL);
chunk := list.last(BYTECHUNK);
IF chunk.count = LENOFBYTECHUNK THEN
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
END;
chunk.data[chunk.count] := byte;
INC(chunk.count);
INC(list.length)
END PushByte;
PROCEDURE WriteToFile* (file: WR.FILE; list: BYTELIST);
VAR
chunk: BYTECHUNK;
BEGIN
chunk := list.first(BYTECHUNK);
WHILE chunk # NIL DO
WR.Write(file, chunk.data, chunk.count);
chunk := chunk.next(BYTECHUNK)
END
END WriteToFile;
PROCEDURE CreateByteList* (): BYTELIST;
VAR
bytelist: BYTELIST;
list: LISTS.LIST;
chunk: BYTECHUNK;
BEGIN
NEW(bytelist);
list := LISTS.create(bytelist);
bytelist.length := 0;
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
RETURN list(BYTELIST)
END CreateByteList;
PROCEDURE SetInt* (list: INTLIST; idx: INTEGER; int: INTEGER);
VAR
ChunkNum: INTEGER;
chunk: INTCHUNK;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
ChunkNum := idx DIV LENOFINTCHUNK;
idx := idx MOD LENOFINTCHUNK;
chunk := list.first(INTCHUNK);
WHILE (chunk # NIL) & (ChunkNum > 0) DO
chunk := chunk.next(INTCHUNK);
DEC(ChunkNum)
END;
ASSERT(chunk # NIL);
ASSERT(idx < chunk.count);
chunk.data[idx] := int
END SetInt;
PROCEDURE GetInt* (list: INTLIST; idx: INTEGER): INTEGER;
VAR
ChunkNum: INTEGER;
chunk: INTCHUNK;
BEGIN
ASSERT(idx >= 0);
ASSERT(list # NIL);
ChunkNum := idx DIV LENOFINTCHUNK;
idx := idx MOD LENOFINTCHUNK;
chunk := list.first(INTCHUNK);
WHILE (chunk # NIL) & (ChunkNum > 0) DO
chunk := chunk.next(INTCHUNK);
DEC(ChunkNum)
END;
ASSERT(chunk # NIL);
ASSERT(idx < chunk.count)
RETURN chunk.data[idx]
END GetInt;
PROCEDURE PushInt* (list: INTLIST; int: INTEGER);
VAR
chunk: INTCHUNK;
BEGIN
ASSERT(list # NIL);
chunk := list.last(INTCHUNK);
IF chunk.count = LENOFINTCHUNK THEN
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
END;
chunk.data[chunk.count] := int;
INC(chunk.count);
INC(list.length)
END PushInt;
PROCEDURE CreateIntList* (): INTLIST;
VAR
intlist: INTLIST;
list: LISTS.LIST;
chunk: INTCHUNK;
BEGIN
NEW(intlist);
list := LISTS.create(intlist);
intlist.length := 0;
NEW(chunk);
chunk.count := 0;
LISTS.push(list, chunk)
RETURN list(INTLIST)
END CreateIntList;
PROCEDURE Length* (list: ANYLIST): INTEGER;
RETURN list.length
END Length;
END CHUNKLISTS.

1179
programs/develop/oberon07/Source/CODE.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

59
programs/develop/oberon07/Source/COLLECTIONS.ob07 Normal file
View File

@ -0,0 +1,59 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE COLLECTIONS;
TYPE
ITEM* = POINTER TO RECORD
link: ITEM
END;
COLLECTION* = POINTER TO RECORD
last: ITEM
END;
PROCEDURE push* (collection: COLLECTION; item: ITEM);
BEGIN
item.link := collection.last;
collection.last := item
END push;
PROCEDURE pop* (collection: COLLECTION): ITEM;
VAR
item: ITEM;
BEGIN
item := collection.last;
IF item # NIL THEN
collection.last := item.link
END
RETURN item
END pop;
PROCEDURE create* (): COLLECTION;
VAR
collection: COLLECTION;
BEGIN
NEW(collection);
collection.last := NIL
RETURN collection
END create;
END COLLECTIONS.

72
programs/develop/oberon07/Source/CONSOLE.ob07 Normal file
View File

@ -0,0 +1,72 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE CONSOLE;
IMPORT UTILS, STRINGS;
PROCEDURE String* (s: ARRAY OF CHAR);
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
UTILS.OutChar(s[i]);
INC(i)
END
END String;
PROCEDURE Int* (n: INTEGER);
VAR
s: ARRAY 32 OF CHAR;
BEGIN
STRINGS.IntToStr(n, s);
String(s)
END Int;
PROCEDURE Int2* (n: INTEGER);
BEGIN
IF n < 10 THEN
String("0")
END;
Int(n)
END Int2;
PROCEDURE Ln*;
BEGIN
String(UTILS.eol)
END Ln;
PROCEDURE StringLn* (s: ARRAY OF CHAR);
BEGIN
String(s);
Ln
END StringLn;
PROCEDURE IntLn* (n: INTEGER);
BEGIN
Int(n);
Ln
END IntLn;
PROCEDURE Int2Ln* (n: INTEGER);
BEGIN
Int2(n);
Ln
END Int2Ln;
END CONSOLE.

43
programs/develop/oberon07/Source/CONSTANTS.ob07 Normal file
View File

@ -0,0 +1,43 @@
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE CONSTANTS;
CONST
vMajor* = 0;
vMinor* = 98;
FILE_EXT* = ".ob07";
RTL_NAME* = "RTL";
MAX_GLOBAL_SIZE* = 1600000000;
Target_iConsole* = 1;
Target_iGUI* = 2;
Target_iDLL* = 3;
Target_iKolibri* = 4;
Target_iObject* = 5;
Target_iConsole64* = 6;
Target_iGUI64* = 7;
Target_iDLL64* = 8;
Target_iELF32* = 9;
Target_iELF64* = 10;
Target_sConsole* = "console";
Target_sGUI* = "gui";
Target_sDLL* = "dll";
Target_sKolibri* = "kos";
Target_sObject* = "obj";
Target_sConsole64* = "console64";
Target_sGUI64* = "gui64";
Target_sDLL64* = "dll64";
Target_sELF32* = "elfexe";
Target_sELF64* = "elfexe64";
END CONSTANTS.

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

655
programs/develop/oberon07/Source/ELF.ob07
View File

@ -1,295 +1,382 @@
(*
Copyright 2016 Anton Krotov
(*
BSD 2-Clause License
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2019, Anton Krotov
All rights reserved.
*)
MODULE ELF;
IMPORT SYSTEM;
IMPORT BIN, WR := WRITER, CHL := CHUNKLISTS;
CONST size* = 8346;
PROCEDURE [stdcall] data;
CONST
EI_NIDENT = 16;
ET_EXEC = 2;
ET_DYN = 3;
EM_386 = 3;
EM_8664 = 3EH;
ELFCLASS32 = 1;
ELFCLASS64 = 2;
ELFDATA2LSB = 1;
ELFDATA2MSB = 2;
PF_X = 1;
PF_W = 2;
PF_R = 4;
TYPE
Elf32_Ehdr = RECORD
e_ident: ARRAY EI_NIDENT OF BYTE;
e_type,
e_machine: WCHAR;
e_version,
e_entry,
e_phoff,
e_shoff,
e_flags: INTEGER;
e_ehsize,
e_phentsize,
e_phnum,
e_shentsize,
e_shnum,
e_shstrndx: WCHAR
END;
Elf32_Phdr = RECORD
p_type,
p_offset,
p_vaddr,
p_paddr,
p_filesz,
p_memsz,
p_flags,
p_align: INTEGER
END;
FILE = WR.FILE;
PROCEDURE align (n, _align: INTEGER): INTEGER;
BEGIN
SYSTEM.CODE("7F454C4601010100000000000000000002000300010000004086040834000000");
SYSTEM.CODE("A41120000000000034002000080028001D001A00060000003400000034800408");
SYSTEM.CODE("3480040800010000000100000500000004000000030000003401000034810408");
SYSTEM.CODE("3481040813000000130000000400000001000000010000000000000000800408");
SYSTEM.CODE("00800408240C1000240C10000500000000100000010000000C0F10000C9F1408");
SYSTEM.CODE("0C9F1408540110009401900C060000000010000002000000200F1000209F1408");
SYSTEM.CODE("209F1408D0000000D00000000600000004000000040000004801000048810408");
SYSTEM.CODE("488104084400000044000000040000000400000051E574640000000000000000");
SYSTEM.CODE("000000000000000000000000060000000400000052E574640C0F10000C9F1408");
SYSTEM.CODE("0C9F1408F4000000F400000004000000010000002F6C69622F6C642D6C696E75");
SYSTEM.CODE("782E736F2E320000040000001000000001000000474E55000000000002000000");
SYSTEM.CODE("060000000F000000040000001400000003000000474E55006D648AA1A4FF8A62");
SYSTEM.CODE("6855372198B3905D7B4527570300000005000000040000000700000092005000");
SYSTEM.CODE("126388F68400000080044030050000000800000013000000AEC44D0F281D8C1C");
SYSTEM.CODE("4701750FAC4BE3C086F0967C328E750F20CF09FD38F28B1C7C8B730F060204F9");
SYSTEM.CODE("16EA76FE3CAD390D665561103F7E967C7D1B760F000000000000000000000000");
SYSTEM.CODE("000000000C0000000000000000000000200000001B0000000000000000000000");
SYSTEM.CODE("20000000A20000000000000000000000120000006C0000000000000000000000");
SYSTEM.CODE("12000000360000008C85040800000000120000007900000080A0240804000000");
SYSTEM.CODE("110018009C0000001C8604080000000012000000460000000C8C140804000000");
SYSTEM.CODE("11000F00B40000007C8504080000000012000000730000009C85040800000000");
SYSTEM.CODE("1200000080000000AC85040800000000120000008E00000060A0240804000000");
SYSTEM.CODE("110018005A000000BC85040800000000120000002F000000CC85040800000000");
SYSTEM.CODE("1200000095000000FC8504080000000012000000870000000C86040800000000");
SYSTEM.CODE("120000006600000064A024080400000011001800550000002C86040800000000");
SYSTEM.CODE("1200000060000000DC8504080000000012000000006C6962646C2E736F2E3200");
SYSTEM.CODE("5F5F676D6F6E5F73746172745F5F005F4A765F5265676973746572436C617373");
SYSTEM.CODE("657300646C6F70656E00646C73796D006C6962632E736F2E36005F494F5F7374");
SYSTEM.CODE("64696E5F75736564006578697400666F70656E006674656C6C00737464696E00");
SYSTEM.CODE("7072696E746600667365656B007374646F75740066636C6F7365006D616C6C6F");
SYSTEM.CODE("630073746465727200667772697465006672656164005F5F6C6962635F737461");
SYSTEM.CODE("72745F6D61696E006672656500474C4942435F322E3100474C4942435F322E30");
SYSTEM.CODE("0000000000000000020002000300020002000100020002000400020004000500");
SYSTEM.CODE("020002000200020002000000010002000100000010000000300000001169690D");
SYSTEM.CODE("00000500B9000000100000001069690D00000300C30000000000000001000200");
SYSTEM.CODE("3C00000010000000000000001169690D00000400B9000000100000001069690D");
SYSTEM.CODE("00000200C300000000000000F09F14080601000060A02408050C000064A02408");
SYSTEM.CODE("0511000080A024080506000000A014080701000004A014080703000008A01408");
SYSTEM.CODE("070900000CA014080705000010A01408070A000014A01408070B000018A01408");
SYSTEM.CODE("070D00001CA01408070E000020A014080713000024A014080704000028A01408");
SYSTEM.CODE("070F00002CA014080710000030A014080707000034A01408071200005589E553");
SYSTEM.CODE("83EC04E8000000005B81C3CC1A10008B93FCFFFFFF85D27405E81E000000E88D");
SYSTEM.CODE("010000E878061000585BC9C3FF35F89F1408FF25FC9F140800000000FF2500A0");
SYSTEM.CODE("14086800000000E9E0FFFFFFFF2504A014086808000000E9D0FFFFFFFF2508A0");
SYSTEM.CODE("14086810000000E9C0FFFFFFFF250CA014086818000000E9B0FFFFFFFF2510A0");
SYSTEM.CODE("14086820000000E9A0FFFFFFFF2514A014086828000000E990FFFFFFFF2518A0");
SYSTEM.CODE("14086830000000E980FFFFFFFF251CA014086838000000E970FFFFFFFF2520A0");
SYSTEM.CODE("14086840000000E960FFFFFFFF2524A014086848000000E950FFFFFFFF2528A0");
SYSTEM.CODE("14086850000000E940FFFFFFFF252CA014086858000000E930FFFFFFFF2530A0");
SYSTEM.CODE("14086860000000E920FFFFFFFF2534A014086868000000E910FFFFFF00000000");
SYSTEM.CODE("31ED5E89E183E4F050545268B08B140868508B1408515668F4860408E80BFFFF");
SYSTEM.CODE("FFF490909090909090909090909090905589E55383EC04803D84A0240800753F");
SYSTEM.CODE("A188A02408BB189F140881EB149F1408C1FB0283EB0139D8731E8DB600000000");
SYSTEM.CODE("83C001A388A02408FF1485149F1408A188A0240839D872E8C60584A024080183");
SYSTEM.CODE("C4045B5DC38D7426008DBC27000000005589E583EC18A11C9F140885C07412B8");
SYSTEM.CODE("0000000085C07409C704241C9F1408FFD0C9C3905589E583E4F0565383EC38C7");
SYSTEM.CODE("44242CA0A024088B55088B44242C89108344242C048B550C8B44242C89108344");
SYSTEM.CODE("242C048B55108B44242C89108344242C04BACC8504088B44242C89108344242C");
SYSTEM.CODE("04BA8C8504088B44242C89108344242C04BA2C8604088B44242C89108344242C");
SYSTEM.CODE("04A164A0240889C28B44242C89108344242C04A180A0240889C28B44242C8910");
SYSTEM.CODE("8344242C04A160A0240889C28B44242C89108344242C04BA0C8604088B44242C");
SYSTEM.CODE("89108344242C04BA7C8504088B44242C89108344242C04BABC8504088B44242C");
SYSTEM.CODE("89108344242C04BAAC8504088B44242C89108344242C04BAFC8504088B44242C");
SYSTEM.CODE("89108344242C04BA1C8604088B44242C89108344242C04BA9C8504088B44242C");
SYSTEM.CODE("89108344242C04BADC8504088B44242C89108344242C048B35B8A02408BBF486");
SYSTEM.CODE("0408B9A0A02408BA60A01408B8108C140889742410895C240C894C2408895424");
SYSTEM.CODE("04890424E8B9FAEFFFB80000000083C4385B5E89EC5DC3909090909090909090");
SYSTEM.CODE("9090909090905589E5575653E85A00000081C39914000083EC1CE8B3F9EFFF8D");
SYSTEM.CODE("BB18FFFFFF8D8318FFFFFF29C7C1FF0285FF742431F68B4510894424088B450C");
SYSTEM.CODE("894424048B4508890424FF94B318FFFFFF83C60139FE72DE83C41C5B5E5F5DC3");
SYSTEM.CODE("8DB6000000005589E55DC38B1C24C3909090909090905589E55383EC04A10C9F");
SYSTEM.CODE("140883F8FF7413BB0C9F1408669083EB04FFD08B0383F8FF75F483C4045B5DC3");
SYSTEM.CODE("90905589E55383EC04E8000000005B81C3FC130000E86CFAEFFF595BC9C30300");
SYSTEM.CODE("00000100020025750A25750A25750A25750A0000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000FFFFFFFF00000000FFFFFFFF000000000000000001000000010000000100");
SYSTEM.CODE("00003C0000000C0000001C8504080D000000EC8B1408F5FEFF6F8C8104080500");
SYSTEM.CODE("00003483040806000000F48104080A000000CD0000000B000000100000001500");
SYSTEM.CODE("00000000000003000000F49F1408020000007000000014000000110000001700");
SYSTEM.CODE("0000AC840408110000008C84040812000000200000001300000008000000FEFF");
SYSTEM.CODE("FF6F2C840408FFFFFF6F02000000F0FFFF6F0284040800000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("00000000000000000000209F1408000000000000000062850408728504088285");
SYSTEM.CODE("040892850408A2850408B2850408C2850408D2850408E2850408F28504080286");
SYSTEM.CODE("0408128604082286040832860408000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000004743433A20285562756E74");
SYSTEM.CODE("752F4C696E61726F20342E352E322D387562756E7475342920342E352E320047");
SYSTEM.CODE("43433A20285562756E74752F4C696E61726F20342E352E322D387562756E7475");
SYSTEM.CODE("332920342E352E3200002E73796D746162002E737472746162002E7368737472");
SYSTEM.CODE("746162002E696E74657270002E6E6F74652E4142492D746167002E6E6F74652E");
SYSTEM.CODE("676E752E6275696C642D6964002E676E752E68617368002E64796E73796D002E");
SYSTEM.CODE("64796E737472002E676E752E76657273696F6E002E676E752E76657273696F6E");
SYSTEM.CODE("5F72002E72656C2E64796E002E72656C2E706C74002E696E6974002E74657874");
SYSTEM.CODE("002E66696E69002E726F64617461002E65685F6672616D65002E63746F727300");
SYSTEM.CODE("2E64746F7273002E6A6372002E64796E616D6963002E676F74002E676F742E70");
SYSTEM.CODE("6C74002E64617461002E627373002E636F6D6D656E7400000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("001B000000010000000200000034810408340100001300000000000000000000");
SYSTEM.CODE("0001000000000000002300000007000000020000004881040848010000200000");
SYSTEM.CODE("0000000000000000000400000000000000310000000700000002000000688104");
SYSTEM.CODE("0868010000240000000000000000000000040000000000000044000000F6FFFF");
SYSTEM.CODE("6F020000008C8104088C01000068000000050000000000000004000000040000");
SYSTEM.CODE("004E0000000B00000002000000F4810408F40100004001000006000000010000");
SYSTEM.CODE("0004000000100000005600000003000000020000003483040834030000CD0000");
SYSTEM.CODE("00000000000000000001000000000000005E000000FFFFFF6F02000000028404");
SYSTEM.CODE("080204000028000000050000000000000002000000020000006B000000FEFFFF");
SYSTEM.CODE("6F020000002C8404082C04000060000000060000000200000004000000000000");
SYSTEM.CODE("007A00000009000000020000008C8404088C0400002000000005000000000000");
SYSTEM.CODE("000400000008000000830000000900000002000000AC840408AC040000700000");
SYSTEM.CODE("00050000000C00000004000000080000008C00000001000000060000001C8504");
SYSTEM.CODE("081C050000300000000000000000000000040000000000000087000000010000");
SYSTEM.CODE("00060000004C8504084C050000F0000000000000000000000004000000040000");
SYSTEM.CODE("009200000001000000060000004086040840060000AC05100000000000000000");
SYSTEM.CODE("001000000000000000980000000100000006000000EC8B1408EC0B10001C0000");
SYSTEM.CODE("00000000000000000004000000000000009E0000000100000002000000088C14");
SYSTEM.CODE("08080C10001500000000000000000000000400000000000000A6000000010000");
SYSTEM.CODE("0002000000208C1408200C100004000000000000000000000004000000000000");
SYSTEM.CODE("00B000000001000000030000000C9F14080C0F10000800000000000000000000");
SYSTEM.CODE("000400000000000000B70000000100000003000000149F1408140F1000080000");
SYSTEM.CODE("0000000000000000000400000000000000BE00000001000000030000001C9F14");
SYSTEM.CODE("081C0F10000400000000000000000000000400000000000000C3000000060000");
SYSTEM.CODE("0003000000209F1408200F1000D0000000060000000000000004000000080000");
SYSTEM.CODE("00CC0000000100000003000000F09F1408F00F10000400000000000000000000");
SYSTEM.CODE("000400000004000000D10000000100000003000000F49F1408F40F1000440000");
SYSTEM.CODE("0000000000000000000400000004000000DA000000010000000300000040A014");
SYSTEM.CODE("08401010002000100000000000000000002000000000000000E0000000080000");
SYSTEM.CODE("000300000060A02408601020004000800C000000000000000020000000000000");
SYSTEM.CODE("00E5000000010000003000000000000000601020005400000000000000000000");
SYSTEM.CODE("00010000000100000011000000030000000000000000000000B4102000EE0000");
SYSTEM.CODE("0000000000000000000100000000000000010000000200000000000000000000");
SYSTEM.CODE("002C162000000500001C0000002C000000040000001000000009000000030000");
SYSTEM.CODE("0000000000000000002C1B2000F9020000000000000000000001000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000003481040800000000030001");
SYSTEM.CODE("0000000000488104080000000003000200000000006881040800000000030003");
SYSTEM.CODE("00000000008C810408000000000300040000000000F481040800000000030005");
SYSTEM.CODE("0000000000348304080000000003000600000000000284040800000000030007");
SYSTEM.CODE("00000000002C8404080000000003000800000000008C84040800000000030009");
SYSTEM.CODE("0000000000AC8404080000000003000A00000000001C8504080000000003000B");
SYSTEM.CODE("00000000004C8504080000000003000C0000000000408604080000000003000D");
SYSTEM.CODE("0000000000EC8B14080000000003000E0000000000088C14080000000003000F");
SYSTEM.CODE("0000000000208C14080000000003001000000000000C9F140800000000030011");
SYSTEM.CODE("0000000000149F14080000000003001200000000001C9F140800000000030013");
SYSTEM.CODE("0000000000209F1408000000000300140000000000F09F140800000000030015");
SYSTEM.CODE("0000000000F49F140800000000030016000000000040A0140800000000030017");
SYSTEM.CODE("000000000060A024080000000003001800000000000000000000000000030019");
SYSTEM.CODE("000100000000000000000000000400F1FF0C0000000C9F140800000000010011");
SYSTEM.CODE("001A000000149F14080000000001001200280000001C9F140800000000010013");
SYSTEM.CODE("0035000000708604080000000002000D004B00000084A0240801000000010018");
SYSTEM.CODE("005A00000088A02408040000000100180068000000D08604080000000002000D");
SYSTEM.CODE("000100000000000000000000000400F1FF74000000109F140800000000010011");
SYSTEM.CODE("0081000000208C140800000000010010008F0000001C9F140800000000010013");
SYSTEM.CODE("009B000000C08B14080000000002000D00B100000000000000000000000400F1");
SYSTEM.CODE("FFB8000000F49F14080000000001001600CE0000000C9F140800000000000011");
SYSTEM.CODE("00DF0000000C9F14080000000000001100F2000000209F140800000000010014");
SYSTEM.CODE("00FB00000040A01408000000002000170006010000B08B14080500000012000D");
SYSTEM.CODE("0016010000408604080000000012000D001D0100000000000000000000200000");
SYSTEM.CODE("002C01000000000000000000002000000040010000088C14080400000011000F");
SYSTEM.CODE("0047010000EC8B14080000000012000E004D0100000000000000000000120000");
SYSTEM.CODE("006A0100000C8C14080400000011000F00790100007C85040800000000120000");
SYSTEM.CODE("0089010000A0A024080000800C110018008E01000040A0140800000000100017");
SYSTEM.CODE("009B0100008C8504080000000012000000AC0100009C85040800000000120000");
SYSTEM.CODE("00BD010000AC8504080000000012000000CF01000060A0240804000000110018");
SYSTEM.CODE("00E1010000BC8504080000000012000000F201000044A0140800000000110217");
SYSTEM.CODE("00FF010000CC850408000000001200000011020000DC85040800000000120000");
SYSTEM.CODE("0022020000189F140800000000110212002F020000508B14085A00000012000D");
SYSTEM.CODE("003F02000000000000000000001200000051020000FC85040800000000120000");
SYSTEM.CODE("006302000060A02408000000001000F1FF6F0200000C86040800000000120000");
SYSTEM.CODE("008102000060A0140800001000110017008702000064A0240804000000110018");
SYSTEM.CODE("0098020000A0A0A414000000001000F1FF9D02000080A0240804000000110018");
SYSTEM.CODE("00AF0200001C8604080000000012000000C002000060A02408000000001000F1");
SYSTEM.CODE("FFC70200002C8604080000000012000000D7020000B58B14080000000012020D");
SYSTEM.CODE("00EE020000F48604084D04100012000D00F30200001C8504080000000012000B");
SYSTEM.CODE("000063727473747566662E63005F5F43544F525F4C4953545F5F005F5F44544F");
SYSTEM.CODE("525F4C4953545F5F005F5F4A43525F4C4953545F5F005F5F646F5F676C6F6261");
SYSTEM.CODE("6C5F64746F72735F61757800636F6D706C657465642E363135350064746F725F");
SYSTEM.CODE("6964782E36313537006672616D655F64756D6D79005F5F43544F525F454E445F");
SYSTEM.CODE("5F005F5F4652414D455F454E445F5F005F5F4A43525F454E445F5F005F5F646F");
SYSTEM.CODE("5F676C6F62616C5F63746F72735F6175780070726F672E63005F474C4F42414C");
SYSTEM.CODE("5F4F46465345545F5441424C455F005F5F696E69745F61727261795F656E6400");
SYSTEM.CODE("5F5F696E69745F61727261795F7374617274005F44594E414D49430064617461");
SYSTEM.CODE("5F7374617274005F5F6C6962635F6373755F66696E69005F7374617274005F5F");
SYSTEM.CODE("676D6F6E5F73746172745F5F005F4A765F5265676973746572436C6173736573");
SYSTEM.CODE("005F66705F6877005F66696E69005F5F6C6962635F73746172745F6D61696E40");
SYSTEM.CODE("40474C4942435F322E30005F494F5F737464696E5F7573656400667265654040");
SYSTEM.CODE("474C4942435F322E300064617461005F5F646174615F737461727400646C7379");
SYSTEM.CODE("6D4040474C4942435F322E3000667365656B4040474C4942435F322E30006663");
SYSTEM.CODE("6C6F73654040474C4942435F322E31007374646572724040474C4942435F322E");
SYSTEM.CODE("3000666F70656E4040474C4942435F322E31005F5F64736F5F68616E646C6500");
SYSTEM.CODE("646C6F70656E4040474C4942435F322E31006674656C6C4040474C4942435F32");
SYSTEM.CODE("2E30005F5F44544F525F454E445F5F005F5F6C6962635F6373755F696E697400");
SYSTEM.CODE("7072696E74664040474C4942435F322E30006677726974654040474C4942435F");
SYSTEM.CODE("322E30005F5F6273735F7374617274006D616C6C6F634040474C4942435F322E");
SYSTEM.CODE("3000696461746100737464696E4040474C4942435F322E30005F656E64007374");
SYSTEM.CODE("646F75744040474C4942435F322E300066726561644040474C4942435F322E30");
SYSTEM.CODE("005F656461746100657869744040474C4942435F322E30005F5F693638362E67");
SYSTEM.CODE("65745F70635F7468756E6B2E6278006D61696E005F696E697400");
END data;
IF n MOD _align # 0 THEN
n := n + _align - (n MOD _align)
END
RETURN n
END align;
PROCEDURE Write16 (file: FILE; w: WCHAR);
BEGIN
WR.Write16LE(file, ORD(w))
END Write16;
PROCEDURE WritePH (file: FILE; ph: Elf32_Phdr);
BEGIN
WR.Write32LE(file, ph.p_type);
WR.Write32LE(file, ph.p_offset);
WR.Write32LE(file, ph.p_vaddr);
WR.Write32LE(file, ph.p_paddr);
WR.Write32LE(file, ph.p_filesz);
WR.Write32LE(file, ph.p_memsz);
WR.Write32LE(file, ph.p_flags);
WR.Write32LE(file, ph.p_align)
END WritePH;
PROCEDURE WritePH64 (file: FILE; ph: Elf32_Phdr);
BEGIN
WR.Write32LE(file, ph.p_type);
WR.Write32LE(file, ph.p_flags);
WR.Write64LE(file, ph.p_offset);
WR.Write64LE(file, ph.p_vaddr);
WR.Write64LE(file, ph.p_paddr);
WR.Write64LE(file, ph.p_filesz);
WR.Write64LE(file, ph.p_memsz);
WR.Write64LE(file, ph.p_align)
END WritePH64;
PROCEDURE fixup (program: BIN.PROGRAM; text, data, bss: INTEGER; amd64: BOOLEAN);
VAR
reloc: BIN.RELOC;
L, delta: INTEGER;
BEGIN
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
L := BIN.get32le(program.code, reloc.offset);
delta := 3 - reloc.offset - text - 7 * ORD(amd64);
CASE reloc.opcode OF
|BIN.PICDATA: BIN.put32le(program.code, reloc.offset, L + data + delta)
|BIN.PICCODE: BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + text + delta)
|BIN.PICBSS: BIN.put32le(program.code, reloc.offset, L + bss + delta)
END;
reloc := reloc.next(BIN.RELOC)
END;
END fixup;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; amd64: BOOLEAN);
CONST
interp = 0;
dyn = 1;
header = 2;
text = 3;
data = 4;
bss = 5;
VAR
ehdr: Elf32_Ehdr;
phdr: ARRAY 16 OF Elf32_Phdr;
i, LoadAdr, offset, pad, VA: INTEGER;
SizeOf: RECORD header, code, data, bss: INTEGER END;
File: FILE;
str: ARRAY 40 OF CHAR; lstr: INTEGER;
Dyn: ARRAY 350 OF BYTE;
BEGIN
IF amd64 THEN
str := "/lib64/ld-linux-x86-64.so.2"
ELSE
str := "/lib/ld-linux.so.2"
END;
lstr := LENGTH(str);
IF amd64 THEN
LoadAdr := 400000H
ELSE
LoadAdr := 08048000H
END;
SizeOf.code := CHL.Length(program.code);
SizeOf.data := CHL.Length(program.data);
SizeOf.bss := program.bss;
ehdr.e_ident[0] := 7FH;
ehdr.e_ident[1] := ORD("E");
ehdr.e_ident[2] := ORD("L");
ehdr.e_ident[3] := ORD("F");
IF amd64 THEN
ehdr.e_ident[4] := ELFCLASS64
ELSE
ehdr.e_ident[4] := ELFCLASS32
END;
ehdr.e_ident[5] := ELFDATA2LSB;
ehdr.e_ident[6] := 1;
ehdr.e_ident[7] := 3;
FOR i := 8 TO EI_NIDENT - 1 DO
ehdr.e_ident[i] := 0
END;
ehdr.e_type := WCHR(ET_EXEC);
ehdr.e_version := 1;
ehdr.e_shoff := 0;
ehdr.e_flags := 0;
ehdr.e_shnum := WCHR(0);
ehdr.e_shstrndx := WCHR(0);
ehdr.e_phnum := WCHR(6);
IF amd64 THEN
ehdr.e_machine := WCHR(EM_8664);
ehdr.e_phoff := 40H;
ehdr.e_ehsize := WCHR(40H);
ehdr.e_phentsize := WCHR(38H);
ehdr.e_shentsize := WCHR(40H)
ELSE
ehdr.e_machine := WCHR(EM_386);
ehdr.e_phoff := 34H;
ehdr.e_ehsize := WCHR(34H);
ehdr.e_phentsize := WCHR(20H);
ehdr.e_shentsize := WCHR(28H)
END;
SizeOf.header := ORD(ehdr.e_ehsize) + ORD(ehdr.e_phentsize) * ORD(ehdr.e_phnum);
phdr[interp].p_type := 3;
phdr[interp].p_offset := SizeOf.header;
phdr[interp].p_vaddr := LoadAdr + phdr[interp].p_offset;
phdr[interp].p_paddr := LoadAdr + phdr[interp].p_offset;
phdr[interp].p_filesz := lstr + 1;
phdr[interp].p_memsz := lstr + 1;
phdr[interp].p_flags := PF_R;
phdr[interp].p_align := 1;
phdr[dyn].p_type := 2;
phdr[dyn].p_offset := phdr[interp].p_offset + phdr[interp].p_filesz;
phdr[dyn].p_vaddr := LoadAdr + phdr[dyn].p_offset;
phdr[dyn].p_paddr := LoadAdr + phdr[dyn].p_offset;
IF amd64 THEN
phdr[dyn].p_filesz := 0A0H;
phdr[dyn].p_memsz := 0A0H
ELSE
phdr[dyn].p_filesz := 50H;
phdr[dyn].p_memsz := 50H
END;
phdr[dyn].p_flags := PF_R;
phdr[dyn].p_align := 1;
offset := 0;
phdr[header].p_type := 1;
phdr[header].p_offset := offset;
phdr[header].p_vaddr := LoadAdr;
phdr[header].p_paddr := LoadAdr;
IF amd64 THEN
phdr[header].p_filesz := 305H;
phdr[header].p_memsz := 305H
ELSE
phdr[header].p_filesz := 1D0H;
phdr[header].p_memsz := 1D0H
END;
phdr[header].p_flags := PF_R + PF_W;
phdr[header].p_align := 1000H;
offset := offset + phdr[header].p_filesz;
VA := LoadAdr + offset + 1000H;
phdr[text].p_type := 1;
phdr[text].p_offset := offset;
phdr[text].p_vaddr := VA;
phdr[text].p_paddr := VA;
phdr[text].p_filesz := SizeOf.code;
phdr[text].p_memsz := SizeOf.code;
phdr[text].p_flags := PF_X + PF_R;
phdr[text].p_align := 1000H;
ehdr.e_entry := phdr[text].p_vaddr;
offset := offset + phdr[text].p_filesz;
VA := LoadAdr + offset + 2000H;
pad := (16 - VA MOD 16) MOD 16;
phdr[data].p_type := 1;
phdr[data].p_offset := offset;
phdr[data].p_vaddr := VA;
phdr[data].p_paddr := VA;
phdr[data].p_filesz := SizeOf.data + pad;
phdr[data].p_memsz := SizeOf.data + pad;
phdr[data].p_flags := PF_R + PF_W;
phdr[data].p_align := 1000H;
offset := offset + phdr[data].p_filesz;
VA := LoadAdr + offset + 3000H;
phdr[bss].p_type := 1;
phdr[bss].p_offset := offset;
phdr[bss].p_vaddr := VA;
phdr[bss].p_paddr := VA;
phdr[bss].p_filesz := 0;
phdr[bss].p_memsz := SizeOf.bss + 16;
phdr[bss].p_flags := PF_R + PF_W;
phdr[bss].p_align := 1000H;
fixup(program, phdr[text].p_vaddr, phdr[data].p_vaddr + pad, align(phdr[bss].p_vaddr, 16), amd64);
File := WR.Create(FileName);
FOR i := 0 TO EI_NIDENT - 1 DO
WR.WriteByte(File, ehdr.e_ident[i])
END;
Write16(File, ehdr.e_type);
Write16(File, ehdr.e_machine);
WR.Write32LE(File, ehdr.e_version);
IF amd64 THEN
WR.Write64LE(File, ehdr.e_entry);
WR.Write64LE(File, ehdr.e_phoff);
WR.Write64LE(File, ehdr.e_shoff)
ELSE
WR.Write32LE(File, ehdr.e_entry);
WR.Write32LE(File, ehdr.e_phoff);
WR.Write32LE(File, ehdr.e_shoff)
END;
WR.Write32LE(File, ehdr.e_flags);
Write16(File, ehdr.e_ehsize);
Write16(File, ehdr.e_phentsize);
Write16(File, ehdr.e_phnum);
Write16(File, ehdr.e_shentsize);
Write16(File, ehdr.e_shnum);
Write16(File, ehdr.e_shstrndx);
IF amd64 THEN
WritePH64(File, phdr[interp]);
WritePH64(File, phdr[dyn]);
WritePH64(File, phdr[header]);
WritePH64(File, phdr[text]);
WritePH64(File, phdr[data]);
WritePH64(File, phdr[bss])
ELSE
WritePH(File, phdr[interp]);
WritePH(File, phdr[dyn]);
WritePH(File, phdr[header]);
WritePH(File, phdr[text]);
WritePH(File, phdr[data]);
WritePH(File, phdr[bss])
END;
FOR i := 0 TO lstr DO
WR.WriteByte(File, ORD(str[i]))
END;
i := 0;
IF amd64 THEN
BIN.InitArray(Dyn, i, "01000000000000000E000000000000000500000000000000DC02400000000000");
BIN.InitArray(Dyn, i, "0A00000000000000190000000000000006000000000000004C02400000000000");
BIN.InitArray(Dyn, i, "0B00000000000000180000000000000007000000000000009402400000000000");
BIN.InitArray(Dyn, i, "0800000000000000300000000000000009000000000000001800000000000000");
BIN.InitArray(Dyn, i, "0400000000000000C40240000000000000000000000000000000000000000000");
BIN.InitArray(Dyn, i, "0000000000000000000000000000000000000000000000000100000012000000");
BIN.InitArray(Dyn, i, "0000000000000000000000000000000008000000120000000000000000000000");
BIN.InitArray(Dyn, i, "0000000000000000F50240000000000001000000010000000000000000000000");
BIN.InitArray(Dyn, i, "FD02400000000000010000000200000000000000000000000100000003000000");
BIN.InitArray(Dyn, i, "0000000001000000020000000000000000646C6F70656E00646C73796D006C69");
BIN.InitArray(Dyn, i, "62646C2E736F2E320000000000000000000000000000000000")
ELSE
BIN.InitArray(Dyn, i, "010000000E00000005000000AF8104080A000000190000000600000057810408");
BIN.InitArray(Dyn, i, "0B00000010000000110000008781040812000000100000001300000008000000");
BIN.InitArray(Dyn, i, "0400000097810408000000000000000000000000000000000000000000000000");
BIN.InitArray(Dyn, i, "0100000000000000000000001200000008000000000000000000000012000000");
BIN.InitArray(Dyn, i, "C881040801010000CC8104080102000001000000030000000000000001000000");
BIN.InitArray(Dyn, i, "020000000000000000646C6F70656E00646C73796D006C6962646C2E736F2E32");
BIN.InitArray(Dyn, i, "000000000000000000")
END;
WR.Write(File, Dyn, i);
CHL.WriteToFile(File, program.code);
WHILE pad > 0 DO
WR.WriteByte(File, 0);
DEC(pad)
END;
CHL.WriteToFile(File, program.data);
WR.Close(File)
END write;
PROCEDURE get*(): INTEGER;
RETURN SYSTEM.ADR(data) + 3
END get;
END ELF.

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

@ -1,285 +1,171 @@
(*
Copyright 2016, 2017 Anton Krotov
(*
BSD 2-Clause License
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE ERRORS;
IMPORT H := HOST;
IMPORT C := CONSOLE, UTILS;
TYPE
STRING = ARRAY 1024 OF CHAR;
PROCEDURE hintmsg* (name: ARRAY OF CHAR; line, col, hint: INTEGER);
BEGIN
IF hint = 0 THEN
C.String(" hint ("); C.Int(line); C.String(":"); C.Int(col); C.String(")");
C.String(" variable '"); C.String(name); C.StringLn("' never used")
END
END hintmsg;
CP = ARRAY 256 OF INTEGER;
PROCEDURE errormsg* (fname: ARRAY OF CHAR; line, col, errno: INTEGER);
VAR
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;
str: ARRAY 80 OF CHAR;
BEGIN
InitCP866(cp)
C.Ln;
C.String(" error ("); C.Int(line); C.String(":"); C.Int(col); C.String(") ");
CASE errno OF
| 1: str := "missing 'H' or 'X'"
| 2: str := "missing scale"
| 3: str := "unclosed string"
| 4: str := "illegal character"
| 5: str := "string too long"
| 6: str := "identifier too long"
| 7: str := "number too long"
| 8..12: str := "number too large"
| 21: str := "'MODULE' expected"
| 22: str := "identifier expected"
| 23: str := "module name does not match file name"
| 24: str := "';' expected"
| 25: str := "identifier does not match module name"
| 26: str := "'.' expected"
| 27: str := "'END' expected"
| 28: str := "',', ';' or ':=' expected"
| 29: str := "module not found"
| 30: str := "multiply defined identifier"
| 31: str := "recursive import"
| 32: str := "'=' expected"
| 33: str := "')' expected"
| 34: str := "syntax error in expression"
| 35: str := "'}' expected"
| 36: str := "incompatible operand"
| 37: str := "incompatible operands"
| 38: str := "'RETURN' expected"
| 39: str := "integer overflow"
| 40: str := "floating point overflow"
| 41: str := "not enough floating point registers; simplify expression"
| 42: str := "out of range 0..255"
| 43: str := "expression is not an integer"
| 44: str := "out of range 0..MAXSET"
| 45: str := "division by zero"
| 46: str := "integer division by zero"
| 47: str := "'OF' or ',' expected"
| 48: str := "undeclared identifier"
| 49: str := "type expected"
| 50: str := "recursive type definition"
| 51: str := "illegal value of constant"
| 52: str := "not a record type"
| 53: str := "':' expected"
| 54: str := "need to import SYSTEM"
| 55: str := "pointer type not defined"
| 56: str := "out of range 0..MAXSET"
| 57: str := "'TO' expected"
| 58: str := "not a record type"
| 59: str := "this expression cannot be a procedure"
| 60: str := "identifier does not match procedure name"
| 61: str := "illegally marked identifier"
| 62: str := "expression should be constant"
| 63: str := "'stdcall', 'ccall', 'ccall16', 'windows' or 'linux' expected"
| 64: str := "'(' expected"
| 65: str := "',' expected"
| 66: str := "incompatible parameter"
| 67: str := "'OF' expected"
| 68: str := "type expected"
| 69: str := "result type of procedure is not a basic type"
| 70: str := "import not supported"
| 71: str := "']' expected"
| 72: str := "expression is not BOOLEAN"
| 73: str := "not a record"
| 74: str := "undefined record field"
| 75: str := "not an array"
| 76: str := "expression is not an integer"
| 77: str := "not a pointer"
| 78: str := "type guard not allowed"
| 79: str := "not a type"
| 80: str := "not a record type"
| 81: str := "not a pointer type"
| 82: str := "type guard not allowed"
| 83: str := "index out of range"
| 84: str := "dimension too large"
| 85: str := "procedure must have level 0"
| 86: str := "not a procedure"
| 87: str := "incompatible expression (RETURN)"
| 88: str := "'THEN' expected"
| 89: str := "'DO' expected"
| 90: str := "'UNTIL' expected"
| 91: str := "incompatible assignment"
| 92: str := "procedure call of a function"
| 93: str := "not a variable"
| 94: str := "read only variable"
| 95: str := "invalid type of expression (CASE)"
| 96: str := "':=' expected"
| 97: str := "not INTEGER variable"
| 98: str := "illegal value of constant (0)"
| 99: str := "incompatible label"
|100: str := "multiply defined label"
|101: str := "too large parameter of WCHR"
|102: str := "label expected"
|103: str := "illegal value of constant"
|104: str := "type too large"
|105: str := "access to intermediate variables not allowed"
|106: str := "qualified identifier expected"
|107: str := "too large parameter of CHR"
|108: str := "a variable or a procedure expected"
|109: str := "expression should be constant"
|110: str := "'noalign' expected"
|111: str := "record [noalign] cannot have a base type"
|112: str := "record [noalign] cannot be a base type"
|113: str := "result type of procedure should not be REAL"
|114: str := "identifiers 'lib_init' and 'version' are reserved"
|115: str := "recursive constant definition"
|116: str := "procedure too deep nested"
|117: str := "'stdcall64', 'win64', 'systemv', 'windows' or 'linux' expected"
|118: str := "this flag for Windows only"
|119: str := "this flag for Linux only"
|120: str := "too many formal parameters"
END;
C.StringLn(str);
C.String(" file: "); C.StringLn(fname);
UTILS.Exit(1)
END errormsg;
PROCEDURE error1* (s1: ARRAY OF CHAR);
BEGIN
C.Ln;
C.StringLn(s1);
UTILS.Exit(1)
END error1;
PROCEDURE error3* (s1, s2, s3: ARRAY OF CHAR);
BEGIN
C.Ln;
C.String(s1); C.String(s2); C.StringLn(s3);
UTILS.Exit(1)
END error3;
PROCEDURE error5* (s1, s2, s3, s4, s5: ARRAY OF CHAR);
BEGIN
C.Ln;
C.String(s1); C.String(s2); C.String(s3); C.String(s4); C.StringLn(s5);
UTILS.Exit(1)
END error5;
END ERRORS.

219
programs/develop/oberon07/Source/FILES.ob07 Normal file
View File

@ -0,0 +1,219 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE FILES;
IMPORT UTILS, C := COLLECTIONS, CONSOLE;
TYPE
FILE* = POINTER TO RECORD (C.ITEM)
ptr: INTEGER;
buffer: ARRAY 64*1024 OF BYTE;
count: INTEGER
END;
VAR
files: C.COLLECTION;
PROCEDURE copy (src: ARRAY OF BYTE; src_idx: INTEGER; VAR dst: ARRAY OF BYTE; dst_idx: INTEGER; bytes: INTEGER);
BEGIN
WHILE bytes > 0 DO
dst[dst_idx] := src[src_idx];
INC(dst_idx);
INC(src_idx);
DEC(bytes)
END
END copy;
PROCEDURE flush (file: FILE): INTEGER;
VAR
res: INTEGER;
BEGIN
IF file # NIL THEN
res := UTILS.FileWrite(file.ptr, file.buffer, file.count);
IF res < 0 THEN
res := 0
END
ELSE
res := 0
END
RETURN res
END flush;
PROCEDURE NewFile (): FILE;
VAR
file: FILE;
citem: C.ITEM;
BEGIN
citem := C.pop(files);
IF citem = NIL THEN
NEW(file)
ELSE
file := citem(FILE)
END
RETURN file
END NewFile;
PROCEDURE create* (name: ARRAY OF CHAR): FILE;
VAR
file: FILE;
ptr: INTEGER;
BEGIN
ptr := UTILS.FileCreate(name);
IF ptr > 0 THEN
file := NewFile();
file.ptr := ptr;
file.count := 0
ELSE
file := NIL
END
RETURN file
END create;
PROCEDURE open* (name: ARRAY OF CHAR): FILE;
VAR
file: FILE;
ptr: INTEGER;
BEGIN
ptr := UTILS.FileOpen(name);
IF ptr > 0 THEN
file := NewFile();
file.ptr := ptr;
file.count := -1
ELSE
file := NIL
END
RETURN file
END open;
PROCEDURE close* (VAR file: FILE);
VAR
n: INTEGER;
BEGIN
IF file # NIL THEN
IF file.count > 0 THEN
n := flush(file)
END;
file.count := -1;
UTILS.FileClose(file.ptr);
file.ptr := 0;
C.push(files, file);
file := NIL
END
END close;
PROCEDURE read* (file: FILE; VAR chunk: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
IF file # NIL THEN
res := UTILS.FileRead(file.ptr, chunk, MAX(MIN(bytes, LEN(chunk)), 0));
IF res < 0 THEN
res := 0
END
ELSE
res := 0
END
RETURN res
END read;
PROCEDURE write* (file: FILE; chunk: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
VAR
free, n, k, res, idx: INTEGER;
BEGIN
idx := 0;
res := 0;
IF (file # NIL) & (file.count >= 0) THEN
free := LEN(file.buffer) - file.count;
WHILE bytes > 0 DO
n := MIN(free, bytes);
copy(chunk, idx, file.buffer, file.count, n);
INC(res, n);
DEC(free, n);
DEC(bytes, n);
INC(idx, n);
INC(file.count, n);
IF free = 0 THEN
k := flush(file);
IF k # LEN(file.buffer) THEN
bytes := 0;
DEC(res, n)
ELSE
file.count := 0;
free := LEN(file.buffer)
END
END
END
END
RETURN res
END write;
PROCEDURE WriteByte* (file: FILE; byte: BYTE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := TRUE;
IF (file # NIL) & (file.count >= 0) THEN
IF file.count = LEN(file.buffer) THEN
IF flush(file) # LEN(file.buffer) THEN
res := FALSE
ELSE
file.buffer[0] := byte;
file.count := 1
END
ELSE
file.buffer[file.count] := byte;
INC(file.count)
END
ELSE
res := FALSE
END
RETURN res
END WriteByte;
BEGIN
files := C.create()
END FILES.

218
programs/develop/oberon07/Source/KOS.ob07 Normal file
View File

@ -0,0 +1,218 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE KOS;
IMPORT BIN, WR := WRITER, LISTS, CHL := CHUNKLISTS;
CONST
HEADER_SIZE = 36;
SIZE_OF_DWORD = 4;
TYPE
FILE = WR.FILE;
HEADER = RECORD
menuet01: ARRAY 9 OF CHAR;
ver, start, size, mem, sp, param, path: INTEGER
END;
PROCEDURE align (n, _align: INTEGER): INTEGER;
BEGIN
IF n MOD _align # 0 THEN
n := n + _align - (n MOD _align)
END
RETURN n
END align;
PROCEDURE Import* (program: BIN.PROGRAM; idata: INTEGER; VAR ImportTable: CHL.INTLIST; VAR len, libcount, size: INTEGER);
VAR
i: INTEGER;
import: BIN.IMPRT;
BEGIN
libcount := 0;
import := program.imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
INC(libcount)
END;
import := import.next(BIN.IMPRT)
END;
len := libcount * 2 + 2;
size := (LISTS.count(program.imp_list) + len + 1) * SIZE_OF_DWORD;
ImportTable := CHL.CreateIntList();
FOR i := 0 TO size DIV SIZE_OF_DWORD - 1 DO
CHL.PushInt(ImportTable, 0)
END;
i := 0;
import := program.imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
CHL.SetInt(ImportTable, len, 0);
INC(len);
CHL.SetInt(ImportTable, i, idata + len * SIZE_OF_DWORD);
INC(i);
CHL.SetInt(ImportTable, i, import.nameoffs + size + idata);
INC(i)
ELSE
CHL.SetInt(ImportTable, len, import.nameoffs + size + idata);
import.label := len * SIZE_OF_DWORD;
INC(len)
END;
import := import.next(BIN.IMPRT)
END;
CHL.SetInt(ImportTable, len, 0);
CHL.SetInt(ImportTable, i, 0);
CHL.SetInt(ImportTable, i + 1, 0);
INC(len);
size := size + CHL.Length(program.import)
END Import;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR);
CONST
PARAM_SIZE = 2048;
FileAlignment = 16;
VAR
header: HEADER;
base, text, data, idata, bss: INTEGER;
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
L: INTEGER;
delta: INTEGER;
i: INTEGER;
File: FILE;
ImportTable: CHL.INTLIST;
ILen, libcount, isize: INTEGER;
icount, dcount, ccount: INTEGER;
BEGIN
base := 0;
icount := CHL.Length(program.import);
dcount := CHL.Length(program.data);
ccount := CHL.Length(program.code);
text := base + HEADER_SIZE;
data := align(text + ccount, FileAlignment);
idata := align(data + dcount, FileAlignment);
Import(program, idata, ImportTable, ILen, libcount, isize);
bss := align(idata + isize, FileAlignment);
header.menuet01 := "MENUET01";
header.ver := 1;
header.start := text;
header.size := idata + isize - base;
header.mem := align(header.size + program.stack + program.bss + PARAM_SIZE * 2 + 4096, FileAlignment);
header.sp := base + header.mem - PARAM_SIZE * 2;
header.param := header.sp;
header.path := header.param + PARAM_SIZE;
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
L := BIN.get32le(program.code, reloc.offset);
delta := 3 - reloc.offset - text;
CASE reloc.opcode OF
|BIN.RIMP:
iproc := BIN.GetIProc(program, L);
BIN.put32le(program.code, reloc.offset, idata + iproc.label)
|BIN.RBSS:
BIN.put32le(program.code, reloc.offset, L + bss)
|BIN.RDATA:
BIN.put32le(program.code, reloc.offset, L + data)
|BIN.RCODE:
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + text)
|BIN.PICDATA:
BIN.put32le(program.code, reloc.offset, L + data + delta)
|BIN.PICCODE:
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + text + delta)
|BIN.PICBSS:
BIN.put32le(program.code, reloc.offset, L + bss + delta)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
BIN.put32le(program.code, reloc.offset, idata + iproc.label + delta)
|BIN.IMPTAB:
BIN.put32le(program.code, reloc.offset, idata + delta)
END;
reloc := reloc.next(BIN.RELOC)
END;
File := WR.Create(FileName);
FOR i := 0 TO 7 DO
WR.WriteByte(File, ORD(header.menuet01[i]))
END;
WR.Write32LE(File, header.ver);
WR.Write32LE(File, header.start);
WR.Write32LE(File, header.size);
WR.Write32LE(File, header.mem);
WR.Write32LE(File, header.sp);
WR.Write32LE(File, header.param);
WR.Write32LE(File, header.path);
CHL.WriteToFile(File, program.code);
WR.Padding(File, FileAlignment);
CHL.WriteToFile(File, program.data);
WR.Padding(File, FileAlignment);
FOR i := 0 TO ILen - 1 DO
WR.Write32LE(File, CHL.GetInt(ImportTable, i))
END;
CHL.WriteToFile(File, program.import);
WR.Close(File)
END write;
END KOS.

184
programs/develop/oberon07/Source/LISTS.ob07 Normal file
View File

@ -0,0 +1,184 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE LISTS;
IMPORT C := COLLECTIONS;
TYPE
ITEM* = POINTER TO RECORD (C.ITEM)
prev*, next*: ITEM
END;
LIST* = POINTER TO RECORD
first*, last*: ITEM
END;
PROCEDURE push* (list: LIST; item: ITEM);
BEGIN
ASSERT(list # NIL);
ASSERT(item # NIL);
IF list.first = NIL THEN
list.first := item;
list.last := item;
item.prev := NIL;
item.next := NIL
ELSE
ASSERT(list.last # NIL);
item.prev := list.last;
list.last.next := item;
item.next := NIL;
list.last := item
END
END push;
PROCEDURE pop* (list: LIST): ITEM;
VAR
last: ITEM;
BEGIN
ASSERT(list # NIL);
last := list.last;
IF last # NIL THEN
IF last = list.first THEN
list.first := NIL;
list.last := NIL
ELSE
list.last := last.prev;
list.last.next := NIL
END;
last.next := NIL;
last.prev := NIL
END
RETURN last
END pop;
PROCEDURE insert* (list: LIST; cur, nov: ITEM);
VAR
next: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(nov # NIL);
ASSERT(cur # NIL);
next := cur.next;
IF next # NIL THEN
next.prev := nov;
nov.next := next;
cur.next := nov;
nov.prev := cur
ELSE
push(list, nov)
END
END insert;
PROCEDURE insertL* (list: LIST; cur, nov: ITEM);
VAR
prev: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(nov # NIL);
ASSERT(cur # NIL);
prev := cur.prev;
IF prev # NIL THEN
prev.next := nov;
nov.prev := prev;
cur.prev := nov;
nov.next := cur
ELSE
nov.prev := NIL;
cur.prev := nov;
nov.next := cur;
list.first := nov
END
END insertL;
PROCEDURE delete* (list: LIST; item: ITEM);
VAR
prev, next: ITEM;
BEGIN
ASSERT(list # NIL);
ASSERT(item # NIL);
prev := item.prev;
next := item.next;
IF (next # NIL) & (prev # NIL) THEN
prev.next := next;
next.prev := prev
ELSIF (next = NIL) & (prev = NIL) THEN
list.first := NIL;
list.last := NIL
ELSIF (next = NIL) & (prev # NIL) THEN
prev.next := NIL;
list.last := prev
ELSIF (next # NIL) & (prev = NIL) THEN
next.prev := NIL;
list.first := next
END
END delete;
PROCEDURE count* (list: LIST): INTEGER;
VAR
item: ITEM;
res: INTEGER;
BEGIN
ASSERT(list # NIL);
res := 0;
item := list.first;
WHILE item # NIL DO
INC(res);
item := item.next
END
RETURN res
END count;
PROCEDURE create* (list: LIST): LIST;
BEGIN
IF list = NIL THEN
NEW(list)
END;
list.first := NIL;
list.last := NIL
RETURN list
END create;
END LISTS.

110
programs/develop/oberon07/Source/MACHINE.ob07 Normal file
View File

@ -0,0 +1,110 @@
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE MACHINE;
IMPORT UTILS;
CONST
min32* = -2147483647-1;
max32* = 2147483647;
VAR
target*:
RECORD
bit_depth*,
maxInt*,
minInt*,
maxSet*,
maxHex*: INTEGER;
maxReal*: REAL
END;
_64to32*: BOOLEAN;
PROCEDURE SetBitDepth* (pBitDepth: INTEGER);
BEGIN
ASSERT(pBitDepth <= UTILS.bit_depth);
ASSERT((pBitDepth = 32) OR (pBitDepth = 64));
_64to32 := (UTILS.bit_depth = 64) & (pBitDepth = 32);
target.bit_depth := pBitDepth;
target.maxSet := pBitDepth - 1;
target.maxHex := pBitDepth DIV 4;
target.minInt := ASR(UTILS.minint, UTILS.bit_depth - pBitDepth);
target.maxInt := ASR(UTILS.maxint, UTILS.bit_depth - pBitDepth);
target.maxReal := 1.9;
PACK(target.maxReal, 1023);
END SetBitDepth;
PROCEDURE Byte* (n: INTEGER; idx: INTEGER): BYTE;
BEGIN
WHILE idx > 0 DO
n := ASR(n, 8);
DEC(idx)
END
RETURN ORD(BITS(n) * {0..7})
END Byte;
PROCEDURE Align* (VAR bytes: INTEGER; align: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF bytes MOD align # 0 THEN
res := UTILS.maxint - bytes >= align - (bytes MOD align);
IF res THEN
bytes := bytes + align - (bytes MOD align)
END
ELSE
res := TRUE
END
RETURN res
END Align;
PROCEDURE Int32To64* (value: INTEGER): INTEGER;
BEGIN
IF UTILS.bit_depth = 64 THEN
value := LSL(value, 16);
value := LSL(value, 16);
value := ASR(value, 16);
value := ASR(value, 16)
END
RETURN value
END Int32To64;
PROCEDURE Int64To32* (value: INTEGER): INTEGER;
BEGIN
IF UTILS.bit_depth = 64 THEN
value := LSL(value, 16);
value := LSL(value, 16);
value := LSR(value, 16);
value := LSR(value, 16)
END
RETURN value
END Int64To32;
END MACHINE.

316
programs/develop/oberon07/Source/MSCOFF.ob07 Normal file
View File

@ -0,0 +1,316 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE MSCOFF;
IMPORT BIN, PE32, KOS, WR := WRITER, UTILS, ERRORS, LISTS, CHL := CHUNKLISTS;
CONST
SIZE_OF_DWORD = 4;
(* SectionHeader.Characteristics *)
SHC_flat = 040500020H;
SHC_data = 0C0500040H;
SHC_bss = 0C03000C0H;
TYPE
FH = PE32.IMAGE_FILE_HEADER;
SH = PE32.IMAGE_SECTION_HEADER;
PROCEDURE WriteReloc (File: WR.FILE; VirtualAddress, SymbolTableIndex, Type: INTEGER);
BEGIN
WR.Write32LE(File, VirtualAddress);
WR.Write32LE(File, SymbolTableIndex);
WR.Write16LE(File, Type)
END WriteReloc;
PROCEDURE Reloc (program: BIN.PROGRAM; File: WR.FILE);
VAR
reloc: BIN.RELOC;
BEGIN
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
CASE reloc.opcode OF
|BIN.RIMP, BIN.IMPTAB:
WriteReloc(File, reloc.offset, 4, 6)
|BIN.RBSS:
WriteReloc(File, reloc.offset, 5, 6)
|BIN.RDATA:
WriteReloc(File, reloc.offset, 2, 6)
|BIN.RCODE:
WriteReloc(File, reloc.offset, 1, 6)
END;
reloc := reloc.next(BIN.RELOC)
END;
END Reloc;
PROCEDURE RelocCount (program: BIN.PROGRAM): INTEGER;
VAR
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
res, L: INTEGER;
BEGIN
res := 0;
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
INC(res);
IF reloc.opcode = BIN.RIMP THEN
L := BIN.get32le(program.code, reloc.offset);
iproc := BIN.GetIProc(program, L);
BIN.put32le(program.code, reloc.offset, iproc.label)
END;
IF reloc.opcode = BIN.RCODE THEN
L := BIN.get32le(program.code, reloc.offset);
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L))
END;
reloc := reloc.next(BIN.RELOC)
END
RETURN res
END RelocCount;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; ver: INTEGER);
VAR
File: WR.FILE;
exp: BIN.EXPRT;
n, i: INTEGER;
szversion: PE32.NAME;
ImportTable: CHL.INTLIST;
ILen, LibCount, isize: INTEGER;
ExpCount: INTEGER;
icount, ecount, dcount, ccount: INTEGER;
FileHeader: FH;
flat, data, edata, idata, bss: SH;
PROCEDURE ICount (ImportTable: CHL.INTLIST; ILen: INTEGER): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := 0;
FOR i := 0 TO ILen - 1 DO
IF CHL.GetInt(ImportTable, i) # 0 THEN
INC(res)
END
END
RETURN res
END ICount;
PROCEDURE SetNumberOfRelocations (VAR section: SH; NumberOfRelocations: INTEGER);
BEGIN
IF NumberOfRelocations >= 65536 THEN
ERRORS.error1("too many relocations")
END;
section.NumberOfRelocations := WCHR(NumberOfRelocations)
END SetNumberOfRelocations;
BEGIN
szversion := "version";
ASSERT(LENGTH(szversion) = 7);
KOS.Import(program, 0, ImportTable, ILen, LibCount, isize);
ExpCount := LISTS.count(program.exp_list);
icount := CHL.Length(program.import);
dcount := CHL.Length(program.data);
ccount := CHL.Length(program.code);
ecount := CHL.Length(program.export);
FileHeader.Machine := 014CX;
FileHeader.NumberOfSections := 5X;
FileHeader.TimeDateStamp := UTILS.UnixTime();
//FileHeader.PointerToSymbolTable := 0;
FileHeader.NumberOfSymbols := 6;
FileHeader.SizeOfOptionalHeader := 0X;
FileHeader.Characteristics := 0184X;
flat.Name := ".flat";
flat.VirtualSize := 0;
flat.VirtualAddress := 0;
flat.SizeOfRawData := ccount;
flat.PointerToRawData := ORD(FileHeader.NumberOfSections) * PE32.SIZE_OF_IMAGE_SECTION_HEADER + PE32.SIZE_OF_IMAGE_FILE_HEADER;
//flat.PointerToRelocations := 0;
flat.PointerToLinenumbers := 0;
SetNumberOfRelocations(flat, RelocCount(program));
flat.NumberOfLinenumbers := 0X;
flat.Characteristics := SHC_flat;
data.Name := ".data";
data.VirtualSize := 0;
data.VirtualAddress := 0;
data.SizeOfRawData := dcount;
data.PointerToRawData := flat.PointerToRawData + flat.SizeOfRawData;
data.PointerToRelocations := 0;
data.PointerToLinenumbers := 0;
data.NumberOfRelocations := 0X;
data.NumberOfLinenumbers := 0X;
data.Characteristics := SHC_data;
edata.Name := ".edata";
edata.VirtualSize := 0;
edata.VirtualAddress := 0;
edata.SizeOfRawData := ((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD + LENGTH(szversion) + 1 + ecount;
edata.PointerToRawData := data.PointerToRawData + data.SizeOfRawData;
//edata.PointerToRelocations := 0;
edata.PointerToLinenumbers := 0;
SetNumberOfRelocations(edata, ExpCount * 2 + 1);
edata.NumberOfLinenumbers := 0X;
edata.Characteristics := SHC_data;
idata.Name := ".idata";
idata.VirtualSize := 0;
idata.VirtualAddress := 0;
idata.SizeOfRawData := isize;
idata.PointerToRawData := edata.PointerToRawData + edata.SizeOfRawData;
//idata.PointerToRelocations := 0;
idata.PointerToLinenumbers := 0;
SetNumberOfRelocations(idata, ICount(ImportTable, ILen));
idata.NumberOfLinenumbers := 0X;
idata.Characteristics := SHC_data;
bss.Name := ".bss";
bss.VirtualSize := 0;
bss.VirtualAddress := 0;
bss.SizeOfRawData := program.bss;
bss.PointerToRawData := 0;
bss.PointerToRelocations := 0;
bss.PointerToLinenumbers := 0;
bss.NumberOfRelocations := 0X;
bss.NumberOfLinenumbers := 0X;
bss.Characteristics := SHC_bss;
flat.PointerToRelocations := idata.PointerToRawData + idata.SizeOfRawData;
edata.PointerToRelocations := flat.PointerToRelocations + ORD(flat.NumberOfRelocations) * 10;
idata.PointerToRelocations := edata.PointerToRelocations + ORD(edata.NumberOfRelocations) * 10;
FileHeader.PointerToSymbolTable := idata.PointerToRelocations + ORD(idata.NumberOfRelocations) * 10;
File := WR.Create(FileName);
PE32.WriteFileHeader(File, FileHeader);
PE32.WriteSectionHeader(File, flat);
PE32.WriteSectionHeader(File, data);
PE32.WriteSectionHeader(File, edata);
PE32.WriteSectionHeader(File, idata);
PE32.WriteSectionHeader(File, bss);
CHL.WriteToFile(File, program.code);
CHL.WriteToFile(File, program.data);
exp := program.exp_list.first(BIN.EXPRT);
WHILE exp # NIL DO
WR.Write32LE(File, exp.nameoffs + edata.SizeOfRawData - ecount);
WR.Write32LE(File, exp.label);
exp := exp.next(BIN.EXPRT)
END;
WR.Write32LE(File, ((ExpCount + 1) * 2 + 1) * SIZE_OF_DWORD);
WR.Write32LE(File, ver);
WR.Write32LE(File, 0);
PE32.WriteName(File, szversion);
CHL.WriteToFile(File, program.export);
FOR i := 0 TO ILen - 1 DO
WR.Write32LE(File, CHL.GetInt(ImportTable, i))
END;
CHL.WriteToFile(File, program.import);
Reloc(program, File);
n := 0;
exp := program.exp_list.first(BIN.EXPRT);
WHILE exp # NIL DO
WriteReloc(File, n, 3, 6);
INC(n, 4);
WriteReloc(File, n, 1, 6);
INC(n, 4);
exp := exp.next(BIN.EXPRT)
END;
WriteReloc(File, n, 3, 6);
i := 0;
WHILE i < LibCount * 2 DO
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6);
INC(i);
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6);
INC(i)
END;
FOR i := LibCount * 2 TO ILen - 1 DO
IF CHL.GetInt(ImportTable, i) # 0 THEN
WriteReloc(File, i * SIZE_OF_DWORD, 4, 6)
END
END;
PE32.WriteName(File, "EXPORTS");
WriteReloc(File, 0, 3, 2);
PE32.WriteName(File, ".flat");
WriteReloc(File, 0, 1, 3);
PE32.WriteName(File, ".data");
WriteReloc(File, 0, 2, 3);
PE32.WriteName(File, ".edata");
WriteReloc(File, 0, 3, 3);
PE32.WriteName(File, ".idata");
WriteReloc(File, 0, 4, 3);
PE32.WriteName(File, ".bss");
WriteReloc(File, 0, 5, 3);
WR.Write32LE(File, 4);
WR.Close(File)
END write;
END MSCOFF.

1166
programs/develop/oberon07/Source/PARS.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

109
programs/develop/oberon07/Source/PATHS.ob07 Normal file
View File

@ -0,0 +1,109 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE PATHS;
IMPORT STRINGS, UTILS;
CONST
slash = UTILS.slash;
PATHLEN = 2048;
TYPE
PATH* = ARRAY PATHLEN OF CHAR;
PROCEDURE split* (fname: ARRAY OF CHAR; VAR path, name, ext: ARRAY OF CHAR);
VAR
pos1, pos2, len: INTEGER;
BEGIN
len := LENGTH(fname);
pos1 := len - 1;
pos2 := len - 1;
STRINGS.search(fname, pos1, slash, FALSE);
STRINGS.search(fname, pos2, ".", FALSE);
path := fname;
path[pos1 + 1] := 0X;
IF (pos2 = -1) OR (pos2 < pos1) THEN
pos2 := len
END;
INC(pos1);
STRINGS.copy(fname, name, pos1, 0, pos2 - pos1);
name[pos2 - pos1] := 0X;
STRINGS.copy(fname, ext, pos2, 0, len - pos2);
ext[len - pos2] := 0X;
END split;
PROCEDURE RelPath* (absolute, relative: ARRAY OF CHAR; VAR res: ARRAY OF CHAR);
VAR
i, j: INTEGER;
error: BOOLEAN;
BEGIN
COPY(absolute, res);
i := LENGTH(res) - 1;
WHILE (i >= 0) & (res[i] # slash) DO
DEC(i)
END;
INC(i);
res[i] := 0X;
error := FALSE;
j := 0;
WHILE ~error & (relative[j] # 0X) DO
IF (relative[j] = ".") & (relative[j + 1] = ".") & (relative[j + 2] = slash) & (i > 0) & (res[i - 1] = slash) THEN
DEC(i, 2);
WHILE (i >= 0) & (res[i] # slash) DO
DEC(i)
END;
IF i < 0 THEN
error := TRUE
ELSE
INC(i);
INC(j, 3)
END
ELSE
res[i] := relative[j];
INC(i);
INC(j)
END
END;
IF error THEN
COPY(relative, res)
ELSE
res[i] := 0X
END
END RelPath;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN UTILS.isRelative(path)
END isRelative;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
BEGIN
UTILS.GetCurrentDirectory(path)
END GetCurrentDirectory;
END PATHS.

733
programs/develop/oberon07/Source/PE32.ob07 Normal file
View File

@ -0,0 +1,733 @@
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE PE32;
IMPORT BIN, LISTS, UTILS, WR := WRITER, mConst := CONSTANTS, CHL := CHUNKLISTS;
CONST
SIZE_OF_DWORD = 4;
SIZE_OF_WORD = 2;
SIZE_OF_IMAGE_EXPORT_DIRECTORY = 40;
IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16;
IMAGE_SIZEOF_SHORT_NAME = 8;
SIZE_OF_IMAGE_FILE_HEADER* = 20;
SIZE_OF_IMAGE_SECTION_HEADER* = 40;
(* SectionHeader.Characteristics *)
SHC_text = 060000020H;
SHC_data = 0C0000040H;
SHC_bss = 0C00000C0H;
SectionAlignment = 1000H;
FileAlignment = 200H;
TYPE
WORD = WCHAR;
DWORD = INTEGER;
NAME* = ARRAY IMAGE_SIZEOF_SHORT_NAME OF CHAR;
IMAGE_DATA_DIRECTORY = RECORD
VirtualAddress: DWORD;
Size: DWORD
END;
IMAGE_OPTIONAL_HEADER = RECORD
Magic: WORD;
MajorLinkerVersion: BYTE;
MinorLinkerVersion: BYTE;
SizeOfCode: DWORD;
SizeOfInitializedData: DWORD;
SizeOfUninitializedData: DWORD;
AddressOfEntryPoint: DWORD;
BaseOfCode: DWORD;
BaseOfData: DWORD;
ImageBase: DWORD;
SectionAlignment: DWORD;
FileAlignment: DWORD;
MajorOperatingSystemVersion: WORD;
MinorOperatingSystemVersion: WORD;
MajorImageVersion: WORD;
MinorImageVersion: WORD;
MajorSubsystemVersion: WORD;
MinorSubsystemVersion: WORD;
Win32VersionValue: DWORD;
SizeOfImage: DWORD;
SizeOfHeaders: DWORD;
CheckSum: DWORD;
Subsystem: WORD;
DllCharacteristics: WORD;
SizeOfStackReserve: DWORD;
SizeOfStackCommit: DWORD;
SizeOfHeapReserve: DWORD;
SizeOfHeapCommit: DWORD;
LoaderFlags: DWORD;
NumberOfRvaAndSizes: DWORD;
DataDirectory: ARRAY IMAGE_NUMBEROF_DIRECTORY_ENTRIES OF IMAGE_DATA_DIRECTORY
END;
IMAGE_FILE_HEADER* = RECORD
Machine*: WORD;
NumberOfSections*: WORD;
TimeDateStamp*: DWORD;
PointerToSymbolTable*: DWORD;
NumberOfSymbols*: DWORD;
SizeOfOptionalHeader*: WORD;
Characteristics*: WORD
END;
IMAGE_NT_HEADERS = RECORD
Signature: ARRAY 4 OF BYTE;
FileHeader: IMAGE_FILE_HEADER;
OptionalHeader: IMAGE_OPTIONAL_HEADER
END;
IMAGE_SECTION_HEADER* = RECORD
Name*: NAME;
VirtualSize*,
VirtualAddress*,
SizeOfRawData*,
PointerToRawData*,
PointerToRelocations*,
PointerToLinenumbers*: DWORD;
NumberOfRelocations*,
NumberOfLinenumbers*: WORD;
Characteristics*: DWORD
END;
IMAGE_EXPORT_DIRECTORY = RECORD
Characteristics: DWORD;
TimeDateStamp: DWORD;
MajorVersion: WORD;
MinorVersion: WORD;
Name,
Base,
NumberOfFunctions,
NumberOfNames,
AddressOfFunctions,
AddressOfNames,
AddressOfNameOrdinals: DWORD
END;
VIRTUAL_ADDR = RECORD
Code, Data, Bss, Import: INTEGER
END;
FILE = WR.FILE;
VAR
msdos: ARRAY 128 OF BYTE;
PEHeader: IMAGE_NT_HEADERS;
SectionHeaders: ARRAY 16 OF IMAGE_SECTION_HEADER;
Relocations: LISTS.LIST;
bit64: BOOLEAN;
libcnt: INTEGER;
PROCEDURE SIZE (): INTEGER;
RETURN SIZE_OF_DWORD * (ORD(bit64) + 1)
END SIZE;
PROCEDURE Export (program: BIN.PROGRAM; DataRVA: INTEGER; VAR ExportDir: IMAGE_EXPORT_DIRECTORY): INTEGER;
BEGIN
ExportDir.Characteristics := 0;
ExportDir.TimeDateStamp := PEHeader.FileHeader.TimeDateStamp;
ExportDir.MajorVersion := 0X;
ExportDir.MinorVersion := 0X;
ExportDir.Name := program.modname + DataRVA;
ExportDir.Base := 0;
ExportDir.NumberOfFunctions := LISTS.count(program.exp_list);
ExportDir.NumberOfNames := ExportDir.NumberOfFunctions;
ExportDir.AddressOfFunctions := SIZE_OF_IMAGE_EXPORT_DIRECTORY;
ExportDir.AddressOfNames := ExportDir.AddressOfFunctions + ExportDir.NumberOfFunctions * SIZE_OF_DWORD;
ExportDir.AddressOfNameOrdinals := ExportDir.AddressOfNames + ExportDir.NumberOfFunctions * SIZE_OF_DWORD
RETURN SIZE_OF_IMAGE_EXPORT_DIRECTORY + ExportDir.NumberOfFunctions * (2 * SIZE_OF_DWORD + SIZE_OF_WORD)
END Export;
PROCEDURE align (n, _align: INTEGER): INTEGER;
BEGIN
IF n MOD _align # 0 THEN
n := n + _align - (n MOD _align)
END
RETURN n
END align;
PROCEDURE GetProcCount (lib: BIN.IMPRT): INTEGER;
VAR
import: BIN.IMPRT;
res: INTEGER;
BEGIN
res := 0;
import := lib.next(BIN.IMPRT);
WHILE (import # NIL) & (import.label # 0) DO
INC(res);
import := import.next(BIN.IMPRT)
END
RETURN res
END GetProcCount;
PROCEDURE GetImportSize (imp_list: LISTS.LIST): INTEGER;
VAR
import: BIN.IMPRT;
proccnt: INTEGER;
procoffs: INTEGER;
OriginalCurrentThunk,
CurrentThunk: INTEGER;
BEGIN
libcnt := 0;
proccnt := 0;
import := imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
INC(libcnt)
ELSE
INC(proccnt)
END;
import := import.next(BIN.IMPRT)
END;
procoffs := 0;
import := imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
import.OriginalFirstThunk := procoffs;
import.FirstThunk := procoffs + (GetProcCount(import) + 1);
OriginalCurrentThunk := import.OriginalFirstThunk;
CurrentThunk := import.FirstThunk;
procoffs := procoffs + (GetProcCount(import) + 1) * 2
ELSE
import.OriginalFirstThunk := OriginalCurrentThunk;
import.FirstThunk := CurrentThunk;
INC(OriginalCurrentThunk);
INC(CurrentThunk)
END;
import := import.next(BIN.IMPRT)
END
RETURN (libcnt + 1) * 5 * SIZE_OF_DWORD + (proccnt + libcnt) * 2 * SIZE()
END GetImportSize;
PROCEDURE fixup (program: BIN.PROGRAM; Address: VIRTUAL_ADDR);
VAR
reloc: BIN.RELOC;
iproc: BIN.IMPRT;
L: INTEGER;
delta: INTEGER;
AdrImp: INTEGER;
BEGIN
AdrImp := Address.Import + (libcnt + 1) * 5 * SIZE_OF_DWORD;
reloc := program.rel_list.first(BIN.RELOC);
WHILE reloc # NIL DO
L := BIN.get32le(program.code, reloc.offset);
delta := 3 - reloc.offset - Address.Code - 7 * ORD(bit64);
CASE reloc.opcode OF
|BIN.PICDATA:
BIN.put32le(program.code, reloc.offset, L + Address.Data + delta)
|BIN.PICCODE:
BIN.put32le(program.code, reloc.offset, BIN.GetLabel(program, L) + Address.Code + delta)
|BIN.PICBSS:
BIN.put32le(program.code, reloc.offset, L + Address.Bss + delta)
|BIN.PICIMP:
iproc := BIN.GetIProc(program, L);
BIN.put32le(program.code, reloc.offset, iproc.FirstThunk * SIZE() + AdrImp + delta)
END;
reloc := reloc.next(BIN.RELOC)
END
END fixup;
PROCEDURE WriteWord (file: FILE; w: WORD);
BEGIN
WR.Write16LE(file, ORD(w))
END WriteWord;
PROCEDURE WriteName* (File: FILE; name: NAME);
VAR
i, nameLen: INTEGER;
BEGIN
nameLen := LENGTH(name);
FOR i := 0 TO nameLen - 1 DO
WR.WriteByte(File, ORD(name[i]))
END;
i := LEN(name) - nameLen;
WHILE i > 0 DO
WR.WriteByte(File, 0);
DEC(i)
END
END WriteName;
PROCEDURE WriteSectionHeader* (file: FILE; h: IMAGE_SECTION_HEADER);
VAR
i, nameLen: INTEGER;
BEGIN
nameLen := LENGTH(h.Name);
FOR i := 0 TO nameLen - 1 DO
WR.WriteByte(file, ORD(h.Name[i]))
END;
i := LEN(h.Name) - nameLen;
WHILE i > 0 DO
WR.WriteByte(file, 0);
DEC(i)
END;
WR.Write32LE(file, h.VirtualSize);
WR.Write32LE(file, h.VirtualAddress);
WR.Write32LE(file, h.SizeOfRawData);
WR.Write32LE(file, h.PointerToRawData);
WR.Write32LE(file, h.PointerToRelocations);
WR.Write32LE(file, h.PointerToLinenumbers);
WriteWord(file, h.NumberOfRelocations);
WriteWord(file, h.NumberOfLinenumbers);
WR.Write32LE(file, h.Characteristics)
END WriteSectionHeader;
PROCEDURE WriteFileHeader* (file: FILE; h: IMAGE_FILE_HEADER);
BEGIN
WriteWord(file, h.Machine);
WriteWord(file, h.NumberOfSections);
WR.Write32LE(file, h.TimeDateStamp);
WR.Write32LE(file, h.PointerToSymbolTable);
WR.Write32LE(file, h.NumberOfSymbols);
WriteWord(file, h.SizeOfOptionalHeader);
WriteWord(file, h.Characteristics)
END WriteFileHeader;
PROCEDURE write* (program: BIN.PROGRAM; FileName: ARRAY OF CHAR; BaseAddress: INTEGER; console, dll, amd64: BOOLEAN);
VAR
i, n: INTEGER;
Size: RECORD
Code, Data, Bss, Stack, Import, Reloc, Export: INTEGER
END;
Address: VIRTUAL_ADDR;
File: FILE;
import: BIN.IMPRT;
ImportTable: CHL.INTLIST;
ExportDir: IMAGE_EXPORT_DIRECTORY;
export: BIN.EXPRT;
PROCEDURE WriteExportDir (file: FILE; e: IMAGE_EXPORT_DIRECTORY);
BEGIN
WR.Write32LE(file, e.Characteristics);
WR.Write32LE(file, e.TimeDateStamp);
WriteWord(file, e.MajorVersion);
WriteWord(file, e.MinorVersion);
WR.Write32LE(file, e.Name);
WR.Write32LE(file, e.Base);
WR.Write32LE(file, e.NumberOfFunctions);
WR.Write32LE(file, e.NumberOfNames);
WR.Write32LE(file, e.AddressOfFunctions);
WR.Write32LE(file, e.AddressOfNames);
WR.Write32LE(file, e.AddressOfNameOrdinals)
END WriteExportDir;
PROCEDURE WriteOptHeader (file: FILE; h: IMAGE_OPTIONAL_HEADER);
VAR
i: INTEGER;
BEGIN
WriteWord(file, h.Magic);
WR.WriteByte(file, h.MajorLinkerVersion);
WR.WriteByte(file, h.MinorLinkerVersion);
WR.Write32LE(file, h.SizeOfCode);
WR.Write32LE(file, h.SizeOfInitializedData);
WR.Write32LE(file, h.SizeOfUninitializedData);
WR.Write32LE(file, h.AddressOfEntryPoint);
WR.Write32LE(file, h.BaseOfCode);
IF bit64 THEN
WR.Write64LE(file, h.ImageBase)
ELSE
WR.Write32LE(file, h.BaseOfData);
WR.Write32LE(file, h.ImageBase)
END;
WR.Write32LE(file, h.SectionAlignment);
WR.Write32LE(file, h.FileAlignment);
WriteWord(file, h.MajorOperatingSystemVersion);
WriteWord(file, h.MinorOperatingSystemVersion);
WriteWord(file, h.MajorImageVersion);
WriteWord(file, h.MinorImageVersion);
WriteWord(file, h.MajorSubsystemVersion);
WriteWord(file, h.MinorSubsystemVersion);
WR.Write32LE(file, h.Win32VersionValue);
WR.Write32LE(file, h.SizeOfImage);
WR.Write32LE(file, h.SizeOfHeaders);
WR.Write32LE(file, h.CheckSum);
WriteWord(file, h.Subsystem);
WriteWord(file, h.DllCharacteristics);
IF bit64 THEN
WR.Write64LE(file, h.SizeOfStackReserve);
WR.Write64LE(file, h.SizeOfStackCommit);
WR.Write64LE(file, h.SizeOfHeapReserve);
WR.Write64LE(file, h.SizeOfHeapCommit)
ELSE
WR.Write32LE(file, h.SizeOfStackReserve);
WR.Write32LE(file, h.SizeOfStackCommit);
WR.Write32LE(file, h.SizeOfHeapReserve);
WR.Write32LE(file, h.SizeOfHeapCommit)
END;
WR.Write32LE(file, h.LoaderFlags);
WR.Write32LE(file, h.NumberOfRvaAndSizes);
FOR i := 0 TO LEN(h.DataDirectory) - 1 DO
WR.Write32LE(file, h.DataDirectory[i].VirtualAddress);
WR.Write32LE(file, h.DataDirectory[i].Size)
END
END WriteOptHeader;
PROCEDURE WritePEHeader (file: FILE; h: IMAGE_NT_HEADERS);
BEGIN
WR.Write(file, h.Signature, LEN(h.Signature));
WriteFileHeader(file, h.FileHeader);
WriteOptHeader(file, h.OptionalHeader)
END WritePEHeader;
PROCEDURE InitSection (VAR section: IMAGE_SECTION_HEADER; Name: NAME; Characteristics: DWORD);
BEGIN
section.Name := Name;
section.PointerToRelocations := 0;
section.PointerToLinenumbers := 0;
section.NumberOfRelocations := 0X;
section.NumberOfLinenumbers := 0X;
section.Characteristics := Characteristics
END InitSection;
BEGIN
bit64 := amd64;
Relocations := LISTS.create(NIL);
Size.Code := CHL.Length(program.code);
Size.Data := CHL.Length(program.data);
Size.Bss := program.bss;
Size.Stack := program.stack;
PEHeader.Signature[0] := 50H;
PEHeader.Signature[1] := 45H;
PEHeader.Signature[2] := 0;
PEHeader.Signature[3] := 0;
IF amd64 THEN
PEHeader.FileHeader.Machine := 08664X
ELSE
PEHeader.FileHeader.Machine := 014CX
END;
PEHeader.FileHeader.NumberOfSections := WCHR(4 + ORD(dll));
PEHeader.FileHeader.TimeDateStamp := UTILS.UnixTime();
PEHeader.FileHeader.PointerToSymbolTable := 0H;
PEHeader.FileHeader.NumberOfSymbols := 0H;
PEHeader.FileHeader.SizeOfOptionalHeader := WCHR(0E0H + 10H * ORD(amd64));
PEHeader.FileHeader.Characteristics := WCHR(010EH + (20H - 100H) * ORD(amd64) + 2000H * ORD(dll));
PEHeader.OptionalHeader.Magic := WCHR(010BH + 100H * ORD(amd64));
PEHeader.OptionalHeader.MajorLinkerVersion := mConst.vMajor;
PEHeader.OptionalHeader.MinorLinkerVersion := mConst.vMinor;
PEHeader.OptionalHeader.SizeOfCode := align(Size.Code, FileAlignment);
PEHeader.OptionalHeader.SizeOfInitializedData := 0;
PEHeader.OptionalHeader.SizeOfUninitializedData := 0;
PEHeader.OptionalHeader.AddressOfEntryPoint := SectionAlignment;
PEHeader.OptionalHeader.BaseOfCode := SectionAlignment;
PEHeader.OptionalHeader.BaseOfData := PEHeader.OptionalHeader.BaseOfCode + align(Size.Code, SectionAlignment);
PEHeader.OptionalHeader.ImageBase := BaseAddress;
PEHeader.OptionalHeader.SectionAlignment := SectionAlignment;
PEHeader.OptionalHeader.FileAlignment := FileAlignment;
PEHeader.OptionalHeader.MajorOperatingSystemVersion := 1X;
PEHeader.OptionalHeader.MinorOperatingSystemVersion := 0X;
PEHeader.OptionalHeader.MajorImageVersion := 0X;
PEHeader.OptionalHeader.MinorImageVersion := 0X;
PEHeader.OptionalHeader.MajorSubsystemVersion := 4X;
PEHeader.OptionalHeader.MinorSubsystemVersion := 0X;
PEHeader.OptionalHeader.Win32VersionValue := 0H;
PEHeader.OptionalHeader.SizeOfImage := SectionAlignment;
PEHeader.OptionalHeader.SizeOfHeaders := 400H;
PEHeader.OptionalHeader.CheckSum := 0;
PEHeader.OptionalHeader.Subsystem := WCHR((2 + ORD(console)) * ORD(~dll));
PEHeader.OptionalHeader.DllCharacteristics := 0040X;
PEHeader.OptionalHeader.SizeOfStackReserve := Size.Stack;
PEHeader.OptionalHeader.SizeOfStackCommit := Size.Stack DIV 16;
PEHeader.OptionalHeader.SizeOfHeapReserve := 100000H;
PEHeader.OptionalHeader.SizeOfHeapCommit := 10000H;
PEHeader.OptionalHeader.LoaderFlags := 0;
PEHeader.OptionalHeader.NumberOfRvaAndSizes := IMAGE_NUMBEROF_DIRECTORY_ENTRIES;
InitSection(SectionHeaders[0], ".text", SHC_text);
SectionHeaders[0].VirtualSize := Size.Code;
SectionHeaders[0].VirtualAddress := 1000H;
SectionHeaders[0].SizeOfRawData := align(Size.Code, FileAlignment);
SectionHeaders[0].PointerToRawData := PEHeader.OptionalHeader.SizeOfHeaders;
InitSection(SectionHeaders[1], ".data", SHC_data);
SectionHeaders[1].VirtualSize := Size.Data;
SectionHeaders[1].VirtualAddress := align(SectionHeaders[0].VirtualAddress + SectionHeaders[0].VirtualSize, SectionAlignment);
SectionHeaders[1].SizeOfRawData := align(Size.Data, FileAlignment);
SectionHeaders[1].PointerToRawData := SectionHeaders[0].PointerToRawData + SectionHeaders[0].SizeOfRawData;
InitSection(SectionHeaders[2], ".bss", SHC_bss);
SectionHeaders[2].VirtualSize := Size.Bss;
SectionHeaders[2].VirtualAddress := align(SectionHeaders[1].VirtualAddress + SectionHeaders[1].VirtualSize, SectionAlignment);
SectionHeaders[2].SizeOfRawData := 0;
SectionHeaders[2].PointerToRawData := SectionHeaders[1].PointerToRawData + SectionHeaders[1].SizeOfRawData;
Size.Import := GetImportSize(program.imp_list);
InitSection(SectionHeaders[3], ".idata", SHC_data);
SectionHeaders[3].VirtualSize := Size.Import + CHL.Length(program.import);
SectionHeaders[3].VirtualAddress := align(SectionHeaders[2].VirtualAddress + SectionHeaders[2].VirtualSize, SectionAlignment);
SectionHeaders[3].SizeOfRawData := align(SectionHeaders[3].VirtualSize, FileAlignment);
SectionHeaders[3].PointerToRawData := SectionHeaders[2].PointerToRawData + SectionHeaders[2].SizeOfRawData;
Address.Code := SectionHeaders[0].VirtualAddress + PEHeader.OptionalHeader.ImageBase;
Address.Data := SectionHeaders[1].VirtualAddress + PEHeader.OptionalHeader.ImageBase;
Address.Bss := SectionHeaders[2].VirtualAddress + PEHeader.OptionalHeader.ImageBase;
Address.Import := SectionHeaders[3].VirtualAddress + PEHeader.OptionalHeader.ImageBase;
fixup(program, Address);
IF dll THEN
Size.Export := Export(program, SectionHeaders[1].VirtualAddress, ExportDir);
InitSection(SectionHeaders[4], ".edata", SHC_data);
SectionHeaders[4].VirtualSize := Size.Export + CHL.Length(program.export);
SectionHeaders[4].VirtualAddress := align(SectionHeaders[3].VirtualAddress + SectionHeaders[3].VirtualSize, SectionAlignment);
SectionHeaders[4].SizeOfRawData := align(SectionHeaders[4].VirtualSize, FileAlignment);
SectionHeaders[4].PointerToRawData := SectionHeaders[3].PointerToRawData + SectionHeaders[3].SizeOfRawData;
END;
FOR i := 0 TO IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1 DO
PEHeader.OptionalHeader.DataDirectory[i].VirtualAddress := 0;
PEHeader.OptionalHeader.DataDirectory[i].Size := 0
END;
IF dll THEN
PEHeader.OptionalHeader.DataDirectory[0].VirtualAddress := SectionHeaders[4].VirtualAddress;
PEHeader.OptionalHeader.DataDirectory[0].Size := SectionHeaders[4].VirtualSize
END;
PEHeader.OptionalHeader.DataDirectory[1].VirtualAddress := SectionHeaders[3].VirtualAddress;
PEHeader.OptionalHeader.DataDirectory[1].Size := SectionHeaders[3].VirtualSize;
FOR i := 0 TO ORD(PEHeader.FileHeader.NumberOfSections) - 1 DO
INC(PEHeader.OptionalHeader.SizeOfInitializedData, SectionHeaders[i].SizeOfRawData)
END;
DEC(PEHeader.OptionalHeader.SizeOfInitializedData, SectionHeaders[0].SizeOfRawData);
DEC(PEHeader.OptionalHeader.SizeOfInitializedData, SectionHeaders[2].SizeOfRawData);
PEHeader.OptionalHeader.SizeOfUninitializedData := align(SectionHeaders[2].VirtualSize, FileAlignment);
FOR i := 0 TO ORD(PEHeader.FileHeader.NumberOfSections) - 1 DO
INC(PEHeader.OptionalHeader.SizeOfImage, align(SectionHeaders[i].VirtualSize, SectionAlignment))
END;
n := 0;
BIN.InitArray(msdos, n, "4D5A80000100000004001000FFFF000040010000000000004000000000000000");
BIN.InitArray(msdos, n, "0000000000000000000000000000000000000000000000000000000080000000");
BIN.InitArray(msdos, n, "0E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F");
BIN.InitArray(msdos, n, "742062652072756E20696E20444F53206D6F64652E0D0A240000000000000000");
File := WR.Create(FileName);
WR.Write(File, msdos, LEN(msdos));
WritePEHeader(File, PEHeader);
FOR i := 0 TO ORD(PEHeader.FileHeader.NumberOfSections) - 1 DO
WriteSectionHeader(File, SectionHeaders[i])
END;
WR.Padding(File, FileAlignment);
CHL.WriteToFile(File, program.code);
WR.Padding(File, FileAlignment);
CHL.WriteToFile(File, program.data);
WR.Padding(File, FileAlignment);
n := (libcnt + 1) * 5;
ImportTable := CHL.CreateIntList();
FOR i := 0 TO (Size.Import - n * SIZE_OF_DWORD) DIV SIZE() + n - 1 DO
CHL.PushInt(ImportTable, 0)
END;
i := 0;
import := program.imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label = 0 THEN
CHL.SetInt(ImportTable, i + 0, import.OriginalFirstThunk * SIZE() + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
CHL.SetInt(ImportTable, i + 1, 0);
CHL.SetInt(ImportTable, i + 2, 0);
CHL.SetInt(ImportTable, i + 3, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress);
CHL.SetInt(ImportTable, i + 4, import.FirstThunk * SIZE() + SectionHeaders[3].VirtualAddress + n * SIZE_OF_DWORD);
i := i + 5
END;
import := import.next(BIN.IMPRT)
END;
CHL.SetInt(ImportTable, i + 0, 0);
CHL.SetInt(ImportTable, i + 1, 0);
CHL.SetInt(ImportTable, i + 2, 0);
CHL.SetInt(ImportTable, i + 3, 0);
CHL.SetInt(ImportTable, i + 4, 0);
import := program.imp_list.first(BIN.IMPRT);
WHILE import # NIL DO
IF import.label # 0 THEN
CHL.SetInt(ImportTable, import.OriginalFirstThunk + n, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress - 2);
CHL.SetInt(ImportTable, import.FirstThunk + n, import.nameoffs + Size.Import + SectionHeaders[3].VirtualAddress - 2)
END;
import := import.next(BIN.IMPRT)
END;
FOR i := 0 TO n - 1 DO
WR.Write32LE(File, CHL.GetInt(ImportTable, i))
END;
FOR i := n TO CHL.Length(ImportTable) - 1 DO
IF amd64 THEN
WR.Write64LE(File, CHL.GetInt(ImportTable, i))
ELSE
WR.Write32LE(File, CHL.GetInt(ImportTable, i))
END
END;
CHL.WriteToFile(File, program.import);
WR.Padding(File, FileAlignment);
IF dll THEN
INC(ExportDir.AddressOfFunctions, SectionHeaders[4].VirtualAddress);
INC(ExportDir.AddressOfNames, SectionHeaders[4].VirtualAddress);
INC(ExportDir.AddressOfNameOrdinals, SectionHeaders[4].VirtualAddress);
WriteExportDir(File, ExportDir);
export := program.exp_list.first(BIN.EXPRT);
WHILE export # NIL DO
WR.Write32LE(File, export.label + SectionHeaders[0].VirtualAddress);
export := export.next(BIN.EXPRT)
END;
export := program.exp_list.first(BIN.EXPRT);
WHILE export # NIL DO
WR.Write32LE(File, export.nameoffs + Size.Export + SectionHeaders[4].VirtualAddress);
export := export.next(BIN.EXPRT)
END;
FOR i := 0 TO ExportDir.NumberOfFunctions - 1 DO
WriteWord(File, WCHR(i))
END;
CHL.WriteToFile(File, program.export);
WR.Padding(File, FileAlignment)
END;
WR.Close(File)
END write;
END PE32.

1311
programs/develop/oberon07/Source/PROG.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

434
programs/develop/oberon07/Source/REG.ob07 Normal file
View File

@ -0,0 +1,434 @@
(*
BSD 2-Clause License
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE REG;
CONST
N = 16;
R0* = 0; R1* = 1; R2* = 2;
R8* = 8; R9* = 9; R10* = 10; R11* = 11;
NVR = 32;
TYPE
OP1 = PROCEDURE (arg: INTEGER);
OP2 = PROCEDURE (arg1, arg2: INTEGER);
OP3 = PROCEDURE (arg1, arg2, arg3: INTEGER);
REGS* = POINTER TO RECORD
regs*: SET;
stk*: ARRAY N OF INTEGER;
top*: INTEGER;
pushed*: INTEGER;
vregs*: SET;
offs: ARRAY NVR OF INTEGER;
size: ARRAY NVR OF INTEGER;
push, pop: OP1;
mov, xch: OP2;
load, save: OP3
END;
PROCEDURE push (R: REGS);
VAR
i, reg: INTEGER;
BEGIN
reg := R.stk[0];
INCL(R.regs, reg);
R.push(reg);
FOR i := 0 TO R.top - 1 DO
R.stk[i] := R.stk[i + 1]
END;
DEC(R.top);
INC(R.pushed)
END push;
PROCEDURE pop (R: REGS; reg: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := R.top + 1 TO 1 BY -1 DO
R.stk[i] := R.stk[i - 1]
END;
R.stk[0] := reg;
EXCL(R.regs, reg);
R.pop(reg);
INC(R.top);
DEC(R.pushed)
END pop;
PROCEDURE InStk (R: REGS; reg: INTEGER): INTEGER;
VAR
i, n: INTEGER;
BEGIN
i := 0;
n := R.top;
WHILE (i <= n) & (R.stk[i] # reg) DO
INC(i)
END;
IF i > n THEN
i := -1
END
RETURN i
END InStk;
PROCEDURE GetFreeReg (R: REGS): INTEGER;
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (i < N) & ~(i IN R.regs) DO
INC(i)
END;
IF i = N THEN
i := -1
END
RETURN i
END GetFreeReg;
PROCEDURE Put (R: REGS; reg: INTEGER);
BEGIN
EXCL(R.regs, reg);
INC(R.top);
R.stk[R.top] := reg
END Put;
PROCEDURE PopAnyReg (R: REGS): INTEGER;
VAR
reg: INTEGER;
BEGIN
reg := GetFreeReg(R);
ASSERT(reg # -1);
ASSERT(R.top < LEN(R.stk) - 1);
ASSERT(R.pushed > 0);
pop(R, reg)
RETURN reg
END PopAnyReg;
PROCEDURE GetAnyReg* (R: REGS): INTEGER;
VAR
reg: INTEGER;
BEGIN
reg := GetFreeReg(R);
IF reg = -1 THEN
ASSERT(R.top >= 0);
reg := R.stk[0];
push(R)
END;
Put(R, reg)
RETURN reg
END GetAnyReg;
PROCEDURE GetReg* (R: REGS; reg: INTEGER): BOOLEAN;
VAR
free, n: INTEGER;
res: BOOLEAN;
PROCEDURE exch (R: REGS; reg1, reg2: INTEGER);
VAR
n1, n2: INTEGER;
BEGIN
n1 := InStk(R, reg1);
n2 := InStk(R, reg2);
R.stk[n1] := reg2;
R.stk[n2] := reg1;
R.xch(reg1, reg2)
END exch;
BEGIN
IF reg IN R.regs THEN
Put(R, reg);
res := TRUE
ELSE
n := InStk(R, reg);
IF n # -1 THEN
free := GetFreeReg(R);
IF free # -1 THEN
Put(R, free);
exch(R, reg, free)
ELSE
push(R);
free := GetFreeReg(R);
ASSERT(free # -1);
Put(R, free);
IF free # reg THEN
exch(R, reg, free)
END
END;
res := TRUE
ELSE
res := FALSE
END
END
RETURN res
END GetReg;
PROCEDURE Exchange* (R: REGS; reg1, reg2: INTEGER): BOOLEAN;
VAR
n1, n2: INTEGER;
res: BOOLEAN;
BEGIN
res := FALSE;
IF reg1 # reg2 THEN
n1 := InStk(R, reg1);
n2 := InStk(R, reg2);
IF (n1 # -1) & (n2 # -1) THEN
R.stk[n1] := reg2;
R.stk[n2] := reg1;
R.xch(reg2, reg1);
res := TRUE
ELSIF (n1 # -1) & (reg2 IN R.regs) THEN
R.stk[n1] := reg2;
INCL(R.regs, reg1);
EXCL(R.regs, reg2);
R.mov(reg2, reg1);
res := TRUE
ELSIF (n2 # -1) & (reg1 IN R.regs) THEN
R.stk[n2] := reg1;
EXCL(R.regs, reg1);
INCL(R.regs, reg2);
R.mov(reg1, reg2);
res := TRUE
END
ELSE
res := TRUE
END
RETURN res
END Exchange;
PROCEDURE Drop* (R: REGS);
BEGIN
INCL(R.regs, R.stk[R.top]);
DEC(R.top)
END Drop;
PROCEDURE BinOp* (R: REGS; VAR reg1, reg2: INTEGER);
BEGIN
IF R.top > 0 THEN
reg1 := R.stk[R.top - 1];
reg2 := R.stk[R.top]
ELSIF R.top = 0 THEN
reg1 := PopAnyReg(R);
reg2 := R.stk[R.top]
ELSIF R.top < 0 THEN
reg2 := PopAnyReg(R);
reg1 := PopAnyReg(R)
END
END BinOp;
PROCEDURE UnOp* (R: REGS; VAR reg: INTEGER);
BEGIN
IF R.top >= 0 THEN
reg := R.stk[R.top]
ELSE
reg := PopAnyReg(R)
END
END UnOp;
PROCEDURE PushAll* (R: REGS);
BEGIN
WHILE R.top >= 0 DO
push(R)
END
END PushAll;
PROCEDURE Lock* (R: REGS; reg, offs, size: INTEGER);
BEGIN
ASSERT(reg IN R.vregs);
ASSERT(offs # 0);
R.offs[reg] := offs;
IF size = 0 THEN
size := 8
END;
R.size[reg] := size
END Lock;
PROCEDURE Release* (R: REGS; reg: INTEGER);
BEGIN
ASSERT(reg IN R.vregs);
R.offs[reg] := 0
END Release;
PROCEDURE Load* (R: REGS; reg: INTEGER);
VAR
offs: INTEGER;
BEGIN
ASSERT(reg IN R.vregs);
offs := R.offs[reg];
IF offs # 0 THEN
R.load(reg, offs, R.size[reg])
END
END Load;
PROCEDURE Save* (R: REGS; reg: INTEGER);
VAR
offs: INTEGER;
BEGIN
ASSERT(reg IN R.vregs);
offs := R.offs[reg];
IF offs # 0 THEN
R.save(reg, offs, R.size[reg])
END
END Save;
PROCEDURE Store* (R: REGS);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO NVR - 1 DO
IF i IN R.vregs THEN
Save(R, i)
END
END
END Store;
PROCEDURE Restore* (R: REGS);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO NVR - 1 DO
IF i IN R.vregs THEN
Load(R, i)
END
END
END Restore;
PROCEDURE Reset* (R: REGS);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO NVR - 1 DO
IF i IN R.vregs THEN
R.offs[i] := 0
END
END
END Reset;
PROCEDURE GetVarReg* (R: REGS; offs: INTEGER): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := -1;
i := 0;
WHILE i < NVR DO
IF (i IN R.vregs) & (R.offs[i] = offs) THEN
res := i;
i := NVR
END;
INC(i)
END
RETURN res
END GetVarReg;
PROCEDURE GetAnyVarReg* (R: REGS): INTEGER;
VAR
i, res: INTEGER;
BEGIN
res := -1;
i := 0;
WHILE i < NVR DO
IF (i IN R.vregs) & (R.offs[i] = 0) THEN
res := i;
i := NVR
END;
INC(i)
END
RETURN res
END GetAnyVarReg;
PROCEDURE Create* (push, pop: OP1; mov, xch: OP2; load, save: OP3; regs, vregs: SET): REGS;
VAR
R: REGS;
i: INTEGER;
BEGIN
NEW(R);
R.regs := regs;
R.pushed := 0;
R.top := -1;
R.push := push;
R.pop := pop;
R.mov := mov;
R.xch := xch;
R.load := load;
R.save := save;
R.vregs := vregs;
FOR i := 0 TO NVR - 1 DO
R.offs[i] := 0;
R.size[i] := 0
END
RETURN R
END Create;
END REG.

1320
programs/develop/oberon07/Source/SCAN.ob07
View File

File diff suppressed because it is too large Load Diff

3297
programs/develop/oberon07/Source/STATEMENTS.ob07 Normal file
View File

File diff suppressed because it is too large Load Diff

291
programs/develop/oberon07/Source/STRINGS.ob07 Normal file
View File

@ -0,0 +1,291 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE STRINGS;
IMPORT UTILS;
PROCEDURE append* (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
VAR
n1, n2, i, j: INTEGER;
BEGIN
n1 := LENGTH(s1);
n2 := LENGTH(s2);
ASSERT(n1 + n2 < LEN(s1));
i := 0;
j := n1;
WHILE i < n2 DO
s1[j] := s2[i];
INC(i);
INC(j)
END;
s1[j] := 0X
END append;
PROCEDURE reverse* (VAR s: ARRAY OF CHAR);
VAR
i, j: INTEGER;
a, b: CHAR;
BEGIN
i := 0;
j := LENGTH(s) - 1;
WHILE i < j DO
a := s[i];
b := s[j];
s[i] := b;
s[j] := a;
INC(i);
DEC(j)
END
END reverse;
PROCEDURE IntToStr* (x: INTEGER; VAR str: ARRAY OF CHAR);
VAR
i, a: INTEGER;
minus: BOOLEAN;
BEGIN
IF x = UTILS.minint THEN
IF UTILS.bit_depth = 32 THEN
COPY("-2147483648", str)
ELSIF UTILS.bit_depth = 64 THEN
COPY("-9223372036854775808", str)
END
ELSE
minus := x < 0;
IF minus THEN
x := -x
END;
i := 0;
a := 0;
REPEAT
str[i] := CHR(x MOD 10 + ORD("0"));
x := x DIV 10;
INC(i)
UNTIL x = 0;
IF minus THEN
str[i] := "-";
INC(i)
END;
str[i] := 0X;
reverse(str)
END
END IntToStr;
PROCEDURE copy* (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR; spos, dpos, count: INTEGER);
BEGIN
WHILE count > 0 DO
dst[dpos] := src[spos];
INC(spos);
INC(dpos);
DEC(count)
END
END copy;
PROCEDURE search* (s: ARRAY OF CHAR; VAR pos: INTEGER; c: CHAR; forward: BOOLEAN);
VAR
length: INTEGER;
BEGIN
length := LENGTH(s);
IF (0 <= pos) & (pos < length) THEN
IF forward THEN
WHILE (pos < length) & (s[pos] # c) DO
INC(pos)
END;
IF pos = length THEN
pos := -1
END
ELSE
WHILE (pos >= 0) & (s[pos] # c) DO
DEC(pos)
END
END
ELSE
pos := -1
END
END search;
PROCEDURE letter* (c: CHAR): BOOLEAN;
RETURN ("a" <= c) & (c <= "z") OR ("A" <= c) & (c <= "Z") OR (c = "_")
END letter;
PROCEDURE digit* (c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9")
END digit;
PROCEDURE hexdigit* (c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9") OR ("A" <= c) & (c <= "F")
END hexdigit;
PROCEDURE space* (c: CHAR): BOOLEAN;
RETURN (0X < c) & (c <= 20X)
END space;
PROCEDURE StrToInt* (str: ARRAY OF CHAR; VAR x: INTEGER): BOOLEAN;
VAR
i, k: INTEGER;
res: BOOLEAN;
BEGIN
res := TRUE;
i := 0;
x := 0;
k := LENGTH(str);
WHILE i < k DO
IF digit(str[i]) THEN
x := x * 10 + ORD(str[i]) - ORD("0")
ELSE
i := k;
res := FALSE
END;
INC(i)
END
RETURN res
END StrToInt;
PROCEDURE CheckVer (str: ARRAY OF CHAR): BOOLEAN;
VAR
i, k: INTEGER;
res: BOOLEAN;
BEGIN
k := LENGTH(str);
res := k < LEN(str);
IF res & digit(str[0]) THEN
i := 0;
WHILE (i < k) & digit(str[i]) DO
INC(i)
END;
IF (i < k) & (str[i] = ".") THEN
INC(i);
IF i < k THEN
WHILE (i < k) & digit(str[i]) DO
INC(i)
END
ELSE
res := FALSE
END
ELSE
res := FALSE
END;
res := res & (i = k)
ELSE
res := FALSE
END
RETURN res
END CheckVer;
PROCEDURE StrToVer* (str: ARRAY OF CHAR; VAR major, minor: INTEGER): BOOLEAN;
VAR
i: INTEGER;
res: BOOLEAN;
BEGIN
res := CheckVer(str);
IF res THEN
i := 0;
minor := 0;
major := 0;
WHILE digit(str[i]) DO
major := major * 10 + ORD(str[i]) - ORD("0");
INC(i)
END;
INC(i);
WHILE digit(str[i]) DO
minor := minor * 10 + ORD(str[i]) - ORD("0");
INC(i)
END
END
RETURN res
END StrToVer;
PROCEDURE Utf8To16* (src: ARRAY OF CHAR; VAR dst: ARRAY OF WCHAR): INTEGER;
VAR
i, j, u, srclen, dstlen: INTEGER;
c: CHAR;
BEGIN
srclen := LEN(src);
dstlen := LEN(dst);
i := 0;
j := 0;
WHILE (i < srclen) & (j < dstlen) & (src[i] # 0X) DO
c := src[i];
CASE c OF
|00X..7FX:
u := ORD(c)
|0C1X..0DFX:
u := LSL(ORD(c) - 0C0H, 6);
IF i + 1 < srclen THEN
u := u + ROR(LSL(ORD(src[i + 1]), 26), 26);
INC(i)
END
|0E1X..0EFX:
u := LSL(ORD(c) - 0E0H, 12);
IF i + 1 < srclen THEN
u := u + ROR(LSL(ORD(src[i + 1]), 26), 20);
INC(i)
END;
IF i + 1 < srclen THEN
u := u + ROR(LSL(ORD(src[i + 1]), 26), 26);
INC(i)
END
(*
|0F1X..0F7X:
|0F9X..0FBX:
|0FDX:
*)
ELSE
END;
INC(i);
dst[j] := WCHR(u);
INC(j)
END;
IF j < dstlen THEN
dst[j] := WCHR(0)
END
RETURN j
END Utf8To16;
END STRINGS.

209
programs/develop/oberon07/Source/TEXTDRV.ob07 Normal file
View File

@ -0,0 +1,209 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE TEXTDRV;
IMPORT FILES, C := COLLECTIONS;
CONST
CR = 0DX; LF = 0AX;
CHUNK = 1024 * 256;
TYPE
TEXT* = POINTER TO RECORD (C.ITEM)
chunk: ARRAY CHUNK OF BYTE;
pos, size: INTEGER;
file: FILES.FILE;
utf8: BOOLEAN;
CR: BOOLEAN;
line*, col*: INTEGER;
eof*: BOOLEAN;
eol*: BOOLEAN;
open*: PROCEDURE (text: TEXT; name: ARRAY OF CHAR): BOOLEAN;
peak*: PROCEDURE (text: TEXT): CHAR;
nextc*: PROCEDURE (text: TEXT)
END;
VAR
texts: C.COLLECTION;
PROCEDURE reset (text: TEXT);
BEGIN
text.chunk[0] := 0;
text.pos := 0;
text.size := 0;
text.file := NIL;
text.utf8 := FALSE;
text.CR := FALSE;
text.line := 1;
text.col := 1;
text.eof := FALSE;
text.eol := FALSE
END reset;
PROCEDURE peak (text: TEXT): CHAR;
RETURN CHR(text.chunk[text.pos])
END peak;
PROCEDURE load (text: TEXT);
BEGIN
IF ~text.eof THEN
text.size := FILES.read(text.file, text.chunk, LEN(text.chunk));
text.pos := 0;
IF text.size = 0 THEN
text.eof := TRUE;
text.chunk[0] := 0
END
END
END load;
PROCEDURE next (text: TEXT);
VAR
c: CHAR;
BEGIN
IF text.pos < text.size - 1 THEN
INC(text.pos)
ELSE
load(text)
END;
IF ~text.eof THEN
c := peak(text);
IF c = CR THEN
INC(text.line);
text.col := 0;
text.eol := TRUE;
text.CR := TRUE
ELSIF c = LF THEN
IF ~text.CR THEN
INC(text.line);
text.col := 0;
text.eol := TRUE
ELSE
text.eol := FALSE
END;
text.CR := FALSE
ELSE
text.eol := FALSE;
IF text.utf8 THEN
IF (c < 80X) OR (c > 0BFX) THEN
INC(text.col)
END
ELSE
INC(text.col)
END;
text.CR := FALSE
END
END
END next;
PROCEDURE init (text: TEXT);
BEGIN
IF (text.pos = 0) & (text.size >= 3) THEN
IF (text.chunk[0] = 0EFH) &
(text.chunk[1] = 0BBH) &
(text.chunk[2] = 0BFH) THEN
text.pos := 3;
text.utf8 := TRUE
END
END;
IF text.size = 0 THEN
text.chunk[0] := 0;
text.size := 1;
text.eof := FALSE
END;
text.line := 1;
text.col := 1
END init;
PROCEDURE open (text: TEXT; name: ARRAY OF CHAR): BOOLEAN;
BEGIN
ASSERT(text # NIL);
reset(text);
text.file := FILES.open(name);
IF text.file # NIL THEN
load(text);
init(text)
END
RETURN text.file # NIL
END open;
PROCEDURE NewText (): TEXT;
VAR
text: TEXT;
citem: C.ITEM;
BEGIN
citem := C.pop(texts);
IF citem = NIL THEN
NEW(text)
ELSE
text := citem(TEXT)
END
RETURN text
END NewText;
PROCEDURE create* (): TEXT;
VAR
text: TEXT;
BEGIN
text := NewText();
reset(text);
text.open := open;
text.peak := peak;
text.nextc := next
RETURN text
END create;
PROCEDURE destroy* (VAR text: TEXT);
BEGIN
IF text # NIL THEN
IF text.file # NIL THEN
FILES.close(text.file)
END;
C.push(texts, text);
text := NIL
END
END destroy;
BEGIN
texts := C.create()
END TEXTDRV.

69
programs/develop/oberon07/Source/UNIXTIME.ob07 Normal file
View File

@ -0,0 +1,69 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE UNIXTIME;
VAR
days: ARRAY 12, 31, 2 OF INTEGER;
PROCEDURE init;
VAR
i, j, k, n0, n1: INTEGER;
BEGIN
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
days[i, j, 0] := 0;
days[i, j, 1] := 0;
END
END;
days[ 1, 28, 0] := -1;
FOR k := 0 TO 1 DO
days[ 1, 29, k] := -1;
days[ 1, 30, k] := -1;
days[ 3, 30, k] := -1;
days[ 5, 30, k] := -1;
days[ 8, 30, k] := -1;
days[10, 30, k] := -1;
END;
n0 := 0;
n1 := 0;
FOR i := 0 TO 11 DO
FOR j := 0 TO 30 DO
IF days[i, j, 0] = 0 THEN
days[i, j, 0] := n0;
INC(n0)
END;
IF days[i, j, 1] = 0 THEN
days[i, j, 1] := n1;
INC(n1)
END
END
END
END init;
PROCEDURE time* (year, month, day, hour, min, sec: INTEGER): INTEGER;
VAR
d, s: INTEGER;
BEGIN
d := (year - 1970) * 365 + days[month - 1, day - 1, ORD(year DIV 4 = 0)] + (year - 1969) DIV 4;
s := d * 86400 + hour * 3600 + min * 60 + sec
RETURN s
END time;
BEGIN
init
END UNIXTIME.

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

@ -1,418 +1,120 @@
(*
Copyright 2016, 2017 Anton Krotov
(*
BSD 2-Clause License
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
Copyright (c) 2018, 2019, Anton Krotov
All rights reserved.
*)
MODULE UTILS;
IMPORT sys := SYSTEM, H := HOST, ERRORS;
IMPORT HOST, UNIXTIME;
CONST
OS* = H.OS;
Slash* = H.Slash;
Ext* = ".ob07";
MAX_PATH = 1024;
MAX_PARAM = 1024;
Date* = 1509580800; (* 2017-11-02 *)
slash* = HOST.slash;
TYPE
bit_depth* = HOST.bit_depth;
maxint* = HOST.maxint;
minint* = HOST.minint;
OS = HOST.OS;
STRING* = ARRAY MAX_PATH OF CHAR;
ITEM* = POINTER TO rITEM;
rITEM* = RECORD
Next*, Prev*: ITEM
END;
LIST* = POINTER TO RECORD
First*, Last*: ITEM;
Count*: INTEGER
END;
STRCONST* = POINTER TO RECORD (rITEM)
Str*: STRING;
Len*, Number*: INTEGER
END;
VAR
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
ParamCount*, Line*, Unit*: INTEGER;
FileName: STRING;
time*: INTEGER;
PROCEDURE SetFile*(F: STRING);
eol*: ARRAY 3 OF CHAR;
maxreal*: REAL;
PROCEDURE FileRead* (F: INTEGER; VAR Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN HOST.FileRead(F, Buffer, bytes)
END FileRead;
PROCEDURE FileWrite* (F: INTEGER; Buffer: ARRAY OF BYTE; bytes: INTEGER): INTEGER;
RETURN HOST.FileWrite(F, Buffer, bytes)
END FileWrite;
PROCEDURE FileCreate* (FName: ARRAY OF CHAR): INTEGER;
RETURN HOST.FileCreate(FName)
END FileCreate;
PROCEDURE FileClose* (F: INTEGER);
BEGIN
FileName := F
END SetFile;
HOST.FileClose(F)
END FileClose;
PROCEDURE IsInf*(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
PROCEDURE GetChar(adr: INTEGER): CHAR;
VAR res: CHAR;
PROCEDURE FileOpen* (FName: ARRAY OF CHAR): INTEGER;
RETURN HOST.FileOpen(FName)
END FileOpen;
PROCEDURE GetArg* (i: INTEGER; VAR str: ARRAY OF CHAR);
BEGIN
sys.GET(adr, res)
RETURN res
END GetChar;
HOST.GetArg(i, str)
END GetArg;
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
PROCEDURE Exit* (code: INTEGER);
BEGIN
HOST.ExitProcess(code)
END Exit;
PROCEDURE GetTickCount* (): INTEGER;
RETURN HOST.GetTickCount()
END GetTickCount;
PROCEDURE OutChar* (c: CHAR);
BEGIN
HOST.OutChar(c)
END OutChar;
PROCEDURE splitf* (x: REAL; VAR a, b: INTEGER): INTEGER;
RETURN HOST.splitf(x, a, b)
END splitf;
PROCEDURE isRelative* (path: ARRAY OF CHAR): BOOLEAN;
RETURN HOST.isRelative(path)
END isRelative;
PROCEDURE GetCurrentDirectory* (VAR path: ARRAY OF CHAR);
BEGIN
HOST.GetCurrentDirectory(path)
END GetCurrentDirectory;
PROCEDURE UnixTime* (): INTEGER;
VAR
year, month, day, hour, min, sec: INTEGER;
res: INTEGER;
BEGIN
IF OS = "LINUX" THEN
res := HOST.UnixTime()
ELSE
HOST.now(year, month, day, hour, min, sec);
res := UNIXTIME.time(year, month, day, hour, min, sec)
END
END ChangeCond;
RETURN res
END UnixTime;
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 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
time := GetTickCount();
COPY(HOST.eol, eol);
maxreal := 1.9;
PACK(maxreal, 1023)
END UTILS.

111
programs/develop/oberon07/Source/WRITER.ob07 Normal file
View File

@ -0,0 +1,111 @@
(*
BSD 2-Clause License
Copyright (c) 2018, Anton Krotov
All rights reserved.
*)
MODULE WRITER;
IMPORT FILES, ERRORS, MACHINE;
TYPE
FILE* = FILES.FILE;
VAR
counter*: INTEGER;
PROCEDURE align (n, _align: INTEGER): INTEGER;
BEGIN
IF n MOD _align # 0 THEN
n := n + _align - (n MOD _align)
END
RETURN n
END align;
PROCEDURE WriteByte* (file: FILE; n: BYTE);
BEGIN
IF FILES.WriteByte(file, n) THEN
INC(counter)
ELSE
ERRORS.error1("writing file error")
END
END WriteByte;
PROCEDURE Write* (file: FILE; chunk: ARRAY OF BYTE; bytes: INTEGER);
VAR
n: INTEGER;
BEGIN
n := FILES.write(file, chunk, bytes);
IF n # bytes THEN
ERRORS.error1("writing file error")
END;
INC(counter, n)
END Write;
PROCEDURE Write64LE* (file: FILE; n: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 7 DO
WriteByte(file, MACHINE.Byte(n, i))
END
END Write64LE;
PROCEDURE Write32LE* (file: FILE; n: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO 3 DO
WriteByte(file, MACHINE.Byte(n, i))
END
END Write32LE;
PROCEDURE Write16LE* (file: FILE; n: INTEGER);
BEGIN
WriteByte(file, MACHINE.Byte(n, 0));
WriteByte(file, MACHINE.Byte(n, 1))
END Write16LE;
PROCEDURE Padding* (file: FILE; FileAlignment: INTEGER);
VAR
i: INTEGER;
BEGIN
i := align(counter, FileAlignment) - counter;
WHILE i > 0 DO
WriteByte(file, 0);
DEC(i)
END
END Padding;
PROCEDURE Create* (FileName: ARRAY OF CHAR): FILE;
BEGIN
counter := 0
RETURN FILES.create(FileName)
END Create;
PROCEDURE Close* (VAR file: FILE);
BEGIN
FILES.close(file)
END Close;
END WRITER.

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

File diff suppressed because it is too large Load Diff