├── .gitignore
├── Sources
    └── ExtendedOberon
    │   ├── TestLoop.Mod
    │   ├── TestForward.Mod
    │   ├── TestWith.Mod
    │   ├── ORS.Mod
    │   ├── ORB.Mod
    │   ├── ORG.Mod
    │   └── ORP.Mod
├── oberon2dos
├── dos2oberon
└── README.md


/.gitignore:
--------------------------------------------------------------------------------
1 | # Temporary files
2 | *~
3 | \#*#
4 | 
5 | # MacOS X Finder metadata
6 | .DS_Store
7 | 


--------------------------------------------------------------------------------
/Sources/ExtendedOberon/TestLoop.Mod:
--------------------------------------------------------------------------------
 1 | MODULE^ TestLoop;  (*test LOOP statement / ^ after MODULE enables the retro compiler / AP 11.1.22 Extended Oberon*)
 2 |   IMPORT Out;
 3 | 
 4 |   PROCEDURE Go*;
 5 |     VAR i, j: INTEGER;
 6 |   BEGIN i := 0; j := 0;
 7 |     LOOP
 8 |       IF i < 5 THEN Out.Int(i, 2); Out.String(" "); INC(i); j := 0;
 9 |         LOOP
10 |           IF j < 3 THEN Out.String("*"); INC(j)
11 |           ELSE EXIT
12 |           END
13 |         END
14 |       ELSE EXIT
15 |       END
16 |     END
17 |   END Go;
18 | 
19 | END TestLoop.
20 | 
21 | ORP.Compile ORS.Mod/s ORB.Mod/s ORG.Mod/s ORP.Mod/s ~   # compile the new compiler
22 | System.Free ORTool ORP ORG ORB ORS ~                    # unload the old compiler
23 | 
24 | ORP.Compile TestLoop.Mod/s ~
25 | TestLoop.Go ~
26 | 


--------------------------------------------------------------------------------
/oberon2dos:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | #
 3 | # oberon2dos  -- convert an Oberon file (only CR as line ending) to a DOS file (CR + LF as line endings)
 4 | #             -- we also allow files which have only LF as line ending and convert them to a DOS file (CR + LF)
 5 | #
 6 | # Sample workflow:
 7 | #   1) ./pcsend.sh File.Mod                      (export file from Oberon to DOS or MacOS)
 8 | #   2) ./oberon2dos File.Mod Sources/File.Mod    (convert file to DOS-style)
 9 | #
10 | #   Converting a file from Oberon-style (uses only CR as line endings) to DOS-style (uses CRLF as line
11 | #   endings) ensures that the file can be properly displayed on web sites such as www.github.com.
12 | #
13 | # See also:
14 | #   dos2oberon   (converts a DOS file to Oberon format)
15 | #
16 | # Notes:
17 | #   CR  = 13 (decimal) = 0D (hex) = 15C (octal) = \r (Perl) 
18 | #   LF  = 10 (decimal) = 0A (hex) = 12C (octal) = \n (Perl)
19 | #   TAB = 09 (decimal) = 09 (hex) = 11C (octal) = \t (Perl)
20 | #   SUB = 26 (decimal) = 1A (hex) = 32C (octal) = ?  (Perl)
21 | #
22 | #   We use Perl, because on some host systems (e.g., MacOS), the corresponding sed command does not work
23 | #
24 | # Author: Andreas Pirklbauer
25 | #
26 | 
27 | # quit unless we have the correct number of command line arguments
28 | $num_args = $#ARGV + 1;
29 | if ($num_args != 2) {
30 |     print "Usage: oberon2dos inputfile outputfile\n";
31 |     exit;
32 | }
33 | 
34 | # get the two command line arguments
35 | $inputfile=$ARGV[0];
36 | $outputfile=$ARGV[1];
37 | 
38 | open(FILE, "$inputfile") || die "inputfile not found";
39 | my @lines = <FILE>;
40 | close(FILE);
41 | 
42 | my @newlines;
43 | foreach(@lines) {
44 |     # convert all CRLF (\r\n) to CR (\r) only, so we no longer have any CRLF in the file afterwards
45 |     $_ =~ s/\r\n/\r/g;
46 |     # convert all LF (\n) to CR (\r) only, so we no longer have any LF in the file afterwards
47 |     $_ =~ s/\n/\r/g;
48 |     # convert all CR (\r) to CRLF (\r\n), so we ONLY have CRLF in the file afterwards
49 |     $_ =~ s/\r/\r\n/g;
50 |     # replace a TAB (\t) with two spaces (\s\s)
51 |     $_ =~ s/\t/  /g;
52 |     # push output line
53 |     push(@newlines,$_);
54 | }
55 | 
56 | open(FILE, ">$outputfile") || die "File not found";
57 | print FILE @newlines;
58 | close(FILE);
59 | 
60 | 


--------------------------------------------------------------------------------
/dos2oberon:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/perl
 2 | #
 3 | # dos2oberon  -- convert a DOS file (CR + LF as line ending) to an Oberon file (only CR as line endings)
 4 | #             -- we also allow files which have only LF as line ending and convert them to an Oberon file (only CR)
 5 | #
 6 | # Sample workflow:
 7 | #   1) ./dos2oberon File.Mod File.Mod            (convert file to Oberon-style)
 8 | #   2) ./pcreceive.sh File.Mod                   (import this file into Oberon)
 9 | #
10 | #   Converting a file from DOS-style (uses CRLF as line endings) to Oberon-style (uses only CR as line
11 | #   endings) also make the following conversions:
12 | #     - two spaces at the beginning of a line are converted to a TAB
13 | #     - two spaces in front of Oberon comments enclosed by (* and *) are converted to a TAB.
14 | #   which make them look nice in the Oberon system.
15 | #
16 | # See also:
17 | #   oberon2dos   (converts an Oberon file to DOS format)
18 | #
19 | # Notes:
20 | #   CR  = 13 (decimal) = 0D (hex) = 15C (octal) = \r (Perl) 
21 | #   LF  = 10 (decimal) = 0A (hex) = 12C (octal) = \n (Perl)
22 | #   TAB = 09 (decimal) = 09 (hex) = 11C (octal) = \t (Perl)
23 | #   SUB = 26 (decimal) = 1A (hex) = 32C (octal) = ?  (Perl)
24 | #
25 | #   We use Perl, because on some host systems (e.g., MacOS), the corresponding sed command does not work
26 | #
27 | # Author: Andreas Pirklbauer
28 | #
29 | 
30 | # quit unless we have the correct number of command line arguments
31 | $num_args = $#ARGV + 1;
32 | if ($num_args != 2) {
33 |     print "Usage: dos2oberon inputfile outputfile\n";
34 |     exit;
35 | }
36 | 
37 | # get the two command line arguments
38 | $inputfile=$ARGV[0];
39 | $outputfile=$ARGV[1];
40 | 
41 | open(FILE, "$inputfile") || die "inputfile not found";
42 | my @lines = <FILE>;
43 | close(FILE);
44 | 
45 | my $x = "  " ;    # 2 spaces
46 | my $y = "\t" ;    # 1 TAB
47 | 
48 | my @newlines;
49 | foreach(@lines) {
50 |     # convert all CRLF (\r\n) to CR (\r) only, so we no longer have any CRLF in the file afterwards
51 |     $_ =~ s/\r\n/\r/g;
52 |     # convert all LF (\n) to CR (\r) only, so we no longer have any LF in the file afterwards
53 |     $_ =~ s/\n/\r/g;
54 |     # replace two spaces with one TAB (\t), but only at the beginning of a ($_ =~ s/  /\t/g could cause trouble inside strings!)
55 |     while ($_ =~ s/^($y*)$x/$1$y/) {}
56 |     # replace 2 spaces before a comment by a TAB
57 |     $_ =~ s/$x(\(\*.*\**\))/$y$1/g;       
58 |     # push output line
59 |     push(@newlines,$_);
60 | }
61 | 
62 | open(FILE, ">$outputfile") || die "File not found";
63 | print FILE @newlines;
64 | close(FILE);
65 | 
66 | 


--------------------------------------------------------------------------------
/Sources/ExtendedOberon/TestForward.Mod:
--------------------------------------------------------------------------------
 1 | MODULE TestForward; (*test forward declarations of procedures / ^ after MODULE enables the retro compiler / AP 11.1.22 Extended Oberon*)
 2 |   IMPORT Texts, Oberon;
 3 |   TYPE T = PROCEDURE(VAR x, y: INTEGER; z: REAL);
 4 |     Ptr = POINTER TO Rec;
 5 |     PtrExt = POINTER TO RecExt;
 6 |     Rec = RECORD x, y: INTEGER END ;
 7 |     RecExt = RECORD (Rec) z: INTEGER END ;
 8 | 
 9 |   VAR W: Texts.Writer; G: T; ptr: Ptr; ptrext: PtrExt;
10 | 
11 |   PROCEDURE^ P(VAR x, y: INTEGER; z: REAL);
12 | 
13 |   PROCEDURE w(s: ARRAY OF CHAR);
14 |   BEGIN Texts.WriteString(W, s); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
15 |   END w;
16 | 
17 |   PROCEDURE A(VAR x, y: INTEGER; z: REAL); BEGIN w("A") END A;
18 | 
19 |   PROCEDURE Go1*;
20 |     VAR i, j: INTEGER; k: REAL; b: T;
21 | 
22 |     PROCEDURE S(t: T): T;
23 |       VAR a, b: INTEGER; c: REAL;
24 |     BEGIN w("S"); A(a, b, c); P(a, b, c); RETURN t
25 |     END S;
26 | 
27 |   BEGIN w("Go1");
28 |     A(i, j, k);
29 |     P(i, j, k);
30 |     b := S(P); b(i, j, k);
31 |     b := S(A); b(i, j, k);
32 |     G := A; G(i, j, k);
33 |     G := P; G(i, j, k)
34 |   END Go1;
35 | 
36 |   PROCEDURE P(VAR x, y: INTEGER; z: REAL);
37 |     PROCEDURE Q;
38 |       PROCEDURE R;
39 |         VAR a, b: INTEGER; c: REAL;
40 |       BEGIN w("R"); A(a, b, c)
41 |       END R;
42 |     BEGIN w("Q"); R
43 |     END Q;
44 |   BEGIN w("P"); Q
45 |   END P;
46 | 
47 |   PROCEDURE Go2*;
48 |     VAR i, j: INTEGER; k: REAL;
49 |   BEGIN w("Go2"); G := P; G(i, j, k)
50 |   END Go2;
51 | 
52 |   (*forward declarations of type bound procedures*)
53 | 
54 |   PROCEDURE^ (ptr: Ptr) Method (str: ARRAY OF CHAR);
55 |   PROCEDURE^ (ptrext: PtrExt) Method (str: ARRAY OF CHAR);
56 | 
57 |   PROCEDURE Go3*;
58 |   BEGIN ptr.Method("base type")
59 |   END Go3;
60 | 
61 |   PROCEDURE Go4*;
62 |   BEGIN ptrext.Method("extended type")
63 |   END Go4;
64 | 
65 |   PROCEDURE (ptr: Ptr) Method (str: ARRAY OF CHAR);
66 |   BEGIN Texts.WriteString(W, "Hello from Ptr.Method; str = "); Texts.WriteString(W, str);
67 |     Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
68 |   END Method;
69 | 
70 |   PROCEDURE (ptrext: PtrExt) Method (str: ARRAY OF CHAR);
71 |   BEGIN Texts.WriteString(W, "Hello from PtrExt.Method; str = "); Texts.WriteString(W, str);
72 |     Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
73 |   END Method;
74 | 
75 | BEGIN Texts.OpenWriter(W); G := A; NEW(ptr); NEW(ptrext)
76 | END TestForward.
77 | 
78 | ORP.Compile ORS.Mod/s ORB.Mod/s ORG.Mod/s ORP.Mod/s ~   # compile the new compiler
79 | System.Free ORTool ORP ORG ORB ORS ~                    # unload the old compiler
80 | 
81 | ORP.Compile TestForward.Mod/s ~
82 | System.Free TestForward ~
83 | ORTool.DecObj TestForward.rsc ~
84 | 
85 | TestForward.Go1
86 | TestForward.Go2
87 | TestForward.Go3
88 | TestForward.Go4
89 | 


--------------------------------------------------------------------------------
/Sources/ExtendedOberon/TestWith.Mod:
--------------------------------------------------------------------------------
 1 | MODULE^ TestWith;  (*test WITH statement / ^ after MODULE enables the retro compiler / AP 11.1.22 Extended Oberon*)
 2 |   IMPORT Texts, Oberon;
 3 |   TYPE R0 = RECORD fld0: INTEGER END ;
 4 |     R1 = RECORD (R0) fld1: INTEGER END ;
 5 |     R2 = RECORD (R0) fld2: INTEGER END ;
 6 | 
 7 |     P0 = POINTER TO R0;
 8 |     P1 = POINTER TO R1;
 9 |     P2 = POINTER TO R2;
10 | 
11 |     A = ARRAY OF INTEGER;  (*open array*)
12 |     P = POINTER TO A;
13 | 
14 |   VAR p: P; p0: P0; p1: P1; p2: P2; q, q0, q1, q2: P0;
15 |     r0: R0; r1: R1; r2: R2;
16 | 
17 |     W: Texts.Writer;
18 | 
19 |   PROCEDURE Str*(s: ARRAY OF CHAR);
20 |   BEGIN Texts.WriteString(W, s); Texts.Append(Oberon.Log, W.buf)
21 |   END Str;
22 | 
23 |   PROCEDURE Ln*;
24 |   BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
25 |   END Ln;
26 | 
27 |   PROCEDURE Proc1(p0: P0); BEGIN END Proc1;
28 |   PROCEDURE Proc2(VAR p1: P1); BEGIN END Proc2;
29 |   PROCEDURE Proc3(VAR r0: R0); BEGIN r0 := r2 (*projection*) END Proc3;
30 |   PROCEDURE Proc4(r0: R0); BEGIN END Proc4;
31 |   PROCEDURE Proc5(VAR i: INTEGER); BEGIN END Proc5;
32 |   PROCEDURE Proc6(b: BOOLEAN); BEGIN END Proc6;
33 | 
34 |   PROCEDURE check();
35 |     VAR r0, r1, r2: P0;
36 |   BEGIN r0 := q0; r1 := q1; r2 := q2;
37 |     WITH
38 |       r2: P2 DO Str("r2 IS P2"); Ln; q0:= p0; q1 := p1; q2 := p0
39 |     | r1: P1 DO Str("r1 IS P1"); Ln; q0:= p0; q1 := p0; q2 := p0
40 |     | r0: P0 DO Str("r0 IS P0"); Ln; q0:= p0; q1 := p0; q2 := p2
41 |     END
42 |   END check;
43 | 
44 |   (*
45 |   PROCEDURE check1();
46 |     VAR p, pa, pb: P0; pc: P1;
47 |   BEGIN p := p1; p.fld0 := 33; pa := p; pb := p1; pc := p1;
48 |     WITH 
49 |       p: P1 DO
50 |         pa := p;
51 |         Proc1(p);
52 |         Proc2(p);          (*ERROR "read-only" - cannot pass a with variable of a pointer type as a VAR parameter*)
53 |         Proc5(p.fld1);
54 |         p := p2;           (*ERROR "read-only" - cannot modify a with variable through an assignment*)
55 |         p.fld1 := 123;
56 |         WITH
57 |           p: P1 DO
58 |             p := p1;       (*ERROR "read-only" - cannot modify a with variable through an assignment*)
59 |             Proc1(p);
60 |             Proc2(p)       (*ERROR "read-only" - cannot pass a with variable of a pointer type as a VAR parameter*)
61 |         |pa: P0 DO
62 |           pa := pb;        (*ERROR "read-only" - cannot modify a with variable through an assignment*)
63 |           pb := pa;
64 |           p := pa;         (*ERROR "read-only" - cannot modify an (outer!) with variable through an assignment*)
65 |           pc := p1
66 |         END ;
67 |         p := p1            (*ERROR "read-only" - cannot modify a with variable through an assignment*)
68 |     | pc: P1 DO
69 |       p1 := pc;
70 |       pc := p1             (*ERROR "read-only" - cannot modify a with variable through an assignment*)
71 |     ELSE p := p1
72 |     END
73 |   END check1;
74 |   *)
75 | 
76 |   PROCEDURE Go*;
77 |   BEGIN check()(*; check1()*)
78 |   END Go;
79 | 
80 | BEGIN Texts.OpenWriter(W); NEW(p, 100); NEW(p0); NEW(p1); NEW(p2); q0 := p0; q1 := p1; q2 := p2
81 | END TestWith.
82 | 
83 | ORP.Compile ORS.Mod/s ORB.Mod/s ORG.Mod/s ORP.Mod/s ~   # compile the new compiler
84 | System.Free ORTool ORP ORG ORB ORS ~                    # unload the old compiler
85 | 
86 | ORP.Compile TestWith.Mod/s ~
87 | System.Free TestWith ~
88 | TestWith.Go
89 | 


--------------------------------------------------------------------------------
/Sources/ExtendedOberon/ORS.Mod:
--------------------------------------------------------------------------------
  1 | MODULE ORS; (* NW 19.9.93 / 20.3.2017  Scanner in Oberon-07 / AP 11.1.22 Extended Oberon with retro elements*)
  2 |   IMPORT SYSTEM, Texts, Oberon;
  3 | 
  4 | (* Oberon Scanner does lexical analysis. Input is Oberon-Text, output is
  5 |   sequence of symbols, i.e identifiers, numbers, strings, and special symbols.
  6 |   Recognises all Oberon keywords and skips comments. The keywords are
  7 |   recorded in a table.
  8 |   Get(sym) delivers next symbol from input text with Reader R.
  9 |   Mark(msg) records error and delivers error message with Writer W.
 10 |   If Get delivers ident, then the identifier (a string) is in variable id, if int or char
 11 |   in ival, if real in rval, and if string in str (and slen) *)
 12 |   
 13 |   CONST IdLen* = 32;
 14 |     NKW = 38;  (*nof keywords*)
 15 |     maxExp = 38; stringBufSize = 256;
 16 |   
 17 |     (*lexical symbols*)
 18 |     null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4;
 19 |     and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9;
 20 |     neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14;
 21 |     in* = 15; is* = 16; arrow* = 17; period* = 18;
 22 |     char* = 20; int* = 21; real* = 22; false* = 23; true* = 24;
 23 |     nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29;
 24 |     lbrace* = 30; ident* = 31;
 25 |     if* = 32; while* = 33; repeat* = 34; loop* = 35; exit* = 36;
 26 |     return* = 37; case* = 38; with* = 39; for* = 40;
 27 |     comma* = 41; colon* = 42; becomes* = 43; upto* = 44; rparen* = 45;
 28 |     rbrak* = 46; rbrace* = 47; then* = 48; of* = 49; do* = 50;
 29 |     to* = 51; by* = 52; semicolon* = 53; bar* = 54; end* = 55;
 30 |     else* = 56; elsif* = 57; until* = 58;
 31 |     array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64;
 32 |     var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69; final* = 70; eot = 71;
 33 | 
 34 |   TYPE Ident* = ARRAY IdLen OF CHAR;
 35 | 
 36 |   VAR ival*, slen*: LONGINT;  (*results of Get*)
 37 |     rval*: REAL;
 38 |     id*: Ident;  (*for identifiers*)
 39 |     str*: ARRAY stringBufSize OF CHAR;
 40 |     errcnt*: INTEGER;
 41 | 
 42 |     ch: CHAR;  (*last character read*)
 43 |     errpos: LONGINT;
 44 |     R: Texts.Reader;
 45 |     W: Texts.Writer;
 46 |     k: INTEGER;
 47 |     KWX: ARRAY 10 OF INTEGER;
 48 |     keyTab: ARRAY NKW OF
 49 |         RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END;
 50 |   
 51 |   PROCEDURE CopyId*(VAR ident: Ident);
 52 |   BEGIN ident := id
 53 |   END CopyId;
 54 | 
 55 |   PROCEDURE Pos*(): LONGINT;
 56 |   BEGIN RETURN Texts.Pos(R) - 1
 57 |   END Pos;
 58 | 
 59 |   PROCEDURE Mark*(msg: ARRAY OF CHAR);
 60 |     VAR p: LONGINT;
 61 |   BEGIN p := Pos();
 62 |     IF (p > errpos) & (errcnt < 25) THEN
 63 |       Texts.WriteLn(W); Texts.WriteString(W, "  pos "); Texts.WriteInt(W, p, 1); Texts.Write(W, " ");
 64 |       Texts.WriteString(W, msg); Texts.Append(Oberon.Log, W.buf)
 65 |     END ;
 66 |     INC(errcnt); errpos := p + 4
 67 |   END Mark;
 68 | 
 69 |   PROCEDURE Identifier(VAR sym: INTEGER);
 70 |     VAR i, k: INTEGER;
 71 |   BEGIN i := 0;
 72 |     REPEAT
 73 |       IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
 74 |       Texts.Read(R, ch)
 75 |     UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
 76 |     id[i] := 0X; 
 77 |     IF i < 10 THEN k := KWX[i-1];  (*search for keyword*)
 78 |       WHILE (id # keyTab[k].id) & (k < KWX[i]) DO INC(k) END ;
 79 |       IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END
 80 |     ELSE sym := ident
 81 |     END
 82 |   END Identifier;
 83 | 
 84 |   PROCEDURE String;
 85 |     VAR i: INTEGER;
 86 |   BEGIN i := 0; Texts.Read(R, ch);
 87 |     WHILE ~R.eot & (ch # 22X) DO
 88 |       IF ch >= " " THEN
 89 |         IF i < stringBufSize-1 THEN str[i] := ch; INC(i) ELSE Mark("string too long") END ;
 90 |       END ;
 91 |       Texts.Read(R, ch)
 92 |     END ;
 93 |     str[i] := 0X; INC(i); Texts.Read(R, ch); slen := i
 94 |   END String;
 95 | 
 96 |   PROCEDURE HexString;
 97 |     VAR i, m, n: INTEGER;
 98 |   BEGIN i := 0; Texts.Read(R, ch);
 99 |     WHILE ~R.eot & (ch # "$") DO
100 |       WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END ;  (*skip*)
101 |       IF ("0" <= ch) & (ch <= "9") THEN m := ORD(ch) - 30H
102 |       ELSIF ("A" <= ch) & (ch <= "F") THEN m := ORD(ch) - 37H
103 |       ELSE m := 0; Mark("hexdig expected")
104 |       END ;
105 |       Texts.Read(R, ch);
106 |       IF ("0" <= ch) & (ch <= "9") THEN n := ORD(ch) - 30H
107 |       ELSIF ("A" <= ch) & (ch <= "F") THEN n := ORD(ch) - 37H
108 |       ELSE n := 0; Mark("hexdig expected")
109 |       END ;
110 |       IF i < stringBufSize THEN str[i] := CHR(m*10H + n); INC(i) ELSE Mark("string too long") END ;
111 |       Texts.Read(R, ch)
112 |     END ;
113 |     Texts.Read(R, ch); slen := i  (*no 0X appended!*)
114 |   END HexString;
115 | 
116 |   PROCEDURE Ten(e: LONGINT): REAL;
117 |     VAR x, t: REAL;
118 |   BEGIN x := 1.0; t := 10.0;
119 |     WHILE e > 0 DO
120 |       IF ODD(e) THEN x := t * x END ;
121 |       t := t * t; e := e DIV 2
122 |     END ;
123 |     RETURN x
124 |   END Ten;
125 | 
126 |   PROCEDURE Number(VAR sym: INTEGER);
127 |     CONST max = 2147483647 (*2^31 - 1*);
128 |     VAR i, k, e, n, s, h: LONGINT; x: REAL;
129 |       d: ARRAY 16 OF INTEGER;
130 |       negE: BOOLEAN;
131 |   BEGIN ival := 0; i := 0; n := 0; k := 0;
132 |     REPEAT
133 |       IF n < 16 THEN d[n] := ORD(ch)-30H; INC(n) ELSE Mark("too many digits"); n := 0 END ;
134 |       Texts.Read(R, ch)
135 |     UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F");
136 |     IF (ch = "H") OR (ch = "R") OR (ch = "X") THEN  (*hex*)
137 |       REPEAT h := d[i];
138 |         IF h >= 10 THEN h := h-7 END ;
139 |         k := k*10H + h; INC(i) (*no overflow check*)
140 |       UNTIL i = n;
141 |       IF ch = "X" THEN sym := char;
142 |         IF k < 100H THEN ival := k ELSE Mark("illegal value"); ival := 0 END
143 |       ELSIF ch = "R" THEN sym := real; rval := SYSTEM.VAL(REAL, k)
144 |       ELSE sym := int; ival := k
145 |       END ;
146 |       Texts.Read(R, ch)
147 |     ELSIF ch = "." THEN
148 |       Texts.Read(R, ch);
149 |       IF ch = "." THEN (*double dot*) ch := 7FX;  (*decimal integer*)
150 |         REPEAT
151 |           IF d[i] < 10 THEN
152 |             IF k <= (max-d[i]) DIV 10 THEN k := k *10 + d[i] ELSE Mark("too large"); k := 0 END
153 |           ELSE Mark("bad integer")
154 |           END ;
155 |           INC(i)
156 |         UNTIL i = n;
157 |         sym := int; ival := k
158 |       ELSE (*real number*) x := 0.0; e := 0;
159 |         REPEAT  (*integer part*) x := x * 10.0 + FLT(d[i]); INC(i) UNTIL i = n;
160 |         WHILE (ch >= "0") & (ch <= "9") DO  (*fraction*)
161 |           x := x * 10.0 + FLT(ORD(ch) - 30H); DEC(e); Texts.Read(R, ch)
162 |         END ;
163 |         IF (ch = "E") OR (ch = "D") THEN  (*scale factor*)
164 |           Texts.Read(R, ch); s := 0; 
165 |           IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch)
166 |           ELSE negE := FALSE;
167 |             IF ch = "+" THEN Texts.Read(R, ch) END
168 |           END ;
169 |           IF (ch >= "0") & (ch <= "9") THEN
170 |             REPEAT s := s*10 + ORD(ch)-30H; Texts.Read(R, ch)
171 |             UNTIL (ch < "0") OR (ch >"9");
172 |             IF negE THEN e := e-s ELSE e := e+s END
173 |           ELSE Mark("digit?")
174 |           END
175 |         END ;
176 |         IF e < 0 THEN
177 |           IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END
178 |         ELSIF e > 0 THEN
179 |           IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0; Mark("too large") END
180 |         END ;
181 |         sym := real; rval := x
182 |       END
183 |     ELSE  (*decimal integer*)
184 |       REPEAT
185 |         IF d[i] < 10 THEN
186 |           IF k <= (max-d[i]) DIV 10 THEN k := k*10 + d[i] ELSE Mark("too large"); k := 0 END
187 |         ELSE Mark("bad integer")
188 |         END ;
189 |         INC(i)
190 |       UNTIL i = n;
191 |       sym := int; ival := k
192 |     END
193 |   END Number;
194 | 
195 |   PROCEDURE comment;
196 |   BEGIN Texts.Read(R, ch);
197 |     REPEAT
198 |       WHILE ~R.eot & (ch # "*") DO
199 |         IF ch = "(" THEN Texts.Read(R, ch);
200 |           IF ch = "*" THEN comment END
201 |         ELSE Texts.Read(R, ch)
202 |         END
203 |       END ;
204 |       WHILE ch = "*" DO Texts.Read(R, ch) END
205 |     UNTIL (ch = ")") OR R.eot;
206 |     IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("unterminated comment") END
207 |   END comment;
208 | 
209 |   PROCEDURE Get*(VAR sym: INTEGER);
210 |   BEGIN
211 |     REPEAT
212 |       WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
213 |       IF R.eot THEN sym := eot
214 |       ELSIF ch < "A" THEN
215 |         IF ch < "0" THEN
216 |           IF ch = 22X THEN String; sym := string
217 |           ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
218 |           ELSIF ch = "$" THEN HexString; sym := string
219 |           ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
220 |           ELSIF ch = "(" THEN Texts.Read(R, ch); 
221 |             IF ch = "*" THEN sym := null; comment ELSE sym := lparen END
222 |           ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
223 |           ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times
224 |           ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
225 |           ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
226 |           ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus
227 |           ELSIF ch = "." THEN Texts.Read(R, ch);
228 |             IF ch = "." THEN Texts.Read(R, ch); sym := upto ELSE sym := period END
229 |           ELSIF ch = "/" THEN Texts.Read(R, ch); sym := rdiv
230 |           ELSE Texts.Read(R, ch); (* ! % ' *) sym := null
231 |           END
232 |         ELSIF ch < ":" THEN Number(sym)
233 |         ELSIF ch = ":" THEN Texts.Read(R, ch);
234 |           IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END 
235 |         ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
236 |         ELSIF ch = "<" THEN  Texts.Read(R, ch);
237 |           IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
238 |         ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
239 |         ELSIF ch = ">" THEN Texts.Read(R, ch);
240 |           IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
241 |         ELSE (* ? @ *) Texts.Read(R, ch); sym := null
242 |         END
243 |       ELSIF ch < "[" THEN Identifier(sym)
244 |       ELSIF ch < "a" THEN
245 |         IF ch = "[" THEN sym := lbrak
246 |         ELSIF ch = "]" THEN  sym := rbrak
247 |         ELSIF ch = "^" THEN sym := arrow
248 |         ELSE (* _ ` *) sym := null
249 |         END ;
250 |         Texts.Read(R, ch)
251 |       ELSIF ch < "{" THEN Identifier(sym) ELSE
252 |         IF ch = "{" THEN sym := lbrace
253 |         ELSIF ch = "}" THEN sym := rbrace
254 |         ELSIF ch = "|" THEN sym := bar
255 |         ELSIF ch = "~" THEN  sym := not
256 |         ELSIF ch = 7FX THEN  sym := upto
257 |         ELSE sym := null
258 |         END ;
259 |         Texts.Read(R, ch)
260 |       END
261 |     UNTIL sym # null
262 |   END Get;
263 | 
264 |   PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
265 |   BEGIN errpos := pos; errcnt := 0; Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
266 |   END Init;
267 | 
268 |   PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR);
269 |   BEGIN keyTab[k].id := name; keyTab[k].sym := sym; INC(k)
270 |   END EnterKW;
271 | 
272 | BEGIN Texts.OpenWriter(W); k := 0; KWX[0] := 0; KWX[1] := 0;
273 |   EnterKW(if, "IF");
274 |   EnterKW(do, "DO");
275 |   EnterKW(of, "OF");
276 |   EnterKW(or, "OR");
277 |   EnterKW(to, "TO");
278 |   EnterKW(in, "IN");
279 |   EnterKW(is, "IS");
280 |   EnterKW(by, "BY");
281 |   KWX[2] := k;
282 |   EnterKW(end, "END");
283 |   EnterKW(nil, "NIL");
284 |   EnterKW(var, "VAR");
285 |   EnterKW(div, "DIV");
286 |   EnterKW(mod, "MOD");
287 |   EnterKW(for, "FOR");
288 |   KWX[3] := k;
289 |   EnterKW(else, "ELSE");
290 |   EnterKW(then, "THEN");
291 |   EnterKW(true, "TRUE");
292 |   EnterKW(type, "TYPE");
293 |   EnterKW(case, "CASE");
294 |   EnterKW(loop, "LOOP");
295 |   EnterKW(exit, "EXIT");
296 |   EnterKW(with, "WITH");
297 |   KWX[4] := k;
298 |   EnterKW(elsif, "ELSIF");
299 |   EnterKW(false, "FALSE");
300 |   EnterKW(array, "ARRAY");
301 |   EnterKW(begin, "BEGIN");
302 |   EnterKW(const, "CONST");
303 |   EnterKW(until, "UNTIL");
304 |   EnterKW(while, "WHILE");
305 |   EnterKW(final, "FINAL");
306 |   KWX[5] := k;
307 |   EnterKW(record, "RECORD");
308 |   EnterKW(repeat, "REPEAT");
309 |   EnterKW(return, "RETURN");
310 |   EnterKW(import, "IMPORT");
311 |   EnterKW(module, "MODULE");
312 |   KWX[6] := k;
313 |   EnterKW(pointer, "POINTER");
314 |   KWX[7] := k; KWX[8] := k;
315 |   EnterKW(procedure, "PROCEDURE");
316 |   KWX[9] := k
317 | END ORS.
318 | 


--------------------------------------------------------------------------------
/Sources/ExtendedOberon/ORB.Mod:
--------------------------------------------------------------------------------
  1 | MODULE ORB;   (*NW 25.6.2014  / AP 4.3.2020 / 5.3.2019  in Oberon-07 / AP 1.11.23 Extended Oberon*)
  2 |   IMPORT Files, ORS;
  3 |   (*Definition of data types Object and Type, which together form the data structure
  4 |     called "symbol table". Contains procedures for creation of Objects, and for search:
  5 |     NewObj, this, thisimport, thisfield (and OpenScope, CloseScope).
  6 |     Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures
  7 |     Import and Export. This module contains the list of standard identifiers, with which
  8 |     the symbol table (universe), and that of the pseudo-module SYSTEM are initialized. *)
  9 | 
 10 |   CONST versionkey* = 1; maxTypTab = 64; C20 = 100000H;
 11 |     (* class values*) Head* = 0;
 12 |       Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5;
 13 |       SProc* = 6; SFunc* = 7; Mod* = 8;
 14 | 
 15 |     (* form values*)
 16 |       Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6;
 17 |       Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10; TProc* = 11;
 18 |       String* = 12; Array* = 13; Record* = 14;
 19 |       Ptrs* = {Pointer, NilTyp}; Procs* = {Proc, NoTyp};
 20 | 
 21 |   TYPE Object* = POINTER TO ObjDesc;
 22 |     Module* = POINTER TO ModDesc;
 23 |     Type* = POINTER TO TypeDesc;
 24 | 
 25 |     ObjDesc*= RECORD
 26 |       class*, exno*: BYTE;
 27 |       expo*, rdo*: BOOLEAN;  (*exported / read-only*)
 28 |       lev*: INTEGER;
 29 |       next*, dsc*: Object;
 30 |       type*: Type;
 31 |       name*: ORS.Ident;
 32 |       val*: LONGINT
 33 |     END ;
 34 | 
 35 |     ModDesc* = RECORD (ObjDesc) orgname*: ORS.Ident END ;
 36 | 
 37 |     TypeDesc* = RECORD
 38 |       form*, mno*, ref, orgref: INTEGER;  (*ref and orgref are only used for import/export*)
 39 |       nofpar*: INTEGER;  (*for procedures, extension level for records*)
 40 |       len*: LONGINT;  (*for arrays, len < 0 => open array; for records: adr of descriptor*)
 41 |       dsc*, typobj*: Object;
 42 |       base*: Type;  (*for arrays, records, pointers*)
 43 |       size*: LONGINT  (*in bytes; always multiple of 4, except for Byte, Bool and Char*)
 44 |     END ;
 45 | 
 46 |   (* Object classes and the meaning of "val":
 47 |     class    val
 48 |     ----------
 49 |     Var      address
 50 |     Par      address
 51 |     Const    value
 52 |     Fld      offset
 53 |     Typ      type descriptor (TD) address
 54 |     SProc    inline code number
 55 |     SFunc    inline code number
 56 |     Mod      key
 57 | 
 58 |   Type forms and the meaning of "dsc" and "base":
 59 |     form     dsc      base
 60 |     ------------------------
 61 |     Pointer  -        type of dereferenced object
 62 |     Proc     params   result type
 63 |     Array    -        type of elements
 64 |     Record   fields   extension *)
 65 | 
 66 |   VAR topScope*, universe, system*: Object;
 67 |     byteType*, boolType*, charType*: Type;
 68 |     intType*, realType*, setType*, nilType*, noType*, strType*: Type;
 69 |     nofmod, Ref: INTEGER;
 70 |     typtab: ARRAY maxTypTab OF Type;
 71 |     self: ORS.Ident;  (*name of module being compiled*)
 72 | 
 73 |   PROCEDURE NewObj*(VAR obj: Object; id: ORS.Ident; class: INTEGER);  (*insert new Object with name id*)
 74 |     VAR new, x: Object;
 75 |   BEGIN x := topScope;
 76 |     WHILE (x.next # NIL) & ((x.next.name # id) OR (x.next.class = Mod) & ~x.next.rdo) DO x := x.next END ;
 77 |     IF x.next = NIL THEN
 78 |       NEW(new); new.name := id; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL;
 79 |       x.next := new; obj := new
 80 |     ELSE obj := x.next; ORS.Mark("mult def")
 81 |     END
 82 |   END NewObj;
 83 | 
 84 |   PROCEDURE FindObj*(id: ORS.Ident; list: Object): Object;  (*search id in list*)
 85 |     VAR x: Object;
 86 |   BEGIN x := list;
 87 |     WHILE (x # NIL) & ((x.name # id) OR (x.class = Mod) & ~x.rdo) DO x := x.next END ;
 88 |     RETURN x
 89 |   END FindObj;
 90 | 
 91 |   PROCEDURE thisObj*(): Object;
 92 |     VAR s, x: Object;
 93 |   BEGIN s := topScope;
 94 |     REPEAT x := s.next;
 95 |       WHILE (x # NIL) & ((x.name # ORS.id) OR (x.class = Mod) & ~x.rdo) DO x := x.next END ;
 96 |       s := s.dsc
 97 |     UNTIL (x # NIL) OR (s = NIL);
 98 |     RETURN x
 99 |   END thisObj;
100 | 
101 |   PROCEDURE thisimport*(mod: Object): Object;
102 |     VAR obj: Object;
103 |   BEGIN (*mod.rdo*) obj := mod.dsc;
104 |     WHILE (obj # NIL) & (obj.name # ORS.id) DO obj := obj.next END ;
105 |     RETURN obj
106 |   END thisimport;
107 | 
108 |   PROCEDURE thisfield*(rec: Type): Object;
109 |     VAR fld: Object;
110 |   BEGIN fld := rec.dsc;
111 |     WHILE (fld # NIL) & (fld.name # ORS.id) DO fld := fld.next END ;
112 |     RETURN fld
113 |   END thisfield;
114 | 
115 |   PROCEDURE FindField*(id: ORS.Ident; rec: Type): Object;  (*search id in fields of rec proper, but not its base types*)
116 |     VAR fld, bot: Object;
117 |   BEGIN fld := rec.dsc;
118 |     IF rec.base # NIL THEN bot := rec.base.dsc ELSE bot := NIL END ;
119 |     WHILE (fld # bot) & (fld.name # id) DO fld := fld.next END ;
120 |     IF fld = bot THEN fld := NIL END ;
121 |     RETURN fld
122 |   END FindField;
123 | 
124 |   PROCEDURE NofMethods*(rec: Type): INTEGER;  (*number of methods bound to rec and its base types*)
125 |     VAR fld: Object; max: INTEGER;
126 |   BEGIN fld := rec.dsc; max := -1;
127 |     WHILE fld # NIL DO
128 |       IF (fld.class = Const) & (fld.lev > max) THEN max := fld.lev END ;
129 |       fld := fld.next
130 |     END ;
131 |     RETURN max + 1
132 |   END NofMethods;
133 | 
134 |   PROCEDURE NewMethod*(rec: Type; VAR mth, redef: Object; id: ORS.Ident);  (*insert new method with name id*)
135 |     VAR fld, fld0, new, bot: Object;
136 | 
137 |     PROCEDURE UpdateLinks(rec: Type; new, bot: Object);  (*between field lists of extensions*)
138 |       VAR obj, fld: Object;
139 |     BEGIN obj := rec.typobj.next;
140 |       WHILE obj # NIL DO
141 |         IF (obj.class = Typ) & (obj.type.form = Record) & (obj.type.base = rec) THEN
142 |           IF obj.type.dsc = bot THEN obj.type.dsc := new; UpdateLinks(obj.type, new, bot)
143 |           ELSE fld := obj.type.dsc;
144 |             WHILE fld.next # bot DO fld := fld.next END ;
145 |             fld.next := new
146 |           END
147 |         END ;
148 |         obj := obj.next
149 |       END
150 |     END UpdateLinks;
151 | 
152 |   BEGIN (*rec.typobj # NIL*) fld := rec.dsc; redef := NIL;
153 |     IF rec.base # NIL THEN bot := rec.base.dsc ELSE bot := NIL END ;
154 |     WHILE (fld # bot) & (fld.name # id) DO fld0 := fld; fld := fld.next END ;  (*search id in fields of rec proper*)
155 |     IF fld = bot THEN
156 |       WHILE (fld # NIL) & (fld.name # id) DO fld := fld.next END ;  (*search id in fields of base types of rec*)
157 |       IF (fld = NIL) OR (fld.class = Const) THEN
158 |         NEW(new); new.name := id; new.class := Const; new.rdo := FALSE; new.dsc := NIL; new.next := bot; mth := new;
159 |         IF fld = NIL THEN new.lev := NofMethods(rec) ELSE new.lev := fld.lev; redef := fld END ;  (*assign mthno*)
160 |         IF rec.dsc = bot THEN rec.dsc := new; UpdateLinks(rec, new, bot) ELSE fld0.next := new END
161 |       ELSE mth := fld; ORS.Mark("mult def")
162 |       END
163 |     ELSE mth := fld; ORS.Mark("mult def")
164 |     END
165 |   END NewMethod;
166 | 
167 |   PROCEDURE OpenScope*;
168 |     VAR s: Object;
169 |   BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s
170 |   END OpenScope;
171 | 
172 |   PROCEDURE CloseScope*;
173 |   BEGIN topScope := topScope.dsc
174 |   END CloseScope;
175 | 
176 |   (*------------------------------- Import ---------------------------------*)
177 | 
178 |   PROCEDURE MakeFileName*(VAR FName: ORS.Ident; name, ext: ARRAY OF CHAR);
179 |     VAR i, j: INTEGER;
180 |   BEGIN i := 0; j := 0;  (*assume name suffix less than 4 characters*)
181 |     WHILE (i < ORS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ;
182 |     REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X;
183 |     FName[i] := 0X
184 |   END MakeFileName;
185 | 
186 |   PROCEDURE ThisModule(name, orgname: ORS.Ident; decl: BOOLEAN; key: LONGINT): Object;
187 |     VAR mod: Module; obj, obj1: Object;
188 |   BEGIN obj1 := topScope;
189 |     IF decl THEN obj := obj1.next;  (*search for alias*)
190 |       WHILE (obj # NIL) & ((obj.name # name) OR ~obj.rdo) DO obj := obj.next END
191 |     ELSE obj := NIL
192 |     END ;
193 |     IF obj = NIL THEN obj := obj1.next;  (*search for module*)
194 |       WHILE (obj # NIL) & (obj(Module).orgname # orgname) DO obj1 := obj; obj := obj1.next END ;
195 |       IF obj = NIL THEN (*insert new module*)
196 |         IF orgname = self THEN ORS.Mark("recursive import not allowed") END ;
197 |         NEW(mod); mod.class := Mod; mod.rdo := decl;
198 |         mod.name := name; mod.orgname := orgname; mod.val := key;
199 |         mod.lev := nofmod; INC(nofmod); mod.type := noType; mod.dsc := NIL; mod.next := NIL;
200 |         obj1.next := mod; obj := mod
201 |       ELSE (*module already present*)
202 |         IF obj.val # key THEN ORS.Mark("imported with bad key")
203 |         ELSIF decl THEN (*explicit import by declaration*)
204 |           IF obj.rdo THEN ORS.Mark("mult def") ELSE obj.name := name; obj.rdo := TRUE END
205 |         END
206 |       END
207 |     ELSE ORS.Mark("mult def")
208 |     END ;
209 |     RETURN obj
210 |   END ThisModule;
211 | 
212 |   PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER);
213 |     VAR b: BYTE;
214 |   BEGIN Files.ReadByte(R, b);
215 |     IF b < 80H THEN x := b ELSE x := b - 100H END
216 |   END Read;
217 | 
218 |   PROCEDURE InType(VAR R: Files.Rider; thismod: Object; VAR T: Type);
219 |     VAR key: LONGINT;
220 |       ref, orgref, class, form, np, readonly: INTEGER;
221 |       fld, par, obj, mod, last: Object;
222 |       t: Type;
223 |       name, modname: ORS.Ident;
224 |   BEGIN Read(R, ref);
225 |     IF ref < 0 THEN T := typtab[-ref]  (*already read*)
226 |     ELSE NEW(t); T := t; t.mno := thismod.lev; t.orgref := ref;
227 |       IF ref > 0 THEN  (*named type*)
228 |         Files.ReadString(R, modname);
229 |         IF modname[0] # 0X THEN  (*re-import*)
230 |           Files.ReadInt(R, key); Files.ReadString(R, name); Read(R, orgref);
231 |           mod := ThisModule(modname, modname, FALSE, key);
232 |           obj := mod.dsc;  (*search type*)
233 |           WHILE (obj # NIL) & (obj.name # name) DO obj := obj.next END ;
234 |           IF obj # NIL THEN T := obj.type  (*type object found in object list of mod*)
235 |           ELSE (*insert new type object in object list of mod*)
236 |             NEW(obj); obj.name := name; obj.class := Typ; obj.next := mod.dsc; mod.dsc := obj; obj.type := t;
237 |             t.mno := mod.lev; t.typobj := obj; t.orgref := orgref
238 |           END
239 |         ELSIF typtab[ref] # NIL THEN T := typtab[ref]  (*already re-imported*)
240 |         END ;
241 |         typtab[ref] := T
242 |       END ;
243 |       Read(R, form); t.form := form;
244 |       IF form = Pointer THEN InType(R, thismod, t.base); t.size := 4
245 |       ELSIF form = Array THEN InType(R, thismod, t.base); Files.ReadNum(R, t.len); Files.ReadNum(R, t.size)
246 |       ELSIF form = Record THEN InType(R, thismod, t.base);
247 |         IF t.base.form = NoTyp THEN t.base := NIL; obj := NIL ELSE obj := t.base.dsc END ;
248 |         Files.ReadNum(R, t.len); Files.ReadNum(R, t.nofpar); Files.ReadNum(R, t.size);  (*TD adr exno, ext level, size*)
249 |         Read(R, class); last := NIL;
250 |         WHILE class # 0 DO  (*fields*)
251 |           NEW(fld); fld.class := class; Files.ReadString(R, fld.name);
252 |           IF last = NIL THEN t.dsc := fld ELSE last.next := fld END ;
253 |           last := fld;
254 |           IF fld.name[0] # 0X THEN fld.expo := TRUE; InType(R, thismod, fld.type); Files.ReadNum(R, fld.val)
255 |           ELSE (*hidden*) fld.expo := FALSE;
256 |             IF class = Const THEN fld.type := strType  (*type-bound procedure*)
257 |             ELSE Files.ReadNum(R, fld.val);  (*offset*)
258 |               IF fld.val < 0 THEN fld.val := -fld.val-1; fld.type := noType  (*procedure*)
259 |               ELSE fld.type := nilType  (*pointer*)
260 |               END
261 |             END
262 |           END ;
263 |           IF class = Const THEN Files.ReadNum(R, fld.lev) END ;  (*mthno*)
264 |           Read(R, class)
265 |         END ;
266 |         IF last = NIL THEN t.dsc := obj ELSE last.next := obj END
267 |       ELSIF form IN {Proc, TProc} THEN InType(R, thismod, t.base);
268 |         obj := NIL; np := 0; Read(R, class);
269 |         WHILE class # 0 DO  (*parameters*)
270 |           NEW(par); par.class := class; Read(R, readonly); par.rdo := readonly = 1;
271 |           InType(R, thismod, par.type); par.next := obj; obj := par; INC(np); Read(R, class)
272 |         END ;
273 |         t.dsc := obj; t.nofpar := np; t.size := 4
274 |       END
275 |     END
276 |   END InType;
277 | 
278 |   PROCEDURE Import*(VAR modid, modid1: ORS.Ident);
279 |     VAR key: LONGINT; class: INTEGER;
280 |       obj, thismod: Object;
281 |       t: Type;
282 |       name, modname: ORS.Ident;
283 |       F: Files.File; R: Files.Rider;
284 |   BEGIN
285 |     IF modid1 = "SYSTEM" THEN
286 |       thismod := ThisModule(modid, modid1, TRUE, key); DEC(nofmod); thismod.lev := 0; thismod.dsc := system
287 |     ELSE MakeFileName(name, modid1, ".smb"); F := Files.Old(name);
288 |       IF F # NIL THEN
289 |         Files.Set(R, F, 0); Files.ReadInt(R, key); Files.ReadInt(R, key); Files.ReadString(R, modname);
290 |         thismod := ThisModule(modid, modid1, TRUE, key);
291 |         FOR class := Record+1 TO maxTypTab-1 DO typtab[class] := NIL END ;
292 |         obj := thismod.dsc;  (*initialize typtab with already re-imported types*)
293 |         WHILE obj # NIL DO obj.type.mno := -obj.type.mno; typtab[obj.type.orgref] := obj.type; obj := obj.next END ;
294 |         Read(R, class); (*version key*)
295 |         IF class # versionkey THEN ORS.Mark("wrong version") END ;
296 |         Read(R, class);
297 |         WHILE class # 0 DO
298 |           Files.ReadString(R, name); InType(R, thismod, t);
299 |           IF t.mno < 0 THEN t.mno := -t.mno  (*type already re-imported via other modules*)
300 |           ELSE NEW(obj); obj.class := class; obj.name := name; obj.type := t; obj.lev := -thismod.lev;
301 |             IF class = Const THEN Files.ReadNum(R, obj.val)
302 |             ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE
303 |             ELSIF t.typobj = NIL THEN t.typobj := obj
304 |             END ;
305 |             obj.next := thismod.dsc; thismod.dsc := obj
306 |           END ;
307 |           Read(R, class)
308 |         END
309 |       ELSE ORS.Mark("import not available")
310 |       END
311 |     END
312 |   END Import;
313 | 
314 |   (*-------------------------------- Export ---------------------------------*)
315 | 
316 |   PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
317 |   BEGIN Files.WriteByte(R, x)  (* -128 <= x < 128 *)
318 |   END Write;
319 | 
320 |   PROCEDURE OutType(VAR R: Files.Rider; t: Type);
321 |     VAR obj, mod, fld, bot: Object;
322 | 
323 |     PROCEDURE OutPar(VAR R: Files.Rider; par: Object; n: INTEGER);
324 |       VAR cl: INTEGER;
325 |     BEGIN
326 |       IF n > 0 THEN
327 |         OutPar(R, par.next, n-1); cl := par.class;
328 |         Write(R, cl);
329 |         IF par.rdo THEN Write(R, 1) ELSE Write(R, 0) END ;
330 |         OutType(R, par.type)
331 |       END
332 |     END OutPar;
333 | 
334 |     PROCEDURE FindHiddenFields(VAR R: Files.Rider; typ: Type; off: LONGINT);
335 |       VAR fld: Object; i, s: LONGINT;
336 |     BEGIN
337 |       IF typ.form IN Ptrs THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, off)  (*pointer*)
338 |       ELSIF typ.form IN Procs THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, -off-1)  (*procedure*)
339 |       ELSIF typ.form = Record THEN fld := typ.dsc;
340 |         WHILE fld # NIL DO FindHiddenFields(R, fld.type, fld.val + off); fld := fld.next END
341 |       ELSIF typ.form = Array THEN s := typ.base.size;
342 |         FOR i := 0 TO typ.len-1 DO FindHiddenFields(R, typ.base, i*s + off) END
343 |       END
344 |     END FindHiddenFields;
345 | 
346 |   BEGIN
347 |     IF t.ref > 0 THEN (*type was already output*) Write(R, -t.ref)
348 |     ELSE obj := t.typobj;
349 |       IF obj # NIL THEN Write(R, Ref); t.ref := Ref; INC(Ref);
350 |         IF t.mno > 0 THEN  (*re-export, output name*)
351 |           mod := topScope.next;
352 |           WHILE (mod # NIL) & (mod.lev # t.mno) DO mod := mod.next END ;
353 |           IF mod # NIL THEN Files.WriteString(R, mod(Module).orgname); Files.WriteInt(R, mod.val);
354 |             Files.WriteString(R, obj.name); Write(R, t.orgref)
355 |           ELSE ORS.Mark("re-export not found"); Write(R, 0)
356 |           END
357 |         ELSE Write(R, 0)
358 |         END
359 |       ELSE (*anonymous*) Write(R, 0)
360 |       END ;
361 |       Write(R, t.form);
362 |       IF t.form = Pointer THEN OutType(R, t.base)
363 |       ELSIF t.form = Array THEN OutType(R, t.base); Files.WriteNum(R, t.len); Files.WriteNum(R, t.size)
364 |       ELSIF t.form = Record THEN
365 |         IF t.base # NIL THEN OutType(R, t.base); bot := t.base.dsc ELSE OutType(R, noType); bot := NIL END ;
366 |         IF obj # NIL THEN
367 |           IF t.mno > 0 THEN Files.WriteNum(R, t.len) ELSE Files.WriteNum(R, obj.exno) END
368 |         ELSE Write(R, 0)
369 |         END ;
370 |         Files.WriteNum(R, t.nofpar); Files.WriteNum(R, t.size);
371 |         fld := t.dsc;
372 |         WHILE fld # bot DO  (*fields*)
373 |           IF fld.class = Const THEN Write(R, Const);  (*type-bound procedure*)
374 |             IF fld.expo THEN Files.WriteString(R, fld.name); OutType(R, fld.type);
375 |               IF t.mno > 0 THEN Files.WriteNum(R, fld.val) ELSE Files.WriteNum(R, fld.exno) END  (*exno*)
376 |             ELSE (*hidden*) Write(R, 0)
377 |             END ;
378 |             Files.WriteNum(R, fld.lev)  (*mthno*)
379 |           ELSIF fld.expo THEN
380 |             Write(R, Fld); Files.WriteString(R, fld.name); OutType(R, fld.type); Files.WriteNum(R, fld.val)  (*offset*)
381 |           ELSE (*hidden*) FindHiddenFields(R, fld.type, fld.val)
382 |           END ;
383 |           fld := fld.next
384 |         END ;
385 |         Write(R, 0)
386 |       ELSIF t.form IN {Proc, TProc} THEN OutType(R, t.base); OutPar(R, t.dsc, t.nofpar); Write(R, 0)
387 |       END
388 |     END
389 |   END OutType;
390 | 
391 |   PROCEDURE Export*(VAR modid: ORS.Ident; VAR newSF: BOOLEAN; VAR key: LONGINT);
392 |     VAR x, sum, oldkey: LONGINT;
393 |       obj: Object;
394 |       filename: ORS.Ident;
395 |       F, F1: Files.File; R, R1: Files.Rider;
396 |   BEGIN Ref := Record + 1; MakeFileName(filename, modid, ".smb");
397 |     F := Files.New(filename); Files.Set(R, F, 0);
398 |     Files.WriteInt(R, 0); (*placeholder*)
399 |     Files.WriteInt(R, 0); (*placeholder for key to be inserted at the end*)
400 |     Files.WriteString(R, modid); Write(R, versionkey);
401 |     obj := topScope.next;
402 |     WHILE obj # NIL DO
403 |       IF obj.expo THEN
404 |         Write(R, obj.class); Files.WriteString(R, obj.name);
405 |         OutType(R, obj.type);
406 |         IF obj.class = Const THEN
407 |           IF obj.type.form = Proc THEN Files.WriteNum(R, obj.exno)
408 |           ELSIF obj.type.form = String THEN Files.WriteNum(R, obj.exno + obj.val DIV C20 (*len*) * C20)
409 |           ELSE Files.WriteNum(R, obj.val)
410 |           END
411 |         ELSIF obj.class = Var THEN Files.WriteNum(R, obj.exno)
412 |         END
413 |       END ;
414 |       obj := obj.next
415 |     END ;
416 |     REPEAT Write(R, 0) UNTIL Files.Length(F) MOD 4 = 0;
417 |     FOR Ref := Record+1 TO maxTypTab-1 DO typtab[Ref] := NIL END ;
418 |     Files.Set(R, F, 0); sum := 0; Files.ReadInt(R, x);  (* compute key (checksum) *)
419 |     WHILE ~R.eof DO sum := sum + x; Files.ReadInt(R, x) END ;
420 |     F1 := Files.Old(filename); (*sum is new key*)
421 |     IF F1 # NIL THEN Files.Set(R1, F1, 4); Files.ReadInt(R1, oldkey) ELSE oldkey := sum+1 END ;
422 |     IF sum # oldkey THEN
423 |       IF newSF OR (F1 = NIL) THEN
424 |         key := sum; newSF := TRUE; Files.Set(R, F, 4); Files.WriteInt(R, sum); Files.Register(F)  (*insert checksum*)
425 |       ELSE ORS.Mark("new symbol file inhibited")
426 |       END
427 |     ELSE newSF := FALSE; key := sum
428 |     END
429 |   END Export;
430 | 
431 |   PROCEDURE Init*(modid: ORS.Ident);
432 |   BEGIN self := modid; topScope := universe; nofmod := 1
433 |   END Init;
434 | 
435 |   PROCEDURE type(ref, form: INTEGER; size: LONGINT): Type;
436 |     VAR tp: Type;
437 |   BEGIN NEW(tp); tp.form := form; tp.size := size; tp.ref := ref; tp.base := NIL;
438 |     typtab[ref] := tp; RETURN tp
439 |   END type;
440 | 
441 |   PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: LONGINT);
442 |     VAR obj: Object;
443 |   BEGIN NEW(obj); obj.name := name; obj.class := cl; obj.type := type; obj.val := n; obj.dsc := NIL;
444 |     IF cl = Typ THEN type.typobj := obj; obj.expo := TRUE END ;
445 |     obj.next := system; system := obj
446 |   END enter;
447 | 
448 | BEGIN
449 |   byteType := type(Byte, Int, 1);
450 |   boolType := type(Bool, Bool, 1);
451 |   charType := type(Char, Char,1);
452 |   intType := type(Int, Int, 4);
453 |   realType := type(Real, Real, 4);
454 |   setType := type(Set, Set,4);
455 |   nilType := type(NilTyp, NilTyp, 4);
456 |   noType := type(NoTyp, NoTyp, 4);
457 |   strType := type(String, String, 8);
458 | 
459 |   (*initialize universe with data types and in-line procedures;
460 |     LONGINT is synonym to INTEGER, LONGREAL to REAL.
461 |     LED, ADC, SBC; LDPSR, LDREG, REG, COND are not in language definition*)
462 |   system := NIL;  (*n = procno*10 + nofpar*)
463 |   enter("UML", SFunc, intType, 132);  (*functions*)
464 |   enter("SBC", SFunc, intType, 122);
465 |   enter("ADC", SFunc, intType, 112);
466 |   enter("ROR", SFunc, intType, 92);
467 |   enter("ASR", SFunc, intType, 82);
468 |   enter("LSL", SFunc, intType, 72);
469 |   enter("LEN", SFunc, intType, 61);
470 |   enter("CHR", SFunc, charType, 51);
471 |   enter("ORD", SFunc, intType, 41);
472 |   enter("FLT", SFunc, realType, 31);
473 |   enter("FLOOR", SFunc, intType, 21);
474 |   enter("ODD", SFunc, boolType, 11);
475 |   enter("ABS", SFunc, intType, 1);
476 |   enter("LED", SProc, noType, 81);  (*procedures*)
477 |   enter("UNPK", SProc, noType, 72);
478 |   enter("PACK", SProc, noType, 62);
479 |   enter("NEW", SProc, noType, 51);
480 |   enter("ASSERT", SProc, noType, 41);
481 |   enter("EXCL", SProc, noType, 32);
482 |   enter("INCL", SProc, noType, 22);
483 |   enter("DEC", SProc, noType, 11);
484 |   enter("INC", SProc, noType, 1);
485 |   enter("SET", Typ, setType, 0);  (*types*)
486 |   enter("BOOLEAN", Typ, boolType, 0);
487 |   enter("BYTE", Typ, byteType, 0);
488 |   enter("CHAR", Typ, charType, 0);
489 |   enter("LONGREAL", Typ, realType, 0);
490 |   enter("REAL", Typ, realType, 0);
491 |   enter("LONGINT", Typ, intType, 0);
492 |   enter("INTEGER", Typ, intType, 0);
493 |   topScope := NIL; OpenScope; topScope.next := system; universe := topScope;
494 | 
495 |   system := NIL;  (* initialize "unsafe" pseudo-module SYSTEM*)
496 |   enter("H", SFunc, intType, 201);     (*functions*)
497 |   enter("COND", SFunc, boolType, 191);
498 |   enter("SIZE", SFunc, intType, 181);
499 |   enter("ADR", SFunc, intType, 171);
500 |   enter("VAL", SFunc, intType, 162);
501 |   enter("REG", SFunc, intType, 151);
502 |   enter("BIT", SFunc, boolType, 142);
503 |   enter("LDREG", SProc, noType, 142);  (*procedures*)
504 |   enter("LDPSR", SProc, noType, 131);
505 |   enter("COPY", SProc, noType, 123);
506 |   enter("PUT", SProc, noType, 112);
507 |   enter("GET", SProc, noType, 102)
508 | END ORB.
509 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # Oberon-retro-compiler
  2 | A modified Oberon compiler which supports the LOOP, EXIT, WITH and multiple RETURN statements, and forward declarations of procedures, as they have existed in the *original* versions of the Oberon and Oberon-2 languages defined around 1990.
  3 | 
  4 | This compiler implements a superset of the Extended Oberon compiler available at http://github.com/andreaspirklbauer/Oberon-extended, which itself adds some Oberon-2 language constructs (such as type-bound procedures) to the Oberon-07 language as defined at http://www.projectoberon.com (Project Oberon 2013).
  5 | 
  6 | This may help when porting *legacy* Oberon systems (e.g., Oberon V4) to Project Oberon 2013. However, we recommend to refactor all legacy code to use Oberon-07 language constructs only.
  7 | 
  8 | In order to invoke the retro compiler, the programmer must mark the source code of the module to be compiled with an arrow (^) immediately after the symbol MODULE:
  9 | 
 10 |     MODULE^ TestLoop;  (*the ^ character after the symbol MODULE enables the retro compiler*)
 11 |       PROCEDURE Go*;
 12 |         VAR i, j: INTEGER;
 13 |       BEGIN i := 0; j := 0;
 14 |         LOOP
 15 |           IF i < 5 THEN j := 0;
 16 |             LOOP
 17 |               IF j < 3 THEN INC(j) ELSE EXIT END
 18 |             END
 19 |           ELSE EXIT
 20 |           END
 21 |         END
 22 |       END Go;
 23 |     END TestLoop.
 24 | 
 25 | **PREREQUISITES**: A current version of Extended Oberon (http://github.com/andreaspirklbauer/Oberon-extended)
 26 | 
 27 | ------------------------------------------------------
 28 | **IMPLEMENTED LANGUAGE CONSTRUCTS**
 29 | 
 30 | **1) LOOP and EXIT statements**
 31 | 
 32 |       LoopStatement = LOOP StatementSequence END.
 33 | 
 34 | Example:
 35 | 
 36 |       LOOP
 37 |         ReadInt(i);
 38 |         IF i < 0 THEN EXIT END;
 39 |         WriteInt(i)
 40 |       END
 41 | 
 42 | **2) WITH statement (Oberon-2 style regional type guard)**
 43 | 
 44 |       WithStatement = WITH Guard DO StatementSequence {"|" Guard DO StatementSequence}
 45 |                       [ELSE StatementSequence] END.
 46 |       Guard = Qualident ":" Qualident.
 47 | 
 48 | Example:
 49 | 
 50 |       WITH t0: Tree DO w := t1.width;
 51 |         | t1: CenterTree DO w := t1.width; h := t1.height
 52 |         | t2: SuperTree DO w := t2.width; h := t2.height; c := t2.subnode
 53 |       ELSE w := 0
 54 |       END
 55 | 
 56 | **3) Multiple RETURN statements in a single procedure**
 57 | 
 58 |       ReturnStatement = RETURN [Expression].
 59 | 
 60 | Example:
 61 | 
 62 |       PROCEDURE P(x): INTEGER;
 63 |       BEGIN
 64 |         IF x = 0 THEN RETURN 10
 65 |         ELSIF x = 1 THEN RETURN 100
 66 |         ELSE RETURN 1000
 67 |         END
 68 |       END P;
 69 | 
 70 | **4) Forward declarations of procedures**
 71 | 
 72 |      ForwardDeclaration = PROCEDURE "^" [Receiver] IdentDef [FormalParameters].
 73 | 
 74 |      DeclarationSequence = [CONST {ConstantDeclaration ";"}]
 75 |        [TYPE {TypeDeclaration ";"}] [VAR {VariableDeclaration ";"} ]
 76 |        {ProcedureDeclaration ";" | ForwardDeclaration ";"].
 77 | 
 78 | Example:
 79 | 
 80 |       PROCEDURE^ P(x: INTEGER);
 81 | 
 82 |       PROCEDURE Q;
 83 |       BEGIN P(1);
 84 |       END Q;
 85 | 
 86 |       PROCEDURE P(x: INTEGER);
 87 |       BEGIN (*...*)
 88 |       END P;
 89 | 
 90 | 
 91 | ------------------------------------------------------
 92 | **DOWNLOADING AND BUILDING THE OBERON RETRO COMPILER**
 93 | 
 94 | Download the Oberon retro compiler from the [**Sources/ExtendedOberon**](Sources/ExtendedOberon) directory of this repository.
 95 | 
 96 | Convert the downloaded files to Oberon format (Oberon uses CR as line endings) using the command [**dos2oberon**](dos2oberon), also available in this repository (example shown for Mac or Linux):
 97 | 
 98 |      for x in *.Mod ; do ./dos2oberon $x $x ; done
 99 | 
100 | Import the files to your Oberon system. If you use an emulator (e.g., **https://github.com/pdewacht/oberon-risc-emu**) to run the Oberon system, click on the *PCLink1.Run* link in the *System.Tool* viewer, copy the files to the emulator directory, and execute the following command on the command shell of your host system:
101 | 
102 |      cd oberon-risc-emu
103 |      for x in *.Mod ; do ./pcreceive.sh $x ; sleep 1 ; done
104 | 
105 | Create the Oberon retro compiler:
106 | 
107 |      ORP.Compile ORS.Mod/s ORB.Mod/s ~
108 |      ORP.Compile ORG.Mod/s ORP.Mod/s ~
109 |      ORP.Compile ORL.Mod/s ORX.Mod/s ORTool.Mod/s ~
110 |      System.Free ORTool ORP ORG ORB ORS ORL ORX ~
111 | 
112 | Compile any programs with LOOP, EXIT, WITH or multiple RETURNs that you may have.
113 | 
114 | ------------------------------------------------------
115 | **DIFFERENCES TO EXTENDED OBERON**
116 | 
117 | **ORS.Mod**
118 | 
119 | ```diff
120 | --- Oberon-extended/Sources/ORS.Mod	2021-10-02 14:35:23.000000000 +0200
121 | +++ Oberon-retro-compiler/Sources/ExtendedOberon/ORS.Mod	2022-01-21 06:26:37.000000000 +0100
122 | @@ -1,4 +1,4 @@
123 | -MODULE ORS; (* NW 19.9.93 / 20.3.2017  Scanner in Oberon-07 / AP 1.10.21 Extended Oberon*)
124 | +MODULE ORS; (* NW 19.9.93 / 20.3.2017  Scanner in Oberon-07 / AP 11.1.22 Extended Oberon with retro elements*)
125 |    IMPORT SYSTEM, Texts, Oberon;
126 |  
127 |  (* Oberon Scanner does lexical analysis. Input is Oberon-Text, output is
128 | @@ -11,7 +11,7 @@
129 |    in ival, if real in rval, and if string in str (and slen) *)
130 |    
131 |    CONST IdLen* = 32;
132 | -    NKW = 35;  (*nof keywords*)
133 | +    NKW = 38;  (*nof keywords*)
134 |      maxExp = 38; stringBufSize = 256;
135 |    
136 |      (*lexical symbols*)
137 | @@ -22,11 +22,12 @@
138 |      char* = 20; int* = 21; real* = 22; false* = 23; true* = 24;
139 |      nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29;
140 |      lbrace* = 30; ident* = 31;
141 | -    if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37;
142 | -    comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44;
143 | -    rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49;
144 | -    to* = 50; by* = 51; semicolon* = 52; bar* = 53; end* = 54;
145 | -    else* = 55; elsif* = 56; until* = 57; return* = 58;
146 | +    if* = 32; while* = 33; repeat* = 34; loop* = 35; exit* = 36;
147 | +    return* = 37; case* = 38; with* = 39; for* = 40;
148 | +    comma* = 41; colon* = 42; becomes* = 43; upto* = 44; rparen* = 45;
149 | +    rbrak* = 46; rbrace* = 47; then* = 48; of* = 49; do* = 50;
150 | +    to* = 51; by* = 52; semicolon* = 53; bar* = 54; end* = 55;
151 | +    else* = 56; elsif* = 57; until* = 58;
152 |      array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64;
153 |      var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69; final* = 70; eot = 71;
154 |  
155 | @@ -290,6 +291,9 @@
156 |    EnterKW(true, "TRUE");
157 |    EnterKW(type, "TYPE");
158 |    EnterKW(case, "CASE");
159 | +  EnterKW(loop, "LOOP");
160 | +  EnterKW(exit, "EXIT");
161 | +  EnterKW(with, "WITH");
162 |    KWX[4] := k;
163 |    EnterKW(elsif, "ELSIF");
164 |    EnterKW(false, "FALSE");
165 | ```
166 | 
167 | **ORB.Mod**
168 | 
169 | ```diff
170 | --- Oberon-extended/Sources/ORB.Mod	2022-06-19 08:47:26.000000000 +0200
171 | +++ Oberon-retro-compiler/Sources/ExtendedOberon/ORB.Mod	2022-06-20 09:36:50.000000000 +0200
172 | @@ -1,4 +1,4 @@
173 | -MODULE ORB;   (*NW 25.6.2014  / AP 4.3.2020 / 5.3.2019  in Oberon-07 / AP 19.6.22 Extended Oberon*)
174 | +MODULE ORB;   (*NW 25.6.2014  / AP 4.3.2020 / 5.3.2019  in Oberon-07 / AP 19.6.22 Extended Oberon with retro elements*)
175 |    IMPORT Files, ORS;
176 |    (*Definition of data types Object and Type, which together form the data structure
177 |      called "symbol table". Contains procedures for creation of Objects, and for search:
178 | @@ -80,6 +80,13 @@
179 |      END
180 |    END NewObj;
181 |  
182 | +  PROCEDURE FindObj*(id: ORS.Ident; list: Object): Object;  (*search id in list*)
183 | +    VAR x: Object;
184 | +  BEGIN x := list;
185 | +    WHILE (x # NIL) & ((x.name # id) OR (x.class = Mod) & ~x.rdo) DO x := x.next END ;
186 | +    RETURN x
187 | +  END FindObj;
188 | +
189 |    PROCEDURE thisObj*(): Object;
190 |      VAR s, x: Object;
191 |    BEGIN s := topScope;
192 | ```
193 | 
194 | **ORG.Mod**
195 | 
196 | ```diff
197 | --- Oberon-extended/Sources/ORG.Mod	2022-06-12 10:50:57.000000000 +0200
198 | +++ Oberon-retro-compiler/Sources/ExtendedOberon/ORG.Mod	2022-06-20 09:46:07.000000000 +0200
199 | @@ -1,4 +1,4 @@
200 | -MODULE ORG; (* N.Wirth, 16.4.2016 / 4.4.2017 / 31.5.2019  Oberon compiler; code generator for RISC / AP 12.6.22 Extended Oberon*)
201 | +MODULE ORG; (* N.Wirth, 16.4.2016 / 4.4.2017 / 31.5.2019  Oberon compiler; code generator for RISC / AP 19.6.22 Extended Oberon with retro elements*)
202 |    IMPORT SYSTEM, Files, ORS, ORB;
203 |    (*Code generator for Oberon compiler for RISC processor.
204 |       Procedural interface to Parser ORP; result in array "code".
205 | @@ -160,10 +160,6 @@
206 |      code[at] := code[at] DIV C24 * C24 + with MOD C24
207 |    END fix3;
208 |  
209 | -  PROCEDURE FixOne*(at: LONGINT);
210 | -  BEGIN fix3(at, pc-at-1)
211 | -  END FixOne;
212 | -
213 |    PROCEDURE FixLinkWith(L, dst: LONGINT);
214 |      VAR L1: LONGINT;
215 |    BEGIN (*fix chain of branch instructions*)
216 | @@ -174,6 +170,16 @@
217 |    BEGIN FixLinkWith(L, pc)
218 |    END FixLink;
219 |  
220 | +  PROCEDURE FixLinkMixed*(L: LONGINT);
221 | +    VAR L1, format: LONGINT; p: INTEGER;
222 | +  BEGIN (*fix chain of instructions of different formats*)
223 | +    WHILE L # 0 DO p := code[L];
224 | +      format := p DIV C30 MOD 4; L1 := p MOD C16;
225 | +      IF format < 3 THEN fix1(L, (pc-L)*4) ELSE fix3(L, pc-L-1) END ;
226 | +      L := L1
227 | +    END
228 | +  END FixLinkMixed;
229 | +
230 |    PROCEDURE FixLinkPair(L, adr: LONGINT);
231 |      VAR L1: LONGINT; p, q: INTEGER;
232 |    BEGIN (*fix chain of instruction pairs with an address that is spread across both instructions, 0 <= adr < C24*)
233 | @@ -204,7 +210,8 @@
234 |        IF x.type.size = 1 THEN op := Ldr+1 ELSE op := Ldr END ;
235 |        IF x.mode = ORB.Const THEN
236 |          IF x.type.form = ORB.Proc THEN
237 |            IF x.r > 0 THEN (*local*) ORS.Mark("not allowed")
238 | +          ELSIF x.a < 0 THEN (*forward*) Put3(BL, 7, 0); Put1(Add, RH, LNK, x.type.len); x.type.len := pc-1  (*fixed up in ORP.Body*)
239 |            ELSIF x.r = 0 THEN (*global*) Put3(BL, 7, 0); Put1a(Sub, RH, LNK, pc*4 - x.a)
240 |            ELSE (*imported*) PutPair(x.r, Add, RH, RH, x.a + C8, 1) (*mark as progbase-relative*)
241 |            END
242 | @@ -848,7 +855,8 @@
243 |          Put2(Ldr, RH, RH, -4-x.a*4); Put3(BLR, 7, RH)
244 |        END
245 |      ELSIF x.mode = ORB.Const THEN  (*regular procedure*)
246 | -      IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1)
247 | +      IF x.a < 0 THEN (*forward*) Put3(BL, 7, x.type.len); x.type.len := pc-1  (*fixed up in ORP.Body*)
248 | +      ELSIF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1)
249 |        ELSE (*imported*) Put3a(BL, -x.r, x.a, pc-fixorgP); fixorgP := pc-1
250 |        END
251 |      ELSE  (*installed procedure*)
252 | ```
253 | 
254 | **ORP.Mod**
255 | 
256 | ```diff
257 | --- Oberon-extended/Sources/ORP.Mod	2022-06-16 10:27:36.000000000 +0200
258 | +++ Oberon-retro-compiler/Sources/ExtendedOberon/ORP.Mod	2022-06-20 09:36:51.000000000 +0200
259 | @@ -1,4 +1,4 @@
260 | -MODULE ORP; (*N. Wirth 1.7.97 / 8.3.2020  Oberon compiler for RISC in Oberon-07 / AP 15.6.22 Extended Oberon*)
261 | +MODULE ORP; (*N. Wirth 1.7.97 / 8.3.2020  Oberon compiler for RISC in Oberon-07 / AP 19.6.22 Extended Oberon with retro elements*)
262 |    IMPORT Texts, Oberon, ORS, ORB, ORG;
263 |    (*Author: Niklaus Wirth, 2014. Oberon-2 extensions by Andreas Pirklbauer, 2020.
264 |      Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens),
265 | @@ -6,7 +6,7 @@
266 |      ORG to produce binary code. ORP performs type checking and data allocation.
267 |      Parser is target-independent, except for part of the handling of allocations.*)
268 |  
269 | -  CONST NofCases = 256; C20 = 100000H;
270 | +  CONST NofCases = 256; maxExit = 16; C20 = 100000H;
271 |  
272 |    TYPE PtrBase = POINTER TO PtrBaseDesc;
273 |      PtrBaseDesc = RECORD  (*list of names of pointer base types*)
274 | @@ -14,15 +14,16 @@
275 |      END ;
276 |    
277 |    VAR sym: INTEGER;   (*last symbol read*)
278 | -    dc: LONGINT;    (*data counter*)
279 | -    level, exno, version: INTEGER;
280 | -    newSF: BOOLEAN;  (*option flag*)
281 | +    dc, fc: LONGINT;    (*data counter, forward counter*)
282 | +    level, exno, version, looplev, exitno: INTEGER;
283 | +    newSF, retro, return: BOOLEAN;  (*option, retro and return flags*)
284 |      expression: PROCEDURE (VAR x: ORG.Item);  (*to avoid forward reference*)
285 |      Type: PROCEDURE (VAR type: ORB.Type; expo: BOOLEAN);
286 |      FormalType: PROCEDURE (VAR typ: ORB.Type; dim: INTEGER);
287 |      modid: ORS.Ident;
288 |      pbsList: PtrBase;   (*list of names of pointer base types*)
289 |      dummy: ORB.Object;
290 | +    exit: ARRAY maxExit OF INTEGER;
291 |      W: Texts.Writer;
292 |  
293 |    PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR);
294 | @@ -82,11 +83,17 @@
295 |      IF x.rdo THEN ORS.Mark("read-only") END
296 |    END CheckReadOnly;
297 |  
298 | +  PROCEDURE CheckRetro;
299 | +  BEGIN
300 | +    IF ~retro THEN ORS.Mark("add ^ after MODULE") END
301 | +  END CheckRetro;
302 | +
303 |    PROCEDURE CheckExport(VAR expo: BOOLEAN);
304 |    BEGIN
305 | -    IF sym = ORS.times THEN
306 | +    IF (sym = ORS.times) OR (sym = ORS.minus) THEN
307 |        expo := TRUE; ORS.Get(sym);
308 | -      IF level # 0 THEN ORS.Mark("remove asterisk") END
309 | +      IF level # 0 THEN ORS.Mark("remove export mark") END ;
310 | +      IF sym = ORS.minus THEN CheckRetro END
311 |      ELSE expo := FALSE
312 |      END
313 |    END CheckExport;
314 | @@ -541,6 +548,32 @@
315 |        ORG.FixLink(L0)
316 |      END TypeCasePart;
317 |  
318 | +    PROCEDURE With(VAR L0: LONGINT);
319 | +      VAR obj, typobj: ORB.Object; x: ORG.Item;
320 | +        orgtype: ORB.Type;  (*original type of with var*)
321 | +    BEGIN qualident(obj);
322 | +      IF ((obj.type.form = ORB.Pointer) & (obj.class = ORB.Var) & (obj.type.base.form = ORB.Record) OR
323 | +          (obj.type.form = ORB.Record) & (obj.class = ORB.Par)) & (obj.lev > 0) THEN
324 | +        Check(ORS.colon, ": expected");
325 | +        qualident(typobj); ORG.MakeItem(x, obj); orgtype := obj.type;
326 | +        IF typobj.class # ORB.Typ THEN ORS.Mark("not a type") END ;
327 | +        TypeTest(x, typobj.type, FALSE); obj.type := typobj.type;
328 | +        ORG.CFJump(x); Check(ORS.do, "no DO"); StatSequence;
329 | +        ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype
330 | +      ELSE ORS.Mark("invalid with variable"); Check(ORS.colon, ": expected"); Check(ORS.do, "no DO"); StatSequence
331 | +      END
332 | +    END With;
333 | +
334 | +    PROCEDURE WithPart;
335 | +      VAR L0: LONGINT;
336 | +    BEGIN L0 := 0; With(L0);
337 | +      WHILE sym <= ORS.bar DO
338 | +        IF sym = ORS.bar THEN ORS.Get(sym) ELSE With(L0) END
339 | +      END ;
340 | +      IF sym = ORS.else THEN ORS.Get(sym); StatSequence END ;
341 | +      ORG.FixLink(L0)
342 | +    END WithPart;
343 | +
344 |      PROCEDURE CaseLabel(VAR x: ORG.Item);
345 |      BEGIN expression(x); CheckConst(x);
346 |        IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x)
347 | @@ -596,7 +629,7 @@
348 |      END SkipCase;
349 |  
350 |    BEGIN (* StatSequence *)
351 | -    REPEAT (*sync*)
352 | +    REPEAT (*sync*) return := FALSE;
353 |        IF ~((sym >= ORS.ident) & (sym <= ORS.for) OR (sym >= ORS.semicolon)) THEN
354 |          ORS.Mark("statement expected");
355 |          REPEAT ORS.Get(sym) UNTIL sym >= ORS.ident
356 | @@ -660,6 +693,28 @@
357 |            ORS.Get(sym); expression(x); CheckBool(x); ORG.CBJump(x, L0)
358 |          ELSE ORS.Mark("missing UNTIL")
359 |          END
360 | +      ELSIF sym = ORS.loop THEN
361 | +        ORS.Get(sym); CheckRetro; rx := exitno; INC(looplev);
362 | +        L0 := ORG.Here(); StatSequence; ORG.BJump(L0); DEC(looplev);
363 | +        WHILE exitno > rx DO DEC(exitno); ORG.FixLink(exit[exitno]) END ;
364 | +        Check(ORS.end, "no END")
365 | +      ELSIF sym = ORS.exit THEN
366 | +        ORS.Get(sym); CheckRetro; L0 := 0; ORG.FJump(L0);
367 | +        IF looplev = 0 THEN ORS.Mark("exit not allowed")
368 | +        ELSIF exitno < maxExit THEN exit[exitno] := L0; INC(exitno)
369 | +        ELSE ORS.Mark("too many exits")
370 | +        END
371 | +      ELSIF sym = ORS.return THEN
372 | +        ORS.Get(sym);
373 | +        IF level # 0 THEN return := TRUE;
374 | +          obj := ORB.topScope; INC(obj.lev);
375 | +          IF obj.type.base.form # ORB.NoTyp THEN expression(x);
376 | +            IF ~CompTypes(obj.type.base, x.type, FALSE) THEN ORS.Mark("wrong result type") END
377 | +          ELSE x.type := ORB.noType
378 | +          END ;
379 | +          ORG.Return(obj.type.base.form, x, obj.val, obj.expo)
380 | +        ELSE ORS.Mark("return not allowed")
381 | +        END
382 |        ELSIF sym = ORS.for THEN
383 |          ORS.Get(sym);
384 |          IF sym = ORS.ident THEN
385 | @@ -686,6 +741,8 @@
386 |          ELSE ORS.Mark("invalid case variable"); SkipCase
387 |          END ;
388 |          Check(ORS.end, "no END")
389 | +      ELSIF sym = ORS.with THEN
390 | +        ORS.Get(sym); WithPart; Check(ORS.end, "no END")
391 |        END ;
392 |        ORG.CheckRegs;
393 |        IF sym = ORS.semicolon THEN ORS.Get(sym)
394 | @@ -894,8 +951,8 @@
395 |        x: ORG.Item; tp: ORB.Type; ptbase: PtrBase;
396 |        expo: BOOLEAN; id: ORS.Ident;
397 |    BEGIN (*sync*) pbsList := NIL;
398 | -    IF (sym < ORS.const) & (sym # ORS.end) & (sym # ORS.return) THEN ORS.Mark("declaration?");
399 | -      REPEAT ORS.Get(sym) UNTIL (sym >= ORS.const) OR (sym = ORS.end) OR (sym = ORS.return)
400 | +    IF (sym < ORS.const) & (sym # ORS.end) THEN ORS.Mark("declaration?");
401 | +      REPEAT ORS.Get(sym) UNTIL (sym >= ORS.const) OR (sym = ORS.end)
402 |      END ;
403 |      IF sym = ORS.const THEN
404 |        ORS.Get(sym);
405 | @@ -985,28 +1042,24 @@
406 |      VAR proc, redef, obj: ORB.Object;
407 |        type, typ, rec: ORB.Type;
408 |        procid, recid: ORS.Ident;
409 | -      parblksize: LONGINT; class: INTEGER;
410 | -      int, expo: BOOLEAN;
411 | +      parblksize: LONGINT; form, class: INTEGER;
412 | +      int, body, expo: BOOLEAN;
413 |  
414 |      PROCEDURE Body(proc: ORB.Object; parblksize: LONGINT; int: BOOLEAN);
415 | -      VAR x: ORG.Item; locblksize, L: LONGINT;
416 | +      VAR obj: ORB.Object; x: ORG.Item; locblksize: LONGINT;
417 |      BEGIN Check(ORS.semicolon, "no ;"); locblksize := parblksize;
418 | -      Declarations(locblksize);
419 | -      proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next;
420 | -      IF sym = ORS.procedure THEN
421 | -        L := 0; ORG.FJump(L);
422 | -        REPEAT ProcedureDecl; Check(ORS.semicolon, "no ;") UNTIL sym # ORS.procedure;
423 | -        ORG.FixOne(L); proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next
424 | -      END ;
425 | +      Declarations(locblksize); obj := ORB.topScope; proc.type.dsc := obj.next;
426 | +      obj.type := proc.type; obj.val := locblksize; obj.lev := 0; obj.expo := int;  (*for RETURN statements*)
427 | +      WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ;
428 | +      ORG.FixLinkMixed(proc.type.len);  (*fix forward references generated in ORG*)
429 | +      proc.val := ORG.Here() * 4; proc.type.dsc := obj.next; DEC(fc);
430 |        ORG.Enter(parblksize, locblksize, int);
431 |        IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ;
432 | -      IF sym = ORS.return THEN
433 | -        ORS.Get(sym); expression(x);
434 | -        IF proc.type.base = ORB.noType THEN ORS.Mark("this is not a function")
435 | -        ELSIF ~CompTypes(proc.type.base, x.type, FALSE) THEN ORS.Mark("wrong result type")
436 | +      IF proc.type.base.form # ORB.NoTyp THEN  (*function procedure*)
437 | +        IF obj.lev = 0 THEN ORS.Mark("function without result")
438 | +        ELSIF ~return OR (obj.lev # 1) THEN CheckRetro
439 |          END
440 | -      ELSIF proc.type.base.form # ORB.NoTyp THEN
441 | -        ORS.Mark("function without result"); proc.type.base := ORB.noType
442 | +      ELSIF obj.lev > 0 THEN CheckRetro
443 |        END ;
444 |        ORG.Return(proc.type.base.form, x, locblksize, int); Check(ORS.end, "no END");
445 |        IF sym = ORS.ident THEN
446 | @@ -1016,30 +1069,43 @@
447 |        END
448 |      END Body;
449 |  
450 | -  BEGIN (* ProcedureDecl *) int := FALSE; rec := NIL; ORS.Get(sym);
451 | -    IF sym = ORS.times THEN ORS.Get(sym); int := TRUE END ;
452 | +  BEGIN (* ProcedureDecl *) int := FALSE; body := TRUE; rec := NIL; ORS.Get(sym);
453 | +    IF sym = ORS.times THEN (*interrupt*) ORS.Get(sym); int := TRUE
454 | +    ELSIF sym = ORS.arrow THEN (*forward*) ORS.Get(sym); body := FALSE
455 | +    END ;
456 |      IF sym = ORS.lparen THEN
457 | -      ORS.Get(sym); Receiver(class, recid, typ, rec);
458 | +      ORS.Get(sym); Receiver(class, recid, typ, rec); form := ORB.TProc;
459 |        IF level # 0 THEN ORS.Mark("local type-bound procedures not implemented") END
460 | +    ELSE form := ORB.Proc
461 |      END ;
462 |      IF sym = ORS.ident THEN
463 |        ORS.CopyId(procid); ORS.Get(sym); CheckExport(expo);
464 |        IF int THEN parblksize := 12 ELSE parblksize := 4 END ;
465 | -      NEW(type); type.size := ORG.WordSize;
466 | +      NEW(type); type.size := ORG.WordSize; type.len := 0; (*len used as heading of fixup chain of forward refs*)
467 |        IF rec = NIL THEN  (*regular procedure*)
468 | -        ORB.NewObj(proc, procid, ORB.Const);
469 | -        type.form := ORB.Proc; proc.type := type; proc.val := -1; proc.lev := level; proc.expo := expo;
470 | -        IF expo THEN proc.exno := exno; INC(exno) END ;
471 | +        proc := ORB.FindObj(procid, ORB.topScope.next);
472 | +        IF proc = NIL THEN  (*identifier not found in the symbol table*)
473 | +          ORB.NewObj(proc, procid, ORB.Const); INC(fc);
474 | +          type.form := ORB.Proc; proc.type := type; proc.val := -1; proc.lev := level; proc.expo := expo;
475 | +          IF expo THEN proc.exno := exno; INC(exno) END
476 | +        END ;
477 |          ORB.OpenScope; INC(level); type.base := ORB.noType;
478 |          ProcedureType(type, parblksize); type.dsc := ORB.topScope.next  (*formal parameter list*)
479 |        ELSE  (*type-bound procedure*)
480 | -        ORB.NewMethod(rec, proc, redef, procid);
481 | -        IF rec.typobj.val > 0 THEN ORS.Mark("invalid method order") ELSE DisallowMethods(rec.base) END ;
482 | -        type.form := ORB.TProc; proc.type := type; proc.val := -1; proc.expo := expo;
483 | -        IF expo THEN proc.exno := exno; INC(exno);
484 | -          IF ~typ.typobj.expo THEN ORS.Mark("receiver must be exported") END ;
485 | -          procid := "@"; ORB.NewObj(obj, procid, ORB.Const); obj.name[0] := 0X; (*dummy to preserve linear order of exno*)
486 | -          obj.type := proc.type; obj.dsc := proc; obj.exno := proc.exno; obj.expo := FALSE
487 | +        IF rec.base # NIL THEN redef := ORB.FindObj(procid, rec.base.dsc);  (*search in base types of receiver*)
488 | +          IF (redef # NIL) & ((redef.class # ORB.Const) OR (redef.type.form # ORB.TProc)) THEN ORS.Mark("mult def") END
489 | +        ELSE redef := NIL
490 | +        END ;
491 | +        proc := ORB.FindFld(procid, rec);  (*search in fields of receiver proper, but not of its base types*)
492 | +        IF proc = NIL THEN
493 | +          ORB.NewMethod(rec, proc, redef, procid); INC(fc);
494 | +          IF rec.typobj.val > 0 THEN ORS.Mark("invalid method order") ELSE DisallowMethods(rec.base) END ;
495 | +          type.form := ORB.TProc; proc.type := type; proc.val := -1; proc.expo := expo;
496 | +          IF expo THEN proc.exno := exno; INC(exno);
497 | +            IF ~typ.typobj.expo THEN ORS.Mark("receiver must be exported") END ;
498 | +            procid := "@"; ORB.NewObj(obj, procid, ORB.Const); obj.name[0] := 0X; (*dummy to preserve linear order of exno*)
499 | +            obj.type := proc.type; obj.dsc := proc; obj.exno := proc.exno; obj.expo := FALSE
500 | +          END
501 |          END ;
502 |          ORB.OpenScope; INC(level); type.base := ORB.noType;
503 |          ORB.NewObj(obj, recid, class);  (*insert receiver as first parameter*)
504 | @@ -1052,7 +1118,13 @@
505 |            END
506 |          END
507 |        END ;
508 | -      Body(proc, parblksize, int); ORB.CloseScope; DEC(level)
509 | +      IF proc.type # type THEN  (*identifier found in the symbol table*)
510 | +        IF (proc.class # ORB.Const) OR (proc.type.form # form) OR (proc.val >= 0) OR ~body THEN ORS.Mark("mult def")
511 | +        ELSIF (proc.expo # expo) OR ~EqualSignatures(proc.type, type) THEN ORS.Mark("must match forward declaration")
512 | +        END
513 | +      END ;
514 | +      IF body THEN Body(proc, parblksize, int) END ;
515 | +      ORB.CloseScope; DEC(level)
516 |      ELSE ORS.Mark("proc id expected")
517 |      END
518 |    END ProcedureDecl;
519 | @@ -1080,18 +1152,22 @@
520 |      VAR key: LONGINT;
521 |    BEGIN Texts.WriteString(W, "  compiling "); ORS.Get(sym);
522 |      IF sym = ORS.module THEN
523 | -      ORS.Get(sym);
524 | -      IF sym = ORS.times THEN version := 0; dc := 8; Texts.Write(W, "*"); ORS.Get(sym) ELSE dc := 0; version := 1 END ;
525 | +      ORS.Get(sym); retro := FALSE;
526 | +      IF sym = ORS.times THEN version := 0; dc := 8; Texts.Write(W, "*"); ORS.Get(sym)
527 | +      ELSE dc := 0; version := 1;
528 | +        IF sym = ORS.arrow THEN retro := TRUE; Texts.Write(W, "^"); ORS.Get(sym) END
529 | +      END ;
530 |        ORB.Init; ORB.OpenScope;
531 |        IF sym = ORS.ident THEN
532 |          ORS.CopyId(modid); ORS.Get(sym);
533 |          Texts.WriteString(W, modid); Texts.Append(Oberon.Log, W.buf)
534 |        ELSE ORS.Mark("identifier expected")
535 |        END ;
536 | -      Check(ORS.semicolon, "no ;"); level := 0; exno := 1; key := 0;
537 | +      Check(ORS.semicolon, "no ;"); level := 0; fc := 0; exno := 1; key := 0; looplev := 0; exitno := 0;
538 |        IF sym = ORS.import THEN ImportList; Check(ORS.semicolon, "; missing") END ;
539 |        ORG.Open(version); Declarations(dc); ORG.SetDataSize((dc + 3) DIV 4 * 4);
540 |        WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ;
541 | +      IF fc > 0 THEN ORS.Mark("undefined forward declarations") END ;
542 |        ORG.Header;
543 |        IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ;
544 |        ORG.Exit;
545 | @@ -1158,7 +1234,7 @@
546 |      Oberon.Collect(0); Oberon.Return(res)
547 |    END Compile;
548 |  
549 | -BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler  8.3.2020 / AP 15.6.22");
550 | +BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Retro Compiler  8.3.2020 / AP 19.6.22");
551 |    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
552 |    NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType;
553 |    expression := expression0; Type := Type0; FormalType := FormalType0
554 | ```
555 | 
556 | ------------------------------------------------------
557 | **IMPLEMENTATION NOTES**
558 | 
559 | **LOOP and EXIT statements**
560 | 
561 | * An EXIT statement is implemented as a *forward jump* to the end of the LOOP statement that contains it. Thus, a *fixup* is required to insert the branch destination once it is known. Note that LOOP statements can be nested.
562 | 
563 | * However, when compiling the statement sequence of the LOOP statement using procedure *ORP.StatSequence*, one cannot use a *local* variable to hold the code locations of EXIT statements that require *fixups* (as is usually done).
564 | 
565 | * This is because the compiler may (recursively) enter *ORP.StatSequence* again before it reaches any EXIT statement belonging to the corresponding LOOP statement.
566 | 
567 | * Example:
568 | 
569 |       LOOP
570 |         ..
571 |         EXIT;  (*exitno = 0*)
572 |         ..
573 |         IF cond1 THEN (*new StatSequence entered here*) EXIT END ; (*exitno = 1*)
574 |         ..
575 |         IF cond2 THEN (*new StatSequence entered here*) EXIT END ; (*exitno = 2*)
576 |         ..
577 |         LOOP
578 |           ..
579 |           EXIT;   (*exitno = 3*)
580 |           ..
581 |           IF cond3 THEN (*new StatSequence entered here*) EXIT END ; (*exitno = 4*)
582 |           ..
583 |           IF cond4 THEN (*new StatSequence entered here*) EXIT END ; (*exitno = 5*)
584 |           ..
585 |         END ;
586 |         ..
587 |         EXIT;  (*exitno = 3*)
588 |          ..
589 |          IF cond5 THEN (*new StatSequence entered here*) EXIT END  (*exitno = 4*)
590 |       END
591 | 
592 | * This can be addressed by using a *global* table to hold the locations of the EXIT statements that require fixups, while keeping track of the stack of nested LOOP statements in the process.
593 | 
594 |   * When *entering* a LOOP statement, one remembers the *location* of the *next* EXIT statement that is to be processed. In the above example, when entering the inner LOOP statement, that location is exitno = 3.
595 | 
596 |   * When *exiting* a LOOP statement, one "fixes up" all exits statements from that location onward, i.e. only the EXIT statements of the LOOP itself. In the above example, when exiting the inner LOOP statement, only the EXIT instructions 3, 4, 5 are fixed up.
597 | 
598 | **Multiple return statements**
599 | 
600 | * Since *multiple* RETURN statements in a *single* procedure are now allowed in the language, the code generating procedure *ORG.Return* can no longer be called by the parser procedure that processes procedure declarations (*ORP.ProcedureDecl*), but must be called from the procedure handling statement *sequences* (*ORP.StatSequence*).
601 | 
602 | * There are three pieces of information required to call *ORG.Return*:
603 | 
604 |   * the procedure object in the symbol table (*proc*)
605 |   * the size of the local variables (*locblksize*)
606 |   * whether a procedure is an interrupt procedure or not (*int*).
607 | 
608 | * In our implementation, this information is made available as follows:
609 | 
610 |   * *ORB.topScope.type* is "abused" to point to the procedure's type object (*proc.type*).
611 | 
612 |   * *ORB.topScope.val* is "abused" to hold the size of the procedure's local variable (*locblksize*).
613 | 
614 |   * *ORB.topScope.expo* is "abused" to remember whether *proc* is an interrupt procedure (*int*).
615 | 
616 |   * In addition, *ORB.topScope.lev* is "abused" to count the number of RETURN statements in procedure (there hast to be at least one RETURN statement in a procedure).
617 | 
618 | * This works because each procedure object in the symbol table has its *own* type object (i.e. there is no sharing of *type* objects among procedures) and also because the "abused" fields of *ORB.topScope* are not otherwise used in the compiler.
619 | 
620 | **Forward declarations of procedures**
621 | 
622 | We implement forward *declarations* of procedures as described below:
623 | 
624 | Note that in our implementation both global *and* local procedures can be declared forward.
625 | 
626 | **1. Processing of the procedure heading of a forward-declared procedure P (ORP.ProcedureDecl)**:
627 | 
628 | When this *heading* of a forward-declared procedure P, i.e. the heading
629 | 
630 |       PROCEDURE^ P(x: INTEGER);
631 | 
632 | is processed, the field *obj.type.len* is set to 0 to indicate that no forward reference to P has been generated yet, and *obj.val* is set to -1 to indicate that the body of P has not been compiled yet. See *ORP.ProcedureDecl*:
633 | 
634 |         proc.val := -1;       (*<0: body of P has not been compiled yet; otherwise: entry address of P*)
635 | 
636 | The field *proc.type.len* is used as the heading of the fixup list for forward references to P (initially set to 0). This is acceptable, because every procedure object *obj* (of type *ORB.Object*) has its **own** type object *obj.type* (of type *ORB.Type*) and its field *obj.type.len* is not used otherwise.
637 | 
638 | The field *obj.type.len* is available during code generation as the field *x.type.len* in source level items generated from the procedure object *obj* using procedure *ORG.MakeItem*, while the field *obj.val* is available as the field *x.a*.
639 | 
640 | **2. Assigning P to a procedure variable, passing P as a procedure parameter, returning P as a result of a function procedure (ORG.load)**:
641 | 
642 | If a procedure P, whose body has not been compiled yet, is assigned to a procedure variable, passed as parameter to a procedure or returned as the result of a function procedure, a *forward reference* in the form of a *register* instruction is generated that will eventually contain an instruction operand.
643 | 
644 | This adds a single line to *ORG.load*:
645 | 
646 |        IF x.a < 0 THEN (*forward*) Put3(BL, 7, 0); Put1(Add, RH, LNK, x.type.len); x.type.len := pc-1    (*fixed up in ORP.Body*)
647 | 
648 | The purpose of the first instruction generated (branch zero step forward) is to merely deposit the link address PC+1 in register LNK ("LNK := PC+1"). To this address, we then add the code distance to procedure P (determined later during the fixup step in ORP.Body).
649 | 
650 | Here we use PC-relative addressing, so that we can fix up this instruction at *compile* time rather than only at module *load* time.
651 | 
652 | **3. Calling a forward-declared procedure P (ORG.Call)**:
653 | 
654 | If a procedure P, whose body has not been compiled yet, is *called*, a forward reference in the form of a *branch* instruction is generated that will eventually contain the branch displacement.
655 | 
656 | This adds a single line to *ORG.Call*:.
657 | 
658 |        IF x.a < 0 THEN (*forward*) Put3(BL, 7, x.type.len); x.type.len := pc-1  (*fixed up in ORP.Body*)
659 | 
660 | **4. Compilation of the procedure body of a forward-declared procedure P (ORP.Body)**:
661 | 
662 | When the procedure *body* of P is *compiled*, all forward references to P are *fixed up* with the now known actual entry address of P, and the field *obj.val* is changed to that address.
663 | 
664 |    This changes *ORP.Body* from:
665 | 
666 |         proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next;
667 |         IF sym = ORS.procedure THEN
668 |           L := 0; ORG.FJump(L);
669 |           REPEAT ProcedureDecl; Check(ORS.semicolon, "no ;") UNTIL sym # ORS.procedure;
670 |           ORG.FixOne(L); proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next
671 |         END ;
672 | 
673 |    to:
674 | 
675 |         proc.type.dsc := ORB.topScope.next;
676 |         WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ;
677 |         ORG.FixLinkMixed(proc.type.len);  (*fix forward references generated in ORG.load and ORG.Call*)
678 |         proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next; DEC(fc);
679 | 
680 | As one can see, the forward jump at the beginning of P is no longer generated (no calls to *ORG.FJump* anymore).
681 | 
682 | The second assignment *proc.type.dsc := ORB.topScope.next* is necessary to cover the case, where *proc.type.dsc* has been NIL before local procedures have been processed (in this case, a new object for the local procedure will be added).
683 | 
684 | Note that procedure *ORG.FixLink* of the Project Oberon 2013 compiler assumes that the instructions to be fixed up are format-3 *branch* instructions. But in our implementation we also generate format-1 *register* instructions (in *ORG.load*, see above).
685 | 
686 | We could have decided to just generalize *ORG.FixLink* to also handle the format-1 ADD instruction generated in *ORG.load*.
687 | 
688 | However, we have opted to add a *separate* procedure *ORG.FixLinkMixed* that can handle both format-1 and format-3 instructions embedded in the *same* fixup list.
689 | 
690 | This has the advantage, that the (more complex) code in *ORG.FixLinkMixed* is only called when compiling procedure bodies, and not in all cases where format-3 branch instructions are to be fixed up. This choice also nicely isolates the addition of this feature, which, after all, exists only in the retro compiler, and only to implement forward declarations of procedures.
691 | 
692 |         PROCEDURE fix1(at, with: LONGINT);
693 |           VAR v: LONGINT;
694 |         BEGIN (*fix format-1 register instruction*)
695 |            IF with < 0 THEN v := C28 (*set v bit*) ELSE v := 0 END ;
696 |            code[at] := code[at] DIV C16 * C16 + with MOD C16 + v
697 |         END fix1;
698 | 
699 |         PROCEDURE FixLinkMixed*(L: LONGINT);
700 |           VAR L1, format: LONGINT; p: INTEGER;
701 |         BEGIN (*fix chain of instructions of different formats*)
702 |           WHILE L # 0 DO p := code[L];
703 |             format := p DIV C30 MOD 4; L1 := p MOD C16;
704 |             IF format < 3 THEN fix1(L, (pc-L)*4) ELSE fix(L, pc-L-1) END ;
705 |             L := L1
706 |           END
707 |         END FixLinkMixed;
708 | 
709 | Note that it is *essential* that the origin of the fixup list for a procedure P is **not** rooted in a variable *L* local to the parsing procedure *ProcedureDecl* (as is typical in other parsing procedures), because forward references may be generated from *other* procedures in
710 | 
711 | * the surrounding scope,
712 | * the same scope, or
713 | * from within a nested scope (as in the example above).
714 | 
715 | However, the fixup list must be associated with P at all times. A field in the symbol table entry (such as *obj.type.len*) for P is therefore ideally suited for this purpose.
716 | 
717 | **5. Compilations of calls to P after the procedure body of P has been compiled**:
718 | 
719 | Any references to P later in the source text are *backward* references using the actual entry address of P, and no fixups are needed for such calls.
720 | 
721 | **6. More efficient forward references for nested procedures come**:
722 | 
723 | The implementation of forward declarations of procedures, as described above, automatically makes forward *references* for nested procedures more efficient, since only *forward* calls are generated from within a procedure body of a nested procedure.
724 | 
725 | If a procedure Q which is local to procedure P refers to the enclosing procedure P, as in
726 | 
727 |      PROCEDURE P;
728 |        PROCEDURE Q;
729 |        BEGIN (*body of Q*) P  (*forward reference from Q to P, as the body of P is not compiled yet*)
730 |        END Q;
731 |      BEGIN (*body of P*)
732 |      END P;
733 | 
734 | then the official Oberon-07 compiler, as published on www.projectoberon.com, generates the following code:
735 | 
736 |      20  P'   BL  10         ; forward branch to line 31 (the body of P)
737 |      21  Q    body of Q
738 |               ...
739 |               ...            ; any calls from Q to P are BACKWARD jumps to line 20 and from there forward to line 31
740 |               ...
741 |      31  P    body of P
742 | 
743 | whereas the modified compiler provided in **this** repository generates the following, more efficient, code:
744 | 
745 |      20  Q   body of Q
746 |              ...
747 |              ...             ; any calls from Q to P are FORWARD jumps to line 30, fixed up when the body of P is compiled
748 |              ...
749 |      30  P   body of P
750 | 
751 | i.e. it does **not** generate an extra forward jump in line 20 around Q to the body of P and backward jumps from Q to line 20. In Project Oberon 2013, the extra BL instruction in line 20 exists, so that Q can call P (Q is compiled before P).
752 | 


--------------------------------------------------------------------------------
/Sources/ExtendedOberon/ORG.Mod:
--------------------------------------------------------------------------------
   1 | MODULE ORG; (* N.Wirth, 16.4.2016 / 4.4.2017 / 31.5.2019  Oberon compiler; code generator for RISC / AP 1.1.25 Extended Oberon*)
   2 |   IMPORT SYSTEM, Files, ORS, ORB;
   3 |   (*Code generator for Oberon compiler for RISC processor.
   4 |      Procedural interface to Parser ORP; result in array "code".
   5 |      Procedure Close writes code-files*)
   6 | 
   7 |   CONST WordSize* = 4;
   8 |     StkOrg0 = -64; VarOrg0 = 0;  (*for RISC-0 only*)
   9 |     TR = 13; SP = 14; LNK = 15;  (*dedicated registers*)
  10 |     maxCode = 9000; maxStrx = 3500; maxTD = 160; maxSet = WordSize*8;
  11 |     Reg = 10; RegI = 11; Cond = 12;  (*internal item modes*)
  12 |     ZeroD = 4B00H;  (*denormalized zero used for FLOOR/FLT conversions*)
  13 |     BCT = 0E7000000H; RTI = 10H; STI = 20H; F2 = -2;  (*instructions*)
  14 |     C4 = 10H; C6 = 40H; C8 = 100H; C10 = 400H; C12 = 1000H; C14 = 4000H; C16 = 10000H;
  15 |     C20 = 100000H; C24 = 1000000H; C28 = 10000000H; C30 = 40000000H;
  16 | 
  17 |   (*frequently used opcodes*)  U = 2000H; V = 1000H;
  18 |     Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7;
  19 |     Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11;
  20 |     Fad = 12; Fsb = 13; Fml = 14; Fdv = 15;
  21 |     Ldr = 8; Str = 10;
  22 |     BR = 0; BLR = 1; BC = 2; BL = 3;
  23 |     MI = 0; PL = 8; EQ = 1; NE = 9; CS = 2; CC = 10; LT = 5; GE = 13; LE = 6; GT = 14;
  24 | 
  25 |     TYPE Item* = RECORD
  26 |       mode*: INTEGER;
  27 |       type*: ORB.Type;
  28 |       obj*: ORB.Object;
  29 |       a*, b*, r: LONGINT;
  30 |       rdo*, deref, super: BOOLEAN  (*read only, dereferenced, super call*)
  31 |     END ;
  32 |     LabelRange* = RECORD low*, high*, label*: INTEGER END ;
  33 | 
  34 |   (* Item forms and meaning of fields:
  35 |     mode    r      a       b
  36 |     --------------------------------
  37 |     Const   -     value (proc adr)  (immediate value)
  38 |     Var     base   off     -               (direct adr)
  39 |     Par      -     off0     off1         (indirect adr)
  40 |     Reg    regno
  41 |     RegI   regno   off     -
  42 |     Cond  cond   Fchain  Tchain  *)
  43 | 
  44 |   VAR pc*: LONGINT;    (*program counter*)
  45 |     varx, strx, tdw: LONGINT;  (*varx and strx in bytes, tdw in words*)
  46 |     entry, final: LONGINT;   (*main entry point, finalization sequence*)
  47 |     RH: LONGINT;  (*available registers R[0] ... R[H-1]*)
  48 |     frame: LONGINT;  (*frame offset changed in SaveRegs and RestoreRegs*)
  49 |     fixorgP, fixorgD, fixorgT, fixorgM: LONGINT;   (*origins of lists of locations to be fixed up by loader*)
  50 |     check: BOOLEAN;  (*emit run-time checks*)
  51 |     version: INTEGER;  (* 0 = RISC-0, 1 = RISC-5 *)
  52 | 
  53 |     relmap: ARRAY 6 OF INTEGER;  (*condition codes for relations*)
  54 |     code: ARRAY maxCode OF LONGINT;
  55 |     str: ARRAY maxStrx OF CHAR;  (*strings*)
  56 |     td: ARRAY maxTD OF LONGINT;  (*type descriptors*)
  57 | 
  58 |   (*instruction assemblers according to formats*)
  59 | 
  60 |   PROCEDURE incR;
  61 |   BEGIN
  62 |     IF RH < TR-1 THEN INC(RH) ELSE ORS.Mark("register stack overflow") END
  63 |   END incR;
  64 | 
  65 |   PROCEDURE Put0(op, a, b, c: LONGINT);
  66 |   BEGIN (*emit format-0 register instruction*)
  67 |     code[pc] := ((a*C4 + b) * C4 + op) * C16 + c; INC(pc)
  68 |   END Put0;
  69 | 
  70 |   PROCEDURE Put1(op, a, b, im: LONGINT);
  71 |   BEGIN (*emit format-1 register instruction, -C16 <= im < C16*)
  72 |     IF im < 0 THEN INC(op, V) END ;
  73 |     code[pc] := (((a+C6) * C4 + b) * C4 + op) * C16 + im MOD C16; INC(pc)
  74 |   END Put1;
  75 | 
  76 |   PROCEDURE Put1a(op, a, b, im: LONGINT);
  77 |     VAR r: INTEGER;
  78 |   BEGIN (*same as Put1, but with range test -C16 <= im < C16*)
  79 |     IF (im >= -C16) & (im < C16) THEN Put1(op, a, b, im)
  80 |     ELSIF op = Mov THEN
  81 |       Put1(Mov+U, a, 0, im DIV C16);
  82 |       IF im MOD C16 # 0 THEN Put1(Ior, a, a, im MOD C16) END
  83 |     ELSE r := RH;
  84 |       IF (a = RH) OR (b = RH) THEN incR END ;
  85 |       Put1(Mov+U, RH, 0, im DIV C16);
  86 |       IF im MOD C16 # 0 THEN Put1(Ior, RH, RH, im MOD C16) END ;
  87 |       Put0(op, a, b, RH); RH := r
  88 |     END
  89 |   END Put1a;
  90 | 
  91 |   PROCEDURE Put1b(r, mno, off, disp: LONGINT);
  92 |   BEGIN (*emit modified register instruction to be fixed up by loader, 0 <= mno < 64, 0 <= off < 256*)
  93 |     code[pc] := (((r+16) * C6 + mno) * C8 + off) * C12 + disp MOD C12; INC(pc)
  94 |   END Put1b;
  95 | 
  96 |   PROCEDURE Put2(op, a, b, off: LONGINT);
  97 |   BEGIN (*emit load/store instruction*)
  98 |     code[pc] := ((op * C4 + a) * C4 + b) * C20 + off MOD C20; INC(pc)
  99 |   END Put2;
 100 | 
 101 |   PROCEDURE Put3(op, cond, off: LONGINT);
 102 |   BEGIN (*emit branch instruction*)
 103 |     code[pc] := ((op+12) * C4 + cond) * C24 + off MOD C24; INC(pc)
 104 |   END Put3;
 105 | 
 106 |   PROCEDURE Put3a(op, mno, pno, disp: LONGINT);
 107 |   BEGIN (*emit modified branch instruction to be fixed up by loader, 0 <= mno < 64*)
 108 |     code[pc] := (((op+12) * C6 + mno) * C8 + pno) * C14 + disp MOD C14; INC(pc)
 109 |   END Put3a;
 110 | 
 111 |   PROCEDURE PutPair(base, op, a, b, off: LONGINT);
 112 |   BEGIN (*emit instruction pair to be fixed up by loader, base <= 0, 0 <= off < C24*)
 113 |     IF version = 0 THEN off := off + VarOrg0; Put1(Mov+U, RH, 0, off DIV C16)
 114 |     ELSIF pc - fixorgD < C12 THEN
 115 |       Put1b(RH, -base, off DIV C16 MOD C8, pc-fixorgD); fixorgD := pc-1  (*Mov+U*)
 116 |     ELSE ORS.Mark("fixup impossible")
 117 |     END ;
 118 |     IF op = Ior THEN Put1(Ior, a, b, off MOD C16) ELSE Put2(op, a, b, off MOD C16) (*Ldr/Str*) END
 119 |   END PutPair;
 120 | 
 121 |   PROCEDURE CheckRegs*;
 122 |   BEGIN
 123 |     IF RH # 0 THEN ORS.Mark("Reg Stack"); RH := 0 END ;
 124 |     IF pc >= maxCode - 40 THEN ORS.Mark("program too long") END ;
 125 |     IF frame # 0 THEN ORS.Mark("frame error"); frame := 0 END
 126 |   END CheckRegs;
 127 | 
 128 |   PROCEDURE SetCC(VAR x: Item; n: LONGINT);
 129 |   BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n
 130 |   END SetCC;
 131 | 
 132 |   PROCEDURE Trap(cond, num: LONGINT);
 133 |   BEGIN Put3(BLR, cond, ORS.Pos()*C8 + num*C4 + TR)
 134 |   END Trap;
 135 | 
 136 |   PROCEDURE NilCheck;
 137 |   BEGIN IF check THEN Trap(EQ, 4) END
 138 |   END NilCheck;
 139 | 
 140 |   (*handling of forward reference, fixups of instruction operands*)
 141 | 
 142 |   PROCEDURE negated(cond: LONGINT): LONGINT;
 143 |   BEGIN
 144 |     IF cond < 8 THEN cond := cond+8 ELSE cond := cond-8 END ;
 145 |     RETURN cond
 146 |   END negated;
 147 | 
 148 |   PROCEDURE fix1(at, with: LONGINT);
 149 |     VAR v: LONGINT;
 150 |   BEGIN (*fix format-1 register instruction*)
 151 |     IF with < 0 THEN v := C28 (*set v bit*) ELSE v := 0 END ;
 152 |     code[at] := code[at] DIV C16 * C16 + with MOD C16 + v
 153 |   END fix1;
 154 | 
 155 |   PROCEDURE fix3(at, with: LONGINT);
 156 |   BEGIN (*fix branch instruction*)
 157 |     code[at] := code[at] DIV C24 * C24 + with MOD C24
 158 |   END fix3;
 159 | 
 160 |   PROCEDURE FixLinkWith(L, dst: LONGINT);
 161 |     VAR L1: LONGINT;
 162 |   BEGIN (*fix chain of branch instructions*)
 163 |     WHILE L # 0 DO L1 := code[L] MOD C24; fix3(L, dst-L-1); L := L1 END
 164 |   END FixLinkWith;
 165 | 
 166 |   PROCEDURE FixLink*(L: LONGINT);
 167 |   BEGIN FixLinkWith(L, pc)
 168 |   END FixLink;
 169 | 
 170 |   PROCEDURE FixLinkMixed*(L: LONGINT);
 171 |     VAR L1, format: LONGINT; p: INTEGER;
 172 |   BEGIN (*fix chain of instructions of different formats*)
 173 |     WHILE L # 0 DO p := code[L];
 174 |       format := p DIV C30 MOD 4; L1 := p MOD C16;
 175 |       IF format < 3 THEN fix1(L, (pc-L)*4) ELSE fix3(L, pc-L-1) END ;
 176 |       L := L1
 177 |     END
 178 |   END FixLinkMixed;
 179 | 
 180 |   PROCEDURE FixLinkPair(L, adr: LONGINT);
 181 |     VAR L1: LONGINT; p, q: INTEGER;
 182 |   BEGIN (*fix chain of instruction pairs with an address that is spread across both instructions, 0 <= adr < C24*)
 183 |     WHILE L # 0 DO p := code[L-1]; q := code[L];
 184 |       L1 := p DIV C12 MOD C8 * C16 + q MOD C16;
 185 |       code[L-1] := p DIV C20 * C20 + adr DIV C16 MOD C8 * C12 + p MOD C12;
 186 |       code[L] := q DIV C16 * C16 + adr MOD C16;
 187 |       L := L1
 188 |     END
 189 |   END FixLinkPair;
 190 | 
 191 |   PROCEDURE merged(L0, L1: LONGINT): LONGINT;
 192 |     VAR L2, L3: LONGINT;
 193 |   BEGIN (*merge chains of the two operands of AND and OR*)
 194 |     IF L0 # 0 THEN L3 := L0;
 195 |       REPEAT L2 := L3; L3 := code[L2] MOD C16 UNTIL L3 = 0;
 196 |       code[L2] := code[L2] + L1; L1 := L0
 197 |     END ;
 198 |     RETURN L1
 199 |   END merged;
 200 | 
 201 |   (* loading of operands and addresses into registers *)
 202 | 
 203 |   PROCEDURE load(VAR x: Item);
 204 |     VAR op: LONGINT;
 205 |   BEGIN
 206 |     IF x.mode # Reg THEN
 207 |       IF x.type.size = 1 THEN op := Ldr+1 ELSE op := Ldr END ;
 208 |       IF x.mode = ORB.Const THEN
 209 |         IF x.type.form = ORB.Proc THEN
 210 |           IF x.r > 0 THEN (*local*) ORS.Mark("not allowed")
 211 |           ELSIF x.a < 0 THEN (*forward*) Put3(BL, 7, 0); Put1(Add, RH, LNK, x.type.len); x.type.len := pc-1  (*fixed up in ORP.Body*)
 212 |           ELSIF x.r = 0 THEN (*global*) Put3(BL, 7, 0); Put1a(Sub, RH, LNK, pc*4 - x.a)
 213 |           ELSE (*imported*) PutPair(x.r, Ior, RH, RH, x.a + C8)  (*mark as progbase-relative*)
 214 |           END
 215 |         ELSE Put1a(Mov, RH, 0, x.a)
 216 |         END ;
 217 |         x.r := RH; incR
 218 |       ELSIF x.mode = ORB.Var THEN
 219 |         IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a + frame)
 220 |         ELSE PutPair(x.r, op, RH, RH, x.a)
 221 |         END ;
 222 |         x.r := RH; incR
 223 |       ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, RH, RH, x.b); x.r := RH; incR
 224 |       ELSIF x.mode = RegI THEN Put2(op, x.r, x.r, x.a)
 225 |       ELSIF x.mode = Cond THEN
 226 |         Put3(BC, negated(x.r), 2);
 227 |         FixLink(x.b); Put1(Mov, RH, 0, 1); Put3(BC, 7, 1);
 228 |         FixLink(x.a); Put1(Mov, RH, 0, 0); x.r := RH; incR
 229 |       END ;
 230 |       x.mode := Reg
 231 |     END
 232 |   END load;
 233 | 
 234 |   PROCEDURE loadAdr(VAR x: Item);
 235 |   BEGIN
 236 |     IF x.mode = ORB.Var THEN
 237 |       IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a + frame)
 238 |       ELSE PutPair(x.r, Ior, RH, RH, x.a)
 239 |       END ;
 240 |       x.r := RH; incR
 241 |     ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame);
 242 |       IF x.b # 0 THEN Put1a(Add, RH, RH, x.b) END ;
 243 |       x.r := RH; incR
 244 |     ELSIF x.mode = RegI THEN
 245 |       IF x.a # 0 THEN Put1a(Add, x.r, x.r, x.a) END
 246 |     ELSE ORS.Mark("address error")
 247 |     END ;
 248 |     x.mode := Reg
 249 |   END loadAdr;
 250 | 
 251 |   PROCEDURE loadCond(VAR x: Item);
 252 |   BEGIN
 253 |     IF x.mode # Cond THEN
 254 |       IF x.type.form = ORB.Bool THEN
 255 |         IF x.mode = ORB.Const THEN x.r := 15 - x.a*8
 256 |         ELSE load(x);
 257 |           IF code[pc-1] DIV C30 # F2 THEN Put1(Cmp, x.r, x.r, 0) END ;
 258 |           x.r := NE; DEC(RH)
 259 |         END ;
 260 |         x.mode := Cond; x.a := 0; x.b := 0
 261 |       ELSE ORS.Mark("not Boolean?")
 262 |       END
 263 |     END
 264 |   END loadCond;
 265 | 
 266 |   PROCEDURE loadTypTagAdr(T: ORB.Type);
 267 |   BEGIN
 268 |     IF T.mno <= 0 THEN PutPair(0, Ior, RH, RH, T.len); T.len := pc-1  (*insert into fixorgD chain, fixed up in Close*)
 269 |     ELSE (*imported*) PutPair(-T.mno, Ior, RH, RH, T.len)
 270 |     END ;
 271 |     incR
 272 |   END loadTypTagAdr;
 273 | 
 274 |   PROCEDURE loadStringAdr(VAR x: Item);
 275 |   BEGIN
 276 |     IF x.r >= 0 THEN PutPair(0, Ior, RH, RH, varx + x.a)
 277 |     ELSE (*imported*) PutPair(x.r, Ior, RH, RH, x.a)
 278 |     END ;
 279 |     x.mode := Reg; x.r := RH; incR
 280 |   END loadStringAdr;
 281 | 
 282 |   (* Items: Conversion from constants or from Objects on the Heap to Items on the Stack*)
 283 | 
 284 |   PROCEDURE MakeConstItem*(VAR x: Item; typ: ORB.Type; val: LONGINT);
 285 |   BEGIN x.mode := ORB.Const; x.type := typ; x.a := val
 286 |   END MakeConstItem;
 287 | 
 288 |   PROCEDURE MakeRealItem*(VAR x: Item; val: REAL);
 289 |   BEGIN x.mode := ORB.Const; x.type := ORB.realType; x.a := SYSTEM.VAL(LONGINT, val)
 290 |   END MakeRealItem;
 291 | 
 292 |   PROCEDURE MakeStringItem*(VAR x: Item; len: LONGINT);  (*copies string from ORS-buffer to ORG-string array*)
 293 |     VAR i: LONGINT;
 294 |   BEGIN x.mode := ORB.Const; x.type := ORB.strType; x.a := strx; x.b := len; x.r := 0; i := 0;
 295 |     IF strx + len + 4 < maxStrx THEN
 296 |       WHILE len > 0 DO str[strx] := ORS.str[i]; INC(strx); INC(i); DEC(len) END ;
 297 |       WHILE strx MOD 4 # 0 DO str[strx] := 0X; INC(strx) END
 298 |     ELSE ORS.Mark("too many strings")
 299 |     END
 300 |   END MakeStringItem;
 301 | 
 302 |   PROCEDURE MakeItem*(VAR x: Item; y: ORB.Object);
 303 |   BEGIN x.obj := y; x.mode := y.class; x.type := y.type; x.a := y.val; x.rdo := y.rdo; x.deref := FALSE;
 304 |     IF y.class = ORB.Par THEN x.b := 0
 305 |     ELSE x.r := y.lev;
 306 |       IF (y.class = ORB.Const) & (y.type.form = ORB.String) THEN
 307 |         x.a := y.val MOD C20; (*strx/exno*) x.b := y.val DIV C20 (*len*)
 308 |       END
 309 |     END
 310 |   END MakeItem;
 311 | 
 312 |   (* Code generation for Selectors, Variables, Constants *)
 313 | 
 314 |   PROCEDURE Field*(VAR x: Item; y: ORB.Object);   (* x := x.y *)
 315 |   BEGIN x.deref := FALSE;
 316 |     IF x.mode = ORB.Var THEN
 317 |       IF x.r >= 0 THEN x.a := x.a + y.val
 318 |       ELSE (*imported*) loadAdr(x); x.mode := RegI; x.a := y.val
 319 |       END
 320 |     ELSIF x.mode = RegI THEN x.a := x.a + y.val
 321 |     ELSIF x.mode = ORB.Par THEN x.b := x.b + y.val
 322 |     END
 323 |   END Field;
 324 | 
 325 |   PROCEDURE Index*(VAR x, y: Item);   (* x := x[y] *)
 326 |     VAR s, lim: LONGINT;
 327 |   BEGIN s := x.type.base.size; lim := x.type.len; x.deref := FALSE;
 328 |     IF (y.mode = ORB.Const) & (y.a < 0) THEN ORS.Mark("bad index") END ;
 329 |     IF (y.mode = ORB.Const) & (lim >= 0) THEN
 330 |       IF y.a >= lim THEN ORS.Mark("bad index") END ;
 331 |       IF x.mode = ORB.Var THEN
 332 |         IF x.r >= 0 THEN x.a := y.a * s + x.a
 333 |         ELSE (*imported*) loadAdr(x); x.mode := RegI; x.a := y.a * s
 334 |         END
 335 |       ELSIF x.mode = RegI THEN x.a := y.a * s + x.a
 336 |       ELSIF x.mode = ORB.Par THEN x.b := y.a * s + x.b
 337 |       END
 338 |     ELSE load(y);
 339 |       IF check THEN  (*check array bounds*)
 340 |         IF lim >= 0 THEN Put1a(Cmp, RH, y.r, lim)
 341 |         ELSIF x.mode IN {ORB.Var, ORB.Par} THEN (*open array param*) Put2(Ldr, RH, SP, x.a+4+frame); Put0(Cmp, RH, y.r, RH)
 342 |         ELSIF x.mode = RegI THEN (*dynamic open array*) Put2(Ldr, RH, x.r, -16); (*len*) Put0(Cmp, RH, y.r, RH)
 343 |         ELSE ORS.Mark("error in Index")
 344 |         END ;
 345 |         Trap(CC, 1)
 346 |       END ;
 347 |       IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1a(Mul, y.r, y.r, s) END ;
 348 |       IF x.mode = ORB.Var THEN
 349 |         IF x.r > 0 THEN (*local*) Put0(Add, y.r, SP, y.r); INC(x.a, frame)
 350 |         ELSIF x.r = 0 THEN (*global*) PutPair(0, Ior, RH, RH, 0); Put0(Add, y.r, RH, y.r)
 351 |         ELSE (*imported*) PutPair(x.r, Ior, RH, RH, x.a); Put0(Add, y.r, RH, y.r); x.a := 0
 352 |         END ;
 353 |         x.r := y.r; x.mode := RegI
 354 |       ELSIF x.mode = ORB.Par THEN
 355 |         Put2(Ldr, RH, SP, x.a + frame);
 356 |         Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r; x.a := x.b
 357 |       ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH)
 358 |       END
 359 |     END
 360 |   END Index;
 361 | 
 362 |   PROCEDURE DeRef*(VAR x: Item);
 363 |   BEGIN
 364 |     IF x.mode = ORB.Var THEN
 365 |       IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a + frame)
 366 |       ELSE PutPair(x.r, Ldr, RH, RH, x.a)
 367 |       END ;
 368 |       NilCheck; x.r := RH; incR
 369 |     ELSIF x.mode = ORB.Par THEN
 370 |       Put2(Ldr, RH, SP, x.a + frame); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR
 371 |     ELSIF x.mode = RegI THEN Put2(Ldr, x.r, x.r, x.a); NilCheck
 372 |     ELSIF x.mode # Reg THEN ORS.Mark("bad mode in DeRef")
 373 |     END ;
 374 |     IF x.type.base.form = ORB.Array THEN Put1(Add, x.r, x.r, 16) END ; (*pointer to array*)
 375 |     x.mode := RegI; x.a := 0; x.b := 0; x.deref := TRUE
 376 |   END DeRef;
 377 | 
 378 |   PROCEDURE Method*(VAR x: Item; y: ORB.Object; super: BOOLEAN);
 379 |   BEGIN loadAdr(x); (*receiver*) x.super := super;
 380 |     IF super THEN x.a := y.val; (*mthadr/exno*) x.b := -y.type.mno
 381 |     ELSE x.a := y.lev; (*mthno*)
 382 |       IF x.deref THEN x.b := ORB.Var ELSE x.b := ORB.Par END
 383 |     END
 384 |   END Method;
 385 | 
 386 |   PROCEDURE Q(T: ORB.Type; VAR tdw: LONGINT);
 387 |   BEGIN (*one entry of type descriptor extension table*)
 388 |     IF T.base # NIL THEN
 389 |       Q(T.base, tdw); td[tdw] := (T.mno*C12 + T.len (*TDoff/exno*)) * C12 + tdw - fixorgT;
 390 |       fixorgT := tdw; INC(tdw)
 391 |     END
 392 |   END Q;
 393 | 
 394 |   PROCEDURE FindRefFlds(ftyp: SET; typ: ORB.Type; off: LONGINT; VAR tdw: LONGINT);
 395 |     VAR fld: ORB.Object; i, s: LONGINT;
 396 |   BEGIN
 397 |     IF typ.form IN ftyp THEN td[tdw] := off; INC(tdw)
 398 |     ELSIF typ.form = ORB.Record THEN fld := typ.dsc;
 399 |       WHILE fld # NIL DO FindRefFlds(ftyp, fld.type, fld.val + off, tdw); fld := fld.next END
 400 |     ELSIF typ.form = ORB.Array THEN s := typ.base.size;
 401 |       FOR i := 0 TO typ.len-1 DO FindRefFlds(ftyp, typ.base, i*s + off, tdw) END
 402 |     END
 403 |   END FindRefFlds;
 404 | 
 405 |   PROCEDURE BuildTD(T: ORB.Type; VAR tdw: LONGINT);
 406 |     VAR k, s: LONGINT; fld, bot: ORB.Object; t: ORB.Type;
 407 |   BEGIN (*type descriptors of base types of T already built*)
 408 |     k := ORB.NofMethods(T); td[tdw] := -k-1; INC(tdw); s := tdw;
 409 |     WHILE k > 0 DO td[tdw] := -1; INC(tdw); DEC(k) END ;
 410 |     t := T; fld := NIL;  (*build method table*)
 411 |     WHILE t # NIL DO fld := t.dsc;
 412 |       IF t.base # NIL THEN bot := t.base.dsc ELSE bot := NIL END ;
 413 |       WHILE fld # bot DO
 414 |         IF (fld.class = ORB.Const) & (td[tdw-fld.lev-1] = -1) & ((t.mno = 0) OR (fld.name[0] # 0X)) THEN
 415 |           td[tdw-fld.lev-1] := (t.mno*C16 + fld.val (*mthadr/exno*)) * C10
 416 |         END ;
 417 |         fld := fld.next
 418 |       END ;
 419 |       t := t.base
 420 |     END ;
 421 |     FOR k := s TO tdw-1 DO  (*insert displacements in ascending order*)
 422 |       IF td[k] # -1 THEN td[k] := td[k] + k - fixorgM; fixorgM := k ELSE td[k] := 0 END
 423 |     END ;
 424 |     s := T.size;  (*convert size for heap allocation*)
 425 |     IF s <= 24 THEN s := 32 ELSIF s <= 56 THEN s := 64 ELSIF s <= 120 THEN s := 128
 426 |     ELSE s := (s+263) DIV 256 * 256
 427 |     END ;
 428 |     T.len := tdw*4; td[tdw] := s; INC(tdw);  (*len used as type descriptor offset in bytes relative to tdx*)
 429 |     k := T.nofpar;  (*extension level!*)
 430 |     IF k > 3 THEN ORS.Mark("ext level too large")
 431 |     ELSE Q(T, tdw);
 432 |       WHILE k < 3 DO td[tdw] := -1; INC(tdw); INC(k) END
 433 |     END ;
 434 |     FindRefFlds(ORB.Ptrs, T, 0, tdw); td[tdw] := -1; INC(tdw);
 435 |     FindRefFlds(ORB.Procs, T, 0, tdw); td[tdw] := -1; INC(tdw);
 436 |     IF tdw >= maxTD THEN ORS.Mark("too many record types"); tdw := 0 END
 437 |   END BuildTD;
 438 | 
 439 |   PROCEDURE TypeTest*(VAR x: Item; T: ORB.Type; varpar, isguard: BOOLEAN);
 440 |     VAR pc0: LONGINT;
 441 |   BEGIN
 442 |     IF T = NIL THEN
 443 |       IF x.mode >= Reg THEN DEC(RH) END ;
 444 |       SetCC(x, 7)
 445 |     ELSE (*fetch tag into RH*)
 446 |       IF varpar THEN Put2(Ldr, RH, SP, x.a+4+frame)
 447 |       ELSE load(x);
 448 |         pc0 := pc; Put3(BC, EQ, 0);  (*NIL belongs to every pointer type*)
 449 |         Put2(Ldr, RH, x.r, -8)
 450 |       END ;
 451 |       Put2(Ldr, RH, RH, T.nofpar*4); incR;
 452 |       loadTypTagAdr(T);  (*tag of T*)
 453 |       Put0(Cmp, RH-1, RH-1, RH-2); DEC(RH, 2);
 454 |       IF ~varpar THEN fix3(pc0, pc - pc0 - 1) END ;
 455 |       IF isguard THEN
 456 |         IF check THEN Trap(NE, 2) END
 457 |       ELSE SetCC(x, EQ);
 458 |         IF ~varpar THEN DEC(RH) END
 459 |       END
 460 |     END
 461 |   END TypeTest;
 462 | 
 463 |   (* Code generation for Boolean operators *)
 464 | 
 465 |   PROCEDURE Not*(VAR x: Item);   (* x := ~x *)
 466 |     VAR t: LONGINT;
 467 |   BEGIN loadCond(x); x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t
 468 |   END Not;
 469 | 
 470 |   PROCEDURE And1*(VAR x: Item);   (* x := x & *)
 471 |   BEGIN loadCond(x); Put3(BC, negated(x.r), x.a); x.a := pc-1; FixLink(x.b); x.b := 0
 472 |   END And1;
 473 | 
 474 |   PROCEDURE And2*(VAR x, y: Item);
 475 |   BEGIN loadCond(y); x.a := merged(y.a, x.a); x.b := y.b; x.r := y.r
 476 |   END And2;
 477 | 
 478 |   PROCEDURE Or1*(VAR x: Item);   (* x := x OR *)
 479 |   BEGIN loadCond(x); Put3(BC, x.r, x.b);  x.b := pc-1; FixLink(x.a); x.a := 0
 480 |   END Or1;
 481 | 
 482 |   PROCEDURE Or2*(VAR x, y: Item);
 483 |   BEGIN loadCond(y); x.a := y.a; x.b := merged(y.b, x.b); x.r := y.r
 484 |   END Or2;
 485 | 
 486 |   (* Code generation for arithmetic operators *)
 487 | 
 488 |   PROCEDURE Neg*(VAR x: Item);   (* x := -x *)
 489 |   BEGIN
 490 |     IF x.type.form = ORB.Int THEN
 491 |       IF x.mode = ORB.Const THEN x.a := -x.a
 492 |       ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r)
 493 |       END
 494 |     ELSIF x.type.form = ORB.Real THEN
 495 |       IF x.mode = ORB.Const THEN x.a := x.a + 7FFFFFFFH + 1
 496 |       ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Fsb, x.r, RH, x.r)
 497 |       END
 498 |     ELSE (*form = Set*)
 499 |       IF x.mode = ORB.Const THEN x.a := -x.a-1 
 500 |       ELSE load(x); Put1(Xor, x.r, x.r, -1)
 501 |       END
 502 |     END
 503 |   END Neg;
 504 | 
 505 |   PROCEDURE AddOp*(op: LONGINT; VAR x, y: Item);   (* x := x +- y *)
 506 |   BEGIN
 507 |     IF op = ORS.plus THEN
 508 |       IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a + y.a
 509 |       ELSIF y.mode = ORB.Const THEN load(x);
 510 |         IF y.a # 0 THEN Put1a(Add, x.r, x.r, y.a) END
 511 |       ELSE load(x); load(y); Put0(Add, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
 512 |       END
 513 |     ELSE (*op = ORS.minus*)
 514 |       IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a - y.a
 515 |       ELSIF y.mode = ORB.Const THEN load(x);
 516 |         IF y.a # 0 THEN Put1a(Sub, x.r, x.r, y.a) END
 517 |       ELSE load(x); load(y); Put0(Sub, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
 518 |       END
 519 |     END
 520 |   END AddOp;
 521 | 
 522 |   PROCEDURE log2(m: LONGINT; VAR e: LONGINT): LONGINT;
 523 |   BEGIN e := 0;
 524 |     WHILE ~ODD(m) DO m := m DIV 2; INC(e) END ;
 525 |     RETURN m
 526 |   END log2;
 527 | 
 528 |   PROCEDURE MulOp*(VAR x, y: Item);   (* x := x * y *)
 529 |     VAR e: LONGINT;
 530 |   BEGIN
 531 |     IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a * y.a
 532 |     ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Lsl, x.r, x.r, e)
 533 |     ELSIF y.mode = ORB.Const THEN load(x); Put1a(Mul, x.r, x.r, y.a)
 534 |     ELSIF (x.mode = ORB.Const) & (x.a >= 2) & (log2(x.a, e) = 1) THEN load(y); Put1(Lsl, y.r, y.r, e); x.mode := Reg; x.r := y.r
 535 |     ELSIF x.mode = ORB.Const THEN load(y); Put1a(Mul, y.r, y.r, x.a); x.mode := Reg; x.r := y.r
 536 |     ELSE load(x); load(y); Put0(Mul, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
 537 |     END
 538 |   END MulOp;
 539 | 
 540 |   PROCEDURE DivOp*(op: LONGINT; VAR x, y: Item);   (* x := x op y *)
 541 |     VAR e: LONGINT;
 542 |   BEGIN
 543 |     IF op = ORS.div THEN
 544 |       IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN
 545 |         IF y.a > 0 THEN x.a := x.a DIV y.a ELSE ORS.Mark("bad divisor") END
 546 |       ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Asr, x.r, x.r, e)
 547 |       ELSIF y.mode = ORB.Const THEN
 548 |         IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a) ELSE ORS.Mark("bad divisor") END
 549 |       ELSE load(y);
 550 |         IF check THEN Trap(LE, 6) END ;
 551 |         load(x); Put0(Div, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
 552 |       END
 553 |     ELSE (*op = ORS.mod*)
 554 |       IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN
 555 |         IF y.a > 0 THEN x.a := x.a MOD y.a ELSE ORS.Mark("bad modulus") END
 556 |       ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x);
 557 |         IF e <= 16 THEN Put1(And, x.r, x.r, y.a-1) ELSE Put1(Lsl, x.r, x.r, 32-e); Put1(Ror, x.r, x.r, 32-e) END
 558 |       ELSIF y.mode = ORB.Const THEN
 559 |         IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a); Put0(Mov+U, x.r, 0, 0) ELSE ORS.Mark("bad modulus") END
 560 |       ELSE load(y);
 561 |         IF check THEN Trap(LE, 6) END ;
 562 |         load(x); Put0(Div, RH-2, x.r, y.r); Put0(Mov+U, RH-2, 0, 0); DEC(RH); x.r := RH-1
 563 |       END
 564 |     END
 565 |   END DivOp;
 566 | 
 567 |   (* Code generation for REAL operators *)
 568 | 
 569 |   PROCEDURE RealOp*(op: INTEGER; VAR x, y: Item);   (* x := x op y *)
 570 |   BEGIN load(x); load(y);
 571 |     IF op = ORS.plus THEN Put0(Fad, RH-2, x.r, y.r)
 572 |     ELSIF op = ORS.minus THEN Put0(Fsb, RH-2, x.r, y.r)
 573 |     ELSIF op = ORS.times THEN Put0(Fml, RH-2, x.r, y.r)
 574 |     ELSIF op = ORS.rdiv THEN Put0(Fdv, RH-2, x.r, y.r)
 575 |     END ;
 576 |     DEC(RH); x.r := RH-1
 577 |   END RealOp;
 578 | 
 579 |   (* Code generation for set operators *)
 580 | 
 581 |   PROCEDURE Singleton*(VAR x: Item);  (* x := {x} *)
 582 |   BEGIN
 583 |     IF x.mode = ORB.Const THEN x.a := LSL(1, x.a)
 584 |     ELSE load(x); Put1(Mov, RH, 0, 1); Put0(Lsl, x.r, RH,  x.r)
 585 |     END
 586 |   END Singleton;
 587 | 
 588 |   PROCEDURE Set*(VAR x, y: Item);   (* x := {x .. y} *)
 589 |   BEGIN
 590 |     IF (x.mode = ORB.Const) & ( y.mode = ORB.Const) THEN
 591 |       IF x.a <= y.a THEN x.a := LSL(2, y.a) - LSL(1, x.a) ELSE x.a := 0 END
 592 |     ELSE
 593 |       IF (x.mode = ORB.Const) & (x.a <= 16) THEN x.a := LSL(-1, x.a)
 594 |       ELSE load(x); Put1(Mov, RH, 0, -1); Put0(Lsl, x.r, RH, x.r)
 595 |       END ;
 596 |       IF (y.mode = ORB.Const) & (y.a < 16) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; incR
 597 |       ELSE load(y); Put1(Mov, RH, 0, -2); Put0(Lsl, y.r, RH, y.r)
 598 |       END ;
 599 |       IF x.mode = ORB.Const THEN
 600 |         IF x.a # 0 THEN Put1(Xor, y.r, y.r, -1); Put1a(And, RH-1, y.r, x.a) END ;
 601 |         x.mode := Reg
 602 |       ELSE DEC(RH); Put0(Ann, RH-1, x.r, y.r)
 603 |       END ;
 604 |       x.r := RH-1
 605 |     END
 606 |   END Set;
 607 | 
 608 |   PROCEDURE In*(VAR x, y: Item);  (* x := x IN y *)
 609 |   BEGIN load(y);
 610 |     IF x.mode = ORB.Const THEN Put1(Ror, y.r, y.r, (x.a + 1) MOD maxSet); DEC(RH)
 611 |     ELSE load(x); Put1(Add, x.r, x.r, 1); Put0(Ror, y.r, y.r, x.r); DEC(RH, 2)
 612 |     END ;
 613 |     SetCC(x, MI)
 614 |   END In;
 615 | 
 616 |   PROCEDURE SetOp*(op: LONGINT; VAR x, y: Item);   (* x := x op y *)
 617 |     VAR xset, yset: SET; (*x.type.form = Set*)
 618 |   BEGIN
 619 |     IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN
 620 |       xset := SYSTEM.VAL(SET, x.a); yset := SYSTEM.VAL(SET, y.a);
 621 |       IF op = ORS.plus THEN xset := xset + yset
 622 |       ELSIF op = ORS.minus THEN xset := xset - yset
 623 |       ELSIF op = ORS.times THEN xset := xset * yset
 624 |       ELSIF op = ORS.rdiv THEN xset := xset / yset
 625 |       END ;
 626 |       x.a := SYSTEM.VAL(LONGINT, xset)
 627 |     ELSIF y.mode = ORB.Const THEN
 628 |       load(x);
 629 |       IF op = ORS.plus THEN Put1a(Ior, x.r, x.r, y.a)
 630 |       ELSIF op = ORS.minus THEN Put1a(Ann, x.r, x.r, y.a)
 631 |       ELSIF op = ORS.times THEN Put1a(And, x.r, x.r, y.a)
 632 |       ELSIF op = ORS.rdiv THEN Put1a(Xor, x.r, x.r, y.a)
 633 |       END ;
 634 |     ELSE load(x); load(y);
 635 |       IF op = ORS.plus THEN Put0(Ior, RH-2, x.r, y.r)
 636 |       ELSIF op = ORS.minus THEN Put0(Ann, RH-2, x.r, y.r)
 637 |       ELSIF op = ORS.times THEN Put0(And, RH-2, x.r, y.r)
 638 |       ELSIF op = ORS.rdiv THEN Put0(Xor, RH-2, x.r, y.r)
 639 |       END ;
 640 |       DEC(RH); x.r := RH-1
 641 |     END 
 642 |   END SetOp;
 643 | 
 644 |   (* Code generation for relations *)
 645 | 
 646 |   PROCEDURE IntRelation*(op: INTEGER; VAR x, y: Item);   (* x := x < y *)
 647 |   BEGIN
 648 |     IF (y.mode = ORB.Const) & (y.type.form # ORB.Proc) THEN
 649 |       load(x);
 650 |       IF (y.a # 0) OR ~(op IN {ORS.eql, ORS.neq}) OR (code[pc-1] DIV C30 # F2) THEN Put1a(Cmp, x.r, x.r, y.a) END ;
 651 |       DEC(RH)
 652 |     ELSE
 653 |       IF (x.mode = Cond) OR (y.mode = Cond) THEN ORS.Mark("not implemented") END ;
 654 |       load(x); load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2)
 655 |     END ;
 656 |     SetCC(x, relmap[op - ORS.eql])
 657 |   END IntRelation;
 658 | 
 659 |   PROCEDURE RealRelation*(op: INTEGER; VAR x, y: Item);   (* x := x < y *)
 660 |   BEGIN load(x);
 661 |     IF (y.mode = ORB.Const) & (y.a = 0) THEN DEC(RH)
 662 |     ELSE load(y); Put0(Fsb, x.r, x.r, y.r); DEC(RH, 2)
 663 |     END ;
 664 |     SetCC(x, relmap[op - ORS.eql])
 665 |   END RealRelation;
 666 | 
 667 |   PROCEDURE StringRelation*(op: INTEGER; VAR x, y: Item);   (* x := x < y *)
 668 |     (*x, y are char arrays or strings*)
 669 |   BEGIN
 670 |     IF x.type.form = ORB.String THEN loadStringAdr(x) ELSE loadAdr(x) END ;
 671 |     IF y.type.form = ORB.String THEN loadStringAdr(y) ELSE loadAdr(y) END ;
 672 |     Put2(Ldr+1, RH, x.r, 0); Put1(Add, x.r, x.r, 1); incR;
 673 |     Put2(Ldr+1, RH, y.r, 0); Put1(Add, y.r, y.r, 1); incR;
 674 |     Put0(Cmp, RH, RH-2, RH-1); Put3(BC, NE, 2);
 675 |     Put1(Cmp, RH, RH-2, 0); Put3(BC, NE, -8);
 676 |     DEC(RH, 4); SetCC(x, relmap[op - ORS.eql])
 677 |   END StringRelation;
 678 | 
 679 |   (* Code generation of Assignments *)
 680 | 
 681 |   PROCEDURE StrToChar*(VAR x: Item);
 682 |   BEGIN x.type := ORB.charType; DEC(strx, 4); x.a := ORD(str[x.a])
 683 |   END StrToChar;
 684 | 
 685 |   PROCEDURE Store*(VAR x, y: Item); (* x := y *)
 686 |     VAR op: LONGINT;
 687 |   BEGIN  load(y);
 688 |     IF x.type.size = 1 THEN op := Str+1 ELSE op := Str END ;
 689 |     IF x.mode = ORB.Var THEN
 690 |       IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a + frame)
 691 |       ELSE PutPair(x.r, op, y.r, RH, x.a)
 692 |       END
 693 |     ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, y.r, RH, x.b);
 694 |     ELSIF x.mode = RegI THEN Put2(op, y.r, x.r, x.a); DEC(RH);
 695 |     ELSE ORS.Mark("bad mode in Store")
 696 |     END ;
 697 |     DEC(RH)
 698 |   END Store;
 699 | 
 700 |   PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y, frame = 0 *)
 701 |     VAR s, pc0: LONGINT;
 702 |   BEGIN loadAdr(x); loadAdr(y);
 703 |     IF (x.type.form = ORB.Array) & (x.type.len # 0) & (y.type.len # 0) THEN
 704 |       IF (x.type.len < 0) OR (y.type.len < 0) THEN
 705 |         IF y.type.len < 0 THEN  (*y open array param or dynamic open array*)
 706 |           IF y.type.size > 0 THEN Put2(Ldr, RH, SP, y.a+4) ELSE Put2(Ldr, RH, y.r, -16) END ;  (*y len*)
 707 |           s := y.type.base.size;  (*y element size*)
 708 |           pc0 := pc; Put3(BC, EQ, 0);
 709 |           IF s = 1 THEN Put1(Add, RH, RH, 3); Put1(Asr, RH, RH, 2)
 710 |           ELSIF s # 4 THEN Put1a(Mul, RH, RH, s DIV 4)
 711 |           END
 712 |         ELSE Put1a(Mov, RH, 0, (y.type.size+3) DIV 4)
 713 |         END ;
 714 |         IF check THEN (*check array lengths*) incR;
 715 |           IF x.type.len < 0 THEN  (*x open array param or dynamic open array*)
 716 |             IF x.type.size > 0 THEN Put2(Ldr, RH, SP, x.a+4) ELSE Put2(Ldr, RH, x.r, -16) END ;  (*x len*)
 717 |             s := x.type.base.size;  (*x element size*)
 718 |             IF s = 1 THEN Put1(Add, RH, RH, 3); Put1(Asr, RH, RH, 2)
 719 |             ELSIF s # 4 THEN Put1a(Mul, RH, RH, s DIV 4)
 720 |             END
 721 |           ELSE Put1a(Mov, RH, 0, (x.type.size+3) DIV 4)
 722 |           END ;
 723 |           Put0(Cmp, RH, RH-1, RH); Trap(GT, 3); DEC(RH)
 724 |         END ;
 725 |         IF y.type.len < 0 THEN fix3(pc0, pc + 5 - pc0) END
 726 |       ELSE  (*x, y fixed length arrays*)
 727 |         IF x.type.size = y.type.size THEN Put1a(Mov, RH, 0, (y.type.size+3) DIV 4)
 728 |         ELSE ORS.Mark("different length/size, not implemented")
 729 |         END
 730 |       END
 731 |     ELSIF x.type.form = ORB.Record THEN Put1a(Mov, RH, 0, x.type.size DIV 4)
 732 |     ELSE ORS.Mark("inadmissible assignment")
 733 |     END ;
 734 |     incR;
 735 |     Put2(Ldr, RH, y.r, 0); Put1(Add, y.r, y.r, 4);
 736 |     Put2(Str, RH, x.r, 0); Put1(Add, x.r, x.r, 4);
 737 |     Put1(Sub, RH-1, RH-1, 1); Put3(BC, NE, -6); RH := 0
 738 |   END StoreStruct;
 739 | 
 740 |   PROCEDURE CopyString*(VAR x, y: Item);  (* x := y, frame = 0 *) 
 741 |      VAR len: LONGINT;
 742 |    BEGIN loadAdr(x); len := x.type.len;
 743 |     IF len >= 0 THEN
 744 |       IF len <  y.b THEN ORS.Mark("string too long") END
 745 |     ELSIF check THEN  (*x open array param or dynamic open array*)
 746 |       IF x.type.size > 0 THEN Put2(Ldr, RH, SP, x.a+4) ELSE Put2(Ldr, RH, x.r, -16) END ;  (*x len*)
 747 |       Put1(Cmp,RH, RH, y.b); Trap(LT, 3)
 748 |     END ;
 749 |     loadStringAdr(y);
 750 |     Put2(Ldr, RH, y.r, 0); Put1(Add, y.r, y.r, 4);
 751 |     Put2(Str, RH, x.r, 0); Put1(Add, x.r, x.r, 4);
 752 |     Put1(Asr, RH, RH, 24); Put3(BC, NE,  -6);  RH := 0
 753 |   END CopyString;
 754 | 
 755 |   (* Code generation for parameters *)
 756 | 
 757 |   PROCEDURE VarParam*(VAR x: Item; ftype: ORB.Type);
 758 |     VAR xmd: INTEGER;
 759 |   BEGIN xmd := x.mode; loadAdr(x);
 760 |     IF (ftype.form = ORB.Array) & (ftype.len < 0) THEN  (*open array*)
 761 |       IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len)
 762 |       ELSE  (*x open array param or dynamic open array*)
 763 |         IF x.type.size > 0 THEN Put2(Ldr, RH, SP, x.a+4+frame) ELSE Put2(Ldr, RH, x.r, -16) END  (*x len*)
 764 |       END ;
 765 |       incR
 766 |     ELSIF ftype.form = ORB.Record THEN
 767 |       IF x.deref THEN Put2(Ldr, RH, x.r, -8); incR
 768 |       ELSIF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4+frame); incR
 769 |       ELSE loadTypTagAdr(x.type)
 770 |       END
 771 |     END
 772 |   END VarParam;
 773 | 
 774 |   PROCEDURE ValueParam*(VAR x: Item);
 775 |   BEGIN load(x)
 776 |   END ValueParam;
 777 | 
 778 |   PROCEDURE StringParam*(VAR x: Item);
 779 |   BEGIN loadStringAdr(x); Put1(Mov, RH, 0, x.b); incR  (*len*)
 780 |   END StringParam;
 781 | 
 782 |   PROCEDURE ReceiverParam*(VAR x: Item; par: ORB.Object);
 783 |   BEGIN
 784 |     IF x.r # RH THEN Put0(Mov, RH, 0, x.r) END ;  (*receiver*)
 785 |     incR;
 786 |     IF par.class = ORB.Par THEN loadTypTagAdr(par.type)  (*type tag*)
 787 |     ELSIF ~x.deref THEN ORS.Mark("incompatible receiver")
 788 |     END
 789 |   END ReceiverParam;
 790 | 
 791 |   (*For Statements*)
 792 | 
 793 |   PROCEDURE For0*(VAR x, y: Item);
 794 |   BEGIN load(y)
 795 |   END For0;
 796 | 
 797 |   PROCEDURE For1*(VAR x, y, z, w: Item; VAR L: LONGINT);
 798 |   BEGIN 
 799 |     IF z.mode = ORB.Const THEN Put1a(Cmp, RH, y.r, z.a)
 800 |     ELSE load(z); Put0(Cmp, RH-1, y.r, z.r); DEC(RH)
 801 |     END ;
 802 |     L := pc;
 803 |     IF w.a > 0 THEN Put3(BC, GT, 0)
 804 |     ELSIF w.a < 0 THEN Put3(BC, LT, 0)
 805 |     ELSE ORS.Mark("zero increment"); Put3(BC, MI, 0)
 806 |     END ;
 807 |     Store(x, y)
 808 |   END For1;
 809 | 
 810 |   PROCEDURE For2*(VAR x, y, w: Item);
 811 |   BEGIN load(x); DEC(RH); Put1a(Add, x.r, x.r, w.a)
 812 |   END For2;
 813 | 
 814 |   (* Branches, procedure calls, procedure prolog and epilog *)
 815 | 
 816 |   PROCEDURE Here*(): LONGINT;
 817 |   BEGIN RETURN pc
 818 |   END Here;
 819 | 
 820 |   PROCEDURE FJump*(VAR L: LONGINT);
 821 |   BEGIN Put3(BC, 7, L); L := pc-1
 822 |   END FJump;
 823 | 
 824 |   PROCEDURE CFJump*(VAR x: Item);
 825 |   BEGIN loadCond(x); Put3(BC, negated(x.r), x.a); FixLink(x.b); x.a := pc-1
 826 |   END CFJump;
 827 | 
 828 |   PROCEDURE BJump*(L: LONGINT);
 829 |   BEGIN Put3(BC, 7, L-pc-1)
 830 |   END BJump;
 831 | 
 832 |   PROCEDURE CBJump*(VAR x: Item; L: LONGINT);
 833 |   BEGIN loadCond(x); Put3(BC, negated(x.r), L-pc-1); FixLink(x.b); FixLinkWith(x.a, L)
 834 |   END CBJump;
 835 | 
 836 |   PROCEDURE Fixup*(VAR x: Item);
 837 |   BEGIN FixLink(x.a)
 838 |   END Fixup;
 839 | 
 840 |   PROCEDURE SaveRegs(r: LONGINT);  (* R[0 .. r-1]*)
 841 |     VAR r0: LONGINT;
 842 |   BEGIN (*r > 0*) r0 := 0;
 843 |     Put1(Sub, SP, SP, r*4); INC(frame, 4*r);
 844 |     REPEAT Put2(Str, r0, SP, (r-r0-1)*4); INC(r0) UNTIL r0 = r
 845 |   END SaveRegs;
 846 | 
 847 |   PROCEDURE RestoreRegs(r: LONGINT); (*R[0 .. r-1]*)
 848 |     VAR r0: LONGINT;
 849 |   BEGIN (*r > 0*) r0 := r;
 850 |     REPEAT DEC(r0); Put2(Ldr, r0, SP, (r-r0-1)*4) UNTIL r0 = 0;
 851 |     Put1(Add, SP, SP, r*4); DEC(frame, 4*r)
 852 |   END RestoreRegs;
 853 | 
 854 |   PROCEDURE PrepCall*(VAR x: Item; VAR r: LONGINT);
 855 |   BEGIN (*x.type.form IN {ORB.Proc, ORB.TProc}*)
 856 |     IF x.type.form = ORB.TProc THEN DEC(RH) ELSIF x.mode > ORB.Par THEN load(x) END ;
 857 |     r := RH;
 858 |     IF RH > 0 THEN SaveRegs(RH); RH := 0 END
 859 |   END PrepCall;
 860 | 
 861 |   PROCEDURE Call*(VAR x: Item; r: LONGINT);
 862 |   BEGIN (*x.type.form IN {ORB.Proc, ORB.TProc}*)
 863 |     IF x.type.form = ORB.TProc THEN  (*type-bound procedure*)
 864 |       IF x.super THEN  (*super call*)
 865 |         IF x.b >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1)
 866 |         ELSE (*imported*) Put3a(BL, -x.b, x.a, pc-fixorgP); fixorgP := pc-1
 867 |         END
 868 |       ELSE  (*method call*)
 869 |         IF x.b = ORB.Var THEN Put2(Ldr, RH, 0, -8) ELSE Put0(Mov, RH, 0, 1) END ;
 870 |         Put2(Ldr, RH, RH, -4-x.a*4); Put3(BLR, 7, RH)
 871 |       END
 872 |     ELSIF x.mode = ORB.Const THEN
 873 |       IF x.a < 0 THEN (*forward*) Put3(BL, 7, x.type.len); x.type.len := pc-1  (*fixed up in ORP.Body*)
 874 |       ELSIF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1)
 875 |       ELSE (*imported*) Put3a(BL, -x.r, x.a, pc-fixorgP); fixorgP := pc-1
 876 |       END
 877 |     ELSE
 878 |       IF x.mode <= ORB.Par THEN load(x); DEC(RH)
 879 |       ELSE Put2(Ldr, RH, SP, 0); Put1(Add, SP, SP, 4); DEC(r); DEC(frame, 4)
 880 |       END ;
 881 |       IF check THEN Trap(EQ, 5) END ;
 882 |       Put3(BLR, 7, RH)
 883 |     END ;
 884 |     IF x.type.base.form = ORB.NoTyp THEN (*procedure*) RH := 0
 885 |     ELSE  (*function*)
 886 |       IF r > 0 THEN Put0(Mov, r, 0, 0); RestoreRegs(r); RH := r ELSE RH := 0 END ;
 887 |       x.mode := Reg; x.r := RH; incR
 888 |     END
 889 |   END Call;
 890 | 
 891 |   PROCEDURE Enter*(parblksize, locblksize: LONGINT; int: BOOLEAN);
 892 |     VAR a, r: LONGINT;
 893 |   BEGIN frame := 0;
 894 |     IF ~int THEN (*procedure prolog*)
 895 |       IF locblksize >= C16 THEN ORS.Mark("too many locals") END ;
 896 |       a := 4; r := 0;
 897 |       Put1(Sub, SP, SP, locblksize); Put2(Str, LNK, SP, 0);
 898 |       WHILE a < parblksize DO Put2(Str, r, SP, a); INC(r); INC(a, 4) END
 899 |     ELSE (*interrupt procedure*)
 900 |       Put1(Sub, SP, SP, locblksize); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4); Put2(Str, 2, SP, 8)
 901 |       (*R0, R1, R2 saved on stack*)
 902 |     END
 903 |   END Enter;
 904 | 
 905 |   PROCEDURE Return*(form: INTEGER; VAR x: Item; size: LONGINT; int: BOOLEAN);
 906 |   BEGIN
 907 |     IF form # ORB.NoTyp THEN load(x) END ;
 908 |     IF ~int THEN (*procedure epilog*)
 909 |       Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK)
 910 |     ELSE (*interrupt return, restore R2, R1, R0*)
 911 |       Put2(Ldr, 2, SP, 8); Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, size);
 912 |       Put3(BR, 7, RTI)
 913 |     END ;
 914 |     RH := 0
 915 |   END Return;
 916 | 
 917 |   (* Case Statements *)
 918 | 
 919 |   PROCEDURE CaseHead*(VAR x: Item; VAR L0: LONGINT);
 920 |   BEGIN load(x);  (*value of case expression*)
 921 |     L0 := pc; Put1(Cmp, RH, x.r, 0);  (*higher bound, fixed up in CaseTail*)
 922 |     Put3(BC, CC, 0);  (*branch to else, fixed up in CaseTail*)
 923 |     Put1(Add, x.r, x.r, 0);  (*nof words between BL instruction at L0+4 and jump table, fixed up in CaseTail*)
 924 |     Put1(Lsl, x.r, x.r, 2);
 925 |     (*L0+4*) Put3(BL, 7, 0);  (*LNK := PC+1*)
 926 |     Put0(Add, LNK, LNK, x.r); Put3(BR, 7, LNK); DEC(RH)
 927 |   END CaseHead;
 928 | 
 929 |   PROCEDURE CaseTail*(L0, L1: LONGINT; n: INTEGER; VAR tab: ARRAY OF LabelRange);  (*L1 = label for else*)
 930 |     VAR i, j: INTEGER;
 931 |   BEGIN
 932 |     IF n > 0 THEN fix1(L0, tab[n-1].high + 1) (*higher bound*) ELSIF L1 = 0 THEN ORS.Mark("empty case") END ;
 933 |     IF L1 = 0 THEN L1 := pc; Trap(7, 1) END ;  (*create else*)
 934 |     fix3(L0+1, L1-L0-2);  (*branch to else*)
 935 |     fix1(L0+2, pc-L0-5);  (*nof words between BL instruction at L0+4 and jump table*)
 936 |     j := 0;
 937 |     FOR i := 0 TO n-1 DO  (*construct jump table*)
 938 |       WHILE j < tab[i].low DO BJump(L1); INC(j) END ;  (*else*)
 939 |       WHILE j <= tab[i].high DO BJump(tab[i].label); INC(j) END
 940 |     END
 941 |   END CaseTail;
 942 | 
 943 |   (* In-line code procedures *)
 944 | 
 945 |   PROCEDURE Increment*(upordown: LONGINT; VAR x, y: Item);
 946 |     VAR op, zr, v: LONGINT;
 947 |   BEGIN (*frame = 0*)
 948 |     IF upordown = 0 THEN op := Add ELSE op := Sub END ;
 949 |     IF x.type = ORB.byteType THEN v := 1 ELSE v := 0 END ;
 950 |     IF y.type.form = ORB.NoTyp THEN y.mode := ORB.Const; y.a := 1 END ;
 951 |     IF (x.mode = ORB.Var) & (x.r > 0) THEN
 952 |       zr := RH; Put2(Ldr+v, zr, SP, x.a); incR;
 953 |       IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
 954 |       Put2(Str+v, zr, SP, x.a); DEC(RH)
 955 |     ELSE loadAdr(x); zr := RH; Put2(Ldr+v, RH, x.r, 0); incR;
 956 |       IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
 957 |       Put2(Str+v, zr, x.r, 0); DEC(RH, 2)
 958 |     END
 959 |   END Increment;
 960 | 
 961 |   PROCEDURE Include*(inorex: LONGINT; VAR x, y: Item);
 962 |     VAR op, zr: LONGINT;
 963 |   BEGIN loadAdr(x); zr := RH; Put2(Ldr, RH, x.r, 0); incR;
 964 |     IF inorex = 0 THEN op := Ior ELSE op := Ann END ;
 965 |     IF y.mode = ORB.Const THEN Put1a(op, zr, zr, LSL(1, y.a))
 966 |     ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(op, zr, zr, y.r); DEC(RH)
 967 |     END ;
 968 |     Put2(Str, zr, x.r, 0); DEC(RH, 2)
 969 |   END Include;
 970 | 
 971 |   PROCEDURE Assert*(VAR x: Item);
 972 |     VAR cond: LONGINT;
 973 |   BEGIN loadCond(x);
 974 |     IF x.a = 0 THEN cond := negated(x.r)
 975 |     ELSE Put3(BC, x.r, x.b); FixLink(x.a); x.b := pc-1; cond := 7
 976 |     END ;
 977 |     Trap(cond, 7); FixLink(x.b)
 978 |   END Assert;
 979 | 
 980 |   PROCEDURE New*(VAR x, y: Item);
 981 |     VAR z: Item; xt: ORB.Type; xf: INTEGER;
 982 |   BEGIN loadAdr(x);
 983 |     IF y.type = ORB.noType THEN (*record*) loadTypTagAdr(x.type.base)
 984 |     ELSE (*array*) xt:= x.type.base.base; xf := xt.form;
 985 |       IF xf = ORB.Record THEN loadTypTagAdr(xt); Put1(Add, RH-1, RH-1, 1)  (*array of record, blktyp = 1*)
 986 |       ELSIF xf = ORB.Pointer THEN Put1(Mov, RH, 0, 2); incR  (*array of pointer, blktyp = 2*)
 987 |       ELSIF xf = ORB.Proc THEN Put1(Mov, RH, 0, 7); incR  (*array of procedure, blktyp = 3, tag = 7*)
 988 |       ELSIF xf < ORB.Pointer THEN Put1(Mov, RH, 0, 3); incR  (*array of basic type, blktyp = 3, tag = 3*)
 989 |       ELSE ORS.Mark("no valid ptr base type")
 990 |       END ;
 991 |       IF y.mode = ORB.Const THEN
 992 |         IF y.a > 0 THEN load(y) (*len*) ELSE ORS.Mark("not a valid dyn array length") END
 993 |       ELSE load(y); (*len*)
 994 |         IF check THEN Trap(LE, 1) END
 995 |       END ;
 996 |       z.mode := ORB.Const; z.type := ORB.intType; z.a := xt.size; load(z) (*elemsize*)
 997 |     END ;
 998 |     Trap(7, 0); RH := 0
 999 |   END New;
1000 | 
1001 |   PROCEDURE Pack*(VAR x, y: Item);
1002 |     VAR z: Item;
1003 |   BEGIN z := x; load(x); load(y);
1004 |     Put1(Lsl, y.r, y.r, 23); Put0(Add, x.r, x.r, y.r); DEC(RH); Store(z, x)
1005 |   END Pack;
1006 | 
1007 |   PROCEDURE Unpk*(VAR x, y: Item);
1008 |     VAR z, e0: Item;
1009 |   BEGIN  z := x; load(x); e0.mode := Reg; e0.r := RH; e0.type := ORB.intType;
1010 |     Put1(Asr, RH, x.r, 23); Put1(Sub, RH, RH, 127); Store(y, e0); incR;
1011 |     Put1(Lsl, RH, RH, 23); Put0(Sub, x.r, x.r, RH); Store(z, x)
1012 |   END Unpk;
1013 | 
1014 |   PROCEDURE Led*(VAR x: Item);
1015 |   BEGIN load(x); Put1(Mov, RH, 0, -60); Put2(Str, x.r, RH, 0); DEC(RH)
1016 |   END Led;
1017 | 
1018 |   PROCEDURE Get*(VAR x, y: Item);
1019 |   BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(y, x)
1020 |   END Get;
1021 | 
1022 |   PROCEDURE Put*(VAR x, y: Item);
1023 |   BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(x, y)
1024 |   END Put;
1025 | 
1026 |   PROCEDURE Copy*(VAR x, y, z: Item);
1027 |   BEGIN load(x); load(y);
1028 |     IF z.mode = ORB.Const THEN
1029 |       IF z.a > 0 THEN load(z) ELSE ORS.Mark("bad count") END
1030 |     ELSE load(z);
1031 |       IF check THEN Trap(LT, 3) END ;
1032 |       Put3(BC, EQ, 6)
1033 |     END ;
1034 |     Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4);
1035 |     Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4);
1036 |     Put1(Sub, z.r, z.r, 1); Put3(BC, NE, -6); DEC(RH, 3)
1037 |   END Copy;
1038 | 
1039 |   PROCEDURE LDPSR*(VAR x: Item);
1040 |   BEGIN (*x.mode = Const*)  Put3(0, 15, x.a + STI)
1041 |   END LDPSR;
1042 | 
1043 |   PROCEDURE LDREG*(VAR x, y: Item);
1044 |   BEGIN
1045 |     IF y.mode = ORB.Const THEN Put1a(Mov, x.a, 0, y.a)
1046 |     ELSE load(y); Put0(Mov, x.a, 0, y.r); DEC(RH)
1047 |     END
1048 |   END LDREG;
1049 | 
1050 |   (* In-line code functions *)
1051 | 
1052 |   PROCEDURE Abs*(VAR x: Item);
1053 |   BEGIN
1054 |     IF x.mode = ORB.Const THEN x.a := ABS(x.a)
1055 |     ELSE load(x);
1056 |       IF x.type.form = ORB.Real THEN Put1(Lsl, x.r, x.r, 1); Put1(Ror, x.r, x.r, 1)
1057 |       ELSE Put1(Cmp, x.r, x.r, 0); Put3(BC, GE, 2); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r)
1058 |       END
1059 |     END
1060 |   END Abs;
1061 | 
1062 |   PROCEDURE Odd*(VAR x: Item);
1063 |   BEGIN load(x); Put1(And, x.r, x.r, 1); SetCC(x, NE); DEC(RH)
1064 |   END Odd;
1065 | 
1066 |   PROCEDURE Floor*(VAR x: Item);
1067 |   BEGIN load(x); Put1(Mov+U, RH, 0, ZeroD); Put0(Fad+V, x.r, x.r, RH)
1068 |   END Floor;
1069 | 
1070 |   PROCEDURE Float*(VAR x: Item);
1071 |   BEGIN load(x); Put1(Mov+U, RH, 0, ZeroD);  Put0(Fad+U, x.r, x.r, RH)
1072 |   END Float;
1073 | 
1074 |   PROCEDURE Ord*(VAR x: Item);
1075 |   BEGIN
1076 |     IF x.mode IN {ORB.Var, ORB.Par, RegI, Cond} THEN load(x);
1077 |       IF (x.type.form = ORB.Pointer) & (x.type.base.form = ORB.Array) THEN Put1(Add, x.r, x.r, 16) END
1078 |     END
1079 |   END Ord;
1080 | 
1081 |   PROCEDURE Len*(VAR x: Item);
1082 |   BEGIN
1083 |     IF x.type.len >= 0 THEN
1084 |       IF x.mode = RegI THEN DEC(RH) END ;
1085 |       x.mode := ORB.Const; x.a := x.type.len
1086 |     ELSE  (*x open array param or dynamic open array*)
1087 |       IF x.type.size > 0 THEN Put2(Ldr, RH, SP, x.a+4+frame); x.r := RH; incR ELSE Put2(Ldr, x.r, x.r, -16) END ;  (*x len*)
1088 |       x.mode := Reg
1089 |     END
1090 |   END Len;
1091 | 
1092 |   PROCEDURE Shift*(fct: LONGINT; VAR x, y: Item);
1093 |     VAR op: LONGINT;
1094 |   BEGIN load(x);
1095 |     IF fct = 0 THEN op := Lsl ELSIF fct = 1 THEN op := Asr ELSE op := Ror END ;
1096 |     IF y.mode = ORB.Const THEN Put1(op, x.r, x.r, y.a MOD maxSet)
1097 |     ELSE load(y); Put0(op, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
1098 |     END
1099 |   END Shift;
1100 | 
1101 |   PROCEDURE ADC*(VAR x, y: Item);
1102 |   BEGIN load(x); load(y); Put0(Add+U, x.r, x.r, y.r); DEC(RH)
1103 |   END ADC;
1104 | 
1105 |   PROCEDURE SBC*(VAR x, y: Item);
1106 |   BEGIN load(x); load(y); Put0(Sub+U, x.r, x.r, y.r); DEC(RH)
1107 |   END SBC;
1108 | 
1109 |   PROCEDURE UML*(VAR x, y: Item);
1110 |   BEGIN load(x); load(y); Put0(Mul+U, x.r, x.r, y.r); DEC(RH)
1111 |   END UML;
1112 | 
1113 |   PROCEDURE Bit*(VAR x, y: Item);
1114 |   BEGIN load(x); Put2(Ldr, x.r, x.r, 0);
1115 |     IF y.mode = ORB.Const THEN Put1(Ror, x.r, x.r, y.a+1); DEC(RH)
1116 |     ELSE load(y); Put1(Add, y.r, y.r, 1); Put0(Ror, x.r, x.r, y.r); DEC(RH, 2)
1117 |     END ;
1118 |     SetCC(x, MI)
1119 |   END Bit;
1120 | 
1121 |   PROCEDURE Register*(VAR x: Item);
1122 |   BEGIN (*x.mode = Const*)
1123 |     Put0(Mov, RH, 0, x.a MOD C4); x.mode := Reg; x.r := RH; incR
1124 |   END Register;
1125 | 
1126 |   PROCEDURE H*(VAR x: Item);
1127 |   BEGIN (*x.mode = Const*)
1128 |     Put0(Mov + U + x.a MOD 2 * V, RH, 0, 0); x.mode := Reg; x.r := RH; incR
1129 |   END H;
1130 | 
1131 |   PROCEDURE Adr*(VAR x: Item);
1132 |   BEGIN 
1133 |     IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN loadAdr(x)
1134 |     ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.Proc) THEN load(x)
1135 |     ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.String) THEN loadStringAdr(x)
1136 |     ELSE ORS.Mark("not addressable")
1137 |     END
1138 |   END Adr;
1139 | 
1140 |   PROCEDURE Condition*(VAR x: Item);
1141 |   BEGIN (*x.mode = Const*) SetCC(x, x.a)
1142 |   END Condition;
1143 | 
1144 |   PROCEDURE Open*(v: INTEGER);
1145 |   BEGIN pc := 0; final := -1; strx := 0; tdw := 0; RH := 0; check := v # 0; version := v;
1146 |     fixorgP := 0; fixorgD := 0; fixorgT := 0; fixorgM := 0;
1147 |     IF v = 0 THEN pc := 1;
1148 |       REPEAT code[pc] := 0; INC(pc) UNTIL pc = 8
1149 |     END
1150 |   END Open;
1151 | 
1152 |   PROCEDURE SetDataSize*(dc: LONGINT);
1153 |   BEGIN varx := dc
1154 |   END SetDataSize;
1155 | 
1156 |   PROCEDURE Header*;
1157 |   BEGIN entry := pc*4;
1158 |     IF version = 0 THEN code[0] := BCT - 1 + pc;  Put1a(Mov, SP, 0, StkOrg0)  (*RISC-0*)
1159 |     ELSE Put1(Sub, SP, SP, 4); Put2(Str, LNK, SP, 0)
1160 |     END
1161 |   END Header;
1162 | 
1163 |   PROCEDURE Exit*;
1164 |   BEGIN (*exit code*)
1165 |     IF version = 0 THEN Put1(Mov, 0, 0, 0); Put3(BR, 7, 0)  (*RISC-0*)
1166 |     ELSE Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, 4); Put3(BR, 7, LNK)
1167 |     END
1168 |   END Exit;
1169 | 
1170 |   PROCEDURE Final*;
1171 |   BEGIN final := pc*4;
1172 |     IF version # 0 THEN Put1(Sub, SP, SP, 4); Put2(Str, LNK, SP, 0) END
1173 |   END Final;
1174 | 
1175 |   PROCEDURE NofRefs(ftyp: SET; typ: ORB.Type): LONGINT;
1176 |     VAR fld: ORB.Object; n: LONGINT;
1177 |   BEGIN
1178 |     IF typ.form IN ftyp THEN n := 1
1179 |     ELSIF typ.form = ORB.Record THEN fld := typ.dsc; n := 0;
1180 |       WHILE fld # NIL DO n := NofRefs(ftyp, fld.type) + n; fld := fld.next END
1181 |     ELSIF typ.form = ORB.Array THEN n := NofRefs(ftyp, typ.base) * typ.len
1182 |     ELSE n := 0
1183 |     END ;
1184 |     RETURN n
1185 |   END NofRefs;
1186 | 
1187 |   PROCEDURE FindRefs(VAR R: Files.Rider; ftyp: SET; typ: ORB.Type; off: LONGINT);
1188 |     VAR fld: ORB.Object; i, s: LONGINT;
1189 |   BEGIN
1190 |     IF typ.form IN ftyp THEN Files.WriteInt(R, off)
1191 |     ELSIF typ.form = ORB.Record THEN fld := typ.dsc;
1192 |       WHILE fld # NIL DO FindRefs(R, ftyp, fld.type, fld.val + off); fld := fld.next END
1193 |     ELSIF typ.form = ORB.Array THEN s := typ.base.size;
1194 |       FOR i := 0 TO typ.len-1 DO FindRefs(R, ftyp, typ.base, i*s + off) END
1195 |     END
1196 |   END FindRefs;
1197 | 
1198 |   PROCEDURE Close*(VAR modid: ORS.Ident; key, nofent: LONGINT);
1199 |     VAR obj: ORB.Object;
1200 |       i, comsize, nofimps, nofrefs, size, tdx, fix: LONGINT;
1201 |       name: ORS.Ident;
1202 |       F: Files.File; R: Files.Rider;
1203 |   BEGIN obj := ORB.topScope.next; nofimps := 0; comsize := 4; nofrefs := 0; tdx := varx + strx;
1204 |     WHILE obj # NIL DO
1205 |       IF (obj.class = ORB.Mod) & (obj.dsc # ORB.system) THEN INC(nofimps)  (*count imports*)
1206 |       ELSIF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc)
1207 |           & (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN i := 0;  (*count commands*)
1208 |         WHILE obj.name[i] # 0X DO INC(i) END ;
1209 |         i := (i+4) DIV 4 * 4; INC(comsize, i+4)
1210 |       ELSIF obj.class = ORB.Var THEN INC(nofrefs, NofRefs(ORB.Ptrs + ORB.Procs, obj.type))  (*count ptrs and pvrs*)
1211 |       ELSIF (obj.class = ORB.Typ) & (obj.type.form = ORB.Record) & (obj.type.typobj = obj) THEN  (*build type descriptors*)
1212 |         fix := obj.type.len;  (*heading of fixup chain of instruction pairs inserted into fixorgD chain in loadTypTagAdr*)
1213 |         BuildTD(obj.type, tdw);  (*obj.type.len now used as type descriptor (TD) offset in bytes relative to tdx*)
1214 |         IF fix > 0 THEN FixLinkPair(fix, tdx + obj.type.len) END  (*fix chain of instruction pairs with TD adr*)
1215 |       END ;
1216 |       obj := obj.next
1217 |     END ;
1218 |     size := tdx + tdw*4 + comsize + (pc + nofimps + nofent + nofrefs + 2)*4;
1219 |     ORB.MakeFileName(name, modid, ".rsc");  (*write code file*)
1220 |     F := Files.New(name); Files.Set(R, F, 0); Files.WriteString(R, modid); Files.WriteInt(R, key); Files.Write(R, CHR(version));
1221 |     Files.WriteInt(R, size);
1222 |     obj := ORB.topScope.next;
1223 |     WHILE (obj # NIL) & (obj.class = ORB.Mod) DO  (*imports*)
1224 |       IF obj.dsc # ORB.system THEN Files.WriteString(R, obj(ORB.Module).orgname); Files.WriteInt(R, obj.val) END ;
1225 |       obj := obj.next
1226 |     END ;
1227 |     Files.Write(R, 0X);
1228 |     Files.WriteInt(R, varx);  (*variable space*)
1229 |     Files.WriteInt(R, strx);
1230 |     FOR i := 0 TO strx-1 DO Files.Write(R, str[i]) END ;  (*strings*)
1231 |     Files.WriteInt(R, tdw*4);
1232 |     FOR i := 0 TO tdw-1 DO Files.WriteInt(R, td[i]) END ;  (*type descriptors*)
1233 |     Files.WriteInt(R, pc);  (*code len*)
1234 |     FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ;  (*program*)
1235 |     obj := ORB.topScope.next;
1236 |     WHILE obj # NIL DO  (*commands*)
1237 |       IF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) &
1238 |           (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN
1239 |         Files.WriteString(R, obj.name); Files.WriteInt(R, obj.val)
1240 |       END ;
1241 |       obj := obj.next
1242 |     END ;
1243 |     Files.Write(R, 0X);
1244 |     Files.WriteInt(R, nofent); Files.WriteInt(R, entry);
1245 |     obj := ORB.topScope.next;
1246 |     WHILE obj # NIL DO  (*entries*)
1247 |       IF obj.exno # 0 THEN
1248 |         IF  obj.class = ORB.Const THEN
1249 |           IF obj.type.form = ORB.String THEN Files.WriteInt(R, varx + obj.val MOD C20)  (*convert strx to SB-relative*)
1250 |           ELSIF obj.type.form = ORB.Proc THEN Files.WriteInt(R, obj.val)
1251 |           ELSIF obj.type.form = ORB.TProc THEN (*dummy to preserve linear order of exno*) Files.WriteInt(R, obj.dsc.val)
1252 |           END
1253 |         ELSIF obj.class = ORB.Typ THEN
1254 |           IF obj.type.form = ORB.Record THEN Files.WriteInt(R, tdx + obj.type.len MOD C16)
1255 |           ELSIF (obj.type.form = ORB.Pointer) & ((obj.type.base.typobj = NIL) OR (obj.type.base.typobj.exno = 0)) THEN
1256 |             Files.WriteInt(R, tdx + obj.type.base.len MOD C16)
1257 |           END
1258 |         ELSIF obj.class = ORB.Var THEN Files.WriteInt(R, obj.val)
1259 |         END
1260 |       END ;
1261 |       obj := obj.next
1262 |     END ;
1263 |     obj := ORB.topScope.next;
1264 |     WHILE obj # NIL DO  (*pointer variables*)
1265 |       IF obj.class = ORB.Var THEN FindRefs(R, ORB.Ptrs, obj.type, obj.val) END ;
1266 |       obj := obj.next
1267 |     END ;
1268 |     Files.WriteInt(R, -1);
1269 |     obj := ORB.topScope.next;
1270 |     WHILE obj # NIL DO  (*procedure variables*)
1271 |       IF obj.class = ORB.Var THEN FindRefs(R, ORB.Procs, obj.type, obj.val) END ;
1272 |       obj := obj.next
1273 |     END ;
1274 |     Files.WriteInt(R, -1);
1275 |     Files.WriteInt(R, fixorgP); Files.WriteInt(R, fixorgD); Files.WriteInt(R, fixorgT); Files.WriteInt(R, fixorgM);
1276 |     Files.WriteInt(R, entry); Files.WriteInt(R, final);
1277 |     Files.Write(R, "O"); Files.Register(F)
1278 |   END Close;
1279 | 
1280 | BEGIN relmap[0] := 1; relmap[1] := 9; relmap[2] := 5; relmap[3] := 6; relmap[4] := 14; relmap[5] := 13
1281 | END ORG.
1282 | 


--------------------------------------------------------------------------------
/Sources/ExtendedOberon/ORP.Mod:
--------------------------------------------------------------------------------
   1 | MODULE ORP; (*N. Wirth 1.7.97 / 8.3.2020  Oberon compiler for RISC in Oberon-07 / AP 1.2.25 Extended Oberon with retro elements*)
   2 |   IMPORT Texts, Oberon, ORS, ORB, ORG;
   3 |   (*Author: Niklaus Wirth, 2014. Oberon-2 extensions by Andreas Pirklbauer, 2020.
   4 |     Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens),
   5 |     ORB for definition of data structures and for handling import and export, and
   6 |     ORG to produce binary code. ORP performs type checking and data allocation.
   7 |     Parser is target-independent, except for part of the handling of allocations.*)
   8 | 
   9 |   CONST NofCases = 256; maxExit = 16; C20 = 100000H;
  10 | 
  11 |   TYPE PtrBase = POINTER TO PtrBaseDesc;
  12 |     PtrBaseDesc = RECORD  (*list of names of pointer base types*)
  13 |       name: ORS.Ident; type: ORB.Type; next: PtrBase
  14 |     END ;
  15 |   
  16 |   VAR sym: INTEGER;   (*last symbol read*)
  17 |     dc, fc: LONGINT;    (*data counter, forward counter*)
  18 |     level, exno, version, looplev, exitno: INTEGER;
  19 |     newSF, retro, return: BOOLEAN;  (*option, retro and return flags*)
  20 |     expression: PROCEDURE (VAR x: ORG.Item);  (*to avoid forward reference*)
  21 |     Type: PROCEDURE (VAR type: ORB.Type; expoone, expoall: BOOLEAN);
  22 |     FormalType: PROCEDURE (VAR typ: ORB.Type; dim: INTEGER);
  23 |     modid: ORS.Ident;
  24 |     pbsList: PtrBase;   (*list of names of pointer base types*)
  25 |     dummy: ORB.Object;
  26 |     exit: ARRAY maxExit OF INTEGER;
  27 |     W: Texts.Writer;
  28 | 
  29 |   PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR);
  30 |   BEGIN
  31 |     IF sym = s THEN ORS.Get(sym) ELSE ORS.Mark(msg) END
  32 |   END Check;
  33 | 
  34 |   PROCEDURE qualident(VAR obj: ORB.Object);
  35 |   BEGIN obj := ORB.thisObj(); ORS.Get(sym);
  36 |     IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END ;
  37 |     IF (sym = ORS.period) & (obj.class = ORB.Mod) THEN
  38 |       ORS.Get(sym);
  39 |       IF sym = ORS.ident THEN obj := ORB.thisimport(obj); ORS.Get(sym);
  40 |         IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END
  41 |       ELSE ORS.Mark("identifier expected"); obj := dummy
  42 |       END
  43 |     ELSIF (obj.lev > 0) & (obj.lev # level) &
  44 |       ((obj.class # ORB.Const) OR (obj.type.form # ORB.Proc)) THEN ORS.Mark("not accessible")
  45 |     END
  46 |   END qualident;
  47 | 
  48 |   PROCEDURE CheckBool(VAR x: ORG.Item);
  49 |   BEGIN
  50 |     IF x.type.form # ORB.Bool THEN ORS.Mark("not Boolean"); x.type := ORB.boolType END
  51 |   END CheckBool;
  52 | 
  53 |   PROCEDURE CheckInt(VAR x: ORG.Item);
  54 |   BEGIN
  55 |     IF x.type.form # ORB.Int THEN ORS.Mark("not Integer"); x.type := ORB.intType END
  56 |   END CheckInt;
  57 | 
  58 |   PROCEDURE CheckReal(VAR x: ORG.Item);
  59 |   BEGIN
  60 |     IF x.type.form # ORB.Real THEN ORS.Mark("not Real"); x.type := ORB.realType END
  61 |   END CheckReal;
  62 | 
  63 |   PROCEDURE CheckSet(VAR x: ORG.Item);
  64 |   BEGIN
  65 |     IF x.type.form # ORB.Set THEN ORS.Mark("not Set"); x.type := ORB.setType END 
  66 |   END CheckSet;
  67 | 
  68 |   PROCEDURE CheckSetVal(VAR x: ORG.Item);
  69 |   BEGIN
  70 |     IF x.type.form # ORB.Int THEN ORS.Mark("not Int"); x.type := ORB.setType
  71 |     ELSIF x.mode = ORB.Const THEN
  72 |       IF (x.a < 0) OR (x.a >= 32) THEN ORS.Mark("invalid set") END
  73 |     END 
  74 |   END CheckSetVal;
  75 | 
  76 |   PROCEDURE CheckConst(VAR x: ORG.Item);
  77 |   BEGIN
  78 |     IF x.mode # ORB.Const THEN ORS.Mark("not a constant"); x.mode := ORB.Const END
  79 |   END CheckConst;
  80 | 
  81 |   PROCEDURE CheckReadOnly(VAR x: ORG.Item);
  82 |   BEGIN
  83 |     IF x.rdo THEN ORS.Mark("read-only") END
  84 |   END CheckReadOnly;
  85 | 
  86 |   PROCEDURE CheckRetro;
  87 |   BEGIN
  88 |     IF ~retro THEN ORS.Mark("add ^ after MODULE") END
  89 |   END CheckRetro;
  90 | 
  91 |   PROCEDURE CheckExport(VAR expo, expoone, expoall: BOOLEAN);
  92 |   BEGIN
  93 |     IF (sym = ORS.times) OR (sym = ORS.minus) THEN
  94 |       expo := TRUE; expoone := TRUE; ORS.Get(sym);
  95 |       IF level # 0 THEN ORS.Mark("remove export mark") END ;
  96 |       IF sym = ORS.minus THEN CheckRetro END
  97 |     ELSE expo := FALSE; expoall := FALSE
  98 |     END
  99 |   END CheckExport;
 100 | 
 101 |   PROCEDURE IsExtension(t0, t1: ORB.Type): BOOLEAN;
 102 |   BEGIN (*t1 is an extension of t0*)
 103 |     RETURN (t0 = t1) OR (t1 # NIL) & IsExtension(t0, t1.base)
 104 |   END IsExtension;
 105 | 
 106 |   PROCEDURE DisallowMethods(rec: ORB.Type);  (*disallow binding methods to rec and its base types*)
 107 |   BEGIN
 108 |     WHILE rec # NIL DO rec.typobj.val := 1; rec := rec.base END
 109 |   END DisallowMethods;
 110 | 
 111 |   (* expressions *)
 112 | 
 113 |   PROCEDURE TypeTest(VAR x: ORG.Item; T: ORB.Type; guard: BOOLEAN);
 114 |     VAR xt: ORB.Type;
 115 |   BEGIN xt := x.type;
 116 |     IF (T.form = xt.form ) & ((T.form = ORB.Pointer) OR (T.form = ORB.Record) & (x.mode = ORB.Par)) THEN
 117 |       WHILE (xt # T) & (xt # NIL) DO xt := xt.base END ;
 118 |       IF xt # T THEN xt := x.type;
 119 |         IF xt.form = ORB.Pointer THEN
 120 |           IF IsExtension(xt.base, T.base) THEN ORG.TypeTest(x, T.base, FALSE, guard); x.type := T
 121 |           ELSE ORS.Mark("not an extension")
 122 |           END
 123 |         ELSIF (xt.form = ORB.Record) & (x.mode = ORB.Par) THEN
 124 |           IF IsExtension(xt, T) THEN  ORG.TypeTest(x, T, TRUE, guard); x.type := T
 125 |           ELSE ORS.Mark("not an extension")
 126 |           END
 127 |         ELSE ORS.Mark("incompatible types")
 128 |         END
 129 |       ELSIF ~guard THEN ORG.TypeTest(x, NIL, FALSE, FALSE)
 130 |       END
 131 |     ELSE ORS.Mark("type mismatch")
 132 |     END ;
 133 |     IF ~guard THEN x.type := ORB.boolType END
 134 |   END TypeTest;
 135 | 
 136 |   PROCEDURE selector(VAR x: ORG.Item);
 137 |     VAR y: ORG.Item; obj: ORB.Object;
 138 |   BEGIN
 139 |     WHILE (sym = ORS.lbrak) OR (sym = ORS.period) OR (sym = ORS.arrow)
 140 |         OR (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) DO
 141 |       IF sym = ORS.lbrak THEN
 142 |         IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base END ;
 143 |         REPEAT ORS.Get(sym); expression(y);
 144 |           IF x.type.form = ORB.Array THEN
 145 |             CheckInt(y); ORG.Index(x, y); x.type := x.type.base
 146 |           ELSE ORS.Mark("not an array")
 147 |           END
 148 |         UNTIL sym # ORS.comma;
 149 |         Check(ORS.rbrak, "no ]")
 150 |       ELSIF sym = ORS.period THEN
 151 |         ORS.Get(sym);
 152 |         IF sym = ORS.ident THEN
 153 |           IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base END ;
 154 |           IF x.type.form = ORB.Record THEN
 155 |             obj := ORB.thisfield(x.type); ORS.Get(sym);
 156 |             IF obj # NIL THEN
 157 |               IF obj.type.form = ORB.TProc THEN  (*type-bound procedure*)
 158 |                 IF sym = ORS.arrow THEN (*super call*)
 159 |                   IF (obj.type.dsc = ORB.topScope.next) & (obj.type.dsc = x.obj) THEN
 160 |                     obj := ORB.thisfield(x.type.base); ORS.Get(sym);
 161 |                     IF (obj # NIL) & (obj.type.form = ORB.TProc) THEN
 162 |                       ORG.Method(x, obj, TRUE); DisallowMethods(x.type.base); x.type := obj.type
 163 |                     ELSE ORS.Mark("method undefined in base types")
 164 |                     END
 165 |                   ELSE ORS.Mark("invalid super call")
 166 |                   END
 167 |                 ELSE (*method call*) ORG.Method(x, obj, FALSE); x.type := obj.type
 168 |                 END
 169 |               ELSE ORG.Field(x, obj); x.type := obj.type
 170 |               END
 171 |             ELSE ORS.Mark("undef")
 172 |             END
 173 |           ELSE ORS.Mark("not a record")
 174 |           END
 175 |         ELSE ORS.Mark("ident?")
 176 |         END
 177 |       ELSIF sym = ORS.arrow THEN
 178 |         ORS.Get(sym);
 179 |         IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base
 180 |         ELSE ORS.Mark("not a pointer")
 181 |         END
 182 |       ELSIF (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) THEN (*type guard*)
 183 |         ORS.Get(sym);
 184 |         IF sym = ORS.ident THEN
 185 |           qualident(obj);
 186 |           IF obj.class = ORB.Typ THEN TypeTest(x, obj.type, TRUE)
 187 |           ELSE ORS.Mark("guard type expected")
 188 |           END
 189 |         ELSE ORS.Mark("not an identifier")
 190 |         END ;
 191 |         Check(ORS.rparen, " ) missing")
 192 |       END ;
 193 |       x.obj := NIL
 194 |     END
 195 |   END selector;
 196 | 
 197 |   PROCEDURE EqualSignatures(t0, t1: ORB.Type): BOOLEAN;
 198 |     VAR p0, p1: ORB.Object; com, ext: BOOLEAN;
 199 |   BEGIN com := TRUE; ext := FALSE;
 200 |     IF (t0.base = t1.base) & (t0.nofpar = t1.nofpar) THEN
 201 |       p0 := t0.dsc; p1 := t1.dsc;
 202 |       IF t1.form = ORB.TProc THEN  (*type-bound procedure*)
 203 |         IF t0.form = ORB.TProc THEN  (*check whether its receiver is an extension of p0*)
 204 |           IF p1.type.form = ORB.Pointer THEN ext := IsExtension(p0.type.base, p1.type.base)
 205 |           ELSE ext := IsExtension(p0.type, p1.type)
 206 |           END
 207 |         END ;
 208 |         IF ext THEN p0 := p0.next; p1 := p1.next ELSE p0 := NIL; com := FALSE END
 209 |       END ;
 210 |       WHILE (p0 # NIL) & (p1 # NIL) DO
 211 |         IF (p0.class = p1.class) &  (p0.rdo = p1.rdo) &
 212 |           ((p0.type = p1.type) OR
 213 |           (p0.type.form = ORB.Array) & (p1.type.form = ORB.Array) & (p0.type.len = p1.type.len) & (p0.type.base = p1.type.base) OR
 214 |           (p0.type.form = ORB.Proc) & (p1.type.form = ORB.Proc) & EqualSignatures(p0.type, p1.type))
 215 |         THEN p0 := p0.next; p1 := p1.next
 216 |         ELSE p0 := NIL; com := FALSE
 217 |         END
 218 |       END
 219 |     ELSE com := FALSE
 220 |     END ;
 221 |     RETURN com
 222 |   END EqualSignatures;
 223 | 
 224 |   PROCEDURE CompTypes(t0, t1: ORB.Type; varpar: BOOLEAN): BOOLEAN;
 225 |   BEGIN (*check for assignment compatibility*)
 226 |     RETURN (t0 = t1)    (*openarray assignment disallowed in ORG*)
 227 |       OR (t0.form = ORB.Array) & (t1.form = ORB.Array) & (t0.base =  t1.base) & (t0.len = t1.len)
 228 |       OR (t0.form = ORB.Record) & (t1.form = ORB.Record)  & IsExtension(t0, t1)
 229 |       OR ~varpar &
 230 |         ((t0.form = ORB.Pointer) & (t1.form = ORB.Pointer)  & IsExtension(t0.base, t1.base)
 231 |         OR (t0.form = ORB.Proc) & (t1.form = ORB.Proc) & EqualSignatures(t0, t1)
 232 |         OR (t0.form IN {ORB.Pointer, ORB.Proc}) & (t1.form = ORB.NilTyp))
 233 |   END CompTypes;
 234 | 
 235 |   PROCEDURE Parameter(par: ORB.Object);
 236 |     VAR x: ORG.Item; varpar: BOOLEAN;
 237 |   BEGIN expression(x);
 238 |     IF par # NIL THEN
 239 |       varpar := par.class = ORB.Par;
 240 |       IF CompTypes(par.type, x.type, varpar)
 241 |           OR (x.type.form = ORB.Array) & (par.type.form = ORB.Array)
 242 |             & (x.type.base = par.type.base) & (par.type.len < 0)  (*open array*)
 243 |           OR (par.type.form = ORB.Array) & (par.type.base = ORB.byteType)
 244 |             & (par.type.len >= 0) & (x.type.len >= 0) & (par.type.size = x.type.size) THEN
 245 |         IF ~varpar THEN ORG.ValueParam(x)
 246 |         ELSE (*par.class = Par*)
 247 |           IF ~par.rdo THEN CheckReadOnly(x) END ;
 248 |           ORG.VarParam(x, par.type)
 249 |         END
 250 |       ELSIF varpar & (x.type.form = ORB.String) & par.rdo & (par.type.form = ORB.Array) &
 251 |           (par.type.base.form = ORB.Char) & (par.type.len < 0) THEN ORG.StringParam(x)
 252 |       ELSIF ~varpar & (x.type.form = ORB.Int) & (par.type.form = ORB.Int) THEN ORG.ValueParam(x)  (*BYTE*)
 253 |       ELSIF ~varpar & (x.type.form = ORB.String) & (x.b = 2) & (par.type.form = ORB.Char) THEN
 254 |         ORG.StrToChar(x); ORG.ValueParam(x)
 255 |       ELSE ORS.Mark("incompatible parameters")
 256 |       END
 257 |     END
 258 |   END Parameter;
 259 | 
 260 |   PROCEDURE ParamList(VAR x: ORG.Item);
 261 |     VAR n: INTEGER; par: ORB.Object;
 262 |   BEGIN par := x.type.dsc; n := 0;
 263 |     IF x.type.form = ORB.TProc THEN  (*type-bound procedure*)
 264 |       IF (par.class = ORB.Par) & ~par.rdo THEN CheckReadOnly(x) END ;
 265 |       ORG.ReceiverParam(x, par); INC(n); par := par.next
 266 |     END ;
 267 |     IF sym # ORS.rparen THEN
 268 |       Parameter(par); INC(n);
 269 |       WHILE sym <= ORS.comma DO
 270 |         Check(ORS.comma, "comma?");
 271 |         IF par # NIL THEN par := par.next END ;
 272 |         Parameter(par); INC(n)
 273 |       END ;
 274 |       Check(ORS.rparen, ") missing")
 275 |     ELSE ORS.Get(sym);
 276 |     END ;
 277 |     IF n < x.type.nofpar THEN ORS.Mark("too few params")
 278 |     ELSIF n > x.type.nofpar THEN ORS.Mark("too many params")
 279 |     END
 280 |   END ParamList;
 281 | 
 282 |   PROCEDURE StandFunc(VAR x: ORG.Item; fct: LONGINT; restyp: ORB.Type);
 283 |     VAR y: ORG.Item; n, npar: LONGINT;
 284 |   BEGIN Check(ORS.lparen, "no (");
 285 |     npar := fct MOD 10; fct := fct DIV 10; expression(x); n := 1;
 286 |     WHILE sym = ORS.comma DO ORS.Get(sym); expression(y); INC(n) END ;
 287 |     Check(ORS.rparen, "no )");
 288 |     IF n = npar THEN
 289 |       IF fct = 0 THEN (*ABS*)
 290 |         IF x.type.form IN {ORB.Int, ORB.Real} THEN ORG.Abs(x); restyp := x.type ELSE ORS.Mark("bad type") END
 291 |       ELSIF fct = 1 THEN (*ODD*) CheckInt(x); ORG.Odd(x)
 292 |       ELSIF fct = 2 THEN (*FLOOR*) CheckReal(x); ORG.Floor(x)
 293 |       ELSIF fct = 3 THEN (*FLT*) CheckInt(x); ORG.Float(x)
 294 |       ELSIF fct = 4 THEN (*ORD*)
 295 |         IF x.type.form <= ORB.Proc THEN ORG.Ord(x)
 296 |         ELSIF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x)
 297 |         ELSE ORS.Mark("bad type")
 298 |         END
 299 |       ELSIF fct = 5 THEN (*CHR*) CheckInt(x); ORG.Ord(x)
 300 |       ELSIF fct = 6 THEN (*LEN*)
 301 |         IF x.type.form = ORB.Array THEN ORG.Len(x) ELSE ORS.Mark("not an array") END
 302 |       ELSIF fct IN {7, 8, 9} THEN (*LSL, ASR, ROR*) CheckInt(y);
 303 |         IF x.type.form IN {ORB.Int, ORB.Set} THEN ORG.Shift(fct-7, x, y); restyp := x.type ELSE ORS.Mark("bad type") END
 304 |       ELSIF fct = 11 THEN (*ADC*) ORG.ADC(x, y)
 305 |       ELSIF fct = 12 THEN (*SBC*) ORG.SBC(x, y)
 306 |       ELSIF fct = 13 THEN (*UML*) ORG.UML(x, y)
 307 |       ELSIF fct = 14 THEN (*BIT*) CheckInt(x); CheckInt(y); ORG.Bit(x, y)
 308 |       ELSIF fct = 15 THEN (*REG*) CheckConst(x); CheckInt(x); ORG.Register(x)
 309 |       ELSIF fct = 16 THEN (*VAL*)
 310 |         IF (x.mode= ORB.Typ) & (x.type.size <= y.type.size) THEN restyp := x.type; x := y
 311 |         ELSE ORS.Mark("casting not allowed")
 312 |         END
 313 |       ELSIF fct = 17 THEN (*ADR*) ORG.Adr(x)
 314 |       ELSIF fct = 18 THEN (*SIZE*)
 315 |         IF x.mode = ORB.Typ THEN ORG.MakeConstItem(x, ORB.intType, x.type.size)
 316 |         ELSE ORS.Mark("must be a type")
 317 |         END
 318 |       ELSIF fct = 19 THEN (*COND*) CheckConst(x); CheckInt(x); ORG.Condition(x)
 319 |       ELSIF fct = 20 THEN (*H*) CheckConst(x); CheckInt(x); ORG.H(x)
 320 |       END ;
 321 |       x.type := restyp
 322 |     ELSE ORS.Mark("wrong nof params")
 323 |     END
 324 |   END StandFunc;
 325 | 
 326 |   PROCEDURE element(VAR x: ORG.Item);
 327 |     VAR y: ORG.Item;
 328 |   BEGIN expression(x); CheckSetVal(x);
 329 |     IF sym = ORS.upto THEN ORS.Get(sym); expression(y); CheckSetVal(y); ORG.Set(x, y)
 330 |     ELSE ORG.Singleton(x)
 331 |     END ;
 332 |     x.type := ORB.setType
 333 |   END element;
 334 |   
 335 |   PROCEDURE set(VAR x: ORG.Item);
 336 |     VAR y: ORG.Item;
 337 |   BEGIN
 338 |     IF sym >= ORS.if THEN
 339 |       IF sym # ORS.rbrace THEN ORS.Mark(" } missing") END ;
 340 |       ORG.MakeConstItem(x, ORB.setType, 0) (*empty set*)
 341 |     ELSE element(x);
 342 |       WHILE (sym <= ORS.comma) OR (sym = ORS.semicolon) DO
 343 |         IF sym = ORS.comma THEN ORS.Get(sym) ELSE ORS.Mark("comma?") END ;
 344 |         element(y); ORG.SetOp(ORS.plus, x, y)
 345 |       END
 346 |     END
 347 |   END set; 
 348 | 
 349 |   PROCEDURE factor(VAR x: ORG.Item);
 350 |     VAR obj: ORB.Object; rx: LONGINT;
 351 |   BEGIN (*sync*)
 352 |     IF (sym < ORS.char) OR (sym > ORS.ident) THEN ORS.Mark("expression expected");
 353 |       REPEAT ORS.Get(sym) UNTIL (sym >= ORS.char) & (sym <= ORS.for) OR (sym >= ORS.then)
 354 |     END ;
 355 |     IF sym = ORS.ident THEN
 356 |       qualident(obj);
 357 |       IF obj.class = ORB.SFunc THEN StandFunc(x, obj.val, obj.type)
 358 |       ELSE ORG.MakeItem(x, obj); selector(x);
 359 |         IF sym = ORS.lparen THEN
 360 |           ORS.Get(sym);
 361 |           IF (x.type.form IN {ORB.Proc, ORB.TProc}) & (x.type.base.form # ORB.NoTyp) THEN
 362 |             ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx); x.type := x.type.base
 363 |           ELSE ORS.Mark("not a function"); ParamList(x)
 364 |           END
 365 |         END
 366 |       END
 367 |     ELSIF sym = ORS.int THEN ORG.MakeConstItem(x, ORB.intType, ORS.ival); ORS.Get(sym)
 368 |     ELSIF sym = ORS.real THEN ORG.MakeRealItem(x, ORS.rval); ORS.Get(sym)
 369 |     ELSIF sym = ORS.char THEN ORG.MakeConstItem(x, ORB.charType, ORS.ival); ORS.Get(sym)
 370 |     ELSIF sym = ORS.nil THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.nilType, 0)
 371 |     ELSIF sym = ORS.string THEN ORG.MakeStringItem(x, ORS.slen); ORS.Get(sym)
 372 |     ELSIF sym = ORS.lparen THEN ORS.Get(sym); expression(x); Check(ORS.rparen, "no )")
 373 |     ELSIF sym = ORS.lbrace THEN ORS.Get(sym); set(x); Check(ORS.rbrace, "no }")
 374 |     ELSIF sym = ORS.not THEN ORS.Get(sym); factor(x); CheckBool(x); ORG.Not(x)
 375 |     ELSIF sym = ORS.false THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 0)
 376 |     ELSIF sym = ORS.true THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 1)
 377 |     ELSE ORS.Mark("not a factor"); ORG.MakeConstItem(x, ORB.intType, 0)
 378 |     END
 379 |   END factor;
 380 | 
 381 |   PROCEDURE term(VAR x: ORG.Item);
 382 |     VAR y: ORG.Item; op, f: INTEGER;
 383 |   BEGIN factor(x); f := x.type.form;
 384 |     WHILE (sym >= ORS.times) & (sym <= ORS.and) DO
 385 |       op := sym; ORS.Get(sym);
 386 |       IF op = ORS.times THEN
 387 |         IF f = ORB.Int THEN factor(y); CheckInt(y); ORG.MulOp(x, y)
 388 |         ELSIF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y)
 389 |         ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y)
 390 |         ELSE ORS.Mark("bad type")
 391 |         END
 392 |       ELSIF (op = ORS.div) OR (op = ORS.mod) THEN
 393 |         CheckInt(x); factor(y); CheckInt(y); ORG.DivOp(op, x, y)
 394 |       ELSIF op = ORS.rdiv THEN
 395 |         IF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y)
 396 |         ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y)
 397 |         ELSE ORS.Mark("bad type")
 398 |         END
 399 |       ELSE (*op = and*) CheckBool(x); ORG.And1(x); factor(y); CheckBool(y); ORG.And2(x, y)
 400 |       END
 401 |     END
 402 |   END term;
 403 | 
 404 |   PROCEDURE SimpleExpression(VAR x: ORG.Item);
 405 |     VAR y: ORG.Item; op: INTEGER;
 406 |   BEGIN
 407 |     IF sym = ORS.minus THEN ORS.Get(sym); term(x);
 408 |       IF x.type.form IN {ORB.Int, ORB.Real, ORB.Set} THEN ORG.Neg(x) ELSE CheckInt(x) END
 409 |     ELSIF sym = ORS.plus THEN ORS.Get(sym); term(x);
 410 |     ELSE term(x)
 411 |     END ;
 412 |     WHILE (sym >= ORS.plus) & (sym <= ORS.or) DO
 413 |       op := sym; ORS.Get(sym);
 414 |       IF op = ORS.or THEN ORG.Or1(x); CheckBool(x); term(y); CheckBool(y); ORG.Or2(x, y)
 415 |       ELSIF x.type.form = ORB.Int THEN term(y); CheckInt(y); ORG.AddOp(op, x, y)
 416 |       ELSIF x.type.form = ORB.Real THEN term(y); CheckReal(y); ORG.RealOp(op, x, y)
 417 |       ELSE CheckSet(x); term(y); CheckSet(y); ORG.SetOp(op, x, y)
 418 |       END
 419 |     END
 420 |   END SimpleExpression;
 421 | 
 422 |   PROCEDURE expression0(VAR x: ORG.Item);
 423 |     VAR y: ORG.Item; obj: ORB.Object; rel, xf, yf: INTEGER;
 424 |   BEGIN SimpleExpression(x);
 425 |     IF (sym >= ORS.eql) & (sym <= ORS.geq) THEN
 426 |       rel := sym; ORS.Get(sym); SimpleExpression(y); xf := x.type.form; yf := y.type.form;
 427 |       IF x.type = y.type THEN
 428 |         IF (xf IN {ORB.Char, ORB.Int}) THEN ORG.IntRelation(rel, x, y)
 429 |         ELSIF xf = ORB.Real THEN ORG.RealRelation(rel, x, y)
 430 |         ELSIF (xf IN {ORB.Set, ORB.Pointer, ORB.Proc, ORB.NilTyp, ORB.Bool}) THEN
 431 |           IF rel <= ORS.neq THEN ORG.IntRelation(rel, x, y) ELSE ORS.Mark("only = or #") END
 432 |         ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) OR (xf = ORB.String) THEN
 433 |           ORG.StringRelation(rel, x, y)
 434 |         ELSE ORS.Mark("illegal comparison")
 435 |         END
 436 |       ELSIF (xf IN {ORB.Pointer, ORB.Proc}) & (yf = ORB.NilTyp)
 437 |           OR (yf IN {ORB.Pointer, ORB.Proc}) & (xf = ORB.NilTyp) THEN
 438 |         IF rel <= ORS.neq THEN ORG.IntRelation(rel, x,  y) ELSE ORS.Mark("only = or #") END
 439 |       ELSIF (xf = ORB.Pointer) & (yf = ORB.Pointer) &
 440 |           (IsExtension(x.type.base, y.type.base) OR IsExtension(y.type.base, x.type.base))
 441 |           OR (xf = ORB.Proc) & (yf = ORB.Proc) & EqualSignatures(x.type, y.type) THEN
 442 |         IF rel <= ORS.neq THEN ORG.IntRelation(rel,  x, y) ELSE ORS.Mark("only = or #") END
 443 |       ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) &
 444 |             ((yf = ORB.String) OR (yf = ORB.Array) & (y.type.base.form = ORB.Char))
 445 |           OR (yf = ORB.Array) & (y.type.base.form = ORB.Char) & (xf = ORB.String) THEN
 446 |         ORG.StringRelation(rel, x, y)
 447 |       ELSIF (xf = ORB.Char) & (yf = ORB.String) & (y.b = 2) THEN
 448 |         ORG.StrToChar(y); ORG.IntRelation(rel, x, y)
 449 |       ELSIF (yf = ORB.Char) & (xf = ORB.String) & (x.b = 2) THEN
 450 |         ORG.StrToChar(x); ORG.IntRelation(rel, x, y)
 451 |       ELSIF (xf = ORB.Int) & (yf = ORB.Int) THEN ORG.IntRelation(rel,  x, y)  (*BYTE*)
 452 |       ELSE ORS.Mark("illegal comparison")
 453 |       END ;
 454 |       x.type := ORB.boolType
 455 |     ELSIF sym = ORS.in THEN
 456 |       ORS.Get(sym); CheckInt(x); SimpleExpression(y); CheckSet(y); ORG.In(x, y) ;
 457 |       x.type := ORB.boolType
 458 |     ELSIF sym = ORS.is THEN
 459 |       ORS.Get(sym); qualident(obj); TypeTest(x, obj.type, FALSE) ;
 460 |       x.type := ORB.boolType
 461 |     END
 462 |   END expression0;
 463 | 
 464 |   (* statements *)
 465 | 
 466 |   PROCEDURE StandProc(pno: LONGINT);
 467 |     VAR nap, npar: LONGINT; (*nof actual/formal parameters*)
 468 |       x, y, z: ORG.Item;
 469 |   BEGIN Check(ORS.lparen, "no (");
 470 |     npar := pno MOD 10; pno := pno DIV 10; expression(x); nap := 1;
 471 |     IF sym = ORS.comma THEN
 472 |       ORS.Get(sym); expression(y); nap := 2; z.type := ORB.noType;
 473 |       WHILE sym = ORS.comma DO ORS.Get(sym); expression(z); INC(nap) END
 474 |     ELSE y.type := ORB.noType
 475 |     END ;
 476 |     Check(ORS.rparen, "no )");
 477 |     IF (npar = nap) OR (pno IN {0, 1, 5}) THEN
 478 |       IF pno IN {0, 1} THEN (*INC, DEC*)
 479 |         CheckInt(x); CheckReadOnly(x);
 480 |         IF y.type # ORB.noType THEN CheckInt(y) END ;
 481 |         ORG.Increment(pno, x, y)
 482 |       ELSIF pno IN {2, 3} THEN (*INCL, EXCL*)
 483 |         CheckSet(x); CheckReadOnly(x); CheckInt(y); ORG.Include(pno-2, x, y)
 484 |       ELSIF pno = 4 THEN CheckBool(x); ORG.Assert(x)
 485 |       ELSIF pno = 5 THEN(*NEW*) CheckReadOnly(x);
 486 |         IF (x.type.form = ORB.Pointer) & (x.type.base.form IN {ORB.Record, ORB.Array}) THEN
 487 |           IF nap = 1 THEN
 488 |             IF x.type.base.form = ORB.Array THEN
 489 |               IF x.type.base.len >= 0 THEN ORG.MakeConstItem(y, ORB.intType, x.type.base.len)
 490 |               ELSE ORS.Mark("wrong nof params")
 491 |               END
 492 |             END
 493 |           ELSIF (nap = 2) & (x.type.base.form = ORB.Array) & (x.type.base.len < 0) THEN CheckInt(y) (*open array*)
 494 |           ELSE ORS.Mark("wrong nof params")
 495 |           END ;
 496 |           ORG.New(x, y)
 497 |         ELSE ORS.Mark("not a pointer to record or open array")
 498 |         END
 499 |       ELSIF pno = 6 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Pack(x, y)
 500 |       ELSIF pno = 7 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Unpk(x, y)
 501 |       ELSIF pno = 8 THEN
 502 |         IF x.type.form <= ORB.Set THEN ORG.Led(x) ELSE ORS.Mark("bad type") END
 503 |       ELSIF pno = 10 THEN CheckInt(x); ORG.Get(x, y)
 504 |       ELSIF pno = 11 THEN CheckInt(x); ORG.Put(x, y)
 505 |       ELSIF pno = 12 THEN CheckInt(x); CheckInt(y); CheckInt(z); ORG.Copy(x, y, z)
 506 |       ELSIF pno = 13 THEN CheckConst(x); CheckInt(x); ORG.LDPSR(x)
 507 |       ELSIF pno = 14 THEN CheckInt(x); ORG.LDREG(x, y)
 508 |       END
 509 |     ELSE ORS.Mark("wrong nof parameters")
 510 |     END
 511 |   END StandProc;
 512 | 
 513 |   PROCEDURE StatSequence;
 514 |     VAR obj: ORB.Object;
 515 |       x, y, z, w: ORG.Item;
 516 |       L0, L1, rx: LONGINT;
 517 | 
 518 |     PROCEDURE TypeCase(obj: ORB.Object; VAR L0: LONGINT);
 519 |       VAR typobj: ORB.Object; x: ORG.Item;
 520 |         orgtype: ORB.Type;  (*original type of case var*)
 521 |     BEGIN
 522 |       IF sym = ORS.ident THEN
 523 |         qualident(typobj); ORG.MakeItem(x, obj); orgtype := obj.type;
 524 |         IF typobj.class # ORB.Typ THEN ORS.Mark("not a type") END ;
 525 |         TypeTest(x, typobj.type, FALSE); obj.type := typobj.type;
 526 |         ORG.CFJump(x); Check(ORS.colon, ": expected"); StatSequence;
 527 |         ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype;
 528 |       ELSE ORS.Mark("type id expected"); Check(ORS.colon, ": expected"); StatSequence
 529 |       END
 530 |     END TypeCase;
 531 | 
 532 |     PROCEDURE TypeCasePart(obj: ORB.Object);
 533 |       VAR L0: LONGINT;
 534 |     BEGIN Check(ORS.of, "OF expected"); L0 := 0;
 535 |       WHILE sym <= ORS.bar DO
 536 |         IF sym = ORS.bar THEN ORS.Get(sym) ELSE TypeCase(obj, L0) END
 537 |       END ;
 538 |       IF sym = ORS.else THEN ORS.Get(sym); StatSequence END ;
 539 |       ORG.FixLink(L0)
 540 |     END TypeCasePart;
 541 | 
 542 |     PROCEDURE With(VAR L0: LONGINT);
 543 |       VAR obj, typobj: ORB.Object; x: ORG.Item;
 544 |         orgtype: ORB.Type;  (*original type of with var*)
 545 |     BEGIN qualident(obj);
 546 |       IF ((obj.type.form = ORB.Pointer) & (obj.class = ORB.Var) & (obj.type.base.form = ORB.Record) OR
 547 |           (obj.type.form = ORB.Record) & (obj.class = ORB.Par)) & (obj.lev > 0) THEN
 548 |         Check(ORS.colon, ": expected");
 549 |         qualident(typobj); ORG.MakeItem(x, obj); orgtype := obj.type;
 550 |         IF typobj.class # ORB.Typ THEN ORS.Mark("not a type") END ;
 551 |         TypeTest(x, typobj.type, FALSE); obj.type := typobj.type;
 552 |         ORG.CFJump(x); Check(ORS.do, "no DO"); StatSequence;
 553 |         ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype
 554 |       ELSE ORS.Mark("invalid with variable"); Check(ORS.colon, ": expected"); Check(ORS.do, "no DO"); StatSequence
 555 |       END
 556 |     END With;
 557 | 
 558 |     PROCEDURE WithPart;
 559 |       VAR L0: LONGINT;
 560 |     BEGIN L0 := 0; With(L0);
 561 |       WHILE sym <= ORS.bar DO
 562 |         IF sym = ORS.bar THEN ORS.Get(sym) ELSE With(L0) END
 563 |       END ;
 564 |       IF sym = ORS.else THEN ORS.Get(sym); StatSequence END ;
 565 |       ORG.FixLink(L0)
 566 |     END WithPart;
 567 | 
 568 |     PROCEDURE CaseLabel(VAR x: ORG.Item);
 569 |     BEGIN expression(x); CheckConst(x);
 570 |       IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x)
 571 |       ELSIF ~(x.type.form IN {ORB.Int, ORB.Char}) OR (x.a < 0) OR (x.a > 255) THEN
 572 |         ORS.Mark("invalid case label"); x.type := ORB.intType
 573 |       END
 574 |     END CaseLabel;
 575 | 
 576 |     PROCEDURE NumericCase(LabelForm: INTEGER; VAR n: INTEGER; VAR tab: ARRAY OF ORG.LabelRange);
 577 |       VAR x, y: ORG.Item; i: INTEGER;
 578 |     BEGIN
 579 |       REPEAT CaseLabel(x);
 580 |         IF x.type.form # LabelForm THEN ORS.Mark("invalid label form") END ;
 581 |         IF sym = ORS.upto THEN ORS.Get(sym); CaseLabel(y);
 582 |           IF (x.type.form # y.type.form) OR (x.a >= y.a) THEN ORS.Mark("invalid label range"); y := x END
 583 |         ELSE y := x
 584 |         END ;
 585 |         IF n < NofCases THEN (*enter label range into ordered table*) i := n;
 586 |           WHILE (i > 0) & (tab[i-1].low > y.a) DO tab[i] := tab[i-1]; DEC(i) END ;
 587 |           IF (i > 0) & (tab[i-1].high >= x.a) THEN ORS.Mark("overlapping case labels") END ;
 588 |           tab[i].low := x.a; tab[i].high := y.a; tab[i].label := ORG.Here(); INC(n)
 589 |         ELSE ORS.Mark("too many case labels")
 590 |         END ;
 591 |         IF sym = ORS.comma THEN ORS.Get(sym)
 592 |         ELSIF (sym < ORS.comma) OR (sym = ORS.semicolon) THEN ORS.Mark("comma?")
 593 |         END
 594 |       UNTIL (sym > ORS.comma) & (sym # ORS.semicolon);
 595 |       Check(ORS.colon, ": expected"); StatSequence
 596 |     END NumericCase;
 597 | 
 598 |     PROCEDURE NumericCasePart(VAR x: ORG.Item);
 599 |       VAR L0, L1, L2: LONGINT; n, labelform: INTEGER;
 600 |         tab: ARRAY NofCases OF ORG.LabelRange;  (*ordered table of label ranges*)
 601 |     BEGIN Check(ORS.of, "OF expected"); ORG.CaseHead(x, L0); n := 0; L2 := 0; labelform := x.type.form;
 602 |       WHILE sym <= ORS.bar DO
 603 |         IF sym = ORS.bar THEN ORS.Get(sym) ELSE NumericCase(labelform, n, tab); ORG.FJump(L2) END
 604 |       END ;
 605 |       IF sym = ORS.else THEN ORS.Get(sym); L1 := ORG.Here(); StatSequence; ORG.FJump(L2) ELSE L1 := 0 END ;
 606 |       ORG.CaseTail(L0, L1, n, tab); ORG.FixLink(L2)
 607 |     END NumericCasePart;
 608 | 
 609 |     PROCEDURE SkipCase;
 610 |       VAR obj: ORB.Object;
 611 |     BEGIN Check(ORS.of, "OF expected");
 612 |       WHILE sym <= ORS.bar DO
 613 |         IF sym = ORS.bar THEN ORS.Get(sym)
 614 |         ELSE (*type case assumed*)
 615 |           IF sym = ORS.ident THEN qualident(obj) END ;
 616 |           Check(ORS.colon, ": expected"); StatSequence
 617 |         END
 618 |       END ;
 619 |       IF sym = ORS.else THEN ORS.Get(sym); StatSequence END
 620 |     END SkipCase;
 621 | 
 622 |   BEGIN (* StatSequence *)
 623 |     REPEAT (*sync*) return := FALSE;
 624 |       IF ~((sym >= ORS.ident) & (sym <= ORS.for) OR (sym >= ORS.semicolon)) THEN
 625 |         ORS.Mark("statement expected");
 626 |         REPEAT ORS.Get(sym) UNTIL sym >= ORS.ident
 627 |       END ;
 628 |       IF sym = ORS.ident THEN
 629 |         qualident(obj); ORG.MakeItem(x, obj);
 630 |         IF x.mode = ORB.SProc THEN StandProc(obj.val)
 631 |         ELSE selector(x);
 632 |           IF sym = ORS.becomes THEN (*assignment*)
 633 |             ORS.Get(sym); CheckReadOnly(x); expression(y);
 634 |             IF CompTypes(x.type, y.type, FALSE) THEN
 635 |               IF (x.type.form <= ORB.Pointer) OR (x.type.form = ORB.Proc) THEN ORG.Store(x, y)
 636 |               ELSE ORG.StoreStruct(x, y)
 637 |               END
 638 |             ELSIF (x.type.form = ORB.Array) & (y.type.form = ORB.Array) & (x.type.base = y.type.base) THEN
 639 |               ORG.StoreStruct(x, y)
 640 |             ELSIF (x.type.form = ORB.Array) & (x.type.base.form = ORB.Char) & (y.type.form = ORB.String) THEN
 641 |               ORG.CopyString(x, y)
 642 |             ELSIF (x.type.form = ORB.Int) & (y.type.form = ORB.Int) THEN ORG.Store(x, y)  (*BYTE*)
 643 |             ELSIF (x.type.form = ORB.Char) & (y.type.form = ORB.String) & (y.b = 2) THEN
 644 |               ORG.StrToChar(y); ORG.Store(x, y)
 645 |             ELSE ORS.Mark("illegal assignment")
 646 |             END
 647 |           ELSIF sym = ORS.eql THEN ORS.Mark("should be :="); ORS.Get(sym); expression(y)
 648 |           ELSIF sym = ORS.lparen THEN (*procedure call*)
 649 |             ORS.Get(sym);
 650 |             IF (x.type.form IN {ORB.Proc, ORB.TProc}) & (x.type.base.form = ORB.NoTyp) THEN
 651 |               ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx)
 652 |             ELSE ORS.Mark("not a procedure"); ParamList(x)
 653 |             END
 654 |           ELSIF x.type.form = ORB.Proc THEN (*procedure call without parameters*)
 655 |             IF x.type.nofpar > 0 THEN ORS.Mark("missing parameters") END ;
 656 |             IF x.type.base.form = ORB.NoTyp THEN ORG.PrepCall(x, rx); ORG.Call(x, rx) ELSE ORS.Mark("not a procedure") END
 657 |           ELSIF x.mode = ORB.Typ THEN ORS.Mark("illegal assignment")
 658 |           ELSE ORS.Mark("not a procedure")
 659 |           END
 660 |         END
 661 |       ELSIF sym = ORS.if THEN
 662 |         ORS.Get(sym); expression(x); CheckBool(x); ORG.CFJump(x);
 663 |         Check(ORS.then, "no THEN");
 664 |         StatSequence; L0 := 0;
 665 |         WHILE sym = ORS.elsif DO
 666 |           ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); expression(x); CheckBool(x);
 667 |           ORG.CFJump(x); Check(ORS.then, "no THEN"); StatSequence
 668 |         END ;
 669 |         IF sym = ORS.else THEN ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); StatSequence
 670 |         ELSE ORG.Fixup(x)
 671 |         END ;
 672 |         ORG.FixLink(L0); Check(ORS.end, "no END")
 673 |       ELSIF sym = ORS.while THEN
 674 |         ORS.Get(sym); L0 := ORG.Here(); expression(x); CheckBool(x); ORG.CFJump(x);
 675 |         Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0);
 676 |         WHILE sym = ORS.elsif DO
 677 |           ORS.Get(sym); ORG.Fixup(x); expression(x); CheckBool(x); ORG.CFJump(x);
 678 |           Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0)
 679 |         END ;
 680 |         ORG.Fixup(x); Check(ORS.end, "no END")
 681 |       ELSIF sym = ORS.repeat THEN
 682 |         ORS.Get(sym); L0 := ORG.Here(); StatSequence;
 683 |         IF sym = ORS.until THEN
 684 |           ORS.Get(sym); expression(x); CheckBool(x); ORG.CBJump(x, L0)
 685 |         ELSE ORS.Mark("missing UNTIL")
 686 |         END
 687 |       ELSIF sym = ORS.loop THEN
 688 |         ORS.Get(sym); CheckRetro; rx := exitno; INC(looplev);
 689 |         L0 := ORG.Here(); StatSequence; ORG.BJump(L0); DEC(looplev);
 690 |         WHILE exitno > rx DO DEC(exitno); ORG.FixLink(exit[exitno]) END ;
 691 |         Check(ORS.end, "no END")
 692 |       ELSIF sym = ORS.exit THEN
 693 |         ORS.Get(sym); CheckRetro; L0 := 0; ORG.FJump(L0);
 694 |         IF looplev = 0 THEN ORS.Mark("exit not allowed")
 695 |         ELSIF exitno < maxExit THEN exit[exitno] := L0; INC(exitno)
 696 |         ELSE ORS.Mark("too many exits")
 697 |         END
 698 |       ELSIF sym = ORS.return THEN
 699 |         ORS.Get(sym);
 700 |         IF level # 0 THEN return := TRUE;
 701 |           obj := ORB.topScope; INC(obj.lev);
 702 |           IF obj.type.base.form # ORB.NoTyp THEN expression(x);
 703 |             IF ~CompTypes(obj.type.base, x.type, FALSE) THEN ORS.Mark("wrong result type") END
 704 |           ELSE x.type := ORB.noType
 705 |           END ;
 706 |           ORG.Return(obj.type.base.form, x, obj.val, obj.expo)
 707 |         ELSE ORS.Mark("return not allowed")
 708 |         END
 709 |       ELSIF sym = ORS.for THEN
 710 |         ORS.Get(sym);
 711 |         IF sym = ORS.ident THEN
 712 |           qualident(obj); ORG.MakeItem(x, obj); CheckInt(x); CheckReadOnly(x);
 713 |           IF sym = ORS.becomes THEN
 714 |             ORS.Get(sym); expression(y); CheckInt(y); ORG.For0(x, y); L0 := ORG.Here();
 715 |             Check(ORS.to, "no TO"); expression(z); CheckInt(z); obj.rdo := TRUE;
 716 |             IF sym = ORS.by THEN ORS.Get(sym); expression(w); CheckConst(w); CheckInt(w)
 717 |             ELSE ORG.MakeConstItem(w, ORB.intType, 1)
 718 |             END ;
 719 |             Check(ORS.do, "no DO"); ORG.For1(x, y, z, w, L1);
 720 |             StatSequence; Check(ORS.end, "no END");
 721 |             ORG.For2(x, y, w); ORG.BJump(L0); ORG.FixLink(L1); obj.rdo := FALSE
 722 |           ELSE ORS.Mark(":= expected")
 723 |           END
 724 |         ELSE ORS.Mark("identifier expected")
 725 |         END
 726 |       ELSIF sym = ORS.case THEN
 727 |         ORS.Get(sym); x.obj := NIL; expression(x);
 728 |         IF x.type.form IN {ORB.Int, ORB.Byte, ORB.Char} THEN NumericCasePart(x)
 729 |         ELSIF (x.obj # NIL) &
 730 |           ((x.type.form = ORB.Pointer) & (x.type.base.form = ORB.Record) OR
 731 |            (x.type.form = ORB.Record) & (x.mode = ORB.Par)) THEN TypeCasePart(x.obj)
 732 |         ELSE ORS.Mark("invalid case variable"); SkipCase
 733 |         END ;
 734 |         Check(ORS.end, "no END")
 735 |       ELSIF sym = ORS.with THEN
 736 |         ORS.Get(sym); WithPart; Check(ORS.end, "no END")
 737 |       END ;
 738 |       ORG.CheckRegs;
 739 |       IF sym = ORS.semicolon THEN ORS.Get(sym)
 740 |       ELSIF sym < ORS.semicolon THEN ORS.Mark("missing semicolon?")
 741 |       END
 742 |     UNTIL sym > ORS.semicolon
 743 |   END StatSequence;
 744 | 
 745 |   (* Types and declarations *)
 746 | 
 747 |   PROCEDURE IdentList(class: INTEGER; VAR first: ORB.Object; VAR expoone, expoall: BOOLEAN);
 748 |     VAR obj: ORB.Object;
 749 |   BEGIN expoone := FALSE; expoall := TRUE;
 750 |     IF sym = ORS.ident THEN
 751 |       ORB.NewObj(first, ORS.id, class); ORS.Get(sym); CheckExport(first.expo, expoone, expoall);
 752 |       WHILE sym = ORS.comma DO
 753 |         ORS.Get(sym);
 754 |         IF sym = ORS.ident THEN ORB.NewObj(obj, ORS.id, class); ORS.Get(sym); CheckExport(obj.expo, expoone, expoall)
 755 |         ELSE ORS.Mark("ident?")
 756 |         END
 757 |       END ;
 758 |       IF sym = ORS.colon THEN ORS.Get(sym) ELSE ORS.Mark(":?") END
 759 |     ELSE first := NIL
 760 |     END
 761 |   END IdentList;
 762 | 
 763 |   PROCEDURE ArrayType(VAR type: ORB.Type; expoone, expoall: BOOLEAN);
 764 |     VAR x: ORG.Item; typ: ORB.Type; len: LONGINT;
 765 |   BEGIN NEW(typ); typ.form := ORB.NoTyp;
 766 |     IF sym = ORS.of THEN (*open array type*)
 767 |       ORS.Get(sym); Type(typ.base, expoone, expoall); typ.len := -1; typ.size := 0;
 768 |       IF (typ.base.form = ORB.Array) & (typ.base.len < 0) THEN ORS.Mark("multi-dimensional open arrays not allowed") END
 769 |     ELSE expression(x);
 770 |       IF (x.mode = ORB.Const) & (x.type.form = ORB.Int) & (x.a >= 0) THEN len := x.a
 771 |       ELSE len := 1; ORS.Mark("not a valid length")
 772 |       END ;
 773 |       IF sym = ORS.of THEN ORS.Get(sym); Type(typ.base, expoone, expoall);
 774 |         IF (typ.base.form = ORB.Array) & (typ.base.len < 0) THEN ORS.Mark("dyn array not allowed") END
 775 |       ELSIF sym = ORS.comma THEN ORS.Get(sym); ArrayType(typ.base, expoone, expoall)
 776 |       ELSE ORS.Mark("missing OF"); typ.base := ORB.intType
 777 |       END ;
 778 |       typ.size := (len * typ.base.size + 3) DIV 4 * 4; typ.len := len
 779 |     END ;
 780 |     typ.form := ORB.Array; type := typ
 781 |   END ArrayType;
 782 | 
 783 |   PROCEDURE RecordType(VAR type: ORB.Type; expoone, expoall: BOOLEAN);
 784 |     VAR obj, obj0, new, bot, base: ORB.Object;
 785 |       typ, tp: ORB.Type;
 786 |       offset, off, n: LONGINT; fldexpoone, fldexpoall: BOOLEAN;
 787 |   BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := -level; typ.nofpar := 0; typ.len := 0; offset := 0; bot := NIL;
 788 |     IF sym = ORS.lparen THEN
 789 |       ORS.Get(sym); (*record extension*)
 790 |       IF level # 0 THEN ORS.Mark("extension of local types not implemented") END ;
 791 |       IF sym = ORS.ident THEN
 792 |         qualident(base);
 793 |         IF base.class = ORB.Typ THEN
 794 |           IF base.type.form = ORB.Record THEN typ.base := base.type
 795 |           ELSE typ.base := ORB.intType; ORS.Mark("invalid extension")
 796 |           END ;
 797 |           typ.nofpar := typ.base.nofpar + 1; (*"nofpar" here abused for extension level*)
 798 |           bot := typ.base.dsc; offset := typ.base.size
 799 |         ELSE typ.base := ORB.intType; ORS.Mark("type expected")
 800 |         END
 801 |       ELSE typ.base := ORB.intType; ORS.Mark("ident expected")
 802 |       END ;
 803 |       Check(ORS.rparen, "no )")
 804 |     END ;
 805 |     WHILE sym = ORS.ident DO  (*fields*)
 806 |       n := 0; obj := bot; fldexpoone := FALSE; fldexpoall := TRUE;
 807 |       WHILE sym = ORS.ident DO
 808 |         obj0 := obj;
 809 |         WHILE (obj0 # NIL) & (obj0.name # ORS.id) DO obj0 := obj0.next END ;
 810 |         IF obj0 # NIL THEN ORS.Mark("mult def") END ;
 811 |         NEW(new); ORS.CopyId(new.name); new.class := ORB.Fld; new.next := obj; obj := new; INC(n);
 812 |         ORS.Get(sym); CheckExport(new.expo, fldexpoone, fldexpoall);
 813 |         IF new.expo & ~expoall THEN ORS.Mark("invalid field export") END ;
 814 |         IF sym = ORS.comma THEN ORS.Get(sym) ELSIF sym # ORS.colon THEN ORS.Mark("comma expected") END
 815 |       END ;
 816 |       Check(ORS.colon, "colon expected"); Type(tp, expoone & fldexpoone, expoall & fldexpoall);
 817 |       IF (tp.form = ORB.Array) & (tp.len < 0) THEN ORS.Mark("dyn array not allowed") END ;
 818 |       IF tp.size > 1 THEN offset := (offset+3) DIV 4 * 4 END ;
 819 |       offset := offset + n * tp.size; off := offset; obj0 := obj;
 820 |       WHILE obj0 # bot DO obj0.type := tp; obj0.lev := 0; off := off - tp.size; obj0.val := off; obj0 := obj0.next END ;
 821 |       bot := obj;
 822 |       IF sym = ORS.semicolon THEN ORS.Get(sym) ELSIF sym # ORS.end THEN ORS.Mark(" ; or END") END
 823 |     END ;
 824 |     typ.form := ORB.Record; typ.dsc := bot; typ.size := (offset + 3) DIV 4 * 4; type := typ
 825 |   END RecordType;
 826 | 
 827 |   PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER);
 828 |     VAR obj, first: ORB.Object; tp: ORB.Type;
 829 |       parsize: LONGINT; cl: INTEGER; rdo, expoone, expoall: BOOLEAN;
 830 |   BEGIN
 831 |     IF sym = ORS.var THEN ORS.Get(sym); cl := ORB.Par ELSE cl := ORB.Var END ;
 832 |     IdentList(cl, first, expoone, expoall); FormalType(tp, 0); rdo := FALSE;
 833 |     IF (cl = ORB.Var) & (tp.form >= ORB.Array) THEN cl := ORB.Par; rdo := TRUE END ;
 834 |     IF (tp.form = ORB.Array) & (tp.len < 0) OR (tp.form = ORB.Record) THEN
 835 |       parsize := 2*ORG.WordSize  (*open array or record, needs second word for length or type tag*)
 836 |     ELSE parsize := ORG.WordSize
 837 |     END ;
 838 |     obj := first;
 839 |     WHILE obj # NIL DO
 840 |       INC(nofpar); obj.class := cl; obj.type := tp; obj.rdo := rdo; obj.lev := level; obj.val := adr;
 841 |       adr := adr + parsize; obj := obj.next
 842 |     END ;
 843 |     IF adr >= 52 THEN ORS.Mark("too many parameters") END
 844 |   END FPSection;
 845 | 
 846 |   PROCEDURE ProcedureType(ptype: ORB.Type; VAR parblksize: LONGINT);
 847 |     VAR obj: ORB.Object; size: LONGINT; nofpar: INTEGER;
 848 |   BEGIN ptype.base := ORB.noType; size := parblksize; nofpar := 0; ptype.dsc := NIL;
 849 |     IF sym = ORS.lparen THEN
 850 |       ORS.Get(sym);
 851 |       IF sym = ORS.rparen THEN ORS.Get(sym)
 852 |       ELSE FPSection(size, nofpar);
 853 |         WHILE sym = ORS.semicolon DO ORS.Get(sym); FPSection(size, nofpar) END ;
 854 |         Check(ORS.rparen, "no )")
 855 |       END ;
 856 |       IF sym = ORS.colon THEN  (*function*)
 857 |         ORS.Get(sym);
 858 |         IF sym = ORS.ident THEN
 859 |           qualident(obj); ptype.base := obj.type;
 860 |           IF ~((obj.class = ORB.Typ) & (obj.type.form IN {ORB.Byte .. ORB.Pointer, ORB.Proc})) THEN
 861 |             ORS.Mark("illegal function type")
 862 |           END
 863 |         ELSE ORS.Mark("type identifier expected")
 864 |         END
 865 |       END
 866 |     END ;
 867 |     ptype.nofpar := nofpar; parblksize := size
 868 |   END ProcedureType;
 869 | 
 870 |   PROCEDURE FormalType0(VAR typ: ORB.Type; dim: INTEGER);
 871 |     VAR obj: ORB.Object; dmy: LONGINT;
 872 |   BEGIN
 873 |     IF sym = ORS.ident THEN
 874 |       qualident(obj);
 875 |       IF obj.class = ORB.Typ THEN typ := obj.type ELSE ORS.Mark("not a type"); typ := ORB.intType END
 876 |     ELSIF sym = ORS.array THEN
 877 |       ORS.Get(sym); Check(ORS.of, "OF ?");
 878 |       IF dim >= 1 THEN ORS.Mark("multi-dimensional open arrays not implemented") END ;
 879 |       NEW(typ); typ.form := ORB.Array; typ.len := -1; typ.size := 2*ORG.WordSize; 
 880 |       FormalType(typ.base, dim+1)
 881 |     ELSIF sym = ORS.procedure THEN
 882 |       ORS.Get(sym); ORB.OpenScope;
 883 |       NEW(typ); typ.form := ORB.Proc; typ.size := ORG.WordSize; dmy := 0; ProcedureType(typ, dmy);
 884 |       typ.dsc := ORB.topScope.next; ORB.CloseScope
 885 |     ELSE ORS.Mark("identifier expected"); typ := ORB.noType
 886 |     END
 887 |   END FormalType0;
 888 | 
 889 |   PROCEDURE CheckRecLevel(lev: INTEGER);
 890 |   BEGIN
 891 |     IF lev # 0 THEN ORS.Mark("ptr base must be global") END
 892 |   END CheckRecLevel;
 893 | 
 894 |   PROCEDURE Type0(VAR type: ORB.Type; expoone, expoall: BOOLEAN);
 895 |     VAR dmy: LONGINT; obj: ORB.Object; ptbase: PtrBase;
 896 |   BEGIN type := ORB.intType; (*sync*)
 897 |     IF (sym # ORS.ident) & (sym < ORS.array) THEN ORS.Mark("not a type");
 898 |       REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.array)
 899 |     END ;
 900 |     IF sym = ORS.ident THEN
 901 |       qualident(obj);
 902 |       IF obj.class = ORB.Typ THEN
 903 |         IF (obj.type # NIL) & (obj.type.form # ORB.NoTyp) THEN type := obj.type END
 904 |       ELSE ORS.Mark("not a type or undefined")
 905 |       END
 906 |     ELSIF sym = ORS.array THEN ORS.Get(sym); ArrayType(type, expoone, expoall)
 907 |     ELSIF sym = ORS.record THEN
 908 |       ORS.Get(sym); RecordType(type, expoone, expoall); Check(ORS.end, "no END")
 909 |     ELSIF sym = ORS.pointer THEN
 910 |       ORS.Get(sym); Check(ORS.to, "no TO");
 911 |       NEW(type);  type.form := ORB.Pointer; type.size := ORG.WordSize; type.base := ORB.intType;
 912 |       IF sym = ORS.ident THEN
 913 |         obj := ORB.thisObj();
 914 |         IF obj # NIL THEN
 915 |           IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.Array}) THEN
 916 |             CheckRecLevel(obj.lev); type.base := obj.type
 917 |           ELSIF obj.class = ORB.Mod THEN ORS.Mark("external base type not implemented")
 918 |           ELSE ORS.Mark("no valid base type")
 919 |           END
 920 |         ELSE CheckRecLevel(level); (*enter into list of forward references to be fixed in Declarations*)
 921 |           NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase
 922 |         END ;
 923 |         ORS.Get(sym)
 924 |       ELSE Type(type.base, expoone, expoall); ORS.Mark("must point to a named type")
 925 |       END
 926 |     ELSIF sym = ORS.procedure THEN
 927 |       ORS.Get(sym); ORB.OpenScope; INC(level);
 928 |       NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; dmy := 0;
 929 |       ProcedureType(type, dmy); type.dsc := ORB.topScope.next; ORB.CloseScope; DEC(level)
 930 |     ELSE ORS.Mark("illegal type")
 931 |     END ;
 932 |     IF expoone & (type.mno <= 0) & (type.typobj # NIL) & ~type.typobj.expo THEN ORS.Mark("type not exported") END
 933 |   END Type0;
 934 | 
 935 |   PROCEDURE Declarations(VAR varsize: LONGINT);
 936 |     VAR obj, first: ORB.Object;
 937 |       x: ORG.Item; tp: ORB.Type; ptbase: PtrBase;
 938 |       expo, expoone, expoall: BOOLEAN; id: ORS.Ident;
 939 |   BEGIN (*sync*) pbsList := NIL;
 940 |     IF (sym < ORS.const) & (sym # ORS.end) & (sym # ORS.return) THEN ORS.Mark("declaration?");
 941 |       REPEAT ORS.Get(sym) UNTIL (sym >= ORS.const) OR (sym = ORS.end) OR (sym = ORS.return)
 942 |     END ;
 943 |     IF sym = ORS.const THEN
 944 |       ORS.Get(sym);
 945 |       WHILE sym = ORS.ident DO
 946 |         ORS.CopyId(id); ORS.Get(sym); CheckExport(expo, expoone, expoall);
 947 |         IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("= ?") END;
 948 |         expression(x);
 949 |         IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) END ;
 950 |         ORB.NewObj(obj, id, ORB.Const); obj.expo := expo; obj.lev := level;
 951 |         IF x.mode = ORB.Const THEN obj.type := x.type;
 952 |           IF expo & (obj.type.form = ORB.String) THEN obj.exno := exno; INC(exno) ELSE obj.exno := 0 END ;
 953 |           IF obj.type.form = ORB.String THEN obj.val := x.a (*strx*) + x.b (*len*) * C20 ELSE obj.val := x.a END
 954 |         ELSE ORS.Mark("expression not constant"); obj.type := ORB.intType
 955 |         END;
 956 |         Check(ORS.semicolon, "; missing")
 957 |       END
 958 |     END ;
 959 |     IF sym = ORS.type THEN
 960 |       ORS.Get(sym);
 961 |       WHILE sym = ORS.ident DO
 962 |         ORS.CopyId(id); ORS.Get(sym); CheckExport(expo, expoone, expoall);
 963 |         IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("=?") END ;
 964 |         Type(tp, expo, expo);
 965 |         ORB.NewObj(obj, id, ORB.Typ); obj.type := tp; obj.expo := expo; obj.lev := level;
 966 |         IF tp.typobj = NIL THEN tp.typobj := obj END ;
 967 |         IF expo & (obj.type.form = ORB.Record) THEN obj.exno := exno; INC(exno) ELSE obj.exno := 0 END ;
 968 |         IF tp.form IN {ORB.Record, ORB.Array} THEN
 969 |           ptbase := pbsList;  (*check whether this is base of a pointer type; search and fixup*)
 970 |           WHILE ptbase # NIL DO
 971 |             IF obj.name = ptbase.name THEN ptbase.type.base := obj.type END ;
 972 |             ptbase := ptbase.next
 973 |           END
 974 |         END ;
 975 |         Check(ORS.semicolon, "; missing")
 976 |       END
 977 |     END ;
 978 |     IF sym = ORS.var THEN
 979 |       ORS.Get(sym);
 980 |       WHILE sym = ORS.ident DO
 981 |         IdentList(ORB.Var, first, expoone, expoall); Type(tp, expoone, expoall);
 982 |         IF (tp.form = ORB.Array) & (tp.len < 0) THEN ORS.Mark("open array not allowed") END ;
 983 |         obj := first;
 984 |         WHILE obj # NIL DO
 985 |           obj.type := tp; obj.lev := level;
 986 |           IF tp.size > 1 THEN varsize := (varsize + 3) DIV 4 * 4 (*align*) END ;
 987 |           obj.val := varsize; varsize := varsize + obj.type.size;
 988 |           IF obj.expo THEN obj.exno := exno; INC(exno) END ;
 989 |           obj := obj.next
 990 |         END ;
 991 |         Check(ORS.semicolon, "; missing")
 992 |       END
 993 |     END ;
 994 |     varsize := (varsize + 3) DIV 4 * 4;
 995 |     ptbase := pbsList;
 996 |     WHILE ptbase # NIL DO
 997 |       IF ptbase.type.base.form = ORB.Int THEN ORS.Mark("undefined pointer base of") END ;
 998 |       ptbase := ptbase.next
 999 |     END ;
1000 |     IF (sym >= ORS.const) & (sym <= ORS.var) THEN ORS.Mark("declaration in bad order") END
1001 |   END Declarations;
1002 | 
1003 |   PROCEDURE Receiver(VAR class: INTEGER; VAR name: ORS.Ident; VAR typ, rec: ORB.Type);
1004 |     VAR obj: ORB.Object;
1005 |   BEGIN rec := NIL;
1006 |     IF sym = ORS.var THEN ORS.Get(sym); class := ORB.Par ELSE class := ORB.Var END ;
1007 |     IF sym = ORS.ident THEN ORS.CopyId(name); ORS.Get(sym) ELSE ORS.Mark("ident?") END ;
1008 |     Check(ORS.colon, ": expected");
1009 |     IF sym = ORS.ident THEN
1010 |       qualident(obj);
1011 |       IF obj.class = ORB.Typ THEN typ := obj.type;
1012 |         IF (class = ORB.Var) & (typ.form = ORB.Pointer) & (typ.base.form = ORB.Record) OR
1013 |            (class = ORB.Par) & (typ.form = ORB.Record) THEN
1014 |           IF typ.form = ORB.Pointer THEN rec := typ.base ELSE rec := typ END ;
1015 |           IF rec.mno # -level THEN ORS.Mark("must be bound to record of same scope"); rec := NIL END
1016 |         ELSE ORS.Mark("invalid receiver type")
1017 |         END
1018 |       ELSE ORS.Mark("receiver type expected")
1019 |       END
1020 |     ELSE ORS.Mark("type identifier expected")
1021 |     END ;
1022 |     Check(ORS.rparen, "no )")
1023 |   END Receiver;
1024 | 
1025 |   PROCEDURE ProcedureDecl;
1026 |     VAR proc, redef, obj: ORB.Object;
1027 |       type, typ, rec: ORB.Type;
1028 |       procid, recid: ORS.Ident;
1029 |       parblksize: LONGINT; form, class: INTEGER;
1030 |       int, body, expo, expoone, expoall: BOOLEAN;
1031 | 
1032 |     PROCEDURE Body(proc: ORB.Object; parblksize: LONGINT; int: BOOLEAN);
1033 |       VAR obj: ORB.Object; x: ORG.Item; locblksize: LONGINT;
1034 |     BEGIN Check(ORS.semicolon, "no ;"); locblksize := parblksize;
1035 |       Declarations(locblksize); obj := ORB.topScope; proc.type.dsc := obj.next;
1036 |       obj.type := proc.type; obj.val := locblksize; obj.lev := 0; obj.expo := int;  (*for RETURN statements*)
1037 |       WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ;
1038 |       ORG.FixLinkMixed(proc.type.len);  (*fix forward references generated in ORG*)
1039 |       proc.val := ORG.Here() * 4; proc.type.dsc := obj.next; DEC(fc);
1040 |       ORG.Enter(parblksize, locblksize, int);
1041 |       IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ;
1042 |       IF proc.type.base.form # ORB.NoTyp THEN  (*function procedure*)
1043 |         IF obj.lev = 0 THEN ORS.Mark("function without result")
1044 |         ELSIF ~return OR (obj.lev # 1) THEN CheckRetro
1045 |         END
1046 |       ELSIF obj.lev > 0 THEN CheckRetro
1047 |       END ;
1048 |       ORG.Return(proc.type.base.form, x, locblksize, int); Check(ORS.end, "no END");
1049 |       IF sym = ORS.ident THEN
1050 |         IF ORS.id # proc.name THEN ORS.Mark("no match") END ;
1051 |         ORS.Get(sym)
1052 |       ELSE ORS.Mark("no proc id")
1053 |       END
1054 |     END Body;
1055 | 
1056 |   BEGIN (* ProcedureDecl *) int := FALSE; body := TRUE; rec := NIL; ORS.Get(sym);
1057 |     IF sym = ORS.times THEN (*interrupt*) ORS.Get(sym); int := TRUE
1058 |     ELSIF sym = ORS.arrow THEN (*forward*) ORS.Get(sym); body := FALSE
1059 |     END ;
1060 |     IF sym = ORS.lparen THEN
1061 |       ORS.Get(sym); Receiver(class, recid, typ, rec); form := ORB.TProc;
1062 |       IF level # 0 THEN ORS.Mark("local type-bound procedures not implemented") END
1063 |     ELSE form := ORB.Proc
1064 |     END ;
1065 |     IF sym = ORS.ident THEN
1066 |       ORS.CopyId(procid); ORS.Get(sym); CheckExport(expo, expoone, expoall);
1067 |       IF int THEN parblksize := 12 ELSE parblksize := 4 END ;
1068 |       NEW(type); type.size := ORG.WordSize; type.len := 0; (*len used as heading of fixup chain of forward refs*)
1069 |       IF rec = NIL THEN  (*regular procedure*)
1070 |         proc := ORB.FindObj(procid, ORB.topScope.next);
1071 |         IF proc = NIL THEN  (*identifier not found in the symbol table*)
1072 |           ORB.NewObj(proc, procid, ORB.Const); INC(fc);
1073 |           type.form := ORB.Proc; proc.type := type; proc.val := -1; proc.lev := level; proc.expo := expo;
1074 |           IF expo THEN proc.exno := exno; INC(exno) END
1075 |         END ;
1076 |         ORB.OpenScope; INC(level); type.base := ORB.noType;
1077 |         ProcedureType(type, parblksize); type.dsc := ORB.topScope.next  (*formal parameter list*)
1078 |       ELSE  (*type-bound procedure*)
1079 |         IF rec.base # NIL THEN redef := ORB.FindObj(procid, rec.base.dsc);  (*search in base types of receiver*)
1080 |           IF (redef # NIL) & ((redef.class # ORB.Const) OR (redef.type.form # ORB.TProc)) THEN ORS.Mark("mult def") END
1081 |         ELSE redef := NIL
1082 |         END ;
1083 |         proc := ORB.FindField(procid, rec);  (*search in fields of receiver proper, but not of its base types*)
1084 |         IF proc = NIL THEN
1085 |           ORB.NewMethod(rec, proc, redef, procid); INC(fc);
1086 |           IF rec.typobj.val > 0 THEN ORS.Mark("invalid method order") ELSE DisallowMethods(rec.base) END ;
1087 |           type.form := ORB.TProc; proc.type := type; proc.val := -1; proc.expo := expo;
1088 |           IF expo THEN proc.exno := exno; INC(exno);
1089 |             IF ~typ.typobj.expo THEN ORS.Mark("receiver must be exported") END ;
1090 |             procid := "@"; ORB.NewObj(obj, procid, ORB.Const); obj.name[0] := 0X; (*dummy to preserve linear order of exno*)
1091 |             obj.type := proc.type; obj.dsc := proc; obj.exno := proc.exno; obj.expo := FALSE
1092 |           END
1093 |         END ;
1094 |         ORB.OpenScope; INC(level); type.base := ORB.noType;
1095 |         ORB.NewObj(obj, recid, class);  (*insert receiver as first parameter*)
1096 |         obj.type := typ; obj.rdo := FALSE; obj.lev := level; obj.val := parblksize;
1097 |         IF typ.form = ORB.Record THEN INC(parblksize, 2*ORG.WordSize)  (*record, needs second word for type tag*)
1098 |         ELSE INC(parblksize, ORG.WordSize)
1099 |         END ;
1100 |         ProcedureType(type, parblksize); type.dsc := ORB.topScope.next; INC(type.nofpar);  (*formal parameter list*)
1101 |         IF redef # NIL THEN  (*redefined method found*)
1102 |           IF redef.expo & typ.typobj.expo & ~proc.expo THEN ORS.Mark("overriding method must be exported")
1103 |           ELSIF ~EqualSignatures(redef.type, proc.type) THEN ORS.Mark("must match redefined method")
1104 |           END
1105 |         END
1106 |       END ;
1107 |       IF proc.type # type THEN  (*identifier found in the symbol table*)
1108 |         IF (proc.class # ORB.Const) OR (proc.type.form # form) OR (proc.val >= 0) OR ~body THEN ORS.Mark("mult def")
1109 |         ELSIF (proc.expo # expo) OR ~EqualSignatures(proc.type, type) THEN ORS.Mark("must match forward declaration")
1110 |         END
1111 |       END ;
1112 |       IF body THEN Body(proc, parblksize, int) END ;
1113 |       ORB.CloseScope; DEC(level)
1114 |     ELSE ORS.Mark("proc id expected")
1115 |     END
1116 |   END ProcedureDecl;
1117 | 
1118 |   PROCEDURE ImportList;
1119 |     VAR impid, impid1: ORS.Ident;
1120 |   BEGIN
1121 |     REPEAT ORS.Get(sym);
1122 |       IF sym = ORS.ident THEN
1123 |         ORS.CopyId(impid); ORS.Get(sym);
1124 |         IF sym = ORS.becomes THEN
1125 |           ORS.Get(sym);
1126 |           IF sym = ORS.ident THEN ORS.CopyId(impid1); ORS.Get(sym)
1127 |           ELSE ORS.Mark("id expected"); impid1 := impid
1128 |           END
1129 |         ELSE impid1 := impid
1130 |         END ;
1131 |         ORB.Import(impid, impid1)
1132 |       ELSE ORS.Mark("id expected")
1133 |       END
1134 |     UNTIL sym # ORS.comma
1135 |   END ImportList;
1136 | 
1137 |   PROCEDURE Module;
1138 |     VAR key: LONGINT;
1139 |   BEGIN Texts.WriteString(W, "  compiling "); ORS.Get(sym);
1140 |     IF sym = ORS.module THEN
1141 |       ORS.Get(sym); retro := FALSE;
1142 |       IF sym = ORS.times THEN version := 0; dc := 8; Texts.Write(W, "*"); ORS.Get(sym)
1143 |       ELSE dc := 0; version := 1;
1144 |         IF sym = ORS.arrow THEN retro := TRUE; Texts.Write(W, "^"); ORS.Get(sym) END
1145 |       END ;
1146 |       IF sym = ORS.ident THEN
1147 |         ORS.CopyId(modid); ORS.Get(sym);
1148 |         Texts.WriteString(W, modid); Texts.Append(Oberon.Log, W.buf)
1149 |       ELSE Texts.Write(W, "?"); Texts.Append(Oberon.Log, W.buf); ORS.Mark("identifier expected")
1150 |       END ;
1151 |       Check(ORS.semicolon, "no ;"); level := 0; fc := 0; exno := 1; key := 0; looplev := 0; exitno := 0;
1152 |       ORB.Init(modid); ORB.OpenScope;
1153 |       IF sym = ORS.import THEN ImportList; Check(ORS.semicolon, "; missing") END ;
1154 |       ORG.Open(version); Declarations(dc); ORG.SetDataSize((dc + 3) DIV 4 * 4);
1155 |       WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ;
1156 |       IF fc > 0 THEN ORS.Mark("undefined forward declarations") END ;
1157 |       ORG.Header;
1158 |       IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ;
1159 |       ORG.Exit;
1160 |       IF (sym = ORS.final) & (version # 0) THEN ORG.Final; ORS.Get(sym); StatSequence; ORG.Exit END ;
1161 |       Check(ORS.end, "no END");
1162 |       IF sym = ORS.ident THEN
1163 |         IF ORS.id # modid THEN ORS.Mark("no match") END ;
1164 |         ORS.Get(sym)
1165 |       ELSE ORS.Mark("identifier missing")
1166 |       END ;
1167 |       IF sym # ORS.period THEN ORS.Mark("period missing") END ;
1168 |       IF (ORS.errcnt = 0) & (version # 0) THEN
1169 |         ORB.Export(modid, newSF, key);
1170 |         IF newSF THEN Texts.WriteString(W, " new symbol file") END
1171 |       END ;
1172 |       IF ORS.errcnt = 0 THEN
1173 |         ORG.Close(modid, key, exno);
1174 |         Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteHex(W, key)
1175 |       END ;
1176 |       ORB.CloseScope; pbsList := NIL
1177 |     ELSE Texts.Write(W, "?"); Texts.Append(Oberon.Log, W.buf); ORS.Mark("must start with MODULE")
1178 |     END ;
1179 |     IF ORS.errcnt > 0 THEN Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED") END ;
1180 |     Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
1181 |   END Module;
1182 | 
1183 |   PROCEDURE Option(VAR S: Texts.Scanner);
1184 |   BEGIN newSF := FALSE;
1185 |     IF S.nextCh = "/" THEN
1186 |       Texts.Scan(S); Texts.Scan(S);
1187 |       IF (S.class = Texts.Name) & (S.s[0] = "s") THEN newSF := TRUE END
1188 |     END
1189 |   END Option;
1190 | 
1191 |   PROCEDURE Compile*;
1192 |     VAR beg, end, time: LONGINT; res: INTEGER;
1193 |       T: Texts.Text;
1194 |       S: Texts.Scanner;
1195 |   BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); res := 0;
1196 |     IF S.class = Texts.Char THEN
1197 |       IF S.c = "@" THEN
1198 |         Option(S); Oberon.GetSelection(T, beg, end, time);
1199 |         IF time >= 0 THEN ORS.Init(T, beg); Module; res := ORS.errcnt END
1200 |       ELSIF S.c = "^" THEN
1201 |         Option(S); Oberon.GetSelection(T, beg, end, time);
1202 |         IF time >= 0 THEN
1203 |           Texts.OpenScanner(S, T, beg); Texts.Scan(S);
1204 |           IF S.class = Texts.Name THEN
1205 |             NEW(T); Texts.Open(T, S.s);
1206 |             IF T.len > 0 THEN ORS.Init(T, 0); Module; res := ORS.errcnt
1207 |             ELSE Texts.WriteString(W, "  "); Texts.WriteString(W, S.s); Texts.WriteString(W, " not found"); Texts.WriteLn(W)
1208 |             END
1209 |           END
1210 |         END
1211 |       END
1212 |     ELSE
1213 |       WHILE S.class = Texts.Name DO
1214 |         NEW(T); Texts.Open(T, S.s);
1215 |         IF T.len > 0 THEN Option(S); ORS.Init(T, 0); Module; res := ORS.errcnt
1216 |         ELSE Texts.WriteString(W, "  "); Texts.WriteString(W, S.s); Texts.WriteString(W, " not found"); Texts.WriteLn(W)
1217 |         END ;
1218 |         IF (T.len # 0) & (ORS.errcnt = 0) THEN Texts.Scan(S) ELSE S.class := 0 END
1219 |       END
1220 |     END ;
1221 |     Texts.Append(Oberon.Log, W.buf); Oberon.Collect(0); Oberon.Return(res)
1222 |   END Compile;
1223 | 
1224 | BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Retro Compiler  8.3.2020 / AP 1.2.25"); Texts.WriteLn(W);
1225 |   NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType;
1226 |   expression := expression0; Type := Type0; FormalType := FormalType0
1227 | END ORP.
1228 | 


--------------------------------------------------------------------------------