upd

people.inf.ethz.ch/wirth/CompilerConstruction/IO.Mod.txt

@@ -1,30 +1,30 @@
-MODULE IO;   (*for Oberon0   NW 29.4.2017*)
-  IMPORT Texts,Oberon;
-  VAR S: Texts.Scanner;  W: Texts.Writer;
-
-  PROCEDURE OpenInput*;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S)
-  END OpenInput;
-
-  PROCEDURE ReadInt*(VAR x: LONGINT);
-  BEGIN x := S.i;  Texts.Scan(S)
-  END ReadInt;
-
-  PROCEDURE Class*(): INTEGER;
-  BEGIN RETURN S.class
-  END Class;
-
-  PROCEDURE Write*(ch: CHAR);
-  BEGIN Texts.Write(W, ch)
-  END Write;
-
-  PROCEDURE WriteInt*(x: LONGINT; n: INTEGER);
-  BEGIN Texts.WriteInt(W, x, n)
-  END WriteInt;
-
-  PROCEDURE WriteLn*;
-  BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END WriteLn;
-
-BEGIN Texts.OpenWriter(W)
-END IO.
+MODULE IO;   (*for Oberon0   NW 29.4.2017*)
+  IMPORT Texts,Oberon;
+  VAR S: Texts.Scanner;  W: Texts.Writer;
+
+  PROCEDURE OpenInput*;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S)
+  END OpenInput;
+
+  PROCEDURE ReadInt*(VAR x: LONGINT);
+  BEGIN x := S.i;  Texts.Scan(S)
+  END ReadInt;
+
+  PROCEDURE Class*(): INTEGER;
+  BEGIN RETURN S.class
+  END Class;
+
+  PROCEDURE Write*(ch: CHAR);
+  BEGIN Texts.Write(W, ch)
+  END Write;
+
+  PROCEDURE WriteInt*(x: LONGINT; n: INTEGER);
+  BEGIN Texts.WriteInt(W, x, n)
+  END WriteInt;
+
+  PROCEDURE WriteLn*;
+  BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END WriteLn;
+
+BEGIN Texts.OpenWriter(W)
+END IO.

people.inf.ethz.ch/wirth/CompilerConstruction/OSG.Mod.txt

@@ -1,559 +1,559 @@
-MODULE OSG; (* NW 19.12.94 / 20.10.07 / OSGX  9.5.2017*) 
-  IMPORT SYSTEM, Files, Texts, Oberon, OSS;
-
-  CONST MemSize = 8192;
-    (* class / mode*) Head* = 0;
-    Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5;
-    SProc* = 6; SFunc* = 7; Proc* = 8; NoTyp* = 9; Reg = 10; RegI = 11; Cond = 12;
-    SB = 13; SP = 14; LNK = 15;   (*reserved registers*)
-    (* form *) Boolean* = 0; Integer* = 1; Array* = 2; Record* = 3;
-
-  (*frequently used opcodes*)  U = 2000H;
-    Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7;
-    Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11;
-    Ldw = 0; Stw = 2;
-    BR = 0; BLR = 1; BC = 2; BL = 3;
-    MI = 0; PL = 8; EQ = 1; NE = 9; LT = 5; GE = 13; LE = 6; GT = 14;
-
-  TYPE Object* = POINTER TO ObjDesc;
-    Type* = POINTER TO TypeDesc;
-
-    Item* = RECORD
-      mode*, lev*: INTEGER;
-      type*: Type;
-      a*, b, r: LONGINT
-    END ;
-
-    ObjDesc*= RECORD
-      class*, lev*: INTEGER;
-      next*, dsc*: Object;
-      type*: Type;
-      name*: OSS.Ident;
-      val*, nofpar*: LONGINT;
-      comd*: BOOLEAN
-    END ;
-
-    TypeDesc* = RECORD
-      form*: INTEGER;
-      dsc*: Object;
-      base*: Type;
-      size*, len*, nofpar*: LONGINT
-    END ;
-  
-  VAR boolType*, intType*: Type;
-    curlev*, pc*: INTEGER;
-    curSB: INTEGER;
-    entry, fixlist, fixorgD: LONGINT;
-    RH: LONGINT;  (*register stack pointer*)
-    W: Texts.Writer;
-    relmap: ARRAY 6 OF INTEGER;
-    code*: ARRAY MemSize OF LONGINT;
-    mnemo0, mnemo1: ARRAY 16, 4 OF CHAR;  (*for decoder*)
-
-  PROCEDURE Put0(op, a, b, c: LONGINT);
-  BEGIN (*emit format-0 instruction*)
-    code[pc] := ((a*10H + b) * 10H + op) * 10000H + c; INC(pc)
-  END Put0;
-
-  PROCEDURE Put1(op, a, b, im: LONGINT);
-  BEGIN (*emit format-1 instruction*)
-    IF im < 0 THEN INC(op, 1000H) END ;  (*set v-bit*)
-    code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc)
-  END Put1;
-
-  PROCEDURE Put2(op, a, b, off: LONGINT);
-  BEGIN (*emit load/store instruction*)
-    code[pc] := (((op+8) * 10H + a) * 10H + b) * 100000H + (off MOD 10000H); INC(pc)
-  END Put2;
-
-  PROCEDURE Put3(op, cond, off: LONGINT);
-  BEGIN (*emit branch instruction*)
-    code[pc] := ((op+12) * 10H + cond) * 1000000H + (off MOD 1000000H); INC(pc)
-  END Put3;
-
-  PROCEDURE incR;
-  BEGIN
-    IF RH < SB THEN INC(RH) ELSE OSS.Mark("register stack overflow") END
-  END incR;
-
-  PROCEDURE CheckRegs*;
-  BEGIN
-    IF RH # 0 THEN
-    (*  Texts.WriteString(W, "RegStack!"); Texts.WriteInt(W, R, 4);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) *)
-      OSS.Mark("Reg Stack"); RH := 0
-    END
-  END CheckRegs;
-
-  PROCEDURE SetCC(VAR x: Item; n: LONGINT);
-  BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n
-  END SetCC;
-
-  PROCEDURE TestRange(x: LONGINT);
-  BEGIN (*16-bit entity*)
-    IF (x > 0FFFFH) OR (x < -10000H) THEN OSS.Mark("value too large") END
-  END TestRange;
-
-  PROCEDURE negated(cond: LONGINT): LONGINT;
-  BEGIN
-    IF cond < 8 THEN cond := cond+8 ELSE cond := cond-8 END ;
-    RETURN cond
-  END negated;
-
-  PROCEDURE invalSB;
-  BEGIN curSB := 1
-  END invalSB;
-
-  PROCEDURE fix(at, with: LONGINT);
-  BEGIN code[at] := code[at] DIV 1000000H * 1000000H + (with MOD 1000000H)
-  END fix;
-
-  PROCEDURE FixLink*(L: LONGINT);
-    VAR L1: LONGINT;
-  BEGIN 
-    WHILE L # 0 DO
-      IF L < MemSize THEN L1 := code[L] MOD 40000H; fix(L, pc-L-1); L := L1 END
-    END
-  END FixLink;
-  
-  PROCEDURE GetSB;
-  BEGIN
-    IF curSB = 1 THEN Put2(Ldw, SB, 0, pc-fixorgD); fixorgD := pc-1; curSB := 0 END
-  END GetSB;
-
-  PROCEDURE load(VAR x: Item);
-  BEGIN
-    IF x.mode # Reg THEN
-      IF x.mode = Var THEN
-        IF x.r > 0 THEN (*local*) Put2(Ldw, RH, SP, x.a) ELSE GetSB; Put2(Ldw, RH, SB, x.a) END ;
-        x.r := RH; incR
-      ELSIF x.mode = Par THEN Put2(Ldw, RH, x.r, x.a); Put2(Ldw, RH, RH, 0); x.r := RH; incR
-      ELSIF x.mode = Const THEN
-        IF (x.a >= 10000H) OR (x.a < -10000H) THEN OSS.Mark("const too large") END ;
-        Put1(Mov, RH, 0, x.a); x.r := RH; incR
-      ELSIF x.mode = RegI THEN Put2(Ldw, x.r, x.r, x.a)
-      ELSIF x.mode = Cond THEN
-        Put3(2, negated(x.r), 2);
-        FixLink(x.b); Put1(Mov, RH, 0, 1); Put3(2, 7, 1);
-        FixLink(x.a); Put1(Mov, RH, 0, 0); x.r := RH; incR
-      END ;
-      x.mode := Reg
-    END
-  END load;
-
-  PROCEDURE loadAdr(VAR x: Item);
-  BEGIN
-    IF x.mode = Var THEN
-      IF x.r > 0 THEN (*local*) Put1(Add, RH, SP, x.a); x.r := RH ELSE GetSB; Put1(Add, RH, SB, x.a) END ;
-      incR
-    ELSIF x.mode = Par THEN Put2(Ldw, RH, SP, x.a); Put1(Add, RH, RH, x.b); x.r := RH; incR
-    ELSIF (x.mode = RegI) & (x.a # 0) THEN Put1(Add, x.r, x.r, x.a)
-    ELSE OSS.Mark("address error") 
-    END ;
-    x.mode := Reg
-  END loadAdr;
-
-  PROCEDURE loadCond(VAR x: Item);
-  BEGIN
-    IF x.type.form = Boolean THEN
-      IF x.mode = Const THEN x.r := 15 - x.a*8 ELSE load(x); Put1(Cmp, x.r, x.r, 0); x.r := NE; DEC(RH) END ;
-      x.mode := Cond; x.a := 0; x.b := 0
-    ELSE OSS.Mark("not Boolean")
-    END
-  END loadCond;
-
-  PROCEDURE merged(L0, L1: LONGINT): LONGINT;
-    VAR L2, L3: LONGINT;
-  BEGIN 
-    IF L0 # 0 THEN
-      L3 := L0;
-      REPEAT L2 := L3; L3 := code[L2] MOD 40000H UNTIL L3 = 0;
-      code[L2] := code[L2] + L1; L1 := L0
-    END ;
-    RETURN L1
-  END merged;
-
-  (*-----------------------------------------------*)
-
-  PROCEDURE IncLevel*(n: INTEGER);
-  BEGIN curlev := curlev + n
-  END IncLevel;
-
-  PROCEDURE MakeConstItem*(VAR x: Item; typ: Type; val: LONGINT);
-  BEGIN x.mode := Const; x.type := typ; x.a := val
-  END MakeConstItem;
-
-  PROCEDURE MakeItem*(VAR x: Item; y: Object; curlev: LONGINT);
-    VAR r: LONGINT;
-  BEGIN x.mode := y.class; x.type := y.type; x.a := y.val; x.r := y.lev;
-    IF y.class = Par THEN x.b := 0 END ;
-    IF (y.lev > 0) & (y.lev # curlev) & (y.class # Const) THEN OSS.Mark("level error") END
-  END MakeItem;
-
-  PROCEDURE Field*(VAR x: Item; y: Object);   (* x := x.y *)
-  BEGIN
-    IF (x.mode = Var) OR (x.mode = RegI) THEN x.a := x.a + y.val
-    ELSIF x.mode = Par THEN Put2(Ldw, RH, x.r, x.a); x.mode := RegI; x.r := RH; x.a := y.val; incR
-    END
-  END Field;
-
-  PROCEDURE Index*(VAR x, y: Item);   (* x := x[y] *)
-    VAR s: LONGINT;
-  BEGIN
-    IF y.mode = Const THEN
-      IF (y.a < 0) OR (y.a >= x.type.len) THEN OSS.Mark("bad index") END ;
-      IF x.mode = Par THEN Put2(Ldw, RH, x.r, x.a); x.mode := RegI; x.a := 0 END ;
-      x.a := x.a + y.a * x.type.base.size
-    ELSE s := x.type.base.size;
-      IF y.mode # Reg THEN load(y) END ;
-      IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSE Put1(Mul, y.r, y.r, s) END ;
-      IF x.mode = Var THEN
-        IF x.r > 0 THEN Put0(Add, y.r, SP, y.r) ELSE GetSB; Put0(Add, y.r, SB, y.r) END ;
-        x.mode := RegI; x.r := y.r
-      ELSIF x.mode = Par THEN
-        Put2(Ldw, RH, SP, x.a); Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r
-      ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH)
-      END
-    END
-  END Index;
-  
-  (* Code generation for Boolean operators *)
-
-  PROCEDURE Not*(VAR x: Item);   (* x := ~x *)
-    VAR t: LONGINT;
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t
-  END Not;
-
-  PROCEDURE And1*(VAR x: Item);   (* x := x & *)
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    Put3(BC, negated(x.r), x.a); x.a := pc-1; FixLink(x.b); x.b := 0
-  END And1;
-
-  PROCEDURE And2*(VAR x, y: Item);
-  BEGIN
-    IF y.mode # Cond THEN loadCond(y) END ;
-    x.a := merged(y.a, x.a); x.b := y.b; x.r := y.r
-  END And2;
-
-  PROCEDURE Or1*(VAR x: Item);   (* x := x OR *)
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    Put3(BC, x.r, x.b);  x.b := pc-1; FixLink(x.a); x.a := 0
-  END Or1;
-
-  PROCEDURE Or2*(VAR x, y: Item);
-  BEGIN
-    IF y.mode # Cond THEN loadCond(y) END ;
-    x.a := y.a; x.b := merged(y.b, x.b); x.r := y.r
-  END Or2;
-
-  (* Code generation for arithmetic operators *)
-
-  PROCEDURE Neg*(VAR x: Item);   (* x := -x *)
-  BEGIN
-    IF x.mode = Const THEN x.a := -x.a
-    ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r)
-    END
-  END Neg;
-
-  PROCEDURE AddOp*(op: LONGINT; VAR x, y: Item);   (* x := x +- y *)
-  BEGIN
-    IF op = OSS.plus THEN
-      IF (x.mode = Const) & (y.mode = Const) THEN x.a := x.a + y.a
-      ELSIF y.mode = Const THEN load(x);
-        IF y.a # 0 THEN Put1(Add, x.r, x.r, y.a) END
-      ELSE load(x); load(y); Put0(Add, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
-      END
-    ELSE (*op = OSS.minus*)
-      IF (x.mode = Const) & (y.mode = Const) THEN x.a := x.a - y.a
-      ELSIF y.mode = Const THEN load(x);
-        IF y.a # 0 THEN Put1(Sub, x.r, x.r, y.a) END
-      ELSE load(x); load(y); Put0(Sub, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
-      END
-    END
-  END AddOp;
-
-  PROCEDURE MulOp*(VAR x, y: Item);   (* x := x * y *)
-  BEGIN
-    IF (x.mode = Const) & (y.mode = Const) THEN x.a := x.a * y.a
-    ELSIF (y.mode = Const) & (y.a = 2) THEN load(x); Put1(Lsl, x.r, x.r, 1)
-    ELSIF y.mode = Const THEN load(x); Put1(Mul, x.r, x.r, y.a)
-    ELSIF x.mode = Const THEN load(y); Put1(Mul, y.r, y.r, x.a); x.mode := Reg; x.r := y.r
-    ELSE load(x); load(y); Put0(Mul, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
-    END
-  END MulOp;
-
-  PROCEDURE DivOp*(op: LONGINT; VAR x, y: Item);   (* x := x op y *)
-  BEGIN
-    IF op = OSS.div THEN
-      IF (x.mode = Const) & (y.mode = Const) THEN
-        IF y.a > 0 THEN x.a := x.a DIV y.a ELSE OSS.Mark("bad divisor") END
-      ELSIF (y.mode = Const) & (y.a = 2) THEN load(x); Put1(Asr, x.r, x.r, 1)
-      ELSIF y.mode = Const THEN
-        IF y.a > 0 THEN load(x); Put1(Div, x.r, x.r, y.a) ELSE OSS.Mark("bad divisor") END
-      ELSE load(y); load(x); Put0(Div, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
-      END
-    ELSE (*op = OSS.mod*)
-      IF (x.mode = Const) & (y.mode = Const) THEN
-        IF y.a > 0 THEN x.a := x.a MOD y.a ELSE OSS.Mark("bad modulus") END
-      ELSIF (y.mode = Const) & (y.a = 2) THEN load(x); Put1(And, x.r, x.r, 1)
-      ELSIF y.mode = Const THEN
-        IF y.a > 0 THEN load(x); Put1(Div, x.r, x.r, y.a); Put0(Mov+U, x.r, 0, 0) ELSE OSS.Mark("bad modulus") END
-      ELSE load(y); load(x); Put0(Div, RH-2, x.r, y.r); Put0(Mov+U, RH-2, 0, 0); DEC(RH); x.r := RH-1
-      END
-    END
-  END DivOp;
-
-  PROCEDURE Relation*(op: INTEGER; VAR x, y: Item);   (* x := x ? y *)
-  BEGIN
-    IF y.mode = Const THEN load(x); Put1(Cmp, x.r, x.r, y.a); DEC(RH)
-    ELSE load(x); load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2)
-    END ;
-    SetCC(x, relmap[op - OSS.eql])
-  END Relation;
-  
-  PROCEDURE Store*(VAR x, y: Item); (* x := y *)
-  BEGIN load(y);
-    IF x.mode = Var THEN
-      IF x.r > 0 THEN (*local*) Put2(Stw, y.r, SP, x.a) ELSE GetSB; Put2(Stw, y.r, SB, x.a) END
-    ELSIF x.mode = Par THEN Put2(Ldw, RH, SP, x.a); Put2(Stw, y.r, RH, x.b)
-    ELSIF x.mode = RegI THEN Put2(Stw, y.r, x.r, x.a); DEC(RH)
-    ELSE OSS.Mark("illegal assignment")
-    END ;
-    DEC(RH)
-  END Store;
-
-  PROCEDURE VarParam*(VAR x: Item; ftype: Type);
-    VAR xmd: INTEGER;
-  BEGIN xmd := x.mode; loadAdr(x);
-    IF (ftype.form = Array) & (ftype.len < 0) THEN (*open array*)
-      IF x.type.len >= 0 THEN Put1(Mov, RH, 0, x.type.len) ELSE  Put2(Ldw, RH, SP, x.a+4) END ;
-      incR
-    ELSIF ftype.form = Record THEN
-      IF xmd = Par THEN Put2(Ldw, RH, SP, x.a+4); incR END
-    END
-  END VarParam;
-
-  PROCEDURE ValueParam*(VAR x: Item);
-  BEGIN load(x)
-  END ValueParam;
-
-  PROCEDURE OpenArrayParam*(VAR x: Item);
-  BEGIN loadAdr(x);
-    IF x.type.len >= 0 THEN Put1(Mov, RH, 0, x.type.len) ELSE Put2(Ldw, RH, SP, x.a+4) END ;
-    incR
-  END OpenArrayParam;
-
-  (*---------------------------------*)
-  
-  PROCEDURE CFJump*(VAR x: Item);  (*conditional forward jump*)
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    Put3(2, negated(x.r), x.a); FixLink(x.b); x.a := pc-1
-  END CFJump;
-
-  PROCEDURE FJump*(VAR L: LONGINT);  (*unconditional forward jump*)
-  BEGIN Put3(2, 7, L); L := pc-1
-  END FJump;
-
-  PROCEDURE CBJump*(VAR x: Item; L: LONGINT);  (*conditional backward jump*)
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    Put3(2, negated(x.r), L-pc-1)
-  END CBJump;
-  
-  PROCEDURE BJump*(L: LONGINT);  (*unconditional backward jump*)
-  BEGIN Put3(2, 7, L-pc-1)
-  END BJump;
-
-  PROCEDURE Call*(VAR obj: Object);
-  BEGIN Put3(3, 7, (obj.val DIV 4) - pc-1); RH := 0
-  END Call;
-
-  PROCEDURE Enter*(parblksize, locblksize: LONGINT; comd: BOOLEAN);
-    VAR a, r: LONGINT;
-  BEGIN a := 4; r := 0; Put1(Sub, SP, SP, locblksize); Put2(Stw, LNK, SP, 0);
-    WHILE a < parblksize DO Put2(Stw, r, SP, a); INC(r); INC(a, 4) END ;
-  (* IF comd THEN Put2(Ldw, SB, 0, 0) END *)
-  END Enter;
-
-  PROCEDURE Return*(size: LONGINT);
-  BEGIN Put2(Ldw, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK); RH := 0
-  END Return;
-
-  PROCEDURE Ord*(VAR x: Item);
-  BEGIN load(x); x.type := intType
-  END Ord;
-
-  PROCEDURE OpenInput*;
-  BEGIN Put3(3, 7, pc - fixlist + 101000H); fixlist := pc-1; invalSB
-  END OpenInput;
-
-  PROCEDURE ReadInt*(VAR x: Item);
-  BEGIN loadAdr(x); Put3(3, 7, pc - fixlist + 102000H); fixlist := pc-1; DEC(RH); invalSB
-  END ReadInt;
-
-  PROCEDURE eot*(VAR x: Item);
-  BEGIN Put3(3, 7, pc - fixlist + 103000H); fixlist := pc-1; Put1(Cmp, 0, 0, Texts.Int); SetCC(x, NE); invalSB
-  END eot;
-
-  PROCEDURE WriteChar*(VAR x: Item);
-  BEGIN load(x); Put3(3, 7, pc - fixlist + 104000H); fixlist:= pc-1; DEC(RH); invalSB
-  END WriteChar;
-
-  PROCEDURE WriteInt*(VAR x, y: Item);
-  BEGIN load(x); load(y); Put3(3, 7, pc - fixlist + 105000H); fixlist := pc-1; DEC(RH, 2); invalSB
-  END WriteInt;
-
-  PROCEDURE WriteLn*;
-  BEGIN Put3(3, 7, pc - fixlist + 106000H); fixlist := pc-1; invalSB
-  END WriteLn;
-
-  PROCEDURE Switch*(VAR x: Item);
-  BEGIN Put1(Mov, RH, 0, -60); Put2(Ldw, RH, RH, 0);
-    x.mode := Reg; x.type := intType; x.r := RH; INC(RH)
-  END Switch;
-
-  PROCEDURE LED*(VAR x: Item);
-  BEGIN load(x); Put1(Mov, RH, 0, -60); Put2(Stw, x.r, RH, 0); DEC(RH)
-  END LED ;
-
-  PROCEDURE Open*;
-  BEGIN curlev := 0; pc := 0; RH := 0; fixlist := 0; fixorgD := 0
-  END Open;
-
-  PROCEDURE Header*(size: LONGINT);
-  BEGIN entry := pc*4; Put1(Sub, SP, SP, 4); Put2(Stw, LNK, SP, 0); invalSB
-  END Header;
-
-  PROCEDURE MakeFileName(VAR FName: OSS.Ident; name, ext: ARRAY OF CHAR);
-    VAR i, j: INTEGER;
-  BEGIN i := 0; j := 0;  (*assume name suffix less than 4 characters*)
-    WHILE (i < OSS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ;
-    REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X;
-    FName[i] := 0X
-  END MakeFileName;
-
-  PROCEDURE Close*(VAR modid: OSS.Ident; key, datasize: LONGINT; topScope: Object);  (*write code file*)
-    VAR i, nofent, nofimp, comsize, size: INTEGER;
-      obj: Object;
-      name: OSS.Ident;
-      F: Files.File; R: Files.Rider;
-  BEGIN Put2(Ldw, LNK, SP, 0); Put1(Add, SP, SP, 4); Put3(BR, 7, LNK);
-    obj := topScope.next; comsize := 4; nofent := 1; nofimp := 1;
-    WHILE obj # NIL DO
-      IF obj.comd THEN i := 0; (*count entries and commands*)
-        WHILE obj.name[i] # 0X DO INC(i) END ;
-        i := (i+4) DIV 4 * 4; INC(comsize, i+4); INC(nofent); INC(nofimp)
-      END ;
-      obj := obj.next
-    END ;
-    size := datasize + comsize + (pc + nofimp + nofent + 1)*4;
-    MakeFileName(name, modid, ".rsc"); (*write code file*)
-    F := Files.New(name); Files.Set(R, F, 0);
-    Files.WriteString(R, modid); Files.WriteInt(R, key); Files.Write(R, 1X);   (*version*)
-    Files.WriteInt(R, size);
-    Files.WriteString(R, "IO"); Files.WriteInt(R, 3A8372E2H); Files.Write(R, 0X);  (*import*)
-    Files.WriteInt(R, 0);  (*no type descriptors*)
-    Files.WriteInt(R, datasize);  (*data*)
-    Files.WriteInt(R, 0);   (*no strings*)
-    Files.WriteInt(R, pc);  (*code len*)
-    FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ;  (*program*)
-    obj := topScope.next;
-    WHILE obj # NIL DO  (*commands*)
-      IF obj.comd THEN Files.WriteString(R, obj.name); Files.WriteInt(R, obj.val) END ;
-      obj := obj.next
-    END ;
-    Files.Write(R, 0X);
-    Files.WriteInt(R, nofent); Files.WriteInt(R, entry);   (*of program body*)
-    obj := topScope.next;
-    WHILE obj # NIL DO  (*entries*)
-      IF obj.comd THEN Files.WriteInt(R, obj.val) END ;
-      obj := obj.next
-    END ;
-    Files.WriteInt(R, -1);   (*no pointer variables*)
-    Files.WriteInt(R, fixlist); Files.WriteInt(R, fixorgD); Files.WriteInt(R, 0); Files.WriteInt(R, entry);
-    Files.Write(R, "O"); Files.Register(F)
-  END Close;
-
-  (*-------------------- output -----------------------*)
-
-  PROCEDURE WriteReg(r: LONGINT);
-  BEGIN Texts.Write(W, " ");
-    IF r < 13 THEN Texts.Write(W, "R"); Texts.WriteInt(W, r, 1)
-    ELSIF r = 13 THEN Texts.WriteString(W, "SB")
-    ELSIF r = 14 THEN Texts.WriteString(W, "SP")
-    ELSIF r = 15 THEN Texts.WriteString(W, "LNK")
-    END
-  END WriteReg;
-
-  PROCEDURE Decode*;
-    VAR i, w, a, b, c, op: LONGINT;
-  BEGIN Texts.WriteHex(W, code[0]); Texts.WriteHex(W, code[1]); Texts.WriteLn(W);
-    i := 0;
-    WHILE i < pc DO
-      w := code[i];
-      a := w DIV 1000000H MOD 10H;
-      b := w DIV 100000H MOD 10H;
-      Texts.WriteInt(W, i, 4); Texts.WriteHex(W, w); Texts.Write(W, 9X);
-      IF ASR(w, 31) = 0 THEN  (*~p:  register instruction*)
-        op := w DIV 10000H MOD 10H;
-        Texts.WriteString(W, mnemo0[op]); WriteReg(a); WriteReg(b);
-        IF ~ODD(w DIV 40000000H) THEN (*~q*) WriteReg(w MOD 10H)
-        ELSE c := w MOD 10000H;;
-          IF ODD(w DIV 10000000H) THEN (*v*) c := c + 0FFFF0000H END ;
-          Texts.WriteInt(W, c, 8)
-        END
-      ELSIF ~ODD(w DIV 40000000H) THEN  (*load/store*)
-        IF ODD(w DIV 20000000H) THEN Texts.WriteString(W, "STW ") ELSE Texts.WriteString(W, "LDW") END ;
-        WriteReg(a); WriteReg(b); Texts.WriteInt(W, w MOD 100000H, 8)
-      ELSE  (*Branch instr*)
-        Texts.Write(W, "B");
-        IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ;
-        Texts.WriteString(W, mnemo1[a]);
-        IF ~ODD(w DIV 20000000H) THEN WriteReg(w MOD 10H) ELSE
-          w := w MOD 1000000H;
-          IF w >= 800000H THEN w := w - 1000000H END ;
-          Texts.WriteInt(W, w, 8)
-        END
-      END ;
-      Texts.WriteLn(W); INC(i)
-    END ;
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END Decode;
-
-  PROCEDURE HexCh(k: LONGINT): CHAR;
-  BEGIN
-    IF k >= 10 THEN INC(k, 27H) END ; 
-    RETURN CHR(k+30H)
-  END HexCh;
-
-BEGIN Texts.OpenWriter(W);
-  NEW(boolType); boolType.form := Boolean; boolType.size := 4;
-  NEW(intType); intType.form := Integer; intType.size := 4;
-  relmap[0] := EQ; relmap[1] := NE; relmap[2] := LT; relmap[3] := LE; relmap[4] := GT; relmap[5] := GE;
-  mnemo0[Mov] := "MOV";
-  mnemo0[Lsl] := "LSL";
-  mnemo0[Asr] := "ASR";
-  mnemo0[Ror] := "ROR";
-  mnemo0[And] := "AND";
-  mnemo0[Ann] := "ANN";
-  mnemo0[Ior] := "IOR";
-  mnemo0[Xor] := "XOR";
-  mnemo0[Add] := "ADD";
-  mnemo0[Sub] := "SUB";
-  mnemo0[Mul] := "MUL";
-  mnemo0[Div] := "DIV";
-  mnemo1[PL] := "PL ";
-  mnemo1[MI] := "MI ";
-  mnemo1[EQ] := "EQ ";
-  mnemo1[NE] := "NE ";
-  mnemo1[LT] := "LT ";
-  mnemo1[GE] := "GE ";
-  mnemo1[LE] := "LE ";
-  mnemo1[GT] := "GT ";
-  mnemo1[15] := "NO ";
-END OSG.
+MODULE OSG; (* NW 19.12.94 / 20.10.07 / OSGX  9.5.2017*) 
+  IMPORT SYSTEM, Files, Texts, Oberon, OSS;
+
+  CONST MemSize = 8192;
+    (* class / mode*) Head* = 0;
+    Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5;
+    SProc* = 6; SFunc* = 7; Proc* = 8; NoTyp* = 9; Reg = 10; RegI = 11; Cond = 12;
+    SB = 13; SP = 14; LNK = 15;   (*reserved registers*)
+    (* form *) Boolean* = 0; Integer* = 1; Array* = 2; Record* = 3;
+
+  (*frequently used opcodes*)  U = 2000H;
+    Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7;
+    Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11;
+    Ldw = 0; Stw = 2;
+    BR = 0; BLR = 1; BC = 2; BL = 3;
+    MI = 0; PL = 8; EQ = 1; NE = 9; LT = 5; GE = 13; LE = 6; GT = 14;
+
+  TYPE Object* = POINTER TO ObjDesc;
+    Type* = POINTER TO TypeDesc;
+
+    Item* = RECORD
+      mode*, lev*: INTEGER;
+      type*: Type;
+      a*, b, r: LONGINT
+    END ;
+
+    ObjDesc*= RECORD
+      class*, lev*: INTEGER;
+      next*, dsc*: Object;
+      type*: Type;
+      name*: OSS.Ident;
+      val*, nofpar*: LONGINT;
+      comd*: BOOLEAN
+    END ;
+
+    TypeDesc* = RECORD
+      form*: INTEGER;
+      dsc*: Object;
+      base*: Type;
+      size*, len*, nofpar*: LONGINT
+    END ;
+  
+  VAR boolType*, intType*: Type;
+    curlev*, pc*: INTEGER;
+    curSB: INTEGER;
+    entry, fixlist, fixorgD: LONGINT;
+    RH: LONGINT;  (*register stack pointer*)
+    W: Texts.Writer;
+    relmap: ARRAY 6 OF INTEGER;
+    code*: ARRAY MemSize OF LONGINT;
+    mnemo0, mnemo1: ARRAY 16, 4 OF CHAR;  (*for decoder*)
+
+  PROCEDURE Put0(op, a, b, c: LONGINT);
+  BEGIN (*emit format-0 instruction*)
+    code[pc] := ((a*10H + b) * 10H + op) * 10000H + c; INC(pc)
+  END Put0;
+
+  PROCEDURE Put1(op, a, b, im: LONGINT);
+  BEGIN (*emit format-1 instruction*)
+    IF im < 0 THEN INC(op, 1000H) END ;  (*set v-bit*)
+    code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc)
+  END Put1;
+
+  PROCEDURE Put2(op, a, b, off: LONGINT);
+  BEGIN (*emit load/store instruction*)
+    code[pc] := (((op+8) * 10H + a) * 10H + b) * 100000H + (off MOD 10000H); INC(pc)
+  END Put2;
+
+  PROCEDURE Put3(op, cond, off: LONGINT);
+  BEGIN (*emit branch instruction*)
+    code[pc] := ((op+12) * 10H + cond) * 1000000H + (off MOD 1000000H); INC(pc)
+  END Put3;
+
+  PROCEDURE incR;
+  BEGIN
+    IF RH < SB THEN INC(RH) ELSE OSS.Mark("register stack overflow") END
+  END incR;
+
+  PROCEDURE CheckRegs*;
+  BEGIN
+    IF RH # 0 THEN
+    (*  Texts.WriteString(W, "RegStack!"); Texts.WriteInt(W, R, 4);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) *)
+      OSS.Mark("Reg Stack"); RH := 0
+    END
+  END CheckRegs;
+
+  PROCEDURE SetCC(VAR x: Item; n: LONGINT);
+  BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n
+  END SetCC;
+
+  PROCEDURE TestRange(x: LONGINT);
+  BEGIN (*16-bit entity*)
+    IF (x > 0FFFFH) OR (x < -10000H) THEN OSS.Mark("value too large") END
+  END TestRange;
+
+  PROCEDURE negated(cond: LONGINT): LONGINT;
+  BEGIN
+    IF cond < 8 THEN cond := cond+8 ELSE cond := cond-8 END ;
+    RETURN cond
+  END negated;
+
+  PROCEDURE invalSB;
+  BEGIN curSB := 1
+  END invalSB;
+
+  PROCEDURE fix(at, with: LONGINT);
+  BEGIN code[at] := code[at] DIV 1000000H * 1000000H + (with MOD 1000000H)
+  END fix;
+
+  PROCEDURE FixLink*(L: LONGINT);
+    VAR L1: LONGINT;
+  BEGIN 
+    WHILE L # 0 DO
+      IF L < MemSize THEN L1 := code[L] MOD 40000H; fix(L, pc-L-1); L := L1 END
+    END
+  END FixLink;
+  
+  PROCEDURE GetSB;
+  BEGIN
+    IF curSB = 1 THEN Put2(Ldw, SB, 0, pc-fixorgD); fixorgD := pc-1; curSB := 0 END
+  END GetSB;
+
+  PROCEDURE load(VAR x: Item);
+  BEGIN
+    IF x.mode # Reg THEN
+      IF x.mode = Var THEN
+        IF x.r > 0 THEN (*local*) Put2(Ldw, RH, SP, x.a) ELSE GetSB; Put2(Ldw, RH, SB, x.a) END ;
+        x.r := RH; incR
+      ELSIF x.mode = Par THEN Put2(Ldw, RH, x.r, x.a); Put2(Ldw, RH, RH, 0); x.r := RH; incR
+      ELSIF x.mode = Const THEN
+        IF (x.a >= 10000H) OR (x.a < -10000H) THEN OSS.Mark("const too large") END ;
+        Put1(Mov, RH, 0, x.a); x.r := RH; incR
+      ELSIF x.mode = RegI THEN Put2(Ldw, x.r, x.r, x.a)
+      ELSIF x.mode = Cond THEN
+        Put3(2, negated(x.r), 2);
+        FixLink(x.b); Put1(Mov, RH, 0, 1); Put3(2, 7, 1);
+        FixLink(x.a); Put1(Mov, RH, 0, 0); x.r := RH; incR
+      END ;
+      x.mode := Reg
+    END
+  END load;
+
+  PROCEDURE loadAdr(VAR x: Item);
+  BEGIN
+    IF x.mode = Var THEN
+      IF x.r > 0 THEN (*local*) Put1(Add, RH, SP, x.a); x.r := RH ELSE GetSB; Put1(Add, RH, SB, x.a) END ;
+      incR
+    ELSIF x.mode = Par THEN Put2(Ldw, RH, SP, x.a); Put1(Add, RH, RH, x.b); x.r := RH; incR
+    ELSIF (x.mode = RegI) & (x.a # 0) THEN Put1(Add, x.r, x.r, x.a)
+    ELSE OSS.Mark("address error") 
+    END ;
+    x.mode := Reg
+  END loadAdr;
+
+  PROCEDURE loadCond(VAR x: Item);
+  BEGIN
+    IF x.type.form = Boolean THEN
+      IF x.mode = Const THEN x.r := 15 - x.a*8 ELSE load(x); Put1(Cmp, x.r, x.r, 0); x.r := NE; DEC(RH) END ;
+      x.mode := Cond; x.a := 0; x.b := 0
+    ELSE OSS.Mark("not Boolean")
+    END
+  END loadCond;
+
+  PROCEDURE merged(L0, L1: LONGINT): LONGINT;
+    VAR L2, L3: LONGINT;
+  BEGIN 
+    IF L0 # 0 THEN
+      L3 := L0;
+      REPEAT L2 := L3; L3 := code[L2] MOD 40000H UNTIL L3 = 0;
+      code[L2] := code[L2] + L1; L1 := L0
+    END ;
+    RETURN L1
+  END merged;
+
+  (*-----------------------------------------------*)
+
+  PROCEDURE IncLevel*(n: INTEGER);
+  BEGIN curlev := curlev + n
+  END IncLevel;
+
+  PROCEDURE MakeConstItem*(VAR x: Item; typ: Type; val: LONGINT);
+  BEGIN x.mode := Const; x.type := typ; x.a := val
+  END MakeConstItem;
+
+  PROCEDURE MakeItem*(VAR x: Item; y: Object; curlev: LONGINT);
+    VAR r: LONGINT;
+  BEGIN x.mode := y.class; x.type := y.type; x.a := y.val; x.r := y.lev;
+    IF y.class = Par THEN x.b := 0 END ;
+    IF (y.lev > 0) & (y.lev # curlev) & (y.class # Const) THEN OSS.Mark("level error") END
+  END MakeItem;
+
+  PROCEDURE Field*(VAR x: Item; y: Object);   (* x := x.y *)
+  BEGIN
+    IF (x.mode = Var) OR (x.mode = RegI) THEN x.a := x.a + y.val
+    ELSIF x.mode = Par THEN Put2(Ldw, RH, x.r, x.a); x.mode := RegI; x.r := RH; x.a := y.val; incR
+    END
+  END Field;
+
+  PROCEDURE Index*(VAR x, y: Item);   (* x := x[y] *)
+    VAR s: LONGINT;
+  BEGIN
+    IF y.mode = Const THEN
+      IF (y.a < 0) OR (y.a >= x.type.len) THEN OSS.Mark("bad index") END ;
+      IF x.mode = Par THEN Put2(Ldw, RH, x.r, x.a); x.mode := RegI; x.a := 0 END ;
+      x.a := x.a + y.a * x.type.base.size
+    ELSE s := x.type.base.size;
+      IF y.mode # Reg THEN load(y) END ;
+      IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSE Put1(Mul, y.r, y.r, s) END ;
+      IF x.mode = Var THEN
+        IF x.r > 0 THEN Put0(Add, y.r, SP, y.r) ELSE GetSB; Put0(Add, y.r, SB, y.r) END ;
+        x.mode := RegI; x.r := y.r
+      ELSIF x.mode = Par THEN
+        Put2(Ldw, RH, SP, x.a); Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r
+      ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH)
+      END
+    END
+  END Index;
+  
+  (* Code generation for Boolean operators *)
+
+  PROCEDURE Not*(VAR x: Item);   (* x := ~x *)
+    VAR t: LONGINT;
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t
+  END Not;
+
+  PROCEDURE And1*(VAR x: Item);   (* x := x & *)
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    Put3(BC, negated(x.r), x.a); x.a := pc-1; FixLink(x.b); x.b := 0
+  END And1;
+
+  PROCEDURE And2*(VAR x, y: Item);
+  BEGIN
+    IF y.mode # Cond THEN loadCond(y) END ;
+    x.a := merged(y.a, x.a); x.b := y.b; x.r := y.r
+  END And2;
+
+  PROCEDURE Or1*(VAR x: Item);   (* x := x OR *)
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    Put3(BC, x.r, x.b);  x.b := pc-1; FixLink(x.a); x.a := 0
+  END Or1;
+
+  PROCEDURE Or2*(VAR x, y: Item);
+  BEGIN
+    IF y.mode # Cond THEN loadCond(y) END ;
+    x.a := y.a; x.b := merged(y.b, x.b); x.r := y.r
+  END Or2;
+
+  (* Code generation for arithmetic operators *)
+
+  PROCEDURE Neg*(VAR x: Item);   (* x := -x *)
+  BEGIN
+    IF x.mode = Const THEN x.a := -x.a
+    ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r)
+    END
+  END Neg;
+
+  PROCEDURE AddOp*(op: LONGINT; VAR x, y: Item);   (* x := x +- y *)
+  BEGIN
+    IF op = OSS.plus THEN
+      IF (x.mode = Const) & (y.mode = Const) THEN x.a := x.a + y.a
+      ELSIF y.mode = Const THEN load(x);
+        IF y.a # 0 THEN Put1(Add, x.r, x.r, y.a) END
+      ELSE load(x); load(y); Put0(Add, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
+      END
+    ELSE (*op = OSS.minus*)
+      IF (x.mode = Const) & (y.mode = Const) THEN x.a := x.a - y.a
+      ELSIF y.mode = Const THEN load(x);
+        IF y.a # 0 THEN Put1(Sub, x.r, x.r, y.a) END
+      ELSE load(x); load(y); Put0(Sub, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
+      END
+    END
+  END AddOp;
+
+  PROCEDURE MulOp*(VAR x, y: Item);   (* x := x * y *)
+  BEGIN
+    IF (x.mode = Const) & (y.mode = Const) THEN x.a := x.a * y.a
+    ELSIF (y.mode = Const) & (y.a = 2) THEN load(x); Put1(Lsl, x.r, x.r, 1)
+    ELSIF y.mode = Const THEN load(x); Put1(Mul, x.r, x.r, y.a)
+    ELSIF x.mode = Const THEN load(y); Put1(Mul, y.r, y.r, x.a); x.mode := Reg; x.r := y.r
+    ELSE load(x); load(y); Put0(Mul, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
+    END
+  END MulOp;
+
+  PROCEDURE DivOp*(op: LONGINT; VAR x, y: Item);   (* x := x op y *)
+  BEGIN
+    IF op = OSS.div THEN
+      IF (x.mode = Const) & (y.mode = Const) THEN
+        IF y.a > 0 THEN x.a := x.a DIV y.a ELSE OSS.Mark("bad divisor") END
+      ELSIF (y.mode = Const) & (y.a = 2) THEN load(x); Put1(Asr, x.r, x.r, 1)
+      ELSIF y.mode = Const THEN
+        IF y.a > 0 THEN load(x); Put1(Div, x.r, x.r, y.a) ELSE OSS.Mark("bad divisor") END
+      ELSE load(y); load(x); Put0(Div, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
+      END
+    ELSE (*op = OSS.mod*)
+      IF (x.mode = Const) & (y.mode = Const) THEN
+        IF y.a > 0 THEN x.a := x.a MOD y.a ELSE OSS.Mark("bad modulus") END
+      ELSIF (y.mode = Const) & (y.a = 2) THEN load(x); Put1(And, x.r, x.r, 1)
+      ELSIF y.mode = Const THEN
+        IF y.a > 0 THEN load(x); Put1(Div, x.r, x.r, y.a); Put0(Mov+U, x.r, 0, 0) ELSE OSS.Mark("bad modulus") END
+      ELSE load(y); load(x); Put0(Div, RH-2, x.r, y.r); Put0(Mov+U, RH-2, 0, 0); DEC(RH); x.r := RH-1
+      END
+    END
+  END DivOp;
+
+  PROCEDURE Relation*(op: INTEGER; VAR x, y: Item);   (* x := x ? y *)
+  BEGIN
+    IF y.mode = Const THEN load(x); Put1(Cmp, x.r, x.r, y.a); DEC(RH)
+    ELSE load(x); load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2)
+    END ;
+    SetCC(x, relmap[op - OSS.eql])
+  END Relation;
+  
+  PROCEDURE Store*(VAR x, y: Item); (* x := y *)
+  BEGIN load(y);
+    IF x.mode = Var THEN
+      IF x.r > 0 THEN (*local*) Put2(Stw, y.r, SP, x.a) ELSE GetSB; Put2(Stw, y.r, SB, x.a) END
+    ELSIF x.mode = Par THEN Put2(Ldw, RH, SP, x.a); Put2(Stw, y.r, RH, x.b)
+    ELSIF x.mode = RegI THEN Put2(Stw, y.r, x.r, x.a); DEC(RH)
+    ELSE OSS.Mark("illegal assignment")
+    END ;
+    DEC(RH)
+  END Store;
+
+  PROCEDURE VarParam*(VAR x: Item; ftype: Type);
+    VAR xmd: INTEGER;
+  BEGIN xmd := x.mode; loadAdr(x);
+    IF (ftype.form = Array) & (ftype.len < 0) THEN (*open array*)
+      IF x.type.len >= 0 THEN Put1(Mov, RH, 0, x.type.len) ELSE  Put2(Ldw, RH, SP, x.a+4) END ;
+      incR
+    ELSIF ftype.form = Record THEN
+      IF xmd = Par THEN Put2(Ldw, RH, SP, x.a+4); incR END
+    END
+  END VarParam;
+
+  PROCEDURE ValueParam*(VAR x: Item);
+  BEGIN load(x)
+  END ValueParam;
+
+  PROCEDURE OpenArrayParam*(VAR x: Item);
+  BEGIN loadAdr(x);
+    IF x.type.len >= 0 THEN Put1(Mov, RH, 0, x.type.len) ELSE Put2(Ldw, RH, SP, x.a+4) END ;
+    incR
+  END OpenArrayParam;
+
+  (*---------------------------------*)
+  
+  PROCEDURE CFJump*(VAR x: Item);  (*conditional forward jump*)
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    Put3(2, negated(x.r), x.a); FixLink(x.b); x.a := pc-1
+  END CFJump;
+
+  PROCEDURE FJump*(VAR L: LONGINT);  (*unconditional forward jump*)
+  BEGIN Put3(2, 7, L); L := pc-1
+  END FJump;
+
+  PROCEDURE CBJump*(VAR x: Item; L: LONGINT);  (*conditional backward jump*)
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    Put3(2, negated(x.r), L-pc-1)
+  END CBJump;
+  
+  PROCEDURE BJump*(L: LONGINT);  (*unconditional backward jump*)
+  BEGIN Put3(2, 7, L-pc-1)
+  END BJump;
+
+  PROCEDURE Call*(VAR obj: Object);
+  BEGIN Put3(3, 7, (obj.val DIV 4) - pc-1); RH := 0
+  END Call;
+
+  PROCEDURE Enter*(parblksize, locblksize: LONGINT; comd: BOOLEAN);
+    VAR a, r: LONGINT;
+  BEGIN a := 4; r := 0; Put1(Sub, SP, SP, locblksize); Put2(Stw, LNK, SP, 0);
+    WHILE a < parblksize DO Put2(Stw, r, SP, a); INC(r); INC(a, 4) END ;
+  (* IF comd THEN Put2(Ldw, SB, 0, 0) END *)
+  END Enter;
+
+  PROCEDURE Return*(size: LONGINT);
+  BEGIN Put2(Ldw, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK); RH := 0
+  END Return;
+
+  PROCEDURE Ord*(VAR x: Item);
+  BEGIN load(x); x.type := intType
+  END Ord;
+
+  PROCEDURE OpenInput*;
+  BEGIN Put3(3, 7, pc - fixlist + 101000H); fixlist := pc-1; invalSB
+  END OpenInput;
+
+  PROCEDURE ReadInt*(VAR x: Item);
+  BEGIN loadAdr(x); Put3(3, 7, pc - fixlist + 102000H); fixlist := pc-1; DEC(RH); invalSB
+  END ReadInt;
+
+  PROCEDURE eot*(VAR x: Item);
+  BEGIN Put3(3, 7, pc - fixlist + 103000H); fixlist := pc-1; Put1(Cmp, 0, 0, Texts.Int); SetCC(x, NE); invalSB
+  END eot;
+
+  PROCEDURE WriteChar*(VAR x: Item);
+  BEGIN load(x); Put3(3, 7, pc - fixlist + 104000H); fixlist:= pc-1; DEC(RH); invalSB
+  END WriteChar;
+
+  PROCEDURE WriteInt*(VAR x, y: Item);
+  BEGIN load(x); load(y); Put3(3, 7, pc - fixlist + 105000H); fixlist := pc-1; DEC(RH, 2); invalSB
+  END WriteInt;
+
+  PROCEDURE WriteLn*;
+  BEGIN Put3(3, 7, pc - fixlist + 106000H); fixlist := pc-1; invalSB
+  END WriteLn;
+
+  PROCEDURE Switch*(VAR x: Item);
+  BEGIN Put1(Mov, RH, 0, -60); Put2(Ldw, RH, RH, 0);
+    x.mode := Reg; x.type := intType; x.r := RH; INC(RH)
+  END Switch;
+
+  PROCEDURE LED*(VAR x: Item);
+  BEGIN load(x); Put1(Mov, RH, 0, -60); Put2(Stw, x.r, RH, 0); DEC(RH)
+  END LED ;
+
+  PROCEDURE Open*;
+  BEGIN curlev := 0; pc := 0; RH := 0; fixlist := 0; fixorgD := 0
+  END Open;
+
+  PROCEDURE Header*(size: LONGINT);
+  BEGIN entry := pc*4; Put1(Sub, SP, SP, 4); Put2(Stw, LNK, SP, 0); invalSB
+  END Header;
+
+  PROCEDURE MakeFileName(VAR FName: OSS.Ident; name, ext: ARRAY OF CHAR);
+    VAR i, j: INTEGER;
+  BEGIN i := 0; j := 0;  (*assume name suffix less than 4 characters*)
+    WHILE (i < OSS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ;
+    REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X;
+    FName[i] := 0X
+  END MakeFileName;
+
+  PROCEDURE Close*(VAR modid: OSS.Ident; key, datasize: LONGINT; topScope: Object);  (*write code file*)
+    VAR i, nofent, nofimp, comsize, size: INTEGER;
+      obj: Object;
+      name: OSS.Ident;
+      F: Files.File; R: Files.Rider;
+  BEGIN Put2(Ldw, LNK, SP, 0); Put1(Add, SP, SP, 4); Put3(BR, 7, LNK);
+    obj := topScope.next; comsize := 4; nofent := 1; nofimp := 1;
+    WHILE obj # NIL DO
+      IF obj.comd THEN i := 0; (*count entries and commands*)
+        WHILE obj.name[i] # 0X DO INC(i) END ;
+        i := (i+4) DIV 4 * 4; INC(comsize, i+4); INC(nofent); INC(nofimp)
+      END ;
+      obj := obj.next
+    END ;
+    size := datasize + comsize + (pc + nofimp + nofent + 1)*4;
+    MakeFileName(name, modid, ".rsc"); (*write code file*)
+    F := Files.New(name); Files.Set(R, F, 0);
+    Files.WriteString(R, modid); Files.WriteInt(R, key); Files.Write(R, 1X);   (*version*)
+    Files.WriteInt(R, size);
+    Files.WriteString(R, "IO"); Files.WriteInt(R, 3A8372E2H); Files.Write(R, 0X);  (*import*)
+    Files.WriteInt(R, 0);  (*no type descriptors*)
+    Files.WriteInt(R, datasize);  (*data*)
+    Files.WriteInt(R, 0);   (*no strings*)
+    Files.WriteInt(R, pc);  (*code len*)
+    FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ;  (*program*)
+    obj := topScope.next;
+    WHILE obj # NIL DO  (*commands*)
+      IF obj.comd THEN Files.WriteString(R, obj.name); Files.WriteInt(R, obj.val) END ;
+      obj := obj.next
+    END ;
+    Files.Write(R, 0X);
+    Files.WriteInt(R, nofent); Files.WriteInt(R, entry);   (*of program body*)
+    obj := topScope.next;
+    WHILE obj # NIL DO  (*entries*)
+      IF obj.comd THEN Files.WriteInt(R, obj.val) END ;
+      obj := obj.next
+    END ;
+    Files.WriteInt(R, -1);   (*no pointer variables*)
+    Files.WriteInt(R, fixlist); Files.WriteInt(R, fixorgD); Files.WriteInt(R, 0); Files.WriteInt(R, entry);
+    Files.Write(R, "O"); Files.Register(F)
+  END Close;
+
+  (*-------------------- output -----------------------*)
+
+  PROCEDURE WriteReg(r: LONGINT);
+  BEGIN Texts.Write(W, " ");
+    IF r < 13 THEN Texts.Write(W, "R"); Texts.WriteInt(W, r, 1)
+    ELSIF r = 13 THEN Texts.WriteString(W, "SB")
+    ELSIF r = 14 THEN Texts.WriteString(W, "SP")
+    ELSIF r = 15 THEN Texts.WriteString(W, "LNK")
+    END
+  END WriteReg;
+
+  PROCEDURE Decode*;
+    VAR i, w, a, b, c, op: LONGINT;
+  BEGIN Texts.WriteHex(W, code[0]); Texts.WriteHex(W, code[1]); Texts.WriteLn(W);
+    i := 0;
+    WHILE i < pc DO
+      w := code[i];
+      a := w DIV 1000000H MOD 10H;
+      b := w DIV 100000H MOD 10H;
+      Texts.WriteInt(W, i, 4); Texts.WriteHex(W, w); Texts.Write(W, 9X);
+      IF ASR(w, 31) = 0 THEN  (*~p:  register instruction*)
+        op := w DIV 10000H MOD 10H;
+        Texts.WriteString(W, mnemo0[op]); WriteReg(a); WriteReg(b);
+        IF ~ODD(w DIV 40000000H) THEN (*~q*) WriteReg(w MOD 10H)
+        ELSE c := w MOD 10000H;;
+          IF ODD(w DIV 10000000H) THEN (*v*) c := c + 0FFFF0000H END ;
+          Texts.WriteInt(W, c, 8)
+        END
+      ELSIF ~ODD(w DIV 40000000H) THEN  (*load/store*)
+        IF ODD(w DIV 20000000H) THEN Texts.WriteString(W, "STW ") ELSE Texts.WriteString(W, "LDW") END ;
+        WriteReg(a); WriteReg(b); Texts.WriteInt(W, w MOD 100000H, 8)
+      ELSE  (*Branch instr*)
+        Texts.Write(W, "B");
+        IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ;
+        Texts.WriteString(W, mnemo1[a]);
+        IF ~ODD(w DIV 20000000H) THEN WriteReg(w MOD 10H) ELSE
+          w := w MOD 1000000H;
+          IF w >= 800000H THEN w := w - 1000000H END ;
+          Texts.WriteInt(W, w, 8)
+        END
+      END ;
+      Texts.WriteLn(W); INC(i)
+    END ;
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END Decode;
+
+  PROCEDURE HexCh(k: LONGINT): CHAR;
+  BEGIN
+    IF k >= 10 THEN INC(k, 27H) END ; 
+    RETURN CHR(k+30H)
+  END HexCh;
+
+BEGIN Texts.OpenWriter(W);
+  NEW(boolType); boolType.form := Boolean; boolType.size := 4;
+  NEW(intType); intType.form := Integer; intType.size := 4;
+  relmap[0] := EQ; relmap[1] := NE; relmap[2] := LT; relmap[3] := LE; relmap[4] := GT; relmap[5] := GE;
+  mnemo0[Mov] := "MOV";
+  mnemo0[Lsl] := "LSL";
+  mnemo0[Asr] := "ASR";
+  mnemo0[Ror] := "ROR";
+  mnemo0[And] := "AND";
+  mnemo0[Ann] := "ANN";
+  mnemo0[Ior] := "IOR";
+  mnemo0[Xor] := "XOR";
+  mnemo0[Add] := "ADD";
+  mnemo0[Sub] := "SUB";
+  mnemo0[Mul] := "MUL";
+  mnemo0[Div] := "DIV";
+  mnemo1[PL] := "PL ";
+  mnemo1[MI] := "MI ";
+  mnemo1[EQ] := "EQ ";
+  mnemo1[NE] := "NE ";
+  mnemo1[LT] := "LT ";
+  mnemo1[GE] := "GE ";
+  mnemo1[LE] := "LE ";
+  mnemo1[GT] := "GT ";
+  mnemo1[15] := "NO ";
+END OSG.

people.inf.ethz.ch/wirth/CompilerConstruction/OSP.Mod.txt

@@ -1,502 +1,502 @@
-MODULE OSP; (* NW 23.9.93 / 9,5.2017   OSPX*)
-  IMPORT Texts, Oberon, OSS, OSG;
-
-  CONST WordSize = 4;
-  VAR sym, level: INTEGER;
-    topScope, universe, dummy: OSG.Object;
-    expression: PROCEDURE (VAR x: OSG.Item);  (*to avoid forward reference*)
-    W: Texts.Writer;
-  
-  PROCEDURE NewObj(VAR obj: OSG.Object; class: INTEGER);
-    VAR new, x: OSG.Object;
-  BEGIN x := topScope;
-    WHILE (x.next # NIL) & (x.next.name # OSS.id) DO x := x.next END ;
-    IF x.next = NIL THEN
-      NEW(new); new.name := OSS.id; new.class := class; new.next := NIL;
-      x.next := new; obj := new
-    ELSE obj := x.next; OSS.Mark("mult def")
-    END
-  END NewObj;
-  
-  PROCEDURE find(VAR obj: OSG.Object);
-    VAR s, x: OSG.Object;
-  BEGIN s := topScope;
-    REPEAT x := s.next;
-      WHILE (x # NIL) & (x.name # OSS.id) DO x := x.next END ;
-       s := s.dsc
-    UNTIL (x # NIL) OR (s = NIL);
-    IF x = NIL THEN x := dummy; OSS.Mark("undef") END ;
-    obj := x
-  END find;
-
-  PROCEDURE FindField(VAR obj: OSG.Object; list: OSG.Object);
-  BEGIN
-    WHILE (list # NIL) & (list.name # OSS.id) DO list := list.next END ;
-    IF list # NIL THEN obj := list ELSE OSS.Mark("undef"); obj := dummy END
-  END FindField;
-
-  PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR);
-  BEGIN
-    IF sym = s THEN OSS.Get(sym) ELSE OSS.Mark(msg) END
-  END Check;
-
-  PROCEDURE CheckInt(VAR x: OSG.Item);
-  BEGIN
-    IF x.type.form # OSG.Integer THEN OSS.Mark("not integer") END
-  END CheckInt;
-
-  PROCEDURE CheckBool(VAR x: OSG.Item);
-  BEGIN
-    IF x.type.form # OSG.Boolean THEN OSS.Mark("not Boolean") END
-  END CheckBool;
-
-  PROCEDURE OpenScope;
-    VAR s: OSG.Object;
-  BEGIN NEW(s); s.class := OSG.Head; s.dsc := topScope; s.next := NIL; topScope := s
-  END OpenScope;
-
-  PROCEDURE CloseScope;
-  BEGIN topScope := topScope.dsc
-  END CloseScope;
-
-  (* -------------------- Parser ---------------------*)
-
-  PROCEDURE selector(VAR x: OSG.Item);
-    VAR y: OSG.Item; obj: OSG.Object;
-  BEGIN
-    WHILE (sym = OSS.lbrak) OR (sym = OSS.period) DO
-      IF sym = OSS.lbrak THEN
-        OSS.Get(sym); expression(y);
-        IF x.type.form = OSG.Array THEN
-          CheckInt(y); OSG.Index(x, y); x.type := x.type.base
-        ELSE OSS.Mark("not an array")
-        END ;
-        Check(OSS.rbrak, "no ]")
-      ELSE (*period*) OSS.Get(sym);
-        IF sym = OSS.ident THEN
-          IF x.type.form = OSG.Record THEN
-            FindField(obj, x.type.dsc); OSS.Get(sym);
-            IF obj # NIL THEN OSG.Field(x, obj); x.type := obj.type END
-          ELSE OSS.Mark("not a record")
-          END
-        ELSE OSS.Mark("ident?")
-        END
-      END
-    END
-  END selector;
-
-  PROCEDURE CompTypes(t0, t1: OSG.Type): BOOLEAN;
-  BEGIN (*Compatible Types*)
-    RETURN (t0 = t1)
-      OR (t0.form = OSG.Array) & (t1.form = OSG.Array) & CompTypes(t0.base, t1.base)
-  END CompTypes;
-
-  PROCEDURE Parameter(par: OSG.Object);
-    VAR x: OSG.Item; varpar: BOOLEAN;
-  BEGIN expression(x);
-    IF par # NIL THEN
-      varpar := par.class = OSG.Par;
-      IF CompTypes(par.type, x.type) THEN
-        IF ~varpar THEN OSG.ValueParam(x)
-        ELSE OSG.VarParam(x, par.type)
-        END
-      ELSIF (x.type.form = OSG.Array) & (par.type.form = OSG.Array) &
-          (x.type.base.form = par.type.base.form) & (par.type.len < 0) THEN
-        OSG.OpenArrayParam(x)
-      ELSE OSS.Mark("incompatible parameters")
-      END
-    END
-  END Parameter;
-
-  PROCEDURE ParamList(VAR obj: OSG.Object);
-    VAR n: INTEGER; par: OSG.Object;
-  BEGIN par := obj.dsc; n := 0;
-    IF sym # OSS.rparen THEN
-      Parameter(par); n := 1;
-      WHILE sym <= OSS.comma DO
-        Check(sym, "comma?");
-        IF par # NIL THEN par := par.next END ;
-        INC(n); Parameter(par)
-      END ;
-      Check(OSS.rparen, ") missing")
-    ELSE OSS.Get(sym);
-    END ;
-    IF n < obj.nofpar THEN OSS.Mark("too few params")
-    ELSIF n > obj.nofpar THEN OSS.Mark("too many params")
-    END
-  END ParamList;
-
-  PROCEDURE StandFunc(VAR x: OSG.Item; fctno: LONGINT);
-    VAR y, z: OSG.Item;
-  BEGIN
-    IF sym = OSS.lparen THEN
-      OSS.Get(sym);
-      IF fctno = 0 THEN (*ORD*) expression(x); OSG.Ord(x)
-      ELSIF fctno = 1 THEN (*eot*) OSG.eot(x)
-      ELSE (*fctno = 2*) OSG.Switch(x)
-      END ;
-      IF sym = OSS.rparen THEN OSS.Get(sym) ELSE OSS.Mark("rparen expected") END
-    ELSE OSS.Mark("param missing"); OSG.MakeConstItem(x, OSG.intType, 0)
-    END
-  END StandFunc;
-
-  PROCEDURE factor(VAR x: OSG.Item);
-    VAR obj: OSG.Object;
-  BEGIN (*sync*)
-    IF (sym < OSS.char) OR (sym > OSS.ident) THEN OSS.Mark("expression expected");
-      REPEAT OSS.Get(sym) UNTIL (sym >= OSS.int) & (sym <= OSS.ident)
-    END ;
-    IF sym = OSS.ident THEN
-      find(obj); OSS.Get(sym);
-      IF obj.class = OSG.SFunc THEN
-        IF obj.type = NIL THEN OSS.Mark("not a function"); obj.type := OSG.intType END ;
-        StandFunc(x, obj.val); x.type := obj.type
-      ELSE OSG.MakeItem(x, obj, level); selector(x)
-      END
-    ELSIF sym = OSS.int THEN OSG.MakeConstItem(x, OSG.intType, OSS.val); OSS.Get(sym)
-    ELSIF sym = OSS.char THEN OSG.MakeConstItem(x, OSG.intType, OSS.val); OSS.Get(sym)
-    ELSIF sym = OSS.lparen THEN
-      OSS.Get(sym);
-      IF sym # OSS.rparen THEN expression(x) END ;
-      Check(OSS.rparen, "no )")
-    ELSIF sym = OSS.not THEN OSS.Get(sym); factor(x); CheckBool(x); OSG.Not(x)
-    ELSIF sym = OSS.false THEN OSS.Get(sym); OSG.MakeConstItem(x, OSG.boolType, 0)
-    ELSIF sym = OSS.true THEN OSS.Get(sym); OSG.MakeConstItem(x, OSG.boolType, 1)
-    ELSE OSS.Mark("factor?"); OSG.MakeItem(x, dummy, level)
-    END
-  END factor;
-
-  PROCEDURE term(VAR x: OSG.Item);
-    VAR y: OSG.Item; op: INTEGER;
-  BEGIN factor(x);
-    WHILE (sym >= OSS.times) & (sym <= OSS.and) DO
-      op := sym; OSS.Get(sym);
-      IF op = OSS.times THEN CheckInt(x); factor(y); CheckInt(y); OSG.MulOp(x, y)
-      ELSIF (op = OSS.div) OR (op = OSS.mod) THEN CheckInt(x); factor(y); CheckInt(y); OSG.DivOp(op, x, y)
-      ELSE (*op = and*) CheckBool(x); OSG.And1(x); factor(y); CheckBool(y); OSG.And2(x, y)
-      END
-    END
-  END term;
-
-  PROCEDURE SimpleExpression(VAR x: OSG.Item);
-    VAR y: OSG.Item; op: INTEGER;
-  BEGIN
-    IF sym = OSS.plus THEN OSS.Get(sym); term(x); CheckInt(x)
-    ELSIF sym = OSS.minus THEN OSS.Get(sym); term(x); CheckInt(x); OSG.Neg(x)
-    ELSE term(x)
-    END;
-    WHILE (sym >= OSS.plus) & (sym <= OSS.or) DO
-      op := sym; OSS.Get(sym);
-      IF op = OSS.or THEN OSG.Or1(x); CheckBool(x); term(y); CheckBool(y); OSG.Or2(x, y)
-      ELSE CheckInt(x); term(y); CheckInt(y); OSG.AddOp(op, x, y)
-      END
-    END
-  END SimpleExpression;
-
-  PROCEDURE expression0(VAR x: OSG.Item);
-    VAR y: OSG.Item; op: INTEGER;
-  BEGIN SimpleExpression(x);
-    IF (sym >= OSS.eql) & (sym <= OSS.geq) THEN
-      op := sym; OSS.Get(sym); SimpleExpression(y);
-      IF x.type = y.type THEN OSG.Relation(op, x, y) ELSE OSS.Mark("incompatible types") END ;
-      x.type := OSG.boolType
-    END
-  END expression0;
-
-  PROCEDURE StandProc(pno: LONGINT);
-    VAR x, y: OSG.Item;
-  BEGIN
-    IF pno = 0 THEN  OSG.OpenInput
-    ELSIF pno IN {1, 2, 3, 5} THEN
-      IF sym = OSS.lparen THEN OSS.Get(sym); expression(x);
-        IF pno = 1 THEN OSG.ReadInt(x);
-        ELSIF pno = 2 THEN
-          IF sym = OSS.comma THEN OSS.Get(sym); expression(y); OSG.WriteInt(x, y) ELSE OSS.Mark("no comma") END
-        ELSIF pno = 3 THEN OSG.WriteChar(x)
-        ELSIF pno = 5 THEN OSG.LED(x)
-            END ;
-            IF sym = OSS.rparen THEN OSS.Get(sym) ELSE OSS.Mark("no rparen") END
-          ELSE OSS.Mark(" missing lparen")
-          END
-    ELSIF pno = 4 THEN  OSG.WriteLn
-    ELSE OSS.Mark("undef proc")
-    END
-  END StandProc;
-
-  PROCEDURE StatSequence;
-    VAR par, obj: OSG.Object; x, y: OSG.Item; n, L: LONGINT;
-  BEGIN (* StatSequence *)
-    REPEAT (*sync*) obj := NIL;
-      IF ~((sym = OSS.ident) OR (sym >= OSS.if) & (sym <= OSS.repeat) OR (sym >= OSS.semicolon)) THEN
-        OSS.Mark("statement expected");
-        REPEAT OSS.Get(sym) UNTIL (sym = OSS.ident) OR (sym >= OSS.if)
-      END ;
-      IF sym = OSS.ident THEN
-        find(obj); OSS.Get(sym);
-        IF obj.class = OSG.SProc THEN StandProc(obj.val)
-        ELSE OSG.MakeItem(x, obj, level); selector(x);
-          IF sym = OSS.becomes THEN (*assignment*)
-            OSS.Get(sym); expression(y);
-            IF (x.type.form IN {OSG.Boolean, OSG.Integer}) & (x.type.form = y.type.form) THEN OSG.Store(x, y)
-            ELSE OSS.Mark("incompatible assignment")
-            END
-          ELSIF sym = OSS.eql THEN OSS.Mark("should be :="); OSS.Get(sym); expression(y)
-          ELSIF sym = OSS.lparen THEN (*procedure call*)
-            OSS.Get(sym);
-            IF (obj.class = OSG.Proc) & (obj.type = NIL) THEN ParamList(obj); OSG.Call(obj);
-            ELSE OSS.Mark("not a procedure")
-            END
-          ELSIF obj.class = OSG.Proc THEN (*procedure call without parameters*)
-            IF obj.nofpar > 0 THEN OSS.Mark("missing parameters") END ;
-            IF obj.type = NIL THEN OSG.Call(obj) ELSE OSS.Mark("not a procedure") END
-          ELSIF (obj.class = OSG.SProc) & (obj.val = 3) THEN OSG.WriteLn
-          ELSIF obj.class = OSG.Typ THEN OSS.Mark("illegal assignment")
-          ELSE OSS.Mark("not a procedure")
-          END
-        END
-      ELSIF sym = OSS.if THEN
-        OSS.Get(sym); expression(x); CheckBool(x); OSG.CFJump(x); Check(OSS.then, "no THEN");
-        StatSequence; L := 0;
-        WHILE sym = OSS.elsif DO
-          OSS.Get(sym); OSG.FJump(L); OSG.FixLink(x.a); expression(x); CheckBool(x); OSG.CFJump(x);
-          IF sym = OSS.then THEN OSS.Get(sym) ELSE OSS.Mark("THEN?") END ;
-          StatSequence
-        END ;
-        IF sym = OSS.else THEN
-          OSS.Get(sym); OSG.FJump(L); OSG.FixLink(x.a); StatSequence
-        ELSE OSG.FixLink(x.a)
-        END ;
-        OSG.FixLink(L);
-        IF sym = OSS.end THEN OSS.Get(sym) ELSE OSS.Mark("END?") END
-      ELSIF sym = OSS.while THEN
-        OSS.Get(sym); L := OSG.pc; expression(x); CheckBool(x); OSG.CFJump(x);
-        Check(OSS.do, "no DO"); StatSequence; OSG.BJump(L); OSG.FixLink(x.a);
-        Check(OSS.end, "no END")
-      ELSIF sym = OSS.repeat THEN
-        OSS.Get(sym); L := OSG.pc; StatSequence;
-        IF sym = OSS.until THEN
-          OSS.Get(sym); expression(x); CheckBool(x); OSG.CBJump(x, L)
-        ELSE OSS.Mark("missing UNTIL"); OSS.Get(sym)
-        END        
-      END ;
-      OSG.CheckRegs;
-      IF sym = OSS.semicolon THEN OSS.Get(sym)
-      ELSIF sym < OSS.semicolon THEN OSS.Mark("missing semicolon?")
-      END
-    UNTIL sym > OSS.semicolon
-  END StatSequence;
-  
-  PROCEDURE IdentList(class: INTEGER; VAR first: OSG.Object);
-    VAR obj: OSG.Object;
-  BEGIN
-    IF sym = OSS.ident THEN
-      NewObj(first, class); OSS.Get(sym);
-      WHILE sym = OSS.comma DO
-        OSS.Get(sym);
-        IF sym = OSS.ident THEN NewObj(obj, class); OSS.Get(sym)
-        ELSE OSS.Mark("ident?")
-        END
-      END;
-      Check(OSS.colon, "no :")
-    END
-  END IdentList;
-  
-  PROCEDURE Type(VAR type: OSG.Type);
-    VAR obj, first: OSG.Object; x: OSG.Item; tp: OSG.Type;
-  BEGIN type := OSG.intType; (*sync*)
-    IF (sym # OSS.ident) & (sym < OSS.array) THEN OSS.Mark("type?");
-      REPEAT OSS.Get(sym) UNTIL (sym = OSS.ident) OR (sym >= OSS.array)
-    END ;
-    IF sym = OSS.ident THEN
-      find(obj); OSS.Get(sym);
-      IF obj.class = OSG.Typ THEN type := obj.type ELSE OSS.Mark("type?") END
-    ELSIF sym = OSS.array THEN
-      OSS.Get(sym); expression(x);
-      IF (x.mode # OSG.Const) OR (x.a < 0) THEN OSS.Mark("bad index") END ;
-      IF sym = OSS.of THEN OSS.Get(sym) ELSE OSS.Mark("OF?") END ;
-      Type(tp); NEW(type); type.form := OSG.Array; type.base := tp;
-      type.len := x.a; type.size := type.len * tp.size
-    ELSIF sym = OSS.record THEN
-      OSS.Get(sym); NEW(type); type.form := OSG.Record; type.size := 0; OpenScope;
-      REPEAT
-        IF sym = OSS.ident THEN
-          IdentList(OSG.Fld, first); Type(tp); obj := first;
-          WHILE obj # NIL DO
-            obj.type := tp; obj.val := type.size; type.size := type.size + obj.type.size; obj := obj.next
-          END
-        END ;
-        IF sym = OSS.semicolon THEN OSS.Get(sym)
-        ELSIF sym = OSS.ident THEN OSS.Mark("; ?")
-        END
-      UNTIL sym # OSS.ident;
-      type.dsc := topScope.next; CloseScope; Check(OSS.end, "no END")
-    ELSE OSS.Mark("ident?")  
-    END
-  END Type;
-
-  PROCEDURE Declarations(VAR varsize: LONGINT);
-    VAR obj, first: OSG.Object;
-      x: OSG.Item; tp: OSG.Type; L: LONGINT;
-  BEGIN (*sync*)
-    IF (sym < OSS.const) & (sym # OSS.end) THEN OSS.Mark("declaration?");
-      REPEAT OSS.Get(sym) UNTIL (sym >= OSS.const) OR (sym = OSS.end)
-    END ;
-    IF sym = OSS.const THEN
-      OSS.Get(sym);
-      WHILE sym = OSS.ident DO
-        NewObj(obj, OSG.Const); OSS.Get(sym);
-        IF sym = OSS.eql THEN OSS.Get(sym) ELSE OSS.Mark("=?") END;
-        expression(x);
-        IF x.mode = OSG.Const THEN obj.val := x.a; obj.type := x.type
-        ELSE OSS.Mark("expression not constant")
-        END ;
-        Check(OSS.semicolon, "; expected")
-      END
-    END ;
-    IF sym = OSS.type THEN
-      OSS.Get(sym);
-      WHILE sym = OSS.ident DO
-        NewObj(obj, OSG.Typ); OSS.Get(sym);
-        IF sym = OSS.eql THEN OSS.Get(sym) ELSE OSS.Mark("=?") END ; 
-        Type(obj.type); Check(OSS.semicolon, "; expected")
-      END
-    END ;
-    IF sym = OSS.var THEN
-      OSS.Get(sym);
-      WHILE sym = OSS.ident DO
-        IdentList(OSG.Var, first); Type(tp);
-        obj := first;
-        WHILE obj # NIL DO
-          obj.type := tp; obj.lev := level;
-          obj.val := varsize; varsize := varsize + obj.type.size; obj := obj.next
-        END ;
-        Check(OSS.semicolon, "; expected")
-      END
-    END ;
-    IF (sym >= OSS.const) & (sym <= OSS.var) THEN OSS.Mark("declaration in bad order") END
-  END Declarations;
-
-  PROCEDURE ProcedureDecl;
-    CONST marksize = 4;
-    VAR proc, obj: OSG.Object;
-      procid: OSS.Ident;
-      nofpar: INTEGER;
-      locblksize, parblksize: LONGINT;
-      
-    PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER);
-      VAR obj, first: OSG.Object; tp: OSG.Type; parsize: LONGINT;
-    BEGIN
-      IF sym = OSS.var THEN OSS.Get(sym); IdentList(OSG.Par, first)
-      ELSE IdentList(OSG.Var, first)
-      END ;
-      IF sym = OSS.ident THEN
-        find(obj); OSS.Get(sym);
-        IF obj.class = OSG.Typ THEN tp := obj.type ELSE OSS.Mark("type?"); tp := OSG.intType END
-      ELSE OSS.Mark("ident?"); tp := OSG.intType
-      END ;
-      IF first.class = OSG.Var THEN
-        parsize := tp.size;
-        IF tp.form >= OSG.Array THEN OSS.Mark("no struct params") END ;
-      ELSE parsize := WordSize
-      END ;
-      obj := first;
-      WHILE obj # NIL DO
-        INC(nofpar); obj.type := tp; obj.lev := level; obj.val := adr; adr := adr + parsize;
-        obj := obj.next
-      END
-    END FPSection;
-    
-  BEGIN (* ProcedureDecl *) OSS.Get(sym);
-    IF sym = OSS.ident THEN
-      procid := OSS.id; NewObj(proc, OSG.Proc); OSS.Get(sym); parblksize := marksize; nofpar := 0;
-    (* Texts.Write(W, "%"); Texts.WriteInt(W, sym, 4); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); *)
-      OpenScope;  INC(level); proc.val := -1;
-      IF sym = OSS.times THEN proc.comd := TRUE; OSS.Get(sym) ELSE proc.comd := FALSE END ;
-      IF sym = OSS.lparen THEN
-        OSS.Get(sym);
-        IF sym = OSS.rparen THEN OSS.Get(sym)
-        ELSE FPSection(parblksize, nofpar);
-          WHILE sym = OSS.semicolon DO OSS.Get(sym); FPSection(parblksize, nofpar) END ;
-          IF sym = OSS.rparen THEN OSS.Get(sym) ELSE OSS.Mark(")?") END ;
-          IF proc.comd THEN OSS.Mark("no params allowed") END
-        END
-      END ;
-      locblksize := parblksize; proc.type := NIL; proc.dsc := topScope.next; proc.nofpar := nofpar;
-      Check(OSS.semicolon, "; expected");
-      Declarations(locblksize); proc.dsc := topScope.next;
-      WHILE sym = OSS.procedure DO
-        ProcedureDecl; Check(OSS.semicolon, "; expected")
-      END ;
-      proc.val := OSG.pc * 4; OSG.Enter(parblksize, locblksize, proc.comd);
-      IF sym = OSS.begin THEN OSS.Get(sym); StatSequence END ;
-      Check(OSS.end, "no END");
-      IF sym = OSS.ident THEN
-        IF procid # OSS.id THEN OSS.Mark("no match") END ;
-        OSS.Get(sym)
-      END ;
-      OSG.Return(locblksize); DEC(level); CloseScope
-    END
-  END ProcedureDecl;
-
-  PROCEDURE Module;
-    VAR modid: OSS.Ident; dc: LONGINT;
-  BEGIN Texts.WriteString(W, "  compiling ");
-    IF sym = OSS.module THEN
-      OSS.Get(sym); OSG.Open; OpenScope; dc := 0; level := 0;
-      IF sym = OSS.ident THEN
-        modid := OSS.id; OSS.Get(sym);
-        Texts.WriteString(W, modid); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-      ELSE OSS.Mark("ident?")
-      END ;
-      Check(OSS.semicolon, "; expected");
-      Declarations(dc);
-      WHILE sym = OSS.procedure DO ProcedureDecl; Check(OSS.semicolon, "; expected") END ;
-      OSG.Header(dc);
-      IF sym = OSS.begin THEN OSS.Get(sym); StatSequence END ;
-      Check(OSS.end, "no END");
-      IF sym = OSS.ident THEN
-        IF modid # OSS.id THEN OSS.Mark("no match") END ;
-        OSS.Get(sym)
-      ELSE OSS.Mark("ident?")
-      END ;
-      IF sym # OSS.period THEN OSS.Mark(". ?") END ;
-      IF ~OSS.error THEN
-        OSG.Close(modid, 1, dc, topScope); Texts.WriteString(W, "code generated "); Texts.WriteString(W, modid);
-        Texts.WriteInt(W, OSG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-      END ;
-      CloseScope
-    ELSE OSS.Mark("MODULE?")
-    END
-  END Module;
-  
-  PROCEDURE Compile*;
-    VAR beg, end, time: LONGINT; T: Texts.Text;
-  BEGIN Oberon.GetSelection(T, beg, end, time);
-    IF time >= 0 THEN OSS.Init(T, beg); OSS.Get(sym); Module END
-  END Compile;
-
-  PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; n: LONGINT;  type: OSG.Type);
-    VAR obj: OSG.Object;
-  BEGIN NEW(obj);
-    obj.class := cl; obj.val := n; obj.name := name; obj.type := type; obj.dsc := NIL;
-    obj.next := topScope.next; topScope.next := obj
-  END enter; 
-
-BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "Oberon-0 Compiler OSP  9.5.2017");
-  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-  NEW(dummy); dummy.class := OSG.Var; dummy.type := OSG.intType; dummy.val := 0;
-  expression := expression0;
-  topScope := NIL; OpenScope;;
-  enter("ORD", OSG.SFunc, 0, OSG.intType);
-  enter("eot", OSG.SFunc, 1, OSG.boolType);
-  enter("Switch", OSG.SFunc, 2, OSG.intType);
-  enter("OpenInput", OSG.SProc, 0, NIL);
-  enter("ReadInt", OSG.SProc, 1, NIL);
-  enter("WriteInt", OSG.SProc, 2, NIL);
-  enter("WriteChar", OSG.SProc, 3, NIL);
-  enter("WriteLn", OSG.SProc, 4, NIL);
-  enter("LED", OSG.SProc, 5, NIL);
-  enter("BOOLEAN", OSG.Typ, 0, OSG.boolType);
-  enter("INTEGER", OSG.Typ, 1, OSG.intType);
-  universe := topScope
-END OSP.
+MODULE OSP; (* NW 23.9.93 / 9,5.2017   OSPX*)
+  IMPORT Texts, Oberon, OSS, OSG;
+
+  CONST WordSize = 4;
+  VAR sym, level: INTEGER;
+    topScope, universe, dummy: OSG.Object;
+    expression: PROCEDURE (VAR x: OSG.Item);  (*to avoid forward reference*)
+    W: Texts.Writer;
+  
+  PROCEDURE NewObj(VAR obj: OSG.Object; class: INTEGER);
+    VAR new, x: OSG.Object;
+  BEGIN x := topScope;
+    WHILE (x.next # NIL) & (x.next.name # OSS.id) DO x := x.next END ;
+    IF x.next = NIL THEN
+      NEW(new); new.name := OSS.id; new.class := class; new.next := NIL;
+      x.next := new; obj := new
+    ELSE obj := x.next; OSS.Mark("mult def")
+    END
+  END NewObj;
+  
+  PROCEDURE find(VAR obj: OSG.Object);
+    VAR s, x: OSG.Object;
+  BEGIN s := topScope;
+    REPEAT x := s.next;
+      WHILE (x # NIL) & (x.name # OSS.id) DO x := x.next END ;
+       s := s.dsc
+    UNTIL (x # NIL) OR (s = NIL);
+    IF x = NIL THEN x := dummy; OSS.Mark("undef") END ;
+    obj := x
+  END find;
+
+  PROCEDURE FindField(VAR obj: OSG.Object; list: OSG.Object);
+  BEGIN
+    WHILE (list # NIL) & (list.name # OSS.id) DO list := list.next END ;
+    IF list # NIL THEN obj := list ELSE OSS.Mark("undef"); obj := dummy END
+  END FindField;
+
+  PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR);
+  BEGIN
+    IF sym = s THEN OSS.Get(sym) ELSE OSS.Mark(msg) END
+  END Check;
+
+  PROCEDURE CheckInt(VAR x: OSG.Item);
+  BEGIN
+    IF x.type.form # OSG.Integer THEN OSS.Mark("not integer") END
+  END CheckInt;
+
+  PROCEDURE CheckBool(VAR x: OSG.Item);
+  BEGIN
+    IF x.type.form # OSG.Boolean THEN OSS.Mark("not Boolean") END
+  END CheckBool;
+
+  PROCEDURE OpenScope;
+    VAR s: OSG.Object;
+  BEGIN NEW(s); s.class := OSG.Head; s.dsc := topScope; s.next := NIL; topScope := s
+  END OpenScope;
+
+  PROCEDURE CloseScope;
+  BEGIN topScope := topScope.dsc
+  END CloseScope;
+
+  (* -------------------- Parser ---------------------*)
+
+  PROCEDURE selector(VAR x: OSG.Item);
+    VAR y: OSG.Item; obj: OSG.Object;
+  BEGIN
+    WHILE (sym = OSS.lbrak) OR (sym = OSS.period) DO
+      IF sym = OSS.lbrak THEN
+        OSS.Get(sym); expression(y);
+        IF x.type.form = OSG.Array THEN
+          CheckInt(y); OSG.Index(x, y); x.type := x.type.base
+        ELSE OSS.Mark("not an array")
+        END ;
+        Check(OSS.rbrak, "no ]")
+      ELSE (*period*) OSS.Get(sym);
+        IF sym = OSS.ident THEN
+          IF x.type.form = OSG.Record THEN
+            FindField(obj, x.type.dsc); OSS.Get(sym);
+            IF obj # NIL THEN OSG.Field(x, obj); x.type := obj.type END
+          ELSE OSS.Mark("not a record")
+          END
+        ELSE OSS.Mark("ident?")
+        END
+      END
+    END
+  END selector;
+
+  PROCEDURE CompTypes(t0, t1: OSG.Type): BOOLEAN;
+  BEGIN (*Compatible Types*)
+    RETURN (t0 = t1)
+      OR (t0.form = OSG.Array) & (t1.form = OSG.Array) & CompTypes(t0.base, t1.base)
+  END CompTypes;
+
+  PROCEDURE Parameter(par: OSG.Object);
+    VAR x: OSG.Item; varpar: BOOLEAN;
+  BEGIN expression(x);
+    IF par # NIL THEN
+      varpar := par.class = OSG.Par;
+      IF CompTypes(par.type, x.type) THEN
+        IF ~varpar THEN OSG.ValueParam(x)
+        ELSE OSG.VarParam(x, par.type)
+        END
+      ELSIF (x.type.form = OSG.Array) & (par.type.form = OSG.Array) &
+          (x.type.base.form = par.type.base.form) & (par.type.len < 0) THEN
+        OSG.OpenArrayParam(x)
+      ELSE OSS.Mark("incompatible parameters")
+      END
+    END
+  END Parameter;
+
+  PROCEDURE ParamList(VAR obj: OSG.Object);
+    VAR n: INTEGER; par: OSG.Object;
+  BEGIN par := obj.dsc; n := 0;
+    IF sym # OSS.rparen THEN
+      Parameter(par); n := 1;
+      WHILE sym <= OSS.comma DO
+        Check(sym, "comma?");
+        IF par # NIL THEN par := par.next END ;
+        INC(n); Parameter(par)
+      END ;
+      Check(OSS.rparen, ") missing")
+    ELSE OSS.Get(sym);
+    END ;
+    IF n < obj.nofpar THEN OSS.Mark("too few params")
+    ELSIF n > obj.nofpar THEN OSS.Mark("too many params")
+    END
+  END ParamList;
+
+  PROCEDURE StandFunc(VAR x: OSG.Item; fctno: LONGINT);
+    VAR y, z: OSG.Item;
+  BEGIN
+    IF sym = OSS.lparen THEN
+      OSS.Get(sym);
+      IF fctno = 0 THEN (*ORD*) expression(x); OSG.Ord(x)
+      ELSIF fctno = 1 THEN (*eot*) OSG.eot(x)
+      ELSE (*fctno = 2*) OSG.Switch(x)
+      END ;
+      IF sym = OSS.rparen THEN OSS.Get(sym) ELSE OSS.Mark("rparen expected") END
+    ELSE OSS.Mark("param missing"); OSG.MakeConstItem(x, OSG.intType, 0)
+    END
+  END StandFunc;
+
+  PROCEDURE factor(VAR x: OSG.Item);
+    VAR obj: OSG.Object;
+  BEGIN (*sync*)
+    IF (sym < OSS.char) OR (sym > OSS.ident) THEN OSS.Mark("expression expected");
+      REPEAT OSS.Get(sym) UNTIL (sym >= OSS.int) & (sym <= OSS.ident)
+    END ;
+    IF sym = OSS.ident THEN
+      find(obj); OSS.Get(sym);
+      IF obj.class = OSG.SFunc THEN
+        IF obj.type = NIL THEN OSS.Mark("not a function"); obj.type := OSG.intType END ;
+        StandFunc(x, obj.val); x.type := obj.type
+      ELSE OSG.MakeItem(x, obj, level); selector(x)
+      END
+    ELSIF sym = OSS.int THEN OSG.MakeConstItem(x, OSG.intType, OSS.val); OSS.Get(sym)
+    ELSIF sym = OSS.char THEN OSG.MakeConstItem(x, OSG.intType, OSS.val); OSS.Get(sym)
+    ELSIF sym = OSS.lparen THEN
+      OSS.Get(sym);
+      IF sym # OSS.rparen THEN expression(x) END ;
+      Check(OSS.rparen, "no )")
+    ELSIF sym = OSS.not THEN OSS.Get(sym); factor(x); CheckBool(x); OSG.Not(x)
+    ELSIF sym = OSS.false THEN OSS.Get(sym); OSG.MakeConstItem(x, OSG.boolType, 0)
+    ELSIF sym = OSS.true THEN OSS.Get(sym); OSG.MakeConstItem(x, OSG.boolType, 1)
+    ELSE OSS.Mark("factor?"); OSG.MakeItem(x, dummy, level)
+    END
+  END factor;
+
+  PROCEDURE term(VAR x: OSG.Item);
+    VAR y: OSG.Item; op: INTEGER;
+  BEGIN factor(x);
+    WHILE (sym >= OSS.times) & (sym <= OSS.and) DO
+      op := sym; OSS.Get(sym);
+      IF op = OSS.times THEN CheckInt(x); factor(y); CheckInt(y); OSG.MulOp(x, y)
+      ELSIF (op = OSS.div) OR (op = OSS.mod) THEN CheckInt(x); factor(y); CheckInt(y); OSG.DivOp(op, x, y)
+      ELSE (*op = and*) CheckBool(x); OSG.And1(x); factor(y); CheckBool(y); OSG.And2(x, y)
+      END
+    END
+  END term;
+
+  PROCEDURE SimpleExpression(VAR x: OSG.Item);
+    VAR y: OSG.Item; op: INTEGER;
+  BEGIN
+    IF sym = OSS.plus THEN OSS.Get(sym); term(x); CheckInt(x)
+    ELSIF sym = OSS.minus THEN OSS.Get(sym); term(x); CheckInt(x); OSG.Neg(x)
+    ELSE term(x)
+    END;
+    WHILE (sym >= OSS.plus) & (sym <= OSS.or) DO
+      op := sym; OSS.Get(sym);
+      IF op = OSS.or THEN OSG.Or1(x); CheckBool(x); term(y); CheckBool(y); OSG.Or2(x, y)
+      ELSE CheckInt(x); term(y); CheckInt(y); OSG.AddOp(op, x, y)
+      END
+    END
+  END SimpleExpression;
+
+  PROCEDURE expression0(VAR x: OSG.Item);
+    VAR y: OSG.Item; op: INTEGER;
+  BEGIN SimpleExpression(x);
+    IF (sym >= OSS.eql) & (sym <= OSS.geq) THEN
+      op := sym; OSS.Get(sym); SimpleExpression(y);
+      IF x.type = y.type THEN OSG.Relation(op, x, y) ELSE OSS.Mark("incompatible types") END ;
+      x.type := OSG.boolType
+    END
+  END expression0;
+
+  PROCEDURE StandProc(pno: LONGINT);
+    VAR x, y: OSG.Item;
+  BEGIN
+    IF pno = 0 THEN  OSG.OpenInput
+    ELSIF pno IN {1, 2, 3, 5} THEN
+      IF sym = OSS.lparen THEN OSS.Get(sym); expression(x);
+        IF pno = 1 THEN OSG.ReadInt(x);
+        ELSIF pno = 2 THEN
+          IF sym = OSS.comma THEN OSS.Get(sym); expression(y); OSG.WriteInt(x, y) ELSE OSS.Mark("no comma") END
+        ELSIF pno = 3 THEN OSG.WriteChar(x)
+        ELSIF pno = 5 THEN OSG.LED(x)
+            END ;
+            IF sym = OSS.rparen THEN OSS.Get(sym) ELSE OSS.Mark("no rparen") END
+          ELSE OSS.Mark(" missing lparen")
+          END
+    ELSIF pno = 4 THEN  OSG.WriteLn
+    ELSE OSS.Mark("undef proc")
+    END
+  END StandProc;
+
+  PROCEDURE StatSequence;
+    VAR par, obj: OSG.Object; x, y: OSG.Item; n, L: LONGINT;
+  BEGIN (* StatSequence *)
+    REPEAT (*sync*) obj := NIL;
+      IF ~((sym = OSS.ident) OR (sym >= OSS.if) & (sym <= OSS.repeat) OR (sym >= OSS.semicolon)) THEN
+        OSS.Mark("statement expected");
+        REPEAT OSS.Get(sym) UNTIL (sym = OSS.ident) OR (sym >= OSS.if)
+      END ;
+      IF sym = OSS.ident THEN
+        find(obj); OSS.Get(sym);
+        IF obj.class = OSG.SProc THEN StandProc(obj.val)
+        ELSE OSG.MakeItem(x, obj, level); selector(x);
+          IF sym = OSS.becomes THEN (*assignment*)
+            OSS.Get(sym); expression(y);
+            IF (x.type.form IN {OSG.Boolean, OSG.Integer}) & (x.type.form = y.type.form) THEN OSG.Store(x, y)
+            ELSE OSS.Mark("incompatible assignment")
+            END
+          ELSIF sym = OSS.eql THEN OSS.Mark("should be :="); OSS.Get(sym); expression(y)
+          ELSIF sym = OSS.lparen THEN (*procedure call*)
+            OSS.Get(sym);
+            IF (obj.class = OSG.Proc) & (obj.type = NIL) THEN ParamList(obj); OSG.Call(obj);
+            ELSE OSS.Mark("not a procedure")
+            END
+          ELSIF obj.class = OSG.Proc THEN (*procedure call without parameters*)
+            IF obj.nofpar > 0 THEN OSS.Mark("missing parameters") END ;
+            IF obj.type = NIL THEN OSG.Call(obj) ELSE OSS.Mark("not a procedure") END
+          ELSIF (obj.class = OSG.SProc) & (obj.val = 3) THEN OSG.WriteLn
+          ELSIF obj.class = OSG.Typ THEN OSS.Mark("illegal assignment")
+          ELSE OSS.Mark("not a procedure")
+          END
+        END
+      ELSIF sym = OSS.if THEN
+        OSS.Get(sym); expression(x); CheckBool(x); OSG.CFJump(x); Check(OSS.then, "no THEN");
+        StatSequence; L := 0;
+        WHILE sym = OSS.elsif DO
+          OSS.Get(sym); OSG.FJump(L); OSG.FixLink(x.a); expression(x); CheckBool(x); OSG.CFJump(x);
+          IF sym = OSS.then THEN OSS.Get(sym) ELSE OSS.Mark("THEN?") END ;
+          StatSequence
+        END ;
+        IF sym = OSS.else THEN
+          OSS.Get(sym); OSG.FJump(L); OSG.FixLink(x.a); StatSequence
+        ELSE OSG.FixLink(x.a)
+        END ;
+        OSG.FixLink(L);
+        IF sym = OSS.end THEN OSS.Get(sym) ELSE OSS.Mark("END?") END
+      ELSIF sym = OSS.while THEN
+        OSS.Get(sym); L := OSG.pc; expression(x); CheckBool(x); OSG.CFJump(x);
+        Check(OSS.do, "no DO"); StatSequence; OSG.BJump(L); OSG.FixLink(x.a);
+        Check(OSS.end, "no END")
+      ELSIF sym = OSS.repeat THEN
+        OSS.Get(sym); L := OSG.pc; StatSequence;
+        IF sym = OSS.until THEN
+          OSS.Get(sym); expression(x); CheckBool(x); OSG.CBJump(x, L)
+        ELSE OSS.Mark("missing UNTIL"); OSS.Get(sym)
+        END        
+      END ;
+      OSG.CheckRegs;
+      IF sym = OSS.semicolon THEN OSS.Get(sym)
+      ELSIF sym < OSS.semicolon THEN OSS.Mark("missing semicolon?")
+      END
+    UNTIL sym > OSS.semicolon
+  END StatSequence;
+  
+  PROCEDURE IdentList(class: INTEGER; VAR first: OSG.Object);
+    VAR obj: OSG.Object;
+  BEGIN
+    IF sym = OSS.ident THEN
+      NewObj(first, class); OSS.Get(sym);
+      WHILE sym = OSS.comma DO
+        OSS.Get(sym);
+        IF sym = OSS.ident THEN NewObj(obj, class); OSS.Get(sym)
+        ELSE OSS.Mark("ident?")
+        END
+      END;
+      Check(OSS.colon, "no :")
+    END
+  END IdentList;
+  
+  PROCEDURE Type(VAR type: OSG.Type);
+    VAR obj, first: OSG.Object; x: OSG.Item; tp: OSG.Type;
+  BEGIN type := OSG.intType; (*sync*)
+    IF (sym # OSS.ident) & (sym < OSS.array) THEN OSS.Mark("type?");
+      REPEAT OSS.Get(sym) UNTIL (sym = OSS.ident) OR (sym >= OSS.array)
+    END ;
+    IF sym = OSS.ident THEN
+      find(obj); OSS.Get(sym);
+      IF obj.class = OSG.Typ THEN type := obj.type ELSE OSS.Mark("type?") END
+    ELSIF sym = OSS.array THEN
+      OSS.Get(sym); expression(x);
+      IF (x.mode # OSG.Const) OR (x.a < 0) THEN OSS.Mark("bad index") END ;
+      IF sym = OSS.of THEN OSS.Get(sym) ELSE OSS.Mark("OF?") END ;
+      Type(tp); NEW(type); type.form := OSG.Array; type.base := tp;
+      type.len := x.a; type.size := type.len * tp.size
+    ELSIF sym = OSS.record THEN
+      OSS.Get(sym); NEW(type); type.form := OSG.Record; type.size := 0; OpenScope;
+      REPEAT
+        IF sym = OSS.ident THEN
+          IdentList(OSG.Fld, first); Type(tp); obj := first;
+          WHILE obj # NIL DO
+            obj.type := tp; obj.val := type.size; type.size := type.size + obj.type.size; obj := obj.next
+          END
+        END ;
+        IF sym = OSS.semicolon THEN OSS.Get(sym)
+        ELSIF sym = OSS.ident THEN OSS.Mark("; ?")
+        END
+      UNTIL sym # OSS.ident;
+      type.dsc := topScope.next; CloseScope; Check(OSS.end, "no END")
+    ELSE OSS.Mark("ident?")  
+    END
+  END Type;
+
+  PROCEDURE Declarations(VAR varsize: LONGINT);
+    VAR obj, first: OSG.Object;
+      x: OSG.Item; tp: OSG.Type; L: LONGINT;
+  BEGIN (*sync*)
+    IF (sym < OSS.const) & (sym # OSS.end) THEN OSS.Mark("declaration?");
+      REPEAT OSS.Get(sym) UNTIL (sym >= OSS.const) OR (sym = OSS.end)
+    END ;
+    IF sym = OSS.const THEN
+      OSS.Get(sym);
+      WHILE sym = OSS.ident DO
+        NewObj(obj, OSG.Const); OSS.Get(sym);
+        IF sym = OSS.eql THEN OSS.Get(sym) ELSE OSS.Mark("=?") END;
+        expression(x);
+        IF x.mode = OSG.Const THEN obj.val := x.a; obj.type := x.type
+        ELSE OSS.Mark("expression not constant")
+        END ;
+        Check(OSS.semicolon, "; expected")
+      END
+    END ;
+    IF sym = OSS.type THEN
+      OSS.Get(sym);
+      WHILE sym = OSS.ident DO
+        NewObj(obj, OSG.Typ); OSS.Get(sym);
+        IF sym = OSS.eql THEN OSS.Get(sym) ELSE OSS.Mark("=?") END ; 
+        Type(obj.type); Check(OSS.semicolon, "; expected")
+      END
+    END ;
+    IF sym = OSS.var THEN
+      OSS.Get(sym);
+      WHILE sym = OSS.ident DO
+        IdentList(OSG.Var, first); Type(tp);
+        obj := first;
+        WHILE obj # NIL DO
+          obj.type := tp; obj.lev := level;
+          obj.val := varsize; varsize := varsize + obj.type.size; obj := obj.next
+        END ;
+        Check(OSS.semicolon, "; expected")
+      END
+    END ;
+    IF (sym >= OSS.const) & (sym <= OSS.var) THEN OSS.Mark("declaration in bad order") END
+  END Declarations;
+
+  PROCEDURE ProcedureDecl;
+    CONST marksize = 4;
+    VAR proc, obj: OSG.Object;
+      procid: OSS.Ident;
+      nofpar: INTEGER;
+      locblksize, parblksize: LONGINT;
+      
+    PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER);
+      VAR obj, first: OSG.Object; tp: OSG.Type; parsize: LONGINT;
+    BEGIN
+      IF sym = OSS.var THEN OSS.Get(sym); IdentList(OSG.Par, first)
+      ELSE IdentList(OSG.Var, first)
+      END ;
+      IF sym = OSS.ident THEN
+        find(obj); OSS.Get(sym);
+        IF obj.class = OSG.Typ THEN tp := obj.type ELSE OSS.Mark("type?"); tp := OSG.intType END
+      ELSE OSS.Mark("ident?"); tp := OSG.intType
+      END ;
+      IF first.class = OSG.Var THEN
+        parsize := tp.size;
+        IF tp.form >= OSG.Array THEN OSS.Mark("no struct params") END ;
+      ELSE parsize := WordSize
+      END ;
+      obj := first;
+      WHILE obj # NIL DO
+        INC(nofpar); obj.type := tp; obj.lev := level; obj.val := adr; adr := adr + parsize;
+        obj := obj.next
+      END
+    END FPSection;
+    
+  BEGIN (* ProcedureDecl *) OSS.Get(sym);
+    IF sym = OSS.ident THEN
+      procid := OSS.id; NewObj(proc, OSG.Proc); OSS.Get(sym); parblksize := marksize; nofpar := 0;
+    (* Texts.Write(W, "%"); Texts.WriteInt(W, sym, 4); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); *)
+      OpenScope;  INC(level); proc.val := -1;
+      IF sym = OSS.times THEN proc.comd := TRUE; OSS.Get(sym) ELSE proc.comd := FALSE END ;
+      IF sym = OSS.lparen THEN
+        OSS.Get(sym);
+        IF sym = OSS.rparen THEN OSS.Get(sym)
+        ELSE FPSection(parblksize, nofpar);
+          WHILE sym = OSS.semicolon DO OSS.Get(sym); FPSection(parblksize, nofpar) END ;
+          IF sym = OSS.rparen THEN OSS.Get(sym) ELSE OSS.Mark(")?") END ;
+          IF proc.comd THEN OSS.Mark("no params allowed") END
+        END
+      END ;
+      locblksize := parblksize; proc.type := NIL; proc.dsc := topScope.next; proc.nofpar := nofpar;
+      Check(OSS.semicolon, "; expected");
+      Declarations(locblksize); proc.dsc := topScope.next;
+      WHILE sym = OSS.procedure DO
+        ProcedureDecl; Check(OSS.semicolon, "; expected")
+      END ;
+      proc.val := OSG.pc * 4; OSG.Enter(parblksize, locblksize, proc.comd);
+      IF sym = OSS.begin THEN OSS.Get(sym); StatSequence END ;
+      Check(OSS.end, "no END");
+      IF sym = OSS.ident THEN
+        IF procid # OSS.id THEN OSS.Mark("no match") END ;
+        OSS.Get(sym)
+      END ;
+      OSG.Return(locblksize); DEC(level); CloseScope
+    END
+  END ProcedureDecl;
+
+  PROCEDURE Module;
+    VAR modid: OSS.Ident; dc: LONGINT;
+  BEGIN Texts.WriteString(W, "  compiling ");
+    IF sym = OSS.module THEN
+      OSS.Get(sym); OSG.Open; OpenScope; dc := 0; level := 0;
+      IF sym = OSS.ident THEN
+        modid := OSS.id; OSS.Get(sym);
+        Texts.WriteString(W, modid); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+      ELSE OSS.Mark("ident?")
+      END ;
+      Check(OSS.semicolon, "; expected");
+      Declarations(dc);
+      WHILE sym = OSS.procedure DO ProcedureDecl; Check(OSS.semicolon, "; expected") END ;
+      OSG.Header(dc);
+      IF sym = OSS.begin THEN OSS.Get(sym); StatSequence END ;
+      Check(OSS.end, "no END");
+      IF sym = OSS.ident THEN
+        IF modid # OSS.id THEN OSS.Mark("no match") END ;
+        OSS.Get(sym)
+      ELSE OSS.Mark("ident?")
+      END ;
+      IF sym # OSS.period THEN OSS.Mark(". ?") END ;
+      IF ~OSS.error THEN
+        OSG.Close(modid, 1, dc, topScope); Texts.WriteString(W, "code generated "); Texts.WriteString(W, modid);
+        Texts.WriteInt(W, OSG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+      END ;
+      CloseScope
+    ELSE OSS.Mark("MODULE?")
+    END
+  END Module;
+  
+  PROCEDURE Compile*;
+    VAR beg, end, time: LONGINT; T: Texts.Text;
+  BEGIN Oberon.GetSelection(T, beg, end, time);
+    IF time >= 0 THEN OSS.Init(T, beg); OSS.Get(sym); Module END
+  END Compile;
+
+  PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; n: LONGINT;  type: OSG.Type);
+    VAR obj: OSG.Object;
+  BEGIN NEW(obj);
+    obj.class := cl; obj.val := n; obj.name := name; obj.type := type; obj.dsc := NIL;
+    obj.next := topScope.next; topScope.next := obj
+  END enter; 
+
+BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "Oberon-0 Compiler OSP  9.5.2017");
+  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+  NEW(dummy); dummy.class := OSG.Var; dummy.type := OSG.intType; dummy.val := 0;
+  expression := expression0;
+  topScope := NIL; OpenScope;;
+  enter("ORD", OSG.SFunc, 0, OSG.intType);
+  enter("eot", OSG.SFunc, 1, OSG.boolType);
+  enter("Switch", OSG.SFunc, 2, OSG.intType);
+  enter("OpenInput", OSG.SProc, 0, NIL);
+  enter("ReadInt", OSG.SProc, 1, NIL);
+  enter("WriteInt", OSG.SProc, 2, NIL);
+  enter("WriteChar", OSG.SProc, 3, NIL);
+  enter("WriteLn", OSG.SProc, 4, NIL);
+  enter("LED", OSG.SProc, 5, NIL);
+  enter("BOOLEAN", OSG.Typ, 0, OSG.boolType);
+  enter("INTEGER", OSG.Typ, 1, OSG.intType);
+  universe := topScope
+END OSP.

people.inf.ethz.ch/wirth/CompilerConstruction/OSS.Mod.txt

@@ -1,178 +1,178 @@
-MODULE OSS; (* NW 19.9.93 / 17.11.94 / 1.11.2013*)
-  IMPORT Texts, Oberon;
-
-  CONST IdLen* = 16; KW = 34; maxInt = 2147483647;
-
-    (*lexical symbols of Oberon*)
-    null = 0; times* = 1; div* = 3; mod* = 4;
-    and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9;
-    neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14;
-    period* = 18; char* = 20; int* = 21; false* = 23; true* = 24;
-    not* = 27; lparen* = 28; lbrak* = 29;
-    ident* = 31; if* = 32; while* = 34;
-    repeat* = 35;
-    comma* = 40; colon* = 41; becomes* = 42; rparen* = 44;
-    rbrak* = 45; then* = 47; of* = 48; do* = 49;
-    semicolon* = 52; end* = 53; 
-    else* = 55; elsif* = 56; until* = 57; 
-    array* = 60; record* = 61; const* = 63; type* = 64;
-    var* = 65; procedure* = 66; begin* = 67;  module* = 69;
-    eof = 70;
-
-  TYPE Ident* = ARRAY IdLen OF CHAR;
-
-  VAR val*: LONGINT;
-    id*: Ident;
-    error*: BOOLEAN;
-
-    ch: CHAR;
-    nkw: INTEGER;
-    errpos: LONGINT;
-    R: Texts.Reader;
-    W: Texts.Writer;
-    keyTab: ARRAY KW OF  (*keywords of Oberon*)
-        RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END;
-
-  PROCEDURE Mark*(msg: ARRAY OF CHAR);
-    VAR p: LONGINT;
-  BEGIN p := Texts.Pos(R) - 1;
-    IF p > errpos THEN
-      Texts.WriteString(W, "  pos "); Texts.WriteInt(W, p, 1);
-      Texts.Write(W, " "); Texts.WriteString(W, msg);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END ;
-    errpos := p; error := TRUE
-  END Mark;
-
-  PROCEDURE Identifier(VAR sym: INTEGER);
-    VAR i, k: INTEGER;
-  BEGIN i := 0;
-    REPEAT
-      IF i < IdLen THEN id[i] := ch; INC(i) END ;
-      Texts.Read(R, ch)
-    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
-    id[i] := 0X; k := 0;
-    WHILE (k < nkw) & (id # keyTab[k].id) DO INC(k) END ;
-    IF k < nkw THEN sym := keyTab[k].sym ELSE sym := ident END
-  END Identifier;
-
-  PROCEDURE Number(VAR sym: INTEGER);
-  BEGIN val := 0; sym := int;
-    REPEAT
-      IF val <= (maxInt - ORD(ch) + ORD("0")) DIV 10 THEN
-        val := 10 * val + (ORD(ch) - ORD("0"))
-      ELSE Mark("number too large"); val := 0
-      END ;
-      Texts.Read(R, ch)
-    UNTIL (ch < "0") OR (ch > "9")
-  END Number;
-
-  PROCEDURE comment;
-  BEGIN
-    REPEAT
-      REPEAT Texts.Read(R, ch);
-        WHILE ch = "(" DO Texts.Read(R, ch);
-          IF ch = "*" THEN comment END
-        END ;
-      UNTIL (ch = "*") OR R.eot;
-      REPEAT Texts.Read(R, ch) UNTIL (ch # "*") OR R.eot
-    UNTIL (ch = ")") OR R.eot;
-    IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("comment not terminated") END
-  END comment;
-
-  PROCEDURE Get*(VAR sym: INTEGER);
-  BEGIN
-    REPEAT
-      WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
-        IF ch < "A" THEN
-        IF ch < "0" THEN
-          IF ch = 22X THEN
-            Texts.Read(R, ch); val := ORD(ch);
-            REPEAT Texts.Read(R, ch) UNTIL (ch = 22X) OR R.eot;
-            Texts.Read(R, ch); sym := char
-          ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
-          ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
-          ELSIF ch = "(" THEN Texts.Read(R, ch); 
-            IF ch = "*" THEN sym := null; comment ELSE sym := lparen END
-          ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
-          ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times
-          ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
-          ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
-          ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus
-          ELSIF ch = "." THEN Texts.Read(R, ch); sym := period
-          ELSIF ch = "/" THEN Texts.Read(R, ch); sym := null
-          ELSE Texts.Read(R, ch); (* ! $ % *) sym := null
-          END
-        ELSIF ch < ":" THEN Number(sym)
-        ELSIF ch = ":" THEN Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END 
-        ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
-        ELSIF ch = "<" THEN  Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
-        ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
-        ELSIF ch = ">" THEN Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
-        ELSE (* ? @ *) Texts.Read(R, ch); sym := null
-        END
-      ELSIF ch < "[" THEN Identifier(sym)
-      ELSIF ch < "a" THEN
-        IF ch = "[" THEN sym := lbrak
-        ELSIF ch = "]" THEN  sym := rbrak
-        ELSIF ch = "^" THEN sym := null
-        ELSE (* _ ` *) sym := null
-        END ;
-        Texts.Read(R, ch)
-      ELSIF ch < "{" THEN Identifier(sym) ELSE
-        IF ch = "{" THEN sym := null
-        ELSIF ch = "}" THEN sym := null
-        ELSIF ch = "|" THEN sym := null
-        ELSIF ch = "~" THEN  sym := not
-        ELSE sym := null
-        END ;
-        Texts.Read(R, ch)
-      END
-    UNTIL sym # null
-  END Get;
-
-  PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
-  BEGIN error := FALSE; errpos := pos; Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
-  END Init;
-  
-  PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR);
-  BEGIN keyTab[nkw].sym := sym; COPY(name, keyTab[nkw].id); INC(nkw)
-  END EnterKW;
-
-BEGIN Texts.OpenWriter(W); error := TRUE; nkw := 0;
-  EnterKW(array, "ARRAY");
-  EnterKW(begin, "BEGIN");
-  EnterKW(null, "BY");
-  EnterKW(const, "CONST");
-  EnterKW(div, "DIV");
-  EnterKW(do, "DO");
-  EnterKW(else, "ELSE");
-  EnterKW(elsif, "ELSIF");
-  EnterKW(end, "END");
-  EnterKW(false, "FALSE");
-  EnterKW(null, "FOR");
-  EnterKW(if, "IF");
-  EnterKW(null, "IMPORT");
-  EnterKW(null, "IN");
-  EnterKW(null, "IS");
-  EnterKW(mod, "MOD");
-  EnterKW(module, "MODULE");
-  EnterKW(null, "NIL");
-  EnterKW(of, "OF");
-  EnterKW(or, "OR");
-  EnterKW(null, "POINTER");
-  EnterKW(procedure, "PROCEDURE");
-  EnterKW(record, "RECORD");
-  EnterKW(repeat, "REPEAT");
-  EnterKW(null, "RETURN");
-  EnterKW(then, "THEN");
-  EnterKW(null, "TO");
-  EnterKW(true, "TRUE");
-  EnterKW(type, "TYPE");
-  EnterKW(until, "UNTIL");
-  EnterKW(var, "VAR");
-  EnterKW(while, "WHILE")
-END OSS.
+MODULE OSS; (* NW 19.9.93 / 17.11.94 / 1.11.2013*)
+  IMPORT Texts, Oberon;
+
+  CONST IdLen* = 16; KW = 34; maxInt = 2147483647;
+
+    (*lexical symbols of Oberon*)
+    null = 0; times* = 1; div* = 3; mod* = 4;
+    and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9;
+    neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14;
+    period* = 18; char* = 20; int* = 21; false* = 23; true* = 24;
+    not* = 27; lparen* = 28; lbrak* = 29;
+    ident* = 31; if* = 32; while* = 34;
+    repeat* = 35;
+    comma* = 40; colon* = 41; becomes* = 42; rparen* = 44;
+    rbrak* = 45; then* = 47; of* = 48; do* = 49;
+    semicolon* = 52; end* = 53; 
+    else* = 55; elsif* = 56; until* = 57; 
+    array* = 60; record* = 61; const* = 63; type* = 64;
+    var* = 65; procedure* = 66; begin* = 67;  module* = 69;
+    eof = 70;
+
+  TYPE Ident* = ARRAY IdLen OF CHAR;
+
+  VAR val*: LONGINT;
+    id*: Ident;
+    error*: BOOLEAN;
+
+    ch: CHAR;
+    nkw: INTEGER;
+    errpos: LONGINT;
+    R: Texts.Reader;
+    W: Texts.Writer;
+    keyTab: ARRAY KW OF  (*keywords of Oberon*)
+        RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END;
+
+  PROCEDURE Mark*(msg: ARRAY OF CHAR);
+    VAR p: LONGINT;
+  BEGIN p := Texts.Pos(R) - 1;
+    IF p > errpos THEN
+      Texts.WriteString(W, "  pos "); Texts.WriteInt(W, p, 1);
+      Texts.Write(W, " "); Texts.WriteString(W, msg);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END ;
+    errpos := p; error := TRUE
+  END Mark;
+
+  PROCEDURE Identifier(VAR sym: INTEGER);
+    VAR i, k: INTEGER;
+  BEGIN i := 0;
+    REPEAT
+      IF i < IdLen THEN id[i] := ch; INC(i) END ;
+      Texts.Read(R, ch)
+    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
+    id[i] := 0X; k := 0;
+    WHILE (k < nkw) & (id # keyTab[k].id) DO INC(k) END ;
+    IF k < nkw THEN sym := keyTab[k].sym ELSE sym := ident END
+  END Identifier;
+
+  PROCEDURE Number(VAR sym: INTEGER);
+  BEGIN val := 0; sym := int;
+    REPEAT
+      IF val <= (maxInt - ORD(ch) + ORD("0")) DIV 10 THEN
+        val := 10 * val + (ORD(ch) - ORD("0"))
+      ELSE Mark("number too large"); val := 0
+      END ;
+      Texts.Read(R, ch)
+    UNTIL (ch < "0") OR (ch > "9")
+  END Number;
+
+  PROCEDURE comment;
+  BEGIN
+    REPEAT
+      REPEAT Texts.Read(R, ch);
+        WHILE ch = "(" DO Texts.Read(R, ch);
+          IF ch = "*" THEN comment END
+        END ;
+      UNTIL (ch = "*") OR R.eot;
+      REPEAT Texts.Read(R, ch) UNTIL (ch # "*") OR R.eot
+    UNTIL (ch = ")") OR R.eot;
+    IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("comment not terminated") END
+  END comment;
+
+  PROCEDURE Get*(VAR sym: INTEGER);
+  BEGIN
+    REPEAT
+      WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
+        IF ch < "A" THEN
+        IF ch < "0" THEN
+          IF ch = 22X THEN
+            Texts.Read(R, ch); val := ORD(ch);
+            REPEAT Texts.Read(R, ch) UNTIL (ch = 22X) OR R.eot;
+            Texts.Read(R, ch); sym := char
+          ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
+          ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
+          ELSIF ch = "(" THEN Texts.Read(R, ch); 
+            IF ch = "*" THEN sym := null; comment ELSE sym := lparen END
+          ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
+          ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times
+          ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
+          ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
+          ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus
+          ELSIF ch = "." THEN Texts.Read(R, ch); sym := period
+          ELSIF ch = "/" THEN Texts.Read(R, ch); sym := null
+          ELSE Texts.Read(R, ch); (* ! $ % *) sym := null
+          END
+        ELSIF ch < ":" THEN Number(sym)
+        ELSIF ch = ":" THEN Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END 
+        ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
+        ELSIF ch = "<" THEN  Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
+        ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
+        ELSIF ch = ">" THEN Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
+        ELSE (* ? @ *) Texts.Read(R, ch); sym := null
+        END
+      ELSIF ch < "[" THEN Identifier(sym)
+      ELSIF ch < "a" THEN
+        IF ch = "[" THEN sym := lbrak
+        ELSIF ch = "]" THEN  sym := rbrak
+        ELSIF ch = "^" THEN sym := null
+        ELSE (* _ ` *) sym := null
+        END ;
+        Texts.Read(R, ch)
+      ELSIF ch < "{" THEN Identifier(sym) ELSE
+        IF ch = "{" THEN sym := null
+        ELSIF ch = "}" THEN sym := null
+        ELSIF ch = "|" THEN sym := null
+        ELSIF ch = "~" THEN  sym := not
+        ELSE sym := null
+        END ;
+        Texts.Read(R, ch)
+      END
+    UNTIL sym # null
+  END Get;
+
+  PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
+  BEGIN error := FALSE; errpos := pos; Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
+  END Init;
+  
+  PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR);
+  BEGIN keyTab[nkw].sym := sym; COPY(name, keyTab[nkw].id); INC(nkw)
+  END EnterKW;
+
+BEGIN Texts.OpenWriter(W); error := TRUE; nkw := 0;
+  EnterKW(array, "ARRAY");
+  EnterKW(begin, "BEGIN");
+  EnterKW(null, "BY");
+  EnterKW(const, "CONST");
+  EnterKW(div, "DIV");
+  EnterKW(do, "DO");
+  EnterKW(else, "ELSE");
+  EnterKW(elsif, "ELSIF");
+  EnterKW(end, "END");
+  EnterKW(false, "FALSE");
+  EnterKW(null, "FOR");
+  EnterKW(if, "IF");
+  EnterKW(null, "IMPORT");
+  EnterKW(null, "IN");
+  EnterKW(null, "IS");
+  EnterKW(mod, "MOD");
+  EnterKW(module, "MODULE");
+  EnterKW(null, "NIL");
+  EnterKW(of, "OF");
+  EnterKW(or, "OR");
+  EnterKW(null, "POINTER");
+  EnterKW(procedure, "PROCEDURE");
+  EnterKW(record, "RECORD");
+  EnterKW(repeat, "REPEAT");
+  EnterKW(null, "RETURN");
+  EnterKW(then, "THEN");
+  EnterKW(null, "TO");
+  EnterKW(true, "TRUE");
+  EnterKW(type, "TYPE");
+  EnterKW(until, "UNTIL");
+  EnterKW(var, "VAR");
+  EnterKW(while, "WHILE")
+END OSS.

people.inf.ethz.ch/wirth/CompilerConstruction/RISC.Mod.txt

@@ -1,78 +1,78 @@
-MODULE RISC;     (*NW 22.9.07 / 15.12.2013*)
-  IMPORT SYSTEM, Texts, Oberon;
-  CONST
-    MOV = 0; LSL = 1; ASR = 2; ROR = 3; AND = 4; ANN = 5; IOR = 6; XOR = 7;
-    ADD = 8; SUB = 9;  MUL = 10; Div = 11;
-
-  VAR IR: LONGINT;   (*instruction register*)
-    PC: LONGINT;   (*program counter*)
-    N, Z: BOOLEAN;  (*condition flags*)
-    R: ARRAY 16 OF LONGINT;
-    H: LONGINT;  (*aux register for division*)
-    
-  PROCEDURE Execute*(VAR M: ARRAY OF LONGINT; pc: LONGINT;
-      VAR S: Texts.Scanner; VAR W: Texts.Writer);
-    VAR a, b, op, im: LONGINT;  (*instruction fields*)
-      adr, A, B, C: LONGINT;
-      MemSize: LONGINT;
-  BEGIN PC := 0; R[13] := pc * 4; R[14] := LEN(M)*4;
-    REPEAT (*interpretation cycle*)
-      IR := M[PC]; INC(PC);
-      a := IR DIV 1000000H MOD 10H;
-      b := IR DIV 100000H MOD 10H;
-      op := IR DIV 10000H MOD 10H;
-      im := IR MOD 10000H;
-      IF ~ODD(ASH(IR, -31)) THEN  (*~p:  register instruction*)
-        B := R[b];
-        IF ~ODD(ASH(IR, -30)) THEN (*~q*) C := R[IR MOD 10H]
-        ELSIF ~ODD(ASH(IR, -28)) THEN (*q&~v*) C := im 
-        ELSE (*q&v*) C := im + 0FFFF0000H
-        END ;
-        CASE op OF
-            MOV: IF ~ODD(ASH(IR, -29)) THEN A := C ELSE A := H END |
-            LSL: A := SYSTEM.LSH(B, C) |
-            ASR: A := ASH(B, -C) |
-            ROR: A := SYSTEM.ROT(B, -C) |
-            AND: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) * SYSTEM.VAL(SET, C)) |
-            ANN: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) - SYSTEM.VAL(SET, C)) |
-            IOR: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) + SYSTEM.VAL(SET, C)) |
-            XOR: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) / SYSTEM.VAL(SET, C)) |
-            ADD: A := B + C |
-            SUB: A := B - C |
-            MUL: A := B * C |
-            Div: A := B DIV C; H := B MOD C
-         END ;
-         R[a] := A; N := A < 0; Z := A = 0
-      ELSIF ~ODD(ASH(IR, -30)) THEN (*p & ~q: memory instruction*)
-        adr := (R[b] + IR MOD 100000H) DIV 4;
-        IF ~ODD(ASH(IR, -29)) THEN
-          IF adr >= 0 THEN (*load*) R[a] := M[adr]; N := A < 0; Z := A = 0
-          ELSE (*input*)
-            IF adr = -1 THEN (*ReadInt*) Texts.Scan(S); R[a] := S.i;
-            ELSIF adr = -2 THEN (*eot*)  Z := S.class # Texts.Int
-            END 
-          END
-        ELSE
-          IF adr >= 0 THEN (*store*) M[adr] := R[a];
-          ELSE (*output*);
-            IF adr = -1 THEN Texts.WriteInt(W, R[a], 4)
-            ELSIF adr = -2 THEN Texts.Write(W, CHR(R[a] MOD 80H))
-            ELSIF adr = -3 THEN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-            END
-          END
-        END
-      ELSE (* p & q: branch instruction*)
-        IF (a = 0) & N OR (a = 1) & Z OR (a = 5) & N OR (a = 6) & (N OR Z) OR (a = 7) OR
-            (a = 8) & ~N OR (a = 9) & ~Z OR (a = 13) & ~N OR (a = 14) & ~(N OR Z) THEN
-          IF ODD(ASH(IR, -28)) THEN R[15] := PC * 4 END ;
-          IF ODD(ASH(IR, -29)) THEN PC := (PC + (IR MOD 1000000H)) MOD 40000H 
-          ELSE PC := R[IR MOD 10H] DIV 4
-          END
-        END
-      END
-    UNTIL PC = 0;
-    Texts.Append(Oberon.Log, W.buf)
-  END Execute;
-END RISC.
-
-
+MODULE RISC;     (*NW 22.9.07 / 15.12.2013*)
+  IMPORT SYSTEM, Texts, Oberon;
+  CONST
+    MOV = 0; LSL = 1; ASR = 2; ROR = 3; AND = 4; ANN = 5; IOR = 6; XOR = 7;
+    ADD = 8; SUB = 9;  MUL = 10; Div = 11;
+
+  VAR IR: LONGINT;   (*instruction register*)
+    PC: LONGINT;   (*program counter*)
+    N, Z: BOOLEAN;  (*condition flags*)
+    R: ARRAY 16 OF LONGINT;
+    H: LONGINT;  (*aux register for division*)
+    
+  PROCEDURE Execute*(VAR M: ARRAY OF LONGINT; pc: LONGINT;
+      VAR S: Texts.Scanner; VAR W: Texts.Writer);
+    VAR a, b, op, im: LONGINT;  (*instruction fields*)
+      adr, A, B, C: LONGINT;
+      MemSize: LONGINT;
+  BEGIN PC := 0; R[13] := pc * 4; R[14] := LEN(M)*4;
+    REPEAT (*interpretation cycle*)
+      IR := M[PC]; INC(PC);
+      a := IR DIV 1000000H MOD 10H;
+      b := IR DIV 100000H MOD 10H;
+      op := IR DIV 10000H MOD 10H;
+      im := IR MOD 10000H;
+      IF ~ODD(ASH(IR, -31)) THEN  (*~p:  register instruction*)
+        B := R[b];
+        IF ~ODD(ASH(IR, -30)) THEN (*~q*) C := R[IR MOD 10H]
+        ELSIF ~ODD(ASH(IR, -28)) THEN (*q&~v*) C := im 
+        ELSE (*q&v*) C := im + 0FFFF0000H
+        END ;
+        CASE op OF
+            MOV: IF ~ODD(ASH(IR, -29)) THEN A := C ELSE A := H END |
+            LSL: A := SYSTEM.LSH(B, C) |
+            ASR: A := ASH(B, -C) |
+            ROR: A := SYSTEM.ROT(B, -C) |
+            AND: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) * SYSTEM.VAL(SET, C)) |
+            ANN: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) - SYSTEM.VAL(SET, C)) |
+            IOR: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) + SYSTEM.VAL(SET, C)) |
+            XOR: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) / SYSTEM.VAL(SET, C)) |
+            ADD: A := B + C |
+            SUB: A := B - C |
+            MUL: A := B * C |
+            Div: A := B DIV C; H := B MOD C
+         END ;
+         R[a] := A; N := A < 0; Z := A = 0
+      ELSIF ~ODD(ASH(IR, -30)) THEN (*p & ~q: memory instruction*)
+        adr := (R[b] + IR MOD 100000H) DIV 4;
+        IF ~ODD(ASH(IR, -29)) THEN
+          IF adr >= 0 THEN (*load*) R[a] := M[adr]; N := A < 0; Z := A = 0
+          ELSE (*input*)
+            IF adr = -1 THEN (*ReadInt*) Texts.Scan(S); R[a] := S.i;
+            ELSIF adr = -2 THEN (*eot*)  Z := S.class # Texts.Int
+            END 
+          END
+        ELSE
+          IF adr >= 0 THEN (*store*) M[adr] := R[a];
+          ELSE (*output*);
+            IF adr = -1 THEN Texts.WriteInt(W, R[a], 4)
+            ELSIF adr = -2 THEN Texts.Write(W, CHR(R[a] MOD 80H))
+            ELSIF adr = -3 THEN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+            END
+          END
+        END
+      ELSE (* p & q: branch instruction*)
+        IF (a = 0) & N OR (a = 1) & Z OR (a = 5) & N OR (a = 6) & (N OR Z) OR (a = 7) OR
+            (a = 8) & ~N OR (a = 9) & ~Z OR (a = 13) & ~N OR (a = 14) & ~(N OR Z) THEN
+          IF ODD(ASH(IR, -28)) THEN R[15] := PC * 4 END ;
+          IF ODD(ASH(IR, -29)) THEN PC := (PC + (IR MOD 1000000H)) MOD 40000H 
+          ELSE PC := R[IR MOD 10H] DIV 4
+          END
+        END
+      END
+    UNTIL PC = 0;
+    Texts.Append(Oberon.Log, W.buf)
+  END Execute;
+END RISC.
+
+

people.inf.ethz.ch/wirth/CompilerConstruction/TestOberon0.Mod.txt

@@ -1,137 +1,137 @@
-OSP.Compile @
-TestOberon0.Permutations 2 3 4~
-TestOberon0.MagicSquares  3~.
-TestOberon0.PrimeNumbers 12
-TestOberon0.Fractions 16
-TestOberon0.Powers 16
-
-MODULE TestOberon0;
-  VAR n: INTEGER;
-    a: ARRAY 10 OF INTEGER;
-
-  PROCEDURE perm(k: INTEGER);
-    VAR i, x: INTEGER;
-  BEGIN
-    IF k = 0 THEN i := 0;
-      WHILE i < n DO WriteInt(a[i], 5); i := i+1 END ;
-      WriteLn;
-    ELSE perm(k-1); i := 0;
-      WHILE i < k-1 DO
-        x := a[i]; a[i] := a[k-1]; a[k-1] := x;
-        perm(k-1);
-        x := a[i]; a[i] := a[k-1]; a[k-1] := x;
-        i := i+1
-      END
-    END
-  END perm;
-
-  PROCEDURE Permutations*;
-  BEGIN OpenInput; n := 0;
-    WHILE ~eot() DO ReadInt(a[n]); n := n+1 END ;
-    perm(n)
-  END Permutations;
-
-  PROCEDURE MagicSquares*;  (*magic square of order 3, 5, 7, ... *)
-    VAR i, j, x, nx, nsq, n: INTEGER;
-      M: ARRAY 13 OF ARRAY 13 OF INTEGER;
-  BEGIN OpenInput;
-    IF ~eot() THEN
-      ReadInt(n); nsq := n*n; x := 0;
-      i := n DIV 2; j := n-1;
-      WHILE x < nsq DO
-        nx := n + x; j := (j-1) MOD n; x := x+1; M[i][j] := x;
-        WHILE x < nx DO
-          i := (i+1) MOD n; j := (j+1) MOD n;
-          x := x+1; M[i][j] := x
-        END
-      END ;
-      i := 0;
-      WHILE i < n DO
-        j := 0;
-        WHILE j < n DO WriteInt(M[i][j], 6); j := j+1 END ;
-        i := i+1; WriteLn
-      END
-    END
-  END MagicSquares;
-
-  PROCEDURE PrimeNumbers*;
-    VAR i, k, m, x, inc, lim, sqr: INTEGER; prim: BOOLEAN;
-      p: ARRAY 400 OF INTEGER;
-      v: ARRAY 20 OF INTEGER;
-  BEGIN OpenInput; ReadInt(n);
-    x := 1; inc := 4; lim := 1; sqr := 4; m := 0; i := 3;
-    WHILE i <= n DO
-      REPEAT x := x + inc; inc := 6 - inc;
-        IF sqr <= x THEN  (*sqr = p[lim]^2*)
-          v[lim] := sqr; lim := lim + 1; sqr := p[lim]*p[lim]
-        END ;
-        k := 2; prim := TRUE;
-        WHILE prim & (k < lim) DO
-          k := k+1;
-          IF v[k] < x THEN v[k] := v[k] + p[k] END ;
-          prim := x # v[k]
-        END
-      UNTIL prim;
-      p[i] := x; WriteInt(x, 5); i := i+1;
-      IF m = 10 THEN WriteLn; m := 0 ELSE m := m+1 END
-    END ;
-    IF m > 0 THEN WriteLn END
-  END PrimeNumbers;
-
-  PROCEDURE Fractions*;  (* Tabulate fractions 1/n*)
-    CONST Base = 10; N = 32;
-    VAR i, j, m, r, n: INTEGER;
-      d: ARRAY N OF INTEGER;  (*digits*)
-      x: ARRAY N OF INTEGER;  (*index*)
-  BEGIN OpenInput;
-    IF ~eot() THEN
-      ReadInt(n); i := 2;
-      WHILE i <= n DO j := 0;
-        WHILE j < i DO x[j] := 0; j := j+1 END ;
-        m := 0; r := 1;
-        WHILE x[r] = 0 DO
-          x[r] := m; r := Base*r; d[m] := r DIV i; r := r MOD i; m := m+1
-        END ;
-        WriteInt(i, 5); WriteChar(9); WriteChar(46); j := 0;
-        WHILE j < x[r] DO WriteChar(d[j] + 48); j := j+1 END ;
-        WriteChar(32);  (*blank*)
-        WHILE j < m DO WriteChar(d[j] + 48); j := j+1 END ;
-        WriteLn; i := i+1
-      END
-    END
-  END Fractions;
-
-  PROCEDURE Powers*;
-    CONST N = 32; M = 11;  (*M ~ N*log2*)
-    VAR i, k, n, exp: INTEGER;
-      c, r, t: INTEGER;
-      d: ARRAY M OF INTEGER;
-      f: ARRAY N OF INTEGER;
-  BEGIN OpenInput;
-    IF ~eot() THEN
-      ReadInt(n); d[0] := 1; k := 1; exp := 1;
-      WHILE exp < n DO
-        (*compute d = 2^exp*)
-        c := 0;  (*carry*) i := 0;
-        WHILE i < k DO
-          t := 2*d[i] + c;
-          IF t < 10 THEN d[i] := t; c := 0 ELSE d[i] := t - 10; c := 1 END ;
-          i := i+1
-        END ;
-        IF c = 1 THEN d[k] := 1; k := k+1 END ;
-        (*write d*) i := M;
-        WHILE i > k DO i := i-1; WriteChar(32) (*blank*) END ;
-        WHILE i > 0 DO i := i-1; WriteChar(d[i] + 48) END ;
-        WriteInt(exp, M);
-        (*compute  f = 2^-exp*)
-        WriteChar(9);; WriteChar(46); r := 0; i := 1;
-        WHILE i < exp DO
-          r := 10*r + f[i]; f[i] := r DIV 2; r := r MOD 2;
-          WriteChar(f[i] + 48); i := i+1
-        END ;
-        f[exp] := 5; WriteChar(53); (*5*) WriteLn; exp := exp + 1
-      END
-    END
-  END Powers;
-
-END TestOberon0.
+OSP.Compile @
+TestOberon0.Permutations 2 3 4~
+TestOberon0.MagicSquares  3~.
+TestOberon0.PrimeNumbers 12
+TestOberon0.Fractions 16
+TestOberon0.Powers 16
+
+MODULE TestOberon0;
+  VAR n: INTEGER;
+    a: ARRAY 10 OF INTEGER;
+
+  PROCEDURE perm(k: INTEGER);
+    VAR i, x: INTEGER;
+  BEGIN
+    IF k = 0 THEN i := 0;
+      WHILE i < n DO WriteInt(a[i], 5); i := i+1 END ;
+      WriteLn;
+    ELSE perm(k-1); i := 0;
+      WHILE i < k-1 DO
+        x := a[i]; a[i] := a[k-1]; a[k-1] := x;
+        perm(k-1);
+        x := a[i]; a[i] := a[k-1]; a[k-1] := x;
+        i := i+1
+      END
+    END
+  END perm;
+
+  PROCEDURE Permutations*;
+  BEGIN OpenInput; n := 0;
+    WHILE ~eot() DO ReadInt(a[n]); n := n+1 END ;
+    perm(n)
+  END Permutations;
+
+  PROCEDURE MagicSquares*;  (*magic square of order 3, 5, 7, ... *)
+    VAR i, j, x, nx, nsq, n: INTEGER;
+      M: ARRAY 13 OF ARRAY 13 OF INTEGER;
+  BEGIN OpenInput;
+    IF ~eot() THEN
+      ReadInt(n); nsq := n*n; x := 0;
+      i := n DIV 2; j := n-1;
+      WHILE x < nsq DO
+        nx := n + x; j := (j-1) MOD n; x := x+1; M[i][j] := x;
+        WHILE x < nx DO
+          i := (i+1) MOD n; j := (j+1) MOD n;
+          x := x+1; M[i][j] := x
+        END
+      END ;
+      i := 0;
+      WHILE i < n DO
+        j := 0;
+        WHILE j < n DO WriteInt(M[i][j], 6); j := j+1 END ;
+        i := i+1; WriteLn
+      END
+    END
+  END MagicSquares;
+
+  PROCEDURE PrimeNumbers*;
+    VAR i, k, m, x, inc, lim, sqr: INTEGER; prim: BOOLEAN;
+      p: ARRAY 400 OF INTEGER;
+      v: ARRAY 20 OF INTEGER;
+  BEGIN OpenInput; ReadInt(n);
+    x := 1; inc := 4; lim := 1; sqr := 4; m := 0; i := 3;
+    WHILE i <= n DO
+      REPEAT x := x + inc; inc := 6 - inc;
+        IF sqr <= x THEN  (*sqr = p[lim]^2*)
+          v[lim] := sqr; lim := lim + 1; sqr := p[lim]*p[lim]
+        END ;
+        k := 2; prim := TRUE;
+        WHILE prim & (k < lim) DO
+          k := k+1;
+          IF v[k] < x THEN v[k] := v[k] + p[k] END ;
+          prim := x # v[k]
+        END
+      UNTIL prim;
+      p[i] := x; WriteInt(x, 5); i := i+1;
+      IF m = 10 THEN WriteLn; m := 0 ELSE m := m+1 END
+    END ;
+    IF m > 0 THEN WriteLn END
+  END PrimeNumbers;
+
+  PROCEDURE Fractions*;  (* Tabulate fractions 1/n*)
+    CONST Base = 10; N = 32;
+    VAR i, j, m, r, n: INTEGER;
+      d: ARRAY N OF INTEGER;  (*digits*)
+      x: ARRAY N OF INTEGER;  (*index*)
+  BEGIN OpenInput;
+    IF ~eot() THEN
+      ReadInt(n); i := 2;
+      WHILE i <= n DO j := 0;
+        WHILE j < i DO x[j] := 0; j := j+1 END ;
+        m := 0; r := 1;
+        WHILE x[r] = 0 DO
+          x[r] := m; r := Base*r; d[m] := r DIV i; r := r MOD i; m := m+1
+        END ;
+        WriteInt(i, 5); WriteChar(9); WriteChar(46); j := 0;
+        WHILE j < x[r] DO WriteChar(d[j] + 48); j := j+1 END ;
+        WriteChar(32);  (*blank*)
+        WHILE j < m DO WriteChar(d[j] + 48); j := j+1 END ;
+        WriteLn; i := i+1
+      END
+    END
+  END Fractions;
+
+  PROCEDURE Powers*;
+    CONST N = 32; M = 11;  (*M ~ N*log2*)
+    VAR i, k, n, exp: INTEGER;
+      c, r, t: INTEGER;
+      d: ARRAY M OF INTEGER;
+      f: ARRAY N OF INTEGER;
+  BEGIN OpenInput;
+    IF ~eot() THEN
+      ReadInt(n); d[0] := 1; k := 1; exp := 1;
+      WHILE exp < n DO
+        (*compute d = 2^exp*)
+        c := 0;  (*carry*) i := 0;
+        WHILE i < k DO
+          t := 2*d[i] + c;
+          IF t < 10 THEN d[i] := t; c := 0 ELSE d[i] := t - 10; c := 1 END ;
+          i := i+1
+        END ;
+        IF c = 1 THEN d[k] := 1; k := k+1 END ;
+        (*write d*) i := M;
+        WHILE i > k DO i := i-1; WriteChar(32) (*blank*) END ;
+        WHILE i > 0 DO i := i-1; WriteChar(d[i] + 48) END ;
+        WriteInt(exp, M);
+        (*compute  f = 2^-exp*)
+        WriteChar(9);; WriteChar(46); r := 0; i := 1;
+        WHILE i < exp DO
+          r := 10*r + f[i]; f[i] := r DIV 2; r := r MOD 2;
+          WriteChar(f[i] + 48); i := i+1
+        END ;
+        f[exp] := 5; WriteChar(53); (*5*) WriteLn; exp := exp + 1
+      END
+    END
+  END Powers;
+
+END TestOberon0.

people.inf.ethz.ch/wirth/CompilerConstruction/index.html

@@ -1,24 +1,24 @@
-<HTML>
-<HEAD>
-   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
-   <TITLE>Compiler Construction</TITLE>
-</HEAD>
-<BODY>
-  <H1>Compiler Construction</H1>
-  <UL>
-    <LI><A HREF="CompilerConstruction1.pdf">Chapters 1-8</A>
-    <LI><A HREF="CompilerConstruction2.pdf">Chapters 9-16</A>
-  </UL>
-  &nbsp;
-  <A HREF="RISC.Mod.txt">RISC.Mod</A>
-  <A HREF="OSS.Mod.txt">OSS.Mod</A>
-  <A HREF="OSG.Mod.txt">OSG.Mod</A>
-  <A HREF="OSP.Mod.txt">OSP.Mod</A>
-  <A HREF="IO.Mod.txt">IO.Mod</A>
-  <A HREF="TestOberon0.Mod.txt">TestOberon0.Mod</A>
-  <BR>&nbsp;
-<HR>
-<P>
-Back to my <A HREF="../index.html">home page</A>.
-</BODY>
-</HTML>
+<HTML>
+<HEAD>
+   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+   <TITLE>Compiler Construction</TITLE>
+</HEAD>
+<BODY>
+  <H1>Compiler Construction</H1>
+  <UL>
+    <LI><A HREF="CompilerConstruction1.pdf">Chapters 1-8</A>
+    <LI><A HREF="CompilerConstruction2.pdf">Chapters 9-16</A>
+  </UL>
+  &nbsp;
+  <A HREF="RISC.Mod.txt">RISC.Mod</A>
+  <A HREF="OSS.Mod.txt">OSS.Mod</A>
+  <A HREF="OSG.Mod.txt">OSG.Mod</A>
+  <A HREF="OSP.Mod.txt">OSP.Mod</A>
+  <A HREF="IO.Mod.txt">IO.Mod</A>
+  <A HREF="TestOberon0.Mod.txt">TestOberon0.Mod</A>
+  <BR>&nbsp;
+<HR>
+<P>
+Back to my <A HREF="../index.html">home page</A>.
+</BODY>
+</HTML>

people.inf.ethz.ch/wirth/FPGA-relatedWork/Divider.v

@@ -1,28 +1,28 @@
-`timescale 1ns / 1ps  // NW 31.10.10
-
-module Divider(
-  input clk, run,
-  output stall,
-  input [31:0] x, y,
-  output [31:0] quot, rem);
-
-reg [4:0] S;  // state
-reg [31:0] r3, q2;
-wire [31:0] r0, r1, r2, q0, q1, d;
-
-assign stall = run & ~(S == 31);
-assign r0 = (S == 0) ? 0 : r3;
-assign d = r1 - y;
-assign r1 = {r0[30:0], q0[31]};
-assign r2 = d[31] ? r1 : d;
-assign q0 = (S == 0) ? x : q2;
-assign q1 = {q0[30:0], ~d[31]};
-assign rem = r2;
-assign quot = q1;
-
-always @ (posedge(clk)) begin
-  r3 <= r2; q2 <= q1;
-  S <= run ? S+1 : 0;
-end
-
-endmodule
+`timescale 1ns / 1ps  // NW 31.10.10
+
+module Divider(
+  input clk, run,
+  output stall,
+  input [31:0] x, y,
+  output [31:0] quot, rem);
+
+reg [4:0] S;  // state
+reg [31:0] r3, q2;
+wire [31:0] r0, r1, r2, q0, q1, d;
+
+assign stall = run & ~(S == 31);
+assign r0 = (S == 0) ? 0 : r3;
+assign d = r1 - y;
+assign r1 = {r0[30:0], q0[31]};
+assign r2 = d[31] ? r1 : d;
+assign q0 = (S == 0) ? x : q2;
+assign q1 = {q0[30:0], ~d[31]};
+assign rem = r2;
+assign quot = q1;
+
+always @ (posedge(clk)) begin
+  r3 <= r2; q2 <= q1;
+  S <= run ? S+1 : 0;
+end
+
+endmodule

people.inf.ethz.ch/wirth/FPGA-relatedWork/Multiplier.v

@@ -1,28 +1,28 @@
-`timescale 1ns / 1ps  // NW 3.12.2010
-
-module Multiplier(
-  input clk, run, u,
-  output stall,
-  input [31:0] x, y,
-  output [63:0] z);
-
-reg [4:0] S;    // state
-reg [31:0] B2, A2;  // high and low parts of partial product
-wire [32:0] B0, B00, B01;
-wire [31:0] B1, A0, A1;
-
-assign stall = run & ~(S == 31);
-assign B00 = (S == 0) ? 0 : {B2[31] & u, B2};
-assign B01 = A0[0] ? {y[31] & u, y} : 0;
-assign B0 = ((S == 31) & u) ? B00 - B01 : B00 + B01;
-assign B1 = B0[32:1];
-assign A0 = (S == 0) ? x : A2;
-assign A1 = {B0[0], A0[31:1]};
-assign z = {B1, A1};
-
-always @ (posedge(clk)) begin
-  B2 <= B1; A2 <= A1;
-  S <= run ? S+1 : 0;
-end
-
-endmodule
+`timescale 1ns / 1ps  // NW 3.12.2010
+
+module Multiplier(
+  input clk, run, u,
+  output stall,
+  input [31:0] x, y,
+  output [63:0] z);
+
+reg [4:0] S;    // state
+reg [31:0] B2, A2;  // high and low parts of partial product
+wire [32:0] B0, B00, B01;
+wire [31:0] B1, A0, A1;
+
+assign stall = run & ~(S == 31);
+assign B00 = (S == 0) ? 0 : {B2[31] & u, B2};
+assign B01 = A0[0] ? {y[31] & u, y} : 0;
+assign B0 = ((S == 31) & u) ? B00 - B01 : B00 + B01;
+assign B1 = B0[32:1];
+assign A0 = (S == 0) ? x : A2;
+assign A1 = {B0[0], A0[31:1]};
+assign z = {B1, A1};
+
+always @ (posedge(clk)) begin
+  B2 <= B1; A2 <= A1;
+  S <= run ? S+1 : 0;
+end
+
+endmodule

people.inf.ethz.ch/wirth/FPGA-relatedWork/Multiplier1.v

@@ -1,28 +1,28 @@
-`timescale 1ns / 1ps  // NW 29.4.2011
-module Multiplier1(
-  input clk, run, u,
-  output stall,
-  input [31:0] x, y,
-  output [63:0] z);
-	 
-reg S;  // state
-reg [15:0] z0;
-reg [47:0] z1, z2;
-wire [35:0] p0, p1, p2, p3;
-
-assign stall = run & ~S;
-assign z[15:0] = z0;
-assign z[63:16] = z1 + z2;
-
-MULT18X18 mult0(.P(p0), .A({2'b0, x[15:0]}), .B({2'b0, y[15:0]}));
-MULT18X18 mult1(.P(p1), .A({{2{u&x[31]}}, x[31:16]}), .B({2'b0, y[15:0]}));
-MULT18X18 mult2(.P(p2), .A({2'b0, x[15:0]}), .B({{2{u&y[31]}}, y[31:16]}));
-MULT18X18 mult3(.P(p3), .A({{2{u&x[31]}}, x[31:16]}), .B({{2{u&y[31]}}, y[31:16]}));
-
-always @(posedge clk) begin
-  S <= stall;
-  z0 <= p0[15:0];
-  z1 <= {{32'b0}, p0[31:16]} + {{16{u&p1[31]}}, p1[31:0]};
-  z2 <= {{16{u&p2[31]}}, p2[31:0]} + {p3[31:0], 16'b0};
-end
-endmodule
+`timescale 1ns / 1ps  // NW 29.4.2011
+module Multiplier1(
+  input clk, run, u,
+  output stall,
+  input [31:0] x, y,
+  output [63:0] z);
+	 
+reg S;  // state
+reg [15:0] z0;
+reg [47:0] z1, z2;
+wire [35:0] p0, p1, p2, p3;
+
+assign stall = run & ~S;
+assign z[15:0] = z0;
+assign z[63:16] = z1 + z2;
+
+MULT18X18 mult0(.P(p0), .A({2'b0, x[15:0]}), .B({2'b0, y[15:0]}));
+MULT18X18 mult1(.P(p1), .A({{2{u&x[31]}}, x[31:16]}), .B({2'b0, y[15:0]}));
+MULT18X18 mult2(.P(p2), .A({2'b0, x[15:0]}), .B({{2{u&y[31]}}, y[31:16]}));
+MULT18X18 mult3(.P(p3), .A({{2{u&x[31]}}, x[31:16]}), .B({{2{u&y[31]}}, y[31:16]}));
+
+always @(posedge clk) begin
+  S <= stall;
+  z0 <= p0[15:0];
+  z1 <= {{32'b0}, p0[31:16]} + {{16{u&p1[31]}}, p1[31:0]};
+  z2 <= {{16{u&p2[31]}}, p2[31:0]} + {p3[31:0], 16'b0};
+end
+endmodule

people.inf.ethz.ch/wirth/FPGA-relatedWork/RISC0.ucf

@@ -1,24 +1,24 @@
-NET "CLK50M" LOC = "T9" ;
-NET "CLK50M" PERIOD = 20.0ns HIGH 50%;
-NET "rstIN" LOC = "L14";
-
-NET "TxD" LOC = "R13"; 
-NET "RxD" LOC = "T13" ; 
-
-NET "swi[0]" LOC = "F12";
-NET "swi[1]" LOC = "G12";
-NET "swi[2]" LOC = "H14";
-NET "swi[3]" LOC = "H13";
-NET "swi[4]" LOC = "J14";
-NET "swi[5]" LOC = "J13";
-NET "swi[6]" LOC = "K14";
-NET "swi[7]" LOC = "K13";
-
-NET "leds[0]" LOC = "K12";
-NET "leds[1]" LOC = "P14";
-NET "leds[2]" LOC = "L12";
-NET "leds[3]" LOC = "N14";
-NET "leds[4]" LOC = "P13";
-NET "leds[5]" LOC = "N12";
-NET "leds[6]" LOC = "P12";
-NET "leds[7]" LOC = "P11";
+NET "CLK50M" LOC = "T9" ;
+NET "CLK50M" PERIOD = 20.0ns HIGH 50%;
+NET "rstIN" LOC = "L14";
+
+NET "TxD" LOC = "R13"; 
+NET "RxD" LOC = "T13" ; 
+
+NET "swi[0]" LOC = "F12";
+NET "swi[1]" LOC = "G12";
+NET "swi[2]" LOC = "H14";
+NET "swi[3]" LOC = "H13";
+NET "swi[4]" LOC = "J14";
+NET "swi[5]" LOC = "J13";
+NET "swi[6]" LOC = "K14";
+NET "swi[7]" LOC = "K13";
+
+NET "leds[0]" LOC = "K12";
+NET "leds[1]" LOC = "P14";
+NET "leds[2]" LOC = "L12";
+NET "leds[3]" LOC = "N14";
+NET "leds[4]" LOC = "P13";
+NET "leds[5]" LOC = "N12";
+NET "leds[6]" LOC = "P12";
+NET "leds[7]" LOC = "P11";

people.inf.ethz.ch/wirth/FPGA-relatedWork/RISC0.v

@@ -1,180 +1,180 @@
-`timescale 1ns / 1ps  // NW 8.10.12  rev. 26.12.2013
-
-module RISC0(
-input clk, rst,
-input [31:0] inbus,
-output [5:0] ioadr,
-output iord, iowr,
-output [31:0] outbus);
-
-reg [11:0] PC;
-reg N, Z, C, OV;  // condition flags
-reg [31:0] R [0:15];  // array of 16 registers
-reg [31:0] H;  // aux register
-reg stall1;
-
-wire [31:0] IR;
-wire [31:0] pmout;
-wire [11:0] pcmux, nxpc;
-wire cond, S;
-wire sa, sb, sc;
-
-wire p, q, u, v, w;  // instruction fields
-wire [3:0] op, ira, ira0, irb, irc;
-wire [2:0] cc;
-wire [15:0] imm;
-wire [19:0] off;
-
-wire regwr;
-wire [13:0] dmadr;
-wire dmwr, ioenb;
-wire [31:0] dmin, dmout;
-wire [1:0] sc1, sc0;  // shift counts
-
-wire [31:0] A, B, C0, C1, regmux;
-wire [31:0] s1, s2, s3, t1, t2, t3;
-wire [32:0] aluRes;
-wire [31:0] quotient, remainder;
-wire [63:0] product;
-wire stall, stallL, stallM, stallD;
-
-wire MOV, LSL, ASR, ROR, AND, ANN, IOR, XOR;  // operation signals
-wire ADD, SUB, MUL, DIV; 
-wire LDR, STR, BR;
-
-PROM PM (.adr(pcmux[10:0]), .data(pmout), .clk(clk));
-DRAM DM (.adr(dmadr[12:2]), .din(dmin), .dout(dmout), .we(dmwr), .clk(clk));
-
-Multiplier1 mulUnit (.clk(clk), .run(MUL), .stall(stallM),
-   .u(~u), .x(B), .y(C1), .z(product));
-
-Divider divUnit (.clk(clk), .run(DIV), .stall(stallD),
-   .x(B), .y(C1), .quot(quotient), .rem(remainder));
-
-assign IR = pmout;  // decoding
-assign p = IR[31];
-assign q = IR[30];
-assign u = IR[29];
-assign v = IR[28];
-assign w = IR[16];
-assign cc  = IR[26:24];
-assign ira = IR[27:24];
-assign irb = IR[23:20];
-assign op  = IR[19:16];
-assign irc = IR[3:0];
-assign imm = IR[15:0];
-assign off = IR[19:0];
-
-assign MOV = ~p & (op == 0);
-assign LSL = ~p & (op == 1);
-assign ASR = ~p & (op == 2);
-assign ROR = ~p & (op == 3);
-assign AND = ~p & (op == 4);
-assign ANN = ~p & (op == 5);
-assign IOR = ~p & (op == 6);
-assign XOR = ~p & (op == 7);
-assign ADD = ~p & (op == 8);
-assign SUB = ~p & (op == 9);
-assign MUL = ~p & (op == 10);
-assign DIV = ~p & (op == 11);
-
-assign LDR = p & ~q & ~u;
-assign STR = p & ~q & u;
-assign BR  = p & q;
-
-assign A = R[ira0];  // register data signals
-assign B = R[irb];
-assign C0 = R[irc];
-
-// Arithmetic-logical unit (ALU)
-assign ira0 = BR ? 15 : ira;
-assign C1 = ~q ? C0 : {{16{v}}, imm};
-assign dmadr = B[13:0] + off[13:0];
-assign dmwr = STR & ~stall;
-assign dmin = A;
-
-assign ioenb = (dmadr[13:6] == 8'b11111111);
-assign iowr = STR & ioenb;
-assign iord = LDR & ioenb;
-assign ioadr = dmadr[5:0];
-assign outbus = A;
-
-assign sc0 = C1[1:0];
-assign sc1 = C1[3:2];
-
-// shifter for ASR and ROR
-assign s1 = (sc0 == 3) ? {(w ? B[2:0] : {3{B[31]}}), B[31:3]} :
-    (sc0 == 2) ? {(w ? B[1:0] : {2{B[31]}}), B[31:2]} :
-    (sc0 == 1) ? {(w ? B[0] : B[31]), B[31:1]} : B;
-assign s2 = (sc1 == 3) ? {(w ? s1[11:0] : {12{s1[31]}}), s1[31:12]} :
-    (sc1 == 2) ? {(w ? s1[7:0] : {8{s1[31]}}), s1[31:8]} :
-    (sc1 == 1) ? {(w ? s1[3:0] : {4{s1[31]}}), s1[31:4]} : s1;
-assign s3 = C1[4] ? {(w ? s2[15:0] : {16{s2[31]}}), s2[31:16]} : s2;
-
-// shifter for LSL
-assign t1 = (sc0 == 3) ? {B[28:0], 3'b0} :
-    (sc0 == 2) ? {B[29:0], 2'b0} :
-    (sc0 == 1) ? {B[30:0], 1'b0} : B;
-assign t2 = (sc1 == 3) ? {t1[19:0], 12'b0} :
-    (sc1 == 2) ? {t1[23:0], 8'b0} :
-    (sc1 == 1) ? {t1[27:0], 4'b0} : t1;
-assign t3 = C1[4] ? {t2[15:0], 16'b0} : t2;
-
-assign aluRes =
-  MOV ? (q ?
-    (~u ? {{16{v}}, imm} : {imm, 16'b0}) :
-    (~u ? C0 : (~v ? H : {N, Z, C, OV, 20'b0, 8'b10100000}))) :
-  LSL ? t3 :
-  (ASR|ROR) ? s3 :
-  AND ? B & C1 :
-  ANN ? B & ~C1 :
-  IOR  ? B | C1 :
-  XOR ? B ^ C1 :
-  ADD ? B + C1 + (u & C) :
-  SUB ? B - C1 - (u & C) :
-  MUL ? product[31:0] :
-  DIV ? quotient : 0;
-
-assign regwr = ~p & ~stall | (LDR & stall1)| (BR & cond & v) ;
-assign regmux = 
-  (LDR & ~ioenb) ? dmout :
-  (LDR & ioenb) ? inbus :
-  (BR & v) ? {18'b0, nxpc, 2'b0} : aluRes;
-
-// Control unit CU
-assign S = N ^ OV;
-assign nxpc = PC + 1;
-assign cond = IR[27] ^
-  ((cc == 0) & N | // MI, PL
-   (cc == 1) & Z | // EQ, NE
-   (cc == 2) & C | // CS, CC
-   (cc == 3) & OV | // VS, VC
-   (cc == 4) & (C|Z) | // LS, HI
-   (cc == 5) & S | // LT, GE
-   (cc == 6) & (S|Z) | // LE, GT
-   (cc == 7)); // T, F
-
-assign pcmux =
-  (~rst) ? 0 :
-  (stall) ? PC :
-  (BR & cond & u) ? off[11:0] + nxpc :
-  (BR & cond & ~u) ? C0[13:2] : nxpc;
-
-assign sa = aluRes[31];
-assign sb = B[31];
-assign sc = C1[31] ^ SUB;
-
-assign stall = stallL | stallM | stallD;
-assign stallL = LDR & ~stall1;
-
-always @ (posedge clk) begin
-  PC <= pcmux;
-  stall1 <= stallL;
-  R[ira0] <= regwr ? regmux : A;
-  N <= regwr ? regmux[31] : N;
-  Z <= regwr ? (regmux[31:0] == 0) : Z;
-  C <= (ADD|SUB) ? aluRes[32] : C;
-  OV <= (ADD|SUB) ? (sa & ~sb & ~sc | ~sa & sb & sc) : OV;
-  H <= MUL ? product[63:32] : DIV ? remainder : H;
-end 
-endmodule 
+`timescale 1ns / 1ps  // NW 8.10.12  rev. 26.12.2013
+
+module RISC0(
+input clk, rst,
+input [31:0] inbus,
+output [5:0] ioadr,
+output iord, iowr,
+output [31:0] outbus);
+
+reg [11:0] PC;
+reg N, Z, C, OV;  // condition flags
+reg [31:0] R [0:15];  // array of 16 registers
+reg [31:0] H;  // aux register
+reg stall1;
+
+wire [31:0] IR;
+wire [31:0] pmout;
+wire [11:0] pcmux, nxpc;
+wire cond, S;
+wire sa, sb, sc;
+
+wire p, q, u, v, w;  // instruction fields
+wire [3:0] op, ira, ira0, irb, irc;
+wire [2:0] cc;
+wire [15:0] imm;
+wire [19:0] off;
+
+wire regwr;
+wire [13:0] dmadr;
+wire dmwr, ioenb;
+wire [31:0] dmin, dmout;
+wire [1:0] sc1, sc0;  // shift counts
+
+wire [31:0] A, B, C0, C1, regmux;
+wire [31:0] s1, s2, s3, t1, t2, t3;
+wire [32:0] aluRes;
+wire [31:0] quotient, remainder;
+wire [63:0] product;
+wire stall, stallL, stallM, stallD;
+
+wire MOV, LSL, ASR, ROR, AND, ANN, IOR, XOR;  // operation signals
+wire ADD, SUB, MUL, DIV; 
+wire LDR, STR, BR;
+
+PROM PM (.adr(pcmux[10:0]), .data(pmout), .clk(clk));
+DRAM DM (.adr(dmadr[12:2]), .din(dmin), .dout(dmout), .we(dmwr), .clk(clk));
+
+Multiplier1 mulUnit (.clk(clk), .run(MUL), .stall(stallM),
+   .u(~u), .x(B), .y(C1), .z(product));
+
+Divider divUnit (.clk(clk), .run(DIV), .stall(stallD),
+   .x(B), .y(C1), .quot(quotient), .rem(remainder));
+
+assign IR = pmout;  // decoding
+assign p = IR[31];
+assign q = IR[30];
+assign u = IR[29];
+assign v = IR[28];
+assign w = IR[16];
+assign cc  = IR[26:24];
+assign ira = IR[27:24];
+assign irb = IR[23:20];
+assign op  = IR[19:16];
+assign irc = IR[3:0];
+assign imm = IR[15:0];
+assign off = IR[19:0];
+
+assign MOV = ~p & (op == 0);
+assign LSL = ~p & (op == 1);
+assign ASR = ~p & (op == 2);
+assign ROR = ~p & (op == 3);
+assign AND = ~p & (op == 4);
+assign ANN = ~p & (op == 5);
+assign IOR = ~p & (op == 6);
+assign XOR = ~p & (op == 7);
+assign ADD = ~p & (op == 8);
+assign SUB = ~p & (op == 9);
+assign MUL = ~p & (op == 10);
+assign DIV = ~p & (op == 11);
+
+assign LDR = p & ~q & ~u;
+assign STR = p & ~q & u;
+assign BR  = p & q;
+
+assign A = R[ira0];  // register data signals
+assign B = R[irb];
+assign C0 = R[irc];
+
+// Arithmetic-logical unit (ALU)
+assign ira0 = BR ? 15 : ira;
+assign C1 = ~q ? C0 : {{16{v}}, imm};
+assign dmadr = B[13:0] + off[13:0];
+assign dmwr = STR & ~stall;
+assign dmin = A;
+
+assign ioenb = (dmadr[13:6] == 8'b11111111);
+assign iowr = STR & ioenb;
+assign iord = LDR & ioenb;
+assign ioadr = dmadr[5:0];
+assign outbus = A;
+
+assign sc0 = C1[1:0];
+assign sc1 = C1[3:2];
+
+// shifter for ASR and ROR
+assign s1 = (sc0 == 3) ? {(w ? B[2:0] : {3{B[31]}}), B[31:3]} :
+    (sc0 == 2) ? {(w ? B[1:0] : {2{B[31]}}), B[31:2]} :
+    (sc0 == 1) ? {(w ? B[0] : B[31]), B[31:1]} : B;
+assign s2 = (sc1 == 3) ? {(w ? s1[11:0] : {12{s1[31]}}), s1[31:12]} :
+    (sc1 == 2) ? {(w ? s1[7:0] : {8{s1[31]}}), s1[31:8]} :
+    (sc1 == 1) ? {(w ? s1[3:0] : {4{s1[31]}}), s1[31:4]} : s1;
+assign s3 = C1[4] ? {(w ? s2[15:0] : {16{s2[31]}}), s2[31:16]} : s2;
+
+// shifter for LSL
+assign t1 = (sc0 == 3) ? {B[28:0], 3'b0} :
+    (sc0 == 2) ? {B[29:0], 2'b0} :
+    (sc0 == 1) ? {B[30:0], 1'b0} : B;
+assign t2 = (sc1 == 3) ? {t1[19:0], 12'b0} :
+    (sc1 == 2) ? {t1[23:0], 8'b0} :
+    (sc1 == 1) ? {t1[27:0], 4'b0} : t1;
+assign t3 = C1[4] ? {t2[15:0], 16'b0} : t2;
+
+assign aluRes =
+  MOV ? (q ?
+    (~u ? {{16{v}}, imm} : {imm, 16'b0}) :
+    (~u ? C0 : (~v ? H : {N, Z, C, OV, 20'b0, 8'b10100000}))) :
+  LSL ? t3 :
+  (ASR|ROR) ? s3 :
+  AND ? B & C1 :
+  ANN ? B & ~C1 :
+  IOR  ? B | C1 :
+  XOR ? B ^ C1 :
+  ADD ? B + C1 + (u & C) :
+  SUB ? B - C1 - (u & C) :
+  MUL ? product[31:0] :
+  DIV ? quotient : 0;
+
+assign regwr = ~p & ~stall | (LDR & stall1)| (BR & cond & v) ;
+assign regmux = 
+  (LDR & ~ioenb) ? dmout :
+  (LDR & ioenb) ? inbus :
+  (BR & v) ? {18'b0, nxpc, 2'b0} : aluRes;
+
+// Control unit CU
+assign S = N ^ OV;
+assign nxpc = PC + 1;
+assign cond = IR[27] ^
+  ((cc == 0) & N | // MI, PL
+   (cc == 1) & Z | // EQ, NE
+   (cc == 2) & C | // CS, CC
+   (cc == 3) & OV | // VS, VC
+   (cc == 4) & (C|Z) | // LS, HI
+   (cc == 5) & S | // LT, GE
+   (cc == 6) & (S|Z) | // LE, GT
+   (cc == 7)); // T, F
+
+assign pcmux =
+  (~rst) ? 0 :
+  (stall) ? PC :
+  (BR & cond & u) ? off[11:0] + nxpc :
+  (BR & cond & ~u) ? C0[13:2] : nxpc;
+
+assign sa = aluRes[31];
+assign sb = B[31];
+assign sc = C1[31] ^ SUB;
+
+assign stall = stallL | stallM | stallD;
+assign stallL = LDR & ~stall1;
+
+always @ (posedge clk) begin
+  PC <= pcmux;
+  stall1 <= stallL;
+  R[ira0] <= regwr ? regmux : A;
+  N <= regwr ? regmux[31] : N;
+  Z <= regwr ? (regmux[31:0] == 0) : Z;
+  C <= (ADD|SUB) ? aluRes[32] : C;
+  OV <= (ADD|SUB) ? (sa & ~sb & ~sc | ~sa & sb & sc) : OV;
+  H <= MUL ? product[63:32] : DIV ? remainder : H;
+end 
+endmodule 

people.inf.ethz.ch/wirth/FPGA-relatedWork/RISC0Top.v

@@ -51,7 +51,7 @@ begin
 end
 
 //The Clocks
-IBUFG clkInBuf(.I(CLK50M), .O(clk50));
+IBUFG clkInBuf(.I(CLK50M), .O(clk50));
 always @ (posedge clk50) clk25 <= ~clk25;
 BUFG clk150buf(.I(clk25), .O(clk));
 endmodule

people.inf.ethz.ch/wirth/FPGA-relatedWork/RS232R.v

@@ -1,34 +1,34 @@
-`timescale 1ns / 1ps  // NW 4.5.09 / 15.8.10 / 15.11.10
-
-// RS232 receiver for 19200 bps, 8 bit data
-// clock is 25 MHz; 25000 / 1302 = 19.2 KHz
-// clock is 35 MHz; 35000 / 1823 = 19.2 KHz
-
-module RS232R(
-    input clk, rst,
-    input done,   // "byte has been read"
-    input RxD,
-    output rdy,
-    output [7:0] data);
-
-wire endtick, midtick;
-reg run, stat;
-reg [11:0] tick;
-reg [3:0] bitcnt;
-reg [7:0] shreg;
-
-assign endtick = tick == 1302;
-assign midtick = tick == 651;
-assign endbit = bitcnt == 8;
-assign data = shreg;
-assign rdy = stat;
-
-always @ (posedge clk) begin
-  run <= (~RxD) ? 1 : (~rst | endtick & endbit) ? 0 : run;
-  tick <= (run & ~endtick) ? tick + 1 : 0;
-  bitcnt <= (endtick & ~endbit) ? bitcnt + 1 :
-    (endtick & endbit) ? 0 : bitcnt;
-  shreg <= midtick ? {RxD, shreg[7:1]} : shreg;
-  stat <= (endtick & endbit) ? 1 : (~rst | done) ? 0 : stat;
-end	 
-endmodule
+`timescale 1ns / 1ps  // NW 4.5.09 / 15.8.10 / 15.11.10
+
+// RS232 receiver for 19200 bps, 8 bit data
+// clock is 25 MHz; 25000 / 1302 = 19.2 KHz
+// clock is 35 MHz; 35000 / 1823 = 19.2 KHz
+
+module RS232R(
+    input clk, rst,
+    input done,   // "byte has been read"
+    input RxD,
+    output rdy,
+    output [7:0] data);
+
+wire endtick, midtick;
+reg run, stat;
+reg [11:0] tick;
+reg [3:0] bitcnt;
+reg [7:0] shreg;
+
+assign endtick = tick == 1302;
+assign midtick = tick == 651;
+assign endbit = bitcnt == 8;
+assign data = shreg;
+assign rdy = stat;
+
+always @ (posedge clk) begin
+  run <= (~RxD) ? 1 : (~rst | endtick & endbit) ? 0 : run;
+  tick <= (run & ~endtick) ? tick + 1 : 0;
+  bitcnt <= (endtick & ~endbit) ? bitcnt + 1 :
+    (endtick & endbit) ? 0 : bitcnt;
+  shreg <= midtick ? {RxD, shreg[7:1]} : shreg;
+  stat <= (endtick & endbit) ? 1 : (~rst | done) ? 0 : stat;
+end	 
+endmodule

people.inf.ethz.ch/wirth/FPGA-relatedWork/RS232T.v

@@ -1,33 +1,33 @@
-`timescale 1ns / 1ps  // NW 4.5.09 / 15.8.10 / 15.11.10
-
-// RS232 receiver for 19200 bps, 8 bit data
-// clock is 25 MHz; 25000 / 1302 = 19.2 KHz
-// clock is 35 MHz; 35000 / 1823 = 19.2 KHz
-
-module RS232T(
-    input clk, rst,
-    input start, // request to accept and send a byte
-    input [7:0] data,
-    output rdy,
-    output TxD);
-
-wire endtick, endbit;
-reg run;
-reg [11:0] tick;
-reg [3:0] bitcnt;
-reg [8:0] shreg;
-
-assign endtick = tick == 1302;
-assign endbit = bitcnt == 9;
-assign rdy = ~run;
-assign TxD = shreg[0];
-
-always @ (posedge clk) begin
-  run <= (~rst | endtick & endbit) ? 0 : start ? 1 : run;
-  tick <= (run & ~endtick) ? tick + 1 : 0;
-  bitcnt <= (endtick & ~endbit) ? bitcnt + 1 :
-    (endtick & endbit) ? 0 : bitcnt;
-  shreg <= (~rst) ? 1 : start ? {data, 1'b0} :
-    endtick ? {1'b1, shreg[8:1]} : shreg;
-end
-endmodule
+`timescale 1ns / 1ps  // NW 4.5.09 / 15.8.10 / 15.11.10
+
+// RS232 receiver for 19200 bps, 8 bit data
+// clock is 25 MHz; 25000 / 1302 = 19.2 KHz
+// clock is 35 MHz; 35000 / 1823 = 19.2 KHz
+
+module RS232T(
+    input clk, rst,
+    input start, // request to accept and send a byte
+    input [7:0] data,
+    output rdy,
+    output TxD);
+
+wire endtick, endbit;
+reg run;
+reg [11:0] tick;
+reg [3:0] bitcnt;
+reg [8:0] shreg;
+
+assign endtick = tick == 1302;
+assign endbit = bitcnt == 9;
+assign rdy = ~run;
+assign TxD = shreg[0];
+
+always @ (posedge clk) begin
+  run <= (~rst | endtick & endbit) ? 0 : start ? 1 : run;
+  tick <= (run & ~endtick) ? tick + 1 : 0;
+  bitcnt <= (endtick & ~endbit) ? bitcnt + 1 :
+    (endtick & endbit) ? 0 : bitcnt;
+  shreg <= (~rst) ? 1 : start ? {data, 1'b0} :
+    endtick ? {1'b1, shreg[8:1]} : shreg;
+end
+endmodule

people.inf.ethz.ch/wirth/FPGA-relatedWork/index.html

@@ -1,33 +1,33 @@
-<HTML>
-<HEAD>
-   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
-   <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
-   <TITLE>FPGA-related Work</TITLE>
-</HEAD>
-<BODY>
-
-<H1>FPGA-related Work</H1>
-<UL>
-  <LI><A HREF="ComputerSystemDesign.pdf">The TRM: Experiments in Computer System Design</A></LI><BR>
-  <LI><A HREF="RISC.pdf">The Design of a RISC Architecture and its Implementation with an FPGA</A><BR>
-    <A HREF="RISC0.v">[RISC0.v]</A>
-    <A HREF="RISC0Top.v">[RISC0Top.v]</A>
-    <A HREF="PROM.v">[PROM.v]</A>
-    <A HREF="DRAM.v">[DRAM.v]</A>
-    <A HREF="Multiplier.v">[Multiplier.v]</A>
-    <A HREF="Multiplier1.v">[Multiplier1.v]</A>
-    <A HREF="Divider.v">[Divider.v]</A>
-    <A HREF="RISC0.ucf">[RISC0.ucf]</A>
-    <A HREF="RS232R.v">[RS232R.v]</A>
-    <A HREF="RS232T.v">[RS232T.v]</A><BR><BR>
-    <A HREF="StandalonePrograms.Mod.txt">StandalonePrograms.Mod</A>
-&nbsp;&nbsp;(See Project Oberon section for Oberon RISC compiler)<BR>
-  </LI><BR>
-  <LI><A HREF="RISC-Arch.pdf">RISC Architecture</A></LI><BR>
-  <LI><A HREF="ThreeCounters.pdf">Three Counters</A>&nbsp;&nbsp;(See also Lola section)</LI><BR>
-</UL>
-<HR>
-<P>
-Back to my <A HREF="../index.html">home page</A>.
-</BODY>
-</HTML>
+<HTML>
+<HEAD>
+   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+   <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
+   <TITLE>FPGA-related Work</TITLE>
+</HEAD>
+<BODY>
+
+<H1>FPGA-related Work</H1>
+<UL>
+  <LI><A HREF="ComputerSystemDesign.pdf">The TRM: Experiments in Computer System Design</A></LI><BR>
+  <LI><A HREF="RISC.pdf">The Design of a RISC Architecture and its Implementation with an FPGA</A><BR>
+    <A HREF="RISC0.v">[RISC0.v]</A>
+    <A HREF="RISC0Top.v">[RISC0Top.v]</A>
+    <A HREF="PROM.v">[PROM.v]</A>
+    <A HREF="DRAM.v">[DRAM.v]</A>
+    <A HREF="Multiplier.v">[Multiplier.v]</A>
+    <A HREF="Multiplier1.v">[Multiplier1.v]</A>
+    <A HREF="Divider.v">[Divider.v]</A>
+    <A HREF="RISC0.ucf">[RISC0.ucf]</A>
+    <A HREF="RS232R.v">[RS232R.v]</A>
+    <A HREF="RS232T.v">[RS232T.v]</A><BR><BR>
+    <A HREF="StandalonePrograms.Mod.txt">StandalonePrograms.Mod</A>
+&nbsp;&nbsp;(See Project Oberon section for Oberon RISC compiler)<BR>
+  </LI><BR>
+  <LI><A HREF="RISC-Arch.pdf">RISC Architecture</A></LI><BR>
+  <LI><A HREF="ThreeCounters.pdf">Three Counters</A>&nbsp;&nbsp;(See also Lola section)</LI><BR>
+</UL>
+<HR>
+<P>
+Back to my <A HREF="../index.html">home page</A>.
+</BODY>
+</HTML>

people.inf.ethz.ch/wirth/Lola/Sources/DCMX3.v

@@ -1,4 +1,4 @@
-module DCMX3 (input CLKIN, output CLKFX);
-(* LOC = "DCM_X1Y1" *) DCM #(.CLKFX_MULTIPLY(3), .CLK_FEEDBACK("NONE"))
-  dcm(.CLKIN(CLKIN), .CLKFX(CLKFX));
-endmodule
+module DCMX3 (input CLKIN, output CLKFX);
+(* LOC = "DCM_X1Y1" *) DCM #(.CLKFX_MULTIPLY(3), .CLK_FEEDBACK("NONE"))
+  dcm(.CLKIN(CLKIN), .CLKFX(CLKFX));
+endmodule

people.inf.ethz.ch/wirth/Lola/Sources/Divider.Lola.txt

@@ -1,20 +1,20 @@
-MODULE Divider(   (*NW 14.9.2015*)
-  IN clk, run, u: BIT;
-  OUT stall: BIT;
-  IN x, y: WORD;  (*y > 0*)
-  OUT quot, rem: WORD);
-  
-  REG (clk) S: [6] BIT;
-    RQ: [64] BIT;
-  VAR sign: BIT;
-    x0, w0, w1: WORD;
-BEGIN stall := run & (S # 33);
-  sign := x.31 & u;
-  x0 := sign -> -x : x;
-  w0 := RQ[62:31];
-  w1 := w0 - y;
-  S := run -> S+1 : 0;
-  quot  := ~sign -> RQ[31:0] : (RQ[63:32] = 0) -> -RQ[31:0] : -RQ[31:0] - 1;
-  rem := ~sign -> RQ[63:32] : (RQ[63:32] = 0) -> 0 :  y - RQ[63:32];
-  RQ := (S = 0) -> {0'32, x0} : {w1.31 -> w0 : w1,  RQ[30:0], ~w1[31]}
-END Divider.
+MODULE Divider(   (*NW 14.9.2015*)
+  IN clk, run, u: BIT;
+  OUT stall: BIT;
+  IN x, y: WORD;  (*y > 0*)
+  OUT quot, rem: WORD);
+  
+  REG (clk) S: [6] BIT;
+    RQ: [64] BIT;
+  VAR sign: BIT;
+    x0, w0, w1: WORD;
+BEGIN stall := run & (S # 33);
+  sign := x.31 & u;
+  x0 := sign -> -x : x;
+  w0 := RQ[62:31];
+  w1 := w0 - y;
+  S := run -> S+1 : 0;
+  quot  := ~sign -> RQ[31:0] : (RQ[63:32] = 0) -> -RQ[31:0] : -RQ[31:0] - 1;
+  rem := ~sign -> RQ[63:32] : (RQ[63:32] = 0) -> 0 :  y - RQ[63:32];
+  RQ := (S = 0) -> {0'32, x0} : {w1.31 -> w0 : w1,  RQ[30:0], ~w1[31]}
+END Divider.

people.inf.ethz.ch/wirth/Lola/Sources/FPAdder.Lola.txt

@@ -1,101 +1,101 @@
-MODULE FPAdder(   (*NW  4.10.2016*)
-  IN clk, run, u, v: BIT; x, y: WORD;
-  OUT stall: BIT; z: WORD);
-
-  REG (clk) State: [2] BIT;
-    x3, y3, t3: [25] BIT;
-    Sum: [27] BIT;
-
-  VAR xs, ys, xn, yn: BIT;  (*signs, null*)
-    xe, ye: [9] BIT;  (*exponents*)
-    xm, ym: [25] BIT;  (*mantissas*)
-
-    dx, dy, e0, e1: [9] BIT;
-    sx, sy: [9] BIT;  (*shift counts*)
-    sx0, sx1, sy0, sy1: [2] BIT;
-    sxh, syh: BIT;
-    x0, x1,x2,  y0, y1, y2: [25] BIT;
-    s: [27] BIT;
-
-    z24, z22, z20, z18, z16, z14, z12, z10, z8, z6, z4, z2: BIT;
-    sc: [5] BIT;  (*shift count*)
-    sc0, sc1: [2] BIT;
-    t1, t2: [25] BIT;
-
-BEGIN  (*unpack*)
-  xs := x.31;
-  xe := u -> 150'9 : {0'1, x[30:23]};
-  xm := {(~u | x.23), x[22:0], 0'1};
-  xn := x[30:0] = 0;
-  ys := y.31;
-  ye := {0'1, y[30:23]};
-  ym := {(~u & ~v), y[22:0], 0'1};
-  yn := y[30:0] = 0;
-  dx := xe - ye; dy := ye - xe;
-  e0 := dx.8 -> ye : xe;
-  sx := dy.8 -> 0 : dy; sy := dx.8 -> 0 : dx;
-  sx0 := sx[1:0]; sx1 := sx[3:2];
-  sy0 := sy[1:0]; sy1 := sy[3:2];
-  sxh := sx.7 | sx.6 | sx.5;  syh := sy.7 | sy.6 | sy.5;
-
-(*denormalize; right shift*)
-  x0 := (xs & ~u) -> -xm : xm;
-  x1 := (sx0 = 3) -> {xs!3, x0[24:3]} :
-    (sx0 = 2) -> {xs!2, x0[24:2]} :
-    (sx0 = 1) -> {xs, x0[24:1]} : x0;
-  x2 := (sx1 = 3) -> {xs!12, x1[24:12]} :
-    (sx1 = 2) -> {xs!8, x1[24:8]} :
-    (sx1 = 1) -> {xs!4, x1[24:4]} : x1;
-  x3 := sxh -> {xs!25} : sx.4 -> {xs!16, x2[24:16]} : x2;
-
-  y0 := (ys & ~u) -> -ym : ym;
-  y1 := (sy0 = 3) -> {ys!3, y0[24:3]} :
-    (sy0 = 2) -> {ys!2, y0[24:2]} :
-    (sy0 = 1) -> {ys, y0[24:1]} : y0;
-  y2 := (sy1 = 3) -> {ys!12, y1[24:12]} :
-    (sy1 = 2) -> {ys!8, y1[24:8]} :
-    (sy1 = 1) -> {ys!4, y1[24:4]} : y1;
-  y3 := syh -> {ys!25} : (sy.4 -> {ys!16, y2[24:16]} : y2);
-  
-(*addition*)
-  Sum := {xs, xs, x3} + {ys, ys, y3}; s := (Sum.26 -> -Sum : Sum) + 1;   (*round*)
-
-(*post-normalize, shift left;  sc = shift count*)
-  z24 := ~s.25 & ~s.24;
-  z22 := z24 & ~s.23 & ~s.22;
-  z20 := z22 & ~s.21 & ~s.20;
-  z18 := z20 & ~s.19 & ~s.18;
-  z16 := z18 & ~s.17 & ~s.16;
-  z14 := z16 & ~s.15 & ~s.14;
-  z12 := z14 & ~s.13 & ~s.12;
-  z10 := z12 & ~s.11 & ~s.10;
-  z8 := z10 & ~s.9 & ~s.8;
-  z6 := z8 & ~s.7 & ~s.6;
-  z4 := z6 & ~s.5 & ~s.4;
-  z2 := z4 & ~s.3 & ~s.2;
-
-  sc := {z10,
-    z18 & (s.17 | s.16 | s.15 | s.14 | s.13 | s.12 | s.11 | s.10) | z2,
-    z22 & (s.21 | s.20 | s.19 | s.18)  |  z14 & (s.13 | s.12 | s.11 | s.10)  |  z6 & (s.5 | s.4 | s.3 | s.2),
-    z24 & (s.23 | s.22)  |  z20 & (s.19 | s.18)  |  z16 & (s.15 | s.14)  |  z12 & (s.11 | s.10)  |  z8 & (s.7 | s.6)  |  z4 & (s.3 | s.2),
-    ~s.25 & s.24 | z24 & ~s.23 & s.22 | z24 & ~s.23 & s.22 |  z22 & ~s.21 & s.20 | z20 & ~s.19 & s.18 | z18 & ~s.17 & s.16 |  
-      z16 & ~s.15 & s.14 | z14 & ~s.13 & s.12 | z12 & ~s.11 & s.10 | z10 & ~s.9 & s.8 | z8 & ~s.7 & s.6 | z6 & ~s.5 & s.4 | z4 & ~s.3 & s.2};
-
-  e1 := e0 - {0'4, sc} + 1;
-  sc0 := sc[1:0]; sc1 := sc[3:2];
-  t1 := (sc0 = 3) -> {s[22:1], 0'3} :
-    (sc0 = 2) -> {s[23:1], 0'2} :
-    (sc0 = 1) -> {s[24:1], 0'1} : s[25:1];
-  t2 := (sc1 = 3) -> {t1[12:0], 0'12} :
-    (sc1 = 2) -> {t1[16:0], 0'8} :
-    (sc1 = 1) -> {t1[20:0], 0'4} : t1;
-  t3 := sc.4 -> {t2[8:0], 0'16} : t2;
-
-  stall := run & (State # 3);
-  State := run -> State+1 : 0;
-
-  z := v -> {Sum.26 ! 7, Sum[25:1]} :   (*FLOOR*)
-    xn -> (u|yn -> 0 : y) :
-    yn -> x :
-    (t3 = 0) | e1.8 -> 0 : {Sum.26, e1[7:0], t3[23:1]}
-END FPAdder.
+MODULE FPAdder(   (*NW  4.10.2016*)
+  IN clk, run, u, v: BIT; x, y: WORD;
+  OUT stall: BIT; z: WORD);
+
+  REG (clk) State: [2] BIT;
+    x3, y3, t3: [25] BIT;
+    Sum: [27] BIT;
+
+  VAR xs, ys, xn, yn: BIT;  (*signs, null*)
+    xe, ye: [9] BIT;  (*exponents*)
+    xm, ym: [25] BIT;  (*mantissas*)
+
+    dx, dy, e0, e1: [9] BIT;
+    sx, sy: [9] BIT;  (*shift counts*)
+    sx0, sx1, sy0, sy1: [2] BIT;
+    sxh, syh: BIT;
+    x0, x1,x2,  y0, y1, y2: [25] BIT;
+    s: [27] BIT;
+
+    z24, z22, z20, z18, z16, z14, z12, z10, z8, z6, z4, z2: BIT;
+    sc: [5] BIT;  (*shift count*)
+    sc0, sc1: [2] BIT;
+    t1, t2: [25] BIT;
+
+BEGIN  (*unpack*)
+  xs := x.31;
+  xe := u -> 150'9 : {0'1, x[30:23]};
+  xm := {(~u | x.23), x[22:0], 0'1};
+  xn := x[30:0] = 0;
+  ys := y.31;
+  ye := {0'1, y[30:23]};
+  ym := {(~u & ~v), y[22:0], 0'1};
+  yn := y[30:0] = 0;
+  dx := xe - ye; dy := ye - xe;
+  e0 := dx.8 -> ye : xe;
+  sx := dy.8 -> 0 : dy; sy := dx.8 -> 0 : dx;
+  sx0 := sx[1:0]; sx1 := sx[3:2];
+  sy0 := sy[1:0]; sy1 := sy[3:2];
+  sxh := sx.7 | sx.6 | sx.5;  syh := sy.7 | sy.6 | sy.5;
+
+(*denormalize; right shift*)
+  x0 := (xs & ~u) -> -xm : xm;
+  x1 := (sx0 = 3) -> {xs!3, x0[24:3]} :
+    (sx0 = 2) -> {xs!2, x0[24:2]} :
+    (sx0 = 1) -> {xs, x0[24:1]} : x0;
+  x2 := (sx1 = 3) -> {xs!12, x1[24:12]} :
+    (sx1 = 2) -> {xs!8, x1[24:8]} :
+    (sx1 = 1) -> {xs!4, x1[24:4]} : x1;
+  x3 := sxh -> {xs!25} : sx.4 -> {xs!16, x2[24:16]} : x2;
+
+  y0 := (ys & ~u) -> -ym : ym;
+  y1 := (sy0 = 3) -> {ys!3, y0[24:3]} :
+    (sy0 = 2) -> {ys!2, y0[24:2]} :
+    (sy0 = 1) -> {ys, y0[24:1]} : y0;
+  y2 := (sy1 = 3) -> {ys!12, y1[24:12]} :
+    (sy1 = 2) -> {ys!8, y1[24:8]} :
+    (sy1 = 1) -> {ys!4, y1[24:4]} : y1;
+  y3 := syh -> {ys!25} : (sy.4 -> {ys!16, y2[24:16]} : y2);
+  
+(*addition*)
+  Sum := {xs, xs, x3} + {ys, ys, y3}; s := (Sum.26 -> -Sum : Sum) + 1;   (*round*)
+
+(*post-normalize, shift left;  sc = shift count*)
+  z24 := ~s.25 & ~s.24;
+  z22 := z24 & ~s.23 & ~s.22;
+  z20 := z22 & ~s.21 & ~s.20;
+  z18 := z20 & ~s.19 & ~s.18;
+  z16 := z18 & ~s.17 & ~s.16;
+  z14 := z16 & ~s.15 & ~s.14;
+  z12 := z14 & ~s.13 & ~s.12;
+  z10 := z12 & ~s.11 & ~s.10;
+  z8 := z10 & ~s.9 & ~s.8;
+  z6 := z8 & ~s.7 & ~s.6;
+  z4 := z6 & ~s.5 & ~s.4;
+  z2 := z4 & ~s.3 & ~s.2;
+
+  sc := {z10,
+    z18 & (s.17 | s.16 | s.15 | s.14 | s.13 | s.12 | s.11 | s.10) | z2,
+    z22 & (s.21 | s.20 | s.19 | s.18)  |  z14 & (s.13 | s.12 | s.11 | s.10)  |  z6 & (s.5 | s.4 | s.3 | s.2),
+    z24 & (s.23 | s.22)  |  z20 & (s.19 | s.18)  |  z16 & (s.15 | s.14)  |  z12 & (s.11 | s.10)  |  z8 & (s.7 | s.6)  |  z4 & (s.3 | s.2),
+    ~s.25 & s.24 | z24 & ~s.23 & s.22 | z24 & ~s.23 & s.22 |  z22 & ~s.21 & s.20 | z20 & ~s.19 & s.18 | z18 & ~s.17 & s.16 |  
+      z16 & ~s.15 & s.14 | z14 & ~s.13 & s.12 | z12 & ~s.11 & s.10 | z10 & ~s.9 & s.8 | z8 & ~s.7 & s.6 | z6 & ~s.5 & s.4 | z4 & ~s.3 & s.2};
+
+  e1 := e0 - {0'4, sc} + 1;
+  sc0 := sc[1:0]; sc1 := sc[3:2];
+  t1 := (sc0 = 3) -> {s[22:1], 0'3} :
+    (sc0 = 2) -> {s[23:1], 0'2} :
+    (sc0 = 1) -> {s[24:1], 0'1} : s[25:1];
+  t2 := (sc1 = 3) -> {t1[12:0], 0'12} :
+    (sc1 = 2) -> {t1[16:0], 0'8} :
+    (sc1 = 1) -> {t1[20:0], 0'4} : t1;
+  t3 := sc.4 -> {t2[8:0], 0'16} : t2;
+
+  stall := run & (State # 3);
+  State := run -> State+1 : 0;
+
+  z := v -> {Sum.26 ! 7, Sum[25:1]} :   (*FLOOR*)
+    xn -> (u|yn -> 0 : y) :
+    yn -> x :
+    (t3 = 0) | e1.8 -> 0 : {Sum.26, e1[7:0], t3[23:1]}
+END FPAdder.

people.inf.ethz.ch/wirth/Lola/Sources/FPDivider.Lola.txt

@@ -1,38 +1,38 @@
-MODULE FPDivider(   (*NW 28.10.2016*)
-  IN clk, run: BIT; x, y: WORD;
-  OUT stall: BIT; z: WORD);
-
-  REG (clk) S: [5] BIT;   (*state*)
-    R: [24] BIT;   (*remainder*)
-    Q: [26] BIT;   (*quotient*)
-
-  VAR sign: BIT;
-    xe, ye: [8] BIT;
-    e0, e1: [9] BIT;
-    r0,  r1, d: [25] BIT;
-    q0: [26] BIT;
-    z0, z1: [25] BIT;
-
-BEGIN
-  sign := x.31 ^ y.31;   (*xor*)
-  xe := x[30:23]; ye := y[30:23];
-  e0 := {0'1, xe} - {0'1, ye};
-  e1 := e0 + 126 + {0'8, Q.25};
-  stall := run & (S # 26);
-
-  r0 := (S = 0) -> {1'2, x[22:0]} : {R, 0'1};
-  r1 := d.24 -> 0 : d;
-  d := r0 - {1'2, y[22:0]};
-  q0 := (S = 0) -> 0 : Q;
-
-  z0 := Q.25 -> Q[25:1] : Q[24:0];  (* normalize*)
-  z1 := z0 + 1;   (*round*)
-  z := (xe = 0) -> 0 :
-    (ye = 0) -> {sign, 0FFH'8, 0'23} :  (*divide by 0*)
-    ~e1.8 -> {sign, e1[7:0], z1[23:1]} :
-    ~e1.7 -> {sign, 0FFH'8, z0[23:1]} : 0;   (*overflow*)
-
-  R := r1[23:0];
-  Q := {q0[24:0], ~d.24};
-  S := run -> S+1 : 0
-END FPDivider.
+MODULE FPDivider(   (*NW 28.10.2016*)
+  IN clk, run: BIT; x, y: WORD;
+  OUT stall: BIT; z: WORD);
+
+  REG (clk) S: [5] BIT;   (*state*)
+    R: [24] BIT;   (*remainder*)
+    Q: [26] BIT;   (*quotient*)
+
+  VAR sign: BIT;
+    xe, ye: [8] BIT;
+    e0, e1: [9] BIT;
+    r0,  r1, d: [25] BIT;
+    q0: [26] BIT;
+    z0, z1: [25] BIT;
+
+BEGIN
+  sign := x.31 ^ y.31;   (*xor*)
+  xe := x[30:23]; ye := y[30:23];
+  e0 := {0'1, xe} - {0'1, ye};
+  e1 := e0 + 126 + {0'8, Q.25};
+  stall := run & (S # 26);
+
+  r0 := (S = 0) -> {1'2, x[22:0]} : {R, 0'1};
+  r1 := d.24 -> 0 : d;
+  d := r0 - {1'2, y[22:0]};
+  q0 := (S = 0) -> 0 : Q;
+
+  z0 := Q.25 -> Q[25:1] : Q[24:0];  (* normalize*)
+  z1 := z0 + 1;   (*round*)
+  z := (xe = 0) -> 0 :
+    (ye = 0) -> {sign, 0FFH'8, 0'23} :  (*divide by 0*)
+    ~e1.8 -> {sign, e1[7:0], z1[23:1]} :
+    ~e1.7 -> {sign, 0FFH'8, z0[23:1]} : 0;   (*overflow*)
+
+  R := r1[23:0];
+  Q := {q0[24:0], ~d.24};
+  S := run -> S+1 : 0
+END FPDivider.

people.inf.ethz.ch/wirth/Lola/Sources/FPMultiplier.Lola.txt

@@ -1,62 +1,62 @@
-MODULE FPMultiplier(   (*NW 28.10.2016*)
-  IN clk, run: BIT; x, y: WORD;
-  OUT stall: BIT; z: WORD);
-
-  REG (clk) S: [5] BIT;   (*state*)
-    P: [48] BIT;   (*product*)
-
-  VAR sign: BIT;
-    xe, ye: [8] BIT;
-    e0, e1: [9] BIT;
-    w0: [24] BIT;
-    w1, z0: [25] BIT;
-
-BEGIN sign := x.31 ^ y.31;   (*xor*)
-  xe := x[30:23]; ye := y[30:23];
-  e0 := {0'1, xe} + {0'1, ye};
-  e1 := e0 - 127 + {0'8, P.47};
-  stall := run & (S # 25);
-  w0 := P.0 -> {1'1, y[22:0]} : 0;
-  w1 := {0'1, P[47:24]} + {0'1, w0};
-
-  P := (S = 0) -> {0'24, 1'1, x[22:0]} : {w1, P[23:1]};
-  S := run -> S+1 : 0;
-
-  z0 := P.47 -> P[47:23]+1 : P[46:22]+1;  (*round & normalize*)
-  z := (xe = 0) | (ye = 0) -> 0 :
-    ~e1.8 -> {sign, e1[7:0], z0[23:1]} :
-    ~e1.7 -> {sign, 0FFH'8, z0[23:1]} : 0;  (*overflow*)
-END FPMultiplier.
-
-MODULE FPMultiplier(
-  IN clk, run: BIT; x, y: WORD;
-  OUT stall: BIT; z: WORD);
-
-  REG (clk) S: [5] BIT;   (*state*)
-    B2, A2: [24] BIT;
-
-  VAR sign: BIT;
-    xe, ye: [8] BIT;
-    e0, e1: [9] BIT;
-    B0: [25] BIT;
-    B00, B01, B1, A1, A0, z0: [24] BIT;
-
-BEGIN sign := x.31 ^ y.31;   (*xor*)
-  xe := x[30:23]; ye := y[30:23]; e0 := {0'1, xe} + {0'1, ye};
-  B00 := (S = 0) -> 0 : B2;
-  B01 := A0.0 -> {1'1, y[22:0]} : 0;
-  B0 := {0'1, B00} + {0'1, B01};
-  B1 := B0[24:1];
-  A0 := (S = 0) -> {1'1, x[22:0]} : A2;
-  A1 := {B0.0, A0[23:1]};
-
-  e1 := e0 - 127 + B1.23;
-  z0 := B1.23 -> B1 : {B1[22:0], A1.23};
-  z := (xe = 0) | (ye = 0) -> 0 :
-    ~e1.8 -> {sign, e1[7:0], z0[22:0]} :
-    ~e1.7 -> {sign, 0FFH'8, z0[22:0]} : 0;  (*overflow*)
-  stall := run & (S # 23);
-
-  B2 := B1; A2 := A1;
-  S := run -> S+1 : 0;
-END FPMultiplier.
+MODULE FPMultiplier(   (*NW 28.10.2016*)
+  IN clk, run: BIT; x, y: WORD;
+  OUT stall: BIT; z: WORD);
+
+  REG (clk) S: [5] BIT;   (*state*)
+    P: [48] BIT;   (*product*)
+
+  VAR sign: BIT;
+    xe, ye: [8] BIT;
+    e0, e1: [9] BIT;
+    w0: [24] BIT;
+    w1, z0: [25] BIT;
+
+BEGIN sign := x.31 ^ y.31;   (*xor*)
+  xe := x[30:23]; ye := y[30:23];
+  e0 := {0'1, xe} + {0'1, ye};
+  e1 := e0 - 127 + {0'8, P.47};
+  stall := run & (S # 25);
+  w0 := P.0 -> {1'1, y[22:0]} : 0;
+  w1 := {0'1, P[47:24]} + {0'1, w0};
+
+  P := (S = 0) -> {0'24, 1'1, x[22:0]} : {w1, P[23:1]};
+  S := run -> S+1 : 0;
+
+  z0 := P.47 -> P[47:23]+1 : P[46:22]+1;  (*round & normalize*)
+  z := (xe = 0) | (ye = 0) -> 0 :
+    ~e1.8 -> {sign, e1[7:0], z0[23:1]} :
+    ~e1.7 -> {sign, 0FFH'8, z0[23:1]} : 0;  (*overflow*)
+END FPMultiplier.
+
+MODULE FPMultiplier(
+  IN clk, run: BIT; x, y: WORD;
+  OUT stall: BIT; z: WORD);
+
+  REG (clk) S: [5] BIT;   (*state*)
+    B2, A2: [24] BIT;
+
+  VAR sign: BIT;
+    xe, ye: [8] BIT;
+    e0, e1: [9] BIT;
+    B0: [25] BIT;
+    B00, B01, B1, A1, A0, z0: [24] BIT;
+
+BEGIN sign := x.31 ^ y.31;   (*xor*)
+  xe := x[30:23]; ye := y[30:23]; e0 := {0'1, xe} + {0'1, ye};
+  B00 := (S = 0) -> 0 : B2;
+  B01 := A0.0 -> {1'1, y[22:0]} : 0;
+  B0 := {0'1, B00} + {0'1, B01};
+  B1 := B0[24:1];
+  A0 := (S = 0) -> {1'1, x[22:0]} : A2;
+  A1 := {B0.0, A0[23:1]};
+
+  e1 := e0 - 127 + B1.23;
+  z0 := B1.23 -> B1 : {B1[22:0], A1.23};
+  z := (xe = 0) | (ye = 0) -> 0 :
+    ~e1.8 -> {sign, e1[7:0], z0[22:0]} :
+    ~e1.7 -> {sign, 0FFH'8, z0[22:0]} : 0;  (*overflow*)
+  stall := run & (S # 23);
+
+  B2 := B1; A2 := A1;
+  S := run -> S+1 : 0;
+END FPMultiplier.

people.inf.ethz.ch/wirth/Lola/Sources/LSB.Mod.txt

@@ -1,52 +1,52 @@
-MODULE LSB;  (*Lola System Compiler Base LSBX, 26.9.2015*)
-  IMPORT Texts, Oberon;
-  
-  CONST
-    bit* = 0; array* = 1; unit* = 2;   (*type forms*)
-    
-    (*tags in output*) const* = 1; typ* = 2; var* = 3; lit* = 4; sel* = 7; range* = 8; cons* = 9;
-    repl* = 10; not* = 11; and* = 12; mul* = 13; div* = 14; or* = 15; xor* = 16; add* = 17; sub* = 18;
-    eql* = 20; neq* = 21; lss* = 22; geq* = 23; leq* = 24; gtr* = 25;
-    then* = 30; else* = 31; ts* = 32; next* = 33;
-
-  TYPE
-    Item* = POINTER TO ItemDesc;
-    Object* = POINTER TO ObjDesc;
-    Type* = POINTER TO TypeDesc;
-    ArrayType* = POINTER TO ArrayTypeDesc;
-    UnitType* = POINTER TO UnitTypeDesc;
-
-    ItemDesc* = RECORD
-      tag*: INTEGER;
-      type*: Type;
-      val*, size*: LONGINT;
-      a*, b*: Item
-    END ;
-
-    ObjDesc* = RECORD (ItemDesc)
-      next*: Object;
-      name*: ARRAY 32 OF CHAR;
-      marked*: BOOLEAN
-    END ;
-
-    TypeDesc* = RECORD len*, size*: LONGINT; typobj*: Object END ;
-    ArrayTypeDesc* = RECORD (TypeDesc) eltyp*: Type END ;
-    UnitTypeDesc* = RECORD (TypeDesc) firstobj*: Object END ;
-
-  VAR root*, top*: Object;
-    bitType*, integer*, string*: Type;
-    byteType*, wordType*: ArrayType;
-    modname*: ARRAY 32 OF CHAR;
-
-  PROCEDURE Register*(name: ARRAY OF CHAR; list: Object);
-  BEGIN modname := name; top := list
-  END Register;
-
-BEGIN NEW(bitType); bitType.len := 0; bitType.size := 1; NEW(integer); NEW(string);
-  NEW(byteType); byteType.len := 8; byteType.size := 8; byteType.eltyp := bitType;
-  NEW(wordType); wordType.len := 32; wordType.size := 32; wordType.eltyp := bitType;
-  NEW(root); root.tag := typ; root.name := "WORD"; root.type := wordType; root.next := NIL;
-  NEW(top); top.tag := typ; top.name := "BYTE"; top.type := byteType; top.next := root; root := top;
-  NEW(top); top.tag := typ; top.name := "BIT"; top.type := bitType; top.next := root; root := top
-END LSB.
-
+MODULE LSB;  (*Lola System Compiler Base LSBX, 26.9.2015*)
+  IMPORT Texts, Oberon;
+  
+  CONST
+    bit* = 0; array* = 1; unit* = 2;   (*type forms*)
+    
+    (*tags in output*) const* = 1; typ* = 2; var* = 3; lit* = 4; sel* = 7; range* = 8; cons* = 9;
+    repl* = 10; not* = 11; and* = 12; mul* = 13; div* = 14; or* = 15; xor* = 16; add* = 17; sub* = 18;
+    eql* = 20; neq* = 21; lss* = 22; geq* = 23; leq* = 24; gtr* = 25;
+    then* = 30; else* = 31; ts* = 32; next* = 33;
+
+  TYPE
+    Item* = POINTER TO ItemDesc;
+    Object* = POINTER TO ObjDesc;
+    Type* = POINTER TO TypeDesc;
+    ArrayType* = POINTER TO ArrayTypeDesc;
+    UnitType* = POINTER TO UnitTypeDesc;
+
+    ItemDesc* = RECORD
+      tag*: INTEGER;
+      type*: Type;
+      val*, size*: LONGINT;
+      a*, b*: Item
+    END ;
+
+    ObjDesc* = RECORD (ItemDesc)
+      next*: Object;
+      name*: ARRAY 32 OF CHAR;
+      marked*: BOOLEAN
+    END ;
+
+    TypeDesc* = RECORD len*, size*: LONGINT; typobj*: Object END ;
+    ArrayTypeDesc* = RECORD (TypeDesc) eltyp*: Type END ;
+    UnitTypeDesc* = RECORD (TypeDesc) firstobj*: Object END ;
+
+  VAR root*, top*: Object;
+    bitType*, integer*, string*: Type;
+    byteType*, wordType*: ArrayType;
+    modname*: ARRAY 32 OF CHAR;
+
+  PROCEDURE Register*(name: ARRAY OF CHAR; list: Object);
+  BEGIN modname := name; top := list
+  END Register;
+
+BEGIN NEW(bitType); bitType.len := 0; bitType.size := 1; NEW(integer); NEW(string);
+  NEW(byteType); byteType.len := 8; byteType.size := 8; byteType.eltyp := bitType;
+  NEW(wordType); wordType.len := 32; wordType.size := 32; wordType.eltyp := bitType;
+  NEW(root); root.tag := typ; root.name := "WORD"; root.type := wordType; root.next := NIL;
+  NEW(top); top.tag := typ; top.name := "BYTE"; top.type := byteType; top.next := root; root := top;
+  NEW(top); top.tag := typ; top.name := "BIT"; top.type := bitType; top.next := root; root := top
+END LSB.
+

people.inf.ethz.ch/wirth/Lola/Sources/LSC.Mod.txt

@@ -1,534 +1,534 @@
-MODULE LSC;  (*Lola System Compiler, NW 8.1.95 / 27.8.2018 for RISC (LSCX)*)
-  IMPORT Texts, Oberon, LSB, LSS;
-  
-  VAR sym: INTEGER;
-    err: BOOLEAN;  (*used at end of Unit*)
-    top, bot, undef: LSB.Object;
-    factor: PROCEDURE (VAR x: LSB.Item);  (*to avoid forward references*)
-    expression: PROCEDURE (VAR x: LSB.Item);
-    Unit: PROCEDURE (VAR locals: LSB.Object);
-    W: Texts.Writer;
-
-  PROCEDURE Err(n: INTEGER);
-  BEGIN LSS.Mark("type error"); Texts.WriteInt(W, n, 4);
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END Err;
-
-  PROCEDURE Log(m: LONGINT): LONGINT;
-    VAR n: LONGINT;
-  BEGIN n := 1;
-    WHILE m > 1 DO m := m DIV 2; INC(n) END ;
-    RETURN n
-  END Log;
-
-  PROCEDURE New(tag: INTEGER; a, b: LSB.Item): LSB.Item;
-    VAR z: LSB.Item;
-  BEGIN NEW(z); z.tag := tag; z.a := a; z.b := b; z.val := b.val; RETURN z
-  END New;
-
-  PROCEDURE NewObj(class: INTEGER): LSB.Object; (*insert at end, before BIT*)
-    VAR new, x: LSB.Object;
-  BEGIN x := top;
-    WHILE (x.next # bot) & (x.next.name # LSS.id) DO x := x.next END ;
-    IF x.next = bot THEN
-      NEW(new); new.name := LSS.id; new.tag := class; new.next := bot; x.next := new
-    ELSE LSS.Mark("mult def"); new := x
-    END ;
-    RETURN new
-  END NewObj;
-
-  PROCEDURE ThisObj(id: LSS.Ident): LSB.Object;  (*find object with name = identifier last read*)
-    VAR x: LSB.Object;
-  BEGIN x := top.next;
-    WHILE (x # NIL) & (x.name # id) DO x := x.next END ;
-    IF x = NIL THEN LSS.Mark("undef"); x := undef END ;
-    RETURN x
-  END ThisObj;
-
-  PROCEDURE CheckTypes(x, y, z: LSB.Item);  (*z.type = result type*)
-    VAR xtyp, ytyp: LSB.Type;
-  BEGIN xtyp := x.type; ytyp := y.type; z.type := xtyp; z.size := x.size; z.val := x.val;
-    IF xtyp = LSB.bitType THEN
-      IF ytyp = LSB.integer THEN  (* b + 0 *)
-        IF y.val >= 2 THEN Err(20); LSS.Mark("only 0 or 1") END
-      ELSIF ytyp = LSB.string THEN (* b + {...} *) Err(21)
-      ELSIF ytyp # LSB.bitType THEN Err(22)
-      END
-    ELSIF xtyp IS LSB.ArrayType THEN
-      IF xtyp(LSB.ArrayType).eltyp = LSB.bitType THEN
-        IF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = LSB.bitType) THEN
-          IF xtyp.size # ytyp.size THEN Err(33) END  (* x + y *)
-        ELSIF ytyp = LSB.integer THEN   (* w + 5 *)
-          IF xtyp.size < Log(y.val) THEN Err(30) END
-        ELSIF ytyp = LSB.string THEN   (*x + {...} *)
-          IF xtyp.size # y.size THEN Err(31) END
-        ELSE Err(34)
-        END
-      ELSIF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = ytyp(LSB.ArrayType).eltyp) THEN
-        IF (xtyp.size # ytyp.size) THEN Err(40) END
-      ELSE Err(41)
-      END 
-    ELSIF xtyp = LSB.string THEN
-      IF ytyp = LSB.bitType THEN  (* {...} + b *) Err(12)
-      ELSIF (ytyp IS LSB.ArrayType) & (ytyp(LSB.ArrayType).eltyp = LSB.bitType) THEN  (* {...} + w *)
-        IF x.size # ytyp.size THEN Err(13) END
-      ELSIF ytyp = LSB.integer THEN  (* {...} + 5*)
-        IF x.size < Log(y.val) THEN Err(10) END
-      ELSIF ytyp = LSB.string THEN  (* {...} + {...} *)
-        IF x.size # y.size THEN Err(11) END ;  
-      ELSE Err(14)
-      END
-    ELSIF xtyp = LSB.integer THEN
-      IF (ytyp IS LSB.ArrayType) & (ytyp(LSB.ArrayType).eltyp = LSB.bitType) THEN  (* 5 + w *)
-        IF Log(x.val) > ytyp.size THEN Err(3); LSS.Mark("const too large") END
-      ELSIF ytyp = LSB.bitType THEN (* 5 + b *)
-        IF x.val >= 2 THEN Err(2) END
-      ELSIF ytyp = LSB.integer THEN  (* 5 + 5 *)
-      ELSIF ytyp = LSB.string THEN  (* 5 + {...} *)
-        IF Log(x.val) > y.size THEN Err(12) END
-      ELSE Err(4)
-      END
-    END
-  END CheckTypes;
-
-  PROCEDURE selector(VAR x: LSB.Item);
-    VAR y, z: LSB.Item; obj: LSB.Object;
-      eltyp: LSB.Type; len, kind: LONGINT;
-  BEGIN
-    WHILE (sym = LSS.lbrak) OR (sym = LSS.period) DO
-      IF sym = LSS.lbrak THEN
-        eltyp := x.type(LSB.ArrayType).eltyp; LSS.Get(sym); expression(y);
-        IF sym = LSS.colon THEN (*range*)
-          LSS.Get(sym); expression(z);
-          IF (y.tag = LSB.lit) & (z.tag = LSB.lit) THEN
-            len := y.val - z.val + 1; y := New(LSB.range, y, z); x := New(LSB.sel, x, y); x.type := LSB.string; x.size := len
-          END
-        ELSE kind := x.val; x := New(LSB.sel, x, y); x.type := eltyp; x.val := kind
-        END ;
-        IF sym = LSS.rbrak THEN LSS.Get(sym) ELSE LSS.Mark("rbrak ?") END
-      ELSE (*sym = LSS.period*) LSS.Get(sym); factor(y);
-        IF (y.tag = LSB.lit) & (y.val >= x.type.len) THEN LSS.Mark("too large") END ;
-        eltyp := x.type(LSB.ArrayType).eltyp; kind := x.val; x := New(LSB.sel, x, y); x.type := eltyp; x.val := kind
-      END
-    END
-  END selector;
-
-  PROCEDURE elem(VAR x: LSB.Item; VAR len: LONGINT);
-    VAR y, z: LSB.Item; m, n: LONGINT;
-  BEGIN expression(x);
-    IF (x.type = LSB.integer) OR (x.type = LSB.string) THEN m := x.size ELSE m := x.type.size END ;
-    IF sym = LSS.repl THEN
-      LSS.Get(sym);
-      IF sym = LSS.integer THEN
-        NEW(y); y.tag := LSB.lit; n := LSS.val; y.val := n; y.type := LSB.integer; LSS.Get(sym);
-        x := New(LSB.repl, x, y)
-      END
-    ELSE n := 1
-    END ;
-    len := m*n
-  END elem;
-
-  PROCEDURE constructor(VAR x: LSB.Item);
-    VAR y: LSB.Item; n, len: LONGINT;
-  BEGIN elem(x, len);
-    WHILE sym = LSS.comma DO
-      LSS.Get(sym); elem(y, n); INC(len, n); x := New(LSB.cons, x, y); x.val := len
-    END ;
-    x.size := len; x.type := LSB.string;
-    IF sym = LSS.rbrace THEN LSS.Get(sym) ELSE LSS.Mark("rbrace ?") END
-  END constructor;
-
-  PROCEDURE factor0(VAR x: LSB.Item);
-    VAR obj: LSB.Object; y, z: LSB.Item;
-      n, len: LONGINT; t: LSB.ArrayType;
-  BEGIN
-    IF sym = LSS.ident THEN
-      x := ThisObj(LSS.id); LSS.Get(sym);
-      IF x.tag = LSB.var THEN selector(x)
-      ELSIF x.tag = LSB.const THEN n := x.b.val; NEW(x); x.tag := LSB.lit; x.val := n; x.type := LSB.integer
-      ELSE LSS.Mark("bad factor")
-      END
-    ELSIF sym = LSS.lparen THEN
-      LSS.Get(sym); expression(x);
-      IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END
-    ELSIF sym = LSS.integer THEN
-      NEW(x); x.tag := LSB.lit; x.val := LSS.val; x.type := LSB.integer; LSS.Get(sym);
-      IF sym = LSS.apo THEN LSS.Get(sym);
-        IF sym = LSS.integer THEN
-          len := LSS.val; LSS.Get(sym);
-          IF len < Log(x.val) THEN LSS.Mark("value too large") END
-        ELSE LSS.Mark("integer ?"); len := 0
-        END
-      ELSE len := 0
-      END ;
-      x.size := len
-    ELSIF sym = LSS.not THEN
-      LSS.Get(sym); factor(x); y := New(LSB.not, NIL, x); y.type := x.type; y.size := x.size; x := y
-    ELSIF sym = LSS.lbrace THEN LSS.Get(sym); constructor(x)
-    ELSE LSS.Mark("bad factor")
-    END
-  END factor0;
-
-  PROCEDURE term(VAR x: LSB.Item);
-    VAR y, z: LSB.Item; op: INTEGER;
-  BEGIN factor(x);
-    WHILE (sym >= LSS.times) & (sym <= LSS.and) DO
-      IF sym = LSS.and THEN op := LSB.and
-      ELSIF sym = LSS.times THEN op := LSB.mul
-      ELSIF sym = LSS.div THEN op := LSB.div
-      END ;
-      LSS.Get(sym); factor(y); z := New(op, x, y); CheckTypes(x, y, z); x := z
-    END
-  END term;
-
-  PROCEDURE SimpleExpression(VAR x: LSB.Item);
-    VAR y, z: LSB.Item; op: INTEGER;
-  BEGIN
-    IF sym = LSS.minus THEN LSS.Get(sym); term(y);
-      IF y.tag = LSB.lit THEN x := y; x.val := -y.val
-      ELSE x := New(LSB.sub, NIL, y); x.type := y.type; x.size := y.size
-      END
-    ELSIF sym = LSS.plus THEN LSS.Get(sym); term(x);
-    ELSE term(x)
-    END ;
-    WHILE (sym >= LSS.plus) & (sym <= LSS.xor) DO
-      IF sym = LSS.or THEN op := LSB.or
-      ELSIF sym = LSS.xor THEN op := LSB.xor
-      ELSIF sym = LSS.plus THEN op := LSB.add
-      ELSIF sym = LSS.minus THEN op := LSB.sub
-      END ;
-      LSS.Get(sym); term(y); z := New(op, x, y); CheckTypes(x, y, z); x := z
-    END
-  END SimpleExpression;
-
-  PROCEDURE UncondExpression(VAR x: LSB.Item);
-    VAR y, z: LSB.Item; rel: INTEGER;
-  BEGIN SimpleExpression(x);
-    IF (sym >= LSS.eql) & (sym <= LSS.geq) THEN
-      IF sym = LSS.eql THEN rel := LSB.eql
-      ELSIF sym = LSS.neq THEN rel := LSB.neq
-      ELSIF sym = LSS.lss THEN rel := LSB.lss
-      ELSIF sym = LSS.geq THEN rel := LSB.geq
-      ELSIF sym = LSS.leq THEN rel := LSB.leq
-      ELSE rel := LSB.gtr
-      END ;
-      LSS.Get(sym); SimpleExpression(y); z := New(rel, x, y); CheckTypes(x, y, z); z.type := LSB.bitType; x := z
-    END
-  END UncondExpression;
-
-  PROCEDURE expression0(VAR x: LSB.Item);
-    VAR y, z, w: LSB.Item;
-  BEGIN UncondExpression(x);
-    IF sym = LSS.then THEN
-      IF x.type # LSB.bitType THEN LSS.Mark("Boolean?") END ;
-      LSS.Get(sym); expression(y);
-      IF sym = LSS.colon THEN
-        LSS.Get(sym); expression(z); w := New(LSB.else, y, z); CheckTypes(y, z, w);
-        x := New(LSB.then, x, w); x.type := w.type; x.size := w.size
-      ELSE LSS.Mark("colon ?")
-      END
-    END
-  END expression0;
-
-  PROCEDURE CheckAssign(x, y: LSB.Item);
-    VAR xtyp, ytyp: LSB.Type;
-  BEGIN xtyp := x.type; ytyp := y.type;
-    IF xtyp # ytyp THEN
-      IF xtyp = LSB.bitType THEN
-        IF (ytyp # LSB.integer) OR (y.val >= 2) THEN Err(70); END
-      ELSIF xtyp IS LSB.ArrayType THEN
-        IF xtyp(LSB.ArrayType).eltyp = LSB.bitType THEN
-          IF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (*w := w*)
-            IF xtyp.size # ytyp.size THEN Err(71) END  (* x + y *)
-          ELSIF ytyp = LSB.integer THEN   (* w := 5 *)
-            IF xtyp.size < Log(y.val) THEN Err(72) END
-          ELSIF ytyp = LSB.string THEN   (* w := {...} *)
-            IF xtyp.size # y.size THEN Err(73) END
-          ELSE Err(74)
-          END
-        ELSE Err(74)
-        END
-      END
-    END
-  END CheckAssign;
-
-  PROCEDURE Param(fpar: LSB.Object; VAR apar: LSB.Item);
-    VAR y, z: LSB.Item;
-  BEGIN expression(y); apar := New(LSB.next, NIL, y); CheckAssign(fpar, y);
-    IF fpar.val IN {3, 4} THEN  (*OUT or INOUT parameter*)
-      IF ~(y.tag IN {3, 7}) THEN  (*actual param is expression?*) LSS.Mark("bad actual param")
-      ELSIF y.b = NIL THEN y.b := undef
-      END
-    END
-  END Param;
-
-  PROCEDURE Statement;
-    VAR x, y, z, w, apar, npar: LSB.Item;
-      unit: LSB.UnitType; fpar: LSB.Object;
-  BEGIN
-    IF sym < LSS.ident THEN LSS.Mark("bad factor");
-      REPEAT LSS.Get(sym) UNTIL sym >= LSS.ident
-    END ;
-    IF sym = LSS.ident THEN
-      x := ThisObj(LSS.id); z := x; LSS.Get(sym); selector(z);
-      IF sym = LSS.becomes THEN LSS.Get(sym);
-        IF x.val >= 5 THEN LSS.Mark("assignment to read-only") END ;
-        IF (x.b # NIL) & ~(x.type IS LSB.ArrayType) THEN LSS.Mark("mult assign") END ;
-        expression(y); CheckAssign(z, y); x.b := y; (*tricky*)
-        IF z # x THEN x.a := z.b; x.val := 1 (*overwriting clk field x.a *) END
-      ELSIF sym = LSS.lparen THEN LSS.Get(sym);  (*unit instantiation*)
-        IF x.type IS LSB.UnitType THEN
-          unit := x.type(LSB.UnitType); fpar := unit.firstobj;
-          IF sym # LSS.rparen THEN
-            Param(fpar, apar); x.b := apar; fpar := fpar.next;
-            WHILE sym # LSS.rparen DO
-              IF sym = LSS.comma THEN LSS.Get(sym) END ;
-              Param(fpar, npar);
-              IF fpar.tag >= 3 THEN fpar := fpar.next; apar.a := npar; apar := npar
-              ELSE LSS.Mark("too many params")
-              END
-            END ;
-            IF fpar.val >= 3 THEN LSS.Mark("too few params") END
-          END ;
-          IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END
-        ELSE LSS.Mark("not a module")
-        END
-      ELSE LSS.Mark("bad statement")
-      END
-    ELSIF sym = LSS.ts THEN  (*tri-state*) LSS.Get(sym);
-      IF sym = LSS.lparen THEN LSS.Get(sym) ELSE LSS.Mark("( missing") END ;
-      IF sym = LSS.ident THEN
-        x := ThisObj(LSS.id); x.b := undef;  (*INOUT parameter*)
-        IF x.val # 5 THEN LSS.Mark("not INOUT") END ;
-        LSS.Get(sym);
-        IF sym = LSS.comma THEN LSS.Get(sym) END ;
-        IF sym = LSS.ident THEN y := ThisObj(LSS.id); CheckAssign(x, y); y.b := undef END ;  (*output from gate*)
-        LSS.Get(sym);
-        IF sym = LSS.comma THEN LSS.Get(sym) END ;
-        expression(z);
-        IF (z.tag = LSB.lit) & (z.val <= 1) THEN z.type := LSB.bitType END ;
-        CheckAssign(x, z); LSS.Get(sym);
-        IF sym = LSS.comma THEN LSS.Get(sym) END ;
-        expression(w);  (*control*)
-        IF w.type # LSB.bitType THEN CheckAssign(x, w) END ;
-        w := New(LSB.next, z, w); x.b := New(LSB.ts, y, w);
-        IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark(") missing") END
-      END
-    END
-  END Statement;
-
-  PROCEDURE StatSequence;
-  BEGIN Statement;
-    WHILE sym <= LSS.semicolon DO
-      IF sym < LSS.semicolon THEN LSS.Mark("semicolon missing?") END ;
-      WHILE sym = LSS.semicolon DO LSS.Get(sym) END ;
-      Statement
-    END ;
-    IF sym = LSS.end THEN LSS.Get(sym) ELSE LSS.Mark("END ?") END
-  END StatSequence;
-
-  (*---------------------------------------------------*)
-  
-  (* for variables and registers,, obj.val has the meaning
-    0  register
-    1  --
-    2  variable
-    3  output parameter
-    4  --
-    5  inout parameter
-    6  input parameter  *)
-  
-  PROCEDURE ConstDeclaration;
-    VAR obj: LSB.Object;
-  BEGIN
-    IF sym = LSS.ident THEN
-      obj := NewObj(LSB.const); LSS.Get(sym);
-      IF sym = LSS.eql THEN LSS.Get(sym) ELSE LSS.Mark(":= ?") END ;
-      expression(obj.b); obj.type := LSB.integer;
-      IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END
-    ELSE LSS.Mark("ident ?")
-    END
-  END ConstDeclaration;
-
-  PROCEDURE Type0(VAR type: LSB.Type);
-    VAR obj: LSB.Object; len, size: LONGINT;
-      eltyp: LSB.Type; arrtyp: LSB.ArrayType;
-  BEGIN len := 1;
-    IF sym = LSS.lbrak THEN (*array*) LSS.Get(sym);
-      IF sym = LSS.integer THEN len := LSS.val; LSS.Get(sym)
-      ELSIF sym = LSS.ident THEN obj := ThisObj(LSS.id); len := obj.val
-      END ;
-      IF sym = LSS.rbrak THEN LSS.Get(sym) ELSE LSS.Mark("rbrak ?") END ;
-      Type0(eltyp); NEW(arrtyp); size := eltyp.size * len;
-      arrtyp.eltyp := eltyp; type := arrtyp; type.len := len; type.size := size
-    ELSIF sym = LSS.ident THEN
-      obj := ThisObj(LSS.id); LSS.Get(sym);
-      IF obj # NIL THEN
-        IF obj.tag = LSB.typ THEN type := obj.type ELSE LSS.Mark("not a type"); type := LSB.bitType END
-      ELSE LSS.Mark("type ?")
-      END
-    ELSE type := LSB.bitType; LSS.Mark("ident or [")
-    END
-  END Type0;
-
-  PROCEDURE TypeDeclaration;
-    VAR obj: LSB.Object; utyp: LSB.UnitType;
-  BEGIN
-    IF sym = LSS.ident THEN
-      obj := NewObj(LSB.typ); LSS.Get(sym);
-      IF sym = LSS.eql THEN LSS.Get(sym) ELSE LSS.Mark(":= ?") END ;
-      IF sym = LSS.module THEN
-        LSS.Get(sym); NEW(utyp); Unit(utyp.firstobj); obj.type := utyp; obj.type.typobj := obj
-      ELSE Type0(obj.type)
-      END ;
-      IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END
-    ELSE LSS.Mark("ident ?")
-    END
-  END TypeDeclaration;
-
-  PROCEDURE VarList(kind: INTEGER; clk: LSB.Item);
-    VAR first, new, obj: LSB.Object; type: LSB.Type;
-  BEGIN obj := NIL;
-    WHILE sym = LSS.ident DO
-      new := NewObj(LSB.var); new.name := LSS.id; new.val := kind; first := new; LSS.Get(sym);
-      IF sym = LSS.comma THEN LSS.Get(sym) ELSIF sym = LSS.ident THEN LSS.Mark("comma missing") END ;
-      WHILE sym = LSS.ident DO
-        new := NewObj(LSB.var); new.name := LSS.id; new.val := kind; LSS.Get(sym);
-        IF sym = LSS.comma THEN LSS.Get(sym) ELSIF sym = LSS.ident THEN LSS.Mark("comma missing") END
-      END ;
-      IF sym = LSS.colon THEN
-        LSS.Get(sym); Type0(type); obj := first;
-        WHILE obj # bot DO obj.type := type; obj.a := clk; obj := obj.next END
-      ELSE LSS.Mark("colon ?")
-      END ;
-      IF sym = LSS.semicolon THEN LSS.Get(sym)
-      ELSIF sym # LSS.rparen THEN LSS.Mark("semicolon or rparen missing")
-      END
-    END
-  END VarList;
-
-  PROCEDURE ParamList;
-    VAR kind: INTEGER;
-  BEGIN
-    IF sym = LSS.in THEN LSS.Get(sym); kind := 6
-    ELSIF sym = LSS.out THEN LSS.Get(sym); kind := 3
-    ELSIF sym = LSS.inout THEN LSS.Get(sym); kind := 5
-    END ;
-    VarList(kind, NIL)
-  END ParamList;
-
-  PROCEDURE Traverse(x: LSB.Item);
-  BEGIN
-    IF x # NIL THEN
-      IF x IS LSB.Object THEN
-        IF (x.tag = LSB.var) & (x.val >= 2) THEN  (*not reg*) 
-          IF x(LSB.Object).marked THEN (*loop*)
-            Texts.WriteString(W, x(LSB.Object).name); Texts.Write(W, " "); err := TRUE
-          ELSIF x.b # NIL THEN x(LSB.Object).marked := TRUE; Traverse(x.b)
-          END ;
-          x(LSB.Object).marked := FALSE
-        END
-      ELSE Traverse(x.a); Traverse(x.b)
-      END
-    END
-  END Traverse;
-
-  PROCEDURE Unit0(VAR locals: LSB.Object);
-    VAR obj, oldtop: LSB.Object; kind: INTEGER; clock: LSB.Item;
-  BEGIN oldtop := top.next; top.next := LSB.root;  (*top is dummy*)
-    IF sym = LSS.lparen THEN LSS.Get(sym) ELSE LSS.Mark("lparen ?") END ;
-    WHILE (sym = LSS.in) OR (sym = LSS.out) OR (sym = LSS.inout) DO ParamList END ;
-    IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END ;
-    IF sym = LSS.xor (*arrow*) THEN LSS.Get(sym); locals := top.next
-    ELSE
-      IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END ;
-      IF sym = LSS.const THEN LSS.Get(sym);
-        WHILE sym = LSS.ident DO ConstDeclaration END
-      END ;
-      IF sym = LSS.type THEN LSS.Get(sym);
-        WHILE sym = LSS.ident DO TypeDeclaration END
-      END ;
-      WHILE (sym = LSS.var) OR (sym = LSS.reg) DO
-        IF sym = LSS.var THEN LSS.Get(sym);
-          WHILE sym = LSS.ident DO VarList(2, NIL) END
-        ELSE (*reg*) kind := 0; LSS.Get(sym);
-          IF sym = LSS.lparen THEN (*clock*)
-            LSS.Get(sym); expression(clock);
-            IF clock.type # LSB.bitType THEN LSS.Mark("clock must be bitType") END ;
-            IF (clock IS LSB.Object) & (clock(LSB.Object).name = "clk") THEN kind := 1; clock := NIL END ;
-            IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END
-          ELSE LSS.Mark("lparen expected"); clock := undef
-          END ;
-          WHILE sym = LSS.ident DO VarList(kind, clock) END
-        END
-      END ;
-      locals := top.next;
-      IF sym = LSS.begin THEN LSS.Get(sym); StatSequence END ;
-      obj := locals; err := FALSE;  (*find unassigned variables*)
-      WHILE obj # LSB.root DO
-        IF (obj.tag = LSB.var) & (obj.val < 5) THEN
-          IF (obj.b = NIL) & (obj.val < 4) THEN Texts.WriteString(W, obj.name); Texts.Write(W, " "); err := TRUE
-          ELSIF obj.b = undef THEN obj.b := NIL
-          END
-        END ;
-        obj := obj.next
-      END ;
-      IF err THEN Texts.WriteString(W, " unassigned"); Texts.WriteLn(W)
-      ELSE obj := locals; err := FALSE;  (*find combinatorial loops*)
-        WHILE obj # LSB.root DO
-          IF obj.tag = LSB.var THEN obj.marked := TRUE; Traverse(obj.b); obj.marked := FALSE END ;
-          obj := obj.next
-        END ;
-        IF err THEN Texts.WriteString(W, "in loop"); Texts.WriteLn(W) END
-      END
-    END ;
-    IF err THEN Texts.Append(Oberon.Log, W.buf) END ;
-    top.next := oldtop
-  END Unit0;
-
-  PROCEDURE Module(T: Texts.Text; pos: LONGINT);
-    VAR root: LSB.Object; modname: ARRAY 32 OF CHAR;
-  BEGIN Texts.WriteString(W, "compiling Lola: ");
-    bot := LSB.root; top.next := bot; LSS.Init(T, pos); LSS.Get(sym);
-    IF sym = LSS.module THEN
-      LSS.Get(sym);
-      IF sym = LSS.ident THEN
-        modname := LSS.id; Texts.WriteString(W, LSS.id); LSS.Get(sym);
-        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-      ELSE LSS.Mark("ident ?")
-      END ;
-      Unit(root);
-      IF sym = LSS.ident THEN LSS.Get(sym);
-        IF LSS.id # modname THEN LSS.Mark("no match") END
-      END ;
-      IF sym # LSS.period THEN LSS.Mark("period ?") END ;
-      IF ~LSS.error THEN LSB.Register(modname, root)
-      ELSE Texts.WriteString(W, "compilation failed"); Texts.WriteLn(W); LSB.Register("", LSB.root)
-      END
-    ELSE LSS.Mark("module ?")
-    END ;
-    Texts.Append(Oberon.Log, W.buf)
-  END Module;
-
-  PROCEDURE Compile*;
-    VAR beg, end, time: LONGINT;
-      S: Texts.Scanner; T: Texts.Text;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Char THEN
-      IF S.c = "*" THEN
-      ELSIF S.c = "@" THEN
-        Oberon.GetSelection(T, beg, end, time);
-        IF time >= 0 THEN Module(T, beg) END
-      END
-    ELSIF S.class = Texts.Name THEN
-      NEW(T); Texts.Open(T, S.s); Module(T, 0)
-    END ;
-    Texts.Append(Oberon.Log, W.buf)
-  END Compile;
-
-BEGIN Texts.OpenWriter(W);
-  Texts.WriteString(W, "Lola compiler; NW 27.8.2018"); Texts.WriteLn(W);
-  factor := factor0; expression := expression0; Unit := Unit0;
-  NEW(top); bot := LSB.root;
-  NEW(undef); undef.tag := LSB.typ; undef.type := LSB.bitType; undef.next := NIL
-END LSC.
+MODULE LSC;  (*Lola System Compiler, NW 8.1.95 / 27.8.2018 for RISC (LSCX)*)
+  IMPORT Texts, Oberon, LSB, LSS;
+  
+  VAR sym: INTEGER;
+    err: BOOLEAN;  (*used at end of Unit*)
+    top, bot, undef: LSB.Object;
+    factor: PROCEDURE (VAR x: LSB.Item);  (*to avoid forward references*)
+    expression: PROCEDURE (VAR x: LSB.Item);
+    Unit: PROCEDURE (VAR locals: LSB.Object);
+    W: Texts.Writer;
+
+  PROCEDURE Err(n: INTEGER);
+  BEGIN LSS.Mark("type error"); Texts.WriteInt(W, n, 4);
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END Err;
+
+  PROCEDURE Log(m: LONGINT): LONGINT;
+    VAR n: LONGINT;
+  BEGIN n := 1;
+    WHILE m > 1 DO m := m DIV 2; INC(n) END ;
+    RETURN n
+  END Log;
+
+  PROCEDURE New(tag: INTEGER; a, b: LSB.Item): LSB.Item;
+    VAR z: LSB.Item;
+  BEGIN NEW(z); z.tag := tag; z.a := a; z.b := b; z.val := b.val; RETURN z
+  END New;
+
+  PROCEDURE NewObj(class: INTEGER): LSB.Object; (*insert at end, before BIT*)
+    VAR new, x: LSB.Object;
+  BEGIN x := top;
+    WHILE (x.next # bot) & (x.next.name # LSS.id) DO x := x.next END ;
+    IF x.next = bot THEN
+      NEW(new); new.name := LSS.id; new.tag := class; new.next := bot; x.next := new
+    ELSE LSS.Mark("mult def"); new := x
+    END ;
+    RETURN new
+  END NewObj;
+
+  PROCEDURE ThisObj(id: LSS.Ident): LSB.Object;  (*find object with name = identifier last read*)
+    VAR x: LSB.Object;
+  BEGIN x := top.next;
+    WHILE (x # NIL) & (x.name # id) DO x := x.next END ;
+    IF x = NIL THEN LSS.Mark("undef"); x := undef END ;
+    RETURN x
+  END ThisObj;
+
+  PROCEDURE CheckTypes(x, y, z: LSB.Item);  (*z.type = result type*)
+    VAR xtyp, ytyp: LSB.Type;
+  BEGIN xtyp := x.type; ytyp := y.type; z.type := xtyp; z.size := x.size; z.val := x.val;
+    IF xtyp = LSB.bitType THEN
+      IF ytyp = LSB.integer THEN  (* b + 0 *)
+        IF y.val >= 2 THEN Err(20); LSS.Mark("only 0 or 1") END
+      ELSIF ytyp = LSB.string THEN (* b + {...} *) Err(21)
+      ELSIF ytyp # LSB.bitType THEN Err(22)
+      END
+    ELSIF xtyp IS LSB.ArrayType THEN
+      IF xtyp(LSB.ArrayType).eltyp = LSB.bitType THEN
+        IF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = LSB.bitType) THEN
+          IF xtyp.size # ytyp.size THEN Err(33) END  (* x + y *)
+        ELSIF ytyp = LSB.integer THEN   (* w + 5 *)
+          IF xtyp.size < Log(y.val) THEN Err(30) END
+        ELSIF ytyp = LSB.string THEN   (*x + {...} *)
+          IF xtyp.size # y.size THEN Err(31) END
+        ELSE Err(34)
+        END
+      ELSIF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = ytyp(LSB.ArrayType).eltyp) THEN
+        IF (xtyp.size # ytyp.size) THEN Err(40) END
+      ELSE Err(41)
+      END 
+    ELSIF xtyp = LSB.string THEN
+      IF ytyp = LSB.bitType THEN  (* {...} + b *) Err(12)
+      ELSIF (ytyp IS LSB.ArrayType) & (ytyp(LSB.ArrayType).eltyp = LSB.bitType) THEN  (* {...} + w *)
+        IF x.size # ytyp.size THEN Err(13) END
+      ELSIF ytyp = LSB.integer THEN  (* {...} + 5*)
+        IF x.size < Log(y.val) THEN Err(10) END
+      ELSIF ytyp = LSB.string THEN  (* {...} + {...} *)
+        IF x.size # y.size THEN Err(11) END ;  
+      ELSE Err(14)
+      END
+    ELSIF xtyp = LSB.integer THEN
+      IF (ytyp IS LSB.ArrayType) & (ytyp(LSB.ArrayType).eltyp = LSB.bitType) THEN  (* 5 + w *)
+        IF Log(x.val) > ytyp.size THEN Err(3); LSS.Mark("const too large") END
+      ELSIF ytyp = LSB.bitType THEN (* 5 + b *)
+        IF x.val >= 2 THEN Err(2) END
+      ELSIF ytyp = LSB.integer THEN  (* 5 + 5 *)
+      ELSIF ytyp = LSB.string THEN  (* 5 + {...} *)
+        IF Log(x.val) > y.size THEN Err(12) END
+      ELSE Err(4)
+      END
+    END
+  END CheckTypes;
+
+  PROCEDURE selector(VAR x: LSB.Item);
+    VAR y, z: LSB.Item; obj: LSB.Object;
+      eltyp: LSB.Type; len, kind: LONGINT;
+  BEGIN
+    WHILE (sym = LSS.lbrak) OR (sym = LSS.period) DO
+      IF sym = LSS.lbrak THEN
+        eltyp := x.type(LSB.ArrayType).eltyp; LSS.Get(sym); expression(y);
+        IF sym = LSS.colon THEN (*range*)
+          LSS.Get(sym); expression(z);
+          IF (y.tag = LSB.lit) & (z.tag = LSB.lit) THEN
+            len := y.val - z.val + 1; y := New(LSB.range, y, z); x := New(LSB.sel, x, y); x.type := LSB.string; x.size := len
+          END
+        ELSE kind := x.val; x := New(LSB.sel, x, y); x.type := eltyp; x.val := kind
+        END ;
+        IF sym = LSS.rbrak THEN LSS.Get(sym) ELSE LSS.Mark("rbrak ?") END
+      ELSE (*sym = LSS.period*) LSS.Get(sym); factor(y);
+        IF (y.tag = LSB.lit) & (y.val >= x.type.len) THEN LSS.Mark("too large") END ;
+        eltyp := x.type(LSB.ArrayType).eltyp; kind := x.val; x := New(LSB.sel, x, y); x.type := eltyp; x.val := kind
+      END
+    END
+  END selector;
+
+  PROCEDURE elem(VAR x: LSB.Item; VAR len: LONGINT);
+    VAR y, z: LSB.Item; m, n: LONGINT;
+  BEGIN expression(x);
+    IF (x.type = LSB.integer) OR (x.type = LSB.string) THEN m := x.size ELSE m := x.type.size END ;
+    IF sym = LSS.repl THEN
+      LSS.Get(sym);
+      IF sym = LSS.integer THEN
+        NEW(y); y.tag := LSB.lit; n := LSS.val; y.val := n; y.type := LSB.integer; LSS.Get(sym);
+        x := New(LSB.repl, x, y)
+      END
+    ELSE n := 1
+    END ;
+    len := m*n
+  END elem;
+
+  PROCEDURE constructor(VAR x: LSB.Item);
+    VAR y: LSB.Item; n, len: LONGINT;
+  BEGIN elem(x, len);
+    WHILE sym = LSS.comma DO
+      LSS.Get(sym); elem(y, n); INC(len, n); x := New(LSB.cons, x, y); x.val := len
+    END ;
+    x.size := len; x.type := LSB.string;
+    IF sym = LSS.rbrace THEN LSS.Get(sym) ELSE LSS.Mark("rbrace ?") END
+  END constructor;
+
+  PROCEDURE factor0(VAR x: LSB.Item);
+    VAR obj: LSB.Object; y, z: LSB.Item;
+      n, len: LONGINT; t: LSB.ArrayType;
+  BEGIN
+    IF sym = LSS.ident THEN
+      x := ThisObj(LSS.id); LSS.Get(sym);
+      IF x.tag = LSB.var THEN selector(x)
+      ELSIF x.tag = LSB.const THEN n := x.b.val; NEW(x); x.tag := LSB.lit; x.val := n; x.type := LSB.integer
+      ELSE LSS.Mark("bad factor")
+      END
+    ELSIF sym = LSS.lparen THEN
+      LSS.Get(sym); expression(x);
+      IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END
+    ELSIF sym = LSS.integer THEN
+      NEW(x); x.tag := LSB.lit; x.val := LSS.val; x.type := LSB.integer; LSS.Get(sym);
+      IF sym = LSS.apo THEN LSS.Get(sym);
+        IF sym = LSS.integer THEN
+          len := LSS.val; LSS.Get(sym);
+          IF len < Log(x.val) THEN LSS.Mark("value too large") END
+        ELSE LSS.Mark("integer ?"); len := 0
+        END
+      ELSE len := 0
+      END ;
+      x.size := len
+    ELSIF sym = LSS.not THEN
+      LSS.Get(sym); factor(x); y := New(LSB.not, NIL, x); y.type := x.type; y.size := x.size; x := y
+    ELSIF sym = LSS.lbrace THEN LSS.Get(sym); constructor(x)
+    ELSE LSS.Mark("bad factor")
+    END
+  END factor0;
+
+  PROCEDURE term(VAR x: LSB.Item);
+    VAR y, z: LSB.Item; op: INTEGER;
+  BEGIN factor(x);
+    WHILE (sym >= LSS.times) & (sym <= LSS.and) DO
+      IF sym = LSS.and THEN op := LSB.and
+      ELSIF sym = LSS.times THEN op := LSB.mul
+      ELSIF sym = LSS.div THEN op := LSB.div
+      END ;
+      LSS.Get(sym); factor(y); z := New(op, x, y); CheckTypes(x, y, z); x := z
+    END
+  END term;
+
+  PROCEDURE SimpleExpression(VAR x: LSB.Item);
+    VAR y, z: LSB.Item; op: INTEGER;
+  BEGIN
+    IF sym = LSS.minus THEN LSS.Get(sym); term(y);
+      IF y.tag = LSB.lit THEN x := y; x.val := -y.val
+      ELSE x := New(LSB.sub, NIL, y); x.type := y.type; x.size := y.size
+      END
+    ELSIF sym = LSS.plus THEN LSS.Get(sym); term(x);
+    ELSE term(x)
+    END ;
+    WHILE (sym >= LSS.plus) & (sym <= LSS.xor) DO
+      IF sym = LSS.or THEN op := LSB.or
+      ELSIF sym = LSS.xor THEN op := LSB.xor
+      ELSIF sym = LSS.plus THEN op := LSB.add
+      ELSIF sym = LSS.minus THEN op := LSB.sub
+      END ;
+      LSS.Get(sym); term(y); z := New(op, x, y); CheckTypes(x, y, z); x := z
+    END
+  END SimpleExpression;
+
+  PROCEDURE UncondExpression(VAR x: LSB.Item);
+    VAR y, z: LSB.Item; rel: INTEGER;
+  BEGIN SimpleExpression(x);
+    IF (sym >= LSS.eql) & (sym <= LSS.geq) THEN
+      IF sym = LSS.eql THEN rel := LSB.eql
+      ELSIF sym = LSS.neq THEN rel := LSB.neq
+      ELSIF sym = LSS.lss THEN rel := LSB.lss
+      ELSIF sym = LSS.geq THEN rel := LSB.geq
+      ELSIF sym = LSS.leq THEN rel := LSB.leq
+      ELSE rel := LSB.gtr
+      END ;
+      LSS.Get(sym); SimpleExpression(y); z := New(rel, x, y); CheckTypes(x, y, z); z.type := LSB.bitType; x := z
+    END
+  END UncondExpression;
+
+  PROCEDURE expression0(VAR x: LSB.Item);
+    VAR y, z, w: LSB.Item;
+  BEGIN UncondExpression(x);
+    IF sym = LSS.then THEN
+      IF x.type # LSB.bitType THEN LSS.Mark("Boolean?") END ;
+      LSS.Get(sym); expression(y);
+      IF sym = LSS.colon THEN
+        LSS.Get(sym); expression(z); w := New(LSB.else, y, z); CheckTypes(y, z, w);
+        x := New(LSB.then, x, w); x.type := w.type; x.size := w.size
+      ELSE LSS.Mark("colon ?")
+      END
+    END
+  END expression0;
+
+  PROCEDURE CheckAssign(x, y: LSB.Item);
+    VAR xtyp, ytyp: LSB.Type;
+  BEGIN xtyp := x.type; ytyp := y.type;
+    IF xtyp # ytyp THEN
+      IF xtyp = LSB.bitType THEN
+        IF (ytyp # LSB.integer) OR (y.val >= 2) THEN Err(70); END
+      ELSIF xtyp IS LSB.ArrayType THEN
+        IF xtyp(LSB.ArrayType).eltyp = LSB.bitType THEN
+          IF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (*w := w*)
+            IF xtyp.size # ytyp.size THEN Err(71) END  (* x + y *)
+          ELSIF ytyp = LSB.integer THEN   (* w := 5 *)
+            IF xtyp.size < Log(y.val) THEN Err(72) END
+          ELSIF ytyp = LSB.string THEN   (* w := {...} *)
+            IF xtyp.size # y.size THEN Err(73) END
+          ELSE Err(74)
+          END
+        ELSE Err(74)
+        END
+      END
+    END
+  END CheckAssign;
+
+  PROCEDURE Param(fpar: LSB.Object; VAR apar: LSB.Item);
+    VAR y, z: LSB.Item;
+  BEGIN expression(y); apar := New(LSB.next, NIL, y); CheckAssign(fpar, y);
+    IF fpar.val IN {3, 4} THEN  (*OUT or INOUT parameter*)
+      IF ~(y.tag IN {3, 7}) THEN  (*actual param is expression?*) LSS.Mark("bad actual param")
+      ELSIF y.b = NIL THEN y.b := undef
+      END
+    END
+  END Param;
+
+  PROCEDURE Statement;
+    VAR x, y, z, w, apar, npar: LSB.Item;
+      unit: LSB.UnitType; fpar: LSB.Object;
+  BEGIN
+    IF sym < LSS.ident THEN LSS.Mark("bad factor");
+      REPEAT LSS.Get(sym) UNTIL sym >= LSS.ident
+    END ;
+    IF sym = LSS.ident THEN
+      x := ThisObj(LSS.id); z := x; LSS.Get(sym); selector(z);
+      IF sym = LSS.becomes THEN LSS.Get(sym);
+        IF x.val >= 5 THEN LSS.Mark("assignment to read-only") END ;
+        IF (x.b # NIL) & ~(x.type IS LSB.ArrayType) THEN LSS.Mark("mult assign") END ;
+        expression(y); CheckAssign(z, y); x.b := y; (*tricky*)
+        IF z # x THEN x.a := z.b; x.val := 1 (*overwriting clk field x.a *) END
+      ELSIF sym = LSS.lparen THEN LSS.Get(sym);  (*unit instantiation*)
+        IF x.type IS LSB.UnitType THEN
+          unit := x.type(LSB.UnitType); fpar := unit.firstobj;
+          IF sym # LSS.rparen THEN
+            Param(fpar, apar); x.b := apar; fpar := fpar.next;
+            WHILE sym # LSS.rparen DO
+              IF sym = LSS.comma THEN LSS.Get(sym) END ;
+              Param(fpar, npar);
+              IF fpar.tag >= 3 THEN fpar := fpar.next; apar.a := npar; apar := npar
+              ELSE LSS.Mark("too many params")
+              END
+            END ;
+            IF fpar.val >= 3 THEN LSS.Mark("too few params") END
+          END ;
+          IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END
+        ELSE LSS.Mark("not a module")
+        END
+      ELSE LSS.Mark("bad statement")
+      END
+    ELSIF sym = LSS.ts THEN  (*tri-state*) LSS.Get(sym);
+      IF sym = LSS.lparen THEN LSS.Get(sym) ELSE LSS.Mark("( missing") END ;
+      IF sym = LSS.ident THEN
+        x := ThisObj(LSS.id); x.b := undef;  (*INOUT parameter*)
+        IF x.val # 5 THEN LSS.Mark("not INOUT") END ;
+        LSS.Get(sym);
+        IF sym = LSS.comma THEN LSS.Get(sym) END ;
+        IF sym = LSS.ident THEN y := ThisObj(LSS.id); CheckAssign(x, y); y.b := undef END ;  (*output from gate*)
+        LSS.Get(sym);
+        IF sym = LSS.comma THEN LSS.Get(sym) END ;
+        expression(z);
+        IF (z.tag = LSB.lit) & (z.val <= 1) THEN z.type := LSB.bitType END ;
+        CheckAssign(x, z); LSS.Get(sym);
+        IF sym = LSS.comma THEN LSS.Get(sym) END ;
+        expression(w);  (*control*)
+        IF w.type # LSB.bitType THEN CheckAssign(x, w) END ;
+        w := New(LSB.next, z, w); x.b := New(LSB.ts, y, w);
+        IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark(") missing") END
+      END
+    END
+  END Statement;
+
+  PROCEDURE StatSequence;
+  BEGIN Statement;
+    WHILE sym <= LSS.semicolon DO
+      IF sym < LSS.semicolon THEN LSS.Mark("semicolon missing?") END ;
+      WHILE sym = LSS.semicolon DO LSS.Get(sym) END ;
+      Statement
+    END ;
+    IF sym = LSS.end THEN LSS.Get(sym) ELSE LSS.Mark("END ?") END
+  END StatSequence;
+
+  (*---------------------------------------------------*)
+  
+  (* for variables and registers,, obj.val has the meaning
+    0  register
+    1  --
+    2  variable
+    3  output parameter
+    4  --
+    5  inout parameter
+    6  input parameter  *)
+  
+  PROCEDURE ConstDeclaration;
+    VAR obj: LSB.Object;
+  BEGIN
+    IF sym = LSS.ident THEN
+      obj := NewObj(LSB.const); LSS.Get(sym);
+      IF sym = LSS.eql THEN LSS.Get(sym) ELSE LSS.Mark(":= ?") END ;
+      expression(obj.b); obj.type := LSB.integer;
+      IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END
+    ELSE LSS.Mark("ident ?")
+    END
+  END ConstDeclaration;
+
+  PROCEDURE Type0(VAR type: LSB.Type);
+    VAR obj: LSB.Object; len, size: LONGINT;
+      eltyp: LSB.Type; arrtyp: LSB.ArrayType;
+  BEGIN len := 1;
+    IF sym = LSS.lbrak THEN (*array*) LSS.Get(sym);
+      IF sym = LSS.integer THEN len := LSS.val; LSS.Get(sym)
+      ELSIF sym = LSS.ident THEN obj := ThisObj(LSS.id); len := obj.val
+      END ;
+      IF sym = LSS.rbrak THEN LSS.Get(sym) ELSE LSS.Mark("rbrak ?") END ;
+      Type0(eltyp); NEW(arrtyp); size := eltyp.size * len;
+      arrtyp.eltyp := eltyp; type := arrtyp; type.len := len; type.size := size
+    ELSIF sym = LSS.ident THEN
+      obj := ThisObj(LSS.id); LSS.Get(sym);
+      IF obj # NIL THEN
+        IF obj.tag = LSB.typ THEN type := obj.type ELSE LSS.Mark("not a type"); type := LSB.bitType END
+      ELSE LSS.Mark("type ?")
+      END
+    ELSE type := LSB.bitType; LSS.Mark("ident or [")
+    END
+  END Type0;
+
+  PROCEDURE TypeDeclaration;
+    VAR obj: LSB.Object; utyp: LSB.UnitType;
+  BEGIN
+    IF sym = LSS.ident THEN
+      obj := NewObj(LSB.typ); LSS.Get(sym);
+      IF sym = LSS.eql THEN LSS.Get(sym) ELSE LSS.Mark(":= ?") END ;
+      IF sym = LSS.module THEN
+        LSS.Get(sym); NEW(utyp); Unit(utyp.firstobj); obj.type := utyp; obj.type.typobj := obj
+      ELSE Type0(obj.type)
+      END ;
+      IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END
+    ELSE LSS.Mark("ident ?")
+    END
+  END TypeDeclaration;
+
+  PROCEDURE VarList(kind: INTEGER; clk: LSB.Item);
+    VAR first, new, obj: LSB.Object; type: LSB.Type;
+  BEGIN obj := NIL;
+    WHILE sym = LSS.ident DO
+      new := NewObj(LSB.var); new.name := LSS.id; new.val := kind; first := new; LSS.Get(sym);
+      IF sym = LSS.comma THEN LSS.Get(sym) ELSIF sym = LSS.ident THEN LSS.Mark("comma missing") END ;
+      WHILE sym = LSS.ident DO
+        new := NewObj(LSB.var); new.name := LSS.id; new.val := kind; LSS.Get(sym);
+        IF sym = LSS.comma THEN LSS.Get(sym) ELSIF sym = LSS.ident THEN LSS.Mark("comma missing") END
+      END ;
+      IF sym = LSS.colon THEN
+        LSS.Get(sym); Type0(type); obj := first;
+        WHILE obj # bot DO obj.type := type; obj.a := clk; obj := obj.next END
+      ELSE LSS.Mark("colon ?")
+      END ;
+      IF sym = LSS.semicolon THEN LSS.Get(sym)
+      ELSIF sym # LSS.rparen THEN LSS.Mark("semicolon or rparen missing")
+      END
+    END
+  END VarList;
+
+  PROCEDURE ParamList;
+    VAR kind: INTEGER;
+  BEGIN
+    IF sym = LSS.in THEN LSS.Get(sym); kind := 6
+    ELSIF sym = LSS.out THEN LSS.Get(sym); kind := 3
+    ELSIF sym = LSS.inout THEN LSS.Get(sym); kind := 5
+    END ;
+    VarList(kind, NIL)
+  END ParamList;
+
+  PROCEDURE Traverse(x: LSB.Item);
+  BEGIN
+    IF x # NIL THEN
+      IF x IS LSB.Object THEN
+        IF (x.tag = LSB.var) & (x.val >= 2) THEN  (*not reg*) 
+          IF x(LSB.Object).marked THEN (*loop*)
+            Texts.WriteString(W, x(LSB.Object).name); Texts.Write(W, " "); err := TRUE
+          ELSIF x.b # NIL THEN x(LSB.Object).marked := TRUE; Traverse(x.b)
+          END ;
+          x(LSB.Object).marked := FALSE
+        END
+      ELSE Traverse(x.a); Traverse(x.b)
+      END
+    END
+  END Traverse;
+
+  PROCEDURE Unit0(VAR locals: LSB.Object);
+    VAR obj, oldtop: LSB.Object; kind: INTEGER; clock: LSB.Item;
+  BEGIN oldtop := top.next; top.next := LSB.root;  (*top is dummy*)
+    IF sym = LSS.lparen THEN LSS.Get(sym) ELSE LSS.Mark("lparen ?") END ;
+    WHILE (sym = LSS.in) OR (sym = LSS.out) OR (sym = LSS.inout) DO ParamList END ;
+    IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END ;
+    IF sym = LSS.xor (*arrow*) THEN LSS.Get(sym); locals := top.next
+    ELSE
+      IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END ;
+      IF sym = LSS.const THEN LSS.Get(sym);
+        WHILE sym = LSS.ident DO ConstDeclaration END
+      END ;
+      IF sym = LSS.type THEN LSS.Get(sym);
+        WHILE sym = LSS.ident DO TypeDeclaration END
+      END ;
+      WHILE (sym = LSS.var) OR (sym = LSS.reg) DO
+        IF sym = LSS.var THEN LSS.Get(sym);
+          WHILE sym = LSS.ident DO VarList(2, NIL) END
+        ELSE (*reg*) kind := 0; LSS.Get(sym);
+          IF sym = LSS.lparen THEN (*clock*)
+            LSS.Get(sym); expression(clock);
+            IF clock.type # LSB.bitType THEN LSS.Mark("clock must be bitType") END ;
+            IF (clock IS LSB.Object) & (clock(LSB.Object).name = "clk") THEN kind := 1; clock := NIL END ;
+            IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END
+          ELSE LSS.Mark("lparen expected"); clock := undef
+          END ;
+          WHILE sym = LSS.ident DO VarList(kind, clock) END
+        END
+      END ;
+      locals := top.next;
+      IF sym = LSS.begin THEN LSS.Get(sym); StatSequence END ;
+      obj := locals; err := FALSE;  (*find unassigned variables*)
+      WHILE obj # LSB.root DO
+        IF (obj.tag = LSB.var) & (obj.val < 5) THEN
+          IF (obj.b = NIL) & (obj.val < 4) THEN Texts.WriteString(W, obj.name); Texts.Write(W, " "); err := TRUE
+          ELSIF obj.b = undef THEN obj.b := NIL
+          END
+        END ;
+        obj := obj.next
+      END ;
+      IF err THEN Texts.WriteString(W, " unassigned"); Texts.WriteLn(W)
+      ELSE obj := locals; err := FALSE;  (*find combinatorial loops*)
+        WHILE obj # LSB.root DO
+          IF obj.tag = LSB.var THEN obj.marked := TRUE; Traverse(obj.b); obj.marked := FALSE END ;
+          obj := obj.next
+        END ;
+        IF err THEN Texts.WriteString(W, "in loop"); Texts.WriteLn(W) END
+      END
+    END ;
+    IF err THEN Texts.Append(Oberon.Log, W.buf) END ;
+    top.next := oldtop
+  END Unit0;
+
+  PROCEDURE Module(T: Texts.Text; pos: LONGINT);
+    VAR root: LSB.Object; modname: ARRAY 32 OF CHAR;
+  BEGIN Texts.WriteString(W, "compiling Lola: ");
+    bot := LSB.root; top.next := bot; LSS.Init(T, pos); LSS.Get(sym);
+    IF sym = LSS.module THEN
+      LSS.Get(sym);
+      IF sym = LSS.ident THEN
+        modname := LSS.id; Texts.WriteString(W, LSS.id); LSS.Get(sym);
+        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+      ELSE LSS.Mark("ident ?")
+      END ;
+      Unit(root);
+      IF sym = LSS.ident THEN LSS.Get(sym);
+        IF LSS.id # modname THEN LSS.Mark("no match") END
+      END ;
+      IF sym # LSS.period THEN LSS.Mark("period ?") END ;
+      IF ~LSS.error THEN LSB.Register(modname, root)
+      ELSE Texts.WriteString(W, "compilation failed"); Texts.WriteLn(W); LSB.Register("", LSB.root)
+      END
+    ELSE LSS.Mark("module ?")
+    END ;
+    Texts.Append(Oberon.Log, W.buf)
+  END Module;
+
+  PROCEDURE Compile*;
+    VAR beg, end, time: LONGINT;
+      S: Texts.Scanner; T: Texts.Text;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Char THEN
+      IF S.c = "*" THEN
+      ELSIF S.c = "@" THEN
+        Oberon.GetSelection(T, beg, end, time);
+        IF time >= 0 THEN Module(T, beg) END
+      END
+    ELSIF S.class = Texts.Name THEN
+      NEW(T); Texts.Open(T, S.s); Module(T, 0)
+    END ;
+    Texts.Append(Oberon.Log, W.buf)
+  END Compile;
+
+BEGIN Texts.OpenWriter(W);
+  Texts.WriteString(W, "Lola compiler; NW 27.8.2018"); Texts.WriteLn(W);
+  factor := factor0; expression := expression0; Unit := Unit0;
+  NEW(top); bot := LSB.root;
+  NEW(undef); undef.tag := LSB.typ; undef.type := LSB.bitType; undef.next := NIL
+END LSC.

people.inf.ethz.ch/wirth/Lola/Sources/LSP.Mod.txt

@@ -1,85 +1,85 @@
-MODULE LSP;  (*display data structure;  NW 28.8.2015*)
-  IMPORT Texts, Oberon, LSB;
-
-  VAR W: Texts.Writer;
-    C: ARRAY 64, 6 OF CHAR;
-
-  PROCEDURE PrintType(typ: LSB.Type);
-    VAR obj: LSB.Object;
-  BEGIN
-    IF typ IS LSB.ArrayType THEN
-      Texts.Write(W, "["); Texts.WriteInt(W, typ.len, 1); Texts.Write(W, "]"); PrintType(typ(LSB.ArrayType).eltyp)
-    ELSIF typ IS LSB.UnitType THEN
-      Texts.WriteString(W, "UnitType "); obj := typ(LSB.UnitType).firstobj;
-    ELSE Texts.WriteString(W, "BIT")
-    END ;
-    Texts.Append(Oberon.Log, W.buf)
-  END PrintType;
-
-  PROCEDURE PrintTree(x: LSB.Item; n: INTEGER);
-    VAR i: INTEGER;
-  BEGIN
-    IF x # NIL THEN  i := n;
-      IF x IS LSB.Object THEN
-        WHILE i > 0 DO Texts.Write(W, 9X); DEC(i) END ;
-        Texts.WriteString(W, x(LSB.Object).name); Texts.WriteLn(W)
-      ELSE
-        PrintTree(x.a, n+1);
-        WHILE i > 0 DO Texts.Write(W, 9X); DEC(i) END ;
-        IF x.tag = LSB.lit THEN Texts. WriteInt(W, x.val, 1) ELSE Texts.WriteString(W, C[x.tag]); END ;
-        Texts.WriteLn(W);
-        PrintTree(x.b, n+1)
-      END
-    END
-  END PrintTree;
-
-  PROCEDURE PrintObj(obj: LSB.Object; n: INTEGER);
-    VAR apar: LSB.Item; obj1: LSB.Object;
-  BEGIN
-    IF n > 0 THEN Texts.Write(W, 9X) END ;
-    Texts.WriteString(W, C[obj.tag]); Texts.Write(W, " "); Texts.WriteString(W, obj.name); Texts.Append(Oberon.Log, W.buf);
-    IF obj.tag = LSB.const THEN Texts.WriteString(W, " = "); PrintTree(obj.b, 1); Texts.WriteLn(W)
-    ELSIF obj.tag = LSB.typ THEN
-      IF obj.type IS LSB.UnitType THEN  (*formal param list*)
-        obj1 := obj.type(LSB.UnitType).firstobj;
-        Texts.WriteString(W, " BEGIN "); Texts.WriteLn(W);
-        WHILE (obj1 # NIL) & (obj1 # LSB.root) DO PrintObj(obj1, 0); obj1 := obj1.next END ;
-        Texts.WriteString(W, "END"); Texts.WriteLn(W)
-      ELSE PrintType(obj.type)
-      END
-    ELSE (*var*) Texts.WriteString(W, ": ");
-      IF obj.type IS LSB.UnitType THEN
-        Texts.WriteString(W, obj.type.typobj.name);
-        apar := obj.b; Texts.WriteString(W, " [");  (*actual param list*)
-        WHILE apar # NIL DO PrintTree(apar.b, 1); apar := apar.a END ;
-        Texts.Write(W, "]"); Texts.WriteLn(W)
-      ELSE PrintType(obj.type);
-        Texts.WriteString(W, " #"); Texts.WriteInt(W, obj.val, 1);
-        IF obj.a # NIL THEN
-           IF obj.val = 0 THEN Texts.WriteString(W, " CLK") ELSIF obj.val = 1 THEN (*indexed*) Texts.WriteString(W, " DEMUX") END ;
-           PrintTree(obj.a, 1)
-        END ;
-        IF obj.b # NIL THEN Texts.WriteString(W, " := "); Texts.WriteLn(W); PrintTree(obj.b, 1)
-        ELSE Texts.WriteLn(W)
-        END
-      END
-    END ;
-    Texts.Append(Oberon.Log, W.buf)
-  END PrintObj;
-
-  PROCEDURE List*;
-    VAR obj: LSB.Object;
-  BEGIN obj := LSB.top;
-    Texts.WriteString(W, "listing "); Texts.WriteString(W, LSB.modname); Texts.WriteLn(W);
-    WHILE (obj # LSB.root) & (obj # NIL) DO PrintObj(obj, 0); obj := obj.next END ;
-    Texts.Append(Oberon.Log, W.buf)
-  END List;
-
-BEGIN Texts.OpenWriter(W);
-  C[LSB.const] := "CONST"; C[LSB.typ] := "TYPE"; C[LSB.var] := "VAR";
-  C[LSB.lit] := "LIT"; C[LSB.sel] := "MUX"; C[LSB.range] := ": "; C[LSB.cons] := ", "; C[LSB.repl] := "**";
-  C[LSB.or] := "| "; C[LSB.xor] := "^ "; C[LSB.and] := "& ";  C[LSB.not] := "~ ";
-  C[LSB.add] := "+ "; C[LSB.sub] := "- "; C[LSB.mul] := "* "; C[LSB.div] := "/ ";
-  C[LSB.eql] := "= "; C[LSB.neq] := "# "; C[LSB.lss] := "< "; C[LSB.geq] := ">="; C[LSB.leq] := "<="; C[LSB.gtr] := "> ";
-  C[LSB.then] := " -> "; C[LSB.else] := " :: "; C[LSB.ts] := "TS "; C[LSB.next] := "--"
-END LSP.
+MODULE LSP;  (*display data structure;  NW 28.8.2015*)
+  IMPORT Texts, Oberon, LSB;
+
+  VAR W: Texts.Writer;
+    C: ARRAY 64, 6 OF CHAR;
+
+  PROCEDURE PrintType(typ: LSB.Type);
+    VAR obj: LSB.Object;
+  BEGIN
+    IF typ IS LSB.ArrayType THEN
+      Texts.Write(W, "["); Texts.WriteInt(W, typ.len, 1); Texts.Write(W, "]"); PrintType(typ(LSB.ArrayType).eltyp)
+    ELSIF typ IS LSB.UnitType THEN
+      Texts.WriteString(W, "UnitType "); obj := typ(LSB.UnitType).firstobj;
+    ELSE Texts.WriteString(W, "BIT")
+    END ;
+    Texts.Append(Oberon.Log, W.buf)
+  END PrintType;
+
+  PROCEDURE PrintTree(x: LSB.Item; n: INTEGER);
+    VAR i: INTEGER;
+  BEGIN
+    IF x # NIL THEN  i := n;
+      IF x IS LSB.Object THEN
+        WHILE i > 0 DO Texts.Write(W, 9X); DEC(i) END ;
+        Texts.WriteString(W, x(LSB.Object).name); Texts.WriteLn(W)
+      ELSE
+        PrintTree(x.a, n+1);
+        WHILE i > 0 DO Texts.Write(W, 9X); DEC(i) END ;
+        IF x.tag = LSB.lit THEN Texts. WriteInt(W, x.val, 1) ELSE Texts.WriteString(W, C[x.tag]); END ;
+        Texts.WriteLn(W);
+        PrintTree(x.b, n+1)
+      END
+    END
+  END PrintTree;
+
+  PROCEDURE PrintObj(obj: LSB.Object; n: INTEGER);
+    VAR apar: LSB.Item; obj1: LSB.Object;
+  BEGIN
+    IF n > 0 THEN Texts.Write(W, 9X) END ;
+    Texts.WriteString(W, C[obj.tag]); Texts.Write(W, " "); Texts.WriteString(W, obj.name); Texts.Append(Oberon.Log, W.buf);
+    IF obj.tag = LSB.const THEN Texts.WriteString(W, " = "); PrintTree(obj.b, 1); Texts.WriteLn(W)
+    ELSIF obj.tag = LSB.typ THEN
+      IF obj.type IS LSB.UnitType THEN  (*formal param list*)
+        obj1 := obj.type(LSB.UnitType).firstobj;
+        Texts.WriteString(W, " BEGIN "); Texts.WriteLn(W);
+        WHILE (obj1 # NIL) & (obj1 # LSB.root) DO PrintObj(obj1, 0); obj1 := obj1.next END ;
+        Texts.WriteString(W, "END"); Texts.WriteLn(W)
+      ELSE PrintType(obj.type)
+      END
+    ELSE (*var*) Texts.WriteString(W, ": ");
+      IF obj.type IS LSB.UnitType THEN
+        Texts.WriteString(W, obj.type.typobj.name);
+        apar := obj.b; Texts.WriteString(W, " [");  (*actual param list*)
+        WHILE apar # NIL DO PrintTree(apar.b, 1); apar := apar.a END ;
+        Texts.Write(W, "]"); Texts.WriteLn(W)
+      ELSE PrintType(obj.type);
+        Texts.WriteString(W, " #"); Texts.WriteInt(W, obj.val, 1);
+        IF obj.a # NIL THEN
+           IF obj.val = 0 THEN Texts.WriteString(W, " CLK") ELSIF obj.val = 1 THEN (*indexed*) Texts.WriteString(W, " DEMUX") END ;
+           PrintTree(obj.a, 1)
+        END ;
+        IF obj.b # NIL THEN Texts.WriteString(W, " := "); Texts.WriteLn(W); PrintTree(obj.b, 1)
+        ELSE Texts.WriteLn(W)
+        END
+      END
+    END ;
+    Texts.Append(Oberon.Log, W.buf)
+  END PrintObj;
+
+  PROCEDURE List*;
+    VAR obj: LSB.Object;
+  BEGIN obj := LSB.top;
+    Texts.WriteString(W, "listing "); Texts.WriteString(W, LSB.modname); Texts.WriteLn(W);
+    WHILE (obj # LSB.root) & (obj # NIL) DO PrintObj(obj, 0); obj := obj.next END ;
+    Texts.Append(Oberon.Log, W.buf)
+  END List;
+
+BEGIN Texts.OpenWriter(W);
+  C[LSB.const] := "CONST"; C[LSB.typ] := "TYPE"; C[LSB.var] := "VAR";
+  C[LSB.lit] := "LIT"; C[LSB.sel] := "MUX"; C[LSB.range] := ": "; C[LSB.cons] := ", "; C[LSB.repl] := "**";
+  C[LSB.or] := "| "; C[LSB.xor] := "^ "; C[LSB.and] := "& ";  C[LSB.not] := "~ ";
+  C[LSB.add] := "+ "; C[LSB.sub] := "- "; C[LSB.mul] := "* "; C[LSB.div] := "/ ";
+  C[LSB.eql] := "= "; C[LSB.neq] := "# "; C[LSB.lss] := "< "; C[LSB.geq] := ">="; C[LSB.leq] := "<="; C[LSB.gtr] := "> ";
+  C[LSB.then] := " -> "; C[LSB.else] := " :: "; C[LSB.ts] := "TS "; C[LSB.next] := "--"
+END LSP.

people.inf.ethz.ch/wirth/Lola/Sources/LSS.Mod.txt

@@ -1,165 +1,165 @@
-MODULE LSS; (* NW 16.10.93 / 13.8.2018*)
-  IMPORT Texts, Oberon;
-  
-  CONST IdLen* = 32; NofKeys = 11;
-    (*symbols*) null = 0;
-    arrow* = 1; times* = 2; div* = 3; and* = 4; plus* = 5; minus* = 6; or* = 7; xor* = 8;  not* = 9;
-    eql* = 10; neq* = 11; lss* = 12; leq* = 13; gtr* = 14; geq* = 15;
-    at* = 16; apo* = 17; period* = 18; comma* = 19; colon* = 20; rparen* = 21; rbrak* = 22; rbrace* = 23; 
-    then* = 24; lparen* = 26; lbrak* = 27; lbrace* = 28; repl* = 29; becomes* = 30;
-    integer* = 31; ident* = 32; ts* = 33; semicolon* = 40; end* = 41;
-    const* = 51; type* = 52; reg* = 53; var* = 54; out* = 55; inout* = 56; in* = 57;
-    begin* = 58; module* = 59; eof = 60;
-
-  TYPE Ident* = ARRAY IdLen OF CHAR;
-
-  VAR val*: LONGINT;
-    id*: Ident;
-    error*: BOOLEAN;
-
-    ch: CHAR;
-    errpos: LONGINT;
-    R: Texts.Reader;
-    W: Texts.Writer;
-    key: ARRAY NofKeys OF Ident;
-    symno: ARRAY NofKeys OF INTEGER;
-
-  PROCEDURE Mark*(msg: ARRAY OF CHAR);
-    VAR p: LONGINT;
-  BEGIN p := Texts.Pos(R);
-    IF p > errpos+2 THEN
-      Texts.WriteString(W, "  pos "); Texts.WriteInt(W, p, 1);
-      Texts.WriteString(W, "  err:  "); Texts.WriteString(W, msg);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END ;
-    errpos := p; error := TRUE
-  END Mark;
-  
-  PROCEDURE identifier(VAR sym: INTEGER);
-    VAR i: INTEGER;
-  BEGIN i := 0;
-    REPEAT
-      IF i < IdLen THEN id[i] := ch; INC(i) END ;
-      Texts.Read(R, ch)
-    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
-    IF ch = "'" THEN
-      IF i < IdLen THEN id[i] := ch; INC(i) END ;
-      Texts.Read(R, ch)
-    END ;
-    IF i = IdLen THEN Mark("ident too long"); id[IdLen-1] := 0X
-    ELSE id[i] := 0X
-    END ;
-    i := 0;
-    WHILE (i < NofKeys) & (id # key[i]) DO INC(i) END ;
-    IF i < NofKeys THEN sym := symno[i] ELSE sym := ident END
-  END identifier;
-
-  PROCEDURE Number(VAR sym: INTEGER);
-    VAR i, k, h, n, d: LONGINT;
-      hex: BOOLEAN;
-      dig: ARRAY 16 OF LONGINT;
-  BEGIN sym := integer; i := 0; k := 0; n := 0; hex := FALSE;
-    REPEAT
-      IF n < 16 THEN d := ORD(ch)-30H;
-        IF d >= 10 THEN hex := TRUE ; d := d - 7 END ;
-        dig[n] := d; INC(n)
-      ELSE Mark("too many digits"); n := 0
-      END ;
-      Texts.Read(R, ch)
-    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F");
-    IF ch = "H" THEN (*hex*)
-      REPEAT h := dig[i]; k := k*10H + h; INC(i) (*no overflow check*)
-      UNTIL i = n;
-      Texts.Read(R, ch)
-    ELSE
-      IF hex THEN Mark("illegal hex digit") END ;
-      REPEAT k := k*10 + dig[i]; INC(i) UNTIL i = n
-    END ;
-    val := k
-  END Number;
-
-  PROCEDURE comment;
-  BEGIN Texts.Read(R, ch);
-    REPEAT
-      WHILE ~R.eot & (ch # "*") DO
-        IF ch = "(" THEN Texts.Read(R, ch);
-          IF ch = "*" THEN comment END
-        ELSE Texts.Read(R, ch)
-        END
-      END ;
-      WHILE ch = "*" DO Texts.Read(R, ch) END
-    UNTIL (ch = ")") OR R.eot;
-    IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("comment not terminated") END
-  END comment;
-
-  PROCEDURE Get*(VAR sym: INTEGER);
-  BEGIN
-    REPEAT
-      WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
-      IF R.eot THEN sym := eof
-      ELSIF ch < "A" THEN 
-        IF ch < "0" THEN
-          IF ch = "!" THEN Texts.Read(R, ch); sym := repl
-          ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
-          ELSIF ch = "$" THEN Texts.Read(R, ch); sym := null
-          ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
-          ELSIF ch = "'" THEN Texts.Read(R, ch); sym := apo
-          ELSIF ch = "(" THEN Texts.Read(R, ch); 
-            IF ch = "*" THEN sym := null; comment ELSE sym := lparen END
-          ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
-          ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times
-          ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
-          ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
-          ELSIF ch = "-" THEN Texts.Read(R, ch);
-            IF ch = ">" THEN Texts.Read(R, ch); sym := then ELSE sym := minus END
-          ELSIF ch = "." THEN Texts.Read(R, ch); sym := period
-          ELSIF ch = "/" THEN Texts.Read(R, ch); sym := div
-          ELSE sym := null
-          END
-        ELSIF ch <= "9" THEN Number(sym)
-        ELSIF ch = ":" THEN Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END
-        ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
-        ELSIF ch = "<" THEN Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
-        ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
-        ELSIF ch = ">" THEN Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
-        ELSIF ch = "?" THEN Texts.Read(R, ch); sym := then
-        ELSIF ch = "@" THEN Texts.Read(R, ch); sym := at
-        ELSE sym := null
-        END
-      ELSIF ch <= "Z" THEN identifier(sym)
-      ELSIF ch < "a" THEN
-        IF ch = "[" THEN Texts.Read(R, ch); sym := lbrak
-        ELSIF ch = "]" THEN Texts.Read(R, ch); sym := rbrak
-        ELSIF ch = "^" THEN Texts.Read(R, ch); sym := xor
-        ELSE sym := null
-        END
-      ELSIF ch <= "z" THEN identifier(sym)
-      ELSIF ch <= "{" THEN Texts.Read(R, ch); sym := lbrace
-      ELSIF ch <= "|" THEN Texts.Read(R, ch); sym := or
-      ELSIF ch <= "}" THEN Texts.Read(R, ch); sym := rbrace
-      ELSIF ch <= "~" THEN Texts.Read(R, ch); sym := not
-      ELSE sym := null
-      END
-    UNTIL sym # null
-  END Get;
-
-  PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
-  BEGIN error := FALSE; errpos := pos; Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
-  END Init;
-  
-BEGIN Texts.OpenWriter(W);
-  key[ 0] := "BEGIN"; symno[0] := begin;
-  key[ 1] := "CONST"; symno[1] := const;
-  key[ 2] := "END"; symno[2] := end;
-  key[3] := "IN"; symno[3] := in;
-  key[4] := "INOUT"; symno[4] := inout;
-  key[5] := "MODULE"; symno[5] := module;
-  key[6] := "OUT"; symno[6] := out;
-  key[7] := "REG"; symno[7] := reg;
-  key[8] := "TYPE"; symno[8] := type;
-  key[9] := "VAR"; symno[9] := var;
-  key[10] := "TS"; symno[10] := ts
-END LSS.
+MODULE LSS; (* NW 16.10.93 / 13.8.2018*)
+  IMPORT Texts, Oberon;
+  
+  CONST IdLen* = 32; NofKeys = 11;
+    (*symbols*) null = 0;
+    arrow* = 1; times* = 2; div* = 3; and* = 4; plus* = 5; minus* = 6; or* = 7; xor* = 8;  not* = 9;
+    eql* = 10; neq* = 11; lss* = 12; leq* = 13; gtr* = 14; geq* = 15;
+    at* = 16; apo* = 17; period* = 18; comma* = 19; colon* = 20; rparen* = 21; rbrak* = 22; rbrace* = 23; 
+    then* = 24; lparen* = 26; lbrak* = 27; lbrace* = 28; repl* = 29; becomes* = 30;
+    integer* = 31; ident* = 32; ts* = 33; semicolon* = 40; end* = 41;
+    const* = 51; type* = 52; reg* = 53; var* = 54; out* = 55; inout* = 56; in* = 57;
+    begin* = 58; module* = 59; eof = 60;
+
+  TYPE Ident* = ARRAY IdLen OF CHAR;
+
+  VAR val*: LONGINT;
+    id*: Ident;
+    error*: BOOLEAN;
+
+    ch: CHAR;
+    errpos: LONGINT;
+    R: Texts.Reader;
+    W: Texts.Writer;
+    key: ARRAY NofKeys OF Ident;
+    symno: ARRAY NofKeys OF INTEGER;
+
+  PROCEDURE Mark*(msg: ARRAY OF CHAR);
+    VAR p: LONGINT;
+  BEGIN p := Texts.Pos(R);
+    IF p > errpos+2 THEN
+      Texts.WriteString(W, "  pos "); Texts.WriteInt(W, p, 1);
+      Texts.WriteString(W, "  err:  "); Texts.WriteString(W, msg);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END ;
+    errpos := p; error := TRUE
+  END Mark;
+  
+  PROCEDURE identifier(VAR sym: INTEGER);
+    VAR i: INTEGER;
+  BEGIN i := 0;
+    REPEAT
+      IF i < IdLen THEN id[i] := ch; INC(i) END ;
+      Texts.Read(R, ch)
+    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
+    IF ch = "'" THEN
+      IF i < IdLen THEN id[i] := ch; INC(i) END ;
+      Texts.Read(R, ch)
+    END ;
+    IF i = IdLen THEN Mark("ident too long"); id[IdLen-1] := 0X
+    ELSE id[i] := 0X
+    END ;
+    i := 0;
+    WHILE (i < NofKeys) & (id # key[i]) DO INC(i) END ;
+    IF i < NofKeys THEN sym := symno[i] ELSE sym := ident END
+  END identifier;
+
+  PROCEDURE Number(VAR sym: INTEGER);
+    VAR i, k, h, n, d: LONGINT;
+      hex: BOOLEAN;
+      dig: ARRAY 16 OF LONGINT;
+  BEGIN sym := integer; i := 0; k := 0; n := 0; hex := FALSE;
+    REPEAT
+      IF n < 16 THEN d := ORD(ch)-30H;
+        IF d >= 10 THEN hex := TRUE ; d := d - 7 END ;
+        dig[n] := d; INC(n)
+      ELSE Mark("too many digits"); n := 0
+      END ;
+      Texts.Read(R, ch)
+    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F");
+    IF ch = "H" THEN (*hex*)
+      REPEAT h := dig[i]; k := k*10H + h; INC(i) (*no overflow check*)
+      UNTIL i = n;
+      Texts.Read(R, ch)
+    ELSE
+      IF hex THEN Mark("illegal hex digit") END ;
+      REPEAT k := k*10 + dig[i]; INC(i) UNTIL i = n
+    END ;
+    val := k
+  END Number;
+
+  PROCEDURE comment;
+  BEGIN Texts.Read(R, ch);
+    REPEAT
+      WHILE ~R.eot & (ch # "*") DO
+        IF ch = "(" THEN Texts.Read(R, ch);
+          IF ch = "*" THEN comment END
+        ELSE Texts.Read(R, ch)
+        END
+      END ;
+      WHILE ch = "*" DO Texts.Read(R, ch) END
+    UNTIL (ch = ")") OR R.eot;
+    IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("comment not terminated") END
+  END comment;
+
+  PROCEDURE Get*(VAR sym: INTEGER);
+  BEGIN
+    REPEAT
+      WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
+      IF R.eot THEN sym := eof
+      ELSIF ch < "A" THEN 
+        IF ch < "0" THEN
+          IF ch = "!" THEN Texts.Read(R, ch); sym := repl
+          ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
+          ELSIF ch = "$" THEN Texts.Read(R, ch); sym := null
+          ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
+          ELSIF ch = "'" THEN Texts.Read(R, ch); sym := apo
+          ELSIF ch = "(" THEN Texts.Read(R, ch); 
+            IF ch = "*" THEN sym := null; comment ELSE sym := lparen END
+          ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
+          ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times
+          ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
+          ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
+          ELSIF ch = "-" THEN Texts.Read(R, ch);
+            IF ch = ">" THEN Texts.Read(R, ch); sym := then ELSE sym := minus END
+          ELSIF ch = "." THEN Texts.Read(R, ch); sym := period
+          ELSIF ch = "/" THEN Texts.Read(R, ch); sym := div
+          ELSE sym := null
+          END
+        ELSIF ch <= "9" THEN Number(sym)
+        ELSIF ch = ":" THEN Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END
+        ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
+        ELSIF ch = "<" THEN Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
+        ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
+        ELSIF ch = ">" THEN Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
+        ELSIF ch = "?" THEN Texts.Read(R, ch); sym := then
+        ELSIF ch = "@" THEN Texts.Read(R, ch); sym := at
+        ELSE sym := null
+        END
+      ELSIF ch <= "Z" THEN identifier(sym)
+      ELSIF ch < "a" THEN
+        IF ch = "[" THEN Texts.Read(R, ch); sym := lbrak
+        ELSIF ch = "]" THEN Texts.Read(R, ch); sym := rbrak
+        ELSIF ch = "^" THEN Texts.Read(R, ch); sym := xor
+        ELSE sym := null
+        END
+      ELSIF ch <= "z" THEN identifier(sym)
+      ELSIF ch <= "{" THEN Texts.Read(R, ch); sym := lbrace
+      ELSIF ch <= "|" THEN Texts.Read(R, ch); sym := or
+      ELSIF ch <= "}" THEN Texts.Read(R, ch); sym := rbrace
+      ELSIF ch <= "~" THEN Texts.Read(R, ch); sym := not
+      ELSE sym := null
+      END
+    UNTIL sym # null
+  END Get;
+
+  PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
+  BEGIN error := FALSE; errpos := pos; Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
+  END Init;
+  
+BEGIN Texts.OpenWriter(W);
+  key[ 0] := "BEGIN"; symno[0] := begin;
+  key[ 1] := "CONST"; symno[1] := const;
+  key[ 2] := "END"; symno[2] := end;
+  key[3] := "IN"; symno[3] := in;
+  key[4] := "INOUT"; symno[4] := inout;
+  key[5] := "MODULE"; symno[5] := module;
+  key[6] := "OUT"; symno[6] := out;
+  key[7] := "REG"; symno[7] := reg;
+  key[8] := "TYPE"; symno[8] := type;
+  key[9] := "VAR"; symno[9] := var;
+  key[10] := "TS"; symno[10] := ts
+END LSS.

people.inf.ethz.ch/wirth/Lola/Sources/LSV.Mod.txt

@@ -1,233 +1,233 @@
-MODULE LSV;  (*Lola System: display Verilog; generate txt-File; NW 27.8.2018*)
-  IMPORT Files, Texts, Oberon, LSB;
-
-  VAR W: Texts.Writer;
-    nofgen: INTEGER;
-    Constructor: PROCEDURE (VAR x: LSB.Item);   (*to avoid forward reference*)
-    F: Files.File; R: Files.Rider;
-    C: ARRAY 64, 6 OF CHAR;
-
-  PROCEDURE Write(ch: CHAR);
-  BEGIN Files.Write(R, ch)
-  END Write;
-
-  PROCEDURE WriteLn;
-  BEGIN Files.Write(R, 0DX); Files.Write(R, 0AX)
-  END WriteLn;
-
-  PROCEDURE WriteInt(x: LONGINT);  (* x >= 0 *)
-    VAR i: INTEGER; d: ARRAY 14 OF LONGINT;
-  BEGIN i := 0;
-    IF x < 0 THEN Files.Write(R, "-"); x := -x END ;
-    REPEAT d[i] := x MOD 10; x := x DIV 10; INC(i) UNTIL x = 0;
-    REPEAT DEC(i); Files.Write(R, CHR(d[i] + 30H)) UNTIL i = 0
-  END WriteInt;
-
-  PROCEDURE WriteHex(x: LONGINT);  (*x >= 0*)
-    VAR i: INTEGER; d: ARRAY 8 OF LONGINT;
-  BEGIN i := 0;
-    REPEAT d[i] := x MOD 10H; x := x DIV 10H; INC(i) UNTIL (x = 0) OR (i = 8);
-    REPEAT DEC(i);
-      IF d[i] >= 10 THEN Files.Write(R, CHR(d[i] + 37H)) ELSE Files.Write(R, CHR(d[i] + 30H)) END
-    UNTIL i = 0
-  END WriteHex;
-
-  PROCEDURE WriteString(s: ARRAY OF CHAR);
-    VAR i: INTEGER;
-  BEGIN i := 0;
-    WHILE s[i] # 0X DO Files.Write(R, s[i]); INC(i) END
-  END WriteString;
-
-  (* ------------------------------- *)
-
-  PROCEDURE Type(typ: LSB.Type);
-    VAR obj: LSB.Object;
-  BEGIN
-    IF typ IS LSB.ArrayType THEN
-      IF typ(LSB.ArrayType).eltyp # LSB.bitType THEN
-        Write("["); WriteInt(typ.len - 1); WriteString(":0]"); Type(typ(LSB.ArrayType).eltyp)
-      END
-    ELSIF typ IS LSB.UnitType THEN (* obj := typ(LSB.UnitType).firstobj; *)
-    END
-  END Type;
-
-  PROCEDURE BitArrLen(typ: LSB.Type);
-    VAR eltyp: LSB.Type;
-  BEGIN
-    IF typ IS LSB.ArrayType THEN
-      eltyp := typ(LSB.ArrayType).eltyp;
-      WHILE eltyp IS LSB.ArrayType DO typ := eltyp; eltyp := typ(LSB.ArrayType).eltyp END ;
-      IF eltyp = LSB.bitType THEN
-        Write("["); WriteInt(typ.len - 1);WriteString(":0] ")
-      END
-    END
-  END BitArrLen;
-
-  PROCEDURE Expression(x: LSB.Item);
-    VAR z: LSB.Item;
-  BEGIN
-    IF x # NIL THEN
-      IF x IS LSB.Object THEN WriteString(x(LSB.Object).name)
-      ELSIF x.tag = LSB.cons THEN
-        Write("{"); Constructor(x); Write("}")
-      ELSE
-        IF x.tag = LSB.repl THEN
-          Write("{"); WriteInt(x.b.val); Write("{"); Expression(x.a);
-          Write("}"); Write("}")
-        ELSE
-          IF (x.tag >= LSB.and) & (x.tag <= LSB.then) THEN Write("(") END ;
-          Expression(x.a);
-          IF x.tag = LSB.sel THEN Write("["); Expression(x.b); Write("]")
-          ELSIF x.tag = LSB.lit THEN
-            IF x.size # 0 THEN WriteInt(x.size); Write("'"); Write("h"); WriteHex(x.val)
-            ELSE WriteInt(x.val)
-            END
-          ELSE WriteString(C[x.tag]); Expression(x.b)
-          END ;
-          IF (x.tag >= LSB.and) & (x.tag <= LSB.then) THEN Write(")") END
-        END
-      END
-    END
-  END Expression;
-
-  PROCEDURE Elem(VAR x: LSB.Item);
-  BEGIN
-    IF x.tag = LSB.repl THEN
-      Write("{"); WriteInt(x.b.val); Write("{"); Expression(x.a);  WriteString("}}")
-    ELSE Expression(x)
-    END
-  END Elem;
-
-  PROCEDURE Constructor0(VAR x: LSB.Item);
-  BEGIN
-    IF x.tag = LSB.cons THEN Constructor(x.a); WriteString(", "); Elem(x.b) ELSE Elem(x) END
-  END Constructor0;
-
-  PROCEDURE Declaration(obj: LSB.Object);
-    VAR apar: LSB.Item; typ: LSB.Type;
-  BEGIN typ := obj.type;
-    IF obj.type IS LSB.UnitType THEN WriteString("unit ") ELSE Type(obj.type) END ;
-    IF obj.tag = LSB.var THEN
-      IF obj.type IS LSB.UnitType THEN
-        apar := obj.a; WriteLn; Write("[");
-        WHILE apar # NIL DO Expression(apar.b); apar := apar.a END ;
-        Write("]")
-      END
-    ELSIF obj.tag = LSB.const THEN WriteString(" = "); WriteInt(obj.val)
-    END
-  END Declaration;
-
-  PROCEDURE ObjList0(obj: LSB.Object);  (*declarations*)
-    VAR obj1: LSB.Object; param: BOOLEAN;
-  BEGIN param := TRUE;
-    WHILE obj # LSB.root DO
-      IF (obj.tag = LSB.var) & ~(obj.type IS LSB.UnitType) THEN
-        IF obj.val = 0 THEN WriteString("reg ")
-        ELSIF obj.val = 2 THEN WriteString("wire ")
-        ELSIF obj.val = 3 THEN WriteString("output ")
-        ELSIF obj.val = 5 THEN WriteString("inout ")
-        ELSIF obj.val = 6 THEN WriteString("input ")
-        ELSE WriteString("??? ")
-        END ;
-        BitArrLen(obj.type); WriteString(obj.name);
-        obj1 := obj.next;
-        WHILE (obj1 # LSB.root) & (obj1.type = obj.type) & (obj1.val = obj.val) DO
-          WriteString(", "); obj := obj1; WriteString(obj.name); obj1 := obj.next
-        END ;
-        IF param & (obj.val >= 3) & (obj1.val < 3) THEN  (*end param list*) param := FALSE; Write(")")
-        END ;
-        IF (obj.type # LSB.bitType) & (obj.type(LSB.ArrayType).eltyp # LSB.bitType) THEN Type(obj.type) END ;
-        IF param THEN Write(",") ELSE Write(";") END ;
-        WriteLn
-      ELSIF obj.tag = LSB.const THEN
-      END ;
-      obj := obj.next
-    END
-  END ObjList0;
-
-  PROCEDURE ActParam(VAR x: LSB.Item; fpar: LSB.Object);
-  BEGIN Write("."); WriteString(fpar.name); Write("("); Expression(x); Write(")")
-  END ActParam;
-
-  PROCEDURE ObjList1(obj: LSB.Object);  (*assignments to variables*)
-    VAR apar, x: LSB.Item; fpar: LSB.Object; size: LONGINT;
-  BEGIN
-    WHILE obj # LSB.root DO
-      IF (obj.tag = LSB.var) OR (obj.tag = LSB.const) THEN
-        IF obj.type IS LSB.UnitType THEN
-          WriteString(obj.type.typobj.name); Write(" "); WriteString(obj.name);
-          apar := obj.b; fpar := obj.type(LSB.UnitType).firstobj;
-          Write("("); ActParam(apar.b, fpar); apar := apar.a; fpar := fpar.next;  (*actual param list*)
-          WHILE apar # NIL DO WriteString(", "); ActParam(apar.b, fpar); apar := apar.a; fpar := fpar.next END ;
-          Write(")"); Write(";"); WriteLn
-        ELSIF (obj.b # NIL) & (obj.val = 5) THEN  (*tri-state*)
-          size := obj.type.size; x := obj.b;
-        IF x.tag = LSB.ts THEN
-            IF obj.type = LSB.bitType THEN
-              WriteString("IOBUF block"); INC(nofgen); WriteInt(nofgen); WriteString(" (.IO("); WriteString(obj.name);
-              WriteString("), .O("); WriteString(x.a(LSB.Object).name); WriteString("), .I("); x := x.b; 
-              IF x.a.type = LSB.bitType THEN Expression(x.a) ELSE WriteString(x.a(LSB.Object).name) END ;
-              WriteString("), .T(");
-              IF x.b.type = LSB.bitType THEN Expression(x.b) ELSE  WriteString(x.b(LSB.Object).name) END ;
-              WriteString("));")
-            ELSE  (*array type*)
-              IF nofgen = 0 THEN WriteString("genvar i;"); WriteLn END ;
-              INC(nofgen); WriteString("generate"); WriteLn;
-              WriteString("for (i = 0; i < "); WriteInt(size); WriteString("; i = i+1) begin : bufblock"); WriteInt(nofgen); WriteLn;
-              WriteString("IOBUF block (.IO("); WriteString(obj.name);
-              WriteString("[i]), .O("); WriteString(x.a(LSB.Object).name); WriteString("[i]), .I("); x := x.b;
-              WriteString(x.a(LSB.Object).name); WriteString("[i]), .T(");
-              IF x.b.type = LSB.bitType THEN Expression(x.b) ELSE WriteString(x.b(LSB.Object).name); WriteString("[i]") END ;
-              WriteString("));"); WriteLn; WriteString("end"); WriteLn; WriteString("endgenerate")
-            END ;
-            WriteLn
-          END
-        ELSIF (obj.b # NIL) & (obj.val >= 2) THEN
-          WriteString("assign "); WriteString(obj.name);
-          IF (obj.a # NIL) THEN Write("["); Expression(obj.a); Write("]") END ;
-          WriteString(" = "); Expression(obj.b); Write(";"); WriteLn
-        END
-      ELSIF obj.tag = LSB.typ THEN (*instantiation; actual parameters*)
-      END ;
-      obj := obj.next
-    END
-  END ObjList1;
-
-  PROCEDURE ObjList2(obj: LSB.Object);  (*assignments to registers*)
-    VAR clk: LSB.Item;
-  BEGIN
-    WHILE obj # LSB.root DO
-      IF (obj.tag = LSB.var) & ~(obj.type IS LSB.UnitType) & (obj.val = 0) THEN
-        WriteString("always @ (posedge "); clk := obj.a; Expression(clk);
-        WriteString(") begin ");
-        REPEAT WriteString(obj.name);
-          WriteString(" <= "); Expression(obj.b); Write(";"); WriteLn; obj := obj.next
-        UNTIL (obj = LSB.top) OR (obj.a # clk);
-        WriteString("end"); WriteLn
-      ELSE obj := obj.next
-      END
-    END
-  END ObjList2;
-
-  PROCEDURE List*;
-    VAR S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF (S.class = Texts.Name) OR (S.class = Texts.String) THEN
-      Texts.WriteString(W, LSB.modname); Texts.WriteString(W, " translating to  "); Texts.WriteString(W, S.s);
-      F := Files.New(S.s); Files.Set(R, F, 0);
-      WriteString("`timescale 1ns / 1 ps"); WriteLn; nofgen := 0;
-      WriteString("module "); WriteString(LSB.modname); WriteString("(   // translated from Lola"); WriteLn;
-      ObjList0(LSB.top); ObjList1(LSB.top); ObjList2(LSB.top);
-      WriteString("endmodule"); WriteLn;
-      Files.Register(F); Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END List;
-
-BEGIN Texts.OpenWriter(W); Constructor := Constructor0;
-  C[LSB.const] := "CONST"; C[LSB.typ] := "TYPE"; C[LSB.var] := "VAR";
-  C[LSB.lit] := "LIT"; C[LSB.sel] := "SEL"; C[LSB.range] := ":"; C[LSB.cons] := ",";
-  C[LSB.or] := " | "; C[LSB.xor] := " ^ "; C[LSB.and] := " & ";  C[LSB.not] := "~";
-  C[LSB.add] := " + "; C[LSB.sub] := " - "; C[LSB.mul] := " * "; C[LSB.div] := " / ";
-  C[LSB.eql] := " == "; C[LSB.neq] := " != "; C[LSB.lss] := " <  "; C[LSB.geq] := " >= "; C[LSB.leq] := " <= "; C[LSB.gtr] := " >  ";
-  C[LSB.then] := " ? "; C[LSB.else] := " : "; C[LSB.ts] := "TS"; C[LSB.next] := "--"
-END LSV.
+MODULE LSV;  (*Lola System: display Verilog; generate txt-File; NW 27.8.2018*)
+  IMPORT Files, Texts, Oberon, LSB;
+
+  VAR W: Texts.Writer;
+    nofgen: INTEGER;
+    Constructor: PROCEDURE (VAR x: LSB.Item);   (*to avoid forward reference*)
+    F: Files.File; R: Files.Rider;
+    C: ARRAY 64, 6 OF CHAR;
+
+  PROCEDURE Write(ch: CHAR);
+  BEGIN Files.Write(R, ch)
+  END Write;
+
+  PROCEDURE WriteLn;
+  BEGIN Files.Write(R, 0DX); Files.Write(R, 0AX)
+  END WriteLn;
+
+  PROCEDURE WriteInt(x: LONGINT);  (* x >= 0 *)
+    VAR i: INTEGER; d: ARRAY 14 OF LONGINT;
+  BEGIN i := 0;
+    IF x < 0 THEN Files.Write(R, "-"); x := -x END ;
+    REPEAT d[i] := x MOD 10; x := x DIV 10; INC(i) UNTIL x = 0;
+    REPEAT DEC(i); Files.Write(R, CHR(d[i] + 30H)) UNTIL i = 0
+  END WriteInt;
+
+  PROCEDURE WriteHex(x: LONGINT);  (*x >= 0*)
+    VAR i: INTEGER; d: ARRAY 8 OF LONGINT;
+  BEGIN i := 0;
+    REPEAT d[i] := x MOD 10H; x := x DIV 10H; INC(i) UNTIL (x = 0) OR (i = 8);
+    REPEAT DEC(i);
+      IF d[i] >= 10 THEN Files.Write(R, CHR(d[i] + 37H)) ELSE Files.Write(R, CHR(d[i] + 30H)) END
+    UNTIL i = 0
+  END WriteHex;
+
+  PROCEDURE WriteString(s: ARRAY OF CHAR);
+    VAR i: INTEGER;
+  BEGIN i := 0;
+    WHILE s[i] # 0X DO Files.Write(R, s[i]); INC(i) END
+  END WriteString;
+
+  (* ------------------------------- *)
+
+  PROCEDURE Type(typ: LSB.Type);
+    VAR obj: LSB.Object;
+  BEGIN
+    IF typ IS LSB.ArrayType THEN
+      IF typ(LSB.ArrayType).eltyp # LSB.bitType THEN
+        Write("["); WriteInt(typ.len - 1); WriteString(":0]"); Type(typ(LSB.ArrayType).eltyp)
+      END
+    ELSIF typ IS LSB.UnitType THEN (* obj := typ(LSB.UnitType).firstobj; *)
+    END
+  END Type;
+
+  PROCEDURE BitArrLen(typ: LSB.Type);
+    VAR eltyp: LSB.Type;
+  BEGIN
+    IF typ IS LSB.ArrayType THEN
+      eltyp := typ(LSB.ArrayType).eltyp;
+      WHILE eltyp IS LSB.ArrayType DO typ := eltyp; eltyp := typ(LSB.ArrayType).eltyp END ;
+      IF eltyp = LSB.bitType THEN
+        Write("["); WriteInt(typ.len - 1);WriteString(":0] ")
+      END
+    END
+  END BitArrLen;
+
+  PROCEDURE Expression(x: LSB.Item);
+    VAR z: LSB.Item;
+  BEGIN
+    IF x # NIL THEN
+      IF x IS LSB.Object THEN WriteString(x(LSB.Object).name)
+      ELSIF x.tag = LSB.cons THEN
+        Write("{"); Constructor(x); Write("}")
+      ELSE
+        IF x.tag = LSB.repl THEN
+          Write("{"); WriteInt(x.b.val); Write("{"); Expression(x.a);
+          Write("}"); Write("}")
+        ELSE
+          IF (x.tag >= LSB.and) & (x.tag <= LSB.then) THEN Write("(") END ;
+          Expression(x.a);
+          IF x.tag = LSB.sel THEN Write("["); Expression(x.b); Write("]")
+          ELSIF x.tag = LSB.lit THEN
+            IF x.size # 0 THEN WriteInt(x.size); Write("'"); Write("h"); WriteHex(x.val)
+            ELSE WriteInt(x.val)
+            END
+          ELSE WriteString(C[x.tag]); Expression(x.b)
+          END ;
+          IF (x.tag >= LSB.and) & (x.tag <= LSB.then) THEN Write(")") END
+        END
+      END
+    END
+  END Expression;
+
+  PROCEDURE Elem(VAR x: LSB.Item);
+  BEGIN
+    IF x.tag = LSB.repl THEN
+      Write("{"); WriteInt(x.b.val); Write("{"); Expression(x.a);  WriteString("}}")
+    ELSE Expression(x)
+    END
+  END Elem;
+
+  PROCEDURE Constructor0(VAR x: LSB.Item);
+  BEGIN
+    IF x.tag = LSB.cons THEN Constructor(x.a); WriteString(", "); Elem(x.b) ELSE Elem(x) END
+  END Constructor0;
+
+  PROCEDURE Declaration(obj: LSB.Object);
+    VAR apar: LSB.Item; typ: LSB.Type;
+  BEGIN typ := obj.type;
+    IF obj.type IS LSB.UnitType THEN WriteString("unit ") ELSE Type(obj.type) END ;
+    IF obj.tag = LSB.var THEN
+      IF obj.type IS LSB.UnitType THEN
+        apar := obj.a; WriteLn; Write("[");
+        WHILE apar # NIL DO Expression(apar.b); apar := apar.a END ;
+        Write("]")
+      END
+    ELSIF obj.tag = LSB.const THEN WriteString(" = "); WriteInt(obj.val)
+    END
+  END Declaration;
+
+  PROCEDURE ObjList0(obj: LSB.Object);  (*declarations*)
+    VAR obj1: LSB.Object; param: BOOLEAN;
+  BEGIN param := TRUE;
+    WHILE obj # LSB.root DO
+      IF (obj.tag = LSB.var) & ~(obj.type IS LSB.UnitType) THEN
+        IF obj.val = 0 THEN WriteString("reg ")
+        ELSIF obj.val = 2 THEN WriteString("wire ")
+        ELSIF obj.val = 3 THEN WriteString("output ")
+        ELSIF obj.val = 5 THEN WriteString("inout ")
+        ELSIF obj.val = 6 THEN WriteString("input ")
+        ELSE WriteString("??? ")
+        END ;
+        BitArrLen(obj.type); WriteString(obj.name);
+        obj1 := obj.next;
+        WHILE (obj1 # LSB.root) & (obj1.type = obj.type) & (obj1.val = obj.val) DO
+          WriteString(", "); obj := obj1; WriteString(obj.name); obj1 := obj.next
+        END ;
+        IF param & (obj.val >= 3) & (obj1.val < 3) THEN  (*end param list*) param := FALSE; Write(")")
+        END ;
+        IF (obj.type # LSB.bitType) & (obj.type(LSB.ArrayType).eltyp # LSB.bitType) THEN Type(obj.type) END ;
+        IF param THEN Write(",") ELSE Write(";") END ;
+        WriteLn
+      ELSIF obj.tag = LSB.const THEN
+      END ;
+      obj := obj.next
+    END
+  END ObjList0;
+
+  PROCEDURE ActParam(VAR x: LSB.Item; fpar: LSB.Object);
+  BEGIN Write("."); WriteString(fpar.name); Write("("); Expression(x); Write(")")
+  END ActParam;
+
+  PROCEDURE ObjList1(obj: LSB.Object);  (*assignments to variables*)
+    VAR apar, x: LSB.Item; fpar: LSB.Object; size: LONGINT;
+  BEGIN
+    WHILE obj # LSB.root DO
+      IF (obj.tag = LSB.var) OR (obj.tag = LSB.const) THEN
+        IF obj.type IS LSB.UnitType THEN
+          WriteString(obj.type.typobj.name); Write(" "); WriteString(obj.name);
+          apar := obj.b; fpar := obj.type(LSB.UnitType).firstobj;
+          Write("("); ActParam(apar.b, fpar); apar := apar.a; fpar := fpar.next;  (*actual param list*)
+          WHILE apar # NIL DO WriteString(", "); ActParam(apar.b, fpar); apar := apar.a; fpar := fpar.next END ;
+          Write(")"); Write(";"); WriteLn
+        ELSIF (obj.b # NIL) & (obj.val = 5) THEN  (*tri-state*)
+          size := obj.type.size; x := obj.b;
+        IF x.tag = LSB.ts THEN
+            IF obj.type = LSB.bitType THEN
+              WriteString("IOBUF block"); INC(nofgen); WriteInt(nofgen); WriteString(" (.IO("); WriteString(obj.name);
+              WriteString("), .O("); WriteString(x.a(LSB.Object).name); WriteString("), .I("); x := x.b; 
+              IF x.a.type = LSB.bitType THEN Expression(x.a) ELSE WriteString(x.a(LSB.Object).name) END ;
+              WriteString("), .T(");
+              IF x.b.type = LSB.bitType THEN Expression(x.b) ELSE  WriteString(x.b(LSB.Object).name) END ;
+              WriteString("));")
+            ELSE  (*array type*)
+              IF nofgen = 0 THEN WriteString("genvar i;"); WriteLn END ;
+              INC(nofgen); WriteString("generate"); WriteLn;
+              WriteString("for (i = 0; i < "); WriteInt(size); WriteString("; i = i+1) begin : bufblock"); WriteInt(nofgen); WriteLn;
+              WriteString("IOBUF block (.IO("); WriteString(obj.name);
+              WriteString("[i]), .O("); WriteString(x.a(LSB.Object).name); WriteString("[i]), .I("); x := x.b;
+              WriteString(x.a(LSB.Object).name); WriteString("[i]), .T(");
+              IF x.b.type = LSB.bitType THEN Expression(x.b) ELSE WriteString(x.b(LSB.Object).name); WriteString("[i]") END ;
+              WriteString("));"); WriteLn; WriteString("end"); WriteLn; WriteString("endgenerate")
+            END ;
+            WriteLn
+          END
+        ELSIF (obj.b # NIL) & (obj.val >= 2) THEN
+          WriteString("assign "); WriteString(obj.name);
+          IF (obj.a # NIL) THEN Write("["); Expression(obj.a); Write("]") END ;
+          WriteString(" = "); Expression(obj.b); Write(";"); WriteLn
+        END
+      ELSIF obj.tag = LSB.typ THEN (*instantiation; actual parameters*)
+      END ;
+      obj := obj.next
+    END
+  END ObjList1;
+
+  PROCEDURE ObjList2(obj: LSB.Object);  (*assignments to registers*)
+    VAR clk: LSB.Item;
+  BEGIN
+    WHILE obj # LSB.root DO
+      IF (obj.tag = LSB.var) & ~(obj.type IS LSB.UnitType) & (obj.val = 0) THEN
+        WriteString("always @ (posedge "); clk := obj.a; Expression(clk);
+        WriteString(") begin ");
+        REPEAT WriteString(obj.name);
+          WriteString(" <= "); Expression(obj.b); Write(";"); WriteLn; obj := obj.next
+        UNTIL (obj = LSB.top) OR (obj.a # clk);
+        WriteString("end"); WriteLn
+      ELSE obj := obj.next
+      END
+    END
+  END ObjList2;
+
+  PROCEDURE List*;
+    VAR S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF (S.class = Texts.Name) OR (S.class = Texts.String) THEN
+      Texts.WriteString(W, LSB.modname); Texts.WriteString(W, " translating to  "); Texts.WriteString(W, S.s);
+      F := Files.New(S.s); Files.Set(R, F, 0);
+      WriteString("`timescale 1ns / 1 ps"); WriteLn; nofgen := 0;
+      WriteString("module "); WriteString(LSB.modname); WriteString("(   // translated from Lola"); WriteLn;
+      ObjList0(LSB.top); ObjList1(LSB.top); ObjList2(LSB.top);
+      WriteString("endmodule"); WriteLn;
+      Files.Register(F); Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END List;
+
+BEGIN Texts.OpenWriter(W); Constructor := Constructor0;
+  C[LSB.const] := "CONST"; C[LSB.typ] := "TYPE"; C[LSB.var] := "VAR";
+  C[LSB.lit] := "LIT"; C[LSB.sel] := "SEL"; C[LSB.range] := ":"; C[LSB.cons] := ",";
+  C[LSB.or] := " | "; C[LSB.xor] := " ^ "; C[LSB.and] := " & ";  C[LSB.not] := "~";
+  C[LSB.add] := " + "; C[LSB.sub] := " - "; C[LSB.mul] := " * "; C[LSB.div] := " / ";
+  C[LSB.eql] := " == "; C[LSB.neq] := " != "; C[LSB.lss] := " <  "; C[LSB.geq] := " >= "; C[LSB.leq] := " <= "; C[LSB.gtr] := " >  ";
+  C[LSB.then] := " ? "; C[LSB.else] := " : "; C[LSB.ts] := "TS"; C[LSB.next] := "--"
+END LSV.

people.inf.ethz.ch/wirth/Lola/Sources/LeftShifter.Lola.txt

@@ -1,17 +1,17 @@
-MODULE LeftShifter(    (*NW 10.11.2016*)
-  IN x: WORD; sc: [5] BIT;
-  OUT y: WORD);
-
-  VAR sc0, sc1: [2] BIT;
-    t1, t2: WORD;
-
-BEGIN sc0 := sc[1:0]; sc1 := sc[3:2];
-  t1 := (sc0 = 3) -> {x[28:0], 0'3} :
-      (sc0 = 2) -> {x[29:0], 0'2} :
-      (sc0 = 1) -> {x[30:0], 0'1} : x;
-  t2 := (sc1 = 3) -> {t1[19:0], 0'12} :
-      (sc1 = 2) -> {t1[23:0], 0'8} :
-      (sc1 = 1) -> {t1[27:0], 0'4} : t1;
-  y := sc.4 -> {t2[15:0], 0'16} : t2
-END LeftShifter.
-
+MODULE LeftShifter(    (*NW 10.11.2016*)
+  IN x: WORD; sc: [5] BIT;
+  OUT y: WORD);
+
+  VAR sc0, sc1: [2] BIT;
+    t1, t2: WORD;
+
+BEGIN sc0 := sc[1:0]; sc1 := sc[3:2];
+  t1 := (sc0 = 3) -> {x[28:0], 0'3} :
+      (sc0 = 2) -> {x[29:0], 0'2} :
+      (sc0 = 1) -> {x[30:0], 0'1} : x;
+  t2 := (sc1 = 3) -> {t1[19:0], 0'12} :
+      (sc1 = 2) -> {t1[23:0], 0'8} :
+      (sc1 = 1) -> {t1[27:0], 0'4} : t1;
+  y := sc.4 -> {t2[15:0], 0'16} : t2
+END LeftShifter.
+

people.inf.ethz.ch/wirth/Lola/Sources/MouseP.Lola.txt

@@ -1,93 +1,93 @@
-MODULE MouseP (   (*NW 7.9.2015*)
-  IN clk, rst: BIT;
-  INOUT msclk, msdat: BIT;
-  OUT out: [28] BIT);
-  (* init mouse cmd F4 (start reporting) with start, parity and stop bits added *)
-  CONST InitBuf = 0FFFFFDE8H;  (* 1...1 1 0 1111 0100 0 *)
-  REG (clk) x, y: [10] BIT;   (*counters*)
-    btns: [3] BIT;
-    Q0, Q1, run: BIT;
-    shreg: [32] BIT;
-  VAR shift, endbit, reply: BIT;
-    dx, dy: [10] BIT;
-    msclk0, msdat0: BIT;
-BEGIN TS(msclk, msclk0, 0'1, rst);
-  TS(msdat, msdat0, 0'1, run | shreg.0);
-  shift := Q1 & ~Q0;   (*falling edge detector*)
-  reply := ~run & ~shreg.1;   (*start bit of echoed initBuf, if response*)
-  endbit := run & ~shreg.0;   (*normal packet received*)
-  dx := {shreg.5 !2, shreg.7 -> 0'8 : shreg[19:12]};   (*sign + ovfl*)
-  dy := {shreg.6 !2, shreg.8 -> 0'8 : shreg[30:23]};   (*sign + ovfl*)
-  out := {run, btns, 0'2, y, 0'2, x};
-  
-  run := rst & (reply | run);
-  Q0 := msclk0; Q1 := Q0;  (*edhe detector*)
-  shreg := ~rst -> 0FFFFFDE8H:
-    (endbit | reply) -> 0FFFFFFFFH'32:
-    shift -> {msdat0, shreg[31:1]} : shreg;
-  x := ~rst -> 0'10 : endbit -> x + dx : x;
-  y := ~rst -> 0'10 : endbit -> y + dy : y;
-  btns := ~rst -> 0'3 : endbit -> {shreg.1, shreg.3, shreg.2} : btns
-END MouseP.
-
-MODULE MouseP (
-  IN clk, rst, msdat: BIT;
-  INOUT msclk: BIT;
-  OUT out: [28] BIT);
-
-  CONST InitBuf := 0; (*0FFFFFBE8H;  hex*)
-  TYPE IOBUF = MODULE (IN I: BIT; OUT O: BIT; INOUT IO: BIT; IN T: BIT) ^;
-  REG x, y: [10] BIT;   (*counters*)
-    btns: [3] BIT;
-    Q0, Q1, run: BIT;
-    shreg: [32] BIT;
-    iobuf: IOBUF;
-  VAR shift, endbit, reply, q: BIT;
-    dx, dy: [10] BIT;
-BEGIN iobuf (0, q msclk, rst);
-  shift := Q1 & ~Q0;   (*falling edge detector*)
-  reply := ~run & ~shreg.11;   (*start bit of echoed initBuf, if response*)
-  endbit := run & ~shreg.0;   (*normal packet received*)
-  dx := {shreg.5 !2, shreg.7 -> 0'8 : shreg[19:12]};   (*sign + ovfl*)
-  dy := {shreg.6 !2, shreg.8 -> 0'8 : shreg[30:23]};   (*sign + ovfl*)
-  out := {run, btns, 0'2, y, 0'2, x};
-
-  run := rst & (reply | run);
-  Q0 := q; Q1 := Q0;
-  shreg := ~rst -> InitBuf : (endbit | reply) -> 0FFFFFFFFH'32: shift -> {msdat, shreg[31:1]} : shreg;
-  x := ~rst -> 0'10 : endbit -> x + dx : x;
-  y := ~rst -> 0'10 : endbit -> y + dy : y;
-  btns := ~rst -> 0'3 : endbit -> {shreg.1, shreg.3, shreg.2} : btns
-END MouseP.
-
-MODULE MouseP (
-  IN clk, rst: BIT;
-  INOUT io: [2] BIT;
-  OUT out: [28] BIT);
-
-  (* init mouse cmd F4 (start reporting) with start, parity and stop bits added *)
-  CONST InitBuf := 0FFFFFDE8H;  (* 1...1 1 0 1111 0100 0 *)
-  TYPE PS2BUF = MODULE (OUT O: [2] BIT; INOUT IO: [2] BIT; IN T: [2] BIT) ^;
-  REG x, y: [10] BIT;   (*counters*)
-    btns: [3] BIT;
-    Q0, Q1, run: BIT;
-    shreg: [32] BIT;
-  VAR shift, endbit, reply: BIT;
-    dx, dy: [10] BIT;
-    in: [2] BIT;
-    ps2buf: PS2BUF;
-BEGIN ps2buf(in, io, {run | shreg[0], rst});  (*open-collector wiring*)
-  shift := Q1 & ~Q0;   (*falling edge detector*)
-  reply := ~run & ~shreg.11;   (*start bit of echoed initBuf, if response*)
-  endbit := run & ~shreg.0;   (*normal packet received*)
-  dx := {shreg.5 !2, shreg.7 -> 0'8 : shreg[19:12]};   (*sign + ovfl*)
-  dy := {shreg.6 !2, shreg.8 -> 0'8 : shreg[30:23]};   (*sign + ovfl*)
-  out := {run, btns, 0'2, y, 0'2, x};
-
-  run := rst & (reply | run);
-  Q0 := in[0]; Q1 := Q0;
-  shreg := ~rst -> InitBuf : (endbit | reply) -> 0FFFFFFFFH'32: shift -> {in[1], shreg[31:1]} : shreg;
-  x := ~rst -> 0'10 : endbit -> x + dx : x;
-  y := ~rst -> 0'10 : endbit -> y + dy : y;
-  btns := ~rst -> 0'3 : endbit -> {shreg.1, shreg.3, shreg.2} : btns
-END MouseP.
+MODULE MouseP (   (*NW 7.9.2015*)
+  IN clk, rst: BIT;
+  INOUT msclk, msdat: BIT;
+  OUT out: [28] BIT);
+  (* init mouse cmd F4 (start reporting) with start, parity and stop bits added *)
+  CONST InitBuf = 0FFFFFDE8H;  (* 1...1 1 0 1111 0100 0 *)
+  REG (clk) x, y: [10] BIT;   (*counters*)
+    btns: [3] BIT;
+    Q0, Q1, run: BIT;
+    shreg: [32] BIT;
+  VAR shift, endbit, reply: BIT;
+    dx, dy: [10] BIT;
+    msclk0, msdat0: BIT;
+BEGIN TS(msclk, msclk0, 0'1, rst);
+  TS(msdat, msdat0, 0'1, run | shreg.0);
+  shift := Q1 & ~Q0;   (*falling edge detector*)
+  reply := ~run & ~shreg.1;   (*start bit of echoed initBuf, if response*)
+  endbit := run & ~shreg.0;   (*normal packet received*)
+  dx := {shreg.5 !2, shreg.7 -> 0'8 : shreg[19:12]};   (*sign + ovfl*)
+  dy := {shreg.6 !2, shreg.8 -> 0'8 : shreg[30:23]};   (*sign + ovfl*)
+  out := {run, btns, 0'2, y, 0'2, x};
+  
+  run := rst & (reply | run);
+  Q0 := msclk0; Q1 := Q0;  (*edhe detector*)
+  shreg := ~rst -> 0FFFFFDE8H:
+    (endbit | reply) -> 0FFFFFFFFH'32:
+    shift -> {msdat0, shreg[31:1]} : shreg;
+  x := ~rst -> 0'10 : endbit -> x + dx : x;
+  y := ~rst -> 0'10 : endbit -> y + dy : y;
+  btns := ~rst -> 0'3 : endbit -> {shreg.1, shreg.3, shreg.2} : btns
+END MouseP.
+
+MODULE MouseP (
+  IN clk, rst, msdat: BIT;
+  INOUT msclk: BIT;
+  OUT out: [28] BIT);
+
+  CONST InitBuf := 0; (*0FFFFFBE8H;  hex*)
+  TYPE IOBUF = MODULE (IN I: BIT; OUT O: BIT; INOUT IO: BIT; IN T: BIT) ^;
+  REG x, y: [10] BIT;   (*counters*)
+    btns: [3] BIT;
+    Q0, Q1, run: BIT;
+    shreg: [32] BIT;
+    iobuf: IOBUF;
+  VAR shift, endbit, reply, q: BIT;
+    dx, dy: [10] BIT;
+BEGIN iobuf (0, q msclk, rst);
+  shift := Q1 & ~Q0;   (*falling edge detector*)
+  reply := ~run & ~shreg.11;   (*start bit of echoed initBuf, if response*)
+  endbit := run & ~shreg.0;   (*normal packet received*)
+  dx := {shreg.5 !2, shreg.7 -> 0'8 : shreg[19:12]};   (*sign + ovfl*)
+  dy := {shreg.6 !2, shreg.8 -> 0'8 : shreg[30:23]};   (*sign + ovfl*)
+  out := {run, btns, 0'2, y, 0'2, x};
+
+  run := rst & (reply | run);
+  Q0 := q; Q1 := Q0;
+  shreg := ~rst -> InitBuf : (endbit | reply) -> 0FFFFFFFFH'32: shift -> {msdat, shreg[31:1]} : shreg;
+  x := ~rst -> 0'10 : endbit -> x + dx : x;
+  y := ~rst -> 0'10 : endbit -> y + dy : y;
+  btns := ~rst -> 0'3 : endbit -> {shreg.1, shreg.3, shreg.2} : btns
+END MouseP.
+
+MODULE MouseP (
+  IN clk, rst: BIT;
+  INOUT io: [2] BIT;
+  OUT out: [28] BIT);
+
+  (* init mouse cmd F4 (start reporting) with start, parity and stop bits added *)
+  CONST InitBuf := 0FFFFFDE8H;  (* 1...1 1 0 1111 0100 0 *)
+  TYPE PS2BUF = MODULE (OUT O: [2] BIT; INOUT IO: [2] BIT; IN T: [2] BIT) ^;
+  REG x, y: [10] BIT;   (*counters*)
+    btns: [3] BIT;
+    Q0, Q1, run: BIT;
+    shreg: [32] BIT;
+  VAR shift, endbit, reply: BIT;
+    dx, dy: [10] BIT;
+    in: [2] BIT;
+    ps2buf: PS2BUF;
+BEGIN ps2buf(in, io, {run | shreg[0], rst});  (*open-collector wiring*)
+  shift := Q1 & ~Q0;   (*falling edge detector*)
+  reply := ~run & ~shreg.11;   (*start bit of echoed initBuf, if response*)
+  endbit := run & ~shreg.0;   (*normal packet received*)
+  dx := {shreg.5 !2, shreg.7 -> 0'8 : shreg[19:12]};   (*sign + ovfl*)
+  dy := {shreg.6 !2, shreg.8 -> 0'8 : shreg[30:23]};   (*sign + ovfl*)
+  out := {run, btns, 0'2, y, 0'2, x};
+
+  run := rst & (reply | run);
+  Q0 := in[0]; Q1 := Q0;
+  shreg := ~rst -> InitBuf : (endbit | reply) -> 0FFFFFFFFH'32: shift -> {in[1], shreg[31:1]} : shreg;
+  x := ~rst -> 0'10 : endbit -> x + dx : x;
+  y := ~rst -> 0'10 : endbit -> y + dy : y;
+  btns := ~rst -> 0'3 : endbit -> {shreg.1, shreg.3, shreg.2} : btns
+END MouseP.

people.inf.ethz.ch/wirth/Lola/Sources/Multiplier.Lola.txt

@@ -1,18 +1,18 @@
-MODULE Multiplier (     (*NW 13.9.2014*)
-  IN clk, run, u: BIT;
-  OUT stall: BIT;
-  IN x, y: WORD;   (*32 bit*)
-  OUT z: [64] BIT);
-
-  REG (clk) S: [6] BIT;   (*state*)
-    P: [64] BIT;   (*product*)
-  VAR w0: WORD;
-    w1: [33] BIT;
-
-BEGIN stall := run & (S # 33);
-  w0 := P.0 -> y : 0;
-  w1 := (S =32) & u -> {P.63, P[63:32]} - {w0.31, w0} : {P.63, P[63:32]} + {w0.31, w0};
-  S := run -> S+1 : 0;
-  P := (S = 0) -> {0'32, x} : {w1[32:0], P[31:1]};
-  z := P
-END Multiplier.
+MODULE Multiplier (     (*NW 13.9.2014*)
+  IN clk, run, u: BIT;
+  OUT stall: BIT;
+  IN x, y: WORD;   (*32 bit*)
+  OUT z: [64] BIT);
+
+  REG (clk) S: [6] BIT;   (*state*)
+    P: [64] BIT;   (*product*)
+  VAR w0: WORD;
+    w1: [33] BIT;
+
+BEGIN stall := run & (S # 33);
+  w0 := P.0 -> y : 0;
+  w1 := (S =32) & u -> {P.63, P[63:32]} - {w0.31, w0} : {P.63, P[63:32]} + {w0.31, w0};
+  S := run -> S+1 : 0;
+  P := (S = 0) -> {0'32, x} : {w1[32:0], P[31:1]};
+  z := P
+END Multiplier.

people.inf.ethz.ch/wirth/Lola/Sources/PS2.Lola.txt

@@ -1,25 +1,25 @@
-MODULE PS2 (
-  IN clk, rst, done: BIT;
-  OUT rdy, shift: BIT;
-  OUT data: BYTE;
-  IN PS2C, PS2D: BIT);
-
-  REG (clk)
-    Q0, Q1: BIT;   (*synchronizer and falling edge detector*)
-    shreg: [11] BIT;
-    inptr, outptr: [4] BIT;
-    fifo: [16] BYTE;
-  VAR endbit: BIT;
-
-BEGIN endbit := ~shreg.0;   (*start bit reached correct pos*)
-  shift := Q1 & ~Q0;
-  Q0 := PS2C; Q1 := Q0;
-  data := fifo[outptr];
-  rdy := (inptr # outptr);
-
-  shreg := (~rst | endbit) -> 7FFH'11:
-    shift -> {PS2D, shreg[10:1]} : shreg;
-  outptr := ~rst -> 0 : rdy & done -> outptr + 1 : outptr;
-  inptr := ~rst -> 0 : endbit -> inptr + 1 : inptr;
-  fifo[inptr] := endbit -> shreg[8:1] : fifo[inptr];
-END PS2.
+MODULE PS2 (
+  IN clk, rst, done: BIT;
+  OUT rdy, shift: BIT;
+  OUT data: BYTE;
+  IN PS2C, PS2D: BIT);
+
+  REG (clk)
+    Q0, Q1: BIT;   (*synchronizer and falling edge detector*)
+    shreg: [11] BIT;
+    inptr, outptr: [4] BIT;
+    fifo: [16] BYTE;
+  VAR endbit: BIT;
+
+BEGIN endbit := ~shreg.0;   (*start bit reached correct pos*)
+  shift := Q1 & ~Q0;
+  Q0 := PS2C; Q1 := Q0;
+  data := fifo[outptr];
+  rdy := (inptr # outptr);
+
+  shreg := (~rst | endbit) -> 7FFH'11:
+    shift -> {PS2D, shreg[10:1]} : shreg;
+  outptr := ~rst -> 0 : rdy & done -> outptr + 1 : outptr;
+  inptr := ~rst -> 0 : endbit -> inptr + 1 : inptr;
+  fifo[inptr] := endbit -> shreg[8:1] : fifo[inptr];
+END PS2.

people.inf.ethz.ch/wirth/Lola/Sources/RISC5.Lola.txt

@@ -1,201 +1,201 @@
-MODULE RISC5(   (*NW 14.8.2018; with floating-point and interrupts*)
-  IN clk, rst, irq, stallX: BIT;
-  IN inbus, codebus: WORD;
-  OUT adr: [24] BIT;
-    rd, wr, ben: BIT;
-    outbus: WORD);
-  
-  CONST StartAdr = 3FF800H'22;
-
-  TYPE Registers = MODULE (IN clk, wr: BIT;
-      IN rno0, rno1, rno2: [4] BIT;
-      IN din: WORD;
-      OUT dout0, dout1, dout2: WORD) ^;
-
-    Multiplier = MODULE (IN clk, run, u: BIT;
-      OUT stall: BIT;
-      IN x, y: WORD;
-      OUT z: [64] BIT) ^;
-
-    Divider = MODULE (IN clk, run, u: BIT;
-      OUT stall: BIT;
-      IN x, y: WORD;
-      OUT quot, rem: WORD) ^;
-
-    LeftShifter = MODULE (IN x: WORD; sc: [5] BIT; OUT y: WORD) ^;
-
-    RightShifter = MODULE (IN x: WORD; sc: [5] BIT; md: BIT; OUT y: WORD) ^;
-
-    FPAdder = MODULE (IN clk, run, u, v: BIT; OUT stall: BIT;
-      IN x, y: WORD; OUT z: WORD) ^;
-
-    FPMultiplier = MODULE (IN clk, run: BIT; OUT  stall: BIT;
-      IN x, y: WORD; OUT z: WORD) ^;
-
-    FPDivider = MODULE (IN clk, run: BIT; OUT stall: BIT;
-      IN x, y: WORD; OUT z: WORD) ^;
-
-  REG (clk) PC: [22] BIT;  (*program counter*)
-    IR: WORD;   (*instruction register*)
-    N, Z, C, OV: BIT;   (*condition flags*)
-    stallL1: BIT;
-    H: WORD;  (*auxiliary register*)
-    irq1, intEnb, intPnd, intMd: BIT;
-    SPC: [26] BIT;  (*saved PC on interrupt*)
-
-  VAR regs: Registers;
-    mulUnit: Multiplier;
-    divUnit: Divider;
-    LshUnit: LeftShifter;
-    RshUnit: RightShifter;
-    faddUnit: FPAdder;
-    fmulUnit: FPMultiplier;
-    fdivUnit: FPDivider;
-
-    pcmux, pcmux0, nxpc: [22] BIT;
-    cond, S: BIT;
-    sa, sb, sc: BIT;
-
-    p, q, u, v: BIT;   (*instruction fields*)
-    op, ira, ira0, irb, irc: [4] BIT;
-    cc: [3] BIT;
-    imm: [16] BIT;
-    off: [20] BIT;
-    disp: [22] BIT;
-
-    regwr: BIT;
-    stall, stallL0, stallM, stallD, stallFA, stallFM, stallFD: BIT;
-    intAck, nn, zz, cx, vv: BIT;
-
-    A, B, C0, C1, aluRes, regmux, inbus1: WORD;
-    lshout, rshout: WORD;  (*shifting*)
-    quotient, remainder: WORD;
-    product: [64] BIT;
-    fsum, fprod, fquot: WORD;
-
-    Add, Sub, Mul, Div: BIT;
-    Fadd, Fsub, Fmul, Fdiv: BIT; 
-    Ldr, Str, Br, RTI: BIT;
-
-BEGIN 
-  regs (clk, regwr, ira0, irb, irc, regmux, A, B, C0);
-  mulUnit (clk, Mul, ~u, stallM, B, C1, product);
-  divUnit (clk, Div, ~u, stallD, B, C1, quotient, remainder);
-  LshUnit (B, C1[4:0], lshout);
-  RshUnit (B, C1[4:0], IR.16, rshout);
-  faddUnit (clk, Fadd|Fsub, u, v, stallFA, B, {Fsub^C0.31, C0[30:0]}, fsum);
-  fmulUnit (clk, Fmul, stallFM, B, C0, fprod);
-  fdivUnit (clk, Fdiv, stallFD, B, C0, fquot);
-
-  p := IR.31;  (*instruction fields*)
-  q := IR.30;
-  u := IR.29;
-  v := IR.28;
-  cc:= IR[26:24];
-  ira := IR[27:24];
-  irb := IR[23:20];
-  op := IR[19:16];
-  irc := IR[3:0];
-  imm := IR[15:0];  (*reg instr*)
-  off := IR[19:0];    (*mem instr*)
-  disp := IR[21:0];  (*branch instr*)
-
-  Add := ~p & (op = 8);
-  Sub := ~p & (op = 9);
-  Mul := ~p & (op = 10);
-  Div := ~p & (op = 11);
-  Fadd := ~p & (op = 12);
-  Fsub := ~p & (op = 13);
-  Fmul := ~p & (op = 14);
-  Fdiv := ~p & (op = 15);
-  Ldr := p & ~q & ~u;
-  Str := p & ~q & u;
-  Br := p & q;
-  RTI := Br & ~u & ~v & IR[4];
-
-  (*ALU*)
-  C1 := q -> {v!16, imm} : C0 ;
-  ira0 := Br -> 15'4 : ira;
-  adr := stallL0 -> B[23:0] + {off.19 ! 4, off} : {pcmux, 0'2};
-  rd := Ldr & ~stallX & ~stallL1;
-  wr := Str & ~stallX & ~stallL1;
-  ben := p & ~q & v & ~stallX & ~stallL1; (*byte enable*)
-
-  aluRes :=
-    ~op.3 ->
-      (~op.2 ->
-        (~op.1 ->
-          (~op.0 ->  (*Mov*)
-            (q -> 
-              (~u ->  {v!16 , imm} : {imm, 0'16}) :
-              (~u -> C0 : (~v -> H : {N, Z, C, OV, 0'20, 5BH'8}))) :
-            lshout ):   (*Lsl*)
-          rshout) :   (*Asr, Ror*)
-        (~op.1 -> 
-          (~op.0 -> B & C1 : B & ~C1) :   (*And, Ann*)
-          (~op.0 -> B | C1 : B ^ C1)) ):   (*Ior, Xor*)
-      (~op.2 ->
-        (~op.1 ->
-          (~op.0 -> B + C1 + {0'31, (u&C)} : B - C1 - {0'31, (u&C)}) :   (*Add, Sub*)
-          (~op.0 -> product[31:0] : quotient)) :       (*Mul, Div*)
-        (~op.1 ->
-          fsum :     (*Fad, Fsb*)
-          (~op.0 -> fprod : fquot))) ;  (*Fml, Fdv*)
-
-  regwr := ~p & ~stall | (Ldr & ~stallX & ~stallL1) | (Br & cond & v & ~stallX);
-  regmux := Ldr -> inbus1 : (Br  & v) -> {0'8, nxpc, 0'2} : aluRes ;
-  inbus1 := ~ben -> inbus :
-    {0'24, (adr[1] -> (adr[0] -> inbus[31:24] : inbus[23:16]) :
-            (adr[0] -> inbus[15:8] : inbus[7:0]))};
-  outbus := ~ben -> A :
-    adr[1] -> (adr[0] -> {A[7:0], 0'24} : {0'8, A[7:0], 0'16}) :
-            (adr[0] -> {0'16, A[7:0], 0'8} : {0'24, A[7:0]});
-
-  (*control unit*)
-  S := N ^ OV;
-  nxpc := PC + 1;
-  cond := IR.27 ^ (
-      (cc = 0) & N  |  (*MI, PL*)
-      (cc = 1) & Z  |  (*EQ, NE*)
-      (cc = 2) & C  |  (*CS, CC*)
-      (cc = 3) & OV  |  (*VS, VC*)
-      (cc = 4) & (C|Z)  |  (*LS, HI*)
-      (cc = 5) & S  |  (*LT, GE*)
-      (cc = 6) & (S|Z) | (*LE, GT*)
-      (cc = 7));
-
-  intAck := intPnd & intEnb & ~intMd & ~stall;
-  pcmux0 := stall -> PC :
-    RTI-> SPC[21:0] :
-    (Br & cond) -> (u -> disp + nxpc : C0[23:2]) : nxpc;
-  pcmux := ~rst -> StartAdr : intAck -> 1 : pcmux0;
-
-  sa := aluRes.31;
-  sb := B.31;
-  sc := C1.31;
-
-  nn := RTI -> SPC[25] : regwr -> regmux.31 : N;
-  zz := RTI -> SPC[24] :  regwr -> (regmux = 0) : Z;
-  cx := RTI -> SPC[23] :
-    Add -> (sb&sc) | (~sa&~sb&sc) | (~sa&sb&~sc&sa) :
-    Sub -> (~sb&sc) | (sa&~sb&~sc) | (sa&sb&sc) : C;
-  vv := RTI -> SPC[22] :
-    Add -> (sa&~sb&~sc) | (~sa&sb&sc) :
-    Sub -> (sa&~sb&sc) | (~sa&sb&~sc) : OV;
-
-  stall := stallL0 | stallM | stallD | stallFA | stallFM | stallFD | stallX;
-  stallL0 := (Ldr | Str) & ~stallL1;
-  
-  (*assignments to registers*)
-  PC := pcmux;
-  IR := stall -> IR : codebus;
-  stallL1 := stallX -> stallL1 : stallL0;
-  N := nn; Z := zz; C := cx; OV := vv;
-  H := Mul -> product[63:32] : Div -> remainder : H;
-
-  irq1 := irq;   (*edge detector*)
-  intPnd := rst & ~intAck & ((~irq1 & irq) | intPnd);
-  intMd := rst & ~RTI & (intAck | intMd);
-  intEnb := ~rst -> 0 : (Br & ~u & ~v & IR[5]) -> IR[0] : intEnb;
-  SPC := intAck -> {nn, zz, cx, vv, pcmux0} : SPC
-END RISC5.
+MODULE RISC5(   (*NW 14.8.2018; with floating-point and interrupts*)
+  IN clk, rst, irq, stallX: BIT;
+  IN inbus, codebus: WORD;
+  OUT adr: [24] BIT;
+    rd, wr, ben: BIT;
+    outbus: WORD);
+  
+  CONST StartAdr = 3FF800H'22;
+
+  TYPE Registers = MODULE (IN clk, wr: BIT;
+      IN rno0, rno1, rno2: [4] BIT;
+      IN din: WORD;
+      OUT dout0, dout1, dout2: WORD) ^;
+
+    Multiplier = MODULE (IN clk, run, u: BIT;
+      OUT stall: BIT;
+      IN x, y: WORD;
+      OUT z: [64] BIT) ^;
+
+    Divider = MODULE (IN clk, run, u: BIT;
+      OUT stall: BIT;
+      IN x, y: WORD;
+      OUT quot, rem: WORD) ^;
+
+    LeftShifter = MODULE (IN x: WORD; sc: [5] BIT; OUT y: WORD) ^;
+
+    RightShifter = MODULE (IN x: WORD; sc: [5] BIT; md: BIT; OUT y: WORD) ^;
+
+    FPAdder = MODULE (IN clk, run, u, v: BIT; OUT stall: BIT;
+      IN x, y: WORD; OUT z: WORD) ^;
+
+    FPMultiplier = MODULE (IN clk, run: BIT; OUT  stall: BIT;
+      IN x, y: WORD; OUT z: WORD) ^;
+
+    FPDivider = MODULE (IN clk, run: BIT; OUT stall: BIT;
+      IN x, y: WORD; OUT z: WORD) ^;
+
+  REG (clk) PC: [22] BIT;  (*program counter*)
+    IR: WORD;   (*instruction register*)
+    N, Z, C, OV: BIT;   (*condition flags*)
+    stallL1: BIT;
+    H: WORD;  (*auxiliary register*)
+    irq1, intEnb, intPnd, intMd: BIT;
+    SPC: [26] BIT;  (*saved PC on interrupt*)
+
+  VAR regs: Registers;
+    mulUnit: Multiplier;
+    divUnit: Divider;
+    LshUnit: LeftShifter;
+    RshUnit: RightShifter;
+    faddUnit: FPAdder;
+    fmulUnit: FPMultiplier;
+    fdivUnit: FPDivider;
+
+    pcmux, pcmux0, nxpc: [22] BIT;
+    cond, S: BIT;
+    sa, sb, sc: BIT;
+
+    p, q, u, v: BIT;   (*instruction fields*)
+    op, ira, ira0, irb, irc: [4] BIT;
+    cc: [3] BIT;
+    imm: [16] BIT;
+    off: [20] BIT;
+    disp: [22] BIT;
+
+    regwr: BIT;
+    stall, stallL0, stallM, stallD, stallFA, stallFM, stallFD: BIT;
+    intAck, nn, zz, cx, vv: BIT;
+
+    A, B, C0, C1, aluRes, regmux, inbus1: WORD;
+    lshout, rshout: WORD;  (*shifting*)
+    quotient, remainder: WORD;
+    product: [64] BIT;
+    fsum, fprod, fquot: WORD;
+
+    Add, Sub, Mul, Div: BIT;
+    Fadd, Fsub, Fmul, Fdiv: BIT; 
+    Ldr, Str, Br, RTI: BIT;
+
+BEGIN 
+  regs (clk, regwr, ira0, irb, irc, regmux, A, B, C0);
+  mulUnit (clk, Mul, ~u, stallM, B, C1, product);
+  divUnit (clk, Div, ~u, stallD, B, C1, quotient, remainder);
+  LshUnit (B, C1[4:0], lshout);
+  RshUnit (B, C1[4:0], IR.16, rshout);
+  faddUnit (clk, Fadd|Fsub, u, v, stallFA, B, {Fsub^C0.31, C0[30:0]}, fsum);
+  fmulUnit (clk, Fmul, stallFM, B, C0, fprod);
+  fdivUnit (clk, Fdiv, stallFD, B, C0, fquot);
+
+  p := IR.31;  (*instruction fields*)
+  q := IR.30;
+  u := IR.29;
+  v := IR.28;
+  cc:= IR[26:24];
+  ira := IR[27:24];
+  irb := IR[23:20];
+  op := IR[19:16];
+  irc := IR[3:0];
+  imm := IR[15:0];  (*reg instr*)
+  off := IR[19:0];    (*mem instr*)
+  disp := IR[21:0];  (*branch instr*)
+
+  Add := ~p & (op = 8);
+  Sub := ~p & (op = 9);
+  Mul := ~p & (op = 10);
+  Div := ~p & (op = 11);
+  Fadd := ~p & (op = 12);
+  Fsub := ~p & (op = 13);
+  Fmul := ~p & (op = 14);
+  Fdiv := ~p & (op = 15);
+  Ldr := p & ~q & ~u;
+  Str := p & ~q & u;
+  Br := p & q;
+  RTI := Br & ~u & ~v & IR[4];
+
+  (*ALU*)
+  C1 := q -> {v!16, imm} : C0 ;
+  ira0 := Br -> 15'4 : ira;
+  adr := stallL0 -> B[23:0] + {off.19 ! 4, off} : {pcmux, 0'2};
+  rd := Ldr & ~stallX & ~stallL1;
+  wr := Str & ~stallX & ~stallL1;
+  ben := p & ~q & v & ~stallX & ~stallL1; (*byte enable*)
+
+  aluRes :=
+    ~op.3 ->
+      (~op.2 ->
+        (~op.1 ->
+          (~op.0 ->  (*Mov*)
+            (q -> 
+              (~u ->  {v!16 , imm} : {imm, 0'16}) :
+              (~u -> C0 : (~v -> H : {N, Z, C, OV, 0'20, 5BH'8}))) :
+            lshout ):   (*Lsl*)
+          rshout) :   (*Asr, Ror*)
+        (~op.1 -> 
+          (~op.0 -> B & C1 : B & ~C1) :   (*And, Ann*)
+          (~op.0 -> B | C1 : B ^ C1)) ):   (*Ior, Xor*)
+      (~op.2 ->
+        (~op.1 ->
+          (~op.0 -> B + C1 + {0'31, (u&C)} : B - C1 - {0'31, (u&C)}) :   (*Add, Sub*)
+          (~op.0 -> product[31:0] : quotient)) :       (*Mul, Div*)
+        (~op.1 ->
+          fsum :     (*Fad, Fsb*)
+          (~op.0 -> fprod : fquot))) ;  (*Fml, Fdv*)
+
+  regwr := ~p & ~stall | (Ldr & ~stallX & ~stallL1) | (Br & cond & v & ~stallX);
+  regmux := Ldr -> inbus1 : (Br  & v) -> {0'8, nxpc, 0'2} : aluRes ;
+  inbus1 := ~ben -> inbus :
+    {0'24, (adr[1] -> (adr[0] -> inbus[31:24] : inbus[23:16]) :
+            (adr[0] -> inbus[15:8] : inbus[7:0]))};
+  outbus := ~ben -> A :
+    adr[1] -> (adr[0] -> {A[7:0], 0'24} : {0'8, A[7:0], 0'16}) :
+            (adr[0] -> {0'16, A[7:0], 0'8} : {0'24, A[7:0]});
+
+  (*control unit*)
+  S := N ^ OV;
+  nxpc := PC + 1;
+  cond := IR.27 ^ (
+      (cc = 0) & N  |  (*MI, PL*)
+      (cc = 1) & Z  |  (*EQ, NE*)
+      (cc = 2) & C  |  (*CS, CC*)
+      (cc = 3) & OV  |  (*VS, VC*)
+      (cc = 4) & (C|Z)  |  (*LS, HI*)
+      (cc = 5) & S  |  (*LT, GE*)
+      (cc = 6) & (S|Z) | (*LE, GT*)
+      (cc = 7));
+
+  intAck := intPnd & intEnb & ~intMd & ~stall;
+  pcmux0 := stall -> PC :
+    RTI-> SPC[21:0] :
+    (Br & cond) -> (u -> disp + nxpc : C0[23:2]) : nxpc;
+  pcmux := ~rst -> StartAdr : intAck -> 1 : pcmux0;
+
+  sa := aluRes.31;
+  sb := B.31;
+  sc := C1.31;
+
+  nn := RTI -> SPC[25] : regwr -> regmux.31 : N;
+  zz := RTI -> SPC[24] :  regwr -> (regmux = 0) : Z;
+  cx := RTI -> SPC[23] :
+    Add -> (sb&sc) | (~sa&~sb&sc) | (~sa&sb&~sc&sa) :
+    Sub -> (~sb&sc) | (sa&~sb&~sc) | (sa&sb&sc) : C;
+  vv := RTI -> SPC[22] :
+    Add -> (sa&~sb&~sc) | (~sa&sb&sc) :
+    Sub -> (sa&~sb&sc) | (~sa&sb&~sc) : OV;
+
+  stall := stallL0 | stallM | stallD | stallFA | stallFM | stallFD | stallX;
+  stallL0 := (Ldr | Str) & ~stallL1;
+  
+  (*assignments to registers*)
+  PC := pcmux;
+  IR := stall -> IR : codebus;
+  stallL1 := stallX -> stallL1 : stallL0;
+  N := nn; Z := zz; C := cx; OV := vv;
+  H := Mul -> product[63:32] : Div -> remainder : H;
+
+  irq1 := irq;   (*edge detector*)
+  intPnd := rst & ~intAck & ((~irq1 & irq) | intPnd);
+  intMd := rst & ~RTI & (intAck | intMd);
+  intEnb := ~rst -> 0 : (Br & ~u & ~v & IR[5]) -> IR[0] : intEnb;
+  SPC := intAck -> {nn, zz, cx, vv, pcmux0} : SPC
+END RISC5.

people.inf.ethz.ch/wirth/Lola/Sources/RISC5Top.Lola.txt

@@ -1,167 +1,167 @@
-MODULE RISC5Top(   (*NW 25.7.2018*)
-  IN CLK50M: BIT;
-  IN btn: [4] BIT;
-  IN swi: BYTE;
-  IN RxD: BIT;
-  OUT TxD: BIT;
-  OUT leds: BYTE;
-  OUT SRce0, SRce1, SRwe, SRoe: BIT;  (*SRAM*)
-  OUT SRbe: [4] BIT;
-  OUT SRadr: [18] BIT;
-  INOUT SRdat: WORD;
-  IN MISO: [2] BIT;   (*SPI - SD card & network*)
-  OUT SCLK, MOSI, SS: [2] BIT;
-  OUT NEN: BIT;   (*network enable*)
-  OUT hsync, vsync: BIT;   (*video control*)
-  OUT RGB: [3] BIT;
-  IN PS2C, PS2D: BIT;   (*keyboard*)
-  INOUT msclk, msdat: BIT;
-  INOUT gpio: BYTE);
-
-(* I/O addresses:
-  0  millisconds / --
-  1  switches / LEDs
-  2  RS232 data / data (start)
-  3  RS232 status / control
-  4  SPI data / data (start)
-  5  SPI status / control
-  6  PS2 keyboard data
-  7  mouse
-  8  general-purpose I/O data
-  9  general-purpose I/O tri-state control *)
-
-TYPE RISC5 = MODULE (
-    IN clk, rst, irq, stallX: BIT;
-      inbus, codebus: WORD;
-    OUT adr: [24] BIT;
-      rd, wr, ben: BIT;
-      outbus: WORD) ^;
-
-  PROM = MODULE (IN clk: BIT;
-      IN adr: [9] BIT;
-      OUT data: WORD) ^;
-
-  RS232R = MODULE (
-    IN clk, rst, done, RxD, fsel: BIT;
-    OUT rdy: BIT; data: BYTE) ^;
-
-  RS232T = MODULE (
-    IN clk, rst, start, fsel: BIT; data: BYTE;
-    OUT rdy, TxD: BIT) ^;
-
-  SPI = MODULE (
-    IN clk, rst, start, fast: BIT; dataTx: WORD;
-    OUT dataRx: WORD; rdy: BIT;
-    IN MISO: BIT; 
-    OUT MOSI, SCLK: BIT)  ^;
-
-  VID = MODULE (
-    IN clk, inv: BIT; viddata: WORD;
-    OUT req: BIT; vidadr: [18] BIT;
-      hsync, vsync: BIT; RGB: [3] BIT) ^;
-
-  MouseP = MODULE ( 
-    IN clk, rst: BIT;
-    INOUT msclk, msdat: BIT;
-    OUT out: [28] BIT) ^;
-
-  PS2 = MODULE (
-    IN clk, rst, done: BIT;
-    OUT rdy, shift: BIT; data: BYTE;
-    IN PS2C, PS2D: BIT) ^;
-
-REG (CLK50M) clk: BIT;
-REG (clk) rst: BIT;
-  bitrate: BIT;   (*RS-232*)
-  Lreg: BYTE;  (*LED*)
-  cnt0: [16] BIT;
-  cnt1: WORD;  (*milliseconds*)
-  spiCtrl: [4] BIT;
-  gpout, gpoc: BYTE;
-
-VAR riscx: RISC5;   (*instantiations*)
-  PM: PROM;  (*mem for boot loader*)
-  receiver: RS232R;
-  transmitter: RS232T;
-  spi: SPI;  (*CD-ROM and net*)
-  vid: VID;
-  kbd: PS2;
-  Ms: MouseP;
-
-  dmy: BIT;
-  adr: [24] BIT;
-  iowadr: [4] BIT;  (*word adress*)
-  rd, wr, ben, ioenb, dspreq: BIT;
-  be0, be1: BIT;
-  inbus, inbus0: WORD;  (*data to RISC6 core*)
-  outbus: WORD;   (*data from RISC6 core*)
-  romout, codebus: WORD;
-
-  dataTx, dataRx, dataKbd: BYTE;
-  rdyRx, doneRx, startTx, rdyTx, rdyKbd, doneKbd: BIT;
-  dataMs: [28] BIT;   (*mouse*)
-  limit: BIT;   (*of cnt0*)
-  spiRx: WORD;
-  spiStart, spiRdy, MOSI1, SCLK1: BIT;
-  vidadr: [18] BIT;
-  gpin: BYTE;
-
-BEGIN
-  riscx (clk, rst, limit, dspreq, inbus, codebus, adr, rd, wr, ben, outbus);
-  PM (~clk, adr[10:2], romout);
-  receiver (clk, rst, doneRx, RxD, bitrate, rdyRx, dataRx);
-  transmitter (clk, rst, startTx, bitrate, dataTx, rdyTx, TxD);
-  spi (clk, rst, spiStart, spiCtrl.2, outbus, spiRx, spiRdy, MISO.0 & MISO.1, MOSI1, SCLK1); 
-  vid (clk, swi.7, inbus0, dspreq, vidadr, hsync, vsync, RGB);
-  kbd (clk, rst, doneKbd, rdyKbd, dmy, dataKbd, PS2C, PS2D);
-  Ms (clk, rst, msclk, msdat, dataMs);
-  TS(SRdat, inbus0, outbus, ~wr);
-  TS(gpio, gpin, gpout, gpoc);
-
-  codebus := (adr[23:14] = 3FFH'10) -> romout : inbus0;
-  iowadr := adr[5:2];
-  ioenb := (adr[23:6] = 3FFFFH'18);
-  inbus := ~ioenb -> inbus0 :
-    ((iowadr = 0) -> cnt1 :
-    (iowadr = 1) -> {0'20, btn, swi} :
-    (iowadr = 2) -> {0'24, dataRx} :
-    (iowadr = 3) -> {0'30, rdyTx, rdyRx} :
-    (iowadr = 4) -> spiRx :
-    (iowadr = 5) -> {0'31, spiRdy} :
-    (iowadr = 6) -> {0'3, rdyKbd, dataMs} :
-    (iowadr = 7) -> {0'24, dataKbd} :
-    (iowadr = 8) -> {0'24, gpin} :
-    (iowadr = 9) -> {0'24, gpoc} : 0'32);
-
-(*access to SRAM*)
-  be0 := ben & adr.0;
-  be1 := ben & ~adr.0;
-  SRce0 := ben & adr.1;
-  SRce1 := ben & ~adr.1;
-  SRwe := ~wr | clk;
-  SRoe := wr;
-  SRbe := {be1, be0, be1, be0};
-  SRadr := dspreq -> vidadr : adr[19:2];
-
-  dataTx := outbus[7:0];
-  startTx := wr & ioenb & (iowadr = 2);
-  doneRx := rd & ioenb & (iowadr = 2);
-  spiStart := wr & ioenb & (iowadr = 4);
-  doneKbd := rd & ioenb & (iowadr = 7);
-  limit := (cnt0 = 24999);
-  leds := Lreg;
-  SS := ~spiCtrl[1:0];   (*active low slave select*)
-  MOSI := {MOSI1, MOSI1}; SCLK := {SCLK1, SCLK1};
-  NEN := spiCtrl[3];
-
-  rst := (cnt1[4:0] = 0'5) & limit -> ~btn[3] : rst;
-  Lreg := ~rst -> 0 : (wr & ioenb & (iowadr = 1)) -> outbus[7:0] : Lreg;
-  spiCtrl := ~rst -> 0 : (wr & ioenb & (iowadr = 5)) -> outbus[3:0] : spiCtrl;
-  bitrate := ~rst -> 0 : (wr & ioenb & (iowadr = 3)) -> outbus[0] : bitrate;
-  gpout := ~rst -> 0 : (wr & ioenb & (iowadr = 8)) -> outbus[7:0] : gpout;
-  gpoc := ~rst -> 0 : (wr & ioenb & (iowadr = 9)) -> outbus[7:0] : gpoc;
-  cnt0 := limit -> 0 : cnt0 + 1;
-  cnt1 := cnt1 + {0'31, limit};
-
-  clk := ~clk  (* @ 50 MHz *)
-END RISC5Top.
+MODULE RISC5Top(   (*NW 25.7.2018*)
+  IN CLK50M: BIT;
+  IN btn: [4] BIT;
+  IN swi: BYTE;
+  IN RxD: BIT;
+  OUT TxD: BIT;
+  OUT leds: BYTE;
+  OUT SRce0, SRce1, SRwe, SRoe: BIT;  (*SRAM*)
+  OUT SRbe: [4] BIT;
+  OUT SRadr: [18] BIT;
+  INOUT SRdat: WORD;
+  IN MISO: [2] BIT;   (*SPI - SD card & network*)
+  OUT SCLK, MOSI, SS: [2] BIT;
+  OUT NEN: BIT;   (*network enable*)
+  OUT hsync, vsync: BIT;   (*video control*)
+  OUT RGB: [3] BIT;
+  IN PS2C, PS2D: BIT;   (*keyboard*)
+  INOUT msclk, msdat: BIT;
+  INOUT gpio: BYTE);
+
+(* I/O addresses:
+  0  millisconds / --
+  1  switches / LEDs
+  2  RS232 data / data (start)
+  3  RS232 status / control
+  4  SPI data / data (start)
+  5  SPI status / control
+  6  PS2 keyboard data
+  7  mouse
+  8  general-purpose I/O data
+  9  general-purpose I/O tri-state control *)
+
+TYPE RISC5 = MODULE (
+    IN clk, rst, irq, stallX: BIT;
+      inbus, codebus: WORD;
+    OUT adr: [24] BIT;
+      rd, wr, ben: BIT;
+      outbus: WORD) ^;
+
+  PROM = MODULE (IN clk: BIT;
+      IN adr: [9] BIT;
+      OUT data: WORD) ^;
+
+  RS232R = MODULE (
+    IN clk, rst, done, RxD, fsel: BIT;
+    OUT rdy: BIT; data: BYTE) ^;
+
+  RS232T = MODULE (
+    IN clk, rst, start, fsel: BIT; data: BYTE;
+    OUT rdy, TxD: BIT) ^;
+
+  SPI = MODULE (
+    IN clk, rst, start, fast: BIT; dataTx: WORD;
+    OUT dataRx: WORD; rdy: BIT;
+    IN MISO: BIT; 
+    OUT MOSI, SCLK: BIT)  ^;
+
+  VID = MODULE (
+    IN clk, inv: BIT; viddata: WORD;
+    OUT req: BIT; vidadr: [18] BIT;
+      hsync, vsync: BIT; RGB: [3] BIT) ^;
+
+  MouseP = MODULE ( 
+    IN clk, rst: BIT;
+    INOUT msclk, msdat: BIT;
+    OUT out: [28] BIT) ^;
+
+  PS2 = MODULE (
+    IN clk, rst, done: BIT;
+    OUT rdy, shift: BIT; data: BYTE;
+    IN PS2C, PS2D: BIT) ^;
+
+REG (CLK50M) clk: BIT;
+REG (clk) rst: BIT;
+  bitrate: BIT;   (*RS-232*)
+  Lreg: BYTE;  (*LED*)
+  cnt0: [16] BIT;
+  cnt1: WORD;  (*milliseconds*)
+  spiCtrl: [4] BIT;
+  gpout, gpoc: BYTE;
+
+VAR riscx: RISC5;   (*instantiations*)
+  PM: PROM;  (*mem for boot loader*)
+  receiver: RS232R;
+  transmitter: RS232T;
+  spi: SPI;  (*CD-ROM and net*)
+  vid: VID;
+  kbd: PS2;
+  Ms: MouseP;
+
+  dmy: BIT;
+  adr: [24] BIT;
+  iowadr: [4] BIT;  (*word adress*)
+  rd, wr, ben, ioenb, dspreq: BIT;
+  be0, be1: BIT;
+  inbus, inbus0: WORD;  (*data to RISC6 core*)
+  outbus: WORD;   (*data from RISC6 core*)
+  romout, codebus: WORD;
+
+  dataTx, dataRx, dataKbd: BYTE;
+  rdyRx, doneRx, startTx, rdyTx, rdyKbd, doneKbd: BIT;
+  dataMs: [28] BIT;   (*mouse*)
+  limit: BIT;   (*of cnt0*)
+  spiRx: WORD;
+  spiStart, spiRdy, MOSI1, SCLK1: BIT;
+  vidadr: [18] BIT;
+  gpin: BYTE;
+
+BEGIN
+  riscx (clk, rst, limit, dspreq, inbus, codebus, adr, rd, wr, ben, outbus);
+  PM (~clk, adr[10:2], romout);
+  receiver (clk, rst, doneRx, RxD, bitrate, rdyRx, dataRx);
+  transmitter (clk, rst, startTx, bitrate, dataTx, rdyTx, TxD);
+  spi (clk, rst, spiStart, spiCtrl.2, outbus, spiRx, spiRdy, MISO.0 & MISO.1, MOSI1, SCLK1); 
+  vid (clk, swi.7, inbus0, dspreq, vidadr, hsync, vsync, RGB);
+  kbd (clk, rst, doneKbd, rdyKbd, dmy, dataKbd, PS2C, PS2D);
+  Ms (clk, rst, msclk, msdat, dataMs);
+  TS(SRdat, inbus0, outbus, ~wr);
+  TS(gpio, gpin, gpout, gpoc);
+
+  codebus := (adr[23:14] = 3FFH'10) -> romout : inbus0;
+  iowadr := adr[5:2];
+  ioenb := (adr[23:6] = 3FFFFH'18);
+  inbus := ~ioenb -> inbus0 :
+    ((iowadr = 0) -> cnt1 :
+    (iowadr = 1) -> {0'20, btn, swi} :
+    (iowadr = 2) -> {0'24, dataRx} :
+    (iowadr = 3) -> {0'30, rdyTx, rdyRx} :
+    (iowadr = 4) -> spiRx :
+    (iowadr = 5) -> {0'31, spiRdy} :
+    (iowadr = 6) -> {0'3, rdyKbd, dataMs} :
+    (iowadr = 7) -> {0'24, dataKbd} :
+    (iowadr = 8) -> {0'24, gpin} :
+    (iowadr = 9) -> {0'24, gpoc} : 0'32);
+
+(*access to SRAM*)
+  be0 := ben & adr.0;
+  be1 := ben & ~adr.0;
+  SRce0 := ben & adr.1;
+  SRce1 := ben & ~adr.1;
+  SRwe := ~wr | clk;
+  SRoe := wr;
+  SRbe := {be1, be0, be1, be0};
+  SRadr := dspreq -> vidadr : adr[19:2];
+
+  dataTx := outbus[7:0];
+  startTx := wr & ioenb & (iowadr = 2);
+  doneRx := rd & ioenb & (iowadr = 2);
+  spiStart := wr & ioenb & (iowadr = 4);
+  doneKbd := rd & ioenb & (iowadr = 7);
+  limit := (cnt0 = 24999);
+  leds := Lreg;
+  SS := ~spiCtrl[1:0];   (*active low slave select*)
+  MOSI := {MOSI1, MOSI1}; SCLK := {SCLK1, SCLK1};
+  NEN := spiCtrl[3];
+
+  rst := (cnt1[4:0] = 0'5) & limit -> ~btn[3] : rst;
+  Lreg := ~rst -> 0 : (wr & ioenb & (iowadr = 1)) -> outbus[7:0] : Lreg;
+  spiCtrl := ~rst -> 0 : (wr & ioenb & (iowadr = 5)) -> outbus[3:0] : spiCtrl;
+  bitrate := ~rst -> 0 : (wr & ioenb & (iowadr = 3)) -> outbus[0] : bitrate;
+  gpout := ~rst -> 0 : (wr & ioenb & (iowadr = 8)) -> outbus[7:0] : gpout;
+  gpoc := ~rst -> 0 : (wr & ioenb & (iowadr = 9)) -> outbus[7:0] : gpoc;
+  cnt0 := limit -> 0 : cnt0 + 1;
+  cnt1 := cnt1 + {0'31, limit};
+
+  clk := ~clk  (* @ 50 MHz *)
+END RISC5Top.

people.inf.ethz.ch/wirth/Lola/Sources/RS232R.Lola.txt

@@ -1,28 +1,28 @@
-MODULE RS232R (    (*NW 10.8.2015*)
-  IN clk, rst, done, RxD, fsel: BIT;
-  OUT rdy: BIT; data: BYTE);
-  REG (clk) run, stat: BIT;
-    Q0, Q1: BIT;   (*synchronizer and edge detector*)
-    tick: [12] BIT;
-    bitcnt: [4] BIT;
-    shreg: BYTE;
-  VAR endtick, midtick, endbit: BIT;
-    limit: [12] BIT;
-BEGIN
-  limit := fsel -> 217 : 1302;
-  endtick := tick = limit;
-  midtick := tick = {0'1, limit[11:1]};   (*limit/2*)
-  endbit := bitcnt = 8;
-  data := shreg;
-  rdy := stat;
-
-  Q0 := RxD; Q1 := Q0;
-  run := (Q1 & ~Q0) | ~(~rst | endtick & endbit) & run;
-  tick := (run & ~endtick) -> tick + 1 : 0;
-  bitcnt := (endtick & ~endbit) -> bitcnt + 1 :
-    (endtick & endbit) -> 0 : bitcnt;
-  shreg := midtick -> {Q1, shreg[7:1]} : shreg;
-  stat := (endtick & endbit) | ~(~rst | done) & stat
-END RS232R.
-
+MODULE RS232R (    (*NW 10.8.2015*)
+  IN clk, rst, done, RxD, fsel: BIT;
+  OUT rdy: BIT; data: BYTE);
+  REG (clk) run, stat: BIT;
+    Q0, Q1: BIT;   (*synchronizer and edge detector*)
+    tick: [12] BIT;
+    bitcnt: [4] BIT;
+    shreg: BYTE;
+  VAR endtick, midtick, endbit: BIT;
+    limit: [12] BIT;
+BEGIN
+  limit := fsel -> 217 : 1302;
+  endtick := tick = limit;
+  midtick := tick = {0'1, limit[11:1]};   (*limit/2*)
+  endbit := bitcnt = 8;
+  data := shreg;
+  rdy := stat;
+
+  Q0 := RxD; Q1 := Q0;
+  run := (Q1 & ~Q0) | ~(~rst | endtick & endbit) & run;
+  tick := (run & ~endtick) -> tick + 1 : 0;
+  bitcnt := (endtick & ~endbit) -> bitcnt + 1 :
+    (endtick & endbit) -> 0 : bitcnt;
+  shreg := midtick -> {Q1, shreg[7:1]} : shreg;
+  stat := (endtick & endbit) | ~(~rst | done) & stat
+END RS232R.
+
   

people.inf.ethz.ch/wirth/Lola/Sources/RS232T.Lola.txt

@@ -1,23 +1,23 @@
-MODULE RS232T (IN clk, rst: BIT;   (*NW 15.9.2014*)
-  IN start, fsel: BIT;  (*request to send a byte / freq select*)
-  IN data: BYTE; OUT rdy, TxD: BIT);
-  REG (clk) run: BIT;
-    tick: [12] BIT;
-    bitcnt: [4] BIT;
-    shreg: [9] BIT;
-  VAR endtick, endbit: BIT;
-    limit: [12] BIT;
-BEGIN limit := fsel -> 217 : 1302;
-  endtick := tick = limit;
-  endbit := bitcnt = 9;
-  rdy := ~run;
-  TxD := shreg.0;
-
-  run := (~rst | endtick & endbit) -> 0 : start -> 1 : run;
-  tick := (run & ~endtick) -> tick + 1 : 0;
-  bitcnt := (endtick & ~endbit) -> bitcnt + 1 :
-    (endtick & endbit) -> 0'4 : bitcnt;
-  shreg := ~rst -> 1 :
-    start -> {data, 0'1} :
-    endtick -> {1'1, shreg[8:1]} : shreg;
-END RS232T.
+MODULE RS232T (IN clk, rst: BIT;   (*NW 15.9.2014*)
+  IN start, fsel: BIT;  (*request to send a byte / freq select*)
+  IN data: BYTE; OUT rdy, TxD: BIT);
+  REG (clk) run: BIT;
+    tick: [12] BIT;
+    bitcnt: [4] BIT;
+    shreg: [9] BIT;
+  VAR endtick, endbit: BIT;
+    limit: [12] BIT;
+BEGIN limit := fsel -> 217 : 1302;
+  endtick := tick = limit;
+  endbit := bitcnt = 9;
+  rdy := ~run;
+  TxD := shreg.0;
+
+  run := (~rst | endtick & endbit) -> 0 : start -> 1 : run;
+  tick := (run & ~endtick) -> tick + 1 : 0;
+  bitcnt := (endtick & ~endbit) -> bitcnt + 1 :
+    (endtick & endbit) -> 0'4 : bitcnt;
+  shreg := ~rst -> 1 :
+    start -> {data, 0'1} :
+    endtick -> {1'1, shreg[8:1]} : shreg;
+END RS232T.

people.inf.ethz.ch/wirth/Lola/Sources/RightShifter.Lola.txt

@@ -1,16 +1,16 @@
-MODULE RightShifter(    (*NW 11.11.2016*)
-  IN x: WORD; sc: [5] BIT; md: BIT;    (*md = 0 -> rotate; md = 1 -=> arith shift*)
-  OUT y: WORD);
-
-  VAR sc0, sc1: [2] BIT;
-    s1, s2: WORD;
-
-BEGIN sc0 := sc[1:0]; sc1 := sc[3:2];
-  s1 := (sc0 = 3) -> {(md -> x[2:0] : {x.31 ! 3}), x[31:3]} :
-      (sc0 = 2) -> {(md -> x[1:0] : {x.31 ! 2}), x[31:2]} :
-      (sc0 = 1) -> {(md -> x.0 : x.31), x[31:1]} : x;
-  s2 := (sc1 = 3) -> {(md -> s1[11:0] : {x.31 ! 12}), s1[31:12]} :
-      (sc1 = 2) -> {(md -> s1[7:0] : {x.31 ! 8}), s1[31:8]} :
-      (sc1 = 1) -> {(md -> s1[3:0] : {x.31 ! 4}), s1[31:4]} : s1;
-  y := sc.4 -> {(md -> s2[15:0] : {s2.31 ! 16}), s2[31:16]} : s2;
-END RightShifter.
+MODULE RightShifter(    (*NW 11.11.2016*)
+  IN x: WORD; sc: [5] BIT; md: BIT;    (*md = 0 -> rotate; md = 1 -=> arith shift*)
+  OUT y: WORD);
+
+  VAR sc0, sc1: [2] BIT;
+    s1, s2: WORD;
+
+BEGIN sc0 := sc[1:0]; sc1 := sc[3:2];
+  s1 := (sc0 = 3) -> {(md -> x[2:0] : {x.31 ! 3}), x[31:3]} :
+      (sc0 = 2) -> {(md -> x[1:0] : {x.31 ! 2}), x[31:2]} :
+      (sc0 = 1) -> {(md -> x.0 : x.31), x[31:1]} : x;
+  s2 := (sc1 = 3) -> {(md -> s1[11:0] : {x.31 ! 12}), s1[31:12]} :
+      (sc1 = 2) -> {(md -> s1[7:0] : {x.31 ! 8}), s1[31:8]} :
+      (sc1 = 1) -> {(md -> s1[3:0] : {x.31 ! 4}), s1[31:4]} : s1;
+  y := sc.4 -> {(md -> s2[15:0] : {s2.31 ! 16}), s2[31:16]} : s2;
+END RightShifter.

people.inf.ethz.ch/wirth/Lola/Sources/SPI.Lola.txt

@@ -1,25 +1,25 @@
-MODULE SPI (
-  IN clk, rst, start, fast: BIT; dataTx: WORD;
-  OUT dataRx: WORD; rdy: BIT;
-  IN MISO: BIT;
-  OUT MOSI, SCLK: BIT);
-
-  REG (clk) rdyR: BIT;
-    shreg: WORD;
-    tick: [6] BIT;
-    bitcnt: [5] BIT;
-  VAR endbit, endtick: BIT;
-
-BEGIN endtick := fast -> (tick = 1) : (tick = 63);    (*25 MHz clock*)
-  endbit := fast -> (bitcnt = 31) : (bitcnt = 7);
-  rdy := rdyR;
-  dataRx := fast -> shreg : {0'24, shreg[7:0]};
-  MOSI := (~rst | rdyR) -> 1 : shreg.7;
-  SCLK := (~rst | rdyR) -> 1 : (fast -> tick.0 : tick.5);
-
-  tick := (~rst | rdyR | endtick) -> 0 : tick + 1;
-  rdyR := (~rst | endtick & endbit) | ~start & rdyR;
-  bitcnt := (~rst | start) -> 0 : (endtick & ~endbit) -> bitcnt + 1 : bitcnt;
-  shreg := ~rst -> $FFFFFFFF'32 : start -> dataTx :
-    endtick -> {shreg[30:24], MISO, shreg[22:16], shreg[31], shreg[14:8], shreg[23], shreg[6:0], (fast -> shreg[15] : MISO)} : shreg;
-END SPI.
+MODULE SPI (
+  IN clk, rst, start, fast: BIT; dataTx: WORD;
+  OUT dataRx: WORD; rdy: BIT;
+  IN MISO: BIT;
+  OUT MOSI, SCLK: BIT);
+
+  REG (clk) rdyR: BIT;
+    shreg: WORD;
+    tick: [6] BIT;
+    bitcnt: [5] BIT;
+  VAR endbit, endtick: BIT;
+
+BEGIN endtick := fast -> (tick = 1) : (tick = 63);    (*25 MHz clock*)
+  endbit := fast -> (bitcnt = 31) : (bitcnt = 7);
+  rdy := rdyR;
+  dataRx := fast -> shreg : {0'24, shreg[7:0]};
+  MOSI := (~rst | rdyR) -> 1 : shreg.7;
+  SCLK := (~rst | rdyR) -> 1 : (fast -> tick.0 : tick.5);
+
+  tick := (~rst | rdyR | endtick) -> 0 : tick + 1;
+  rdyR := (~rst | endtick & endbit) | ~start & rdyR;
+  bitcnt := (~rst | start) -> 0 : (endtick & ~endbit) -> bitcnt + 1 : bitcnt;
+  shreg := ~rst -> $FFFFFFFF'32 : start -> dataTx :
+    endtick -> {shreg[30:24], MISO, shreg[22:16], shreg[31], shreg[14:8], shreg[23], shreg[6:0], (fast -> shreg[15] : MISO)} : shreg;
+END SPI.

people.inf.ethz.ch/wirth/Lola/Sources/SmallPrograms.Lola.txt

@@ -1,36 +1,36 @@
-(*  LSC.Compile @    LSV.List Test.Lola.v  *)
-
-MODULE Counter (IN CLK50M, rstIn: BIT;
-  IN swi: BYTE; OUT leds: BYTE);
-REG (CLK50M) rst: BIT;
-  cnt0: [16] BIT;  (*milliseconds*)
-  cnt1: [10] BIT;  (*half seconds*)
-  cnt2: [8] BIT;
-VAR tick0, tick1: BIT;
-  BEGIN leds := swi.7 -> swi :  cnt2;
-  tick0 := (cnt0 = 24999);
-  tick1 := tick0 & (cnt1 = 499);
-  rst := ~rstIn;
-  cnt0 := ~rst -> 0 : tick0 -> 0 : cnt0 + 1;
-  cnt1 := ~rst -> 0 : tick1 -> 0 : cnt1 + tick0;
-  cnt2 := ~rst -> 0 : cnt2 + tick1
-END Counter.
-
-MODULE Shifter(IN CLK50M, rstIn: BIT;
-  IN swi: BYTE; OUT leds: BYTE);
-REG (CLK50M) rst, up: BIT;
-  cnt0: [16] BIT;  (*milliseconds*)
-  cnt1: [10] BIT;  (*half seconds*)
-  shreg: [8] BIT;
-VAR tick0, tick1: BIT;
-BEGIN leds := swi.7 -> swi :  shreg;
-  tick0 := (cnt0 = 24999);
-  tick1 := tick0 & (cnt1 = 499);
-  rst := ~rstIn;
-  cnt0 := ~rst -> 0 : tick0 -> 0 : cnt0 + 1;
-  cnt1 := ~rst -> 0 : tick1 -> 0 : cnt1 + tick0;
-  shreg := ~rst -> 1'8 :
-    ~tick1 -> shreg  :
-    up -> {shreg[6:0], 0'1} : {0'1, shreg[7:1]};
-  up := shreg.0 -> 1 : shreg.7 -> 0 : up
-END Shifter.
+(*  LSC.Compile @    LSV.List Test.Lola.v  *)
+
+MODULE Counter (IN CLK50M, rstIn: BIT;
+  IN swi: BYTE; OUT leds: BYTE);
+REG (CLK50M) rst: BIT;
+  cnt0: [16] BIT;  (*milliseconds*)
+  cnt1: [10] BIT;  (*half seconds*)
+  cnt2: [8] BIT;
+VAR tick0, tick1: BIT;
+  BEGIN leds := swi.7 -> swi :  cnt2;
+  tick0 := (cnt0 = 24999);
+  tick1 := tick0 & (cnt1 = 499);
+  rst := ~rstIn;
+  cnt0 := ~rst -> 0 : tick0 -> 0 : cnt0 + 1;
+  cnt1 := ~rst -> 0 : tick1 -> 0 : cnt1 + tick0;
+  cnt2 := ~rst -> 0 : cnt2 + tick1
+END Counter.
+
+MODULE Shifter(IN CLK50M, rstIn: BIT;
+  IN swi: BYTE; OUT leds: BYTE);
+REG (CLK50M) rst, up: BIT;
+  cnt0: [16] BIT;  (*milliseconds*)
+  cnt1: [10] BIT;  (*half seconds*)
+  shreg: [8] BIT;
+VAR tick0, tick1: BIT;
+BEGIN leds := swi.7 -> swi :  shreg;
+  tick0 := (cnt0 = 24999);
+  tick1 := tick0 & (cnt1 = 499);
+  rst := ~rstIn;
+  cnt0 := ~rst -> 0 : tick0 -> 0 : cnt0 + 1;
+  cnt1 := ~rst -> 0 : tick1 -> 0 : cnt1 + tick0;
+  shreg := ~rst -> 1'8 :
+    ~tick1 -> shreg  :
+    up -> {shreg[6:0], 0'1} : {0'1, shreg[7:1]};
+  up := shreg.0 -> 1 : shreg.7 -> 0 : up
+END Shifter.

people.inf.ethz.ch/wirth/Lola/Sources/VID.Lola.txt

@@ -1,73 +1,73 @@
-MODULE VID (
-  IN clk, inv: BIT;
-    viddata: WORD;
-  OUT  req: BIT;  (*SRAM read request*)
-      vidadr: [18] BIT;
-    hsync, vsync: BIT;  (*to display*)
-    RGB: [3] BIT);
-
-  CONST Org = 37FC0H; (* DFF00: adr of vcnt=1023 *)
-  TYPE DCMX3 = MODULE (IN CLKIN: BIT; OUT CLKFX: BIT) ^;
-  VAR hend, vend, vblank, xfer, vid, pclk: BIT;
-    dcmx3: DCMX3;
-  REG (pclk) hcnt: [11] BIT;
-      vcnt: [10] BIT;
-    hblank: BIT;
-    pixbuf, vidbuf: WORD;
-  REG (clk) req1: BIT;
-    hword: [5] BIT;  (*from hcnt, but latched in the clk domain*)
-
-BEGIN dcmx3 (clk, pclk);  (* pixel clock generation *)
-  hend := (hcnt = 1343); vend := (vcnt = 801);
-  vblank := (vcnt.8 & vcnt.9);   (*vcnt >= 768*)
-  hsync := ~((hcnt >= 1086) & (hcnt < 1190));   (*-ve polarity*)
-  vsync := (vcnt >= 771) & (vcnt < 776);   (*+ve polarity*)
-  xfer := (hcnt[4:0] = 6'5);   (*data delay > hcnt cycle + req cycle*)
-  vid := (pixbuf.0 ^ inv) & ~hblank & ~ vblank;
-  RGB := {vid, vid, vid};
-  vidadr := Org + {0'3, ~vcnt, hword};
-(*on pclk:*)  
-  hcnt := hend -> 0 : hcnt + 1;
-  vcnt := hend -> (vend -> 0 : vcnt + 1) : vcnt;
-  hblank := xfer -> hcnt.10 : hblank;  (*hcnt >= 1024*)
-  pixbuf := xfer -> vidbuf : {0'1, pixbuf[31:1]};
-(*on clk:*)
-  hword := hcnt[9:5];
-  req := req1; req1 := ~vblank & ~hcnt.10 & (hcnt.5 ^ hword.0);
-  vidbuf := req -> viddata : vidbuf
-END VID.
-
-MODULE VID (
-  IN clk, inv: BIT;
-    viddata: WORD;
-  OUT  req: BIT;   (*SRAM read request*)
-    vidadr: [18] BIT;
-    hsync, vsync: BIT;
-    RGB: [3] BIT);
-
-  CONST Org := 0DFF00H;
-  REG (clk) hcnt, vcnt: [10] BIT;
-    buffer: WORD;  (*from hcnt, but latched in the clk domain*)
-    hblank1: BIT;
-  VAR hend, vend, hblank, vblank, pixel, vid: BIT;
-    
-BEGIN (*25MHz clock; 2 pixels per cycle*)
-  hend := (hcnt = 591);
-  vend := (vcnt = 791);
-  hblank := hcnt.9;  (*hcnt = 512*)
-  vblank := vcnt.8 & vcnt.9;  (*vcnt >= 768*)
-  hsync := (hcnt >= 537) & (hcnt < 553);
-  vsync := ~((vcnt >= 772) & (vcnt < 776));
-
-  vidadr := {0'3, ~vcnt, hcnt[8:4]} + 37FC0H'18;
-  req := ~vblank & ~hcnt.9 & (hcnt[3:0] = 0'4);
-  pixel := clk -> buffer.0 : buffer.1;
-  vid := (pixel ^ inv) & ~hblank1 & ~vblank;
-  RGB := {vid, vid, vid};
-
-  hcnt := hend -> 0 : hcnt+1;
-  vcnt := hend -> (vend -> 0 : vcnt+1) : vcnt;
-  hblank1 := hblank;
-  buffer := req -> viddata : {0'2, buffer[31:2]}
-END VID.
-
+MODULE VID (
+  IN clk, inv: BIT;
+    viddata: WORD;
+  OUT  req: BIT;  (*SRAM read request*)
+      vidadr: [18] BIT;
+    hsync, vsync: BIT;  (*to display*)
+    RGB: [3] BIT);
+
+  CONST Org = 37FC0H; (* DFF00: adr of vcnt=1023 *)
+  TYPE DCMX3 = MODULE (IN CLKIN: BIT; OUT CLKFX: BIT) ^;
+  VAR hend, vend, vblank, xfer, vid, pclk: BIT;
+    dcmx3: DCMX3;
+  REG (pclk) hcnt: [11] BIT;
+      vcnt: [10] BIT;
+    hblank: BIT;
+    pixbuf, vidbuf: WORD;
+  REG (clk) req1: BIT;
+    hword: [5] BIT;  (*from hcnt, but latched in the clk domain*)
+
+BEGIN dcmx3 (clk, pclk);  (* pixel clock generation *)
+  hend := (hcnt = 1343); vend := (vcnt = 801);
+  vblank := (vcnt.8 & vcnt.9);   (*vcnt >= 768*)
+  hsync := ~((hcnt >= 1086) & (hcnt < 1190));   (*-ve polarity*)
+  vsync := (vcnt >= 771) & (vcnt < 776);   (*+ve polarity*)
+  xfer := (hcnt[4:0] = 6'5);   (*data delay > hcnt cycle + req cycle*)
+  vid := (pixbuf.0 ^ inv) & ~hblank & ~ vblank;
+  RGB := {vid, vid, vid};
+  vidadr := Org + {0'3, ~vcnt, hword};
+(*on pclk:*)  
+  hcnt := hend -> 0 : hcnt + 1;
+  vcnt := hend -> (vend -> 0 : vcnt + 1) : vcnt;
+  hblank := xfer -> hcnt.10 : hblank;  (*hcnt >= 1024*)
+  pixbuf := xfer -> vidbuf : {0'1, pixbuf[31:1]};
+(*on clk:*)
+  hword := hcnt[9:5];
+  req := req1; req1 := ~vblank & ~hcnt.10 & (hcnt.5 ^ hword.0);
+  vidbuf := req -> viddata : vidbuf
+END VID.
+
+MODULE VID (
+  IN clk, inv: BIT;
+    viddata: WORD;
+  OUT  req: BIT;   (*SRAM read request*)
+    vidadr: [18] BIT;
+    hsync, vsync: BIT;
+    RGB: [3] BIT);
+
+  CONST Org := 0DFF00H;
+  REG (clk) hcnt, vcnt: [10] BIT;
+    buffer: WORD;  (*from hcnt, but latched in the clk domain*)
+    hblank1: BIT;
+  VAR hend, vend, hblank, vblank, pixel, vid: BIT;
+    
+BEGIN (*25MHz clock; 2 pixels per cycle*)
+  hend := (hcnt = 591);
+  vend := (vcnt = 791);
+  hblank := hcnt.9;  (*hcnt = 512*)
+  vblank := vcnt.8 & vcnt.9;  (*vcnt >= 768*)
+  hsync := (hcnt >= 537) & (hcnt < 553);
+  vsync := ~((vcnt >= 772) & (vcnt < 776));
+
+  vidadr := {0'3, ~vcnt, hcnt[8:4]} + 37FC0H'18;
+  req := ~vblank & ~hcnt.9 & (hcnt[3:0] = 0'4);
+  pixel := clk -> buffer.0 : buffer.1;
+  vid := (pixel ^ inv) & ~hblank1 & ~vblank;
+  RGB := {vid, vid, vid};
+
+  hcnt := hend -> 0 : hcnt+1;
+  vcnt := hend -> (vend -> 0 : vcnt+1) : vcnt;
+  hblank1 := hblank;
+  buffer := req -> viddata : {0'2, buffer[31:2]}
+END VID.
+

people.inf.ethz.ch/wirth/Lola/index.html

@@ -1,60 +1,60 @@
-<HTML>
-<HEAD>
-   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
-   <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
-   <TITLE>Lola-2: A Logic Description Language</TITLE>
-</HEAD>
-<BODY>
-
-<H1>
-Lola-2: A Logic Description Language</H1>
-
-	<UL>
-			<LI> <A HREF="Lola2.pdf">Lola-2: A Logic Description Language</A> 
-			<BR>&nbsp;
-				
-			<LI> <A HREF="LolaCompiler.pdf">Translating from Lola to Verilog</A>
-			<BR>&nbsp;
-			
-			
-	</UL>
-<HR>
-<P>Lola Compiler for Project Oberon, 2013 Edition</P>
-&nbsp;&nbsp;
-  <A HREF="Sources/LSS.Mod.txt">LSS.Mod</A>
-  <A HREF="Sources/LSB.Mod.txt">LSB.Mod</A>
-  <A HREF="Sources/LSP.Mod.txt">LSP.Mod</A>
-  <A HREF="Sources/LSC.Mod.txt">LSC.Mod</A>
-  <A HREF="Sources/LSV.Mod.txt">LSV.Mod</A><BR><BR>
-&nbsp;&nbsp;
-  <A HREF="Sources/SmallPrograms.Lola.txt">SmallPrograms.Lola</A>
-<P></P><BR>
-<HR>
-<P>Lola Definition of RISC5 Computer</P>
-&nbsp;&nbsp;
-  <A HREF="Sources/RISC5.Lola.txt">RISC5.Lola</A>
-  <A HREF="Sources/LeftShifter.Lola.txt">LeftShifter.Lola</A>
-  <A HREF="Sources/RightShifter.Lola.txt">RightShifter.Lola</A>
-  <A HREF="Sources/Multiplier.Lola.txt">Multiplier.Lola</A>
-  <A HREF="Sources/Divider.Lola.txt">Divider.Lola</A><BR>
-&nbsp;&nbsp;
-  <A HREF="Sources/FPAdder.Lola.txt">FPAdder.Lola</A>
-  <A HREF="Sources/FPMultiplier.Lola.txt">FPMultiplier.Lola</A>
-  <A HREF="Sources/FPDivider.Lola.txt">FPDivider.Lola</A><BR><BR>
-&nbsp;&nbsp;
-  <A HREF="Sources/RISC5Top.Lola.txt">RISC5Top.Lola</A>
-  <A HREF="Sources/PS2.Lola.txt">PS2.Lola</A>
-  <A HREF="Sources/MouseP.Lola.txt">MouseP.Lola</A>
-  <A HREF="Sources/RS232R.Lola.txt">RS232R.Lola</A>
-  <A HREF="Sources/RS232T.Lola.txt">RS232T.Lola</A>
-  <A HREF="Sources/SPI.Lola.txt">SPI.Lola</A>
-  <A HREF="Sources/VID.Lola.txt">VID.Lola</A><BR><BR>
-&nbsp;&nbsp;
-  <A HREF="Sources/DCMX3.v">DCMX3.v</A>
-<P></P><BR>
-<HR>
-<P>
-Back to my <A HREF="../index.html">home page</A>.
-
-</BODY>
-</HTML>
+<HTML>
+<HEAD>
+   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+   <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
+   <TITLE>Lola-2: A Logic Description Language</TITLE>
+</HEAD>
+<BODY>
+
+<H1>
+Lola-2: A Logic Description Language</H1>
+
+	<UL>
+			<LI> <A HREF="Lola2.pdf">Lola-2: A Logic Description Language</A> 
+			<BR>&nbsp;
+				
+			<LI> <A HREF="LolaCompiler.pdf">Translating from Lola to Verilog</A>
+			<BR>&nbsp;
+			
+			
+	</UL>
+<HR>
+<P>Lola Compiler for Project Oberon, 2013 Edition</P>
+&nbsp;&nbsp;
+  <A HREF="Sources/LSS.Mod.txt">LSS.Mod</A>
+  <A HREF="Sources/LSB.Mod.txt">LSB.Mod</A>
+  <A HREF="Sources/LSP.Mod.txt">LSP.Mod</A>
+  <A HREF="Sources/LSC.Mod.txt">LSC.Mod</A>
+  <A HREF="Sources/LSV.Mod.txt">LSV.Mod</A><BR><BR>
+&nbsp;&nbsp;
+  <A HREF="Sources/SmallPrograms.Lola.txt">SmallPrograms.Lola</A>
+<P></P><BR>
+<HR>
+<P>Lola Definition of RISC5 Computer</P>
+&nbsp;&nbsp;
+  <A HREF="Sources/RISC5.Lola.txt">RISC5.Lola</A>
+  <A HREF="Sources/LeftShifter.Lola.txt">LeftShifter.Lola</A>
+  <A HREF="Sources/RightShifter.Lola.txt">RightShifter.Lola</A>
+  <A HREF="Sources/Multiplier.Lola.txt">Multiplier.Lola</A>
+  <A HREF="Sources/Divider.Lola.txt">Divider.Lola</A><BR>
+&nbsp;&nbsp;
+  <A HREF="Sources/FPAdder.Lola.txt">FPAdder.Lola</A>
+  <A HREF="Sources/FPMultiplier.Lola.txt">FPMultiplier.Lola</A>
+  <A HREF="Sources/FPDivider.Lola.txt">FPDivider.Lola</A><BR><BR>
+&nbsp;&nbsp;
+  <A HREF="Sources/RISC5Top.Lola.txt">RISC5Top.Lola</A>
+  <A HREF="Sources/PS2.Lola.txt">PS2.Lola</A>
+  <A HREF="Sources/MouseP.Lola.txt">MouseP.Lola</A>
+  <A HREF="Sources/RS232R.Lola.txt">RS232R.Lola</A>
+  <A HREF="Sources/RS232T.Lola.txt">RS232T.Lola</A>
+  <A HREF="Sources/SPI.Lola.txt">SPI.Lola</A>
+  <A HREF="Sources/VID.Lola.txt">VID.Lola</A><BR><BR>
+&nbsp;&nbsp;
+  <A HREF="Sources/DCMX3.v">DCMX3.v</A>
+<P></P><BR>
+<HR>
+<P>
+Back to my <A HREF="../index.html">home page</A>.
+
+</BODY>
+</HTML>

people.inf.ethz.ch/wirth/Miscellaneous/index.html

@@ -1,27 +1,27 @@
-<HTML>
-<HEAD>
-   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
-   <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
-   <TITLE>Miscellaneous topics</TITLE>
-</HEAD>
-<BODY>
-
-<H1>
-Miscellaneous topics</H1>
-<UL>
-  <LI><A HREF="Styles.pdf">On Programming Styles</A><BR>&nbsp;
-  <LI><A HREF="PLD.pdf">Programmable Logic Devices and the crux of growing complexity </A><BR>&nbsp;
-  <LI><A HREF="CounterShifter.pdf">A triptychon of digital circuits </A><BR>&nbsp;
-  <LI><A HREF="Division.pdf">Implementing division on a computer without division </A><BR>&nbsp;
-  <LI><A HREF="IEEE-Annals.pdf">A brief history of Software Engineering </A><BR>&nbsp;
-  <LI><A HREF="Informatika2008.pdf">The Year of Informatics</A><BR>&nbsp;
-  <LI><A HREF="Informatik68.pdf">40 Jahre Informatik an der ETH</A><BR>&nbsp;
-  <LI><A HREF="Denkplatz.pdf">Was ist ein Denkplatz, und warum erstreben wir ihn?</A><BR>&nbsp;
-  <LI><A HREF="ComputersAndComputing.pdf">Computers and Computing</A><BR>&nbsp;
-</UL>
-<HR>
-<P>
-Back to my <A HREF="../index.html">home page</A>.
-</BODY>
-</HTML>
-
+<HTML>
+<HEAD>
+   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+   <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
+   <TITLE>Miscellaneous topics</TITLE>
+</HEAD>
+<BODY>
+
+<H1>
+Miscellaneous topics</H1>
+<UL>
+  <LI><A HREF="Styles.pdf">On Programming Styles</A><BR>&nbsp;
+  <LI><A HREF="PLD.pdf">Programmable Logic Devices and the crux of growing complexity </A><BR>&nbsp;
+  <LI><A HREF="CounterShifter.pdf">A triptychon of digital circuits </A><BR>&nbsp;
+  <LI><A HREF="Division.pdf">Implementing division on a computer without division </A><BR>&nbsp;
+  <LI><A HREF="IEEE-Annals.pdf">A brief history of Software Engineering </A><BR>&nbsp;
+  <LI><A HREF="Informatika2008.pdf">The Year of Informatics</A><BR>&nbsp;
+  <LI><A HREF="Informatik68.pdf">40 Jahre Informatik an der ETH</A><BR>&nbsp;
+  <LI><A HREF="Denkplatz.pdf">Was ist ein Denkplatz, und warum erstreben wir ihn?</A><BR>&nbsp;
+  <LI><A HREF="ComputersAndComputing.pdf">Computers and Computing</A><BR>&nbsp;
+</UL>
+<HR>
+<P>
+Back to my <A HREF="../index.html">home page</A>.
+</BODY>
+</HTML>
+

people.inf.ethz.ch/wirth/Oberon/index.html

@@ -1,66 +1,66 @@
-<HTML>
-<HEAD>
-   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
-   <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
-   <TITLE>Oberon</TITLE>
-</HEAD>
-<BODY>
-
-<H1>Oberon</H1>
-
-	<UL>
-							
-			<LI> <A HREF="OberonAtAGlance.pdf"> Oberon at a Glance</A> 
-			<BR>&nbsp;
-			
-			<LI> <A HREF="PIO.pdf"> Programming in Oberon (a Tutorial) </A> 
-			<BR>&nbsp;
-			
-			<LI> <A HREF="Oberon.Report.pdf"> The Programming Language Oberon (1990)</A> 
-			<BR>&nbsp;
-
-			<LI> <A HREF="Oberon07.Report.pdf"> The Programming Language Oberon-07 (Revised Oberon)</A> 
-			<BR>&nbsp;
-					
-			<LI> <A HREF="Oberon07.pdf"> Difference between Oberon-07 and Oberon</A>
-			<BR>&nbsp;
-					
-			<LI> <A HREF="Oberon.ARM.Compiler.pdf"> An Oberon Compiler for the ARM Processor</A>
-			<BR>&nbsp;
-					
-			<LI> <A HREF="Interrupts.pdf"> Interrupts and Traps in Oberon-ARM</A>
-			<BR>&nbsp;
-					
-		    <LI> <A HREF="PortingOberon.pdf"> Porting the Oberon Compiler from Oberon to Oberon-07</A> 
-		    <BR>&nbsp;
-					
-		    	<LI> <A HREF="SETs.pdf"> SET: A neglected data type and its compilation for the ARM</A>
-		    	<BR>&nbsp;
-				
-	</UL>
-	
-<H1>
-Related documents </H1>
-
-	<UL>
-			<LI> <A HREF="284.pdf"> A Computer System for Model Helicopter Flight Control Technical Memo, 
-						Technical Reports 284, ETH Z&uuml;rich, Institute of Computer Systems, 01 1998.</A> 
-			<BR>&nbsp;
-				
-			<LI> <A HREF="285.pdf">A Computer System for Model Helicopter Flight Control, 
-					Technical Reports 285, ETH Z&uuml;rich, Institute of Computer Systems, 03 1999.</A> 
-			<BR>&nbsp;
-				
-			<LI> <A HREF="286.pdf"> Hardware Compilation, 
-							Technical Reports 286, ETH Z&uuml;rich, Institute of Computer Systems, 01 1998.</A> 
-			<BR>&nbsp;
-				
-	</UL>
-
-</BODY>
-
-<HR>
-<P>
-Back to my <A HREF="../index.html">home page</A>.
-
-</HTML>
+<HTML>
+<HEAD>
+   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+   <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
+   <TITLE>Oberon</TITLE>
+</HEAD>
+<BODY>
+
+<H1>Oberon</H1>
+
+	<UL>
+							
+			<LI> <A HREF="OberonAtAGlance.pdf"> Oberon at a Glance</A> 
+			<BR>&nbsp;
+			
+			<LI> <A HREF="PIO.pdf"> Programming in Oberon (a Tutorial) </A> 
+			<BR>&nbsp;
+			
+			<LI> <A HREF="Oberon.Report.pdf"> The Programming Language Oberon (1990)</A> 
+			<BR>&nbsp;
+
+			<LI> <A HREF="Oberon07.Report.pdf"> The Programming Language Oberon-07 (Revised Oberon)</A> 
+			<BR>&nbsp;
+					
+			<LI> <A HREF="Oberon07.pdf"> Difference between Oberon-07 and Oberon</A>
+			<BR>&nbsp;
+					
+			<LI> <A HREF="Oberon.ARM.Compiler.pdf"> An Oberon Compiler for the ARM Processor</A>
+			<BR>&nbsp;
+					
+			<LI> <A HREF="Interrupts.pdf"> Interrupts and Traps in Oberon-ARM</A>
+			<BR>&nbsp;
+					
+		    <LI> <A HREF="PortingOberon.pdf"> Porting the Oberon Compiler from Oberon to Oberon-07</A> 
+		    <BR>&nbsp;
+					
+		    	<LI> <A HREF="SETs.pdf"> SET: A neglected data type and its compilation for the ARM</A>
+		    	<BR>&nbsp;
+				
+	</UL>
+	
+<H1>
+Related documents </H1>
+
+	<UL>
+			<LI> <A HREF="284.pdf"> A Computer System for Model Helicopter Flight Control Technical Memo, 
+						Technical Reports 284, ETH Z&uuml;rich, Institute of Computer Systems, 01 1998.</A> 
+			<BR>&nbsp;
+				
+			<LI> <A HREF="285.pdf">A Computer System for Model Helicopter Flight Control, 
+					Technical Reports 285, ETH Z&uuml;rich, Institute of Computer Systems, 03 1999.</A> 
+			<BR>&nbsp;
+				
+			<LI> <A HREF="286.pdf"> Hardware Compilation, 
+							Technical Reports 286, ETH Z&uuml;rich, Institute of Computer Systems, 01 1998.</A> 
+			<BR>&nbsp;
+				
+	</UL>
+
+</BODY>
+
+<HR>
+<P>
+Back to my <A HREF="../index.html">home page</A>.
+
+</HTML>

people.inf.ethz.ch/wirth/PICL/Sources/PICL.Mod.txt

@@ -1,581 +1,581 @@
-MODULE PICL;  (*NW 22.2.2005 / 16.10.2014*)
-  IMPORT Texts, Oberon, PICS, SYSTEM;
-
-  CONST var = 1; con = 2; proc = 3;   (*item forms*)
-    intT = 1; setT = 2; boolT = 3;    (*types*)
-    gpio= -32; gpoc = -28;  (*general-purpose, 2-bit I/O data and output control*)
-
-    (*symbols*) null = 0;
-    ast = 1; slash = 2; plus = 3; minus = 4; not = 5; and = 6; or = 7;
-    eql = 10; neq = 11; geq = 12; lss = 13; leq = 14; gtr = 15;
-    period = 16; comma = 17; colon = 18; 
-    op = 20; query = 21; lparen = 22; becomes = 23;
-    ident = 24; if = 25; while = 26; repeat = 27;
-    inc = 28; dec = 29; rol = 30; ror = 31;
-    number = 32; rparen = 33; then = 34; do =  35;
-    semicolon = 36; end = 37; else = 38 ; elsif =  39; until =  40; return = 41;
-    int = 42; set = 43; bool = 44;
-    const = 50; begin = 51; proced = 52; module = 53; eof = 54;
-
-  TYPE Object = POINTER TO ObjDesc;
-    ObjDesc = RECORD
-        name: ARRAY PICS.IdLen OF CHAR;
-        form, typ, ptyp, a: INTEGER;
-        next: Object
-      END ;
-
-    OpCode = ARRAY 8 OF CHAR;
-
-  VAR sym: INTEGER;  (*last symbol read by scanner*)
-    IdList, IdList0, undef: Object;
-    pc, dc: INTEGER;
-    error: BOOLEAN;
-    errpos: INTEGER;
-    Statement: PROCEDURE;
-    W: Texts.Writer;
-    code: ARRAY 1024 OF INTEGER;
-
-    table0, table3: ARRAY 16 OF OpCode;  (*for decoding only*)
-    table1: ARRAY 4 OF OpCode;
-    table2: ARRAY 2 OF OpCode;
-
-  PROCEDURE Mark(num: INTEGER);
-    VAR p: INTEGER;
-  BEGIN p := PICS.position();
-    IF p > errpos+2 THEN
-      Texts.WriteString(W, "  pos "); Texts.WriteInt(W, p, 1);
-      Texts.WriteString(W, "  err "); Texts.WriteInt(W, num, 1);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END ;
-    errpos := p; error := TRUE
-  END Mark;
-
-  PROCEDURE this(id: ARRAY OF CHAR): Object;
-    VAR obj: Object;
-  BEGIN obj := IdList;
-    WHILE (obj # NIL) & (obj.name # id) DO obj := obj.next END ;
-    IF obj = NIL THEN Mark(0); obj := undef END ;
-    RETURN obj
-  END this;
-
-  PROCEDURE enter(id: ARRAY OF CHAR; form, typ, a: INTEGER);
-    VAR obj: Object;
-  BEGIN NEW(obj); obj.name := id; obj.form := form; obj.typ := typ; obj.a := a;
-    obj.next := IdList; IdList := obj
-  END enter;
-
-  PROCEDURE emit(op, a: INTEGER);
-  BEGIN code[pc] := op*100H + a; INC(pc)
-  END emit;
-
-  PROCEDURE emit1(op, n, a: INTEGER);
-  BEGIN code[pc] := ((op+4)*8 + n) * 80H + a; INC(pc)
-  END emit1;
-
-  PROCEDURE index(VAR n: INTEGER);
-  BEGIN n := 0;
-    IF sym = period THEN
-      PICS.Get(sym);
-      IF sym = number THEN n := PICS.val; PICS.Get(sym) ELSE Mark(11) END
-    END
-  END index;
-
-  PROCEDURE expression;
-    VAR x, y: Object; op, xf, xt, xval, yt, yval: INTEGER;
-  BEGIN xval := 0;
-    IF sym = ident THEN x := this(PICS.id); xf := x.form; xt := x.typ; xval := x.a; PICS.Get(sym)
-    ELSIF sym = number THEN xf := con; xval := PICS.val; xt := PICS.typ; PICS.Get(sym)
-    ELSE Mark(10)
-    END ;
-    IF sym = lparen THEN  (*function call*)
-      PICS.Get(sym);
-      IF x.form # proc THEN Mark(3) END ;
-      IF sym # rparen THEN expression END ;
-      emit(20H, x.a);   (*CALL x*)
-      IF sym = rparen THEN PICS.Get(sym) ELSE Mark(8) END
-    ELSIF (sym >= ast) & (sym <= minus) THEN
-      op := sym; PICS.Get(sym); yval := 0;;
-      IF sym = ident THEN
-        y := this(PICS.id); yt := y.typ; PICS.Get(sym);
-        IF y.form = var THEN emit(8, y.a)    (*MOVFW y*)
-        ELSIF y.form = con THEN emit(30H, y.a)   (*MOVLW y*)
-        ELSE Mark(10)
-        END
-      ELSIF sym = number THEN
-        yval := PICS.val; yt := PICS.typ; emit(30H, yval); PICS.Get(sym)
-      END ;
-      IF xt # yt THEN Mark(111) END ;
-      IF xf = var THEN
-        IF op = plus THEN
-          IF xt = intT THEN emit(7, x.a) ELSE emit(4, x.a) END   (*ADDFW/IORFW*)
-        ELSIF op = minus THEN
-          IF xt = intT THEN emit(2, x.a) ELSE emit(6, x.a) END   (*SUBFW/XORFW*)
-        ELSIF op = ast THEN
-          IF xt = intT THEN Mark(11) ELSE emit(5, x.a) END   (*ANDFW*)
-        END
-      ELSIF xf = con THEN
-        IF op = plus THEN
-          IF xt = intT THEN emit(3EH, xval) ELSE emit(38H, xval) END   (*ADDLW/IORLW*)
-        ELSIF op = minus THEN
-          IF xt = intT THEN emit(3CH, xval) ELSE emit(3AH, xval) END   (*SUBLW/XORLW*)
-        ELSIF op = ast THEN
-          IF xt = intT THEN Mark(11) ELSE emit(39H, xval) END   (*ANDLW*)
-        ELSE Mark(9)
-        END
-      ELSE Mark(10)
-      END
-    ELSIF xf = var THEN emit(8, x.a);    (*MOVFW x*)
-    ELSIF xf = con THEN emit(30H, xval)
-    ELSE Mark(10)
-    END
-  END expression;
-
-  PROCEDURE term;
-    VAR x, y: Object; n, rel, yf, ya: INTEGER;
-  BEGIN
-    IF sym = ident THEN
-      x := this(PICS.id); PICS.Get(sym);
-      IF (sym >= eql) & (sym <= gtr) THEN
-        rel := sym; PICS.Get(sym);
-        IF sym = ident THEN y := this(PICS.id); PICS.Get(sym); yf := y.form; ya := y.a;
-        ELSIF sym = number THEN yf := con; ya := PICS.val; PICS.Get(sym)
-        END ;
-        IF rel < leq THEN  (* eql neq geq lss:  x-y*)
-          IF yf = var THEN emit(8, ya); emit(2, x.a)   (*MOVFW y  SUBFW x*)
-          ELSIF yf = con THEN
-            IF ya = 0 THEN emit(8, x.a)    (*MOVLW x*)
-            ELSE emit(30H, ya); emit(2, x.a)   (*MOVLW y  SUBFW x*)
-            END
-          END
-        ELSE  (* leq gtr:   y-x*)
-          emit(8, x.a);   (*MOVFW x*)
-          IF yf = var THEN emit(2, ya)   (*SUBFW y*)
-          ELSIF (yf = con) & (ya # 0) THEN emit(60, ya)   (*SUBLW y*)
-          END
-        END ;
-        IF rel = eql THEN emit1(3, 2, 3)     (*BTFSS S.Z*)
-        ELSIF rel = neq THEN emit1(2, 2, 3)  (*BTFSC S.Z*)
-        ELSIF (rel = geq) OR (rel = leq) THEN emit1(3, 0, 3)  (*BTFSS S.C*)
-        ELSIF (rel = lss) OR( rel = gtr) THEN emit1(2, 0, 3)  (*BTFSC S.C*)
-        END
-      ELSE index(n); emit1(3, n, x.a)  (*BTFSC n, x*)
-      END
-    ELSIF sym = not THEN
-      PICS.Get(sym);
-      IF sym = ident THEN
-        x := this(PICS.id); PICS.Get(sym);
-        index(n); emit1(2, n, x.a)  (*BTFSS n, x*)
-      ELSE Mark(10)
-      END
-    ELSE Mark(10)
-    END
-  END term;
-
-  PROCEDURE condition(VAR link: INTEGER);
-    VAR L, L0, L1: INTEGER;
-  BEGIN term; code[pc] := 0; L := pc; INC(pc);
-    IF sym = and THEN
-      REPEAT PICS.Get(sym); term; code[pc] := L; L := pc; INC(pc)
-      UNTIL sym # and
-    ELSIF sym = or THEN
-      REPEAT PICS.Get(sym); term; code[pc] := L; L := pc; INC(pc)
-      UNTIL sym # or;
-      L0 := code[L]; code[L] := 0;
-      REPEAT (*invert skip sense*)
-        IF code[L0-1] DIV 400H = 6 THEN (*BITFSC*) INC(code[L0-1], 400H)
-        ELSE (*BITFSS*) DEC(code[L0-1], 400H)
-        END ;
-        L1 := code[L0]; code[L0] := pc+2800H; L0 := L1
-      UNTIL L0 = 0
-    END ;
-    link := L
-  END condition;
-
-  PROCEDURE fixup(L, k: INTEGER);
-    VAR L1: INTEGER;
-  BEGIN
-    WHILE L # 0 DO L1 := code[L]; code[L] := k+2800H; L := L1 END
-  END fixup;
- 
-  PROCEDURE StatSeq;
-  BEGIN Statement;
-    WHILE sym = semicolon DO PICS.Get(sym); Statement END
-  END StatSeq;
-  
-  PROCEDURE Guarded(VAR L: INTEGER);
-  BEGIN condition(L);
-    IF sym = then THEN PICS.Get(sym) ELSE Mark(14) END ;
-    StatSeq
-  END Guarded;
-
-  PROCEDURE IfStat;
-    VAR L0, L: INTEGER;
-  BEGIN condition(L);
-    IF sym = then THEN PICS.Get(sym) ELSE Mark(14) END ;
-    StatSeq; L0 := 0; 
-    WHILE sym = elsif DO
-      code[pc] := L0; L0 := pc; INC(pc); fixup(L, pc);
-      PICS.Get(sym); condition(L);
-      IF sym = then THEN PICS.Get(sym) ELSE Mark(14) END ;
-      StatSeq
-    END ;
-    IF sym = else THEN
-      code[pc] := L0; L0 := pc; INC(pc); fixup(L, pc);
-      PICS.Get(sym); StatSeq
-    ELSE fixup(L, pc)
-    END ;
-    IF sym = end THEN PICS.Get(sym) ELSE Mark(15) END ;
-    fixup(L0, pc)
-  END IfStat;
-
-  PROCEDURE WhileStat;
-    VAR L0, L: INTEGER;
-  BEGIN L0 := pc; condition(L);
-    IF sym = do THEN PICS.Get(sym) ELSE Mark(14) END ;
-    StatSeq; emit(28H, L0); fixup(L, pc);
-    WHILE sym = elsif DO
-      PICS.Get(sym); condition(L);
-      IF sym = do THEN PICS.Get(sym) ELSE Mark(14) END ;
-      StatSeq; emit(28H, L0); fixup(L, pc)
-    END ;
-    IF sym = end THEN PICS.Get(sym) ELSE Mark(16) END
-  END WhileStat;
-
-  PROCEDURE RepeatStat;
-    VAR L0, L: INTEGER;
-  BEGIN L0 := pc; StatSeq;
-    IF sym = until THEN
-      PICS.Get(sym); condition(L);  (*try to use DECFSZ*)
-      IF (code[pc-4] DIV 100H = 3) & (code[pc-3] DIV 100H = 8) &
-        (code[pc-2] = 1D03H) & (code[pc-4] MOD 80H = code[pc-3] MOD 100H) THEN
-          INC(code[pc-4], 800H); code[pc-3] := 0; DEC(pc, 2); L := pc-1
-      END ;
-      fixup(L, L0)
-    ELSIF sym = end THEN PICS.Get(sym); emit(28H, L0)
-    ELSE Mark(25)
-    END
-  END RepeatStat;
-
-  PROCEDURE Operand1(cd: INTEGER);
-    VAR x: Object;
-  BEGIN
-    IF sym = ident THEN
-      x := this(PICS.id); PICS.Get(sym);
-      IF x.form # var THEN Mark(2) END ;
-      emit(cd, x.a + 80H)  (*INCF/DECF/RRF/RLF*)
-    ELSE Mark(10)
-    END
-  END Operand1;
-
-  PROCEDURE Operand2(cd: INTEGER);
-    VAR x: Object; op, n: INTEGER;
-  BEGIN
-    IF sym = ident THEN
-      x := this(PICS.id); PICS.Get(sym);
-      IF x.form # var THEN Mark(2) END ;
-      index(n); emit1(cd, n, x.a)  (*BSF/BCF*)
-    ELSE Mark(10)
-    END
-  END Operand2;
-
-  PROCEDURE Statement0;
-    VAR x: Object; w: INTEGER;
-  BEGIN
-    IF sym = ident THEN
-      x := this(PICS.id); PICS.Get(sym);
-      IF sym = becomes THEN
-        PICS.Get(sym);
-        IF x.form # var THEN Mark(2) END ;
-        expression; w := code[pc-1];
-        IF w = 3000H THEN code[pc-1] := x.a + 180H   (*CLR x*)
-        ELSIF (w DIV 100H <= 13) & (w MOD 100H = x.a) THEN INC(code[pc-1], 80H)
-        ELSE emit(0, x.a + 80H)   (*MOVWF*)
-        END
-      ELSE (*proc call*)
-        IF x.form # proc THEN Mark(3) END ;
-        IF sym = lparen THEN
-          PICS.Get(sym); expression; emit(20H, x.a);   (*CALL*)
-          IF sym = rparen THEN PICS.Get(sym) ELSE Mark(8) END
-        ELSE
-          emit(20H, x.a)   (*CALL*)
-        END
-      END
-    ELSIF sym = inc THEN PICS.Get(sym); Operand1(10)   (*INCF*)
-    ELSIF sym = dec THEN PICS.Get(sym); Operand1(3)   (*DECF*)
-    ELSIF sym = rol THEN PICS.Get(sym); Operand1(13)   (*RLF*)
-    ELSIF sym = ror THEN PICS.Get(sym); Operand1(12)   (*RRF*)
-    ELSIF sym = op THEN PICS.Get(sym);
-      IF sym = not THEN PICS.Get(sym); Operand2(0)   (*BCF*)
-      ELSE Operand2(1)    (*BSF*)
-      END ;
-    ELSIF sym = query THEN PICS.Get(sym);
-      IF sym = not THEN PICS.Get(sym); Operand2(2) ELSE Operand2(3) END ;
-      emit(28H, pc-1)   (*BTFSS/BTFSC*)
-    ELSIF sym = lparen THEN
-      PICS.Get(sym); StatSeq;
-      IF sym = rparen THEN PICS.Get(sym) ELSE Mark(8) END
-    ELSIF sym = if THEN PICS.Get(sym); IfStat
-    ELSIF sym = while THEN PICS.Get(sym); WhileStat
-    ELSIF sym = repeat THEN PICS.Get(sym); RepeatStat
-    END
-  END Statement0;
-
-  PROCEDURE ProcDecl;
-    VAR typ, partyp, restyp, pc0: INTEGER;
-      obj, res: Object;
-      name: ARRAY 32 OF CHAR;
-  BEGIN obj := IdList; partyp := 0; restyp := 0; pc0 := pc;
-    IF sym = ident THEN name := PICS.id; PICS.Get(sym) ELSE Mark(10) END ;
-    IF sym = lparen THEN (*parameter*)
-      PICS.Get(sym);
-      IF (sym >= int) & (sym <= bool) THEN
-        partyp := sym - int + 1; PICS.Get(sym);
-        IF sym = ident THEN enter(PICS.id, var, partyp, dc); PICS.Get(sym); emit(0, dc+80H); INC(dc)
-        ELSE Mark(10)
-        END
-      END ;
-      IF sym = rparen THEN PICS.Get(sym) ELSE Mark(8) END
-    END ;
-    IF sym = colon THEN  (*result type*)
-      PICS.Get(sym);
-      IF (sym >= int) & (sym <= bool) THEN restyp := sym - int + 1; PICS.Get(sym);
-      ELSE Mark(10)
-      END
-    END ;
-    IF sym = semicolon THEN PICS.Get(sym) ELSE Mark(20) END ;
-    WHILE (sym >= int) & (sym <= bool) DO  (*variable declarations*)
-      typ := sym - int + 1; PICS.Get(sym);
-      WHILE sym = ident DO
-        enter(PICS.id, var, typ, dc); INC(dc); PICS.Get(sym);
-        IF sym = comma THEN PICS.Get(sym) END
-      END ;
-      IF sym = semicolon THEN PICS.Get(sym) ELSE Mark(20) END ;
-    END ;
-    IF sym = begin THEN PICS.Get(sym); StatSeq ELSE Mark(21) END ;
-    IF sym = return THEN PICS.Get(sym); expression END ;
-    emit(0, 8);  (*RET*)
-    IF sym = end THEN PICS.Get(sym);
-      IF sym = ident THEN
-        IF PICS.id # name THEN Mark(22) END ;
-        PICS.Get(sym)
-      ELSE Mark(10)
-      END
-    ELSE Mark(18)
-    END ;
-    IF sym = semicolon THEN PICS.Get(sym) ELSE Mark(20) END ;
-    IdList := obj;    (*reset scope*)
-    enter(name, proc, restyp, pc0); IdList.ptyp := partyp
-  END ProcDecl;
-
-  PROCEDURE Module;
-    VAR typ: INTEGER; name: ARRAY PICS.IdLen OF CHAR;
-  BEGIN name[0] := 0X;
-    IF sym = module THEN
-      PICS.Get(sym);
-      IF sym = ident THEN name := PICS.id; PICS.Get(sym) ELSE Mark(10) END ;
-      IF sym = semicolon THEN PICS.Get(sym) ELSE Mark(20) END ;
-    END ;
-    Texts.WriteString(W, "PIC compiling "); Texts.WriteString(W, name); Texts.WriteLn(W);
-    IF sym = const THEN
-      PICS.Get(sym);
-      WHILE sym = ident DO
-        enter(PICS.id, 2, 1, 0); PICS.Get(sym);
-        IF sym = eql THEN
-          PICS.Get(sym);
-          IF sym = number THEN IdList.a := PICS.val; PICS.Get(sym) ELSE Mark(10) END
-        ELSE Mark(5)
-        END ;
-        IF sym = semicolon THEN PICS.Get(sym) ELSE Mark(20) END
-      END
-    END ;
-    WHILE (sym >= int) & (sym <= bool) DO
-      typ := sym - int + 1; PICS.Get(sym);
-      WHILE sym = ident DO
-        enter(PICS.id, var, typ, dc); INC(dc); PICS.Get(sym);
-        IF sym = comma THEN PICS.Get(sym) END
-      END ;
-      IF sym = semicolon THEN PICS.Get(sym) END
-    END ;
-    WHILE sym = proced DO PICS.Get(sym); ProcDecl END ;
-    IF pc > 1 THEN code[0] := pc + 2800H ELSE pc := 0 END ;
-    IF sym = begin THEN PICS.Get(sym); StatSeq END ;
-    IF sym = end THEN PICS.Get(sym);
-      IF PICS.id # name THEN Mark(22) END
-    ELSE Mark(18) 
-    END ;
-    Texts.WriteInt(W, pc, 5); Texts.WriteLn(W)
-  END Module;
-
-  PROCEDURE Compile*;
-    VAR i, u, v: INTEGER; obj: Object;
-      T: Texts.Text;
-      beg, end, time: INTEGER;
-  BEGIN Oberon.GetSelection(T, beg, end, time);
-    IF time >= 0 THEN
-      IdList := IdList0; PICS.Init(T, beg); pc := 1; dc := 12; error := FALSE; errpos := 0;
-      PICS.Get(sym); Module;
-      Texts.Append(Oberon.Log, W.buf)
-    END
-  END Compile;
-
-  PROCEDURE Decode*;
-    VAR i, u, v: INTEGER; obj: Object;
-  BEGIN obj := IdList;
-      WHILE obj # IdList0 DO
-        Texts.WriteInt(W, obj.form, 4); Texts.WriteInt(W, obj.typ, 4); Texts.WriteInt(W, obj.a, 4);
-        Texts.Write(W, " "); Texts.WriteString(W, obj.name); Texts.WriteLn(W);
-        obj := obj.next
-      END ;
-      Texts.Append(Oberon.Log, W.buf);
-      FOR i := 0 TO pc-1 DO
-        Texts.WriteInt(W, i, 4); u := code[i]; Texts.WriteHex(W, u); Texts.Write(W, " ");
-        v := u DIV 1000H; u := u MOD 1000H;
-        IF v = 0 THEN
-          IF u = 8 THEN Texts.WriteString(W, "RET"); Texts.WriteLn(W)
-          ELSE Texts.WriteString(W, table0[u DIV 100H]);
-            Texts.WriteInt(W, u DIV 80H MOD 2, 3); Texts.WriteInt(W, u MOD 80H, 4)
-          END
-        ELSIF v = 1 THEN
-          Texts.WriteString(W, table1[u DIV 400H]);
-          Texts.WriteInt(W, u DIV 80H MOD 8, 3);  Texts.WriteInt(W, u MOD 80H, 4)
-        ELSIF v = 2 THEN
-          Texts.WriteString(W, table2[u DIV 800H]);
-          Texts.WriteInt(W, u MOD 100H, 5)
-        ELSIF v = 3 THEN
-          Texts.WriteString(W, table3[u DIV 100H]);
-          Texts.WriteInt(W, u MOD 100H, 6)
-        END ;
-        Texts.WriteLn(W)
-      END ;
-      Texts.Append(Oberon.Log, W.buf)
-  END Decode;
-
-  (*------------ Procedures for loading code into PIC ------------*)
-  
-  (* Port represents a 2-wire connection to the PIC-board:
-    bit 0: data, PIC B7
-    bit 1: clock, PIC B6 *)
-
-  PROCEDURE delay;  (* >3us *)
-    VAR t: INTEGER;
-  BEGIN t :=8;
-    REPEAT DEC(t) UNTIL t = 0
-  END delay;
-
-  PROCEDURE delay1;  (*10ms*)
-    VAR T: INTEGER;
-  BEGIN T := Oberon.Time() + 10;
-    REPEAT UNTIL Oberon.Time() >= T
-  END delay1;
-
-  PROCEDURE bits(x, n: INTEGER);
-    VAR b: INTEGER;
-  BEGIN (*send n bits of x*)
-    REPEAT DEC(n); b := x MOD 2; x := x DIV 2;
-      SYSTEM.PUT(gpio, b+2); SYSTEM.PUT(gpio, b)
-    UNTIL n = 0
-  END bits;
-
-  PROCEDURE SendWord(x: INTEGER);
-    VAR i: INTEGER;
-  BEGIN bits(2, 6);  (*load cmd*)
-    bits(x*2, 16);  (*data*)
-    bits(8, 6);  (*program cmd*)
-    delay1;
-    bits(6, 6);  (*inc adr cmd*)
-  END SendWord;
-  
-  PROCEDURE ReceiveWord(VAR x: INTEGER);
-    VAR a,  i: INTEGER; b: BYTE;
-  BEGIN SYSTEM.PUT(gpio, 3); bits(4, 6);  (*read cmd*)
-    delay; a := 0; i := 16;
-    REPEAT SYSTEM.PUT(gpio, 3); SYSTEM.PUT(gpio, 1); delay;
-      SYSTEM.PUT(gpoc, 2); (*switch to input*)
-      SYSTEM.GET(gpio, b); b := b DIV 40H MOD 2;  (*bit 6*)
-      a := ORD(SYSTEM.BIT(gpio, 0)) * 8000H + (a DIV 2);
-      SYSTEM.PUT(gpoc, 3); delay; (*switch back to output*); DEC(i)
-    UNTIL i = 0;
-    x := a DIV 2 MOD 4000H;
-    SYSTEM.PUT(gpio, 0); bits(6, 6);  (*inc adr cmd*)
-  END ReceiveWord;
-
-  PROCEDURE Reset*;
-  BEGIN SYSTEM.PUT(gpio, 0); SYSTEM.PUT(gpoc, 3)
-  END Reset;
-
-  PROCEDURE Program*;
-    VAR i: INTEGER;
-  BEGIN Reset; Texts.WriteString(W, "programming PIC ... "); Texts.Append(Oberon.Log, W.buf);
-    delay1; i := 0;
-    WHILE i < pc DO SendWord(code[i]); INC(i) END ;
-    Texts.WriteString(W, "done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END Program;
-
-  PROCEDURE Configure*;
-    VAR i, x: INTEGER; S: Texts.Scanner;
-  BEGIN Reset;
-    Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    Texts.WriteString(W, "confirguring PIC  "); Texts.WriteHex(W, S.i);
-    SYSTEM.PUT(gpio, 0); delay1;
-    bits(0, 6); bits(S.i * 2, 16); i := 0;
-    REPEAT bits(6, 6); INC(i) UNTIL i = 7;
-    bits(1, 6); bits(7, 6); bits(8, 6); delay; bits(1, 6); bits(7, 6);
-    ReceiveWord(x);
-    Texts.WriteHex(W, x); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-  END Configure;
-
-  PROCEDURE EraseProgram*;
-  BEGIN Reset; Texts.WriteString(W, "erase program"); Texts.Append(Oberon.Log, W.buf);
-    SYSTEM.PUT(gpio, 0); delay1;
-    SendWord(-1); bits(9, 6); bits(8, 6); delay1;
-    Texts.WriteString(W, "done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END EraseProgram;
-  
-  PROCEDURE EraseData*;
-  BEGIN Reset; Texts.WriteString(W, "erase data"); Texts.Append(Oberon.Log, W.buf);
-    SYSTEM.PUT(gpio, 0); delay1;
-    SendWord(-1); bits(11, 6); bits(8, 6); delay1;
-    Texts.WriteString(W, "done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END EraseData;
-  
-  PROCEDURE Verify*;
-    VAR i, x: INTEGER;
-  BEGIN Reset; Texts.WriteString(W, "verifying PIC ... "); Texts.Append(Oberon.Log, W.buf);
-    SYSTEM.PUT(gpio, 0); delay1;
-    i := 0;
-    WHILE i < pc DO
-      ReceiveWord(x);
-      IF code[i] # x THEN
-        Texts.WriteString(W, " error at"); Texts.WriteInt(W, i, 5); Texts.WriteHex(W, x); i := pc 
-      ELSE INC(i)
-      END
-    END ;
-    Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END Verify;
-
-  PROCEDURE enter1(id: CHAR; form, typ, a: INTEGER);
-    VAR obj: Object;
-  BEGIN NEW(obj); obj.name[0] := id; obj.form := form; obj.typ := typ; obj.a := a;
-    obj.next := IdList; IdList := obj
-  END enter1;
-
-BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "PICL  8.8.2014");
-  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); NEW(undef);
-  (* instruction names for decoder*)
-  table0[0] := "MOVWF"; table0[1] := "CLRF "; table0[2] := "SUBWF"; table0[3] := "DECF ";
-  table0[4] := "IORWF"; table0[5] := "ANDWF"; table0[6] := "XORWF"; table0[7] := "ADDWF";
-  table0[8] := "MOVFW"; table0[9] := "COMF "; table0[10] := "INCF "; table0[11] := "DECFSZ";
-  table0[12] := "RRF  "; table0[13] := "RLF  "; table0[14] := "SWAPF"; table0[15] := "INCFSZ";
-
-  table1[0] := "BCF  "; table1[1] := "BSF  "; table1[2] := "BTFSC"; table1[3] := "BTFSS";
-  table2[0] := "CALL "; table2[1] := "GOTO ";
-
-  table3[0] := "MOVLW"; table3[4] := "RETLW";
-  table3[8] := "IORLW"; table3[9] := "ANDLW"; table3[10] := "XORLW";
-  table3[12] := "SUBLW"; table3[14] := "ADDLW";
-  
-  (*predefined registers A, B, S, T / timer or option*)
-  enter1("T", 1, 2, 1); enter1("S", 1, 2, 3); enter1("A", 1, 2, 5); enter1("B", 1, 2, 6);
-  IdList0 := IdList; Statement := Statement0; Reset
-END PICL. 
-
+MODULE PICL;  (*NW 22.2.2005 / 16.10.2014*)
+  IMPORT Texts, Oberon, PICS, SYSTEM;
+
+  CONST var = 1; con = 2; proc = 3;   (*item forms*)
+    intT = 1; setT = 2; boolT = 3;    (*types*)
+    gpio= -32; gpoc = -28;  (*general-purpose, 2-bit I/O data and output control*)
+
+    (*symbols*) null = 0;
+    ast = 1; slash = 2; plus = 3; minus = 4; not = 5; and = 6; or = 7;
+    eql = 10; neq = 11; geq = 12; lss = 13; leq = 14; gtr = 15;
+    period = 16; comma = 17; colon = 18; 
+    op = 20; query = 21; lparen = 22; becomes = 23;
+    ident = 24; if = 25; while = 26; repeat = 27;
+    inc = 28; dec = 29; rol = 30; ror = 31;
+    number = 32; rparen = 33; then = 34; do =  35;
+    semicolon = 36; end = 37; else = 38 ; elsif =  39; until =  40; return = 41;
+    int = 42; set = 43; bool = 44;
+    const = 50; begin = 51; proced = 52; module = 53; eof = 54;
+
+  TYPE Object = POINTER TO ObjDesc;
+    ObjDesc = RECORD
+        name: ARRAY PICS.IdLen OF CHAR;
+        form, typ, ptyp, a: INTEGER;
+        next: Object
+      END ;
+
+    OpCode = ARRAY 8 OF CHAR;
+
+  VAR sym: INTEGER;  (*last symbol read by scanner*)
+    IdList, IdList0, undef: Object;
+    pc, dc: INTEGER;
+    error: BOOLEAN;
+    errpos: INTEGER;
+    Statement: PROCEDURE;
+    W: Texts.Writer;
+    code: ARRAY 1024 OF INTEGER;
+
+    table0, table3: ARRAY 16 OF OpCode;  (*for decoding only*)
+    table1: ARRAY 4 OF OpCode;
+    table2: ARRAY 2 OF OpCode;
+
+  PROCEDURE Mark(num: INTEGER);
+    VAR p: INTEGER;
+  BEGIN p := PICS.position();
+    IF p > errpos+2 THEN
+      Texts.WriteString(W, "  pos "); Texts.WriteInt(W, p, 1);
+      Texts.WriteString(W, "  err "); Texts.WriteInt(W, num, 1);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END ;
+    errpos := p; error := TRUE
+  END Mark;
+
+  PROCEDURE this(id: ARRAY OF CHAR): Object;
+    VAR obj: Object;
+  BEGIN obj := IdList;
+    WHILE (obj # NIL) & (obj.name # id) DO obj := obj.next END ;
+    IF obj = NIL THEN Mark(0); obj := undef END ;
+    RETURN obj
+  END this;
+
+  PROCEDURE enter(id: ARRAY OF CHAR; form, typ, a: INTEGER);
+    VAR obj: Object;
+  BEGIN NEW(obj); obj.name := id; obj.form := form; obj.typ := typ; obj.a := a;
+    obj.next := IdList; IdList := obj
+  END enter;
+
+  PROCEDURE emit(op, a: INTEGER);
+  BEGIN code[pc] := op*100H + a; INC(pc)
+  END emit;
+
+  PROCEDURE emit1(op, n, a: INTEGER);
+  BEGIN code[pc] := ((op+4)*8 + n) * 80H + a; INC(pc)
+  END emit1;
+
+  PROCEDURE index(VAR n: INTEGER);
+  BEGIN n := 0;
+    IF sym = period THEN
+      PICS.Get(sym);
+      IF sym = number THEN n := PICS.val; PICS.Get(sym) ELSE Mark(11) END
+    END
+  END index;
+
+  PROCEDURE expression;
+    VAR x, y: Object; op, xf, xt, xval, yt, yval: INTEGER;
+  BEGIN xval := 0;
+    IF sym = ident THEN x := this(PICS.id); xf := x.form; xt := x.typ; xval := x.a; PICS.Get(sym)
+    ELSIF sym = number THEN xf := con; xval := PICS.val; xt := PICS.typ; PICS.Get(sym)
+    ELSE Mark(10)
+    END ;
+    IF sym = lparen THEN  (*function call*)
+      PICS.Get(sym);
+      IF x.form # proc THEN Mark(3) END ;
+      IF sym # rparen THEN expression END ;
+      emit(20H, x.a);   (*CALL x*)
+      IF sym = rparen THEN PICS.Get(sym) ELSE Mark(8) END
+    ELSIF (sym >= ast) & (sym <= minus) THEN
+      op := sym; PICS.Get(sym); yval := 0;;
+      IF sym = ident THEN
+        y := this(PICS.id); yt := y.typ; PICS.Get(sym);
+        IF y.form = var THEN emit(8, y.a)    (*MOVFW y*)
+        ELSIF y.form = con THEN emit(30H, y.a)   (*MOVLW y*)
+        ELSE Mark(10)
+        END
+      ELSIF sym = number THEN
+        yval := PICS.val; yt := PICS.typ; emit(30H, yval); PICS.Get(sym)
+      END ;
+      IF xt # yt THEN Mark(111) END ;
+      IF xf = var THEN
+        IF op = plus THEN
+          IF xt = intT THEN emit(7, x.a) ELSE emit(4, x.a) END   (*ADDFW/IORFW*)
+        ELSIF op = minus THEN
+          IF xt = intT THEN emit(2, x.a) ELSE emit(6, x.a) END   (*SUBFW/XORFW*)
+        ELSIF op = ast THEN
+          IF xt = intT THEN Mark(11) ELSE emit(5, x.a) END   (*ANDFW*)
+        END
+      ELSIF xf = con THEN
+        IF op = plus THEN
+          IF xt = intT THEN emit(3EH, xval) ELSE emit(38H, xval) END   (*ADDLW/IORLW*)
+        ELSIF op = minus THEN
+          IF xt = intT THEN emit(3CH, xval) ELSE emit(3AH, xval) END   (*SUBLW/XORLW*)
+        ELSIF op = ast THEN
+          IF xt = intT THEN Mark(11) ELSE emit(39H, xval) END   (*ANDLW*)
+        ELSE Mark(9)
+        END
+      ELSE Mark(10)
+      END
+    ELSIF xf = var THEN emit(8, x.a);    (*MOVFW x*)
+    ELSIF xf = con THEN emit(30H, xval)
+    ELSE Mark(10)
+    END
+  END expression;
+
+  PROCEDURE term;
+    VAR x, y: Object; n, rel, yf, ya: INTEGER;
+  BEGIN
+    IF sym = ident THEN
+      x := this(PICS.id); PICS.Get(sym);
+      IF (sym >= eql) & (sym <= gtr) THEN
+        rel := sym; PICS.Get(sym);
+        IF sym = ident THEN y := this(PICS.id); PICS.Get(sym); yf := y.form; ya := y.a;
+        ELSIF sym = number THEN yf := con; ya := PICS.val; PICS.Get(sym)
+        END ;
+        IF rel < leq THEN  (* eql neq geq lss:  x-y*)
+          IF yf = var THEN emit(8, ya); emit(2, x.a)   (*MOVFW y  SUBFW x*)
+          ELSIF yf = con THEN
+            IF ya = 0 THEN emit(8, x.a)    (*MOVLW x*)
+            ELSE emit(30H, ya); emit(2, x.a)   (*MOVLW y  SUBFW x*)
+            END
+          END
+        ELSE  (* leq gtr:   y-x*)
+          emit(8, x.a);   (*MOVFW x*)
+          IF yf = var THEN emit(2, ya)   (*SUBFW y*)
+          ELSIF (yf = con) & (ya # 0) THEN emit(60, ya)   (*SUBLW y*)
+          END
+        END ;
+        IF rel = eql THEN emit1(3, 2, 3)     (*BTFSS S.Z*)
+        ELSIF rel = neq THEN emit1(2, 2, 3)  (*BTFSC S.Z*)
+        ELSIF (rel = geq) OR (rel = leq) THEN emit1(3, 0, 3)  (*BTFSS S.C*)
+        ELSIF (rel = lss) OR( rel = gtr) THEN emit1(2, 0, 3)  (*BTFSC S.C*)
+        END
+      ELSE index(n); emit1(3, n, x.a)  (*BTFSC n, x*)
+      END
+    ELSIF sym = not THEN
+      PICS.Get(sym);
+      IF sym = ident THEN
+        x := this(PICS.id); PICS.Get(sym);
+        index(n); emit1(2, n, x.a)  (*BTFSS n, x*)
+      ELSE Mark(10)
+      END
+    ELSE Mark(10)
+    END
+  END term;
+
+  PROCEDURE condition(VAR link: INTEGER);
+    VAR L, L0, L1: INTEGER;
+  BEGIN term; code[pc] := 0; L := pc; INC(pc);
+    IF sym = and THEN
+      REPEAT PICS.Get(sym); term; code[pc] := L; L := pc; INC(pc)
+      UNTIL sym # and
+    ELSIF sym = or THEN
+      REPEAT PICS.Get(sym); term; code[pc] := L; L := pc; INC(pc)
+      UNTIL sym # or;
+      L0 := code[L]; code[L] := 0;
+      REPEAT (*invert skip sense*)
+        IF code[L0-1] DIV 400H = 6 THEN (*BITFSC*) INC(code[L0-1], 400H)
+        ELSE (*BITFSS*) DEC(code[L0-1], 400H)
+        END ;
+        L1 := code[L0]; code[L0] := pc+2800H; L0 := L1
+      UNTIL L0 = 0
+    END ;
+    link := L
+  END condition;
+
+  PROCEDURE fixup(L, k: INTEGER);
+    VAR L1: INTEGER;
+  BEGIN
+    WHILE L # 0 DO L1 := code[L]; code[L] := k+2800H; L := L1 END
+  END fixup;
+ 
+  PROCEDURE StatSeq;
+  BEGIN Statement;
+    WHILE sym = semicolon DO PICS.Get(sym); Statement END
+  END StatSeq;
+  
+  PROCEDURE Guarded(VAR L: INTEGER);
+  BEGIN condition(L);
+    IF sym = then THEN PICS.Get(sym) ELSE Mark(14) END ;
+    StatSeq
+  END Guarded;
+
+  PROCEDURE IfStat;
+    VAR L0, L: INTEGER;
+  BEGIN condition(L);
+    IF sym = then THEN PICS.Get(sym) ELSE Mark(14) END ;
+    StatSeq; L0 := 0; 
+    WHILE sym = elsif DO
+      code[pc] := L0; L0 := pc; INC(pc); fixup(L, pc);
+      PICS.Get(sym); condition(L);
+      IF sym = then THEN PICS.Get(sym) ELSE Mark(14) END ;
+      StatSeq
+    END ;
+    IF sym = else THEN
+      code[pc] := L0; L0 := pc; INC(pc); fixup(L, pc);
+      PICS.Get(sym); StatSeq
+    ELSE fixup(L, pc)
+    END ;
+    IF sym = end THEN PICS.Get(sym) ELSE Mark(15) END ;
+    fixup(L0, pc)
+  END IfStat;
+
+  PROCEDURE WhileStat;
+    VAR L0, L: INTEGER;
+  BEGIN L0 := pc; condition(L);
+    IF sym = do THEN PICS.Get(sym) ELSE Mark(14) END ;
+    StatSeq; emit(28H, L0); fixup(L, pc);
+    WHILE sym = elsif DO
+      PICS.Get(sym); condition(L);
+      IF sym = do THEN PICS.Get(sym) ELSE Mark(14) END ;
+      StatSeq; emit(28H, L0); fixup(L, pc)
+    END ;
+    IF sym = end THEN PICS.Get(sym) ELSE Mark(16) END
+  END WhileStat;
+
+  PROCEDURE RepeatStat;
+    VAR L0, L: INTEGER;
+  BEGIN L0 := pc; StatSeq;
+    IF sym = until THEN
+      PICS.Get(sym); condition(L);  (*try to use DECFSZ*)
+      IF (code[pc-4] DIV 100H = 3) & (code[pc-3] DIV 100H = 8) &
+        (code[pc-2] = 1D03H) & (code[pc-4] MOD 80H = code[pc-3] MOD 100H) THEN
+          INC(code[pc-4], 800H); code[pc-3] := 0; DEC(pc, 2); L := pc-1
+      END ;
+      fixup(L, L0)
+    ELSIF sym = end THEN PICS.Get(sym); emit(28H, L0)
+    ELSE Mark(25)
+    END
+  END RepeatStat;
+
+  PROCEDURE Operand1(cd: INTEGER);
+    VAR x: Object;
+  BEGIN
+    IF sym = ident THEN
+      x := this(PICS.id); PICS.Get(sym);
+      IF x.form # var THEN Mark(2) END ;
+      emit(cd, x.a + 80H)  (*INCF/DECF/RRF/RLF*)
+    ELSE Mark(10)
+    END
+  END Operand1;
+
+  PROCEDURE Operand2(cd: INTEGER);
+    VAR x: Object; op, n: INTEGER;
+  BEGIN
+    IF sym = ident THEN
+      x := this(PICS.id); PICS.Get(sym);
+      IF x.form # var THEN Mark(2) END ;
+      index(n); emit1(cd, n, x.a)  (*BSF/BCF*)
+    ELSE Mark(10)
+    END
+  END Operand2;
+
+  PROCEDURE Statement0;
+    VAR x: Object; w: INTEGER;
+  BEGIN
+    IF sym = ident THEN
+      x := this(PICS.id); PICS.Get(sym);
+      IF sym = becomes THEN
+        PICS.Get(sym);
+        IF x.form # var THEN Mark(2) END ;
+        expression; w := code[pc-1];
+        IF w = 3000H THEN code[pc-1] := x.a + 180H   (*CLR x*)
+        ELSIF (w DIV 100H <= 13) & (w MOD 100H = x.a) THEN INC(code[pc-1], 80H)
+        ELSE emit(0, x.a + 80H)   (*MOVWF*)
+        END
+      ELSE (*proc call*)
+        IF x.form # proc THEN Mark(3) END ;
+        IF sym = lparen THEN
+          PICS.Get(sym); expression; emit(20H, x.a);   (*CALL*)
+          IF sym = rparen THEN PICS.Get(sym) ELSE Mark(8) END
+        ELSE
+          emit(20H, x.a)   (*CALL*)
+        END
+      END
+    ELSIF sym = inc THEN PICS.Get(sym); Operand1(10)   (*INCF*)
+    ELSIF sym = dec THEN PICS.Get(sym); Operand1(3)   (*DECF*)
+    ELSIF sym = rol THEN PICS.Get(sym); Operand1(13)   (*RLF*)
+    ELSIF sym = ror THEN PICS.Get(sym); Operand1(12)   (*RRF*)
+    ELSIF sym = op THEN PICS.Get(sym);
+      IF sym = not THEN PICS.Get(sym); Operand2(0)   (*BCF*)
+      ELSE Operand2(1)    (*BSF*)
+      END ;
+    ELSIF sym = query THEN PICS.Get(sym);
+      IF sym = not THEN PICS.Get(sym); Operand2(2) ELSE Operand2(3) END ;
+      emit(28H, pc-1)   (*BTFSS/BTFSC*)
+    ELSIF sym = lparen THEN
+      PICS.Get(sym); StatSeq;
+      IF sym = rparen THEN PICS.Get(sym) ELSE Mark(8) END
+    ELSIF sym = if THEN PICS.Get(sym); IfStat
+    ELSIF sym = while THEN PICS.Get(sym); WhileStat
+    ELSIF sym = repeat THEN PICS.Get(sym); RepeatStat
+    END
+  END Statement0;
+
+  PROCEDURE ProcDecl;
+    VAR typ, partyp, restyp, pc0: INTEGER;
+      obj, res: Object;
+      name: ARRAY 32 OF CHAR;
+  BEGIN obj := IdList; partyp := 0; restyp := 0; pc0 := pc;
+    IF sym = ident THEN name := PICS.id; PICS.Get(sym) ELSE Mark(10) END ;
+    IF sym = lparen THEN (*parameter*)
+      PICS.Get(sym);
+      IF (sym >= int) & (sym <= bool) THEN
+        partyp := sym - int + 1; PICS.Get(sym);
+        IF sym = ident THEN enter(PICS.id, var, partyp, dc); PICS.Get(sym); emit(0, dc+80H); INC(dc)
+        ELSE Mark(10)
+        END
+      END ;
+      IF sym = rparen THEN PICS.Get(sym) ELSE Mark(8) END
+    END ;
+    IF sym = colon THEN  (*result type*)
+      PICS.Get(sym);
+      IF (sym >= int) & (sym <= bool) THEN restyp := sym - int + 1; PICS.Get(sym);
+      ELSE Mark(10)
+      END
+    END ;
+    IF sym = semicolon THEN PICS.Get(sym) ELSE Mark(20) END ;
+    WHILE (sym >= int) & (sym <= bool) DO  (*variable declarations*)
+      typ := sym - int + 1; PICS.Get(sym);
+      WHILE sym = ident DO
+        enter(PICS.id, var, typ, dc); INC(dc); PICS.Get(sym);
+        IF sym = comma THEN PICS.Get(sym) END
+      END ;
+      IF sym = semicolon THEN PICS.Get(sym) ELSE Mark(20) END ;
+    END ;
+    IF sym = begin THEN PICS.Get(sym); StatSeq ELSE Mark(21) END ;
+    IF sym = return THEN PICS.Get(sym); expression END ;
+    emit(0, 8);  (*RET*)
+    IF sym = end THEN PICS.Get(sym);
+      IF sym = ident THEN
+        IF PICS.id # name THEN Mark(22) END ;
+        PICS.Get(sym)
+      ELSE Mark(10)
+      END
+    ELSE Mark(18)
+    END ;
+    IF sym = semicolon THEN PICS.Get(sym) ELSE Mark(20) END ;
+    IdList := obj;    (*reset scope*)
+    enter(name, proc, restyp, pc0); IdList.ptyp := partyp
+  END ProcDecl;
+
+  PROCEDURE Module;
+    VAR typ: INTEGER; name: ARRAY PICS.IdLen OF CHAR;
+  BEGIN name[0] := 0X;
+    IF sym = module THEN
+      PICS.Get(sym);
+      IF sym = ident THEN name := PICS.id; PICS.Get(sym) ELSE Mark(10) END ;
+      IF sym = semicolon THEN PICS.Get(sym) ELSE Mark(20) END ;
+    END ;
+    Texts.WriteString(W, "PIC compiling "); Texts.WriteString(W, name); Texts.WriteLn(W);
+    IF sym = const THEN
+      PICS.Get(sym);
+      WHILE sym = ident DO
+        enter(PICS.id, 2, 1, 0); PICS.Get(sym);
+        IF sym = eql THEN
+          PICS.Get(sym);
+          IF sym = number THEN IdList.a := PICS.val; PICS.Get(sym) ELSE Mark(10) END
+        ELSE Mark(5)
+        END ;
+        IF sym = semicolon THEN PICS.Get(sym) ELSE Mark(20) END
+      END
+    END ;
+    WHILE (sym >= int) & (sym <= bool) DO
+      typ := sym - int + 1; PICS.Get(sym);
+      WHILE sym = ident DO
+        enter(PICS.id, var, typ, dc); INC(dc); PICS.Get(sym);
+        IF sym = comma THEN PICS.Get(sym) END
+      END ;
+      IF sym = semicolon THEN PICS.Get(sym) END
+    END ;
+    WHILE sym = proced DO PICS.Get(sym); ProcDecl END ;
+    IF pc > 1 THEN code[0] := pc + 2800H ELSE pc := 0 END ;
+    IF sym = begin THEN PICS.Get(sym); StatSeq END ;
+    IF sym = end THEN PICS.Get(sym);
+      IF PICS.id # name THEN Mark(22) END
+    ELSE Mark(18) 
+    END ;
+    Texts.WriteInt(W, pc, 5); Texts.WriteLn(W)
+  END Module;
+
+  PROCEDURE Compile*;
+    VAR i, u, v: INTEGER; obj: Object;
+      T: Texts.Text;
+      beg, end, time: INTEGER;
+  BEGIN Oberon.GetSelection(T, beg, end, time);
+    IF time >= 0 THEN
+      IdList := IdList0; PICS.Init(T, beg); pc := 1; dc := 12; error := FALSE; errpos := 0;
+      PICS.Get(sym); Module;
+      Texts.Append(Oberon.Log, W.buf)
+    END
+  END Compile;
+
+  PROCEDURE Decode*;
+    VAR i, u, v: INTEGER; obj: Object;
+  BEGIN obj := IdList;
+      WHILE obj # IdList0 DO
+        Texts.WriteInt(W, obj.form, 4); Texts.WriteInt(W, obj.typ, 4); Texts.WriteInt(W, obj.a, 4);
+        Texts.Write(W, " "); Texts.WriteString(W, obj.name); Texts.WriteLn(W);
+        obj := obj.next
+      END ;
+      Texts.Append(Oberon.Log, W.buf);
+      FOR i := 0 TO pc-1 DO
+        Texts.WriteInt(W, i, 4); u := code[i]; Texts.WriteHex(W, u); Texts.Write(W, " ");
+        v := u DIV 1000H; u := u MOD 1000H;
+        IF v = 0 THEN
+          IF u = 8 THEN Texts.WriteString(W, "RET"); Texts.WriteLn(W)
+          ELSE Texts.WriteString(W, table0[u DIV 100H]);
+            Texts.WriteInt(W, u DIV 80H MOD 2, 3); Texts.WriteInt(W, u MOD 80H, 4)
+          END
+        ELSIF v = 1 THEN
+          Texts.WriteString(W, table1[u DIV 400H]);
+          Texts.WriteInt(W, u DIV 80H MOD 8, 3);  Texts.WriteInt(W, u MOD 80H, 4)
+        ELSIF v = 2 THEN
+          Texts.WriteString(W, table2[u DIV 800H]);
+          Texts.WriteInt(W, u MOD 100H, 5)
+        ELSIF v = 3 THEN
+          Texts.WriteString(W, table3[u DIV 100H]);
+          Texts.WriteInt(W, u MOD 100H, 6)
+        END ;
+        Texts.WriteLn(W)
+      END ;
+      Texts.Append(Oberon.Log, W.buf)
+  END Decode;
+
+  (*------------ Procedures for loading code into PIC ------------*)
+  
+  (* Port represents a 2-wire connection to the PIC-board:
+    bit 0: data, PIC B7
+    bit 1: clock, PIC B6 *)
+
+  PROCEDURE delay;  (* >3us *)
+    VAR t: INTEGER;
+  BEGIN t :=8;
+    REPEAT DEC(t) UNTIL t = 0
+  END delay;
+
+  PROCEDURE delay1;  (*10ms*)
+    VAR T: INTEGER;
+  BEGIN T := Oberon.Time() + 10;
+    REPEAT UNTIL Oberon.Time() >= T
+  END delay1;
+
+  PROCEDURE bits(x, n: INTEGER);
+    VAR b: INTEGER;
+  BEGIN (*send n bits of x*)
+    REPEAT DEC(n); b := x MOD 2; x := x DIV 2;
+      SYSTEM.PUT(gpio, b+2); SYSTEM.PUT(gpio, b)
+    UNTIL n = 0
+  END bits;
+
+  PROCEDURE SendWord(x: INTEGER);
+    VAR i: INTEGER;
+  BEGIN bits(2, 6);  (*load cmd*)
+    bits(x*2, 16);  (*data*)
+    bits(8, 6);  (*program cmd*)
+    delay1;
+    bits(6, 6);  (*inc adr cmd*)
+  END SendWord;
+  
+  PROCEDURE ReceiveWord(VAR x: INTEGER);
+    VAR a,  i: INTEGER; b: BYTE;
+  BEGIN SYSTEM.PUT(gpio, 3); bits(4, 6);  (*read cmd*)
+    delay; a := 0; i := 16;
+    REPEAT SYSTEM.PUT(gpio, 3); SYSTEM.PUT(gpio, 1); delay;
+      SYSTEM.PUT(gpoc, 2); (*switch to input*)
+      SYSTEM.GET(gpio, b); b := b DIV 40H MOD 2;  (*bit 6*)
+      a := ORD(SYSTEM.BIT(gpio, 0)) * 8000H + (a DIV 2);
+      SYSTEM.PUT(gpoc, 3); delay; (*switch back to output*); DEC(i)
+    UNTIL i = 0;
+    x := a DIV 2 MOD 4000H;
+    SYSTEM.PUT(gpio, 0); bits(6, 6);  (*inc adr cmd*)
+  END ReceiveWord;
+
+  PROCEDURE Reset*;
+  BEGIN SYSTEM.PUT(gpio, 0); SYSTEM.PUT(gpoc, 3)
+  END Reset;
+
+  PROCEDURE Program*;
+    VAR i: INTEGER;
+  BEGIN Reset; Texts.WriteString(W, "programming PIC ... "); Texts.Append(Oberon.Log, W.buf);
+    delay1; i := 0;
+    WHILE i < pc DO SendWord(code[i]); INC(i) END ;
+    Texts.WriteString(W, "done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END Program;
+
+  PROCEDURE Configure*;
+    VAR i, x: INTEGER; S: Texts.Scanner;
+  BEGIN Reset;
+    Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    Texts.WriteString(W, "confirguring PIC  "); Texts.WriteHex(W, S.i);
+    SYSTEM.PUT(gpio, 0); delay1;
+    bits(0, 6); bits(S.i * 2, 16); i := 0;
+    REPEAT bits(6, 6); INC(i) UNTIL i = 7;
+    bits(1, 6); bits(7, 6); bits(8, 6); delay; bits(1, 6); bits(7, 6);
+    ReceiveWord(x);
+    Texts.WriteHex(W, x); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+  END Configure;
+
+  PROCEDURE EraseProgram*;
+  BEGIN Reset; Texts.WriteString(W, "erase program"); Texts.Append(Oberon.Log, W.buf);
+    SYSTEM.PUT(gpio, 0); delay1;
+    SendWord(-1); bits(9, 6); bits(8, 6); delay1;
+    Texts.WriteString(W, "done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END EraseProgram;
+  
+  PROCEDURE EraseData*;
+  BEGIN Reset; Texts.WriteString(W, "erase data"); Texts.Append(Oberon.Log, W.buf);
+    SYSTEM.PUT(gpio, 0); delay1;
+    SendWord(-1); bits(11, 6); bits(8, 6); delay1;
+    Texts.WriteString(W, "done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END EraseData;
+  
+  PROCEDURE Verify*;
+    VAR i, x: INTEGER;
+  BEGIN Reset; Texts.WriteString(W, "verifying PIC ... "); Texts.Append(Oberon.Log, W.buf);
+    SYSTEM.PUT(gpio, 0); delay1;
+    i := 0;
+    WHILE i < pc DO
+      ReceiveWord(x);
+      IF code[i] # x THEN
+        Texts.WriteString(W, " error at"); Texts.WriteInt(W, i, 5); Texts.WriteHex(W, x); i := pc 
+      ELSE INC(i)
+      END
+    END ;
+    Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END Verify;
+
+  PROCEDURE enter1(id: CHAR; form, typ, a: INTEGER);
+    VAR obj: Object;
+  BEGIN NEW(obj); obj.name[0] := id; obj.form := form; obj.typ := typ; obj.a := a;
+    obj.next := IdList; IdList := obj
+  END enter1;
+
+BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "PICL  8.8.2014");
+  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); NEW(undef);
+  (* instruction names for decoder*)
+  table0[0] := "MOVWF"; table0[1] := "CLRF "; table0[2] := "SUBWF"; table0[3] := "DECF ";
+  table0[4] := "IORWF"; table0[5] := "ANDWF"; table0[6] := "XORWF"; table0[7] := "ADDWF";
+  table0[8] := "MOVFW"; table0[9] := "COMF "; table0[10] := "INCF "; table0[11] := "DECFSZ";
+  table0[12] := "RRF  "; table0[13] := "RLF  "; table0[14] := "SWAPF"; table0[15] := "INCFSZ";
+
+  table1[0] := "BCF  "; table1[1] := "BSF  "; table1[2] := "BTFSC"; table1[3] := "BTFSS";
+  table2[0] := "CALL "; table2[1] := "GOTO ";
+
+  table3[0] := "MOVLW"; table3[4] := "RETLW";
+  table3[8] := "IORLW"; table3[9] := "ANDLW"; table3[10] := "XORLW";
+  table3[12] := "SUBLW"; table3[14] := "ADDLW";
+  
+  (*predefined registers A, B, S, T / timer or option*)
+  enter1("T", 1, 2, 1); enter1("S", 1, 2, 3); enter1("A", 1, 2, 5); enter1("B", 1, 2, 6);
+  IdList0 := IdList; Statement := Statement0; Reset
+END PICL. 
+

people.inf.ethz.ch/wirth/PICL/Sources/PICS.Mod.txt

@@ -1,149 +1,149 @@
-MODULE PICS;  (* NW 22.2.2005 / 13.8.2014    Scanner for PIC compiler*)
-  IMPORT Texts, Oberon;
-  
-  CONST IdLen* = 32; NofKeys = 25;
-    (*symbols*) null = 0;
-    ast = 1; slash = 2; plus = 3; minus = 4; not = 5; and = 6; or = 7;
-    eql = 10; neq = 11; geq = 12; lss = 13; leq = 14; gtr = 15;
-    period = 16; comma = 17; colon = 18; 
-    op = 20; query = 21; lparen = 22; becomes = 23;
-    ident = 24; if = 25; while = 26; repeat = 27;
-    inc = 28; dec = 29; rol = 30; ror = 31;
-    number = 32; rparen = 33; then = 34; do =  35;
-    semicolon = 36; end = 37; else = 38 ; elsif =  39; until =  40; return = 41;
-    int = 42; set = 43; bool = 44;
-    const = 50; begin = 51; proced = 52; module = 53; eof = 54;
-
-  VAR val*, typ*: INTEGER;
-    id*: ARRAY IdLen OF CHAR;
-
-    ch: CHAR;  (*lookahead*)
-    K: INTEGER;
-    R: Texts.Reader;
-    W: Texts.Writer;
-    key: ARRAY NofKeys, 16 OF CHAR;
-    symno: ARRAY NofKeys OF INTEGER;
-
-  PROCEDURE position*(): LONGINT;
-  BEGIN RETURN Texts.Pos(R)
-  END position;
-  
-  PROCEDURE Ident(VAR sym: INTEGER);
-    VAR i, j, m: INTEGER;
-  BEGIN i := 0;
-    REPEAT
-      IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
-      Texts.Read(R, ch)
-    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
-    id[i] := 0X;
-    i := 0; j := NofKeys; (*search for keyword*)
-    WHILE i < j DO
-      m := (i + j) DIV 2;
-      IF key[m] < id THEN i := m+1 ELSE j := m END
-    END ;
-    IF key[j] = id THEN sym := symno[i] ELSE sym := ident END
-  END Ident;
-
-  PROCEDURE Number;
-  BEGIN val := 0; typ := 1;
-    REPEAT val := 10 * val + ORD(ch) - ORD("0"); Texts.Read(R, ch)
-    UNTIL (ch < "0") OR (ch > "9")
-  END Number;
-
-  PROCEDURE GetDigit(): INTEGER;
-    VAR d: INTEGER;
-  BEGIN
-    IF ("0" <= ch) & (ch <= "9") THEN d := ORD(ch) - 30H
-    ELSIF ("A" <= ch) & (ch <= "F") THEN d := ORD(ch) - 37H
-    ELSE d := 0
-    END ;
-    Texts.Read(R, ch); RETURN d
-  END GetDigit;
-
-  PROCEDURE Hex;
-    VAR d1, d0: INTEGER;
-  BEGIN val := GetDigit()*10H + GetDigit(); typ := 2
-  END Hex;
-
-  PROCEDURE Get*(VAR sym: INTEGER);
-  BEGIN
-    WHILE (ch <= " ") OR (ch = "{") DO
-      IF ch = "{" THEN
-        REPEAT Texts.Read(R, ch) UNTIL (ch = "}") OR R.eot
-      END ;
-      Texts.Read(R, ch)
-    END ;
-    REPEAT
-      WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
-      IF ch < "A" THEN
-        IF ch < "0" THEN
-          IF ch = "!" THEN Texts.Read(R, ch); sym := op
-          ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
-          ELSIF ch = "$" THEN Texts.Read(R, ch); Hex; sym := number; typ := 2
-          ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
-          ELSIF ch = "(" THEN Texts.Read(R, ch); sym := lparen
-          ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
-          ELSIF ch = "*" THEN Texts.Read(R, ch); sym := ast
-          ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
-          ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
-          ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus
-          ELSIF ch = "." THEN Texts.Read(R, ch); sym := period
-          ELSIF ch = "/" THEN Texts.Read(R, ch); sym := slash
-          ELSE Texts.Read(R, ch); (* " %  ' *) sym := null
-          END
-        ELSIF ch <= "9" THEN Number; sym := number
-        ELSIF ch = ":" THEN Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END 
-        ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
-        ELSIF ch = "<" THEN  Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
-        ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
-        ELSIF ch = ">" THEN Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
-        ELSIF ch = "?" THEN Texts.Read(R, ch); sym := query
-        ELSE (* @ *) Texts.Read(R, ch); sym := null
-        END
-      ELSIF  ch < "a" THEN
-        IF ch <= "Z" THEN Ident(sym)
-        ELSE (* [ \ ] ^ _ `*) Texts.Read(R, ch); sym := null
-        END
-      ELSIF ch <= "z" THEN Ident(sym)
-      ELSIF ch = "~" THEN Texts.Read(R, ch); sym := not
-      ELSE (* { | } *) Texts.Read(R, ch); sym := null
-      END
-    UNTIL sym # null
-  END Get;
-
-  PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
-  BEGIN Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
-  END Init;
-
-  PROCEDURE Enter(word: ARRAY OF CHAR; val: INTEGER);
-  BEGIN key[K] := word; symno[K] := val; INC(K)
-  END Enter;
-  
-BEGIN Texts.OpenWriter(W); K := 0;
-  Enter("BEGIN", begin);
-  Enter("BOOL", bool);
-  Enter("CONST", const);
-  Enter("DEC", dec);
-  Enter("DO", do);
-  Enter("ELSE", else);
-  Enter("ELSIF", elsif);
-  Enter("END", end);
-  Enter("IF", if);
-  Enter("INC", inc);
-  Enter("INT", int);
-  Enter("MODULE", module);
-  Enter("OR", or);
-  Enter("PROCEDURE", proced);
-  Enter("REPEAT", repeat);
-  Enter("RETURN", return);
-  Enter("ROL", rol);
-  Enter("ROR", ror);
-  Enter("SET", set);
-  Enter("THEN", then);
-  Enter("UNTIL", until);
-  Enter("WHILE", while);
-  key[K] := "~ "
-END PICS.
+MODULE PICS;  (* NW 22.2.2005 / 13.8.2014    Scanner for PIC compiler*)
+  IMPORT Texts, Oberon;
+  
+  CONST IdLen* = 32; NofKeys = 25;
+    (*symbols*) null = 0;
+    ast = 1; slash = 2; plus = 3; minus = 4; not = 5; and = 6; or = 7;
+    eql = 10; neq = 11; geq = 12; lss = 13; leq = 14; gtr = 15;
+    period = 16; comma = 17; colon = 18; 
+    op = 20; query = 21; lparen = 22; becomes = 23;
+    ident = 24; if = 25; while = 26; repeat = 27;
+    inc = 28; dec = 29; rol = 30; ror = 31;
+    number = 32; rparen = 33; then = 34; do =  35;
+    semicolon = 36; end = 37; else = 38 ; elsif =  39; until =  40; return = 41;
+    int = 42; set = 43; bool = 44;
+    const = 50; begin = 51; proced = 52; module = 53; eof = 54;
+
+  VAR val*, typ*: INTEGER;
+    id*: ARRAY IdLen OF CHAR;
+
+    ch: CHAR;  (*lookahead*)
+    K: INTEGER;
+    R: Texts.Reader;
+    W: Texts.Writer;
+    key: ARRAY NofKeys, 16 OF CHAR;
+    symno: ARRAY NofKeys OF INTEGER;
+
+  PROCEDURE position*(): LONGINT;
+  BEGIN RETURN Texts.Pos(R)
+  END position;
+  
+  PROCEDURE Ident(VAR sym: INTEGER);
+    VAR i, j, m: INTEGER;
+  BEGIN i := 0;
+    REPEAT
+      IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
+      Texts.Read(R, ch)
+    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
+    id[i] := 0X;
+    i := 0; j := NofKeys; (*search for keyword*)
+    WHILE i < j DO
+      m := (i + j) DIV 2;
+      IF key[m] < id THEN i := m+1 ELSE j := m END
+    END ;
+    IF key[j] = id THEN sym := symno[i] ELSE sym := ident END
+  END Ident;
+
+  PROCEDURE Number;
+  BEGIN val := 0; typ := 1;
+    REPEAT val := 10 * val + ORD(ch) - ORD("0"); Texts.Read(R, ch)
+    UNTIL (ch < "0") OR (ch > "9")
+  END Number;
+
+  PROCEDURE GetDigit(): INTEGER;
+    VAR d: INTEGER;
+  BEGIN
+    IF ("0" <= ch) & (ch <= "9") THEN d := ORD(ch) - 30H
+    ELSIF ("A" <= ch) & (ch <= "F") THEN d := ORD(ch) - 37H
+    ELSE d := 0
+    END ;
+    Texts.Read(R, ch); RETURN d
+  END GetDigit;
+
+  PROCEDURE Hex;
+    VAR d1, d0: INTEGER;
+  BEGIN val := GetDigit()*10H + GetDigit(); typ := 2
+  END Hex;
+
+  PROCEDURE Get*(VAR sym: INTEGER);
+  BEGIN
+    WHILE (ch <= " ") OR (ch = "{") DO
+      IF ch = "{" THEN
+        REPEAT Texts.Read(R, ch) UNTIL (ch = "}") OR R.eot
+      END ;
+      Texts.Read(R, ch)
+    END ;
+    REPEAT
+      WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
+      IF ch < "A" THEN
+        IF ch < "0" THEN
+          IF ch = "!" THEN Texts.Read(R, ch); sym := op
+          ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
+          ELSIF ch = "$" THEN Texts.Read(R, ch); Hex; sym := number; typ := 2
+          ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
+          ELSIF ch = "(" THEN Texts.Read(R, ch); sym := lparen
+          ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
+          ELSIF ch = "*" THEN Texts.Read(R, ch); sym := ast
+          ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
+          ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
+          ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus
+          ELSIF ch = "." THEN Texts.Read(R, ch); sym := period
+          ELSIF ch = "/" THEN Texts.Read(R, ch); sym := slash
+          ELSE Texts.Read(R, ch); (* " %  ' *) sym := null
+          END
+        ELSIF ch <= "9" THEN Number; sym := number
+        ELSIF ch = ":" THEN Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END 
+        ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
+        ELSIF ch = "<" THEN  Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
+        ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
+        ELSIF ch = ">" THEN Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
+        ELSIF ch = "?" THEN Texts.Read(R, ch); sym := query
+        ELSE (* @ *) Texts.Read(R, ch); sym := null
+        END
+      ELSIF  ch < "a" THEN
+        IF ch <= "Z" THEN Ident(sym)
+        ELSE (* [ \ ] ^ _ `*) Texts.Read(R, ch); sym := null
+        END
+      ELSIF ch <= "z" THEN Ident(sym)
+      ELSIF ch = "~" THEN Texts.Read(R, ch); sym := not
+      ELSE (* { | } *) Texts.Read(R, ch); sym := null
+      END
+    UNTIL sym # null
+  END Get;
+
+  PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
+  BEGIN Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
+  END Init;
+
+  PROCEDURE Enter(word: ARRAY OF CHAR; val: INTEGER);
+  BEGIN key[K] := word; symno[K] := val; INC(K)
+  END Enter;
+  
+BEGIN Texts.OpenWriter(W); K := 0;
+  Enter("BEGIN", begin);
+  Enter("BOOL", bool);
+  Enter("CONST", const);
+  Enter("DEC", dec);
+  Enter("DO", do);
+  Enter("ELSE", else);
+  Enter("ELSIF", elsif);
+  Enter("END", end);
+  Enter("IF", if);
+  Enter("INC", inc);
+  Enter("INT", int);
+  Enter("MODULE", module);
+  Enter("OR", or);
+  Enter("PROCEDURE", proced);
+  Enter("REPEAT", repeat);
+  Enter("RETURN", return);
+  Enter("ROL", rol);
+  Enter("ROR", ror);
+  Enter("SET", set);
+  Enter("THEN", then);
+  Enter("UNTIL", until);
+  Enter("WHILE", while);
+  key[K] := "~ "
+END PICS.

people.inf.ethz.ch/wirth/PICL/index.html

@@ -1,35 +1,35 @@
-<HTML>
-<HEAD>
-   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
-   <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
-   <TITLE>PICL: A Programming Language for the Microcontroller PIC</TITLE>
-</HEAD>
-<BODY>
-
-<H1>
-PICL: A Programming Language for the Microcontroller PIC</H1>
-
-	<UL>
-			<LI> <A HREF="PIC.pdf"> A Microcontroller System for Experimentation</A> 
-			<BR>&nbsp;
-				
-			<LI> <A HREF="PICL.pdf"> PICL: A Programming Language for the  Microcontroller PIC</A> 
-			<BR>&nbsp;
-			
-			<LI> <A HREF="PICLcompiler.pdf"> The Language PICL and its Implementation</A> 
-			<BR>&nbsp;
-			
-	</UL>
-<HR>
-<P>PICL Compiler for Project Oberon, 2013 Edition</P>
-&nbsp;&nbsp;
-  <A HREF="Sources/PICL.Mod.txt">PICL.Mod</A>
-  <A HREF="Sources/PICS.Mod.txt">PICS.Mod</A>
-<P></P>
-</BODY>
-
-<HR>
-<P>
-Back to my <A HREF="../index.html">home page</A>.
-
-</HTML>
+<HTML>
+<HEAD>
+   <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+   <META NAME="GENERATOR" CONTENT="Mozilla/4.04 [en] (Win95; I) [Netscape]">
+   <TITLE>PICL: A Programming Language for the Microcontroller PIC</TITLE>
+</HEAD>
+<BODY>
+
+<H1>
+PICL: A Programming Language for the Microcontroller PIC</H1>
+
+	<UL>
+			<LI> <A HREF="PIC.pdf"> A Microcontroller System for Experimentation</A> 
+			<BR>&nbsp;
+				
+			<LI> <A HREF="PICL.pdf"> PICL: A Programming Language for the  Microcontroller PIC</A> 
+			<BR>&nbsp;
+			
+			<LI> <A HREF="PICLcompiler.pdf"> The Language PICL and its Implementation</A> 
+			<BR>&nbsp;
+			
+	</UL>
+<HR>
+<P>PICL Compiler for Project Oberon, 2013 Edition</P>
+&nbsp;&nbsp;
+  <A HREF="Sources/PICL.Mod.txt">PICL.Mod</A>
+  <A HREF="Sources/PICS.Mod.txt">PICS.Mod</A>
+<P></P>
+</BODY>
+
+<HR>
+<P>
+Back to my <A HREF="../index.html">home page</A>.
+
+</HTML>

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Blink.Mod.txt

@@ -1,19 +1,19 @@
-MODULE Blink;   (*NW 30.5.2013*)
-  IMPORT SYSTEM, Oberon;
-  VAR z: INTEGER;
-    T: Oberon.Task;
-  
-  PROCEDURE Run*;
-  BEGIN Oberon.Install(T)
-  END Run;
-
-  PROCEDURE Stop*;
-  BEGIN Oberon.Remove(T)
-  END Stop;
-
-  PROCEDURE Tick;
-  BEGIN z := 1-z; LED(z)
-  END Tick;
-
-BEGIN z := 0; T := Oberon.NewTask(Tick, 500)
-END Blink.
+MODULE Blink;   (*NW 30.5.2013*)
+  IMPORT SYSTEM, Oberon;
+  VAR z: INTEGER;
+    T: Oberon.Task;
+  
+  PROCEDURE Run*;
+  BEGIN Oberon.Install(T)
+  END Run;
+
+  PROCEDURE Stop*;
+  BEGIN Oberon.Remove(T)
+  END Stop;
+
+  PROCEDURE Tick;
+  BEGIN z := 1-z; LED(z)
+  END Tick;
+
+BEGIN z := 0; T := Oberon.NewTask(Tick, 500)
+END Blink.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/BootLoad.Mod.txt

@@ -1,201 +1,201 @@
-ORP.Compile @  
-ORX.WriteFile BootLoad.rsc 512 "D:/Verilog/RISC5/prom.mem"~
-
-MODULE* BootLoad;  (*NW 20.10.2013 / PR 4.2.2014; boot from SDHC disk or line*)
-  IMPORT SYSTEM;
-  (* sw0: init SD; sw1: line|disk*)
-  CONST MT = 12; SP = 14; LNK = 15;
-    MTOrg = 20H; MemLim = 0E7EF0H; stackOrg = 80000H;
-    swi = -60; led = -60; rsData = -56; rsCtrl = -52;
-    spiData = -48; spiCtrl = -44;
-    CARD0 = 1; SPIFAST = 4;
-    FSoffset = 80000H;   (*block offset*)
-
-  PROCEDURE RecInt(VAR x: INTEGER);
-    VAR z, y, i: INTEGER;
-  BEGIN z := 0;  i := 4;
-    REPEAT i := i-1;
-      REPEAT UNTIL SYSTEM.BIT(rsCtrl, 0);
-      SYSTEM.GET(rsData, y); z := ROR(z+y, 8)
-    UNTIL i = 0;
-    x := z
-  END RecInt;
-
-  PROCEDURE LoadFromLine;
-    VAR len, adr, dat: INTEGER;
-  BEGIN RecInt(len);
-    WHILE len > 0 DO
-      RecInt(adr);
-      REPEAT RecInt(dat); SYSTEM.PUT(adr, dat); adr := adr + 4; len := len - 4 UNTIL len = 0;
-      RecInt(len)
-    END
-  END LoadFromLine;
-
-(* ---------- disk ------------*)
-
-  PROCEDURE SPIIdle(n: INTEGER); (*send n FFs slowly with no card selected*)
-  BEGIN SYSTEM.PUT(spiCtrl, 0);
-    WHILE n > 0 DO DEC(n); SYSTEM.PUT(spiData, -1);
-      REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0)
-    END
-  END SPIIdle;
-
-  PROCEDURE SPI(n: INTEGER); (*send&rcv byte slowly with card selected*)
-  BEGIN SYSTEM.PUT(spiCtrl, CARD0); SYSTEM.PUT(spiData, n);
-    REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0)
-  END SPI;
-
-  PROCEDURE SPICmd(n, arg: INTEGER);
-    VAR i, data, crc: INTEGER;
-  BEGIN (*send cmd*)
-    REPEAT SPIIdle(1); SYSTEM.GET(spiData, data) UNTIL data = 255; (*flush while unselected*)
-    REPEAT SPI(255); SYSTEM.GET(spiData, data) UNTIL data = 255; (*flush while selected*)
-    IF n = 8 THEN crc := 135 ELSIF n = 0 THEN crc := 149 ELSE crc := 255 END;
-    SPI(n MOD 64 + 64); (*send command*)
-    FOR i := 24 TO 0 BY -8 DO SPI(ROR(arg, i)) END; (*send arg*)
-    SPI(crc); i := 32;
-    REPEAT SPI(255); SYSTEM.GET(spiData, data); DEC(i) UNTIL (data < 80H) OR (i = 0)
-  END SPICmd;
-
-  PROCEDURE InitSPI;
-    VAR res, data: INTEGER;
-  BEGIN SPIIdle(9); (*first, idle for at least 80 clks*)
-    SPICmd(0, 0); (*CMD0 when card selected, sets MMC SPI mode*)
-    SPICmd(8, 1AAH); SPI(-1); SPI(-1); SPI(-1); (*CMD8 for SD cards*)
-    REPEAT (*until card becomes ready*)
-      (*ACMD41, optionally with high-capacity (HCS) bit set, starts init*)
-      SPICmd(55, 0); (*APP cmd follows*)
-      SPICmd(41, LSL(1(*HCS*), 30));
-      SYSTEM.GET(spiData, res);
-      SPI(-1); SPI(-1); SPI(-1); (*flush response*)
-      SPIIdle(10000)
-    UNTIL res = 0;
-    (*CMD16 set block size as a precaution (should default)*)
-    SPICmd(16, 512); SPIIdle(1)
-  END InitSPI;
-
-  PROCEDURE SDShift(VAR n: INTEGER);
-    VAR data: INTEGER;
-  BEGIN SPICmd(58, 0);  (*CMD58 get card capacity bit*)
-    SYSTEM.GET(spiData, data); SPI(-1);
-    IF (data # 0) OR ~SYSTEM.BIT(spiData, 6) THEN n := n * 512 END ;  (*non-SDHC card*)
-    SPI(-1); SPI(-1); SPIIdle(1)  (*flush response*)
-  END SDShift;
-
-  PROCEDURE ReadSD(src, dst: INTEGER);
-    VAR i, data: INTEGER;
-  BEGIN SDShift(src); SPICmd(17, src); (*CMD17 read one block*)
-    i := 0; (*wait for start data marker*)
-    REPEAT SPI(-1); SYSTEM.GET(spiData, data); INC(i) UNTIL data = 254;
-    SYSTEM.PUT(spiCtrl, SPIFAST + CARD0);
-    FOR i := 0 TO 508 BY 4 DO
-      SYSTEM.PUT(spiData, -1);
-      REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0);
-      SYSTEM.GET(spiData, data); SYSTEM.PUT(dst, data); INC(dst, 4)
-    END;
-    SPI(255); SPI(255); SPIIdle(1) (*may be a checksum; deselect card*)
-  END ReadSD;
-
-  PROCEDURE LoadFromDisk;
-    VAR src, dst, adr, lim: INTEGER;
-  BEGIN src := FSoffset + 4;   (*start at boot block*)
-    ReadSD(src, 0); SYSTEM.GET(16, lim);
-    INC(src); dst := 512;
-    WHILE dst < lim DO ReadSD(src, dst); INC(src); INC(dst, 512) END
-  END LoadFromDisk;
-
-BEGIN SYSTEM.LDREG(SP, stackOrg); SYSTEM.LDREG(MT, MTOrg);
-  IF SYSTEM.REG(LNK) = 0 THEN (*cold start*)
-    LED(80H); InitSPI;
-    IF SYSTEM.BIT(swi, 0) THEN LED(81H); LoadFromLine ELSE LED(82H); LoadFromDisk END ;
-  ELSIF SYSTEM.BIT(swi, 0) THEN LED(81H); LoadFromLine
-  END ;
-  SYSTEM.PUT(12, MemLim); SYSTEM.PUT(24, stackOrg); LED(84H)
-END BootLoad.
-
-ORP.Compile @  ORG.Decode
-ORX.WriteFile BootLoad.rsc "Spartan" "D:/Verilog/RISC/scripts/ins1.mem"~
-ORG.WriteFile BootLoad.rsc "Spartan" "D:/Verilog/RISC3/scripts/ins1.mem" ~
-ORG.WriteFile BootLoad.rsc "Spartan" "D:/Verilog/RISC5/scripts/ins1.mem"~
-
-MODULE* BootLoad;  (*NW 10.2.2013, boot from line only*)
-  IMPORT SYSTEM;
-  CONST MT = 12; SP = 14; StkOrg = 0FFFE7F00H;
-    swi = -60; led = -60; data = -56; stat = -52;
-
-  PROCEDURE RecInt(VAR x: INTEGER);
-    VAR z, y, i: INTEGER;
-  BEGIN z := 0;  i := 4;
-    REPEAT i := i-1;
-      REPEAT UNTIL SYSTEM.BIT(stat, 0);
-      SYSTEM.GET(data, y); z := ROR(z+y, 8)
-    UNTIL i = 0;
-    x := z
-  END RecInt;
-
-  PROCEDURE Load;
-    VAR len, adr, dat: INTEGER;
-  BEGIN RecInt(len);
-    WHILE len > 0 DO
-      RecInt(adr);
-      REPEAT RecInt(dat); SYSTEM.PUT(adr, dat); adr := adr + 4; len := len - 4 UNTIL len = 0;
-      RecInt(len)
-    END ;
-    SYSTEM.GET(4, adr); SYSTEM.LDREG(13, adr); SYSTEM.LDREG(12, 20H)
-  END Load;
-
-BEGIN SYSTEM.LDREG(SP, StkOrg); SYSTEM.LDREG(MT, 20H); SYSTEM.PUT(led, 128); 
-  IF ~SYSTEM.BIT(swi, 0) THEN Load END
-END BootLoad.
-
-ORP.Compile @  ORG.Decode
-ORX.WriteFile Counter.rsc 2048 "D:/Verilog/RISC/prom.mem"~
-ORX.WriteFile Shifter.rsc 2048 "D:/Verilog/RISC/prom.mem"~
-ORX.WriteFile TestInt.rsc 2048 "D:/Verilog/RISC3/scripts/ins1.mem"~
-ORX.WriteFile BootLoad.rsc 512 "D:/Verilog/RISC5/prom.mem"~
-
-MODULE* Counter;
-  VAR x, y, z: INTEGER;
-BEGIN LED(1); z := 0;
-  REPEAT LED(z); x := 1000;
-     REPEAT y := 1000;
-       REPEAT y := y-1 UNTIL y = 0;
-       x := x-1
-     UNTIL x = 0;
-     z := z+1
-   UNTIL FALSE
-END Counter.
-
-MODULE* Shifter;
-  VAR x, y, z, d: INTEGER;
-BEGIN  z := 1; d := 1;
-  REPEAT LED(z); x := 1000;
-     REPEAT y := 1000;
-       REPEAT y := y-1 UNTIL y = 0;
-       x := x-1
-     UNTIL x = 0;
-     IF z = 128 THEN d := -1 ELSIF z = 1 THEN d := 1 END ;
-     IF d = 1 THEN z := LSL(z, 1) ELSE z := ASR(z, 1) END
-   UNTIL FALSE
-END Shifter.
-
-MODULE* TestInt;
-  IMPORT SYSTEM;
-  VAR led, led1, cnt, cnt1: INTEGER;
-
-  PROCEDURE* Int; (*interrupt every millisecond*)
-  BEGIN INC(cnt1);
-    IF cnt1 = 500 THEN led1 := 1 - led1; LED(led1); cnt1 := 0 END
-  END Int;
-
-BEGIN led := 0; led1 := 0; cnt := 0; cnt1 := 0;
-  SYSTEM.PUT(4, 0E7000000H + SYSTEM.ADR(Int) DIV 4 - 2);
-  SYSTEM.LDPSR(1);  (*int enable*)
-  REPEAT
-    IF SYSTEM.BIT(-60, 0) THEN
-      cnt := 100000;
-      REPEAT DEC(cnt) UNTIL cnt = 0;
-      LED(led); INC(led)
-    END
-  UNTIL FALSE;
-END TestInt.
+ORP.Compile @  
+ORX.WriteFile BootLoad.rsc 512 "D:/Verilog/RISC5/prom.mem"~
+
+MODULE* BootLoad;  (*NW 20.10.2013 / PR 4.2.2014; boot from SDHC disk or line*)
+  IMPORT SYSTEM;
+  (* sw0: init SD; sw1: line|disk*)
+  CONST MT = 12; SP = 14; LNK = 15;
+    MTOrg = 20H; MemLim = 0E7EF0H; stackOrg = 80000H;
+    swi = -60; led = -60; rsData = -56; rsCtrl = -52;
+    spiData = -48; spiCtrl = -44;
+    CARD0 = 1; SPIFAST = 4;
+    FSoffset = 80000H;   (*block offset*)
+
+  PROCEDURE RecInt(VAR x: INTEGER);
+    VAR z, y, i: INTEGER;
+  BEGIN z := 0;  i := 4;
+    REPEAT i := i-1;
+      REPEAT UNTIL SYSTEM.BIT(rsCtrl, 0);
+      SYSTEM.GET(rsData, y); z := ROR(z+y, 8)
+    UNTIL i = 0;
+    x := z
+  END RecInt;
+
+  PROCEDURE LoadFromLine;
+    VAR len, adr, dat: INTEGER;
+  BEGIN RecInt(len);
+    WHILE len > 0 DO
+      RecInt(adr);
+      REPEAT RecInt(dat); SYSTEM.PUT(adr, dat); adr := adr + 4; len := len - 4 UNTIL len = 0;
+      RecInt(len)
+    END
+  END LoadFromLine;
+
+(* ---------- disk ------------*)
+
+  PROCEDURE SPIIdle(n: INTEGER); (*send n FFs slowly with no card selected*)
+  BEGIN SYSTEM.PUT(spiCtrl, 0);
+    WHILE n > 0 DO DEC(n); SYSTEM.PUT(spiData, -1);
+      REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0)
+    END
+  END SPIIdle;
+
+  PROCEDURE SPI(n: INTEGER); (*send&rcv byte slowly with card selected*)
+  BEGIN SYSTEM.PUT(spiCtrl, CARD0); SYSTEM.PUT(spiData, n);
+    REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0)
+  END SPI;
+
+  PROCEDURE SPICmd(n, arg: INTEGER);
+    VAR i, data, crc: INTEGER;
+  BEGIN (*send cmd*)
+    REPEAT SPIIdle(1); SYSTEM.GET(spiData, data) UNTIL data = 255; (*flush while unselected*)
+    REPEAT SPI(255); SYSTEM.GET(spiData, data) UNTIL data = 255; (*flush while selected*)
+    IF n = 8 THEN crc := 135 ELSIF n = 0 THEN crc := 149 ELSE crc := 255 END;
+    SPI(n MOD 64 + 64); (*send command*)
+    FOR i := 24 TO 0 BY -8 DO SPI(ROR(arg, i)) END; (*send arg*)
+    SPI(crc); i := 32;
+    REPEAT SPI(255); SYSTEM.GET(spiData, data); DEC(i) UNTIL (data < 80H) OR (i = 0)
+  END SPICmd;
+
+  PROCEDURE InitSPI;
+    VAR res, data: INTEGER;
+  BEGIN SPIIdle(9); (*first, idle for at least 80 clks*)
+    SPICmd(0, 0); (*CMD0 when card selected, sets MMC SPI mode*)
+    SPICmd(8, 1AAH); SPI(-1); SPI(-1); SPI(-1); (*CMD8 for SD cards*)
+    REPEAT (*until card becomes ready*)
+      (*ACMD41, optionally with high-capacity (HCS) bit set, starts init*)
+      SPICmd(55, 0); (*APP cmd follows*)
+      SPICmd(41, LSL(1(*HCS*), 30));
+      SYSTEM.GET(spiData, res);
+      SPI(-1); SPI(-1); SPI(-1); (*flush response*)
+      SPIIdle(10000)
+    UNTIL res = 0;
+    (*CMD16 set block size as a precaution (should default)*)
+    SPICmd(16, 512); SPIIdle(1)
+  END InitSPI;
+
+  PROCEDURE SDShift(VAR n: INTEGER);
+    VAR data: INTEGER;
+  BEGIN SPICmd(58, 0);  (*CMD58 get card capacity bit*)
+    SYSTEM.GET(spiData, data); SPI(-1);
+    IF (data # 0) OR ~SYSTEM.BIT(spiData, 6) THEN n := n * 512 END ;  (*non-SDHC card*)
+    SPI(-1); SPI(-1); SPIIdle(1)  (*flush response*)
+  END SDShift;
+
+  PROCEDURE ReadSD(src, dst: INTEGER);
+    VAR i, data: INTEGER;
+  BEGIN SDShift(src); SPICmd(17, src); (*CMD17 read one block*)
+    i := 0; (*wait for start data marker*)
+    REPEAT SPI(-1); SYSTEM.GET(spiData, data); INC(i) UNTIL data = 254;
+    SYSTEM.PUT(spiCtrl, SPIFAST + CARD0);
+    FOR i := 0 TO 508 BY 4 DO
+      SYSTEM.PUT(spiData, -1);
+      REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0);
+      SYSTEM.GET(spiData, data); SYSTEM.PUT(dst, data); INC(dst, 4)
+    END;
+    SPI(255); SPI(255); SPIIdle(1) (*may be a checksum; deselect card*)
+  END ReadSD;
+
+  PROCEDURE LoadFromDisk;
+    VAR src, dst, adr, lim: INTEGER;
+  BEGIN src := FSoffset + 4;   (*start at boot block*)
+    ReadSD(src, 0); SYSTEM.GET(16, lim);
+    INC(src); dst := 512;
+    WHILE dst < lim DO ReadSD(src, dst); INC(src); INC(dst, 512) END
+  END LoadFromDisk;
+
+BEGIN SYSTEM.LDREG(SP, stackOrg); SYSTEM.LDREG(MT, MTOrg);
+  IF SYSTEM.REG(LNK) = 0 THEN (*cold start*)
+    LED(80H); InitSPI;
+    IF SYSTEM.BIT(swi, 0) THEN LED(81H); LoadFromLine ELSE LED(82H); LoadFromDisk END ;
+  ELSIF SYSTEM.BIT(swi, 0) THEN LED(81H); LoadFromLine
+  END ;
+  SYSTEM.PUT(12, MemLim); SYSTEM.PUT(24, stackOrg); LED(84H)
+END BootLoad.
+
+ORP.Compile @  ORG.Decode
+ORX.WriteFile BootLoad.rsc "Spartan" "D:/Verilog/RISC/scripts/ins1.mem"~
+ORG.WriteFile BootLoad.rsc "Spartan" "D:/Verilog/RISC3/scripts/ins1.mem" ~
+ORG.WriteFile BootLoad.rsc "Spartan" "D:/Verilog/RISC5/scripts/ins1.mem"~
+
+MODULE* BootLoad;  (*NW 10.2.2013, boot from line only*)
+  IMPORT SYSTEM;
+  CONST MT = 12; SP = 14; StkOrg = 0FFFE7F00H;
+    swi = -60; led = -60; data = -56; stat = -52;
+
+  PROCEDURE RecInt(VAR x: INTEGER);
+    VAR z, y, i: INTEGER;
+  BEGIN z := 0;  i := 4;
+    REPEAT i := i-1;
+      REPEAT UNTIL SYSTEM.BIT(stat, 0);
+      SYSTEM.GET(data, y); z := ROR(z+y, 8)
+    UNTIL i = 0;
+    x := z
+  END RecInt;
+
+  PROCEDURE Load;
+    VAR len, adr, dat: INTEGER;
+  BEGIN RecInt(len);
+    WHILE len > 0 DO
+      RecInt(adr);
+      REPEAT RecInt(dat); SYSTEM.PUT(adr, dat); adr := adr + 4; len := len - 4 UNTIL len = 0;
+      RecInt(len)
+    END ;
+    SYSTEM.GET(4, adr); SYSTEM.LDREG(13, adr); SYSTEM.LDREG(12, 20H)
+  END Load;
+
+BEGIN SYSTEM.LDREG(SP, StkOrg); SYSTEM.LDREG(MT, 20H); SYSTEM.PUT(led, 128); 
+  IF ~SYSTEM.BIT(swi, 0) THEN Load END
+END BootLoad.
+
+ORP.Compile @  ORG.Decode
+ORX.WriteFile Counter.rsc 2048 "D:/Verilog/RISC/prom.mem"~
+ORX.WriteFile Shifter.rsc 2048 "D:/Verilog/RISC/prom.mem"~
+ORX.WriteFile TestInt.rsc 2048 "D:/Verilog/RISC3/scripts/ins1.mem"~
+ORX.WriteFile BootLoad.rsc 512 "D:/Verilog/RISC5/prom.mem"~
+
+MODULE* Counter;
+  VAR x, y, z: INTEGER;
+BEGIN LED(1); z := 0;
+  REPEAT LED(z); x := 1000;
+     REPEAT y := 1000;
+       REPEAT y := y-1 UNTIL y = 0;
+       x := x-1
+     UNTIL x = 0;
+     z := z+1
+   UNTIL FALSE
+END Counter.
+
+MODULE* Shifter;
+  VAR x, y, z, d: INTEGER;
+BEGIN  z := 1; d := 1;
+  REPEAT LED(z); x := 1000;
+     REPEAT y := 1000;
+       REPEAT y := y-1 UNTIL y = 0;
+       x := x-1
+     UNTIL x = 0;
+     IF z = 128 THEN d := -1 ELSIF z = 1 THEN d := 1 END ;
+     IF d = 1 THEN z := LSL(z, 1) ELSE z := ASR(z, 1) END
+   UNTIL FALSE
+END Shifter.
+
+MODULE* TestInt;
+  IMPORT SYSTEM;
+  VAR led, led1, cnt, cnt1: INTEGER;
+
+  PROCEDURE* Int; (*interrupt every millisecond*)
+  BEGIN INC(cnt1);
+    IF cnt1 = 500 THEN led1 := 1 - led1; LED(led1); cnt1 := 0 END
+  END Int;
+
+BEGIN led := 0; led1 := 0; cnt := 0; cnt1 := 0;
+  SYSTEM.PUT(4, 0E7000000H + SYSTEM.ADR(Int) DIV 4 - 2);
+  SYSTEM.LDPSR(1);  (*int enable*)
+  REPEAT
+    IF SYSTEM.BIT(-60, 0) THEN
+      cnt := 100000;
+      REPEAT DEC(cnt) UNTIL cnt = 0;
+      LED(led); INC(led)
+    END
+  UNTIL FALSE;
+END TestInt.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Checkers.Mod.txt

@@ -1,47 +1,47 @@
-MODULE Checkers;  (*NW 4.10.90 / 10.3.2013*)
-  IMPORT SYSTEM, Display, Viewers, Oberon, MenuViewers, TextFrames;
-
-  TYPE Frame = POINTER TO FrameDesc;
-
-    FrameDesc = RECORD (Display.FrameDesc)
-        col: INTEGER
-      END ;
-
-  VAR i: INTEGER;
-    checks: INTEGER;
-    pat: ARRAY 17 OF INTEGER;
-
-  PROCEDURE Restore(F: Frame);
-  BEGIN Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
-    Display.ReplConst(Display.black, F.X, F.Y, F.W, F.H, Display.replace); (*clear*)
-    Display.ReplPattern(F.col, checks, F.X+1, F.Y, F.W-1, F.H-1, Display.paint)
-  END Restore;
-
-  PROCEDURE Handle(G: Display.Frame; VAR M: Display.FrameMsg);
-    VAR G1: Frame;
-  BEGIN
-    CASE G OF Frame:
-      CASE M OF
-      Oberon.InputMsg:
-        IF M.id = Oberon.track THEN Oberon.DrawMouseArrow(M.X, M.Y) END |
-      Oberon.CopyMsg:
-        Oberon.RemoveMarks(G.X, G.Y, G.W, G.H); NEW(G1); G1^ := G^; M.F := G1 |
-      MenuViewers.ModifyMsg:
-        IF (M.Y # G.Y) OR (M.H # G.H) THEN G.Y := M.Y; G.H := M.H; Restore(G) END
-      END
-    END
-  END Handle;
-
-  PROCEDURE Open*;
-    VAR F: Frame; V: Viewers.Viewer; X, Y: INTEGER;
-  BEGIN NEW(F); F.col := 14; F.handle := Handle;
-    Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
-    V := MenuViewers.New(
-      TextFrames.NewMenu("CheckerViewer", "System.Close System.Copy System.Grow"),
-      F, TextFrames.menuH, X, Y)
-  END Open;
-
-BEGIN checks := SYSTEM.ADR(pat); pat[0] := 1010H; i := 1;
-  REPEAT pat[i] := 0FF00FFH; INC(i) UNTIL i = 9;
-  REPEAT pat[i] := 0FF00FF00H; INC(i) UNTIL i = 17
-END Checkers.
+MODULE Checkers;  (*NW 4.10.90 / 10.3.2013*)
+  IMPORT SYSTEM, Display, Viewers, Oberon, MenuViewers, TextFrames;
+
+  TYPE Frame = POINTER TO FrameDesc;
+
+    FrameDesc = RECORD (Display.FrameDesc)
+        col: INTEGER
+      END ;
+
+  VAR i: INTEGER;
+    checks: INTEGER;
+    pat: ARRAY 17 OF INTEGER;
+
+  PROCEDURE Restore(F: Frame);
+  BEGIN Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
+    Display.ReplConst(Display.black, F.X, F.Y, F.W, F.H, Display.replace); (*clear*)
+    Display.ReplPattern(F.col, checks, F.X+1, F.Y, F.W-1, F.H-1, Display.paint)
+  END Restore;
+
+  PROCEDURE Handle(G: Display.Frame; VAR M: Display.FrameMsg);
+    VAR G1: Frame;
+  BEGIN
+    CASE G OF Frame:
+      CASE M OF
+      Oberon.InputMsg:
+        IF M.id = Oberon.track THEN Oberon.DrawMouseArrow(M.X, M.Y) END |
+      Oberon.CopyMsg:
+        Oberon.RemoveMarks(G.X, G.Y, G.W, G.H); NEW(G1); G1^ := G^; M.F := G1 |
+      MenuViewers.ModifyMsg:
+        IF (M.Y # G.Y) OR (M.H # G.H) THEN G.Y := M.Y; G.H := M.H; Restore(G) END
+      END
+    END
+  END Handle;
+
+  PROCEDURE Open*;
+    VAR F: Frame; V: Viewers.Viewer; X, Y: INTEGER;
+  BEGIN NEW(F); F.col := 14; F.handle := Handle;
+    Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
+    V := MenuViewers.New(
+      TextFrames.NewMenu("CheckerViewer", "System.Close System.Copy System.Grow"),
+      F, TextFrames.menuH, X, Y)
+  END Open;
+
+BEGIN checks := SYSTEM.ADR(pat); pat[0] := 1010H; i := 1;
+  REPEAT pat[i] := 0FF00FFH; INC(i) UNTIL i = 9;
+  REPEAT pat[i] := 0FF00FF00H; INC(i) UNTIL i = 17
+END Checkers.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Curves.Mod.txt

@@ -1,238 +1,238 @@
-MODULE Curves;  (*NW 8.11.90 / 18.4.2013*)
-  IMPORT Display, Files, Oberon, Graphics, GraphicFrames;
-
-  TYPE
-    Curve* = POINTER TO CurveDesc;
-
-    CurveDesc* = RECORD (Graphics.ObjectDesc)
-        kind*, lw*: INTEGER
-      END ;
-
-  (*kind: 0 = up-line, 1 = down-line, 2 = circle, 3 = ellipse*)
-
-  VAR method*: Graphics.Method;
-
-  PROCEDURE Dot(f: GraphicFrames.Frame; col, x, y: INTEGER);
-  BEGIN
-    IF (x >= f.X) & (x+7 < f.X1) & (y >= f.Y) & (x+7 < f.Y1) THEN Display.Dot(col, x, y, Display.replace) END
-  END Dot;
-
-  PROCEDURE mark(f: GraphicFrames.Frame; col, x, y: INTEGER);
-  BEGIN DEC(x, 3); DEC(y, 3);
-    IF (x >= f.X) & (x+7 < f.X1) & (y >= f.Y) & (y+7 < f.Y1) THEN
-      IF col = Display.black THEN Display.ReplConst(Display.black, x, y, 7, 7, Display.replace)
-      ELSE Display.CopyPattern(col, GraphicFrames.tack, x, y, Display.replace)
-      END
-    END
-  END mark;
-
-  PROCEDURE line(f: GraphicFrames.Frame; col: INTEGER; x, y, w, h, d: LONGINT);
-    VAR x1, y1, u: LONGINT;
-  BEGIN
-    IF h < w THEN
-      x1 := x+w; u := (h-w) DIV 2;
-      IF d = -1 THEN INC(y, h) END ;
-      WHILE x < x1 DO
-        Dot(f, col, x, y); INC(x);
-        IF u < 0 THEN INC(u, h) ELSE INC(u, h-w); INC(y, d) END
-      END
-    ELSE y1 := y+h; u := (w-h) DIV 2;
-      IF d = -1 THEN INC(x, w) END ;
-      WHILE y < y1 DO
-        Dot(f, col, x, y); INC(y);
-        IF u < 0 THEN INC(u, w) ELSE INC(u, w-h); INC(x, d) END
-      END
-    END
-  END line;
-
-  PROCEDURE circle(f: GraphicFrames.Frame; col: INTEGER; x0, y0, r: LONGINT);
-    VAR x, y, u: LONGINT;
-  BEGIN u := 1 - r; x := r; y := 0;
-    WHILE y <= x DO
-      Dot(f, col, x0+x, y0+y);
-      Dot(f, col, x0+y, y0+x);
-      Dot(f, col, x0-y, y0+x);
-      Dot(f, col, x0-x, y0+y);
-      Dot(f, col, x0-x, y0-y);
-      Dot(f, col, x0-y, y0-x);
-      Dot(f, col, x0+y, y0-x);
-      Dot(f, col, x0+x, y0-y);
-      IF u < 0 THEN INC(u, 2*y+3) ELSE INC(u, 2*(y-x)+5); DEC(x) END ;
-      INC(y)
-    END
-  END circle;
-
-  PROCEDURE ellipse(f: GraphicFrames.Frame; col: INTEGER; x0, y0, a, b: LONGINT);
-    VAR x, y, y1, aa, bb, d, g, h: LONGINT;
-  BEGIN aa := a*a; bb := b*b;
-    h := (aa DIV 4) - b*aa + bb; g := (9*aa DIV 4) - 3*b*aa + bb; x := 0; y := b;
-    WHILE g < 0 DO
-      Dot(f, col, x0+x, y0+y);
-      Dot(f, col, x0-x, y0+y);
-      Dot(f, col, x0-x, y0-y);
-      Dot(f, col, x0+x, y0-y);
-      IF h < 0 THEN d := (2*x+3)*bb; INC(g, d)
-      ELSE d := (2*x+3)*bb - 2*(y-1)*aa; INC(g, d + 2*aa); DEC(y)
-      END ;
-      INC(h, d); INC(x)
-    END ;
-    y1 := y; h := (bb DIV 4) - a*bb + aa; x := a; y := 0;
-    WHILE y <= y1 DO
-      Dot(f, col, x0+x, y0+y);
-      Dot(f, col, x0-x, y0+y);
-      Dot(f, col, x0-x, y0-y);
-      Dot(f, col, x0+x, y0-y);
-      IF h < 0 THEN INC(h, (2*y+3)*aa) ELSE INC(h, (2*y+3)*aa - 2*(x-1)*bb); DEC(x) END ;
-      INC(y)
-    END
-  END ellipse;
-
-  PROCEDURE New*;
-    VAR c: Curve;
-  BEGIN NEW(c); c.do := method; Graphics.New(c)
-  END New;
-
-  PROCEDURE Copy(src, dst: Graphics.Object);
-  BEGIN dst.x := src.x; dst.y := src.y; dst.w := src.w; dst.h := src.h; dst.col := src.col;
-    dst(Curve).kind := src(Curve).kind; dst(Curve).lw := src(Curve).lw
-  END Copy;
-
-  PROCEDURE Draw(obj: Graphics.Object; VAR M: Graphics.Msg);
-    VAR x, y, w, h, col: INTEGER; f: GraphicFrames.Frame;
-  BEGIN
-    CASE M OF  GraphicFrames.DrawMsg:
-      x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f;
-      IF M.col = Display.black THEN col := obj.col ELSE col := M.col END ;
-      IF (x < f.X1) & (f.X <= x+w) & (y < f.Y1) & (f.Y <= y+h) THEN
-        IF obj(Curve).kind = 0 THEN  (*up-line*)
-          IF M.mode = 0 THEN
-            IF obj.selected THEN mark(f, Display.white, x, y) END ;
-            line(f, col, x, y, w, h, 1)
-          ELSIF M.mode = 1 THEN mark(f, Display.white, x, y)
-          ELSIF M.mode = 2 THEN mark(f, f.col, x, y)
-          ELSIF M.mode = 3 THEN mark(f, Display.black, x, y); line(f, Display.black, x, y, w, h, 1)
-          END
-        ELSIF obj(Curve).kind = 1 THEN  (*down-line*)
-          IF M.mode = 0 THEN
-            IF obj.selected THEN mark(f, Display.white, x, y+h) END ;
-            line(f, col, x, y, w, h, -1)
-          ELSIF M.mode = 1 THEN mark(f, Display.white, x, y+h)
-          ELSIF M.mode = 2 THEN mark(f, f.col, x, y+h)
-          ELSIF M.mode = 3 THEN mark(f, Display.black, x, y+h); line(f, Display.black, x, y, w, h, -1)
-          END
-        ELSIF obj(Curve).kind = 2 THEN  (*circle*)
-          w := w DIV 2;
-          IF M.mode = 0 THEN
-            IF obj.selected THEN mark(f, Display.white, x+w, y) END ;
-            circle(f, col, x+w, y+w, w)
-          ELSIF M.mode = 1 THEN mark(f, Display.white, x+w, y)
-          ELSIF M.mode = 2 THEN mark(f, f.col, x+w, y)
-          ELSIF M.mode = 3 THEN mark(f, Display.black, x+w, y); circle(f, Display.black, x+w, y+w, w)
-          END
-        ELSIF obj(Curve).kind = 3 THEN  (*ellipse*)
-          w := w DIV 2; h := h DIV 2;
-          IF M.mode = 0 THEN
-            IF obj.selected THEN mark(f, Display.white, x+w, y) END ;
-            ellipse(f, col, x+w, y+h, w, h)
-          ELSIF M.mode = 1 THEN mark(f, Display.white, x+w, y)
-          ELSIF M.mode = 2 THEN mark(f, f.col, x+w, y)
-          ELSIF M.mode = 3 THEN mark(f, Display.black, x+w, y); ellipse(f, Display.black, x+w, y+h, w, h)
-          END
-        END
-      END
-    END
-  END Draw;
-
-  PROCEDURE Selectable(obj: Graphics.Object; x, y: INTEGER): BOOLEAN;
-    VAR xm, y0, w, h: INTEGER; res: BOOLEAN;
-  BEGIN
-    IF obj(Curve).kind <= 1 THEN  (*line*)
-      w := obj.w; h := obj.h;
-      IF obj(Curve).kind = 1 THEN y0 := obj.y + h; h := -h ELSE y0 := obj.y END ;
-      res := (obj.x <= x) & (x < obj.x + w) & (ABS(y-y0)*w - (x-obj.x)*h < w*4)
-    ELSE (*circle or ellipse*)
-      xm := obj.w DIV 2 + obj.x;
-      res := (xm - 4 <= x) & (x <= xm + 4) & (obj.y - 4 <= y) & (y <= obj.y + 4)
-    END ;
-    RETURN res
-  END Selectable;
-
-  PROCEDURE Change(obj: Graphics.Object; VAR M: Graphics.Msg);
-  BEGIN
-    IF M IS Graphics.ColorMsg THEN obj.col := M(Graphics.ColorMsg).col END
-  END Change;
-
-  PROCEDURE Read(obj: Graphics.Object; VAR R: Files.Rider; VAR C: Graphics.Context);
-    VAR len: BYTE;
-  BEGIN Files.ReadByte(R, len); Files.ReadByte(R, len); obj(Curve).kind := len;
-    Files.ReadByte(R, len); obj(Curve).lw := len
-  END Read;
-
-  PROCEDURE Write(obj: Graphics.Object; cno: INTEGER; VAR W: Files.Rider; VAR C: Graphics.Context);
-  BEGIN Graphics.WriteObj(W, cno, obj);
-    Files.WriteByte(W, 2); Files.WriteByte(W, obj(Curve).kind); Files.WriteByte(W, obj(Curve).lw)
-  END Write;
-
-  PROCEDURE MakeLine*;  (*command*)
-    VAR x0, x1, y0, y1: INTEGER;
-      c: Curve;
-      G: GraphicFrames.Frame;
-  BEGIN G := GraphicFrames.Focus();
-    IF (G # NIL) & (G.mark.next # NIL) THEN
-      GraphicFrames.Deselect(G);
-      x0 := G.mark.x; y0 := G.mark.y; x1 := G.mark.next.x; y1 := G.mark.next.y;
-      NEW(c); c.col := Oberon.CurCol;
-      c.w := ABS(x1-x0); c.h := ABS(y1-y0); c.lw := Graphics.width;
-      IF x0 <= x1 THEN c.x := x0;
-        IF y0 <= y1 THEN c.kind := 0; c.y := y0 ELSE c.kind := 1; c.y := y1 END
-      ELSE c.x := x1;
-        IF y1 < y0 THEN c.kind := 0; c.y := y1 ELSE c.kind := 1; c.y := y0 END
-      END ;
-      DEC(c.x, G.x); DEC(c.y, G.y); c.do := method;
-      Graphics.Add(G.graph, c);
-      GraphicFrames.Defocus(G); GraphicFrames.DrawObj(G, c)
-    END
-  END MakeLine;
-
-  PROCEDURE MakeCircle*;  (*command*)
-    VAR x0, y0, r: INTEGER;
-      c: Curve;
-      G: GraphicFrames.Frame;
-  BEGIN G := GraphicFrames.Focus();
-    IF (G # NIL) & (G.mark.next # NIL) THEN
-      GraphicFrames.Deselect(G);
-      x0 := G.mark.x; y0 := G.mark.y; r := ABS(G.mark.next.x-x0);
-      IF r > 4 THEN
-        NEW(c); c.x := x0 - r - G.x; c.y := y0 - r - G.y; c.w := 2*r+1; c.h := c.w;
-        c.kind := 2; c.col := Oberon.CurCol;
-        c.lw := Graphics.width; c.do := method;
-        Graphics.Add(G.graph, c);
-        GraphicFrames.Defocus(G); GraphicFrames.DrawObj(G, c)
-      END
-    END
-  END MakeCircle;
-
-  PROCEDURE MakeEllipse*;  (*command*)
-    VAR x0, y0, a, b: INTEGER;
-      c: Curve;
-      G: GraphicFrames.Frame;
-  BEGIN G := GraphicFrames.Focus();
-    IF (G # NIL) & (G.mark.next # NIL) & (G.mark.next.next # NIL) THEN
-      GraphicFrames.Deselect(G);
-      x0 := G.mark.x; y0 := G.mark.y;
-      a := ABS(G.mark.next.x-x0); b := ABS(G.mark.next.next.y - y0);
-      IF (a > 4) & (b > 4) THEN
-        NEW(c); c.x := x0 - a - G.x; c.y := y0 - b - G.y; c.w := 2*a+1; c.h := 2*b+1;
-        c.kind := 3; c.col := Oberon.CurCol;
-        c.lw := Graphics.width; c.do := method;
-        Graphics.Add(G.graph, c);
-        GraphicFrames.Defocus(G); GraphicFrames.DrawObj(G, c)
-      END
-    END
-  END MakeEllipse;
-
-BEGIN NEW(method); method.module := "Curves"; method.allocator := "New";
-  method.new := New; method.copy := Copy; method.draw := Draw;
-  method.selectable := Selectable; method.change := Change;
-  method.read := Read; method.write := Write
-END Curves.
+MODULE Curves;  (*NW 8.11.90 / 18.4.2013*)
+  IMPORT Display, Files, Oberon, Graphics, GraphicFrames;
+
+  TYPE
+    Curve* = POINTER TO CurveDesc;
+
+    CurveDesc* = RECORD (Graphics.ObjectDesc)
+        kind*, lw*: INTEGER
+      END ;
+
+  (*kind: 0 = up-line, 1 = down-line, 2 = circle, 3 = ellipse*)
+
+  VAR method*: Graphics.Method;
+
+  PROCEDURE Dot(f: GraphicFrames.Frame; col, x, y: INTEGER);
+  BEGIN
+    IF (x >= f.X) & (x+7 < f.X1) & (y >= f.Y) & (x+7 < f.Y1) THEN Display.Dot(col, x, y, Display.replace) END
+  END Dot;
+
+  PROCEDURE mark(f: GraphicFrames.Frame; col, x, y: INTEGER);
+  BEGIN DEC(x, 3); DEC(y, 3);
+    IF (x >= f.X) & (x+7 < f.X1) & (y >= f.Y) & (y+7 < f.Y1) THEN
+      IF col = Display.black THEN Display.ReplConst(Display.black, x, y, 7, 7, Display.replace)
+      ELSE Display.CopyPattern(col, GraphicFrames.tack, x, y, Display.replace)
+      END
+    END
+  END mark;
+
+  PROCEDURE line(f: GraphicFrames.Frame; col: INTEGER; x, y, w, h, d: LONGINT);
+    VAR x1, y1, u: LONGINT;
+  BEGIN
+    IF h < w THEN
+      x1 := x+w; u := (h-w) DIV 2;
+      IF d = -1 THEN INC(y, h) END ;
+      WHILE x < x1 DO
+        Dot(f, col, x, y); INC(x);
+        IF u < 0 THEN INC(u, h) ELSE INC(u, h-w); INC(y, d) END
+      END
+    ELSE y1 := y+h; u := (w-h) DIV 2;
+      IF d = -1 THEN INC(x, w) END ;
+      WHILE y < y1 DO
+        Dot(f, col, x, y); INC(y);
+        IF u < 0 THEN INC(u, w) ELSE INC(u, w-h); INC(x, d) END
+      END
+    END
+  END line;
+
+  PROCEDURE circle(f: GraphicFrames.Frame; col: INTEGER; x0, y0, r: LONGINT);
+    VAR x, y, u: LONGINT;
+  BEGIN u := 1 - r; x := r; y := 0;
+    WHILE y <= x DO
+      Dot(f, col, x0+x, y0+y);
+      Dot(f, col, x0+y, y0+x);
+      Dot(f, col, x0-y, y0+x);
+      Dot(f, col, x0-x, y0+y);
+      Dot(f, col, x0-x, y0-y);
+      Dot(f, col, x0-y, y0-x);
+      Dot(f, col, x0+y, y0-x);
+      Dot(f, col, x0+x, y0-y);
+      IF u < 0 THEN INC(u, 2*y+3) ELSE INC(u, 2*(y-x)+5); DEC(x) END ;
+      INC(y)
+    END
+  END circle;
+
+  PROCEDURE ellipse(f: GraphicFrames.Frame; col: INTEGER; x0, y0, a, b: LONGINT);
+    VAR x, y, y1, aa, bb, d, g, h: LONGINT;
+  BEGIN aa := a*a; bb := b*b;
+    h := (aa DIV 4) - b*aa + bb; g := (9*aa DIV 4) - 3*b*aa + bb; x := 0; y := b;
+    WHILE g < 0 DO
+      Dot(f, col, x0+x, y0+y);
+      Dot(f, col, x0-x, y0+y);
+      Dot(f, col, x0-x, y0-y);
+      Dot(f, col, x0+x, y0-y);
+      IF h < 0 THEN d := (2*x+3)*bb; INC(g, d)
+      ELSE d := (2*x+3)*bb - 2*(y-1)*aa; INC(g, d + 2*aa); DEC(y)
+      END ;
+      INC(h, d); INC(x)
+    END ;
+    y1 := y; h := (bb DIV 4) - a*bb + aa; x := a; y := 0;
+    WHILE y <= y1 DO
+      Dot(f, col, x0+x, y0+y);
+      Dot(f, col, x0-x, y0+y);
+      Dot(f, col, x0-x, y0-y);
+      Dot(f, col, x0+x, y0-y);
+      IF h < 0 THEN INC(h, (2*y+3)*aa) ELSE INC(h, (2*y+3)*aa - 2*(x-1)*bb); DEC(x) END ;
+      INC(y)
+    END
+  END ellipse;
+
+  PROCEDURE New*;
+    VAR c: Curve;
+  BEGIN NEW(c); c.do := method; Graphics.New(c)
+  END New;
+
+  PROCEDURE Copy(src, dst: Graphics.Object);
+  BEGIN dst.x := src.x; dst.y := src.y; dst.w := src.w; dst.h := src.h; dst.col := src.col;
+    dst(Curve).kind := src(Curve).kind; dst(Curve).lw := src(Curve).lw
+  END Copy;
+
+  PROCEDURE Draw(obj: Graphics.Object; VAR M: Graphics.Msg);
+    VAR x, y, w, h, col: INTEGER; f: GraphicFrames.Frame;
+  BEGIN
+    CASE M OF  GraphicFrames.DrawMsg:
+      x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f;
+      IF M.col = Display.black THEN col := obj.col ELSE col := M.col END ;
+      IF (x < f.X1) & (f.X <= x+w) & (y < f.Y1) & (f.Y <= y+h) THEN
+        IF obj(Curve).kind = 0 THEN  (*up-line*)
+          IF M.mode = 0 THEN
+            IF obj.selected THEN mark(f, Display.white, x, y) END ;
+            line(f, col, x, y, w, h, 1)
+          ELSIF M.mode = 1 THEN mark(f, Display.white, x, y)
+          ELSIF M.mode = 2 THEN mark(f, f.col, x, y)
+          ELSIF M.mode = 3 THEN mark(f, Display.black, x, y); line(f, Display.black, x, y, w, h, 1)
+          END
+        ELSIF obj(Curve).kind = 1 THEN  (*down-line*)
+          IF M.mode = 0 THEN
+            IF obj.selected THEN mark(f, Display.white, x, y+h) END ;
+            line(f, col, x, y, w, h, -1)
+          ELSIF M.mode = 1 THEN mark(f, Display.white, x, y+h)
+          ELSIF M.mode = 2 THEN mark(f, f.col, x, y+h)
+          ELSIF M.mode = 3 THEN mark(f, Display.black, x, y+h); line(f, Display.black, x, y, w, h, -1)
+          END
+        ELSIF obj(Curve).kind = 2 THEN  (*circle*)
+          w := w DIV 2;
+          IF M.mode = 0 THEN
+            IF obj.selected THEN mark(f, Display.white, x+w, y) END ;
+            circle(f, col, x+w, y+w, w)
+          ELSIF M.mode = 1 THEN mark(f, Display.white, x+w, y)
+          ELSIF M.mode = 2 THEN mark(f, f.col, x+w, y)
+          ELSIF M.mode = 3 THEN mark(f, Display.black, x+w, y); circle(f, Display.black, x+w, y+w, w)
+          END
+        ELSIF obj(Curve).kind = 3 THEN  (*ellipse*)
+          w := w DIV 2; h := h DIV 2;
+          IF M.mode = 0 THEN
+            IF obj.selected THEN mark(f, Display.white, x+w, y) END ;
+            ellipse(f, col, x+w, y+h, w, h)
+          ELSIF M.mode = 1 THEN mark(f, Display.white, x+w, y)
+          ELSIF M.mode = 2 THEN mark(f, f.col, x+w, y)
+          ELSIF M.mode = 3 THEN mark(f, Display.black, x+w, y); ellipse(f, Display.black, x+w, y+h, w, h)
+          END
+        END
+      END
+    END
+  END Draw;
+
+  PROCEDURE Selectable(obj: Graphics.Object; x, y: INTEGER): BOOLEAN;
+    VAR xm, y0, w, h: INTEGER; res: BOOLEAN;
+  BEGIN
+    IF obj(Curve).kind <= 1 THEN  (*line*)
+      w := obj.w; h := obj.h;
+      IF obj(Curve).kind = 1 THEN y0 := obj.y + h; h := -h ELSE y0 := obj.y END ;
+      res := (obj.x <= x) & (x < obj.x + w) & (ABS(y-y0)*w - (x-obj.x)*h < w*4)
+    ELSE (*circle or ellipse*)
+      xm := obj.w DIV 2 + obj.x;
+      res := (xm - 4 <= x) & (x <= xm + 4) & (obj.y - 4 <= y) & (y <= obj.y + 4)
+    END ;
+    RETURN res
+  END Selectable;
+
+  PROCEDURE Change(obj: Graphics.Object; VAR M: Graphics.Msg);
+  BEGIN
+    IF M IS Graphics.ColorMsg THEN obj.col := M(Graphics.ColorMsg).col END
+  END Change;
+
+  PROCEDURE Read(obj: Graphics.Object; VAR R: Files.Rider; VAR C: Graphics.Context);
+    VAR len: BYTE;
+  BEGIN Files.ReadByte(R, len); Files.ReadByte(R, len); obj(Curve).kind := len;
+    Files.ReadByte(R, len); obj(Curve).lw := len
+  END Read;
+
+  PROCEDURE Write(obj: Graphics.Object; cno: INTEGER; VAR W: Files.Rider; VAR C: Graphics.Context);
+  BEGIN Graphics.WriteObj(W, cno, obj);
+    Files.WriteByte(W, 2); Files.WriteByte(W, obj(Curve).kind); Files.WriteByte(W, obj(Curve).lw)
+  END Write;
+
+  PROCEDURE MakeLine*;  (*command*)
+    VAR x0, x1, y0, y1: INTEGER;
+      c: Curve;
+      G: GraphicFrames.Frame;
+  BEGIN G := GraphicFrames.Focus();
+    IF (G # NIL) & (G.mark.next # NIL) THEN
+      GraphicFrames.Deselect(G);
+      x0 := G.mark.x; y0 := G.mark.y; x1 := G.mark.next.x; y1 := G.mark.next.y;
+      NEW(c); c.col := Oberon.CurCol;
+      c.w := ABS(x1-x0); c.h := ABS(y1-y0); c.lw := Graphics.width;
+      IF x0 <= x1 THEN c.x := x0;
+        IF y0 <= y1 THEN c.kind := 0; c.y := y0 ELSE c.kind := 1; c.y := y1 END
+      ELSE c.x := x1;
+        IF y1 < y0 THEN c.kind := 0; c.y := y1 ELSE c.kind := 1; c.y := y0 END
+      END ;
+      DEC(c.x, G.x); DEC(c.y, G.y); c.do := method;
+      Graphics.Add(G.graph, c);
+      GraphicFrames.Defocus(G); GraphicFrames.DrawObj(G, c)
+    END
+  END MakeLine;
+
+  PROCEDURE MakeCircle*;  (*command*)
+    VAR x0, y0, r: INTEGER;
+      c: Curve;
+      G: GraphicFrames.Frame;
+  BEGIN G := GraphicFrames.Focus();
+    IF (G # NIL) & (G.mark.next # NIL) THEN
+      GraphicFrames.Deselect(G);
+      x0 := G.mark.x; y0 := G.mark.y; r := ABS(G.mark.next.x-x0);
+      IF r > 4 THEN
+        NEW(c); c.x := x0 - r - G.x; c.y := y0 - r - G.y; c.w := 2*r+1; c.h := c.w;
+        c.kind := 2; c.col := Oberon.CurCol;
+        c.lw := Graphics.width; c.do := method;
+        Graphics.Add(G.graph, c);
+        GraphicFrames.Defocus(G); GraphicFrames.DrawObj(G, c)
+      END
+    END
+  END MakeCircle;
+
+  PROCEDURE MakeEllipse*;  (*command*)
+    VAR x0, y0, a, b: INTEGER;
+      c: Curve;
+      G: GraphicFrames.Frame;
+  BEGIN G := GraphicFrames.Focus();
+    IF (G # NIL) & (G.mark.next # NIL) & (G.mark.next.next # NIL) THEN
+      GraphicFrames.Deselect(G);
+      x0 := G.mark.x; y0 := G.mark.y;
+      a := ABS(G.mark.next.x-x0); b := ABS(G.mark.next.next.y - y0);
+      IF (a > 4) & (b > 4) THEN
+        NEW(c); c.x := x0 - a - G.x; c.y := y0 - b - G.y; c.w := 2*a+1; c.h := 2*b+1;
+        c.kind := 3; c.col := Oberon.CurCol;
+        c.lw := Graphics.width; c.do := method;
+        Graphics.Add(G.graph, c);
+        GraphicFrames.Defocus(G); GraphicFrames.DrawObj(G, c)
+      END
+    END
+  END MakeEllipse;
+
+BEGIN NEW(method); method.module := "Curves"; method.allocator := "New";
+  method.new := New; method.copy := Copy; method.draw := Draw;
+  method.selectable := Selectable; method.change := Change;
+  method.read := Read; method.write := Write
+END Curves.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Display.Mod.txt

@@ -1,190 +1,190 @@
-MODULE Display;  (*NW 5.11.2013 / 17.1.2019*)
-  IMPORT SYSTEM;
-
-  CONST black* = 0; white* = 1;  (*black = background*)
-    replace* = 0; paint* = 1; invert* = 2;  (*modes*)
-    base = 0E7F00H;  (*adr of 1024 x 768 pixel, monocolor display frame*)
-
-  TYPE Frame* = POINTER TO FrameDesc;
-    FrameMsg* = RECORD END ;
-    Handler* = PROCEDURE (F: Frame; VAR M: FrameMsg);
-    FrameDesc* = RECORD next*, dsc*: Frame;
-        X*, Y*, W*, H*: INTEGER;
-        handle*: Handler
-      END ;
-
-  VAR Base*, Width*, Height*: INTEGER;
-    arrow*, star*, hook*, updown*, block*, cross*, grey*: INTEGER;
-    (*a pattern is an array of bytes; the first is its width (< 32), the second its height, the rest the raster*)
-
-  PROCEDURE Handle*(F: Frame; VAR M: FrameMsg);
-  BEGIN
-    IF (F # NIL) & (F.handle # NIL) THEN F.handle(F, M) END
-  END Handle;
-
-  (* raster ops *)
-    
-  PROCEDURE Dot*(col, x, y, mode: INTEGER);
-    VAR a: INTEGER; u, s: SET;
-  BEGIN a := base + (x DIV 32)*4 + y*128;
-    s := {x MOD 32}; SYSTEM.GET(a, u);
-    IF mode = paint THEN SYSTEM.PUT(a, u + s)
-    ELSIF mode = invert THEN SYSTEM.PUT(a, u / s)
-    ELSE (*mode = replace*)
-      IF col # black THEN SYSTEM.PUT(a, u + s) ELSE SYSTEM.PUT(a, u - s) END
-    END
-  END Dot;
-
-  PROCEDURE ReplConst*(col, x, y, w, h, mode: INTEGER);
-    VAR al, ar, a0, a1: INTEGER; left, right, mid, pix, pixl, pixr: SET;
-  BEGIN al := base + y*128;
-    ar := ((x+w-1) DIV 32)*4 + al; al := (x DIV 32)*4 + al;
-    IF ar = al THEN
-      mid := {(x MOD 32) .. ((x+w-1) MOD 32)};
-      FOR a1 := al TO al + (h-1)*128 BY 128 DO
-        SYSTEM.GET(a1, pix);
-        IF mode = invert THEN SYSTEM.PUT(a1, pix / mid)
-        ELSIF (mode = replace) & (col = black) THEN (*erase*) SYSTEM.PUT(a1, pix - mid)
-        ELSE (* (mode = paint) OR (mode = replace) & (col # black) *) SYSTEM.PUT(a1, pix + mid)
-        END
-      END
-    ELSIF ar > al THEN
-      left := {(x MOD 32) .. 31}; right := {0 .. ((x+w-1) MOD 32)};
-      FOR a0 := al TO al + (h-1)*128 BY 128 DO
-        SYSTEM.GET(a0, pixl); SYSTEM.GET(ar, pixr);
-        IF mode = invert THEN
-          SYSTEM.PUT(a0, pixl / left);
-          FOR a1 := a0+4 TO ar-4 BY 4 DO SYSTEM.GET(a1, pix); SYSTEM.PUT(a1, -pix) END ;
-          SYSTEM.PUT(ar, pixr / right)
-        ELSIF (mode = replace) & (col = black) THEN (*erase*)
-          SYSTEM.PUT(a0, pixl - left);
-          FOR a1 := a0+4 TO ar-4 BY 4 DO SYSTEM.PUT(a1, {}) END ;
-          SYSTEM.PUT(ar, pixr - right)
-        ELSE (* (mode = paint) OR (mode = replace) & (col # black) *)
-          SYSTEM.PUT(a0, pixl + left);
-          FOR a1 := a0+4 TO ar-4 BY 4 DO SYSTEM.PUT(a1, {0 .. 31}) END ;
-          SYSTEM.PUT(ar, pixr + right)
-        END ;
-        INC(ar, 128)
-      END
-    END
-  END ReplConst;
-
-  PROCEDURE CopyPattern*(col, patadr, x, y, mode: INTEGER);  (*only for modes = paint, invert*)
-    VAR a, a0, pwd: INTEGER;
-      w, h, pbt: BYTE; pix, mask: SET;
-  BEGIN SYSTEM.GET(patadr, w); SYSTEM.GET(patadr+1, h); INC(patadr, 2);
-    a := base + (x DIV 32)*4 + y*128; x := x MOD 32; mask := SYSTEM.VAL(SET, ASR(7FFFFFFFH, 31-x));
-    FOR a0 := a TO a + (h-1)*128 BY 128 DO
-      (*build pattern line; w <= 32*)
-      SYSTEM.GET(patadr, pbt); INC(patadr); pwd := pbt;
-      IF w > 8 THEN SYSTEM.GET(patadr, pbt); INC(patadr); pwd := pbt*100H + pwd;
-        IF w > 16 THEN SYSTEM.GET(patadr, pbt); INC(patadr); pwd := pbt*10000H + pwd;
-          IF w > 24 THEN SYSTEM.GET(patadr, pbt); INC(patadr); pwd := pbt*1000000H + pwd END
-        END
-      END ;
-      SYSTEM.GET(a0, pix);
-      IF mode = invert THEN SYSTEM.PUT(a0, SYSTEM.VAL(SET, LSL(pwd, x)) / pix)
-      ELSE SYSTEM.PUT(a0, SYSTEM.VAL(SET, LSL(pwd, x)) + pix)
-      END ;
-      IF x + w > 32 THEN (*spill over*)
-        SYSTEM.GET(a0+4, pix);
-        IF mode = invert THEN SYSTEM.PUT(a0+4, SYSTEM.VAL(SET, ASR(pwd, -x)) * mask/ pix)
-        ELSE SYSTEM.PUT(a0+4, SYSTEM.VAL(SET, ASR(pwd, -x)) * mask+ pix)
-        END
-      END
-    END
-  END CopyPattern;
-
-  PROCEDURE CopyBlock*(sx, sy, w, h, dx, dy, mode: INTEGER); (*only for mode = replace*)
-    VAR sa, da, sa0, sa1, d, len: INTEGER;
-      u0, u1, u2, u3, v0, v1, v2, v3, n: INTEGER;
-      end, step: INTEGER;
-      src, dst, spill: SET;
-      m0, m1, m2, m3: SET;
-  BEGIN
-    u0 := sx DIV 32; u1 := sx MOD 32; u2 := (sx+w) DIV 32; u3 := (sx+w) MOD 32;
-    v0 := dx DIV 32; v1 := dx MOD 32; v2 := (dx+w) DIV 32; v3 := (dx+w) MOD 32;
-    sa := base + u0*4 + sy*128; da := base + v0*4 + dy*128;
-    d := da - sa; n := u1 - v1;   (*displacement in words and bits*)
-    len := (u2 - u0) * 4;
-    m0 := {v1 .. 31}; m2 := {v3 .. 31}; m3 := m0 / m2;
-    IF d >= 0 THEN (*copy up, scan down*) sa0 := sa + (h-1)*128; end := sa-128; step := -128
-    ELSE (*copy down, scan up*) sa0 := sa; end := sa + h*128; step := 128
-    END ;
-    WHILE sa0 # end DO
-      IF n >= 0 THEN (*shift right*) m1 := {n .. 31};
-        IF v1 + w >= 32 THEN
-          SYSTEM.GET(sa0+len, src); src := ROR(src, n);
-          SYSTEM.GET(sa0+len+d, dst);
-          SYSTEM.PUT(sa0+len+d, (dst * m2) + (src - m2));
-          spill := src - m1;
-          FOR sa1 := sa0 + len-4 TO sa0+4  BY -4 DO
-            SYSTEM.GET(sa1, src); src := ROR(src, n);
-            SYSTEM.PUT(sa1+d, spill + (src * m1));
-            spill := src - m1
-          END ;
-          SYSTEM.GET(sa0, src); src := ROR(src, n);
-          SYSTEM.GET(sa0+d, dst);
-          SYSTEM.PUT(sa0+d, (src * m0) + (dst - m0))
-        ELSE SYSTEM.GET(sa0, src); src := ROR(src, n);
-          SYSTEM.GET(sa0+d, dst);
-          SYSTEM.PUT(sa0+d, (src * m3) + (dst - m3))
-        END
-      ELSE (*shift left*) m1 := {-n .. 31};
-        SYSTEM.GET(sa0, src); src := ROR(src, n);
-        SYSTEM.GET(sa0+d, dst);
-        IF v1 + w < 32 THEN
-          SYSTEM.PUT(sa0+d, (dst - m3) + (src * m3))
-        ELSE SYSTEM.PUT(sa0+d, (dst - m0) + (src * m0));
-          spill := src - m1;
-          FOR sa1 := sa0+4 TO sa0 + len-4 BY 4 DO
-            SYSTEM.GET(sa1, src); src := ROR(src, n);
-            SYSTEM.PUT(sa1+d, spill + (src * m1));
-            spill := src - m1
-          END ;
-          SYSTEM.GET(sa0+len, src); src := ROR(src, n);
-          SYSTEM.GET(sa0+len+d, dst);
-          SYSTEM.PUT(sa0+len+d, (src - m2) + (dst * m2))
-        END
-      END ;
-      INC(sa0, step)
-    END
-  END CopyBlock;
-
-  PROCEDURE ReplPattern*(col, patadr, x, y, w, h, mode: INTEGER);
-  (* pattern width = 32, fixed; pattern starts at patadr+4, for mode = invert only *)
-    VAR al, ar, a0, a1: INTEGER;
-      pta0, pta1: INTEGER;  (*pattern addresses*)
-      ph: BYTE;
-      left, right, mid, pix, pixl, pixr, ptw: SET;
-  BEGIN al := base + y*128; SYSTEM.GET(patadr+1, ph);
-    pta0 := patadr+4; pta1 := ph*4 + pta0;
-    ar := ((x+w-1) DIV 32)*4 + al; al := (x DIV 32)*4 + al;
-    IF ar = al THEN
-      mid := {(x MOD 32) .. ((x+w-1) MOD 32)};
-      FOR a1 := al TO al + (h-1)*128 BY 128 DO
-        SYSTEM.GET(a1, pix); SYSTEM.GET(pta0, ptw); SYSTEM.PUT(a1, (pix - mid) + (pix/ptw * mid)); INC(pta0, 4);
-        IF pta0 = pta1 THEN pta0 := patadr+4 END
-      END
-    ELSIF ar > al THEN
-      left := {(x MOD 32) .. 31}; right := {0 .. ((x+w-1) MOD 32)};
-      FOR a0 := al TO al + (h-1)*128 BY 128 DO
-        SYSTEM.GET(a0, pixl); SYSTEM.GET(pta0, ptw); SYSTEM.PUT(a0, (pixl - left) + (pixl/ptw * left));
-        FOR a1 := a0+4 TO ar-4 BY 4 DO SYSTEM.GET(a1, pix); SYSTEM.PUT(a1, pix/ptw) END ;
-        SYSTEM.GET(ar, pixr); SYSTEM.PUT(ar, (pixr - right) + (pixr/ptw * right));
-        INC(pta0, 4); INC(ar, 128);
-        IF pta0 = pta1 THEN pta0 := patadr+4 END
-      END
-    END
-  END ReplPattern;
-
-BEGIN Base := base; Width := 1024; Height := 768;
-  arrow := SYSTEM.ADR($0F0F 0060 0070 0038 001C 000E 0007 8003 C101 E300 7700 3F00 1F00 3F00 7F00 FF00$);
-  star := SYSTEM.ADR($0F0F 8000 8220 8410 8808 9004 A002 C001 7F7F C001 A002 9004 8808 8410 8220 8000$);
-  hook := SYSTEM.ADR($0C0C 070F 8707 C703 E701 F700 7F00 3F00 1F00 0F00 0700 0300 01$);
-  updown := SYSTEM.ADR($080E 183C 7EFF 1818 1818 1818 FF7E3C18$);
-  block := SYSTEM.ADR($0808 FFFF C3C3 C3C3 FFFF$);
-  cross := SYSTEM.ADR($0F0F 0140 0220 0410 0808 1004 2002 4001 0000 4001 2002 1004 0808 0410 0220 0140$);
-  grey := SYSTEM.ADR($2002 0000 5555 5555 AAAA AAAA$)
-END Display.
+MODULE Display;  (*NW 5.11.2013 / 17.1.2019*)
+  IMPORT SYSTEM;
+
+  CONST black* = 0; white* = 1;  (*black = background*)
+    replace* = 0; paint* = 1; invert* = 2;  (*modes*)
+    base = 0E7F00H;  (*adr of 1024 x 768 pixel, monocolor display frame*)
+
+  TYPE Frame* = POINTER TO FrameDesc;
+    FrameMsg* = RECORD END ;
+    Handler* = PROCEDURE (F: Frame; VAR M: FrameMsg);
+    FrameDesc* = RECORD next*, dsc*: Frame;
+        X*, Y*, W*, H*: INTEGER;
+        handle*: Handler
+      END ;
+
+  VAR Base*, Width*, Height*: INTEGER;
+    arrow*, star*, hook*, updown*, block*, cross*, grey*: INTEGER;
+    (*a pattern is an array of bytes; the first is its width (< 32), the second its height, the rest the raster*)
+
+  PROCEDURE Handle*(F: Frame; VAR M: FrameMsg);
+  BEGIN
+    IF (F # NIL) & (F.handle # NIL) THEN F.handle(F, M) END
+  END Handle;
+
+  (* raster ops *)
+    
+  PROCEDURE Dot*(col, x, y, mode: INTEGER);
+    VAR a: INTEGER; u, s: SET;
+  BEGIN a := base + (x DIV 32)*4 + y*128;
+    s := {x MOD 32}; SYSTEM.GET(a, u);
+    IF mode = paint THEN SYSTEM.PUT(a, u + s)
+    ELSIF mode = invert THEN SYSTEM.PUT(a, u / s)
+    ELSE (*mode = replace*)
+      IF col # black THEN SYSTEM.PUT(a, u + s) ELSE SYSTEM.PUT(a, u - s) END
+    END
+  END Dot;
+
+  PROCEDURE ReplConst*(col, x, y, w, h, mode: INTEGER);
+    VAR al, ar, a0, a1: INTEGER; left, right, mid, pix, pixl, pixr: SET;
+  BEGIN al := base + y*128;
+    ar := ((x+w-1) DIV 32)*4 + al; al := (x DIV 32)*4 + al;
+    IF ar = al THEN
+      mid := {(x MOD 32) .. ((x+w-1) MOD 32)};
+      FOR a1 := al TO al + (h-1)*128 BY 128 DO
+        SYSTEM.GET(a1, pix);
+        IF mode = invert THEN SYSTEM.PUT(a1, pix / mid)
+        ELSIF (mode = replace) & (col = black) THEN (*erase*) SYSTEM.PUT(a1, pix - mid)
+        ELSE (* (mode = paint) OR (mode = replace) & (col # black) *) SYSTEM.PUT(a1, pix + mid)
+        END
+      END
+    ELSIF ar > al THEN
+      left := {(x MOD 32) .. 31}; right := {0 .. ((x+w-1) MOD 32)};
+      FOR a0 := al TO al + (h-1)*128 BY 128 DO
+        SYSTEM.GET(a0, pixl); SYSTEM.GET(ar, pixr);
+        IF mode = invert THEN
+          SYSTEM.PUT(a0, pixl / left);
+          FOR a1 := a0+4 TO ar-4 BY 4 DO SYSTEM.GET(a1, pix); SYSTEM.PUT(a1, -pix) END ;
+          SYSTEM.PUT(ar, pixr / right)
+        ELSIF (mode = replace) & (col = black) THEN (*erase*)
+          SYSTEM.PUT(a0, pixl - left);
+          FOR a1 := a0+4 TO ar-4 BY 4 DO SYSTEM.PUT(a1, {}) END ;
+          SYSTEM.PUT(ar, pixr - right)
+        ELSE (* (mode = paint) OR (mode = replace) & (col # black) *)
+          SYSTEM.PUT(a0, pixl + left);
+          FOR a1 := a0+4 TO ar-4 BY 4 DO SYSTEM.PUT(a1, {0 .. 31}) END ;
+          SYSTEM.PUT(ar, pixr + right)
+        END ;
+        INC(ar, 128)
+      END
+    END
+  END ReplConst;
+
+  PROCEDURE CopyPattern*(col, patadr, x, y, mode: INTEGER);  (*only for modes = paint, invert*)
+    VAR a, a0, pwd: INTEGER;
+      w, h, pbt: BYTE; pix, mask: SET;
+  BEGIN SYSTEM.GET(patadr, w); SYSTEM.GET(patadr+1, h); INC(patadr, 2);
+    a := base + (x DIV 32)*4 + y*128; x := x MOD 32; mask := SYSTEM.VAL(SET, ASR(7FFFFFFFH, 31-x));
+    FOR a0 := a TO a + (h-1)*128 BY 128 DO
+      (*build pattern line; w <= 32*)
+      SYSTEM.GET(patadr, pbt); INC(patadr); pwd := pbt;
+      IF w > 8 THEN SYSTEM.GET(patadr, pbt); INC(patadr); pwd := pbt*100H + pwd;
+        IF w > 16 THEN SYSTEM.GET(patadr, pbt); INC(patadr); pwd := pbt*10000H + pwd;
+          IF w > 24 THEN SYSTEM.GET(patadr, pbt); INC(patadr); pwd := pbt*1000000H + pwd END
+        END
+      END ;
+      SYSTEM.GET(a0, pix);
+      IF mode = invert THEN SYSTEM.PUT(a0, SYSTEM.VAL(SET, LSL(pwd, x)) / pix)
+      ELSE SYSTEM.PUT(a0, SYSTEM.VAL(SET, LSL(pwd, x)) + pix)
+      END ;
+      IF x + w > 32 THEN (*spill over*)
+        SYSTEM.GET(a0+4, pix);
+        IF mode = invert THEN SYSTEM.PUT(a0+4, SYSTEM.VAL(SET, ASR(pwd, -x)) * mask/ pix)
+        ELSE SYSTEM.PUT(a0+4, SYSTEM.VAL(SET, ASR(pwd, -x)) * mask+ pix)
+        END
+      END
+    END
+  END CopyPattern;
+
+  PROCEDURE CopyBlock*(sx, sy, w, h, dx, dy, mode: INTEGER); (*only for mode = replace*)
+    VAR sa, da, sa0, sa1, d, len: INTEGER;
+      u0, u1, u2, u3, v0, v1, v2, v3, n: INTEGER;
+      end, step: INTEGER;
+      src, dst, spill: SET;
+      m0, m1, m2, m3: SET;
+  BEGIN
+    u0 := sx DIV 32; u1 := sx MOD 32; u2 := (sx+w) DIV 32; u3 := (sx+w) MOD 32;
+    v0 := dx DIV 32; v1 := dx MOD 32; v2 := (dx+w) DIV 32; v3 := (dx+w) MOD 32;
+    sa := base + u0*4 + sy*128; da := base + v0*4 + dy*128;
+    d := da - sa; n := u1 - v1;   (*displacement in words and bits*)
+    len := (u2 - u0) * 4;
+    m0 := {v1 .. 31}; m2 := {v3 .. 31}; m3 := m0 / m2;
+    IF d >= 0 THEN (*copy up, scan down*) sa0 := sa + (h-1)*128; end := sa-128; step := -128
+    ELSE (*copy down, scan up*) sa0 := sa; end := sa + h*128; step := 128
+    END ;
+    WHILE sa0 # end DO
+      IF n >= 0 THEN (*shift right*) m1 := {n .. 31};
+        IF v1 + w >= 32 THEN
+          SYSTEM.GET(sa0+len, src); src := ROR(src, n);
+          SYSTEM.GET(sa0+len+d, dst);
+          SYSTEM.PUT(sa0+len+d, (dst * m2) + (src - m2));
+          spill := src - m1;
+          FOR sa1 := sa0 + len-4 TO sa0+4  BY -4 DO
+            SYSTEM.GET(sa1, src); src := ROR(src, n);
+            SYSTEM.PUT(sa1+d, spill + (src * m1));
+            spill := src - m1
+          END ;
+          SYSTEM.GET(sa0, src); src := ROR(src, n);
+          SYSTEM.GET(sa0+d, dst);
+          SYSTEM.PUT(sa0+d, (src * m0) + (dst - m0))
+        ELSE SYSTEM.GET(sa0, src); src := ROR(src, n);
+          SYSTEM.GET(sa0+d, dst);
+          SYSTEM.PUT(sa0+d, (src * m3) + (dst - m3))
+        END
+      ELSE (*shift left*) m1 := {-n .. 31};
+        SYSTEM.GET(sa0, src); src := ROR(src, n);
+        SYSTEM.GET(sa0+d, dst);
+        IF v1 + w < 32 THEN
+          SYSTEM.PUT(sa0+d, (dst - m3) + (src * m3))
+        ELSE SYSTEM.PUT(sa0+d, (dst - m0) + (src * m0));
+          spill := src - m1;
+          FOR sa1 := sa0+4 TO sa0 + len-4 BY 4 DO
+            SYSTEM.GET(sa1, src); src := ROR(src, n);
+            SYSTEM.PUT(sa1+d, spill + (src * m1));
+            spill := src - m1
+          END ;
+          SYSTEM.GET(sa0+len, src); src := ROR(src, n);
+          SYSTEM.GET(sa0+len+d, dst);
+          SYSTEM.PUT(sa0+len+d, (src - m2) + (dst * m2))
+        END
+      END ;
+      INC(sa0, step)
+    END
+  END CopyBlock;
+
+  PROCEDURE ReplPattern*(col, patadr, x, y, w, h, mode: INTEGER);
+  (* pattern width = 32, fixed; pattern starts at patadr+4, for mode = invert only *)
+    VAR al, ar, a0, a1: INTEGER;
+      pta0, pta1: INTEGER;  (*pattern addresses*)
+      ph: BYTE;
+      left, right, mid, pix, pixl, pixr, ptw: SET;
+  BEGIN al := base + y*128; SYSTEM.GET(patadr+1, ph);
+    pta0 := patadr+4; pta1 := ph*4 + pta0;
+    ar := ((x+w-1) DIV 32)*4 + al; al := (x DIV 32)*4 + al;
+    IF ar = al THEN
+      mid := {(x MOD 32) .. ((x+w-1) MOD 32)};
+      FOR a1 := al TO al + (h-1)*128 BY 128 DO
+        SYSTEM.GET(a1, pix); SYSTEM.GET(pta0, ptw); SYSTEM.PUT(a1, (pix - mid) + (pix/ptw * mid)); INC(pta0, 4);
+        IF pta0 = pta1 THEN pta0 := patadr+4 END
+      END
+    ELSIF ar > al THEN
+      left := {(x MOD 32) .. 31}; right := {0 .. ((x+w-1) MOD 32)};
+      FOR a0 := al TO al + (h-1)*128 BY 128 DO
+        SYSTEM.GET(a0, pixl); SYSTEM.GET(pta0, ptw); SYSTEM.PUT(a0, (pixl - left) + (pixl/ptw * left));
+        FOR a1 := a0+4 TO ar-4 BY 4 DO SYSTEM.GET(a1, pix); SYSTEM.PUT(a1, pix/ptw) END ;
+        SYSTEM.GET(ar, pixr); SYSTEM.PUT(ar, (pixr - right) + (pixr/ptw * right));
+        INC(pta0, 4); INC(ar, 128);
+        IF pta0 = pta1 THEN pta0 := patadr+4 END
+      END
+    END
+  END ReplPattern;
+
+BEGIN Base := base; Width := 1024; Height := 768;
+  arrow := SYSTEM.ADR($0F0F 0060 0070 0038 001C 000E 0007 8003 C101 E300 7700 3F00 1F00 3F00 7F00 FF00$);
+  star := SYSTEM.ADR($0F0F 8000 8220 8410 8808 9004 A002 C001 7F7F C001 A002 9004 8808 8410 8220 8000$);
+  hook := SYSTEM.ADR($0C0C 070F 8707 C703 E701 F700 7F00 3F00 1F00 0F00 0700 0300 01$);
+  updown := SYSTEM.ADR($080E 183C 7EFF 1818 1818 1818 FF7E3C18$);
+  block := SYSTEM.ADR($0808 FFFF C3C3 C3C3 FFFF$);
+  cross := SYSTEM.ADR($0F0F 0140 0220 0410 0808 1004 2002 4001 0000 4001 2002 1004 0808 0410 0220 0140$);
+  grey := SYSTEM.ADR($2002 0000 5555 5555 AAAA AAAA$)
+END Display.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Draw.Mod.txt

@@ -1,156 +1,156 @@
-MODULE Draw; (*NW 29.6.88 / 12.11.94 / 18.11.2013*)
-
-  IMPORT Files, Fonts, Viewers, Texts, Oberon,
-    TextFrames, MenuViewers, Graphics, GraphicFrames;
-
-  CONST Menu = "System.Close  System.Copy  System.Grow  Draw.Delete  Draw.Ticks  Draw.Restore  Draw.Store";
-
-  VAR W: Texts.Writer;
-
-  (*Exported commands:
-    Open, Delete,
-    SetWidth, ChangeColor, ChangeWidth, ChangeFont,
-    Store, Print, Macro, Ticks, Restore*)
-
-  PROCEDURE Open*;
-    VAR X, Y: INTEGER;
-      beg, end, t: LONGINT;
-      G: Graphics.Graph;
-      F: GraphicFrames.Frame;
-      V: Viewers.Viewer;
-      S: Texts.Scanner;
-      text: Texts.Text;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF (S.class = Texts.Char) & (S.c = "^") THEN
-      Oberon.GetSelection(text, beg, end, t);
-      IF t >= 0 THEN Texts.OpenScanner(S, text, beg); Texts.Scan(S) END
-    END ;
-    IF S.class = Texts.Name THEN
-      NEW(G); Graphics.Open(G, S.s);
-      NEW(F); GraphicFrames.Open(F, G);
-      Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
-      V := MenuViewers.New(TextFrames.NewMenu(S.s, Menu), F, TextFrames.menuH, X, Y)
-    END
-  END Open;
-
-  PROCEDURE Delete*;
-    VAR F: GraphicFrames.Frame;
-  BEGIN
-    IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN
-      F := Oberon.Par.vwr.dsc.next(GraphicFrames.Frame);
-      GraphicFrames.Erase(F); Graphics.Delete(F.graph)
-    END
-  END Delete;
-
-  PROCEDURE GetArg(VAR S: Texts.Scanner);
-    VAR T: Texts.Text; beg, end, time: LONGINT;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF (S.class = Texts.Char) & (S.c = "^") THEN
-      Oberon.GetSelection(T, beg, end, time);
-      IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
-    END
-  END GetArg;
-
-  PROCEDURE SetWidth*;
-    VAR S: Texts.Scanner;
-  BEGIN GetArg(S);
-    IF (S.class = Texts.Int) & (S.i > 0) & (S.i < 7) THEN Graphics.SetWidth(S.i) END
-  END SetWidth;
-
-  PROCEDURE ChangeColor*;
-    VAR S: Texts.Scanner; CM: Graphics.ColorMsg;
-  BEGIN GetArg(S);
-    IF S.class = Texts.Int THEN
-      CM.col := S.i MOD 16; GraphicFrames.Change(GraphicFrames.Selected(), CM)
-    END
-  END ChangeColor;
-
-  PROCEDURE ChangeWidth*;
-    VAR S: Texts.Scanner; WM: Graphics.WidMsg;
-  BEGIN GetArg(S);
-    IF S.class = Texts.Int THEN
-      WM.w := S.i; GraphicFrames.Change(GraphicFrames.Selected(), WM)
-    END
-  END ChangeWidth;
-
-  PROCEDURE ChangeFont*;
-    VAR S: Texts.Scanner; FM: Graphics.FontMsg;
-  BEGIN GetArg(S);
-    IF S.class = Texts.Name THEN
-      FM.fnt := Fonts.This(S.s);
-      IF FM.fnt # NIL THEN GraphicFrames.Change(GraphicFrames.Selected(), FM) END
-    END
-  END ChangeFont;
-
-  PROCEDURE Redraw(Q: BOOLEAN);
-    VAR v: Viewers.Viewer; G: GraphicFrames.Frame;
-  BEGIN
-    IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN v := Oberon.Par.vwr
-    ELSE v := Oberon.MarkedViewer()
-    END ;
-    IF (v # NIL) & (v.dsc # NIL) & (v.dsc.next IS GraphicFrames.Frame) THEN
-      G := v.dsc.next(GraphicFrames.Frame); G.ticked := Q OR ~G.ticked; GraphicFrames.Restore(G)
-    END
-  END Redraw;
-
-  PROCEDURE Ticks*;
-  BEGIN Redraw(FALSE)
-  END Ticks;
-
-  PROCEDURE Restore*;
-  BEGIN Redraw(TRUE)
-  END Restore;
-
-  PROCEDURE Backup (VAR name: ARRAY OF CHAR);
-    VAR res, i: INTEGER; ch: CHAR;
-      bak: ARRAY 32 OF CHAR;
-  BEGIN i := 0; ch := name[0];
-    WHILE ch > 0X DO bak[i] := ch; INC(i); ch := name[i] END ;
-    IF i < 28 THEN
-      bak[i] := "."; bak[i+1] := "B"; bak[i+2] := "a"; bak[i+3] := "k"; bak[i+4] := 0X;
-      Files.Rename(name, bak, res)
-    END
-  END Backup;
-
-  PROCEDURE Store*;
-    VAR S: Texts.Scanner;
-      Menu: TextFrames.Frame; G: GraphicFrames.Frame;
-      v: Viewers.Viewer;
-  BEGIN
-    IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN
-      Menu := Oberon.Par.vwr.dsc(TextFrames.Frame); G := Menu.next(GraphicFrames.Frame);
-      Texts.OpenScanner(S, Menu.text, 0); Texts.Scan(S);
-      IF S.class = Texts.Name THEN
-        Texts.WriteString(W, S.s); Texts.WriteString(W, " storing");
-        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-        Backup(S.s); GraphicFrames.Store(G, S.s)
-      END
-    ELSE
-      Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-      IF S.class = Texts.Name THEN
-        v := Oberon.MarkedViewer();
-        IF (v.dsc # NIL) & (v.dsc.next IS GraphicFrames.Frame) THEN
-          G := v.dsc.next(GraphicFrames.Frame);
-          Texts.WriteString(W, S.s); Texts.WriteString(W, " storing");
-          Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-          Backup(S.s); GraphicFrames.Store(G, S.s)
-        END
-      END
-    END
-  END Store;
-
-  PROCEDURE Macro*;
-    VAR S: Texts.Scanner;
-      T: Texts.Text;
-      time, beg, end: LONGINT;
-      Lname: ARRAY 32 OF CHAR;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-      Lname := S.s; Texts.Scan(S);
-      IF S.class = Texts.Name THEN GraphicFrames.Macro(Lname, S.s) END ;
-    END
-  END Macro;
-
-BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "Draw - NW 9.8.2013");
-  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-END Draw.
+MODULE Draw; (*NW 29.6.88 / 12.11.94 / 18.11.2013*)
+
+  IMPORT Files, Fonts, Viewers, Texts, Oberon,
+    TextFrames, MenuViewers, Graphics, GraphicFrames;
+
+  CONST Menu = "System.Close  System.Copy  System.Grow  Draw.Delete  Draw.Ticks  Draw.Restore  Draw.Store";
+
+  VAR W: Texts.Writer;
+
+  (*Exported commands:
+    Open, Delete,
+    SetWidth, ChangeColor, ChangeWidth, ChangeFont,
+    Store, Print, Macro, Ticks, Restore*)
+
+  PROCEDURE Open*;
+    VAR X, Y: INTEGER;
+      beg, end, t: LONGINT;
+      G: Graphics.Graph;
+      F: GraphicFrames.Frame;
+      V: Viewers.Viewer;
+      S: Texts.Scanner;
+      text: Texts.Text;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF (S.class = Texts.Char) & (S.c = "^") THEN
+      Oberon.GetSelection(text, beg, end, t);
+      IF t >= 0 THEN Texts.OpenScanner(S, text, beg); Texts.Scan(S) END
+    END ;
+    IF S.class = Texts.Name THEN
+      NEW(G); Graphics.Open(G, S.s);
+      NEW(F); GraphicFrames.Open(F, G);
+      Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
+      V := MenuViewers.New(TextFrames.NewMenu(S.s, Menu), F, TextFrames.menuH, X, Y)
+    END
+  END Open;
+
+  PROCEDURE Delete*;
+    VAR F: GraphicFrames.Frame;
+  BEGIN
+    IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN
+      F := Oberon.Par.vwr.dsc.next(GraphicFrames.Frame);
+      GraphicFrames.Erase(F); Graphics.Delete(F.graph)
+    END
+  END Delete;
+
+  PROCEDURE GetArg(VAR S: Texts.Scanner);
+    VAR T: Texts.Text; beg, end, time: LONGINT;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF (S.class = Texts.Char) & (S.c = "^") THEN
+      Oberon.GetSelection(T, beg, end, time);
+      IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
+    END
+  END GetArg;
+
+  PROCEDURE SetWidth*;
+    VAR S: Texts.Scanner;
+  BEGIN GetArg(S);
+    IF (S.class = Texts.Int) & (S.i > 0) & (S.i < 7) THEN Graphics.SetWidth(S.i) END
+  END SetWidth;
+
+  PROCEDURE ChangeColor*;
+    VAR S: Texts.Scanner; CM: Graphics.ColorMsg;
+  BEGIN GetArg(S);
+    IF S.class = Texts.Int THEN
+      CM.col := S.i MOD 16; GraphicFrames.Change(GraphicFrames.Selected(), CM)
+    END
+  END ChangeColor;
+
+  PROCEDURE ChangeWidth*;
+    VAR S: Texts.Scanner; WM: Graphics.WidMsg;
+  BEGIN GetArg(S);
+    IF S.class = Texts.Int THEN
+      WM.w := S.i; GraphicFrames.Change(GraphicFrames.Selected(), WM)
+    END
+  END ChangeWidth;
+
+  PROCEDURE ChangeFont*;
+    VAR S: Texts.Scanner; FM: Graphics.FontMsg;
+  BEGIN GetArg(S);
+    IF S.class = Texts.Name THEN
+      FM.fnt := Fonts.This(S.s);
+      IF FM.fnt # NIL THEN GraphicFrames.Change(GraphicFrames.Selected(), FM) END
+    END
+  END ChangeFont;
+
+  PROCEDURE Redraw(Q: BOOLEAN);
+    VAR v: Viewers.Viewer; G: GraphicFrames.Frame;
+  BEGIN
+    IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN v := Oberon.Par.vwr
+    ELSE v := Oberon.MarkedViewer()
+    END ;
+    IF (v # NIL) & (v.dsc # NIL) & (v.dsc.next IS GraphicFrames.Frame) THEN
+      G := v.dsc.next(GraphicFrames.Frame); G.ticked := Q OR ~G.ticked; GraphicFrames.Restore(G)
+    END
+  END Redraw;
+
+  PROCEDURE Ticks*;
+  BEGIN Redraw(FALSE)
+  END Ticks;
+
+  PROCEDURE Restore*;
+  BEGIN Redraw(TRUE)
+  END Restore;
+
+  PROCEDURE Backup (VAR name: ARRAY OF CHAR);
+    VAR res, i: INTEGER; ch: CHAR;
+      bak: ARRAY 32 OF CHAR;
+  BEGIN i := 0; ch := name[0];
+    WHILE ch > 0X DO bak[i] := ch; INC(i); ch := name[i] END ;
+    IF i < 28 THEN
+      bak[i] := "."; bak[i+1] := "B"; bak[i+2] := "a"; bak[i+3] := "k"; bak[i+4] := 0X;
+      Files.Rename(name, bak, res)
+    END
+  END Backup;
+
+  PROCEDURE Store*;
+    VAR S: Texts.Scanner;
+      Menu: TextFrames.Frame; G: GraphicFrames.Frame;
+      v: Viewers.Viewer;
+  BEGIN
+    IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN
+      Menu := Oberon.Par.vwr.dsc(TextFrames.Frame); G := Menu.next(GraphicFrames.Frame);
+      Texts.OpenScanner(S, Menu.text, 0); Texts.Scan(S);
+      IF S.class = Texts.Name THEN
+        Texts.WriteString(W, S.s); Texts.WriteString(W, " storing");
+        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+        Backup(S.s); GraphicFrames.Store(G, S.s)
+      END
+    ELSE
+      Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+      IF S.class = Texts.Name THEN
+        v := Oberon.MarkedViewer();
+        IF (v.dsc # NIL) & (v.dsc.next IS GraphicFrames.Frame) THEN
+          G := v.dsc.next(GraphicFrames.Frame);
+          Texts.WriteString(W, S.s); Texts.WriteString(W, " storing");
+          Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+          Backup(S.s); GraphicFrames.Store(G, S.s)
+        END
+      END
+    END
+  END Store;
+
+  PROCEDURE Macro*;
+    VAR S: Texts.Scanner;
+      T: Texts.Text;
+      time, beg, end: LONGINT;
+      Lname: ARRAY 32 OF CHAR;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+      Lname := S.s; Texts.Scan(S);
+      IF S.class = Texts.Name THEN GraphicFrames.Macro(Lname, S.s) END ;
+    END
+  END Macro;
+
+BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "Draw - NW 9.8.2013");
+  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+END Draw.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Draw.Tool.txt

@@ -1,11 +1,11 @@
-Draw.Open XX.Graph  Draw.Store 
-Rectangles.Make  Curves.MakeCircle
-
-System.SetFont Oberon10.Scn.Fnt
-Draw.SetWidth 2
-Draw.ChangeFont Oberon8.Scn.Fnt
-Draw.ChangeFont Oberon10b.Scn.Fnt
-Draw.ChangeWidth 2
-Draw.Macro TTL0 N02
-
+Draw.Open XX.Graph  Draw.Store 
+Rectangles.Make  Curves.MakeCircle
+
+System.SetFont Oberon10.Scn.Fnt
+Draw.SetWidth 2
+Draw.ChangeFont Oberon8.Scn.Fnt
+Draw.ChangeFont Oberon10b.Scn.Fnt
+Draw.ChangeWidth 2
+Draw.Macro TTL0 N02
+
 Blinkers.Make  Blinkers.Blink  Blinkers.Run  Blinkers.Stop

people.inf.ethz.ch/wirth/ProjectOberon/Sources/EBNF.Mod.txt

@@ -1,394 +1,394 @@
-MODULE EBNF;  (*NW 3.9.97 / 12.9.97 / 1.3.2014*)
-  IMPORT Texts, Oberon;
-
-  CONST IdLen = 16;
-    ident = 0; literal = 2; lparen = 3; lbrak = 4; lbrace = 5; bar = 6; eql = 7;
-    rparen = 8; rbrak = 9; rbrace = 10; period = 11; other = 12;
-
-  TYPE Identifier = ARRAY IdLen OF CHAR;
-
-  (*tag values: 0 = tsym, 1 = ntsym, 2 = option, 3 = iteration, 4 = catenation, 5 = alternate*)
-
-    Item = POINTER TO ItemDesc;
-    ItemDesc = RECORD
-        tag, flag0, flag1: INTEGER;
-        u, v: Item
-      END ;
-
-    Symbol = POINTER TO SymbolDesc;
-    SymbolDesc = RECORD (ItemDesc)
-        id: Identifier;
-        no: INTEGER;
-        first, crit: SET;
-        next: Symbol
-      END ;
-
-  VAR ch: CHAR;
-    sym: INTEGER;
-    lastpos: LONGINT;
-    tsno, ntsno: INTEGER;
-    id: Identifier;
-    root, curs: Symbol;
-    R: Texts.Reader;
-    W: Texts.Writer;
-
-  PROCEDURE error(n: INTEGER);
-    VAR pos: LONGINT;
-  BEGIN pos := Texts.Pos(R);
-    IF pos > lastpos THEN
-      Texts.WriteString(W, "  pos"); Texts.WriteInt(W, pos, 6);
-      Texts.WriteString(W, "  err"); Texts.WriteInt(W, n, 4); lastpos := pos;
-      Texts.WriteString(W, "  sym "); Texts.WriteInt(W, sym, 4);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END error;
-
-  PROCEDURE This(VAR ident: Identifier; tag: INTEGER): Symbol;
-    VAR s: Symbol;   (*find or enter symbol in list*)
-  BEGIN s := root;
-
-    WHILE (s # NIL) & (s.id # ident) DO s := s.next END ;
-    IF s = NIL THEN
-      NEW(s); s.id := ident; s.tag := tag;
-      IF tag = 0 THEN s.no := tsno; INC(tsno) ELSE s.no := ntsno; INC(ntsno) END ;
-      s.next := root; root := s
-    END ;
-    RETURN s
-  END This;
-
-  PROCEDURE New(t: INTEGER; x, y: Item): Item;
-    VAR z: Item;
-  BEGIN NEW(z); z.tag := t; z.u := x; z.v := y; RETURN z
-  END New;
-
-  (*------------------- scanner --------------------*)
-
-  PROCEDURE GetSym;
-    VAR i: INTEGER;
-  BEGIN
-    WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END ;
-    IF (ch >= "a") & (ch <= "z") OR (ch >= "A") & (ch <= "Z") THEN
-      sym := ident; i := 0;
-      REPEAT
-        IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
-        Texts.Read(R, ch)
-      UNTIL ~((ch >= "a") & (ch <= "z") OR (ch >= "A") & (ch <= "Z"));
-      id[i] := 0X
-    ELSE
-      IF ch = 22X THEN
-        Texts.Read(R, ch); sym := literal; i := 0;
-        REPEAT (*at least one char*)
-          IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
-          Texts.Read(R, ch)
-        UNTIL (ch = 22X) OR (ch <= " ");
-        IF ch <= " " THEN error(1) END ;
-        id[i] := 0X
-      ELSIF ch = "=" THEN sym := eql
-      ELSIF ch = "(" THEN sym := lparen
-      ELSIF ch = ")" THEN sym := rparen
-      ELSIF ch = "[" THEN sym := lbrak
-      ELSIF ch = "]" THEN sym := rbrak
-      ELSIF ch = "{" THEN sym := lbrace
-      ELSIF ch = "}" THEN sym := rbrace
-      ELSIF ch = "|" THEN sym := bar
-      ELSIF ch = "." THEN sym := period
-      ELSE sym := other
-      END ;
-      Texts.Read(R, ch)
-    END
-  END GetSym;
-
-  (*-------------------- parser ---------------------*)
-
-  PROCEDURE expression(VAR x: Item);
-    VAR y: Item;
-
-    PROCEDURE term(VAR x: Item);
-      VAR y: Item;
-
-      PROCEDURE factor(VAR x: Item);
-        VAR y: Item;
-      BEGIN
-        IF sym = literal THEN x := This(id, 0); GetSym
-        ELSIF sym = ident THEN x := This(id, 1); GetSym
-        ELSIF sym = lparen THEN
-          GetSym; expression(x);
-          IF sym = rparen THEN GetSym ELSE error(2) END
-        ELSIF sym = lbrak THEN
-          GetSym; expression(y); x := New(2, NIL, y);
-          IF sym = rbrak THEN GetSym ELSE error(3) END
-        ELSIF sym = lbrace THEN
-          GetSym; expression(y); x := New(3, NIL, y);
-          IF sym = rbrace THEN GetSym ELSE error(4) END
-        ELSE error(5)
-        END
-      END factor;
-
-    BEGIN (*term*) factor(x);
-      IF sym < bar THEN term(y); x := New(4, x, y) END
-    END term;
-
-  BEGIN (*expression*) term(x);
-    IF sym = bar THEN GetSym; expression(y); x := New(5, x, y) END
-  END expression;
-
-  PROCEDURE production;
-    VAR s: Symbol;
-  BEGIN (*sym = ident*)
-    s := This(id, 1); GetSym;
-    IF sym = eql THEN GetSym ELSE error(7) END ;
-    expression(s.v);
-    IF sym = period THEN GetSym ELSE error(8) END
-  END production;
-
-  PROCEDURE syntax(T: Texts.Text; pos: LONGINT);
-  BEGIN Texts.OpenReader(R, T, pos);  Texts.Read(R, ch);
-    tsno := 0; ntsno := 0; lastpos := 0; GetSym;
-    WHILE sym = ident DO production END ;
-    Texts.WriteString(W, "compiled"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END syntax;
-
-  PROCEDURE Compile*;
-    VAR beg, end, time: LONGINT;
-      T: Texts.Text;
-      S: Texts.Scanner;
-  BEGIN root := NIL;
-    Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF (S.class = Texts.Char) & (S.c = "@") THEN
-      Oberon.GetSelection(T, beg, end, time);
-      IF time >= 0 THEN syntax(T, beg) END
-    END
-  END Compile;
-
-  (*------------------ List symbols -------------------*)
-
-  PROCEDURE List*;
-    VAR s: Symbol;
-  BEGIN Texts.WriteString(W, "Nonterminals:"); Texts.WriteLn(W); s := root;
-    WHILE s # NIL DO
-      IF s.tag = 1 THEN Texts.Write(W, 9X); Texts.WriteString(W, s.id); Texts.WriteLn(W) END ;
-      s := s.next
-    END ;
-    Texts.WriteString(W, "Terminals:"); Texts.WriteLn(W); s := root;
-    WHILE s # NIL DO
-      IF s.tag = 0 THEN Texts.Write(W, 9X); Texts.WriteString(W, s.id); Texts.WriteLn(W) END ;
-      s := s.next
-    END ;
-    Texts.Append(Oberon.Log, W.buf)
-  END List;
-
-  (*------------------ Tabulate syntax tree -------------------*)
-
-  PROCEDURE traverse(x: Item);
-    VAR t: INTEGER;
-  BEGIN
-    IF x # NIL THEN t := x.tag;
-      IF t = 0 THEN Texts.Write(W, 22X); Texts.WriteString(W, x(Symbol).id); Texts.Write(W, 22X)
-      ELSIF t = 1 THEN Texts.WriteString(W, x(Symbol).id)
-      ELSIF t = 2 THEN Texts.Write(W, "?"); traverse(x.v)
-      ELSIF t = 3 THEN Texts.Write(W, "!"); traverse(x.v)
-      ELSE Texts.Write(W, "("); traverse(x.u);
-        IF t = 4 THEN Texts.Write(W, " ") ELSE Texts.Write(W, "|") END ;
-        traverse(x.v); Texts.Write(W, ")")
-      END
-    END
-  END traverse;
-
-  PROCEDURE Tabulate*;
-    VAR s: Symbol;
-  BEGIN s := root;
-    WHILE s # NIL DO
-      IF s.tag = 1 THEN
-        Texts.WriteString(W, s.id); Texts.WriteString(W, " =  "); traverse(s.v); Texts.WriteLn(W)
-      END ;
-      s := s.next
-    END ;
-    Texts.Append(Oberon.Log, W.buf)
-  END Tabulate;
-
-  (*------------------ Find sets of first symbols -------------------*)
-
-  PROCEDURE WriteSet(VAR id: ARRAY OF CHAR; s: SET);
-    VAR x: Symbol;
-  BEGIN Texts.Write(W, 9X); Texts.WriteString(W, id); Texts.WriteString(W, " :: ");
-    x := root;
-    WHILE (s # {}) & (x # NIL) DO
-      IF (x.tag = 0) & (x.no IN s) THEN Texts.Write(W, " "); Texts.WriteString(W, x.id); EXCL(s, x.no) END ;
-      x := x.next
-    END ;
-    Texts.WriteLn(W)
-  END WriteSet;
-
-  PROCEDURE first(x: Item): SET;
-    VAR t: INTEGER; s, a, b: SET; save: Symbol;
-  BEGIN
-    IF x # NIL THEN t := x.tag;
-      IF t = 0 THEN s := {x(Symbol).no}
-      ELSIF t = 1 THEN
-        IF x.flag0 = 0 THEN x.flag0 := 1; save := curs; curs := x(Symbol);
-          s := first(x.v); x.flag0 := 2; x(Symbol).first := s; curs := save
-        ELSIF x.flag0 > 1 THEN s := x(Symbol).first
-        END
-      ELSIF t <= 3 THEN s := first(x.v)
-      ELSIF t = 4 THEN s := first(x.u);
-        IF x.u.tag IN {2, 3} THEN s := first(x.u.v) + first(x.v) ELSE s := first(x.u) END
-      ELSIF x.tag = 5 THEN
-        a := first(x.u); b := first(x.v); s := a+b;
-        IF a*b # {} THEN
-          Texts.WriteString(W, "error A in "); WriteSet(curs.id, a/b); Texts.WriteLn(W)
-        END
-      END
-    ELSE s := {}
-    END ;
-    RETURN s
-  END first;
-
-  PROCEDURE First*;
-    VAR s: Symbol;
-  BEGIN Texts.WriteString(W, "First symbols:"); Texts.WriteLn(W); s := root;
-    WHILE s # NIL DO
-      IF s.tag = 1 THEN curs := s; s.first := first(s.v); WriteSet(s.id, s.first) END ;
-      s := s.next
-    END ;
-    Texts.Append(Oberon.Log, W.buf)
-  END First;
-
-  (*------------------ Find sets of follow symbols -------------------*)
-
-  PROCEDURE critical(x: Item): SET;
-    VAR t: INTEGER; s: SET;
-  BEGIN
-    IF x # NIL THEN t := x.tag;
-      IF t = 0 THEN s := {}
-      ELSIF t = 1 THEN
-        IF x.flag1 = 0 THEN x.flag1 := 1; x(Symbol).crit := critical(x.v) END ;
-        s := x(Symbol).crit
-      ELSIF t <= 3 THEN s := first(x.v)
-      ELSIF t = 4 THEN s := critical(x.v)
-      ELSIF t = 5 THEN s := critical(x.u) + critical(x.v)
-      END
-    ELSE s := {}
-    END ;
-    RETURN s
-  END critical;
-
-  PROCEDURE pair(x: Item);
-  BEGIN
-    IF (x # NIL) & (x.tag >= 2) THEN
-      pair(x.u); pair(x.v);
-      IF (x.tag = 4) & (x.u.tag = 1) THEN
-        IF first(x.v) * x.u(Symbol).crit # {} THEN
-          Texts.WriteString(W, " clash "); WriteSet(x.u(Symbol).id, x.u(Symbol).crit);
-          Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-        END
-      END
-    END
-  END pair;
-
-  PROCEDURE Follow*;
-    VAR s: Symbol;
-  BEGIN Texts.WriteString(W, "Non-follow symbols:"); Texts.WriteLn(W); s := root;
-    WHILE s # NIL DO
-      IF s.tag = 1 THEN curs := s; s.crit := critical(s.v) END ;
-      s := s.next
-    END ;
-    s := root;
-    WHILE s # NIL DO
-      IF s.tag = 1 THEN WriteSet(s.id, s.crit) END ;
-
-      s := s.next
-    END ;
-    s := root;
-    WHILE s # NIL DO
-      IF s.tag = 1 THEN pair(s.v) END ;
-      s := s.next
-    END ;
-    Texts.Append(Oberon.Log, W.buf)
-  END Follow;
-
-BEGIN Texts.OpenWriter(W)
-END EBNF.
-
-EBNF.Compile @  EBNF.List  EBNF.Tabulate  EBNF.First  EBNF.Follow
-
-Syntax  =  {Production} .
-Production  =  "id" "=" Expression "." .
-Expression  =  Term {"|" Term}.
-Term  =  Factor {Factor}.
-Factor  =  "id" | "lit" | "(" Expression ")" | "[" Expression "]" | "{" Expression "}" .
-~
-
-S  =  A | B.
-A  =  "0" | "2".
-B  =  "1" | "3".
-~
-
-S  =  A B.
-A  =  "0" {"0"}.
-B  =  "1" | "2".
-~
-
-S  =  A B C.
-A  =  "0" {"0"}.
-B  =  "1" {"1"}.
-C  =  "2" | "3".
-~
-
-S  =  A B.
-A  =  "*".
-B  =  {"0"} {"1"} ("2" | "3").
-~
-
-syntax  =  expression {"," expression} .
-expression  =  ["+" | "-"] term {("+" | "-") term}.
-term  =  factor {("*" | "/") factor}.
-factor  =  "id" | "(" expression ")" .
-~
-
-syntax  =  {production} .
-production  =  "id" "=" expression "." .
-expression  =  term ["|" expression].
-term  =  factor [term].
-factor  =  "id" | "lit" | "(" expression ")" | "[" expression "]" | "{" expression "}" .
-~
-
-syntax  =  {production} .
-production  =  "id" "=" expression "." .
-expression  =  term {"|" term}.
-term  =  factor {factor}.
-
-factor  =  "id" | "lit" | "(" expression ")" | "[" expression "]" | "{" expression "}" .
-~
-
-primary  =  "variable" | "number" | "(" arithExp ")" .
-factor  =  primary | factor "^" primary.
-term  =  factor | term ("*" | "/" | "DIV") factor.
-simArithExp  =  term | ("+" | "-") term | simArithExp ("+" | "-") term.
-arithExp  =  simArithExp | "IF" BoolExp "THEN" simArithExp "ELSE" arithExp.
-relOp  =  "<" | "<=" | "=" | ">=" | ">" | "#" .
-relation  =  arithExp relOp arithExp.
-BoolPrimary  =  "TRUE" | "FALSE" | "variable" | relation | "(" BoolExp ")".
-BoolSec  =  BoolPrimary | "~" BoolPrimary.
-BoolFactor  =  BoolSec | BoolFactor "&" BoolSec.
-BoolTerm  =  BoolFactor | BoolTerm "|" BoolFactor.
-implication  =  BoolTerm | implication "=>" BooleanTerm.
-simpleBoolean  =  implication | simpleBoolean "==" implication.
-BoolExp  =  simpleBoolean | "IF" BoolExp "THEN" simpleBoolean "ELSE" BoolExp.
-expression  =  arithExp | BoolExp .
-~
-
-primary  =  "variable" | "number" | "(" arithExp ")" .
-factor  =  primary {"^" primary}.
-term  =  factor {("*" | "/" | "DIV") factor}.
-simArithExp  =  ["+" | "-"] term {("+" | "-") term}.
-arithExp  =  simArithExp | "IF" BoolExp "THEN" simArithExp "ELSE" arithExp.
-relOp  =  "<" | "<=" | "=" | ">=" | ">" | "#" .
-relation  =  arithExp relOp arithExp.
-BoolPrimary  =  "TRUE" | "FALSE" | "Bvariable" | relation | "[" BoolExp "]".
-BoolSec  =  ["~"] BoolPrimary.
-BoolFactor  =  BoolSec {"&" BoolSec}.
-BoolTerm  =  BoolFactor {"|" BoolFactor}.
-implication  =  BoolTerm {"=>" BooleanTerm}.
-simBoolExp  =  implication {"==" implication}.
-BoolExp  =  simBoolExp | "IFB" BoolExp "THEN" simBoolExp "ELSE" BoolExp.
+MODULE EBNF;  (*NW 3.9.97 / 12.9.97 / 1.3.2014*)
+  IMPORT Texts, Oberon;
+
+  CONST IdLen = 16;
+    ident = 0; literal = 2; lparen = 3; lbrak = 4; lbrace = 5; bar = 6; eql = 7;
+    rparen = 8; rbrak = 9; rbrace = 10; period = 11; other = 12;
+
+  TYPE Identifier = ARRAY IdLen OF CHAR;
+
+  (*tag values: 0 = tsym, 1 = ntsym, 2 = option, 3 = iteration, 4 = catenation, 5 = alternate*)
+
+    Item = POINTER TO ItemDesc;
+    ItemDesc = RECORD
+        tag, flag0, flag1: INTEGER;
+        u, v: Item
+      END ;
+
+    Symbol = POINTER TO SymbolDesc;
+    SymbolDesc = RECORD (ItemDesc)
+        id: Identifier;
+        no: INTEGER;
+        first, crit: SET;
+        next: Symbol
+      END ;
+
+  VAR ch: CHAR;
+    sym: INTEGER;
+    lastpos: LONGINT;
+    tsno, ntsno: INTEGER;
+    id: Identifier;
+    root, curs: Symbol;
+    R: Texts.Reader;
+    W: Texts.Writer;
+
+  PROCEDURE error(n: INTEGER);
+    VAR pos: LONGINT;
+  BEGIN pos := Texts.Pos(R);
+    IF pos > lastpos THEN
+      Texts.WriteString(W, "  pos"); Texts.WriteInt(W, pos, 6);
+      Texts.WriteString(W, "  err"); Texts.WriteInt(W, n, 4); lastpos := pos;
+      Texts.WriteString(W, "  sym "); Texts.WriteInt(W, sym, 4);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END error;
+
+  PROCEDURE This(VAR ident: Identifier; tag: INTEGER): Symbol;
+    VAR s: Symbol;   (*find or enter symbol in list*)
+  BEGIN s := root;
+
+    WHILE (s # NIL) & (s.id # ident) DO s := s.next END ;
+    IF s = NIL THEN
+      NEW(s); s.id := ident; s.tag := tag;
+      IF tag = 0 THEN s.no := tsno; INC(tsno) ELSE s.no := ntsno; INC(ntsno) END ;
+      s.next := root; root := s
+    END ;
+    RETURN s
+  END This;
+
+  PROCEDURE New(t: INTEGER; x, y: Item): Item;
+    VAR z: Item;
+  BEGIN NEW(z); z.tag := t; z.u := x; z.v := y; RETURN z
+  END New;
+
+  (*------------------- scanner --------------------*)
+
+  PROCEDURE GetSym;
+    VAR i: INTEGER;
+  BEGIN
+    WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END ;
+    IF (ch >= "a") & (ch <= "z") OR (ch >= "A") & (ch <= "Z") THEN
+      sym := ident; i := 0;
+      REPEAT
+        IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
+        Texts.Read(R, ch)
+      UNTIL ~((ch >= "a") & (ch <= "z") OR (ch >= "A") & (ch <= "Z"));
+      id[i] := 0X
+    ELSE
+      IF ch = 22X THEN
+        Texts.Read(R, ch); sym := literal; i := 0;
+        REPEAT (*at least one char*)
+          IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
+          Texts.Read(R, ch)
+        UNTIL (ch = 22X) OR (ch <= " ");
+        IF ch <= " " THEN error(1) END ;
+        id[i] := 0X
+      ELSIF ch = "=" THEN sym := eql
+      ELSIF ch = "(" THEN sym := lparen
+      ELSIF ch = ")" THEN sym := rparen
+      ELSIF ch = "[" THEN sym := lbrak
+      ELSIF ch = "]" THEN sym := rbrak
+      ELSIF ch = "{" THEN sym := lbrace
+      ELSIF ch = "}" THEN sym := rbrace
+      ELSIF ch = "|" THEN sym := bar
+      ELSIF ch = "." THEN sym := period
+      ELSE sym := other
+      END ;
+      Texts.Read(R, ch)
+    END
+  END GetSym;
+
+  (*-------------------- parser ---------------------*)
+
+  PROCEDURE expression(VAR x: Item);
+    VAR y: Item;
+
+    PROCEDURE term(VAR x: Item);
+      VAR y: Item;
+
+      PROCEDURE factor(VAR x: Item);
+        VAR y: Item;
+      BEGIN
+        IF sym = literal THEN x := This(id, 0); GetSym
+        ELSIF sym = ident THEN x := This(id, 1); GetSym
+        ELSIF sym = lparen THEN
+          GetSym; expression(x);
+          IF sym = rparen THEN GetSym ELSE error(2) END
+        ELSIF sym = lbrak THEN
+          GetSym; expression(y); x := New(2, NIL, y);
+          IF sym = rbrak THEN GetSym ELSE error(3) END
+        ELSIF sym = lbrace THEN
+          GetSym; expression(y); x := New(3, NIL, y);
+          IF sym = rbrace THEN GetSym ELSE error(4) END
+        ELSE error(5)
+        END
+      END factor;
+
+    BEGIN (*term*) factor(x);
+      IF sym < bar THEN term(y); x := New(4, x, y) END
+    END term;
+
+  BEGIN (*expression*) term(x);
+    IF sym = bar THEN GetSym; expression(y); x := New(5, x, y) END
+  END expression;
+
+  PROCEDURE production;
+    VAR s: Symbol;
+  BEGIN (*sym = ident*)
+    s := This(id, 1); GetSym;
+    IF sym = eql THEN GetSym ELSE error(7) END ;
+    expression(s.v);
+    IF sym = period THEN GetSym ELSE error(8) END
+  END production;
+
+  PROCEDURE syntax(T: Texts.Text; pos: LONGINT);
+  BEGIN Texts.OpenReader(R, T, pos);  Texts.Read(R, ch);
+    tsno := 0; ntsno := 0; lastpos := 0; GetSym;
+    WHILE sym = ident DO production END ;
+    Texts.WriteString(W, "compiled"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END syntax;
+
+  PROCEDURE Compile*;
+    VAR beg, end, time: LONGINT;
+      T: Texts.Text;
+      S: Texts.Scanner;
+  BEGIN root := NIL;
+    Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF (S.class = Texts.Char) & (S.c = "@") THEN
+      Oberon.GetSelection(T, beg, end, time);
+      IF time >= 0 THEN syntax(T, beg) END
+    END
+  END Compile;
+
+  (*------------------ List symbols -------------------*)
+
+  PROCEDURE List*;
+    VAR s: Symbol;
+  BEGIN Texts.WriteString(W, "Nonterminals:"); Texts.WriteLn(W); s := root;
+    WHILE s # NIL DO
+      IF s.tag = 1 THEN Texts.Write(W, 9X); Texts.WriteString(W, s.id); Texts.WriteLn(W) END ;
+      s := s.next
+    END ;
+    Texts.WriteString(W, "Terminals:"); Texts.WriteLn(W); s := root;
+    WHILE s # NIL DO
+      IF s.tag = 0 THEN Texts.Write(W, 9X); Texts.WriteString(W, s.id); Texts.WriteLn(W) END ;
+      s := s.next
+    END ;
+    Texts.Append(Oberon.Log, W.buf)
+  END List;
+
+  (*------------------ Tabulate syntax tree -------------------*)
+
+  PROCEDURE traverse(x: Item);
+    VAR t: INTEGER;
+  BEGIN
+    IF x # NIL THEN t := x.tag;
+      IF t = 0 THEN Texts.Write(W, 22X); Texts.WriteString(W, x(Symbol).id); Texts.Write(W, 22X)
+      ELSIF t = 1 THEN Texts.WriteString(W, x(Symbol).id)
+      ELSIF t = 2 THEN Texts.Write(W, "?"); traverse(x.v)
+      ELSIF t = 3 THEN Texts.Write(W, "!"); traverse(x.v)
+      ELSE Texts.Write(W, "("); traverse(x.u);
+        IF t = 4 THEN Texts.Write(W, " ") ELSE Texts.Write(W, "|") END ;
+        traverse(x.v); Texts.Write(W, ")")
+      END
+    END
+  END traverse;
+
+  PROCEDURE Tabulate*;
+    VAR s: Symbol;
+  BEGIN s := root;
+    WHILE s # NIL DO
+      IF s.tag = 1 THEN
+        Texts.WriteString(W, s.id); Texts.WriteString(W, " =  "); traverse(s.v); Texts.WriteLn(W)
+      END ;
+      s := s.next
+    END ;
+    Texts.Append(Oberon.Log, W.buf)
+  END Tabulate;
+
+  (*------------------ Find sets of first symbols -------------------*)
+
+  PROCEDURE WriteSet(VAR id: ARRAY OF CHAR; s: SET);
+    VAR x: Symbol;
+  BEGIN Texts.Write(W, 9X); Texts.WriteString(W, id); Texts.WriteString(W, " :: ");
+    x := root;
+    WHILE (s # {}) & (x # NIL) DO
+      IF (x.tag = 0) & (x.no IN s) THEN Texts.Write(W, " "); Texts.WriteString(W, x.id); EXCL(s, x.no) END ;
+      x := x.next
+    END ;
+    Texts.WriteLn(W)
+  END WriteSet;
+
+  PROCEDURE first(x: Item): SET;
+    VAR t: INTEGER; s, a, b: SET; save: Symbol;
+  BEGIN
+    IF x # NIL THEN t := x.tag;
+      IF t = 0 THEN s := {x(Symbol).no}
+      ELSIF t = 1 THEN
+        IF x.flag0 = 0 THEN x.flag0 := 1; save := curs; curs := x(Symbol);
+          s := first(x.v); x.flag0 := 2; x(Symbol).first := s; curs := save
+        ELSIF x.flag0 > 1 THEN s := x(Symbol).first
+        END
+      ELSIF t <= 3 THEN s := first(x.v)
+      ELSIF t = 4 THEN s := first(x.u);
+        IF x.u.tag IN {2, 3} THEN s := first(x.u.v) + first(x.v) ELSE s := first(x.u) END
+      ELSIF x.tag = 5 THEN
+        a := first(x.u); b := first(x.v); s := a+b;
+        IF a*b # {} THEN
+          Texts.WriteString(W, "error A in "); WriteSet(curs.id, a/b); Texts.WriteLn(W)
+        END
+      END
+    ELSE s := {}
+    END ;
+    RETURN s
+  END first;
+
+  PROCEDURE First*;
+    VAR s: Symbol;
+  BEGIN Texts.WriteString(W, "First symbols:"); Texts.WriteLn(W); s := root;
+    WHILE s # NIL DO
+      IF s.tag = 1 THEN curs := s; s.first := first(s.v); WriteSet(s.id, s.first) END ;
+      s := s.next
+    END ;
+    Texts.Append(Oberon.Log, W.buf)
+  END First;
+
+  (*------------------ Find sets of follow symbols -------------------*)
+
+  PROCEDURE critical(x: Item): SET;
+    VAR t: INTEGER; s: SET;
+  BEGIN
+    IF x # NIL THEN t := x.tag;
+      IF t = 0 THEN s := {}
+      ELSIF t = 1 THEN
+        IF x.flag1 = 0 THEN x.flag1 := 1; x(Symbol).crit := critical(x.v) END ;
+        s := x(Symbol).crit
+      ELSIF t <= 3 THEN s := first(x.v)
+      ELSIF t = 4 THEN s := critical(x.v)
+      ELSIF t = 5 THEN s := critical(x.u) + critical(x.v)
+      END
+    ELSE s := {}
+    END ;
+    RETURN s
+  END critical;
+
+  PROCEDURE pair(x: Item);
+  BEGIN
+    IF (x # NIL) & (x.tag >= 2) THEN
+      pair(x.u); pair(x.v);
+      IF (x.tag = 4) & (x.u.tag = 1) THEN
+        IF first(x.v) * x.u(Symbol).crit # {} THEN
+          Texts.WriteString(W, " clash "); WriteSet(x.u(Symbol).id, x.u(Symbol).crit);
+          Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+        END
+      END
+    END
+  END pair;
+
+  PROCEDURE Follow*;
+    VAR s: Symbol;
+  BEGIN Texts.WriteString(W, "Non-follow symbols:"); Texts.WriteLn(W); s := root;
+    WHILE s # NIL DO
+      IF s.tag = 1 THEN curs := s; s.crit := critical(s.v) END ;
+      s := s.next
+    END ;
+    s := root;
+    WHILE s # NIL DO
+      IF s.tag = 1 THEN WriteSet(s.id, s.crit) END ;
+
+      s := s.next
+    END ;
+    s := root;
+    WHILE s # NIL DO
+      IF s.tag = 1 THEN pair(s.v) END ;
+      s := s.next
+    END ;
+    Texts.Append(Oberon.Log, W.buf)
+  END Follow;
+
+BEGIN Texts.OpenWriter(W)
+END EBNF.
+
+EBNF.Compile @  EBNF.List  EBNF.Tabulate  EBNF.First  EBNF.Follow
+
+Syntax  =  {Production} .
+Production  =  "id" "=" Expression "." .
+Expression  =  Term {"|" Term}.
+Term  =  Factor {Factor}.
+Factor  =  "id" | "lit" | "(" Expression ")" | "[" Expression "]" | "{" Expression "}" .
+~
+
+S  =  A | B.
+A  =  "0" | "2".
+B  =  "1" | "3".
+~
+
+S  =  A B.
+A  =  "0" {"0"}.
+B  =  "1" | "2".
+~
+
+S  =  A B C.
+A  =  "0" {"0"}.
+B  =  "1" {"1"}.
+C  =  "2" | "3".
+~
+
+S  =  A B.
+A  =  "*".
+B  =  {"0"} {"1"} ("2" | "3").
+~
+
+syntax  =  expression {"," expression} .
+expression  =  ["+" | "-"] term {("+" | "-") term}.
+term  =  factor {("*" | "/") factor}.
+factor  =  "id" | "(" expression ")" .
+~
+
+syntax  =  {production} .
+production  =  "id" "=" expression "." .
+expression  =  term ["|" expression].
+term  =  factor [term].
+factor  =  "id" | "lit" | "(" expression ")" | "[" expression "]" | "{" expression "}" .
+~
+
+syntax  =  {production} .
+production  =  "id" "=" expression "." .
+expression  =  term {"|" term}.
+term  =  factor {factor}.
+
+factor  =  "id" | "lit" | "(" expression ")" | "[" expression "]" | "{" expression "}" .
+~
+
+primary  =  "variable" | "number" | "(" arithExp ")" .
+factor  =  primary | factor "^" primary.
+term  =  factor | term ("*" | "/" | "DIV") factor.
+simArithExp  =  term | ("+" | "-") term | simArithExp ("+" | "-") term.
+arithExp  =  simArithExp | "IF" BoolExp "THEN" simArithExp "ELSE" arithExp.
+relOp  =  "<" | "<=" | "=" | ">=" | ">" | "#" .
+relation  =  arithExp relOp arithExp.
+BoolPrimary  =  "TRUE" | "FALSE" | "variable" | relation | "(" BoolExp ")".
+BoolSec  =  BoolPrimary | "~" BoolPrimary.
+BoolFactor  =  BoolSec | BoolFactor "&" BoolSec.
+BoolTerm  =  BoolFactor | BoolTerm "|" BoolFactor.
+implication  =  BoolTerm | implication "=>" BooleanTerm.
+simpleBoolean  =  implication | simpleBoolean "==" implication.
+BoolExp  =  simpleBoolean | "IF" BoolExp "THEN" simpleBoolean "ELSE" BoolExp.
+expression  =  arithExp | BoolExp .
+~
+
+primary  =  "variable" | "number" | "(" arithExp ")" .
+factor  =  primary {"^" primary}.
+term  =  factor {("*" | "/" | "DIV") factor}.
+simArithExp  =  ["+" | "-"] term {("+" | "-") term}.
+arithExp  =  simArithExp | "IF" BoolExp "THEN" simArithExp "ELSE" arithExp.
+relOp  =  "<" | "<=" | "=" | ">=" | ">" | "#" .
+relation  =  arithExp relOp arithExp.
+BoolPrimary  =  "TRUE" | "FALSE" | "Bvariable" | relation | "[" BoolExp "]".
+BoolSec  =  ["~"] BoolPrimary.
+BoolFactor  =  BoolSec {"&" BoolSec}.
+BoolTerm  =  BoolFactor {"|" BoolFactor}.
+implication  =  BoolTerm {"=>" BooleanTerm}.
+simBoolExp  =  implication {"==" implication}.
+BoolExp  =  simBoolExp | "IFB" BoolExp "THEN" simBoolExp "ELSE" BoolExp.
 ~ 

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Edit.Mod.txt

@@ -1,232 +1,232 @@
-MODULE Edit; (*JG 2.11.90 / NW 28.11.2015*)
-  IMPORT Files, Fonts, Texts, Display, Viewers, Oberon, MenuViewers, TextFrames;
-
-  CONST CR = 0DX; maxlen = 32;
-    StandardMenu = "System.Close System.Copy System.Grow Edit.Search Edit.Store";
-
-  VAR W: Texts.Writer;
-    time: LONGINT;
-    M: INTEGER;
-    pat: ARRAY maxlen OF CHAR;
-    d: ARRAY 256 OF INTEGER;
-
-  PROCEDURE Max(i, j: LONGINT): LONGINT;
-    VAR m: LONGINT;
-  BEGIN IF i >= j THEN m := i ELSE m := j END ;
-    RETURN m
-  END Max;
-
-  PROCEDURE Open*;
-    VAR T: Texts.Text;
-    S: Texts.Scanner;
-    V: Viewers.Viewer;
-    X, Y: INTEGER;
-    beg, end, time: LONGINT;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF (S.class = Texts.Char) & (S.c = "^") OR (S.line # 0) THEN
-      Oberon.GetSelection(T, beg, end, time);
-      IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
-    END;
-    IF S.class = Texts.Name THEN
-      Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
-      V := MenuViewers.New(
-        TextFrames.NewMenu(S.s, StandardMenu),
-        TextFrames.NewText(TextFrames.Text(S.s), 0),
-        TextFrames.menuH, X, Y)
-    END
-  END Open;
-
-  PROCEDURE Store*;
-    VAR V: Viewers.Viewer;
-      Text: TextFrames.Frame;
-      T: Texts.Text;
-      S: Texts.Scanner;
-      f: Files.File; R: Files.Rider;
-      beg, end, time, len: LONGINT;
-
-    PROCEDURE Backup (VAR name: ARRAY OF CHAR);
-      VAR res, i: INTEGER; bak: ARRAY 32 OF CHAR;
-    BEGIN i := 0;
-      WHILE name[i] # 0X DO bak[i] := name[i]; INC(i) END;
-      bak[i] := "."; bak[i+1] := "B"; bak[i+2] := "a"; bak[i+3] := "k"; bak[i+4] := 0X;
-      Files.Rename(name, bak, res)
-    END Backup;
-
-  BEGIN Texts.WriteString(W, "Edit.Store ");
-    IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN
-      V := Oberon.Par.vwr; Texts.OpenScanner(S, V.dsc(TextFrames.Frame).text, 0)
-    ELSE V := Oberon.MarkedViewer(); Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos)
-    END;
-    Texts.Scan(S);
-    IF (S.class = Texts.Char) & (S.c = "^") THEN
-      Oberon.GetSelection(T, beg, end, time);
-      IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
-    END;
-    IF (S.class = Texts.Name) & (V.dsc # NIL) & (V.dsc.next IS TextFrames.Frame) THEN
-      Text := V.dsc.next(TextFrames.Frame);
-      Texts.WriteString(W, S.s); Texts.WriteInt(W, Text.text.len, 8);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-      Backup(S.s); Texts.Close(Text.text, S.s)
-    END
-  END Store;
-
-  PROCEDURE CopyLooks*;
-    VAR T: Texts.Text;
-      F: TextFrames.Frame;
-      v: Viewers.Viewer;
-      beg, end, time: LONGINT;
-      fnt: Fonts.Font; col, voff: INTEGER;
-  BEGIN Oberon.GetSelection(T, beg, end, time);
-    IF time >= 0 THEN
-      v := Oberon.FocusViewer;
-      IF (v # NIL) & (v.dsc # NIL) & (v.dsc.next IS TextFrames.Frame) THEN
-        F := v.dsc.next(TextFrames.Frame);
-        Texts.Attributes(F.text, F.carloc.pos, fnt, col, voff);
-        Texts.ChangeLooks(T, beg, end, {0,1,2}, fnt, col, voff)
-      END
-    END
-  END CopyLooks; 
-
-  PROCEDURE ChangeFont*;
-    VAR S: Texts.Scanner; T: Texts.Text; beg, end: LONGINT;
-  BEGIN
-    Oberon.GetSelection(T, beg, end, time);
-    IF time >= 0 THEN
-      Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-      IF S.class = Texts.Name THEN
-        Texts.ChangeLooks(T, beg, end, {0}, Fonts.This(S.s), 0, 0)
-      END
-    END
-  END ChangeFont;
-
-  PROCEDURE ChangeColor*;
-    VAR S: Texts.Scanner;
-      T: Texts.Text;
-      col: INTEGER;
-      beg, end, time: LONGINT;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Int THEN
-      col := S.i; Oberon.GetSelection(T, beg, end, time);
-      IF time >= 0 THEN Texts.ChangeLooks(T, beg, end, {1}, NIL, col, 0) END
-    END
-  END ChangeColor;
-
-  PROCEDURE ChangeOffset*;
-    VAR S: Texts.Scanner;
-      T: Texts.Text;
-      voff: INTEGER; ch: CHAR;
-      beg, end, time: LONGINT;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Int THEN
-      voff := S.i; Oberon.GetSelection(T, beg, end, time);
-      IF time >= 0 THEN Texts.ChangeLooks(T, beg, end, {2}, NIL, voff, 0) END
-    END
-  END ChangeOffset;
-
-  PROCEDURE Search*;  (*uses global variables M, pat, d for Boyer-Moore search*)
-    VAR Text: TextFrames.Frame;
-      V: Viewers.Viewer;
-      R: Texts.Reader;
-      T: Texts.Text;
-      pos, beg, end, prevTime, len: LONGINT; n, i, j: INTEGER;
-      buf: ARRAY 32 OF CHAR;
-
-    PROCEDURE Forward(n: INTEGER; VAR R: Texts.Reader; VAR buf: ARRAY OF CHAR);
-      VAR m: INTEGER; j: INTEGER;
-    BEGIN m := M - n; j := 0;
-      WHILE j # m DO buf[j] := buf[n + j]; INC(j) END;
-      WHILE j # M DO Texts.Read(R, buf[j]); INC(j) END
-    END Forward;
-
-  BEGIN V := Oberon.Par.vwr;
-    IF Oberon.Par.frame # V.dsc THEN V := Oberon.FocusViewer END;
-    IF (V.dsc # NIL) & (V.dsc.next IS TextFrames.Frame) THEN
-      Text := V.dsc.next(TextFrames.Frame);
-      prevTime := time; Oberon.GetSelection(T, beg, end, time);
-      IF time > prevTime THEN
-        Texts.OpenReader(R, T, beg);
-        i := 0; pos := beg;
-        REPEAT Texts.Read(R, pat[i]); INC(i); INC(pos)
-        UNTIL (i = maxlen) OR (pos = end);
-        M := i; j := 0;
-        WHILE j # 256 DO d[j] := M; INC(j) END;
-        j := 0;
-        WHILE j # M - 1 DO d[ORD(pat[j])] := M - 1 - j; INC(j) END
-      END;
-      IF Text.hasCar THEN pos := Text.carloc.pos ELSE pos := 0 END;
-      len := Text.text.len;
-      Texts.OpenReader(R, Text.text, pos);
-      Forward(M, R, buf); pos := pos + M;
-      j := M;
-      REPEAT DEC(j) UNTIL (j < 0) OR (buf[j] # pat[j]);
-      WHILE (j >= 0) & (pos < len) DO
-        n := d[ORD(buf[M-1])]; Forward(n, R, buf); INC(pos, n); j := M;
-        REPEAT DEC(j) UNTIL (j < 0) OR (buf[j] # pat[j])
-      END ;
-      IF j < 0 THEN
-        TextFrames.RemoveSelection(Text); TextFrames.RemoveCaret(Text);
-        Oberon.RemoveMarks(Text.X, Text.Y, Text.W, Text.H);
-        TextFrames.Show(Text, pos - 300); Oberon.PassFocus(V);
-        TextFrames.SetCaret(Text, pos)
-      END
-    END
-  END Search;
-
-  PROCEDURE Locate*;
-    VAR Text: TextFrames.Frame;
-      T: Texts.Text; S: Texts.Scanner;
-      V: Viewers.Viewer;
-      beg, end, time: LONGINT;
-  BEGIN
-    V := Oberon.FocusViewer;
-    IF (V.dsc # NIL) & (V.dsc.next IS TextFrames.Frame) THEN
-      Text := V.dsc.next(TextFrames.Frame);
-      Oberon.GetSelection(T, beg, end, time);
-      IF time >= 0 THEN
-        Texts.OpenScanner(S, T, beg);
-        REPEAT Texts.Scan(S) UNTIL (S.class >= Texts.Int); (*skip names*)
-        IF S.class = Texts.Int THEN
-          TextFrames.RemoveSelection(Text);
-          TextFrames.RemoveCaret(Text);
-          Oberon.RemoveMarks(Text.X, Text.Y, Text.W, Text.H);
-          TextFrames.Show(Text, Max(0, S.i - 200));
-          Oberon.PassFocus(V);
-          TextFrames.SetCaret(Text, S.i)
-        END
-      END
-    END
-  END Locate;
-
-  PROCEDURE Recall*;
-    VAR Menu, Main: Display.Frame;
-      buf: Texts.Buffer;
-      V: Viewers.Viewer;
-      pos: LONGINT;
-      M: TextFrames.Frame;
-  BEGIN V := Oberon.FocusViewer;
-    IF (V # NIL) & (V IS MenuViewers.Viewer) THEN
-      Menu := V.dsc; Main := V.dsc.next;
-      IF Main IS TextFrames.Frame THEN
-        M := Main(TextFrames.Frame);
-        IF M.hasCar THEN
-          TextFrames.Recall(buf);
-          pos := M.carloc.pos + buf.len;
-          Texts.Insert(M.text, M.carloc.pos, buf);
-          TextFrames.SetCaret(M, pos)
-        END
-      ELSIF Menu IS TextFrames.Frame THEN
-        M := Menu(TextFrames.Frame);
-        IF M.hasCar THEN
-          TextFrames.Recall(buf);
-          pos := M.carloc.pos + buf.len;
-          Texts.Insert(M.text, M.carloc.pos, buf);
-          TextFrames.SetCaret(M, pos)
-        END
-      END
-    END
-  END Recall;
-
-BEGIN Texts.OpenWriter(W)
-END Edit.
-
-
+MODULE Edit; (*JG 2.11.90 / NW 28.11.2015*)
+  IMPORT Files, Fonts, Texts, Display, Viewers, Oberon, MenuViewers, TextFrames;
+
+  CONST CR = 0DX; maxlen = 32;
+    StandardMenu = "System.Close System.Copy System.Grow Edit.Search Edit.Store";
+
+  VAR W: Texts.Writer;
+    time: LONGINT;
+    M: INTEGER;
+    pat: ARRAY maxlen OF CHAR;
+    d: ARRAY 256 OF INTEGER;
+
+  PROCEDURE Max(i, j: LONGINT): LONGINT;
+    VAR m: LONGINT;
+  BEGIN IF i >= j THEN m := i ELSE m := j END ;
+    RETURN m
+  END Max;
+
+  PROCEDURE Open*;
+    VAR T: Texts.Text;
+    S: Texts.Scanner;
+    V: Viewers.Viewer;
+    X, Y: INTEGER;
+    beg, end, time: LONGINT;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF (S.class = Texts.Char) & (S.c = "^") OR (S.line # 0) THEN
+      Oberon.GetSelection(T, beg, end, time);
+      IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
+    END;
+    IF S.class = Texts.Name THEN
+      Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
+      V := MenuViewers.New(
+        TextFrames.NewMenu(S.s, StandardMenu),
+        TextFrames.NewText(TextFrames.Text(S.s), 0),
+        TextFrames.menuH, X, Y)
+    END
+  END Open;
+
+  PROCEDURE Store*;
+    VAR V: Viewers.Viewer;
+      Text: TextFrames.Frame;
+      T: Texts.Text;
+      S: Texts.Scanner;
+      f: Files.File; R: Files.Rider;
+      beg, end, time, len: LONGINT;
+
+    PROCEDURE Backup (VAR name: ARRAY OF CHAR);
+      VAR res, i: INTEGER; bak: ARRAY 32 OF CHAR;
+    BEGIN i := 0;
+      WHILE name[i] # 0X DO bak[i] := name[i]; INC(i) END;
+      bak[i] := "."; bak[i+1] := "B"; bak[i+2] := "a"; bak[i+3] := "k"; bak[i+4] := 0X;
+      Files.Rename(name, bak, res)
+    END Backup;
+
+  BEGIN Texts.WriteString(W, "Edit.Store ");
+    IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN
+      V := Oberon.Par.vwr; Texts.OpenScanner(S, V.dsc(TextFrames.Frame).text, 0)
+    ELSE V := Oberon.MarkedViewer(); Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos)
+    END;
+    Texts.Scan(S);
+    IF (S.class = Texts.Char) & (S.c = "^") THEN
+      Oberon.GetSelection(T, beg, end, time);
+      IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
+    END;
+    IF (S.class = Texts.Name) & (V.dsc # NIL) & (V.dsc.next IS TextFrames.Frame) THEN
+      Text := V.dsc.next(TextFrames.Frame);
+      Texts.WriteString(W, S.s); Texts.WriteInt(W, Text.text.len, 8);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+      Backup(S.s); Texts.Close(Text.text, S.s)
+    END
+  END Store;
+
+  PROCEDURE CopyLooks*;
+    VAR T: Texts.Text;
+      F: TextFrames.Frame;
+      v: Viewers.Viewer;
+      beg, end, time: LONGINT;
+      fnt: Fonts.Font; col, voff: INTEGER;
+  BEGIN Oberon.GetSelection(T, beg, end, time);
+    IF time >= 0 THEN
+      v := Oberon.FocusViewer;
+      IF (v # NIL) & (v.dsc # NIL) & (v.dsc.next IS TextFrames.Frame) THEN
+        F := v.dsc.next(TextFrames.Frame);
+        Texts.Attributes(F.text, F.carloc.pos, fnt, col, voff);
+        Texts.ChangeLooks(T, beg, end, {0,1,2}, fnt, col, voff)
+      END
+    END
+  END CopyLooks; 
+
+  PROCEDURE ChangeFont*;
+    VAR S: Texts.Scanner; T: Texts.Text; beg, end: LONGINT;
+  BEGIN
+    Oberon.GetSelection(T, beg, end, time);
+    IF time >= 0 THEN
+      Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+      IF S.class = Texts.Name THEN
+        Texts.ChangeLooks(T, beg, end, {0}, Fonts.This(S.s), 0, 0)
+      END
+    END
+  END ChangeFont;
+
+  PROCEDURE ChangeColor*;
+    VAR S: Texts.Scanner;
+      T: Texts.Text;
+      col: INTEGER;
+      beg, end, time: LONGINT;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Int THEN
+      col := S.i; Oberon.GetSelection(T, beg, end, time);
+      IF time >= 0 THEN Texts.ChangeLooks(T, beg, end, {1}, NIL, col, 0) END
+    END
+  END ChangeColor;
+
+  PROCEDURE ChangeOffset*;
+    VAR S: Texts.Scanner;
+      T: Texts.Text;
+      voff: INTEGER; ch: CHAR;
+      beg, end, time: LONGINT;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Int THEN
+      voff := S.i; Oberon.GetSelection(T, beg, end, time);
+      IF time >= 0 THEN Texts.ChangeLooks(T, beg, end, {2}, NIL, voff, 0) END
+    END
+  END ChangeOffset;
+
+  PROCEDURE Search*;  (*uses global variables M, pat, d for Boyer-Moore search*)
+    VAR Text: TextFrames.Frame;
+      V: Viewers.Viewer;
+      R: Texts.Reader;
+      T: Texts.Text;
+      pos, beg, end, prevTime, len: LONGINT; n, i, j: INTEGER;
+      buf: ARRAY 32 OF CHAR;
+
+    PROCEDURE Forward(n: INTEGER; VAR R: Texts.Reader; VAR buf: ARRAY OF CHAR);
+      VAR m: INTEGER; j: INTEGER;
+    BEGIN m := M - n; j := 0;
+      WHILE j # m DO buf[j] := buf[n + j]; INC(j) END;
+      WHILE j # M DO Texts.Read(R, buf[j]); INC(j) END
+    END Forward;
+
+  BEGIN V := Oberon.Par.vwr;
+    IF Oberon.Par.frame # V.dsc THEN V := Oberon.FocusViewer END;
+    IF (V.dsc # NIL) & (V.dsc.next IS TextFrames.Frame) THEN
+      Text := V.dsc.next(TextFrames.Frame);
+      prevTime := time; Oberon.GetSelection(T, beg, end, time);
+      IF time > prevTime THEN
+        Texts.OpenReader(R, T, beg);
+        i := 0; pos := beg;
+        REPEAT Texts.Read(R, pat[i]); INC(i); INC(pos)
+        UNTIL (i = maxlen) OR (pos = end);
+        M := i; j := 0;
+        WHILE j # 256 DO d[j] := M; INC(j) END;
+        j := 0;
+        WHILE j # M - 1 DO d[ORD(pat[j])] := M - 1 - j; INC(j) END
+      END;
+      IF Text.hasCar THEN pos := Text.carloc.pos ELSE pos := 0 END;
+      len := Text.text.len;
+      Texts.OpenReader(R, Text.text, pos);
+      Forward(M, R, buf); pos := pos + M;
+      j := M;
+      REPEAT DEC(j) UNTIL (j < 0) OR (buf[j] # pat[j]);
+      WHILE (j >= 0) & (pos < len) DO
+        n := d[ORD(buf[M-1])]; Forward(n, R, buf); INC(pos, n); j := M;
+        REPEAT DEC(j) UNTIL (j < 0) OR (buf[j] # pat[j])
+      END ;
+      IF j < 0 THEN
+        TextFrames.RemoveSelection(Text); TextFrames.RemoveCaret(Text);
+        Oberon.RemoveMarks(Text.X, Text.Y, Text.W, Text.H);
+        TextFrames.Show(Text, pos - 300); Oberon.PassFocus(V);
+        TextFrames.SetCaret(Text, pos)
+      END
+    END
+  END Search;
+
+  PROCEDURE Locate*;
+    VAR Text: TextFrames.Frame;
+      T: Texts.Text; S: Texts.Scanner;
+      V: Viewers.Viewer;
+      beg, end, time: LONGINT;
+  BEGIN
+    V := Oberon.FocusViewer;
+    IF (V.dsc # NIL) & (V.dsc.next IS TextFrames.Frame) THEN
+      Text := V.dsc.next(TextFrames.Frame);
+      Oberon.GetSelection(T, beg, end, time);
+      IF time >= 0 THEN
+        Texts.OpenScanner(S, T, beg);
+        REPEAT Texts.Scan(S) UNTIL (S.class >= Texts.Int); (*skip names*)
+        IF S.class = Texts.Int THEN
+          TextFrames.RemoveSelection(Text);
+          TextFrames.RemoveCaret(Text);
+          Oberon.RemoveMarks(Text.X, Text.Y, Text.W, Text.H);
+          TextFrames.Show(Text, Max(0, S.i - 200));
+          Oberon.PassFocus(V);
+          TextFrames.SetCaret(Text, S.i)
+        END
+      END
+    END
+  END Locate;
+
+  PROCEDURE Recall*;
+    VAR Menu, Main: Display.Frame;
+      buf: Texts.Buffer;
+      V: Viewers.Viewer;
+      pos: LONGINT;
+      M: TextFrames.Frame;
+  BEGIN V := Oberon.FocusViewer;
+    IF (V # NIL) & (V IS MenuViewers.Viewer) THEN
+      Menu := V.dsc; Main := V.dsc.next;
+      IF Main IS TextFrames.Frame THEN
+        M := Main(TextFrames.Frame);
+        IF M.hasCar THEN
+          TextFrames.Recall(buf);
+          pos := M.carloc.pos + buf.len;
+          Texts.Insert(M.text, M.carloc.pos, buf);
+          TextFrames.SetCaret(M, pos)
+        END
+      ELSIF Menu IS TextFrames.Frame THEN
+        M := Menu(TextFrames.Frame);
+        IF M.hasCar THEN
+          TextFrames.Recall(buf);
+          pos := M.carloc.pos + buf.len;
+          Texts.Insert(M.text, M.carloc.pos, buf);
+          TextFrames.SetCaret(M, pos)
+        END
+      END
+    END
+  END Recall;
+
+BEGIN Texts.OpenWriter(W)
+END Edit.
+
+

people.inf.ethz.ch/wirth/ProjectOberon/Sources/FileDir.Mod.txt

@@ -1,352 +1,352 @@
-MODULE FileDir;   (*NW 12.1.86 / 23.8.90 / 15.8.2013*)
-  IMPORT SYSTEM, Kernel;
-
-  (*File Directory is a B-tree with its root page at DirRootAdr.
-    Each entry contains a file name and the disk address of the file's head sector*)
-
-  CONST FnLength*    = 32;
-        SecTabSize*   = 64;
-        ExTabSize*   = 12;
-        SectorSize*   = 1024;
-        IndexSize*   = SectorSize DIV 4;
-        HeaderSize*  = 352;
-        DirRootAdr*  = 29;
-        DirPgSize*   = 24;
-        N = DirPgSize DIV 2;
-        DirMark*    = 9B1EA38DH;
-        HeaderMark* = 9BA71D86H;
-        FillerSize = 52;
-
-  TYPE DiskAdr      = INTEGER;
-    FileName*       = ARRAY FnLength OF CHAR;
-    SectorTable*    = ARRAY SecTabSize OF DiskAdr;
-    ExtensionTable* = ARRAY ExTabSize OF DiskAdr;
-    EntryHandler*   = PROCEDURE (name: FileName; sec: DiskAdr; VAR continue: BOOLEAN);
-
-    FileHeader* =
-      RECORD (*first page of each file on disk*)
-        mark*: INTEGER;
-        name*: FileName;
-        aleng*, bleng*, date*: INTEGER;
-        ext*:  ExtensionTable;
-        sec*: SectorTable;
-        fill: ARRAY SectorSize - HeaderSize OF BYTE;
-      END ;
-
-    FileHd* = POINTER TO FileHeader;
-    IndexSector* = ARRAY IndexSize OF DiskAdr;
-    DataSector* = ARRAY SectorSize OF BYTE;
-
-    DirEntry* =  (*B-tree node*)
-      RECORD
-        name*: FileName;
-        adr*:  DiskAdr; (*sec no of file header*)
-        p*:    DiskAdr  (*sec no of descendant in directory*)
-      END ;
-
-    DirPage*  =
-      RECORD mark*:  INTEGER;
-        m*:     INTEGER;
-        p0*:    DiskAdr;  (*sec no of left descendant in directory*)
-        fill:  ARRAY FillerSize OF BYTE;
-        e*:  ARRAY DirPgSize OF DirEntry
-      END ;
-
-  (*Exported procedures: Search, Insert, Delete, Enumerate, Init*)
-
-  PROCEDURE Search*(name: FileName; VAR A: DiskAdr);
-    VAR i, L, R: INTEGER; dadr: DiskAdr;
-      a: DirPage;
-  BEGIN dadr := DirRootAdr; A := 0;
-    REPEAT Kernel.GetSector(dadr, a); ASSERT(a.mark = DirMark);
-      L := 0; R := a.m; (*binary search*)
-      WHILE L < R DO
-        i := (L+R) DIV 2;
-        IF name <= a.e[i].name THEN R := i ELSE L := i+1 END
-      END ;
-      IF (R < a.m) & (name = a.e[R].name) THEN A := a.e[R].adr (*found*)
-      ELSIF R = 0 THEN dadr := a.p0
-      ELSE dadr := a.e[R-1].p
-      END ;
-    UNTIL (dadr = 0) OR (A # 0)
-  END Search;
-
-  PROCEDURE insert(name: FileName;
-                   dpg0:  DiskAdr;
-                   VAR h: BOOLEAN;
-                   VAR v: DirEntry;
-                   fad:     DiskAdr);
-    (*h = "tree has become higher and v is ascending element"*)
-    VAR ch: CHAR;
-      i, j, L, R: INTEGER;
-      dpg1: DiskAdr;
-      u: DirEntry;
-      a: DirPage;
-
-  BEGIN (*~h*) Kernel.GetSector(dpg0, a); ASSERT(a.mark = DirMark);
-    L := 0; R := a.m; (*binary search*)
-    WHILE L < R DO
-      i := (L+R) DIV 2;
-      IF name <= a.e[i].name THEN R := i ELSE L := i+1 END
-    END ;
-    IF (R < a.m) & (name = a.e[R].name) THEN
-      a.e[R].adr := fad; Kernel.PutSector(dpg0, a)  (*replace*)
-    ELSE (*not on this page*)
-      IF R = 0 THEN dpg1 := a.p0 ELSE dpg1 := a.e[R-1].p END ;
-      IF dpg1 = 0 THEN (*not in tree, insert*)
-        u.adr := fad; u.p := 0; h := TRUE; j := 0;
-        REPEAT ch := name[j]; u.name[j] := ch; INC(j)
-        UNTIL ch = 0X;
-        WHILE j < FnLength DO u.name[j] := 0X; INC(j) END ;
-      ELSE
-        insert(name, dpg1, h, u, fad)
-      END ;
-      IF h THEN (*insert u to the left of e[R]*)
-        IF a.m < DirPgSize THEN
-          h := FALSE; i := a.m;
-          WHILE i > R DO DEC(i); a.e[i+1] := a.e[i] END ;
-          a.e[R] := u; INC(a.m)
-        ELSE (*split page and assign the middle element to v*)
-          a.m := N; a.mark := DirMark;
-          IF R < N THEN (*insert in left half*)
-            v := a.e[N-1]; i := N-1;
-            WHILE i > R DO DEC(i); a.e[i+1] := a.e[i] END ;
-            a.e[R] := u; Kernel.PutSector(dpg0, a);
-            Kernel.AllocSector(dpg0, dpg0); i := 0;
-            WHILE i < N DO a.e[i] := a.e[i+N]; INC(i) END
-          ELSE (*insert in right half*)
-            Kernel.PutSector(dpg0, a);
-            Kernel.AllocSector(dpg0, dpg0); DEC(R, N); i := 0;
-            IF R = 0 THEN v := u
-            ELSE v := a.e[N];
-              WHILE i < R-1 DO a.e[i] := a.e[N+1+i]; INC(i) END ;
-              a.e[i] := u; INC(i)
-            END ;
-            WHILE i < N DO a.e[i] := a.e[N+i]; INC(i) END
-          END ;
-          a.p0 := v.p; v.p := dpg0
-        END ;
-        Kernel.PutSector(dpg0, a)
-      END
-    END
-  END insert;
-
-  PROCEDURE Insert*(name: FileName; fad: DiskAdr);
-    VAR  oldroot: DiskAdr;
-      h: BOOLEAN; U: DirEntry;
-      a: DirPage;
-  BEGIN h := FALSE;
-    insert(name, DirRootAdr, h, U, fad);
-    IF h THEN (*root overflow*)
-      Kernel.GetSector(DirRootAdr, a); ASSERT(a.mark = DirMark);
-      Kernel.AllocSector(DirRootAdr, oldroot); Kernel.PutSector(oldroot, a);
-      a.mark := DirMark; a.m := 1; a.p0 := oldroot; a.e[0] := U;
-      Kernel.PutSector(DirRootAdr, a)
-    END
-  END Insert;
-
-
-  PROCEDURE underflow(VAR c: DirPage;  (*ancestor page*)
-                      dpg0:  DiskAdr;
-                      s:     INTEGER;  (*insertion point in c*)
-                      VAR h: BOOLEAN); (*c undersize*)
-    VAR i, k: INTEGER;
-        dpg1: DiskAdr;
-        a, b: DirPage;  (*a := underflowing page, b := neighbouring page*)
-  BEGIN Kernel.GetSector(dpg0, a); ASSERT(a.mark = DirMark);
-    (*h & a.m = N-1 & dpg0 = c.e[s-1].p*)
-    IF s < c.m THEN (*b := page to the right of a*)
-      dpg1 := c.e[s].p; Kernel.GetSector(dpg1, b); ASSERT(b.mark = DirMark);
-      k := (b.m-N+1) DIV 2; (*k = no. of items available on page b*)
-      a.e[N-1] := c.e[s]; a.e[N-1].p := b.p0;
-      IF k > 0 THEN
-        (*move k-1 items from b to a, one to c*) i := 0;
-        WHILE i < k-1 DO a.e[i+N] := b.e[i]; INC(i) END ;
-        c.e[s] := b.e[i]; b.p0 := c.e[s].p;
-        c.e[s].p := dpg1; b.m := b.m - k; i := 0;
-        WHILE i < b.m DO b.e[i] := b.e[i+k]; INC(i) END ;
-        Kernel.PutSector(dpg1, b); a.m := N-1+k; h := FALSE
-      ELSE (*merge pages a and b, discard b*) i := 0;
-        WHILE i < N DO a.e[i+N] := b.e[i]; INC(i) END ;
-        i := s; DEC(c.m);
-        WHILE i < c.m DO c.e[i] := c.e[i+1]; INC(i) END ;
-        a.m := 2*N; h := c.m < N
-      END ;
-      Kernel.PutSector(dpg0, a)
-    ELSE (*b := page to the left of a*) DEC(s);
-      IF s = 0 THEN dpg1 := c.p0 ELSE dpg1 := c.e[s-1].p END ;
-      Kernel.GetSector(dpg1, b); ASSERT(b.mark = DirMark);
-      k := (b.m-N+1) DIV 2; (*k = no. of items available on page b*)
-      IF k > 0 THEN
-        i := N-1;
-        WHILE i > 0 DO DEC(i); a.e[i+k] := a.e[i] END ;
-        i := k-1; a.e[i] := c.e[s]; a.e[i].p := a.p0;
-        (*move k-1 items from b to a, one to c*) b.m := b.m - k;
-        WHILE i > 0 DO DEC(i); a.e[i] := b.e[i+b.m+1] END ;
-        c.e[s] := b.e[b.m]; a.p0 := c.e[s].p;
-        c.e[s].p := dpg0; a.m := N-1+k; h := FALSE;
-        Kernel.PutSector(dpg0, a)
-      ELSE (*merge pages a and b, discard a*)
-        c.e[s].p := a.p0; b.e[N] := c.e[s]; i := 0;
-        WHILE i < N-1 DO b.e[i+N+1] := a.e[i]; INC(i) END ;
-        b.m := 2*N; DEC(c.m); h := c.m < N
-      END ;
-      Kernel.PutSector(dpg1, b)
-    END
-  END underflow;
-
-  PROCEDURE delete(name: FileName;
-                   dpg0: DiskAdr;
-                   VAR h: BOOLEAN;
-                   VAR fad: DiskAdr);
-  (*search and delete entry with key name; if a page underflow arises,
-    balance with adjacent page or merge; h := "page dpg0 is undersize"*)
-
-    VAR i, L, R: INTEGER;
-      dpg1: DiskAdr;
-      a: DirPage;
-
-    PROCEDURE del(VAR a: DirPage; R: INTEGER; dpg1: DiskAdr; VAR h: BOOLEAN);
-      VAR dpg2: DiskAdr;  (*global: a, R*)
-          b: DirPage;
-    BEGIN Kernel.GetSector(dpg1, b); ASSERT(b.mark = DirMark); dpg2 := b.e[b.m-1].p;
-      IF dpg2 # 0 THEN del(a, R, dpg2, h);
-        IF h THEN underflow(b, dpg2, b.m, h); Kernel.PutSector(dpg1, b) END
-      ELSE
-        b.e[b.m-1].p := a.e[R].p; a.e[R] := b.e[b.m-1];
-        DEC(b.m); h := b.m < N; Kernel.PutSector(dpg1, b)
-      END
-    END del;
-
-  BEGIN (*~h*) Kernel.GetSector(dpg0, a); ASSERT(a.mark = DirMark);
-    L := 0; R := a.m; (*binary search*)
-    WHILE L < R DO
-      i := (L+R) DIV 2;
-      IF name <= a.e[i].name THEN R := i ELSE L := i+1 END
-    END ;
-    IF R = 0 THEN dpg1 := a.p0 ELSE dpg1 := a.e[R-1].p END ;
-    IF (R < a.m) & (name = a.e[R].name) THEN
-      (*found, now delete*) fad := a.e[R].adr;
-      IF dpg1 = 0 THEN  (*a is a leaf page*)
-        DEC(a.m); h := a.m < N; i := R;
-        WHILE i < a.m DO a.e[i] := a.e[i+1]; INC(i) END
-      ELSE del(a, R, dpg1, h);
-        IF h THEN underflow(a, dpg1, R, h) END
-      END ;
-      Kernel.PutSector(dpg0, a)
-    ELSIF dpg1 # 0 THEN
-      delete(name, dpg1, h, fad);
-      IF h THEN underflow(a, dpg1, R, h); Kernel.PutSector(dpg0, a) END
-    ELSE (*not in tree*) fad := 0
-    END
-  END delete;
-
-  PROCEDURE Delete*(name: FileName; VAR fad: DiskAdr);
-    VAR h: BOOLEAN; newroot: DiskAdr;
-      a: DirPage;
-  BEGIN h := FALSE;
-    delete(name, DirRootAdr, h, fad);
-    IF h THEN (*root underflow*)
-      Kernel.GetSector(DirRootAdr, a); ASSERT(a.mark = DirMark);
-      IF (a.m = 0) & (a.p0 # 0) THEN
-        newroot := a.p0; Kernel.GetSector(newroot, a); ASSERT(a.mark = DirMark);
-        Kernel.PutSector(DirRootAdr, a) (*discard newroot*)
-      END
-    END
-  END Delete;
-
-  PROCEDURE enumerate(prefix:   ARRAY OF CHAR;
-                      dpg:          DiskAdr;
-                      proc:         EntryHandler;
-                      VAR continue: BOOLEAN);
-    VAR i, j: INTEGER; pfx, nmx: CHAR;
-      dpg1: DiskAdr; a: DirPage;
-  BEGIN Kernel.GetSector(dpg, a); ASSERT(a.mark = DirMark); i := 0;
-    WHILE (i < a.m) & continue DO
-      j := 0;
-      REPEAT pfx := prefix[j]; nmx := a.e[i].name[j]; INC(j)
-      UNTIL (nmx # pfx) OR (pfx = 0X);
-      IF nmx >= pfx THEN
-        IF i = 0 THEN dpg1 := a.p0 ELSE dpg1 := a.e[i-1].p END ;
-        IF dpg1 # 0 THEN enumerate(prefix, dpg1, proc, continue) END ;
-        IF pfx = 0X THEN
-          IF continue THEN proc(a.e[i].name, a.e[i].adr, continue) END
-        ELSE continue := FALSE
-        END
-      END ;
-      INC(i)
-    END ;
-    IF continue & (i > 0) & (a.e[i-1].p # 0) THEN
-      enumerate(prefix, a.e[i-1].p, proc, continue)
-    END
-  END enumerate;
-
-  PROCEDURE Enumerate*(prefix: ARRAY OF CHAR; proc: EntryHandler);
-    VAR b: BOOLEAN;
-  BEGIN b := TRUE; enumerate(prefix, DirRootAdr, proc, b)
-  END Enumerate;
-
-(* ----- initialization ----- *)
-
-PROCEDURE Init*;
-    VAR k: INTEGER;
-        A: ARRAY 2000 OF DiskAdr;
-
-    PROCEDURE MarkSectors(VAR A: ARRAY OF DiskAdr; k: INTEGER);
-      VAR L, R, i, j, n: INTEGER; x: DiskAdr;
-        hd: FileHeader;
-        B: IndexSector;
-
-      PROCEDURE sift(VAR A: ARRAY OF DiskAdr; L, R: INTEGER);
-        VAR i, j: INTEGER; x: DiskAdr;
-      BEGIN j := L; x := A[j];
-        REPEAT i := j; j := 2*j + 1;
-          IF (j+1 < R) & (A[j] < A[j+1]) THEN INC(j) END ;
-          IF (j < R) & (x <= A[j]) THEN A[i] := A[j] END
-        UNTIL (j >= R) OR (x > A[j]);
-        A[i] := x
-      END sift;
-
-    BEGIN L := k DIV 2; R := k; (*heapsort*)
-      WHILE L > 0 DO DEC(L); sift(A, L, R) END ;
-      WHILE R > 0 DO
-        DEC(R); x := A[0]; A[0] := A[R]; A[R] := x; sift(A, L, R)
-      END ;
-      WHILE L < k DO
-        Kernel.GetSector(A[L], hd); ASSERT(hd.mark = HeaderMark);
-        IF hd.aleng < SecTabSize THEN j := hd.aleng + 1;
-          REPEAT DEC(j); Kernel.MarkSector(hd.sec[j]) UNTIL j = 0
-        ELSE j := SecTabSize;
-          REPEAT DEC(j); Kernel.MarkSector(hd.sec[j]) UNTIL j = 0;
-          n := (hd.aleng - SecTabSize) DIV 256; i := 0;
-          WHILE i <= n DO
-            Kernel.MarkSector(hd.ext[i]);
-            Kernel.GetSector(hd.ext[i], B); (*index sector*)
-            IF i < n THEN j := 256 ELSE j := (hd.aleng - SecTabSize) MOD 256 + 1 END ;
-            REPEAT DEC(j); Kernel.MarkSector(B[j]) UNTIL j = 0;
-            INC(i)
-          END
-        END ;
-        INC(L)
-      END
-    END MarkSectors;
-
-    PROCEDURE TraverseDir(VAR A: ARRAY OF DiskAdr; VAR k: INTEGER; dpg: DiskAdr);
-      VAR i: INTEGER; a: DirPage;
-    BEGIN Kernel.GetSector(dpg, a); ASSERT(a.mark = DirMark); Kernel.MarkSector(dpg); i := 0;
-      WHILE i < a.m DO
-        A[k] := a.e[i].adr; INC(k); INC(i);
-        IF k = 2000 THEN MarkSectors(A, k); k := 0 END
-      END ;
-      IF a.p0 # 0 THEN
-        TraverseDir(A, k, a.p0); i := 0;
-        WHILE i < a.m DO
-          TraverseDir(A, k, a.e[i].p); INC(i)
-        END
-      END
-    END TraverseDir;
-
-  BEGIN k := 0; TraverseDir(A, k, DirRootAdr); MarkSectors(A, k)
-  END Init; 
-  
-END FileDir.
+MODULE FileDir;   (*NW 12.1.86 / 23.8.90 / 15.8.2013*)
+  IMPORT SYSTEM, Kernel;
+
+  (*File Directory is a B-tree with its root page at DirRootAdr.
+    Each entry contains a file name and the disk address of the file's head sector*)
+
+  CONST FnLength*    = 32;
+        SecTabSize*   = 64;
+        ExTabSize*   = 12;
+        SectorSize*   = 1024;
+        IndexSize*   = SectorSize DIV 4;
+        HeaderSize*  = 352;
+        DirRootAdr*  = 29;
+        DirPgSize*   = 24;
+        N = DirPgSize DIV 2;
+        DirMark*    = 9B1EA38DH;
+        HeaderMark* = 9BA71D86H;
+        FillerSize = 52;
+
+  TYPE DiskAdr      = INTEGER;
+    FileName*       = ARRAY FnLength OF CHAR;
+    SectorTable*    = ARRAY SecTabSize OF DiskAdr;
+    ExtensionTable* = ARRAY ExTabSize OF DiskAdr;
+    EntryHandler*   = PROCEDURE (name: FileName; sec: DiskAdr; VAR continue: BOOLEAN);
+
+    FileHeader* =
+      RECORD (*first page of each file on disk*)
+        mark*: INTEGER;
+        name*: FileName;
+        aleng*, bleng*, date*: INTEGER;
+        ext*:  ExtensionTable;
+        sec*: SectorTable;
+        fill: ARRAY SectorSize - HeaderSize OF BYTE;
+      END ;
+
+    FileHd* = POINTER TO FileHeader;
+    IndexSector* = ARRAY IndexSize OF DiskAdr;
+    DataSector* = ARRAY SectorSize OF BYTE;
+
+    DirEntry* =  (*B-tree node*)
+      RECORD
+        name*: FileName;
+        adr*:  DiskAdr; (*sec no of file header*)
+        p*:    DiskAdr  (*sec no of descendant in directory*)
+      END ;
+
+    DirPage*  =
+      RECORD mark*:  INTEGER;
+        m*:     INTEGER;
+        p0*:    DiskAdr;  (*sec no of left descendant in directory*)
+        fill:  ARRAY FillerSize OF BYTE;
+        e*:  ARRAY DirPgSize OF DirEntry
+      END ;
+
+  (*Exported procedures: Search, Insert, Delete, Enumerate, Init*)
+
+  PROCEDURE Search*(name: FileName; VAR A: DiskAdr);
+    VAR i, L, R: INTEGER; dadr: DiskAdr;
+      a: DirPage;
+  BEGIN dadr := DirRootAdr; A := 0;
+    REPEAT Kernel.GetSector(dadr, a); ASSERT(a.mark = DirMark);
+      L := 0; R := a.m; (*binary search*)
+      WHILE L < R DO
+        i := (L+R) DIV 2;
+        IF name <= a.e[i].name THEN R := i ELSE L := i+1 END
+      END ;
+      IF (R < a.m) & (name = a.e[R].name) THEN A := a.e[R].adr (*found*)
+      ELSIF R = 0 THEN dadr := a.p0
+      ELSE dadr := a.e[R-1].p
+      END ;
+    UNTIL (dadr = 0) OR (A # 0)
+  END Search;
+
+  PROCEDURE insert(name: FileName;
+                   dpg0:  DiskAdr;
+                   VAR h: BOOLEAN;
+                   VAR v: DirEntry;
+                   fad:     DiskAdr);
+    (*h = "tree has become higher and v is ascending element"*)
+    VAR ch: CHAR;
+      i, j, L, R: INTEGER;
+      dpg1: DiskAdr;
+      u: DirEntry;
+      a: DirPage;
+
+  BEGIN (*~h*) Kernel.GetSector(dpg0, a); ASSERT(a.mark = DirMark);
+    L := 0; R := a.m; (*binary search*)
+    WHILE L < R DO
+      i := (L+R) DIV 2;
+      IF name <= a.e[i].name THEN R := i ELSE L := i+1 END
+    END ;
+    IF (R < a.m) & (name = a.e[R].name) THEN
+      a.e[R].adr := fad; Kernel.PutSector(dpg0, a)  (*replace*)
+    ELSE (*not on this page*)
+      IF R = 0 THEN dpg1 := a.p0 ELSE dpg1 := a.e[R-1].p END ;
+      IF dpg1 = 0 THEN (*not in tree, insert*)
+        u.adr := fad; u.p := 0; h := TRUE; j := 0;
+        REPEAT ch := name[j]; u.name[j] := ch; INC(j)
+        UNTIL ch = 0X;
+        WHILE j < FnLength DO u.name[j] := 0X; INC(j) END ;
+      ELSE
+        insert(name, dpg1, h, u, fad)
+      END ;
+      IF h THEN (*insert u to the left of e[R]*)
+        IF a.m < DirPgSize THEN
+          h := FALSE; i := a.m;
+          WHILE i > R DO DEC(i); a.e[i+1] := a.e[i] END ;
+          a.e[R] := u; INC(a.m)
+        ELSE (*split page and assign the middle element to v*)
+          a.m := N; a.mark := DirMark;
+          IF R < N THEN (*insert in left half*)
+            v := a.e[N-1]; i := N-1;
+            WHILE i > R DO DEC(i); a.e[i+1] := a.e[i] END ;
+            a.e[R] := u; Kernel.PutSector(dpg0, a);
+            Kernel.AllocSector(dpg0, dpg0); i := 0;
+            WHILE i < N DO a.e[i] := a.e[i+N]; INC(i) END
+          ELSE (*insert in right half*)
+            Kernel.PutSector(dpg0, a);
+            Kernel.AllocSector(dpg0, dpg0); DEC(R, N); i := 0;
+            IF R = 0 THEN v := u
+            ELSE v := a.e[N];
+              WHILE i < R-1 DO a.e[i] := a.e[N+1+i]; INC(i) END ;
+              a.e[i] := u; INC(i)
+            END ;
+            WHILE i < N DO a.e[i] := a.e[N+i]; INC(i) END
+          END ;
+          a.p0 := v.p; v.p := dpg0
+        END ;
+        Kernel.PutSector(dpg0, a)
+      END
+    END
+  END insert;
+
+  PROCEDURE Insert*(name: FileName; fad: DiskAdr);
+    VAR  oldroot: DiskAdr;
+      h: BOOLEAN; U: DirEntry;
+      a: DirPage;
+  BEGIN h := FALSE;
+    insert(name, DirRootAdr, h, U, fad);
+    IF h THEN (*root overflow*)
+      Kernel.GetSector(DirRootAdr, a); ASSERT(a.mark = DirMark);
+      Kernel.AllocSector(DirRootAdr, oldroot); Kernel.PutSector(oldroot, a);
+      a.mark := DirMark; a.m := 1; a.p0 := oldroot; a.e[0] := U;
+      Kernel.PutSector(DirRootAdr, a)
+    END
+  END Insert;
+
+
+  PROCEDURE underflow(VAR c: DirPage;  (*ancestor page*)
+                      dpg0:  DiskAdr;
+                      s:     INTEGER;  (*insertion point in c*)
+                      VAR h: BOOLEAN); (*c undersize*)
+    VAR i, k: INTEGER;
+        dpg1: DiskAdr;
+        a, b: DirPage;  (*a := underflowing page, b := neighbouring page*)
+  BEGIN Kernel.GetSector(dpg0, a); ASSERT(a.mark = DirMark);
+    (*h & a.m = N-1 & dpg0 = c.e[s-1].p*)
+    IF s < c.m THEN (*b := page to the right of a*)
+      dpg1 := c.e[s].p; Kernel.GetSector(dpg1, b); ASSERT(b.mark = DirMark);
+      k := (b.m-N+1) DIV 2; (*k = no. of items available on page b*)
+      a.e[N-1] := c.e[s]; a.e[N-1].p := b.p0;
+      IF k > 0 THEN
+        (*move k-1 items from b to a, one to c*) i := 0;
+        WHILE i < k-1 DO a.e[i+N] := b.e[i]; INC(i) END ;
+        c.e[s] := b.e[i]; b.p0 := c.e[s].p;
+        c.e[s].p := dpg1; b.m := b.m - k; i := 0;
+        WHILE i < b.m DO b.e[i] := b.e[i+k]; INC(i) END ;
+        Kernel.PutSector(dpg1, b); a.m := N-1+k; h := FALSE
+      ELSE (*merge pages a and b, discard b*) i := 0;
+        WHILE i < N DO a.e[i+N] := b.e[i]; INC(i) END ;
+        i := s; DEC(c.m);
+        WHILE i < c.m DO c.e[i] := c.e[i+1]; INC(i) END ;
+        a.m := 2*N; h := c.m < N
+      END ;
+      Kernel.PutSector(dpg0, a)
+    ELSE (*b := page to the left of a*) DEC(s);
+      IF s = 0 THEN dpg1 := c.p0 ELSE dpg1 := c.e[s-1].p END ;
+      Kernel.GetSector(dpg1, b); ASSERT(b.mark = DirMark);
+      k := (b.m-N+1) DIV 2; (*k = no. of items available on page b*)
+      IF k > 0 THEN
+        i := N-1;
+        WHILE i > 0 DO DEC(i); a.e[i+k] := a.e[i] END ;
+        i := k-1; a.e[i] := c.e[s]; a.e[i].p := a.p0;
+        (*move k-1 items from b to a, one to c*) b.m := b.m - k;
+        WHILE i > 0 DO DEC(i); a.e[i] := b.e[i+b.m+1] END ;
+        c.e[s] := b.e[b.m]; a.p0 := c.e[s].p;
+        c.e[s].p := dpg0; a.m := N-1+k; h := FALSE;
+        Kernel.PutSector(dpg0, a)
+      ELSE (*merge pages a and b, discard a*)
+        c.e[s].p := a.p0; b.e[N] := c.e[s]; i := 0;
+        WHILE i < N-1 DO b.e[i+N+1] := a.e[i]; INC(i) END ;
+        b.m := 2*N; DEC(c.m); h := c.m < N
+      END ;
+      Kernel.PutSector(dpg1, b)
+    END
+  END underflow;
+
+  PROCEDURE delete(name: FileName;
+                   dpg0: DiskAdr;
+                   VAR h: BOOLEAN;
+                   VAR fad: DiskAdr);
+  (*search and delete entry with key name; if a page underflow arises,
+    balance with adjacent page or merge; h := "page dpg0 is undersize"*)
+
+    VAR i, L, R: INTEGER;
+      dpg1: DiskAdr;
+      a: DirPage;
+
+    PROCEDURE del(VAR a: DirPage; R: INTEGER; dpg1: DiskAdr; VAR h: BOOLEAN);
+      VAR dpg2: DiskAdr;  (*global: a, R*)
+          b: DirPage;
+    BEGIN Kernel.GetSector(dpg1, b); ASSERT(b.mark = DirMark); dpg2 := b.e[b.m-1].p;
+      IF dpg2 # 0 THEN del(a, R, dpg2, h);
+        IF h THEN underflow(b, dpg2, b.m, h); Kernel.PutSector(dpg1, b) END
+      ELSE
+        b.e[b.m-1].p := a.e[R].p; a.e[R] := b.e[b.m-1];
+        DEC(b.m); h := b.m < N; Kernel.PutSector(dpg1, b)
+      END
+    END del;
+
+  BEGIN (*~h*) Kernel.GetSector(dpg0, a); ASSERT(a.mark = DirMark);
+    L := 0; R := a.m; (*binary search*)
+    WHILE L < R DO
+      i := (L+R) DIV 2;
+      IF name <= a.e[i].name THEN R := i ELSE L := i+1 END
+    END ;
+    IF R = 0 THEN dpg1 := a.p0 ELSE dpg1 := a.e[R-1].p END ;
+    IF (R < a.m) & (name = a.e[R].name) THEN
+      (*found, now delete*) fad := a.e[R].adr;
+      IF dpg1 = 0 THEN  (*a is a leaf page*)
+        DEC(a.m); h := a.m < N; i := R;
+        WHILE i < a.m DO a.e[i] := a.e[i+1]; INC(i) END
+      ELSE del(a, R, dpg1, h);
+        IF h THEN underflow(a, dpg1, R, h) END
+      END ;
+      Kernel.PutSector(dpg0, a)
+    ELSIF dpg1 # 0 THEN
+      delete(name, dpg1, h, fad);
+      IF h THEN underflow(a, dpg1, R, h); Kernel.PutSector(dpg0, a) END
+    ELSE (*not in tree*) fad := 0
+    END
+  END delete;
+
+  PROCEDURE Delete*(name: FileName; VAR fad: DiskAdr);
+    VAR h: BOOLEAN; newroot: DiskAdr;
+      a: DirPage;
+  BEGIN h := FALSE;
+    delete(name, DirRootAdr, h, fad);
+    IF h THEN (*root underflow*)
+      Kernel.GetSector(DirRootAdr, a); ASSERT(a.mark = DirMark);
+      IF (a.m = 0) & (a.p0 # 0) THEN
+        newroot := a.p0; Kernel.GetSector(newroot, a); ASSERT(a.mark = DirMark);
+        Kernel.PutSector(DirRootAdr, a) (*discard newroot*)
+      END
+    END
+  END Delete;
+
+  PROCEDURE enumerate(prefix:   ARRAY OF CHAR;
+                      dpg:          DiskAdr;
+                      proc:         EntryHandler;
+                      VAR continue: BOOLEAN);
+    VAR i, j: INTEGER; pfx, nmx: CHAR;
+      dpg1: DiskAdr; a: DirPage;
+  BEGIN Kernel.GetSector(dpg, a); ASSERT(a.mark = DirMark); i := 0;
+    WHILE (i < a.m) & continue DO
+      j := 0;
+      REPEAT pfx := prefix[j]; nmx := a.e[i].name[j]; INC(j)
+      UNTIL (nmx # pfx) OR (pfx = 0X);
+      IF nmx >= pfx THEN
+        IF i = 0 THEN dpg1 := a.p0 ELSE dpg1 := a.e[i-1].p END ;
+        IF dpg1 # 0 THEN enumerate(prefix, dpg1, proc, continue) END ;
+        IF pfx = 0X THEN
+          IF continue THEN proc(a.e[i].name, a.e[i].adr, continue) END
+        ELSE continue := FALSE
+        END
+      END ;
+      INC(i)
+    END ;
+    IF continue & (i > 0) & (a.e[i-1].p # 0) THEN
+      enumerate(prefix, a.e[i-1].p, proc, continue)
+    END
+  END enumerate;
+
+  PROCEDURE Enumerate*(prefix: ARRAY OF CHAR; proc: EntryHandler);
+    VAR b: BOOLEAN;
+  BEGIN b := TRUE; enumerate(prefix, DirRootAdr, proc, b)
+  END Enumerate;
+
+(* ----- initialization ----- *)
+
+PROCEDURE Init*;
+    VAR k: INTEGER;
+        A: ARRAY 2000 OF DiskAdr;
+
+    PROCEDURE MarkSectors(VAR A: ARRAY OF DiskAdr; k: INTEGER);
+      VAR L, R, i, j, n: INTEGER; x: DiskAdr;
+        hd: FileHeader;
+        B: IndexSector;
+
+      PROCEDURE sift(VAR A: ARRAY OF DiskAdr; L, R: INTEGER);
+        VAR i, j: INTEGER; x: DiskAdr;
+      BEGIN j := L; x := A[j];
+        REPEAT i := j; j := 2*j + 1;
+          IF (j+1 < R) & (A[j] < A[j+1]) THEN INC(j) END ;
+          IF (j < R) & (x <= A[j]) THEN A[i] := A[j] END
+        UNTIL (j >= R) OR (x > A[j]);
+        A[i] := x
+      END sift;
+
+    BEGIN L := k DIV 2; R := k; (*heapsort*)
+      WHILE L > 0 DO DEC(L); sift(A, L, R) END ;
+      WHILE R > 0 DO
+        DEC(R); x := A[0]; A[0] := A[R]; A[R] := x; sift(A, L, R)
+      END ;
+      WHILE L < k DO
+        Kernel.GetSector(A[L], hd); ASSERT(hd.mark = HeaderMark);
+        IF hd.aleng < SecTabSize THEN j := hd.aleng + 1;
+          REPEAT DEC(j); Kernel.MarkSector(hd.sec[j]) UNTIL j = 0
+        ELSE j := SecTabSize;
+          REPEAT DEC(j); Kernel.MarkSector(hd.sec[j]) UNTIL j = 0;
+          n := (hd.aleng - SecTabSize) DIV 256; i := 0;
+          WHILE i <= n DO
+            Kernel.MarkSector(hd.ext[i]);
+            Kernel.GetSector(hd.ext[i], B); (*index sector*)
+            IF i < n THEN j := 256 ELSE j := (hd.aleng - SecTabSize) MOD 256 + 1 END ;
+            REPEAT DEC(j); Kernel.MarkSector(B[j]) UNTIL j = 0;
+            INC(i)
+          END
+        END ;
+        INC(L)
+      END
+    END MarkSectors;
+
+    PROCEDURE TraverseDir(VAR A: ARRAY OF DiskAdr; VAR k: INTEGER; dpg: DiskAdr);
+      VAR i: INTEGER; a: DirPage;
+    BEGIN Kernel.GetSector(dpg, a); ASSERT(a.mark = DirMark); Kernel.MarkSector(dpg); i := 0;
+      WHILE i < a.m DO
+        A[k] := a.e[i].adr; INC(k); INC(i);
+        IF k = 2000 THEN MarkSectors(A, k); k := 0 END
+      END ;
+      IF a.p0 # 0 THEN
+        TraverseDir(A, k, a.p0); i := 0;
+        WHILE i < a.m DO
+          TraverseDir(A, k, a.e[i].p); INC(i)
+        END
+      END
+    END TraverseDir;
+
+  BEGIN k := 0; TraverseDir(A, k, DirRootAdr); MarkSectors(A, k)
+  END Init; 
+  
+END FileDir.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Files.Mod.txt

@@ -1,506 +1,506 @@
-MODULE Files;  (*NW 11.1.86 / 22.9.93 / 25.5.95 / 25.12.95 / 15.8.2013*)
-  IMPORT SYSTEM, Kernel, FileDir;
-
-  (*A file consists of a sequence of pages. The first page
-    contains the header. Part of the header is the page table, an array
-    of disk addresses to the pages. A file is referenced through riders.
-    A rider indicates a current position and refers to a file*)
-
-  CONST MaxBufs    = 4;
-      HS        = FileDir.HeaderSize;
-      SS        = FileDir.SectorSize;
-      STS       = FileDir.SecTabSize;
-      XS        = FileDir.IndexSize;
-
-  TYPE  DiskAdr = INTEGER;
-      File*    = POINTER TO FileDesc;
-      Buffer  = POINTER TO BufferRecord;
-      Index   = POINTER TO IndexRecord;
-
-    Rider* =
-      RECORD eof*: BOOLEAN;
-        res*: INTEGER;
-        file: File;
-        apos, bpos: INTEGER;
-        buf: Buffer
-      END ;
-
-    FileDesc =
-      RECORD next: INTEGER; (*list of files invisible to the GC*)
-        nofbufs, aleng, bleng: INTEGER;
-        modH, registered: BOOLEAN;
-        firstbuf: Buffer;
-        sechint: DiskAdr;
-        name: FileDir.FileName;
-        date: INTEGER;
-        ext:  ARRAY FileDir.ExTabSize OF Index;
-        sec: FileDir.SectorTable
-      END ;
-
-    BufferRecord =
-      RECORD apos, lim: INTEGER;
-        mod: BOOLEAN;
-        next: Buffer;
-        data: FileDir.DataSector
-      END ;
-
-    IndexRecord =
-      RECORD adr: DiskAdr;
-        mod: BOOLEAN;
-        sec: FileDir.IndexSector
-      END ;
-
-    (*aleng * SS + bleng = length (including header)
-      apos * SS + bpos = current position
-      0 <= bpos <= lim <= SS
-      0 <= apos <= aleng < PgTabSize
-      (apos < aleng) & (lim = SS) OR (apos = aleng) *)
-
-  VAR root: INTEGER (*File*);  (*list of open files*)
-
-  PROCEDURE Check(s: ARRAY OF CHAR;
-        VAR name: FileDir.FileName; VAR res: INTEGER);
-    VAR i: INTEGER; ch: CHAR;
-  BEGIN ch := s[0]; i := 0;
-    IF (ch >= "A") & (ch <= "Z") OR (ch >= "a") & (ch <= "z") THEN
-      REPEAT name[i] := ch; INC(i); ch := s[i]
-      UNTIL ~((ch >= "0") & (ch <= "9") OR (ch >= "A") & (ch <= "Z")
-        OR (ch >= "a") & (ch <= "z") OR (ch = ".")) OR (i = FileDir.FnLength);
-      IF i = FileDir.FnLength THEN res := 4
-      ELSIF ch = 0X THEN res := 0;
-        WHILE i < FileDir.FnLength DO name[i] := 0X; INC(i) END
-      ELSE res := 5
-      END
-    ELSIF ch = 0X THEN name[0] := 0X; res := -1
-    ELSE res := 3
-    END
-  END Check;
-
-  PROCEDURE Old*(name: ARRAY OF CHAR): File;
-    VAR i, k, res: INTEGER;
-      f: File;
-      header: DiskAdr;
-      buf: Buffer;
-      F: FileDir.FileHd;
-      namebuf: FileDir.FileName;
-      inxpg: Index;
-  BEGIN f := NIL; Check(name, namebuf, res);
-    IF res = 0 THEN
-      FileDir.Search(namebuf, header);
-      IF header # 0 THEN
-        f := SYSTEM.VAL(File, root);
-        WHILE (f # NIL) & (f.sec[0] # header) DO f := SYSTEM.VAL(File, f.next) END ;
-        IF f = NIL THEN (*file not yet present*)
-          NEW(buf); buf.apos := 0; buf.next := buf; buf.mod := FALSE;
-          F := SYSTEM.VAL(FileDir.FileHd, SYSTEM.ADR(buf.data));
-          Kernel.GetSector(header, buf.data); ASSERT(F.mark = FileDir.HeaderMark);
-          NEW(f); f.aleng := F.aleng; f.bleng := F.bleng; f.date := F.date;
-          IF f.aleng = 0 THEN buf.lim := f.bleng ELSE buf.lim := SS END ;
-          f.firstbuf := buf; f.nofbufs := 1; f.name := namebuf; f.registered := TRUE;
-          f.sec := F.sec;
-          k := (f.aleng + (XS-STS)) DIV XS; i := 0;
-          WHILE i < k DO
-            NEW(inxpg); inxpg.adr := F.ext[i]; inxpg.mod := FALSE;
-            Kernel.GetSector(inxpg.adr, inxpg.sec); f.ext[i] := inxpg; INC(i)
-          END ;
-          WHILE i < FileDir.ExTabSize DO f.ext[i] := NIL; INC(i) END ;
-          f.sechint := header; f.modH := FALSE; f.next := root; root := SYSTEM.VAL(INTEGER, f)
-        END
-      END
-    END ;
-    RETURN f
-  END Old;
-
-  PROCEDURE New*(name: ARRAY OF CHAR): File;
-    VAR i, res: INTEGER;
-      f: File;
-      buf: Buffer;
-      F: FileDir.FileHd;
-      namebuf: FileDir.FileName;
-  BEGIN f := NIL; Check(name, namebuf, res);
-    IF res <= 0 THEN
-      NEW(buf); buf.apos := 0; buf.mod := TRUE; buf.lim := HS; buf.next := buf;
-      F := SYSTEM.VAL(FileDir.FileHd, SYSTEM.ADR(buf.data));
-      F.mark := FileDir.HeaderMark;
-      F.aleng := 0; F.bleng := HS; F.name := namebuf;
-      F.date := Kernel.Clock();
-      NEW(f); f.aleng := 0; f.bleng := HS; f.modH := TRUE;
-      f.registered := FALSE; f.date := F.date;
-      f.firstbuf := buf; f.nofbufs := 1; f.name := namebuf; f.sechint := 0;
-      i := 0;
-      REPEAT f.ext[i] := NIL; F.ext[i] := 0; INC(i) UNTIL i = FileDir.ExTabSize;
-      i := 0;
-      REPEAT f.sec[i] := 0; F.sec[i] := 0; INC(i) UNTIL i = STS
-    END ;
-    RETURN f
-  END New;
-
-  PROCEDURE UpdateHeader(f: File; VAR F: FileDir.FileHeader);
-    VAR k: INTEGER;
-  BEGIN F.aleng := f.aleng; F.bleng := f.bleng;
-    F.sec := f.sec; k := (f.aleng + (XS-STS)) DIV XS;
-    WHILE k > 0 DO DEC(k); F.ext[k] := f.ext[k].adr END
-  END UpdateHeader;
-
-  PROCEDURE ReadBuf(f: File; buf: Buffer; pos: INTEGER);
-    VAR sec: DiskAdr;
-  BEGIN
-    IF pos < STS THEN sec := f.sec[pos]
-    ELSE sec := f.ext[(pos-STS) DIV XS].sec[(pos-STS) MOD XS]
-    END ;
-    Kernel.GetSector(sec, buf.data);
-    IF pos < f.aleng THEN buf.lim := SS ELSE buf.lim := f.bleng END ;
-    buf.apos := pos; buf.mod := FALSE
-  END ReadBuf;
-
-  PROCEDURE WriteBuf(f: File; buf: Buffer);
-    VAR i, k: INTEGER;
-      secadr: DiskAdr; inx: Index;
-  BEGIN 
-    IF buf.apos < STS THEN
-      secadr := f.sec[buf.apos];
-      IF secadr = 0 THEN
-        Kernel.AllocSector(f.sechint, secadr);
-        f.modH := TRUE; f.sec[buf.apos] := secadr; f.sechint := secadr
-      END ;
-      IF buf.apos = 0 THEN
-        UpdateHeader(f, SYSTEM.VAL(FileDir.FileHeader, buf.data)); f.modH := FALSE
-      END
-    ELSE i := (buf.apos - STS) DIV XS; inx := f.ext[i];
-      IF inx = NIL THEN
-        NEW(inx); inx.adr := 0; inx.sec[0] := 0; f.ext[i] := inx; f.modH := TRUE
-      END ;
-      k := (buf.apos - STS) MOD XS; secadr := inx.sec[k];
-      IF secadr = 0 THEN
-        Kernel.AllocSector(f.sechint, secadr);
-        f.modH := TRUE; inx.mod := TRUE; inx.sec[k] := secadr; f.sechint := secadr
-      END
-    END ;
-    Kernel.PutSector(secadr, buf.data); buf.mod := FALSE
-  END WriteBuf;
-
-  PROCEDURE Buf(f: File; pos: INTEGER): Buffer;
-    VAR buf: Buffer;
-  BEGIN buf := f.firstbuf;
-    WHILE (buf.apos # pos) & (buf.next # f.firstbuf) DO buf := buf.next END ;
-    IF buf.apos # pos THEN buf := NIL END ;
-    RETURN buf
-  END Buf;
-
-  PROCEDURE GetBuf(f: File; pos: INTEGER): Buffer;
-    VAR buf: Buffer;
-  BEGIN buf := f.firstbuf;
-    WHILE (buf.apos # pos) & (buf.next # f.firstbuf) DO buf := buf.next END ;
-    IF buf.apos # pos THEN 
-      IF f.nofbufs < MaxBufs THEN  (*allocate new buffer*)
-        NEW(buf); buf.next := f.firstbuf.next; f.firstbuf.next := buf; INC(f.nofbufs)
-      ELSE (*reuse a buffer*) f.firstbuf := buf;
-        IF buf.mod THEN WriteBuf(f, buf) END
-      END ;
-      IF pos <= f.aleng THEN ReadBuf(f, buf, pos) ELSE buf.apos := pos; buf.lim := 0; buf.mod := FALSE END
-    END ;
-    RETURN buf
-  END GetBuf;
-
-  PROCEDURE Unbuffer(f: File);
-    VAR i, k: INTEGER;
-      buf: Buffer;
-      inx: Index;
-      head: FileDir.FileHeader;
-  BEGIN buf := f.firstbuf;
-    REPEAT
-      IF buf.mod THEN WriteBuf(f, buf) END ;
-      buf := buf.next
-    UNTIL buf = f.firstbuf;
-    k := (f.aleng + (XS-STS)) DIV XS; i := 0;
-    WHILE i < k DO
-      inx := f.ext[i]; INC(i);
-      IF inx.mod THEN
-        IF inx.adr = 0 THEN
-          Kernel.AllocSector(f.sechint, inx.adr); f.sechint := inx.adr; f.modH := TRUE
-        END ;
-        Kernel.PutSector(inx.adr, inx.sec); inx.mod := FALSE
-      END
-    END ;
-    IF f.modH THEN
-      Kernel.GetSector(f.sec[0], head); UpdateHeader(f, head);
-      Kernel.PutSector(f.sec[0], head); f.modH := FALSE
-    END
-  END Unbuffer;
-
-  PROCEDURE Register*(f: File);
-  BEGIN
-    IF (f # NIL) & (f.name[0] # 0X) THEN
-      Unbuffer(f);
-      IF ~f.registered THEN
-        FileDir.Insert(f.name, f.sec[0]); f.registered := TRUE; f.next := root; root := SYSTEM.VAL(INTEGER, f)
-      END
-    END
-  END Register;
-
-  PROCEDURE Close*(f: File);
-  BEGIN
-    IF f # NIL THEN Unbuffer(f) END
-  END Close;
-
-  PROCEDURE Purge*(f: File);
-    VAR a, i, j, k: INTEGER;
-      ind: FileDir.IndexSector;
-  BEGIN
-    IF f # NIL THEN a := f.aleng + 1; f.aleng := 0; f.bleng := HS;
-      IF a <= STS THEN i := a;
-      ELSE i := STS; DEC(a, i); j := (a-1) MOD XS; k := (a-1) DIV XS;
-        WHILE k >= 0 DO
-          Kernel.GetSector(f.ext[k].adr, ind);
-          REPEAT DEC(j); Kernel.FreeSector(ind[j]) UNTIL j = 0;
-          Kernel.FreeSector(f.ext[k].adr); j := XS; DEC(k)
-        END
-      END ;
-      REPEAT DEC(i); Kernel.FreeSector(f.sec[i]) UNTIL i = 0
-    END
-  END Purge;
-
-  PROCEDURE Delete*(name: ARRAY OF CHAR; VAR res: INTEGER);
-    VAR adr: DiskAdr;
-        namebuf: FileDir.FileName;
-  BEGIN Check(name, namebuf, res);
-    IF res = 0 THEN
-      FileDir.Delete(namebuf, adr);
-      IF adr = 0 THEN res := 2 END
-    END
-  END Delete;
-
-  PROCEDURE Rename*(old, new: ARRAY OF CHAR; VAR res: INTEGER);
-    VAR adr: DiskAdr;
-        oldbuf, newbuf: FileDir.FileName;
-        head: FileDir.FileHeader;
-  BEGIN Check(old, oldbuf, res);
-    IF res = 0 THEN
-      Check(new, newbuf, res);
-      IF res = 0 THEN
-        FileDir.Delete(oldbuf, adr);
-        IF adr # 0 THEN
-          FileDir.Insert(newbuf, adr);
-          Kernel.GetSector(adr, head); head.name := newbuf; Kernel.PutSector(adr, head)
-        ELSE res := 2
-        END
-      END
-    END
-  END Rename;
-
-  PROCEDURE Length*(f: File): INTEGER;
-  BEGIN RETURN f.aleng * SS + f.bleng - HS
-  END Length;
-
-  PROCEDURE Date*(f: File): INTEGER;
-  BEGIN RETURN f.date
-  END Date;
-
-  (*---------------------------Read---------------------------*)
-
-  PROCEDURE Set*(VAR r: Rider; f: File; pos: INTEGER);
-    VAR a, b: INTEGER;
-  BEGIN  r.eof := FALSE; r.res := 0;
-    IF f # NIL THEN
-      IF pos < 0 THEN a := 0; b := HS
-      ELSIF pos < f.aleng * SS + f.bleng - HS THEN
-        a := (pos + HS) DIV SS; b := (pos + HS) MOD SS;
-      ELSE a := f.aleng; b := f.bleng
-      END ;
-      r.file := f; r.apos := a; r.bpos := b; r.buf := f.firstbuf
-    ELSE r.file:= NIL
-    END
-  END Set;
-
-  PROCEDURE Pos*(VAR r: Rider): INTEGER;
-  BEGIN RETURN r.apos * SS + r.bpos - HS
-  END Pos;
-
-  PROCEDURE Base*(VAR r: Rider): File;
-  BEGIN RETURN r.file
-  END Base;
-
-  PROCEDURE ReadByte*(VAR r: Rider; VAR x: BYTE);
-    VAR buf: Buffer;
-  BEGIN
-    IF r.apos # r.buf.apos THEN r.buf := GetBuf(r.file, r.apos) END ;
-    IF r.bpos < r.buf.lim THEN x := r.buf.data[r.bpos]; INC(r.bpos)
-    ELSIF r.apos < r.file.aleng THEN
-      INC(r.apos); buf := Buf(r.file, r.apos);
-      IF buf = NIL THEN
-        IF r.buf.mod THEN WriteBuf(r.file, r.buf) END ;
-        ReadBuf(r.file, r.buf, r.apos)
-      ELSE r.buf := buf
-      END ;
-      x := r.buf.data[0]; r.bpos := 1
-    ELSE x := 0; r.eof := TRUE
-    END
-  END ReadByte;
-
-  PROCEDURE ReadBytes*(VAR r: Rider; VAR x: ARRAY OF BYTE; n: INTEGER);
-    VAR i: INTEGER;
-  BEGIN i := 0;  (*this implementation is to be improved*)
-    WHILE i < n DO ReadByte(r, x[i]); INC(i) END
-  END ReadBytes;
-
-  PROCEDURE Read*(VAR r: Rider; VAR ch: CHAR);
-    VAR buf: Buffer;  (*same as ReadByte*)
-  BEGIN
-    IF r.apos # r.buf.apos THEN r.buf := GetBuf(r.file, r.apos) END ;
-    IF r.bpos < r.buf.lim THEN ch := CHR(r.buf.data[r.bpos]); INC(r.bpos)
-    ELSIF r.apos < r.file.aleng THEN
-      INC(r.apos); buf := Buf(r.file, r.apos);
-      IF buf = NIL THEN
-        IF r.buf.mod THEN WriteBuf(r.file, r.buf) END ;
-        ReadBuf(r.file, r.buf, r.apos)
-      ELSE r.buf := buf
-      END ;
-      ch := CHR(r.buf.data[0]); r.bpos := 1
-    ELSE ch := 0X; r.eof := TRUE
-    END
-  END Read;
-
-  PROCEDURE ReadInt*(VAR R: Rider; VAR x: INTEGER);
-    VAR x0, x1, x2, x3: BYTE;
-  BEGIN ReadByte(R, x0); ReadByte(R, x1); ReadByte(R, x2); ReadByte(R, x3);
-    x := ((x3 * 100H + x2) * 100H + x1) * 100H + x0
-  END ReadInt;
-
-  PROCEDURE ReadSet*(VAR R: Rider; VAR s: SET);
-    VAR n: INTEGER;
-  BEGIN ReadInt(R, SYSTEM.VAL(INTEGER, s))
-  END ReadSet;
-
-  PROCEDURE ReadReal*(VAR R: Rider; VAR x: REAL);
-    VAR n: INTEGER;
-  BEGIN ReadInt(R, SYSTEM.VAL(INTEGER, x))
-  END ReadReal;
-
-  PROCEDURE ReadString*(VAR R: Rider; VAR x: ARRAY OF CHAR);
-    VAR i: INTEGER; ch: CHAR;
-  BEGIN i := 0; Read(R, ch);
-    WHILE ch # 0X DO
-      IF i < LEN(x)-1 THEN x[i] := ch; INC(i) END ;
-      Read(R, ch)
-    END ;
-    x[i] := 0X
-  END ReadString;
-
-  PROCEDURE ReadNum*(VAR R: Rider; VAR x: INTEGER);
-    VAR n, y: INTEGER; b: BYTE;
-  BEGIN n := 32; y := 0; ReadByte(R, b);
-    WHILE b >= 80H DO y := ROR(y + b-80H, 7); DEC(n, 7); ReadByte(R, b) END ;
-    IF n <= 4 THEN x := ROR(y + b MOD 10H, 4) ELSE x := ASR(ROR(y + b, 7), n-7) END
-  END ReadNum;
-        
-  (*---------------------------Write---------------------------*)
-
-  PROCEDURE NewExt(f: File);
-    VAR i, k: INTEGER; ext: Index;
-  BEGIN k := (f.aleng - STS) DIV XS;
-    NEW(ext); ext.adr := 0; ext.mod := TRUE; f.ext[k] := ext; i := XS;
-    REPEAT DEC(i); ext.sec[i] := 0 UNTIL i = 0
-  END NewExt;
-
-  PROCEDURE WriteByte*(VAR r: Rider; x: BYTE);
-    VAR f: File; buf: Buffer;
-  BEGIN
-    IF r.apos # r.buf.apos THEN r.buf := GetBuf(r.file, r.apos); END ;
-    IF r.bpos >= r.buf.lim THEN
-      IF r.bpos < SS THEN
-        INC(r.buf.lim); INC(r.file.bleng); r.file.modH := TRUE
-      ELSE f := r.file; WriteBuf(f, r.buf); INC(r.apos); buf := Buf(r.file, r.apos);
-        IF buf = NIL THEN
-          IF r.apos <= f.aleng THEN ReadBuf(f, r.buf, r.apos)
-          ELSE r.buf.apos := r.apos; r.buf.lim := 1; f.aleng := f.aleng + 1; f.bleng := 1; f.modH := TRUE;
-            IF (f.aleng - STS) MOD XS = 0 THEN NewExt(f) END
-          END
-        ELSE r.buf := buf
-        END ;
-        r.bpos := 0
-      END
-    END ;
-    r.buf.data[r.bpos] := x; INC(r.bpos); r.buf.mod := TRUE
-  END WriteByte;
-
-  PROCEDURE WriteBytes*(VAR r: Rider; x: ARRAY OF BYTE; n: INTEGER);
-    VAR i: INTEGER;
-  BEGIN i := 0; (*this implementation is to be improed*)
-    WHILE i < n DO WriteByte(r, x[i]); INC(i) END
-  END WriteBytes;
-
-  PROCEDURE Write*(VAR r: Rider; ch: CHAR);
-    VAR f: File; buf: Buffer;
-  BEGIN (*same as WriteByte*)
-    IF r.apos # r.buf.apos THEN r.buf := GetBuf(r.file, r.apos); END ;
-    IF r.bpos >= r.buf.lim THEN
-      IF r.bpos < SS THEN
-        INC(r.buf.lim); INC(r.file.bleng); r.file.modH := TRUE
-      ELSE f := r.file; WriteBuf(f, r.buf); INC(r.apos); buf := Buf(r.file, r.apos);
-        IF buf = NIL THEN
-          IF r.apos <= f.aleng THEN ReadBuf(f, r.buf, r.apos)
-          ELSE r.buf.apos := r.apos; r.buf.lim := 1; f.aleng := f.aleng + 1; f.bleng := 1; f.modH := TRUE;
-            IF (f.aleng - STS) MOD XS = 0 THEN NewExt(f) END
-          END
-        ELSE r.buf := buf
-        END ;
-        r.bpos := 0
-      END
-    END ;
-    r.buf.data[r.bpos] := ORD(ch); INC(r.bpos); r.buf.mod := TRUE
-  END Write;
-
-  PROCEDURE WriteInt*(VAR R: Rider; x: INTEGER);
-  BEGIN WriteByte(R, x MOD 100H);
-    WriteByte(R, x DIV 100H MOD 100H);
-    WriteByte(R, x DIV 10000H MOD 100H);
-    WriteByte(R, x DIV 1000000H MOD 100H)
-  END WriteInt;
-
-  PROCEDURE WriteSet*(VAR R: Rider; s: SET);
-  BEGIN WriteInt(R, ORD(s))
-  END WriteSet;
-
-  PROCEDURE WriteReal*(VAR R: Rider; x: REAL);
-  BEGIN  WriteInt(R, ORD(x))
-  END WriteReal;
-
-  PROCEDURE WriteString*(VAR R: Rider; x: ARRAY OF CHAR);
-    VAR i: INTEGER; ch: CHAR;
-  BEGIN i := 0;
-    REPEAT ch := x[i]; Write(R, ch); INC(i) UNTIL ch = 0X
-  END WriteString;
-
-  PROCEDURE WriteNum*(VAR R: Rider; x: INTEGER);
-  BEGIN
-    WHILE (x < -40H) OR (x >= 40H) DO WriteByte(R, x MOD 80H + 80H); x := ASR(x, 7) END ;
-    WriteByte(R, x MOD 80H)
-  END WriteNum;
-
-  (*---------------------------System use---------------------------*)
-
-  PROCEDURE Init*;
-  BEGIN root := 0; Kernel.Init; FileDir.Init
-  END Init;
-
-  PROCEDURE RestoreList*; (*after mark phase of garbage collection*)
-    VAR f, f0: INTEGER;
-
-    PROCEDURE mark(f: INTEGER): INTEGER;
-      VAR m: INTEGER;
-    BEGIN
-      IF f = 0 THEN m := -1 ELSE SYSTEM.GET(f-4, m) END ;
-      RETURN m
-    END mark;
-
-  BEGIN (*field "next" has offset 0*)
-    WHILE mark(root) = 0 DO SYSTEM.GET(root, root) END ;
-    f := root;
-    WHILE f # 0 DO
-      f0 := f;
-      REPEAT SYSTEM.GET(f0, f0) UNTIL mark(f0) # 0;
-      SYSTEM.PUT(f, f0); f := f0
-    END
-  END RestoreList;
-
+MODULE Files;  (*NW 11.1.86 / 22.9.93 / 25.5.95 / 25.12.95 / 15.8.2013*)
+  IMPORT SYSTEM, Kernel, FileDir;
+
+  (*A file consists of a sequence of pages. The first page
+    contains the header. Part of the header is the page table, an array
+    of disk addresses to the pages. A file is referenced through riders.
+    A rider indicates a current position and refers to a file*)
+
+  CONST MaxBufs    = 4;
+      HS        = FileDir.HeaderSize;
+      SS        = FileDir.SectorSize;
+      STS       = FileDir.SecTabSize;
+      XS        = FileDir.IndexSize;
+
+  TYPE  DiskAdr = INTEGER;
+      File*    = POINTER TO FileDesc;
+      Buffer  = POINTER TO BufferRecord;
+      Index   = POINTER TO IndexRecord;
+
+    Rider* =
+      RECORD eof*: BOOLEAN;
+        res*: INTEGER;
+        file: File;
+        apos, bpos: INTEGER;
+        buf: Buffer
+      END ;
+
+    FileDesc =
+      RECORD next: INTEGER; (*list of files invisible to the GC*)
+        nofbufs, aleng, bleng: INTEGER;
+        modH, registered: BOOLEAN;
+        firstbuf: Buffer;
+        sechint: DiskAdr;
+        name: FileDir.FileName;
+        date: INTEGER;
+        ext:  ARRAY FileDir.ExTabSize OF Index;
+        sec: FileDir.SectorTable
+      END ;
+
+    BufferRecord =
+      RECORD apos, lim: INTEGER;
+        mod: BOOLEAN;
+        next: Buffer;
+        data: FileDir.DataSector
+      END ;
+
+    IndexRecord =
+      RECORD adr: DiskAdr;
+        mod: BOOLEAN;
+        sec: FileDir.IndexSector
+      END ;
+
+    (*aleng * SS + bleng = length (including header)
+      apos * SS + bpos = current position
+      0 <= bpos <= lim <= SS
+      0 <= apos <= aleng < PgTabSize
+      (apos < aleng) & (lim = SS) OR (apos = aleng) *)
+
+  VAR root: INTEGER (*File*);  (*list of open files*)
+
+  PROCEDURE Check(s: ARRAY OF CHAR;
+        VAR name: FileDir.FileName; VAR res: INTEGER);
+    VAR i: INTEGER; ch: CHAR;
+  BEGIN ch := s[0]; i := 0;
+    IF (ch >= "A") & (ch <= "Z") OR (ch >= "a") & (ch <= "z") THEN
+      REPEAT name[i] := ch; INC(i); ch := s[i]
+      UNTIL ~((ch >= "0") & (ch <= "9") OR (ch >= "A") & (ch <= "Z")
+        OR (ch >= "a") & (ch <= "z") OR (ch = ".")) OR (i = FileDir.FnLength);
+      IF i = FileDir.FnLength THEN res := 4
+      ELSIF ch = 0X THEN res := 0;
+        WHILE i < FileDir.FnLength DO name[i] := 0X; INC(i) END
+      ELSE res := 5
+      END
+    ELSIF ch = 0X THEN name[0] := 0X; res := -1
+    ELSE res := 3
+    END
+  END Check;
+
+  PROCEDURE Old*(name: ARRAY OF CHAR): File;
+    VAR i, k, res: INTEGER;
+      f: File;
+      header: DiskAdr;
+      buf: Buffer;
+      F: FileDir.FileHd;
+      namebuf: FileDir.FileName;
+      inxpg: Index;
+  BEGIN f := NIL; Check(name, namebuf, res);
+    IF res = 0 THEN
+      FileDir.Search(namebuf, header);
+      IF header # 0 THEN
+        f := SYSTEM.VAL(File, root);
+        WHILE (f # NIL) & (f.sec[0] # header) DO f := SYSTEM.VAL(File, f.next) END ;
+        IF f = NIL THEN (*file not yet present*)
+          NEW(buf); buf.apos := 0; buf.next := buf; buf.mod := FALSE;
+          F := SYSTEM.VAL(FileDir.FileHd, SYSTEM.ADR(buf.data));
+          Kernel.GetSector(header, buf.data); ASSERT(F.mark = FileDir.HeaderMark);
+          NEW(f); f.aleng := F.aleng; f.bleng := F.bleng; f.date := F.date;
+          IF f.aleng = 0 THEN buf.lim := f.bleng ELSE buf.lim := SS END ;
+          f.firstbuf := buf; f.nofbufs := 1; f.name := namebuf; f.registered := TRUE;
+          f.sec := F.sec;
+          k := (f.aleng + (XS-STS)) DIV XS; i := 0;
+          WHILE i < k DO
+            NEW(inxpg); inxpg.adr := F.ext[i]; inxpg.mod := FALSE;
+            Kernel.GetSector(inxpg.adr, inxpg.sec); f.ext[i] := inxpg; INC(i)
+          END ;
+          WHILE i < FileDir.ExTabSize DO f.ext[i] := NIL; INC(i) END ;
+          f.sechint := header; f.modH := FALSE; f.next := root; root := SYSTEM.VAL(INTEGER, f)
+        END
+      END
+    END ;
+    RETURN f
+  END Old;
+
+  PROCEDURE New*(name: ARRAY OF CHAR): File;
+    VAR i, res: INTEGER;
+      f: File;
+      buf: Buffer;
+      F: FileDir.FileHd;
+      namebuf: FileDir.FileName;
+  BEGIN f := NIL; Check(name, namebuf, res);
+    IF res <= 0 THEN
+      NEW(buf); buf.apos := 0; buf.mod := TRUE; buf.lim := HS; buf.next := buf;
+      F := SYSTEM.VAL(FileDir.FileHd, SYSTEM.ADR(buf.data));
+      F.mark := FileDir.HeaderMark;
+      F.aleng := 0; F.bleng := HS; F.name := namebuf;
+      F.date := Kernel.Clock();
+      NEW(f); f.aleng := 0; f.bleng := HS; f.modH := TRUE;
+      f.registered := FALSE; f.date := F.date;
+      f.firstbuf := buf; f.nofbufs := 1; f.name := namebuf; f.sechint := 0;
+      i := 0;
+      REPEAT f.ext[i] := NIL; F.ext[i] := 0; INC(i) UNTIL i = FileDir.ExTabSize;
+      i := 0;
+      REPEAT f.sec[i] := 0; F.sec[i] := 0; INC(i) UNTIL i = STS
+    END ;
+    RETURN f
+  END New;
+
+  PROCEDURE UpdateHeader(f: File; VAR F: FileDir.FileHeader);
+    VAR k: INTEGER;
+  BEGIN F.aleng := f.aleng; F.bleng := f.bleng;
+    F.sec := f.sec; k := (f.aleng + (XS-STS)) DIV XS;
+    WHILE k > 0 DO DEC(k); F.ext[k] := f.ext[k].adr END
+  END UpdateHeader;
+
+  PROCEDURE ReadBuf(f: File; buf: Buffer; pos: INTEGER);
+    VAR sec: DiskAdr;
+  BEGIN
+    IF pos < STS THEN sec := f.sec[pos]
+    ELSE sec := f.ext[(pos-STS) DIV XS].sec[(pos-STS) MOD XS]
+    END ;
+    Kernel.GetSector(sec, buf.data);
+    IF pos < f.aleng THEN buf.lim := SS ELSE buf.lim := f.bleng END ;
+    buf.apos := pos; buf.mod := FALSE
+  END ReadBuf;
+
+  PROCEDURE WriteBuf(f: File; buf: Buffer);
+    VAR i, k: INTEGER;
+      secadr: DiskAdr; inx: Index;
+  BEGIN 
+    IF buf.apos < STS THEN
+      secadr := f.sec[buf.apos];
+      IF secadr = 0 THEN
+        Kernel.AllocSector(f.sechint, secadr);
+        f.modH := TRUE; f.sec[buf.apos] := secadr; f.sechint := secadr
+      END ;
+      IF buf.apos = 0 THEN
+        UpdateHeader(f, SYSTEM.VAL(FileDir.FileHeader, buf.data)); f.modH := FALSE
+      END
+    ELSE i := (buf.apos - STS) DIV XS; inx := f.ext[i];
+      IF inx = NIL THEN
+        NEW(inx); inx.adr := 0; inx.sec[0] := 0; f.ext[i] := inx; f.modH := TRUE
+      END ;
+      k := (buf.apos - STS) MOD XS; secadr := inx.sec[k];
+      IF secadr = 0 THEN
+        Kernel.AllocSector(f.sechint, secadr);
+        f.modH := TRUE; inx.mod := TRUE; inx.sec[k] := secadr; f.sechint := secadr
+      END
+    END ;
+    Kernel.PutSector(secadr, buf.data); buf.mod := FALSE
+  END WriteBuf;
+
+  PROCEDURE Buf(f: File; pos: INTEGER): Buffer;
+    VAR buf: Buffer;
+  BEGIN buf := f.firstbuf;
+    WHILE (buf.apos # pos) & (buf.next # f.firstbuf) DO buf := buf.next END ;
+    IF buf.apos # pos THEN buf := NIL END ;
+    RETURN buf
+  END Buf;
+
+  PROCEDURE GetBuf(f: File; pos: INTEGER): Buffer;
+    VAR buf: Buffer;
+  BEGIN buf := f.firstbuf;
+    WHILE (buf.apos # pos) & (buf.next # f.firstbuf) DO buf := buf.next END ;
+    IF buf.apos # pos THEN 
+      IF f.nofbufs < MaxBufs THEN  (*allocate new buffer*)
+        NEW(buf); buf.next := f.firstbuf.next; f.firstbuf.next := buf; INC(f.nofbufs)
+      ELSE (*reuse a buffer*) f.firstbuf := buf;
+        IF buf.mod THEN WriteBuf(f, buf) END
+      END ;
+      IF pos <= f.aleng THEN ReadBuf(f, buf, pos) ELSE buf.apos := pos; buf.lim := 0; buf.mod := FALSE END
+    END ;
+    RETURN buf
+  END GetBuf;
+
+  PROCEDURE Unbuffer(f: File);
+    VAR i, k: INTEGER;
+      buf: Buffer;
+      inx: Index;
+      head: FileDir.FileHeader;
+  BEGIN buf := f.firstbuf;
+    REPEAT
+      IF buf.mod THEN WriteBuf(f, buf) END ;
+      buf := buf.next
+    UNTIL buf = f.firstbuf;
+    k := (f.aleng + (XS-STS)) DIV XS; i := 0;
+    WHILE i < k DO
+      inx := f.ext[i]; INC(i);
+      IF inx.mod THEN
+        IF inx.adr = 0 THEN
+          Kernel.AllocSector(f.sechint, inx.adr); f.sechint := inx.adr; f.modH := TRUE
+        END ;
+        Kernel.PutSector(inx.adr, inx.sec); inx.mod := FALSE
+      END
+    END ;
+    IF f.modH THEN
+      Kernel.GetSector(f.sec[0], head); UpdateHeader(f, head);
+      Kernel.PutSector(f.sec[0], head); f.modH := FALSE
+    END
+  END Unbuffer;
+
+  PROCEDURE Register*(f: File);
+  BEGIN
+    IF (f # NIL) & (f.name[0] # 0X) THEN
+      Unbuffer(f);
+      IF ~f.registered THEN
+        FileDir.Insert(f.name, f.sec[0]); f.registered := TRUE; f.next := root; root := SYSTEM.VAL(INTEGER, f)
+      END
+    END
+  END Register;
+
+  PROCEDURE Close*(f: File);
+  BEGIN
+    IF f # NIL THEN Unbuffer(f) END
+  END Close;
+
+  PROCEDURE Purge*(f: File);
+    VAR a, i, j, k: INTEGER;
+      ind: FileDir.IndexSector;
+  BEGIN
+    IF f # NIL THEN a := f.aleng + 1; f.aleng := 0; f.bleng := HS;
+      IF a <= STS THEN i := a;
+      ELSE i := STS; DEC(a, i); j := (a-1) MOD XS; k := (a-1) DIV XS;
+        WHILE k >= 0 DO
+          Kernel.GetSector(f.ext[k].adr, ind);
+          REPEAT DEC(j); Kernel.FreeSector(ind[j]) UNTIL j = 0;
+          Kernel.FreeSector(f.ext[k].adr); j := XS; DEC(k)
+        END
+      END ;
+      REPEAT DEC(i); Kernel.FreeSector(f.sec[i]) UNTIL i = 0
+    END
+  END Purge;
+
+  PROCEDURE Delete*(name: ARRAY OF CHAR; VAR res: INTEGER);
+    VAR adr: DiskAdr;
+        namebuf: FileDir.FileName;
+  BEGIN Check(name, namebuf, res);
+    IF res = 0 THEN
+      FileDir.Delete(namebuf, adr);
+      IF adr = 0 THEN res := 2 END
+    END
+  END Delete;
+
+  PROCEDURE Rename*(old, new: ARRAY OF CHAR; VAR res: INTEGER);
+    VAR adr: DiskAdr;
+        oldbuf, newbuf: FileDir.FileName;
+        head: FileDir.FileHeader;
+  BEGIN Check(old, oldbuf, res);
+    IF res = 0 THEN
+      Check(new, newbuf, res);
+      IF res = 0 THEN
+        FileDir.Delete(oldbuf, adr);
+        IF adr # 0 THEN
+          FileDir.Insert(newbuf, adr);
+          Kernel.GetSector(adr, head); head.name := newbuf; Kernel.PutSector(adr, head)
+        ELSE res := 2
+        END
+      END
+    END
+  END Rename;
+
+  PROCEDURE Length*(f: File): INTEGER;
+  BEGIN RETURN f.aleng * SS + f.bleng - HS
+  END Length;
+
+  PROCEDURE Date*(f: File): INTEGER;
+  BEGIN RETURN f.date
+  END Date;
+
+  (*---------------------------Read---------------------------*)
+
+  PROCEDURE Set*(VAR r: Rider; f: File; pos: INTEGER);
+    VAR a, b: INTEGER;
+  BEGIN  r.eof := FALSE; r.res := 0;
+    IF f # NIL THEN
+      IF pos < 0 THEN a := 0; b := HS
+      ELSIF pos < f.aleng * SS + f.bleng - HS THEN
+        a := (pos + HS) DIV SS; b := (pos + HS) MOD SS;
+      ELSE a := f.aleng; b := f.bleng
+      END ;
+      r.file := f; r.apos := a; r.bpos := b; r.buf := f.firstbuf
+    ELSE r.file:= NIL
+    END
+  END Set;
+
+  PROCEDURE Pos*(VAR r: Rider): INTEGER;
+  BEGIN RETURN r.apos * SS + r.bpos - HS
+  END Pos;
+
+  PROCEDURE Base*(VAR r: Rider): File;
+  BEGIN RETURN r.file
+  END Base;
+
+  PROCEDURE ReadByte*(VAR r: Rider; VAR x: BYTE);
+    VAR buf: Buffer;
+  BEGIN
+    IF r.apos # r.buf.apos THEN r.buf := GetBuf(r.file, r.apos) END ;
+    IF r.bpos < r.buf.lim THEN x := r.buf.data[r.bpos]; INC(r.bpos)
+    ELSIF r.apos < r.file.aleng THEN
+      INC(r.apos); buf := Buf(r.file, r.apos);
+      IF buf = NIL THEN
+        IF r.buf.mod THEN WriteBuf(r.file, r.buf) END ;
+        ReadBuf(r.file, r.buf, r.apos)
+      ELSE r.buf := buf
+      END ;
+      x := r.buf.data[0]; r.bpos := 1
+    ELSE x := 0; r.eof := TRUE
+    END
+  END ReadByte;
+
+  PROCEDURE ReadBytes*(VAR r: Rider; VAR x: ARRAY OF BYTE; n: INTEGER);
+    VAR i: INTEGER;
+  BEGIN i := 0;  (*this implementation is to be improved*)
+    WHILE i < n DO ReadByte(r, x[i]); INC(i) END
+  END ReadBytes;
+
+  PROCEDURE Read*(VAR r: Rider; VAR ch: CHAR);
+    VAR buf: Buffer;  (*same as ReadByte*)
+  BEGIN
+    IF r.apos # r.buf.apos THEN r.buf := GetBuf(r.file, r.apos) END ;
+    IF r.bpos < r.buf.lim THEN ch := CHR(r.buf.data[r.bpos]); INC(r.bpos)
+    ELSIF r.apos < r.file.aleng THEN
+      INC(r.apos); buf := Buf(r.file, r.apos);
+      IF buf = NIL THEN
+        IF r.buf.mod THEN WriteBuf(r.file, r.buf) END ;
+        ReadBuf(r.file, r.buf, r.apos)
+      ELSE r.buf := buf
+      END ;
+      ch := CHR(r.buf.data[0]); r.bpos := 1
+    ELSE ch := 0X; r.eof := TRUE
+    END
+  END Read;
+
+  PROCEDURE ReadInt*(VAR R: Rider; VAR x: INTEGER);
+    VAR x0, x1, x2, x3: BYTE;
+  BEGIN ReadByte(R, x0); ReadByte(R, x1); ReadByte(R, x2); ReadByte(R, x3);
+    x := ((x3 * 100H + x2) * 100H + x1) * 100H + x0
+  END ReadInt;
+
+  PROCEDURE ReadSet*(VAR R: Rider; VAR s: SET);
+    VAR n: INTEGER;
+  BEGIN ReadInt(R, SYSTEM.VAL(INTEGER, s))
+  END ReadSet;
+
+  PROCEDURE ReadReal*(VAR R: Rider; VAR x: REAL);
+    VAR n: INTEGER;
+  BEGIN ReadInt(R, SYSTEM.VAL(INTEGER, x))
+  END ReadReal;
+
+  PROCEDURE ReadString*(VAR R: Rider; VAR x: ARRAY OF CHAR);
+    VAR i: INTEGER; ch: CHAR;
+  BEGIN i := 0; Read(R, ch);
+    WHILE ch # 0X DO
+      IF i < LEN(x)-1 THEN x[i] := ch; INC(i) END ;
+      Read(R, ch)
+    END ;
+    x[i] := 0X
+  END ReadString;
+
+  PROCEDURE ReadNum*(VAR R: Rider; VAR x: INTEGER);
+    VAR n, y: INTEGER; b: BYTE;
+  BEGIN n := 32; y := 0; ReadByte(R, b);
+    WHILE b >= 80H DO y := ROR(y + b-80H, 7); DEC(n, 7); ReadByte(R, b) END ;
+    IF n <= 4 THEN x := ROR(y + b MOD 10H, 4) ELSE x := ASR(ROR(y + b, 7), n-7) END
+  END ReadNum;
+        
+  (*---------------------------Write---------------------------*)
+
+  PROCEDURE NewExt(f: File);
+    VAR i, k: INTEGER; ext: Index;
+  BEGIN k := (f.aleng - STS) DIV XS;
+    NEW(ext); ext.adr := 0; ext.mod := TRUE; f.ext[k] := ext; i := XS;
+    REPEAT DEC(i); ext.sec[i] := 0 UNTIL i = 0
+  END NewExt;
+
+  PROCEDURE WriteByte*(VAR r: Rider; x: BYTE);
+    VAR f: File; buf: Buffer;
+  BEGIN
+    IF r.apos # r.buf.apos THEN r.buf := GetBuf(r.file, r.apos); END ;
+    IF r.bpos >= r.buf.lim THEN
+      IF r.bpos < SS THEN
+        INC(r.buf.lim); INC(r.file.bleng); r.file.modH := TRUE
+      ELSE f := r.file; WriteBuf(f, r.buf); INC(r.apos); buf := Buf(r.file, r.apos);
+        IF buf = NIL THEN
+          IF r.apos <= f.aleng THEN ReadBuf(f, r.buf, r.apos)
+          ELSE r.buf.apos := r.apos; r.buf.lim := 1; f.aleng := f.aleng + 1; f.bleng := 1; f.modH := TRUE;
+            IF (f.aleng - STS) MOD XS = 0 THEN NewExt(f) END
+          END
+        ELSE r.buf := buf
+        END ;
+        r.bpos := 0
+      END
+    END ;
+    r.buf.data[r.bpos] := x; INC(r.bpos); r.buf.mod := TRUE
+  END WriteByte;
+
+  PROCEDURE WriteBytes*(VAR r: Rider; x: ARRAY OF BYTE; n: INTEGER);
+    VAR i: INTEGER;
+  BEGIN i := 0; (*this implementation is to be improed*)
+    WHILE i < n DO WriteByte(r, x[i]); INC(i) END
+  END WriteBytes;
+
+  PROCEDURE Write*(VAR r: Rider; ch: CHAR);
+    VAR f: File; buf: Buffer;
+  BEGIN (*same as WriteByte*)
+    IF r.apos # r.buf.apos THEN r.buf := GetBuf(r.file, r.apos); END ;
+    IF r.bpos >= r.buf.lim THEN
+      IF r.bpos < SS THEN
+        INC(r.buf.lim); INC(r.file.bleng); r.file.modH := TRUE
+      ELSE f := r.file; WriteBuf(f, r.buf); INC(r.apos); buf := Buf(r.file, r.apos);
+        IF buf = NIL THEN
+          IF r.apos <= f.aleng THEN ReadBuf(f, r.buf, r.apos)
+          ELSE r.buf.apos := r.apos; r.buf.lim := 1; f.aleng := f.aleng + 1; f.bleng := 1; f.modH := TRUE;
+            IF (f.aleng - STS) MOD XS = 0 THEN NewExt(f) END
+          END
+        ELSE r.buf := buf
+        END ;
+        r.bpos := 0
+      END
+    END ;
+    r.buf.data[r.bpos] := ORD(ch); INC(r.bpos); r.buf.mod := TRUE
+  END Write;
+
+  PROCEDURE WriteInt*(VAR R: Rider; x: INTEGER);
+  BEGIN WriteByte(R, x MOD 100H);
+    WriteByte(R, x DIV 100H MOD 100H);
+    WriteByte(R, x DIV 10000H MOD 100H);
+    WriteByte(R, x DIV 1000000H MOD 100H)
+  END WriteInt;
+
+  PROCEDURE WriteSet*(VAR R: Rider; s: SET);
+  BEGIN WriteInt(R, ORD(s))
+  END WriteSet;
+
+  PROCEDURE WriteReal*(VAR R: Rider; x: REAL);
+  BEGIN  WriteInt(R, ORD(x))
+  END WriteReal;
+
+  PROCEDURE WriteString*(VAR R: Rider; x: ARRAY OF CHAR);
+    VAR i: INTEGER; ch: CHAR;
+  BEGIN i := 0;
+    REPEAT ch := x[i]; Write(R, ch); INC(i) UNTIL ch = 0X
+  END WriteString;
+
+  PROCEDURE WriteNum*(VAR R: Rider; x: INTEGER);
+  BEGIN
+    WHILE (x < -40H) OR (x >= 40H) DO WriteByte(R, x MOD 80H + 80H); x := ASR(x, 7) END ;
+    WriteByte(R, x MOD 80H)
+  END WriteNum;
+
+  (*---------------------------System use---------------------------*)
+
+  PROCEDURE Init*;
+  BEGIN root := 0; Kernel.Init; FileDir.Init
+  END Init;
+
+  PROCEDURE RestoreList*; (*after mark phase of garbage collection*)
+    VAR f, f0: INTEGER;
+
+    PROCEDURE mark(f: INTEGER): INTEGER;
+      VAR m: INTEGER;
+    BEGIN
+      IF f = 0 THEN m := -1 ELSE SYSTEM.GET(f-4, m) END ;
+      RETURN m
+    END mark;
+
+  BEGIN (*field "next" has offset 0*)
+    WHILE mark(root) = 0 DO SYSTEM.GET(root, root) END ;
+    f := root;
+    WHILE f # 0 DO
+      f0 := f;
+      REPEAT SYSTEM.GET(f0, f0) UNTIL mark(f0) # 0;
+      SYSTEM.PUT(f, f0); f := f0
+    END
+  END RestoreList;
+
 END Files.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Fonts.Mod.txt

@@ -1,109 +1,109 @@
-MODULE Fonts; (*JG 18.11.90; PDR 8.6.12; NW 18.1.2019*)
-  IMPORT SYSTEM, Files;
-
-  CONST FontFileId = 0DBH;
-
-  TYPE Font* = POINTER TO FontDesc;
-    FontDesc* = RECORD
-      name*: ARRAY 32 OF CHAR;
-      height*, minX*, maxX*, minY*, maxY*: INTEGER;
-      next*: Font;
-      T: ARRAY 128 OF INTEGER;
-      raster: ARRAY 2360 OF BYTE
-    END ;
-
-    LargeFontDesc = RECORD (FontDesc) ext: ARRAY 2560 OF BYTE END ;
-    LargeFont = POINTER TO LargeFontDesc;
-    RunRec = RECORD beg, end: BYTE END ;
-    BoxRec = RECORD dx, x, y, w, h: BYTE END ;
-    
-  (* raster sizes: Syntax8 1367, Syntax10 1628, Syntax12 1688, Syntax14 1843, Syntax14b 1983,
-      Syntax16 2271, Syntax20 3034, Syntac24 4274, Syntax24b 4302  *)
-
-VAR Default*, root*: Font;
-
-PROCEDURE GetPat*(fnt: Font; ch: CHAR; VAR dx, x, y, w, h, patadr: INTEGER);
-  VAR pa: INTEGER;  dxb, xb, yb, wb, hb: BYTE;
-BEGIN pa := fnt.T[ORD(ch) MOD 80H]; patadr := pa;
-  SYSTEM.GET(pa-3, dxb); SYSTEM.GET(pa-2, xb); SYSTEM.GET(pa-1, yb); SYSTEM.GET(pa, wb); SYSTEM.GET(pa+1, hb);
-  dx := dxb; x := xb; y := yb; w := wb; h := hb;
-  IF yb < 128 THEN y := yb ELSE y := yb - 256 END
-END GetPat;
-
-PROCEDURE This*(name: ARRAY OF CHAR): Font;
-  VAR F: Font; LF: LargeFont;
-    f: Files.File; R: Files.Rider;
-    NofRuns, NofBoxes: BYTE;
-    NofBytes: INTEGER;
-    height, minX, maxX, minY, maxY: BYTE;
-    i, j, k, m, n: INTEGER;
-    a, a0: INTEGER;
-    b, beg, end: BYTE;
-    run: ARRAY 16 OF RunRec;
-    box: ARRAY 512 OF BoxRec;
-
-  PROCEDURE RdInt16(VAR R: Files.Rider; VAR b0: BYTE);
-    VAR b1: BYTE;
-  BEGIN Files.ReadByte(R, b0); Files.ReadByte(R, b1)
-  END RdInt16;
-
-BEGIN F := root;
-  WHILE (F # NIL) & (name # F.name) DO F := F.next END;
-  IF F = NIL THEN
-    f := Files.Old(name);
-    IF f # NIL THEN
-      Files.Set(R, f, 0); Files.ReadByte(R, b);
-      IF b = FontFileId THEN
-        Files.ReadByte(R, b); (*abstraction*)
-        Files.ReadByte(R, b); (*family*)
-        Files.ReadByte(R, b); (*variant*)
-        RdInt16(R, height); RdInt16(R, minX); RdInt16(R, maxX); RdInt16(R, minY); RdInt16(R, maxY); RdInt16(R, NofRuns);
-        NofBoxes := 0; k := 0;
-        WHILE k # NofRuns DO
-          RdInt16(R, beg);
-          run[k].beg := beg; RdInt16(R, end);
-          run[k].end := end; NofBoxes := NofBoxes + end - beg; INC(k)
-        END;
-        NofBytes := 5; j := 0;
-        WHILE j # NofBoxes DO
-          RdInt16(R, box[j].dx); RdInt16(R, box[j].x); RdInt16(R, box[j].y);
-          RdInt16(R, box[j].w); RdInt16(R, box[j].h);
-          NofBytes := NofBytes + 5 + (box[j].w + 7) DIV 8 * box[j].h;
-          INC(j)
-        END;
-        IF NofBytes < 2300 THEN NEW(F) ELSE NEW(LF); F := LF END ;
-        F.name := name;
-        F.height := height; F.minX := minX; F.maxX := maxX; F.maxY := maxY;
-        IF minY >= 80H THEN F.minY := minY - 100H ELSE F.minY := minY END ;
-        a0 := SYSTEM.ADR(F.raster);
-        SYSTEM.PUT(a0, 0X); SYSTEM.PUT(a0+1, 0X); SYSTEM.PUT(a0+2, 0X); SYSTEM.PUT(a0+3, 0X); SYSTEM.PUT(a0+4, 0X);
-        (*null pattern for characters not in a run*)
-        INC(a0, 3); a := a0+2; j := 0; k := 0; m := 0;
-        WHILE k < NofRuns DO
-          WHILE (m < run[k].beg) & (m < 128) DO F.T[m] := a0; INC(m) END;
-          WHILE (m < run[k].end) & (m < 128) DO
-            F.T[m] := a+3;
-            SYSTEM.PUT(a, box[j].dx); SYSTEM.PUT(a+1, box[j].x); SYSTEM.PUT(a+2, box[j].y);
-            SYSTEM.PUT(a+3, box[j].w); SYSTEM.PUT(a+4, box[j].h); INC(a, 5);
-            n := (box[j].w + 7) DIV 8 * box[j].h;
-            WHILE n # 0 DO DEC(n); Files.ReadByte(R, b); SYSTEM.PUT(a, b); INC(a) END ;
-            INC(j); INC(m)
-          END;
-          INC(k)
-        END;
-        WHILE m < 128 DO F.T[m] := a0; INC(m) END ;
-        F.next := root; root := F
-      ELSE (*bad file id*) F := Default
-      END
-    ELSE (*font file not available*) F := Default
-    END
-  END;
-  RETURN F
-END This;
-
-PROCEDURE Free*;  (*remove all but first two from font list*)
-BEGIN IF root.next # NIL THEN root.next.next := NIL END
-END Free;
-
-BEGIN root := NIL; Default := This("Oberon10.Scn.Fnt")
-END Fonts.
+MODULE Fonts; (*JG 18.11.90; PDR 8.6.12; NW 18.1.2019*)
+  IMPORT SYSTEM, Files;
+
+  CONST FontFileId = 0DBH;
+
+  TYPE Font* = POINTER TO FontDesc;
+    FontDesc* = RECORD
+      name*: ARRAY 32 OF CHAR;
+      height*, minX*, maxX*, minY*, maxY*: INTEGER;
+      next*: Font;
+      T: ARRAY 128 OF INTEGER;
+      raster: ARRAY 2360 OF BYTE
+    END ;
+
+    LargeFontDesc = RECORD (FontDesc) ext: ARRAY 2560 OF BYTE END ;
+    LargeFont = POINTER TO LargeFontDesc;
+    RunRec = RECORD beg, end: BYTE END ;
+    BoxRec = RECORD dx, x, y, w, h: BYTE END ;
+    
+  (* raster sizes: Syntax8 1367, Syntax10 1628, Syntax12 1688, Syntax14 1843, Syntax14b 1983,
+      Syntax16 2271, Syntax20 3034, Syntac24 4274, Syntax24b 4302  *)
+
+VAR Default*, root*: Font;
+
+PROCEDURE GetPat*(fnt: Font; ch: CHAR; VAR dx, x, y, w, h, patadr: INTEGER);
+  VAR pa: INTEGER;  dxb, xb, yb, wb, hb: BYTE;
+BEGIN pa := fnt.T[ORD(ch) MOD 80H]; patadr := pa;
+  SYSTEM.GET(pa-3, dxb); SYSTEM.GET(pa-2, xb); SYSTEM.GET(pa-1, yb); SYSTEM.GET(pa, wb); SYSTEM.GET(pa+1, hb);
+  dx := dxb; x := xb; y := yb; w := wb; h := hb;
+  IF yb < 128 THEN y := yb ELSE y := yb - 256 END
+END GetPat;
+
+PROCEDURE This*(name: ARRAY OF CHAR): Font;
+  VAR F: Font; LF: LargeFont;
+    f: Files.File; R: Files.Rider;
+    NofRuns, NofBoxes: BYTE;
+    NofBytes: INTEGER;
+    height, minX, maxX, minY, maxY: BYTE;
+    i, j, k, m, n: INTEGER;
+    a, a0: INTEGER;
+    b, beg, end: BYTE;
+    run: ARRAY 16 OF RunRec;
+    box: ARRAY 512 OF BoxRec;
+
+  PROCEDURE RdInt16(VAR R: Files.Rider; VAR b0: BYTE);
+    VAR b1: BYTE;
+  BEGIN Files.ReadByte(R, b0); Files.ReadByte(R, b1)
+  END RdInt16;
+
+BEGIN F := root;
+  WHILE (F # NIL) & (name # F.name) DO F := F.next END;
+  IF F = NIL THEN
+    f := Files.Old(name);
+    IF f # NIL THEN
+      Files.Set(R, f, 0); Files.ReadByte(R, b);
+      IF b = FontFileId THEN
+        Files.ReadByte(R, b); (*abstraction*)
+        Files.ReadByte(R, b); (*family*)
+        Files.ReadByte(R, b); (*variant*)
+        RdInt16(R, height); RdInt16(R, minX); RdInt16(R, maxX); RdInt16(R, minY); RdInt16(R, maxY); RdInt16(R, NofRuns);
+        NofBoxes := 0; k := 0;
+        WHILE k # NofRuns DO
+          RdInt16(R, beg);
+          run[k].beg := beg; RdInt16(R, end);
+          run[k].end := end; NofBoxes := NofBoxes + end - beg; INC(k)
+        END;
+        NofBytes := 5; j := 0;
+        WHILE j # NofBoxes DO
+          RdInt16(R, box[j].dx); RdInt16(R, box[j].x); RdInt16(R, box[j].y);
+          RdInt16(R, box[j].w); RdInt16(R, box[j].h);
+          NofBytes := NofBytes + 5 + (box[j].w + 7) DIV 8 * box[j].h;
+          INC(j)
+        END;
+        IF NofBytes < 2300 THEN NEW(F) ELSE NEW(LF); F := LF END ;
+        F.name := name;
+        F.height := height; F.minX := minX; F.maxX := maxX; F.maxY := maxY;
+        IF minY >= 80H THEN F.minY := minY - 100H ELSE F.minY := minY END ;
+        a0 := SYSTEM.ADR(F.raster);
+        SYSTEM.PUT(a0, 0X); SYSTEM.PUT(a0+1, 0X); SYSTEM.PUT(a0+2, 0X); SYSTEM.PUT(a0+3, 0X); SYSTEM.PUT(a0+4, 0X);
+        (*null pattern for characters not in a run*)
+        INC(a0, 3); a := a0+2; j := 0; k := 0; m := 0;
+        WHILE k < NofRuns DO
+          WHILE (m < run[k].beg) & (m < 128) DO F.T[m] := a0; INC(m) END;
+          WHILE (m < run[k].end) & (m < 128) DO
+            F.T[m] := a+3;
+            SYSTEM.PUT(a, box[j].dx); SYSTEM.PUT(a+1, box[j].x); SYSTEM.PUT(a+2, box[j].y);
+            SYSTEM.PUT(a+3, box[j].w); SYSTEM.PUT(a+4, box[j].h); INC(a, 5);
+            n := (box[j].w + 7) DIV 8 * box[j].h;
+            WHILE n # 0 DO DEC(n); Files.ReadByte(R, b); SYSTEM.PUT(a, b); INC(a) END ;
+            INC(j); INC(m)
+          END;
+          INC(k)
+        END;
+        WHILE m < 128 DO F.T[m] := a0; INC(m) END ;
+        F.next := root; root := F
+      ELSE (*bad file id*) F := Default
+      END
+    ELSE (*font file not available*) F := Default
+    END
+  END;
+  RETURN F
+END This;
+
+PROCEDURE Free*;  (*remove all but first two from font list*)
+BEGIN IF root.next # NIL THEN root.next.next := NIL END
+END Free;
+
+BEGIN root := NIL; Default := This("Oberon10.Scn.Fnt")
+END Fonts.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/GraphTool.Mod.txt

@@ -1,228 +1,228 @@
-MODULE GraphTool;  (*NW  8.8.2013*)
-  IMPORT Files, Texts, Oberon;
-
-  CONST Context = 0; Line = 1; Caption = 2; Macro = 3; Rectangles = 4;
-  VAR W: Texts.Writer;
-
-  PROCEDURE DecGraph*;
-    VAR ch: CHAR;
-      class, col, fno, cat, inx, libno: BYTE;
-      xy, wh: INTEGER;
-      name: ARRAY 32 OF CHAR;
-      F: Files.File; R: Files.Rider;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-      Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-      F := Files.Old(S.s);
-      IF F # NIL THEN
-        Files.Set(R, F, 0); Files.Read(R, ch);
-        IF ch = 0F8X THEN
-          Files.ReadByte(R, class);
-          WHILE ~R.eof & (class < 255) DO
-            Texts.WriteInt(W, class, 4);
-            IF class = Context THEN
-              Files.ReadByte(R, cat); Files.ReadByte(R, inx); Texts.WriteInt(W, cat, 4); Texts.WriteInt(W, inx, 4);
-              Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
-              IF cat = 2 THEN Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name) END
-            ELSE Files.ReadInt(R, xy);
-              Texts.WriteInt(W, xy * 10000H DIV 10000H, 5); Texts.WriteInt(W, xy DIV 10000H, 5);
-              Files.ReadInt(R, wh);
-              Texts.WriteInt(W, wh * 10000H DIV 10000H, 5); Texts.WriteInt(W, wh DIV 10000H, 5);
-              Files.ReadByte(R, col); Files.Read(R, ch); Texts.WriteInt(W, col, 5); Texts.Write(W, "|");
-              IF class = Line THEN
-              ELSIF class = Caption THEN
-                Files.ReadByte(R, fno);  Texts.WriteInt(W, fno, 5); Texts.Write(W, " ");
-                Files.ReadString(R, name); Texts.WriteString(W, name)
-              ELSIF class = Macro THEN
-                Files.ReadByte(R, libno); Files.ReadString(R, name);
-                Texts.WriteInt(W, libno, 4); Texts.Write(W, " "); Texts.WriteString(W, name)
-              ELSIF class = Rectangles THEN
-                Files.ReadByte(R, fno); Texts.WriteInt(W, fno, 4); Files.ReadByte(R, fno); Texts.WriteInt(W, fno, 4);
-                Files.ReadByte(R, fno); Texts.WriteInt(W, fno, 4)
-              ELSE Texts.WriteString(W, "other class ="); Texts.WriteInt(W, class, 4)
-              END
-            END ;
-            Texts.WriteLn(W); Files.ReadByte(R, class)
-          END
-        ELSE Texts.WriteString(W, " not a graphics file")
-        END
-      ELSE Texts.WriteString(W, " not found")
-      END ;
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END DecGraph;
-
-  PROCEDURE DecGraph1*;
-    VAR ch: CHAR;
-      class, col, fno, len, lw, vers, cat, inx, libno: BYTE;
-      xy, wh: INTEGER;
-      name: ARRAY 32 OF CHAR;
-      F: Files.File; R: Files.Rider;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-      Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-      F := Files.Old(S.s);
-      IF F # NIL THEN
-        Files.Set(R, F, 0); Files.Read(R, ch);
-        IF ch = 0FAX THEN
-          Files.ReadByte(R, class);
-          WHILE ~R.eof & (class < 255) DO
-            Texts.WriteInt(W, class, 4);
-            IF class = Context THEN
-              Files.ReadByte(R, cat); Files.ReadByte(R, inx); Texts.WriteInt(W, cat, 4); Texts.WriteInt(W, inx, 4);
-              Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
-              IF cat = 2 THEN Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name) END
-            ELSE Files.ReadInt(R, xy);
-              Texts.WriteInt(W, xy * 10000H DIV 10000H, 5); Texts.WriteInt(W, xy DIV 10000H, 5);
-              Files.ReadInt(R, wh);
-              Texts.WriteInt(W, wh * 10000H DIV 10000H, 5); Texts.WriteInt(W, wh DIV 10000H, 5);
-              Files.ReadByte(R, col); Texts.WriteInt(W, col, 5); Texts.Write(W, "|");
-              IF class = Line THEN
-              ELSIF class = Caption THEN
-                Files.ReadByte(R, fno);  Texts.WriteInt(W, fno, 5); Texts.Write(W, " ");
-                Files.ReadString(R, name); Texts.WriteString(W, name)
-              ELSIF class = Macro THEN
-                Files.ReadByte(R, libno); Files.ReadString(R, name);
-                Texts.WriteInt(W, libno, 4); Texts.Write(W, " "); Texts.WriteString(W, name)
-              ELSIF class = Rectangles THEN
-                Files.ReadByte(R, len); Texts.WriteInt(W, len, 4);
-                Files.ReadByte(R, lw); Texts.WriteInt(W, lw, 4);
-                Files.ReadByte(R, vers); Texts.WriteInt(W, vers, 4)
-              ELSE Texts.WriteString(W, "other class ="); Texts.WriteInt(W, class, 4)
-              END
-            END ;
-            Texts.WriteLn(W); Files.ReadByte(R, class)
-          END
-        ELSE Texts.WriteString(W, " not a graphics file")
-        END
-      ELSE Texts.WriteString(W, " not found")
-      END ;
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END DecGraph1;
-
-  PROCEDURE DecLibrary1*;
-    VAR ch: CHAR;
-      class, col, fno, cat, inx, libno, len, lnw, vers: BYTE;
-      xy, wh: INTEGER;
-      name: ARRAY 32 OF CHAR;
-      F: Files.File; R: Files.Rider;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-      Texts.WriteString(W, "decode library1 "); Texts.WriteString(W, S.s);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-      F := Files.Old(S.s);
-      IF F # NIL THEN
-        Files.Set(R, F, 0); Files.Read(R, ch);
-        IF ch = 0FBX THEN
-          Files.ReadByte(R, class);
-          WHILE (class < 255) & ~R.eof  DO
-            WHILE class < 255  DO
-              Texts.WriteInt(W, class, 4);
-              IF class = Context THEN
-                Files.ReadByte(R, cat); Files.ReadByte(R, inx); Texts.WriteInt(W, cat, 4); Texts.WriteInt(W, inx, 4);
-                Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
-                IF cat = 2 THEN Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name) END
-              ELSE Files.ReadInt(R, xy);
-                Texts.WriteInt(W, xy * 10000H DIV 10000H, 5); Texts.WriteInt(W, xy DIV 10000H, 5);
-                Files.ReadInt(R, wh);
-                Texts.WriteInt(W, wh * 10000H DIV 10000H, 5); Texts.WriteInt(W, wh DIV 10000H, 5);
-                Files.ReadByte(R, col); Texts.WriteInt(W, col, 5);
-                IF class = Line THEN
-                ELSIF class = Caption THEN
-                  Texts.Write(W, "|"); Files.ReadByte(R, fno);  Texts.WriteInt(W, fno, 5); Texts.Write(W, " ");
-                  Files.ReadString(R, name); Texts.WriteString(W, name)
-                ELSIF class = Rectangles THEN
-                  Texts.Write(W, "|"); Files.ReadByte(R, len); Texts.WriteInt(W, len, 4);
-                  Files.ReadByte(R, lnw); Texts.WriteInt(W, lnw, 4);
-                  Files.ReadByte(R, vers); Texts.WriteInt(W, vers, 4)
-                ELSE Texts.WriteString(W, "other class ="); Texts.WriteInt(W, class, 4)
-                END
-              END ;
-              Texts.WriteLn(W); Files.ReadByte(R, class)
-            END ;
-            (*end macro*) Texts.WriteString(W, "---");
-            Files.ReadInt(R, wh); Texts.WriteInt(W, wh MOD 10000H, 5); Texts.WriteInt(W, wh DIV 10000H, 5);
-            Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
-            Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Files.ReadByte(R, class)
-          END
-        ELSE Texts.WriteString(W, " not a graphics library")
-        END
-      ELSE Texts.WriteString(W, " not found")
-      END ;
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END DecLibrary1;
-
-  PROCEDURE ConvertFontname(VAR x: ARRAY OF CHAR);
-  BEGIN (* Syntax --> Oberon *)
-    IF (x[0] = "S") & (x[1] = "y") & (x[2] = "n") & (x[3] = "t") & (x[4] = "a") & (x[5] = "x") THEN
-      x[0] := "O"; x[1] := "b"; x[2] := "e"; x[3] := "r"; x[4] := "o"; x[5] := "n"
-    END
-  END ConvertFontname;
-
-  PROCEDURE ConvertLibrary*;
-    VAR ch: CHAR;
-      class, col, fno, cat, inx, libno, len, lnw, vers: BYTE;
-      xy, wh: INTEGER;
-      name: ARRAY 32 OF CHAR;
-      F, G: Files.File; R, Q: Files.Rider;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-      Texts.WriteString(W, "convert library "); Texts.WriteString(W, S.s);
-      F := Files.Old(S.s);
-      IF F # NIL THEN
-        Texts.Scan(S); G := Files.New(S.s);
-        Texts.WriteString(W, " => "); Texts.WriteString(W, S.s);
-        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-        Files.Set(R, F, 0); Files.Set(Q, G, 0); Files.Read(R, ch);
-        IF ch = 0FDX THEN
-          Files.Write(Q, 0FBX); Files.ReadByte(R, class);
-          WHILE (class < 255) & ~R.eof  DO
-            WHILE class < 255  DO
-              Files.WriteByte(Q, class);
-              IF class = Context THEN
-                Files.ReadByte(R, cat); Files.ReadByte(R, inx); Texts.WriteInt(W, cat, 4); Texts.WriteInt(W, inx, 4);
-                Files.WriteByte(Q, cat); Files.WriteByte(Q, inx);
-                Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
-                IF cat = 0 THEN (*font*) ConvertFontname(name) END ;
-                Files.WriteString(Q, name);
-                IF cat = 2 THEN (*class*) Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name); Files.WriteString(Q, name) END ;
-                Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-              ELSE Files.ReadInt(R, xy); Files.WriteInt(Q, xy); Files.ReadInt(R, wh); Files.WriteInt(Q, wh);
-                Files.ReadByte(R, col); Files.Read(R, ch); Files.WriteByte(Q, 1);
-                IF class = Line THEN
-                ELSIF class = Caption THEN
-                  Files.ReadByte(R, fno); Files.WriteByte(Q, fno); Files.ReadString(R, name); Files.WriteString(Q, name)
-                ELSIF class = Rectangles THEN
-                  Files.ReadByte(R, len); Files.WriteByte(Q, len); Files.ReadByte(R, len);
-                  Files.ReadByte(R, lnw); Files.WriteByte(Q, lnw);
-                  Files.ReadByte(R, vers); Files.WriteByte(Q, vers)
-                ELSE Texts.WriteString(W, "alien class "); Texts.WriteInt(W, class, 4)
-                END
-              END ;
-              Files.ReadByte(R, class)
-            END ;
-            Files.WriteByte(Q, 255); (*end macro*) Files.ReadInt(R, wh); Files.WriteInt(Q, wh);
-            Files.ReadString(R, name); Files.WriteString(Q, name);
-            Texts.WriteString(W, name); Texts.WriteInt(W, wh MOD 10000H, 4); Texts.WriteInt(W, wh DIV 10000H, 4);
-            Texts.WriteLn(W); Files.ReadByte(R, class)
-          END
-        ELSE Texts.WriteString(W, " not a graphics library")
-        END ;
-        Files.Register(G); Texts.WriteString(W, " done")
-      ELSE Texts.WriteString(W, " not found")
-      END ;
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END ConvertLibrary;
-
-BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "GraphTool 8.8.2013");
-  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-END GraphTool.
+MODULE GraphTool;  (*NW  8.8.2013*)
+  IMPORT Files, Texts, Oberon;
+
+  CONST Context = 0; Line = 1; Caption = 2; Macro = 3; Rectangles = 4;
+  VAR W: Texts.Writer;
+
+  PROCEDURE DecGraph*;
+    VAR ch: CHAR;
+      class, col, fno, cat, inx, libno: BYTE;
+      xy, wh: INTEGER;
+      name: ARRAY 32 OF CHAR;
+      F: Files.File; R: Files.Rider;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+      Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+      F := Files.Old(S.s);
+      IF F # NIL THEN
+        Files.Set(R, F, 0); Files.Read(R, ch);
+        IF ch = 0F8X THEN
+          Files.ReadByte(R, class);
+          WHILE ~R.eof & (class < 255) DO
+            Texts.WriteInt(W, class, 4);
+            IF class = Context THEN
+              Files.ReadByte(R, cat); Files.ReadByte(R, inx); Texts.WriteInt(W, cat, 4); Texts.WriteInt(W, inx, 4);
+              Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
+              IF cat = 2 THEN Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name) END
+            ELSE Files.ReadInt(R, xy);
+              Texts.WriteInt(W, xy * 10000H DIV 10000H, 5); Texts.WriteInt(W, xy DIV 10000H, 5);
+              Files.ReadInt(R, wh);
+              Texts.WriteInt(W, wh * 10000H DIV 10000H, 5); Texts.WriteInt(W, wh DIV 10000H, 5);
+              Files.ReadByte(R, col); Files.Read(R, ch); Texts.WriteInt(W, col, 5); Texts.Write(W, "|");
+              IF class = Line THEN
+              ELSIF class = Caption THEN
+                Files.ReadByte(R, fno);  Texts.WriteInt(W, fno, 5); Texts.Write(W, " ");
+                Files.ReadString(R, name); Texts.WriteString(W, name)
+              ELSIF class = Macro THEN
+                Files.ReadByte(R, libno); Files.ReadString(R, name);
+                Texts.WriteInt(W, libno, 4); Texts.Write(W, " "); Texts.WriteString(W, name)
+              ELSIF class = Rectangles THEN
+                Files.ReadByte(R, fno); Texts.WriteInt(W, fno, 4); Files.ReadByte(R, fno); Texts.WriteInt(W, fno, 4);
+                Files.ReadByte(R, fno); Texts.WriteInt(W, fno, 4)
+              ELSE Texts.WriteString(W, "other class ="); Texts.WriteInt(W, class, 4)
+              END
+            END ;
+            Texts.WriteLn(W); Files.ReadByte(R, class)
+          END
+        ELSE Texts.WriteString(W, " not a graphics file")
+        END
+      ELSE Texts.WriteString(W, " not found")
+      END ;
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END DecGraph;
+
+  PROCEDURE DecGraph1*;
+    VAR ch: CHAR;
+      class, col, fno, len, lw, vers, cat, inx, libno: BYTE;
+      xy, wh: INTEGER;
+      name: ARRAY 32 OF CHAR;
+      F: Files.File; R: Files.Rider;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+      Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+      F := Files.Old(S.s);
+      IF F # NIL THEN
+        Files.Set(R, F, 0); Files.Read(R, ch);
+        IF ch = 0FAX THEN
+          Files.ReadByte(R, class);
+          WHILE ~R.eof & (class < 255) DO
+            Texts.WriteInt(W, class, 4);
+            IF class = Context THEN
+              Files.ReadByte(R, cat); Files.ReadByte(R, inx); Texts.WriteInt(W, cat, 4); Texts.WriteInt(W, inx, 4);
+              Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
+              IF cat = 2 THEN Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name) END
+            ELSE Files.ReadInt(R, xy);
+              Texts.WriteInt(W, xy * 10000H DIV 10000H, 5); Texts.WriteInt(W, xy DIV 10000H, 5);
+              Files.ReadInt(R, wh);
+              Texts.WriteInt(W, wh * 10000H DIV 10000H, 5); Texts.WriteInt(W, wh DIV 10000H, 5);
+              Files.ReadByte(R, col); Texts.WriteInt(W, col, 5); Texts.Write(W, "|");
+              IF class = Line THEN
+              ELSIF class = Caption THEN
+                Files.ReadByte(R, fno);  Texts.WriteInt(W, fno, 5); Texts.Write(W, " ");
+                Files.ReadString(R, name); Texts.WriteString(W, name)
+              ELSIF class = Macro THEN
+                Files.ReadByte(R, libno); Files.ReadString(R, name);
+                Texts.WriteInt(W, libno, 4); Texts.Write(W, " "); Texts.WriteString(W, name)
+              ELSIF class = Rectangles THEN
+                Files.ReadByte(R, len); Texts.WriteInt(W, len, 4);
+                Files.ReadByte(R, lw); Texts.WriteInt(W, lw, 4);
+                Files.ReadByte(R, vers); Texts.WriteInt(W, vers, 4)
+              ELSE Texts.WriteString(W, "other class ="); Texts.WriteInt(W, class, 4)
+              END
+            END ;
+            Texts.WriteLn(W); Files.ReadByte(R, class)
+          END
+        ELSE Texts.WriteString(W, " not a graphics file")
+        END
+      ELSE Texts.WriteString(W, " not found")
+      END ;
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END DecGraph1;
+
+  PROCEDURE DecLibrary1*;
+    VAR ch: CHAR;
+      class, col, fno, cat, inx, libno, len, lnw, vers: BYTE;
+      xy, wh: INTEGER;
+      name: ARRAY 32 OF CHAR;
+      F: Files.File; R: Files.Rider;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+      Texts.WriteString(W, "decode library1 "); Texts.WriteString(W, S.s);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+      F := Files.Old(S.s);
+      IF F # NIL THEN
+        Files.Set(R, F, 0); Files.Read(R, ch);
+        IF ch = 0FBX THEN
+          Files.ReadByte(R, class);
+          WHILE (class < 255) & ~R.eof  DO
+            WHILE class < 255  DO
+              Texts.WriteInt(W, class, 4);
+              IF class = Context THEN
+                Files.ReadByte(R, cat); Files.ReadByte(R, inx); Texts.WriteInt(W, cat, 4); Texts.WriteInt(W, inx, 4);
+                Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
+                IF cat = 2 THEN Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name) END
+              ELSE Files.ReadInt(R, xy);
+                Texts.WriteInt(W, xy * 10000H DIV 10000H, 5); Texts.WriteInt(W, xy DIV 10000H, 5);
+                Files.ReadInt(R, wh);
+                Texts.WriteInt(W, wh * 10000H DIV 10000H, 5); Texts.WriteInt(W, wh DIV 10000H, 5);
+                Files.ReadByte(R, col); Texts.WriteInt(W, col, 5);
+                IF class = Line THEN
+                ELSIF class = Caption THEN
+                  Texts.Write(W, "|"); Files.ReadByte(R, fno);  Texts.WriteInt(W, fno, 5); Texts.Write(W, " ");
+                  Files.ReadString(R, name); Texts.WriteString(W, name)
+                ELSIF class = Rectangles THEN
+                  Texts.Write(W, "|"); Files.ReadByte(R, len); Texts.WriteInt(W, len, 4);
+                  Files.ReadByte(R, lnw); Texts.WriteInt(W, lnw, 4);
+                  Files.ReadByte(R, vers); Texts.WriteInt(W, vers, 4)
+                ELSE Texts.WriteString(W, "other class ="); Texts.WriteInt(W, class, 4)
+                END
+              END ;
+              Texts.WriteLn(W); Files.ReadByte(R, class)
+            END ;
+            (*end macro*) Texts.WriteString(W, "---");
+            Files.ReadInt(R, wh); Texts.WriteInt(W, wh MOD 10000H, 5); Texts.WriteInt(W, wh DIV 10000H, 5);
+            Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
+            Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Files.ReadByte(R, class)
+          END
+        ELSE Texts.WriteString(W, " not a graphics library")
+        END
+      ELSE Texts.WriteString(W, " not found")
+      END ;
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END DecLibrary1;
+
+  PROCEDURE ConvertFontname(VAR x: ARRAY OF CHAR);
+  BEGIN (* Syntax --> Oberon *)
+    IF (x[0] = "S") & (x[1] = "y") & (x[2] = "n") & (x[3] = "t") & (x[4] = "a") & (x[5] = "x") THEN
+      x[0] := "O"; x[1] := "b"; x[2] := "e"; x[3] := "r"; x[4] := "o"; x[5] := "n"
+    END
+  END ConvertFontname;
+
+  PROCEDURE ConvertLibrary*;
+    VAR ch: CHAR;
+      class, col, fno, cat, inx, libno, len, lnw, vers: BYTE;
+      xy, wh: INTEGER;
+      name: ARRAY 32 OF CHAR;
+      F, G: Files.File; R, Q: Files.Rider;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+      Texts.WriteString(W, "convert library "); Texts.WriteString(W, S.s);
+      F := Files.Old(S.s);
+      IF F # NIL THEN
+        Texts.Scan(S); G := Files.New(S.s);
+        Texts.WriteString(W, " => "); Texts.WriteString(W, S.s);
+        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+        Files.Set(R, F, 0); Files.Set(Q, G, 0); Files.Read(R, ch);
+        IF ch = 0FDX THEN
+          Files.Write(Q, 0FBX); Files.ReadByte(R, class);
+          WHILE (class < 255) & ~R.eof  DO
+            WHILE class < 255  DO
+              Files.WriteByte(Q, class);
+              IF class = Context THEN
+                Files.ReadByte(R, cat); Files.ReadByte(R, inx); Texts.WriteInt(W, cat, 4); Texts.WriteInt(W, inx, 4);
+                Files.WriteByte(Q, cat); Files.WriteByte(Q, inx);
+                Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
+                IF cat = 0 THEN (*font*) ConvertFontname(name) END ;
+                Files.WriteString(Q, name);
+                IF cat = 2 THEN (*class*) Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name); Files.WriteString(Q, name) END ;
+                Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+              ELSE Files.ReadInt(R, xy); Files.WriteInt(Q, xy); Files.ReadInt(R, wh); Files.WriteInt(Q, wh);
+                Files.ReadByte(R, col); Files.Read(R, ch); Files.WriteByte(Q, 1);
+                IF class = Line THEN
+                ELSIF class = Caption THEN
+                  Files.ReadByte(R, fno); Files.WriteByte(Q, fno); Files.ReadString(R, name); Files.WriteString(Q, name)
+                ELSIF class = Rectangles THEN
+                  Files.ReadByte(R, len); Files.WriteByte(Q, len); Files.ReadByte(R, len);
+                  Files.ReadByte(R, lnw); Files.WriteByte(Q, lnw);
+                  Files.ReadByte(R, vers); Files.WriteByte(Q, vers)
+                ELSE Texts.WriteString(W, "alien class "); Texts.WriteInt(W, class, 4)
+                END
+              END ;
+              Files.ReadByte(R, class)
+            END ;
+            Files.WriteByte(Q, 255); (*end macro*) Files.ReadInt(R, wh); Files.WriteInt(Q, wh);
+            Files.ReadString(R, name); Files.WriteString(Q, name);
+            Texts.WriteString(W, name); Texts.WriteInt(W, wh MOD 10000H, 4); Texts.WriteInt(W, wh DIV 10000H, 4);
+            Texts.WriteLn(W); Files.ReadByte(R, class)
+          END
+        ELSE Texts.WriteString(W, " not a graphics library")
+        END ;
+        Files.Register(G); Texts.WriteString(W, " done")
+      ELSE Texts.WriteString(W, " not found")
+      END ;
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END ConvertLibrary;
+
+BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "GraphTool 8.8.2013");
+  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+END GraphTool.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/GraphicFrames.Mod.txt

@@ -1,529 +1,529 @@
-MODULE GraphicFrames; (*NW 18.4.88 / 18.11.2013 / 27.8.2018*)
-  IMPORT SYSTEM, Display, Viewers, Input, Fonts, Texts, Graphics, Oberon, MenuViewers;
-
-  CONST (*update message ids*)
-    drawobj = 1; drawobjs = 2; drawobjd = 3;
-    drawnorm = 4; drawsel = 5; drawdel = 6;
-
-    markW = 5;
-
-  TYPE
-    Frame* = POINTER TO FrameDesc;
-    Location* = POINTER TO LocDesc;
-
-    LocDesc* = RECORD
-        x*, y*: INTEGER;
-        next*: Location
-      END ;
-
-    FrameDesc* = RECORD (Display.FrameDesc)
-        graph*: Graphics.Graph;
-        Xg*, Yg*: INTEGER;  (*pos rel to graph origin*)
-        X1*, Y1*: INTEGER;  (*right and upper margins*)
-        x*, y*, col*: INTEGER;  (*x = X + Xg, y = Y + Yg*)
-        marked*, ticked*: BOOLEAN;
-        mark*: LocDesc
-      END ;
-
-    DrawMsg* = RECORD (Graphics.Msg)
-        f*: Frame;
-        x*, y*, col*, mode*: INTEGER
-      END ;
-
-    UpdateMsg = RECORD (Display.FrameMsg)
-        id: INTEGER;
-        graph: Graphics.Graph;
-        obj: Graphics.Object
-      END ;
-
-    ChangedMsg = RECORD (Display.FrameMsg)
-        f: Frame;
-        graph: Graphics.Graph;
-        mode: INTEGER
-      END ;
-
-    SelQuery = RECORD (Display.FrameMsg)
-        f: Frame; time: LONGINT
-      END ;
-
-    FocusQuery = RECORD (Display.FrameMsg)
-        f: Frame
-      END ;
-
-    PosQuery = RECORD (Display.FrameMsg)
-        f: Frame; x, y: INTEGER
-      END ;
-
-    DispMsg = RECORD (Display.FrameMsg)
-        x1, y1, w: INTEGER;
-        pat: INTEGER;
-        graph: Graphics.Graph
-      END ;
-
-  VAR Crosshair*: Oberon.Marker;
-    tack*, dotted*, dotted1*: INTEGER;  (*patterns*)
-    newcap: Graphics.Caption;
-    TBuf: Texts.Buffer;
-    DW, DH, CL: INTEGER;
-    W: Texts.Writer;
-
-  (*Exported procedures:
-    Restore, Focus, Selected, This, Draw, DrawNorm, Erase,
-    DrawObj, EraseObj, Change, Defocus, Deselect, Macro, Open*)
-
-  PROCEDURE SetChangeMark(F: Frame; col: INTEGER); (*set mark in corner of frame*)
-  BEGIN
-    IF F.H > 16 THEN
-      IF col = 0 THEN Display.ReplConst(Display.black, F.X+F.W-12, F.Y+F.H-12, 8, 8, Display.replace)
-      ELSE Display.CopyPattern(Display.white, Display.block, F.X+F.W-12, F.Y+F.H-12, Display.paint)
-      END
-    END
-  END SetChangeMark;
-
-  PROCEDURE Restore*(F: Frame);
-    VAR x, x0, y: INTEGER; M: DrawMsg;
-  BEGIN F.X1 := F.X + F.W; F.Y1 := F.Y + F.H;
-    F.x := (F.X + F.Xg) DIV 16 * 16; F.y := (F.Y + F.Yg) DIV 16 * 16; F.marked := FALSE; F.mark.next := NIL;
-    Oberon.RemoveMarks(F.X, F.Y, F.W, F.H); Display.ReplConst(F.col, F.X, F.Y, F.W, F.H, 0);
-    IF F.ticked THEN
-      x0 := (F.X + 15) DIV 16 * 16; y := (F.Y + 15) DIV 16 * 16;
-      WHILE y < F.Y1 DO
-        x := x0;
-        WHILE x < F.X1 DO Display.Dot(Display.white, x, y, Display.replace); INC(x, 16) END ;
-        INC(y, 16)
-      END
-    END ;
-    M.f := F; M.x := F.x; M.y := F.y; M.col := 0; M.mode := 0; Graphics.Draw(F.graph, M);
-    IF F.graph.changed THEN SetChangeMark(F, 1) END
-  END Restore;
-
-  PROCEDURE FlipCross(X, Y: INTEGER);
-  BEGIN
-    IF X < CL THEN
-      IF X < 7 THEN X := 7 ELSIF X > DW - 7 THEN X := DW - 7 END
-    ELSE
-      IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 7 THEN X := CL + DW - 7 END
-    END;
-    IF Y < 7 THEN Y := 7 ELSIF Y > DH THEN Y := DH - 7 END;
-    Display.CopyPattern(Display.white, Display.cross, X-7, Y-7, Display.invert)
-  END FlipCross;
-
-  PROCEDURE Focus*(): Frame;
-    VAR FQ: FocusQuery;
-  BEGIN FQ.f := NIL; Viewers.Broadcast(FQ); RETURN FQ.f
-  END Focus;
-
-  PROCEDURE Selected*(): Frame;
-    VAR SQ: SelQuery;
-  BEGIN SQ.f := NIL; SQ.time := 0; Viewers.Broadcast(SQ); RETURN SQ.f
-  END Selected;
-
-  PROCEDURE This*(x, y: INTEGER): Frame;
-    VAR PQ: PosQuery;
-  BEGIN PQ.f := NIL; PQ.x := x; PQ.y := y; Viewers.Broadcast(PQ); RETURN PQ.f
-  END This;
-
-  PROCEDURE Mark(F: Frame; mode: INTEGER);
-    VAR CM: ChangedMsg;
-  BEGIN CM.f := F; CM.graph := F.graph; CM.mode := mode; Viewers.Broadcast(CM)
-  END Mark;
-
-  PROCEDURE Draw*(F: Frame);
-    VAR UM: UpdateMsg;
-  BEGIN UM.id := drawsel; UM.graph := F.graph; Viewers.Broadcast(UM)
-  END Draw;
-
-  PROCEDURE DrawNorm(F: Frame);
-    VAR UM: UpdateMsg;
-  BEGIN UM.id := drawnorm; UM.graph := F.graph; Viewers.Broadcast(UM)
-  END DrawNorm;
-
-  PROCEDURE Erase*(F: Frame);
-    VAR UM: UpdateMsg;
-  BEGIN UM.id := drawdel; UM.graph := F.graph; Viewers.Broadcast(UM); Mark(F, 1)
-  END Erase;
-
-  PROCEDURE DrawObj*(F: Frame; obj: Graphics.Object);
-    VAR UM: UpdateMsg;
-  BEGIN UM.id := drawobj; UM.graph := F.graph; UM.obj := obj; Viewers.Broadcast(UM)
-  END DrawObj;
-
-  PROCEDURE EraseObj*(F: Frame; obj: Graphics.Object);
-    VAR UM: UpdateMsg;
-  BEGIN UM.id := drawobjd; UM.graph := F.graph; UM.obj := obj; Viewers.Broadcast(UM)
-  END EraseObj;
-
-  PROCEDURE Change*(F: Frame; VAR msg: Graphics.Msg);
-  BEGIN
-    IF F # NIL THEN Erase(F); Graphics.Change(F.graph, msg); Draw(F) END
-  END Change;
-
-  PROCEDURE FlipMark(x, y: INTEGER);
-  BEGIN
-    Display.ReplConst(Display.white, x-7, y, 15, 1, 2);
-    Display.ReplConst(Display.white, x, y-7, 1, 15, 2)
-  END FlipMark;
-
-  PROCEDURE Defocus*(F: Frame);
-    VAR m: Location;
-  BEGIN newcap := NIL;
-    IF F.marked THEN
-      FlipMark(F.mark.x, F.mark.y); m := F.mark.next;
-      WHILE m # NIL DO FlipMark(m.x, m.y); m := m.next END ;
-      F.marked := FALSE; F.mark.next := NIL
-    END
-  END Defocus;
-
-  PROCEDURE Deselect*(F: Frame);
-    VAR UM: UpdateMsg;
-  BEGIN
-    IF F # NIL THEN
-      UM.id := drawnorm; UM.graph := F.graph; Viewers.Broadcast(UM);
-      Graphics.Deselect(F.graph)
-    END
-  END Deselect;
-
-  PROCEDURE Macro*(Lname, Mname: ARRAY OF CHAR);
-    VAR x, y: INTEGER;
-      F: Frame;
-      mac: Graphics.Macro; mh: Graphics.MacHead;
-      L: Graphics.Library;
-  BEGIN F := Focus();
-    IF F # NIL THEN
-      x := F.mark.x - F.x; y := F.mark.y - F.y;
-      Graphics.GetLib(Lname, FALSE, L);
-      IF L # NIL THEN
-        mh := Graphics.ThisMac(L, Mname);
-        IF mh # NIL THEN
-          Deselect(F); Defocus(F);
-          NEW(mac); mac.x := x; mac.y := y; mac.w := mh.w; mac.h := mh.h;
-          mac.mac := mh; mac.do := Graphics.MacMethod; mac.col := Oberon.CurCol;
-          Graphics.Add(F.graph, mac); DrawObj(F, mac); Mark(F, 1)
-        END
-      ELSE Texts.WriteString(W, Lname); Texts.WriteString(W, " not available");
-        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-      END
-    END
-  END Macro;
-
-  PROCEDURE CaptionCopy(F: Frame;
-      x1, y1: INTEGER; T: Texts.Text; beg, end: LONGINT): Graphics.Caption;
-    VAR ch: CHAR;
-      dx, w, x2, y2, w1, h1: INTEGER;
-      cap: Graphics.Caption;
-      pat: INTEGER;
-      R: Texts.Reader;
-  BEGIN Texts.Write(W, 0DX);
-    NEW(cap); cap.len := end - beg;
-    cap.pos := Graphics.T.len + 1; cap.do := Graphics.CapMethod;
-    Texts.OpenReader(R, T, beg); Texts.Read(R, ch); W.fnt := R.fnt; W.col := R.col; w := 0;
-    cap.x := x1 - F.x; cap.y := y1 - F.y + R.fnt.minY;
-    WHILE beg < end DO
-      Fonts.GetPat(R.fnt, ch, dx, x2, y2, w1, h1, pat);
-      INC(w, dx); INC(beg); Texts.Write(W, ch); Texts.Read(R, ch)
-    END ;
-    cap.w := w; cap.h := W.fnt.height; cap.col := W.col;
-    Texts.Append(Graphics.T, W.buf); Graphics.Add(F.graph, cap);
-    Mark(F, 1); RETURN cap
-  END CaptionCopy;
-
-  PROCEDURE NewLine(F: Frame; G: Graphics.Graph; x, y, w, h: INTEGER);
-    VAR line: Graphics.Line;
-  BEGIN NEW(line); line.col := Oberon.CurCol; line.x := x - F.x; line.y := y - F.y;
-    line.w := w; line.h := h; line.do := Graphics.LineMethod;
-    Graphics.Add(G, line); Mark(F, 1)
-  END NewLine;
-
-  PROCEDURE Edit(F: Frame; x0, y0: INTEGER; k0: SET);
-    VAR obj: Graphics.Object;
-      x1, y1, w, h, t: INTEGER;
-      beg, end, time: LONGINT;
-      k1, k2: SET;
-      mark, newmark: Location;
-      T: Texts.Text;
-      Fd: Frame;
-      G: Graphics.Graph;
-  BEGIN k1 := k0; G := F.graph;
-    REPEAT Input.Mouse(k2, x1, y1); k1 := k1 + k2;
-      DEC(x1, (x1-F.x) MOD 4); DEC(y1, (y1-F.y) MOD 4);
-      Oberon.DrawMouse(Crosshair, x1, y1)
-    UNTIL  k2 = {};
-    Oberon.FadeMouse;
-    IF k0 = {2} THEN (*left key*)
-      w := ABS(x1-x0); h := ABS(y1-y0);
-      IF k1 = {2} THEN
-        IF (w < 7) & (h < 7) THEN (*set mark*)
-          IF (x1 - markW >= F.X) & (x1 + markW < F.X1) &
-            (y1 - markW >= F.Y) & (y1 + markW < F.Y1) THEN
-            Defocus(F); Oberon.PassFocus(Viewers.This(F.X, F.Y));
-            F.mark.x := x1; F.mark.y := y1; F.marked := TRUE; FlipMark(x1, y1)
-          END
-        ELSE (*draw line*) Deselect(F);
-          IF w < h THEN
-            IF y1 < y0 THEN y0 := y1 END ;
-            NewLine(F, G, x0, y0, Graphics.width, h)
-          ELSE
-            IF x1 < x0 THEN x0 := x1 END ;
-            NewLine(F, G, x0, y0, w, Graphics.width)
-          END ;
-          Draw(F)
-        END
-      ELSIF k1 = {2, 1} THEN (*copy text selection to mark*)
-        Deselect(F); Oberon.GetSelection(T, beg, end, time);
-        IF time >= 0 THEN
-          DrawObj(F, CaptionCopy(F, x1, y1, T, beg, end)); Mark(F, 1)
-        END
-      ELSIF k1 = {2, 0} THEN
-        IF F.marked THEN (*set secondary mark*)
-            NEW(newmark); newmark.x := x1; newmark.y := y1; newmark.next := NIL;
-          FlipMark(x1, y1); mark := F.mark.next;
-          IF mark = NIL THEN F.mark.next := newmark ELSE
-            WHILE mark.next # NIL DO mark := mark.next END ;
-            mark.next := newmark
-          END
-        END
-      END
-    ELSIF k0 = {1} THEN (*middle key*)
-      IF k1 = {1} THEN (*move*)
-        IF (x0 # x1) OR (y0 # y1) THEN
-          Fd := This(x1, y1); Erase(F);
-          IF Fd = F THEN Graphics.Move(G, x1-x0, y1-y0)
-          ELSIF (Fd # NIL) & (Fd.graph = G) THEN
-            Graphics.Move(G, (x1-Fd.x-x0+F.x) DIV 4 * 4, (y1-Fd.y-y0+F.y) DIV 4 * 4)
-          END ;
-          Draw(F); Mark(F, 1)
-        END
-      ELSIF k1 = {1, 2} THEN (*copy*)
-        Fd := This(x1, y1);
-        IF Fd # NIL THEN DrawNorm(F);
-          IF Fd = F THEN Graphics.Copy(G, G, x1-x0, y1-y0)
-          ELSE Deselect(Fd);
-            Graphics.Copy(G, Fd.graph, (x1-Fd.x-x0+F.x) DIV 4 * 4, (y1-Fd.y-y0+F.y) DIV 4 * 4)
-          END ;
-          Draw(Fd); Mark(F, 1)
-        END
-      ELSIF k1 = {1, 0} THEN (*shift graph*)
-        INC(F.Xg, x1-x0); INC(F.Yg, y1-y0); Restore(F)
-      END
-    ELSIF k0 = {0} THEN (*right key: select*)
-      newcap := NIL;
-      IF k1 = {0} THEN Deselect(F) END ;
-      IF (ABS(x0-x1) < 7) & (ABS(y0-y1) < 7) THEN
-        obj := Graphics.ThisObj(G, x1 - F.x, y1 - F.y);
-        IF obj # NIL THEN Graphics.SelectObj(G, obj); DrawObj(F, obj) END
-      ELSE
-        IF x1 < x0 THEN t := x0; x0 := x1; x1 := t END ;
-        IF y1 < y0 THEN t := y0; y0 := y1; y1 := t END ;
-        Graphics.SelectArea(G, x0 - F.x, y0 - F.y, x1 - F.x, y1 - F.y); Draw(F)
-      END
-    END
-  END Edit;
-
-  PROCEDURE NewCaption(F: Frame; col: INTEGER; font: Fonts.Font);
-  BEGIN Texts.Write(W, 0DX);
-    NEW(newcap); newcap.x := F.mark.x - F.x; newcap.y := F.mark.y - F.y + font.minY;
-    newcap.w := 0; newcap.h := font.height; newcap.col := col;
-    newcap.pos := Graphics.T.len + 1; newcap.len := 0; newcap.do := Graphics.CapMethod;
-    Graphics.Add(F.graph, newcap); W.fnt := font; ; Mark(F, 1)
-  END NewCaption;
-
-  PROCEDURE InsertChar(F: Frame; ch: CHAR);
-    VAR w1, h1: INTEGER; DM: DispMsg;
-  BEGIN DM.graph := F.graph;
-    Fonts.GetPat(W.fnt, ch, DM.w, DM.x1, DM.y1, w1, h1, DM.pat); DEC(DM.y1, W.fnt.minY);
-    IF newcap.x + newcap.w + DM.w + F.x < F.X1 THEN
-      Viewers.Broadcast(DM); INC(newcap.w, DM.w); INC(newcap.len); Texts.Write(W, ch)
-    END ;
-    Texts.Append(Graphics.T, W.buf)
-  END InsertChar;
-
-  PROCEDURE DeleteChar(F: Frame);
-    VAR w1, h1: INTEGER; ch: CHAR; pos: LONGINT;
-      DM: DispMsg; R: Texts.Reader;
-  BEGIN DM.graph := F.graph;
-    IF newcap.len > 0 THEN
-      pos := Graphics.T.len; Texts.OpenReader(R, Graphics.T, pos-1);  (*backspace*)
-      Texts.Read(R, ch);
-      IF ch >= " " THEN
-        Fonts.GetPat(R.fnt, ch, DM.w, DM.x1, DM.y1, w1, h1, DM.pat);
-        DEC(newcap.w, DM.w); DEC(newcap.len); DEC(DM.y1, R.fnt.minY);
-        Viewers.Broadcast(DM); Texts.Delete(Graphics.T, pos-1, pos, TBuf)
-      END
-    END
-  END DeleteChar;
-
-  PROCEDURE GetSelection(F: Frame; VAR text: Texts.Text; VAR beg, end, time: LONGINT);
-    VAR obj: Graphics.Object;
-  BEGIN obj := F.graph.sel;
-    IF (obj # NIL) & (F.graph.time >= time) THEN
-      CASE obj OF Graphics.Caption:
-        beg := obj.pos; end := obj.pos + obj.len; text := Graphics.T; time := F.graph.time
-      END
-    END
-  END GetSelection;
-
-  PROCEDURE Handle*(G: Display.Frame; VAR M: Display.FrameMsg);
-    VAR x, y, h: INTEGER;
-      DM: DispMsg; dM: DrawMsg;
-      G1: Frame;
-  BEGIN
-    CASE G OF Frame:
-      CASE M OF
-      Oberon.InputMsg:
-        IF M.id = Oberon.track THEN
-          x := M.X - (M.X - G.x) MOD 4; y := M.Y - (M.Y - G.y) MOD 4;
-          IF M.keys # {} THEN Edit(G, x, y, M.keys) ELSE Oberon.DrawMouse(Crosshair, x, y) END
-        ELSIF M.id = Oberon.consume THEN
-          IF M.ch = 7FX THEN (*DEL*)
-            Erase(G); Graphics.Delete(G.graph); Mark(G, 1)
-          ELSIF (M.ch >= 20X) & (M.ch < 7FX) THEN
-            IF newcap # NIL THEN InsertChar(G, M.ch); Mark(G, 1)
-            ELSIF G.marked THEN
-              Defocus(G); Deselect(G); NewCaption(G, M.col, M.fnt); InsertChar(G, M.ch)
-            END
-          ELSIF (M.ch = 8X) & (newcap # NIL) THEN DeleteChar(G); Mark(G, 1)
-          END
-        END
-      | UpdateMsg:
-          IF M.graph = G.graph THEN
-            dM.f := G; dM.x := G.x; dM.y := G.y; dM.col := 0;
-            IF M.id = drawobj THEN dM.mode := 0; M.obj.do.draw(M.obj, dM)
-            ELSIF M.id = drawobjs THEN dM.mode := 1; M.obj.do.draw(M.obj, dM)
-            ELSIF M.id = drawobjd THEN dM.mode := 3; M.obj.do.draw(M.obj, dM)
-            ELSIF M.id = drawsel THEN  dM.mode := 0; Graphics.DrawSel(G.graph, dM)
-            ELSIF M.id = drawnorm THEN dM.mode := 2; Graphics.DrawSel(G.graph, dM)
-            ELSIF M.id = drawdel THEN dM.mode := 3; Graphics.DrawSel(G.graph, dM)
-            END
-          END
-      | ChangedMsg:
-          IF M.graph = G.graph THEN SetChangeMark(G, M.mode) END
-      | SelQuery:
-          IF (G.graph.sel # NIL) & (M.time < G.graph.time) THEN M.f := G(Frame); M.time := G.graph.time END
-      | FocusQuery: IF G.marked THEN M.f := G END
-      | PosQuery: IF (G.X <= M.x) & (M.x < G.X1) & (G.Y <= M.y) & (M.y < G.Y1) THEN M.f := G END
-      | DispMsg:
-        DM := M;
-        x := G.x + newcap.x + newcap.w; y := G.y + newcap.y;
-        IF (DM.graph = G.graph) & (x >= G.X) & (x + DM.w < G.X1) & (y >= G.Y) & (y < G.Y1) THEN
-          Display.CopyPattern(Oberon.CurCol, DM.pat, x + DM.x1, y + DM.y1, 2);
-          Display.ReplConst(Display.white, x, y, DM.w, newcap.h, 2)
-        END
-      | Oberon.ControlMsg:
-          IF M.id = Oberon.neutralize THEN
-            Oberon.RemoveMarks(G.X, G.Y, G.W, G.H); Defocus(G); DrawNorm(G); Graphics.Deselect(G.graph)
-          ELSIF M.id = Oberon.defocus THEN Defocus(G)
-          END
-      | Oberon.SelectionMsg: GetSelection(G, M.text, M.beg, M.end, M.time)
-      | Oberon.CopyMsg: Oberon.RemoveMarks(G.X, G.Y, G.W, G.H); Defocus(G); NEW(G1); G1^ := G^; M.F := G1
-      | MenuViewers.ModifyMsg: G.Y := M.Y; G.H := M.H; Restore(G)
-      END
-    END
-  END Handle;
-
-  PROCEDURE Store*(F: Frame; name: ARRAY OF CHAR);
-  BEGIN Mark(F, 0); Graphics.WriteFile(F.graph, name)
-  END Store;
-
-  (*------------------- Draw Methods -----------------------*)
-
-  PROCEDURE ReplConst*(F: Frame; col, x, y, w, h, mode: INTEGER);
-  BEGIN
-    IF x < F.X THEN DEC(w, F.X-x); x := F.X END ;
-    IF x+w >= F.X1 THEN w := F.X1 - x END ;
-    IF y < F.Y THEN DEC(h, F.Y-y); y := F.Y END ;
-    IF y+h >= F.Y1 THEN h := F.Y1 - y END ;
-    Display.ReplConst(col, x, y, w, h, mode)
-  END ReplConst;
-
-  PROCEDURE ReplPattern*(F: Frame; col, patadr, x, y, w, h, mode: INTEGER);
-  BEGIN
-    IF x < F.X THEN DEC(w, F.X-x); x := F.X END ;
-    IF x+w >= F.X1 THEN w := F.X1 - x END ;
-    IF y < F.Y THEN DEC(h, F.Y-y); y := F.Y END ;
-    IF y+h >= F.Y1 THEN h := F.Y1 - y END ;
-    Display.ReplPattern(col, patadr, x, y, w, h, mode)
-  END ReplPattern;
-  
-  PROCEDURE DrawLine(obj: Graphics.Object; VAR M: Graphics.Msg);
-    (*M.mode = 0: draw according to state,
-        = 1: normal -> selected,
-        = 2: selected -> normal,
-        = 3: erase*)
-    VAR x, y, w, h, col: INTEGER; f: Frame;
-  BEGIN
-    CASE M OF DrawMsg:
-      x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f;
-      IF (x+w > f.X) & (x < f.X1) & (y+h > f.Y) & (y < f.Y1) THEN
-        col := obj.col;
-        IF (M.mode = 0) & obj.selected OR (M.mode = 1) THEN
-          ReplPattern(f, col, Display.grey, x, y, w, h, Display.replace)
-        ELSIF M.mode IN {0, 2} THEN ReplConst(f, col, x, y, w, h, Display.replace)
-        ELSIF M.mode = 3 THEN ReplConst(f, Display.black, x, y, w, h, Display.replace)  (*erase*)
-        END
-      END
-    END
-  END DrawLine;
-
-  PROCEDURE DrawCaption(obj: Graphics.Object; VAR M: Graphics.Msg);
-    VAR x, y, dx, x0, x1, y0, y1, w, h, w1, h1, col: INTEGER;
-      f: Frame;
-      ch: CHAR; pat: INTEGER; fnt: Fonts.Font;
-      R: Texts.Reader;
-  BEGIN
-    CASE M OF DrawMsg:
-      x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f;
-      IF (f.X <= x) & (x <= f.X1) & (f.Y <= y) & (y+h <= f.Y1) THEN
-        IF x+w > f.X1 THEN w := f.X1-x END ;
-        Texts.OpenReader(R, Graphics.T, obj(Graphics.Caption).pos); Texts.Read(R, ch);
-        IF M.mode = 0 THEN
-          IF ch >= " " THEN
-            fnt := R.fnt; x0 := x; y0 := y - fnt.minY; col := obj.col;
-            REPEAT Fonts.GetPat(fnt, ch, dx, x1, y1, w1, h1, pat);
-              IF x0+x1+w1 <= f.X1 THEN
-                Display.CopyPattern(col, pat, x0+x1, y0+y1, Display.paint); INC(x0, dx); Texts.Read(R, ch)
-              ELSE ch := 0X
-              END
-            UNTIL ch < " ";
-            IF obj.selected THEN ReplConst(f, Display.white, x, y, w, h, Display.invert) END
-          END
-        ELSIF M.mode IN {1, 2} THEN ReplConst(f, Display.white, x, y, w, h, Display.invert)
-        ELSIF M.mode = 3 THEN ReplConst(f, Display.black, x, y, w, h, Display.replace)
-        END
-      END
-    END
-  END DrawCaption;
-
-  PROCEDURE DrawMacro(obj: Graphics.Object; VAR M: Graphics.Msg);
-    VAR x, y, w, h: INTEGER;
-      f: Frame; M1: DrawMsg;
-  BEGIN
-    CASE M OF DrawMsg:
-      x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f;
-      IF (x+w > f.X) & (x < f.X1) & (y+h > f.Y) & (y < f.Y1) THEN
-        M1.x := x; M1.y := y;
-        IF M.mode = 0 THEN
-          M1.f := f; M1.col := obj.col; M1.mode := 0; Graphics.DrawMac(obj(Graphics.Macro).mac, M1);
-          IF obj.selected THEN ReplPattern(f, Display.white, dotted, x, y, w, h, Display.invert) END
-        ELSIF M.mode IN {1, 2} THEN ReplPattern(f, Display.white, dotted, x, y, w, h, Display.invert)
-        ELSIF M.mode = 3 THEN ReplConst(f, Display.black, x, y, w, h, Display.replace)
-        END
-      END
-    END
-  END DrawMacro;
-
-  (*---------------------------------------------------------------*)
-
-  PROCEDURE Open*(G: Frame; graph: Graphics.Graph); 
-  BEGIN G.graph := graph; G.Xg := 0; G.Yg := 0; G.x := G.X; G.y := G.Y;
-    G.col := Display.black; G.marked := FALSE;
-    G.mark.next := NIL; G.ticked := TRUE; G.handle := Handle
-  END Open;
-
-BEGIN DW := Display.Width - 8; DH := Display.Height - 8; CL := 0;
-  Texts.OpenWriter(W);
-  tack := SYSTEM.ADR($0707 4122 1408 1422 4100$);
-  dotted := SYSTEM.ADR($2004 0000 1111 1111 0000 0000 0000 0000 0000 0000$);
-  dotted1 := SYSTEM.ADR($2004 0000 1111 1111 0000 0000 4444 4444 0000 0000$);
-  Crosshair.Fade := FlipCross; Crosshair.Draw := FlipCross;
-  Graphics.InstallDrawMethods(DrawLine, DrawCaption, DrawMacro)
-END GraphicFrames.
+MODULE GraphicFrames; (*NW 18.4.88 / 18.11.2013 / 27.8.2018*)
+  IMPORT SYSTEM, Display, Viewers, Input, Fonts, Texts, Graphics, Oberon, MenuViewers;
+
+  CONST (*update message ids*)
+    drawobj = 1; drawobjs = 2; drawobjd = 3;
+    drawnorm = 4; drawsel = 5; drawdel = 6;
+
+    markW = 5;
+
+  TYPE
+    Frame* = POINTER TO FrameDesc;
+    Location* = POINTER TO LocDesc;
+
+    LocDesc* = RECORD
+        x*, y*: INTEGER;
+        next*: Location
+      END ;
+
+    FrameDesc* = RECORD (Display.FrameDesc)
+        graph*: Graphics.Graph;
+        Xg*, Yg*: INTEGER;  (*pos rel to graph origin*)
+        X1*, Y1*: INTEGER;  (*right and upper margins*)
+        x*, y*, col*: INTEGER;  (*x = X + Xg, y = Y + Yg*)
+        marked*, ticked*: BOOLEAN;
+        mark*: LocDesc
+      END ;
+
+    DrawMsg* = RECORD (Graphics.Msg)
+        f*: Frame;
+        x*, y*, col*, mode*: INTEGER
+      END ;
+
+    UpdateMsg = RECORD (Display.FrameMsg)
+        id: INTEGER;
+        graph: Graphics.Graph;
+        obj: Graphics.Object
+      END ;
+
+    ChangedMsg = RECORD (Display.FrameMsg)
+        f: Frame;
+        graph: Graphics.Graph;
+        mode: INTEGER
+      END ;
+
+    SelQuery = RECORD (Display.FrameMsg)
+        f: Frame; time: LONGINT
+      END ;
+
+    FocusQuery = RECORD (Display.FrameMsg)
+        f: Frame
+      END ;
+
+    PosQuery = RECORD (Display.FrameMsg)
+        f: Frame; x, y: INTEGER
+      END ;
+
+    DispMsg = RECORD (Display.FrameMsg)
+        x1, y1, w: INTEGER;
+        pat: INTEGER;
+        graph: Graphics.Graph
+      END ;
+
+  VAR Crosshair*: Oberon.Marker;
+    tack*, dotted*, dotted1*: INTEGER;  (*patterns*)
+    newcap: Graphics.Caption;
+    TBuf: Texts.Buffer;
+    DW, DH, CL: INTEGER;
+    W: Texts.Writer;
+
+  (*Exported procedures:
+    Restore, Focus, Selected, This, Draw, DrawNorm, Erase,
+    DrawObj, EraseObj, Change, Defocus, Deselect, Macro, Open*)
+
+  PROCEDURE SetChangeMark(F: Frame; col: INTEGER); (*set mark in corner of frame*)
+  BEGIN
+    IF F.H > 16 THEN
+      IF col = 0 THEN Display.ReplConst(Display.black, F.X+F.W-12, F.Y+F.H-12, 8, 8, Display.replace)
+      ELSE Display.CopyPattern(Display.white, Display.block, F.X+F.W-12, F.Y+F.H-12, Display.paint)
+      END
+    END
+  END SetChangeMark;
+
+  PROCEDURE Restore*(F: Frame);
+    VAR x, x0, y: INTEGER; M: DrawMsg;
+  BEGIN F.X1 := F.X + F.W; F.Y1 := F.Y + F.H;
+    F.x := (F.X + F.Xg) DIV 16 * 16; F.y := (F.Y + F.Yg) DIV 16 * 16; F.marked := FALSE; F.mark.next := NIL;
+    Oberon.RemoveMarks(F.X, F.Y, F.W, F.H); Display.ReplConst(F.col, F.X, F.Y, F.W, F.H, 0);
+    IF F.ticked THEN
+      x0 := (F.X + 15) DIV 16 * 16; y := (F.Y + 15) DIV 16 * 16;
+      WHILE y < F.Y1 DO
+        x := x0;
+        WHILE x < F.X1 DO Display.Dot(Display.white, x, y, Display.replace); INC(x, 16) END ;
+        INC(y, 16)
+      END
+    END ;
+    M.f := F; M.x := F.x; M.y := F.y; M.col := 0; M.mode := 0; Graphics.Draw(F.graph, M);
+    IF F.graph.changed THEN SetChangeMark(F, 1) END
+  END Restore;
+
+  PROCEDURE FlipCross(X, Y: INTEGER);
+  BEGIN
+    IF X < CL THEN
+      IF X < 7 THEN X := 7 ELSIF X > DW - 7 THEN X := DW - 7 END
+    ELSE
+      IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 7 THEN X := CL + DW - 7 END
+    END;
+    IF Y < 7 THEN Y := 7 ELSIF Y > DH THEN Y := DH - 7 END;
+    Display.CopyPattern(Display.white, Display.cross, X-7, Y-7, Display.invert)
+  END FlipCross;
+
+  PROCEDURE Focus*(): Frame;
+    VAR FQ: FocusQuery;
+  BEGIN FQ.f := NIL; Viewers.Broadcast(FQ); RETURN FQ.f
+  END Focus;
+
+  PROCEDURE Selected*(): Frame;
+    VAR SQ: SelQuery;
+  BEGIN SQ.f := NIL; SQ.time := 0; Viewers.Broadcast(SQ); RETURN SQ.f
+  END Selected;
+
+  PROCEDURE This*(x, y: INTEGER): Frame;
+    VAR PQ: PosQuery;
+  BEGIN PQ.f := NIL; PQ.x := x; PQ.y := y; Viewers.Broadcast(PQ); RETURN PQ.f
+  END This;
+
+  PROCEDURE Mark(F: Frame; mode: INTEGER);
+    VAR CM: ChangedMsg;
+  BEGIN CM.f := F; CM.graph := F.graph; CM.mode := mode; Viewers.Broadcast(CM)
+  END Mark;
+
+  PROCEDURE Draw*(F: Frame);
+    VAR UM: UpdateMsg;
+  BEGIN UM.id := drawsel; UM.graph := F.graph; Viewers.Broadcast(UM)
+  END Draw;
+
+  PROCEDURE DrawNorm(F: Frame);
+    VAR UM: UpdateMsg;
+  BEGIN UM.id := drawnorm; UM.graph := F.graph; Viewers.Broadcast(UM)
+  END DrawNorm;
+
+  PROCEDURE Erase*(F: Frame);
+    VAR UM: UpdateMsg;
+  BEGIN UM.id := drawdel; UM.graph := F.graph; Viewers.Broadcast(UM); Mark(F, 1)
+  END Erase;
+
+  PROCEDURE DrawObj*(F: Frame; obj: Graphics.Object);
+    VAR UM: UpdateMsg;
+  BEGIN UM.id := drawobj; UM.graph := F.graph; UM.obj := obj; Viewers.Broadcast(UM)
+  END DrawObj;
+
+  PROCEDURE EraseObj*(F: Frame; obj: Graphics.Object);
+    VAR UM: UpdateMsg;
+  BEGIN UM.id := drawobjd; UM.graph := F.graph; UM.obj := obj; Viewers.Broadcast(UM)
+  END EraseObj;
+
+  PROCEDURE Change*(F: Frame; VAR msg: Graphics.Msg);
+  BEGIN
+    IF F # NIL THEN Erase(F); Graphics.Change(F.graph, msg); Draw(F) END
+  END Change;
+
+  PROCEDURE FlipMark(x, y: INTEGER);
+  BEGIN
+    Display.ReplConst(Display.white, x-7, y, 15, 1, 2);
+    Display.ReplConst(Display.white, x, y-7, 1, 15, 2)
+  END FlipMark;
+
+  PROCEDURE Defocus*(F: Frame);
+    VAR m: Location;
+  BEGIN newcap := NIL;
+    IF F.marked THEN
+      FlipMark(F.mark.x, F.mark.y); m := F.mark.next;
+      WHILE m # NIL DO FlipMark(m.x, m.y); m := m.next END ;
+      F.marked := FALSE; F.mark.next := NIL
+    END
+  END Defocus;
+
+  PROCEDURE Deselect*(F: Frame);
+    VAR UM: UpdateMsg;
+  BEGIN
+    IF F # NIL THEN
+      UM.id := drawnorm; UM.graph := F.graph; Viewers.Broadcast(UM);
+      Graphics.Deselect(F.graph)
+    END
+  END Deselect;
+
+  PROCEDURE Macro*(Lname, Mname: ARRAY OF CHAR);
+    VAR x, y: INTEGER;
+      F: Frame;
+      mac: Graphics.Macro; mh: Graphics.MacHead;
+      L: Graphics.Library;
+  BEGIN F := Focus();
+    IF F # NIL THEN
+      x := F.mark.x - F.x; y := F.mark.y - F.y;
+      Graphics.GetLib(Lname, FALSE, L);
+      IF L # NIL THEN
+        mh := Graphics.ThisMac(L, Mname);
+        IF mh # NIL THEN
+          Deselect(F); Defocus(F);
+          NEW(mac); mac.x := x; mac.y := y; mac.w := mh.w; mac.h := mh.h;
+          mac.mac := mh; mac.do := Graphics.MacMethod; mac.col := Oberon.CurCol;
+          Graphics.Add(F.graph, mac); DrawObj(F, mac); Mark(F, 1)
+        END
+      ELSE Texts.WriteString(W, Lname); Texts.WriteString(W, " not available");
+        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+      END
+    END
+  END Macro;
+
+  PROCEDURE CaptionCopy(F: Frame;
+      x1, y1: INTEGER; T: Texts.Text; beg, end: LONGINT): Graphics.Caption;
+    VAR ch: CHAR;
+      dx, w, x2, y2, w1, h1: INTEGER;
+      cap: Graphics.Caption;
+      pat: INTEGER;
+      R: Texts.Reader;
+  BEGIN Texts.Write(W, 0DX);
+    NEW(cap); cap.len := end - beg;
+    cap.pos := Graphics.T.len + 1; cap.do := Graphics.CapMethod;
+    Texts.OpenReader(R, T, beg); Texts.Read(R, ch); W.fnt := R.fnt; W.col := R.col; w := 0;
+    cap.x := x1 - F.x; cap.y := y1 - F.y + R.fnt.minY;
+    WHILE beg < end DO
+      Fonts.GetPat(R.fnt, ch, dx, x2, y2, w1, h1, pat);
+      INC(w, dx); INC(beg); Texts.Write(W, ch); Texts.Read(R, ch)
+    END ;
+    cap.w := w; cap.h := W.fnt.height; cap.col := W.col;
+    Texts.Append(Graphics.T, W.buf); Graphics.Add(F.graph, cap);
+    Mark(F, 1); RETURN cap
+  END CaptionCopy;
+
+  PROCEDURE NewLine(F: Frame; G: Graphics.Graph; x, y, w, h: INTEGER);
+    VAR line: Graphics.Line;
+  BEGIN NEW(line); line.col := Oberon.CurCol; line.x := x - F.x; line.y := y - F.y;
+    line.w := w; line.h := h; line.do := Graphics.LineMethod;
+    Graphics.Add(G, line); Mark(F, 1)
+  END NewLine;
+
+  PROCEDURE Edit(F: Frame; x0, y0: INTEGER; k0: SET);
+    VAR obj: Graphics.Object;
+      x1, y1, w, h, t: INTEGER;
+      beg, end, time: LONGINT;
+      k1, k2: SET;
+      mark, newmark: Location;
+      T: Texts.Text;
+      Fd: Frame;
+      G: Graphics.Graph;
+  BEGIN k1 := k0; G := F.graph;
+    REPEAT Input.Mouse(k2, x1, y1); k1 := k1 + k2;
+      DEC(x1, (x1-F.x) MOD 4); DEC(y1, (y1-F.y) MOD 4);
+      Oberon.DrawMouse(Crosshair, x1, y1)
+    UNTIL  k2 = {};
+    Oberon.FadeMouse;
+    IF k0 = {2} THEN (*left key*)
+      w := ABS(x1-x0); h := ABS(y1-y0);
+      IF k1 = {2} THEN
+        IF (w < 7) & (h < 7) THEN (*set mark*)
+          IF (x1 - markW >= F.X) & (x1 + markW < F.X1) &
+            (y1 - markW >= F.Y) & (y1 + markW < F.Y1) THEN
+            Defocus(F); Oberon.PassFocus(Viewers.This(F.X, F.Y));
+            F.mark.x := x1; F.mark.y := y1; F.marked := TRUE; FlipMark(x1, y1)
+          END
+        ELSE (*draw line*) Deselect(F);
+          IF w < h THEN
+            IF y1 < y0 THEN y0 := y1 END ;
+            NewLine(F, G, x0, y0, Graphics.width, h)
+          ELSE
+            IF x1 < x0 THEN x0 := x1 END ;
+            NewLine(F, G, x0, y0, w, Graphics.width)
+          END ;
+          Draw(F)
+        END
+      ELSIF k1 = {2, 1} THEN (*copy text selection to mark*)
+        Deselect(F); Oberon.GetSelection(T, beg, end, time);
+        IF time >= 0 THEN
+          DrawObj(F, CaptionCopy(F, x1, y1, T, beg, end)); Mark(F, 1)
+        END
+      ELSIF k1 = {2, 0} THEN
+        IF F.marked THEN (*set secondary mark*)
+            NEW(newmark); newmark.x := x1; newmark.y := y1; newmark.next := NIL;
+          FlipMark(x1, y1); mark := F.mark.next;
+          IF mark = NIL THEN F.mark.next := newmark ELSE
+            WHILE mark.next # NIL DO mark := mark.next END ;
+            mark.next := newmark
+          END
+        END
+      END
+    ELSIF k0 = {1} THEN (*middle key*)
+      IF k1 = {1} THEN (*move*)
+        IF (x0 # x1) OR (y0 # y1) THEN
+          Fd := This(x1, y1); Erase(F);
+          IF Fd = F THEN Graphics.Move(G, x1-x0, y1-y0)
+          ELSIF (Fd # NIL) & (Fd.graph = G) THEN
+            Graphics.Move(G, (x1-Fd.x-x0+F.x) DIV 4 * 4, (y1-Fd.y-y0+F.y) DIV 4 * 4)
+          END ;
+          Draw(F); Mark(F, 1)
+        END
+      ELSIF k1 = {1, 2} THEN (*copy*)
+        Fd := This(x1, y1);
+        IF Fd # NIL THEN DrawNorm(F);
+          IF Fd = F THEN Graphics.Copy(G, G, x1-x0, y1-y0)
+          ELSE Deselect(Fd);
+            Graphics.Copy(G, Fd.graph, (x1-Fd.x-x0+F.x) DIV 4 * 4, (y1-Fd.y-y0+F.y) DIV 4 * 4)
+          END ;
+          Draw(Fd); Mark(F, 1)
+        END
+      ELSIF k1 = {1, 0} THEN (*shift graph*)
+        INC(F.Xg, x1-x0); INC(F.Yg, y1-y0); Restore(F)
+      END
+    ELSIF k0 = {0} THEN (*right key: select*)
+      newcap := NIL;
+      IF k1 = {0} THEN Deselect(F) END ;
+      IF (ABS(x0-x1) < 7) & (ABS(y0-y1) < 7) THEN
+        obj := Graphics.ThisObj(G, x1 - F.x, y1 - F.y);
+        IF obj # NIL THEN Graphics.SelectObj(G, obj); DrawObj(F, obj) END
+      ELSE
+        IF x1 < x0 THEN t := x0; x0 := x1; x1 := t END ;
+        IF y1 < y0 THEN t := y0; y0 := y1; y1 := t END ;
+        Graphics.SelectArea(G, x0 - F.x, y0 - F.y, x1 - F.x, y1 - F.y); Draw(F)
+      END
+    END
+  END Edit;
+
+  PROCEDURE NewCaption(F: Frame; col: INTEGER; font: Fonts.Font);
+  BEGIN Texts.Write(W, 0DX);
+    NEW(newcap); newcap.x := F.mark.x - F.x; newcap.y := F.mark.y - F.y + font.minY;
+    newcap.w := 0; newcap.h := font.height; newcap.col := col;
+    newcap.pos := Graphics.T.len + 1; newcap.len := 0; newcap.do := Graphics.CapMethod;
+    Graphics.Add(F.graph, newcap); W.fnt := font; ; Mark(F, 1)
+  END NewCaption;
+
+  PROCEDURE InsertChar(F: Frame; ch: CHAR);
+    VAR w1, h1: INTEGER; DM: DispMsg;
+  BEGIN DM.graph := F.graph;
+    Fonts.GetPat(W.fnt, ch, DM.w, DM.x1, DM.y1, w1, h1, DM.pat); DEC(DM.y1, W.fnt.minY);
+    IF newcap.x + newcap.w + DM.w + F.x < F.X1 THEN
+      Viewers.Broadcast(DM); INC(newcap.w, DM.w); INC(newcap.len); Texts.Write(W, ch)
+    END ;
+    Texts.Append(Graphics.T, W.buf)
+  END InsertChar;
+
+  PROCEDURE DeleteChar(F: Frame);
+    VAR w1, h1: INTEGER; ch: CHAR; pos: LONGINT;
+      DM: DispMsg; R: Texts.Reader;
+  BEGIN DM.graph := F.graph;
+    IF newcap.len > 0 THEN
+      pos := Graphics.T.len; Texts.OpenReader(R, Graphics.T, pos-1);  (*backspace*)
+      Texts.Read(R, ch);
+      IF ch >= " " THEN
+        Fonts.GetPat(R.fnt, ch, DM.w, DM.x1, DM.y1, w1, h1, DM.pat);
+        DEC(newcap.w, DM.w); DEC(newcap.len); DEC(DM.y1, R.fnt.minY);
+        Viewers.Broadcast(DM); Texts.Delete(Graphics.T, pos-1, pos, TBuf)
+      END
+    END
+  END DeleteChar;
+
+  PROCEDURE GetSelection(F: Frame; VAR text: Texts.Text; VAR beg, end, time: LONGINT);
+    VAR obj: Graphics.Object;
+  BEGIN obj := F.graph.sel;
+    IF (obj # NIL) & (F.graph.time >= time) THEN
+      CASE obj OF Graphics.Caption:
+        beg := obj.pos; end := obj.pos + obj.len; text := Graphics.T; time := F.graph.time
+      END
+    END
+  END GetSelection;
+
+  PROCEDURE Handle*(G: Display.Frame; VAR M: Display.FrameMsg);
+    VAR x, y, h: INTEGER;
+      DM: DispMsg; dM: DrawMsg;
+      G1: Frame;
+  BEGIN
+    CASE G OF Frame:
+      CASE M OF
+      Oberon.InputMsg:
+        IF M.id = Oberon.track THEN
+          x := M.X - (M.X - G.x) MOD 4; y := M.Y - (M.Y - G.y) MOD 4;
+          IF M.keys # {} THEN Edit(G, x, y, M.keys) ELSE Oberon.DrawMouse(Crosshair, x, y) END
+        ELSIF M.id = Oberon.consume THEN
+          IF M.ch = 7FX THEN (*DEL*)
+            Erase(G); Graphics.Delete(G.graph); Mark(G, 1)
+          ELSIF (M.ch >= 20X) & (M.ch < 7FX) THEN
+            IF newcap # NIL THEN InsertChar(G, M.ch); Mark(G, 1)
+            ELSIF G.marked THEN
+              Defocus(G); Deselect(G); NewCaption(G, M.col, M.fnt); InsertChar(G, M.ch)
+            END
+          ELSIF (M.ch = 8X) & (newcap # NIL) THEN DeleteChar(G); Mark(G, 1)
+          END
+        END
+      | UpdateMsg:
+          IF M.graph = G.graph THEN
+            dM.f := G; dM.x := G.x; dM.y := G.y; dM.col := 0;
+            IF M.id = drawobj THEN dM.mode := 0; M.obj.do.draw(M.obj, dM)
+            ELSIF M.id = drawobjs THEN dM.mode := 1; M.obj.do.draw(M.obj, dM)
+            ELSIF M.id = drawobjd THEN dM.mode := 3; M.obj.do.draw(M.obj, dM)
+            ELSIF M.id = drawsel THEN  dM.mode := 0; Graphics.DrawSel(G.graph, dM)
+            ELSIF M.id = drawnorm THEN dM.mode := 2; Graphics.DrawSel(G.graph, dM)
+            ELSIF M.id = drawdel THEN dM.mode := 3; Graphics.DrawSel(G.graph, dM)
+            END
+          END
+      | ChangedMsg:
+          IF M.graph = G.graph THEN SetChangeMark(G, M.mode) END
+      | SelQuery:
+          IF (G.graph.sel # NIL) & (M.time < G.graph.time) THEN M.f := G(Frame); M.time := G.graph.time END
+      | FocusQuery: IF G.marked THEN M.f := G END
+      | PosQuery: IF (G.X <= M.x) & (M.x < G.X1) & (G.Y <= M.y) & (M.y < G.Y1) THEN M.f := G END
+      | DispMsg:
+        DM := M;
+        x := G.x + newcap.x + newcap.w; y := G.y + newcap.y;
+        IF (DM.graph = G.graph) & (x >= G.X) & (x + DM.w < G.X1) & (y >= G.Y) & (y < G.Y1) THEN
+          Display.CopyPattern(Oberon.CurCol, DM.pat, x + DM.x1, y + DM.y1, 2);
+          Display.ReplConst(Display.white, x, y, DM.w, newcap.h, 2)
+        END
+      | Oberon.ControlMsg:
+          IF M.id = Oberon.neutralize THEN
+            Oberon.RemoveMarks(G.X, G.Y, G.W, G.H); Defocus(G); DrawNorm(G); Graphics.Deselect(G.graph)
+          ELSIF M.id = Oberon.defocus THEN Defocus(G)
+          END
+      | Oberon.SelectionMsg: GetSelection(G, M.text, M.beg, M.end, M.time)
+      | Oberon.CopyMsg: Oberon.RemoveMarks(G.X, G.Y, G.W, G.H); Defocus(G); NEW(G1); G1^ := G^; M.F := G1
+      | MenuViewers.ModifyMsg: G.Y := M.Y; G.H := M.H; Restore(G)
+      END
+    END
+  END Handle;
+
+  PROCEDURE Store*(F: Frame; name: ARRAY OF CHAR);
+  BEGIN Mark(F, 0); Graphics.WriteFile(F.graph, name)
+  END Store;
+
+  (*------------------- Draw Methods -----------------------*)
+
+  PROCEDURE ReplConst*(F: Frame; col, x, y, w, h, mode: INTEGER);
+  BEGIN
+    IF x < F.X THEN DEC(w, F.X-x); x := F.X END ;
+    IF x+w >= F.X1 THEN w := F.X1 - x END ;
+    IF y < F.Y THEN DEC(h, F.Y-y); y := F.Y END ;
+    IF y+h >= F.Y1 THEN h := F.Y1 - y END ;
+    Display.ReplConst(col, x, y, w, h, mode)
+  END ReplConst;
+
+  PROCEDURE ReplPattern*(F: Frame; col, patadr, x, y, w, h, mode: INTEGER);
+  BEGIN
+    IF x < F.X THEN DEC(w, F.X-x); x := F.X END ;
+    IF x+w >= F.X1 THEN w := F.X1 - x END ;
+    IF y < F.Y THEN DEC(h, F.Y-y); y := F.Y END ;
+    IF y+h >= F.Y1 THEN h := F.Y1 - y END ;
+    Display.ReplPattern(col, patadr, x, y, w, h, mode)
+  END ReplPattern;
+  
+  PROCEDURE DrawLine(obj: Graphics.Object; VAR M: Graphics.Msg);
+    (*M.mode = 0: draw according to state,
+        = 1: normal -> selected,
+        = 2: selected -> normal,
+        = 3: erase*)
+    VAR x, y, w, h, col: INTEGER; f: Frame;
+  BEGIN
+    CASE M OF DrawMsg:
+      x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f;
+      IF (x+w > f.X) & (x < f.X1) & (y+h > f.Y) & (y < f.Y1) THEN
+        col := obj.col;
+        IF (M.mode = 0) & obj.selected OR (M.mode = 1) THEN
+          ReplPattern(f, col, Display.grey, x, y, w, h, Display.replace)
+        ELSIF M.mode IN {0, 2} THEN ReplConst(f, col, x, y, w, h, Display.replace)
+        ELSIF M.mode = 3 THEN ReplConst(f, Display.black, x, y, w, h, Display.replace)  (*erase*)
+        END
+      END
+    END
+  END DrawLine;
+
+  PROCEDURE DrawCaption(obj: Graphics.Object; VAR M: Graphics.Msg);
+    VAR x, y, dx, x0, x1, y0, y1, w, h, w1, h1, col: INTEGER;
+      f: Frame;
+      ch: CHAR; pat: INTEGER; fnt: Fonts.Font;
+      R: Texts.Reader;
+  BEGIN
+    CASE M OF DrawMsg:
+      x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f;
+      IF (f.X <= x) & (x <= f.X1) & (f.Y <= y) & (y+h <= f.Y1) THEN
+        IF x+w > f.X1 THEN w := f.X1-x END ;
+        Texts.OpenReader(R, Graphics.T, obj(Graphics.Caption).pos); Texts.Read(R, ch);
+        IF M.mode = 0 THEN
+          IF ch >= " " THEN
+            fnt := R.fnt; x0 := x; y0 := y - fnt.minY; col := obj.col;
+            REPEAT Fonts.GetPat(fnt, ch, dx, x1, y1, w1, h1, pat);
+              IF x0+x1+w1 <= f.X1 THEN
+                Display.CopyPattern(col, pat, x0+x1, y0+y1, Display.paint); INC(x0, dx); Texts.Read(R, ch)
+              ELSE ch := 0X
+              END
+            UNTIL ch < " ";
+            IF obj.selected THEN ReplConst(f, Display.white, x, y, w, h, Display.invert) END
+          END
+        ELSIF M.mode IN {1, 2} THEN ReplConst(f, Display.white, x, y, w, h, Display.invert)
+        ELSIF M.mode = 3 THEN ReplConst(f, Display.black, x, y, w, h, Display.replace)
+        END
+      END
+    END
+  END DrawCaption;
+
+  PROCEDURE DrawMacro(obj: Graphics.Object; VAR M: Graphics.Msg);
+    VAR x, y, w, h: INTEGER;
+      f: Frame; M1: DrawMsg;
+  BEGIN
+    CASE M OF DrawMsg:
+      x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f;
+      IF (x+w > f.X) & (x < f.X1) & (y+h > f.Y) & (y < f.Y1) THEN
+        M1.x := x; M1.y := y;
+        IF M.mode = 0 THEN
+          M1.f := f; M1.col := obj.col; M1.mode := 0; Graphics.DrawMac(obj(Graphics.Macro).mac, M1);
+          IF obj.selected THEN ReplPattern(f, Display.white, dotted, x, y, w, h, Display.invert) END
+        ELSIF M.mode IN {1, 2} THEN ReplPattern(f, Display.white, dotted, x, y, w, h, Display.invert)
+        ELSIF M.mode = 3 THEN ReplConst(f, Display.black, x, y, w, h, Display.replace)
+        END
+      END
+    END
+  END DrawMacro;
+
+  (*---------------------------------------------------------------*)
+
+  PROCEDURE Open*(G: Frame; graph: Graphics.Graph); 
+  BEGIN G.graph := graph; G.Xg := 0; G.Yg := 0; G.x := G.X; G.y := G.Y;
+    G.col := Display.black; G.marked := FALSE;
+    G.mark.next := NIL; G.ticked := TRUE; G.handle := Handle
+  END Open;
+
+BEGIN DW := Display.Width - 8; DH := Display.Height - 8; CL := 0;
+  Texts.OpenWriter(W);
+  tack := SYSTEM.ADR($0707 4122 1408 1422 4100$);
+  dotted := SYSTEM.ADR($2004 0000 1111 1111 0000 0000 0000 0000 0000 0000$);
+  dotted1 := SYSTEM.ADR($2004 0000 1111 1111 0000 0000 4444 4444 0000 0000$);
+  Crosshair.Fade := FlipCross; Crosshair.Draw := FlipCross;
+  Graphics.InstallDrawMethods(DrawLine, DrawCaption, DrawMacro)
+END GraphicFrames.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Graphics.Mod.txt

@@ -1,686 +1,686 @@
-MODULE Graphics;   (*NW 21.12.89 / 18.11.201 / 8.4.2016*)
-  IMPORT SYSTEM, Files, Modules, Fonts, (*Printer,*) Texts, Oberon;
-
-  CONST NameLen* = 32; GraphFileId = 0FAX; LibFileId = 0FBX;
-
-  TYPE
-    Graph* = POINTER TO GraphDesc;
-    Object* = POINTER TO ObjectDesc;
-    Method* = POINTER TO MethodDesc;
-
-    Line* = POINTER TO LineDesc;
-    Caption* = POINTER TO CaptionDesc;
-    Macro* = POINTER TO MacroDesc;
-
-    ObjectDesc* = RECORD
-        x*, y*, w*, h*: INTEGER;
-        col*: BYTE;
-        selected*, marked*: BOOLEAN;
-        do*: Method;
-        next: Object
-      END ;
-
-    Msg* = RECORD END ;
-    WidMsg* = RECORD (Msg) w*: INTEGER END ;
-    ColorMsg* = RECORD (Msg) col*: INTEGER END ;
-    FontMsg* = RECORD (Msg) fnt*: Fonts.Font END ;
-    Name* = ARRAY NameLen OF CHAR;
-
-    GraphDesc* = RECORD
-        time*: LONGINT;
-        sel*, first: Object;
-        changed*: BOOLEAN
-      END ;
-
-    MacHead* = POINTER TO MacHeadDesc;
-    MacExt* = POINTER TO MacExtDesc;
-    Library* = POINTER TO LibraryDesc;
-
-    MacHeadDesc* = RECORD
-        name*: Name;
-        w*, h*: INTEGER;
-        ext*: MacExt;
-        lib*: Library;
-        first: Object;
-        next: MacHead
-      END ;
-
-    LibraryDesc* = RECORD
-        name*: Name;
-        first: MacHead;
-        next: Library
-      END ;
-
-    MacExtDesc* = RECORD END ;
-
-    Context* = RECORD
-        nofonts, noflibs, nofclasses: INTEGER;
-        font: ARRAY 10 OF Fonts.Font;
-        lib: ARRAY 4 OF Library;
-        class: ARRAY 6 OF Modules.Command
-      END;
-
-    MethodDesc* = RECORD
-        module*, allocator*: Name;
-        new*: Modules.Command;
-        copy*: PROCEDURE (from, to: Object);
-        draw*, change*: PROCEDURE (obj: Object; VAR msg: Msg);
-        selectable*: PROCEDURE (obj: Object; x, y: INTEGER): BOOLEAN;
-        read*: PROCEDURE (obj: Object; VAR R: Files.Rider; VAR C: Context);
-        write*: PROCEDURE (obj: Object; cno: INTEGER; VAR R: Files.Rider; VAR C: Context);
-        print*: PROCEDURE (obj: Object; x, y: INTEGER)
-      END ;
-
-    LineDesc* = RECORD (ObjectDesc)
-        unused*: INTEGER
-      END ;
-
-    CaptionDesc* = RECORD (ObjectDesc)
-        pos*, len*: INTEGER
-      END ;
-
-    MacroDesc* = RECORD (ObjectDesc)
-        mac*: MacHead
-      END ;
-
-  VAR width*, res*: INTEGER;
-    new: Object;
-    T*: Texts.Text;  (*captions*)
-    LineMethod*, CapMethod*, MacMethod* : Method;
-    GetLib0: PROCEDURE (name: ARRAY OF CHAR; replace: BOOLEAN; VAR Lib: Library);
-
-    FirstLib: Library;
-    W, TW, XW: Texts.Writer;
-
-  PROCEDURE New*(obj: Object);
-  BEGIN new := obj
-  END New;
-
-  PROCEDURE Add*(G: Graph; obj: Object);
-  BEGIN obj.marked := FALSE; obj.selected := TRUE; obj.next := G.first;
-    G.first := obj; G.sel := obj; G.time := Oberon.Time(); G.changed := TRUE
-  END Add;
-
-  PROCEDURE ThisObj*(G: Graph; x, y: INTEGER): Object;
-    VAR obj: Object;
-  BEGIN obj := G.first;
-    WHILE (obj # NIL) & ~obj.do.selectable(obj, x ,y) DO obj := obj.next END ;
-    RETURN obj
-  END ThisObj;
-
-  PROCEDURE SelectObj*(G: Graph; obj: Object);
-  BEGIN
-    IF obj # NIL THEN obj.selected := TRUE; G.sel := obj; G.time := Oberon.Time() END
-  END SelectObj;
-
-  PROCEDURE SelectArea*(G: Graph; x0, y0, x1, y1: INTEGER);
-    VAR obj: Object; t: INTEGER;
-  BEGIN obj := G.first;
-    IF x1 < x0 THEN t := x0; x0 := x1; x1 := t END ;
-    IF y1 < y0 THEN t := y0; y0 := y1; y1 := t END ;
-    WHILE obj # NIL DO
-      IF (x0 <= obj.x) & (obj.x + obj.w <= x1) & (y0 <= obj.y) & (obj.y + obj.h <= y1) THEN
-        obj.selected := TRUE; G.sel := obj
-      END ;
-      obj := obj.next
-    END ;
-    IF G.sel # NIL THEN G.time := Oberon.Time() END
-  END SelectArea;
-
-  PROCEDURE Draw*(G: Graph; VAR M: Msg);
-    VAR obj: Object;
-  BEGIN obj := G.first;
-    WHILE obj # NIL DO obj.do.draw(obj, M); obj := obj.next END
-  END Draw;
-
-  PROCEDURE List*(G: Graph);
-    VAR obj: Object; tag: INTEGER;
-  BEGIN obj := G.first;
-    WHILE obj # NIL DO
-      Texts.Write(XW, 9X); Texts.WriteHex(XW, ORD(obj)); Texts.Write(XW, 9X);
-      Texts.WriteInt(XW, obj.x, 5); Texts.WriteInt(XW, obj.y, 5); Texts.WriteInt(XW, obj.w, 5); Texts.WriteInt(XW, obj.h, 5);
-      Texts.Write(XW, "/"); SYSTEM.GET(ORD(obj)-8, tag); Texts.WriteHex(XW, tag);
-      SYSTEM.GET(ORD(obj)-4, tag); Texts.WriteHex(XW, tag); Texts.WriteLn(XW); obj := obj.next
-    END ;
-    Texts.Append(Oberon.Log, XW.buf)
-  END List;
-
-  (*----------------procedures operating on selection -------------------*)
-
-  PROCEDURE Deselect*(G: Graph);
-    VAR obj: Object;
-  BEGIN obj := G.first; G.sel := NIL; G.time := 0;
-    WHILE obj # NIL DO obj.selected := FALSE; obj := obj.next END
-  END Deselect;
-
-  PROCEDURE DrawSel*(G: Graph; VAR M: Msg);
-    VAR obj: Object;
-  BEGIN obj := G.first;
-    WHILE obj # NIL DO
-      IF obj.selected THEN obj.do.draw(obj, M) END ;
-      obj := obj.next
-    END
-  END DrawSel;
-
-  PROCEDURE Change*(G: Graph; VAR M: Msg);
-    VAR obj: Object;
-  BEGIN obj := G.first; G.changed := TRUE;
-    WHILE obj # NIL DO
-      IF obj.selected THEN obj.do.change(obj, M) END ;
-      obj := obj.next
-    END
-  END Change;
-
-  PROCEDURE Move*(G: Graph; dx, dy: INTEGER);
-    VAR obj, ob0: Object; x0, x1, y0, y1: INTEGER;
-  BEGIN obj := G.first; G.changed := TRUE;
-    WHILE obj # NIL DO
-      IF obj.selected & ~(obj IS Caption) THEN
-        x0 := obj.x; x1 := obj.w + x0; y0 := obj.y; y1 := obj.h + y0;
-        IF dx = 0 THEN (*vertical move*)
-          ob0 := G.first;
-          WHILE ob0 # NIL DO
-            IF ~ob0.selected & (ob0 IS Line) & (x0 <= ob0.x) & (ob0.x <= x1) & (ob0.w < ob0.h) THEN
-              IF (y0 <= ob0.y) & (ob0.y <= y1) THEN
-                INC(ob0.y, dy); DEC(ob0.h, dy); ob0.marked := TRUE
-              ELSIF (y0 <= ob0.y + ob0.h) & (ob0.y + ob0.h <= y1) THEN
-                INC(ob0.h, dy); ob0.marked := TRUE
-              END
-            END ;
-            ob0 := ob0.next
-          END
-        ELSIF dy = 0 THEN (*horizontal move*)
-          ob0 := G.first;
-          WHILE ob0 # NIL DO
-            IF ~ob0.selected & (ob0 IS Line) & (y0 <= ob0.y) & (ob0.y <= y1) & (ob0.h < ob0.w) THEN
-              IF (x0 <= ob0.x) & (ob0.x <= x1) THEN
-                INC(ob0.x, dx); DEC(ob0.w, dx); ob0.marked := TRUE
-              ELSIF (x0 <= ob0.x + ob0.w) & (ob0.x + ob0.w <= x1) THEN
-                INC(ob0.w, dx); ob0.marked := TRUE
-              END
-            END ;
-            ob0 := ob0.next
-          END
-        END
-      END ;
-      obj := obj.next
-    END ;
-    obj := G.first; (*now move*)
-    WHILE obj # NIL DO
-      IF obj.selected THEN INC(obj.x, dx); INC(obj.y, dy) END ;
-      obj.marked := FALSE; obj := obj.next
-    END
-  END Move;
-
-  PROCEDURE Copy*(Gs, Gd: Graph; dx, dy: INTEGER);
-    VAR obj: Object;
-  BEGIN obj := Gs.first; Gd.changed := TRUE;
-    WHILE obj # NIL DO
-      IF obj.selected THEN
-        obj.do.new; obj.do.copy(obj, new); INC(new.x, dx); INC(new.y, dy);
-        obj.selected := FALSE; Add(Gd, new)
-      END ;
-      obj := obj.next
-    END ;
-    new := NIL
-  END Copy;
-
-  PROCEDURE Delete*(G: Graph);
-    VAR obj, pred: Object;
-  BEGIN G.sel := NIL; G.changed := TRUE; obj := G.first;
-    WHILE (obj # NIL) & obj.selected DO obj := obj.next END ;
-    G.first := obj;
-    IF obj # NIL THEN
-      pred := obj; obj := obj.next;
-      WHILE obj # NIL DO
-        IF obj.selected THEN pred.next := obj.next ELSE pred := obj END ;
-        obj := obj.next
-      END
-    END
-  END Delete;
-
-  (* ---------------------- Storing ----------------------- *)
-
-  PROCEDURE WMsg(s0, s1: ARRAY OF CHAR);
-  BEGIN Texts.WriteString(W, s0); Texts.WriteString(W, s1);
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END WMsg;
-
-  PROCEDURE InitContext(VAR C: Context);
-  BEGIN C.nofonts := 0; C.noflibs := 0; C.nofclasses := 4;
-    C.class[1] := LineMethod.new; C.class[2] := CapMethod.new; C.class[3] := MacMethod.new
-  END InitContext;
-
-  PROCEDURE FontNo*(VAR W: Files.Rider; VAR C: Context; fnt: Fonts.Font): INTEGER;
-    VAR fno: INTEGER;
-  BEGIN fno := 0;
-    WHILE (fno < C.nofonts) & (C.font[fno] # fnt) DO INC(fno) END ;
-    IF fno = C.nofonts THEN
-      Files.WriteByte(W, 0); Files.WriteByte(W, 0); Files.WriteByte(W, fno);
-      Files.WriteString(W, fnt.name); C.font[fno] := fnt; INC(C.nofonts)
-    END ;
-    RETURN fno
-  END FontNo;
-
-  PROCEDURE StoreElems(VAR W: Files.Rider; VAR C: Context; obj: Object);
-    VAR cno: INTEGER;
-  BEGIN
-    WHILE obj # NIL DO
-      cno := 1;
-      WHILE (cno < C.nofclasses) & (obj.do.new # C.class[cno]) DO INC(cno) END ;
-      IF cno = C.nofclasses THEN
-        Files.WriteByte(W, 0); Files.WriteByte(W, 2); Files.WriteByte(W, cno);
-        Files.WriteString(W, obj.do.module); Files.WriteString(W, obj.do.allocator);
-        C.class[cno] := obj.do.new; INC(C.nofclasses)
-      END ;
-      obj.do.write(obj, cno, W, C); obj := obj.next
-    END ;
-    Files.WriteByte(W, 255)
-  END StoreElems;
-
-  PROCEDURE Store*(G: Graph; VAR W: Files.Rider);
-    VAR C: Context;
-  BEGIN InitContext(C); StoreElems(W, C, G.first); G.changed := FALSE
-  END Store;
-
-  PROCEDURE WriteObj*(VAR W: Files.Rider; cno: INTEGER; obj: Object);
-  BEGIN Files.WriteByte(W, cno); Files.WriteInt(W, obj.y * 10000H + obj.x);
-    Files.WriteInt(W, obj.h * 10000H + obj.w); Files.WriteByte(W, obj.col)
-  END WriteObj;
-
-  PROCEDURE WriteFile*(G: Graph; name: ARRAY OF CHAR);
-    VAR F: Files.File; W: Files.Rider; C: Context;
-  BEGIN F := Files.New(name); Files.Set(W, F, 0); Files.Write(W, GraphFileId);
-    InitContext(C); StoreElems(W, C, G.first); Files.Register(F)
-  END WriteFile;
-
-  PROCEDURE Print*(G: Graph; x0, y0: INTEGER);
-    VAR obj: Object;
-  BEGIN obj := G.first;
-    WHILE obj # NIL DO obj.do.print(obj, x0, y0); obj := obj.next END
-  END Print;
-
-  (* ---------------------- Loading ------------------------ *)
-
-  PROCEDURE GetClass*(module, allocator: ARRAY OF CHAR; VAR com: Modules.Command);
-    VAR mod: Modules.Module;
-  BEGIN Modules.Load(module, mod);
-    IF mod # NIL THEN
-      com := Modules.ThisCommand(mod, allocator);
-      IF com = NIL THEN WMsg(allocator, " unknown") END
-    ELSE WMsg(module, " not available"); com := NIL
-    END
-  END GetClass;
-
-  PROCEDURE Font*(VAR R: Files.Rider; VAR C: Context): Fonts.Font;
-    VAR fno: BYTE;
-  BEGIN Files.ReadByte(R, fno); RETURN C.font[fno]
-  END Font;
-
-  PROCEDURE ReadObj(VAR R: Files.Rider; obj: Object);
-    VAR xy, wh: INTEGER; dmy: BYTE;
-  BEGIN Files.ReadInt(R, xy); obj.y := xy DIV 10000H; obj.x := xy * 10000H DIV 10000H;
-    Files.ReadInt(R, wh); obj.h := wh DIV 10000H; obj.w := wh * 10000H DIV 10000H;
-    Files.ReadByte(R, obj.col)
-  END ReadObj;
-
-  PROCEDURE LoadElems(VAR R: Files.Rider; VAR C: Context; VAR fobj: Object);
-    VAR cno, m, n, len: BYTE; pos: INTEGER;
-      obj: Object;
-      fnt: Fonts.Font;
-      name, name1: ARRAY 32 OF CHAR;
-  BEGIN obj := NIL; Files.ReadByte(R, cno);
-    WHILE ~R.eof & (cno < 255) DO
-      IF cno = 0 THEN
-        Files.ReadByte(R, m); Files.ReadByte(R, n); Files.ReadString(R, name);
-        IF m = 0 THEN fnt := Fonts.This(name); C.font[n] := fnt
-        ELSIF m = 1 THEN GetLib0(name, FALSE, C.lib[n])
-        ELSIF m = 2 THEN Files.ReadString(R, name1); GetClass(name, name1, C.class[n])
-        END
-      ELSIF C.class[cno] # NIL THEN
-        C.class[cno];
-        ReadObj(R, new);
-        new.selected := FALSE; new.marked := FALSE; new.next := obj; obj := new;
-        new.do.read(new, R, C)
-      ELSE ReadObj(R, new); Files.ReadByte(R, len); pos := Files.Pos(R); Files.Set(R, Files.Base(R), pos + len)
-      END ;
-      Files.ReadByte(R, cno)
-    END ;
-    new := NIL; fobj := obj
-  END LoadElems;
-
-  PROCEDURE Load*(G: Graph; VAR R: Files.Rider);
-    VAR C: Context;
-  BEGIN G.sel := NIL; InitContext(C); LoadElems(R, C, G.first)
-  END Load;
-
-  PROCEDURE Open*(G: Graph; name: ARRAY OF CHAR);
-    VAR tag: CHAR;
-      F: Files.File; R: Files.Rider; C: Context;
-  BEGIN G.first := NIL; G.sel := NIL; G.time := 0; G.changed := FALSE; F := Files.Old(name);
-    IF F # NIL THEN
-      Files.Set(R, F, 0); Files.Read(R, tag);
-      IF tag = GraphFileId THEN InitContext(C); LoadElems(R, C, G.first); res := 0 ELSE res := 1 END
-    ELSE res := 2
-    END
-  END Open;
-
-  PROCEDURE SetWidth*(w: INTEGER);
-  BEGIN width := w
-  END SetWidth;
-
-  (* --------------------- Macros / Libraries ----------------------- *)
-
-  PROCEDURE GetLib*(name: ARRAY OF CHAR; replace: BOOLEAN; VAR Lib: Library);
-    VAR i, wh: INTEGER; ch: CHAR;
-      L: Library; mh: MacHead; obj: Object;
-      F: Files.File; R: Files.Rider; C: Context;
-      Lname, Fname: ARRAY 32 OF CHAR;
-  BEGIN L := FirstLib; i := 0;
-    WHILE (L # NIL) & (L.name # name) DO L := L.next END ;
-    IF L = NIL THEN
-      (*load library from file*) i := 0;
-      WHILE name[i] > 0X DO Fname[i] := name[i]; INC(i) END ;
-      Fname[i] := "."; Fname[i+1] := "L"; Fname[i+2] := "i"; Fname[i+3] := "b"; Fname[i+4] := 0X;
-      F := Files.Old(Fname);
-      IF F # NIL THEN
-         WMsg("loading ", Fname); Files.Set(R, F, 0); Files.Read(R, ch);
-        IF ch = LibFileId THEN
-          IF L = NIL THEN NEW(L); L.name := name; L.next := FirstLib; FirstLib := L END ;
-          L.first := NIL; InitContext(C); 
-          LoadElems(R, C, obj);
-          WHILE obj # NIL DO
-            NEW(mh); mh.first := obj;
-            Files.ReadInt(R, wh); mh.h := wh DIV 10000H MOD 10000H; mh.w := wh MOD 10000H;
-            Files.ReadString(R, mh.name);
-            mh.lib := L; mh.next := L.first; L.first := mh; LoadElems(R, C, obj)
-          END ;
-        ELSE L := NIL
-        END
-      ELSE L := NIL
-      END
-    END ;
-    Lib := L
-  END GetLib;
-
-  PROCEDURE NewLib*(Lname: ARRAY OF CHAR): Library;
-    VAR L: Library;
-  BEGIN NEW(L); L.name := Lname; L.first := NIL;
-    L.next := FirstLib; FirstLib := L; RETURN L
-  END NewLib;
-
-  PROCEDURE StoreLib*(L: Library; Fname: ARRAY OF CHAR);
-    VAR i: INTEGER;
-      mh: MacHead;
-      F: Files.File; W: Files.Rider;
-      C: Context;
-      Gname: ARRAY 32 OF CHAR;
-  BEGIN L := FirstLib;
-    WHILE (L # NIL) & (L.name # Fname) DO L := L.next END ;
-    IF L # NIL THEN i := 0;
-      WHILE Fname[i] > 0X DO Gname[i] := Fname[i]; INC(i) END ;
-      Gname[i] := "."; Gname[i+1] := "L"; Gname[i+2] := "i"; Gname[i+3] := "b"; Gname[i+4] := 0X;
-      F := Files.New(Gname); Files.Set(W, F, 0); Files.Write(W, LibFileId);
-      InitContext(C); mh := L.first;
-      WHILE mh # NIL DO
-        StoreElems(W, C, mh.first); Files.WriteInt(W, mh.h * 10000H + mh.w);
-        Files.WriteString(W, mh.name); mh := mh.next
-      END ;
-      Files.WriteByte(W, 255); Files.Register(F)
-    ELSE Texts.WriteString(TW, Fname); Texts.WriteString(TW, " not found");
-      Texts.WriteLn(TW); Texts.Append(Oberon.Log, TW.buf)
-    END
-  END StoreLib;
-
-  PROCEDURE RemoveLibraries*;
-  BEGIN FirstLib := NIL
-  END RemoveLibraries;
-
-  PROCEDURE ThisMac*(L: Library; Mname: ARRAY OF CHAR): MacHead;
-    VAR mh: MacHead;
-  BEGIN mh := L.first;
-    WHILE (mh # NIL) & (mh.name # Mname) DO mh := mh.next END ;
-    RETURN mh
-  END ThisMac;
-
-  PROCEDURE DrawMac*(mh: MacHead; VAR M: Msg);
-    VAR elem: Object;
-  BEGIN elem := mh.first;
-    WHILE elem # NIL DO elem.do.draw(elem, M); elem := elem.next END
-  END DrawMac;
-
-  (* -------------------- Procedures for designing macros---------------------*)
-
-  PROCEDURE OpenMac*(mh: MacHead; G: Graph; x, y: INTEGER);
-    VAR obj: Object;
-  BEGIN obj := mh.first;
-    WHILE obj # NIL DO
-      obj.do.new; obj.do.copy(obj, new); INC(new.x, x); INC(new.y, y); new.selected := TRUE;
-      Add(G, new); obj := obj.next
-    END ;
-    new := NIL
-  END OpenMac;
-
-  PROCEDURE MakeMac*(G: Graph; VAR head: MacHead);
-    VAR x0, y0, x1, y1: INTEGER;
-      obj, last: Object;
-      mh: MacHead;
-  BEGIN obj := G.first; last := NIL; x0 := 1024; x1 := 0; y0 := 1024; y1 := 0;
-      WHILE obj # NIL DO
-        IF obj.selected THEN
-          obj.do.new; obj.do.copy(obj, new); new.next := last; new.selected := FALSE; last := new;
-          IF obj.x < x0 THEN x0 := obj.x END ;
-          IF obj.x + obj.w > x1 THEN x1 := obj.x + obj.w END ;
-          IF obj.y < y0 THEN y0 := obj.y END ;
-          IF obj.y + obj.h > y1 THEN y1 := obj.y + obj.h END
-        END ;
-        obj := obj.next
-      END ;
-      obj := last;
-      WHILE obj # NIL DO
-        obj.x := obj.x - x0; obj.y := obj.y - y0; obj := obj.next
-      END ;
-      NEW(mh); mh.w := x1 - x0; mh.h := y1 - y0; mh.first := last; mh.ext := NIL;
-      new := NIL; head := mh
-  END MakeMac;
-
-  PROCEDURE InsertMac*(mh: MacHead; L: Library; VAR new: BOOLEAN);
-    VAR mh1: MacHead;
-  BEGIN mh.lib := L; mh1 := L.first;
-    WHILE (mh1 # NIL) & (mh1.name # mh.name) DO mh1 := mh1.next END ;
-    IF mh1 = NIL THEN
-      new := TRUE; mh.next := L.first; L.first := mh
-    ELSE
-      new := FALSE; mh1.w := mh.w; mh1.h := mh.h; mh1.first := mh.first
-    END
-  END InsertMac;
-
-  (* ---------------------------- Line Methods -----------------------------*)
-
-  PROCEDURE NewLine;
-    VAR line: Line;
-  BEGIN NEW(line); new := line; line.do := LineMethod
-  END NewLine;
-
-  PROCEDURE CopyLine(src, dst: Object);
-  BEGIN dst.x := src.x; dst.y := src.y; dst.w := src.w; dst.h := src.h; dst.col := src.col
-  END CopyLine;
-
-  PROCEDURE ChangeLine(obj: Object; VAR M: Msg);
-  BEGIN
-    CASE M OF
-    WidMsg:
-      IF obj.w < obj.h THEN
-        IF obj.w <= 7 THEN obj.w := M.w END
-      ELSIF obj.h <= 7 THEN obj.h := M.w
-      END |
-    ColorMsg: obj.col := M.col
-    END
-  END ChangeLine;
-
-  PROCEDURE LineSelectable(obj: Object; x, y: INTEGER): BOOLEAN;
-  BEGIN
-    RETURN (obj.x <= x) & (x < obj.x + obj.w) & (obj.y <= y) & (y < obj.y + obj.h)
-  END LineSelectable;
-
-  PROCEDURE ReadLine(obj: Object; VAR R: Files.Rider; VAR C: Context);
-  BEGIN
-  END ReadLine;
-
-  PROCEDURE WriteLine(obj: Object; cno: INTEGER; VAR W: Files.Rider; VAR C: Context);
-  BEGIN WriteObj(W, cno, obj)
-  END WriteLine;
-
-(*PROCEDURE PrintLine(obj: Object; x, y: INTEGER);
-    VAR w, h: INTEGER;
-  BEGIN w := obj.w * 2; h := obj.h * 2;
-    IF w < h THEN h := 2*h ELSE w := 2*w END ;
-    Printer.ReplConst(obj.x * 4 + x, obj.y *4 + y, w, h)
-  END PrintLine; *)
-
-  (* ---------------------- Caption Methods ------------------------ *)
-
-  PROCEDURE NewCaption;
-    VAR cap: Caption;
-  BEGIN NEW(cap); new := cap; cap.do := CapMethod
-  END NewCaption;
-
-  PROCEDURE CopyCaption(src, dst: Object);
-    VAR ch: CHAR; R: Texts.Reader;
-  BEGIN
-    dst.x := src.x; dst.y := src.y; dst.w := src.w; dst.h := src.h; dst.col := src.col;
-    dst(Caption).pos := T.len + 1; dst(Caption).len := src(Caption).len;
-    Texts.Write(TW, 0DX); Texts.OpenReader(R, T, src(Caption).pos);
-    Texts.Read(R, ch); TW.fnt := R.fnt;
-    WHILE ch > 0DX DO Texts.Write(TW, ch); Texts.Read(R, ch) END ;
-    Texts.Append(T, TW.buf)
-  END CopyCaption;
-
-  PROCEDURE ChangeCaption(obj: Object;  VAR M: Msg);
-    VAR dx, x1, dy, y1, w, w1, h1, len: INTEGER;
-      pos: LONGINT;
-      ch: CHAR; patadr: INTEGER; fnt: Fonts.Font;
-      R: Texts.Reader;
-  BEGIN
-    CASE M OF
-    FontMsg: fnt := M(FontMsg).fnt; w := 0; len := 0; pos := obj(Caption).pos;
-      Texts.OpenReader(R, T, pos); Texts.Read(R, ch); dy := R.fnt.minY;
-      WHILE ch > 0DX DO
-        Fonts.GetPat(fnt, ch, dx, x1, y1, w1, h1, patadr);
-        INC(w, dx); INC(len); Texts.Read(R, ch)
-      END ;
-      INC(obj.y, fnt.minY-dy); obj.w := w; obj.h := fnt.height;
-      Texts.ChangeLooks(T, pos, pos+len, {0}, fnt, 0 , 0) |
-    ColorMsg: obj.col := M(ColorMsg).col
-    END
-  END ChangeCaption;
-
-  PROCEDURE CaptionSelectable(obj: Object; x, y: INTEGER): BOOLEAN;
-  BEGIN
-    RETURN (obj.x <= x) & (x < obj.x + obj.w) & (obj.y <= y) & (y < obj.y + obj.h)
-  END CaptionSelectable;
-
-  PROCEDURE ReadCaption(obj: Object; VAR R: Files.Rider; VAR C: Context);
-    VAR ch: CHAR; fno: BYTE; len: INTEGER;
-  BEGIN obj(Caption).pos := T.len + 1; Texts.Write(TW, 0DX);
-    Files.ReadByte(R, fno); TW.fnt := C.font[fno]; len := 0; Files.Read(R, ch);
-    WHILE ch > 0DX DO Texts.Write(TW, ch); INC(len); Files.Read(R, ch) END ;
-    obj(Caption).len := len; Texts.Append(T, TW.buf)
-  END ReadCaption;
-
-  PROCEDURE WriteCaption(obj: Object; cno: INTEGER; VAR W: Files.Rider; VAR C: Context);
-    VAR ch: CHAR; fno: BYTE;
-      TR: Texts.Reader;
-  BEGIN
-    IF obj(Caption).len > 0 THEN
-      Texts.OpenReader(TR, T, obj(Caption).pos); Texts.Read(TR, ch);
-      fno := FontNo(W, C, TR.fnt);
-      WriteObj(W, cno, obj); Files.WriteByte(W, fno);
-      WHILE ch > 0DX DO  Files.Write(W, ch); Texts.Read(TR, ch) END ;
-      Files.Write(W, 0X)
-    END
-  END WriteCaption;
-
-(*  PROCEDURE PrintCaption(obj: Object; x, y: INTEGER);
-    VAR fnt: Fonts.Font;
-      i: INTEGER; ch: CHAR;
-      R: Texts.Reader;
-      s: ARRAY 128 OF CHAR;
-  BEGIN
-    IF obj(Caption).len > 0 THEN
-      Texts.OpenReader(R, T, obj(Caption).pos); Texts.Read(R, ch);
-      fnt := R.fnt; DEC(y, fnt.minY*4); i := 0;
-      WHILE ch >= " " DO s[i] := ch; INC(i); Texts.Read(R, ch) END ;
-      s[i] := 0X;
-      IF i > 0 THEN Printer.String(obj.x*4 + x, obj.y*4 + y, s, fnt.name) END
-    END
-  END PrintCaption; *)
-
-  (* ---------------------- Macro Methods ------------------------ *)
-
-  PROCEDURE NewMacro;
-    VAR mac: Macro;
-  BEGIN NEW(mac); new := mac; mac.do := MacMethod
-  END NewMacro;
-
-  PROCEDURE CopyMacro(src, dst: Object);
-  BEGIN dst.x := src.x; dst.y := src.y; dst.w := src.w; dst.h := src.h;
-    dst.col := src.col; dst(Macro).mac := src(Macro).mac
-  END CopyMacro;
-
-  PROCEDURE ChangeMacro(obj: Object; VAR M: Msg);
-  BEGIN
-    CASE M OF ColorMsg: obj.col := M.col END
-  END ChangeMacro;
-
-  PROCEDURE MacroSelectable(obj: Object; x, y: INTEGER): BOOLEAN;
-  BEGIN
-    RETURN (obj.x <= x) & (x <= obj.x + 8) & (obj.y <= y) & (y <= obj.y + 8)
-  END MacroSelectable;
-
-  PROCEDURE ReadMacro(obj: Object; VAR R: Files.Rider; VAR C: Context);
-    VAR lno: BYTE; name: ARRAY 32 OF CHAR;
-  BEGIN Files.ReadByte(R, lno);
-    Files.ReadString(R, name); obj(Macro).mac := ThisMac(C.lib[lno], name)
-  END ReadMacro;
-
-  PROCEDURE WriteMacro(obj: Object; cno: INTEGER; VAR W1: Files.Rider; VAR C: Context);
-    VAR lno: INTEGER;
-  BEGIN lno := 0;
-    WHILE (lno < C.noflibs) & (obj(Macro).mac.lib # C.lib[lno]) DO INC(lno) END ;
-    IF lno = C.noflibs THEN
-      Files.WriteByte(W1, 0); Files.WriteByte(W1, 1); Files.WriteByte(W1, lno);
-      Files.WriteString(W1, obj(Macro).mac.lib.name); C.lib[lno] := obj(Macro).mac.lib; INC(C.noflibs)
-    END ;
-    WriteObj(W1, cno, obj); Files.WriteByte(W1, lno); Files.WriteString(W1, obj(Macro).mac.name)
-  END WriteMacro;
-
-(*  PROCEDURE PrintMacro(obj: Object; x, y: INTEGER);
-    VAR elem: Object; mh: MacHead;
-  BEGIN mh := obj(Macro).mac;
-    IF mh # NIL THEN elem := mh.first;
-      WHILE elem # NIL DO elem.do.print(elem, obj.x*4 + x, obj.y*4 + y); elem := elem.next END
-    END
-  END PrintMacro; *)
-
-  PROCEDURE Notify(T: Texts.Text; op: INTEGER; beg, end: LONGINT);
-  BEGIN
-  END Notify;
-
-  PROCEDURE InstallDrawMethods*(drawLine, drawCaption, drawMacro: PROCEDURE (obj: Object; VAR msg: Msg));
-  BEGIN LineMethod.draw := drawLine; CapMethod.draw := drawCaption; MacMethod.draw := drawMacro
-  END InstallDrawMethods;
-
-BEGIN Texts.OpenWriter(W); Texts.OpenWriter(TW);  Texts.OpenWriter(XW);
-  width := 1; GetLib0 := GetLib;
-  NEW(T); Texts.Open(T, ""); T.notify := Notify;
-  NEW(LineMethod); LineMethod.new := NewLine; LineMethod.copy := CopyLine;
-  LineMethod.selectable := LineSelectable; LineMethod.change := ChangeLine;
-  LineMethod.read := ReadLine; LineMethod.write := WriteLine; (*LineMethod.print := PrintLine;*)
-  NEW(CapMethod); CapMethod.new := NewCaption; CapMethod.copy := CopyCaption;
-  CapMethod.selectable := CaptionSelectable; CapMethod.change := ChangeCaption;
-  CapMethod.read := ReadCaption; CapMethod.write := WriteCaption; (*CapMethod.print := PrintCaption;*)
-  NEW(MacMethod); MacMethod.new := NewMacro; MacMethod.copy := CopyMacro;
-  MacMethod.selectable := MacroSelectable; MacMethod.change := ChangeMacro;
-  MacMethod.read := ReadMacro; MacMethod.write := WriteMacro; (*MacMethod.print := PrintMacro*)
+MODULE Graphics;   (*NW 21.12.89 / 18.11.201 / 8.4.2016*)
+  IMPORT SYSTEM, Files, Modules, Fonts, (*Printer,*) Texts, Oberon;
+
+  CONST NameLen* = 32; GraphFileId = 0FAX; LibFileId = 0FBX;
+
+  TYPE
+    Graph* = POINTER TO GraphDesc;
+    Object* = POINTER TO ObjectDesc;
+    Method* = POINTER TO MethodDesc;
+
+    Line* = POINTER TO LineDesc;
+    Caption* = POINTER TO CaptionDesc;
+    Macro* = POINTER TO MacroDesc;
+
+    ObjectDesc* = RECORD
+        x*, y*, w*, h*: INTEGER;
+        col*: BYTE;
+        selected*, marked*: BOOLEAN;
+        do*: Method;
+        next: Object
+      END ;
+
+    Msg* = RECORD END ;
+    WidMsg* = RECORD (Msg) w*: INTEGER END ;
+    ColorMsg* = RECORD (Msg) col*: INTEGER END ;
+    FontMsg* = RECORD (Msg) fnt*: Fonts.Font END ;
+    Name* = ARRAY NameLen OF CHAR;
+
+    GraphDesc* = RECORD
+        time*: LONGINT;
+        sel*, first: Object;
+        changed*: BOOLEAN
+      END ;
+
+    MacHead* = POINTER TO MacHeadDesc;
+    MacExt* = POINTER TO MacExtDesc;
+    Library* = POINTER TO LibraryDesc;
+
+    MacHeadDesc* = RECORD
+        name*: Name;
+        w*, h*: INTEGER;
+        ext*: MacExt;
+        lib*: Library;
+        first: Object;
+        next: MacHead
+      END ;
+
+    LibraryDesc* = RECORD
+        name*: Name;
+        first: MacHead;
+        next: Library
+      END ;
+
+    MacExtDesc* = RECORD END ;
+
+    Context* = RECORD
+        nofonts, noflibs, nofclasses: INTEGER;
+        font: ARRAY 10 OF Fonts.Font;
+        lib: ARRAY 4 OF Library;
+        class: ARRAY 6 OF Modules.Command
+      END;
+
+    MethodDesc* = RECORD
+        module*, allocator*: Name;
+        new*: Modules.Command;
+        copy*: PROCEDURE (from, to: Object);
+        draw*, change*: PROCEDURE (obj: Object; VAR msg: Msg);
+        selectable*: PROCEDURE (obj: Object; x, y: INTEGER): BOOLEAN;
+        read*: PROCEDURE (obj: Object; VAR R: Files.Rider; VAR C: Context);
+        write*: PROCEDURE (obj: Object; cno: INTEGER; VAR R: Files.Rider; VAR C: Context);
+        print*: PROCEDURE (obj: Object; x, y: INTEGER)
+      END ;
+
+    LineDesc* = RECORD (ObjectDesc)
+        unused*: INTEGER
+      END ;
+
+    CaptionDesc* = RECORD (ObjectDesc)
+        pos*, len*: INTEGER
+      END ;
+
+    MacroDesc* = RECORD (ObjectDesc)
+        mac*: MacHead
+      END ;
+
+  VAR width*, res*: INTEGER;
+    new: Object;
+    T*: Texts.Text;  (*captions*)
+    LineMethod*, CapMethod*, MacMethod* : Method;
+    GetLib0: PROCEDURE (name: ARRAY OF CHAR; replace: BOOLEAN; VAR Lib: Library);
+
+    FirstLib: Library;
+    W, TW, XW: Texts.Writer;
+
+  PROCEDURE New*(obj: Object);
+  BEGIN new := obj
+  END New;
+
+  PROCEDURE Add*(G: Graph; obj: Object);
+  BEGIN obj.marked := FALSE; obj.selected := TRUE; obj.next := G.first;
+    G.first := obj; G.sel := obj; G.time := Oberon.Time(); G.changed := TRUE
+  END Add;
+
+  PROCEDURE ThisObj*(G: Graph; x, y: INTEGER): Object;
+    VAR obj: Object;
+  BEGIN obj := G.first;
+    WHILE (obj # NIL) & ~obj.do.selectable(obj, x ,y) DO obj := obj.next END ;
+    RETURN obj
+  END ThisObj;
+
+  PROCEDURE SelectObj*(G: Graph; obj: Object);
+  BEGIN
+    IF obj # NIL THEN obj.selected := TRUE; G.sel := obj; G.time := Oberon.Time() END
+  END SelectObj;
+
+  PROCEDURE SelectArea*(G: Graph; x0, y0, x1, y1: INTEGER);
+    VAR obj: Object; t: INTEGER;
+  BEGIN obj := G.first;
+    IF x1 < x0 THEN t := x0; x0 := x1; x1 := t END ;
+    IF y1 < y0 THEN t := y0; y0 := y1; y1 := t END ;
+    WHILE obj # NIL DO
+      IF (x0 <= obj.x) & (obj.x + obj.w <= x1) & (y0 <= obj.y) & (obj.y + obj.h <= y1) THEN
+        obj.selected := TRUE; G.sel := obj
+      END ;
+      obj := obj.next
+    END ;
+    IF G.sel # NIL THEN G.time := Oberon.Time() END
+  END SelectArea;
+
+  PROCEDURE Draw*(G: Graph; VAR M: Msg);
+    VAR obj: Object;
+  BEGIN obj := G.first;
+    WHILE obj # NIL DO obj.do.draw(obj, M); obj := obj.next END
+  END Draw;
+
+  PROCEDURE List*(G: Graph);
+    VAR obj: Object; tag: INTEGER;
+  BEGIN obj := G.first;
+    WHILE obj # NIL DO
+      Texts.Write(XW, 9X); Texts.WriteHex(XW, ORD(obj)); Texts.Write(XW, 9X);
+      Texts.WriteInt(XW, obj.x, 5); Texts.WriteInt(XW, obj.y, 5); Texts.WriteInt(XW, obj.w, 5); Texts.WriteInt(XW, obj.h, 5);
+      Texts.Write(XW, "/"); SYSTEM.GET(ORD(obj)-8, tag); Texts.WriteHex(XW, tag);
+      SYSTEM.GET(ORD(obj)-4, tag); Texts.WriteHex(XW, tag); Texts.WriteLn(XW); obj := obj.next
+    END ;
+    Texts.Append(Oberon.Log, XW.buf)
+  END List;
+
+  (*----------------procedures operating on selection -------------------*)
+
+  PROCEDURE Deselect*(G: Graph);
+    VAR obj: Object;
+  BEGIN obj := G.first; G.sel := NIL; G.time := 0;
+    WHILE obj # NIL DO obj.selected := FALSE; obj := obj.next END
+  END Deselect;
+
+  PROCEDURE DrawSel*(G: Graph; VAR M: Msg);
+    VAR obj: Object;
+  BEGIN obj := G.first;
+    WHILE obj # NIL DO
+      IF obj.selected THEN obj.do.draw(obj, M) END ;
+      obj := obj.next
+    END
+  END DrawSel;
+
+  PROCEDURE Change*(G: Graph; VAR M: Msg);
+    VAR obj: Object;
+  BEGIN obj := G.first; G.changed := TRUE;
+    WHILE obj # NIL DO
+      IF obj.selected THEN obj.do.change(obj, M) END ;
+      obj := obj.next
+    END
+  END Change;
+
+  PROCEDURE Move*(G: Graph; dx, dy: INTEGER);
+    VAR obj, ob0: Object; x0, x1, y0, y1: INTEGER;
+  BEGIN obj := G.first; G.changed := TRUE;
+    WHILE obj # NIL DO
+      IF obj.selected & ~(obj IS Caption) THEN
+        x0 := obj.x; x1 := obj.w + x0; y0 := obj.y; y1 := obj.h + y0;
+        IF dx = 0 THEN (*vertical move*)
+          ob0 := G.first;
+          WHILE ob0 # NIL DO
+            IF ~ob0.selected & (ob0 IS Line) & (x0 <= ob0.x) & (ob0.x <= x1) & (ob0.w < ob0.h) THEN
+              IF (y0 <= ob0.y) & (ob0.y <= y1) THEN
+                INC(ob0.y, dy); DEC(ob0.h, dy); ob0.marked := TRUE
+              ELSIF (y0 <= ob0.y + ob0.h) & (ob0.y + ob0.h <= y1) THEN
+                INC(ob0.h, dy); ob0.marked := TRUE
+              END
+            END ;
+            ob0 := ob0.next
+          END
+        ELSIF dy = 0 THEN (*horizontal move*)
+          ob0 := G.first;
+          WHILE ob0 # NIL DO
+            IF ~ob0.selected & (ob0 IS Line) & (y0 <= ob0.y) & (ob0.y <= y1) & (ob0.h < ob0.w) THEN
+              IF (x0 <= ob0.x) & (ob0.x <= x1) THEN
+                INC(ob0.x, dx); DEC(ob0.w, dx); ob0.marked := TRUE
+              ELSIF (x0 <= ob0.x + ob0.w) & (ob0.x + ob0.w <= x1) THEN
+                INC(ob0.w, dx); ob0.marked := TRUE
+              END
+            END ;
+            ob0 := ob0.next
+          END
+        END
+      END ;
+      obj := obj.next
+    END ;
+    obj := G.first; (*now move*)
+    WHILE obj # NIL DO
+      IF obj.selected THEN INC(obj.x, dx); INC(obj.y, dy) END ;
+      obj.marked := FALSE; obj := obj.next
+    END
+  END Move;
+
+  PROCEDURE Copy*(Gs, Gd: Graph; dx, dy: INTEGER);
+    VAR obj: Object;
+  BEGIN obj := Gs.first; Gd.changed := TRUE;
+    WHILE obj # NIL DO
+      IF obj.selected THEN
+        obj.do.new; obj.do.copy(obj, new); INC(new.x, dx); INC(new.y, dy);
+        obj.selected := FALSE; Add(Gd, new)
+      END ;
+      obj := obj.next
+    END ;
+    new := NIL
+  END Copy;
+
+  PROCEDURE Delete*(G: Graph);
+    VAR obj, pred: Object;
+  BEGIN G.sel := NIL; G.changed := TRUE; obj := G.first;
+    WHILE (obj # NIL) & obj.selected DO obj := obj.next END ;
+    G.first := obj;
+    IF obj # NIL THEN
+      pred := obj; obj := obj.next;
+      WHILE obj # NIL DO
+        IF obj.selected THEN pred.next := obj.next ELSE pred := obj END ;
+        obj := obj.next
+      END
+    END
+  END Delete;
+
+  (* ---------------------- Storing ----------------------- *)
+
+  PROCEDURE WMsg(s0, s1: ARRAY OF CHAR);
+  BEGIN Texts.WriteString(W, s0); Texts.WriteString(W, s1);
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END WMsg;
+
+  PROCEDURE InitContext(VAR C: Context);
+  BEGIN C.nofonts := 0; C.noflibs := 0; C.nofclasses := 4;
+    C.class[1] := LineMethod.new; C.class[2] := CapMethod.new; C.class[3] := MacMethod.new
+  END InitContext;
+
+  PROCEDURE FontNo*(VAR W: Files.Rider; VAR C: Context; fnt: Fonts.Font): INTEGER;
+    VAR fno: INTEGER;
+  BEGIN fno := 0;
+    WHILE (fno < C.nofonts) & (C.font[fno] # fnt) DO INC(fno) END ;
+    IF fno = C.nofonts THEN
+      Files.WriteByte(W, 0); Files.WriteByte(W, 0); Files.WriteByte(W, fno);
+      Files.WriteString(W, fnt.name); C.font[fno] := fnt; INC(C.nofonts)
+    END ;
+    RETURN fno
+  END FontNo;
+
+  PROCEDURE StoreElems(VAR W: Files.Rider; VAR C: Context; obj: Object);
+    VAR cno: INTEGER;
+  BEGIN
+    WHILE obj # NIL DO
+      cno := 1;
+      WHILE (cno < C.nofclasses) & (obj.do.new # C.class[cno]) DO INC(cno) END ;
+      IF cno = C.nofclasses THEN
+        Files.WriteByte(W, 0); Files.WriteByte(W, 2); Files.WriteByte(W, cno);
+        Files.WriteString(W, obj.do.module); Files.WriteString(W, obj.do.allocator);
+        C.class[cno] := obj.do.new; INC(C.nofclasses)
+      END ;
+      obj.do.write(obj, cno, W, C); obj := obj.next
+    END ;
+    Files.WriteByte(W, 255)
+  END StoreElems;
+
+  PROCEDURE Store*(G: Graph; VAR W: Files.Rider);
+    VAR C: Context;
+  BEGIN InitContext(C); StoreElems(W, C, G.first); G.changed := FALSE
+  END Store;
+
+  PROCEDURE WriteObj*(VAR W: Files.Rider; cno: INTEGER; obj: Object);
+  BEGIN Files.WriteByte(W, cno); Files.WriteInt(W, obj.y * 10000H + obj.x);
+    Files.WriteInt(W, obj.h * 10000H + obj.w); Files.WriteByte(W, obj.col)
+  END WriteObj;
+
+  PROCEDURE WriteFile*(G: Graph; name: ARRAY OF CHAR);
+    VAR F: Files.File; W: Files.Rider; C: Context;
+  BEGIN F := Files.New(name); Files.Set(W, F, 0); Files.Write(W, GraphFileId);
+    InitContext(C); StoreElems(W, C, G.first); Files.Register(F)
+  END WriteFile;
+
+  PROCEDURE Print*(G: Graph; x0, y0: INTEGER);
+    VAR obj: Object;
+  BEGIN obj := G.first;
+    WHILE obj # NIL DO obj.do.print(obj, x0, y0); obj := obj.next END
+  END Print;
+
+  (* ---------------------- Loading ------------------------ *)
+
+  PROCEDURE GetClass*(module, allocator: ARRAY OF CHAR; VAR com: Modules.Command);
+    VAR mod: Modules.Module;
+  BEGIN Modules.Load(module, mod);
+    IF mod # NIL THEN
+      com := Modules.ThisCommand(mod, allocator);
+      IF com = NIL THEN WMsg(allocator, " unknown") END
+    ELSE WMsg(module, " not available"); com := NIL
+    END
+  END GetClass;
+
+  PROCEDURE Font*(VAR R: Files.Rider; VAR C: Context): Fonts.Font;
+    VAR fno: BYTE;
+  BEGIN Files.ReadByte(R, fno); RETURN C.font[fno]
+  END Font;
+
+  PROCEDURE ReadObj(VAR R: Files.Rider; obj: Object);
+    VAR xy, wh: INTEGER; dmy: BYTE;
+  BEGIN Files.ReadInt(R, xy); obj.y := xy DIV 10000H; obj.x := xy * 10000H DIV 10000H;
+    Files.ReadInt(R, wh); obj.h := wh DIV 10000H; obj.w := wh * 10000H DIV 10000H;
+    Files.ReadByte(R, obj.col)
+  END ReadObj;
+
+  PROCEDURE LoadElems(VAR R: Files.Rider; VAR C: Context; VAR fobj: Object);
+    VAR cno, m, n, len: BYTE; pos: INTEGER;
+      obj: Object;
+      fnt: Fonts.Font;
+      name, name1: ARRAY 32 OF CHAR;
+  BEGIN obj := NIL; Files.ReadByte(R, cno);
+    WHILE ~R.eof & (cno < 255) DO
+      IF cno = 0 THEN
+        Files.ReadByte(R, m); Files.ReadByte(R, n); Files.ReadString(R, name);
+        IF m = 0 THEN fnt := Fonts.This(name); C.font[n] := fnt
+        ELSIF m = 1 THEN GetLib0(name, FALSE, C.lib[n])
+        ELSIF m = 2 THEN Files.ReadString(R, name1); GetClass(name, name1, C.class[n])
+        END
+      ELSIF C.class[cno] # NIL THEN
+        C.class[cno];
+        ReadObj(R, new);
+        new.selected := FALSE; new.marked := FALSE; new.next := obj; obj := new;
+        new.do.read(new, R, C)
+      ELSE ReadObj(R, new); Files.ReadByte(R, len); pos := Files.Pos(R); Files.Set(R, Files.Base(R), pos + len)
+      END ;
+      Files.ReadByte(R, cno)
+    END ;
+    new := NIL; fobj := obj
+  END LoadElems;
+
+  PROCEDURE Load*(G: Graph; VAR R: Files.Rider);
+    VAR C: Context;
+  BEGIN G.sel := NIL; InitContext(C); LoadElems(R, C, G.first)
+  END Load;
+
+  PROCEDURE Open*(G: Graph; name: ARRAY OF CHAR);
+    VAR tag: CHAR;
+      F: Files.File; R: Files.Rider; C: Context;
+  BEGIN G.first := NIL; G.sel := NIL; G.time := 0; G.changed := FALSE; F := Files.Old(name);
+    IF F # NIL THEN
+      Files.Set(R, F, 0); Files.Read(R, tag);
+      IF tag = GraphFileId THEN InitContext(C); LoadElems(R, C, G.first); res := 0 ELSE res := 1 END
+    ELSE res := 2
+    END
+  END Open;
+
+  PROCEDURE SetWidth*(w: INTEGER);
+  BEGIN width := w
+  END SetWidth;
+
+  (* --------------------- Macros / Libraries ----------------------- *)
+
+  PROCEDURE GetLib*(name: ARRAY OF CHAR; replace: BOOLEAN; VAR Lib: Library);
+    VAR i, wh: INTEGER; ch: CHAR;
+      L: Library; mh: MacHead; obj: Object;
+      F: Files.File; R: Files.Rider; C: Context;
+      Lname, Fname: ARRAY 32 OF CHAR;
+  BEGIN L := FirstLib; i := 0;
+    WHILE (L # NIL) & (L.name # name) DO L := L.next END ;
+    IF L = NIL THEN
+      (*load library from file*) i := 0;
+      WHILE name[i] > 0X DO Fname[i] := name[i]; INC(i) END ;
+      Fname[i] := "."; Fname[i+1] := "L"; Fname[i+2] := "i"; Fname[i+3] := "b"; Fname[i+4] := 0X;
+      F := Files.Old(Fname);
+      IF F # NIL THEN
+         WMsg("loading ", Fname); Files.Set(R, F, 0); Files.Read(R, ch);
+        IF ch = LibFileId THEN
+          IF L = NIL THEN NEW(L); L.name := name; L.next := FirstLib; FirstLib := L END ;
+          L.first := NIL; InitContext(C); 
+          LoadElems(R, C, obj);
+          WHILE obj # NIL DO
+            NEW(mh); mh.first := obj;
+            Files.ReadInt(R, wh); mh.h := wh DIV 10000H MOD 10000H; mh.w := wh MOD 10000H;
+            Files.ReadString(R, mh.name);
+            mh.lib := L; mh.next := L.first; L.first := mh; LoadElems(R, C, obj)
+          END ;
+        ELSE L := NIL
+        END
+      ELSE L := NIL
+      END
+    END ;
+    Lib := L
+  END GetLib;
+
+  PROCEDURE NewLib*(Lname: ARRAY OF CHAR): Library;
+    VAR L: Library;
+  BEGIN NEW(L); L.name := Lname; L.first := NIL;
+    L.next := FirstLib; FirstLib := L; RETURN L
+  END NewLib;
+
+  PROCEDURE StoreLib*(L: Library; Fname: ARRAY OF CHAR);
+    VAR i: INTEGER;
+      mh: MacHead;
+      F: Files.File; W: Files.Rider;
+      C: Context;
+      Gname: ARRAY 32 OF CHAR;
+  BEGIN L := FirstLib;
+    WHILE (L # NIL) & (L.name # Fname) DO L := L.next END ;
+    IF L # NIL THEN i := 0;
+      WHILE Fname[i] > 0X DO Gname[i] := Fname[i]; INC(i) END ;
+      Gname[i] := "."; Gname[i+1] := "L"; Gname[i+2] := "i"; Gname[i+3] := "b"; Gname[i+4] := 0X;
+      F := Files.New(Gname); Files.Set(W, F, 0); Files.Write(W, LibFileId);
+      InitContext(C); mh := L.first;
+      WHILE mh # NIL DO
+        StoreElems(W, C, mh.first); Files.WriteInt(W, mh.h * 10000H + mh.w);
+        Files.WriteString(W, mh.name); mh := mh.next
+      END ;
+      Files.WriteByte(W, 255); Files.Register(F)
+    ELSE Texts.WriteString(TW, Fname); Texts.WriteString(TW, " not found");
+      Texts.WriteLn(TW); Texts.Append(Oberon.Log, TW.buf)
+    END
+  END StoreLib;
+
+  PROCEDURE RemoveLibraries*;
+  BEGIN FirstLib := NIL
+  END RemoveLibraries;
+
+  PROCEDURE ThisMac*(L: Library; Mname: ARRAY OF CHAR): MacHead;
+    VAR mh: MacHead;
+  BEGIN mh := L.first;
+    WHILE (mh # NIL) & (mh.name # Mname) DO mh := mh.next END ;
+    RETURN mh
+  END ThisMac;
+
+  PROCEDURE DrawMac*(mh: MacHead; VAR M: Msg);
+    VAR elem: Object;
+  BEGIN elem := mh.first;
+    WHILE elem # NIL DO elem.do.draw(elem, M); elem := elem.next END
+  END DrawMac;
+
+  (* -------------------- Procedures for designing macros---------------------*)
+
+  PROCEDURE OpenMac*(mh: MacHead; G: Graph; x, y: INTEGER);
+    VAR obj: Object;
+  BEGIN obj := mh.first;
+    WHILE obj # NIL DO
+      obj.do.new; obj.do.copy(obj, new); INC(new.x, x); INC(new.y, y); new.selected := TRUE;
+      Add(G, new); obj := obj.next
+    END ;
+    new := NIL
+  END OpenMac;
+
+  PROCEDURE MakeMac*(G: Graph; VAR head: MacHead);
+    VAR x0, y0, x1, y1: INTEGER;
+      obj, last: Object;
+      mh: MacHead;
+  BEGIN obj := G.first; last := NIL; x0 := 1024; x1 := 0; y0 := 1024; y1 := 0;
+      WHILE obj # NIL DO
+        IF obj.selected THEN
+          obj.do.new; obj.do.copy(obj, new); new.next := last; new.selected := FALSE; last := new;
+          IF obj.x < x0 THEN x0 := obj.x END ;
+          IF obj.x + obj.w > x1 THEN x1 := obj.x + obj.w END ;
+          IF obj.y < y0 THEN y0 := obj.y END ;
+          IF obj.y + obj.h > y1 THEN y1 := obj.y + obj.h END
+        END ;
+        obj := obj.next
+      END ;
+      obj := last;
+      WHILE obj # NIL DO
+        obj.x := obj.x - x0; obj.y := obj.y - y0; obj := obj.next
+      END ;
+      NEW(mh); mh.w := x1 - x0; mh.h := y1 - y0; mh.first := last; mh.ext := NIL;
+      new := NIL; head := mh
+  END MakeMac;
+
+  PROCEDURE InsertMac*(mh: MacHead; L: Library; VAR new: BOOLEAN);
+    VAR mh1: MacHead;
+  BEGIN mh.lib := L; mh1 := L.first;
+    WHILE (mh1 # NIL) & (mh1.name # mh.name) DO mh1 := mh1.next END ;
+    IF mh1 = NIL THEN
+      new := TRUE; mh.next := L.first; L.first := mh
+    ELSE
+      new := FALSE; mh1.w := mh.w; mh1.h := mh.h; mh1.first := mh.first
+    END
+  END InsertMac;
+
+  (* ---------------------------- Line Methods -----------------------------*)
+
+  PROCEDURE NewLine;
+    VAR line: Line;
+  BEGIN NEW(line); new := line; line.do := LineMethod
+  END NewLine;
+
+  PROCEDURE CopyLine(src, dst: Object);
+  BEGIN dst.x := src.x; dst.y := src.y; dst.w := src.w; dst.h := src.h; dst.col := src.col
+  END CopyLine;
+
+  PROCEDURE ChangeLine(obj: Object; VAR M: Msg);
+  BEGIN
+    CASE M OF
+    WidMsg:
+      IF obj.w < obj.h THEN
+        IF obj.w <= 7 THEN obj.w := M.w END
+      ELSIF obj.h <= 7 THEN obj.h := M.w
+      END |
+    ColorMsg: obj.col := M.col
+    END
+  END ChangeLine;
+
+  PROCEDURE LineSelectable(obj: Object; x, y: INTEGER): BOOLEAN;
+  BEGIN
+    RETURN (obj.x <= x) & (x < obj.x + obj.w) & (obj.y <= y) & (y < obj.y + obj.h)
+  END LineSelectable;
+
+  PROCEDURE ReadLine(obj: Object; VAR R: Files.Rider; VAR C: Context);
+  BEGIN
+  END ReadLine;
+
+  PROCEDURE WriteLine(obj: Object; cno: INTEGER; VAR W: Files.Rider; VAR C: Context);
+  BEGIN WriteObj(W, cno, obj)
+  END WriteLine;
+
+(*PROCEDURE PrintLine(obj: Object; x, y: INTEGER);
+    VAR w, h: INTEGER;
+  BEGIN w := obj.w * 2; h := obj.h * 2;
+    IF w < h THEN h := 2*h ELSE w := 2*w END ;
+    Printer.ReplConst(obj.x * 4 + x, obj.y *4 + y, w, h)
+  END PrintLine; *)
+
+  (* ---------------------- Caption Methods ------------------------ *)
+
+  PROCEDURE NewCaption;
+    VAR cap: Caption;
+  BEGIN NEW(cap); new := cap; cap.do := CapMethod
+  END NewCaption;
+
+  PROCEDURE CopyCaption(src, dst: Object);
+    VAR ch: CHAR; R: Texts.Reader;
+  BEGIN
+    dst.x := src.x; dst.y := src.y; dst.w := src.w; dst.h := src.h; dst.col := src.col;
+    dst(Caption).pos := T.len + 1; dst(Caption).len := src(Caption).len;
+    Texts.Write(TW, 0DX); Texts.OpenReader(R, T, src(Caption).pos);
+    Texts.Read(R, ch); TW.fnt := R.fnt;
+    WHILE ch > 0DX DO Texts.Write(TW, ch); Texts.Read(R, ch) END ;
+    Texts.Append(T, TW.buf)
+  END CopyCaption;
+
+  PROCEDURE ChangeCaption(obj: Object;  VAR M: Msg);
+    VAR dx, x1, dy, y1, w, w1, h1, len: INTEGER;
+      pos: LONGINT;
+      ch: CHAR; patadr: INTEGER; fnt: Fonts.Font;
+      R: Texts.Reader;
+  BEGIN
+    CASE M OF
+    FontMsg: fnt := M(FontMsg).fnt; w := 0; len := 0; pos := obj(Caption).pos;
+      Texts.OpenReader(R, T, pos); Texts.Read(R, ch); dy := R.fnt.minY;
+      WHILE ch > 0DX DO
+        Fonts.GetPat(fnt, ch, dx, x1, y1, w1, h1, patadr);
+        INC(w, dx); INC(len); Texts.Read(R, ch)
+      END ;
+      INC(obj.y, fnt.minY-dy); obj.w := w; obj.h := fnt.height;
+      Texts.ChangeLooks(T, pos, pos+len, {0}, fnt, 0 , 0) |
+    ColorMsg: obj.col := M(ColorMsg).col
+    END
+  END ChangeCaption;
+
+  PROCEDURE CaptionSelectable(obj: Object; x, y: INTEGER): BOOLEAN;
+  BEGIN
+    RETURN (obj.x <= x) & (x < obj.x + obj.w) & (obj.y <= y) & (y < obj.y + obj.h)
+  END CaptionSelectable;
+
+  PROCEDURE ReadCaption(obj: Object; VAR R: Files.Rider; VAR C: Context);
+    VAR ch: CHAR; fno: BYTE; len: INTEGER;
+  BEGIN obj(Caption).pos := T.len + 1; Texts.Write(TW, 0DX);
+    Files.ReadByte(R, fno); TW.fnt := C.font[fno]; len := 0; Files.Read(R, ch);
+    WHILE ch > 0DX DO Texts.Write(TW, ch); INC(len); Files.Read(R, ch) END ;
+    obj(Caption).len := len; Texts.Append(T, TW.buf)
+  END ReadCaption;
+
+  PROCEDURE WriteCaption(obj: Object; cno: INTEGER; VAR W: Files.Rider; VAR C: Context);
+    VAR ch: CHAR; fno: BYTE;
+      TR: Texts.Reader;
+  BEGIN
+    IF obj(Caption).len > 0 THEN
+      Texts.OpenReader(TR, T, obj(Caption).pos); Texts.Read(TR, ch);
+      fno := FontNo(W, C, TR.fnt);
+      WriteObj(W, cno, obj); Files.WriteByte(W, fno);
+      WHILE ch > 0DX DO  Files.Write(W, ch); Texts.Read(TR, ch) END ;
+      Files.Write(W, 0X)
+    END
+  END WriteCaption;
+
+(*  PROCEDURE PrintCaption(obj: Object; x, y: INTEGER);
+    VAR fnt: Fonts.Font;
+      i: INTEGER; ch: CHAR;
+      R: Texts.Reader;
+      s: ARRAY 128 OF CHAR;
+  BEGIN
+    IF obj(Caption).len > 0 THEN
+      Texts.OpenReader(R, T, obj(Caption).pos); Texts.Read(R, ch);
+      fnt := R.fnt; DEC(y, fnt.minY*4); i := 0;
+      WHILE ch >= " " DO s[i] := ch; INC(i); Texts.Read(R, ch) END ;
+      s[i] := 0X;
+      IF i > 0 THEN Printer.String(obj.x*4 + x, obj.y*4 + y, s, fnt.name) END
+    END
+  END PrintCaption; *)
+
+  (* ---------------------- Macro Methods ------------------------ *)
+
+  PROCEDURE NewMacro;
+    VAR mac: Macro;
+  BEGIN NEW(mac); new := mac; mac.do := MacMethod
+  END NewMacro;
+
+  PROCEDURE CopyMacro(src, dst: Object);
+  BEGIN dst.x := src.x; dst.y := src.y; dst.w := src.w; dst.h := src.h;
+    dst.col := src.col; dst(Macro).mac := src(Macro).mac
+  END CopyMacro;
+
+  PROCEDURE ChangeMacro(obj: Object; VAR M: Msg);
+  BEGIN
+    CASE M OF ColorMsg: obj.col := M.col END
+  END ChangeMacro;
+
+  PROCEDURE MacroSelectable(obj: Object; x, y: INTEGER): BOOLEAN;
+  BEGIN
+    RETURN (obj.x <= x) & (x <= obj.x + 8) & (obj.y <= y) & (y <= obj.y + 8)
+  END MacroSelectable;
+
+  PROCEDURE ReadMacro(obj: Object; VAR R: Files.Rider; VAR C: Context);
+    VAR lno: BYTE; name: ARRAY 32 OF CHAR;
+  BEGIN Files.ReadByte(R, lno);
+    Files.ReadString(R, name); obj(Macro).mac := ThisMac(C.lib[lno], name)
+  END ReadMacro;
+
+  PROCEDURE WriteMacro(obj: Object; cno: INTEGER; VAR W1: Files.Rider; VAR C: Context);
+    VAR lno: INTEGER;
+  BEGIN lno := 0;
+    WHILE (lno < C.noflibs) & (obj(Macro).mac.lib # C.lib[lno]) DO INC(lno) END ;
+    IF lno = C.noflibs THEN
+      Files.WriteByte(W1, 0); Files.WriteByte(W1, 1); Files.WriteByte(W1, lno);
+      Files.WriteString(W1, obj(Macro).mac.lib.name); C.lib[lno] := obj(Macro).mac.lib; INC(C.noflibs)
+    END ;
+    WriteObj(W1, cno, obj); Files.WriteByte(W1, lno); Files.WriteString(W1, obj(Macro).mac.name)
+  END WriteMacro;
+
+(*  PROCEDURE PrintMacro(obj: Object; x, y: INTEGER);
+    VAR elem: Object; mh: MacHead;
+  BEGIN mh := obj(Macro).mac;
+    IF mh # NIL THEN elem := mh.first;
+      WHILE elem # NIL DO elem.do.print(elem, obj.x*4 + x, obj.y*4 + y); elem := elem.next END
+    END
+  END PrintMacro; *)
+
+  PROCEDURE Notify(T: Texts.Text; op: INTEGER; beg, end: LONGINT);
+  BEGIN
+  END Notify;
+
+  PROCEDURE InstallDrawMethods*(drawLine, drawCaption, drawMacro: PROCEDURE (obj: Object; VAR msg: Msg));
+  BEGIN LineMethod.draw := drawLine; CapMethod.draw := drawCaption; MacMethod.draw := drawMacro
+  END InstallDrawMethods;
+
+BEGIN Texts.OpenWriter(W); Texts.OpenWriter(TW);  Texts.OpenWriter(XW);
+  width := 1; GetLib0 := GetLib;
+  NEW(T); Texts.Open(T, ""); T.notify := Notify;
+  NEW(LineMethod); LineMethod.new := NewLine; LineMethod.copy := CopyLine;
+  LineMethod.selectable := LineSelectable; LineMethod.change := ChangeLine;
+  LineMethod.read := ReadLine; LineMethod.write := WriteLine; (*LineMethod.print := PrintLine;*)
+  NEW(CapMethod); CapMethod.new := NewCaption; CapMethod.copy := CopyCaption;
+  CapMethod.selectable := CaptionSelectable; CapMethod.change := ChangeCaption;
+  CapMethod.read := ReadCaption; CapMethod.write := WriteCaption; (*CapMethod.print := PrintCaption;*)
+  NEW(MacMethod); MacMethod.new := NewMacro; MacMethod.copy := CopyMacro;
+  MacMethod.selectable := MacroSelectable; MacMethod.change := ChangeMacro;
+  MacMethod.read := ReadMacro; MacMethod.write := WriteMacro; (*MacMethod.print := PrintMacro*)
 END Graphics.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Hilbert.Mod.txt

@@ -1,86 +1,86 @@
-MODULE Hilbert;  (*NW 8.1.2013  for RISC*)
-  IMPORT Display, Viewers, Texts, Oberon, MenuViewers, TextFrames;
-
-  CONST Menu = "System.Close  System.Copy  System.Grow";
-
-  VAR x, y, d: INTEGER;
-    A, B, C, D: PROCEDURE (i: INTEGER);
-
-  PROCEDURE E;
-  BEGIN Display.ReplConst(Display.white, x, y, d, 1, Display.paint); INC(x, d)
-  END E;
-
-  PROCEDURE N;
-  BEGIN Display.ReplConst(Display.white, x, y, 1, d, Display.paint); INC(y, d)
-  END N;
-
-  PROCEDURE W;
-  BEGIN DEC(x, d); Display.ReplConst(Display.white, x, y, d, 1, Display.paint)
-  END W;
-
-  PROCEDURE S;
-  BEGIN DEC(y, d); Display.ReplConst(Display.white, x, y, 1, d, Display.paint)
-  END S;
-
-  PROCEDURE HA(i: INTEGER);
-  BEGIN
-    IF i > 0 THEN D(i-1); W; A(i-1); S; A(i-1); E; B(i-1) END
-  END HA;
-
-  PROCEDURE HB(i: INTEGER);
-  BEGIN
-    IF i > 0 THEN C(i-1); N; B(i-1); E; B(i-1); S; A(i-1) END
-  END HB;
-
-  PROCEDURE HC(i: INTEGER);
-  BEGIN
-    IF i > 0 THEN B(i-1); E; C(i-1); N; C(i-1); W; D(i-1) END
-  END HC;
-
-  PROCEDURE HD(i: INTEGER);
-  BEGIN
-    IF i > 0 THEN A(i-1); S; D(i-1); W; D(i-1); N; C(i-1) END
-  END HD;
-
-  PROCEDURE DrawHilbert(F: Display.Frame);
-    VAR k, n, w, x0, y0: INTEGER;
-  BEGIN k := 0; d := 8;
-    IF F.W < F.H THEN w := F.W ELSE w := F.H END ;
-    WHILE d*2 < w DO d := d*2; INC(k) END ;
-    Display.ReplConst(Display.black, F.X, F.Y, F.W, F.H, Display.replace);
-    x0 := F.W DIV 2; y0 := F.H DIV 2; n := 0;
-    WHILE n < k DO
-      d := d DIV 2; INC(x0, d DIV 2); INC(y0, d DIV 2);
-      x := F.X + x0; y := F.Y + y0; INC(n); HA(n)
-    END
-  END DrawHilbert;
-
-  PROCEDURE Handler(F: Display.Frame; VAR M: Display.FrameMsg);
-    VAR F0: Display.Frame;
-  BEGIN
-    IF M IS Oberon.InputMsg THEN
-      IF M(Oberon.InputMsg).id = Oberon.track THEN
-        Oberon.DrawMouseArrow(M(Oberon.InputMsg).X, M(Oberon.InputMsg).Y)
-      END
-    ELSIF M IS MenuViewers.ModifyMsg THEN
-      F.Y := M(MenuViewers.ModifyMsg).Y; F.H := M(MenuViewers.ModifyMsg).H; DrawHilbert(F)
-    ELSIF M IS Oberon.ControlMsg THEN
-      IF M(Oberon.ControlMsg).id = Oberon.neutralize THEN Oberon.RemoveMarks(F.X, F.Y, F.W, F.H) END
-    ELSIF M IS Oberon.CopyMsg THEN
-      NEW(F0); F0^ := F^; M(Oberon.CopyMsg).F := F0
-    END
-  END Handler;
-
-  PROCEDURE New(): Display.Frame;
-    VAR F: Display.Frame;
-  BEGIN NEW(F); F.handle := Handler; RETURN F
-  END New;
-
-  PROCEDURE Draw*;
-    VAR V: Viewers.Viewer; X, Y: INTEGER;
-  BEGIN Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
-    V := MenuViewers.New(TextFrames.NewMenu("Hilbert", Menu), New(), TextFrames.menuH, X, Y)
-  END Draw;
-  
-BEGIN A := HA; B := HB; C := HC; D := HD
-END Hilbert.
+MODULE Hilbert;  (*NW 8.1.2013  for RISC*)
+  IMPORT Display, Viewers, Texts, Oberon, MenuViewers, TextFrames;
+
+  CONST Menu = "System.Close  System.Copy  System.Grow";
+
+  VAR x, y, d: INTEGER;
+    A, B, C, D: PROCEDURE (i: INTEGER);
+
+  PROCEDURE E;
+  BEGIN Display.ReplConst(Display.white, x, y, d, 1, Display.paint); INC(x, d)
+  END E;
+
+  PROCEDURE N;
+  BEGIN Display.ReplConst(Display.white, x, y, 1, d, Display.paint); INC(y, d)
+  END N;
+
+  PROCEDURE W;
+  BEGIN DEC(x, d); Display.ReplConst(Display.white, x, y, d, 1, Display.paint)
+  END W;
+
+  PROCEDURE S;
+  BEGIN DEC(y, d); Display.ReplConst(Display.white, x, y, 1, d, Display.paint)
+  END S;
+
+  PROCEDURE HA(i: INTEGER);
+  BEGIN
+    IF i > 0 THEN D(i-1); W; A(i-1); S; A(i-1); E; B(i-1) END
+  END HA;
+
+  PROCEDURE HB(i: INTEGER);
+  BEGIN
+    IF i > 0 THEN C(i-1); N; B(i-1); E; B(i-1); S; A(i-1) END
+  END HB;
+
+  PROCEDURE HC(i: INTEGER);
+  BEGIN
+    IF i > 0 THEN B(i-1); E; C(i-1); N; C(i-1); W; D(i-1) END
+  END HC;
+
+  PROCEDURE HD(i: INTEGER);
+  BEGIN
+    IF i > 0 THEN A(i-1); S; D(i-1); W; D(i-1); N; C(i-1) END
+  END HD;
+
+  PROCEDURE DrawHilbert(F: Display.Frame);
+    VAR k, n, w, x0, y0: INTEGER;
+  BEGIN k := 0; d := 8;
+    IF F.W < F.H THEN w := F.W ELSE w := F.H END ;
+    WHILE d*2 < w DO d := d*2; INC(k) END ;
+    Display.ReplConst(Display.black, F.X, F.Y, F.W, F.H, Display.replace);
+    x0 := F.W DIV 2; y0 := F.H DIV 2; n := 0;
+    WHILE n < k DO
+      d := d DIV 2; INC(x0, d DIV 2); INC(y0, d DIV 2);
+      x := F.X + x0; y := F.Y + y0; INC(n); HA(n)
+    END
+  END DrawHilbert;
+
+  PROCEDURE Handler(F: Display.Frame; VAR M: Display.FrameMsg);
+    VAR F0: Display.Frame;
+  BEGIN
+    IF M IS Oberon.InputMsg THEN
+      IF M(Oberon.InputMsg).id = Oberon.track THEN
+        Oberon.DrawMouseArrow(M(Oberon.InputMsg).X, M(Oberon.InputMsg).Y)
+      END
+    ELSIF M IS MenuViewers.ModifyMsg THEN
+      F.Y := M(MenuViewers.ModifyMsg).Y; F.H := M(MenuViewers.ModifyMsg).H; DrawHilbert(F)
+    ELSIF M IS Oberon.ControlMsg THEN
+      IF M(Oberon.ControlMsg).id = Oberon.neutralize THEN Oberon.RemoveMarks(F.X, F.Y, F.W, F.H) END
+    ELSIF M IS Oberon.CopyMsg THEN
+      NEW(F0); F0^ := F^; M(Oberon.CopyMsg).F := F0
+    END
+  END Handler;
+
+  PROCEDURE New(): Display.Frame;
+    VAR F: Display.Frame;
+  BEGIN NEW(F); F.handle := Handler; RETURN F
+  END New;
+
+  PROCEDURE Draw*;
+    VAR V: Viewers.Viewer; X, Y: INTEGER;
+  BEGIN Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
+    V := MenuViewers.New(TextFrames.NewMenu("Hilbert", Menu), New(), TextFrames.menuH, X, Y)
+  END Draw;
+  
+BEGIN A := HA; B := HB; C := HC; D := HD
+END Hilbert.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Input.Mod.txt

@@ -1,79 +1,79 @@
-MODULE Input; (*NW 5.10.86 / 15.11.90 Ceres-2; PDR 21.4.12 / NW 15.5.2013 Ceres-4*)
-  IMPORT SYSTEM;
-
-  CONST msAdr = -40; kbdAdr = -36;
-  VAR kbdCode: BYTE; (*last keyboard code read*)
-    Recd, Up, Shift, Ctrl, Ext: BOOLEAN;
-    KTabAdr: INTEGER;  (*keyboard code translation table*)
-    MW, MH, MX, MY: INTEGER; (*mouse limits and coords*)
-    MK: SET; (*mouse keys*)
-
-(*FIFO implemented in hardware, because every read must be handled,
-  including tracking the state of the Shift and Ctrl keys*)
-  
-  PROCEDURE Peek();
-  BEGIN
-    IF SYSTEM.BIT(msAdr, 28) THEN
-      SYSTEM.GET(kbdAdr, kbdCode);
-      IF kbdCode = 0F0H THEN Up := TRUE
-      ELSIF kbdCode = 0E0H THEN Ext := TRUE
-      ELSE
-        IF (kbdCode = 12H) OR (kbdCode = 59H) THEN (*shift*) Shift := ~Up
-        ELSIF kbdCode = 14H THEN (*ctrl*) Ctrl := ~Up
-        ELSIF ~Up THEN Recd := TRUE (*real key going down*)
-        END ;
-        Up := FALSE; Ext := FALSE
-      END
-    END;
-  END Peek;
-
-  PROCEDURE Available*(): INTEGER;
-  BEGIN Peek();
-    RETURN ORD(Recd)
-  END Available;
-
-  PROCEDURE Read*(VAR ch: CHAR);
-  BEGIN
-    WHILE ~Recd DO Peek() END ;
-    IF Shift OR Ctrl THEN INC(kbdCode, 80H) END; (*ctrl implies shift*)
-  (* ch := kbdTab[kbdCode]; *)
-    SYSTEM.GET(KTabAdr + kbdCode, ch);
-    IF Ctrl THEN ch := CHR(ORD(ch) MOD 20H) END;
-    Recd := FALSE
-  END Read;
-
-  PROCEDURE Mouse*(VAR keys: SET; VAR x, y: INTEGER);
-    VAR w: INTEGER;
-  BEGIN SYSTEM.GET(msAdr, w);
-    keys := SYSTEM.VAL(SET, w DIV 1000000H MOD 8);
-    x := w MOD 400H; y := (w DIV 1000H) MOD 400H;
-    IF y >= MH THEN y := MH-1 END
-  END Mouse;
-
-  PROCEDURE SetMouseLimits*(w, h: INTEGER);
-  BEGIN MW := w; MH := h
-  END SetMouseLimits;
-
-  PROCEDURE Init*;
-  BEGIN Up := FALSE; Shift := FALSE; Ctrl := FALSE; Recd := FALSE;
-    KTabAdr := SYSTEM.ADR($
-      00 00 00 00 00 1A 00 00  00 00 00 00 00 09 60 00
-      00 00 00 00 00 71 31 00  00 00 7A 73 61 77 32 00
-      00 63 78 64 65 34 33 00  00 20 76 66 74 72 35 00
-      00 6E 62 68 67 79 36 00  00 00 6D 6A 75 37 38 00
-      00 2C 6B 69 6F 30 39 00  00 2E 2F 6C 3B 70 2D 00
-      00 00 27 00 5B 3D 00 00  00 00 0D 5D 00 5C 00 00
-      00 00 00 00 00 00 08 00  00 00 00 00 00 00 00 00
-      00 7F 00 00 00 00 1B 00  00 00 00 00 00 00 00 00
-      00 00 00 00 00 00 00 00  00 00 00 00 00 09 7E 00
-      00 00 00 00 00 51 21 00  00 00 5A 53 41 57 40 00
-      00 43 58 44 45 24 23 00  00 20 56 46 54 52 25 00
-      00 4E 42 48 47 59 5E 00  00 00 4D 4A 55 26 2A 00
-      00 3C 4B 49 4F 29 28 00  00 3E 3F 4C 3A 50 5F 00
-      00 00 22 00 7B 2B 00 00  00 00 0D 7D 00 7C 00 00
-      00 00 00 00 00 00 08 00  00 00 00 00 00 00 00 00
-      00 7F 00 00 00 00 1B 00  00 00 00 00 00 00 00 00$)
-  END Init;
-
-BEGIN Init
-END Input.
+MODULE Input; (*NW 5.10.86 / 15.11.90 Ceres-2; PDR 21.4.12 / NW 15.5.2013 Ceres-4*)
+  IMPORT SYSTEM;
+
+  CONST msAdr = -40; kbdAdr = -36;
+  VAR kbdCode: BYTE; (*last keyboard code read*)
+    Recd, Up, Shift, Ctrl, Ext: BOOLEAN;
+    KTabAdr: INTEGER;  (*keyboard code translation table*)
+    MW, MH, MX, MY: INTEGER; (*mouse limits and coords*)
+    MK: SET; (*mouse keys*)
+
+(*FIFO implemented in hardware, because every read must be handled,
+  including tracking the state of the Shift and Ctrl keys*)
+  
+  PROCEDURE Peek();
+  BEGIN
+    IF SYSTEM.BIT(msAdr, 28) THEN
+      SYSTEM.GET(kbdAdr, kbdCode);
+      IF kbdCode = 0F0H THEN Up := TRUE
+      ELSIF kbdCode = 0E0H THEN Ext := TRUE
+      ELSE
+        IF (kbdCode = 12H) OR (kbdCode = 59H) THEN (*shift*) Shift := ~Up
+        ELSIF kbdCode = 14H THEN (*ctrl*) Ctrl := ~Up
+        ELSIF ~Up THEN Recd := TRUE (*real key going down*)
+        END ;
+        Up := FALSE; Ext := FALSE
+      END
+    END;
+  END Peek;
+
+  PROCEDURE Available*(): INTEGER;
+  BEGIN Peek();
+    RETURN ORD(Recd)
+  END Available;
+
+  PROCEDURE Read*(VAR ch: CHAR);
+  BEGIN
+    WHILE ~Recd DO Peek() END ;
+    IF Shift OR Ctrl THEN INC(kbdCode, 80H) END; (*ctrl implies shift*)
+  (* ch := kbdTab[kbdCode]; *)
+    SYSTEM.GET(KTabAdr + kbdCode, ch);
+    IF Ctrl THEN ch := CHR(ORD(ch) MOD 20H) END;
+    Recd := FALSE
+  END Read;
+
+  PROCEDURE Mouse*(VAR keys: SET; VAR x, y: INTEGER);
+    VAR w: INTEGER;
+  BEGIN SYSTEM.GET(msAdr, w);
+    keys := SYSTEM.VAL(SET, w DIV 1000000H MOD 8);
+    x := w MOD 400H; y := (w DIV 1000H) MOD 400H;
+    IF y >= MH THEN y := MH-1 END
+  END Mouse;
+
+  PROCEDURE SetMouseLimits*(w, h: INTEGER);
+  BEGIN MW := w; MH := h
+  END SetMouseLimits;
+
+  PROCEDURE Init*;
+  BEGIN Up := FALSE; Shift := FALSE; Ctrl := FALSE; Recd := FALSE;
+    KTabAdr := SYSTEM.ADR($
+      00 00 00 00 00 1A 00 00  00 00 00 00 00 09 60 00
+      00 00 00 00 00 71 31 00  00 00 7A 73 61 77 32 00
+      00 63 78 64 65 34 33 00  00 20 76 66 74 72 35 00
+      00 6E 62 68 67 79 36 00  00 00 6D 6A 75 37 38 00
+      00 2C 6B 69 6F 30 39 00  00 2E 2F 6C 3B 70 2D 00
+      00 00 27 00 5B 3D 00 00  00 00 0D 5D 00 5C 00 00
+      00 00 00 00 00 00 08 00  00 00 00 00 00 00 00 00
+      00 7F 00 00 00 00 1B 00  00 00 00 00 00 00 00 00
+      00 00 00 00 00 00 00 00  00 00 00 00 00 09 7E 00
+      00 00 00 00 00 51 21 00  00 00 5A 53 41 57 40 00
+      00 43 58 44 45 24 23 00  00 20 56 46 54 52 25 00
+      00 4E 42 48 47 59 5E 00  00 00 4D 4A 55 26 2A 00
+      00 3C 4B 49 4F 29 28 00  00 3E 3F 4C 3A 50 5F 00
+      00 00 22 00 7B 2B 00 00  00 00 0D 7D 00 7C 00 00
+      00 00 00 00 00 00 08 00  00 00 00 00 00 00 00 00
+      00 7F 00 00 00 00 1B 00  00 00 00 00 00 00 00 00$)
+  END Init;
+
+BEGIN Init
+END Input.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Kernel.Mod.txt

@@ -1,271 +1,271 @@
-MODULE Kernel;  (*NW/PR  11.4.86 / 27.12.95 / 4.2.2014*)
-  IMPORT SYSTEM;
-  CONST SectorLength* = 1024;
-    timer = -64; spiData = -48; spiCtrl = -44;
-    CARD0 = 1; SPIFAST = 4;
-    FSoffset = 80000H; (*256MB in 512-byte blocks*)
-    mapsize = 10000H; (*1K sectors, 64MB*)
-
-  TYPE Sector* = ARRAY SectorLength OF BYTE;
-
-  VAR allocated*, NofSectors*: INTEGER;
-    heapOrg*, heapLim*: INTEGER; 
-    stackOrg* ,  stackSize*, MemLim*: INTEGER;
-    clock: INTEGER;
-    list0, list1, list2, list3: INTEGER;  (*lists of free blocks of size n*256, 128, 64, 32 bytes*)
-    data: INTEGER; (*SPI data in*)
-    sectorMap: ARRAY mapsize DIV 32 OF SET;
-    
-(* ---------- New: heap allocation ----------*)
-
-  PROCEDURE GetBlock(VAR p: LONGINT; len: LONGINT);
-    (*len is multiple of 256*)
-    VAR q0, q1, q2, size: LONGINT; done: BOOLEAN;
-  BEGIN q0 := 0; q1 := list0; done := FALSE;
-    WHILE ~done & (q1 # 0) DO
-      SYSTEM.GET(q1, size); SYSTEM.GET(q1+8, q2);
-      IF size < len THEN (*no fit*) q0 := q1; q1 := q2
-      ELSIF size = len THEN (*extract -> p*)
-        done := TRUE; p := q1;
-        IF q0 # 0 THEN SYSTEM.PUT(q0+8, q2) ELSE list0 := q2 END
-      ELSE (*reduce size*)
-        done := TRUE; p := q1; q1 := q1 + len;
-        SYSTEM.PUT(q1, size-len); SYSTEM.PUT(q1+4, -1); SYSTEM.PUT(q1+8, q2);
-        IF q0 # 0 THEN SYSTEM.PUT(q0+8, q1) ELSE list0 := q1 END
-      END
-    END ;
-    IF ~done THEN p := 0 END
-  END GetBlock;
-
-  PROCEDURE GetBlock128(VAR p: LONGINT);
-    VAR q: LONGINT;
-  BEGIN
-    IF list1 # 0 THEN p := list1; SYSTEM.GET(list1+8, list1)
-    ELSE GetBlock(q, 256); SYSTEM.PUT(q+128, 128); SYSTEM.PUT(q+132, -1); SYSTEM.PUT(q+136, list1);
-      list1 := q + 128; p := q
-    END
-  END GetBlock128;
-
-  PROCEDURE GetBlock64(VAR p: LONGINT);
-    VAR q: LONGINT;
-  BEGIN
-    IF list2 # 0 THEN p := list2; SYSTEM.GET(list2+8, list2)
-    ELSE GetBlock128(q); SYSTEM.PUT(q+64, 64); SYSTEM.PUT(q+68, -1); SYSTEM.PUT(q+72, list2);
-      list2 := q + 64; p := q
-    END
-  END GetBlock64;
-
-  PROCEDURE GetBlock32(VAR p: LONGINT);
-    VAR q: LONGINT;
-  BEGIN
-    IF list3 # 0 THEN p := list3; SYSTEM.GET(list3+8, list3)
-    ELSE GetBlock64(q); SYSTEM.PUT(q+32, 32); SYSTEM.PUT(q+36, -1); SYSTEM.PUT(q+40, list3);
-      list3 := q + 32; p := q
-    END
-  END GetBlock32;
-
-   PROCEDURE New*(VAR ptr: LONGINT; tag: LONGINT);
-    (*called by NEW via MT[0]; ptr and tag are pointers*)
-    VAR p, size, lim: LONGINT;
-  BEGIN SYSTEM.GET(tag, size);
-    IF size = 32 THEN GetBlock32(p)
-    ELSIF size = 64 THEN GetBlock64(p)
-    ELSIF size = 128 THEN GetBlock128(p)
-    ELSE GetBlock(p, (size+255) DIV 256 * 256)
-    END ;
-    IF p = 0 THEN ptr := 0
-    ELSE ptr := p+8; SYSTEM.PUT(p, tag); lim := p + size; INC(p, 4); INC(allocated, size);
-      WHILE p < lim DO SYSTEM.PUT(p, 0); INC(p, 4) END
-    END
-  END New;
-
-(* ---------- Garbage collector ----------*)
-
-  PROCEDURE Mark*(pref: LONGINT);
-    VAR pvadr, offadr, offset, tag, p, q, r: LONGINT;
-  BEGIN SYSTEM.GET(pref, pvadr); (*pointers < heapOrg considered NIL*)
-    WHILE pvadr # 0 DO
-      SYSTEM.GET(pvadr, p); SYSTEM.GET(p-4, offadr);
-      IF (p >= heapOrg) & (offadr = 0) THEN q := p;   (*mark elements in data structure with root p*)
-        REPEAT SYSTEM.GET(p-4, offadr);
-          IF offadr = 0 THEN SYSTEM.GET(p-8, tag); offadr := tag + 16 ELSE INC(offadr, 4) END ;
-          SYSTEM.PUT(p-4, offadr); SYSTEM.GET(offadr, offset);
-          IF offset # -1 THEN (*down*)
-            SYSTEM.GET(p+offset, r); SYSTEM.GET(r-4, offadr);
-            IF (r >= heapOrg) & (offadr = 0) THEN SYSTEM.PUT(p+offset, q); q := p; p := r END
-          ELSE (*up*) SYSTEM.GET(q-4, offadr); SYSTEM.GET(offadr, offset);
-            IF p # q THEN SYSTEM.GET(q+offset, r); SYSTEM.PUT(q+offset, p); p := q; q := r END
-          END
-        UNTIL (p = q) & (offset = -1)
-      END ;
-      INC(pref, 4); SYSTEM.GET(pref, pvadr)
-    END
-  END Mark;
-
-  PROCEDURE Scan*;
-    VAR p, q, mark, tag, size: LONGINT;
-  BEGIN p := heapOrg;
-    REPEAT SYSTEM.GET(p+4, mark); q := p;
-      WHILE mark = 0 DO
-        SYSTEM.GET(p, tag); SYSTEM.GET(tag, size); INC(p, size); SYSTEM.GET(p+4, mark)
-      END ;
-      size := p - q; DEC(allocated, size);  (*size of free block*)
-      IF size > 0 THEN
-        IF size MOD 64 # 0 THEN
-          SYSTEM.PUT(q, 32); SYSTEM.PUT(q+4, -1); SYSTEM.PUT(q+8, list3); list3 := q; INC(q, 32); DEC(size, 32)
-        END ;
-        IF size MOD 128 # 0 THEN
-          SYSTEM.PUT(q, 64); SYSTEM.PUT(q+4, -1); SYSTEM.PUT(q+8, list2); list2 := q; INC(q, 64); DEC(size, 64)
-        END ;
-        IF size MOD 256 # 0 THEN
-          SYSTEM.PUT(q, 128); SYSTEM.PUT(q+4, -1); SYSTEM.PUT(q+8,  list1); list1 := q; INC(q, 128); DEC(size, 128)
-        END ;
-        IF size > 0 THEN
-          SYSTEM.PUT(q, size); SYSTEM.PUT(q+4, -1); SYSTEM.PUT(q+8, list0); list0 := q; INC(q, size)
-        END
-      END ;
-      IF mark > 0 THEN SYSTEM.GET(p, tag); SYSTEM.GET(tag, size); SYSTEM.PUT(p+4, 0); INC(p, size)
-      ELSE (*free*) SYSTEM.GET(p, size); INC(p, size)
-      END
-    UNTIL p >= heapLim
-  END Scan;
-
-(* ---------- Disk storage management ----------*)
-
-  PROCEDURE SPIIdle(n: INTEGER); (*send n FFs slowly with no card selected*)
-  BEGIN SYSTEM.PUT(spiCtrl, 0);
-    WHILE n > 0 DO DEC(n); SYSTEM.PUT(spiData, -1);
-      REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0);
-      SYSTEM.GET(spiData, data)
-    END
-  END SPIIdle;
-
-  PROCEDURE SPI(n: INTEGER); (*send&rcv byte slowly with card selected*)
-  BEGIN SYSTEM.PUT(spiCtrl, CARD0); SYSTEM.PUT(spiData, n);
-    REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0);
-    SYSTEM.GET(spiData, data)
-  END SPI;
-
-  PROCEDURE SPICmd(n, arg: INTEGER);
-    VAR i, crc: INTEGER;
-  BEGIN (*send cmd*)
-    REPEAT SPIIdle(1) UNTIL data = 255; (*flush while unselected*)
-    REPEAT SPI(255) UNTIL data = 255; (*flush while selected*)
-    IF n = 8 THEN crc := 135 ELSIF n = 0 THEN crc := 149 ELSE crc := 255 END;
-    SPI(n MOD 64 + 64); (*send command*)
-    FOR i := 24 TO 0 BY -8 DO SPI(ROR(arg, i)) END; (*send arg*)
-    SPI(crc); i := 32;
-    REPEAT SPI(255); DEC(i) UNTIL (data < 80H) OR (i = 0)
-  END SPICmd;
-
-  PROCEDURE SDShift(VAR n: INTEGER);
-    VAR data: INTEGER;
-  BEGIN SPICmd(58, 0);  (*CMD58 get card capacity bit*)
-    SYSTEM.GET(spiData, data); SPI(-1);
-    IF (data # 0) OR ~SYSTEM.BIT(spiData, 6) THEN n := n * 512 END ;  (*non-SDHC card*)
-    SPI(-1); SPI(-1); SPIIdle(1)  (*flush response*)
-  END SDShift;
-
-  PROCEDURE ReadSD(src, dst: INTEGER);
-    VAR i: INTEGER;
-  BEGIN SDShift(src); SPICmd(17, src); ASSERT(data = 0); (*CMD17 read one block*)
-    i := 0; (*wait for start data marker*)
-    REPEAT SPI(-1); INC(i) UNTIL data = 254;
-    SYSTEM.PUT(spiCtrl, SPIFAST + CARD0);
-    FOR i := 0 TO 508 BY 4 DO
-      SYSTEM.PUT(spiData, -1);
-      REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0);
-      SYSTEM.GET(spiData, data); SYSTEM.PUT(dst, data); INC(dst, 4)
-    END;
-    SPI(255); SPI(255); SPIIdle(1) (*may be a checksum; deselect card*)
-  END ReadSD;
-
-  PROCEDURE WriteSD(dst, src: INTEGER);
-    VAR i, n: INTEGER; x: BYTE;
-  BEGIN SDShift(dst); SPICmd(24, dst); ASSERT(data = 0); (*CMD24 write one block*)
-    SPI(254); (*write start data marker*)
-    SYSTEM.PUT(spiCtrl, SPIFAST + CARD0);
-    FOR i := 0 TO 508 BY 4 DO
-      SYSTEM.GET(src, n); INC(src, 4); SYSTEM.PUT(spiData, n);
-      REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0)
-    END;
-    SPI(255); SPI(255); (*dummy checksum*) i := 0;
-    REPEAT SPI(-1); INC(i); UNTIL (data MOD 32 = 5) OR (i = 10000);
-    ASSERT(data MOD 32 = 5); SPIIdle(1) (*deselect card*)
-  END WriteSD;
-
-  PROCEDURE InitSecMap*;
-    VAR i: INTEGER;
-  BEGIN NofSectors := 0; sectorMap[0] := {0 .. 31}; sectorMap[1] := {0 .. 31};
-    FOR i := 2 TO mapsize DIV 32 - 1 DO sectorMap[i] := {} END
-  END InitSecMap;
-
-  PROCEDURE MarkSector*(sec: INTEGER);
-  BEGIN sec := sec DIV 29; ASSERT(SYSTEM.H(0) = 0);
-    INCL(sectorMap[sec DIV 32], sec MOD 32); INC(NofSectors)
-  END MarkSector;
-
-  PROCEDURE FreeSector*(sec: INTEGER);
-  BEGIN sec := sec DIV 29; ASSERT(SYSTEM.H(0) = 0);
-    EXCL(sectorMap[sec DIV 32], sec MOD 32); DEC(NofSectors)
-  END FreeSector;
-
-  PROCEDURE AllocSector*(hint: INTEGER; VAR sec: INTEGER);
-    VAR s: INTEGER;
-  BEGIN (*find free sector, starting after hint*)
-    hint := hint DIV 29; ASSERT(SYSTEM.H(0) = 0); s := hint;
-    REPEAT INC(s);
-      IF s = mapsize THEN s := 1 END ;
-    UNTIL ~(s MOD 32 IN sectorMap[s DIV 32]);
-    INCL(sectorMap[s DIV 32], s MOD 32); INC(NofSectors); sec := s * 29
-  END AllocSector;
-
-  PROCEDURE GetSector*(src: INTEGER; VAR dst: Sector);
-  BEGIN src := src DIV 29; ASSERT(SYSTEM.H(0) = 0);
-    src := src * 2 + FSoffset;
-    ReadSD(src, SYSTEM.ADR(dst)); ReadSD(src+1, SYSTEM.ADR(dst)+512) 
-  END GetSector;
-  
-  PROCEDURE PutSector*(dst: INTEGER; VAR src: Sector);
-  BEGIN dst := dst DIV 29; ASSERT(SYSTEM.H(0) =  0);
-    dst := dst * 2 + FSoffset;
-    WriteSD(dst, SYSTEM.ADR(src)); WriteSD(dst+1, SYSTEM.ADR(src)+512)
-  END PutSector;
-
-(*-------- Miscellaneous procedures----------*)
-
-  PROCEDURE Time*(): INTEGER;
-    VAR t: INTEGER;
-  BEGIN SYSTEM.GET(timer, t); RETURN t
-  END Time;
-
-  PROCEDURE Clock*(): INTEGER;
-  BEGIN RETURN clock
-  END Clock;
-
-  PROCEDURE SetClock*(dt: INTEGER);
-  BEGIN clock := dt
-  END SetClock;
-
-  PROCEDURE Install*(Padr, at: INTEGER);
-  BEGIN SYSTEM.PUT(at, 0E7000000H + (Padr - at) DIV 4 -1)
-  END Install;
-
-  PROCEDURE Trap(VAR a: INTEGER; b: INTEGER);
-    VAR u, v, w: INTEGER;
-  BEGIN u := SYSTEM.REG(15); SYSTEM.GET(u - 4, v); w := v DIV 10H MOD 10H; (*trap number*)
-    IF w = 0 THEN New(a, b)
-    ELSE (*stop*) LED(w + 192); REPEAT UNTIL FALSE
-    END
-  END Trap;
-
-  PROCEDURE Init*;
-  BEGIN Install(SYSTEM.ADR(Trap), 20H);  (*install temporary trap*)
-    SYSTEM.GET(12, MemLim); SYSTEM.GET(24, heapOrg);
-    stackOrg := heapOrg; stackSize := 8000H; heapLim := MemLim;
-    list1 := 0; list2 := 0; list3 := 0; list0 := heapOrg;
-    SYSTEM.PUT(list0, heapLim - heapOrg); SYSTEM.PUT(list0+4, -1); SYSTEM.PUT(list0+8, 0);
-    allocated := 0; clock := 0; InitSecMap
-  END Init;
-
-END Kernel.
+MODULE Kernel;  (*NW/PR  11.4.86 / 27.12.95 / 4.2.2014*)
+  IMPORT SYSTEM;
+  CONST SectorLength* = 1024;
+    timer = -64; spiData = -48; spiCtrl = -44;
+    CARD0 = 1; SPIFAST = 4;
+    FSoffset = 80000H; (*256MB in 512-byte blocks*)
+    mapsize = 10000H; (*1K sectors, 64MB*)
+
+  TYPE Sector* = ARRAY SectorLength OF BYTE;
+
+  VAR allocated*, NofSectors*: INTEGER;
+    heapOrg*, heapLim*: INTEGER; 
+    stackOrg* ,  stackSize*, MemLim*: INTEGER;
+    clock: INTEGER;
+    list0, list1, list2, list3: INTEGER;  (*lists of free blocks of size n*256, 128, 64, 32 bytes*)
+    data: INTEGER; (*SPI data in*)
+    sectorMap: ARRAY mapsize DIV 32 OF SET;
+    
+(* ---------- New: heap allocation ----------*)
+
+  PROCEDURE GetBlock(VAR p: LONGINT; len: LONGINT);
+    (*len is multiple of 256*)
+    VAR q0, q1, q2, size: LONGINT; done: BOOLEAN;
+  BEGIN q0 := 0; q1 := list0; done := FALSE;
+    WHILE ~done & (q1 # 0) DO
+      SYSTEM.GET(q1, size); SYSTEM.GET(q1+8, q2);
+      IF size < len THEN (*no fit*) q0 := q1; q1 := q2
+      ELSIF size = len THEN (*extract -> p*)
+        done := TRUE; p := q1;
+        IF q0 # 0 THEN SYSTEM.PUT(q0+8, q2) ELSE list0 := q2 END
+      ELSE (*reduce size*)
+        done := TRUE; p := q1; q1 := q1 + len;
+        SYSTEM.PUT(q1, size-len); SYSTEM.PUT(q1+4, -1); SYSTEM.PUT(q1+8, q2);
+        IF q0 # 0 THEN SYSTEM.PUT(q0+8, q1) ELSE list0 := q1 END
+      END
+    END ;
+    IF ~done THEN p := 0 END
+  END GetBlock;
+
+  PROCEDURE GetBlock128(VAR p: LONGINT);
+    VAR q: LONGINT;
+  BEGIN
+    IF list1 # 0 THEN p := list1; SYSTEM.GET(list1+8, list1)
+    ELSE GetBlock(q, 256); SYSTEM.PUT(q+128, 128); SYSTEM.PUT(q+132, -1); SYSTEM.PUT(q+136, list1);
+      list1 := q + 128; p := q
+    END
+  END GetBlock128;
+
+  PROCEDURE GetBlock64(VAR p: LONGINT);
+    VAR q: LONGINT;
+  BEGIN
+    IF list2 # 0 THEN p := list2; SYSTEM.GET(list2+8, list2)
+    ELSE GetBlock128(q); SYSTEM.PUT(q+64, 64); SYSTEM.PUT(q+68, -1); SYSTEM.PUT(q+72, list2);
+      list2 := q + 64; p := q
+    END
+  END GetBlock64;
+
+  PROCEDURE GetBlock32(VAR p: LONGINT);
+    VAR q: LONGINT;
+  BEGIN
+    IF list3 # 0 THEN p := list3; SYSTEM.GET(list3+8, list3)
+    ELSE GetBlock64(q); SYSTEM.PUT(q+32, 32); SYSTEM.PUT(q+36, -1); SYSTEM.PUT(q+40, list3);
+      list3 := q + 32; p := q
+    END
+  END GetBlock32;
+
+   PROCEDURE New*(VAR ptr: LONGINT; tag: LONGINT);
+    (*called by NEW via MT[0]; ptr and tag are pointers*)
+    VAR p, size, lim: LONGINT;
+  BEGIN SYSTEM.GET(tag, size);
+    IF size = 32 THEN GetBlock32(p)
+    ELSIF size = 64 THEN GetBlock64(p)
+    ELSIF size = 128 THEN GetBlock128(p)
+    ELSE GetBlock(p, (size+255) DIV 256 * 256)
+    END ;
+    IF p = 0 THEN ptr := 0
+    ELSE ptr := p+8; SYSTEM.PUT(p, tag); lim := p + size; INC(p, 4); INC(allocated, size);
+      WHILE p < lim DO SYSTEM.PUT(p, 0); INC(p, 4) END
+    END
+  END New;
+
+(* ---------- Garbage collector ----------*)
+
+  PROCEDURE Mark*(pref: LONGINT);
+    VAR pvadr, offadr, offset, tag, p, q, r: LONGINT;
+  BEGIN SYSTEM.GET(pref, pvadr); (*pointers < heapOrg considered NIL*)
+    WHILE pvadr # 0 DO
+      SYSTEM.GET(pvadr, p); SYSTEM.GET(p-4, offadr);
+      IF (p >= heapOrg) & (offadr = 0) THEN q := p;   (*mark elements in data structure with root p*)
+        REPEAT SYSTEM.GET(p-4, offadr);
+          IF offadr = 0 THEN SYSTEM.GET(p-8, tag); offadr := tag + 16 ELSE INC(offadr, 4) END ;
+          SYSTEM.PUT(p-4, offadr); SYSTEM.GET(offadr, offset);
+          IF offset # -1 THEN (*down*)
+            SYSTEM.GET(p+offset, r); SYSTEM.GET(r-4, offadr);
+            IF (r >= heapOrg) & (offadr = 0) THEN SYSTEM.PUT(p+offset, q); q := p; p := r END
+          ELSE (*up*) SYSTEM.GET(q-4, offadr); SYSTEM.GET(offadr, offset);
+            IF p # q THEN SYSTEM.GET(q+offset, r); SYSTEM.PUT(q+offset, p); p := q; q := r END
+          END
+        UNTIL (p = q) & (offset = -1)
+      END ;
+      INC(pref, 4); SYSTEM.GET(pref, pvadr)
+    END
+  END Mark;
+
+  PROCEDURE Scan*;
+    VAR p, q, mark, tag, size: LONGINT;
+  BEGIN p := heapOrg;
+    REPEAT SYSTEM.GET(p+4, mark); q := p;
+      WHILE mark = 0 DO
+        SYSTEM.GET(p, tag); SYSTEM.GET(tag, size); INC(p, size); SYSTEM.GET(p+4, mark)
+      END ;
+      size := p - q; DEC(allocated, size);  (*size of free block*)
+      IF size > 0 THEN
+        IF size MOD 64 # 0 THEN
+          SYSTEM.PUT(q, 32); SYSTEM.PUT(q+4, -1); SYSTEM.PUT(q+8, list3); list3 := q; INC(q, 32); DEC(size, 32)
+        END ;
+        IF size MOD 128 # 0 THEN
+          SYSTEM.PUT(q, 64); SYSTEM.PUT(q+4, -1); SYSTEM.PUT(q+8, list2); list2 := q; INC(q, 64); DEC(size, 64)
+        END ;
+        IF size MOD 256 # 0 THEN
+          SYSTEM.PUT(q, 128); SYSTEM.PUT(q+4, -1); SYSTEM.PUT(q+8,  list1); list1 := q; INC(q, 128); DEC(size, 128)
+        END ;
+        IF size > 0 THEN
+          SYSTEM.PUT(q, size); SYSTEM.PUT(q+4, -1); SYSTEM.PUT(q+8, list0); list0 := q; INC(q, size)
+        END
+      END ;
+      IF mark > 0 THEN SYSTEM.GET(p, tag); SYSTEM.GET(tag, size); SYSTEM.PUT(p+4, 0); INC(p, size)
+      ELSE (*free*) SYSTEM.GET(p, size); INC(p, size)
+      END
+    UNTIL p >= heapLim
+  END Scan;
+
+(* ---------- Disk storage management ----------*)
+
+  PROCEDURE SPIIdle(n: INTEGER); (*send n FFs slowly with no card selected*)
+  BEGIN SYSTEM.PUT(spiCtrl, 0);
+    WHILE n > 0 DO DEC(n); SYSTEM.PUT(spiData, -1);
+      REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0);
+      SYSTEM.GET(spiData, data)
+    END
+  END SPIIdle;
+
+  PROCEDURE SPI(n: INTEGER); (*send&rcv byte slowly with card selected*)
+  BEGIN SYSTEM.PUT(spiCtrl, CARD0); SYSTEM.PUT(spiData, n);
+    REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0);
+    SYSTEM.GET(spiData, data)
+  END SPI;
+
+  PROCEDURE SPICmd(n, arg: INTEGER);
+    VAR i, crc: INTEGER;
+  BEGIN (*send cmd*)
+    REPEAT SPIIdle(1) UNTIL data = 255; (*flush while unselected*)
+    REPEAT SPI(255) UNTIL data = 255; (*flush while selected*)
+    IF n = 8 THEN crc := 135 ELSIF n = 0 THEN crc := 149 ELSE crc := 255 END;
+    SPI(n MOD 64 + 64); (*send command*)
+    FOR i := 24 TO 0 BY -8 DO SPI(ROR(arg, i)) END; (*send arg*)
+    SPI(crc); i := 32;
+    REPEAT SPI(255); DEC(i) UNTIL (data < 80H) OR (i = 0)
+  END SPICmd;
+
+  PROCEDURE SDShift(VAR n: INTEGER);
+    VAR data: INTEGER;
+  BEGIN SPICmd(58, 0);  (*CMD58 get card capacity bit*)
+    SYSTEM.GET(spiData, data); SPI(-1);
+    IF (data # 0) OR ~SYSTEM.BIT(spiData, 6) THEN n := n * 512 END ;  (*non-SDHC card*)
+    SPI(-1); SPI(-1); SPIIdle(1)  (*flush response*)
+  END SDShift;
+
+  PROCEDURE ReadSD(src, dst: INTEGER);
+    VAR i: INTEGER;
+  BEGIN SDShift(src); SPICmd(17, src); ASSERT(data = 0); (*CMD17 read one block*)
+    i := 0; (*wait for start data marker*)
+    REPEAT SPI(-1); INC(i) UNTIL data = 254;
+    SYSTEM.PUT(spiCtrl, SPIFAST + CARD0);
+    FOR i := 0 TO 508 BY 4 DO
+      SYSTEM.PUT(spiData, -1);
+      REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0);
+      SYSTEM.GET(spiData, data); SYSTEM.PUT(dst, data); INC(dst, 4)
+    END;
+    SPI(255); SPI(255); SPIIdle(1) (*may be a checksum; deselect card*)
+  END ReadSD;
+
+  PROCEDURE WriteSD(dst, src: INTEGER);
+    VAR i, n: INTEGER; x: BYTE;
+  BEGIN SDShift(dst); SPICmd(24, dst); ASSERT(data = 0); (*CMD24 write one block*)
+    SPI(254); (*write start data marker*)
+    SYSTEM.PUT(spiCtrl, SPIFAST + CARD0);
+    FOR i := 0 TO 508 BY 4 DO
+      SYSTEM.GET(src, n); INC(src, 4); SYSTEM.PUT(spiData, n);
+      REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0)
+    END;
+    SPI(255); SPI(255); (*dummy checksum*) i := 0;
+    REPEAT SPI(-1); INC(i); UNTIL (data MOD 32 = 5) OR (i = 10000);
+    ASSERT(data MOD 32 = 5); SPIIdle(1) (*deselect card*)
+  END WriteSD;
+
+  PROCEDURE InitSecMap*;
+    VAR i: INTEGER;
+  BEGIN NofSectors := 0; sectorMap[0] := {0 .. 31}; sectorMap[1] := {0 .. 31};
+    FOR i := 2 TO mapsize DIV 32 - 1 DO sectorMap[i] := {} END
+  END InitSecMap;
+
+  PROCEDURE MarkSector*(sec: INTEGER);
+  BEGIN sec := sec DIV 29; ASSERT(SYSTEM.H(0) = 0);
+    INCL(sectorMap[sec DIV 32], sec MOD 32); INC(NofSectors)
+  END MarkSector;
+
+  PROCEDURE FreeSector*(sec: INTEGER);
+  BEGIN sec := sec DIV 29; ASSERT(SYSTEM.H(0) = 0);
+    EXCL(sectorMap[sec DIV 32], sec MOD 32); DEC(NofSectors)
+  END FreeSector;
+
+  PROCEDURE AllocSector*(hint: INTEGER; VAR sec: INTEGER);
+    VAR s: INTEGER;
+  BEGIN (*find free sector, starting after hint*)
+    hint := hint DIV 29; ASSERT(SYSTEM.H(0) = 0); s := hint;
+    REPEAT INC(s);
+      IF s = mapsize THEN s := 1 END ;
+    UNTIL ~(s MOD 32 IN sectorMap[s DIV 32]);
+    INCL(sectorMap[s DIV 32], s MOD 32); INC(NofSectors); sec := s * 29
+  END AllocSector;
+
+  PROCEDURE GetSector*(src: INTEGER; VAR dst: Sector);
+  BEGIN src := src DIV 29; ASSERT(SYSTEM.H(0) = 0);
+    src := src * 2 + FSoffset;
+    ReadSD(src, SYSTEM.ADR(dst)); ReadSD(src+1, SYSTEM.ADR(dst)+512) 
+  END GetSector;
+  
+  PROCEDURE PutSector*(dst: INTEGER; VAR src: Sector);
+  BEGIN dst := dst DIV 29; ASSERT(SYSTEM.H(0) =  0);
+    dst := dst * 2 + FSoffset;
+    WriteSD(dst, SYSTEM.ADR(src)); WriteSD(dst+1, SYSTEM.ADR(src)+512)
+  END PutSector;
+
+(*-------- Miscellaneous procedures----------*)
+
+  PROCEDURE Time*(): INTEGER;
+    VAR t: INTEGER;
+  BEGIN SYSTEM.GET(timer, t); RETURN t
+  END Time;
+
+  PROCEDURE Clock*(): INTEGER;
+  BEGIN RETURN clock
+  END Clock;
+
+  PROCEDURE SetClock*(dt: INTEGER);
+  BEGIN clock := dt
+  END SetClock;
+
+  PROCEDURE Install*(Padr, at: INTEGER);
+  BEGIN SYSTEM.PUT(at, 0E7000000H + (Padr - at) DIV 4 -1)
+  END Install;
+
+  PROCEDURE Trap(VAR a: INTEGER; b: INTEGER);
+    VAR u, v, w: INTEGER;
+  BEGIN u := SYSTEM.REG(15); SYSTEM.GET(u - 4, v); w := v DIV 10H MOD 10H; (*trap number*)
+    IF w = 0 THEN New(a, b)
+    ELSE (*stop*) LED(w + 192); REPEAT UNTIL FALSE
+    END
+  END Trap;
+
+  PROCEDURE Init*;
+  BEGIN Install(SYSTEM.ADR(Trap), 20H);  (*install temporary trap*)
+    SYSTEM.GET(12, MemLim); SYSTEM.GET(24, heapOrg);
+    stackOrg := heapOrg; stackSize := 8000H; heapLim := MemLim;
+    list1 := 0; list2 := 0; list3 := 0; list0 := heapOrg;
+    SYSTEM.PUT(list0, heapLim - heapOrg); SYSTEM.PUT(list0+4, -1); SYSTEM.PUT(list0+8, 0);
+    allocated := 0; clock := 0; InitSecMap
+  END Init;
+
+END Kernel.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/MacroTool.Mod.txt

@@ -1,73 +1,73 @@
-MODULE MacroTool;  (*NW  6.8.2013*)
-  IMPORT Texts, Oberon, Graphics, GraphicFrames;
-  VAR W: Texts.Writer;
-
-  PROCEDURE OpenMacro*;
-    VAR F: GraphicFrames.Frame; sel: Graphics.Object;
-  BEGIN (*expand selected macro to caret position*)
-    F := GraphicFrames.Selected();
-    IF F # NIL THEN
-      sel := F.graph.sel;
-      IF (sel # NIL) & (sel IS Graphics.Macro) THEN
-        GraphicFrames.Deselect(F);
-        Graphics.OpenMac(sel(Graphics.Macro).mac, F.graph, F.mark.x - F.x, F.mark.y - F.y);
-        GraphicFrames.Draw(F)
-      END
-    END
-  END OpenMacro;
-
-  PROCEDURE MakeMacro*;  (*lib mac*)
-    (*compose macro from selected elements into caret area*)
-    VAR newMac: BOOLEAN;
-      machead: Graphics.MacHead;
-      F: GraphicFrames.Frame;
-      L: Graphics.Library;
-      S: Texts.Scanner;
-      Lname, Mname: ARRAY 32 OF CHAR;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-      Lname := S.s; Texts.Scan(S);
-      IF (S.class  = Texts.Name) OR (S.class = Texts.String) & (S.len <= 8) THEN
-        F := GraphicFrames.Focus(); Mname := S.s;
-        IF (F # NIL) & (F.graph.sel # NIL) THEN
-          Graphics.GetLib(Lname, FALSE, L);
-          IF L = NIL THEN
-            Texts.WriteString(W, "new library "); Texts.WriteString(W, Lname); Texts.WriteLn(W);
-            L := Graphics.NewLib(Lname)
-          END ;
-          Graphics.MakeMac(F.graph, machead);
-          IF machead # NIL THEN
-            machead.name := Mname; Graphics.InsertMac(machead, L, newMac); Texts.WriteString(W, Mname);
-            IF newMac THEN Texts.WriteString(W, " inserted in ") ELSE Texts.WriteString(W, " replaced in ") END ;
-            Texts.WriteString(W, Lname)
-          ELSE Texts.WriteString(W, " empty macro")
-          END ;
-          Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-        END
-      END
-    END
-  END MakeMacro;
-
-  PROCEDURE LoadLibrary*;  (*lib file name*)
-    VAR S: Texts.Scanner; L: Graphics.Library;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-      Texts.WriteString(W, S.s); Graphics.GetLib(S.s, FALSE, L);
-      IF L # NIL THEN Texts.WriteString(W, " loaded") ELSE Texts.WriteString(W, " not found") END ;
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END LoadLibrary;
-
-  PROCEDURE StoreLibrary*;  (*lib file name*)
-    VAR i: INTEGER; S: Texts.Scanner; L: Graphics.Library;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-       Graphics.StoreLib(L, S.s); Texts.WriteString(W, S.s);
-       IF L # NIL THEN Texts.WriteString(W, " stored") ELSE Texts.WriteString(W, " not found") END ;
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END StoreLibrary;
-
-BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "MacroTool - NW 6.8.2013");
-  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-END MacroTool.
+MODULE MacroTool;  (*NW  6.8.2013*)
+  IMPORT Texts, Oberon, Graphics, GraphicFrames;
+  VAR W: Texts.Writer;
+
+  PROCEDURE OpenMacro*;
+    VAR F: GraphicFrames.Frame; sel: Graphics.Object;
+  BEGIN (*expand selected macro to caret position*)
+    F := GraphicFrames.Selected();
+    IF F # NIL THEN
+      sel := F.graph.sel;
+      IF (sel # NIL) & (sel IS Graphics.Macro) THEN
+        GraphicFrames.Deselect(F);
+        Graphics.OpenMac(sel(Graphics.Macro).mac, F.graph, F.mark.x - F.x, F.mark.y - F.y);
+        GraphicFrames.Draw(F)
+      END
+    END
+  END OpenMacro;
+
+  PROCEDURE MakeMacro*;  (*lib mac*)
+    (*compose macro from selected elements into caret area*)
+    VAR newMac: BOOLEAN;
+      machead: Graphics.MacHead;
+      F: GraphicFrames.Frame;
+      L: Graphics.Library;
+      S: Texts.Scanner;
+      Lname, Mname: ARRAY 32 OF CHAR;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+      Lname := S.s; Texts.Scan(S);
+      IF (S.class  = Texts.Name) OR (S.class = Texts.String) & (S.len <= 8) THEN
+        F := GraphicFrames.Focus(); Mname := S.s;
+        IF (F # NIL) & (F.graph.sel # NIL) THEN
+          Graphics.GetLib(Lname, FALSE, L);
+          IF L = NIL THEN
+            Texts.WriteString(W, "new library "); Texts.WriteString(W, Lname); Texts.WriteLn(W);
+            L := Graphics.NewLib(Lname)
+          END ;
+          Graphics.MakeMac(F.graph, machead);
+          IF machead # NIL THEN
+            machead.name := Mname; Graphics.InsertMac(machead, L, newMac); Texts.WriteString(W, Mname);
+            IF newMac THEN Texts.WriteString(W, " inserted in ") ELSE Texts.WriteString(W, " replaced in ") END ;
+            Texts.WriteString(W, Lname)
+          ELSE Texts.WriteString(W, " empty macro")
+          END ;
+          Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+        END
+      END
+    END
+  END MakeMacro;
+
+  PROCEDURE LoadLibrary*;  (*lib file name*)
+    VAR S: Texts.Scanner; L: Graphics.Library;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+      Texts.WriteString(W, S.s); Graphics.GetLib(S.s, FALSE, L);
+      IF L # NIL THEN Texts.WriteString(W, " loaded") ELSE Texts.WriteString(W, " not found") END ;
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END LoadLibrary;
+
+  PROCEDURE StoreLibrary*;  (*lib file name*)
+    VAR i: INTEGER; S: Texts.Scanner; L: Graphics.Library;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+       Graphics.StoreLib(L, S.s); Texts.WriteString(W, S.s);
+       IF L # NIL THEN Texts.WriteString(W, " stored") ELSE Texts.WriteString(W, " not found") END ;
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END StoreLibrary;
+
+BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "MacroTool - NW 6.8.2013");
+  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+END MacroTool.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Math.Mod.txt

@@ -1,112 +1,112 @@
-MODULE Math;   (*Standard functions;  NW 12.10.2013*)
-
-  PROCEDURE sqrt*(x: REAL): REAL;
-    CONST c1 = 0.70710680;   (* 1/sqrt(2) *)
-      c2 = 0.590162067;
-      c3 = 1.4142135;  (*sqrt(2)*)
-    VAR s: REAL; e: INTEGER;
-  BEGIN ASSERT(x >= 0.0);
-    IF x > 0.0 THEN
-      UNPK(x, e);
-      s := c2*(x+c1);
-      s := s + (x/s);
-      s := 0.25*s + x/s;
-      s := 0.5 * (s + x/s);
-      IF ODD(e) THEN s := c3*s END ;
-      PACK(s, e DIV 2)
-    ELSE s := 0.0
-    END ;
-    RETURN s
-  END sqrt;
-
-  PROCEDURE exp*(x: REAL): REAL;
-    CONST
-      c1 = 1.4426951;  (*1/ln(2) *)
-      p0 = 1.513864173E3;
-      p1= 2.020170000E1;
-      p2 = 2.309432127E-2;
-      q0 = 4.368088670E3;
-      q1 = 2.331782320E2;
-    VAR n: INTEGER; p, y, yy: REAL;
-  BEGIN y := c1*x;
-    n := FLOOR(y + 0.5); y := y - FLT(n);
-    yy := y*y;
-    p := ((p2*yy + p1)*yy + p0)*y;
-    p := p/((yy + q1)*yy + q0 - p) + 0.5;
-    PACK(p, n+1); RETURN p
-  END exp;
-
-  PROCEDURE ln*(x: REAL): REAL;
-    CONST c1 = 0.70710680;  (* 1/sqrt(2) *)
-      c2 =  0.69314720;  (* ln(2) *)
-      p0 = -9.01746917E1;
-      p1 =  9.34639006E1;
-      p2 = -1.83278704E1;
-      q0 = -4.50873458E1;
-      q1 =  6.76106560E1;
-      q2 = -2.07334879E1;
-    VAR e: INTEGER; xx, y: REAL;
-  BEGIN ASSERT(x > 0.0); UNPK(x, e);
-    IF x < c1 THEN x := x*2.0; e := e-1 END ;
-    x := (x-1.0)/(x+1.0);
-    xx := x;
-    y := c2*FLT(e) + x*((p2*xx + p1)*xx + p0) / (((xx + q2)*xx + q1)*xx + q0);
-    RETURN y
-  END ln;
-
-  PROCEDURE sin*(x: REAL): REAL;
-    CONST
-      c1 =  6.3661977E-1; (*2/pi*)
-      p0 =  7.8539816E-1;
-      p1 = -8.0745512E-2;
-      p2 =  2.4903946E-3;
-      p3 = -3.6576204E-5;
-      p4 =  3.1336162E-7;
-      p5 = -1.7571493E-9;
-      p6 =  6.8771004E-12;
-      q0 =  9.9999999E-1;
-      q1 = -3.0842514E-1;
-      q2 =  1.5854344E-2;
-      q3 = -3.2599189E-4;
-      q4 =  3.5908591E-6;
-      q5 = -2.4609457E-8;
-      q6 =  1.1363813E-10;
-    VAR n: INTEGER; y, yy, f: REAL;
-  BEGIN y := c1*x;
-    IF y >= 0.0 THEN n := FLOOR(y + 0.5) ELSE n := FLOOR(y - 0.5) END ;
-    y := (y - FLT(n)) * 2.0; yy := y*y;
-    IF ODD(n) THEN f := (((((q6*yy + q5)*yy + q4)*yy + q3)*yy + q2)*yy + q1)*yy + q0
-    ELSE f := ((((((p6*yy + p5)*yy + p4)*yy + p3)*yy + p2)*yy + p1)*yy + p0)*y
-    END ;
-    IF ODD(n DIV 2) THEN f := -f END ;
-    RETURN f
-  END sin;
-
-  PROCEDURE cos*(x: REAL): REAL;
-    CONST
-      c1 =  6.3661977E-1; (*2/pi*)
-      p0 =  7.8539816E-1;
-      p1 = -8.0745512E-2;
-      p2 =  2.4903946E-3;
-      p3 = -3.6576204E-5;
-      p4 =  3.1336162E-7;
-      p5 = -1.7571493E-9;
-      p6 = 6.8771004E-12;
-      q0 =  9.9999999E-1;
-      q1 = -3.0842514E-1;
-      q2 =  1.5854344E-2;
-      q3 = -3.2599189E-4;
-      q4 =  3.5908591E-6;
-      q5 = -2.4609457E-8;
-      q6 =  1.1363813E-10;
-    VAR n: INTEGER; y, yy, f: REAL;
-  BEGIN y := c1*x;
-    IF y >= 0.0 THEN n := FLOOR(y + 0.5) ELSE n := FLOOR(y - 0.5) END ;
-    y := (y - FLT(n)) * 2.0; yy := y*y;
-    IF ~ODD(n) THEN f := (((((q6*yy + q5)*yy + q4)*yy + q3)*yy + q2)*yy + q1)*yy + q0
-    ELSE f := ((((((p6*yy + p5)*yy + p4)*yy + p3)*yy + p2)*yy + p1)*yy + p0)*y
-    END ;
-    IF ODD((n+1) DIV 2) THEN f := -f END ;
-    RETURN f
-  END cos;
-END Math.
+MODULE Math;   (*Standard functions;  NW 12.10.2013*)
+
+  PROCEDURE sqrt*(x: REAL): REAL;
+    CONST c1 = 0.70710680;   (* 1/sqrt(2) *)
+      c2 = 0.590162067;
+      c3 = 1.4142135;  (*sqrt(2)*)
+    VAR s: REAL; e: INTEGER;
+  BEGIN ASSERT(x >= 0.0);
+    IF x > 0.0 THEN
+      UNPK(x, e);
+      s := c2*(x+c1);
+      s := s + (x/s);
+      s := 0.25*s + x/s;
+      s := 0.5 * (s + x/s);
+      IF ODD(e) THEN s := c3*s END ;
+      PACK(s, e DIV 2)
+    ELSE s := 0.0
+    END ;
+    RETURN s
+  END sqrt;
+
+  PROCEDURE exp*(x: REAL): REAL;
+    CONST
+      c1 = 1.4426951;  (*1/ln(2) *)
+      p0 = 1.513864173E3;
+      p1= 2.020170000E1;
+      p2 = 2.309432127E-2;
+      q0 = 4.368088670E3;
+      q1 = 2.331782320E2;
+    VAR n: INTEGER; p, y, yy: REAL;
+  BEGIN y := c1*x;
+    n := FLOOR(y + 0.5); y := y - FLT(n);
+    yy := y*y;
+    p := ((p2*yy + p1)*yy + p0)*y;
+    p := p/((yy + q1)*yy + q0 - p) + 0.5;
+    PACK(p, n+1); RETURN p
+  END exp;
+
+  PROCEDURE ln*(x: REAL): REAL;
+    CONST c1 = 0.70710680;  (* 1/sqrt(2) *)
+      c2 =  0.69314720;  (* ln(2) *)
+      p0 = -9.01746917E1;
+      p1 =  9.34639006E1;
+      p2 = -1.83278704E1;
+      q0 = -4.50873458E1;
+      q1 =  6.76106560E1;
+      q2 = -2.07334879E1;
+    VAR e: INTEGER; xx, y: REAL;
+  BEGIN ASSERT(x > 0.0); UNPK(x, e);
+    IF x < c1 THEN x := x*2.0; e := e-1 END ;
+    x := (x-1.0)/(x+1.0);
+    xx := x;
+    y := c2*FLT(e) + x*((p2*xx + p1)*xx + p0) / (((xx + q2)*xx + q1)*xx + q0);
+    RETURN y
+  END ln;
+
+  PROCEDURE sin*(x: REAL): REAL;
+    CONST
+      c1 =  6.3661977E-1; (*2/pi*)
+      p0 =  7.8539816E-1;
+      p1 = -8.0745512E-2;
+      p2 =  2.4903946E-3;
+      p3 = -3.6576204E-5;
+      p4 =  3.1336162E-7;
+      p5 = -1.7571493E-9;
+      p6 =  6.8771004E-12;
+      q0 =  9.9999999E-1;
+      q1 = -3.0842514E-1;
+      q2 =  1.5854344E-2;
+      q3 = -3.2599189E-4;
+      q4 =  3.5908591E-6;
+      q5 = -2.4609457E-8;
+      q6 =  1.1363813E-10;
+    VAR n: INTEGER; y, yy, f: REAL;
+  BEGIN y := c1*x;
+    IF y >= 0.0 THEN n := FLOOR(y + 0.5) ELSE n := FLOOR(y - 0.5) END ;
+    y := (y - FLT(n)) * 2.0; yy := y*y;
+    IF ODD(n) THEN f := (((((q6*yy + q5)*yy + q4)*yy + q3)*yy + q2)*yy + q1)*yy + q0
+    ELSE f := ((((((p6*yy + p5)*yy + p4)*yy + p3)*yy + p2)*yy + p1)*yy + p0)*y
+    END ;
+    IF ODD(n DIV 2) THEN f := -f END ;
+    RETURN f
+  END sin;
+
+  PROCEDURE cos*(x: REAL): REAL;
+    CONST
+      c1 =  6.3661977E-1; (*2/pi*)
+      p0 =  7.8539816E-1;
+      p1 = -8.0745512E-2;
+      p2 =  2.4903946E-3;
+      p3 = -3.6576204E-5;
+      p4 =  3.1336162E-7;
+      p5 = -1.7571493E-9;
+      p6 = 6.8771004E-12;
+      q0 =  9.9999999E-1;
+      q1 = -3.0842514E-1;
+      q2 =  1.5854344E-2;
+      q3 = -3.2599189E-4;
+      q4 =  3.5908591E-6;
+      q5 = -2.4609457E-8;
+      q6 =  1.1363813E-10;
+    VAR n: INTEGER; y, yy, f: REAL;
+  BEGIN y := c1*x;
+    IF y >= 0.0 THEN n := FLOOR(y + 0.5) ELSE n := FLOOR(y - 0.5) END ;
+    y := (y - FLT(n)) * 2.0; yy := y*y;
+    IF ~ODD(n) THEN f := (((((q6*yy + q5)*yy + q4)*yy + q3)*yy + q2)*yy + q1)*yy + q0
+    ELSE f := ((((((p6*yy + p5)*yy + p4)*yy + p3)*yy + p2)*yy + p1)*yy + p0)*y
+    END ;
+    IF ODD((n+1) DIV 2) THEN f := -f END ;
+    RETURN f
+  END cos;
+END Math.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/MenuViewers.Mod.txt

@@ -1,208 +1,208 @@
-MODULE MenuViewers; (*JG 26.8.90 / 16.9.93 / NW 10.3.2013*)
-  IMPORT Input, Display, Viewers, Oberon;
-
-  CONST extend* = 0; reduce* = 1; FrameColor = Display.white;
-
-  TYPE Viewer* = POINTER TO ViewerDesc;
-
-    ViewerDesc* = RECORD (Viewers.ViewerDesc)
-      menuH*: INTEGER
-    END;
-
-    ModifyMsg* = RECORD (Display.FrameMsg)
-      id*: INTEGER;
-      dY*, Y*, H*: INTEGER
-    END;
-
-  PROCEDURE Copy (V: Viewer; VAR V1: Viewer);
-    VAR Menu, Main: Display.Frame; M: Oberon.CopyMsg;
-  BEGIN Menu := V.dsc; Main := V.dsc.next;
-    NEW(V1); V1^ := V^; V1.state := 0;
-    M.F := NIL; Menu.handle(Menu, M); V1.dsc := M.F;
-    M.F := NIL; Main.handle(Main, M); V1.dsc.next := M.F
-  END Copy;
-
-  PROCEDURE Draw (V: Viewers.Viewer);
-  BEGIN
-    Display.ReplConst(FrameColor, V.X, V.Y, 1, V.H, Display.replace);
-    Display.ReplConst(FrameColor, V.X + V.W - 1, V.Y, 1, V.H, Display.replace);
-    Display.ReplConst(FrameColor, V.X + 1, V.Y, V.W - 2, 1, Display.replace);
-    Display.ReplConst(FrameColor, V.X + 1, V.Y + V.H - 1, V.W - 2, 1, Display.replace)
-  END Draw;
-
-  PROCEDURE Extend (V: Viewer; newY: INTEGER);
-    VAR dH: INTEGER;
-  BEGIN dH := V.Y - newY;
-    IF dH > 0 THEN
-      Display.ReplConst(Display.black, V.X + 1, newY + 1, V.W - 2, dH, Display.replace);
-      Display.ReplConst(FrameColor, V.X, newY, 1, dH, Display.replace);
-      Display.ReplConst(FrameColor, V.X + V.W - 1, newY, 1, dH, Display.replace);
-      Display.ReplConst(FrameColor, V.X + 1, newY, V.W - 2, 1, Display.replace)
-    END
-  END Extend;
-
-  PROCEDURE Reduce (V: Viewer; newY: INTEGER);
-  BEGIN Display.ReplConst(FrameColor, V.X + 1, newY, V.W - 2, 1, Display.replace)
-  END Reduce;
-
-  PROCEDURE Grow (V: Viewer; oldH: INTEGER);
-    VAR dH: INTEGER;
-  BEGIN dH := V.H - oldH;
-    IF dH > 0 THEN
-      Display.ReplConst(FrameColor, V.X, V.Y + oldH, 1, dH, Display.replace);
-      Display.ReplConst(FrameColor, V.X + V.W - 1, V.Y + oldH, 1, dH, Display.replace);
-      Display.ReplConst(FrameColor, V.X + 1, V.Y + V.H - 1, V.W - 2, 1, Display.replace)
-    END
-  END Grow;
-
-  PROCEDURE Shrink (V: Viewer; newH: INTEGER);
-  BEGIN Display.ReplConst(FrameColor, V.X + 1, V.Y + newH - 1, V.W - 2, 1, Display.replace)
-  END Shrink;
-
-  PROCEDURE Adjust (F: Display.Frame; id, dY, Y, H: INTEGER);
-    VAR M: ModifyMsg;
-  BEGIN M.id := id; M.dY := dY; M.Y := Y; M.H := H; F.handle(F, M); F.Y := Y; F.H := H
-  END Adjust;
-
-  PROCEDURE Restore (V: Viewer);
-    VAR Menu, Main: Display.Frame;
-  BEGIN Menu := V.dsc; Main := V.dsc.next;
-    Oberon.RemoveMarks(V.X, V.Y, V.W, V.H);
-    Draw(V);
-    Menu.X := V.X + 1; Menu.Y := V.Y + V.H - 1; Menu.W := V.W - 2; Menu.H := 0;
-    Main.X := V.X + 1; Main.Y := V.Y + V.H - V.menuH; Main.W := V.W - 2; Main.H := 0;
-    IF V.H > V.menuH + 1 THEN
-      Adjust(Menu, extend, 0, V.Y + V.H - V.menuH, V.menuH - 1);
-      Adjust(Main, extend, 0, V.Y + 1, V.H - V.menuH - 1)
-    ELSE Adjust(Menu, extend, 0, V.Y + 1, V.H - 2)
-    END
-  END Restore;
-
-  PROCEDURE Modify (V: Viewer; Y, H: INTEGER);
-    VAR Menu, Main: Display.Frame;
-  BEGIN Menu := V.dsc; Main := V.dsc.next;
-    IF Y < V.Y THEN (*extend*)
-      Oberon.RemoveMarks(V.X, Y, V.W, V.Y - Y);
-      Extend(V, Y);
-      IF H > V.menuH + 1 THEN
-        Adjust(Menu, extend, 0, Y + H - V.menuH, V.menuH - 1);
-        Adjust(Main, extend, 0, Y + 1, H - V.menuH - 1)
-      ELSE Adjust(Menu, extend, 0, Y + 1, H - 2)
-      END
-    ELSIF Y > V.Y THEN (*reduce*)
-      Oberon.RemoveMarks(V.X, V.Y, V.W, V.H);
-      IF H > V.menuH + 1 THEN
-        Adjust(Main, reduce, 0, Y + 1, H - V.menuH - 1);
-        Adjust(Menu, reduce, 0, Y + H - V.menuH, V.menuH - 1)
-      ELSE
-        Adjust(Main, reduce, 0, Y + H - V.menuH, 0);
-        Adjust(Menu, reduce, 0, Y + 1, H - 2)
-      END;
-      Reduce(V, Y)
-    END
-  END Modify;
-
-  PROCEDURE Change (V: Viewer; X, Y: INTEGER; Keys: SET);
-    VAR Menu, Main: Display.Frame;
-      V1: Viewers.Viewer;
-      keysum: SET; Y0, dY, H: INTEGER;
-  BEGIN (*Keys # {}*)
-    Menu := V.dsc; Main := V.dsc.next;
-    Oberon.DrawMouseArrow(X, Y);
-    Display.ReplConst(Display.white, V.X + 1, V.Y + V.H - 1 - V.dsc.H, V.W - 2, V.dsc.H, Display.invert);
-    Y0 := Y; keysum := Keys; Input.Mouse(Keys, X, Y);
-    WHILE Keys # {} DO
-      keysum := keysum + Keys;
-      Oberon.DrawMouseArrow(X, Y); Input.Mouse(Keys, X, Y)
-    END;
-    Display.ReplConst(Display.white, V.X + 1, V.Y + V.H - 1 - V.dsc.H, V.W - 2, V.dsc.H, Display.invert);
-    IF ~(0 IN keysum) THEN
-      IF 1 IN keysum THEN V1 := Viewers.This(X, Y);
-        IF (V1 IS Viewer) & (Y > V1.Y + V1.H - V1(Viewer).menuH - 2) THEN Y := V1.Y + V1.H END;
-        IF Y < V1.Y + V.menuH + 2 THEN Y := V1.Y + V.menuH + 2 END;
-        Viewers.Close(V); Viewers.Open(V, X, Y); Restore(V)
-      ELSE
-        IF Y > Y0 THEN (*extend*) dY := Y - Y0;
-          V1 := Viewers.Next(V);
-          IF V1.state > 1 THEN
-            CASE V1 OF
-            Viewer:
-              IF V1.H < V1.menuH + 2 THEN dY := 0
-              ELSIF V1.H < V1.menuH + 2 + dY THEN dY := V1.H - V1.menuH - 2
-              END |
-            Viewers.Viewer: IF V1.H < 1 + dY THEN dY := V1.H - 1 END
-            END
-          ELSIF V1.H < dY THEN dY := V1.H
-          END;
-          Viewers.Change(V, V.Y + V.H + dY);
-          Oberon.RemoveMarks(V.X, V.Y, V.W, V.H);
-          Grow(V, V.H - dY);
-          IF V.H > V.menuH + 1 THEN
-            Adjust(Menu, extend, dY, V.Y + V.H - V.menuH, V.menuH - 1);
-            Adjust(Main, extend, dY, V.Y + 1, V.H - V.menuH - 1)
-          ELSE (*V.H > 1*)
-            Adjust(Menu, extend, dY, V.Y + 1, V.H - 2);
-            Adjust(Main, extend, dY, V.Y + V.H - V.menuH, 0)
-          END
-        ELSIF Y < Y0 THEN (*reduce*) dY := Y0 - Y;
-          IF V.H >= V.menuH + 2 THEN
-            IF V.H < V.menuH + 2 + dY THEN dY := V.H - V.menuH - 2 END;
-            Oberon.RemoveMarks(V.X, V.Y, V.W, V.H);
-            H := V.H - dY;
-            Adjust(Main, reduce, dY, V.Y + 1, H - V.menuH - 1);
-            Adjust(Menu, reduce, dY, V.Y + H - V.menuH, V.menuH - 1);
-            Shrink(V, H); Viewers.Change(V, V.Y + H)
-          END
-        END
-      END
-    END
-  END Change;
-
-  PROCEDURE Suspend (V: Viewer);
-    VAR Menu, Main: Display.Frame;
-  BEGIN Menu := V.dsc; Main := V.dsc.next;
-    Adjust(Main, reduce, 0, V.Y + V.H - V.menuH, 0);
-    Adjust(Menu, reduce, 0, V.Y + V.H - 1, 0)
-  END Suspend;
-
-  PROCEDURE Handle* (V: Display.Frame; VAR M: Display.FrameMsg);
-    VAR X, Y: INTEGER;
-      Menu, Main: Display.Frame; V1: Viewer;
-  BEGIN Menu := V.dsc; Main := V.dsc.next;
-      CASE M OF
-      Oberon.InputMsg:
-        IF M.id = Oberon.track THEN
-          X := M.X; Y := M.Y;
-          IF Y < V.Y + 1 THEN Oberon.DrawMouseArrow(X, Y)
-          ELSIF Y < V.Y + V.H - V(Viewer).menuH THEN Main.handle(Main, M)
-          ELSIF Y < V.Y + V.H - V(Viewer).menuH + 2 THEN Menu.handle(Menu, M)
-          ELSIF Y < V.Y + V.H - 1 THEN
-            IF 2 IN M.keys THEN Change(V(Viewer), X, Y, M.keys) ELSE Menu.handle(Menu, M) END
-          ELSE Oberon.DrawMouseArrow(X, Y)
-          END
-        ELSE Menu.handle(Menu, M); Main.handle(Main, M)
-        END |
-      Oberon.ControlMsg:
-        IF M.id = Oberon.mark THEN
-          X := M.X; Y := M.Y; Oberon.DrawMouseArrow(X, Y); Oberon.DrawPointer(X, Y)
-        ELSE Menu.handle(Menu, M); Main.handle(Main, M)
-        END |
-      Oberon.CopyMsg:
-        Copy(V(Viewer), V1); M.F := V1 |
-      Viewers.ViewerMsg:
-        IF M.id = Viewers.restore THEN Restore(V(Viewer))
-        ELSIF M.id = Viewers.modify THEN Modify(V(Viewer), M.Y, M.H)
-        ELSIF M.id = Viewers.suspend THEN Suspend(V(Viewer))
-        END |
-      Display.FrameMsg: Menu.handle(Menu, M); Main.handle(Main, M)
-      END
-  END Handle;
-
-  PROCEDURE New* (Menu, Main: Display.Frame; menuH, X, Y: INTEGER): Viewer; 
-    VAR V: Viewer;
-  BEGIN NEW(V);
-    V.handle := Handle; V.dsc := Menu; V.dsc.next := Main; V.menuH := menuH;
-    Viewers.Open(V, X, Y); Restore(V); RETURN V
-  END New;
-
-END MenuViewers.
+MODULE MenuViewers; (*JG 26.8.90 / 16.9.93 / NW 10.3.2013*)
+  IMPORT Input, Display, Viewers, Oberon;
+
+  CONST extend* = 0; reduce* = 1; FrameColor = Display.white;
+
+  TYPE Viewer* = POINTER TO ViewerDesc;
+
+    ViewerDesc* = RECORD (Viewers.ViewerDesc)
+      menuH*: INTEGER
+    END;
+
+    ModifyMsg* = RECORD (Display.FrameMsg)
+      id*: INTEGER;
+      dY*, Y*, H*: INTEGER
+    END;
+
+  PROCEDURE Copy (V: Viewer; VAR V1: Viewer);
+    VAR Menu, Main: Display.Frame; M: Oberon.CopyMsg;
+  BEGIN Menu := V.dsc; Main := V.dsc.next;
+    NEW(V1); V1^ := V^; V1.state := 0;
+    M.F := NIL; Menu.handle(Menu, M); V1.dsc := M.F;
+    M.F := NIL; Main.handle(Main, M); V1.dsc.next := M.F
+  END Copy;
+
+  PROCEDURE Draw (V: Viewers.Viewer);
+  BEGIN
+    Display.ReplConst(FrameColor, V.X, V.Y, 1, V.H, Display.replace);
+    Display.ReplConst(FrameColor, V.X + V.W - 1, V.Y, 1, V.H, Display.replace);
+    Display.ReplConst(FrameColor, V.X + 1, V.Y, V.W - 2, 1, Display.replace);
+    Display.ReplConst(FrameColor, V.X + 1, V.Y + V.H - 1, V.W - 2, 1, Display.replace)
+  END Draw;
+
+  PROCEDURE Extend (V: Viewer; newY: INTEGER);
+    VAR dH: INTEGER;
+  BEGIN dH := V.Y - newY;
+    IF dH > 0 THEN
+      Display.ReplConst(Display.black, V.X + 1, newY + 1, V.W - 2, dH, Display.replace);
+      Display.ReplConst(FrameColor, V.X, newY, 1, dH, Display.replace);
+      Display.ReplConst(FrameColor, V.X + V.W - 1, newY, 1, dH, Display.replace);
+      Display.ReplConst(FrameColor, V.X + 1, newY, V.W - 2, 1, Display.replace)
+    END
+  END Extend;
+
+  PROCEDURE Reduce (V: Viewer; newY: INTEGER);
+  BEGIN Display.ReplConst(FrameColor, V.X + 1, newY, V.W - 2, 1, Display.replace)
+  END Reduce;
+
+  PROCEDURE Grow (V: Viewer; oldH: INTEGER);
+    VAR dH: INTEGER;
+  BEGIN dH := V.H - oldH;
+    IF dH > 0 THEN
+      Display.ReplConst(FrameColor, V.X, V.Y + oldH, 1, dH, Display.replace);
+      Display.ReplConst(FrameColor, V.X + V.W - 1, V.Y + oldH, 1, dH, Display.replace);
+      Display.ReplConst(FrameColor, V.X + 1, V.Y + V.H - 1, V.W - 2, 1, Display.replace)
+    END
+  END Grow;
+
+  PROCEDURE Shrink (V: Viewer; newH: INTEGER);
+  BEGIN Display.ReplConst(FrameColor, V.X + 1, V.Y + newH - 1, V.W - 2, 1, Display.replace)
+  END Shrink;
+
+  PROCEDURE Adjust (F: Display.Frame; id, dY, Y, H: INTEGER);
+    VAR M: ModifyMsg;
+  BEGIN M.id := id; M.dY := dY; M.Y := Y; M.H := H; F.handle(F, M); F.Y := Y; F.H := H
+  END Adjust;
+
+  PROCEDURE Restore (V: Viewer);
+    VAR Menu, Main: Display.Frame;
+  BEGIN Menu := V.dsc; Main := V.dsc.next;
+    Oberon.RemoveMarks(V.X, V.Y, V.W, V.H);
+    Draw(V);
+    Menu.X := V.X + 1; Menu.Y := V.Y + V.H - 1; Menu.W := V.W - 2; Menu.H := 0;
+    Main.X := V.X + 1; Main.Y := V.Y + V.H - V.menuH; Main.W := V.W - 2; Main.H := 0;
+    IF V.H > V.menuH + 1 THEN
+      Adjust(Menu, extend, 0, V.Y + V.H - V.menuH, V.menuH - 1);
+      Adjust(Main, extend, 0, V.Y + 1, V.H - V.menuH - 1)
+    ELSE Adjust(Menu, extend, 0, V.Y + 1, V.H - 2)
+    END
+  END Restore;
+
+  PROCEDURE Modify (V: Viewer; Y, H: INTEGER);
+    VAR Menu, Main: Display.Frame;
+  BEGIN Menu := V.dsc; Main := V.dsc.next;
+    IF Y < V.Y THEN (*extend*)
+      Oberon.RemoveMarks(V.X, Y, V.W, V.Y - Y);
+      Extend(V, Y);
+      IF H > V.menuH + 1 THEN
+        Adjust(Menu, extend, 0, Y + H - V.menuH, V.menuH - 1);
+        Adjust(Main, extend, 0, Y + 1, H - V.menuH - 1)
+      ELSE Adjust(Menu, extend, 0, Y + 1, H - 2)
+      END
+    ELSIF Y > V.Y THEN (*reduce*)
+      Oberon.RemoveMarks(V.X, V.Y, V.W, V.H);
+      IF H > V.menuH + 1 THEN
+        Adjust(Main, reduce, 0, Y + 1, H - V.menuH - 1);
+        Adjust(Menu, reduce, 0, Y + H - V.menuH, V.menuH - 1)
+      ELSE
+        Adjust(Main, reduce, 0, Y + H - V.menuH, 0);
+        Adjust(Menu, reduce, 0, Y + 1, H - 2)
+      END;
+      Reduce(V, Y)
+    END
+  END Modify;
+
+  PROCEDURE Change (V: Viewer; X, Y: INTEGER; Keys: SET);
+    VAR Menu, Main: Display.Frame;
+      V1: Viewers.Viewer;
+      keysum: SET; Y0, dY, H: INTEGER;
+  BEGIN (*Keys # {}*)
+    Menu := V.dsc; Main := V.dsc.next;
+    Oberon.DrawMouseArrow(X, Y);
+    Display.ReplConst(Display.white, V.X + 1, V.Y + V.H - 1 - V.dsc.H, V.W - 2, V.dsc.H, Display.invert);
+    Y0 := Y; keysum := Keys; Input.Mouse(Keys, X, Y);
+    WHILE Keys # {} DO
+      keysum := keysum + Keys;
+      Oberon.DrawMouseArrow(X, Y); Input.Mouse(Keys, X, Y)
+    END;
+    Display.ReplConst(Display.white, V.X + 1, V.Y + V.H - 1 - V.dsc.H, V.W - 2, V.dsc.H, Display.invert);
+    IF ~(0 IN keysum) THEN
+      IF 1 IN keysum THEN V1 := Viewers.This(X, Y);
+        IF (V1 IS Viewer) & (Y > V1.Y + V1.H - V1(Viewer).menuH - 2) THEN Y := V1.Y + V1.H END;
+        IF Y < V1.Y + V.menuH + 2 THEN Y := V1.Y + V.menuH + 2 END;
+        Viewers.Close(V); Viewers.Open(V, X, Y); Restore(V)
+      ELSE
+        IF Y > Y0 THEN (*extend*) dY := Y - Y0;
+          V1 := Viewers.Next(V);
+          IF V1.state > 1 THEN
+            CASE V1 OF
+            Viewer:
+              IF V1.H < V1.menuH + 2 THEN dY := 0
+              ELSIF V1.H < V1.menuH + 2 + dY THEN dY := V1.H - V1.menuH - 2
+              END |
+            Viewers.Viewer: IF V1.H < 1 + dY THEN dY := V1.H - 1 END
+            END
+          ELSIF V1.H < dY THEN dY := V1.H
+          END;
+          Viewers.Change(V, V.Y + V.H + dY);
+          Oberon.RemoveMarks(V.X, V.Y, V.W, V.H);
+          Grow(V, V.H - dY);
+          IF V.H > V.menuH + 1 THEN
+            Adjust(Menu, extend, dY, V.Y + V.H - V.menuH, V.menuH - 1);
+            Adjust(Main, extend, dY, V.Y + 1, V.H - V.menuH - 1)
+          ELSE (*V.H > 1*)
+            Adjust(Menu, extend, dY, V.Y + 1, V.H - 2);
+            Adjust(Main, extend, dY, V.Y + V.H - V.menuH, 0)
+          END
+        ELSIF Y < Y0 THEN (*reduce*) dY := Y0 - Y;
+          IF V.H >= V.menuH + 2 THEN
+            IF V.H < V.menuH + 2 + dY THEN dY := V.H - V.menuH - 2 END;
+            Oberon.RemoveMarks(V.X, V.Y, V.W, V.H);
+            H := V.H - dY;
+            Adjust(Main, reduce, dY, V.Y + 1, H - V.menuH - 1);
+            Adjust(Menu, reduce, dY, V.Y + H - V.menuH, V.menuH - 1);
+            Shrink(V, H); Viewers.Change(V, V.Y + H)
+          END
+        END
+      END
+    END
+  END Change;
+
+  PROCEDURE Suspend (V: Viewer);
+    VAR Menu, Main: Display.Frame;
+  BEGIN Menu := V.dsc; Main := V.dsc.next;
+    Adjust(Main, reduce, 0, V.Y + V.H - V.menuH, 0);
+    Adjust(Menu, reduce, 0, V.Y + V.H - 1, 0)
+  END Suspend;
+
+  PROCEDURE Handle* (V: Display.Frame; VAR M: Display.FrameMsg);
+    VAR X, Y: INTEGER;
+      Menu, Main: Display.Frame; V1: Viewer;
+  BEGIN Menu := V.dsc; Main := V.dsc.next;
+      CASE M OF
+      Oberon.InputMsg:
+        IF M.id = Oberon.track THEN
+          X := M.X; Y := M.Y;
+          IF Y < V.Y + 1 THEN Oberon.DrawMouseArrow(X, Y)
+          ELSIF Y < V.Y + V.H - V(Viewer).menuH THEN Main.handle(Main, M)
+          ELSIF Y < V.Y + V.H - V(Viewer).menuH + 2 THEN Menu.handle(Menu, M)
+          ELSIF Y < V.Y + V.H - 1 THEN
+            IF 2 IN M.keys THEN Change(V(Viewer), X, Y, M.keys) ELSE Menu.handle(Menu, M) END
+          ELSE Oberon.DrawMouseArrow(X, Y)
+          END
+        ELSE Menu.handle(Menu, M); Main.handle(Main, M)
+        END |
+      Oberon.ControlMsg:
+        IF M.id = Oberon.mark THEN
+          X := M.X; Y := M.Y; Oberon.DrawMouseArrow(X, Y); Oberon.DrawPointer(X, Y)
+        ELSE Menu.handle(Menu, M); Main.handle(Main, M)
+        END |
+      Oberon.CopyMsg:
+        Copy(V(Viewer), V1); M.F := V1 |
+      Viewers.ViewerMsg:
+        IF M.id = Viewers.restore THEN Restore(V(Viewer))
+        ELSIF M.id = Viewers.modify THEN Modify(V(Viewer), M.Y, M.H)
+        ELSIF M.id = Viewers.suspend THEN Suspend(V(Viewer))
+        END |
+      Display.FrameMsg: Menu.handle(Menu, M); Main.handle(Main, M)
+      END
+  END Handle;
+
+  PROCEDURE New* (Menu, Main: Display.Frame; menuH, X, Y: INTEGER): Viewer; 
+    VAR V: Viewer;
+  BEGIN NEW(V);
+    V.handle := Handle; V.dsc := Menu; V.dsc.next := Main; V.menuH := menuH;
+    Viewers.Open(V, X, Y); Restore(V); RETURN V
+  END New;
+
+END MenuViewers.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Modules.Mod.txt

@@ -1,225 +1,225 @@
-MODULE Modules;  (*Link and load on RISC; NW 20.10.2013 / 8.1.2019*)
-  IMPORT SYSTEM, Files;
-  CONST versionkey = 1X; MT = 12; DescSize = 80;
-
-  TYPE Module* = POINTER TO ModDesc;
-    Command* = PROCEDURE;
-    ModuleName* = ARRAY 32 OF CHAR;
-
-    ModDesc* = RECORD
-        name*: ModuleName;
-        next*: Module;
-        key*, num*, size*, refcnt*: INTEGER;
-        data*, code*, imp*, cmd*, ent*, ptr*, unused: INTEGER  (*addresses*)
-      END ;
-
-  VAR root*, M: Module;
-    MTOrg*, AllocPtr*, res*: INTEGER;
-    importing*, imported*: ModuleName;
-    limit: INTEGER;
-
-  PROCEDURE ThisFile(name: ARRAY OF CHAR): Files.File;
-    VAR i: INTEGER;
-      filename: ModuleName;
-  BEGIN i := 0;
-    WHILE name[i] # 0X DO filename[i] := name[i]; INC(i) END ;
-    filename[i] := "."; filename[i+1] := "r"; filename[i+2] := "s"; filename[i+3] := "c"; filename[i+4] := 0X;
-    RETURN Files.Old(filename)
-  END ThisFile;
-
-  PROCEDURE error(n: INTEGER; name: ARRAY OF CHAR);
-  BEGIN res := n; importing := name
-  END error;
-
-  PROCEDURE Check(s: ARRAY OF CHAR);
-    VAR i: INTEGER; ch: CHAR;
-  BEGIN ch := s[0]; res := 1; i := 1;
-    IF (ch >= "A") & (ch <= "Z") OR (ch >= "a") & (ch <= "z") THEN
-      REPEAT ch := s[i]; INC(i)
-      UNTIL ~((ch >= "0") & (ch <= "9") OR (ch >= "A") & (ch <= "Z")
-        OR (ch >= "a") & (ch <= "z") OR (ch = ".")) OR (i = 32);
-      IF (i < 32) & (ch = 0X) THEN res := 0 END
-    END
-  END Check;
-
-  PROCEDURE Load*(name: ARRAY OF CHAR; VAR newmod: Module);
-    (*search module in list; if not found, load module.
-      res = 0: already present or loaded; res = 2: file not available; res = 3: key conflict;
-      res = 4: bad file version; res = 5: corrupted file; res = 7: no space*)
-    VAR mod, impmod: Module;
-      i, n, key, impkey, mno, nofimps, size: INTEGER;
-      p, u, v, w: INTEGER;  (*addresses*)
-      ch: CHAR;
-      body: Command;
-      fixorgP, fixorgD, fixorgT: INTEGER;
-      disp, adr, inst, pno, vno, dest, offset: INTEGER;
-      name1, impname: ModuleName;
-      F: Files.File; R: Files.Rider;
-      import: ARRAY 16 OF Module;
-  BEGIN mod := root; error(0, name); nofimps := 0;
-    WHILE (mod # NIL) & (name # mod.name) DO mod := mod.next END ;
-    IF mod = NIL THEN (*load*)
-      Check(name);
-      IF res = 0 THEN F := ThisFile(name) ELSE F := NIL END ;
-      IF F # NIL THEN
-        Files.Set(R, F, 0); Files.ReadString(R, name1); Files.ReadInt(R, key); Files.Read(R, ch);
-        Files.ReadInt(R, size); importing := name1;
-        IF ch = versionkey THEN
-          Files.ReadString(R, impname);   (*imports*)
-          WHILE (impname[0] # 0X) & (res = 0) DO
-            Files.ReadInt(R, impkey);
-            Load(impname, impmod); import[nofimps] := impmod; importing := name1;
-            IF res = 0 THEN
-              IF impmod.key = impkey THEN INC(impmod.refcnt); INC(nofimps)
-              ELSE error(3, name1); imported := impname
-              END
-            END ;
-            Files.ReadString(R, impname)
-          END
-        ELSE error(2, name1)
-        END
-      ELSE error(1, name)
-      END ;
-      IF res = 0 THEN (*search for a hole in the list allocate and link*)
-        INC(size, DescSize); mod := root;
-        WHILE (mod # NIL) & ~((mod.name[0] = 0X) & (mod.size >= size)) DO mod := mod.next END ;
-        IF mod = NIL THEN (*no large enough hole was found*)
-          IF AllocPtr + size < limit THEN (*allocate*)
-            p := AllocPtr; mod := SYSTEM.VAL(Module, p);
-            AllocPtr := (p + size + 100H) DIV 20H * 20H; mod.size := AllocPtr - p; mod.num := root.num + 1;
-            mod.next := root; root := mod
-          ELSE error(7, name1)
-          END
-        ELSE (*fill hole*) p := SYSTEM.VAL(INTEGER, mod)
-        END
-      END ; 
-      IF res = 0 THEN (*read file*)
-        INC(p, DescSize); (*allocate descriptor*)
-        mod.name := name; mod.key := key; mod.refcnt := 0;
-        mod.data := p;  (*data*)
-        SYSTEM.PUT(mod.num * 4 + MTOrg, p);  (*module table entry*)
-        Files.ReadInt(R, n);
-        WHILE n > 0 DO Files.ReadInt(R, w); SYSTEM.PUT(p, w); INC(p, 4); DEC(n, 4) END ;  (*type descriptors*)
-        Files.ReadInt(R, n);
-        WHILE n > 0 DO SYSTEM.PUT(p, 0); INC(p, 4); DEC(n, 4) END ;  (*variable space*)
-        Files.ReadInt(R, n);
-        WHILE n > 0 DO Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p); DEC(n) END ;   (*strings*)
-        mod.code := p;  (*program*)
-        Files.ReadInt(R, n);
-        WHILE n > 0 DO Files.ReadInt(R, w); SYSTEM.PUT(p, w); INC(p, 4); DEC(n) END ;  (*program code*)
-        mod.imp := p;  (*copy imports*)
-        i := 0;
-        WHILE i < nofimps DO
-          SYSTEM.PUT(p, import[i]); INC(p, 4); INC(i)
-        END ;
-        mod.cmd := p;  (*commands*) Files.Read(R, ch);
-        WHILE ch # 0X DO
-          REPEAT SYSTEM.PUT(p, ch); INC(p); Files.Read(R, ch) UNTIL ch = 0X;
-          REPEAT SYSTEM.PUT(p, 0X); INC(p) UNTIL p MOD 4 = 0;
-          Files.ReadInt(R, n); SYSTEM.PUT(p, n); INC(p, 4); Files.Read(R, ch)
-        END ;
-        REPEAT SYSTEM.PUT(p, 0X); INC(p) UNTIL p MOD 4 = 0;
-        mod.ent := p;  (*entries*)
-        Files.ReadInt(R, n);
-        WHILE n > 0 DO Files.ReadInt(R, w); SYSTEM.PUT(p, w); INC(p, 4); DEC(n) END ;
-        mod.ptr := p;  (*pointer references*)
-        Files.ReadInt(R, w);
-        WHILE w >= 0 DO SYSTEM.PUT(p, mod.data + w); INC(p, 4); Files.ReadInt(R, w) END ;
-        SYSTEM.PUT(p, 0); INC(p, 4);
-        Files.ReadInt(R, fixorgP); Files.ReadInt(R, fixorgD); Files.ReadInt(R, fixorgT);
-        Files.ReadInt(R, w); body := SYSTEM.VAL(Command, mod.code + w);
-        Files.Read(R, ch);
-        IF ch # "O" THEN (*corrupted file*)  mod := NIL; error(4, name) END
-      END ;
-      IF res = 0 THEN (*fixup of BL*)
-        adr := mod.code + fixorgP*4;
-        WHILE adr # mod.code DO
-          SYSTEM.GET(adr, inst);
-          mno := inst DIV 100000H MOD 10H;
-          pno := inst DIV 1000H MOD 100H;
-          disp := inst MOD 1000H;
-          SYSTEM.GET(mod.imp + (mno-1)*4, impmod);
-          SYSTEM.GET(impmod.ent + pno*4, dest); dest := dest + impmod.code;
-          offset := (dest - adr - 4) DIV 4;
-          SYSTEM.PUT(adr, (offset MOD 1000000H) + 0F7000000H);
-          adr := adr - disp*4
-        END ;
-        (*fixup of LDR/STR/ADD*)
-        adr := mod.code + fixorgD*4;
-        WHILE adr # mod.code DO
-          SYSTEM.GET(adr, inst);
-          mno := inst DIV 100000H MOD 10H;
-          disp := inst MOD 1000H;
-          IF mno = 0 THEN (*global*)
-            SYSTEM.PUT(adr, (inst DIV 1000000H * 10H + MT) * 100000H + mod.num * 4)
-          ELSE (*import*)
-            SYSTEM.GET(mod.imp + (mno-1)*4, impmod); v := impmod.num;
-            SYSTEM.PUT(adr, (inst DIV 1000000H * 10H + MT) * 100000H + v*4);
-            SYSTEM.GET(adr+4, inst); vno := inst MOD 100H;
-            SYSTEM.GET(impmod.ent + vno*4, offset);
-            IF ODD(inst DIV 100H) THEN offset := offset + impmod.code - impmod.data END ;
-            SYSTEM.PUT(adr+4, inst DIV 10000H * 10000H + offset)
-          END ;
-          adr := adr - disp*4
-        END ;
-        (*fixup of type descriptors*)
-        adr := mod.data + fixorgT*4;
-        WHILE adr # mod.data DO
-          SYSTEM.GET(adr, inst);
-          mno := inst DIV 1000000H MOD 10H;
-          vno := inst DIV 1000H MOD 1000H;
-          disp := inst MOD 1000H;
-          IF mno = 0 THEN (*global*) inst := mod.data + vno
-          ELSE (*import*)
-            SYSTEM.GET(mod.imp + (mno-1)*4, impmod);
-            SYSTEM.GET(impmod.ent + vno*4, offset);
-            inst := impmod.data + offset
-          END ;
-          SYSTEM.PUT(adr, inst); adr := adr - disp*4
-        END ;
-        body   (*initialize module*)
-      ELSIF res >= 3 THEN importing := name;
-        WHILE nofimps > 0 DO DEC(nofimps); DEC(import[nofimps].refcnt) END
-      END 
-    END ;
-    newmod :=  mod
-  END Load;
-
-  PROCEDURE ThisCommand*(mod: Module; name: ARRAY OF CHAR): Command;
-    VAR k, adr, w: INTEGER; ch: CHAR;
-      s: ARRAY 32 OF CHAR;
-  BEGIN res := 5; w := 0;
-    IF mod # NIL THEN
-      adr := mod.cmd; SYSTEM.GET(adr, ch);
-      WHILE (ch # 0X) & (res # 0) DO k := 0; (*read command name*)
-        REPEAT s[k] := ch; INC(k); INC(adr); SYSTEM.GET(adr, ch) UNTIL ch = 0X;
-        s[k] := 0X;
-        REPEAT INC(adr) UNTIL adr MOD 4 = 0;
-        SYSTEM.GET(adr, k); INC(adr, 4);
-        IF s = name THEN res := 0; w := mod.code + k ELSE SYSTEM.GET(adr, ch) END
-      END
-    END
-    RETURN SYSTEM.VAL(Command, w)
-  END ThisCommand;
-
-  PROCEDURE Free*(name: ARRAY OF CHAR);
-    VAR mod, imp: Module; p, q: INTEGER;
-  BEGIN mod := root; res := 0;
-    WHILE (mod # NIL) & (mod.name # name) DO mod := mod.next END ;
-    IF mod # NIL THEN
-      IF mod.refcnt = 0 THEN
-        mod.name[0] := 0X; p := mod.imp; q := mod.cmd;
-        WHILE p < q DO SYSTEM.GET(p, imp); DEC(imp.refcnt); INC(p, 4) END ;
-      ELSE res := 1
-      END
-    END
-  END Free;
-
-  PROCEDURE Init*;
-  BEGIN Files.Init; MTOrg := SYSTEM.REG(MT);
-    SYSTEM.GET(16, AllocPtr); SYSTEM.GET(20, root); SYSTEM.GET(24, limit); DEC(limit, 8000H)
-  END Init;
-
-BEGIN Init; Load("Oberon", M);
-    LED(res); REPEAT UNTIL FALSE  (*only if load fails*)
-END Modules.
+MODULE Modules;  (*Link and load on RISC; NW 20.10.2013 / 8.1.2019*)
+  IMPORT SYSTEM, Files;
+  CONST versionkey = 1X; MT = 12; DescSize = 80;
+
+  TYPE Module* = POINTER TO ModDesc;
+    Command* = PROCEDURE;
+    ModuleName* = ARRAY 32 OF CHAR;
+
+    ModDesc* = RECORD
+        name*: ModuleName;
+        next*: Module;
+        key*, num*, size*, refcnt*: INTEGER;
+        data*, code*, imp*, cmd*, ent*, ptr*, unused: INTEGER  (*addresses*)
+      END ;
+
+  VAR root*, M: Module;
+    MTOrg*, AllocPtr*, res*: INTEGER;
+    importing*, imported*: ModuleName;
+    limit: INTEGER;
+
+  PROCEDURE ThisFile(name: ARRAY OF CHAR): Files.File;
+    VAR i: INTEGER;
+      filename: ModuleName;
+  BEGIN i := 0;
+    WHILE name[i] # 0X DO filename[i] := name[i]; INC(i) END ;
+    filename[i] := "."; filename[i+1] := "r"; filename[i+2] := "s"; filename[i+3] := "c"; filename[i+4] := 0X;
+    RETURN Files.Old(filename)
+  END ThisFile;
+
+  PROCEDURE error(n: INTEGER; name: ARRAY OF CHAR);
+  BEGIN res := n; importing := name
+  END error;
+
+  PROCEDURE Check(s: ARRAY OF CHAR);
+    VAR i: INTEGER; ch: CHAR;
+  BEGIN ch := s[0]; res := 1; i := 1;
+    IF (ch >= "A") & (ch <= "Z") OR (ch >= "a") & (ch <= "z") THEN
+      REPEAT ch := s[i]; INC(i)
+      UNTIL ~((ch >= "0") & (ch <= "9") OR (ch >= "A") & (ch <= "Z")
+        OR (ch >= "a") & (ch <= "z") OR (ch = ".")) OR (i = 32);
+      IF (i < 32) & (ch = 0X) THEN res := 0 END
+    END
+  END Check;
+
+  PROCEDURE Load*(name: ARRAY OF CHAR; VAR newmod: Module);
+    (*search module in list; if not found, load module.
+      res = 0: already present or loaded; res = 2: file not available; res = 3: key conflict;
+      res = 4: bad file version; res = 5: corrupted file; res = 7: no space*)
+    VAR mod, impmod: Module;
+      i, n, key, impkey, mno, nofimps, size: INTEGER;
+      p, u, v, w: INTEGER;  (*addresses*)
+      ch: CHAR;
+      body: Command;
+      fixorgP, fixorgD, fixorgT: INTEGER;
+      disp, adr, inst, pno, vno, dest, offset: INTEGER;
+      name1, impname: ModuleName;
+      F: Files.File; R: Files.Rider;
+      import: ARRAY 16 OF Module;
+  BEGIN mod := root; error(0, name); nofimps := 0;
+    WHILE (mod # NIL) & (name # mod.name) DO mod := mod.next END ;
+    IF mod = NIL THEN (*load*)
+      Check(name);
+      IF res = 0 THEN F := ThisFile(name) ELSE F := NIL END ;
+      IF F # NIL THEN
+        Files.Set(R, F, 0); Files.ReadString(R, name1); Files.ReadInt(R, key); Files.Read(R, ch);
+        Files.ReadInt(R, size); importing := name1;
+        IF ch = versionkey THEN
+          Files.ReadString(R, impname);   (*imports*)
+          WHILE (impname[0] # 0X) & (res = 0) DO
+            Files.ReadInt(R, impkey);
+            Load(impname, impmod); import[nofimps] := impmod; importing := name1;
+            IF res = 0 THEN
+              IF impmod.key = impkey THEN INC(impmod.refcnt); INC(nofimps)
+              ELSE error(3, name1); imported := impname
+              END
+            END ;
+            Files.ReadString(R, impname)
+          END
+        ELSE error(2, name1)
+        END
+      ELSE error(1, name)
+      END ;
+      IF res = 0 THEN (*search for a hole in the list allocate and link*)
+        INC(size, DescSize); mod := root;
+        WHILE (mod # NIL) & ~((mod.name[0] = 0X) & (mod.size >= size)) DO mod := mod.next END ;
+        IF mod = NIL THEN (*no large enough hole was found*)
+          IF AllocPtr + size < limit THEN (*allocate*)
+            p := AllocPtr; mod := SYSTEM.VAL(Module, p);
+            AllocPtr := (p + size + 100H) DIV 20H * 20H; mod.size := AllocPtr - p; mod.num := root.num + 1;
+            mod.next := root; root := mod
+          ELSE error(7, name1)
+          END
+        ELSE (*fill hole*) p := SYSTEM.VAL(INTEGER, mod)
+        END
+      END ; 
+      IF res = 0 THEN (*read file*)
+        INC(p, DescSize); (*allocate descriptor*)
+        mod.name := name; mod.key := key; mod.refcnt := 0;
+        mod.data := p;  (*data*)
+        SYSTEM.PUT(mod.num * 4 + MTOrg, p);  (*module table entry*)
+        Files.ReadInt(R, n);
+        WHILE n > 0 DO Files.ReadInt(R, w); SYSTEM.PUT(p, w); INC(p, 4); DEC(n, 4) END ;  (*type descriptors*)
+        Files.ReadInt(R, n);
+        WHILE n > 0 DO SYSTEM.PUT(p, 0); INC(p, 4); DEC(n, 4) END ;  (*variable space*)
+        Files.ReadInt(R, n);
+        WHILE n > 0 DO Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p); DEC(n) END ;   (*strings*)
+        mod.code := p;  (*program*)
+        Files.ReadInt(R, n);
+        WHILE n > 0 DO Files.ReadInt(R, w); SYSTEM.PUT(p, w); INC(p, 4); DEC(n) END ;  (*program code*)
+        mod.imp := p;  (*copy imports*)
+        i := 0;
+        WHILE i < nofimps DO
+          SYSTEM.PUT(p, import[i]); INC(p, 4); INC(i)
+        END ;
+        mod.cmd := p;  (*commands*) Files.Read(R, ch);
+        WHILE ch # 0X DO
+          REPEAT SYSTEM.PUT(p, ch); INC(p); Files.Read(R, ch) UNTIL ch = 0X;
+          REPEAT SYSTEM.PUT(p, 0X); INC(p) UNTIL p MOD 4 = 0;
+          Files.ReadInt(R, n); SYSTEM.PUT(p, n); INC(p, 4); Files.Read(R, ch)
+        END ;
+        REPEAT SYSTEM.PUT(p, 0X); INC(p) UNTIL p MOD 4 = 0;
+        mod.ent := p;  (*entries*)
+        Files.ReadInt(R, n);
+        WHILE n > 0 DO Files.ReadInt(R, w); SYSTEM.PUT(p, w); INC(p, 4); DEC(n) END ;
+        mod.ptr := p;  (*pointer references*)
+        Files.ReadInt(R, w);
+        WHILE w >= 0 DO SYSTEM.PUT(p, mod.data + w); INC(p, 4); Files.ReadInt(R, w) END ;
+        SYSTEM.PUT(p, 0); INC(p, 4);
+        Files.ReadInt(R, fixorgP); Files.ReadInt(R, fixorgD); Files.ReadInt(R, fixorgT);
+        Files.ReadInt(R, w); body := SYSTEM.VAL(Command, mod.code + w);
+        Files.Read(R, ch);
+        IF ch # "O" THEN (*corrupted file*)  mod := NIL; error(4, name) END
+      END ;
+      IF res = 0 THEN (*fixup of BL*)
+        adr := mod.code + fixorgP*4;
+        WHILE adr # mod.code DO
+          SYSTEM.GET(adr, inst);
+          mno := inst DIV 100000H MOD 10H;
+          pno := inst DIV 1000H MOD 100H;
+          disp := inst MOD 1000H;
+          SYSTEM.GET(mod.imp + (mno-1)*4, impmod);
+          SYSTEM.GET(impmod.ent + pno*4, dest); dest := dest + impmod.code;
+          offset := (dest - adr - 4) DIV 4;
+          SYSTEM.PUT(adr, (offset MOD 1000000H) + 0F7000000H);
+          adr := adr - disp*4
+        END ;
+        (*fixup of LDR/STR/ADD*)
+        adr := mod.code + fixorgD*4;
+        WHILE adr # mod.code DO
+          SYSTEM.GET(adr, inst);
+          mno := inst DIV 100000H MOD 10H;
+          disp := inst MOD 1000H;
+          IF mno = 0 THEN (*global*)
+            SYSTEM.PUT(adr, (inst DIV 1000000H * 10H + MT) * 100000H + mod.num * 4)
+          ELSE (*import*)
+            SYSTEM.GET(mod.imp + (mno-1)*4, impmod); v := impmod.num;
+            SYSTEM.PUT(adr, (inst DIV 1000000H * 10H + MT) * 100000H + v*4);
+            SYSTEM.GET(adr+4, inst); vno := inst MOD 100H;
+            SYSTEM.GET(impmod.ent + vno*4, offset);
+            IF ODD(inst DIV 100H) THEN offset := offset + impmod.code - impmod.data END ;
+            SYSTEM.PUT(adr+4, inst DIV 10000H * 10000H + offset)
+          END ;
+          adr := adr - disp*4
+        END ;
+        (*fixup of type descriptors*)
+        adr := mod.data + fixorgT*4;
+        WHILE adr # mod.data DO
+          SYSTEM.GET(adr, inst);
+          mno := inst DIV 1000000H MOD 10H;
+          vno := inst DIV 1000H MOD 1000H;
+          disp := inst MOD 1000H;
+          IF mno = 0 THEN (*global*) inst := mod.data + vno
+          ELSE (*import*)
+            SYSTEM.GET(mod.imp + (mno-1)*4, impmod);
+            SYSTEM.GET(impmod.ent + vno*4, offset);
+            inst := impmod.data + offset
+          END ;
+          SYSTEM.PUT(adr, inst); adr := adr - disp*4
+        END ;
+        body   (*initialize module*)
+      ELSIF res >= 3 THEN importing := name;
+        WHILE nofimps > 0 DO DEC(nofimps); DEC(import[nofimps].refcnt) END
+      END 
+    END ;
+    newmod :=  mod
+  END Load;
+
+  PROCEDURE ThisCommand*(mod: Module; name: ARRAY OF CHAR): Command;
+    VAR k, adr, w: INTEGER; ch: CHAR;
+      s: ARRAY 32 OF CHAR;
+  BEGIN res := 5; w := 0;
+    IF mod # NIL THEN
+      adr := mod.cmd; SYSTEM.GET(adr, ch);
+      WHILE (ch # 0X) & (res # 0) DO k := 0; (*read command name*)
+        REPEAT s[k] := ch; INC(k); INC(adr); SYSTEM.GET(adr, ch) UNTIL ch = 0X;
+        s[k] := 0X;
+        REPEAT INC(adr) UNTIL adr MOD 4 = 0;
+        SYSTEM.GET(adr, k); INC(adr, 4);
+        IF s = name THEN res := 0; w := mod.code + k ELSE SYSTEM.GET(adr, ch) END
+      END
+    END
+    RETURN SYSTEM.VAL(Command, w)
+  END ThisCommand;
+
+  PROCEDURE Free*(name: ARRAY OF CHAR);
+    VAR mod, imp: Module; p, q: INTEGER;
+  BEGIN mod := root; res := 0;
+    WHILE (mod # NIL) & (mod.name # name) DO mod := mod.next END ;
+    IF mod # NIL THEN
+      IF mod.refcnt = 0 THEN
+        mod.name[0] := 0X; p := mod.imp; q := mod.cmd;
+        WHILE p < q DO SYSTEM.GET(p, imp); DEC(imp.refcnt); INC(p, 4) END ;
+      ELSE res := 1
+      END
+    END
+  END Free;
+
+  PROCEDURE Init*;
+  BEGIN Files.Init; MTOrg := SYSTEM.REG(MT);
+    SYSTEM.GET(16, AllocPtr); SYSTEM.GET(20, root); SYSTEM.GET(24, limit); DEC(limit, 8000H)
+  END Init;
+
+BEGIN Init; Load("Oberon", M);
+    LED(res); REPEAT UNTIL FALSE  (*only if load fails*)
+END Modules.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Net.Mod.txt

@@ -1,378 +1,378 @@
-MODULE Net; (*NW 3.7.88 / 25.8.91 / PR 7.8.13 / 9.12.13*)
-  IMPORT SYSTEM, SCC, Files, Viewers, Texts, TextFrames, MenuViewers, Oberon;
-
-  CONST PakSize = 512;
-    (*T0 = 300; T1 = 1000; (*timeouts*)*)
-    T0 = 1000; T1 = 3000; (*timeouts*)
-    ACK = 10H; NAK = 25H; NPR = 26H; (*acknowledgements*)
-    NRQ = 34H; NRS = 35H; (*name request, response*)
-    SND = 41H; REC = 42H; MSG = 44H;
-    TRQ = 46H; TIM = 47H; (*time requests*)
-
-  VAR W: Texts.Writer;
-     Server: Oberon.Task;
-     head0, head1: SCC.Header;
-     partner: ARRAY 8 OF CHAR;
-     dmy: ARRAY 8 OF BYTE;
-     protected: BOOLEAN; (*write-protection*)
-
-  PROCEDURE SetPartner(name: ARRAY OF CHAR);
-  BEGIN head0.dadr := head1.sadr; partner := name
-  END SetPartner;
-
-  PROCEDURE Send(t: BYTE; L: INTEGER; data: ARRAY OF BYTE);
-  BEGIN head0.typ := t; head0.len := L; SCC.SendPacket(head0, data)
-  END Send;
-
-  PROCEDURE ReceiveHead(timeout: LONGINT);
-    VAR time: LONGINT;
-  BEGIN time := Oberon.Time() + timeout;
-    REPEAT
-      SCC.ReceiveHead(head1);
-      IF head1.valid & (head1.sadr # head0.dadr) THEN
-        SCC.Skip(head1.len); head1.valid := FALSE
-      END;
-      IF ~head1.valid & (Oberon.Time() >= time) THEN head1.typ := 0FFH END
-    UNTIL head1.valid OR (head1.typ = 0FFH)
-  END ReceiveHead;
-
-  PROCEDURE FindPartner(name: ARRAY OF CHAR; VAR res: INTEGER);
-    VAR time: LONGINT; k: INTEGER;
-      Id: ARRAY 8 OF CHAR; IdB: ARRAY 8 OF BYTE;
-  BEGIN SCC.Skip(SCC.Available()); res := 0; k := 0;
-    WHILE (k < 7) & (name[k] # 0X) DO Id[k] := name[k]; IdB[k] := ORD(Id[k]); INC(k) END;
-    Id[k] := 0X; IdB[k] := 0; (* <-- also terminate IdB *)
-    IF Id # partner THEN
-      head0.dadr := 0FFH; Send(NRQ, k+1, IdB); time := Oberon.Time() + T1;
-      REPEAT
-        SCC.ReceiveHead(head1);
-        IF head1.valid THEN
-          IF head1.typ = NRS THEN SetPartner(Id)
-          ELSE SCC.Skip(head1.len); head1.valid := FALSE
-          END
-        ELSIF Oberon.Time() >= time THEN res := 1; partner[0] := 0X
-        END
-      UNTIL head1.valid OR (res # 0)
-    END
-  END FindPartner;
-
-  PROCEDURE AppendS(s: ARRAY OF CHAR; VAR d: ARRAY OF BYTE; VAR k: INTEGER);
-    VAR i: INTEGER; ch: CHAR;
-  BEGIN i := 0;
-    REPEAT ch := s[i]; d[k] := ORD(ch); INC(i); INC(k) UNTIL ch = 0X
-  END AppendS;
-
-  PROCEDURE AppendW(s: LONGINT; VAR d: ARRAY OF BYTE;
-      n: INTEGER; VAR k: INTEGER);
-    VAR i: INTEGER;
-  BEGIN i := 0;
-    REPEAT d[k] := s MOD 100H; s := s DIV 100H; INC(i); INC(k) UNTIL i = n
-  END AppendW;
-
-  PROCEDURE PickS(VAR s: ARRAY OF CHAR);
-    VAR i: INTEGER; x: BYTE;
-  BEGIN i := 0;
-    REPEAT SCC.Receive(x); s[i] := CHR(x); INC(i) UNTIL x = 0
-  END PickS;
-
-  PROCEDURE PickQ(VAR w: LONGINT);
-    VAR x0, x1, x2, x3: BYTE;
-  BEGIN SCC.Receive(x0); SCC.Receive(x1); SCC.Receive(x2); SCC.Receive(x3);
-    w := x0 + 100H * (x1 + 100H * (x2 + 100H * x3))
-  END PickQ;
-
-  PROCEDURE SendData(F: Files.File);
-    VAR k, seqno: INTEGER;
-      x: BYTE;
-      len: LONGINT;
-      R: Files.Rider;
-      buf: ARRAY PakSize OF BYTE;
-  BEGIN Files.Set(R, F, 0); len := 0; seqno := 0;
-    REPEAT k := 0;
-      REPEAT Files.ReadByte(R, x);
-        IF ~R.eof THEN buf[k] := x; INC(k) END
-      UNTIL R.eof OR (k = PakSize);
-      REPEAT Send(seqno, k, buf); ReceiveHead(T1)
-      UNTIL head1.typ # seqno + ACK;
-      seqno := (seqno + 1) MOD 8; len := len + k;
-      IF head1.typ # seqno + ACK THEN
-        Texts.WriteString(W, " failed"); k := 0
-      END
-    UNTIL k < PakSize;
-    Texts.WriteInt(W, len, 7)
-  END SendData;
-
-  PROCEDURE ReceiveData(F: Files.File; VAR done: BOOLEAN);
-    VAR k, retry, seqno: INTEGER;
-     x: BYTE;
-     len: LONGINT;
-     R: Files.Rider;
-  BEGIN Files.Set(R, F, 0); seqno := 0; len := 0; retry := 2; k := PakSize;
-    REPEAT
-     IF head1.typ = seqno THEN
-       seqno := (seqno + 1) MOD 8; len := len + head1.len; retry := 2;
-       Send(seqno + ACK, 0, dmy); k := 0;
-       WHILE k < head1.len DO
-         SCC.Receive(x); Files.WriteByte(R, x); INC(k)
-       END ;
-       IF k < PakSize THEN done := TRUE END
-     ELSE DEC(retry);
-       IF retry = 0 THEN
-         Texts.WriteString(W, " failed"); done := FALSE; k := 0
-       END ;
-       Send(seqno + ACK, 0, dmy)
-     END ;
-     ReceiveHead(T0)
-    UNTIL k < PakSize;
-    Texts.WriteInt(W, len, 7)
-  END ReceiveData;
-
-  PROCEDURE reply(msg: INTEGER);
-  BEGIN
-    IF msg = 1 THEN Texts.WriteString(W, " no link")
-    ELSIF msg = 2 THEN Texts.WriteString(W, " no permission")
-    ELSIF msg = 3 THEN Texts.WriteString(W, " not done")
-    ELSIF msg = 4 THEN Texts.WriteString(W, " not found")
-    ELSIF msg = 5 THEN Texts.WriteString(W, " no response")
-    ELSIF msg = 6 THEN Texts.WriteString(W, " time set")
-    END ;
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END reply;
-
-  PROCEDURE Serve;
-    VAR i: INTEGER;
-      done: BOOLEAN; x: BYTE;
-      F: Files.File;
-      pw, clock, newclock: LONGINT;
-      Id: ARRAY 8 OF CHAR;
-      IdB: ARRAY 8 OF BYTE;
-      FileName: ARRAY 32 OF CHAR;
-  BEGIN
-    SCC.ReceiveHead(head1);
-    IF head1.valid THEN
-      IF head1.typ = SND THEN
-        PickS(Id); PickQ(pw); PickS(FileName);
-        Texts.WriteString(W, Id); Texts.Write(W, " ");
-Texts.WriteString(W, FileName);
-        F := Files.Old(FileName);
-        IF F # NIL THEN
-          Texts.WriteString(W, " sending"); SetPartner(Id);
-          Texts.Append(Oberon.Log, W.buf); SendData(F)
-        ELSE Send(NAK, 0, dmy); Texts.Write(W, "~")
-        END ;
-        reply(0)
-      ELSIF head1.typ = REC THEN
-        PickS(Id); PickQ(pw); PickS(FileName);
-        IF ~protected THEN
-          Texts.WriteString(W, Id); Texts.Write(W, " ");
-Texts.WriteString(W, FileName);
-          F := Files.New(FileName);
-          IF F # NIL THEN
-            Texts.WriteString(W, " receiving"); SetPartner(Id);
-            Texts.Append(Oberon.Log, W.buf);
-            Send(ACK, 0, dmy); ReceiveHead(T0); ReceiveData(F, done);
-            IF done THEN Files.Register(F) END
-          ELSE Send(NAK, 0, dmy); Texts.Write(W, "~")
-          END ;
-          reply(0)
-        ELSE Send(NPR, 0, dmy)
-        END
-      ELSIF head1.typ = MSG THEN i := 0;
-        WHILE i < head1.len DO SCC.Receive(x); Texts.Write(W, CHR(x));
-INC(i) END ;
-        Send(ACK, 0, dmy); reply(0)
-      ELSIF head1.typ = TRQ THEN
-        i := 0; AppendW(Oberon.Clock(), IdB, 4, i); Send(TIM, 4, IdB)
-      ELSIF head1.typ = TIM THEN PickQ(newclock); PickS(Id); PickQ(pw);
-        clock := Oberon.Clock();
-        IF ~protected & (Id[0] # 0X) & (ABS(pw - clock) > 10) THEN
-          Oberon.SetClock(newclock);
-          Texts.WriteString(W, Id); Texts.WriteString(W, " changed
-System.Date");
-          Texts.WriteClock(W, newclock); reply(0)
-         END
-      ELSIF head1.typ = NRQ THEN
-        i := 0;
-        REPEAT SCC.Receive(x); Id[i] := CHR(x); INC(i);
-          IF i = 7 THEN Id[7] := 0X; x := 0 END
-        UNTIL x = 0;
-        WHILE i < head1.len DO SCC.Receive(x); INC(i) END ;
-        IF Id = Oberon.User THEN
-          SetPartner(Id); Send(NRS, 0, dmy)
-        END
-      ELSE SCC.Skip(head1.len)
-      END
-    END
-  END Serve;
-
-  PROCEDURE GetPar1(VAR S: Texts.Scanner);
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S)
-  END GetPar1;
-
-  PROCEDURE GetPar(VAR S: Texts.Scanner; VAR end: LONGINT);
-    VAR T: Texts.Text; beg, tm: LONGINT;
-  BEGIN Texts.Scan(S);
-    IF (S.class = Texts.Char) & (S.c = "^") THEN
-      Oberon.GetSelection(T, beg, end, tm);
-      IF tm >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
-    ELSE end := Oberon.Par.text.len
-    END
-  END GetPar;
-
-  PROCEDURE SendFiles*;
-    VAR k: INTEGER;
-      end: LONGINT;
-      S: Texts.Scanner;
-      F: Files.File;
-      buf: ARRAY 64 OF BYTE;
-  BEGIN GetPar1(S);
-    IF S.class = Texts.Name THEN
-      FindPartner(S.s, k);
-      IF k = 0 THEN
-        GetPar(S, end);
-        WHILE (Texts.Pos(S) < end) & (S.class = Texts.Name) DO
-          Texts.WriteString(W, S.s); k := 0;
-          AppendS(Oberon.User, buf, k); AppendW(Oberon.Password, buf, 4, k);
-          AppendS(S.s, buf, k);
-          IF S.nextCh = ":" THEN (*prefix*)
-            Texts.Scan(S); Texts.Scan(S);
-            IF S.class = Texts.Name THEN
-              buf[k-1] := ORD("."); AppendS(S.s, buf, k);
-              Texts.Write(W, ":"); Texts.WriteString(W, S.s)
-            END
-          END ;
-          F := Files.Old(S.s);
-          IF F # NIL THEN
-            Send(REC, k, buf); ReceiveHead(T0);
-            IF head1.typ = ACK THEN
-              Texts.WriteString(W, " sending"); Texts.Append(Oberon.Log,
-W.buf);
-              SendData(F); reply(0)
-            ELSIF head1.typ = NPR THEN reply(2); end := 0
-            ELSIF head1.typ = NAK THEN reply(3); end := 0
-            ELSE reply(5); end := 0
-            END
-          ELSE reply(4)
-          END ;
-          Texts.Scan(S)
-        END
-      ELSE reply(1)
-      END
-    END
-  END SendFiles;
-
-  PROCEDURE ReceiveFiles*;
-    VAR k: INTEGER; done: BOOLEAN;
-      end: LONGINT;
-      S: Texts.Scanner;
-      F: Files.File;
-      buf: ARRAY 64 OF BYTE;
-  BEGIN GetPar1(S);
-    IF S.class = Texts.Name THEN
-      FindPartner(S.s, k);
-      IF k = 0 THEN
-        GetPar(S, end);
-        WHILE (Texts.Pos(S) < end) & (S.class = Texts.Name) DO
-          Texts.WriteString(W, S.s);
-          k := 0; AppendS(Oberon.User, buf, k); AppendW(Oberon.Password,
-buf, 4, k);
-          AppendS(S.s, buf, k);
-          IF S.nextCh = ":" THEN (*prefix*)
-            Texts.Scan(S); Texts.Scan(S);
-            IF S.class = Texts.Name THEN
-              buf[k-1] := ORD("."); AppendS(S.s, buf, k);
-              Texts.Write(W, ":"); Texts.WriteString(W, S.s)
-            END
-          END ;
-          Send(SND, k, buf);
-          Texts.WriteString(W, " receiving"); Texts.Append(Oberon.Log,
-W.buf);
-          ReceiveHead(T1);
-          IF head1.typ = 0 THEN
-            F := Files.New(S.s);
-            IF F # NIL THEN
-              ReceiveData(F, done);
-              IF done THEN Files.Register(F); reply(0) ELSE end := 0 END
-            ELSE reply(3); Send(NAK, 0, dmy)
-            END
-          ELSIF head1.typ = NAK THEN reply(4)
-          ELSIF head1.typ = NPR THEN reply(2); end := 0
-          ELSE reply(5); end := 0
-          END ;
-          Texts.Scan(S)
-        END
-      ELSE reply(1)
-      END
-    END
-  END ReceiveFiles;
-
-  PROCEDURE SendMsg*;
-    VAR i: INTEGER; ch: CHAR;
-      S: Texts.Scanner;
-      msg: ARRAY 64 OF BYTE;
-  BEGIN GetPar1(S);
-    IF S.class = Texts.Name THEN
-      FindPartner(S.s, i);
-      IF i = 0 THEN
-        Texts.Read(S, ch);
-        WHILE (ch >= " ") & (i < 64) DO
-          msg[i] := ORD(ch); INC(i); Texts.Read(S, ch)
-        END ;
-        Send(MSG, i, msg); ReceiveHead(T0);
-        IF head1.typ # ACK THEN reply(3) END
-      ELSE reply(1)
-      END
-    END
-  END SendMsg;
-
-  PROCEDURE GetTime*;
-    VAR dt, res: INTEGER;
-      S: Texts.Scanner;
-  BEGIN GetPar1(S);
-    IF S.class = Texts.Name THEN
-      FindPartner(S.s, res);
-      IF res = 0 THEN
-        Send(TRQ, 0, dmy); ReceiveHead(T1);
-        IF head1.typ = TIM THEN
-          PickQ(dt); Oberon.SetClock(dt); reply(6)
-        END
-      ELSE reply(1)
-      END
-    END
-  END GetTime;
-
-  PROCEDURE StartServer*;
-  BEGIN protected := TRUE; partner[0] := 0X; SCC.Start(TRUE);
-    Oberon.Remove(Server); Oberon.Install(Server);
-    Texts.WriteString(W, " Server started as "); Texts.WriteString(W,
-Oberon.User);
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END StartServer;
-
-  PROCEDURE Unprotect*;
-  BEGIN protected := FALSE
-  END Unprotect;
-
-  PROCEDURE WProtect*;
-  BEGIN protected := TRUE
-  END WProtect;
-
-  PROCEDURE Reset*;
-  BEGIN SCC.Start(TRUE)
-  END Reset;
-
-  PROCEDURE StopServer*;
-  BEGIN Oberon.Remove(Server); Texts.WriteString(W, " Server stopped");
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END StopServer;
-
-  PROCEDURE SCCStatus*;
-  BEGIN
-    Texts.WriteString(W, "SCC.Available() ");
-    Texts.WriteInt(W, SCC.Available(), 1);
-    Texts.WriteLn(W);
-    Texts.Append(Oberon.Log, W.buf)
-  END SCCStatus;
-
-BEGIN Texts.OpenWriter(W); Server := Oberon.NewTask(Serve, 500)
+MODULE Net; (*NW 3.7.88 / 25.8.91 / PR 7.8.13 / 9.12.13*)
+  IMPORT SYSTEM, SCC, Files, Viewers, Texts, TextFrames, MenuViewers, Oberon;
+
+  CONST PakSize = 512;
+    (*T0 = 300; T1 = 1000; (*timeouts*)*)
+    T0 = 1000; T1 = 3000; (*timeouts*)
+    ACK = 10H; NAK = 25H; NPR = 26H; (*acknowledgements*)
+    NRQ = 34H; NRS = 35H; (*name request, response*)
+    SND = 41H; REC = 42H; MSG = 44H;
+    TRQ = 46H; TIM = 47H; (*time requests*)
+
+  VAR W: Texts.Writer;
+     Server: Oberon.Task;
+     head0, head1: SCC.Header;
+     partner: ARRAY 8 OF CHAR;
+     dmy: ARRAY 8 OF BYTE;
+     protected: BOOLEAN; (*write-protection*)
+
+  PROCEDURE SetPartner(name: ARRAY OF CHAR);
+  BEGIN head0.dadr := head1.sadr; partner := name
+  END SetPartner;
+
+  PROCEDURE Send(t: BYTE; L: INTEGER; data: ARRAY OF BYTE);
+  BEGIN head0.typ := t; head0.len := L; SCC.SendPacket(head0, data)
+  END Send;
+
+  PROCEDURE ReceiveHead(timeout: LONGINT);
+    VAR time: LONGINT;
+  BEGIN time := Oberon.Time() + timeout;
+    REPEAT
+      SCC.ReceiveHead(head1);
+      IF head1.valid & (head1.sadr # head0.dadr) THEN
+        SCC.Skip(head1.len); head1.valid := FALSE
+      END;
+      IF ~head1.valid & (Oberon.Time() >= time) THEN head1.typ := 0FFH END
+    UNTIL head1.valid OR (head1.typ = 0FFH)
+  END ReceiveHead;
+
+  PROCEDURE FindPartner(name: ARRAY OF CHAR; VAR res: INTEGER);
+    VAR time: LONGINT; k: INTEGER;
+      Id: ARRAY 8 OF CHAR; IdB: ARRAY 8 OF BYTE;
+  BEGIN SCC.Skip(SCC.Available()); res := 0; k := 0;
+    WHILE (k < 7) & (name[k] # 0X) DO Id[k] := name[k]; IdB[k] := ORD(Id[k]); INC(k) END;
+    Id[k] := 0X; IdB[k] := 0; (* <-- also terminate IdB *)
+    IF Id # partner THEN
+      head0.dadr := 0FFH; Send(NRQ, k+1, IdB); time := Oberon.Time() + T1;
+      REPEAT
+        SCC.ReceiveHead(head1);
+        IF head1.valid THEN
+          IF head1.typ = NRS THEN SetPartner(Id)
+          ELSE SCC.Skip(head1.len); head1.valid := FALSE
+          END
+        ELSIF Oberon.Time() >= time THEN res := 1; partner[0] := 0X
+        END
+      UNTIL head1.valid OR (res # 0)
+    END
+  END FindPartner;
+
+  PROCEDURE AppendS(s: ARRAY OF CHAR; VAR d: ARRAY OF BYTE; VAR k: INTEGER);
+    VAR i: INTEGER; ch: CHAR;
+  BEGIN i := 0;
+    REPEAT ch := s[i]; d[k] := ORD(ch); INC(i); INC(k) UNTIL ch = 0X
+  END AppendS;
+
+  PROCEDURE AppendW(s: LONGINT; VAR d: ARRAY OF BYTE;
+      n: INTEGER; VAR k: INTEGER);
+    VAR i: INTEGER;
+  BEGIN i := 0;
+    REPEAT d[k] := s MOD 100H; s := s DIV 100H; INC(i); INC(k) UNTIL i = n
+  END AppendW;
+
+  PROCEDURE PickS(VAR s: ARRAY OF CHAR);
+    VAR i: INTEGER; x: BYTE;
+  BEGIN i := 0;
+    REPEAT SCC.Receive(x); s[i] := CHR(x); INC(i) UNTIL x = 0
+  END PickS;
+
+  PROCEDURE PickQ(VAR w: LONGINT);
+    VAR x0, x1, x2, x3: BYTE;
+  BEGIN SCC.Receive(x0); SCC.Receive(x1); SCC.Receive(x2); SCC.Receive(x3);
+    w := x0 + 100H * (x1 + 100H * (x2 + 100H * x3))
+  END PickQ;
+
+  PROCEDURE SendData(F: Files.File);
+    VAR k, seqno: INTEGER;
+      x: BYTE;
+      len: LONGINT;
+      R: Files.Rider;
+      buf: ARRAY PakSize OF BYTE;
+  BEGIN Files.Set(R, F, 0); len := 0; seqno := 0;
+    REPEAT k := 0;
+      REPEAT Files.ReadByte(R, x);
+        IF ~R.eof THEN buf[k] := x; INC(k) END
+      UNTIL R.eof OR (k = PakSize);
+      REPEAT Send(seqno, k, buf); ReceiveHead(T1)
+      UNTIL head1.typ # seqno + ACK;
+      seqno := (seqno + 1) MOD 8; len := len + k;
+      IF head1.typ # seqno + ACK THEN
+        Texts.WriteString(W, " failed"); k := 0
+      END
+    UNTIL k < PakSize;
+    Texts.WriteInt(W, len, 7)
+  END SendData;
+
+  PROCEDURE ReceiveData(F: Files.File; VAR done: BOOLEAN);
+    VAR k, retry, seqno: INTEGER;
+     x: BYTE;
+     len: LONGINT;
+     R: Files.Rider;
+  BEGIN Files.Set(R, F, 0); seqno := 0; len := 0; retry := 2; k := PakSize;
+    REPEAT
+     IF head1.typ = seqno THEN
+       seqno := (seqno + 1) MOD 8; len := len + head1.len; retry := 2;
+       Send(seqno + ACK, 0, dmy); k := 0;
+       WHILE k < head1.len DO
+         SCC.Receive(x); Files.WriteByte(R, x); INC(k)
+       END ;
+       IF k < PakSize THEN done := TRUE END
+     ELSE DEC(retry);
+       IF retry = 0 THEN
+         Texts.WriteString(W, " failed"); done := FALSE; k := 0
+       END ;
+       Send(seqno + ACK, 0, dmy)
+     END ;
+     ReceiveHead(T0)
+    UNTIL k < PakSize;
+    Texts.WriteInt(W, len, 7)
+  END ReceiveData;
+
+  PROCEDURE reply(msg: INTEGER);
+  BEGIN
+    IF msg = 1 THEN Texts.WriteString(W, " no link")
+    ELSIF msg = 2 THEN Texts.WriteString(W, " no permission")
+    ELSIF msg = 3 THEN Texts.WriteString(W, " not done")
+    ELSIF msg = 4 THEN Texts.WriteString(W, " not found")
+    ELSIF msg = 5 THEN Texts.WriteString(W, " no response")
+    ELSIF msg = 6 THEN Texts.WriteString(W, " time set")
+    END ;
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END reply;
+
+  PROCEDURE Serve;
+    VAR i: INTEGER;
+      done: BOOLEAN; x: BYTE;
+      F: Files.File;
+      pw, clock, newclock: LONGINT;
+      Id: ARRAY 8 OF CHAR;
+      IdB: ARRAY 8 OF BYTE;
+      FileName: ARRAY 32 OF CHAR;
+  BEGIN
+    SCC.ReceiveHead(head1);
+    IF head1.valid THEN
+      IF head1.typ = SND THEN
+        PickS(Id); PickQ(pw); PickS(FileName);
+        Texts.WriteString(W, Id); Texts.Write(W, " ");
+Texts.WriteString(W, FileName);
+        F := Files.Old(FileName);
+        IF F # NIL THEN
+          Texts.WriteString(W, " sending"); SetPartner(Id);
+          Texts.Append(Oberon.Log, W.buf); SendData(F)
+        ELSE Send(NAK, 0, dmy); Texts.Write(W, "~")
+        END ;
+        reply(0)
+      ELSIF head1.typ = REC THEN
+        PickS(Id); PickQ(pw); PickS(FileName);
+        IF ~protected THEN
+          Texts.WriteString(W, Id); Texts.Write(W, " ");
+Texts.WriteString(W, FileName);
+          F := Files.New(FileName);
+          IF F # NIL THEN
+            Texts.WriteString(W, " receiving"); SetPartner(Id);
+            Texts.Append(Oberon.Log, W.buf);
+            Send(ACK, 0, dmy); ReceiveHead(T0); ReceiveData(F, done);
+            IF done THEN Files.Register(F) END
+          ELSE Send(NAK, 0, dmy); Texts.Write(W, "~")
+          END ;
+          reply(0)
+        ELSE Send(NPR, 0, dmy)
+        END
+      ELSIF head1.typ = MSG THEN i := 0;
+        WHILE i < head1.len DO SCC.Receive(x); Texts.Write(W, CHR(x));
+INC(i) END ;
+        Send(ACK, 0, dmy); reply(0)
+      ELSIF head1.typ = TRQ THEN
+        i := 0; AppendW(Oberon.Clock(), IdB, 4, i); Send(TIM, 4, IdB)
+      ELSIF head1.typ = TIM THEN PickQ(newclock); PickS(Id); PickQ(pw);
+        clock := Oberon.Clock();
+        IF ~protected & (Id[0] # 0X) & (ABS(pw - clock) > 10) THEN
+          Oberon.SetClock(newclock);
+          Texts.WriteString(W, Id); Texts.WriteString(W, " changed
+System.Date");
+          Texts.WriteClock(W, newclock); reply(0)
+         END
+      ELSIF head1.typ = NRQ THEN
+        i := 0;
+        REPEAT SCC.Receive(x); Id[i] := CHR(x); INC(i);
+          IF i = 7 THEN Id[7] := 0X; x := 0 END
+        UNTIL x = 0;
+        WHILE i < head1.len DO SCC.Receive(x); INC(i) END ;
+        IF Id = Oberon.User THEN
+          SetPartner(Id); Send(NRS, 0, dmy)
+        END
+      ELSE SCC.Skip(head1.len)
+      END
+    END
+  END Serve;
+
+  PROCEDURE GetPar1(VAR S: Texts.Scanner);
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S)
+  END GetPar1;
+
+  PROCEDURE GetPar(VAR S: Texts.Scanner; VAR end: LONGINT);
+    VAR T: Texts.Text; beg, tm: LONGINT;
+  BEGIN Texts.Scan(S);
+    IF (S.class = Texts.Char) & (S.c = "^") THEN
+      Oberon.GetSelection(T, beg, end, tm);
+      IF tm >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
+    ELSE end := Oberon.Par.text.len
+    END
+  END GetPar;
+
+  PROCEDURE SendFiles*;
+    VAR k: INTEGER;
+      end: LONGINT;
+      S: Texts.Scanner;
+      F: Files.File;
+      buf: ARRAY 64 OF BYTE;
+  BEGIN GetPar1(S);
+    IF S.class = Texts.Name THEN
+      FindPartner(S.s, k);
+      IF k = 0 THEN
+        GetPar(S, end);
+        WHILE (Texts.Pos(S) < end) & (S.class = Texts.Name) DO
+          Texts.WriteString(W, S.s); k := 0;
+          AppendS(Oberon.User, buf, k); AppendW(Oberon.Password, buf, 4, k);
+          AppendS(S.s, buf, k);
+          IF S.nextCh = ":" THEN (*prefix*)
+            Texts.Scan(S); Texts.Scan(S);
+            IF S.class = Texts.Name THEN
+              buf[k-1] := ORD("."); AppendS(S.s, buf, k);
+              Texts.Write(W, ":"); Texts.WriteString(W, S.s)
+            END
+          END ;
+          F := Files.Old(S.s);
+          IF F # NIL THEN
+            Send(REC, k, buf); ReceiveHead(T0);
+            IF head1.typ = ACK THEN
+              Texts.WriteString(W, " sending"); Texts.Append(Oberon.Log,
+W.buf);
+              SendData(F); reply(0)
+            ELSIF head1.typ = NPR THEN reply(2); end := 0
+            ELSIF head1.typ = NAK THEN reply(3); end := 0
+            ELSE reply(5); end := 0
+            END
+          ELSE reply(4)
+          END ;
+          Texts.Scan(S)
+        END
+      ELSE reply(1)
+      END
+    END
+  END SendFiles;
+
+  PROCEDURE ReceiveFiles*;
+    VAR k: INTEGER; done: BOOLEAN;
+      end: LONGINT;
+      S: Texts.Scanner;
+      F: Files.File;
+      buf: ARRAY 64 OF BYTE;
+  BEGIN GetPar1(S);
+    IF S.class = Texts.Name THEN
+      FindPartner(S.s, k);
+      IF k = 0 THEN
+        GetPar(S, end);
+        WHILE (Texts.Pos(S) < end) & (S.class = Texts.Name) DO
+          Texts.WriteString(W, S.s);
+          k := 0; AppendS(Oberon.User, buf, k); AppendW(Oberon.Password,
+buf, 4, k);
+          AppendS(S.s, buf, k);
+          IF S.nextCh = ":" THEN (*prefix*)
+            Texts.Scan(S); Texts.Scan(S);
+            IF S.class = Texts.Name THEN
+              buf[k-1] := ORD("."); AppendS(S.s, buf, k);
+              Texts.Write(W, ":"); Texts.WriteString(W, S.s)
+            END
+          END ;
+          Send(SND, k, buf);
+          Texts.WriteString(W, " receiving"); Texts.Append(Oberon.Log,
+W.buf);
+          ReceiveHead(T1);
+          IF head1.typ = 0 THEN
+            F := Files.New(S.s);
+            IF F # NIL THEN
+              ReceiveData(F, done);
+              IF done THEN Files.Register(F); reply(0) ELSE end := 0 END
+            ELSE reply(3); Send(NAK, 0, dmy)
+            END
+          ELSIF head1.typ = NAK THEN reply(4)
+          ELSIF head1.typ = NPR THEN reply(2); end := 0
+          ELSE reply(5); end := 0
+          END ;
+          Texts.Scan(S)
+        END
+      ELSE reply(1)
+      END
+    END
+  END ReceiveFiles;
+
+  PROCEDURE SendMsg*;
+    VAR i: INTEGER; ch: CHAR;
+      S: Texts.Scanner;
+      msg: ARRAY 64 OF BYTE;
+  BEGIN GetPar1(S);
+    IF S.class = Texts.Name THEN
+      FindPartner(S.s, i);
+      IF i = 0 THEN
+        Texts.Read(S, ch);
+        WHILE (ch >= " ") & (i < 64) DO
+          msg[i] := ORD(ch); INC(i); Texts.Read(S, ch)
+        END ;
+        Send(MSG, i, msg); ReceiveHead(T0);
+        IF head1.typ # ACK THEN reply(3) END
+      ELSE reply(1)
+      END
+    END
+  END SendMsg;
+
+  PROCEDURE GetTime*;
+    VAR dt, res: INTEGER;
+      S: Texts.Scanner;
+  BEGIN GetPar1(S);
+    IF S.class = Texts.Name THEN
+      FindPartner(S.s, res);
+      IF res = 0 THEN
+        Send(TRQ, 0, dmy); ReceiveHead(T1);
+        IF head1.typ = TIM THEN
+          PickQ(dt); Oberon.SetClock(dt); reply(6)
+        END
+      ELSE reply(1)
+      END
+    END
+  END GetTime;
+
+  PROCEDURE StartServer*;
+  BEGIN protected := TRUE; partner[0] := 0X; SCC.Start(TRUE);
+    Oberon.Remove(Server); Oberon.Install(Server);
+    Texts.WriteString(W, " Server started as "); Texts.WriteString(W,
+Oberon.User);
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END StartServer;
+
+  PROCEDURE Unprotect*;
+  BEGIN protected := FALSE
+  END Unprotect;
+
+  PROCEDURE WProtect*;
+  BEGIN protected := TRUE
+  END WProtect;
+
+  PROCEDURE Reset*;
+  BEGIN SCC.Start(TRUE)
+  END Reset;
+
+  PROCEDURE StopServer*;
+  BEGIN Oberon.Remove(Server); Texts.WriteString(W, " Server stopped");
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END StopServer;
+
+  PROCEDURE SCCStatus*;
+  BEGIN
+    Texts.WriteString(W, "SCC.Available() ");
+    Texts.WriteInt(W, SCC.Available(), 1);
+    Texts.WriteLn(W);
+    Texts.Append(Oberon.Log, W.buf)
+  END SCCStatus;
+
+BEGIN Texts.OpenWriter(W); Server := Oberon.NewTask(Serve, 500)
 END Net.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/ORB.Mod.txt

@@ -1,432 +1,432 @@
-MODULE ORB;   (*NW 25.6.2014  / 1.3.2019  in Oberon-07*)
-  IMPORT Files, ORS;
-  (*Definition of data types Object and Type, which together form the data structure
-    called "symbol table". Contains procedures for creation of Objects, and for search:
-    NewObj, this, thisimport, thisfield (and OpenScope, CloseScope).
-    Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures
-    Import and Export. This module contains the list of standard identifiers, with which
-    the symbol table (universe), and that of the pseudo-module SYSTEM are initialized. *)
-
-  CONST versionkey* = 1; maxTypTab = 64;
-    (* class values*) Head* = 0;
-      Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5;
-      SProc* = 6; SFunc* = 7; Mod* = 8;
-
-    (* form values*)
-      Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6;
-      Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10;
-      String* = 11; Array* = 12; Record* = 13;
-      
-  TYPE Object* = POINTER TO ObjDesc;
-    Module* = POINTER TO ModDesc;
-    Type* = POINTER TO TypeDesc;
-
-    ObjDesc*= RECORD
-      class*, exno*: BYTE;
-      expo*, rdo*: BOOLEAN;   (*exported / read-only*)
-      lev*: INTEGER;
-      next*, dsc*: Object;
-      type*: Type;
-      name*: ORS.Ident;
-      val*: LONGINT
-    END ;
-
-    ModDesc* = RECORD (ObjDesc) orgname*: ORS.Ident END ;
-
-    TypeDesc* = RECORD
-      form*, ref*, mno*: INTEGER;  (*ref is only used for import/export*)
-      nofpar*: INTEGER;  (*for procedures, extension level for records*)
-      len*: LONGINT;  (*for arrays, len < 0 => open array; for records: adr of descriptor*)
-      dsc*, typobj*: Object;
-      base*: Type;  (*for arrays, records, pointers*)
-      size*: LONGINT;  (*in bytes; always multiple of 4, except for Byte, Bool and Char*)
-    END ;
-
-  (* Object classes and the meaning of "val":
-    class    val
-    ----------
-    Var      address
-    Par      address
-    Const    value
-    Fld      offset
-    Typ      type descriptor (TD) address
-    SProc    inline code number
-    SFunc    inline code number
-    Mod      key
-
-  Type forms and the meaning of "dsc" and "base":
-    form     dsc      base
-    ------------------------
-    Pointer  -        type of dereferenced object
-    Proc     params   result type
-    Array    -        type of elements
-    Record   fields   extension *)
-
-  VAR topScope*, universe, system*: Object;
-    byteType*, boolType*, charType*: Type;
-    intType*, realType*, setType*, nilType*, noType*, strType*: Type;
-    nofmod, Ref: INTEGER;
-    typtab: ARRAY maxTypTab OF Type;
-
-  PROCEDURE NewObj*(VAR obj: Object; id: ORS.Ident; class: INTEGER);  (*insert new Object with name id*)
-    VAR new, x: Object;
-  BEGIN x := topScope;
-    WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ;
-    IF x.next = NIL THEN
-      NEW(new); new.name := id; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL;
-      x.next := new; obj := new
-    ELSE obj := x.next; ORS.Mark("mult def")
-    END 
-  END NewObj;
-
-  PROCEDURE thisObj*(): Object;
-    VAR s, x: Object;
-  BEGIN s := topScope;
-    REPEAT x := s.next;
-      WHILE (x # NIL) & (x.name # ORS.id) DO x := x.next END ;
-      s := s.dsc
-    UNTIL (x # NIL) OR (s = NIL);
-    RETURN x
-  END thisObj;
-
-  PROCEDURE thisimport*(mod: Object): Object;
-    VAR obj: Object;
-  BEGIN
-    IF mod.rdo THEN
-      IF mod.name[0] # 0X THEN
-        obj := mod.dsc;
-        WHILE (obj # NIL) & (obj.name # ORS.id) DO obj := obj.next END
-      ELSE obj := NIL
-      END
-    ELSE obj := NIL
-    END ;
-    RETURN obj
-  END thisimport;
-
-  PROCEDURE thisfield*(rec: Type): Object;
-    VAR fld: Object;
-  BEGIN fld := rec.dsc;
-    WHILE (fld # NIL) & (fld.name # ORS.id) DO fld := fld.next END ;
-    RETURN fld
-  END thisfield;
-
-  PROCEDURE OpenScope*;
-    VAR s: Object;
-  BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s
-  END OpenScope;
-
-  PROCEDURE CloseScope*;
-  BEGIN topScope := topScope.dsc
-  END CloseScope;
-
-  (*------------------------------- Import ---------------------------------*)
-
-  PROCEDURE MakeFileName*(VAR FName: ORS.Ident; name, ext: ARRAY OF CHAR);
-    VAR i, j: INTEGER;
-  BEGIN i := 0; j := 0;  (*assume name suffix less than 4 characters*)
-    WHILE (i < ORS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ;
-    REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X;
-    FName[i] := 0X
-  END MakeFileName;
-  
-  PROCEDURE ThisModule(name, orgname: ORS.Ident; non: BOOLEAN; key: LONGINT): Object;
-    VAR mod: Module; obj, obj1: Object;
-  BEGIN obj1 := topScope; obj := obj1.next;  (*search for module*)
-    WHILE (obj # NIL) & (obj.name # name) DO obj1 := obj; obj := obj1.next END ;
-    IF obj = NIL THEN  (*insert new module*)
-      NEW(mod); mod.class := Mod; mod.rdo := FALSE;
-      mod.name := name; mod.orgname := orgname; mod.val := key;
-      mod.lev := nofmod; INC(nofmod); mod.type := noType; mod.dsc := NIL; mod.next := NIL;
-      obj1.next := mod; obj := mod
-    ELSE (*module already present*)
-      IF non THEN ORS.Mark("invalid import order") END
-    END ;
-    RETURN obj
-  END ThisModule;
-  
-  PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER);
-    VAR b: BYTE;
-  BEGIN Files.ReadByte(R, b);
-    IF b < 80H THEN x := b ELSE x := b - 100H END
-  END Read;
-  
-  PROCEDURE InType(VAR R: Files.Rider; thismod: Object; VAR T: Type);
-    VAR key: LONGINT;
-      ref, class, form, np, readonly: INTEGER;
-      fld, par, obj, mod, last: Object;
-      t: Type;
-      name, modname: ORS.Ident;
-  BEGIN Read(R, ref);
-    IF ref < 0 THEN T := typtab[-ref]  (*already read*)
-    ELSE NEW(t); T := t; typtab[ref] := t; t.mno := thismod.lev;
-      Read(R, form); t.form := form;
-      IF form = Pointer THEN InType(R, thismod, t.base); t.size := 4
-      ELSIF form = Array THEN
-        InType(R, thismod, t.base); Files.ReadNum(R, t.len); Files.ReadNum(R, t.size)
-      ELSIF form = Record THEN
-        InType(R, thismod, t.base);
-        IF t.base.form = NoTyp THEN t.base := NIL; obj := NIL ELSE obj := t.base.dsc END ;
-        Files.ReadNum(R, t.len); (*TD adr/exno*)
-        Files.ReadNum(R, t.nofpar);  (*ext level*)
-        Files.ReadNum(R, t.size);
-        Read(R, class); last := NIL;
-        WHILE class # 0 DO  (*fields*)
-          NEW(fld); fld.class := class; Files.ReadString(R, fld.name);
-          IF last = NIL THEN t.dsc := fld ELSE last.next := fld END ;
-          last := fld;
-          IF fld.name[0] # 0X THEN fld.expo := TRUE; InType(R, thismod, fld.type) ELSE fld.expo := FALSE; fld.type := nilType END ;
-          Files.ReadNum(R, fld.val); Read(R, class)
-        END ;
-        IF last = NIL THEN t.dsc := obj ELSE last.next := obj END
-      ELSIF form = Proc THEN
-        InType(R, thismod, t.base);
-        obj := NIL; np := 0; Read(R, class);
-        WHILE class # 0 DO  (*parameters*)
-          NEW(par); par.class := class; Read(R, readonly); par.rdo := readonly = 1; 
-          InType(R, thismod, par.type); par.next := obj; obj := par; INC(np); Read(R, class)
-        END ;
-        t.dsc := obj; t.nofpar := np; t.size := 4
-      END ;
-      Files.ReadString(R, modname);
-      IF modname[0] #  0X THEN  (*re-import*)
-        Files.ReadInt(R, key); Files.ReadString(R, name);
-        mod := ThisModule(modname, modname, FALSE, key);
-        obj := mod.dsc;  (*search type*)
-        WHILE (obj # NIL) & (obj.name # name) DO obj := obj.next END ;
-        IF obj # NIL THEN T := obj.type   (*type object found in object list of mod*)
-        ELSE (*insert new type object in object list of mod*)
-          NEW(obj); obj.name := name; obj.class := Typ; obj.next := mod.dsc; mod.dsc := obj; obj.type := t;
-          t.mno := mod.lev; t.typobj := obj; T := t
-        END ;
-        typtab[ref] := T
-      END
-    END
-  END InType;
-  
-  PROCEDURE Import*(VAR modid, modid1: ORS.Ident);
-    VAR key: LONGINT; class, k: INTEGER;
-      obj: Object;  t: Type;
-      thismod: Object;
-      modname, fname: ORS.Ident;
-      F: Files.File; R: Files.Rider;
-  BEGIN
-    IF modid1 = "SYSTEM" THEN
-      thismod := ThisModule(modid, modid1, TRUE, key); DEC(nofmod);
-      thismod.lev := 0; thismod.dsc := system; thismod.rdo := TRUE
-    ELSE MakeFileName(fname, modid1, ".smb"); F := Files.Old(fname);
-      IF F # NIL THEN
-        Files.Set(R, F, 0); Files.ReadInt(R, key); Files.ReadInt(R, key); Files.ReadString(R, modname);
-        thismod := ThisModule(modid, modid1, TRUE, key); thismod.rdo := TRUE;
-        Read(R, class); (*version key*)
-        IF class # versionkey THEN ORS.Mark("wrong version") END ;
-        Read(R, class);
-        WHILE class # 0 DO
-          NEW(obj); obj.class := class; Files.ReadString(R, obj.name);
-          InType(R, thismod, obj.type); obj.lev := -thismod.lev;
-          IF class = Typ THEN
-            t := obj.type; t.typobj := obj; Read(R, k);  (*fixup bases of previously declared pointer types*)
-            WHILE k # 0 DO typtab[k].base := t; Read(R, k) END
-          ELSE
-            IF class = Const THEN
-              IF obj.type.form = Real THEN Files.ReadInt(R, obj.val) ELSE Files.ReadNum(R, obj.val) END
-            ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE
-            END
-          END ;
-          obj.next := thismod.dsc; thismod.dsc := obj; Read(R, class)
-        END ;
-      ELSE ORS.Mark("import not available")
-      END
-    END
-  END Import;
-  
-  (*-------------------------------- Export ---------------------------------*)
-
-  PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
-  BEGIN Files.WriteByte(R, x)
-  END Write;
-
-  PROCEDURE OutType(VAR R: Files.Rider; t: Type);
-    VAR obj, mod, fld, bot: Object;
-
-    PROCEDURE OutPar(VAR R: Files.Rider; par: Object; n: INTEGER);
-      VAR cl: INTEGER;
-    BEGIN
-      IF n > 0 THEN
-        OutPar(R, par.next, n-1); cl := par.class;
-        Write(R, cl);
-        IF par.rdo THEN Write(R, 1) ELSE Write(R, 0) END ;
-        OutType(R, par.type)
-      END
-    END OutPar;
-
-    PROCEDURE FindHiddenPointers(VAR R: Files.Rider; typ: Type; offset: LONGINT);
-      VAR fld: Object; i, n: LONGINT;
-    BEGIN
-      IF (typ.form = Pointer) OR (typ.form = NilTyp) THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, offset)
-      ELSIF typ.form = Record THEN fld := typ.dsc;
-        WHILE fld # NIL DO FindHiddenPointers(R, fld.type, fld.val + offset); fld := fld.next END
-      ELSIF typ.form = Array THEN i := 0; n := typ.len;
-        WHILE i < n DO FindHiddenPointers(R, typ.base, typ.base.size * i + offset); INC(i) END
-      END
-    END FindHiddenPointers;
-
-  BEGIN
-    IF t.ref > 0 THEN (*type was already output*) Write(R, -t.ref)
-    ELSE obj := t.typobj;
-      IF obj # NIL THEN Write(R, Ref); t.ref := Ref; INC(Ref) ELSE (*anonymous*) Write(R, 0) END ;
-      Write(R, t.form);
-      IF t.form = Pointer THEN OutType(R, t.base)
-      ELSIF t.form = Array THEN OutType(R, t.base); Files.WriteNum(R, t.len); Files.WriteNum(R, t.size)
-      ELSIF t.form = Record THEN
-        IF t.base # NIL THEN OutType(R, t.base); bot := t.base.dsc ELSE OutType(R, noType); bot := NIL END ;
-        IF obj # NIL THEN Files.WriteNum(R, obj.exno) ELSE Write(R, 0) END ;
-        Files.WriteNum(R, t.nofpar); Files.WriteNum(R, t.size);
-        fld := t.dsc;
-        WHILE fld # bot DO  (*fields*)
-          IF fld.expo THEN
-            Write(R, Fld); Files.WriteString(R, fld.name); OutType(R, fld.type); Files.WriteNum(R, fld.val)  (*offset*)
-          ELSE FindHiddenPointers(R, fld.type, fld.val)
-          END ;
-          fld := fld.next
-        END ;
-        Write(R, 0)
-      ELSIF t.form = Proc THEN OutType(R, t.base); OutPar(R, t.dsc, t.nofpar); Write(R, 0)
-      END ;
-      IF (t.mno > 0) & (obj # NIL) THEN  (*re-export, output name*)
-        mod := topScope.next;
-        WHILE (mod # NIL) & (mod.lev # t.mno) DO mod := mod.next END ;
-        IF mod # NIL THEN Files.WriteString(R, mod(Module).orgname); Files.WriteInt(R, mod.val); Files.WriteString(R, obj.name)
-        ELSE ORS.Mark("re-export not found"); Write(R, 0)
-        END
-      ELSE Write(R, 0)
-      END
-    END
-  END OutType;
-
-  PROCEDURE Export*(VAR modid: ORS.Ident; VAR newSF: BOOLEAN; VAR key: LONGINT);
-    VAR x, sum, oldkey: LONGINT;
-      obj, obj0: Object;
-      filename: ORS.Ident;
-      F, F1: Files.File; R, R1: Files.Rider;
-  BEGIN Ref := Record + 1; MakeFileName(filename, modid, ".smb");
-    F := Files.New(filename); Files.Set(R, F, 0);
-    Files.WriteInt(R, 0); (*placeholder*)
-    Files.WriteInt(R, 0); (*placeholder for key to be inserted at the end*)
-    Files.WriteString(R, modid); Write(R, versionkey);
-    obj := topScope.next;
-    WHILE obj # NIL DO
-      IF obj.expo THEN
-        Write(R, obj.class); Files.WriteString(R, obj.name);
-        OutType(R, obj.type);
-        IF obj.class = Typ THEN
-          IF obj.type.form = Record THEN
-            obj0 := topScope.next;  (*check whether this is base of previously declared pointer types*)
-            WHILE obj0 # obj DO
-              IF (obj0.type.form = Pointer) & (obj0.type.base = obj.type) & (obj0.type.ref > 0) THEN Write(R, obj0.type.ref) END ;
-              obj0 := obj0.next
-            END
-          END ;
-          Write(R, 0)
-        ELSIF obj.class = Const THEN
-          IF obj.type.form = Proc THEN Files.WriteNum(R, obj.exno)
-          ELSIF obj.type.form = Real THEN Files.WriteInt(R, obj.val)
-          ELSE Files.WriteNum(R, obj.val)
-          END
-        ELSIF obj.class = Var THEN Files.WriteNum(R, obj.exno)
-        END
-      END ;
-      obj := obj.next
-    END ;
-    REPEAT Write(R, 0) UNTIL Files.Length(F) MOD 4 = 0;
-    FOR Ref := Record+1 TO maxTypTab-1 DO typtab[Ref] := NIL END ;
-    Files.Set(R, F, 0); sum := 0; Files.ReadInt(R, x);  (* compute key (checksum) *)
-    WHILE ~R.eof DO sum := sum + x; Files.ReadInt(R, x) END ;
-    F1 := Files.Old(filename); (*sum is new key*)
-    IF F1 # NIL THEN Files.Set(R1, F1, 4); Files.ReadInt(R1, oldkey) ELSE oldkey := sum+1 END ;
-    IF sum # oldkey THEN
-      IF newSF OR (F1 = NIL) THEN
-        key := sum; newSF := TRUE; Files.Set(R, F, 4); Files.WriteInt(R, sum); Files.Register(F)  (*insert checksum*)
-      ELSE ORS.Mark("new symbol file inhibited")
-      END
-    ELSE newSF := FALSE; key := sum
-    END
-  END Export;
-
-  PROCEDURE Init*;
-  BEGIN topScope := universe; nofmod := 1
-  END Init;
-  
-  PROCEDURE type(ref, form: INTEGER; size: LONGINT): Type;
-    VAR tp: Type;
-  BEGIN NEW(tp); tp.form := form; tp.size := size; tp.ref := ref; tp.base := NIL;
-    typtab[ref] := tp; RETURN tp
-  END type;
-
-  PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: LONGINT);
-    VAR obj: Object;
-  BEGIN NEW(obj); obj.name := name; obj.class := cl; obj.type := type; obj.val := n; obj.dsc := NIL;
-    IF cl = Typ THEN type.typobj := obj END ;
-    obj.next := system; system := obj
-  END enter;
-  
-BEGIN
-  byteType := type(Byte, Int, 1);
-  boolType := type(Bool, Bool, 1);
-  charType := type(Char, Char,1);
-  intType := type(Int, Int, 4);
-  realType := type(Real, Real, 4);
-  setType := type(Set, Set,4);
-  nilType := type(NilTyp, NilTyp, 4);
-  noType := type(NoTyp, NoTyp, 4);
-  strType := type(String, String, 8);
-    
-  (*initialize universe with data types and in-line procedures;
-    LONGINT is synonym to INTEGER, LONGREAL to REAL.
-    LED, ADC, SBC; LDPSR, LDREG, REG, COND are not in language definition*)
-  system := NIL;  (*n = procno*10 + nofpar*)
-  enter("UML", SFunc, intType, 132);  (*functions*)
-  enter("SBC", SFunc, intType, 122);
-  enter("ADC", SFunc, intType, 112);
-  enter("ROR", SFunc, intType, 92);
-  enter("ASR", SFunc, intType, 82);
-  enter("LSL", SFunc, intType, 72);
-  enter("LEN", SFunc, intType, 61);
-  enter("CHR", SFunc, charType, 51);
-  enter("ORD", SFunc, intType, 41);
-  enter("FLT", SFunc, realType, 31);
-  enter("FLOOR", SFunc, intType, 21);
-  enter("ODD", SFunc, boolType, 11);
-  enter("ABS", SFunc, intType, 1);
-  enter("LED", SProc, noType, 81);  (*procedures*)
-  enter("UNPK", SProc, noType, 72);
-  enter("PACK", SProc, noType, 62);
-  enter("NEW", SProc, noType, 51);
-  enter("ASSERT", SProc, noType, 41);
-  enter("EXCL", SProc, noType, 32);
-  enter("INCL", SProc, noType, 22);
-  enter("DEC", SProc, noType, 11);
-  enter("INC", SProc, noType, 1);
-  enter("SET", Typ, setType, 0);   (*types*)
-  enter("BOOLEAN", Typ, boolType, 0);
-  enter("BYTE", Typ, byteType, 0);
-  enter("CHAR", Typ, charType, 0);
-  enter("LONGREAL", Typ, realType, 0);
-  enter("REAL", Typ, realType, 0);
-  enter("LONGINT", Typ, intType, 0);
-  enter("INTEGER", Typ, intType, 0);
-  topScope := NIL; OpenScope; topScope.next := system; universe := topScope;
-  
-  system := NIL;  (* initialize "unsafe" pseudo-module SYSTEM*)
-  enter("H", SFunc, intType, 201);     (*functions*)
-  enter("COND", SFunc, boolType, 191);
-  enter("SIZE", SFunc, intType, 181);
-  enter("ADR", SFunc, intType, 171);
-  enter("VAL", SFunc, intType, 162);
-  enter("REG", SFunc, intType, 151);
-  enter("BIT", SFunc, boolType, 142);
-  enter("LDREG", SProc, noType, 142);  (*procedures*)
-  enter("LDPSR", SProc, noType, 131);
-  enter("COPY", SProc, noType, 123);
-  enter("PUT", SProc, noType, 112);
-  enter("GET", SProc, noType, 102);
-END ORB.
+MODULE ORB;   (*NW 25.6.2014  / 1.3.2019  in Oberon-07*)
+  IMPORT Files, ORS;
+  (*Definition of data types Object and Type, which together form the data structure
+    called "symbol table". Contains procedures for creation of Objects, and for search:
+    NewObj, this, thisimport, thisfield (and OpenScope, CloseScope).
+    Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures
+    Import and Export. This module contains the list of standard identifiers, with which
+    the symbol table (universe), and that of the pseudo-module SYSTEM are initialized. *)
+
+  CONST versionkey* = 1; maxTypTab = 64;
+    (* class values*) Head* = 0;
+      Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5;
+      SProc* = 6; SFunc* = 7; Mod* = 8;
+
+    (* form values*)
+      Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6;
+      Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10;
+      String* = 11; Array* = 12; Record* = 13;
+      
+  TYPE Object* = POINTER TO ObjDesc;
+    Module* = POINTER TO ModDesc;
+    Type* = POINTER TO TypeDesc;
+
+    ObjDesc*= RECORD
+      class*, exno*: BYTE;
+      expo*, rdo*: BOOLEAN;   (*exported / read-only*)
+      lev*: INTEGER;
+      next*, dsc*: Object;
+      type*: Type;
+      name*: ORS.Ident;
+      val*: LONGINT
+    END ;
+
+    ModDesc* = RECORD (ObjDesc) orgname*: ORS.Ident END ;
+
+    TypeDesc* = RECORD
+      form*, ref*, mno*: INTEGER;  (*ref is only used for import/export*)
+      nofpar*: INTEGER;  (*for procedures, extension level for records*)
+      len*: LONGINT;  (*for arrays, len < 0 => open array; for records: adr of descriptor*)
+      dsc*, typobj*: Object;
+      base*: Type;  (*for arrays, records, pointers*)
+      size*: LONGINT;  (*in bytes; always multiple of 4, except for Byte, Bool and Char*)
+    END ;
+
+  (* Object classes and the meaning of "val":
+    class    val
+    ----------
+    Var      address
+    Par      address
+    Const    value
+    Fld      offset
+    Typ      type descriptor (TD) address
+    SProc    inline code number
+    SFunc    inline code number
+    Mod      key
+
+  Type forms and the meaning of "dsc" and "base":
+    form     dsc      base
+    ------------------------
+    Pointer  -        type of dereferenced object
+    Proc     params   result type
+    Array    -        type of elements
+    Record   fields   extension *)
+
+  VAR topScope*, universe, system*: Object;
+    byteType*, boolType*, charType*: Type;
+    intType*, realType*, setType*, nilType*, noType*, strType*: Type;
+    nofmod, Ref: INTEGER;
+    typtab: ARRAY maxTypTab OF Type;
+
+  PROCEDURE NewObj*(VAR obj: Object; id: ORS.Ident; class: INTEGER);  (*insert new Object with name id*)
+    VAR new, x: Object;
+  BEGIN x := topScope;
+    WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ;
+    IF x.next = NIL THEN
+      NEW(new); new.name := id; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL;
+      x.next := new; obj := new
+    ELSE obj := x.next; ORS.Mark("mult def")
+    END 
+  END NewObj;
+
+  PROCEDURE thisObj*(): Object;
+    VAR s, x: Object;
+  BEGIN s := topScope;
+    REPEAT x := s.next;
+      WHILE (x # NIL) & (x.name # ORS.id) DO x := x.next END ;
+      s := s.dsc
+    UNTIL (x # NIL) OR (s = NIL);
+    RETURN x
+  END thisObj;
+
+  PROCEDURE thisimport*(mod: Object): Object;
+    VAR obj: Object;
+  BEGIN
+    IF mod.rdo THEN
+      IF mod.name[0] # 0X THEN
+        obj := mod.dsc;
+        WHILE (obj # NIL) & (obj.name # ORS.id) DO obj := obj.next END
+      ELSE obj := NIL
+      END
+    ELSE obj := NIL
+    END ;
+    RETURN obj
+  END thisimport;
+
+  PROCEDURE thisfield*(rec: Type): Object;
+    VAR fld: Object;
+  BEGIN fld := rec.dsc;
+    WHILE (fld # NIL) & (fld.name # ORS.id) DO fld := fld.next END ;
+    RETURN fld
+  END thisfield;
+
+  PROCEDURE OpenScope*;
+    VAR s: Object;
+  BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s
+  END OpenScope;
+
+  PROCEDURE CloseScope*;
+  BEGIN topScope := topScope.dsc
+  END CloseScope;
+
+  (*------------------------------- Import ---------------------------------*)
+
+  PROCEDURE MakeFileName*(VAR FName: ORS.Ident; name, ext: ARRAY OF CHAR);
+    VAR i, j: INTEGER;
+  BEGIN i := 0; j := 0;  (*assume name suffix less than 4 characters*)
+    WHILE (i < ORS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ;
+    REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X;
+    FName[i] := 0X
+  END MakeFileName;
+  
+  PROCEDURE ThisModule(name, orgname: ORS.Ident; non: BOOLEAN; key: LONGINT): Object;
+    VAR mod: Module; obj, obj1: Object;
+  BEGIN obj1 := topScope; obj := obj1.next;  (*search for module*)
+    WHILE (obj # NIL) & (obj.name # name) DO obj1 := obj; obj := obj1.next END ;
+    IF obj = NIL THEN  (*insert new module*)
+      NEW(mod); mod.class := Mod; mod.rdo := FALSE;
+      mod.name := name; mod.orgname := orgname; mod.val := key;
+      mod.lev := nofmod; INC(nofmod); mod.type := noType; mod.dsc := NIL; mod.next := NIL;
+      obj1.next := mod; obj := mod
+    ELSE (*module already present*)
+      IF non THEN ORS.Mark("invalid import order") END
+    END ;
+    RETURN obj
+  END ThisModule;
+  
+  PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER);
+    VAR b: BYTE;
+  BEGIN Files.ReadByte(R, b);
+    IF b < 80H THEN x := b ELSE x := b - 100H END
+  END Read;
+  
+  PROCEDURE InType(VAR R: Files.Rider; thismod: Object; VAR T: Type);
+    VAR key: LONGINT;
+      ref, class, form, np, readonly: INTEGER;
+      fld, par, obj, mod, last: Object;
+      t: Type;
+      name, modname: ORS.Ident;
+  BEGIN Read(R, ref);
+    IF ref < 0 THEN T := typtab[-ref]  (*already read*)
+    ELSE NEW(t); T := t; typtab[ref] := t; t.mno := thismod.lev;
+      Read(R, form); t.form := form;
+      IF form = Pointer THEN InType(R, thismod, t.base); t.size := 4
+      ELSIF form = Array THEN
+        InType(R, thismod, t.base); Files.ReadNum(R, t.len); Files.ReadNum(R, t.size)
+      ELSIF form = Record THEN
+        InType(R, thismod, t.base);
+        IF t.base.form = NoTyp THEN t.base := NIL; obj := NIL ELSE obj := t.base.dsc END ;
+        Files.ReadNum(R, t.len); (*TD adr/exno*)
+        Files.ReadNum(R, t.nofpar);  (*ext level*)
+        Files.ReadNum(R, t.size);
+        Read(R, class); last := NIL;
+        WHILE class # 0 DO  (*fields*)
+          NEW(fld); fld.class := class; Files.ReadString(R, fld.name);
+          IF last = NIL THEN t.dsc := fld ELSE last.next := fld END ;
+          last := fld;
+          IF fld.name[0] # 0X THEN fld.expo := TRUE; InType(R, thismod, fld.type) ELSE fld.expo := FALSE; fld.type := nilType END ;
+          Files.ReadNum(R, fld.val); Read(R, class)
+        END ;
+        IF last = NIL THEN t.dsc := obj ELSE last.next := obj END
+      ELSIF form = Proc THEN
+        InType(R, thismod, t.base);
+        obj := NIL; np := 0; Read(R, class);
+        WHILE class # 0 DO  (*parameters*)
+          NEW(par); par.class := class; Read(R, readonly); par.rdo := readonly = 1; 
+          InType(R, thismod, par.type); par.next := obj; obj := par; INC(np); Read(R, class)
+        END ;
+        t.dsc := obj; t.nofpar := np; t.size := 4
+      END ;
+      Files.ReadString(R, modname);
+      IF modname[0] #  0X THEN  (*re-import*)
+        Files.ReadInt(R, key); Files.ReadString(R, name);
+        mod := ThisModule(modname, modname, FALSE, key);
+        obj := mod.dsc;  (*search type*)
+        WHILE (obj # NIL) & (obj.name # name) DO obj := obj.next END ;
+        IF obj # NIL THEN T := obj.type   (*type object found in object list of mod*)
+        ELSE (*insert new type object in object list of mod*)
+          NEW(obj); obj.name := name; obj.class := Typ; obj.next := mod.dsc; mod.dsc := obj; obj.type := t;
+          t.mno := mod.lev; t.typobj := obj; T := t
+        END ;
+        typtab[ref] := T
+      END
+    END
+  END InType;
+  
+  PROCEDURE Import*(VAR modid, modid1: ORS.Ident);
+    VAR key: LONGINT; class, k: INTEGER;
+      obj: Object;  t: Type;
+      thismod: Object;
+      modname, fname: ORS.Ident;
+      F: Files.File; R: Files.Rider;
+  BEGIN
+    IF modid1 = "SYSTEM" THEN
+      thismod := ThisModule(modid, modid1, TRUE, key); DEC(nofmod);
+      thismod.lev := 0; thismod.dsc := system; thismod.rdo := TRUE
+    ELSE MakeFileName(fname, modid1, ".smb"); F := Files.Old(fname);
+      IF F # NIL THEN
+        Files.Set(R, F, 0); Files.ReadInt(R, key); Files.ReadInt(R, key); Files.ReadString(R, modname);
+        thismod := ThisModule(modid, modid1, TRUE, key); thismod.rdo := TRUE;
+        Read(R, class); (*version key*)
+        IF class # versionkey THEN ORS.Mark("wrong version") END ;
+        Read(R, class);
+        WHILE class # 0 DO
+          NEW(obj); obj.class := class; Files.ReadString(R, obj.name);
+          InType(R, thismod, obj.type); obj.lev := -thismod.lev;
+          IF class = Typ THEN
+            t := obj.type; t.typobj := obj; Read(R, k);  (*fixup bases of previously declared pointer types*)
+            WHILE k # 0 DO typtab[k].base := t; Read(R, k) END
+          ELSE
+            IF class = Const THEN
+              IF obj.type.form = Real THEN Files.ReadInt(R, obj.val) ELSE Files.ReadNum(R, obj.val) END
+            ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE
+            END
+          END ;
+          obj.next := thismod.dsc; thismod.dsc := obj; Read(R, class)
+        END ;
+      ELSE ORS.Mark("import not available")
+      END
+    END
+  END Import;
+  
+  (*-------------------------------- Export ---------------------------------*)
+
+  PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
+  BEGIN Files.WriteByte(R, x)
+  END Write;
+
+  PROCEDURE OutType(VAR R: Files.Rider; t: Type);
+    VAR obj, mod, fld, bot: Object;
+
+    PROCEDURE OutPar(VAR R: Files.Rider; par: Object; n: INTEGER);
+      VAR cl: INTEGER;
+    BEGIN
+      IF n > 0 THEN
+        OutPar(R, par.next, n-1); cl := par.class;
+        Write(R, cl);
+        IF par.rdo THEN Write(R, 1) ELSE Write(R, 0) END ;
+        OutType(R, par.type)
+      END
+    END OutPar;
+
+    PROCEDURE FindHiddenPointers(VAR R: Files.Rider; typ: Type; offset: LONGINT);
+      VAR fld: Object; i, n: LONGINT;
+    BEGIN
+      IF (typ.form = Pointer) OR (typ.form = NilTyp) THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, offset)
+      ELSIF typ.form = Record THEN fld := typ.dsc;
+        WHILE fld # NIL DO FindHiddenPointers(R, fld.type, fld.val + offset); fld := fld.next END
+      ELSIF typ.form = Array THEN i := 0; n := typ.len;
+        WHILE i < n DO FindHiddenPointers(R, typ.base, typ.base.size * i + offset); INC(i) END
+      END
+    END FindHiddenPointers;
+
+  BEGIN
+    IF t.ref > 0 THEN (*type was already output*) Write(R, -t.ref)
+    ELSE obj := t.typobj;
+      IF obj # NIL THEN Write(R, Ref); t.ref := Ref; INC(Ref) ELSE (*anonymous*) Write(R, 0) END ;
+      Write(R, t.form);
+      IF t.form = Pointer THEN OutType(R, t.base)
+      ELSIF t.form = Array THEN OutType(R, t.base); Files.WriteNum(R, t.len); Files.WriteNum(R, t.size)
+      ELSIF t.form = Record THEN
+        IF t.base # NIL THEN OutType(R, t.base); bot := t.base.dsc ELSE OutType(R, noType); bot := NIL END ;
+        IF obj # NIL THEN Files.WriteNum(R, obj.exno) ELSE Write(R, 0) END ;
+        Files.WriteNum(R, t.nofpar); Files.WriteNum(R, t.size);
+        fld := t.dsc;
+        WHILE fld # bot DO  (*fields*)
+          IF fld.expo THEN
+            Write(R, Fld); Files.WriteString(R, fld.name); OutType(R, fld.type); Files.WriteNum(R, fld.val)  (*offset*)
+          ELSE FindHiddenPointers(R, fld.type, fld.val)
+          END ;
+          fld := fld.next
+        END ;
+        Write(R, 0)
+      ELSIF t.form = Proc THEN OutType(R, t.base); OutPar(R, t.dsc, t.nofpar); Write(R, 0)
+      END ;
+      IF (t.mno > 0) & (obj # NIL) THEN  (*re-export, output name*)
+        mod := topScope.next;
+        WHILE (mod # NIL) & (mod.lev # t.mno) DO mod := mod.next END ;
+        IF mod # NIL THEN Files.WriteString(R, mod(Module).orgname); Files.WriteInt(R, mod.val); Files.WriteString(R, obj.name)
+        ELSE ORS.Mark("re-export not found"); Write(R, 0)
+        END
+      ELSE Write(R, 0)
+      END
+    END
+  END OutType;
+
+  PROCEDURE Export*(VAR modid: ORS.Ident; VAR newSF: BOOLEAN; VAR key: LONGINT);
+    VAR x, sum, oldkey: LONGINT;
+      obj, obj0: Object;
+      filename: ORS.Ident;
+      F, F1: Files.File; R, R1: Files.Rider;
+  BEGIN Ref := Record + 1; MakeFileName(filename, modid, ".smb");
+    F := Files.New(filename); Files.Set(R, F, 0);
+    Files.WriteInt(R, 0); (*placeholder*)
+    Files.WriteInt(R, 0); (*placeholder for key to be inserted at the end*)
+    Files.WriteString(R, modid); Write(R, versionkey);
+    obj := topScope.next;
+    WHILE obj # NIL DO
+      IF obj.expo THEN
+        Write(R, obj.class); Files.WriteString(R, obj.name);
+        OutType(R, obj.type);
+        IF obj.class = Typ THEN
+          IF obj.type.form = Record THEN
+            obj0 := topScope.next;  (*check whether this is base of previously declared pointer types*)
+            WHILE obj0 # obj DO
+              IF (obj0.type.form = Pointer) & (obj0.type.base = obj.type) & (obj0.type.ref > 0) THEN Write(R, obj0.type.ref) END ;
+              obj0 := obj0.next
+            END
+          END ;
+          Write(R, 0)
+        ELSIF obj.class = Const THEN
+          IF obj.type.form = Proc THEN Files.WriteNum(R, obj.exno)
+          ELSIF obj.type.form = Real THEN Files.WriteInt(R, obj.val)
+          ELSE Files.WriteNum(R, obj.val)
+          END
+        ELSIF obj.class = Var THEN Files.WriteNum(R, obj.exno)
+        END
+      END ;
+      obj := obj.next
+    END ;
+    REPEAT Write(R, 0) UNTIL Files.Length(F) MOD 4 = 0;
+    FOR Ref := Record+1 TO maxTypTab-1 DO typtab[Ref] := NIL END ;
+    Files.Set(R, F, 0); sum := 0; Files.ReadInt(R, x);  (* compute key (checksum) *)
+    WHILE ~R.eof DO sum := sum + x; Files.ReadInt(R, x) END ;
+    F1 := Files.Old(filename); (*sum is new key*)
+    IF F1 # NIL THEN Files.Set(R1, F1, 4); Files.ReadInt(R1, oldkey) ELSE oldkey := sum+1 END ;
+    IF sum # oldkey THEN
+      IF newSF OR (F1 = NIL) THEN
+        key := sum; newSF := TRUE; Files.Set(R, F, 4); Files.WriteInt(R, sum); Files.Register(F)  (*insert checksum*)
+      ELSE ORS.Mark("new symbol file inhibited")
+      END
+    ELSE newSF := FALSE; key := sum
+    END
+  END Export;
+
+  PROCEDURE Init*;
+  BEGIN topScope := universe; nofmod := 1
+  END Init;
+  
+  PROCEDURE type(ref, form: INTEGER; size: LONGINT): Type;
+    VAR tp: Type;
+  BEGIN NEW(tp); tp.form := form; tp.size := size; tp.ref := ref; tp.base := NIL;
+    typtab[ref] := tp; RETURN tp
+  END type;
+
+  PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: LONGINT);
+    VAR obj: Object;
+  BEGIN NEW(obj); obj.name := name; obj.class := cl; obj.type := type; obj.val := n; obj.dsc := NIL;
+    IF cl = Typ THEN type.typobj := obj END ;
+    obj.next := system; system := obj
+  END enter;
+  
+BEGIN
+  byteType := type(Byte, Int, 1);
+  boolType := type(Bool, Bool, 1);
+  charType := type(Char, Char,1);
+  intType := type(Int, Int, 4);
+  realType := type(Real, Real, 4);
+  setType := type(Set, Set,4);
+  nilType := type(NilTyp, NilTyp, 4);
+  noType := type(NoTyp, NoTyp, 4);
+  strType := type(String, String, 8);
+    
+  (*initialize universe with data types and in-line procedures;
+    LONGINT is synonym to INTEGER, LONGREAL to REAL.
+    LED, ADC, SBC; LDPSR, LDREG, REG, COND are not in language definition*)
+  system := NIL;  (*n = procno*10 + nofpar*)
+  enter("UML", SFunc, intType, 132);  (*functions*)
+  enter("SBC", SFunc, intType, 122);
+  enter("ADC", SFunc, intType, 112);
+  enter("ROR", SFunc, intType, 92);
+  enter("ASR", SFunc, intType, 82);
+  enter("LSL", SFunc, intType, 72);
+  enter("LEN", SFunc, intType, 61);
+  enter("CHR", SFunc, charType, 51);
+  enter("ORD", SFunc, intType, 41);
+  enter("FLT", SFunc, realType, 31);
+  enter("FLOOR", SFunc, intType, 21);
+  enter("ODD", SFunc, boolType, 11);
+  enter("ABS", SFunc, intType, 1);
+  enter("LED", SProc, noType, 81);  (*procedures*)
+  enter("UNPK", SProc, noType, 72);
+  enter("PACK", SProc, noType, 62);
+  enter("NEW", SProc, noType, 51);
+  enter("ASSERT", SProc, noType, 41);
+  enter("EXCL", SProc, noType, 32);
+  enter("INCL", SProc, noType, 22);
+  enter("DEC", SProc, noType, 11);
+  enter("INC", SProc, noType, 1);
+  enter("SET", Typ, setType, 0);   (*types*)
+  enter("BOOLEAN", Typ, boolType, 0);
+  enter("BYTE", Typ, byteType, 0);
+  enter("CHAR", Typ, charType, 0);
+  enter("LONGREAL", Typ, realType, 0);
+  enter("REAL", Typ, realType, 0);
+  enter("LONGINT", Typ, intType, 0);
+  enter("INTEGER", Typ, intType, 0);
+  topScope := NIL; OpenScope; topScope.next := system; universe := topScope;
+  
+  system := NIL;  (* initialize "unsafe" pseudo-module SYSTEM*)
+  enter("H", SFunc, intType, 201);     (*functions*)
+  enter("COND", SFunc, boolType, 191);
+  enter("SIZE", SFunc, intType, 181);
+  enter("ADR", SFunc, intType, 171);
+  enter("VAL", SFunc, intType, 162);
+  enter("REG", SFunc, intType, 151);
+  enter("BIT", SFunc, boolType, 142);
+  enter("LDREG", SProc, noType, 142);  (*procedures*)
+  enter("LDPSR", SProc, noType, 131);
+  enter("COPY", SProc, noType, 123);
+  enter("PUT", SProc, noType, 112);
+  enter("GET", SProc, noType, 102);
+END ORB.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/ORC.Mod.txt

@@ -1,206 +1,206 @@
-MODULE  ORC;  (*Connection to RISC; NW 11.11.2013*)
-  IMPORT SYSTEM, Files, Texts, Oberon, V24;
-  CONST portno = 1; (*RS-232*)
-    BlkLen = 255; pno = 1;
-    REQ = 20X; REC = 21X; SND = 22X; CLS = 23X; ACK = 10X;
-    Tout = 1000;
-
-  VAR res: LONGINT;
-    W: Texts.Writer;
-
-  PROCEDURE Flush*;
-    VAR ch: CHAR;
-  BEGIN 
-    WHILE V24.Available(portno) > 0 DO V24.Receive(portno, ch, res); Texts.Write(W, ch) END ;
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END Flush;
-
-  PROCEDURE Open*;
-    VAR ch: CHAR;
-  BEGIN V24.Start(pno, 19200, 8, V24.ParNo, V24.Stop1, res);
-    WHILE V24.Available(pno) > 0 DO V24.Receive(pno, ch, res) END ;
-    IF res > 0 THEN Texts.WriteString(W, "open V24, error ="); Texts.WriteInt(W, res, 4)
-    ELSE Texts.WriteString(W, "connection open")
-    END ;
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END Open;
-
-  PROCEDURE TestReq*;
-    VAR ch: CHAR;
-  BEGIN V24.Send(pno, REQ, res); Rec(ch); Texts.WriteInt(W, ORD(ch), 4);
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END TestReq;
-
-  PROCEDURE SendInt(x: LONGINT);
-    VAR i: INTEGER;
-  BEGIN i := 4;
-    WHILE i > 0 DO
-      DEC(i); V24.Send(portno, CHR(x), res); x := x DIV 100H
-    END
-  END SendInt;
-
-  PROCEDURE Load*;  (*linked boot file  F.bin*)
-    VAR i, m, n, w: LONGINT;
-      F: Files.File; R: Files.Rider;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN (*input file name*)
-      Texts.WriteString(W, S.s); F := Files.Old(S.s);
-      IF F # NIL THEN
-        Files.Set(R, F, 0); Files.ReadLInt(R, n); Files.ReadLInt(R, m); n := n DIV 4;
-        Texts.WriteInt(W, n, 6); Texts.WriteString(W, " loading "); Texts.Append(Oberon.Log, W.buf);
-        i := 0; SendInt(n*4); SendInt(m);
-        WHILE i < n DO
-          IF i + 1024 < n THEN m := i + 1024 ELSE m := n END ;
-          WHILE i < m DO Files.ReadLInt(R, w); SendInt(w); INC(i) END ;
-          Texts.Write(W, "."); Texts.Append(Oberon.Log, W.buf)
-        END ;
-        SendInt(0); Texts.WriteString(W, "done")
-      ELSE Texts.WriteString(W, " not found")
-      END ;
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END Load;
-
-(* ------------ send and receive files ------------ *)
-
-  PROCEDURE Rec(VAR ch: CHAR);   (*receive with timeout*)
-    VAR time: LONGINT;
-  BEGIN time := Oberon.Time() + 3000;
-    LOOP
-      IF V24.Available(pno) > 0 THEN V24.Receive(pno, ch, res); EXIT END ;
-      IF Oberon.Time() >= time THEN ch := 0X; EXIT END 
-    END
-  END Rec;
-
-  PROCEDURE SendName(VAR s: ARRAY OF CHAR);
-    VAR i: INTEGER; ch: CHAR;
-  BEGIN i := 0; ch := s[0];
-    WHILE ch > 0X DO V24.Send(pno, ch, res); INC(i); ch := s[i] END ;
-    V24.Send(pno, 0X, res)
-  END SendName;
-
-  PROCEDURE Send*;
-    VAR ch, code: CHAR;
-      n, n0, L: LONGINT;
-      F: Files.File; R: Files.Rider;
-      S: Texts.Scanner;
-  BEGIN V24.Send(pno, REQ, res); Rec(code);
-    IF code = ACK THEN
-      Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-      WHILE S.class = Texts.Name DO
-        Texts.WriteString(W, S.s); F := Files.Old(S.s);
-        IF F # NIL THEN
-          V24.Send(pno, REC, res); SendName(S.s); Rec(code);
-          IF code = ACK THEN
-            Texts.WriteString(W, " sending ");
-            L := Files.Length(F); Files.Set(R, F, 0);
-            REPEAT (*send paket*)
-              IF L > BlkLen THEN n := BlkLen ELSE n := L END ;
-              n0 := n; V24.Send(pno, CHR(n), res); DEC(L, n);
-              WHILE n > 0 DO Files.Read(R, ch); V24.Send(pno, ch, res); DEC(n) END ;
-              Rec(code);
-              IF code = ACK THEN Texts.Write(W, ".") ELSE Texts.Write(W, "*"); n := 0 END ;
-              Texts.Append(Oberon.Log, W.buf)
-            UNTIL n0 < BlkLen;
-            Rec(code)
-          ELSE Texts.WriteString(W, " no response"); Texts.WriteInt(W, ORD(code), 4)
-          END
-        ELSE Texts.WriteString(W, " not found")
-        END ;
-        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S)
-      END
-    ELSE Texts.WriteString(W, " connection not open");
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END Send;
-
-  PROCEDURE Receive*;
-    VAR ch, code: CHAR;
-      n, L, LL: LONGINT;
-      F: Files.File; R: Files.Rider;
-      orgname: ARRAY 32 OF CHAR;
-      S: Texts.Scanner;
-  BEGIN V24.Send(pno, REQ, res); Rec(code);
-    IF code = ACK THEN
-      Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-      WHILE S.class = Texts.Name DO
-        Texts.WriteString(W, S.s); COPY(S.s, orgname);
-        F := Files.New(S.s); Files.Set(R, F, 0); LL := 0;
-        V24.Send(pno, SND, res); SendName(S.s); Rec(code);
-        IF code = ACK THEN
-          Texts.WriteString(W, " receiving ");
-          REPEAT Rec(ch); L := ORD(ch); n := L;
-            WHILE n > 0 DO V24.Receive(pno, ch, res); Files.Write(R, ch); DEC(n) END ;
-            V24.Send(pno, ACK, res); LL := LL + L; Texts.Write(W, "."); Texts.Append(Oberon.Log, W.buf)
-          UNTIL L < BlkLen;
-          Files.Register(F); Texts.WriteInt(W, LL, 6)
-        ELSE Texts.WriteString(W, " no response"); Texts.WriteInt(W, ORD(code), 4)
-        END ;
-        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S)
-      END
-    ELSE Texts.WriteString(W, " connection not open");
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END Receive;
-  
-  PROCEDURE Close*;
-  BEGIN V24.Send(pno, CLS, res);
-    Texts.WriteString(W, "Server closed"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END Close;
-  
-(* ------------ Oberon-0 commands ------------ *)
-
-  PROCEDURE RecByte(VAR ch: CHAR);
-    VAR T: LONGINT; ch0: CHAR;
-  BEGIN T := Oberon.Time() + Tout;
-    REPEAT UNTIL (V24.Available(portno) > 0) OR (Oberon.Time() >= T);
-    IF V24.Available(portno) > 0 THEN V24.Receive(portno, ch, res) ELSE ch := 0X END ;
-  END RecByte;
-
-  PROCEDURE RecInt(VAR x: LONGINT);
-      VAR i, k, T: LONGINT; ch: CHAR;
-  BEGIN i := 4; k := 0;
-    REPEAT
-      DEC(i); V24.Receive(portno, ch, res);
-      k := SYSTEM.ROT(ORD(ch)+k, -8)
-    UNTIL i = 0;
-    x := k
-  END RecInt;
-
-  PROCEDURE SR*;  (*send, then receive sequence of items*)
-    VAR S: Texts.Scanner; i, k: LONGINT; ch, xch: CHAR;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    WHILE (S.class # Texts.Char) & (S.c # "~") DO
-      IF S.class = Texts.Int THEN Texts.WriteInt(W, S.i, 6); SendInt(S.i)
-      ELSIF S.class = Texts.Real THEN
-        Texts.WriteReal(W, S.x, 12); SendInt(SYSTEM.VAL(LONGINT, S.x))
-      ELSIF S.class IN {Texts.Name, Texts.String} THEN
-        Texts.Write(W, " "); Texts.WriteString(W, S.s); i := 0;
-        REPEAT ch := S.s[i]; V24.Send(portno, ch, res); INC(i) UNTIL ch = 0X
-      ELSIF S.class = Texts.Char THEN Texts.Write(W, S.c)
-      ELSE Texts.WriteString(W, "bad value")  
-      END ;
-      Texts.Scan(S)
-    END ;
-    Texts.Write(W, "|"); (*Texts.Append(Oberon.Log, W.buf);*)
-    (*receive input*)
-    REPEAT RecByte(xch);
-      IF xch = 0X THEN Texts.WriteString(W, " timeout"); Flush
-      ELSIF xch = 1X THEN RecInt(k); Texts.WriteInt(W, k, 6)
-      ELSIF xch = 2X THEN RecInt(k); Texts.WriteHex(W, k)
-      ELSIF xch = 3X THEN RecInt(k); Texts.WriteReal(W, SYSTEM.VAL(REAL, k), 15)
-      ELSIF xch = 4X THEN Texts.Write(W, " "); V24.Receive(portno, ch, res);
-        WHILE ch > 0X DO Texts.Write(W, ch); V24.Receive(portno, ch, res) END        
-      ELSIF xch = 5X THEN V24.Receive(portno, ch, res); Texts.Write(W, ch)
-      ELSIF xch = 6X THEN Texts.WriteLn(W)
-      ELSIF xch = 7X THEN Texts.Write(W, "~"); xch := 0X
-      ELSIF xch = 8X THEN RecByte(ch); Texts.WriteInt(W, ORD(ch), 4); Texts.Append(Oberon.Log, W.buf)
-      ELSE xch := 0X
-      END
-    UNTIL xch = 0X;
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END SR;
-
-BEGIN Texts.OpenWriter(W);
-END ORC.
+MODULE  ORC;  (*Connection to RISC; NW 11.11.2013*)
+  IMPORT SYSTEM, Files, Texts, Oberon, V24;
+  CONST portno = 1; (*RS-232*)
+    BlkLen = 255; pno = 1;
+    REQ = 20X; REC = 21X; SND = 22X; CLS = 23X; ACK = 10X;
+    Tout = 1000;
+
+  VAR res: LONGINT;
+    W: Texts.Writer;
+
+  PROCEDURE Flush*;
+    VAR ch: CHAR;
+  BEGIN 
+    WHILE V24.Available(portno) > 0 DO V24.Receive(portno, ch, res); Texts.Write(W, ch) END ;
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END Flush;
+
+  PROCEDURE Open*;
+    VAR ch: CHAR;
+  BEGIN V24.Start(pno, 19200, 8, V24.ParNo, V24.Stop1, res);
+    WHILE V24.Available(pno) > 0 DO V24.Receive(pno, ch, res) END ;
+    IF res > 0 THEN Texts.WriteString(W, "open V24, error ="); Texts.WriteInt(W, res, 4)
+    ELSE Texts.WriteString(W, "connection open")
+    END ;
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END Open;
+
+  PROCEDURE TestReq*;
+    VAR ch: CHAR;
+  BEGIN V24.Send(pno, REQ, res); Rec(ch); Texts.WriteInt(W, ORD(ch), 4);
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END TestReq;
+
+  PROCEDURE SendInt(x: LONGINT);
+    VAR i: INTEGER;
+  BEGIN i := 4;
+    WHILE i > 0 DO
+      DEC(i); V24.Send(portno, CHR(x), res); x := x DIV 100H
+    END
+  END SendInt;
+
+  PROCEDURE Load*;  (*linked boot file  F.bin*)
+    VAR i, m, n, w: LONGINT;
+      F: Files.File; R: Files.Rider;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN (*input file name*)
+      Texts.WriteString(W, S.s); F := Files.Old(S.s);
+      IF F # NIL THEN
+        Files.Set(R, F, 0); Files.ReadLInt(R, n); Files.ReadLInt(R, m); n := n DIV 4;
+        Texts.WriteInt(W, n, 6); Texts.WriteString(W, " loading "); Texts.Append(Oberon.Log, W.buf);
+        i := 0; SendInt(n*4); SendInt(m);
+        WHILE i < n DO
+          IF i + 1024 < n THEN m := i + 1024 ELSE m := n END ;
+          WHILE i < m DO Files.ReadLInt(R, w); SendInt(w); INC(i) END ;
+          Texts.Write(W, "."); Texts.Append(Oberon.Log, W.buf)
+        END ;
+        SendInt(0); Texts.WriteString(W, "done")
+      ELSE Texts.WriteString(W, " not found")
+      END ;
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END Load;
+
+(* ------------ send and receive files ------------ *)
+
+  PROCEDURE Rec(VAR ch: CHAR);   (*receive with timeout*)
+    VAR time: LONGINT;
+  BEGIN time := Oberon.Time() + 3000;
+    LOOP
+      IF V24.Available(pno) > 0 THEN V24.Receive(pno, ch, res); EXIT END ;
+      IF Oberon.Time() >= time THEN ch := 0X; EXIT END 
+    END
+  END Rec;
+
+  PROCEDURE SendName(VAR s: ARRAY OF CHAR);
+    VAR i: INTEGER; ch: CHAR;
+  BEGIN i := 0; ch := s[0];
+    WHILE ch > 0X DO V24.Send(pno, ch, res); INC(i); ch := s[i] END ;
+    V24.Send(pno, 0X, res)
+  END SendName;
+
+  PROCEDURE Send*;
+    VAR ch, code: CHAR;
+      n, n0, L: LONGINT;
+      F: Files.File; R: Files.Rider;
+      S: Texts.Scanner;
+  BEGIN V24.Send(pno, REQ, res); Rec(code);
+    IF code = ACK THEN
+      Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+      WHILE S.class = Texts.Name DO
+        Texts.WriteString(W, S.s); F := Files.Old(S.s);
+        IF F # NIL THEN
+          V24.Send(pno, REC, res); SendName(S.s); Rec(code);
+          IF code = ACK THEN
+            Texts.WriteString(W, " sending ");
+            L := Files.Length(F); Files.Set(R, F, 0);
+            REPEAT (*send paket*)
+              IF L > BlkLen THEN n := BlkLen ELSE n := L END ;
+              n0 := n; V24.Send(pno, CHR(n), res); DEC(L, n);
+              WHILE n > 0 DO Files.Read(R, ch); V24.Send(pno, ch, res); DEC(n) END ;
+              Rec(code);
+              IF code = ACK THEN Texts.Write(W, ".") ELSE Texts.Write(W, "*"); n := 0 END ;
+              Texts.Append(Oberon.Log, W.buf)
+            UNTIL n0 < BlkLen;
+            Rec(code)
+          ELSE Texts.WriteString(W, " no response"); Texts.WriteInt(W, ORD(code), 4)
+          END
+        ELSE Texts.WriteString(W, " not found")
+        END ;
+        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S)
+      END
+    ELSE Texts.WriteString(W, " connection not open");
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END Send;
+
+  PROCEDURE Receive*;
+    VAR ch, code: CHAR;
+      n, L, LL: LONGINT;
+      F: Files.File; R: Files.Rider;
+      orgname: ARRAY 32 OF CHAR;
+      S: Texts.Scanner;
+  BEGIN V24.Send(pno, REQ, res); Rec(code);
+    IF code = ACK THEN
+      Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+      WHILE S.class = Texts.Name DO
+        Texts.WriteString(W, S.s); COPY(S.s, orgname);
+        F := Files.New(S.s); Files.Set(R, F, 0); LL := 0;
+        V24.Send(pno, SND, res); SendName(S.s); Rec(code);
+        IF code = ACK THEN
+          Texts.WriteString(W, " receiving ");
+          REPEAT Rec(ch); L := ORD(ch); n := L;
+            WHILE n > 0 DO V24.Receive(pno, ch, res); Files.Write(R, ch); DEC(n) END ;
+            V24.Send(pno, ACK, res); LL := LL + L; Texts.Write(W, "."); Texts.Append(Oberon.Log, W.buf)
+          UNTIL L < BlkLen;
+          Files.Register(F); Texts.WriteInt(W, LL, 6)
+        ELSE Texts.WriteString(W, " no response"); Texts.WriteInt(W, ORD(code), 4)
+        END ;
+        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S)
+      END
+    ELSE Texts.WriteString(W, " connection not open");
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END Receive;
+  
+  PROCEDURE Close*;
+  BEGIN V24.Send(pno, CLS, res);
+    Texts.WriteString(W, "Server closed"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END Close;
+  
+(* ------------ Oberon-0 commands ------------ *)
+
+  PROCEDURE RecByte(VAR ch: CHAR);
+    VAR T: LONGINT; ch0: CHAR;
+  BEGIN T := Oberon.Time() + Tout;
+    REPEAT UNTIL (V24.Available(portno) > 0) OR (Oberon.Time() >= T);
+    IF V24.Available(portno) > 0 THEN V24.Receive(portno, ch, res) ELSE ch := 0X END ;
+  END RecByte;
+
+  PROCEDURE RecInt(VAR x: LONGINT);
+      VAR i, k, T: LONGINT; ch: CHAR;
+  BEGIN i := 4; k := 0;
+    REPEAT
+      DEC(i); V24.Receive(portno, ch, res);
+      k := SYSTEM.ROT(ORD(ch)+k, -8)
+    UNTIL i = 0;
+    x := k
+  END RecInt;
+
+  PROCEDURE SR*;  (*send, then receive sequence of items*)
+    VAR S: Texts.Scanner; i, k: LONGINT; ch, xch: CHAR;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    WHILE (S.class # Texts.Char) & (S.c # "~") DO
+      IF S.class = Texts.Int THEN Texts.WriteInt(W, S.i, 6); SendInt(S.i)
+      ELSIF S.class = Texts.Real THEN
+        Texts.WriteReal(W, S.x, 12); SendInt(SYSTEM.VAL(LONGINT, S.x))
+      ELSIF S.class IN {Texts.Name, Texts.String} THEN
+        Texts.Write(W, " "); Texts.WriteString(W, S.s); i := 0;
+        REPEAT ch := S.s[i]; V24.Send(portno, ch, res); INC(i) UNTIL ch = 0X
+      ELSIF S.class = Texts.Char THEN Texts.Write(W, S.c)
+      ELSE Texts.WriteString(W, "bad value")  
+      END ;
+      Texts.Scan(S)
+    END ;
+    Texts.Write(W, "|"); (*Texts.Append(Oberon.Log, W.buf);*)
+    (*receive input*)
+    REPEAT RecByte(xch);
+      IF xch = 0X THEN Texts.WriteString(W, " timeout"); Flush
+      ELSIF xch = 1X THEN RecInt(k); Texts.WriteInt(W, k, 6)
+      ELSIF xch = 2X THEN RecInt(k); Texts.WriteHex(W, k)
+      ELSIF xch = 3X THEN RecInt(k); Texts.WriteReal(W, SYSTEM.VAL(REAL, k), 15)
+      ELSIF xch = 4X THEN Texts.Write(W, " "); V24.Receive(portno, ch, res);
+        WHILE ch > 0X DO Texts.Write(W, ch); V24.Receive(portno, ch, res) END        
+      ELSIF xch = 5X THEN V24.Receive(portno, ch, res); Texts.Write(W, ch)
+      ELSIF xch = 6X THEN Texts.WriteLn(W)
+      ELSIF xch = 7X THEN Texts.Write(W, "~"); xch := 0X
+      ELSIF xch = 8X THEN RecByte(ch); Texts.WriteInt(W, ORD(ch), 4); Texts.Append(Oberon.Log, W.buf)
+      ELSE xch := 0X
+      END
+    UNTIL xch = 0X;
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END SR;
+
+BEGIN Texts.OpenWriter(W);
+END ORC.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/ORG.Mod.txt

@@ -1,1115 +1,1115 @@
-MODULE ORG; (* N.Wirth, 16.4.2016 / 4.4.2017 / 17.9.2018  Oberon compiler; code generator for RISC*)
-  IMPORT SYSTEM, Files, ORS, ORB;
-  (*Code generator for Oberon compiler for RISC processor.
-     Procedural interface to Parser OSAP; result in array "code".
-     Procedure Close writes code-files*)
-
-  CONST WordSize* = 4;
-    StkOrg0 = -64; VarOrg0 = 0;  (*for RISC-0 only*)
-    MT = 12; SP = 14; LNK = 15;   (*dedicated registers*)
-    maxCode = 8000; maxStrx = 2400; maxTD = 160; C24 = 1000000H;
-    Reg = 10; RegI = 11; Cond = 12;  (*internal item modes*)
-
-  (*frequently used opcodes*)  U = 2000H; V = 1000H;
-    Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7;
-    Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11;
-    Fad = 12; Fsb = 13; Fml = 14; Fdv = 15;
-    Ldr = 8; Str = 10;
-    BR = 0; BLR = 1; BC = 2; BL = 3;
-    MI = 0; PL = 8; EQ = 1; NE = 9; LT = 5; GE = 13; LE = 6; GT = 14;
-
-    TYPE Item* = RECORD
-      mode*: INTEGER;
-      type*: ORB.Type;
-      a*, b*, r: LONGINT;
-      rdo*: BOOLEAN  (*read only*)
-    END ;
-
-  (* Item forms and meaning of fields:
-    mode    r      a       b
-    --------------------------------
-    Const   -     value (proc adr)  (immediate value)
-    Var     base   off     -               (direct adr)
-    Par      -     off0     off1         (indirect adr)
-    Reg    regno
-    RegI   regno   off     -
-    Cond  cond   Fchain  Tchain  *)
-
-  VAR pc*, varsize: LONGINT;   (*program counter, data index*)
-    tdx, strx: LONGINT;
-    entry: LONGINT;   (*main entry point*)
-    RH: LONGINT;  (*available registers R[0] ... R[H-1]*)
-    frame: LONGINT;  (*frame offset changed in SaveRegs and RestoreRegs*)
-    fixorgP, fixorgD, fixorgT: LONGINT;   (*origins of lists of locations to be fixed up by loader*)
-    check: BOOLEAN;  (*emit run-time checks*)
-    version: INTEGER;  (* 0 = RISC-0, 1 = RISC-5 *)
-    
-    relmap: ARRAY 6 OF INTEGER;  (*condition codes for relations*)
-    code: ARRAY maxCode OF LONGINT;
-    data: ARRAY maxTD OF LONGINT;  (*type descriptors*)
-    str: ARRAY maxStrx OF CHAR;
-
-  (*instruction assemblers according to formats*)
-
-  PROCEDURE Put0(op, a, b, c: LONGINT);
-  BEGIN (*emit format-0 instruction*)
-    code[pc] := ((a*10H + b) * 10H + op) * 10000H + c; INC(pc)
-  END Put0;
-
-  PROCEDURE Put1(op, a, b, im: LONGINT);
-  BEGIN (*emit format-1 instruction,  -10000H <= im < 10000H*)
-    IF im < 0 THEN INC(op, V) END ;
-    code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc)
-  END Put1;
-
-  PROCEDURE Put1a(op, a, b, im: LONGINT);
-  BEGIN (*same as Put1, but with range test  -10000H <= im < 10000H*)
-    IF (im >= -10000H) & (im <= 0FFFFH) THEN Put1(op, a, b, im)
-    ELSE Put1(Mov+U, RH, 0, im DIV 10000H);
-      IF im MOD 10000H # 0 THEN Put1(Ior, RH, RH, im MOD 10000H) END ;
-      Put0(op, a, b, RH)
-    END
-  END Put1a;
-
-  PROCEDURE Put2(op, a, b, off: LONGINT);
-  BEGIN (*emit load/store instruction*)
-    code[pc] := ((op * 10H + a) * 10H + b) * 100000H + (off MOD 100000H); INC(pc)
-  END Put2;
-
-  PROCEDURE Put3(op, cond, off: LONGINT);
-  BEGIN (*emit branch instruction*)
-    code[pc] := ((op+12) * 10H + cond) * 1000000H + (off MOD 1000000H); INC(pc)
-  END Put3;
-
-  PROCEDURE incR;
-  BEGIN
-    IF RH < MT-1 THEN INC(RH) ELSE ORS.Mark("register stack overflow") END
-  END incR;
-
-  PROCEDURE CheckRegs*;
-  BEGIN
-    IF RH # 0 THEN ORS.Mark("Reg Stack"); RH := 0 END ;
-    IF pc >= maxCode - 40 THEN ORS.Mark("program too long") END ;
-    IF frame # 0 THEN ORS.Mark("frame error"); frame := 0 END
-  END CheckRegs;
-
-  PROCEDURE SetCC(VAR x: Item; n: LONGINT);
-  BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n
-  END SetCC;
-
-  PROCEDURE Trap(cond, num: LONGINT);
-  BEGIN Put3(BLR, cond, ORS.Pos()*100H + num*10H + MT)
-  END Trap;
-
-  (*handling of forward reference, fixups of branch addresses and constant tables*)
-
-  PROCEDURE negated(cond: LONGINT): LONGINT;
-  BEGIN
-    IF cond < 8 THEN cond := cond+8 ELSE cond := cond-8 END ;
-    RETURN cond
-  END negated;
-
-  PROCEDURE fix(at, with: LONGINT);
-  BEGIN code[at] := code[at] DIV C24 * C24 + (with MOD C24)
-  END fix;
-
-  PROCEDURE FixOne*(at: LONGINT);
-  BEGIN fix(at, pc-at-1)
-  END FixOne;
-
-  PROCEDURE FixLink*(L: LONGINT);
-    VAR L1: LONGINT;
-  BEGIN
-    WHILE L # 0 DO L1 := code[L] MOD 40000H; fix(L, pc-L-1); L := L1 END
-  END FixLink;
-
-  PROCEDURE FixLinkWith(L0, dst: LONGINT);
-    VAR L1: LONGINT;
-  BEGIN
-    WHILE L0 # 0 DO
-      L1 := code[L0] MOD C24;
-      code[L0] := code[L0] DIV C24 * C24 + ((dst - L0 - 1) MOD C24); L0 := L1
-    END
-  END FixLinkWith;
-
-  PROCEDURE merged(L0, L1: LONGINT): LONGINT;
-    VAR L2, L3: LONGINT;
-  BEGIN 
-    IF L0 # 0 THEN L3 := L0;
-      REPEAT L2 := L3; L3 := code[L2] MOD 40000H UNTIL L3 = 0;
-      code[L2] := code[L2] + L1; L1 := L0
-    END ;
-    RETURN L1
-  END merged;
-
-  (* loading of operands and addresses into registers *)
-
-  PROCEDURE GetSB(base: LONGINT);
-  BEGIN
-    IF version = 0 THEN Put1(Mov, RH, 0, VarOrg0)
-    ELSE Put2(Ldr, RH, -base, pc-fixorgD); fixorgD := pc-1
-    END
-  END GetSB;
-
-  PROCEDURE NilCheck;
-  BEGIN IF check THEN Trap(EQ, 4) END
-  END NilCheck;
-
-  PROCEDURE load(VAR x: Item);
-    VAR op: LONGINT;
-  BEGIN
-    IF x.type.size = 1 THEN op := Ldr+1 ELSE op := Ldr END ;
-    IF x.mode # Reg THEN
-      IF x.mode = ORB.Const THEN
-        IF x.type.form = ORB.Proc THEN
-          IF x.r > 0 THEN ORS.Mark("not allowed")
-          ELSIF x.r = 0 THEN Put3(BL, 7, 0); Put1a(Sub, RH, LNK, pc*4 - x.a)
-          ELSE GetSB(x.r); Put1(Add, RH, RH, x.a + 100H) (*mark as progbase-relative*)
-          END
-        ELSIF (x.a <= 0FFFFH) & (x.a >= -10000H) THEN Put1(Mov, RH, 0, x.a)
-        ELSE Put1(Mov+U, RH, 0, x.a DIV 10000H MOD 10000H);
-          IF x.a MOD 10000H # 0 THEN Put1(Ior, RH, RH, x.a MOD 10000H) END
-        END ;
-        x.r := RH; incR
-      ELSIF x.mode = ORB.Var THEN
-        IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a + frame)
-        ELSE GetSB(x.r); Put2(op, RH, RH, x.a)
-        END ;
-        x.r := RH; incR
-      ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, RH, RH, x.b); x.r := RH; incR
-      ELSIF x.mode = RegI THEN Put2(op, x.r, x.r, x.a)
-      ELSIF x.mode = Cond THEN
-        Put3(BC, negated(x.r), 2);
-        FixLink(x.b); Put1(Mov, RH, 0, 1); Put3(BC, 7, 1);
-        FixLink(x.a); Put1(Mov, RH, 0, 0); x.r := RH; incR
-      END ;
-      x.mode := Reg
-    END
-  END load;
-
-  PROCEDURE loadAdr(VAR x: Item);
-  BEGIN
-    IF x.mode = ORB.Var THEN
-      IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a + frame)
-      ELSE GetSB(x.r); Put1a(Add, RH, RH, x.a)
-      END ;
-      x.r := RH; incR
-    ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame);
-      IF x.b # 0 THEN Put1a(Add, RH, RH, x.b) END ;
-      x.r := RH; incR
-    ELSIF x.mode = RegI THEN
-      IF x.a # 0 THEN Put1a(Add, x.r, x.r, x.a) END
-    ELSE ORS.Mark("address error")
-    END ;
-    x.mode := Reg
-  END loadAdr;
-
-  PROCEDURE loadCond(VAR x: Item);
-  BEGIN
-    IF x.type.form = ORB.Bool THEN
-      IF x.mode = ORB.Const THEN x.r := 15 - x.a*8
-      ELSE load(x);
-        IF code[pc-1] DIV 40000000H # -2 THEN Put1(Cmp, x.r, x.r, 0) END ;
-        x.r := NE; DEC(RH)
-      END ;
-      x.mode := Cond; x.a := 0; x.b := 0
-    ELSE ORS.Mark("not Boolean?")
-    END
-  END loadCond;
-
-  PROCEDURE loadTypTagAdr(T: ORB.Type);
-    VAR x: Item;
-  BEGIN x.mode := ORB.Var; x.a := T.len; x.r := -T.mno; loadAdr(x)
-  END loadTypTagAdr;
-
-  PROCEDURE loadStringAdr(VAR x: Item);
-  BEGIN GetSB(0); Put1a(Add, RH, RH, varsize+x.a); x.mode := Reg; x.r := RH; incR
-  END loadStringAdr;
-
-  (* Items: Conversion from constants or from Objects on the Heap to Items on the Stack*)
-
-  PROCEDURE MakeConstItem*(VAR x: Item; typ: ORB.Type; val: LONGINT);
-  BEGIN x.mode := ORB.Const; x.type := typ; x.a := val
-  END MakeConstItem;
-
-  PROCEDURE MakeRealItem*(VAR x: Item; val: REAL);
-  BEGIN x.mode := ORB.Const; x.type := ORB.realType; x.a := SYSTEM.VAL(LONGINT, val)
-  END MakeRealItem;
-
-  PROCEDURE MakeStringItem*(VAR x: Item; len: LONGINT); (*copies string from ORS-buffer to ORG-string array*)
-    VAR i: LONGINT;
-  BEGIN x.mode := ORB.Const; x.type := ORB.strType; x.a := strx; x.b := len; i := 0;
-    IF strx + len + 4 < maxStrx THEN
-      WHILE len > 0 DO str[strx] := ORS.str[i]; INC(strx); INC(i); DEC(len) END ;
-      WHILE strx MOD 4 # 0 DO str[strx] := 0X; INC(strx) END
-    ELSE ORS.Mark("too many strings")
-    END
-  END MakeStringItem;
-
-  PROCEDURE MakeItem*(VAR x: Item; y: ORB.Object; curlev: LONGINT);
-  BEGIN x.mode := y.class; x.type := y.type; x.a := y.val; x.rdo := y.rdo;
-    IF y.class = ORB.Par THEN x.b := 0
-    ELSIF (y.class = ORB.Const) & (y.type.form = ORB.String) THEN x.b := y.lev  (*len*) ;
-    ELSE x.r := y.lev
-    END ;
-    IF (y.lev > 0) & (y.lev # curlev) & (y.class # ORB.Const) THEN ORS.Mark("not accessible ") END
-  END MakeItem;
-
-  (* Code generation for Selectors, Variables, Constants *)
-
-  PROCEDURE Field*(VAR x: Item; y: ORB.Object);   (* x := x.y *)
-  BEGIN;
-    IF x.mode = ORB.Var THEN
-      IF x.r >= 0 THEN x.a := x.a + y.val
-      ELSE loadAdr(x); x.mode := RegI; x.a := y.val
-      END
-    ELSIF x.mode = RegI THEN x.a := x.a + y.val
-    ELSIF x.mode = ORB.Par THEN x.b := x.b + y.val
-    END
-  END Field;
-
-  PROCEDURE Index*(VAR x, y: Item);   (* x := x[y] *)
-    VAR s, lim: LONGINT;
-  BEGIN s := x.type.base.size; lim := x.type.len;
-    IF (y.mode = ORB.Const) & (lim >= 0) THEN
-      IF (y.a < 0) OR (y.a >= lim) THEN ORS.Mark("bad index") END ;
-      IF x.mode IN {ORB.Var, RegI} THEN x.a := y.a * s + x.a
-      ELSIF x.mode = ORB.Par THEN x.b := y.a * s + x.b
-      END
-    ELSE load(y);
-      IF check THEN  (*check array bounds*)
-        IF lim >= 0 THEN Put1a(Cmp, RH, y.r, lim)
-        ELSE (*open array*)
-          IF x.mode IN {ORB.Var, ORB.Par} THEN Put2(Ldr, RH, SP, x.a+4+frame); Put0(Cmp, RH, y.r, RH)
-          ELSE ORS.Mark("error in Index")
-          END
-        END ;
-        Trap(10, 1)  (*BCC*)
-      END ;
-      IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1a(Mul, y.r, y.r, s) END ;
-      IF x.mode = ORB.Var THEN
-        IF x.r > 0 THEN Put0(Add, y.r, SP, y.r); INC(x.a, frame)
-        ELSE GetSB(x.r);
-          IF x.r = 0 THEN Put0(Add, y.r, RH, y.r)
-          ELSE Put1a(Add, RH, RH, x.a); Put0(Add, y.r, RH, y.r); x.a := 0
-          END
-        END ;
-        x.r := y.r; x.mode := RegI
-      ELSIF x.mode = ORB.Par THEN
-        Put2(Ldr, RH, SP, x.a + frame);
-        Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r; x.a := x.b
-      ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH)
-      END
-    END
-  END Index;
-
-  PROCEDURE DeRef*(VAR x: Item);
-  BEGIN
-    IF x.mode = ORB.Var THEN
-      IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a + frame) ELSE GetSB(x.r); Put2(Ldr, RH, RH, x.a) END ;
-      NilCheck; x.r := RH; incR
-    ELSIF x.mode = ORB.Par THEN
-      Put2(Ldr, RH, SP, x.a + frame); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR
-    ELSIF x.mode = RegI THEN Put2(Ldr, x.r, x.r, x.a); NilCheck
-    ELSIF x.mode # Reg THEN ORS.Mark("bad mode in DeRef")
-    END ;
-    x.mode := RegI; x.a := 0; x.b := 0
-  END DeRef;
-
-  PROCEDURE Q(T: ORB.Type; VAR dcw: LONGINT);
-  BEGIN (*one entry of type descriptor extension table*)
-    IF T.base # NIL THEN
-      Q(T.base, dcw); data[dcw] := (T.mno*1000H + T.len) * 1000H + dcw - fixorgT;
-      fixorgT := dcw; INC(dcw)
-    END
-  END Q;
-
-  PROCEDURE FindPtrFlds(typ: ORB.Type; off: LONGINT; VAR dcw: LONGINT);
-    VAR fld: ORB.Object; i, s: LONGINT;
-  BEGIN
-    IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN data[dcw] := off; INC(dcw)
-    ELSIF typ.form = ORB.Record THEN
-      fld := typ.dsc;
-      WHILE fld # NIL DO FindPtrFlds(fld.type, fld.val + off, dcw); fld := fld.next END
-    ELSIF typ.form = ORB.Array THEN
-      s := typ.base.size;
-      FOR i := 0 TO typ.len-1 DO FindPtrFlds(typ.base, i*s + off, dcw) END
-    END
-  END FindPtrFlds;
-
-  PROCEDURE BuildTD*(T: ORB.Type; VAR dc: LONGINT);
-    VAR dcw, k, s: LONGINT;  (*dcw = word address*)
-  BEGIN dcw := dc DIV 4; s := T.size; (*convert size for heap allocation*)
-    IF s <= 24 THEN s := 32 ELSIF s <= 56 THEN s := 64 ELSIF s <= 120 THEN s := 128
-    ELSE s := (s+263) DIV 256 * 256
-    END ;
-    T.len := dc; data[dcw] := s; INC(dcw);  (*len used as address*)
-    k := T.nofpar;   (*extension level!*)
-    IF k > 3 THEN ORS.Mark("ext level too large")
-    ELSE Q(T, dcw);
-      WHILE k < 3 DO data[dcw] := -1; INC(dcw); INC(k) END
-    END ;
-    FindPtrFlds(T, 0, dcw); data[dcw] := -1; INC(dcw); tdx := dcw; dc := dcw*4;
-    IF tdx >= maxTD THEN ORS.Mark("too many record types"); tdx := 0 END
-  END BuildTD;
-
-  PROCEDURE TypeTest*(VAR x: Item; T: ORB.Type; varpar, isguard: BOOLEAN);
-    VAR pc0: LONGINT;
-  BEGIN (*fetch tag into RH*)
-    IF varpar THEN Put2(Ldr, RH, SP, x.a+4+frame)
-    ELSE load(x);
-      pc0 := pc; Put3(BC, EQ, 0);  (*NIL belongs to every pointer type*)
-      Put2(Ldr, RH, x.r, -8)
-    END ;
-    Put2(Ldr, RH, RH, T.nofpar*4); incR;
-    loadTypTagAdr(T);  (*tag of T*)
-    Put0(Cmp, RH-1, RH-1, RH-2); DEC(RH, 2);
-    IF ~varpar THEN fix(pc0, pc - pc0 - 1) END ;
-    IF isguard THEN
-      IF check THEN Trap(NE, 2) END
-    ELSE SetCC(x, EQ);
-      IF ~varpar THEN DEC(RH) END
-    END
-  END TypeTest;
-
-  (* Code generation for Boolean operators *)
-
-  PROCEDURE Not*(VAR x: Item);   (* x := ~x *)
-    VAR t: LONGINT;
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t
-  END Not;
-
-  PROCEDURE And1*(VAR x: Item);   (* x := x & *)
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    Put3(BC, negated(x.r), x.a); x.a := pc-1; FixLink(x.b); x.b := 0
-  END And1;
-
-  PROCEDURE And2*(VAR x, y: Item);
-  BEGIN
-    IF y.mode # Cond THEN loadCond(y) END ;
-    x.a := merged(y.a, x.a); x.b := y.b; x.r := y.r
-  END And2;
-
-  PROCEDURE Or1*(VAR x: Item);   (* x := x OR *)
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    Put3(BC, x.r, x.b);  x.b := pc-1; FixLink(x.a); x.a := 0
-  END Or1;
-
-  PROCEDURE Or2*(VAR x, y: Item);
-  BEGIN
-    IF y.mode # Cond THEN loadCond(y) END ;
-    x.a := y.a; x.b := merged(y.b, x.b); x.r := y.r
-  END Or2;
-
-  (* Code generation for arithmetic operators *)
-
-  PROCEDURE Neg*(VAR x: Item);   (* x := -x *)
-  BEGIN
-    IF x.type.form = ORB.Int THEN
-      IF x.mode = ORB.Const THEN x.a := -x.a
-      ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r)
-      END
-    ELSIF x.type.form = ORB.Real THEN
-      IF x.mode = ORB.Const THEN x.a := x.a + 7FFFFFFFH + 1
-      ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Fsb, x.r, RH, x.r)
-      END
-    ELSE (*form = Set*)
-      IF x.mode = ORB.Const THEN x.a := -x.a-1 
-      ELSE load(x); Put1(Xor, x.r, x.r, -1)
-      END
-    END
-  END Neg;
-
-  PROCEDURE AddOp*(op: LONGINT; VAR x, y: Item);   (* x := x +- y *)
-  BEGIN
-    IF op = ORS.plus THEN
-      IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a + y.a
-      ELSIF y.mode = ORB.Const THEN load(x);
-        IF y.a # 0 THEN Put1a(Add, x.r, x.r, y.a) END
-      ELSE load(x); load(y); Put0(Add, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
-      END
-    ELSE (*op = ORS.minus*)
-      IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a - y.a
-      ELSIF y.mode = ORB.Const THEN load(x);
-        IF y.a # 0 THEN Put1a(Sub, x.r, x.r, y.a) END
-      ELSE load(x); load(y); Put0(Sub, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
-      END
-    END
-  END AddOp;
-
-  PROCEDURE log2(m: LONGINT; VAR e: LONGINT): LONGINT;
-  BEGIN e := 0;
-    WHILE ~ODD(m) DO m := m DIV 2; INC(e) END ;
-    RETURN m
-  END log2;
-  
-  PROCEDURE MulOp*(VAR x, y: Item);   (* x := x * y *)
-    VAR e: LONGINT;
-  BEGIN
-    IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a * y.a
-    ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Lsl, x.r, x.r, e)
-    ELSIF y.mode = ORB.Const THEN load(x); Put1a(Mul, x.r, x.r, y.a)
-    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
-    ELSIF x.mode = ORB.Const THEN load(y); Put1a(Mul, y.r, y.r, x.a); x.mode := Reg; x.r := y.r
-    ELSE load(x); load(y); Put0(Mul, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
-    END
-  END MulOp;
-
-  PROCEDURE DivOp*(op: LONGINT; VAR x, y: Item);   (* x := x op y *)
-    VAR e: LONGINT;
-  BEGIN
-    IF op = ORS.div THEN
-      IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN
-        IF y.a > 0 THEN x.a := x.a DIV y.a ELSE ORS.Mark("bad divisor") END
-      ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Asr, x.r, x.r, e)
-      ELSIF y.mode = ORB.Const THEN
-        IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a) ELSE ORS.Mark("bad divisor") END
-      ELSE load(y);
-        IF check THEN Trap(LE, 6) END ;
-        load(x); Put0(Div, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
-      END
-    ELSE (*op = ORS.mod*)
-      IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN
-        IF y.a > 0 THEN x.a := x.a MOD y.a ELSE ORS.Mark("bad modulus") END
-      ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x);
-        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
-      ELSIF y.mode = ORB.Const THEN
-        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
-      ELSE load(y);
-        IF check THEN Trap(LE, 6) END ;
-        load(x); Put0(Div, RH-2, x.r, y.r); Put0(Mov+U, RH-2, 0, 0); DEC(RH); x.r := RH-1
-      END
-    END
-  END DivOp;
-
-  (* Code generation for REAL operators *)
-
-  PROCEDURE RealOp*(op: INTEGER; VAR x, y: Item);   (* x := x op y *)
-  BEGIN load(x); load(y);
-    IF op = ORS.plus THEN Put0(Fad, RH-2, x.r, y.r)
-    ELSIF op = ORS.minus THEN Put0(Fsb, RH-2, x.r, y.r)
-    ELSIF op = ORS.times THEN Put0(Fml, RH-2, x.r, y.r)
-    ELSIF op = ORS.rdiv THEN Put0(Fdv, RH-2, x.r, y.r)
-    END ;
-    DEC(RH); x.r := RH-1
-  END RealOp;
-
-  (* Code generation for set operators *)
-
-  PROCEDURE Singleton*(VAR x: Item);  (* x := {x} *)
-  BEGIN
-    IF x.mode = ORB.Const THEN x.a := LSL(1, x.a) 
-    ELSE load(x); Put1(Mov, RH, 0, 1); Put0(Lsl, x.r, RH,  x.r)
-    END
-  END Singleton;
-
-  PROCEDURE Set*(VAR x, y: Item);   (* x := {x .. y} *)
-  BEGIN
-    IF (x.mode = ORB.Const) & ( y.mode = ORB.Const) THEN
-      IF x.a <= y.a THEN x.a := LSL(2, y.a) - LSL(1, x.a) ELSE x.a := 0 END
-    ELSE
-      IF (x.mode = ORB.Const) & (x.a <= 16) THEN x.a := LSL(-1, x.a)
-      ELSE load(x); Put1(Mov, RH, 0, -1); Put0(Lsl, x.r, RH, x.r)
-      END ;
-      IF (y.mode = ORB.Const) & (y.a < 16) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; incR
-      ELSE load(y); Put1(Mov, RH, 0, -2); Put0(Lsl, y.r, RH, y.r)
-      END ;
-      IF x.mode = ORB.Const THEN
-        IF x.a # 0 THEN Put1(Xor, y.r, y.r, -1); Put1a(And, RH-1, y.r, x.a) END ;
-        x.mode := Reg; x.r := RH-1
-      ELSE DEC(RH); Put0(Ann, RH-1, x.r, y.r)
-      END
-    END
-  END Set;
-
-  PROCEDURE In*(VAR x, y: Item);  (* x := x IN y *)
-  BEGIN load(y);
-    IF x.mode = ORB.Const THEN Put1(Ror, y.r, y.r, (x.a + 1) MOD 20H); DEC(RH)
-    ELSE load(x); Put1(Add, x.r, x.r, 1); Put0(Ror, y.r, y.r, x.r); DEC(RH, 2)
-    END ;
-    SetCC(x, MI)
-  END In;
-
-  PROCEDURE SetOp*(op: LONGINT; VAR x, y: Item);   (* x := x op y *)
-    VAR xset, yset: SET; (*x.type.form = Set*)
-  BEGIN
-    IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN
-      xset := SYSTEM.VAL(SET, x.a); yset := SYSTEM.VAL(SET, y.a);
-      IF op = ORS.plus THEN xset := xset + yset
-      ELSIF op = ORS.minus THEN xset := xset - yset
-      ELSIF op = ORS.times THEN xset := xset * yset
-      ELSIF op = ORS.rdiv THEN xset := xset / yset
-      END ;
-      x.a := SYSTEM.VAL(LONGINT, xset)
-    ELSIF y.mode = ORB.Const THEN
-      load(x);
-      IF op = ORS.plus THEN Put1a(Ior, x.r, x.r, y.a)
-      ELSIF op = ORS.minus THEN Put1a(Ann, x.r, x.r, y.a)
-      ELSIF op = ORS.times THEN Put1a(And, x.r, x.r, y.a)
-      ELSIF op = ORS.rdiv THEN Put1a(Xor, x.r, x.r, y.a)
-      END ;
-    ELSE load(x); load(y);
-      IF op = ORS.plus THEN Put0(Ior, RH-2, x.r, y.r)
-      ELSIF op = ORS.minus THEN Put0(Ann, RH-2, x.r, y.r)
-      ELSIF op = ORS.times THEN Put0(And, RH-2, x.r, y.r)
-      ELSIF op = ORS.rdiv THEN Put0(Xor, RH-2, x.r, y.r)
-      END ;
-      DEC(RH); x.r := RH-1
-    END 
-  END SetOp;
-
-  (* Code generation for relations *)
-
-  PROCEDURE IntRelation*(op: INTEGER; VAR x, y: Item);   (* x := x < y *)
-  BEGIN
-    IF (y.mode = ORB.Const) & (y.type.form # ORB.Proc) THEN
-      load(x);
-      IF (y.a # 0) OR ~(op IN {ORS.eql, ORS.neq}) OR (code[pc-1] DIV 40000000H # -2) THEN Put1a(Cmp, x.r, x.r, y.a) END ;
-      DEC(RH)
-    ELSE
-      IF (x.mode = Cond) OR (y.mode = Cond) THEN ORS.Mark("not implemented") END ;
-      load(x); load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2)
-    END ;
-    SetCC(x, relmap[op - ORS.eql])
-  END IntRelation;
-
-  PROCEDURE RealRelation*(op: INTEGER; VAR x, y: Item);   (* x := x < y *)
-  BEGIN load(x);
-    IF (y.mode = ORB.Const) & (y.a = 0) THEN DEC(RH)
-    ELSE load(y); Put0(Fsb, x.r, x.r, y.r); DEC(RH, 2)
-    END ;
-    SetCC(x, relmap[op - ORS.eql])
-  END RealRelation;
-
-  PROCEDURE StringRelation*(op: INTEGER; VAR x, y: Item);   (* x := x < y *)
-    (*x, y are char arrays or strings*)
-  BEGIN
-    IF x.type.form = ORB.String THEN loadStringAdr(x) ELSE loadAdr(x) END ;
-    IF y.type.form = ORB.String THEN loadStringAdr(y) ELSE loadAdr(y) END ;
-    Put2(Ldr+1, RH, x.r, 0); Put1(Add, x.r, x.r, 1);
-    Put2(Ldr+1, RH+1, y.r, 0); Put1(Add, y.r, y.r, 1);
-    Put0(Cmp, RH+2, RH, RH+1); Put3(BC, NE, 2);
-    Put1(Cmp, RH+2, RH, 0); Put3(BC, NE, -8);
-    DEC(RH, 2); SetCC(x, relmap[op - ORS.eql])
-  END StringRelation;
-
-  (* Code generation of Assignments *)
-
-  PROCEDURE StrToChar*(VAR x: Item);
-  BEGIN x.type := ORB.charType; DEC(strx, 4); x.a := ORD(str[x.a])
-  END StrToChar;
-
-  PROCEDURE Store*(VAR x, y: Item); (* x := y *)
-    VAR op: LONGINT;
-  BEGIN  load(y);
-    IF x.type.size = 1 THEN op := Str+1 ELSE op := Str END ;
-    IF x.mode = ORB.Var THEN
-      IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a + frame)
-      ELSE GetSB(x.r); Put2(op, y.r, RH, x.a)
-      END
-    ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, y.r, RH, x.b);
-    ELSIF x.mode = RegI THEN Put2(op, y.r, x.r, x.a); DEC(RH);
-    ELSE ORS.Mark("bad mode in Store")
-    END ;
-    DEC(RH)
-  END Store;
-
-  PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y, frame = 0 *)
-    VAR s, pc0: LONGINT;
-  BEGIN
-    IF y.type.size # 0 THEN
-      loadAdr(x); loadAdr(y);
-      IF (x.type.form = ORB.Array) &  (x.type.len > 0) THEN
-        IF y.type.len >= 0 THEN 
-          IF x.type.size = y.type.size THEN Put1a(Mov, RH, 0, (y.type.size+3) DIV 4)
-          ELSE ORS.Mark("different length/size, not implemented")
-          END
-        ELSE (*y  open array*) Put2(Ldr, RH, SP, y.a+4); s := y.type.base.size;  (*element size*)
-          pc0 := pc; Put3(BC, EQ, 0);
-          IF s = 1 THEN Put1(Add, RH, RH, 3); Put1(Asr, RH, RH, 2)
-          ELSIF s # 4 THEN Put1a(Mul, RH, RH, s DIV 4)
-          END ;
-          IF check THEN
-            Put1a(Mov, RH+1, 0, (x.type.size+3) DIV 4); Put0(Cmp, RH+1, RH, RH+1); Trap(GT, 3)
-          END ;
-          fix(pc0, pc + 5 - pc0)
-        END
-      ELSIF x.type.form = ORB.Record THEN Put1a(Mov, RH, 0, x.type.size DIV 4)
-      ELSE ORS.Mark("inadmissible assignment")
-      END ;
-      Put2(Ldr, RH+1, y.r, 0); Put1(Add, y.r, y.r, 4);
-      Put2(Str, RH+1, x.r, 0); Put1(Add, x.r, x.r, 4);
-      Put1(Sub, RH, RH, 1); Put3(BC, NE, -6)
-    END ;
-    RH := 0
-  END StoreStruct;
-
-  PROCEDURE CopyString*(VAR x, y: Item);  (* x := y *) 
-     VAR len: LONGINT;
-   BEGIN loadAdr(x); len := x.type.len;
-    IF len >= 0 THEN
-      IF len <  y.b THEN ORS.Mark("string too long") END
-    ELSIF check THEN Put2(Ldr, RH, SP, x.a+4);  (*open array len, frame = 0*)
-      Put1(Cmp,RH, RH, y.b); Trap(LT, 3)
-    END ;
-    loadStringAdr(y);
-    Put2(Ldr, RH, y.r, 0); Put1(Add, y.r, y.r, 4);
-    Put2(Str, RH, x.r, 0); Put1(Add, x.r, x.r, 4);
-    Put1(Asr, RH, RH, 24); Put3(BC, NE,  -6);  RH := 0
-   END CopyString;
-  
-  (* Code generation for parameters *)
-  
-  PROCEDURE OpenArrayParam*(VAR x: Item);
-  BEGIN loadAdr(x);
-    IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ;
-    incR
-  END OpenArrayParam;
-
-  PROCEDURE VarParam*(VAR x: Item; ftype: ORB.Type);
-    VAR xmd: INTEGER;
-  BEGIN xmd := x.mode; loadAdr(x);
-    IF (ftype.form = ORB.Array) & (ftype.len < 0) THEN (*open array*)
-      IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE  Put2(Ldr, RH, SP, x.a+4+frame) END ;
-      incR
-    ELSIF ftype.form = ORB.Record THEN
-      IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4+frame); incR ELSE loadTypTagAdr(x.type) END
-    END
-  END VarParam;
-
-  PROCEDURE ValueParam*(VAR x: Item);
-  BEGIN load(x)
-  END ValueParam;
-
-  PROCEDURE StringParam*(VAR x: Item);
-  BEGIN loadStringAdr(x); Put1(Mov, RH, 0, x.b); incR  (*len*)
-  END StringParam;
-
-  (*For Statements*)
-
-  PROCEDURE For0*(VAR x, y: Item);
-  BEGIN load(y)
-  END For0;
-
-  PROCEDURE For1*(VAR x, y, z, w: Item; VAR L: LONGINT);
-  BEGIN 
-    IF z.mode = ORB.Const THEN Put1a(Cmp, RH, y.r, z.a)
-    ELSE load(z); Put0(Cmp, RH-1, y.r, z.r); DEC(RH)
-    END ;
-    L := pc;
-    IF w.a > 0 THEN Put3(BC, GT, 0)
-    ELSIF w.a < 0 THEN Put3(BC, LT, 0)
-    ELSE ORS.Mark("zero increment"); Put3(BC, MI, 0)
-    END ;
-    Store(x, y)
-  END For1;
-
-  PROCEDURE For2*(VAR x, y, w: Item);
-  BEGIN load(x); DEC(RH); Put1a(Add, x.r, x.r, w.a)
-  END For2;
-
-  (* Branches, procedure calls, procedure prolog and epilog *)
-
-  PROCEDURE Here*(): LONGINT;
-  BEGIN RETURN pc
-  END Here;
-
-  PROCEDURE FJump*(VAR L: LONGINT);
-  BEGIN Put3(BC, 7, L); L := pc-1
-  END FJump;
-
-  PROCEDURE CFJump*(VAR x: Item);
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    Put3(BC, negated(x.r), x.a); FixLink(x.b); x.a := pc-1
-  END CFJump;
-
-  PROCEDURE BJump*(L: LONGINT);
-  BEGIN Put3(BC, 7, L-pc-1)
-  END BJump;
-
-  PROCEDURE CBJump*(VAR x: Item; L: LONGINT);
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    Put3(BC, negated(x.r), L-pc-1); FixLink(x.b); FixLinkWith(x.a, L)
-  END CBJump;
-
-  PROCEDURE Fixup*(VAR x: Item);
-  BEGIN FixLink(x.a)
-  END Fixup;
-
-  PROCEDURE SaveRegs(r: LONGINT);  (* R[0 .. r-1]*)
-    VAR r0: LONGINT;
-  BEGIN (*r > 0*) r0 := 0;
-    Put1(Sub, SP, SP, r*4); INC(frame, 4*r);
-    REPEAT Put2(Str, r0, SP, (r-r0-1)*4); INC(r0) UNTIL r0 = r
-  END SaveRegs;
-
-  PROCEDURE RestoreRegs(r: LONGINT); (*R[0 .. r-1]*)
-    VAR r0: LONGINT;
-  BEGIN (*r > 0*) r0 := r;
-    REPEAT DEC(r0); Put2(Ldr, r0, SP, (r-r0-1)*4) UNTIL r0 = 0;
-    Put1(Add, SP, SP, r*4); DEC(frame, 4*r)
-  END RestoreRegs;
-
-  PROCEDURE PrepCall*(VAR x: Item; VAR r: LONGINT);
-  BEGIN (*x.type.form = ORB.Proc*)
-    IF x.mode > ORB.Par THEN load(x) END ;
-    r := RH;
-    IF RH > 0 THEN SaveRegs(RH); RH := 0 END
-  END PrepCall;
-
-  PROCEDURE Call*(VAR x: Item; r: LONGINT);
-  BEGIN (*x.type.form = ORB.Proc*)
-    IF x.mode = ORB.Const THEN
-      IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1)
-      ELSE (*imported*)
-        IF pc - fixorgP < 1000H THEN
-          Put3(BL, 7, ((-x.r) * 100H + x.a) * 1000H + pc-fixorgP); fixorgP := pc-1
-        ELSE ORS.Mark("fixup impossible")
-        END
-      END
-    ELSE
-      IF x.mode <= ORB.Par THEN load(x); DEC(RH)
-      ELSE Put2(Ldr, RH, SP, 0); Put1(Add, SP, SP, 4); DEC(r); DEC(frame, 4)
-      END ;
-      IF check THEN Trap(EQ, 5) END ;
-      Put3(BLR, 7, RH)
-    END ;
-    IF x.type.base.form = ORB.NoTyp THEN (*procedure*) RH := 0
-    ELSE (*function*)
-      IF r > 0 THEN Put0(Mov, r, 0, 0); RestoreRegs(r) END ;
-      x.mode := Reg; x.r := r; RH := r+1
-    END
-  END Call;
-
-  PROCEDURE Enter*(parblksize, locblksize: LONGINT; int: BOOLEAN);
-    VAR a, r: LONGINT;
-  BEGIN frame := 0;
-    IF ~int THEN (*procedure prolog*)
-      IF locblksize >= 10000H THEN ORS.Mark("too many locals") END ;
-      a := 4; r := 0;
-      Put1(Sub, SP, SP, locblksize); Put2(Str, LNK, SP, 0);
-      WHILE a < parblksize DO Put2(Str, r, SP, a); INC(r); INC(a, 4) END
-    ELSE (*interrupt procedure*)
-      Put1(Sub, SP, SP, locblksize); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4); Put2(Str, 2, SP, 8)
-      (*R0, R1, R2 saved on stack*)
-    END
-  END Enter;
-
-  PROCEDURE Return*(form: INTEGER; VAR x: Item; size: LONGINT; int: BOOLEAN);
-  BEGIN
-    IF form # ORB.NoTyp THEN load(x) END ;
-    IF ~int THEN (*procedure epilog*)
-      Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK)
-    ELSE (*interrupt return, restore R2, R1, R0*)
-      Put2(Ldr, 2, SP, 8); Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, size);
-      Put3(BR, 7, 10H) (*RTI*)
-    END ;
-    RH := 0
-  END Return;
-
-  (* In-line code procedures*)
-
-  PROCEDURE Increment*(upordown: LONGINT; VAR x, y: Item);
-    VAR op, zr, v: LONGINT;
-  BEGIN (*frame = 0*)
-    IF upordown = 0 THEN op := Add ELSE op := Sub END ;
-    IF x.type = ORB.byteType THEN v := 1 ELSE v := 0 END ;
-    IF y.type.form = ORB.NoTyp THEN y.mode := ORB.Const; y.a := 1 END ;
-    IF (x.mode = ORB.Var) & (x.r > 0) THEN
-      zr := RH; Put2(Ldr+v, zr, SP, x.a); incR;
-      IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
-      Put2(Str+v, zr, SP, x.a); DEC(RH)
-    ELSE loadAdr(x); zr := RH; Put2(Ldr+v, RH, x.r, 0); incR;
-      IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
-      Put2(Str+v, zr, x.r, 0); DEC(RH, 2)
-    END
-  END Increment;
-
-  PROCEDURE Include*(inorex: LONGINT; VAR x, y: Item);
-    VAR op, zr: LONGINT;
-  BEGIN loadAdr(x); zr := RH; Put2(Ldr, RH, x.r, 0); incR;
-    IF inorex = 0 THEN op := Ior ELSE op := Ann END ;
-    IF y.mode = ORB.Const THEN Put1a(op, zr, zr, LSL(1, y.a))
-    ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(op, zr, zr, y.r); DEC(RH)
-    END ;
-    Put2(Str, zr, x.r, 0); DEC(RH, 2)
-  END Include;
-
-  PROCEDURE Assert*(VAR x: Item);
-    VAR cond: LONGINT;
-  BEGIN
-    IF x.mode # Cond THEN loadCond(x) END ;
-    IF x.a = 0 THEN cond := negated(x.r)
-    ELSE Put3(BC, x.r, x.b); FixLink(x.a); x.b := pc-1; cond := 7
-    END ;
-    Trap(cond, 7); FixLink(x.b)
-  END Assert; 
-
-  PROCEDURE New*(VAR x: Item);
-  BEGIN loadAdr(x); loadTypTagAdr(x.type.base); Trap(7, 0); RH := 0
-  END New;
-
-  PROCEDURE Pack*(VAR x, y: Item);
-    VAR z: Item;
-  BEGIN z := x; load(x); load(y);
-    Put1(Lsl, y.r, y.r, 23); Put0(Add, x.r, x.r, y.r); DEC(RH); Store(z, x)
-  END Pack;
-
-  PROCEDURE Unpk*(VAR x, y: Item);
-    VAR z, e0: Item;
-  BEGIN  z := x; load(x); e0.mode := Reg; e0.r := RH; e0.type := ORB.intType;
-    Put1(Asr, RH, x.r, 23); Put1(Sub, RH, RH, 127); Store(y, e0); incR;
-    Put1(Lsl, RH, RH, 23); Put0(Sub, x.r, x.r, RH); Store(z, x)
-  END Unpk;
-
-  PROCEDURE Led*(VAR x: Item);
-  BEGIN load(x); Put1(Mov, RH, 0, -60); Put2(Str, x.r, RH, 0); DEC(RH)
-  END Led;
-
-  PROCEDURE Get*(VAR x, y: Item);
-  BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(y, x)
-  END Get;
-
-  PROCEDURE Put*(VAR x, y: Item);
-  BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(x, y)
-  END Put;
-
-  PROCEDURE Copy*(VAR x, y, z: Item);
-  BEGIN load(x); load(y);
-    IF z.mode = ORB.Const THEN
-      IF z.a > 0 THEN load(z) ELSE ORS.Mark("bad count") END
-    ELSE load(z);
-      IF check THEN Trap(LT, 3) END ;
-      Put3(BC, EQ, 6)
-    END ;
-    Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4);
-    Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4);
-    Put1(Sub, z.r, z.r, 1); Put3(BC, NE, -6); DEC(RH, 3)
-  END Copy;
-
-  PROCEDURE LDPSR*(VAR x: Item);
-  BEGIN (*x.mode = Const*)  Put3(0, 15, x.a + 20H)
-  END LDPSR;
-
-  PROCEDURE LDREG*(VAR x, y: Item);
-  BEGIN
-    IF y.mode = ORB.Const THEN Put1a(Mov, x.a, 0, y.a)
-    ELSE load(y); Put0(Mov, x.a, 0, y.r); DEC(RH)
-    END
-  END LDREG;
-
-  (*In-line code functions*)
-
-  PROCEDURE Abs*(VAR x: Item);
-  BEGIN
-    IF x.mode = ORB.Const THEN x.a := ABS(x.a)
-    ELSE load(x);
-      IF x.type.form = ORB.Real THEN Put1(Lsl, x.r, x.r, 1); Put1(Ror, x.r, x.r, 1)
-      ELSE Put1(Cmp, x.r, x.r, 0); Put3(BC, GE, 2); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r)
-      END
-    END
-  END Abs;
-
-  PROCEDURE Odd*(VAR x: Item);
-  BEGIN load(x); Put1(And, x.r, x.r, 1); SetCC(x, NE); DEC(RH)
-  END Odd;
-
-  PROCEDURE Floor*(VAR x: Item);
-  BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+V, x.r, x.r, RH)
-  END Floor;
-
-  PROCEDURE Float*(VAR x: Item);
-  BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H);  Put0(Fad+U, x.r, x.r, RH)
-  END Float;
-
-  PROCEDURE Ord*(VAR x: Item);
-  BEGIN
-    IF x.mode IN {ORB.Var, ORB.Par, RegI, Cond} THEN load(x) END
-  END Ord;
-
-  PROCEDURE Len*(VAR x: Item);
-  BEGIN
-    IF x.type.len >= 0 THEN
-      IF x.mode = RegI THEN DEC(RH) END ;
-      x.mode := ORB.Const; x.a := x.type.len
-    ELSE (*open array*) Put2(Ldr, RH, SP, x.a + 4 + frame); x.mode := Reg; x.r := RH; incR
-    END 
-  END Len;
-
-  PROCEDURE Shift*(fct: LONGINT; VAR x, y: Item);
-    VAR op: LONGINT;
-  BEGIN load(x);
-    IF fct = 0 THEN op := Lsl ELSIF fct = 1 THEN op := Asr ELSE op := Ror END ;
-    IF y.mode = ORB.Const THEN Put1(op, x.r, x.r, y.a MOD 20H)
-    ELSE load(y); Put0(op, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
-    END
-  END Shift;
-
-  PROCEDURE ADC*(VAR x, y: Item);
-  BEGIN load(x); load(y); Put0(Add+2000H, x.r, x.r, y.r); DEC(RH)
-  END ADC;
-
-  PROCEDURE SBC*(VAR x, y: Item);
-  BEGIN load(x); load(y); Put0(Sub+2000H, x.r, x.r, y.r); DEC(RH)
-  END SBC;
-
-  PROCEDURE UML*(VAR x, y: Item);
-  BEGIN load(x); load(y); Put0(Mul+2000H, x.r, x.r, y.r); DEC(RH)
-  END UML;
-
-  PROCEDURE Bit*(VAR x, y: Item);
-  BEGIN load(x); Put2(Ldr, x.r, x.r, 0);
-    IF y.mode = ORB.Const THEN Put1(Ror, x.r, x.r, y.a+1); DEC(RH)
-    ELSE load(y); Put1(Add, y.r, y.r, 1); Put0(Ror, x.r, x.r, y.r); DEC(RH, 2)
-    END ;
-    SetCC(x, MI)
-  END Bit;
-
-  PROCEDURE Register*(VAR x: Item);
-  BEGIN (*x.mode = Const*)
-    Put0(Mov, RH, 0, x.a MOD 10H); x.mode := Reg; x.r := RH; incR
-  END Register;
-
-  PROCEDURE H*(VAR x: Item);
-  BEGIN (*x.mode = Const*)
-    Put0(Mov + U + x.a MOD 2 * V, RH, 0, 0); x.mode := Reg; x.r := RH; incR
-  END H;
-
-  PROCEDURE Adr*(VAR x: Item);
-  BEGIN 
-    IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN loadAdr(x)
-    ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.Proc) THEN load(x)
-    ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.String) THEN loadStringAdr(x)
-    ELSE ORS.Mark("not addressable")
-    END
-  END Adr;
-
-  PROCEDURE Condition*(VAR x: Item);
-  BEGIN (*x.mode = Const*) SetCC(x, x.a)
-  END Condition;
-
-  PROCEDURE Open*(v: INTEGER);
-  BEGIN pc := 0; tdx := 0; strx := 0; RH := 0; fixorgP := 0; fixorgD := 0; fixorgT := 0; check := v # 0; version := v;
-    IF v = 0 THEN pc := 1;
-      REPEAT code[pc] := 0; INC(pc) UNTIL pc = 8
-    END
-  END Open;
-
-  PROCEDURE SetDataSize*(dc: LONGINT);
-  BEGIN varsize := dc
-  END SetDataSize;
-
-  PROCEDURE Header*;
-  BEGIN entry := pc*4;
-    IF version = 0 THEN code[0] := 0E7000000H-1 + pc;  Put1a(Mov, SP, 0, StkOrg0)  (*RISC-0*)
-    ELSE Put1(Sub, SP, SP, 4); Put2(Str, LNK, SP, 0)
-    END
-  END Header;
-
-  PROCEDURE NofPtrs(typ: ORB.Type): LONGINT;
-    VAR fld: ORB.Object; n: LONGINT;
-  BEGIN
-    IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN n := 1
-    ELSIF typ.form = ORB.Record THEN
-      fld := typ.dsc; n := 0;
-      WHILE fld # NIL DO n := NofPtrs(fld.type) + n; fld := fld.next END
-    ELSIF typ.form = ORB.Array THEN n := NofPtrs(typ.base) * typ.len
-    ELSE n := 0
-    END ;
-    RETURN n
-  END NofPtrs;
-
-  PROCEDURE FindPtrs(VAR R: Files.Rider; typ: ORB.Type; adr: LONGINT);
-    VAR fld: ORB.Object; i, s: LONGINT;
-  BEGIN
-    IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN Files.WriteInt(R, adr)
-    ELSIF typ.form = ORB.Record THEN
-      fld := typ.dsc;
-      WHILE fld # NIL DO FindPtrs(R, fld.type, fld.val + adr); fld := fld.next END
-    ELSIF typ.form = ORB.Array THEN
-      s := typ.base.size;
-      FOR i := 0 TO typ.len-1 DO FindPtrs(R, typ.base, i*s + adr) END
-    END
-  END FindPtrs;
-
-  PROCEDURE Close*(VAR modid: ORS.Ident; key, nofent: LONGINT);
-    VAR obj: ORB.Object;
-      i, comsize, nofimps, nofptrs, size: LONGINT;
-      name: ORS.Ident;
-      F: Files.File; R: Files.Rider;
-  BEGIN  (*exit code*)
-    IF version = 0 THEN Put1(Mov, 0, 0, 0); Put3(BR, 7, 0)  (*RISC-0*)
-    ELSE Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, 4); Put3(BR, 7, LNK)
-    END ;
-    obj := ORB.topScope.next; nofimps := 0; comsize := 4; nofptrs := 0;
-    WHILE obj # NIL DO
-      IF (obj.class = ORB.Mod) & (obj.dsc # ORB.system) THEN INC(nofimps) (*count imports*)
-      ELSIF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc)
-          & (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN i := 0; (*count commands*)
-        WHILE obj.name[i] # 0X DO INC(i) END ;
-        i := (i+4) DIV 4 * 4; INC(comsize, i+4)
-      ELSIF obj.class = ORB.Var THEN INC(nofptrs, NofPtrs(obj.type))  (*count pointers*)
-      END ;
-      obj := obj.next
-    END ;
-    size := varsize + strx + comsize + (pc + nofimps + nofent + nofptrs + 1)*4;  (*varsize includes type descriptors*)
-    
-    ORB.MakeFileName(name, modid, ".rsc"); (*write code file*)
-    F := Files.New(name); Files.Set(R, F, 0); Files.WriteString(R, modid); Files.WriteInt(R, key); Files.Write(R, CHR(version));
-    Files.WriteInt(R, size);
-    obj := ORB.topScope.next;
-    WHILE (obj # NIL) & (obj.class = ORB.Mod) DO  (*imports*)
-      IF obj.dsc # ORB.system THEN Files.WriteString(R, obj(ORB.Module).orgname); Files.WriteInt(R, obj.val) END ;
-      obj := obj.next
-    END ;
-    Files.Write(R, 0X);
-    Files.WriteInt(R, tdx*4);
-    i := 0;
-    WHILE i < tdx DO Files.WriteInt(R, data[i]); INC(i) END ; (*type descriptors*)
-    Files.WriteInt(R, varsize - tdx*4);  (*data*)
-    Files.WriteInt(R, strx);
-    FOR i := 0 TO strx-1 DO Files.Write(R, str[i]) END ;  (*strings*)
-    Files.WriteInt(R, pc);  (*code len*)
-    FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ;  (*program*)
-    obj := ORB.topScope.next;
-    WHILE obj # NIL DO  (*commands*)
-      IF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) &
-          (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN
-        Files.WriteString(R, obj.name); Files.WriteInt(R, obj.val)
-      END ;
-      obj := obj.next
-    END ;
-    Files.Write(R, 0X);
-    Files.WriteInt(R, nofent); Files.WriteInt(R, entry);
-    obj := ORB.topScope.next;
-    WHILE obj # NIL DO  (*entries*)
-      IF obj.exno # 0 THEN
-        IF (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) OR (obj.class = ORB.Var) THEN
-          Files.WriteInt(R, obj.val);
-        ELSIF obj.class = ORB.Typ THEN
-          IF obj.type.form = ORB.Record THEN Files.WriteInt(R,  obj.type.len MOD 10000H)
-          ELSIF (obj.type.form = ORB.Pointer) & ((obj.type.base.typobj = NIL) OR (obj.type.base.typobj.exno = 0)) THEN
-            Files.WriteInt(R,  obj.type.base.len MOD 10000H)
-          END
-        END
-      END ;
-      obj := obj.next
-    END ;
-    obj := ORB.topScope.next;
-    WHILE obj # NIL DO  (*pointer variables*)
-      IF obj.class = ORB.Var THEN FindPtrs(R, obj.type, obj.val) END ;
-      obj := obj.next
-    END ;
-    Files.WriteInt(R, -1);
-    Files.WriteInt(R, fixorgP); Files.WriteInt(R, fixorgD); Files.WriteInt(R, fixorgT); Files.WriteInt(R, entry);
-    Files.Write(R, "O"); Files.Register(F)
-  END Close;
-
-BEGIN relmap[0] := 1; relmap[1] := 9; relmap[2] := 5; relmap[3] := 6; relmap[4] := 14; relmap[5] := 13;
-END ORG.
+MODULE ORG; (* N.Wirth, 16.4.2016 / 4.4.2017 / 17.9.2018  Oberon compiler; code generator for RISC*)
+  IMPORT SYSTEM, Files, ORS, ORB;
+  (*Code generator for Oberon compiler for RISC processor.
+     Procedural interface to Parser OSAP; result in array "code".
+     Procedure Close writes code-files*)
+
+  CONST WordSize* = 4;
+    StkOrg0 = -64; VarOrg0 = 0;  (*for RISC-0 only*)
+    MT = 12; SP = 14; LNK = 15;   (*dedicated registers*)
+    maxCode = 8000; maxStrx = 2400; maxTD = 160; C24 = 1000000H;
+    Reg = 10; RegI = 11; Cond = 12;  (*internal item modes*)
+
+  (*frequently used opcodes*)  U = 2000H; V = 1000H;
+    Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7;
+    Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11;
+    Fad = 12; Fsb = 13; Fml = 14; Fdv = 15;
+    Ldr = 8; Str = 10;
+    BR = 0; BLR = 1; BC = 2; BL = 3;
+    MI = 0; PL = 8; EQ = 1; NE = 9; LT = 5; GE = 13; LE = 6; GT = 14;
+
+    TYPE Item* = RECORD
+      mode*: INTEGER;
+      type*: ORB.Type;
+      a*, b*, r: LONGINT;
+      rdo*: BOOLEAN  (*read only*)
+    END ;
+
+  (* Item forms and meaning of fields:
+    mode    r      a       b
+    --------------------------------
+    Const   -     value (proc adr)  (immediate value)
+    Var     base   off     -               (direct adr)
+    Par      -     off0     off1         (indirect adr)
+    Reg    regno
+    RegI   regno   off     -
+    Cond  cond   Fchain  Tchain  *)
+
+  VAR pc*, varsize: LONGINT;   (*program counter, data index*)
+    tdx, strx: LONGINT;
+    entry: LONGINT;   (*main entry point*)
+    RH: LONGINT;  (*available registers R[0] ... R[H-1]*)
+    frame: LONGINT;  (*frame offset changed in SaveRegs and RestoreRegs*)
+    fixorgP, fixorgD, fixorgT: LONGINT;   (*origins of lists of locations to be fixed up by loader*)
+    check: BOOLEAN;  (*emit run-time checks*)
+    version: INTEGER;  (* 0 = RISC-0, 1 = RISC-5 *)
+    
+    relmap: ARRAY 6 OF INTEGER;  (*condition codes for relations*)
+    code: ARRAY maxCode OF LONGINT;
+    data: ARRAY maxTD OF LONGINT;  (*type descriptors*)
+    str: ARRAY maxStrx OF CHAR;
+
+  (*instruction assemblers according to formats*)
+
+  PROCEDURE Put0(op, a, b, c: LONGINT);
+  BEGIN (*emit format-0 instruction*)
+    code[pc] := ((a*10H + b) * 10H + op) * 10000H + c; INC(pc)
+  END Put0;
+
+  PROCEDURE Put1(op, a, b, im: LONGINT);
+  BEGIN (*emit format-1 instruction,  -10000H <= im < 10000H*)
+    IF im < 0 THEN INC(op, V) END ;
+    code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc)
+  END Put1;
+
+  PROCEDURE Put1a(op, a, b, im: LONGINT);
+  BEGIN (*same as Put1, but with range test  -10000H <= im < 10000H*)
+    IF (im >= -10000H) & (im <= 0FFFFH) THEN Put1(op, a, b, im)
+    ELSE Put1(Mov+U, RH, 0, im DIV 10000H);
+      IF im MOD 10000H # 0 THEN Put1(Ior, RH, RH, im MOD 10000H) END ;
+      Put0(op, a, b, RH)
+    END
+  END Put1a;
+
+  PROCEDURE Put2(op, a, b, off: LONGINT);
+  BEGIN (*emit load/store instruction*)
+    code[pc] := ((op * 10H + a) * 10H + b) * 100000H + (off MOD 100000H); INC(pc)
+  END Put2;
+
+  PROCEDURE Put3(op, cond, off: LONGINT);
+  BEGIN (*emit branch instruction*)
+    code[pc] := ((op+12) * 10H + cond) * 1000000H + (off MOD 1000000H); INC(pc)
+  END Put3;
+
+  PROCEDURE incR;
+  BEGIN
+    IF RH < MT-1 THEN INC(RH) ELSE ORS.Mark("register stack overflow") END
+  END incR;
+
+  PROCEDURE CheckRegs*;
+  BEGIN
+    IF RH # 0 THEN ORS.Mark("Reg Stack"); RH := 0 END ;
+    IF pc >= maxCode - 40 THEN ORS.Mark("program too long") END ;
+    IF frame # 0 THEN ORS.Mark("frame error"); frame := 0 END
+  END CheckRegs;
+
+  PROCEDURE SetCC(VAR x: Item; n: LONGINT);
+  BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n
+  END SetCC;
+
+  PROCEDURE Trap(cond, num: LONGINT);
+  BEGIN Put3(BLR, cond, ORS.Pos()*100H + num*10H + MT)
+  END Trap;
+
+  (*handling of forward reference, fixups of branch addresses and constant tables*)
+
+  PROCEDURE negated(cond: LONGINT): LONGINT;
+  BEGIN
+    IF cond < 8 THEN cond := cond+8 ELSE cond := cond-8 END ;
+    RETURN cond
+  END negated;
+
+  PROCEDURE fix(at, with: LONGINT);
+  BEGIN code[at] := code[at] DIV C24 * C24 + (with MOD C24)
+  END fix;
+
+  PROCEDURE FixOne*(at: LONGINT);
+  BEGIN fix(at, pc-at-1)
+  END FixOne;
+
+  PROCEDURE FixLink*(L: LONGINT);
+    VAR L1: LONGINT;
+  BEGIN
+    WHILE L # 0 DO L1 := code[L] MOD 40000H; fix(L, pc-L-1); L := L1 END
+  END FixLink;
+
+  PROCEDURE FixLinkWith(L0, dst: LONGINT);
+    VAR L1: LONGINT;
+  BEGIN
+    WHILE L0 # 0 DO
+      L1 := code[L0] MOD C24;
+      code[L0] := code[L0] DIV C24 * C24 + ((dst - L0 - 1) MOD C24); L0 := L1
+    END
+  END FixLinkWith;
+
+  PROCEDURE merged(L0, L1: LONGINT): LONGINT;
+    VAR L2, L3: LONGINT;
+  BEGIN 
+    IF L0 # 0 THEN L3 := L0;
+      REPEAT L2 := L3; L3 := code[L2] MOD 40000H UNTIL L3 = 0;
+      code[L2] := code[L2] + L1; L1 := L0
+    END ;
+    RETURN L1
+  END merged;
+
+  (* loading of operands and addresses into registers *)
+
+  PROCEDURE GetSB(base: LONGINT);
+  BEGIN
+    IF version = 0 THEN Put1(Mov, RH, 0, VarOrg0)
+    ELSE Put2(Ldr, RH, -base, pc-fixorgD); fixorgD := pc-1
+    END
+  END GetSB;
+
+  PROCEDURE NilCheck;
+  BEGIN IF check THEN Trap(EQ, 4) END
+  END NilCheck;
+
+  PROCEDURE load(VAR x: Item);
+    VAR op: LONGINT;
+  BEGIN
+    IF x.type.size = 1 THEN op := Ldr+1 ELSE op := Ldr END ;
+    IF x.mode # Reg THEN
+      IF x.mode = ORB.Const THEN
+        IF x.type.form = ORB.Proc THEN
+          IF x.r > 0 THEN ORS.Mark("not allowed")
+          ELSIF x.r = 0 THEN Put3(BL, 7, 0); Put1a(Sub, RH, LNK, pc*4 - x.a)
+          ELSE GetSB(x.r); Put1(Add, RH, RH, x.a + 100H) (*mark as progbase-relative*)
+          END
+        ELSIF (x.a <= 0FFFFH) & (x.a >= -10000H) THEN Put1(Mov, RH, 0, x.a)
+        ELSE Put1(Mov+U, RH, 0, x.a DIV 10000H MOD 10000H);
+          IF x.a MOD 10000H # 0 THEN Put1(Ior, RH, RH, x.a MOD 10000H) END
+        END ;
+        x.r := RH; incR
+      ELSIF x.mode = ORB.Var THEN
+        IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a + frame)
+        ELSE GetSB(x.r); Put2(op, RH, RH, x.a)
+        END ;
+        x.r := RH; incR
+      ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, RH, RH, x.b); x.r := RH; incR
+      ELSIF x.mode = RegI THEN Put2(op, x.r, x.r, x.a)
+      ELSIF x.mode = Cond THEN
+        Put3(BC, negated(x.r), 2);
+        FixLink(x.b); Put1(Mov, RH, 0, 1); Put3(BC, 7, 1);
+        FixLink(x.a); Put1(Mov, RH, 0, 0); x.r := RH; incR
+      END ;
+      x.mode := Reg
+    END
+  END load;
+
+  PROCEDURE loadAdr(VAR x: Item);
+  BEGIN
+    IF x.mode = ORB.Var THEN
+      IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a + frame)
+      ELSE GetSB(x.r); Put1a(Add, RH, RH, x.a)
+      END ;
+      x.r := RH; incR
+    ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame);
+      IF x.b # 0 THEN Put1a(Add, RH, RH, x.b) END ;
+      x.r := RH; incR
+    ELSIF x.mode = RegI THEN
+      IF x.a # 0 THEN Put1a(Add, x.r, x.r, x.a) END
+    ELSE ORS.Mark("address error")
+    END ;
+    x.mode := Reg
+  END loadAdr;
+
+  PROCEDURE loadCond(VAR x: Item);
+  BEGIN
+    IF x.type.form = ORB.Bool THEN
+      IF x.mode = ORB.Const THEN x.r := 15 - x.a*8
+      ELSE load(x);
+        IF code[pc-1] DIV 40000000H # -2 THEN Put1(Cmp, x.r, x.r, 0) END ;
+        x.r := NE; DEC(RH)
+      END ;
+      x.mode := Cond; x.a := 0; x.b := 0
+    ELSE ORS.Mark("not Boolean?")
+    END
+  END loadCond;
+
+  PROCEDURE loadTypTagAdr(T: ORB.Type);
+    VAR x: Item;
+  BEGIN x.mode := ORB.Var; x.a := T.len; x.r := -T.mno; loadAdr(x)
+  END loadTypTagAdr;
+
+  PROCEDURE loadStringAdr(VAR x: Item);
+  BEGIN GetSB(0); Put1a(Add, RH, RH, varsize+x.a); x.mode := Reg; x.r := RH; incR
+  END loadStringAdr;
+
+  (* Items: Conversion from constants or from Objects on the Heap to Items on the Stack*)
+
+  PROCEDURE MakeConstItem*(VAR x: Item; typ: ORB.Type; val: LONGINT);
+  BEGIN x.mode := ORB.Const; x.type := typ; x.a := val
+  END MakeConstItem;
+
+  PROCEDURE MakeRealItem*(VAR x: Item; val: REAL);
+  BEGIN x.mode := ORB.Const; x.type := ORB.realType; x.a := SYSTEM.VAL(LONGINT, val)
+  END MakeRealItem;
+
+  PROCEDURE MakeStringItem*(VAR x: Item; len: LONGINT); (*copies string from ORS-buffer to ORG-string array*)
+    VAR i: LONGINT;
+  BEGIN x.mode := ORB.Const; x.type := ORB.strType; x.a := strx; x.b := len; i := 0;
+    IF strx + len + 4 < maxStrx THEN
+      WHILE len > 0 DO str[strx] := ORS.str[i]; INC(strx); INC(i); DEC(len) END ;
+      WHILE strx MOD 4 # 0 DO str[strx] := 0X; INC(strx) END
+    ELSE ORS.Mark("too many strings")
+    END
+  END MakeStringItem;
+
+  PROCEDURE MakeItem*(VAR x: Item; y: ORB.Object; curlev: LONGINT);
+  BEGIN x.mode := y.class; x.type := y.type; x.a := y.val; x.rdo := y.rdo;
+    IF y.class = ORB.Par THEN x.b := 0
+    ELSIF (y.class = ORB.Const) & (y.type.form = ORB.String) THEN x.b := y.lev  (*len*) ;
+    ELSE x.r := y.lev
+    END ;
+    IF (y.lev > 0) & (y.lev # curlev) & (y.class # ORB.Const) THEN ORS.Mark("not accessible ") END
+  END MakeItem;
+
+  (* Code generation for Selectors, Variables, Constants *)
+
+  PROCEDURE Field*(VAR x: Item; y: ORB.Object);   (* x := x.y *)
+  BEGIN;
+    IF x.mode = ORB.Var THEN
+      IF x.r >= 0 THEN x.a := x.a + y.val
+      ELSE loadAdr(x); x.mode := RegI; x.a := y.val
+      END
+    ELSIF x.mode = RegI THEN x.a := x.a + y.val
+    ELSIF x.mode = ORB.Par THEN x.b := x.b + y.val
+    END
+  END Field;
+
+  PROCEDURE Index*(VAR x, y: Item);   (* x := x[y] *)
+    VAR s, lim: LONGINT;
+  BEGIN s := x.type.base.size; lim := x.type.len;
+    IF (y.mode = ORB.Const) & (lim >= 0) THEN
+      IF (y.a < 0) OR (y.a >= lim) THEN ORS.Mark("bad index") END ;
+      IF x.mode IN {ORB.Var, RegI} THEN x.a := y.a * s + x.a
+      ELSIF x.mode = ORB.Par THEN x.b := y.a * s + x.b
+      END
+    ELSE load(y);
+      IF check THEN  (*check array bounds*)
+        IF lim >= 0 THEN Put1a(Cmp, RH, y.r, lim)
+        ELSE (*open array*)
+          IF x.mode IN {ORB.Var, ORB.Par} THEN Put2(Ldr, RH, SP, x.a+4+frame); Put0(Cmp, RH, y.r, RH)
+          ELSE ORS.Mark("error in Index")
+          END
+        END ;
+        Trap(10, 1)  (*BCC*)
+      END ;
+      IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1a(Mul, y.r, y.r, s) END ;
+      IF x.mode = ORB.Var THEN
+        IF x.r > 0 THEN Put0(Add, y.r, SP, y.r); INC(x.a, frame)
+        ELSE GetSB(x.r);
+          IF x.r = 0 THEN Put0(Add, y.r, RH, y.r)
+          ELSE Put1a(Add, RH, RH, x.a); Put0(Add, y.r, RH, y.r); x.a := 0
+          END
+        END ;
+        x.r := y.r; x.mode := RegI
+      ELSIF x.mode = ORB.Par THEN
+        Put2(Ldr, RH, SP, x.a + frame);
+        Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r; x.a := x.b
+      ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH)
+      END
+    END
+  END Index;
+
+  PROCEDURE DeRef*(VAR x: Item);
+  BEGIN
+    IF x.mode = ORB.Var THEN
+      IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a + frame) ELSE GetSB(x.r); Put2(Ldr, RH, RH, x.a) END ;
+      NilCheck; x.r := RH; incR
+    ELSIF x.mode = ORB.Par THEN
+      Put2(Ldr, RH, SP, x.a + frame); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR
+    ELSIF x.mode = RegI THEN Put2(Ldr, x.r, x.r, x.a); NilCheck
+    ELSIF x.mode # Reg THEN ORS.Mark("bad mode in DeRef")
+    END ;
+    x.mode := RegI; x.a := 0; x.b := 0
+  END DeRef;
+
+  PROCEDURE Q(T: ORB.Type; VAR dcw: LONGINT);
+  BEGIN (*one entry of type descriptor extension table*)
+    IF T.base # NIL THEN
+      Q(T.base, dcw); data[dcw] := (T.mno*1000H + T.len) * 1000H + dcw - fixorgT;
+      fixorgT := dcw; INC(dcw)
+    END
+  END Q;
+
+  PROCEDURE FindPtrFlds(typ: ORB.Type; off: LONGINT; VAR dcw: LONGINT);
+    VAR fld: ORB.Object; i, s: LONGINT;
+  BEGIN
+    IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN data[dcw] := off; INC(dcw)
+    ELSIF typ.form = ORB.Record THEN
+      fld := typ.dsc;
+      WHILE fld # NIL DO FindPtrFlds(fld.type, fld.val + off, dcw); fld := fld.next END
+    ELSIF typ.form = ORB.Array THEN
+      s := typ.base.size;
+      FOR i := 0 TO typ.len-1 DO FindPtrFlds(typ.base, i*s + off, dcw) END
+    END
+  END FindPtrFlds;
+
+  PROCEDURE BuildTD*(T: ORB.Type; VAR dc: LONGINT);
+    VAR dcw, k, s: LONGINT;  (*dcw = word address*)
+  BEGIN dcw := dc DIV 4; s := T.size; (*convert size for heap allocation*)
+    IF s <= 24 THEN s := 32 ELSIF s <= 56 THEN s := 64 ELSIF s <= 120 THEN s := 128
+    ELSE s := (s+263) DIV 256 * 256
+    END ;
+    T.len := dc; data[dcw] := s; INC(dcw);  (*len used as address*)
+    k := T.nofpar;   (*extension level!*)
+    IF k > 3 THEN ORS.Mark("ext level too large")
+    ELSE Q(T, dcw);
+      WHILE k < 3 DO data[dcw] := -1; INC(dcw); INC(k) END
+    END ;
+    FindPtrFlds(T, 0, dcw); data[dcw] := -1; INC(dcw); tdx := dcw; dc := dcw*4;
+    IF tdx >= maxTD THEN ORS.Mark("too many record types"); tdx := 0 END
+  END BuildTD;
+
+  PROCEDURE TypeTest*(VAR x: Item; T: ORB.Type; varpar, isguard: BOOLEAN);
+    VAR pc0: LONGINT;
+  BEGIN (*fetch tag into RH*)
+    IF varpar THEN Put2(Ldr, RH, SP, x.a+4+frame)
+    ELSE load(x);
+      pc0 := pc; Put3(BC, EQ, 0);  (*NIL belongs to every pointer type*)
+      Put2(Ldr, RH, x.r, -8)
+    END ;
+    Put2(Ldr, RH, RH, T.nofpar*4); incR;
+    loadTypTagAdr(T);  (*tag of T*)
+    Put0(Cmp, RH-1, RH-1, RH-2); DEC(RH, 2);
+    IF ~varpar THEN fix(pc0, pc - pc0 - 1) END ;
+    IF isguard THEN
+      IF check THEN Trap(NE, 2) END
+    ELSE SetCC(x, EQ);
+      IF ~varpar THEN DEC(RH) END
+    END
+  END TypeTest;
+
+  (* Code generation for Boolean operators *)
+
+  PROCEDURE Not*(VAR x: Item);   (* x := ~x *)
+    VAR t: LONGINT;
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t
+  END Not;
+
+  PROCEDURE And1*(VAR x: Item);   (* x := x & *)
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    Put3(BC, negated(x.r), x.a); x.a := pc-1; FixLink(x.b); x.b := 0
+  END And1;
+
+  PROCEDURE And2*(VAR x, y: Item);
+  BEGIN
+    IF y.mode # Cond THEN loadCond(y) END ;
+    x.a := merged(y.a, x.a); x.b := y.b; x.r := y.r
+  END And2;
+
+  PROCEDURE Or1*(VAR x: Item);   (* x := x OR *)
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    Put3(BC, x.r, x.b);  x.b := pc-1; FixLink(x.a); x.a := 0
+  END Or1;
+
+  PROCEDURE Or2*(VAR x, y: Item);
+  BEGIN
+    IF y.mode # Cond THEN loadCond(y) END ;
+    x.a := y.a; x.b := merged(y.b, x.b); x.r := y.r
+  END Or2;
+
+  (* Code generation for arithmetic operators *)
+
+  PROCEDURE Neg*(VAR x: Item);   (* x := -x *)
+  BEGIN
+    IF x.type.form = ORB.Int THEN
+      IF x.mode = ORB.Const THEN x.a := -x.a
+      ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r)
+      END
+    ELSIF x.type.form = ORB.Real THEN
+      IF x.mode = ORB.Const THEN x.a := x.a + 7FFFFFFFH + 1
+      ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Fsb, x.r, RH, x.r)
+      END
+    ELSE (*form = Set*)
+      IF x.mode = ORB.Const THEN x.a := -x.a-1 
+      ELSE load(x); Put1(Xor, x.r, x.r, -1)
+      END
+    END
+  END Neg;
+
+  PROCEDURE AddOp*(op: LONGINT; VAR x, y: Item);   (* x := x +- y *)
+  BEGIN
+    IF op = ORS.plus THEN
+      IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a + y.a
+      ELSIF y.mode = ORB.Const THEN load(x);
+        IF y.a # 0 THEN Put1a(Add, x.r, x.r, y.a) END
+      ELSE load(x); load(y); Put0(Add, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
+      END
+    ELSE (*op = ORS.minus*)
+      IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a - y.a
+      ELSIF y.mode = ORB.Const THEN load(x);
+        IF y.a # 0 THEN Put1a(Sub, x.r, x.r, y.a) END
+      ELSE load(x); load(y); Put0(Sub, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
+      END
+    END
+  END AddOp;
+
+  PROCEDURE log2(m: LONGINT; VAR e: LONGINT): LONGINT;
+  BEGIN e := 0;
+    WHILE ~ODD(m) DO m := m DIV 2; INC(e) END ;
+    RETURN m
+  END log2;
+  
+  PROCEDURE MulOp*(VAR x, y: Item);   (* x := x * y *)
+    VAR e: LONGINT;
+  BEGIN
+    IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a * y.a
+    ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Lsl, x.r, x.r, e)
+    ELSIF y.mode = ORB.Const THEN load(x); Put1a(Mul, x.r, x.r, y.a)
+    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
+    ELSIF x.mode = ORB.Const THEN load(y); Put1a(Mul, y.r, y.r, x.a); x.mode := Reg; x.r := y.r
+    ELSE load(x); load(y); Put0(Mul, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
+    END
+  END MulOp;
+
+  PROCEDURE DivOp*(op: LONGINT; VAR x, y: Item);   (* x := x op y *)
+    VAR e: LONGINT;
+  BEGIN
+    IF op = ORS.div THEN
+      IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN
+        IF y.a > 0 THEN x.a := x.a DIV y.a ELSE ORS.Mark("bad divisor") END
+      ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Asr, x.r, x.r, e)
+      ELSIF y.mode = ORB.Const THEN
+        IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a) ELSE ORS.Mark("bad divisor") END
+      ELSE load(y);
+        IF check THEN Trap(LE, 6) END ;
+        load(x); Put0(Div, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
+      END
+    ELSE (*op = ORS.mod*)
+      IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN
+        IF y.a > 0 THEN x.a := x.a MOD y.a ELSE ORS.Mark("bad modulus") END
+      ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x);
+        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
+      ELSIF y.mode = ORB.Const THEN
+        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
+      ELSE load(y);
+        IF check THEN Trap(LE, 6) END ;
+        load(x); Put0(Div, RH-2, x.r, y.r); Put0(Mov+U, RH-2, 0, 0); DEC(RH); x.r := RH-1
+      END
+    END
+  END DivOp;
+
+  (* Code generation for REAL operators *)
+
+  PROCEDURE RealOp*(op: INTEGER; VAR x, y: Item);   (* x := x op y *)
+  BEGIN load(x); load(y);
+    IF op = ORS.plus THEN Put0(Fad, RH-2, x.r, y.r)
+    ELSIF op = ORS.minus THEN Put0(Fsb, RH-2, x.r, y.r)
+    ELSIF op = ORS.times THEN Put0(Fml, RH-2, x.r, y.r)
+    ELSIF op = ORS.rdiv THEN Put0(Fdv, RH-2, x.r, y.r)
+    END ;
+    DEC(RH); x.r := RH-1
+  END RealOp;
+
+  (* Code generation for set operators *)
+
+  PROCEDURE Singleton*(VAR x: Item);  (* x := {x} *)
+  BEGIN
+    IF x.mode = ORB.Const THEN x.a := LSL(1, x.a) 
+    ELSE load(x); Put1(Mov, RH, 0, 1); Put0(Lsl, x.r, RH,  x.r)
+    END
+  END Singleton;
+
+  PROCEDURE Set*(VAR x, y: Item);   (* x := {x .. y} *)
+  BEGIN
+    IF (x.mode = ORB.Const) & ( y.mode = ORB.Const) THEN
+      IF x.a <= y.a THEN x.a := LSL(2, y.a) - LSL(1, x.a) ELSE x.a := 0 END
+    ELSE
+      IF (x.mode = ORB.Const) & (x.a <= 16) THEN x.a := LSL(-1, x.a)
+      ELSE load(x); Put1(Mov, RH, 0, -1); Put0(Lsl, x.r, RH, x.r)
+      END ;
+      IF (y.mode = ORB.Const) & (y.a < 16) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; incR
+      ELSE load(y); Put1(Mov, RH, 0, -2); Put0(Lsl, y.r, RH, y.r)
+      END ;
+      IF x.mode = ORB.Const THEN
+        IF x.a # 0 THEN Put1(Xor, y.r, y.r, -1); Put1a(And, RH-1, y.r, x.a) END ;
+        x.mode := Reg; x.r := RH-1
+      ELSE DEC(RH); Put0(Ann, RH-1, x.r, y.r)
+      END
+    END
+  END Set;
+
+  PROCEDURE In*(VAR x, y: Item);  (* x := x IN y *)
+  BEGIN load(y);
+    IF x.mode = ORB.Const THEN Put1(Ror, y.r, y.r, (x.a + 1) MOD 20H); DEC(RH)
+    ELSE load(x); Put1(Add, x.r, x.r, 1); Put0(Ror, y.r, y.r, x.r); DEC(RH, 2)
+    END ;
+    SetCC(x, MI)
+  END In;
+
+  PROCEDURE SetOp*(op: LONGINT; VAR x, y: Item);   (* x := x op y *)
+    VAR xset, yset: SET; (*x.type.form = Set*)
+  BEGIN
+    IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN
+      xset := SYSTEM.VAL(SET, x.a); yset := SYSTEM.VAL(SET, y.a);
+      IF op = ORS.plus THEN xset := xset + yset
+      ELSIF op = ORS.minus THEN xset := xset - yset
+      ELSIF op = ORS.times THEN xset := xset * yset
+      ELSIF op = ORS.rdiv THEN xset := xset / yset
+      END ;
+      x.a := SYSTEM.VAL(LONGINT, xset)
+    ELSIF y.mode = ORB.Const THEN
+      load(x);
+      IF op = ORS.plus THEN Put1a(Ior, x.r, x.r, y.a)
+      ELSIF op = ORS.minus THEN Put1a(Ann, x.r, x.r, y.a)
+      ELSIF op = ORS.times THEN Put1a(And, x.r, x.r, y.a)
+      ELSIF op = ORS.rdiv THEN Put1a(Xor, x.r, x.r, y.a)
+      END ;
+    ELSE load(x); load(y);
+      IF op = ORS.plus THEN Put0(Ior, RH-2, x.r, y.r)
+      ELSIF op = ORS.minus THEN Put0(Ann, RH-2, x.r, y.r)
+      ELSIF op = ORS.times THEN Put0(And, RH-2, x.r, y.r)
+      ELSIF op = ORS.rdiv THEN Put0(Xor, RH-2, x.r, y.r)
+      END ;
+      DEC(RH); x.r := RH-1
+    END 
+  END SetOp;
+
+  (* Code generation for relations *)
+
+  PROCEDURE IntRelation*(op: INTEGER; VAR x, y: Item);   (* x := x < y *)
+  BEGIN
+    IF (y.mode = ORB.Const) & (y.type.form # ORB.Proc) THEN
+      load(x);
+      IF (y.a # 0) OR ~(op IN {ORS.eql, ORS.neq}) OR (code[pc-1] DIV 40000000H # -2) THEN Put1a(Cmp, x.r, x.r, y.a) END ;
+      DEC(RH)
+    ELSE
+      IF (x.mode = Cond) OR (y.mode = Cond) THEN ORS.Mark("not implemented") END ;
+      load(x); load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2)
+    END ;
+    SetCC(x, relmap[op - ORS.eql])
+  END IntRelation;
+
+  PROCEDURE RealRelation*(op: INTEGER; VAR x, y: Item);   (* x := x < y *)
+  BEGIN load(x);
+    IF (y.mode = ORB.Const) & (y.a = 0) THEN DEC(RH)
+    ELSE load(y); Put0(Fsb, x.r, x.r, y.r); DEC(RH, 2)
+    END ;
+    SetCC(x, relmap[op - ORS.eql])
+  END RealRelation;
+
+  PROCEDURE StringRelation*(op: INTEGER; VAR x, y: Item);   (* x := x < y *)
+    (*x, y are char arrays or strings*)
+  BEGIN
+    IF x.type.form = ORB.String THEN loadStringAdr(x) ELSE loadAdr(x) END ;
+    IF y.type.form = ORB.String THEN loadStringAdr(y) ELSE loadAdr(y) END ;
+    Put2(Ldr+1, RH, x.r, 0); Put1(Add, x.r, x.r, 1);
+    Put2(Ldr+1, RH+1, y.r, 0); Put1(Add, y.r, y.r, 1);
+    Put0(Cmp, RH+2, RH, RH+1); Put3(BC, NE, 2);
+    Put1(Cmp, RH+2, RH, 0); Put3(BC, NE, -8);
+    DEC(RH, 2); SetCC(x, relmap[op - ORS.eql])
+  END StringRelation;
+
+  (* Code generation of Assignments *)
+
+  PROCEDURE StrToChar*(VAR x: Item);
+  BEGIN x.type := ORB.charType; DEC(strx, 4); x.a := ORD(str[x.a])
+  END StrToChar;
+
+  PROCEDURE Store*(VAR x, y: Item); (* x := y *)
+    VAR op: LONGINT;
+  BEGIN  load(y);
+    IF x.type.size = 1 THEN op := Str+1 ELSE op := Str END ;
+    IF x.mode = ORB.Var THEN
+      IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a + frame)
+      ELSE GetSB(x.r); Put2(op, y.r, RH, x.a)
+      END
+    ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, y.r, RH, x.b);
+    ELSIF x.mode = RegI THEN Put2(op, y.r, x.r, x.a); DEC(RH);
+    ELSE ORS.Mark("bad mode in Store")
+    END ;
+    DEC(RH)
+  END Store;
+
+  PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y, frame = 0 *)
+    VAR s, pc0: LONGINT;
+  BEGIN
+    IF y.type.size # 0 THEN
+      loadAdr(x); loadAdr(y);
+      IF (x.type.form = ORB.Array) &  (x.type.len > 0) THEN
+        IF y.type.len >= 0 THEN 
+          IF x.type.size = y.type.size THEN Put1a(Mov, RH, 0, (y.type.size+3) DIV 4)
+          ELSE ORS.Mark("different length/size, not implemented")
+          END
+        ELSE (*y  open array*) Put2(Ldr, RH, SP, y.a+4); s := y.type.base.size;  (*element size*)
+          pc0 := pc; Put3(BC, EQ, 0);
+          IF s = 1 THEN Put1(Add, RH, RH, 3); Put1(Asr, RH, RH, 2)
+          ELSIF s # 4 THEN Put1a(Mul, RH, RH, s DIV 4)
+          END ;
+          IF check THEN
+            Put1a(Mov, RH+1, 0, (x.type.size+3) DIV 4); Put0(Cmp, RH+1, RH, RH+1); Trap(GT, 3)
+          END ;
+          fix(pc0, pc + 5 - pc0)
+        END
+      ELSIF x.type.form = ORB.Record THEN Put1a(Mov, RH, 0, x.type.size DIV 4)
+      ELSE ORS.Mark("inadmissible assignment")
+      END ;
+      Put2(Ldr, RH+1, y.r, 0); Put1(Add, y.r, y.r, 4);
+      Put2(Str, RH+1, x.r, 0); Put1(Add, x.r, x.r, 4);
+      Put1(Sub, RH, RH, 1); Put3(BC, NE, -6)
+    END ;
+    RH := 0
+  END StoreStruct;
+
+  PROCEDURE CopyString*(VAR x, y: Item);  (* x := y *) 
+     VAR len: LONGINT;
+   BEGIN loadAdr(x); len := x.type.len;
+    IF len >= 0 THEN
+      IF len <  y.b THEN ORS.Mark("string too long") END
+    ELSIF check THEN Put2(Ldr, RH, SP, x.a+4);  (*open array len, frame = 0*)
+      Put1(Cmp,RH, RH, y.b); Trap(LT, 3)
+    END ;
+    loadStringAdr(y);
+    Put2(Ldr, RH, y.r, 0); Put1(Add, y.r, y.r, 4);
+    Put2(Str, RH, x.r, 0); Put1(Add, x.r, x.r, 4);
+    Put1(Asr, RH, RH, 24); Put3(BC, NE,  -6);  RH := 0
+   END CopyString;
+  
+  (* Code generation for parameters *)
+  
+  PROCEDURE OpenArrayParam*(VAR x: Item);
+  BEGIN loadAdr(x);
+    IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ;
+    incR
+  END OpenArrayParam;
+
+  PROCEDURE VarParam*(VAR x: Item; ftype: ORB.Type);
+    VAR xmd: INTEGER;
+  BEGIN xmd := x.mode; loadAdr(x);
+    IF (ftype.form = ORB.Array) & (ftype.len < 0) THEN (*open array*)
+      IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE  Put2(Ldr, RH, SP, x.a+4+frame) END ;
+      incR
+    ELSIF ftype.form = ORB.Record THEN
+      IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4+frame); incR ELSE loadTypTagAdr(x.type) END
+    END
+  END VarParam;
+
+  PROCEDURE ValueParam*(VAR x: Item);
+  BEGIN load(x)
+  END ValueParam;
+
+  PROCEDURE StringParam*(VAR x: Item);
+  BEGIN loadStringAdr(x); Put1(Mov, RH, 0, x.b); incR  (*len*)
+  END StringParam;
+
+  (*For Statements*)
+
+  PROCEDURE For0*(VAR x, y: Item);
+  BEGIN load(y)
+  END For0;
+
+  PROCEDURE For1*(VAR x, y, z, w: Item; VAR L: LONGINT);
+  BEGIN 
+    IF z.mode = ORB.Const THEN Put1a(Cmp, RH, y.r, z.a)
+    ELSE load(z); Put0(Cmp, RH-1, y.r, z.r); DEC(RH)
+    END ;
+    L := pc;
+    IF w.a > 0 THEN Put3(BC, GT, 0)
+    ELSIF w.a < 0 THEN Put3(BC, LT, 0)
+    ELSE ORS.Mark("zero increment"); Put3(BC, MI, 0)
+    END ;
+    Store(x, y)
+  END For1;
+
+  PROCEDURE For2*(VAR x, y, w: Item);
+  BEGIN load(x); DEC(RH); Put1a(Add, x.r, x.r, w.a)
+  END For2;
+
+  (* Branches, procedure calls, procedure prolog and epilog *)
+
+  PROCEDURE Here*(): LONGINT;
+  BEGIN RETURN pc
+  END Here;
+
+  PROCEDURE FJump*(VAR L: LONGINT);
+  BEGIN Put3(BC, 7, L); L := pc-1
+  END FJump;
+
+  PROCEDURE CFJump*(VAR x: Item);
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    Put3(BC, negated(x.r), x.a); FixLink(x.b); x.a := pc-1
+  END CFJump;
+
+  PROCEDURE BJump*(L: LONGINT);
+  BEGIN Put3(BC, 7, L-pc-1)
+  END BJump;
+
+  PROCEDURE CBJump*(VAR x: Item; L: LONGINT);
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    Put3(BC, negated(x.r), L-pc-1); FixLink(x.b); FixLinkWith(x.a, L)
+  END CBJump;
+
+  PROCEDURE Fixup*(VAR x: Item);
+  BEGIN FixLink(x.a)
+  END Fixup;
+
+  PROCEDURE SaveRegs(r: LONGINT);  (* R[0 .. r-1]*)
+    VAR r0: LONGINT;
+  BEGIN (*r > 0*) r0 := 0;
+    Put1(Sub, SP, SP, r*4); INC(frame, 4*r);
+    REPEAT Put2(Str, r0, SP, (r-r0-1)*4); INC(r0) UNTIL r0 = r
+  END SaveRegs;
+
+  PROCEDURE RestoreRegs(r: LONGINT); (*R[0 .. r-1]*)
+    VAR r0: LONGINT;
+  BEGIN (*r > 0*) r0 := r;
+    REPEAT DEC(r0); Put2(Ldr, r0, SP, (r-r0-1)*4) UNTIL r0 = 0;
+    Put1(Add, SP, SP, r*4); DEC(frame, 4*r)
+  END RestoreRegs;
+
+  PROCEDURE PrepCall*(VAR x: Item; VAR r: LONGINT);
+  BEGIN (*x.type.form = ORB.Proc*)
+    IF x.mode > ORB.Par THEN load(x) END ;
+    r := RH;
+    IF RH > 0 THEN SaveRegs(RH); RH := 0 END
+  END PrepCall;
+
+  PROCEDURE Call*(VAR x: Item; r: LONGINT);
+  BEGIN (*x.type.form = ORB.Proc*)
+    IF x.mode = ORB.Const THEN
+      IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1)
+      ELSE (*imported*)
+        IF pc - fixorgP < 1000H THEN
+          Put3(BL, 7, ((-x.r) * 100H + x.a) * 1000H + pc-fixorgP); fixorgP := pc-1
+        ELSE ORS.Mark("fixup impossible")
+        END
+      END
+    ELSE
+      IF x.mode <= ORB.Par THEN load(x); DEC(RH)
+      ELSE Put2(Ldr, RH, SP, 0); Put1(Add, SP, SP, 4); DEC(r); DEC(frame, 4)
+      END ;
+      IF check THEN Trap(EQ, 5) END ;
+      Put3(BLR, 7, RH)
+    END ;
+    IF x.type.base.form = ORB.NoTyp THEN (*procedure*) RH := 0
+    ELSE (*function*)
+      IF r > 0 THEN Put0(Mov, r, 0, 0); RestoreRegs(r) END ;
+      x.mode := Reg; x.r := r; RH := r+1
+    END
+  END Call;
+
+  PROCEDURE Enter*(parblksize, locblksize: LONGINT; int: BOOLEAN);
+    VAR a, r: LONGINT;
+  BEGIN frame := 0;
+    IF ~int THEN (*procedure prolog*)
+      IF locblksize >= 10000H THEN ORS.Mark("too many locals") END ;
+      a := 4; r := 0;
+      Put1(Sub, SP, SP, locblksize); Put2(Str, LNK, SP, 0);
+      WHILE a < parblksize DO Put2(Str, r, SP, a); INC(r); INC(a, 4) END
+    ELSE (*interrupt procedure*)
+      Put1(Sub, SP, SP, locblksize); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4); Put2(Str, 2, SP, 8)
+      (*R0, R1, R2 saved on stack*)
+    END
+  END Enter;
+
+  PROCEDURE Return*(form: INTEGER; VAR x: Item; size: LONGINT; int: BOOLEAN);
+  BEGIN
+    IF form # ORB.NoTyp THEN load(x) END ;
+    IF ~int THEN (*procedure epilog*)
+      Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK)
+    ELSE (*interrupt return, restore R2, R1, R0*)
+      Put2(Ldr, 2, SP, 8); Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, size);
+      Put3(BR, 7, 10H) (*RTI*)
+    END ;
+    RH := 0
+  END Return;
+
+  (* In-line code procedures*)
+
+  PROCEDURE Increment*(upordown: LONGINT; VAR x, y: Item);
+    VAR op, zr, v: LONGINT;
+  BEGIN (*frame = 0*)
+    IF upordown = 0 THEN op := Add ELSE op := Sub END ;
+    IF x.type = ORB.byteType THEN v := 1 ELSE v := 0 END ;
+    IF y.type.form = ORB.NoTyp THEN y.mode := ORB.Const; y.a := 1 END ;
+    IF (x.mode = ORB.Var) & (x.r > 0) THEN
+      zr := RH; Put2(Ldr+v, zr, SP, x.a); incR;
+      IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
+      Put2(Str+v, zr, SP, x.a); DEC(RH)
+    ELSE loadAdr(x); zr := RH; Put2(Ldr+v, RH, x.r, 0); incR;
+      IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
+      Put2(Str+v, zr, x.r, 0); DEC(RH, 2)
+    END
+  END Increment;
+
+  PROCEDURE Include*(inorex: LONGINT; VAR x, y: Item);
+    VAR op, zr: LONGINT;
+  BEGIN loadAdr(x); zr := RH; Put2(Ldr, RH, x.r, 0); incR;
+    IF inorex = 0 THEN op := Ior ELSE op := Ann END ;
+    IF y.mode = ORB.Const THEN Put1a(op, zr, zr, LSL(1, y.a))
+    ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(op, zr, zr, y.r); DEC(RH)
+    END ;
+    Put2(Str, zr, x.r, 0); DEC(RH, 2)
+  END Include;
+
+  PROCEDURE Assert*(VAR x: Item);
+    VAR cond: LONGINT;
+  BEGIN
+    IF x.mode # Cond THEN loadCond(x) END ;
+    IF x.a = 0 THEN cond := negated(x.r)
+    ELSE Put3(BC, x.r, x.b); FixLink(x.a); x.b := pc-1; cond := 7
+    END ;
+    Trap(cond, 7); FixLink(x.b)
+  END Assert; 
+
+  PROCEDURE New*(VAR x: Item);
+  BEGIN loadAdr(x); loadTypTagAdr(x.type.base); Trap(7, 0); RH := 0
+  END New;
+
+  PROCEDURE Pack*(VAR x, y: Item);
+    VAR z: Item;
+  BEGIN z := x; load(x); load(y);
+    Put1(Lsl, y.r, y.r, 23); Put0(Add, x.r, x.r, y.r); DEC(RH); Store(z, x)
+  END Pack;
+
+  PROCEDURE Unpk*(VAR x, y: Item);
+    VAR z, e0: Item;
+  BEGIN  z := x; load(x); e0.mode := Reg; e0.r := RH; e0.type := ORB.intType;
+    Put1(Asr, RH, x.r, 23); Put1(Sub, RH, RH, 127); Store(y, e0); incR;
+    Put1(Lsl, RH, RH, 23); Put0(Sub, x.r, x.r, RH); Store(z, x)
+  END Unpk;
+
+  PROCEDURE Led*(VAR x: Item);
+  BEGIN load(x); Put1(Mov, RH, 0, -60); Put2(Str, x.r, RH, 0); DEC(RH)
+  END Led;
+
+  PROCEDURE Get*(VAR x, y: Item);
+  BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(y, x)
+  END Get;
+
+  PROCEDURE Put*(VAR x, y: Item);
+  BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(x, y)
+  END Put;
+
+  PROCEDURE Copy*(VAR x, y, z: Item);
+  BEGIN load(x); load(y);
+    IF z.mode = ORB.Const THEN
+      IF z.a > 0 THEN load(z) ELSE ORS.Mark("bad count") END
+    ELSE load(z);
+      IF check THEN Trap(LT, 3) END ;
+      Put3(BC, EQ, 6)
+    END ;
+    Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4);
+    Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4);
+    Put1(Sub, z.r, z.r, 1); Put3(BC, NE, -6); DEC(RH, 3)
+  END Copy;
+
+  PROCEDURE LDPSR*(VAR x: Item);
+  BEGIN (*x.mode = Const*)  Put3(0, 15, x.a + 20H)
+  END LDPSR;
+
+  PROCEDURE LDREG*(VAR x, y: Item);
+  BEGIN
+    IF y.mode = ORB.Const THEN Put1a(Mov, x.a, 0, y.a)
+    ELSE load(y); Put0(Mov, x.a, 0, y.r); DEC(RH)
+    END
+  END LDREG;
+
+  (*In-line code functions*)
+
+  PROCEDURE Abs*(VAR x: Item);
+  BEGIN
+    IF x.mode = ORB.Const THEN x.a := ABS(x.a)
+    ELSE load(x);
+      IF x.type.form = ORB.Real THEN Put1(Lsl, x.r, x.r, 1); Put1(Ror, x.r, x.r, 1)
+      ELSE Put1(Cmp, x.r, x.r, 0); Put3(BC, GE, 2); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r)
+      END
+    END
+  END Abs;
+
+  PROCEDURE Odd*(VAR x: Item);
+  BEGIN load(x); Put1(And, x.r, x.r, 1); SetCC(x, NE); DEC(RH)
+  END Odd;
+
+  PROCEDURE Floor*(VAR x: Item);
+  BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+V, x.r, x.r, RH)
+  END Floor;
+
+  PROCEDURE Float*(VAR x: Item);
+  BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H);  Put0(Fad+U, x.r, x.r, RH)
+  END Float;
+
+  PROCEDURE Ord*(VAR x: Item);
+  BEGIN
+    IF x.mode IN {ORB.Var, ORB.Par, RegI, Cond} THEN load(x) END
+  END Ord;
+
+  PROCEDURE Len*(VAR x: Item);
+  BEGIN
+    IF x.type.len >= 0 THEN
+      IF x.mode = RegI THEN DEC(RH) END ;
+      x.mode := ORB.Const; x.a := x.type.len
+    ELSE (*open array*) Put2(Ldr, RH, SP, x.a + 4 + frame); x.mode := Reg; x.r := RH; incR
+    END 
+  END Len;
+
+  PROCEDURE Shift*(fct: LONGINT; VAR x, y: Item);
+    VAR op: LONGINT;
+  BEGIN load(x);
+    IF fct = 0 THEN op := Lsl ELSIF fct = 1 THEN op := Asr ELSE op := Ror END ;
+    IF y.mode = ORB.Const THEN Put1(op, x.r, x.r, y.a MOD 20H)
+    ELSE load(y); Put0(op, RH-2, x.r, y.r); DEC(RH); x.r := RH-1
+    END
+  END Shift;
+
+  PROCEDURE ADC*(VAR x, y: Item);
+  BEGIN load(x); load(y); Put0(Add+2000H, x.r, x.r, y.r); DEC(RH)
+  END ADC;
+
+  PROCEDURE SBC*(VAR x, y: Item);
+  BEGIN load(x); load(y); Put0(Sub+2000H, x.r, x.r, y.r); DEC(RH)
+  END SBC;
+
+  PROCEDURE UML*(VAR x, y: Item);
+  BEGIN load(x); load(y); Put0(Mul+2000H, x.r, x.r, y.r); DEC(RH)
+  END UML;
+
+  PROCEDURE Bit*(VAR x, y: Item);
+  BEGIN load(x); Put2(Ldr, x.r, x.r, 0);
+    IF y.mode = ORB.Const THEN Put1(Ror, x.r, x.r, y.a+1); DEC(RH)
+    ELSE load(y); Put1(Add, y.r, y.r, 1); Put0(Ror, x.r, x.r, y.r); DEC(RH, 2)
+    END ;
+    SetCC(x, MI)
+  END Bit;
+
+  PROCEDURE Register*(VAR x: Item);
+  BEGIN (*x.mode = Const*)
+    Put0(Mov, RH, 0, x.a MOD 10H); x.mode := Reg; x.r := RH; incR
+  END Register;
+
+  PROCEDURE H*(VAR x: Item);
+  BEGIN (*x.mode = Const*)
+    Put0(Mov + U + x.a MOD 2 * V, RH, 0, 0); x.mode := Reg; x.r := RH; incR
+  END H;
+
+  PROCEDURE Adr*(VAR x: Item);
+  BEGIN 
+    IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN loadAdr(x)
+    ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.Proc) THEN load(x)
+    ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.String) THEN loadStringAdr(x)
+    ELSE ORS.Mark("not addressable")
+    END
+  END Adr;
+
+  PROCEDURE Condition*(VAR x: Item);
+  BEGIN (*x.mode = Const*) SetCC(x, x.a)
+  END Condition;
+
+  PROCEDURE Open*(v: INTEGER);
+  BEGIN pc := 0; tdx := 0; strx := 0; RH := 0; fixorgP := 0; fixorgD := 0; fixorgT := 0; check := v # 0; version := v;
+    IF v = 0 THEN pc := 1;
+      REPEAT code[pc] := 0; INC(pc) UNTIL pc = 8
+    END
+  END Open;
+
+  PROCEDURE SetDataSize*(dc: LONGINT);
+  BEGIN varsize := dc
+  END SetDataSize;
+
+  PROCEDURE Header*;
+  BEGIN entry := pc*4;
+    IF version = 0 THEN code[0] := 0E7000000H-1 + pc;  Put1a(Mov, SP, 0, StkOrg0)  (*RISC-0*)
+    ELSE Put1(Sub, SP, SP, 4); Put2(Str, LNK, SP, 0)
+    END
+  END Header;
+
+  PROCEDURE NofPtrs(typ: ORB.Type): LONGINT;
+    VAR fld: ORB.Object; n: LONGINT;
+  BEGIN
+    IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN n := 1
+    ELSIF typ.form = ORB.Record THEN
+      fld := typ.dsc; n := 0;
+      WHILE fld # NIL DO n := NofPtrs(fld.type) + n; fld := fld.next END
+    ELSIF typ.form = ORB.Array THEN n := NofPtrs(typ.base) * typ.len
+    ELSE n := 0
+    END ;
+    RETURN n
+  END NofPtrs;
+
+  PROCEDURE FindPtrs(VAR R: Files.Rider; typ: ORB.Type; adr: LONGINT);
+    VAR fld: ORB.Object; i, s: LONGINT;
+  BEGIN
+    IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN Files.WriteInt(R, adr)
+    ELSIF typ.form = ORB.Record THEN
+      fld := typ.dsc;
+      WHILE fld # NIL DO FindPtrs(R, fld.type, fld.val + adr); fld := fld.next END
+    ELSIF typ.form = ORB.Array THEN
+      s := typ.base.size;
+      FOR i := 0 TO typ.len-1 DO FindPtrs(R, typ.base, i*s + adr) END
+    END
+  END FindPtrs;
+
+  PROCEDURE Close*(VAR modid: ORS.Ident; key, nofent: LONGINT);
+    VAR obj: ORB.Object;
+      i, comsize, nofimps, nofptrs, size: LONGINT;
+      name: ORS.Ident;
+      F: Files.File; R: Files.Rider;
+  BEGIN  (*exit code*)
+    IF version = 0 THEN Put1(Mov, 0, 0, 0); Put3(BR, 7, 0)  (*RISC-0*)
+    ELSE Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, 4); Put3(BR, 7, LNK)
+    END ;
+    obj := ORB.topScope.next; nofimps := 0; comsize := 4; nofptrs := 0;
+    WHILE obj # NIL DO
+      IF (obj.class = ORB.Mod) & (obj.dsc # ORB.system) THEN INC(nofimps) (*count imports*)
+      ELSIF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc)
+          & (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN i := 0; (*count commands*)
+        WHILE obj.name[i] # 0X DO INC(i) END ;
+        i := (i+4) DIV 4 * 4; INC(comsize, i+4)
+      ELSIF obj.class = ORB.Var THEN INC(nofptrs, NofPtrs(obj.type))  (*count pointers*)
+      END ;
+      obj := obj.next
+    END ;
+    size := varsize + strx + comsize + (pc + nofimps + nofent + nofptrs + 1)*4;  (*varsize includes type descriptors*)
+    
+    ORB.MakeFileName(name, modid, ".rsc"); (*write code file*)
+    F := Files.New(name); Files.Set(R, F, 0); Files.WriteString(R, modid); Files.WriteInt(R, key); Files.Write(R, CHR(version));
+    Files.WriteInt(R, size);
+    obj := ORB.topScope.next;
+    WHILE (obj # NIL) & (obj.class = ORB.Mod) DO  (*imports*)
+      IF obj.dsc # ORB.system THEN Files.WriteString(R, obj(ORB.Module).orgname); Files.WriteInt(R, obj.val) END ;
+      obj := obj.next
+    END ;
+    Files.Write(R, 0X);
+    Files.WriteInt(R, tdx*4);
+    i := 0;
+    WHILE i < tdx DO Files.WriteInt(R, data[i]); INC(i) END ; (*type descriptors*)
+    Files.WriteInt(R, varsize - tdx*4);  (*data*)
+    Files.WriteInt(R, strx);
+    FOR i := 0 TO strx-1 DO Files.Write(R, str[i]) END ;  (*strings*)
+    Files.WriteInt(R, pc);  (*code len*)
+    FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ;  (*program*)
+    obj := ORB.topScope.next;
+    WHILE obj # NIL DO  (*commands*)
+      IF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) &
+          (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN
+        Files.WriteString(R, obj.name); Files.WriteInt(R, obj.val)
+      END ;
+      obj := obj.next
+    END ;
+    Files.Write(R, 0X);
+    Files.WriteInt(R, nofent); Files.WriteInt(R, entry);
+    obj := ORB.topScope.next;
+    WHILE obj # NIL DO  (*entries*)
+      IF obj.exno # 0 THEN
+        IF (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) OR (obj.class = ORB.Var) THEN
+          Files.WriteInt(R, obj.val);
+        ELSIF obj.class = ORB.Typ THEN
+          IF obj.type.form = ORB.Record THEN Files.WriteInt(R,  obj.type.len MOD 10000H)
+          ELSIF (obj.type.form = ORB.Pointer) & ((obj.type.base.typobj = NIL) OR (obj.type.base.typobj.exno = 0)) THEN
+            Files.WriteInt(R,  obj.type.base.len MOD 10000H)
+          END
+        END
+      END ;
+      obj := obj.next
+    END ;
+    obj := ORB.topScope.next;
+    WHILE obj # NIL DO  (*pointer variables*)
+      IF obj.class = ORB.Var THEN FindPtrs(R, obj.type, obj.val) END ;
+      obj := obj.next
+    END ;
+    Files.WriteInt(R, -1);
+    Files.WriteInt(R, fixorgP); Files.WriteInt(R, fixorgD); Files.WriteInt(R, fixorgT); Files.WriteInt(R, entry);
+    Files.Write(R, "O"); Files.Register(F)
+  END Close;
+
+BEGIN relmap[0] := 1; relmap[1] := 9; relmap[2] := 5; relmap[3] := 6; relmap[4] := 14; relmap[5] := 13;
+END ORG.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/ORP.Mod.txt

@@ -1,997 +1,997 @@
-MODULE ORP; (*N. Wirth 1.7.97 / 17.9.2018  Oberon compiler for RISC in Oberon-07*)
-  IMPORT Texts, Oberon, ORS, ORB, ORG;
-  (*Author: Niklaus Wirth, 2014.
-    Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens),
-    ORB for definition of data structures and for handling import and export, and
-    ORG to produce binary code. ORP performs type checking and data allocation.
-    Parser is target-independent, except for part of the handling of allocations.*)
-
-  TYPE PtrBase = POINTER TO PtrBaseDesc;
-    PtrBaseDesc = RECORD  (*list of names of pointer base types*)
-      name: ORS.Ident; type: ORB.Type; next: PtrBase
-    END ;
-  
-  VAR sym: INTEGER;   (*last symbol read*)
-    dc: LONGINT;    (*data counter*)
-    level, exno, version: INTEGER;
-    newSF: BOOLEAN;  (*option flag*)
-    expression: PROCEDURE (VAR x: ORG.Item);  (*to avoid forward reference*)
-    Type: PROCEDURE (VAR type: ORB.Type);
-    FormalType: PROCEDURE (VAR typ: ORB.Type; dim: INTEGER);
-    modid: ORS.Ident;
-    pbsList: PtrBase;   (*list of names of pointer base types*)
-    dummy: ORB.Object;
-    W: Texts.Writer;
-
-  PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR);
-  BEGIN
-    IF sym = s THEN ORS.Get(sym) ELSE ORS.Mark(msg) END
-  END Check;
-
-  PROCEDURE qualident(VAR obj: ORB.Object);
-  BEGIN obj := ORB.thisObj(); ORS.Get(sym);
-    IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END ;
-    IF (sym = ORS.period) & (obj.class = ORB.Mod) THEN
-      ORS.Get(sym);
-      IF sym = ORS.ident THEN obj := ORB.thisimport(obj); ORS.Get(sym);
-        IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END
-      ELSE ORS.Mark("identifier expected"); obj := dummy
-      END
-    END
-  END qualident;
-
-  PROCEDURE CheckBool(VAR x: ORG.Item);
-  BEGIN
-    IF x.type.form # ORB.Bool THEN ORS.Mark("not Boolean"); x.type := ORB.boolType END
-  END CheckBool;
-
-  PROCEDURE CheckInt(VAR x: ORG.Item);
-  BEGIN
-    IF x.type.form # ORB.Int THEN ORS.Mark("not Integer"); x.type := ORB.intType END
-  END CheckInt;
-
-  PROCEDURE CheckReal(VAR x: ORG.Item);
-  BEGIN
-    IF x.type.form # ORB.Real THEN ORS.Mark("not Real"); x.type := ORB.realType END
-  END CheckReal;
-
-  PROCEDURE CheckSet(VAR x: ORG.Item);
-  BEGIN
-    IF x.type.form # ORB.Set THEN ORS.Mark("not Set"); x.type := ORB.setType END 
-  END CheckSet;
-
-  PROCEDURE CheckSetVal(VAR x: ORG.Item);
-  BEGIN
-    IF x.type.form # ORB.Int THEN ORS.Mark("not Int"); x.type := ORB.setType
-    ELSIF x.mode = ORB.Const THEN
-      IF (x.a < 0) OR (x.a >= 32) THEN ORS.Mark("invalid set") END
-    END 
-  END CheckSetVal;
-
-  PROCEDURE CheckConst(VAR x: ORG.Item);
-  BEGIN
-    IF x.mode # ORB.Const THEN ORS.Mark("not a constant"); x.mode := ORB.Const END
-  END CheckConst;
-
-  PROCEDURE CheckReadOnly(VAR x: ORG.Item);
-  BEGIN
-    IF x.rdo THEN ORS.Mark("read-only") END
-  END CheckReadOnly;
-
-  PROCEDURE CheckExport(VAR expo: BOOLEAN);
-  BEGIN
-    IF sym = ORS.times THEN
-      expo := TRUE; ORS.Get(sym);
-      IF level # 0 THEN ORS.Mark("remove asterisk") END
-    ELSE expo := FALSE
-    END
-  END CheckExport;
-
-  PROCEDURE IsExtension(t0, t1: ORB.Type): BOOLEAN;
-  BEGIN (*t1 is an extension of t0*)
-    RETURN (t0 = t1) OR (t1 # NIL) & IsExtension(t0, t1.base)
-  END IsExtension;
-
-  (* expressions *)
-
-  PROCEDURE TypeTest(VAR x: ORG.Item; T: ORB.Type; guard: BOOLEAN);
-    VAR xt: ORB.Type;
-  BEGIN xt := x.type;
-    IF (T.form = xt.form ) & ((T.form = ORB.Pointer) OR (T.form = ORB.Record) & (x.mode = ORB.Par)) THEN
-      WHILE (xt # T) & (xt # NIL) DO xt := xt.base END ;
-      IF xt # T THEN xt := x.type;
-        IF xt.form = ORB.Pointer THEN
-          IF IsExtension(xt.base, T.base) THEN ORG.TypeTest(x, T.base, FALSE, guard); x.type := T
-          ELSE ORS.Mark("not an extension")
-          END
-        ELSIF (xt.form = ORB.Record) & (x.mode = ORB.Par) THEN
-          IF IsExtension(xt, T) THEN  ORG.TypeTest(x, T, TRUE, guard); x.type := T
-          ELSE ORS.Mark("not an extension")
-          END
-        ELSE ORS.Mark("incompatible types")
-        END
-      ELSIF ~guard THEN ORG.MakeConstItem(x, ORB.boolType, 1)
-      END
-    ELSE ORS.Mark("type mismatch")
-    END ;
-    IF ~guard THEN x.type := ORB.boolType END
-  END TypeTest;
-
-  PROCEDURE selector(VAR x: ORG.Item);
-    VAR y: ORG.Item; obj: ORB.Object;
-  BEGIN
-    WHILE (sym = ORS.lbrak) OR (sym = ORS.period) OR (sym = ORS.arrow)
-        OR (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) DO
-      IF sym = ORS.lbrak THEN
-        REPEAT ORS.Get(sym); expression(y);
-          IF x.type.form = ORB.Array THEN
-            CheckInt(y); ORG.Index(x, y); x.type := x.type.base
-          ELSE ORS.Mark("not an array")
-          END
-        UNTIL sym # ORS.comma;
-        Check(ORS.rbrak, "no ]")
-      ELSIF sym = ORS.period THEN ORS.Get(sym);
-        IF sym = ORS.ident THEN
-          IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base END ;
-          IF x.type.form = ORB.Record THEN
-            obj := ORB.thisfield(x.type); ORS.Get(sym);
-            IF obj # NIL THEN ORG.Field(x, obj); x.type := obj.type
-            ELSE ORS.Mark("undef")
-            END
-          ELSE ORS.Mark("not a record")
-          END
-        ELSE ORS.Mark("ident?")
-        END
-      ELSIF sym = ORS.arrow THEN
-        ORS.Get(sym);
-        IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base
-        ELSE ORS.Mark("not a pointer")
-        END
-      ELSIF (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) THEN (*type guard*)
-        ORS.Get(sym);
-        IF sym = ORS.ident THEN
-          qualident(obj);
-          IF obj.class = ORB.Typ THEN TypeTest(x, obj.type, TRUE)
-          ELSE ORS.Mark("guard type expected")
-          END
-        ELSE ORS.Mark("not an identifier")
-        END ;
-        Check(ORS.rparen, " ) missing")
-      END
-    END
-  END selector;
-
-  PROCEDURE EqualSignatures(t0, t1: ORB.Type): BOOLEAN;
-    VAR p0, p1: ORB.Object; com: BOOLEAN;
-  BEGIN com := TRUE;
-    IF (t0.base = t1.base) & (t0.nofpar = t1.nofpar) THEN
-      p0 := t0.dsc; p1 := t1.dsc;
-      WHILE p0 # NIL DO
-        IF (p0.class = p1.class) &  (p0.rdo = p1.rdo) &
-          ((p0.type = p1.type) OR
-          (p0.type.form = ORB.Array) & (p1.type.form = ORB.Array) & (p0.type.len = p1.type.len) & (p0.type.base = p1.type.base) OR
-          (p0.type.form = ORB.Proc) & (p1.type.form = ORB.Proc) & EqualSignatures(p0.type, p1.type))
-        THEN p0 := p0.next; p1 := p1.next
-        ELSE p0 := NIL; com := FALSE
-        END
-      END
-    ELSE com := FALSE
-    END ;
-    RETURN com
-  END EqualSignatures;
-
-  PROCEDURE CompTypes(t0, t1: ORB.Type; varpar: BOOLEAN): BOOLEAN;
-  BEGIN (*check for assignment compatibility*)
-    RETURN (t0 = t1)    (*openarray assignment disallowed in ORG*)
-      OR (t0.form = ORB.Array) & (t1.form = ORB.Array) & (t0.base =  t1.base) & (t0.len = t1.len)
-      OR (t0.form = ORB.Record) & (t1.form = ORB.Record)  & IsExtension(t0, t1)
-      OR ~varpar &
-        ((t0.form = ORB.Pointer) & (t1.form = ORB.Pointer)  & IsExtension(t0.base, t1.base)
-        OR (t0.form = ORB.Proc) & (t1.form = ORB.Proc) & EqualSignatures(t0, t1)
-        OR (t0.form IN {ORB.Pointer, ORB.Proc}) & (t1.form = ORB.NilTyp))
-  END CompTypes;
-
-  PROCEDURE Parameter(par: ORB.Object);
-    VAR x: ORG.Item; varpar: BOOLEAN;
-  BEGIN expression(x);
-    IF par # NIL THEN
-      varpar := par.class = ORB.Par;
-      IF CompTypes(par.type, x.type, varpar) THEN
-        IF ~varpar THEN ORG.ValueParam(x)
-        ELSE (*par.class = Par*)
-          IF ~par.rdo THEN CheckReadOnly(x) END ;
-          ORG.VarParam(x, par.type)
-        END
-      ELSIF (x.type.form = ORB.Array) & (par.type.form = ORB.Array) &
-          (x.type.base = par.type.base) & (par.type.len < 0) THEN
-        IF ~par.rdo THEN CheckReadOnly(x) END ;
-        ORG.OpenArrayParam(x)
-      ELSIF (x.type.form = ORB.String) & varpar & par.rdo & (par.type.form = ORB.Array) & 
-          (par.type.base.form = ORB.Char) & (par.type.len < 0) THEN ORG.StringParam(x)
-      ELSIF ~varpar & (par.type.form = ORB.Int) & (x.type.form = ORB.Int) THEN ORG.ValueParam(x)  (*BYTE*)
-      ELSIF (x.type.form = ORB.String) & (x.b = 2) & (par.class = ORB.Var) & (par.type.form = ORB.Char) THEN
-        ORG.StrToChar(x); ORG.ValueParam(x)
-      ELSIF (par.type.form = ORB.Array) & (par.type.base = ORB.byteType) & 
-          (par.type.len >= 0) & (par.type.size = x.type.size) THEN
-        ORG.VarParam(x, par.type)
-      ELSE ORS.Mark("incompatible parameters")
-      END
-    END
-  END Parameter;
-
-  PROCEDURE ParamList(VAR x: ORG.Item);
-    VAR n: INTEGER; par: ORB.Object;
-  BEGIN par := x.type.dsc; n := 0;
-    IF sym # ORS.rparen THEN
-      Parameter(par); n := 1;
-      WHILE sym <= ORS.comma DO
-        Check(sym, "comma?");
-        IF par # NIL THEN par := par.next END ;
-        INC(n); Parameter(par)
-      END ;
-      Check(ORS.rparen, ") missing")
-    ELSE ORS.Get(sym);
-    END ;
-    IF n < x.type.nofpar THEN ORS.Mark("too few params")
-    ELSIF n > x.type.nofpar THEN ORS.Mark("too many params")
-    END
-  END ParamList;
-
-  PROCEDURE StandFunc(VAR x: ORG.Item; fct: LONGINT; restyp: ORB.Type);
-    VAR y: ORG.Item; n, npar: LONGINT;
-  BEGIN Check(ORS.lparen, "no (");
-    npar := fct MOD 10; fct := fct DIV 10; expression(x); n := 1;
-    WHILE sym = ORS.comma DO ORS.Get(sym); expression(y); INC(n) END ;
-    Check(ORS.rparen, "no )");
-    IF n = npar THEN
-      IF fct = 0 THEN (*ABS*)
-        IF x.type.form IN {ORB.Int, ORB.Real} THEN ORG.Abs(x); restyp := x.type ELSE ORS.Mark("bad type") END
-      ELSIF fct = 1 THEN (*ODD*) CheckInt(x); ORG.Odd(x)
-      ELSIF fct = 2 THEN (*FLOOR*) CheckReal(x); ORG.Floor(x)
-      ELSIF fct = 3 THEN (*FLT*) CheckInt(x); ORG.Float(x)
-      ELSIF fct = 4 THEN (*ORD*)
-        IF x.type.form <= ORB.Proc THEN ORG.Ord(x)
-        ELSIF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x)
-        ELSE ORS.Mark("bad type")
-        END
-      ELSIF fct = 5 THEN (*CHR*) CheckInt(x); ORG.Ord(x)
-      ELSIF fct = 6 THEN (*LEN*)
-          IF x.type.form = ORB.Array THEN ORG.Len(x) ELSE ORS.Mark("not an array") END
-      ELSIF fct IN {7, 8, 9} THEN (*LSL, ASR, ROR*) CheckInt(y);
-        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
-      ELSIF fct = 11 THEN (*ADC*) ORG.ADC(x, y)
-      ELSIF fct = 12 THEN (*SBC*) ORG.SBC(x, y)
-      ELSIF fct = 13 THEN (*UML*) ORG.UML(x, y)
-      ELSIF fct = 14 THEN (*BIT*) CheckInt(x); CheckInt(y); ORG.Bit(x, y)
-      ELSIF fct = 15 THEN (*REG*) CheckConst(x); CheckInt(x); ORG.Register(x)
-      ELSIF fct = 16 THEN (*VAL*)
-        IF (x.mode= ORB.Typ) & (x.type.size <= y.type.size) THEN restyp := x.type; x := y
-        ELSE ORS.Mark("casting not allowed")
-        END
-      ELSIF fct = 17 THEN (*ADR*) ORG.Adr(x)
-      ELSIF fct = 18 THEN (*SIZE*)
-        IF x.mode = ORB.Typ THEN ORG.MakeConstItem(x, ORB.intType, x.type.size)
-        ELSE ORS.Mark("must be a type")
-        END
-      ELSIF fct = 19 THEN (*COND*) CheckConst(x); CheckInt(x); ORG.Condition(x)
-      ELSIF fct = 20 THEN (*H*) CheckConst(x); CheckInt(x); ORG.H(x)
-      END ;
-      x.type := restyp
-    ELSE ORS.Mark("wrong nof params")
-    END
-  END StandFunc;
-
-  PROCEDURE element(VAR x: ORG.Item);
-    VAR y: ORG.Item;
-  BEGIN expression(x); CheckSetVal(x);
-    IF sym = ORS.upto THEN ORS.Get(sym); expression(y); CheckSetVal(y); ORG.Set(x, y)
-    ELSE ORG.Singleton(x)
-    END ;
-    x.type := ORB.setType
-  END element;
-  
-  PROCEDURE set(VAR x: ORG.Item);
-    VAR y: ORG.Item;
-  BEGIN
-    IF sym >= ORS.if THEN
-      IF sym # ORS.rbrace THEN ORS.Mark(" } missing") END ;
-      ORG.MakeConstItem(x, ORB.setType, 0) (*empty set*)
-    ELSE element(x);
-      WHILE (sym < ORS.rparen) OR (sym > ORS.rbrace) DO
-        IF sym = ORS.comma THEN ORS.Get(sym)
-        ELSIF sym # ORS.rbrace THEN ORS.Mark("missing comma")
-        END ;
-        element(y); ORG.SetOp(ORS.plus, x, y)
-      END
-    END
-  END set; 
-
-  PROCEDURE factor(VAR x: ORG.Item);
-    VAR obj: ORB.Object; rx: LONGINT;
-  BEGIN (*sync*)
-    IF (sym < ORS.char) OR (sym > ORS.ident) THEN ORS.Mark("expression expected");
-      REPEAT ORS.Get(sym) UNTIL (sym >= ORS.char) & (sym <= ORS.for) OR (sym >= ORS.then)
-    END ;
-    IF sym = ORS.ident THEN
-      qualident(obj);  
-      IF obj.class = ORB.SFunc THEN StandFunc(x, obj.val, obj.type)
-      ELSE ORG.MakeItem(x, obj, level); selector(x);
-        IF sym = ORS.lparen THEN
-          ORS.Get(sym);
-          IF (x.type.form = ORB.Proc) & (x.type.base.form # ORB.NoTyp) THEN
-            ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx); x.type := x.type.base
-          ELSE ORS.Mark("not a function"); ParamList(x)
-          END
-        END
-      END
-    ELSIF sym = ORS.int THEN ORG.MakeConstItem(x, ORB.intType, ORS.ival); ORS.Get(sym)
-    ELSIF sym = ORS.real THEN ORG.MakeRealItem(x, ORS.rval); ORS.Get(sym)
-    ELSIF sym = ORS.char THEN ORG.MakeConstItem(x, ORB.charType, ORS.ival); ORS.Get(sym)
-    ELSIF sym = ORS.nil THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.nilType, 0)
-    ELSIF sym = ORS.string THEN ORG.MakeStringItem(x, ORS.slen); ORS.Get(sym)
-    ELSIF sym = ORS.lparen THEN ORS.Get(sym); expression(x); Check(ORS.rparen, "no )")
-    ELSIF sym = ORS.lbrace THEN ORS.Get(sym); set(x); Check(ORS.rbrace, "no }")
-    ELSIF sym = ORS.not THEN ORS.Get(sym); factor(x); CheckBool(x); ORG.Not(x)
-    ELSIF sym = ORS.false THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 0)
-    ELSIF sym = ORS.true THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 1)
-    ELSE ORS.Mark("not a factor"); ORG.MakeConstItem(x, ORB.intType, 0)
-    END
-  END factor;
-
-  PROCEDURE term(VAR x: ORG.Item);
-    VAR y: ORG.Item; op, f: INTEGER;
-  BEGIN factor(x); f := x.type.form;
-    WHILE (sym >= ORS.times) & (sym <= ORS.and) DO
-      op := sym; ORS.Get(sym);
-      IF op = ORS.times THEN
-        IF f = ORB.Int THEN factor(y); CheckInt(y); ORG.MulOp(x, y)
-        ELSIF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y)
-        ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y)
-        ELSE ORS.Mark("bad type")
-        END
-      ELSIF (op = ORS.div) OR (op = ORS.mod) THEN
-        CheckInt(x); factor(y); CheckInt(y); ORG.DivOp(op, x, y)
-      ELSIF op = ORS.rdiv THEN
-        IF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y)
-        ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y)
-        ELSE ORS.Mark("bad type")
-        END
-      ELSE (*op = and*) CheckBool(x); ORG.And1(x); factor(y); CheckBool(y); ORG.And2(x, y)
-      END
-    END
-  END term;
-
-  PROCEDURE SimpleExpression(VAR x: ORG.Item);
-    VAR y: ORG.Item; op: INTEGER;
-  BEGIN
-    IF sym = ORS.minus THEN ORS.Get(sym); term(x);
-      IF x.type.form IN {ORB.Int, ORB.Real, ORB.Set} THEN ORG.Neg(x) ELSE CheckInt(x) END
-    ELSIF sym = ORS.plus THEN ORS.Get(sym); term(x);
-    ELSE term(x)
-    END ;
-    WHILE (sym >= ORS.plus) & (sym <= ORS.or) DO
-      op := sym; ORS.Get(sym);
-      IF op = ORS.or THEN ORG.Or1(x); CheckBool(x); term(y); CheckBool(y); ORG.Or2(x, y)
-      ELSIF x.type.form = ORB.Int THEN term(y); CheckInt(y); ORG.AddOp(op, x, y)
-      ELSIF x.type.form = ORB.Real THEN term(y); CheckReal(y); ORG.RealOp(op, x, y)
-      ELSE CheckSet(x); term(y); CheckSet(y); ORG.SetOp(op, x, y)
-      END
-    END
-  END SimpleExpression;
-
-  PROCEDURE expression0(VAR x: ORG.Item);
-    VAR y: ORG.Item; obj: ORB.Object; rel, xf, yf: INTEGER;
-  BEGIN SimpleExpression(x);
-    IF (sym >= ORS.eql) & (sym <= ORS.geq) THEN
-      rel := sym; ORS.Get(sym); SimpleExpression(y); xf := x.type.form; yf := y.type.form;
-      IF x.type = y.type THEN
-        IF (xf IN {ORB.Char, ORB.Int}) THEN ORG.IntRelation(rel, x, y)
-        ELSIF xf = ORB.Real THEN ORG.RealRelation(rel, x, y)
-        ELSIF (xf IN {ORB.Set, ORB.Pointer, ORB.Proc, ORB.NilTyp, ORB.Bool}) THEN
-          IF rel <= ORS.neq THEN ORG.IntRelation(rel, x, y) ELSE ORS.Mark("only = or #") END
-        ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) OR (xf = ORB.String) THEN
-          ORG.StringRelation(rel, x, y)
-        ELSE ORS.Mark("illegal comparison")
-        END
-      ELSIF (xf IN {ORB.Pointer, ORB.Proc}) & (yf = ORB.NilTyp)
-          OR (yf IN {ORB.Pointer, ORB.Proc}) & (xf = ORB.NilTyp) THEN
-        IF rel <= ORS.neq THEN ORG.IntRelation(rel, x,  y) ELSE ORS.Mark("only = or #") END
-      ELSIF (xf = ORB.Pointer) & (yf = ORB.Pointer) &
-          (IsExtension(x.type.base, y.type.base) OR IsExtension(y.type.base, x.type.base))
-          OR (xf = ORB.Proc) & (yf = ORB.Proc) & EqualSignatures(x.type, y.type) THEN
-        IF rel <= ORS.neq THEN ORG.IntRelation(rel,  x, y) ELSE ORS.Mark("only = or #") END
-      ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) &
-            ((yf = ORB.String) OR (yf = ORB.Array) & (y.type.base.form = ORB.Char))
-          OR (yf = ORB.Array) & (y.type.base.form = ORB.Char) & (xf = ORB.String) THEN
-        ORG.StringRelation(rel, x, y)
-      ELSIF (xf = ORB.Char) & (yf = ORB.String) & (y.b = 2) THEN
-        ORG.StrToChar(y); ORG.IntRelation(rel, x, y)
-      ELSIF (yf = ORB.Char) & (xf = ORB.String) & (x.b = 2) THEN
-        ORG.StrToChar(x); ORG.IntRelation(rel, x, y)
-      ELSIF (xf = ORB.Int) & (yf = ORB.Int) THEN ORG.IntRelation(rel,  x, y)  (*BYTE*)
-      ELSE ORS.Mark("illegal comparison")
-      END ;
-      x.type := ORB.boolType
-    ELSIF sym = ORS.in THEN
-      ORS.Get(sym); CheckInt(x); SimpleExpression(y); CheckSet(y); ORG.In(x, y) ;
-      x.type := ORB.boolType
-    ELSIF sym = ORS.is THEN
-      ORS.Get(sym); qualident(obj); TypeTest(x, obj.type, FALSE) ;
-      x.type := ORB.boolType
-    END
-  END expression0;
-
-  (* statements *)
-
-  PROCEDURE StandProc(pno: LONGINT);
-    VAR nap, npar: LONGINT; (*nof actual/formal parameters*)
-      x, y, z: ORG.Item;
-  BEGIN Check(ORS.lparen, "no (");
-    npar := pno MOD 10; pno := pno DIV 10; expression(x); nap := 1;
-    IF sym = ORS.comma THEN
-      ORS.Get(sym); expression(y); nap := 2; z.type := ORB.noType;
-      WHILE sym = ORS.comma DO ORS.Get(sym); expression(z); INC(nap) END
-    ELSE y.type := ORB.noType
-    END ;
-    Check(ORS.rparen, "no )");
-    IF (npar = nap) OR (pno IN {0, 1}) THEN 
-      IF pno IN {0, 1} THEN (*INC, DEC*)
-        CheckInt(x); CheckReadOnly(x);
-        IF y.type # ORB.noType THEN CheckInt(y) END ;
-        ORG.Increment(pno, x, y)
-      ELSIF pno IN {2, 3} THEN (*INCL, EXCL*)
-        CheckSet(x); CheckReadOnly(x); CheckInt(y); ORG.Include(pno-2, x, y)
-      ELSIF pno = 4 THEN CheckBool(x); ORG.Assert(x)
-      ELSIF pno = 5 THEN(*NEW*) CheckReadOnly(x);
-         IF (x.type.form = ORB.Pointer) & (x.type.base.form = ORB.Record) THEN ORG.New(x)
-         ELSE ORS.Mark("not a pointer to record")
-         END
-      ELSIF pno = 6 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Pack(x, y)
-      ELSIF pno = 7 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Unpk(x, y)
-      ELSIF pno = 8 THEN
-        IF x.type.form <= ORB.Set THEN ORG.Led(x) ELSE ORS.Mark("bad type") END
-      ELSIF pno = 10 THEN CheckInt(x); ORG.Get(x, y)
-      ELSIF pno = 11 THEN CheckInt(x); ORG.Put(x, y)
-      ELSIF pno = 12 THEN CheckInt(x); CheckInt(y); CheckInt(z); ORG.Copy(x, y, z)
-      ELSIF pno = 13 THEN CheckConst(x); CheckInt(x); ORG.LDPSR(x)
-      ELSIF pno = 14 THEN CheckInt(x); ORG.LDREG(x, y)
-      END
-    ELSE ORS.Mark("wrong nof parameters")
-    END
-  END StandProc;
-
-  PROCEDURE StatSequence;
-    VAR obj: ORB.Object;
-      orgtype: ORB.Type; (*original type of case var*)
-      x, y, z, w: ORG.Item;
-      L0, L1, rx: LONGINT;
-
-    PROCEDURE TypeCase(obj: ORB.Object; VAR x: ORG.Item);
-      VAR typobj: ORB.Object;
-    BEGIN
-      IF sym = ORS.ident THEN
-        qualident(typobj); ORG.MakeItem(x, obj, level);
-        IF typobj.class # ORB.Typ THEN ORS.Mark("not a type") END ;
-        TypeTest(x, typobj.type, FALSE); obj.type := typobj.type;
-        ORG.CFJump(x); Check(ORS.colon, ": expected"); StatSequence
-      ELSE ORG.CFJump(x); ORS.Mark("type id expected")
-      END
-     END TypeCase;
-
-    PROCEDURE SkipCase;
-    BEGIN 
-      WHILE sym # ORS.colon DO ORS.Get(sym) END ;
-      ORS.Get(sym); StatSequence
-    END SkipCase;
-
-  BEGIN (* StatSequence *)
-    REPEAT (*sync*) obj := NIL;
-      IF ~((sym >= ORS.ident)  & (sym <= ORS.for) OR (sym >= ORS.semicolon)) THEN
-        ORS.Mark("statement expected");
-        REPEAT ORS.Get(sym) UNTIL (sym >= ORS.ident)
-      END ;
-      IF sym = ORS.ident THEN
-        qualident(obj); ORG.MakeItem(x, obj, level);
-        IF x.mode = ORB.SProc THEN StandProc(obj.val)
-        ELSE selector(x);
-          IF sym = ORS.becomes THEN (*assignment*)
-            ORS.Get(sym); CheckReadOnly(x); expression(y);
-            IF CompTypes(x.type, y.type, FALSE) THEN
-              IF (x.type.form <= ORB.Pointer) OR (x.type.form = ORB.Proc) THEN ORG.Store(x, y)
-              ELSE ORG.StoreStruct(x, y)
-              END
-            ELSIF (x.type.form = ORB.Array) & (y.type.form = ORB.Array) & (x.type.base = y.type.base) & (y.type.len < 0) THEN
-              ORG.StoreStruct(x, y)
-            ELSIF (x.type.form = ORB.Array) & (x.type.base.form = ORB.Char) & (y.type.form = ORB.String) THEN
-              ORG.CopyString(x, y)
-            ELSIF (x.type.form = ORB.Int) & (y.type.form = ORB.Int) THEN ORG.Store(x, y)  (*BYTE*)
-            ELSIF (x.type.form = ORB.Char) & (y.type.form = ORB.String) & (y.b = 2) THEN
-              ORG.StrToChar(y); ORG.Store(x, y)
-            ELSE ORS.Mark("illegal assignment")
-            END
-          ELSIF sym = ORS.eql THEN ORS.Mark("should be :="); ORS.Get(sym); expression(y)
-          ELSIF sym = ORS.lparen THEN (*procedure call*)
-            ORS.Get(sym);
-            IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN
-              ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx)
-            ELSE ORS.Mark("not a procedure"); ParamList(x)
-            END
-          ELSIF x.type.form = ORB.Proc THEN (*procedure call without parameters*)
-            IF x.type.nofpar > 0 THEN ORS.Mark("missing parameters") END ;
-            IF x.type.base.form = ORB.NoTyp THEN ORG.PrepCall(x, rx); ORG.Call(x, rx) ELSE ORS.Mark("not a procedure") END
-          ELSIF x.mode = ORB.Typ THEN ORS.Mark("illegal assignment")
-          ELSE ORS.Mark("not a procedure")
-          END
-        END
-      ELSIF sym = ORS.if THEN
-        ORS.Get(sym); expression(x); CheckBool(x); ORG.CFJump(x);
-        Check(ORS.then, "no THEN");
-        StatSequence; L0 := 0;
-        WHILE sym = ORS.elsif DO
-          ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); expression(x); CheckBool(x);
-          ORG.CFJump(x); Check(ORS.then, "no THEN"); StatSequence
-        END ;
-        IF sym = ORS.else THEN ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); StatSequence
-        ELSE ORG.Fixup(x)
-        END ;
-        ORG.FixLink(L0); Check(ORS.end, "no END")
-      ELSIF sym = ORS.while THEN
-        ORS.Get(sym); L0 := ORG.Here(); expression(x); CheckBool(x); ORG.CFJump(x);
-        Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0);
-        WHILE sym = ORS.elsif DO
-          ORS.Get(sym); ORG.Fixup(x); expression(x); CheckBool(x); ORG.CFJump(x);
-          Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0)
-        END ;
-        ORG.Fixup(x); Check(ORS.end, "no END")
-      ELSIF sym = ORS.repeat THEN
-        ORS.Get(sym); L0 := ORG.Here(); StatSequence;
-        IF sym = ORS.until THEN
-          ORS.Get(sym); expression(x); CheckBool(x); ORG.CBJump(x, L0)
-        ELSE ORS.Mark("missing UNTIL")
-        END
-      ELSIF sym = ORS.for THEN
-        ORS.Get(sym);
-        IF sym = ORS.ident THEN
-          qualident(obj); ORG.MakeItem(x, obj, level); CheckInt(x); CheckReadOnly(x);
-          IF sym = ORS.becomes THEN
-            ORS.Get(sym); expression(y); CheckInt(y); ORG.For0(x, y); L0 := ORG.Here();
-            Check(ORS.to, "no TO"); expression(z); CheckInt(z); obj.rdo := TRUE;
-            IF sym = ORS.by THEN ORS.Get(sym); expression(w); CheckConst(w); CheckInt(w)
-            ELSE ORG.MakeConstItem(w, ORB.intType, 1)
-            END ;
-            Check(ORS.do, "no DO"); ORG.For1(x, y, z, w, L1);
-            StatSequence; Check(ORS.end, "no END");
-            ORG.For2(x, y, w); ORG.BJump(L0); ORG.FixLink(L1); obj.rdo := FALSE
-          ELSE ORS.Mark(":= expected")
-          END
-        ELSE ORS.Mark("identifier expected")
-        END
-      ELSIF sym = ORS.case THEN
-        ORS.Get(sym);
-        IF sym = ORS.ident THEN
-          qualident(obj); orgtype := obj.type;
-          IF (orgtype.form = ORB.Pointer) OR (orgtype.form = ORB.Record) & (obj.class = ORB.Par) THEN
-            Check(ORS.of, "OF expected"); TypeCase(obj, x); L0 := 0;
-            WHILE sym = ORS.bar DO
-              ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype; TypeCase(obj, x)
-            END ;
-            ORG.Fixup(x); ORG.FixLink(L0); obj.type := orgtype
-          ELSE ORS.Mark("numeric case not implemented");
-            Check(ORS.of, "OF expected"); SkipCase;
-            WHILE sym = ORS.bar DO SkipCase END
-          END
-        ELSE ORS.Mark("ident expected")
-        END ;
-        Check(ORS.end, "no END")
-      END ;
-      ORG.CheckRegs;
-      IF sym = ORS.semicolon THEN ORS.Get(sym)
-      ELSIF sym < ORS.semicolon THEN ORS.Mark("missing semicolon?")
-      END
-    UNTIL sym > ORS.semicolon
-  END StatSequence;
-
-  (* Types and declarations *)
-
-  PROCEDURE IdentList(class: INTEGER; VAR first: ORB.Object);
-    VAR obj: ORB.Object;
-  BEGIN
-    IF sym = ORS.ident THEN
-      ORB.NewObj(first, ORS.id, class); ORS.Get(sym); CheckExport(first.expo);
-      WHILE sym = ORS.comma DO
-        ORS.Get(sym);
-        IF sym = ORS.ident THEN ORB.NewObj(obj, ORS.id, class); ORS.Get(sym); CheckExport(obj.expo)
-        ELSE ORS.Mark("ident?")
-        END
-      END;
-      IF sym = ORS.colon THEN ORS.Get(sym) ELSE ORS.Mark(":?") END
-    ELSE first := NIL
-    END
-  END IdentList;
-  
-  PROCEDURE ArrayType(VAR type: ORB.Type);
-    VAR x: ORG.Item; typ: ORB.Type; len: LONGINT;
-  BEGIN NEW(typ); typ.form := ORB.NoTyp;
-    expression(x);
-    IF (x.mode = ORB.Const) & (x.type.form = ORB.Int) & (x.a >= 0) THEN len := x.a
-    ELSE len := 1; ORS.Mark("not a valid length")
-    END ;
-    IF sym = ORS.of THEN ORS.Get(sym); Type(typ.base);
-      IF (typ.base.form = ORB.Array) & (typ.base.len < 0) THEN ORS.Mark("dyn array not allowed") END
-    ELSIF sym = ORS.comma THEN ORS.Get(sym); ArrayType(typ.base)
-    ELSE ORS.Mark("missing OF"); typ.base := ORB.intType
-    END ;
-    typ.size := (len * typ.base.size + 3) DIV 4 * 4;
-    typ.form := ORB.Array; typ.len := len; type := typ
-  END ArrayType;
-
-  PROCEDURE RecordType(VAR type: ORB.Type);
-    VAR obj, obj0, new, bot, base: ORB.Object;
-      typ, tp: ORB.Type;
-      offset, off, n: LONGINT;
-  BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := -level; typ.nofpar := 0; offset := 0; bot := NIL;
-    IF sym = ORS.lparen THEN
-      ORS.Get(sym); (*record extension*)
-      IF level # 0 THEN ORS.Mark("extension of local types not implemented") END ;
-      IF sym = ORS.ident THEN
-        qualident(base);
-        IF base.class = ORB.Typ THEN
-          IF base.type.form = ORB.Record THEN typ.base := base.type
-          ELSE typ.base := ORB.intType; ORS.Mark("invalid extension")
-          END ;
-          typ.nofpar := typ.base.nofpar + 1; (*"nofpar" here abused for extension level*)
-          bot := typ.base.dsc; offset := typ.base.size
-        ELSE ORS.Mark("type expected")
-        END
-      ELSE ORS.Mark("ident expected")
-      END ;
-      Check(ORS.rparen, "no )")
-    END ;
-    WHILE sym = ORS.ident DO  (*fields*)
-      n := 0; obj := bot;
-      WHILE sym = ORS.ident DO
-        obj0 := obj;
-        WHILE (obj0 # NIL) & (obj0.name # ORS.id) DO obj0 := obj0.next END ;
-        IF obj0 # NIL THEN ORS.Mark("mult def") END ;
-        NEW(new); ORS.CopyId(new.name); new.class := ORB.Fld; new.next := obj; obj := new; INC(n);
-        ORS.Get(sym); CheckExport(new.expo);
-        IF (sym # ORS.comma) & (sym # ORS.colon) THEN ORS.Mark("comma expected")
-        ELSIF sym = ORS.comma THEN ORS.Get(sym)
-        END
-      END ;
-      Check(ORS.colon, "colon expected"); Type(tp);
-      IF (tp.form = ORB.Array) & (tp.len < 0) THEN ORS.Mark("dyn array not allowed") END ;
-      IF tp.size > 1 THEN offset := (offset+3) DIV 4 * 4 END ;
-      offset := offset + n * tp.size; off := offset; obj0 := obj;
-      WHILE obj0 # bot DO obj0.type := tp; obj0.lev := 0; off := off - tp.size; obj0.val := off; obj0 := obj0.next END ;
-      bot := obj;
-      IF sym = ORS.semicolon THEN ORS.Get(sym) ELSIF sym # ORS.end THEN ORS.Mark(" ; or END") END
-    END ;
-    typ.form := ORB.Record; typ.dsc := bot; typ.size := (offset + 3) DIV 4 * 4; type := typ
-  END RecordType;
-
-  PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER);
-    VAR obj, first: ORB.Object; tp: ORB.Type;
-      parsize: LONGINT; cl: INTEGER; rdo: BOOLEAN;
-  BEGIN
-    IF sym = ORS.var THEN ORS.Get(sym); cl := ORB.Par ELSE cl := ORB.Var END ;
-    IdentList(cl, first); FormalType(tp, 0); rdo := FALSE;
-    IF (cl = ORB.Var) & (tp.form >= ORB.Array) THEN cl := ORB.Par; rdo := TRUE END ;
-    IF (tp.form = ORB.Array) & (tp.len < 0) OR (tp.form = ORB.Record) THEN
-      parsize := 2*ORG.WordSize  (*open array or record, needs second word for length or type tag*)
-    ELSE parsize := ORG.WordSize
-    END ;
-    obj := first;
-    WHILE obj # NIL DO
-      INC(nofpar); obj.class := cl; obj.type := tp; obj.rdo := rdo; obj.lev := level; obj.val := adr;
-      adr := adr + parsize; obj := obj.next
-    END ;
-    IF adr >= 52 THEN ORS.Mark("too many parameters") END
-  END FPSection;
-
-  PROCEDURE ProcedureType(ptype: ORB.Type; VAR parblksize: LONGINT);
-    VAR obj: ORB.Object; size: LONGINT; nofpar: INTEGER;
-  BEGIN ptype.base := ORB.noType; size := parblksize; nofpar := 0; ptype.dsc := NIL;
-    IF sym = ORS.lparen THEN
-      ORS.Get(sym);
-      IF sym = ORS.rparen THEN ORS.Get(sym)
-      ELSE FPSection(size, nofpar);
-        WHILE sym = ORS.semicolon DO ORS.Get(sym); FPSection(size, nofpar) END ;
-        Check(ORS.rparen, "no )")
-      END ;
-      IF sym = ORS.colon THEN  (*function*)
-        ORS.Get(sym);
-        IF sym = ORS.ident THEN
-          qualident(obj); ptype.base := obj.type;
-          IF ~((obj.class = ORB.Typ) & (obj.type.form IN {ORB.Byte .. ORB.Pointer, ORB.Proc})) THEN
-            ORS.Mark("illegal function type")
-          END
-        ELSE ORS.Mark("type identifier expected")
-        END
-      END
-    END ;
-    ptype.nofpar := nofpar; parblksize := size
-  END ProcedureType;
-
-  PROCEDURE FormalType0(VAR typ: ORB.Type; dim: INTEGER);
-    VAR obj: ORB.Object; dmy: LONGINT;
-  BEGIN
-    IF sym = ORS.ident THEN
-      qualident(obj);
-      IF obj.class = ORB.Typ THEN typ := obj.type ELSE ORS.Mark("not a type"); typ := ORB.intType END
-    ELSIF sym = ORS.array THEN
-      ORS.Get(sym); Check(ORS.of, "OF ?");
-      IF dim >= 1 THEN ORS.Mark("multi-dimensional open arrays not implemented") END ;
-      NEW(typ); typ.form := ORB.Array; typ.len := -1; typ.size := 2*ORG.WordSize; 
-      FormalType(typ.base, dim+1)
-    ELSIF sym = ORS.procedure THEN
-      ORS.Get(sym); ORB.OpenScope;
-      NEW(typ); typ.form := ORB.Proc; typ.size := ORG.WordSize; dmy := 0; ProcedureType(typ, dmy);
-      typ.dsc := ORB.topScope.next; ORB.CloseScope
-    ELSE ORS.Mark("identifier expected"); typ := ORB.noType
-    END
-  END FormalType0;
-
-  PROCEDURE CheckRecLevel(lev: INTEGER);
-  BEGIN
-    IF lev # 0 THEN ORS.Mark("ptr base must be global") END
-  END CheckRecLevel;
-
-  PROCEDURE Type0(VAR type: ORB.Type);
-    VAR dmy: LONGINT; obj: ORB.Object; ptbase: PtrBase;
-  BEGIN type := ORB.intType; (*sync*)
-    IF (sym # ORS.ident) & (sym < ORS.array) THEN ORS.Mark("not a type");
-      REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.array)
-    END ;
-    IF sym = ORS.ident THEN
-      qualident(obj);
-      IF obj.class = ORB.Typ THEN
-        IF (obj.type # NIL) & (obj.type.form # ORB.NoTyp) THEN type := obj.type END
-      ELSE ORS.Mark("not a type or undefined")
-      END
-    ELSIF sym = ORS.array THEN ORS.Get(sym); ArrayType(type)
-    ELSIF sym = ORS.record THEN
-      ORS.Get(sym); RecordType(type); Check(ORS.end, "no END")
-    ELSIF sym = ORS.pointer THEN
-      ORS.Get(sym); Check(ORS.to, "no TO");
-      NEW(type);  type.form := ORB.Pointer; type.size := ORG.WordSize; type.base := ORB.intType;
-      IF sym = ORS.ident THEN
-        obj := ORB.thisObj();
-        IF obj # NIL THEN
-          IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN
-            CheckRecLevel(obj.lev); type.base := obj.type
-          ELSIF obj.class = ORB.Mod THEN ORS.Mark("external base type not implemented")
-          ELSE ORS.Mark("no valid base type")
-          END
-        ELSE CheckRecLevel(level); (*enter into list of forward references to be fixed in Declarations*)
-          NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase
-        END ;
-        ORS.Get(sym)
-      ELSE Type(type.base);
-        IF (type.base.form # ORB.Record) OR (type.base.typobj = NIL) THEN ORS.Mark("must point to named record") END ;
-        CheckRecLevel(level)
-      END
-    ELSIF sym = ORS.procedure THEN
-      ORS.Get(sym); ORB.OpenScope;
-      NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; dmy := 0;
-      ProcedureType(type, dmy); type.dsc := ORB.topScope.next; ORB.CloseScope
-    ELSE ORS.Mark("illegal type")
-    END
-  END Type0;
-
-  PROCEDURE Declarations(VAR varsize: LONGINT);
-    VAR obj, first: ORB.Object;
-      x: ORG.Item; tp: ORB.Type; ptbase: PtrBase;
-      expo: BOOLEAN; id: ORS.Ident;
-  BEGIN (*sync*) pbsList := NIL;
-    IF (sym < ORS.const) & (sym # ORS.end) & (sym # ORS.return) THEN ORS.Mark("declaration?");
-      REPEAT ORS.Get(sym) UNTIL (sym >= ORS.const) OR (sym = ORS.end) OR (sym = ORS.return)
-    END ;
-    IF sym = ORS.const THEN
-      ORS.Get(sym);
-      WHILE sym = ORS.ident DO
-        ORS.CopyId(id); ORS.Get(sym); CheckExport(expo);
-        IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("= ?") END;
-        expression(x);
-        IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) END ;
-        ORB.NewObj(obj, id, ORB.Const); obj.expo := expo;
-        IF x.mode = ORB.Const THEN obj.val := x.a; obj.lev := x.b; obj.type := x.type
-        ELSE ORS.Mark("expression not constant"); obj.type := ORB.intType
-        END;
-        Check(ORS.semicolon, "; missing")
-      END
-    END ;
-    IF sym = ORS.type THEN
-      ORS.Get(sym);
-      WHILE sym = ORS.ident DO
-        ORS.CopyId(id); ORS.Get(sym); CheckExport(expo);
-        IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("=?") END ;
-        Type(tp);
-        ORB.NewObj(obj, id, ORB.Typ); obj.type := tp; obj.expo := expo; obj.lev := level;
-        IF tp.typobj = NIL THEN tp.typobj := obj END ;
-        IF expo & (obj.type.form = ORB.Record) THEN obj.exno := exno; INC(exno) ELSE obj.exno := 0 END ;
-        IF tp.form = ORB.Record THEN
-          ptbase := pbsList;  (*check whether this is base of a pointer type; search and fixup*)
-          WHILE ptbase # NIL DO
-            IF obj.name = ptbase.name THEN ptbase.type.base := obj.type END ;
-            ptbase := ptbase.next
-          END ;
-          IF level = 0 THEN ORG.BuildTD(tp, dc) END    (*type descriptor; len used as its address*)
-        END ;
-        Check(ORS.semicolon, "; missing")
-      END
-    END ;
-    IF sym = ORS.var THEN
-      ORS.Get(sym);
-      WHILE sym = ORS.ident DO
-        IdentList(ORB.Var, first); Type(tp);
-        obj := first;
-        WHILE obj # NIL DO
-          obj.type := tp; obj.lev := level;
-          IF tp.size > 1 THEN varsize := (varsize + 3) DIV 4 * 4 (*align*) END ;
-          obj.val := varsize; varsize := varsize + obj.type.size;
-          IF obj.expo THEN obj.exno := exno; INC(exno) END ;
-          obj := obj.next
-        END ;
-        Check(ORS.semicolon, "; missing")
-      END
-    END ;
-    varsize := (varsize + 3) DIV 4 * 4;
-    ptbase := pbsList;
-    WHILE ptbase # NIL DO
-      IF ptbase.type.base.form = ORB.Int THEN ORS.Mark("undefined pointer base of") END ;
-      ptbase := ptbase.next
-    END ;
-    IF (sym >= ORS.const) & (sym <= ORS.var) THEN ORS.Mark("declaration in bad order") END
-  END Declarations;
-
-  PROCEDURE ProcedureDecl;
-    VAR proc: ORB.Object;
-      type: ORB.Type;
-      procid: ORS.Ident;
-      x: ORG.Item;
-      locblksize, parblksize, L: LONGINT;
-      int: BOOLEAN;
-  BEGIN (* ProcedureDecl *) int := FALSE; ORS.Get(sym); 
-    IF sym = ORS.times THEN ORS.Get(sym); int := TRUE END ;
-    IF sym = ORS.ident THEN
-      ORS.CopyId(procid); ORS.Get(sym);
-      ORB.NewObj(proc, ORS.id, ORB.Const);
-      IF int THEN parblksize := 12 ELSE parblksize := 4 END ;
-      NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize;
-      proc.type := type; proc.val := -1; proc.lev := level; 
-      CheckExport(proc.expo);
-      IF proc.expo THEN proc.exno := exno; INC(exno) END ;
-      ORB.OpenScope; INC(level); type.base := ORB.noType;
-      ProcedureType(type, parblksize);  (*formal parameter list*)
-      Check(ORS.semicolon, "no ;"); locblksize := parblksize; 
-      Declarations(locblksize);
-      proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next;
-      IF sym = ORS.procedure THEN
-        L := 0; ORG.FJump(L);
-        REPEAT ProcedureDecl; Check(ORS.semicolon, "no ;") UNTIL sym # ORS.procedure;
-        ORG.FixOne(L); proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next
-      END ;
-      ORG.Enter(parblksize, locblksize, int);
-      IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ;
-      IF sym = ORS.return THEN
-        ORS.Get(sym); expression(x);
-        IF type.base = ORB.noType THEN ORS.Mark("this is not a function")
-        ELSIF ~CompTypes(type.base, x.type, FALSE) THEN ORS.Mark("wrong result type")
-        END
-      ELSIF type.base.form # ORB.NoTyp THEN
-        ORS.Mark("function without result"); type.base := ORB.noType
-      END ;
-      ORG.Return(type.base.form, x, locblksize, int);
-      ORB.CloseScope; DEC(level); Check(ORS.end, "no END");
-      IF sym = ORS.ident THEN
-        IF ORS.id # procid THEN ORS.Mark("no match") END ;
-        ORS.Get(sym)
-      ELSE ORS.Mark("no proc id")
-      END
-    END
-  END ProcedureDecl;
-
-  PROCEDURE Module;
-    VAR key: LONGINT;
-      impid, impid1: ORS.Ident;
-  BEGIN Texts.WriteString(W, "  compiling "); ORS.Get(sym);
-    IF sym = ORS.module THEN
-      ORS.Get(sym);
-      IF sym = ORS.times THEN version := 0; Texts.Write(W, "*"); ORS.Get(sym) ELSE version := 1 END ;
-      ORB.Init; ORB.OpenScope;
-      IF sym = ORS.ident THEN
-        ORS.CopyId(modid); ORS.Get(sym);
-        Texts.WriteString(W, modid); Texts.Append(Oberon.Log, W.buf)
-      ELSE ORS.Mark("identifier expected")
-      END ;
-      Check(ORS.semicolon, "no ;"); level := 0; dc := 0; exno := 1; key := 0;
-      IF sym = ORS.import THEN
-        ORS.Get(sym);
-        WHILE sym = ORS.ident DO
-          ORS.CopyId(impid); ORS.Get(sym);
-          IF sym = ORS.becomes THEN
-            ORS.Get(sym);
-            IF sym = ORS.ident THEN ORS.CopyId(impid1); ORS.Get(sym)
-            ELSE ORS.Mark("id expected")
-            END
-          ELSE impid1 := impid
-          END ;
-          ORB.Import(impid, impid1);
-          IF sym = ORS.comma THEN ORS.Get(sym)
-          ELSIF sym = ORS.ident THEN ORS.Mark("comma missing")
-          END
-        END ;
-        Check(ORS.semicolon, "no ;")
-      END ;
-      ORG.Open(version); Declarations(dc); ORG.SetDataSize((dc + 3) DIV 4 * 4);
-      WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ;
-      ORG.Header;
-      IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ;
-      Check(ORS.end, "no END");
-      IF sym = ORS.ident THEN
-        IF ORS.id # modid THEN ORS.Mark("no match") END ;
-        ORS.Get(sym)
-      ELSE ORS.Mark("identifier missing")
-      END ;
-      IF sym # ORS.period THEN ORS.Mark("period missing") END ;
-      IF (ORS.errcnt = 0) & (version # 0) THEN
-        ORB.Export(modid, newSF, key);
-        IF newSF THEN Texts.WriteString(W, " new symbol file") END
-      END ;
-      IF ORS.errcnt = 0 THEN
-        ORG.Close(modid, key, exno);
-        Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteHex(W, key)
-      ELSE Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED")
-      END ;
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-      ORB.CloseScope; pbsList := NIL
-    ELSE ORS.Mark("must start with MODULE")
-    END
-  END Module;
-
-  PROCEDURE Option(VAR S: Texts.Scanner);
-  BEGIN newSF := FALSE;
-    IF S.nextCh = "/" THEN
-      Texts.Scan(S); Texts.Scan(S); 
-      IF (S.class = Texts.Name) & (S.s[0] = "s") THEN newSF := TRUE END
-    END
-  END Option;
-
-  PROCEDURE Compile*;
-    VAR beg, end, time: LONGINT;
-      T: Texts.Text;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Char THEN
-      IF S.c = "@" THEN
-        Option(S); Oberon.GetSelection(T, beg, end, time);
-        IF time >= 0 THEN ORS.Init(T, beg); Module END
-      ELSIF S.c = "^" THEN
-        Option(S); Oberon.GetSelection(T, beg, end, time);
-        IF time >= 0 THEN
-          Texts.OpenScanner(S, T, beg); Texts.Scan(S);
-          IF S.class = Texts.Name THEN
-            Texts.WriteString(W, S.s); NEW(T); Texts.Open(T, S.s);
-            IF T.len > 0 THEN ORS.Init(T, 0); Module END
-          END
-        END
-      END
-    ELSE 
-      WHILE S.class = Texts.Name DO
-        NEW(T); Texts.Open(T, S.s);
-        IF T.len > 0 THEN Option(S); ORS.Init(T, 0); Module
-        ELSE Texts.WriteString(W, S.s); Texts.WriteString(W, " not found");
-          Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-        END ;
-        IF (T.len # 0) & (ORS.errcnt = 0) THEN Texts.Scan(S) ELSE S.class := 0 END
-      END
-    END ;
-    Oberon.Collect(0)
-  END Compile;
-
-BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler  17.9.2018");
-  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-  NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType;
-  expression := expression0; Type := Type0; FormalType := FormalType0
-END ORP.
+MODULE ORP; (*N. Wirth 1.7.97 / 17.9.2018  Oberon compiler for RISC in Oberon-07*)
+  IMPORT Texts, Oberon, ORS, ORB, ORG;
+  (*Author: Niklaus Wirth, 2014.
+    Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens),
+    ORB for definition of data structures and for handling import and export, and
+    ORG to produce binary code. ORP performs type checking and data allocation.
+    Parser is target-independent, except for part of the handling of allocations.*)
+
+  TYPE PtrBase = POINTER TO PtrBaseDesc;
+    PtrBaseDesc = RECORD  (*list of names of pointer base types*)
+      name: ORS.Ident; type: ORB.Type; next: PtrBase
+    END ;
+  
+  VAR sym: INTEGER;   (*last symbol read*)
+    dc: LONGINT;    (*data counter*)
+    level, exno, version: INTEGER;
+    newSF: BOOLEAN;  (*option flag*)
+    expression: PROCEDURE (VAR x: ORG.Item);  (*to avoid forward reference*)
+    Type: PROCEDURE (VAR type: ORB.Type);
+    FormalType: PROCEDURE (VAR typ: ORB.Type; dim: INTEGER);
+    modid: ORS.Ident;
+    pbsList: PtrBase;   (*list of names of pointer base types*)
+    dummy: ORB.Object;
+    W: Texts.Writer;
+
+  PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR);
+  BEGIN
+    IF sym = s THEN ORS.Get(sym) ELSE ORS.Mark(msg) END
+  END Check;
+
+  PROCEDURE qualident(VAR obj: ORB.Object);
+  BEGIN obj := ORB.thisObj(); ORS.Get(sym);
+    IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END ;
+    IF (sym = ORS.period) & (obj.class = ORB.Mod) THEN
+      ORS.Get(sym);
+      IF sym = ORS.ident THEN obj := ORB.thisimport(obj); ORS.Get(sym);
+        IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END
+      ELSE ORS.Mark("identifier expected"); obj := dummy
+      END
+    END
+  END qualident;
+
+  PROCEDURE CheckBool(VAR x: ORG.Item);
+  BEGIN
+    IF x.type.form # ORB.Bool THEN ORS.Mark("not Boolean"); x.type := ORB.boolType END
+  END CheckBool;
+
+  PROCEDURE CheckInt(VAR x: ORG.Item);
+  BEGIN
+    IF x.type.form # ORB.Int THEN ORS.Mark("not Integer"); x.type := ORB.intType END
+  END CheckInt;
+
+  PROCEDURE CheckReal(VAR x: ORG.Item);
+  BEGIN
+    IF x.type.form # ORB.Real THEN ORS.Mark("not Real"); x.type := ORB.realType END
+  END CheckReal;
+
+  PROCEDURE CheckSet(VAR x: ORG.Item);
+  BEGIN
+    IF x.type.form # ORB.Set THEN ORS.Mark("not Set"); x.type := ORB.setType END 
+  END CheckSet;
+
+  PROCEDURE CheckSetVal(VAR x: ORG.Item);
+  BEGIN
+    IF x.type.form # ORB.Int THEN ORS.Mark("not Int"); x.type := ORB.setType
+    ELSIF x.mode = ORB.Const THEN
+      IF (x.a < 0) OR (x.a >= 32) THEN ORS.Mark("invalid set") END
+    END 
+  END CheckSetVal;
+
+  PROCEDURE CheckConst(VAR x: ORG.Item);
+  BEGIN
+    IF x.mode # ORB.Const THEN ORS.Mark("not a constant"); x.mode := ORB.Const END
+  END CheckConst;
+
+  PROCEDURE CheckReadOnly(VAR x: ORG.Item);
+  BEGIN
+    IF x.rdo THEN ORS.Mark("read-only") END
+  END CheckReadOnly;
+
+  PROCEDURE CheckExport(VAR expo: BOOLEAN);
+  BEGIN
+    IF sym = ORS.times THEN
+      expo := TRUE; ORS.Get(sym);
+      IF level # 0 THEN ORS.Mark("remove asterisk") END
+    ELSE expo := FALSE
+    END
+  END CheckExport;
+
+  PROCEDURE IsExtension(t0, t1: ORB.Type): BOOLEAN;
+  BEGIN (*t1 is an extension of t0*)
+    RETURN (t0 = t1) OR (t1 # NIL) & IsExtension(t0, t1.base)
+  END IsExtension;
+
+  (* expressions *)
+
+  PROCEDURE TypeTest(VAR x: ORG.Item; T: ORB.Type; guard: BOOLEAN);
+    VAR xt: ORB.Type;
+  BEGIN xt := x.type;
+    IF (T.form = xt.form ) & ((T.form = ORB.Pointer) OR (T.form = ORB.Record) & (x.mode = ORB.Par)) THEN
+      WHILE (xt # T) & (xt # NIL) DO xt := xt.base END ;
+      IF xt # T THEN xt := x.type;
+        IF xt.form = ORB.Pointer THEN
+          IF IsExtension(xt.base, T.base) THEN ORG.TypeTest(x, T.base, FALSE, guard); x.type := T
+          ELSE ORS.Mark("not an extension")
+          END
+        ELSIF (xt.form = ORB.Record) & (x.mode = ORB.Par) THEN
+          IF IsExtension(xt, T) THEN  ORG.TypeTest(x, T, TRUE, guard); x.type := T
+          ELSE ORS.Mark("not an extension")
+          END
+        ELSE ORS.Mark("incompatible types")
+        END
+      ELSIF ~guard THEN ORG.MakeConstItem(x, ORB.boolType, 1)
+      END
+    ELSE ORS.Mark("type mismatch")
+    END ;
+    IF ~guard THEN x.type := ORB.boolType END
+  END TypeTest;
+
+  PROCEDURE selector(VAR x: ORG.Item);
+    VAR y: ORG.Item; obj: ORB.Object;
+  BEGIN
+    WHILE (sym = ORS.lbrak) OR (sym = ORS.period) OR (sym = ORS.arrow)
+        OR (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) DO
+      IF sym = ORS.lbrak THEN
+        REPEAT ORS.Get(sym); expression(y);
+          IF x.type.form = ORB.Array THEN
+            CheckInt(y); ORG.Index(x, y); x.type := x.type.base
+          ELSE ORS.Mark("not an array")
+          END
+        UNTIL sym # ORS.comma;
+        Check(ORS.rbrak, "no ]")
+      ELSIF sym = ORS.period THEN ORS.Get(sym);
+        IF sym = ORS.ident THEN
+          IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base END ;
+          IF x.type.form = ORB.Record THEN
+            obj := ORB.thisfield(x.type); ORS.Get(sym);
+            IF obj # NIL THEN ORG.Field(x, obj); x.type := obj.type
+            ELSE ORS.Mark("undef")
+            END
+          ELSE ORS.Mark("not a record")
+          END
+        ELSE ORS.Mark("ident?")
+        END
+      ELSIF sym = ORS.arrow THEN
+        ORS.Get(sym);
+        IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base
+        ELSE ORS.Mark("not a pointer")
+        END
+      ELSIF (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) THEN (*type guard*)
+        ORS.Get(sym);
+        IF sym = ORS.ident THEN
+          qualident(obj);
+          IF obj.class = ORB.Typ THEN TypeTest(x, obj.type, TRUE)
+          ELSE ORS.Mark("guard type expected")
+          END
+        ELSE ORS.Mark("not an identifier")
+        END ;
+        Check(ORS.rparen, " ) missing")
+      END
+    END
+  END selector;
+
+  PROCEDURE EqualSignatures(t0, t1: ORB.Type): BOOLEAN;
+    VAR p0, p1: ORB.Object; com: BOOLEAN;
+  BEGIN com := TRUE;
+    IF (t0.base = t1.base) & (t0.nofpar = t1.nofpar) THEN
+      p0 := t0.dsc; p1 := t1.dsc;
+      WHILE p0 # NIL DO
+        IF (p0.class = p1.class) &  (p0.rdo = p1.rdo) &
+          ((p0.type = p1.type) OR
+          (p0.type.form = ORB.Array) & (p1.type.form = ORB.Array) & (p0.type.len = p1.type.len) & (p0.type.base = p1.type.base) OR
+          (p0.type.form = ORB.Proc) & (p1.type.form = ORB.Proc) & EqualSignatures(p0.type, p1.type))
+        THEN p0 := p0.next; p1 := p1.next
+        ELSE p0 := NIL; com := FALSE
+        END
+      END
+    ELSE com := FALSE
+    END ;
+    RETURN com
+  END EqualSignatures;
+
+  PROCEDURE CompTypes(t0, t1: ORB.Type; varpar: BOOLEAN): BOOLEAN;
+  BEGIN (*check for assignment compatibility*)
+    RETURN (t0 = t1)    (*openarray assignment disallowed in ORG*)
+      OR (t0.form = ORB.Array) & (t1.form = ORB.Array) & (t0.base =  t1.base) & (t0.len = t1.len)
+      OR (t0.form = ORB.Record) & (t1.form = ORB.Record)  & IsExtension(t0, t1)
+      OR ~varpar &
+        ((t0.form = ORB.Pointer) & (t1.form = ORB.Pointer)  & IsExtension(t0.base, t1.base)
+        OR (t0.form = ORB.Proc) & (t1.form = ORB.Proc) & EqualSignatures(t0, t1)
+        OR (t0.form IN {ORB.Pointer, ORB.Proc}) & (t1.form = ORB.NilTyp))
+  END CompTypes;
+
+  PROCEDURE Parameter(par: ORB.Object);
+    VAR x: ORG.Item; varpar: BOOLEAN;
+  BEGIN expression(x);
+    IF par # NIL THEN
+      varpar := par.class = ORB.Par;
+      IF CompTypes(par.type, x.type, varpar) THEN
+        IF ~varpar THEN ORG.ValueParam(x)
+        ELSE (*par.class = Par*)
+          IF ~par.rdo THEN CheckReadOnly(x) END ;
+          ORG.VarParam(x, par.type)
+        END
+      ELSIF (x.type.form = ORB.Array) & (par.type.form = ORB.Array) &
+          (x.type.base = par.type.base) & (par.type.len < 0) THEN
+        IF ~par.rdo THEN CheckReadOnly(x) END ;
+        ORG.OpenArrayParam(x)
+      ELSIF (x.type.form = ORB.String) & varpar & par.rdo & (par.type.form = ORB.Array) & 
+          (par.type.base.form = ORB.Char) & (par.type.len < 0) THEN ORG.StringParam(x)
+      ELSIF ~varpar & (par.type.form = ORB.Int) & (x.type.form = ORB.Int) THEN ORG.ValueParam(x)  (*BYTE*)
+      ELSIF (x.type.form = ORB.String) & (x.b = 2) & (par.class = ORB.Var) & (par.type.form = ORB.Char) THEN
+        ORG.StrToChar(x); ORG.ValueParam(x)
+      ELSIF (par.type.form = ORB.Array) & (par.type.base = ORB.byteType) & 
+          (par.type.len >= 0) & (par.type.size = x.type.size) THEN
+        ORG.VarParam(x, par.type)
+      ELSE ORS.Mark("incompatible parameters")
+      END
+    END
+  END Parameter;
+
+  PROCEDURE ParamList(VAR x: ORG.Item);
+    VAR n: INTEGER; par: ORB.Object;
+  BEGIN par := x.type.dsc; n := 0;
+    IF sym # ORS.rparen THEN
+      Parameter(par); n := 1;
+      WHILE sym <= ORS.comma DO
+        Check(sym, "comma?");
+        IF par # NIL THEN par := par.next END ;
+        INC(n); Parameter(par)
+      END ;
+      Check(ORS.rparen, ") missing")
+    ELSE ORS.Get(sym);
+    END ;
+    IF n < x.type.nofpar THEN ORS.Mark("too few params")
+    ELSIF n > x.type.nofpar THEN ORS.Mark("too many params")
+    END
+  END ParamList;
+
+  PROCEDURE StandFunc(VAR x: ORG.Item; fct: LONGINT; restyp: ORB.Type);
+    VAR y: ORG.Item; n, npar: LONGINT;
+  BEGIN Check(ORS.lparen, "no (");
+    npar := fct MOD 10; fct := fct DIV 10; expression(x); n := 1;
+    WHILE sym = ORS.comma DO ORS.Get(sym); expression(y); INC(n) END ;
+    Check(ORS.rparen, "no )");
+    IF n = npar THEN
+      IF fct = 0 THEN (*ABS*)
+        IF x.type.form IN {ORB.Int, ORB.Real} THEN ORG.Abs(x); restyp := x.type ELSE ORS.Mark("bad type") END
+      ELSIF fct = 1 THEN (*ODD*) CheckInt(x); ORG.Odd(x)
+      ELSIF fct = 2 THEN (*FLOOR*) CheckReal(x); ORG.Floor(x)
+      ELSIF fct = 3 THEN (*FLT*) CheckInt(x); ORG.Float(x)
+      ELSIF fct = 4 THEN (*ORD*)
+        IF x.type.form <= ORB.Proc THEN ORG.Ord(x)
+        ELSIF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x)
+        ELSE ORS.Mark("bad type")
+        END
+      ELSIF fct = 5 THEN (*CHR*) CheckInt(x); ORG.Ord(x)
+      ELSIF fct = 6 THEN (*LEN*)
+          IF x.type.form = ORB.Array THEN ORG.Len(x) ELSE ORS.Mark("not an array") END
+      ELSIF fct IN {7, 8, 9} THEN (*LSL, ASR, ROR*) CheckInt(y);
+        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
+      ELSIF fct = 11 THEN (*ADC*) ORG.ADC(x, y)
+      ELSIF fct = 12 THEN (*SBC*) ORG.SBC(x, y)
+      ELSIF fct = 13 THEN (*UML*) ORG.UML(x, y)
+      ELSIF fct = 14 THEN (*BIT*) CheckInt(x); CheckInt(y); ORG.Bit(x, y)
+      ELSIF fct = 15 THEN (*REG*) CheckConst(x); CheckInt(x); ORG.Register(x)
+      ELSIF fct = 16 THEN (*VAL*)
+        IF (x.mode= ORB.Typ) & (x.type.size <= y.type.size) THEN restyp := x.type; x := y
+        ELSE ORS.Mark("casting not allowed")
+        END
+      ELSIF fct = 17 THEN (*ADR*) ORG.Adr(x)
+      ELSIF fct = 18 THEN (*SIZE*)
+        IF x.mode = ORB.Typ THEN ORG.MakeConstItem(x, ORB.intType, x.type.size)
+        ELSE ORS.Mark("must be a type")
+        END
+      ELSIF fct = 19 THEN (*COND*) CheckConst(x); CheckInt(x); ORG.Condition(x)
+      ELSIF fct = 20 THEN (*H*) CheckConst(x); CheckInt(x); ORG.H(x)
+      END ;
+      x.type := restyp
+    ELSE ORS.Mark("wrong nof params")
+    END
+  END StandFunc;
+
+  PROCEDURE element(VAR x: ORG.Item);
+    VAR y: ORG.Item;
+  BEGIN expression(x); CheckSetVal(x);
+    IF sym = ORS.upto THEN ORS.Get(sym); expression(y); CheckSetVal(y); ORG.Set(x, y)
+    ELSE ORG.Singleton(x)
+    END ;
+    x.type := ORB.setType
+  END element;
+  
+  PROCEDURE set(VAR x: ORG.Item);
+    VAR y: ORG.Item;
+  BEGIN
+    IF sym >= ORS.if THEN
+      IF sym # ORS.rbrace THEN ORS.Mark(" } missing") END ;
+      ORG.MakeConstItem(x, ORB.setType, 0) (*empty set*)
+    ELSE element(x);
+      WHILE (sym < ORS.rparen) OR (sym > ORS.rbrace) DO
+        IF sym = ORS.comma THEN ORS.Get(sym)
+        ELSIF sym # ORS.rbrace THEN ORS.Mark("missing comma")
+        END ;
+        element(y); ORG.SetOp(ORS.plus, x, y)
+      END
+    END
+  END set; 
+
+  PROCEDURE factor(VAR x: ORG.Item);
+    VAR obj: ORB.Object; rx: LONGINT;
+  BEGIN (*sync*)
+    IF (sym < ORS.char) OR (sym > ORS.ident) THEN ORS.Mark("expression expected");
+      REPEAT ORS.Get(sym) UNTIL (sym >= ORS.char) & (sym <= ORS.for) OR (sym >= ORS.then)
+    END ;
+    IF sym = ORS.ident THEN
+      qualident(obj);  
+      IF obj.class = ORB.SFunc THEN StandFunc(x, obj.val, obj.type)
+      ELSE ORG.MakeItem(x, obj, level); selector(x);
+        IF sym = ORS.lparen THEN
+          ORS.Get(sym);
+          IF (x.type.form = ORB.Proc) & (x.type.base.form # ORB.NoTyp) THEN
+            ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx); x.type := x.type.base
+          ELSE ORS.Mark("not a function"); ParamList(x)
+          END
+        END
+      END
+    ELSIF sym = ORS.int THEN ORG.MakeConstItem(x, ORB.intType, ORS.ival); ORS.Get(sym)
+    ELSIF sym = ORS.real THEN ORG.MakeRealItem(x, ORS.rval); ORS.Get(sym)
+    ELSIF sym = ORS.char THEN ORG.MakeConstItem(x, ORB.charType, ORS.ival); ORS.Get(sym)
+    ELSIF sym = ORS.nil THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.nilType, 0)
+    ELSIF sym = ORS.string THEN ORG.MakeStringItem(x, ORS.slen); ORS.Get(sym)
+    ELSIF sym = ORS.lparen THEN ORS.Get(sym); expression(x); Check(ORS.rparen, "no )")
+    ELSIF sym = ORS.lbrace THEN ORS.Get(sym); set(x); Check(ORS.rbrace, "no }")
+    ELSIF sym = ORS.not THEN ORS.Get(sym); factor(x); CheckBool(x); ORG.Not(x)
+    ELSIF sym = ORS.false THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 0)
+    ELSIF sym = ORS.true THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 1)
+    ELSE ORS.Mark("not a factor"); ORG.MakeConstItem(x, ORB.intType, 0)
+    END
+  END factor;
+
+  PROCEDURE term(VAR x: ORG.Item);
+    VAR y: ORG.Item; op, f: INTEGER;
+  BEGIN factor(x); f := x.type.form;
+    WHILE (sym >= ORS.times) & (sym <= ORS.and) DO
+      op := sym; ORS.Get(sym);
+      IF op = ORS.times THEN
+        IF f = ORB.Int THEN factor(y); CheckInt(y); ORG.MulOp(x, y)
+        ELSIF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y)
+        ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y)
+        ELSE ORS.Mark("bad type")
+        END
+      ELSIF (op = ORS.div) OR (op = ORS.mod) THEN
+        CheckInt(x); factor(y); CheckInt(y); ORG.DivOp(op, x, y)
+      ELSIF op = ORS.rdiv THEN
+        IF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y)
+        ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y)
+        ELSE ORS.Mark("bad type")
+        END
+      ELSE (*op = and*) CheckBool(x); ORG.And1(x); factor(y); CheckBool(y); ORG.And2(x, y)
+      END
+    END
+  END term;
+
+  PROCEDURE SimpleExpression(VAR x: ORG.Item);
+    VAR y: ORG.Item; op: INTEGER;
+  BEGIN
+    IF sym = ORS.minus THEN ORS.Get(sym); term(x);
+      IF x.type.form IN {ORB.Int, ORB.Real, ORB.Set} THEN ORG.Neg(x) ELSE CheckInt(x) END
+    ELSIF sym = ORS.plus THEN ORS.Get(sym); term(x);
+    ELSE term(x)
+    END ;
+    WHILE (sym >= ORS.plus) & (sym <= ORS.or) DO
+      op := sym; ORS.Get(sym);
+      IF op = ORS.or THEN ORG.Or1(x); CheckBool(x); term(y); CheckBool(y); ORG.Or2(x, y)
+      ELSIF x.type.form = ORB.Int THEN term(y); CheckInt(y); ORG.AddOp(op, x, y)
+      ELSIF x.type.form = ORB.Real THEN term(y); CheckReal(y); ORG.RealOp(op, x, y)
+      ELSE CheckSet(x); term(y); CheckSet(y); ORG.SetOp(op, x, y)
+      END
+    END
+  END SimpleExpression;
+
+  PROCEDURE expression0(VAR x: ORG.Item);
+    VAR y: ORG.Item; obj: ORB.Object; rel, xf, yf: INTEGER;
+  BEGIN SimpleExpression(x);
+    IF (sym >= ORS.eql) & (sym <= ORS.geq) THEN
+      rel := sym; ORS.Get(sym); SimpleExpression(y); xf := x.type.form; yf := y.type.form;
+      IF x.type = y.type THEN
+        IF (xf IN {ORB.Char, ORB.Int}) THEN ORG.IntRelation(rel, x, y)
+        ELSIF xf = ORB.Real THEN ORG.RealRelation(rel, x, y)
+        ELSIF (xf IN {ORB.Set, ORB.Pointer, ORB.Proc, ORB.NilTyp, ORB.Bool}) THEN
+          IF rel <= ORS.neq THEN ORG.IntRelation(rel, x, y) ELSE ORS.Mark("only = or #") END
+        ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) OR (xf = ORB.String) THEN
+          ORG.StringRelation(rel, x, y)
+        ELSE ORS.Mark("illegal comparison")
+        END
+      ELSIF (xf IN {ORB.Pointer, ORB.Proc}) & (yf = ORB.NilTyp)
+          OR (yf IN {ORB.Pointer, ORB.Proc}) & (xf = ORB.NilTyp) THEN
+        IF rel <= ORS.neq THEN ORG.IntRelation(rel, x,  y) ELSE ORS.Mark("only = or #") END
+      ELSIF (xf = ORB.Pointer) & (yf = ORB.Pointer) &
+          (IsExtension(x.type.base, y.type.base) OR IsExtension(y.type.base, x.type.base))
+          OR (xf = ORB.Proc) & (yf = ORB.Proc) & EqualSignatures(x.type, y.type) THEN
+        IF rel <= ORS.neq THEN ORG.IntRelation(rel,  x, y) ELSE ORS.Mark("only = or #") END
+      ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) &
+            ((yf = ORB.String) OR (yf = ORB.Array) & (y.type.base.form = ORB.Char))
+          OR (yf = ORB.Array) & (y.type.base.form = ORB.Char) & (xf = ORB.String) THEN
+        ORG.StringRelation(rel, x, y)
+      ELSIF (xf = ORB.Char) & (yf = ORB.String) & (y.b = 2) THEN
+        ORG.StrToChar(y); ORG.IntRelation(rel, x, y)
+      ELSIF (yf = ORB.Char) & (xf = ORB.String) & (x.b = 2) THEN
+        ORG.StrToChar(x); ORG.IntRelation(rel, x, y)
+      ELSIF (xf = ORB.Int) & (yf = ORB.Int) THEN ORG.IntRelation(rel,  x, y)  (*BYTE*)
+      ELSE ORS.Mark("illegal comparison")
+      END ;
+      x.type := ORB.boolType
+    ELSIF sym = ORS.in THEN
+      ORS.Get(sym); CheckInt(x); SimpleExpression(y); CheckSet(y); ORG.In(x, y) ;
+      x.type := ORB.boolType
+    ELSIF sym = ORS.is THEN
+      ORS.Get(sym); qualident(obj); TypeTest(x, obj.type, FALSE) ;
+      x.type := ORB.boolType
+    END
+  END expression0;
+
+  (* statements *)
+
+  PROCEDURE StandProc(pno: LONGINT);
+    VAR nap, npar: LONGINT; (*nof actual/formal parameters*)
+      x, y, z: ORG.Item;
+  BEGIN Check(ORS.lparen, "no (");
+    npar := pno MOD 10; pno := pno DIV 10; expression(x); nap := 1;
+    IF sym = ORS.comma THEN
+      ORS.Get(sym); expression(y); nap := 2; z.type := ORB.noType;
+      WHILE sym = ORS.comma DO ORS.Get(sym); expression(z); INC(nap) END
+    ELSE y.type := ORB.noType
+    END ;
+    Check(ORS.rparen, "no )");
+    IF (npar = nap) OR (pno IN {0, 1}) THEN 
+      IF pno IN {0, 1} THEN (*INC, DEC*)
+        CheckInt(x); CheckReadOnly(x);
+        IF y.type # ORB.noType THEN CheckInt(y) END ;
+        ORG.Increment(pno, x, y)
+      ELSIF pno IN {2, 3} THEN (*INCL, EXCL*)
+        CheckSet(x); CheckReadOnly(x); CheckInt(y); ORG.Include(pno-2, x, y)
+      ELSIF pno = 4 THEN CheckBool(x); ORG.Assert(x)
+      ELSIF pno = 5 THEN(*NEW*) CheckReadOnly(x);
+         IF (x.type.form = ORB.Pointer) & (x.type.base.form = ORB.Record) THEN ORG.New(x)
+         ELSE ORS.Mark("not a pointer to record")
+         END
+      ELSIF pno = 6 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Pack(x, y)
+      ELSIF pno = 7 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Unpk(x, y)
+      ELSIF pno = 8 THEN
+        IF x.type.form <= ORB.Set THEN ORG.Led(x) ELSE ORS.Mark("bad type") END
+      ELSIF pno = 10 THEN CheckInt(x); ORG.Get(x, y)
+      ELSIF pno = 11 THEN CheckInt(x); ORG.Put(x, y)
+      ELSIF pno = 12 THEN CheckInt(x); CheckInt(y); CheckInt(z); ORG.Copy(x, y, z)
+      ELSIF pno = 13 THEN CheckConst(x); CheckInt(x); ORG.LDPSR(x)
+      ELSIF pno = 14 THEN CheckInt(x); ORG.LDREG(x, y)
+      END
+    ELSE ORS.Mark("wrong nof parameters")
+    END
+  END StandProc;
+
+  PROCEDURE StatSequence;
+    VAR obj: ORB.Object;
+      orgtype: ORB.Type; (*original type of case var*)
+      x, y, z, w: ORG.Item;
+      L0, L1, rx: LONGINT;
+
+    PROCEDURE TypeCase(obj: ORB.Object; VAR x: ORG.Item);
+      VAR typobj: ORB.Object;
+    BEGIN
+      IF sym = ORS.ident THEN
+        qualident(typobj); ORG.MakeItem(x, obj, level);
+        IF typobj.class # ORB.Typ THEN ORS.Mark("not a type") END ;
+        TypeTest(x, typobj.type, FALSE); obj.type := typobj.type;
+        ORG.CFJump(x); Check(ORS.colon, ": expected"); StatSequence
+      ELSE ORG.CFJump(x); ORS.Mark("type id expected")
+      END
+     END TypeCase;
+
+    PROCEDURE SkipCase;
+    BEGIN 
+      WHILE sym # ORS.colon DO ORS.Get(sym) END ;
+      ORS.Get(sym); StatSequence
+    END SkipCase;
+
+  BEGIN (* StatSequence *)
+    REPEAT (*sync*) obj := NIL;
+      IF ~((sym >= ORS.ident)  & (sym <= ORS.for) OR (sym >= ORS.semicolon)) THEN
+        ORS.Mark("statement expected");
+        REPEAT ORS.Get(sym) UNTIL (sym >= ORS.ident)
+      END ;
+      IF sym = ORS.ident THEN
+        qualident(obj); ORG.MakeItem(x, obj, level);
+        IF x.mode = ORB.SProc THEN StandProc(obj.val)
+        ELSE selector(x);
+          IF sym = ORS.becomes THEN (*assignment*)
+            ORS.Get(sym); CheckReadOnly(x); expression(y);
+            IF CompTypes(x.type, y.type, FALSE) THEN
+              IF (x.type.form <= ORB.Pointer) OR (x.type.form = ORB.Proc) THEN ORG.Store(x, y)
+              ELSE ORG.StoreStruct(x, y)
+              END
+            ELSIF (x.type.form = ORB.Array) & (y.type.form = ORB.Array) & (x.type.base = y.type.base) & (y.type.len < 0) THEN
+              ORG.StoreStruct(x, y)
+            ELSIF (x.type.form = ORB.Array) & (x.type.base.form = ORB.Char) & (y.type.form = ORB.String) THEN
+              ORG.CopyString(x, y)
+            ELSIF (x.type.form = ORB.Int) & (y.type.form = ORB.Int) THEN ORG.Store(x, y)  (*BYTE*)
+            ELSIF (x.type.form = ORB.Char) & (y.type.form = ORB.String) & (y.b = 2) THEN
+              ORG.StrToChar(y); ORG.Store(x, y)
+            ELSE ORS.Mark("illegal assignment")
+            END
+          ELSIF sym = ORS.eql THEN ORS.Mark("should be :="); ORS.Get(sym); expression(y)
+          ELSIF sym = ORS.lparen THEN (*procedure call*)
+            ORS.Get(sym);
+            IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN
+              ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx)
+            ELSE ORS.Mark("not a procedure"); ParamList(x)
+            END
+          ELSIF x.type.form = ORB.Proc THEN (*procedure call without parameters*)
+            IF x.type.nofpar > 0 THEN ORS.Mark("missing parameters") END ;
+            IF x.type.base.form = ORB.NoTyp THEN ORG.PrepCall(x, rx); ORG.Call(x, rx) ELSE ORS.Mark("not a procedure") END
+          ELSIF x.mode = ORB.Typ THEN ORS.Mark("illegal assignment")
+          ELSE ORS.Mark("not a procedure")
+          END
+        END
+      ELSIF sym = ORS.if THEN
+        ORS.Get(sym); expression(x); CheckBool(x); ORG.CFJump(x);
+        Check(ORS.then, "no THEN");
+        StatSequence; L0 := 0;
+        WHILE sym = ORS.elsif DO
+          ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); expression(x); CheckBool(x);
+          ORG.CFJump(x); Check(ORS.then, "no THEN"); StatSequence
+        END ;
+        IF sym = ORS.else THEN ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); StatSequence
+        ELSE ORG.Fixup(x)
+        END ;
+        ORG.FixLink(L0); Check(ORS.end, "no END")
+      ELSIF sym = ORS.while THEN
+        ORS.Get(sym); L0 := ORG.Here(); expression(x); CheckBool(x); ORG.CFJump(x);
+        Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0);
+        WHILE sym = ORS.elsif DO
+          ORS.Get(sym); ORG.Fixup(x); expression(x); CheckBool(x); ORG.CFJump(x);
+          Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0)
+        END ;
+        ORG.Fixup(x); Check(ORS.end, "no END")
+      ELSIF sym = ORS.repeat THEN
+        ORS.Get(sym); L0 := ORG.Here(); StatSequence;
+        IF sym = ORS.until THEN
+          ORS.Get(sym); expression(x); CheckBool(x); ORG.CBJump(x, L0)
+        ELSE ORS.Mark("missing UNTIL")
+        END
+      ELSIF sym = ORS.for THEN
+        ORS.Get(sym);
+        IF sym = ORS.ident THEN
+          qualident(obj); ORG.MakeItem(x, obj, level); CheckInt(x); CheckReadOnly(x);
+          IF sym = ORS.becomes THEN
+            ORS.Get(sym); expression(y); CheckInt(y); ORG.For0(x, y); L0 := ORG.Here();
+            Check(ORS.to, "no TO"); expression(z); CheckInt(z); obj.rdo := TRUE;
+            IF sym = ORS.by THEN ORS.Get(sym); expression(w); CheckConst(w); CheckInt(w)
+            ELSE ORG.MakeConstItem(w, ORB.intType, 1)
+            END ;
+            Check(ORS.do, "no DO"); ORG.For1(x, y, z, w, L1);
+            StatSequence; Check(ORS.end, "no END");
+            ORG.For2(x, y, w); ORG.BJump(L0); ORG.FixLink(L1); obj.rdo := FALSE
+          ELSE ORS.Mark(":= expected")
+          END
+        ELSE ORS.Mark("identifier expected")
+        END
+      ELSIF sym = ORS.case THEN
+        ORS.Get(sym);
+        IF sym = ORS.ident THEN
+          qualident(obj); orgtype := obj.type;
+          IF (orgtype.form = ORB.Pointer) OR (orgtype.form = ORB.Record) & (obj.class = ORB.Par) THEN
+            Check(ORS.of, "OF expected"); TypeCase(obj, x); L0 := 0;
+            WHILE sym = ORS.bar DO
+              ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype; TypeCase(obj, x)
+            END ;
+            ORG.Fixup(x); ORG.FixLink(L0); obj.type := orgtype
+          ELSE ORS.Mark("numeric case not implemented");
+            Check(ORS.of, "OF expected"); SkipCase;
+            WHILE sym = ORS.bar DO SkipCase END
+          END
+        ELSE ORS.Mark("ident expected")
+        END ;
+        Check(ORS.end, "no END")
+      END ;
+      ORG.CheckRegs;
+      IF sym = ORS.semicolon THEN ORS.Get(sym)
+      ELSIF sym < ORS.semicolon THEN ORS.Mark("missing semicolon?")
+      END
+    UNTIL sym > ORS.semicolon
+  END StatSequence;
+
+  (* Types and declarations *)
+
+  PROCEDURE IdentList(class: INTEGER; VAR first: ORB.Object);
+    VAR obj: ORB.Object;
+  BEGIN
+    IF sym = ORS.ident THEN
+      ORB.NewObj(first, ORS.id, class); ORS.Get(sym); CheckExport(first.expo);
+      WHILE sym = ORS.comma DO
+        ORS.Get(sym);
+        IF sym = ORS.ident THEN ORB.NewObj(obj, ORS.id, class); ORS.Get(sym); CheckExport(obj.expo)
+        ELSE ORS.Mark("ident?")
+        END
+      END;
+      IF sym = ORS.colon THEN ORS.Get(sym) ELSE ORS.Mark(":?") END
+    ELSE first := NIL
+    END
+  END IdentList;
+  
+  PROCEDURE ArrayType(VAR type: ORB.Type);
+    VAR x: ORG.Item; typ: ORB.Type; len: LONGINT;
+  BEGIN NEW(typ); typ.form := ORB.NoTyp;
+    expression(x);
+    IF (x.mode = ORB.Const) & (x.type.form = ORB.Int) & (x.a >= 0) THEN len := x.a
+    ELSE len := 1; ORS.Mark("not a valid length")
+    END ;
+    IF sym = ORS.of THEN ORS.Get(sym); Type(typ.base);
+      IF (typ.base.form = ORB.Array) & (typ.base.len < 0) THEN ORS.Mark("dyn array not allowed") END
+    ELSIF sym = ORS.comma THEN ORS.Get(sym); ArrayType(typ.base)
+    ELSE ORS.Mark("missing OF"); typ.base := ORB.intType
+    END ;
+    typ.size := (len * typ.base.size + 3) DIV 4 * 4;
+    typ.form := ORB.Array; typ.len := len; type := typ
+  END ArrayType;
+
+  PROCEDURE RecordType(VAR type: ORB.Type);
+    VAR obj, obj0, new, bot, base: ORB.Object;
+      typ, tp: ORB.Type;
+      offset, off, n: LONGINT;
+  BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := -level; typ.nofpar := 0; offset := 0; bot := NIL;
+    IF sym = ORS.lparen THEN
+      ORS.Get(sym); (*record extension*)
+      IF level # 0 THEN ORS.Mark("extension of local types not implemented") END ;
+      IF sym = ORS.ident THEN
+        qualident(base);
+        IF base.class = ORB.Typ THEN
+          IF base.type.form = ORB.Record THEN typ.base := base.type
+          ELSE typ.base := ORB.intType; ORS.Mark("invalid extension")
+          END ;
+          typ.nofpar := typ.base.nofpar + 1; (*"nofpar" here abused for extension level*)
+          bot := typ.base.dsc; offset := typ.base.size
+        ELSE ORS.Mark("type expected")
+        END
+      ELSE ORS.Mark("ident expected")
+      END ;
+      Check(ORS.rparen, "no )")
+    END ;
+    WHILE sym = ORS.ident DO  (*fields*)
+      n := 0; obj := bot;
+      WHILE sym = ORS.ident DO
+        obj0 := obj;
+        WHILE (obj0 # NIL) & (obj0.name # ORS.id) DO obj0 := obj0.next END ;
+        IF obj0 # NIL THEN ORS.Mark("mult def") END ;
+        NEW(new); ORS.CopyId(new.name); new.class := ORB.Fld; new.next := obj; obj := new; INC(n);
+        ORS.Get(sym); CheckExport(new.expo);
+        IF (sym # ORS.comma) & (sym # ORS.colon) THEN ORS.Mark("comma expected")
+        ELSIF sym = ORS.comma THEN ORS.Get(sym)
+        END
+      END ;
+      Check(ORS.colon, "colon expected"); Type(tp);
+      IF (tp.form = ORB.Array) & (tp.len < 0) THEN ORS.Mark("dyn array not allowed") END ;
+      IF tp.size > 1 THEN offset := (offset+3) DIV 4 * 4 END ;
+      offset := offset + n * tp.size; off := offset; obj0 := obj;
+      WHILE obj0 # bot DO obj0.type := tp; obj0.lev := 0; off := off - tp.size; obj0.val := off; obj0 := obj0.next END ;
+      bot := obj;
+      IF sym = ORS.semicolon THEN ORS.Get(sym) ELSIF sym # ORS.end THEN ORS.Mark(" ; or END") END
+    END ;
+    typ.form := ORB.Record; typ.dsc := bot; typ.size := (offset + 3) DIV 4 * 4; type := typ
+  END RecordType;
+
+  PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER);
+    VAR obj, first: ORB.Object; tp: ORB.Type;
+      parsize: LONGINT; cl: INTEGER; rdo: BOOLEAN;
+  BEGIN
+    IF sym = ORS.var THEN ORS.Get(sym); cl := ORB.Par ELSE cl := ORB.Var END ;
+    IdentList(cl, first); FormalType(tp, 0); rdo := FALSE;
+    IF (cl = ORB.Var) & (tp.form >= ORB.Array) THEN cl := ORB.Par; rdo := TRUE END ;
+    IF (tp.form = ORB.Array) & (tp.len < 0) OR (tp.form = ORB.Record) THEN
+      parsize := 2*ORG.WordSize  (*open array or record, needs second word for length or type tag*)
+    ELSE parsize := ORG.WordSize
+    END ;
+    obj := first;
+    WHILE obj # NIL DO
+      INC(nofpar); obj.class := cl; obj.type := tp; obj.rdo := rdo; obj.lev := level; obj.val := adr;
+      adr := adr + parsize; obj := obj.next
+    END ;
+    IF adr >= 52 THEN ORS.Mark("too many parameters") END
+  END FPSection;
+
+  PROCEDURE ProcedureType(ptype: ORB.Type; VAR parblksize: LONGINT);
+    VAR obj: ORB.Object; size: LONGINT; nofpar: INTEGER;
+  BEGIN ptype.base := ORB.noType; size := parblksize; nofpar := 0; ptype.dsc := NIL;
+    IF sym = ORS.lparen THEN
+      ORS.Get(sym);
+      IF sym = ORS.rparen THEN ORS.Get(sym)
+      ELSE FPSection(size, nofpar);
+        WHILE sym = ORS.semicolon DO ORS.Get(sym); FPSection(size, nofpar) END ;
+        Check(ORS.rparen, "no )")
+      END ;
+      IF sym = ORS.colon THEN  (*function*)
+        ORS.Get(sym);
+        IF sym = ORS.ident THEN
+          qualident(obj); ptype.base := obj.type;
+          IF ~((obj.class = ORB.Typ) & (obj.type.form IN {ORB.Byte .. ORB.Pointer, ORB.Proc})) THEN
+            ORS.Mark("illegal function type")
+          END
+        ELSE ORS.Mark("type identifier expected")
+        END
+      END
+    END ;
+    ptype.nofpar := nofpar; parblksize := size
+  END ProcedureType;
+
+  PROCEDURE FormalType0(VAR typ: ORB.Type; dim: INTEGER);
+    VAR obj: ORB.Object; dmy: LONGINT;
+  BEGIN
+    IF sym = ORS.ident THEN
+      qualident(obj);
+      IF obj.class = ORB.Typ THEN typ := obj.type ELSE ORS.Mark("not a type"); typ := ORB.intType END
+    ELSIF sym = ORS.array THEN
+      ORS.Get(sym); Check(ORS.of, "OF ?");
+      IF dim >= 1 THEN ORS.Mark("multi-dimensional open arrays not implemented") END ;
+      NEW(typ); typ.form := ORB.Array; typ.len := -1; typ.size := 2*ORG.WordSize; 
+      FormalType(typ.base, dim+1)
+    ELSIF sym = ORS.procedure THEN
+      ORS.Get(sym); ORB.OpenScope;
+      NEW(typ); typ.form := ORB.Proc; typ.size := ORG.WordSize; dmy := 0; ProcedureType(typ, dmy);
+      typ.dsc := ORB.topScope.next; ORB.CloseScope
+    ELSE ORS.Mark("identifier expected"); typ := ORB.noType
+    END
+  END FormalType0;
+
+  PROCEDURE CheckRecLevel(lev: INTEGER);
+  BEGIN
+    IF lev # 0 THEN ORS.Mark("ptr base must be global") END
+  END CheckRecLevel;
+
+  PROCEDURE Type0(VAR type: ORB.Type);
+    VAR dmy: LONGINT; obj: ORB.Object; ptbase: PtrBase;
+  BEGIN type := ORB.intType; (*sync*)
+    IF (sym # ORS.ident) & (sym < ORS.array) THEN ORS.Mark("not a type");
+      REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.array)
+    END ;
+    IF sym = ORS.ident THEN
+      qualident(obj);
+      IF obj.class = ORB.Typ THEN
+        IF (obj.type # NIL) & (obj.type.form # ORB.NoTyp) THEN type := obj.type END
+      ELSE ORS.Mark("not a type or undefined")
+      END
+    ELSIF sym = ORS.array THEN ORS.Get(sym); ArrayType(type)
+    ELSIF sym = ORS.record THEN
+      ORS.Get(sym); RecordType(type); Check(ORS.end, "no END")
+    ELSIF sym = ORS.pointer THEN
+      ORS.Get(sym); Check(ORS.to, "no TO");
+      NEW(type);  type.form := ORB.Pointer; type.size := ORG.WordSize; type.base := ORB.intType;
+      IF sym = ORS.ident THEN
+        obj := ORB.thisObj();
+        IF obj # NIL THEN
+          IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN
+            CheckRecLevel(obj.lev); type.base := obj.type
+          ELSIF obj.class = ORB.Mod THEN ORS.Mark("external base type not implemented")
+          ELSE ORS.Mark("no valid base type")
+          END
+        ELSE CheckRecLevel(level); (*enter into list of forward references to be fixed in Declarations*)
+          NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase
+        END ;
+        ORS.Get(sym)
+      ELSE Type(type.base);
+        IF (type.base.form # ORB.Record) OR (type.base.typobj = NIL) THEN ORS.Mark("must point to named record") END ;
+        CheckRecLevel(level)
+      END
+    ELSIF sym = ORS.procedure THEN
+      ORS.Get(sym); ORB.OpenScope;
+      NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; dmy := 0;
+      ProcedureType(type, dmy); type.dsc := ORB.topScope.next; ORB.CloseScope
+    ELSE ORS.Mark("illegal type")
+    END
+  END Type0;
+
+  PROCEDURE Declarations(VAR varsize: LONGINT);
+    VAR obj, first: ORB.Object;
+      x: ORG.Item; tp: ORB.Type; ptbase: PtrBase;
+      expo: BOOLEAN; id: ORS.Ident;
+  BEGIN (*sync*) pbsList := NIL;
+    IF (sym < ORS.const) & (sym # ORS.end) & (sym # ORS.return) THEN ORS.Mark("declaration?");
+      REPEAT ORS.Get(sym) UNTIL (sym >= ORS.const) OR (sym = ORS.end) OR (sym = ORS.return)
+    END ;
+    IF sym = ORS.const THEN
+      ORS.Get(sym);
+      WHILE sym = ORS.ident DO
+        ORS.CopyId(id); ORS.Get(sym); CheckExport(expo);
+        IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("= ?") END;
+        expression(x);
+        IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) END ;
+        ORB.NewObj(obj, id, ORB.Const); obj.expo := expo;
+        IF x.mode = ORB.Const THEN obj.val := x.a; obj.lev := x.b; obj.type := x.type
+        ELSE ORS.Mark("expression not constant"); obj.type := ORB.intType
+        END;
+        Check(ORS.semicolon, "; missing")
+      END
+    END ;
+    IF sym = ORS.type THEN
+      ORS.Get(sym);
+      WHILE sym = ORS.ident DO
+        ORS.CopyId(id); ORS.Get(sym); CheckExport(expo);
+        IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("=?") END ;
+        Type(tp);
+        ORB.NewObj(obj, id, ORB.Typ); obj.type := tp; obj.expo := expo; obj.lev := level;
+        IF tp.typobj = NIL THEN tp.typobj := obj END ;
+        IF expo & (obj.type.form = ORB.Record) THEN obj.exno := exno; INC(exno) ELSE obj.exno := 0 END ;
+        IF tp.form = ORB.Record THEN
+          ptbase := pbsList;  (*check whether this is base of a pointer type; search and fixup*)
+          WHILE ptbase # NIL DO
+            IF obj.name = ptbase.name THEN ptbase.type.base := obj.type END ;
+            ptbase := ptbase.next
+          END ;
+          IF level = 0 THEN ORG.BuildTD(tp, dc) END    (*type descriptor; len used as its address*)
+        END ;
+        Check(ORS.semicolon, "; missing")
+      END
+    END ;
+    IF sym = ORS.var THEN
+      ORS.Get(sym);
+      WHILE sym = ORS.ident DO
+        IdentList(ORB.Var, first); Type(tp);
+        obj := first;
+        WHILE obj # NIL DO
+          obj.type := tp; obj.lev := level;
+          IF tp.size > 1 THEN varsize := (varsize + 3) DIV 4 * 4 (*align*) END ;
+          obj.val := varsize; varsize := varsize + obj.type.size;
+          IF obj.expo THEN obj.exno := exno; INC(exno) END ;
+          obj := obj.next
+        END ;
+        Check(ORS.semicolon, "; missing")
+      END
+    END ;
+    varsize := (varsize + 3) DIV 4 * 4;
+    ptbase := pbsList;
+    WHILE ptbase # NIL DO
+      IF ptbase.type.base.form = ORB.Int THEN ORS.Mark("undefined pointer base of") END ;
+      ptbase := ptbase.next
+    END ;
+    IF (sym >= ORS.const) & (sym <= ORS.var) THEN ORS.Mark("declaration in bad order") END
+  END Declarations;
+
+  PROCEDURE ProcedureDecl;
+    VAR proc: ORB.Object;
+      type: ORB.Type;
+      procid: ORS.Ident;
+      x: ORG.Item;
+      locblksize, parblksize, L: LONGINT;
+      int: BOOLEAN;
+  BEGIN (* ProcedureDecl *) int := FALSE; ORS.Get(sym); 
+    IF sym = ORS.times THEN ORS.Get(sym); int := TRUE END ;
+    IF sym = ORS.ident THEN
+      ORS.CopyId(procid); ORS.Get(sym);
+      ORB.NewObj(proc, ORS.id, ORB.Const);
+      IF int THEN parblksize := 12 ELSE parblksize := 4 END ;
+      NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize;
+      proc.type := type; proc.val := -1; proc.lev := level; 
+      CheckExport(proc.expo);
+      IF proc.expo THEN proc.exno := exno; INC(exno) END ;
+      ORB.OpenScope; INC(level); type.base := ORB.noType;
+      ProcedureType(type, parblksize);  (*formal parameter list*)
+      Check(ORS.semicolon, "no ;"); locblksize := parblksize; 
+      Declarations(locblksize);
+      proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next;
+      IF sym = ORS.procedure THEN
+        L := 0; ORG.FJump(L);
+        REPEAT ProcedureDecl; Check(ORS.semicolon, "no ;") UNTIL sym # ORS.procedure;
+        ORG.FixOne(L); proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next
+      END ;
+      ORG.Enter(parblksize, locblksize, int);
+      IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ;
+      IF sym = ORS.return THEN
+        ORS.Get(sym); expression(x);
+        IF type.base = ORB.noType THEN ORS.Mark("this is not a function")
+        ELSIF ~CompTypes(type.base, x.type, FALSE) THEN ORS.Mark("wrong result type")
+        END
+      ELSIF type.base.form # ORB.NoTyp THEN
+        ORS.Mark("function without result"); type.base := ORB.noType
+      END ;
+      ORG.Return(type.base.form, x, locblksize, int);
+      ORB.CloseScope; DEC(level); Check(ORS.end, "no END");
+      IF sym = ORS.ident THEN
+        IF ORS.id # procid THEN ORS.Mark("no match") END ;
+        ORS.Get(sym)
+      ELSE ORS.Mark("no proc id")
+      END
+    END
+  END ProcedureDecl;
+
+  PROCEDURE Module;
+    VAR key: LONGINT;
+      impid, impid1: ORS.Ident;
+  BEGIN Texts.WriteString(W, "  compiling "); ORS.Get(sym);
+    IF sym = ORS.module THEN
+      ORS.Get(sym);
+      IF sym = ORS.times THEN version := 0; Texts.Write(W, "*"); ORS.Get(sym) ELSE version := 1 END ;
+      ORB.Init; ORB.OpenScope;
+      IF sym = ORS.ident THEN
+        ORS.CopyId(modid); ORS.Get(sym);
+        Texts.WriteString(W, modid); Texts.Append(Oberon.Log, W.buf)
+      ELSE ORS.Mark("identifier expected")
+      END ;
+      Check(ORS.semicolon, "no ;"); level := 0; dc := 0; exno := 1; key := 0;
+      IF sym = ORS.import THEN
+        ORS.Get(sym);
+        WHILE sym = ORS.ident DO
+          ORS.CopyId(impid); ORS.Get(sym);
+          IF sym = ORS.becomes THEN
+            ORS.Get(sym);
+            IF sym = ORS.ident THEN ORS.CopyId(impid1); ORS.Get(sym)
+            ELSE ORS.Mark("id expected")
+            END
+          ELSE impid1 := impid
+          END ;
+          ORB.Import(impid, impid1);
+          IF sym = ORS.comma THEN ORS.Get(sym)
+          ELSIF sym = ORS.ident THEN ORS.Mark("comma missing")
+          END
+        END ;
+        Check(ORS.semicolon, "no ;")
+      END ;
+      ORG.Open(version); Declarations(dc); ORG.SetDataSize((dc + 3) DIV 4 * 4);
+      WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ;
+      ORG.Header;
+      IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ;
+      Check(ORS.end, "no END");
+      IF sym = ORS.ident THEN
+        IF ORS.id # modid THEN ORS.Mark("no match") END ;
+        ORS.Get(sym)
+      ELSE ORS.Mark("identifier missing")
+      END ;
+      IF sym # ORS.period THEN ORS.Mark("period missing") END ;
+      IF (ORS.errcnt = 0) & (version # 0) THEN
+        ORB.Export(modid, newSF, key);
+        IF newSF THEN Texts.WriteString(W, " new symbol file") END
+      END ;
+      IF ORS.errcnt = 0 THEN
+        ORG.Close(modid, key, exno);
+        Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteHex(W, key)
+      ELSE Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED")
+      END ;
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+      ORB.CloseScope; pbsList := NIL
+    ELSE ORS.Mark("must start with MODULE")
+    END
+  END Module;
+
+  PROCEDURE Option(VAR S: Texts.Scanner);
+  BEGIN newSF := FALSE;
+    IF S.nextCh = "/" THEN
+      Texts.Scan(S); Texts.Scan(S); 
+      IF (S.class = Texts.Name) & (S.s[0] = "s") THEN newSF := TRUE END
+    END
+  END Option;
+
+  PROCEDURE Compile*;
+    VAR beg, end, time: LONGINT;
+      T: Texts.Text;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Char THEN
+      IF S.c = "@" THEN
+        Option(S); Oberon.GetSelection(T, beg, end, time);
+        IF time >= 0 THEN ORS.Init(T, beg); Module END
+      ELSIF S.c = "^" THEN
+        Option(S); Oberon.GetSelection(T, beg, end, time);
+        IF time >= 0 THEN
+          Texts.OpenScanner(S, T, beg); Texts.Scan(S);
+          IF S.class = Texts.Name THEN
+            Texts.WriteString(W, S.s); NEW(T); Texts.Open(T, S.s);
+            IF T.len > 0 THEN ORS.Init(T, 0); Module END
+          END
+        END
+      END
+    ELSE 
+      WHILE S.class = Texts.Name DO
+        NEW(T); Texts.Open(T, S.s);
+        IF T.len > 0 THEN Option(S); ORS.Init(T, 0); Module
+        ELSE Texts.WriteString(W, S.s); Texts.WriteString(W, " not found");
+          Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+        END ;
+        IF (T.len # 0) & (ORS.errcnt = 0) THEN Texts.Scan(S) ELSE S.class := 0 END
+      END
+    END ;
+    Oberon.Collect(0)
+  END Compile;
+
+BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler  17.9.2018");
+  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+  NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType;
+  expression := expression0; Type := Type0; FormalType := FormalType0
+END ORP.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/ORS.Mod.txt

@@ -1,312 +1,312 @@
-MODULE ORS; (* NW 19.9.93 / 15.3.2017  Scanner in Oberon-07*)
-  IMPORT SYSTEM, Texts, Oberon;
-
-(* Oberon Scanner does lexical analysis. Input is Oberon-Text, output is
-  sequence of symbols, i.e identifiers, numbers, strings, and special symbols.
-  Recognises all Oberon keywords and skips comments. The keywords are
-  recorded in a table.
-  Get(sym) delivers next symbol from input text with Reader R.
-  Mark(msg) records error and delivers error message with Writer W.
-  If Get delivers ident, then the identifier (a string) is in variable id, if int or char
-  in ival, if real in rval, and if string in str (and slen) *)
-  
-  CONST IdLen* = 32;
-    NKW = 34;  (*nof keywords*)
-    maxExp = 38; stringBufSize = 256;
-  
-    (*lexical symbols*)
-    null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4;
-    and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9;
-    neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14;
-    in* = 15; is* = 16; arrow* = 17; period* = 18;
-    char* = 20; int* = 21; real* = 22; false* = 23; true* = 24;
-    nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29;
-    lbrace* = 30; ident* = 31;
-    if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37;
-    comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44;
-    rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49;
-    to* = 50; by* = 51; semicolon* = 52; end* = 53; bar* = 54;
-    else* = 55; elsif* = 56; until* = 57; return* = 58;
-    array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64;
-    var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69; eot = 70;
-
-  TYPE Ident* = ARRAY IdLen OF CHAR;
-
-  VAR ival*, slen*: LONGINT;  (*results of Get*)
-    rval*: REAL;
-    id*: Ident;  (*for identifiers*)
-    str*: ARRAY stringBufSize OF CHAR;
-    errcnt*: INTEGER;
-
-    ch: CHAR;  (*last character read*)
-    errpos: LONGINT;
-    R: Texts.Reader;
-    W: Texts.Writer;
-    k: INTEGER;
-    KWX: ARRAY 10 OF INTEGER;
-    keyTab: ARRAY NKW OF
-        RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END;
-  
-  PROCEDURE CopyId*(VAR ident: Ident);
-  BEGIN ident := id
-  END CopyId;
-
-  PROCEDURE Pos*(): LONGINT;
-  BEGIN RETURN Texts.Pos(R) - 1
-  END Pos;
-
-  PROCEDURE Mark*(msg: ARRAY OF CHAR);
-    VAR p: LONGINT;
-  BEGIN p := Pos();
-    IF (p > errpos) & (errcnt < 25) THEN
-      Texts.WriteLn(W); Texts.WriteString(W, "  pos "); Texts.WriteInt(W, p, 1); Texts.Write(W, " ");
-      Texts.WriteString(W, msg); Texts.Append(Oberon.Log, W.buf)
-    END ;
-    INC(errcnt); errpos := p + 4
-  END Mark;
-
-  PROCEDURE Identifier(VAR sym: INTEGER);
-    VAR i, k: INTEGER;
-  BEGIN i := 0;
-    REPEAT
-      IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
-      Texts.Read(R, ch)
-    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
-    id[i] := 0X; 
-    IF i < 10 THEN k := KWX[i-1];  (*search for keyword*)
-      WHILE (id # keyTab[k].id) & (k < KWX[i]) DO INC(k) END ;
-      IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END
-    ELSE sym := ident
-    END
-  END Identifier;
-
-  PROCEDURE String;
-    VAR i: INTEGER;
-  BEGIN i := 0; Texts.Read(R, ch);
-    WHILE ~R.eot & (ch # 22X) DO
-      IF ch >= " " THEN
-        IF i < stringBufSize-1 THEN str[i] := ch; INC(i) ELSE Mark("string too long") END ;
-      END ;
-      Texts.Read(R, ch)
-    END ;
-    str[i] := 0X; INC(i); Texts.Read(R, ch); slen := i
-  END String;
-
-  PROCEDURE HexString;
-    VAR i, m, n: INTEGER;
-  BEGIN i := 0; Texts.Read(R, ch);
-    WHILE ~R.eot & (ch # "$") DO
-      WHILE ~R.eot  & (ch <= " ") DO Texts.Read(R, ch) END ;  (*skip*)
-      IF ("0" <= ch) & (ch <= "9") THEN m := ORD(ch) - 30H
-      ELSIF ("A" <= ch) & (ch <= "F") THEN m := ORD(ch) - 37H
-      ELSE m := 0; Mark("hexdig expected")
-      END ;
-      Texts.Read(R, ch);
-      IF ("0" <= ch) & (ch <= "9") THEN n := ORD(ch) - 30H
-      ELSIF ("A" <= ch) & (ch <= "F") THEN n := ORD(ch) - 37H
-      ELSE n := 0; Mark("hexdig expected")
-      END ;
-      IF i < stringBufSize THEN str[i] := CHR(m*10H + n); INC(i) ELSE Mark("string too long") END ;
-      Texts.Read(R, ch)
-    END ;
-    Texts.Read(R, ch); slen := i  (*no 0X appended!*)
-  END HexString;
-
-  PROCEDURE Ten(e: LONGINT): REAL;
-    VAR x, t: REAL;
-  BEGIN x := 1.0; t := 10.0;
-    WHILE e > 0 DO
-      IF ODD(e) THEN x := t * x END ;
-      t := t * t; e := e DIV 2
-    END ;
-    RETURN x
-  END Ten;
-
-  PROCEDURE Number(VAR sym: INTEGER);
-    CONST max = 2147483647 (*2^31 - 1*);
-    VAR i, k, e, n, s, h: LONGINT; x: REAL;
-      d: ARRAY 16 OF INTEGER;
-      negE: BOOLEAN;
-  BEGIN ival := 0; i := 0; n := 0; k := 0;
-    REPEAT
-      IF n < 16 THEN d[n] := ORD(ch)-30H; INC(n) ELSE Mark("too many digits"); n := 0 END ;
-      Texts.Read(R, ch)
-    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F");
-    IF (ch = "H") OR (ch = "R") OR (ch = "X") THEN  (*hex*)
-      REPEAT h := d[i];
-        IF h >= 10 THEN h := h-7 END ;
-        k := k*10H + h; INC(i) (*no overflow check*)
-      UNTIL i = n;
-      IF ch = "X" THEN sym := char;
-        IF k < 100H THEN ival := k ELSE Mark("illegal value"); ival := 0 END
-      ELSIF ch = "R" THEN sym := real; rval := SYSTEM.VAL(REAL, k)
-      ELSE sym := int; ival := k
-      END ;
-      Texts.Read(R, ch)
-    ELSIF ch = "." THEN
-      Texts.Read(R, ch);
-      IF ch = "." THEN (*double dot*) ch := 7FX;  (*decimal integer*)
-        REPEAT
-          IF d[i] < 10 THEN
-            IF k <= (max-d[i]) DIV 10 THEN k := k *10 + d[i] ELSE Mark("too large"); k := 0 END
-          ELSE Mark("bad integer")
-          END ;
-          INC(i)
-        UNTIL i = n;
-        sym := int; ival := k
-      ELSE (*real number*) x := 0.0; e := 0;
-        REPEAT  (*integer part*) x := x * 10.0 + FLT(d[i]); INC(i) UNTIL i = n;
-        WHILE (ch >= "0") & (ch <= "9") DO  (*fraction*)
-          x := x * 10.0 + FLT(ORD(ch) - 30H); DEC(e); Texts.Read(R, ch)
-        END ;
-        IF (ch = "E") OR (ch = "D") THEN  (*scale factor*)
-          Texts.Read(R, ch); s := 0; 
-          IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch)
-          ELSE negE := FALSE;
-            IF ch = "+" THEN Texts.Read(R, ch) END
-          END ;
-          IF (ch >= "0") & (ch <= "9") THEN
-            REPEAT s := s*10 + ORD(ch)-30H; Texts.Read(R, ch)
-            UNTIL (ch < "0") OR (ch >"9");
-            IF negE THEN e := e-s ELSE e := e+s END
-          ELSE Mark("digit?")
-          END
-        END ;
-        IF e < 0 THEN
-          IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END
-        ELSIF e > 0 THEN
-          IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0; Mark("too large") END
-        END ;
-        sym := real; rval := x
-      END
-    ELSE  (*decimal integer*)
-      REPEAT
-        IF d[i] < 10 THEN
-          IF k <= (max-d[i]) DIV 10 THEN k := k*10 + d[i] ELSE Mark("too large"); k := 0 END
-        ELSE Mark("bad integer")
-        END ;
-        INC(i)
-      UNTIL i = n;
-      sym := int; ival := k
-    END
-  END Number;
-
-  PROCEDURE comment;
-  BEGIN Texts.Read(R, ch);
-    REPEAT
-      WHILE ~R.eot & (ch # "*") DO
-        IF ch = "(" THEN Texts.Read(R, ch);
-          IF ch = "*" THEN comment END
-        ELSE Texts.Read(R, ch)
-        END
-      END ;
-      WHILE ch = "*" DO Texts.Read(R, ch) END
-    UNTIL (ch = ")") OR R.eot;
-    IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("unterminated comment") END
-  END comment;
-
-  PROCEDURE Get*(VAR sym: INTEGER);
-  BEGIN
-    REPEAT
-      WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
-      IF R.eot THEN sym := eot
-      ELSIF ch < "A" THEN
-        IF ch < "0" THEN
-          IF ch = 22X THEN String; sym := string
-          ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
-          ELSIF ch = "$" THEN HexString; sym := string
-          ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
-          ELSIF ch = "(" THEN Texts.Read(R, ch); 
-            IF ch = "*" THEN sym := null; comment ELSE sym := lparen END
-          ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
-          ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times
-          ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
-          ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
-          ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus
-          ELSIF ch = "." THEN Texts.Read(R, ch);
-            IF ch = "." THEN Texts.Read(R, ch); sym := upto ELSE sym := period END
-          ELSIF ch = "/" THEN Texts.Read(R, ch); sym := rdiv
-          ELSE Texts.Read(R, ch); (* ! % ' *) sym := null
-          END
-        ELSIF ch < ":" THEN Number(sym)
-        ELSIF ch = ":" THEN Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END 
-        ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
-        ELSIF ch = "<" THEN  Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
-        ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
-        ELSIF ch = ">" THEN Texts.Read(R, ch);
-          IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
-        ELSE (* ? @ *) Texts.Read(R, ch); sym := null
-        END
-      ELSIF ch < "[" THEN Identifier(sym)
-      ELSIF ch < "a" THEN
-        IF ch = "[" THEN sym := lbrak
-        ELSIF ch = "]" THEN  sym := rbrak
-        ELSIF ch = "^" THEN sym := arrow
-        ELSE (* _ ` *) sym := null
-        END ;
-        Texts.Read(R, ch)
-      ELSIF ch < "{" THEN Identifier(sym) ELSE
-        IF ch = "{" THEN sym := lbrace
-        ELSIF ch = "}" THEN sym := rbrace
-        ELSIF ch = "|" THEN sym := bar
-        ELSIF ch = "~" THEN  sym := not
-        ELSIF ch = 7FX THEN  sym := upto
-        ELSE sym := null
-        END ;
-        Texts.Read(R, ch)
-      END
-    UNTIL sym # null
-  END Get;
-
-  PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
-  BEGIN errpos := pos; errcnt := 0; Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
-  END Init;
-
-  PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR);
-  BEGIN keyTab[k].id := name; keyTab[k].sym := sym; INC(k)
-  END EnterKW;
-
-BEGIN Texts.OpenWriter(W); k := 0; KWX[0] := 0; KWX[1] := 0;
-  EnterKW(if, "IF");
-  EnterKW(do, "DO");
-  EnterKW(of, "OF");
-  EnterKW(or, "OR");
-  EnterKW(to, "TO");
-  EnterKW(in, "IN");
-  EnterKW(is, "IS");
-  EnterKW(by, "BY");
-  KWX[2] := k;
-  EnterKW(end, "END");
-  EnterKW(nil, "NIL");
-  EnterKW(var, "VAR");
-  EnterKW(div, "DIV");
-  EnterKW(mod, "MOD");
-  EnterKW(for, "FOR");
-  KWX[3] := k;
-  EnterKW(else, "ELSE");
-  EnterKW(then, "THEN");
-  EnterKW(true, "TRUE");
-  EnterKW(type, "TYPE");
-  EnterKW(case, "CASE");
-  KWX[4] := k;
-  EnterKW(elsif, "ELSIF");
-  EnterKW(false, "FALSE");
-  EnterKW(array, "ARRAY");
-  EnterKW(begin, "BEGIN");
-  EnterKW(const, "CONST");
-  EnterKW(until, "UNTIL");
-  EnterKW(while, "WHILE");
-  KWX[5] := k;
-  EnterKW(record, "RECORD");
-  EnterKW(repeat, "REPEAT");
-  EnterKW(return, "RETURN");
-  EnterKW(import, "IMPORT");
-  EnterKW(module, "MODULE");
-  KWX[6] := k;
-  EnterKW(pointer, "POINTER");
-  KWX[7] := k; KWX[8] := k;
-  EnterKW(procedure, "PROCEDURE");
-  KWX[9] := k
-END ORS.
+MODULE ORS; (* NW 19.9.93 / 15.3.2017  Scanner in Oberon-07*)
+  IMPORT SYSTEM, Texts, Oberon;
+
+(* Oberon Scanner does lexical analysis. Input is Oberon-Text, output is
+  sequence of symbols, i.e identifiers, numbers, strings, and special symbols.
+  Recognises all Oberon keywords and skips comments. The keywords are
+  recorded in a table.
+  Get(sym) delivers next symbol from input text with Reader R.
+  Mark(msg) records error and delivers error message with Writer W.
+  If Get delivers ident, then the identifier (a string) is in variable id, if int or char
+  in ival, if real in rval, and if string in str (and slen) *)
+  
+  CONST IdLen* = 32;
+    NKW = 34;  (*nof keywords*)
+    maxExp = 38; stringBufSize = 256;
+  
+    (*lexical symbols*)
+    null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4;
+    and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9;
+    neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14;
+    in* = 15; is* = 16; arrow* = 17; period* = 18;
+    char* = 20; int* = 21; real* = 22; false* = 23; true* = 24;
+    nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29;
+    lbrace* = 30; ident* = 31;
+    if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37;
+    comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44;
+    rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49;
+    to* = 50; by* = 51; semicolon* = 52; end* = 53; bar* = 54;
+    else* = 55; elsif* = 56; until* = 57; return* = 58;
+    array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64;
+    var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69; eot = 70;
+
+  TYPE Ident* = ARRAY IdLen OF CHAR;
+
+  VAR ival*, slen*: LONGINT;  (*results of Get*)
+    rval*: REAL;
+    id*: Ident;  (*for identifiers*)
+    str*: ARRAY stringBufSize OF CHAR;
+    errcnt*: INTEGER;
+
+    ch: CHAR;  (*last character read*)
+    errpos: LONGINT;
+    R: Texts.Reader;
+    W: Texts.Writer;
+    k: INTEGER;
+    KWX: ARRAY 10 OF INTEGER;
+    keyTab: ARRAY NKW OF
+        RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END;
+  
+  PROCEDURE CopyId*(VAR ident: Ident);
+  BEGIN ident := id
+  END CopyId;
+
+  PROCEDURE Pos*(): LONGINT;
+  BEGIN RETURN Texts.Pos(R) - 1
+  END Pos;
+
+  PROCEDURE Mark*(msg: ARRAY OF CHAR);
+    VAR p: LONGINT;
+  BEGIN p := Pos();
+    IF (p > errpos) & (errcnt < 25) THEN
+      Texts.WriteLn(W); Texts.WriteString(W, "  pos "); Texts.WriteInt(W, p, 1); Texts.Write(W, " ");
+      Texts.WriteString(W, msg); Texts.Append(Oberon.Log, W.buf)
+    END ;
+    INC(errcnt); errpos := p + 4
+  END Mark;
+
+  PROCEDURE Identifier(VAR sym: INTEGER);
+    VAR i, k: INTEGER;
+  BEGIN i := 0;
+    REPEAT
+      IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
+      Texts.Read(R, ch)
+    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
+    id[i] := 0X; 
+    IF i < 10 THEN k := KWX[i-1];  (*search for keyword*)
+      WHILE (id # keyTab[k].id) & (k < KWX[i]) DO INC(k) END ;
+      IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END
+    ELSE sym := ident
+    END
+  END Identifier;
+
+  PROCEDURE String;
+    VAR i: INTEGER;
+  BEGIN i := 0; Texts.Read(R, ch);
+    WHILE ~R.eot & (ch # 22X) DO
+      IF ch >= " " THEN
+        IF i < stringBufSize-1 THEN str[i] := ch; INC(i) ELSE Mark("string too long") END ;
+      END ;
+      Texts.Read(R, ch)
+    END ;
+    str[i] := 0X; INC(i); Texts.Read(R, ch); slen := i
+  END String;
+
+  PROCEDURE HexString;
+    VAR i, m, n: INTEGER;
+  BEGIN i := 0; Texts.Read(R, ch);
+    WHILE ~R.eot & (ch # "$") DO
+      WHILE ~R.eot  & (ch <= " ") DO Texts.Read(R, ch) END ;  (*skip*)
+      IF ("0" <= ch) & (ch <= "9") THEN m := ORD(ch) - 30H
+      ELSIF ("A" <= ch) & (ch <= "F") THEN m := ORD(ch) - 37H
+      ELSE m := 0; Mark("hexdig expected")
+      END ;
+      Texts.Read(R, ch);
+      IF ("0" <= ch) & (ch <= "9") THEN n := ORD(ch) - 30H
+      ELSIF ("A" <= ch) & (ch <= "F") THEN n := ORD(ch) - 37H
+      ELSE n := 0; Mark("hexdig expected")
+      END ;
+      IF i < stringBufSize THEN str[i] := CHR(m*10H + n); INC(i) ELSE Mark("string too long") END ;
+      Texts.Read(R, ch)
+    END ;
+    Texts.Read(R, ch); slen := i  (*no 0X appended!*)
+  END HexString;
+
+  PROCEDURE Ten(e: LONGINT): REAL;
+    VAR x, t: REAL;
+  BEGIN x := 1.0; t := 10.0;
+    WHILE e > 0 DO
+      IF ODD(e) THEN x := t * x END ;
+      t := t * t; e := e DIV 2
+    END ;
+    RETURN x
+  END Ten;
+
+  PROCEDURE Number(VAR sym: INTEGER);
+    CONST max = 2147483647 (*2^31 - 1*);
+    VAR i, k, e, n, s, h: LONGINT; x: REAL;
+      d: ARRAY 16 OF INTEGER;
+      negE: BOOLEAN;
+  BEGIN ival := 0; i := 0; n := 0; k := 0;
+    REPEAT
+      IF n < 16 THEN d[n] := ORD(ch)-30H; INC(n) ELSE Mark("too many digits"); n := 0 END ;
+      Texts.Read(R, ch)
+    UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F");
+    IF (ch = "H") OR (ch = "R") OR (ch = "X") THEN  (*hex*)
+      REPEAT h := d[i];
+        IF h >= 10 THEN h := h-7 END ;
+        k := k*10H + h; INC(i) (*no overflow check*)
+      UNTIL i = n;
+      IF ch = "X" THEN sym := char;
+        IF k < 100H THEN ival := k ELSE Mark("illegal value"); ival := 0 END
+      ELSIF ch = "R" THEN sym := real; rval := SYSTEM.VAL(REAL, k)
+      ELSE sym := int; ival := k
+      END ;
+      Texts.Read(R, ch)
+    ELSIF ch = "." THEN
+      Texts.Read(R, ch);
+      IF ch = "." THEN (*double dot*) ch := 7FX;  (*decimal integer*)
+        REPEAT
+          IF d[i] < 10 THEN
+            IF k <= (max-d[i]) DIV 10 THEN k := k *10 + d[i] ELSE Mark("too large"); k := 0 END
+          ELSE Mark("bad integer")
+          END ;
+          INC(i)
+        UNTIL i = n;
+        sym := int; ival := k
+      ELSE (*real number*) x := 0.0; e := 0;
+        REPEAT  (*integer part*) x := x * 10.0 + FLT(d[i]); INC(i) UNTIL i = n;
+        WHILE (ch >= "0") & (ch <= "9") DO  (*fraction*)
+          x := x * 10.0 + FLT(ORD(ch) - 30H); DEC(e); Texts.Read(R, ch)
+        END ;
+        IF (ch = "E") OR (ch = "D") THEN  (*scale factor*)
+          Texts.Read(R, ch); s := 0; 
+          IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch)
+          ELSE negE := FALSE;
+            IF ch = "+" THEN Texts.Read(R, ch) END
+          END ;
+          IF (ch >= "0") & (ch <= "9") THEN
+            REPEAT s := s*10 + ORD(ch)-30H; Texts.Read(R, ch)
+            UNTIL (ch < "0") OR (ch >"9");
+            IF negE THEN e := e-s ELSE e := e+s END
+          ELSE Mark("digit?")
+          END
+        END ;
+        IF e < 0 THEN
+          IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END
+        ELSIF e > 0 THEN
+          IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0; Mark("too large") END
+        END ;
+        sym := real; rval := x
+      END
+    ELSE  (*decimal integer*)
+      REPEAT
+        IF d[i] < 10 THEN
+          IF k <= (max-d[i]) DIV 10 THEN k := k*10 + d[i] ELSE Mark("too large"); k := 0 END
+        ELSE Mark("bad integer")
+        END ;
+        INC(i)
+      UNTIL i = n;
+      sym := int; ival := k
+    END
+  END Number;
+
+  PROCEDURE comment;
+  BEGIN Texts.Read(R, ch);
+    REPEAT
+      WHILE ~R.eot & (ch # "*") DO
+        IF ch = "(" THEN Texts.Read(R, ch);
+          IF ch = "*" THEN comment END
+        ELSE Texts.Read(R, ch)
+        END
+      END ;
+      WHILE ch = "*" DO Texts.Read(R, ch) END
+    UNTIL (ch = ")") OR R.eot;
+    IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("unterminated comment") END
+  END comment;
+
+  PROCEDURE Get*(VAR sym: INTEGER);
+  BEGIN
+    REPEAT
+      WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
+      IF R.eot THEN sym := eot
+      ELSIF ch < "A" THEN
+        IF ch < "0" THEN
+          IF ch = 22X THEN String; sym := string
+          ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
+          ELSIF ch = "$" THEN HexString; sym := string
+          ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
+          ELSIF ch = "(" THEN Texts.Read(R, ch); 
+            IF ch = "*" THEN sym := null; comment ELSE sym := lparen END
+          ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
+          ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times
+          ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
+          ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
+          ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus
+          ELSIF ch = "." THEN Texts.Read(R, ch);
+            IF ch = "." THEN Texts.Read(R, ch); sym := upto ELSE sym := period END
+          ELSIF ch = "/" THEN Texts.Read(R, ch); sym := rdiv
+          ELSE Texts.Read(R, ch); (* ! % ' *) sym := null
+          END
+        ELSIF ch < ":" THEN Number(sym)
+        ELSIF ch = ":" THEN Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END 
+        ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
+        ELSIF ch = "<" THEN  Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
+        ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
+        ELSIF ch = ">" THEN Texts.Read(R, ch);
+          IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
+        ELSE (* ? @ *) Texts.Read(R, ch); sym := null
+        END
+      ELSIF ch < "[" THEN Identifier(sym)
+      ELSIF ch < "a" THEN
+        IF ch = "[" THEN sym := lbrak
+        ELSIF ch = "]" THEN  sym := rbrak
+        ELSIF ch = "^" THEN sym := arrow
+        ELSE (* _ ` *) sym := null
+        END ;
+        Texts.Read(R, ch)
+      ELSIF ch < "{" THEN Identifier(sym) ELSE
+        IF ch = "{" THEN sym := lbrace
+        ELSIF ch = "}" THEN sym := rbrace
+        ELSIF ch = "|" THEN sym := bar
+        ELSIF ch = "~" THEN  sym := not
+        ELSIF ch = 7FX THEN  sym := upto
+        ELSE sym := null
+        END ;
+        Texts.Read(R, ch)
+      END
+    UNTIL sym # null
+  END Get;
+
+  PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
+  BEGIN errpos := pos; errcnt := 0; Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
+  END Init;
+
+  PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR);
+  BEGIN keyTab[k].id := name; keyTab[k].sym := sym; INC(k)
+  END EnterKW;
+
+BEGIN Texts.OpenWriter(W); k := 0; KWX[0] := 0; KWX[1] := 0;
+  EnterKW(if, "IF");
+  EnterKW(do, "DO");
+  EnterKW(of, "OF");
+  EnterKW(or, "OR");
+  EnterKW(to, "TO");
+  EnterKW(in, "IN");
+  EnterKW(is, "IS");
+  EnterKW(by, "BY");
+  KWX[2] := k;
+  EnterKW(end, "END");
+  EnterKW(nil, "NIL");
+  EnterKW(var, "VAR");
+  EnterKW(div, "DIV");
+  EnterKW(mod, "MOD");
+  EnterKW(for, "FOR");
+  KWX[3] := k;
+  EnterKW(else, "ELSE");
+  EnterKW(then, "THEN");
+  EnterKW(true, "TRUE");
+  EnterKW(type, "TYPE");
+  EnterKW(case, "CASE");
+  KWX[4] := k;
+  EnterKW(elsif, "ELSIF");
+  EnterKW(false, "FALSE");
+  EnterKW(array, "ARRAY");
+  EnterKW(begin, "BEGIN");
+  EnterKW(const, "CONST");
+  EnterKW(until, "UNTIL");
+  EnterKW(while, "WHILE");
+  KWX[5] := k;
+  EnterKW(record, "RECORD");
+  EnterKW(repeat, "REPEAT");
+  EnterKW(return, "RETURN");
+  EnterKW(import, "IMPORT");
+  EnterKW(module, "MODULE");
+  KWX[6] := k;
+  EnterKW(pointer, "POINTER");
+  KWX[7] := k; KWX[8] := k;
+  EnterKW(procedure, "PROCEDURE");
+  KWX[9] := k
+END ORS.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/ORTool.Mod.txt

@@ -1,251 +1,251 @@
-MODULE ORTool;  (*NW 18.2.2013*)
-  IMPORT SYSTEM, Files, Texts, Oberon, ORB;
-  VAR W: Texts.Writer;
-    Form: INTEGER;  (*result of ReadType*)
-    mnemo0, mnemo1: ARRAY 16, 4 OF CHAR;  (*mnemonics*)
-
-  PROCEDURE Read(VAR R: Files.Rider; VAR n: INTEGER);
-    VAR b: BYTE;
-  BEGIN Files.ReadByte(R, b);
-    IF b < 80H THEN n := b ELSE n := b - 100H END
-  END Read;
-
-  PROCEDURE ReadType(VAR R: Files.Rider);
-    VAR key, len, lev, size, off: INTEGER;
-      ref, mno, class, form, readonly: INTEGER;
-      name, modname: ARRAY 32 OF CHAR;
-  BEGIN Read(R, ref); Texts.Write(W, " "); Texts.Write(W, "[");
-    IF ref < 0 THEN Texts.Write(W, "^"); Texts.WriteInt(W, -ref, 1)
-    ELSE Texts.WriteInt(W, ref, 1);
-      Read(R, form); Texts.WriteString(W, "  form = "); Texts.WriteInt(W, form, 1);
-      IF form = ORB.Pointer THEN ReadType(R)
-      ELSIF form = ORB.Array THEN
-        ReadType(R); Files.ReadNum(R, len); Files.ReadNum(R, size);
-        Texts.WriteString(W, "  len = "); Texts.WriteInt(W, len, 1);
-        Texts.WriteString(W, "  size = "); Texts.WriteInt(W, size, 1)
-      ELSIF form = ORB.Record THEN
-        ReadType(R);  (*base type*)
-        Files.ReadNum(R, off); Texts.WriteString(W, "  exno = "); Texts.WriteInt(W, off, 1); 
-        Files.ReadNum(R, off); Texts.WriteString(W, "  extlev = "); Texts.WriteInt(W, off, 1);
-        Files.ReadNum(R, size); Texts.WriteString(W, "  size = "); Texts.WriteInt(W, size, 1);
-        Texts.Write(W, " "); Texts.Write(W, "{"); Read(R, class);
-        WHILE class # 0 DO (*fields*)
-          Files.ReadString(R, name);
-          IF name[0] # 0X THEN Texts.Write(W, " "); Texts.WriteString(W, name); ReadType(R)
-          ELSE Texts.WriteString(W, " --")
-          END ;
-          Files.ReadNum(R, off); Texts.WriteInt(W, off, 4); Read(R, class)
-        END ;
-        Texts.Write(W, "}")
-      ELSIF form = ORB.Proc THEN
-        ReadType(R); Texts.Write(W, "("); Read(R, class);
-        WHILE class # 0 DO
-          Texts.WriteString(W, " class = "); Texts.WriteInt(W, class, 1); Read(R, readonly);
-          IF readonly = 1 THEN Texts.Write(W, "#") END ;
-          ReadType(R); Read(R, class)
-        END ;
-        Texts.Write(W, ")")
-      END ;
-      Files.ReadString(R, modname);
-      IF modname[0] # 0X THEN
-        Files.ReadInt(R, key); Files.ReadString(R, name);
-        Texts.Write(W, " "); Texts.WriteString(W, modname); Texts.Write(W, "."); Texts.WriteString(W, name);
-        Texts.WriteHex(W, key)
-      END
-    END ;
-    Form := form; Texts.Write(W, "]")
-  END ReadType;
-
-  PROCEDURE DecSym*;  (*decode symbol file*)
-    VAR class, typno, k: INTEGER;
-      name: ARRAY 32 OF CHAR;
-      F: Files.File; R: Files.Rider;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-      Texts.WriteString(W, "OR-decode "); Texts.WriteString(W, S.s);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-      F := Files.Old(S.s);
-      IF F # NIL THEN
-        Files.Set(R, F, 0); Files.ReadInt(R, k); Files.ReadInt(R, k);
-        Files.ReadString(R, name); Texts.WriteString(W, name); Texts.WriteHex(W, k);
-        Read(R, class); Texts.WriteInt(W, class, 3); (*sym file version*)
-        IF class = ORB.versionkey THEN
-          Texts.WriteLn(W); Read(R, class);
-          WHILE class # 0 DO
-            Texts.WriteInt(W, class, 4); Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
-            ReadType(R);
-            IF class = ORB.Typ THEN
-              Texts.Write(W, "("); Read(R, class);
-              WHILE class # 0 DO  (*pointer base fixup*)
-                Texts.WriteString(W, " ->"); Texts.WriteInt(W, class, 4); Read(R, class)
-              END ;
-              Texts.Write(W, ")")
-            ELSIF (class = ORB.Const) OR (class = ORB.Var) THEN
-              Files.ReadNum(R, k); Texts.WriteInt(W, k, 5);  (*Reals, Strings!*)
-            END ;
-            Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-            Read(R, class)
-          END
-        ELSE Texts.WriteString(W, " bad symfile version")
-        END
-      ELSE Texts.WriteString(W, " not found")
-      END ;
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-    END
-  END DecSym;
-  
-(* ---------------------------------------------------*)
-
-  PROCEDURE WriteReg(r: LONGINT);
-  BEGIN Texts.Write(W, " ");
-    IF r < 12 THEN Texts.WriteString(W, " R"); Texts.WriteInt(W, r MOD 10H, 1)
-    ELSIF r = 12 THEN Texts.WriteString(W, "MT")
-    ELSIF r = 13 THEN Texts.WriteString(W, "SB")
-    ELSIF r = 14 THEN Texts.WriteString(W, "SP")
-    ELSE Texts.WriteString(W, "LNK")
-    END
-  END WriteReg;
-
-  PROCEDURE opcode(w: LONGINT);
-    VAR k, op, u, a, b, c: LONGINT;
-  BEGIN
-      k := w DIV 40000000H MOD 4;
-      a := w DIV 1000000H MOD 10H;
-      b := w DIV 100000H MOD 10H;
-      op := w DIV 10000H MOD 10H;
-      u := w DIV 20000000H MOD 2;
-      IF k = 0 THEN
-        Texts.WriteString(W, mnemo0[op]);
-        IF u = 1 THEN Texts.Write(W, "'") END ;
-        WriteReg(a); WriteReg(b); WriteReg(w MOD 10H)
-      ELSIF k = 1 THEN
-        Texts.WriteString(W, mnemo0[op]);
-        IF u = 1 THEN Texts.Write(W, "'") END ;
-        WriteReg(a); WriteReg(b); w := w MOD 10000H;
-        IF w >= 8000H THEN w := w - 10000H END ;
-        Texts.WriteInt(W, w, 7)
-      ELSIF k = 2 THEN  (*LDR/STR*)
-        IF u = 1 THEN Texts.WriteString(W, "STR ") ELSE Texts.WriteString(W, "LDR") END ;
-        WriteReg(a); WriteReg(b); w := w MOD 100000H;
-        IF w >= 80000H THEN w := w - 100000H END ;
-        Texts.WriteInt(W, w, 8)
-      ELSIF k = 3 THEN  (*Branch instr*)
-        Texts.Write(W, "B");
-        IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ;
-        Texts.WriteString(W, mnemo1[a]);
-        IF u = 0 THEN WriteReg(w MOD 10H) ELSE
-          w := w MOD 100000H;
-          IF w >= 80000H THEN w := w - 100000H END ;
-          Texts.WriteInt(W, w, 8)
-        END
-      END
-  END opcode;
-
-  PROCEDURE Sync(VAR R: Files.Rider);
-    VAR ch: CHAR;
-  BEGIN Files.Read(R, ch); Texts.WriteString(W, "Sync "); Texts.Write(W, ch); Texts.WriteLn(W)
-  END Sync;
-  
-  PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
-  BEGIN Files.WriteByte(R, x)  (* -128 <= x < 128 *)
-  END Write;
-
-  PROCEDURE DecObj*;   (*decode object file*)
-    VAR class, i, n, key, size, fix, adr, data, len: INTEGER;
-      ch: CHAR;
-      name: ARRAY 32 OF CHAR;
-      F: Files.File; R: Files.Rider;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-      Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s); F := Files.Old(S.s);
-      IF F # NIL THEN
-        Files.Set(R, F, 0); Files.ReadString(R, name); Texts.WriteLn(W); Texts.WriteString(W, name);
-        Files.ReadInt(R, key); Texts.WriteHex(W, key); Read(R, class); Texts.WriteInt(W, class, 4); (*version*)
-        Files.ReadInt(R, size); Texts.WriteInt(W, size, 6); Texts.WriteLn(W);
-        Texts.WriteString(W, "imports:"); Texts.WriteLn(W); Files.ReadString(R, name);
-        WHILE name[0] # 0X DO
-          Texts.Write(W, 9X); Texts.WriteString(W, name);
-          Files.ReadInt(R, key); Texts.WriteHex(W, key); Texts.WriteLn(W);
-          Files.ReadString(R, name)
-        END ;
-      (* Sync(R); *)
-        Texts.WriteString(W, "type descriptors"); Texts.WriteLn(W);
-        Files.ReadInt(R, n); n := n DIV 4; i := 0;
-        WHILE i < n DO Files.ReadInt(R, data); Texts.WriteHex(W, data); INC(i) END ;
-        Texts.WriteLn(W);
-        Texts.WriteString(W, "data"); Files.ReadInt(R, data); Texts.WriteInt(W, data, 6); Texts.WriteLn(W);
-        Texts.WriteString(W, "strings"); Texts.WriteLn(W);
-        Files.ReadInt(R, n); i := 0;
-        WHILE i < n DO Files.Read(R, ch); Texts.Write(W, ch); INC(i) END ;
-        Texts.WriteLn(W);
-        Texts.WriteString(W, "code"); Texts.WriteLn(W);
-        Files.ReadInt(R, n); i := 0;
-        WHILE i < n DO
-          Files.ReadInt(R, data); Texts.WriteInt(W, i, 4); Texts.Write(W, 9X); Texts.WriteHex(W, data);
-          Texts.Write(W, 9X); opcode(data); Texts.WriteLn(W); INC(i)
-        END ;
-      (* Sync(R); *)
-        Texts.WriteString(W, "commands:"); Texts.WriteLn(W);
-        Files.ReadString(R, name);
-        WHILE name[0] # 0X DO
-          Texts.Write(W, 9X); Texts.WriteString(W, name);
-          Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 5); Texts.WriteLn(W);
-          Files.ReadString(R, name)
-        END ;
-      (* Sync(R); *)
-        Texts.WriteString(W, "entries"); Texts.WriteLn(W);
-        Files.ReadInt(R, n); i := 0;
-        WHILE i < n DO
-          Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 6); INC(i)
-        END ;
-        Texts.WriteLn(W);
-      (* Sync(R); *)
-        Texts.WriteString(W, "pointer refs"); Texts.WriteLn(W); Files.ReadInt(R, adr);
-        WHILE adr # -1 DO Texts.WriteInt(W, adr, 6); Files.ReadInt(R, adr) END ;
-        Texts.WriteLn(W);
-      (* Sync(R); *)
-        Files.ReadInt(R, data); Texts.WriteString(W, "fixP = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
-        Files.ReadInt(R, data); Texts.WriteString(W, "fixD = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
-        Files.ReadInt(R, data); Texts.WriteString(W, "fixT = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
-        Files.ReadInt(R, data); Texts.WriteString(W, "entry = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
-        Files.Read(R, ch);
-        IF ch # "O" THEN Texts.WriteString(W, "format eror"); Texts.WriteLn(W) END
-      (* Sync(R); *)
-      ELSE Texts.WriteString(W, " not found"); Texts.WriteLn(W)
-      END ;
-      Texts.Append(Oberon.Log, W.buf)
-    END
-  END DecObj;
-
-BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "ORTool 18.2.2013");
-  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-  mnemo0[0] := "MOV";
-  mnemo0[1] := "LSL";
-  mnemo0[2] := "ASR";
-  mnemo0[3] := "ROR";
-  mnemo0[4] := "AND";
-  mnemo0[5] := "ANN";
-  mnemo0[6] := "IOR";
-  mnemo0[7] := "XOR";
-  mnemo0[8] := "ADD";
-  mnemo0[9] := "SUB";
-  mnemo0[10] := "MUL";
-  mnemo0[11] := "DIV";
-  mnemo0[12] := "FAD";
-  mnemo0[13] := "FSB";
-  mnemo0[14] := "FML";
-  mnemo0[15] := "FDV";
-  mnemo1[0] := "MI ";
-  mnemo1[8] := "PL";
-  mnemo1[1] := "EQ ";
-  mnemo1[9] := "NE ";
-  mnemo1[2] := "LS ";
-  mnemo1[10] := "HI ";
-  mnemo1[5] := "LT ";
-  mnemo1[13] := "GE ";
-  mnemo1[6] := "LE ";
-  mnemo1[14] := "GT ";
-  mnemo1[15] := "NO ";
-END ORTool.
+MODULE ORTool;  (*NW 18.2.2013*)
+  IMPORT SYSTEM, Files, Texts, Oberon, ORB;
+  VAR W: Texts.Writer;
+    Form: INTEGER;  (*result of ReadType*)
+    mnemo0, mnemo1: ARRAY 16, 4 OF CHAR;  (*mnemonics*)
+
+  PROCEDURE Read(VAR R: Files.Rider; VAR n: INTEGER);
+    VAR b: BYTE;
+  BEGIN Files.ReadByte(R, b);
+    IF b < 80H THEN n := b ELSE n := b - 100H END
+  END Read;
+
+  PROCEDURE ReadType(VAR R: Files.Rider);
+    VAR key, len, lev, size, off: INTEGER;
+      ref, mno, class, form, readonly: INTEGER;
+      name, modname: ARRAY 32 OF CHAR;
+  BEGIN Read(R, ref); Texts.Write(W, " "); Texts.Write(W, "[");
+    IF ref < 0 THEN Texts.Write(W, "^"); Texts.WriteInt(W, -ref, 1)
+    ELSE Texts.WriteInt(W, ref, 1);
+      Read(R, form); Texts.WriteString(W, "  form = "); Texts.WriteInt(W, form, 1);
+      IF form = ORB.Pointer THEN ReadType(R)
+      ELSIF form = ORB.Array THEN
+        ReadType(R); Files.ReadNum(R, len); Files.ReadNum(R, size);
+        Texts.WriteString(W, "  len = "); Texts.WriteInt(W, len, 1);
+        Texts.WriteString(W, "  size = "); Texts.WriteInt(W, size, 1)
+      ELSIF form = ORB.Record THEN
+        ReadType(R);  (*base type*)
+        Files.ReadNum(R, off); Texts.WriteString(W, "  exno = "); Texts.WriteInt(W, off, 1); 
+        Files.ReadNum(R, off); Texts.WriteString(W, "  extlev = "); Texts.WriteInt(W, off, 1);
+        Files.ReadNum(R, size); Texts.WriteString(W, "  size = "); Texts.WriteInt(W, size, 1);
+        Texts.Write(W, " "); Texts.Write(W, "{"); Read(R, class);
+        WHILE class # 0 DO (*fields*)
+          Files.ReadString(R, name);
+          IF name[0] # 0X THEN Texts.Write(W, " "); Texts.WriteString(W, name); ReadType(R)
+          ELSE Texts.WriteString(W, " --")
+          END ;
+          Files.ReadNum(R, off); Texts.WriteInt(W, off, 4); Read(R, class)
+        END ;
+        Texts.Write(W, "}")
+      ELSIF form = ORB.Proc THEN
+        ReadType(R); Texts.Write(W, "("); Read(R, class);
+        WHILE class # 0 DO
+          Texts.WriteString(W, " class = "); Texts.WriteInt(W, class, 1); Read(R, readonly);
+          IF readonly = 1 THEN Texts.Write(W, "#") END ;
+          ReadType(R); Read(R, class)
+        END ;
+        Texts.Write(W, ")")
+      END ;
+      Files.ReadString(R, modname);
+      IF modname[0] # 0X THEN
+        Files.ReadInt(R, key); Files.ReadString(R, name);
+        Texts.Write(W, " "); Texts.WriteString(W, modname); Texts.Write(W, "."); Texts.WriteString(W, name);
+        Texts.WriteHex(W, key)
+      END
+    END ;
+    Form := form; Texts.Write(W, "]")
+  END ReadType;
+
+  PROCEDURE DecSym*;  (*decode symbol file*)
+    VAR class, typno, k: INTEGER;
+      name: ARRAY 32 OF CHAR;
+      F: Files.File; R: Files.Rider;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+      Texts.WriteString(W, "OR-decode "); Texts.WriteString(W, S.s);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+      F := Files.Old(S.s);
+      IF F # NIL THEN
+        Files.Set(R, F, 0); Files.ReadInt(R, k); Files.ReadInt(R, k);
+        Files.ReadString(R, name); Texts.WriteString(W, name); Texts.WriteHex(W, k);
+        Read(R, class); Texts.WriteInt(W, class, 3); (*sym file version*)
+        IF class = ORB.versionkey THEN
+          Texts.WriteLn(W); Read(R, class);
+          WHILE class # 0 DO
+            Texts.WriteInt(W, class, 4); Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
+            ReadType(R);
+            IF class = ORB.Typ THEN
+              Texts.Write(W, "("); Read(R, class);
+              WHILE class # 0 DO  (*pointer base fixup*)
+                Texts.WriteString(W, " ->"); Texts.WriteInt(W, class, 4); Read(R, class)
+              END ;
+              Texts.Write(W, ")")
+            ELSIF (class = ORB.Const) OR (class = ORB.Var) THEN
+              Files.ReadNum(R, k); Texts.WriteInt(W, k, 5);  (*Reals, Strings!*)
+            END ;
+            Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+            Read(R, class)
+          END
+        ELSE Texts.WriteString(W, " bad symfile version")
+        END
+      ELSE Texts.WriteString(W, " not found")
+      END ;
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+    END
+  END DecSym;
+  
+(* ---------------------------------------------------*)
+
+  PROCEDURE WriteReg(r: LONGINT);
+  BEGIN Texts.Write(W, " ");
+    IF r < 12 THEN Texts.WriteString(W, " R"); Texts.WriteInt(W, r MOD 10H, 1)
+    ELSIF r = 12 THEN Texts.WriteString(W, "MT")
+    ELSIF r = 13 THEN Texts.WriteString(W, "SB")
+    ELSIF r = 14 THEN Texts.WriteString(W, "SP")
+    ELSE Texts.WriteString(W, "LNK")
+    END
+  END WriteReg;
+
+  PROCEDURE opcode(w: LONGINT);
+    VAR k, op, u, a, b, c: LONGINT;
+  BEGIN
+      k := w DIV 40000000H MOD 4;
+      a := w DIV 1000000H MOD 10H;
+      b := w DIV 100000H MOD 10H;
+      op := w DIV 10000H MOD 10H;
+      u := w DIV 20000000H MOD 2;
+      IF k = 0 THEN
+        Texts.WriteString(W, mnemo0[op]);
+        IF u = 1 THEN Texts.Write(W, "'") END ;
+        WriteReg(a); WriteReg(b); WriteReg(w MOD 10H)
+      ELSIF k = 1 THEN
+        Texts.WriteString(W, mnemo0[op]);
+        IF u = 1 THEN Texts.Write(W, "'") END ;
+        WriteReg(a); WriteReg(b); w := w MOD 10000H;
+        IF w >= 8000H THEN w := w - 10000H END ;
+        Texts.WriteInt(W, w, 7)
+      ELSIF k = 2 THEN  (*LDR/STR*)
+        IF u = 1 THEN Texts.WriteString(W, "STR ") ELSE Texts.WriteString(W, "LDR") END ;
+        WriteReg(a); WriteReg(b); w := w MOD 100000H;
+        IF w >= 80000H THEN w := w - 100000H END ;
+        Texts.WriteInt(W, w, 8)
+      ELSIF k = 3 THEN  (*Branch instr*)
+        Texts.Write(W, "B");
+        IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ;
+        Texts.WriteString(W, mnemo1[a]);
+        IF u = 0 THEN WriteReg(w MOD 10H) ELSE
+          w := w MOD 100000H;
+          IF w >= 80000H THEN w := w - 100000H END ;
+          Texts.WriteInt(W, w, 8)
+        END
+      END
+  END opcode;
+
+  PROCEDURE Sync(VAR R: Files.Rider);
+    VAR ch: CHAR;
+  BEGIN Files.Read(R, ch); Texts.WriteString(W, "Sync "); Texts.Write(W, ch); Texts.WriteLn(W)
+  END Sync;
+  
+  PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
+  BEGIN Files.WriteByte(R, x)  (* -128 <= x < 128 *)
+  END Write;
+
+  PROCEDURE DecObj*;   (*decode object file*)
+    VAR class, i, n, key, size, fix, adr, data, len: INTEGER;
+      ch: CHAR;
+      name: ARRAY 32 OF CHAR;
+      F: Files.File; R: Files.Rider;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+      Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s); F := Files.Old(S.s);
+      IF F # NIL THEN
+        Files.Set(R, F, 0); Files.ReadString(R, name); Texts.WriteLn(W); Texts.WriteString(W, name);
+        Files.ReadInt(R, key); Texts.WriteHex(W, key); Read(R, class); Texts.WriteInt(W, class, 4); (*version*)
+        Files.ReadInt(R, size); Texts.WriteInt(W, size, 6); Texts.WriteLn(W);
+        Texts.WriteString(W, "imports:"); Texts.WriteLn(W); Files.ReadString(R, name);
+        WHILE name[0] # 0X DO
+          Texts.Write(W, 9X); Texts.WriteString(W, name);
+          Files.ReadInt(R, key); Texts.WriteHex(W, key); Texts.WriteLn(W);
+          Files.ReadString(R, name)
+        END ;
+      (* Sync(R); *)
+        Texts.WriteString(W, "type descriptors"); Texts.WriteLn(W);
+        Files.ReadInt(R, n); n := n DIV 4; i := 0;
+        WHILE i < n DO Files.ReadInt(R, data); Texts.WriteHex(W, data); INC(i) END ;
+        Texts.WriteLn(W);
+        Texts.WriteString(W, "data"); Files.ReadInt(R, data); Texts.WriteInt(W, data, 6); Texts.WriteLn(W);
+        Texts.WriteString(W, "strings"); Texts.WriteLn(W);
+        Files.ReadInt(R, n); i := 0;
+        WHILE i < n DO Files.Read(R, ch); Texts.Write(W, ch); INC(i) END ;
+        Texts.WriteLn(W);
+        Texts.WriteString(W, "code"); Texts.WriteLn(W);
+        Files.ReadInt(R, n); i := 0;
+        WHILE i < n DO
+          Files.ReadInt(R, data); Texts.WriteInt(W, i, 4); Texts.Write(W, 9X); Texts.WriteHex(W, data);
+          Texts.Write(W, 9X); opcode(data); Texts.WriteLn(W); INC(i)
+        END ;
+      (* Sync(R); *)
+        Texts.WriteString(W, "commands:"); Texts.WriteLn(W);
+        Files.ReadString(R, name);
+        WHILE name[0] # 0X DO
+          Texts.Write(W, 9X); Texts.WriteString(W, name);
+          Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 5); Texts.WriteLn(W);
+          Files.ReadString(R, name)
+        END ;
+      (* Sync(R); *)
+        Texts.WriteString(W, "entries"); Texts.WriteLn(W);
+        Files.ReadInt(R, n); i := 0;
+        WHILE i < n DO
+          Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 6); INC(i)
+        END ;
+        Texts.WriteLn(W);
+      (* Sync(R); *)
+        Texts.WriteString(W, "pointer refs"); Texts.WriteLn(W); Files.ReadInt(R, adr);
+        WHILE adr # -1 DO Texts.WriteInt(W, adr, 6); Files.ReadInt(R, adr) END ;
+        Texts.WriteLn(W);
+      (* Sync(R); *)
+        Files.ReadInt(R, data); Texts.WriteString(W, "fixP = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
+        Files.ReadInt(R, data); Texts.WriteString(W, "fixD = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
+        Files.ReadInt(R, data); Texts.WriteString(W, "fixT = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
+        Files.ReadInt(R, data); Texts.WriteString(W, "entry = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
+        Files.Read(R, ch);
+        IF ch # "O" THEN Texts.WriteString(W, "format eror"); Texts.WriteLn(W) END
+      (* Sync(R); *)
+      ELSE Texts.WriteString(W, " not found"); Texts.WriteLn(W)
+      END ;
+      Texts.Append(Oberon.Log, W.buf)
+    END
+  END DecObj;
+
+BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "ORTool 18.2.2013");
+  Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+  mnemo0[0] := "MOV";
+  mnemo0[1] := "LSL";
+  mnemo0[2] := "ASR";
+  mnemo0[3] := "ROR";
+  mnemo0[4] := "AND";
+  mnemo0[5] := "ANN";
+  mnemo0[6] := "IOR";
+  mnemo0[7] := "XOR";
+  mnemo0[8] := "ADD";
+  mnemo0[9] := "SUB";
+  mnemo0[10] := "MUL";
+  mnemo0[11] := "DIV";
+  mnemo0[12] := "FAD";
+  mnemo0[13] := "FSB";
+  mnemo0[14] := "FML";
+  mnemo0[15] := "FDV";
+  mnemo1[0] := "MI ";
+  mnemo1[8] := "PL";
+  mnemo1[1] := "EQ ";
+  mnemo1[9] := "NE ";
+  mnemo1[2] := "LS ";
+  mnemo1[10] := "HI ";
+  mnemo1[5] := "LT ";
+  mnemo1[13] := "GE ";
+  mnemo1[6] := "LE ";
+  mnemo1[14] := "GT ";
+  mnemo1[15] := "NO ";
+END ORTool.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Oberon.Mod.txt

@@ -1,411 +1,411 @@
-MODULE Oberon; (*JG 6.9.90 / 23.9.93 / 13.8.94 / NW 14.4.2013 / 22.12.2015*)
-  IMPORT SYSTEM, Kernel, Files, Modules, Input, Display, Viewers, Fonts, Texts;
-
-  CONST (*message ids*)
-    consume* = 0; track* = 1; defocus* = 0; neutralize* = 1; mark* = 2;
-    off = 0; idle = 1; active = 2;   (*task states*)
-    BasicCycle = 20;
-    ESC = 1BX; SETSTAR = 1AX;
-
-  TYPE Painter* = PROCEDURE (x, y: INTEGER);
-    Marker* = RECORD Fade*, Draw*: Painter END;
-    
-    Cursor* = RECORD
-        marker*: Marker; on*: BOOLEAN; X*, Y*: INTEGER
-    END;
-
-    InputMsg* = RECORD (Display.FrameMsg)
-      id*: INTEGER;
-      keys*: SET;
-      X*, Y*: INTEGER;
-      ch*: CHAR;
-      fnt*: Fonts.Font;
-      col*, voff*: INTEGER
-    END;
-
-    SelectionMsg* = RECORD (Display.FrameMsg)
-      time*: LONGINT;
-      text*: Texts.Text;
-      beg*, end*: LONGINT
-    END;
-
-    ControlMsg* = RECORD (Display.FrameMsg)
-      id*, X*, Y*: INTEGER
-    END;
-
-    CopyMsg* = RECORD (Display.FrameMsg)
-      F*: Display.Frame
-    END;
-
-    Task* = POINTER TO TaskDesc;
-
-    Handler* = PROCEDURE;
-
-    TaskDesc* = RECORD
-      state, nextTime, period*: INTEGER;
-      next: Task;
-      handle: Handler
-    END;
-
-  VAR User*: ARRAY 8 OF CHAR; Password*: LONGINT;
-    Arrow*, Star*: Marker;
-    Mouse, Pointer: Cursor;
-    FocusViewer*: Viewers.Viewer;
-    Log*: Texts.Text;
-
-    Par*: RECORD
-      vwr*: Viewers.Viewer;
-      frame*: Display.Frame;
-      text*: Texts.Text;
-      pos*: LONGINT
-    END;
-
-    CurFnt*: Fonts.Font;
-    CurCol*, CurOff*: INTEGER;
-    NofTasks*: INTEGER;
-
-    CurTask: Task;
-    DW, DH, CL: INTEGER;
-    ActCnt: INTEGER; (*action count for GC*)
-    Mod: Modules.Module;
-
-  (*user identification*)
-
-  PROCEDURE Code(VAR s: ARRAY OF CHAR): LONGINT;
-    VAR i: INTEGER; a, b, c: LONGINT;
-  BEGIN
-    a := 0; b := 0; i := 0;
-    WHILE s[i] # 0X DO
-      c := b; b := a; a := (c MOD 509 + 1) * 127 + ORD(s[i]);
-      INC(i)
-    END;
-    IF b >= 32768 THEN b := b - 65536 END;
-    RETURN b * 65536 + a
-  END Code;
-
-  PROCEDURE SetUser* (VAR user, password: ARRAY OF CHAR);
-  BEGIN User := user; Password := Code(password)
-  END SetUser;
-
-  PROCEDURE Clock*(): LONGINT;
-  BEGIN RETURN Kernel.Clock()
-  END Clock;
-
-  PROCEDURE SetClock* (d: LONGINT);
-  BEGIN Kernel.SetClock(d)
-  END SetClock;
-
-  PROCEDURE Time*(): LONGINT;
-  BEGIN RETURN Kernel.Time()
-  END Time;
-
-  (*cursor handling*)
-
-  PROCEDURE FlipArrow (X, Y: INTEGER);
-  BEGIN
-    IF X < CL THEN
-      IF X > DW - 15 THEN X := DW - 15 END
-    ELSE
-      IF X > CL + DW - 15 THEN X := CL + DW - 15 END
-    END;
-    IF Y < 14 THEN Y := 14 ELSIF Y > DH THEN Y := DH END;
-    Display.CopyPattern(Display.white, Display.arrow, X, Y - 14, Display.invert)
-  END FlipArrow;
-     
-  PROCEDURE FlipStar (X, Y: INTEGER);
-  BEGIN
-    IF X < CL THEN
-      IF X < 7 THEN X := 7 ELSIF X > DW - 8 THEN X := DW - 8 END
-    ELSE
-      IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 8 THEN X := CL + DW - 8 END
-    END ;
-    IF Y < 7 THEN Y := 7 ELSIF Y > DH - 8 THEN Y := DH - 8 END;
-    Display.CopyPattern(Display.white, Display.star, X - 7, Y - 7, Display.invert)
-  END FlipStar;
-
-  PROCEDURE OpenCursor(VAR c: Cursor);
-  BEGIN c.on := FALSE; c.X := 0; c.Y := 0
-  END OpenCursor;
- 
-  PROCEDURE FadeCursor(VAR c: Cursor);
-  BEGIN IF c.on THEN c.marker.Fade(c.X, c.Y); c.on := FALSE END
-  END FadeCursor;
-
-  PROCEDURE DrawCursor(VAR c: Cursor; m: Marker; x, y: INTEGER);
-  BEGIN
-    IF c.on & ((x # c.X) OR (y # c.Y) OR (m.Draw # c.marker.Draw)) THEN
-      c.marker.Fade(c.X, c.Y); c.on := FALSE
-    END;
-    IF ~c.on THEN
-      m.Draw(x, y); c.marker := m; c.X := x; c.Y := y; c.on := TRUE
-    END
-  END DrawCursor;
-
-  PROCEDURE DrawMouse*(m: Marker; x, y: INTEGER);
-  BEGIN DrawCursor(Mouse, m, x, y)
-  END DrawMouse;
-
-  PROCEDURE DrawMouseArrow*(x, y: INTEGER);
-  BEGIN DrawCursor(Mouse, Arrow, x, y)
-  END DrawMouseArrow;
-
-  PROCEDURE FadeMouse*;
-  BEGIN FadeCursor(Mouse)
-  END FadeMouse;
-
-  PROCEDURE DrawPointer*(x, y: INTEGER);
-  BEGIN DrawCursor(Pointer, Star, x, y)
-  END DrawPointer;
-
-  (*display management*)
-
-  PROCEDURE RemoveMarks* (X, Y, W, H: INTEGER);
-  BEGIN
-    IF (Mouse.X > X - 16) & (Mouse.X < X + W + 16) & (Mouse.Y > Y - 16) & (Mouse.Y < Y + H + 16) THEN
-      FadeCursor(Mouse)
-    END;
-    IF (Pointer.X > X - 8) & (Pointer.X < X + W + 8) & (Pointer.Y > Y - 8) & (Pointer.Y < Y + H + 8) THEN
-      FadeCursor(Pointer)
-    END
-  END RemoveMarks;
-
-  PROCEDURE HandleFiller (V: Display.Frame; VAR M: Display.FrameMsg);
-  BEGIN
-    CASE M OF
-    InputMsg: IF M.id = track THEN DrawCursor(Mouse, Arrow, M.X, M.Y) END |
-    ControlMsg: IF M.id = mark THEN DrawCursor(Pointer, Star, M.X, M.Y) END |
-    Viewers.ViewerMsg:
-      IF (M.id = Viewers.restore) & (V.W > 0) & (V.H > 0) THEN
-        RemoveMarks(V.X, V.Y, V.W, V.H);
-        Display.ReplConst(Display.black, V.X, V.Y, V.W, V.H, Display.replace)
-      ELSIF (M.id = Viewers.modify) & (M.Y < V.Y) THEN
-        RemoveMarks(V.X, M.Y, V.W, V.Y - M.Y);
-        Display.ReplConst(Display.black, V.X, M.Y, V.W, V.Y - M.Y, Display.replace)
-      END
-    END
-  END HandleFiller;
-
-  PROCEDURE OpenDisplay* (UW, SW, H: INTEGER);
-    VAR Filler: Viewers.Viewer;
-  BEGIN
-     Input.SetMouseLimits(Viewers.curW + UW + SW, H);
-     Display.ReplConst(Display.black, Viewers.curW, 0, UW + SW, H, Display.replace);
-     NEW(Filler); Filler.handle := HandleFiller;
-     Viewers.InitTrack(UW, H, Filler); (*init user track*)
-     NEW(Filler); Filler.handle := HandleFiller;
-     Viewers.InitTrack(SW, H, Filler) (*init system track*)
-  END OpenDisplay;
-
-  PROCEDURE DisplayWidth* (X: INTEGER): INTEGER;
-  BEGIN RETURN DW
-  END DisplayWidth;
-
-  PROCEDURE DisplayHeight* (X: INTEGER): INTEGER;
-  BEGIN RETURN DH
-  END DisplayHeight;
-
-  PROCEDURE OpenTrack* (X, W: INTEGER);
-    VAR Filler: Viewers.Viewer;
-  BEGIN
-    NEW(Filler); Filler.handle := HandleFiller;
-    Viewers.OpenTrack(X, W, Filler)
-  END OpenTrack;
-
-  PROCEDURE UserTrack* (X: INTEGER): INTEGER;
-  BEGIN RETURN X DIV DW * DW
-  END UserTrack;
-
-  PROCEDURE SystemTrack* (X: INTEGER): INTEGER;
-  BEGIN RETURN X DIV DW * DW + DW DIV 8 * 5
-  END SystemTrack;
-
-  PROCEDURE UY (X: INTEGER): INTEGER;
-    VAR h: INTEGER;
-      fil, bot, alt, max: Display.Frame;
-  BEGIN
-    Viewers.Locate(X, 0, fil, bot, alt, max);
-    IF fil.H >= DH DIV 8 THEN h := DH ELSE h := max.Y + max.H DIV 2 END ;
-    RETURN h
-  END UY;
-
-  PROCEDURE AllocateUserViewer* (DX: INTEGER; VAR X, Y: INTEGER);
-  BEGIN
-    IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
-    ELSE X := DX DIV DW * DW; Y := UY(X)
-    END
-  END AllocateUserViewer;
-
-  PROCEDURE SY (X: INTEGER): INTEGER;
-    VAR H0, H1, H2, H3, y: INTEGER;
-      fil, bot, alt, max: Display.Frame;
-  BEGIN H3 := DH - DH DIV 3;
-    H2 := H3 - H3 DIV 2; H1 := DH DIV 5; H0 := DH DIV 10;
-    Viewers.Locate(X, DH, fil, bot, alt, max);
-    IF fil.H >= DH DIV 8 THEN y := DH
-    ELSIF max.H >= DH - H0 THEN y := max.Y + H3
-    ELSIF max.H >= H3 - H0 THEN y := max.Y + H2
-    ELSIF max.H >= H2 - H0 THEN y := max.Y + H1
-    ELSIF max # bot THEN y := max.Y + max.H DIV 2
-    ELSIF bot.H >= H1 THEN y := bot.H DIV 2
-    ELSE y := alt.Y + alt.H DIV 2
-    END ;
-    RETURN y
-  END SY;
-
-  PROCEDURE AllocateSystemViewer* (DX: INTEGER; VAR X, Y: INTEGER);
-  BEGIN
-    IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
-    ELSE X := DX DIV DW * DW + DW DIV 8 * 5; Y := SY(X)
-    END
-  END AllocateSystemViewer;
-
-  PROCEDURE MarkedViewer* (): Viewers.Viewer;
-  BEGIN RETURN Viewers.This(Pointer.X, Pointer.Y)
-  END MarkedViewer;
-
-  PROCEDURE PassFocus* (V: Viewers.Viewer);
-    VAR M: ControlMsg;
-  BEGIN M.id := defocus; FocusViewer.handle(FocusViewer, M); FocusViewer := V
-  END PassFocus;
-
-  PROCEDURE OpenLog*(T: Texts.Text);
-  BEGIN Log := T
-  END OpenLog;
-
-  (*command interpretation*)
-  PROCEDURE SetPar*(F: Display.Frame; T: Texts.Text; pos: LONGINT);
-  BEGIN Par.vwr := Viewers.This(F.X, F.Y); Par.frame := F; Par.text := T; Par.pos := pos
-  END SetPar;
-
-  PROCEDURE Call* (name: ARRAY OF CHAR; VAR res: INTEGER);
-    VAR mod: Modules.Module; P: Modules.Command;
-      i, j: INTEGER; ch: CHAR;
-      Mname, Cname: ARRAY 32 OF CHAR;
-  BEGIN i := 0; ch := name[0];
-    WHILE (ch # ".") & (ch # 0X) DO Mname[i] := ch; INC(i); ch := name[i] END ;
-    IF ch = "." THEN
-      Mname[i] := 0X; INC(i);
-      Modules.Load(Mname, mod); res := Modules.res;
-      IF Modules.res = 0 THEN
-        j := 0; ch := name[i]; INC(i);
-        WHILE ch # 0X DO Cname[j] := ch; INC(j); ch := name[i]; INC(i) END ;
-        Cname[j] := 0X;
-        P := Modules.ThisCommand(mod, Cname); res := Modules.res;
-        IF Modules.res = 0 THEN P END
-      END
-    ELSE res := 5
-    END
-  END Call;
-
-  PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
-    VAR M: SelectionMsg;
-  BEGIN
-    M.time := -1; Viewers.Broadcast(M); time := M.time;
-    IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END
-  END GetSelection;
-
-  PROCEDURE GC;
-    VAR mod: Modules.Module;
-  BEGIN
-    IF (ActCnt <= 0) OR (Kernel.allocated >= Kernel.heapLim - Kernel.heapOrg - 10000H) THEN
-      mod := Modules.root; LED(21H);
-      WHILE mod # NIL DO
-        IF mod.name[0] # 0X THEN Kernel.Mark(mod.ptr) END ;
-        mod := mod.next
-      END ;
-      LED(23H);
-      Files.RestoreList; LED(27H);
-      Kernel.Scan; LED(20H);
-      ActCnt := BasicCycle
-    END
-  END GC;
-
-  PROCEDURE NewTask*(h: Handler; period: INTEGER): Task;
-    VAR t: Task;
-  BEGIN NEW(t); t.state := off; t.next := t; t.handle := h; t.period := period; RETURN t
-  END NewTask;
-  
-  PROCEDURE Install* (T: Task);
-  BEGIN
-    IF T.state = off THEN
-      T.next := CurTask.next; CurTask.next := T; T.state := idle; T.nextTime := 0; INC(NofTasks)
-    END
-  END Install;
-
-  PROCEDURE Remove* (T: Task);
-    VAR t: Task;
-  BEGIN
-    IF T.state # off THEN t := T;
-      WHILE t.next # T DO t := t.next END ;
-      t.next := T.next; T.state := off; T.next := NIL; CurTask := t; DEC(NofTasks)
-    END
-  END Remove;
-
-  PROCEDURE Collect* (count: INTEGER);
-  BEGIN ActCnt := count
-  END Collect;
-
-  PROCEDURE SetFont* (fnt: Fonts.Font);
-  BEGIN CurFnt := fnt
-  END SetFont;
-
-  PROCEDURE SetColor* (col: INTEGER);
-  BEGIN CurCol := col
-  END SetColor;
-
-  PROCEDURE SetOffset* (voff: INTEGER);
-  BEGIN CurOff := voff
-  END SetOffset;
-
-  PROCEDURE Loop*;
-    VAR V: Viewers.Viewer; M: InputMsg; N: ControlMsg;
-       prevX, prevY, X, Y, t: INTEGER; keys: SET; ch: CHAR;
-  BEGIN
-    REPEAT
-      Input.Mouse(keys, X, Y);
-      IF Input.Available() > 0 THEN Input.Read(ch);
-        IF ch = ESC THEN
-          N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer); LED(0)
-        ELSIF ch = SETSTAR THEN
-          N.id := mark; N.X := X; N.Y := Y; V := Viewers.This(X, Y); V.handle(V, N)
-        ELSE M.id := consume; M.ch := ch; M.fnt := CurFnt; M.col := CurCol; M.voff := CurOff;
-          FocusViewer.handle(FocusViewer, M); DEC(ActCnt)
-        END
-      ELSIF keys # {} THEN
-        M.id := track; M.X := X; M.Y := Y; M.keys := keys;
-        REPEAT V := Viewers.This(M.X, M.Y); V.handle(V, M); Input.Mouse(M.keys, M.X, M.Y)
-        UNTIL M.keys = {};
-        DEC(ActCnt)
-      ELSE
-        IF (X # prevX) OR (Y # prevY) OR ~Mouse.on THEN
-          M.id := track; M.X := X; 
-          IF Y >= Display.Height THEN Y := Display.Height END ;
-          M.Y := Y; M.keys := keys; V := Viewers.This(X, Y); V.handle(V, M); prevX := X; prevY := Y
-        END;
-        CurTask := CurTask.next; t := Kernel.Time();
-        IF t >= CurTask.nextTime THEN
-          CurTask.nextTime := t + CurTask.period; CurTask.state := active; CurTask.handle; CurTask.state := idle
-        END
-      END
-    UNTIL FALSE
-  END Loop;
-
-  PROCEDURE Reset*;
-  BEGIN
-    IF CurTask.state = active THEN Remove(CurTask) END ;
-    SYSTEM.LDREG(14, Kernel.stackOrg); (*reset stack pointer*) Loop
-  END Reset;
-
-BEGIN User[0] := 0X;
-  Arrow.Fade := FlipArrow; Arrow.Draw := FlipArrow;
-  Star.Fade := FlipStar; Star.Draw := FlipStar;
-  OpenCursor(Mouse); OpenCursor(Pointer);
-
-  DW := Display.Width; DH := Display.Height; CL := DW;
-  OpenDisplay(DW DIV 8 * 5, DW DIV 8 * 3, DH);
-  FocusViewer := Viewers.This(0, 0);
-  CurFnt := Fonts.Default; CurCol := Display.white; CurOff := 0;
-
-  ActCnt := 0; CurTask := NewTask(GC, 1000); Install(CurTask);
-  Modules.Load("System", Mod); Mod := NIL; Loop
+MODULE Oberon; (*JG 6.9.90 / 23.9.93 / 13.8.94 / NW 14.4.2013 / 22.12.2015*)
+  IMPORT SYSTEM, Kernel, Files, Modules, Input, Display, Viewers, Fonts, Texts;
+
+  CONST (*message ids*)
+    consume* = 0; track* = 1; defocus* = 0; neutralize* = 1; mark* = 2;
+    off = 0; idle = 1; active = 2;   (*task states*)
+    BasicCycle = 20;
+    ESC = 1BX; SETSTAR = 1AX;
+
+  TYPE Painter* = PROCEDURE (x, y: INTEGER);
+    Marker* = RECORD Fade*, Draw*: Painter END;
+    
+    Cursor* = RECORD
+        marker*: Marker; on*: BOOLEAN; X*, Y*: INTEGER
+    END;
+
+    InputMsg* = RECORD (Display.FrameMsg)
+      id*: INTEGER;
+      keys*: SET;
+      X*, Y*: INTEGER;
+      ch*: CHAR;
+      fnt*: Fonts.Font;
+      col*, voff*: INTEGER
+    END;
+
+    SelectionMsg* = RECORD (Display.FrameMsg)
+      time*: LONGINT;
+      text*: Texts.Text;
+      beg*, end*: LONGINT
+    END;
+
+    ControlMsg* = RECORD (Display.FrameMsg)
+      id*, X*, Y*: INTEGER
+    END;
+
+    CopyMsg* = RECORD (Display.FrameMsg)
+      F*: Display.Frame
+    END;
+
+    Task* = POINTER TO TaskDesc;
+
+    Handler* = PROCEDURE;
+
+    TaskDesc* = RECORD
+      state, nextTime, period*: INTEGER;
+      next: Task;
+      handle: Handler
+    END;
+
+  VAR User*: ARRAY 8 OF CHAR; Password*: LONGINT;
+    Arrow*, Star*: Marker;
+    Mouse, Pointer: Cursor;
+    FocusViewer*: Viewers.Viewer;
+    Log*: Texts.Text;
+
+    Par*: RECORD
+      vwr*: Viewers.Viewer;
+      frame*: Display.Frame;
+      text*: Texts.Text;
+      pos*: LONGINT
+    END;
+
+    CurFnt*: Fonts.Font;
+    CurCol*, CurOff*: INTEGER;
+    NofTasks*: INTEGER;
+
+    CurTask: Task;
+    DW, DH, CL: INTEGER;
+    ActCnt: INTEGER; (*action count for GC*)
+    Mod: Modules.Module;
+
+  (*user identification*)
+
+  PROCEDURE Code(VAR s: ARRAY OF CHAR): LONGINT;
+    VAR i: INTEGER; a, b, c: LONGINT;
+  BEGIN
+    a := 0; b := 0; i := 0;
+    WHILE s[i] # 0X DO
+      c := b; b := a; a := (c MOD 509 + 1) * 127 + ORD(s[i]);
+      INC(i)
+    END;
+    IF b >= 32768 THEN b := b - 65536 END;
+    RETURN b * 65536 + a
+  END Code;
+
+  PROCEDURE SetUser* (VAR user, password: ARRAY OF CHAR);
+  BEGIN User := user; Password := Code(password)
+  END SetUser;
+
+  PROCEDURE Clock*(): LONGINT;
+  BEGIN RETURN Kernel.Clock()
+  END Clock;
+
+  PROCEDURE SetClock* (d: LONGINT);
+  BEGIN Kernel.SetClock(d)
+  END SetClock;
+
+  PROCEDURE Time*(): LONGINT;
+  BEGIN RETURN Kernel.Time()
+  END Time;
+
+  (*cursor handling*)
+
+  PROCEDURE FlipArrow (X, Y: INTEGER);
+  BEGIN
+    IF X < CL THEN
+      IF X > DW - 15 THEN X := DW - 15 END
+    ELSE
+      IF X > CL + DW - 15 THEN X := CL + DW - 15 END
+    END;
+    IF Y < 14 THEN Y := 14 ELSIF Y > DH THEN Y := DH END;
+    Display.CopyPattern(Display.white, Display.arrow, X, Y - 14, Display.invert)
+  END FlipArrow;
+     
+  PROCEDURE FlipStar (X, Y: INTEGER);
+  BEGIN
+    IF X < CL THEN
+      IF X < 7 THEN X := 7 ELSIF X > DW - 8 THEN X := DW - 8 END
+    ELSE
+      IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 8 THEN X := CL + DW - 8 END
+    END ;
+    IF Y < 7 THEN Y := 7 ELSIF Y > DH - 8 THEN Y := DH - 8 END;
+    Display.CopyPattern(Display.white, Display.star, X - 7, Y - 7, Display.invert)
+  END FlipStar;
+
+  PROCEDURE OpenCursor(VAR c: Cursor);
+  BEGIN c.on := FALSE; c.X := 0; c.Y := 0
+  END OpenCursor;
+ 
+  PROCEDURE FadeCursor(VAR c: Cursor);
+  BEGIN IF c.on THEN c.marker.Fade(c.X, c.Y); c.on := FALSE END
+  END FadeCursor;
+
+  PROCEDURE DrawCursor(VAR c: Cursor; m: Marker; x, y: INTEGER);
+  BEGIN
+    IF c.on & ((x # c.X) OR (y # c.Y) OR (m.Draw # c.marker.Draw)) THEN
+      c.marker.Fade(c.X, c.Y); c.on := FALSE
+    END;
+    IF ~c.on THEN
+      m.Draw(x, y); c.marker := m; c.X := x; c.Y := y; c.on := TRUE
+    END
+  END DrawCursor;
+
+  PROCEDURE DrawMouse*(m: Marker; x, y: INTEGER);
+  BEGIN DrawCursor(Mouse, m, x, y)
+  END DrawMouse;
+
+  PROCEDURE DrawMouseArrow*(x, y: INTEGER);
+  BEGIN DrawCursor(Mouse, Arrow, x, y)
+  END DrawMouseArrow;
+
+  PROCEDURE FadeMouse*;
+  BEGIN FadeCursor(Mouse)
+  END FadeMouse;
+
+  PROCEDURE DrawPointer*(x, y: INTEGER);
+  BEGIN DrawCursor(Pointer, Star, x, y)
+  END DrawPointer;
+
+  (*display management*)
+
+  PROCEDURE RemoveMarks* (X, Y, W, H: INTEGER);
+  BEGIN
+    IF (Mouse.X > X - 16) & (Mouse.X < X + W + 16) & (Mouse.Y > Y - 16) & (Mouse.Y < Y + H + 16) THEN
+      FadeCursor(Mouse)
+    END;
+    IF (Pointer.X > X - 8) & (Pointer.X < X + W + 8) & (Pointer.Y > Y - 8) & (Pointer.Y < Y + H + 8) THEN
+      FadeCursor(Pointer)
+    END
+  END RemoveMarks;
+
+  PROCEDURE HandleFiller (V: Display.Frame; VAR M: Display.FrameMsg);
+  BEGIN
+    CASE M OF
+    InputMsg: IF M.id = track THEN DrawCursor(Mouse, Arrow, M.X, M.Y) END |
+    ControlMsg: IF M.id = mark THEN DrawCursor(Pointer, Star, M.X, M.Y) END |
+    Viewers.ViewerMsg:
+      IF (M.id = Viewers.restore) & (V.W > 0) & (V.H > 0) THEN
+        RemoveMarks(V.X, V.Y, V.W, V.H);
+        Display.ReplConst(Display.black, V.X, V.Y, V.W, V.H, Display.replace)
+      ELSIF (M.id = Viewers.modify) & (M.Y < V.Y) THEN
+        RemoveMarks(V.X, M.Y, V.W, V.Y - M.Y);
+        Display.ReplConst(Display.black, V.X, M.Y, V.W, V.Y - M.Y, Display.replace)
+      END
+    END
+  END HandleFiller;
+
+  PROCEDURE OpenDisplay* (UW, SW, H: INTEGER);
+    VAR Filler: Viewers.Viewer;
+  BEGIN
+     Input.SetMouseLimits(Viewers.curW + UW + SW, H);
+     Display.ReplConst(Display.black, Viewers.curW, 0, UW + SW, H, Display.replace);
+     NEW(Filler); Filler.handle := HandleFiller;
+     Viewers.InitTrack(UW, H, Filler); (*init user track*)
+     NEW(Filler); Filler.handle := HandleFiller;
+     Viewers.InitTrack(SW, H, Filler) (*init system track*)
+  END OpenDisplay;
+
+  PROCEDURE DisplayWidth* (X: INTEGER): INTEGER;
+  BEGIN RETURN DW
+  END DisplayWidth;
+
+  PROCEDURE DisplayHeight* (X: INTEGER): INTEGER;
+  BEGIN RETURN DH
+  END DisplayHeight;
+
+  PROCEDURE OpenTrack* (X, W: INTEGER);
+    VAR Filler: Viewers.Viewer;
+  BEGIN
+    NEW(Filler); Filler.handle := HandleFiller;
+    Viewers.OpenTrack(X, W, Filler)
+  END OpenTrack;
+
+  PROCEDURE UserTrack* (X: INTEGER): INTEGER;
+  BEGIN RETURN X DIV DW * DW
+  END UserTrack;
+
+  PROCEDURE SystemTrack* (X: INTEGER): INTEGER;
+  BEGIN RETURN X DIV DW * DW + DW DIV 8 * 5
+  END SystemTrack;
+
+  PROCEDURE UY (X: INTEGER): INTEGER;
+    VAR h: INTEGER;
+      fil, bot, alt, max: Display.Frame;
+  BEGIN
+    Viewers.Locate(X, 0, fil, bot, alt, max);
+    IF fil.H >= DH DIV 8 THEN h := DH ELSE h := max.Y + max.H DIV 2 END ;
+    RETURN h
+  END UY;
+
+  PROCEDURE AllocateUserViewer* (DX: INTEGER; VAR X, Y: INTEGER);
+  BEGIN
+    IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
+    ELSE X := DX DIV DW * DW; Y := UY(X)
+    END
+  END AllocateUserViewer;
+
+  PROCEDURE SY (X: INTEGER): INTEGER;
+    VAR H0, H1, H2, H3, y: INTEGER;
+      fil, bot, alt, max: Display.Frame;
+  BEGIN H3 := DH - DH DIV 3;
+    H2 := H3 - H3 DIV 2; H1 := DH DIV 5; H0 := DH DIV 10;
+    Viewers.Locate(X, DH, fil, bot, alt, max);
+    IF fil.H >= DH DIV 8 THEN y := DH
+    ELSIF max.H >= DH - H0 THEN y := max.Y + H3
+    ELSIF max.H >= H3 - H0 THEN y := max.Y + H2
+    ELSIF max.H >= H2 - H0 THEN y := max.Y + H1
+    ELSIF max # bot THEN y := max.Y + max.H DIV 2
+    ELSIF bot.H >= H1 THEN y := bot.H DIV 2
+    ELSE y := alt.Y + alt.H DIV 2
+    END ;
+    RETURN y
+  END SY;
+
+  PROCEDURE AllocateSystemViewer* (DX: INTEGER; VAR X, Y: INTEGER);
+  BEGIN
+    IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
+    ELSE X := DX DIV DW * DW + DW DIV 8 * 5; Y := SY(X)
+    END
+  END AllocateSystemViewer;
+
+  PROCEDURE MarkedViewer* (): Viewers.Viewer;
+  BEGIN RETURN Viewers.This(Pointer.X, Pointer.Y)
+  END MarkedViewer;
+
+  PROCEDURE PassFocus* (V: Viewers.Viewer);
+    VAR M: ControlMsg;
+  BEGIN M.id := defocus; FocusViewer.handle(FocusViewer, M); FocusViewer := V
+  END PassFocus;
+
+  PROCEDURE OpenLog*(T: Texts.Text);
+  BEGIN Log := T
+  END OpenLog;
+
+  (*command interpretation*)
+  PROCEDURE SetPar*(F: Display.Frame; T: Texts.Text; pos: LONGINT);
+  BEGIN Par.vwr := Viewers.This(F.X, F.Y); Par.frame := F; Par.text := T; Par.pos := pos
+  END SetPar;
+
+  PROCEDURE Call* (name: ARRAY OF CHAR; VAR res: INTEGER);
+    VAR mod: Modules.Module; P: Modules.Command;
+      i, j: INTEGER; ch: CHAR;
+      Mname, Cname: ARRAY 32 OF CHAR;
+  BEGIN i := 0; ch := name[0];
+    WHILE (ch # ".") & (ch # 0X) DO Mname[i] := ch; INC(i); ch := name[i] END ;
+    IF ch = "." THEN
+      Mname[i] := 0X; INC(i);
+      Modules.Load(Mname, mod); res := Modules.res;
+      IF Modules.res = 0 THEN
+        j := 0; ch := name[i]; INC(i);
+        WHILE ch # 0X DO Cname[j] := ch; INC(j); ch := name[i]; INC(i) END ;
+        Cname[j] := 0X;
+        P := Modules.ThisCommand(mod, Cname); res := Modules.res;
+        IF Modules.res = 0 THEN P END
+      END
+    ELSE res := 5
+    END
+  END Call;
+
+  PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
+    VAR M: SelectionMsg;
+  BEGIN
+    M.time := -1; Viewers.Broadcast(M); time := M.time;
+    IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END
+  END GetSelection;
+
+  PROCEDURE GC;
+    VAR mod: Modules.Module;
+  BEGIN
+    IF (ActCnt <= 0) OR (Kernel.allocated >= Kernel.heapLim - Kernel.heapOrg - 10000H) THEN
+      mod := Modules.root; LED(21H);
+      WHILE mod # NIL DO
+        IF mod.name[0] # 0X THEN Kernel.Mark(mod.ptr) END ;
+        mod := mod.next
+      END ;
+      LED(23H);
+      Files.RestoreList; LED(27H);
+      Kernel.Scan; LED(20H);
+      ActCnt := BasicCycle
+    END
+  END GC;
+
+  PROCEDURE NewTask*(h: Handler; period: INTEGER): Task;
+    VAR t: Task;
+  BEGIN NEW(t); t.state := off; t.next := t; t.handle := h; t.period := period; RETURN t
+  END NewTask;
+  
+  PROCEDURE Install* (T: Task);
+  BEGIN
+    IF T.state = off THEN
+      T.next := CurTask.next; CurTask.next := T; T.state := idle; T.nextTime := 0; INC(NofTasks)
+    END
+  END Install;
+
+  PROCEDURE Remove* (T: Task);
+    VAR t: Task;
+  BEGIN
+    IF T.state # off THEN t := T;
+      WHILE t.next # T DO t := t.next END ;
+      t.next := T.next; T.state := off; T.next := NIL; CurTask := t; DEC(NofTasks)
+    END
+  END Remove;
+
+  PROCEDURE Collect* (count: INTEGER);
+  BEGIN ActCnt := count
+  END Collect;
+
+  PROCEDURE SetFont* (fnt: Fonts.Font);
+  BEGIN CurFnt := fnt
+  END SetFont;
+
+  PROCEDURE SetColor* (col: INTEGER);
+  BEGIN CurCol := col
+  END SetColor;
+
+  PROCEDURE SetOffset* (voff: INTEGER);
+  BEGIN CurOff := voff
+  END SetOffset;
+
+  PROCEDURE Loop*;
+    VAR V: Viewers.Viewer; M: InputMsg; N: ControlMsg;
+       prevX, prevY, X, Y, t: INTEGER; keys: SET; ch: CHAR;
+  BEGIN
+    REPEAT
+      Input.Mouse(keys, X, Y);
+      IF Input.Available() > 0 THEN Input.Read(ch);
+        IF ch = ESC THEN
+          N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer); LED(0)
+        ELSIF ch = SETSTAR THEN
+          N.id := mark; N.X := X; N.Y := Y; V := Viewers.This(X, Y); V.handle(V, N)
+        ELSE M.id := consume; M.ch := ch; M.fnt := CurFnt; M.col := CurCol; M.voff := CurOff;
+          FocusViewer.handle(FocusViewer, M); DEC(ActCnt)
+        END
+      ELSIF keys # {} THEN
+        M.id := track; M.X := X; M.Y := Y; M.keys := keys;
+        REPEAT V := Viewers.This(M.X, M.Y); V.handle(V, M); Input.Mouse(M.keys, M.X, M.Y)
+        UNTIL M.keys = {};
+        DEC(ActCnt)
+      ELSE
+        IF (X # prevX) OR (Y # prevY) OR ~Mouse.on THEN
+          M.id := track; M.X := X; 
+          IF Y >= Display.Height THEN Y := Display.Height END ;
+          M.Y := Y; M.keys := keys; V := Viewers.This(X, Y); V.handle(V, M); prevX := X; prevY := Y
+        END;
+        CurTask := CurTask.next; t := Kernel.Time();
+        IF t >= CurTask.nextTime THEN
+          CurTask.nextTime := t + CurTask.period; CurTask.state := active; CurTask.handle; CurTask.state := idle
+        END
+      END
+    UNTIL FALSE
+  END Loop;
+
+  PROCEDURE Reset*;
+  BEGIN
+    IF CurTask.state = active THEN Remove(CurTask) END ;
+    SYSTEM.LDREG(14, Kernel.stackOrg); (*reset stack pointer*) Loop
+  END Reset;
+
+BEGIN User[0] := 0X;
+  Arrow.Fade := FlipArrow; Arrow.Draw := FlipArrow;
+  Star.Fade := FlipStar; Star.Draw := FlipStar;
+  OpenCursor(Mouse); OpenCursor(Pointer);
+
+  DW := Display.Width; DH := Display.Height; CL := DW;
+  OpenDisplay(DW DIV 8 * 5, DW DIV 8 * 3, DH);
+  FocusViewer := Viewers.This(0, 0);
+  CurFnt := Fonts.Default; CurCol := Display.white; CurOff := 0;
+
+  ActCnt := 0; CurTask := NewTask(GC, 1000); Install(CurTask);
+  Modules.Load("System", Mod); Mod := NIL; Loop
 END Oberon.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/OberonSyntax.Text.txt

@@ -1,72 +1,72 @@
-digit  =   "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".
-hexDigit  =  digit | "A" | "B" | "C" | "D" | "E" | "F".
-ident  =  letter {letter | digit}.
-qualident  =  [ident "."] ident.
-identdef = ident ["*"].
-integer  =  digit {digit} | digit {hexDigit} "H".
-real  =  digit {digit} "." {digit} [ScaleFactor].
-ScaleFactor  =  ("E" |"D") ["+" | "-"] digit {digit}.
-number  =  integer | real.
-string  =  "'" {character} "'" | digit {hexdigit} "X".
-ConstDeclaration  =  identdef "=" ConstExpression.
-ConstExpression  =  expression.
-TypeDeclaration  =  identdef "=" StrucType.
-StrucType  =  ArrayType | RecordType | PointerType | ProcedureType.
-type  =  qualident | StrucType.
-ArrayType  =  "ARRAY" length {"," length} "OF" type.
-length  =  ConstExpression.
-RecordType  =  "RECORD" ["(" BaseType ")"] [FieldListSequence] "END".
-BaseType  =  qualident.
-FieldListSequence  =  FieldList {";" FieldList}.
-FieldList  =  IdentList ":" type.
-IdentList  =  identdef {"," identdef}.
-PointerType  =  "POINTER" "TO" type.
-ProcedureType  =  "PROCEDURE" [FormalParameters].
-VariableDeclaration  =  IdentList ":" type.
-expression  =  SimpleExpression [relation SimpleExpression].
-relation  =  "=" | "#" | "<" | "<=" | ">" | ">=" | "IN" | "IS".
-SimpleExpression  =  ["+" | "-"] term {AddOperator term}.
-AddOperator  =  "+" | "-" | "OR".
-term  =  factor {MulOperator factor}.
-MulOperator  =  "*" | "/" | "DIV" | "MOD" | "&".
-factor  =  number | string | "NIL" | "TRUE" | "FALSE" |
-  set | designator [ActualParameters] | "(" expression ")" | "~" factor.
-designator  =  qualident {selector}.
-selector  =  "." ident | "[" ExpList "]" | "^" |  "(" qualident ")".
-set  =  "{" [element {"," element}] "}".
-element  =  expression [".." expression].
-ExpList  =  expression {"," expression}.
-ActualParameters  =  "(" [ExpList] ")" .
-statement  =  [assignment | ProcedureCall | IfStatement | CaseStatement |
-  WhileStatement | RepeatStatement | ForStatement].
-assignment  =  designator ":=" expression.
-ProcedureCall  =  designator [ActualParameters].
-StatementSequence  =  statement {";" statement}.
-IfStatement  =  "IF" expression "THEN" StatementSequence
-  {"ELSIF" expression "THEN" StatementSequence}
-  ["ELSE" StatementSequence] "END".
-CaseStatement  =  "CASE" expression "OF" case {"|" case} "END".
-Case  =  CaseLabelList ":"  StatementSequence.
-CaseLabelList  = LabelRange {"," LabelRange}.
-LabelRange  =  label [".." label].
-label  =  integer | string | ident.
-WhileStatement  =  "WHILE" expression "DO" StatementSequence
-{"ELSIF" expression "DO" StatementSequence} "END".
-RepeatStatement  =  "REPEAT" StatementSequence "UNTIL" expression.
-ForStatement  =  "FOR" ident ":=" expression "TO" expression ["BY" ConstExpression]
-"DO" StatementSequence "END".
-ProcedureDeclaration  =  ProcedureHeading ";" ProcedureBody ident.
-ProcedureHeading  =  "PROCEDURE" identdef [FormalParameters].
-ProcedureBody  =  DeclarationSequence ["BEGIN" StatementSequence]
-    ["RETURN" expression] "END".
-DeclarationSequence  =  ["CONST" {ConstDeclaration ";"}]
-  ["TYPE" {TypeDeclaration ";"}]
-  ["VAR" {VariableDeclaration ";"}]
-  {ProcedureDeclaration ";"}.
-FormalParameters  =  "(" [FPSection {";" FPSection}] ")" [":" qualident].
-FPSection  =  ["CONST" | "VAR"] ident {"," ident} ":" FormalType.
-FormalType  =  ["ARRAY" "OF"] qualident.
-module  =  "MODULE" ident ";" [ImportList] DeclarationSequence
-  ["BEGIN" StatementSequence] "END" ident "." .
-ImportList  =  "IMPORT" import {"," import} ";".
-import  =  ident [":=" ident].
+digit  =   "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".
+hexDigit  =  digit | "A" | "B" | "C" | "D" | "E" | "F".
+ident  =  letter {letter | digit}.
+qualident  =  [ident "."] ident.
+identdef = ident ["*"].
+integer  =  digit {digit} | digit {hexDigit} "H".
+real  =  digit {digit} "." {digit} [ScaleFactor].
+ScaleFactor  =  ("E" |"D") ["+" | "-"] digit {digit}.
+number  =  integer | real.
+string  =  "'" {character} "'" | digit {hexdigit} "X".
+ConstDeclaration  =  identdef "=" ConstExpression.
+ConstExpression  =  expression.
+TypeDeclaration  =  identdef "=" StrucType.
+StrucType  =  ArrayType | RecordType | PointerType | ProcedureType.
+type  =  qualident | StrucType.
+ArrayType  =  "ARRAY" length {"," length} "OF" type.
+length  =  ConstExpression.
+RecordType  =  "RECORD" ["(" BaseType ")"] [FieldListSequence] "END".
+BaseType  =  qualident.
+FieldListSequence  =  FieldList {";" FieldList}.
+FieldList  =  IdentList ":" type.
+IdentList  =  identdef {"," identdef}.
+PointerType  =  "POINTER" "TO" type.
+ProcedureType  =  "PROCEDURE" [FormalParameters].
+VariableDeclaration  =  IdentList ":" type.
+expression  =  SimpleExpression [relation SimpleExpression].
+relation  =  "=" | "#" | "<" | "<=" | ">" | ">=" | "IN" | "IS".
+SimpleExpression  =  ["+" | "-"] term {AddOperator term}.
+AddOperator  =  "+" | "-" | "OR".
+term  =  factor {MulOperator factor}.
+MulOperator  =  "*" | "/" | "DIV" | "MOD" | "&".
+factor  =  number | string | "NIL" | "TRUE" | "FALSE" |
+  set | designator [ActualParameters] | "(" expression ")" | "~" factor.
+designator  =  qualident {selector}.
+selector  =  "." ident | "[" ExpList "]" | "^" |  "(" qualident ")".
+set  =  "{" [element {"," element}] "}".
+element  =  expression [".." expression].
+ExpList  =  expression {"," expression}.
+ActualParameters  =  "(" [ExpList] ")" .
+statement  =  [assignment | ProcedureCall | IfStatement | CaseStatement |
+  WhileStatement | RepeatStatement | ForStatement].
+assignment  =  designator ":=" expression.
+ProcedureCall  =  designator [ActualParameters].
+StatementSequence  =  statement {";" statement}.
+IfStatement  =  "IF" expression "THEN" StatementSequence
+  {"ELSIF" expression "THEN" StatementSequence}
+  ["ELSE" StatementSequence] "END".
+CaseStatement  =  "CASE" expression "OF" case {"|" case} "END".
+Case  =  CaseLabelList ":"  StatementSequence.
+CaseLabelList  = LabelRange {"," LabelRange}.
+LabelRange  =  label [".." label].
+label  =  integer | string | ident.
+WhileStatement  =  "WHILE" expression "DO" StatementSequence
+{"ELSIF" expression "DO" StatementSequence} "END".
+RepeatStatement  =  "REPEAT" StatementSequence "UNTIL" expression.
+ForStatement  =  "FOR" ident ":=" expression "TO" expression ["BY" ConstExpression]
+"DO" StatementSequence "END".
+ProcedureDeclaration  =  ProcedureHeading ";" ProcedureBody ident.
+ProcedureHeading  =  "PROCEDURE" identdef [FormalParameters].
+ProcedureBody  =  DeclarationSequence ["BEGIN" StatementSequence]
+    ["RETURN" expression] "END".
+DeclarationSequence  =  ["CONST" {ConstDeclaration ";"}]
+  ["TYPE" {TypeDeclaration ";"}]
+  ["VAR" {VariableDeclaration ";"}]
+  {ProcedureDeclaration ";"}.
+FormalParameters  =  "(" [FPSection {";" FPSection}] ")" [":" qualident].
+FPSection  =  ["CONST" | "VAR"] ident {"," ident} ":" FormalType.
+FormalType  =  ["ARRAY" "OF"] qualident.
+module  =  "MODULE" ident ";" [ImportList] DeclarationSequence
+  ["BEGIN" StatementSequence] "END" ident "." .
+ImportList  =  "IMPORT" import {"," import} ";".
+import  =  ident [":=" ident].

people.inf.ethz.ch/wirth/ProjectOberon/Sources/PCLink1.Mod.txt

@@ -1,88 +1,88 @@
-MODULE PCLink1;  (*NW 25.7.2013  for Oberon on RISC*)
-  IMPORT SYSTEM, Files, Texts, Oberon;
-  
-  CONST data = -56; stat = -52;
-    BlkLen = 255;
-    REQ = 20H; REC = 21H; SND = 22H; ACK = 10H; NAK = 11H;
-
-  VAR T: Oberon.Task;
-    W: Texts.Writer;
-
-  PROCEDURE Rec(VAR x: BYTE);
-  BEGIN
-    REPEAT UNTIL SYSTEM.BIT(stat, 0);
-    SYSTEM.GET(data, x)
-  END Rec;
-
-  PROCEDURE RecName(VAR s: ARRAY OF CHAR);
-    VAR i: INTEGER; x: BYTE;
-  BEGIN i := 0; Rec(x);
-    WHILE x > 0 DO s[i] := CHR(x); INC(i); Rec(x) END ;
-    s[i] := 0X
-  END RecName;
-
-  PROCEDURE Send(x: BYTE);
-  BEGIN
-    REPEAT UNTIL SYSTEM.BIT(stat, 1);
-    SYSTEM.PUT(data, x)
-  END Send;
-
-  PROCEDURE Task;
-    VAR len, n, i: INTEGER;
-      x, ack, len1, code: BYTE;
-      name: ARRAY 32 OF CHAR;
-      F: Files.File; R: Files.Rider;
-      buf: ARRAY 256 OF BYTE;
-  BEGIN
-    IF  SYSTEM.BIT(stat, 0) THEN (*byte available*)
-      Rec(code);
-        IF code = SND THEN  (*send file*)
-          LED(20H); RecName(name); F := Files.Old(name);
-          IF F # NIL THEN
-            Texts.WriteString(W, "sending "); Texts.WriteString(W, name);
-            Texts.Append(Oberon.Log, W.buf);
-            Send(ACK); len := Files.Length(F); Files.Set(R, F, 0);
-            REPEAT
-              IF len >= BlkLen THEN len1 := BlkLen ELSE len1 := len END ;
-              Send(len1); n := len1; len := len - len1;
-              WHILE n > 0 DO Files.ReadByte(R, x); Send(x); DEC(n) END ;
-              Rec(ack);
-              IF ack # ACK THEN  len1 := 0 END
-            UNTIL len1 < BlkLen;
-            Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-          ELSE Send(11H)
-          END
-        ELSIF code = REC THEN (*receive file*)
-          LED(30H); RecName(name); F := Files.New(name);
-          IF F # NIL THEN
-            Texts.WriteString(W, "receiving "); Texts.WriteString(W, name);
-            Texts.Append(Oberon.Log, W.buf);
-            Files.Set(R, F, 0); Send(ACK);
-            REPEAT Rec(x); len := x; i := 0;
-              WHILE i < len DO Rec(x); buf[i] := x; INC(i) END ;
-              i := 0;
-              WHILE i < len DO Files.WriteByte(R, buf[i]); INC(i) END ;
-              Send(ACK)
-            UNTIL len < 255;
-            Files.Register(F); Send(ACK);
-            Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-          ELSE Send(NAK)
-          END
-        ELSIF code = REQ THEN Send(ACK)
-        END ;
-      LED(0)
-    END
-  END Task;
-
-  PROCEDURE Run*;
-  BEGIN Oberon.Install(T); Texts.WriteString(W, "PCLink started");
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END Run;
-
-  PROCEDURE Stop*;
-  BEGIN Oberon.Remove(T); Texts.WriteString(W, "PCLink stopped");
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END Stop;
-
-BEGIN Texts.OpenWriter(W); T := Oberon.NewTask(Task, 0)
-END PCLink1.
+MODULE PCLink1;  (*NW 25.7.2013  for Oberon on RISC*)
+  IMPORT SYSTEM, Files, Texts, Oberon;
+  
+  CONST data = -56; stat = -52;
+    BlkLen = 255;
+    REQ = 20H; REC = 21H; SND = 22H; ACK = 10H; NAK = 11H;
+
+  VAR T: Oberon.Task;
+    W: Texts.Writer;
+
+  PROCEDURE Rec(VAR x: BYTE);
+  BEGIN
+    REPEAT UNTIL SYSTEM.BIT(stat, 0);
+    SYSTEM.GET(data, x)
+  END Rec;
+
+  PROCEDURE RecName(VAR s: ARRAY OF CHAR);
+    VAR i: INTEGER; x: BYTE;
+  BEGIN i := 0; Rec(x);
+    WHILE x > 0 DO s[i] := CHR(x); INC(i); Rec(x) END ;
+    s[i] := 0X
+  END RecName;
+
+  PROCEDURE Send(x: BYTE);
+  BEGIN
+    REPEAT UNTIL SYSTEM.BIT(stat, 1);
+    SYSTEM.PUT(data, x)
+  END Send;
+
+  PROCEDURE Task;
+    VAR len, n, i: INTEGER;
+      x, ack, len1, code: BYTE;
+      name: ARRAY 32 OF CHAR;
+      F: Files.File; R: Files.Rider;
+      buf: ARRAY 256 OF BYTE;
+  BEGIN
+    IF  SYSTEM.BIT(stat, 0) THEN (*byte available*)
+      Rec(code);
+        IF code = SND THEN  (*send file*)
+          LED(20H); RecName(name); F := Files.Old(name);
+          IF F # NIL THEN
+            Texts.WriteString(W, "sending "); Texts.WriteString(W, name);
+            Texts.Append(Oberon.Log, W.buf);
+            Send(ACK); len := Files.Length(F); Files.Set(R, F, 0);
+            REPEAT
+              IF len >= BlkLen THEN len1 := BlkLen ELSE len1 := len END ;
+              Send(len1); n := len1; len := len - len1;
+              WHILE n > 0 DO Files.ReadByte(R, x); Send(x); DEC(n) END ;
+              Rec(ack);
+              IF ack # ACK THEN  len1 := 0 END
+            UNTIL len1 < BlkLen;
+            Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+          ELSE Send(11H)
+          END
+        ELSIF code = REC THEN (*receive file*)
+          LED(30H); RecName(name); F := Files.New(name);
+          IF F # NIL THEN
+            Texts.WriteString(W, "receiving "); Texts.WriteString(W, name);
+            Texts.Append(Oberon.Log, W.buf);
+            Files.Set(R, F, 0); Send(ACK);
+            REPEAT Rec(x); len := x; i := 0;
+              WHILE i < len DO Rec(x); buf[i] := x; INC(i) END ;
+              i := 0;
+              WHILE i < len DO Files.WriteByte(R, buf[i]); INC(i) END ;
+              Send(ACK)
+            UNTIL len < 255;
+            Files.Register(F); Send(ACK);
+            Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+          ELSE Send(NAK)
+          END
+        ELSIF code = REQ THEN Send(ACK)
+        END ;
+      LED(0)
+    END
+  END Task;
+
+  PROCEDURE Run*;
+  BEGIN Oberon.Install(T); Texts.WriteString(W, "PCLink started");
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END Run;
+
+  PROCEDURE Stop*;
+  BEGIN Oberon.Remove(T); Texts.WriteString(W, "PCLink stopped");
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END Stop;
+
+BEGIN Texts.OpenWriter(W); T := Oberon.NewTask(Task, 0)
+END PCLink1.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/PIO.Mod.txt

@@ -1,42 +1,42 @@
-MODULE PIO;   (*NW 16.10.2014  PIC Input/Output for RISC*)
-  IMPORT SYSTEM;
-  
-(* PIC interface, output:
-  D0  =  PIC B7  data out
-  D1  =  PIC B6  clk  out
-  D2  =  PIC A4  data in *)
-
-  CONST gpio = -32; gpoc = -28;  (*I/O addresses*)
-
-  PROCEDURE del(i: INTEGER);
-  BEGIN
-    REPEAT DEC(i) UNTIL i = 0
-  END del;
-
-  PROCEDURE Send*(x: LONGINT);
-    VAR i: INTEGER;
-  BEGIN (*send byte*)
-    FOR i := 0 TO 7 DO
-      SYSTEM.PUT(gpio, x MOD 2 + 2); del(60); SYSTEM.PUT(gpio, x MOD 2); del(25); x := x DIV 2
-    END ;
-    SYSTEM.PUT(gpio, 0); del(100)
-  END Send;
-
-  PROCEDURE Receive*(VAR x: LONGINT);
-    VAR i, x0: INTEGER;
-  BEGIN (*receive byte*) x0 := 0;
-    REPEAT UNTIL ~SYSTEM.BIT(gpio, 2);
-    FOR i := 0 TO 7 DO
-      SYSTEM.PUT(gpio, 2); del(60);
-      IF SYSTEM.BIT(gpio, 2) THEN x0 := x0 + 100H END ;
-      SYSTEM.PUT(gpio, 0); del(25); x0 := ROR(x0, 1)
-    END ;
-    x := x0
-  END Receive;
-
-  PROCEDURE Reset*;
-  BEGIN SYSTEM.PUT(gpio, 0); SYSTEM.PUT(gpoc, 3)  (*set bit 0, 1 to output*)
-  END Reset;
-
-BEGIN Reset
-END PIO.
+MODULE PIO;   (*NW 16.10.2014  PIC Input/Output for RISC*)
+  IMPORT SYSTEM;
+  
+(* PIC interface, output:
+  D0  =  PIC B7  data out
+  D1  =  PIC B6  clk  out
+  D2  =  PIC A4  data in *)
+
+  CONST gpio = -32; gpoc = -28;  (*I/O addresses*)
+
+  PROCEDURE del(i: INTEGER);
+  BEGIN
+    REPEAT DEC(i) UNTIL i = 0
+  END del;
+
+  PROCEDURE Send*(x: LONGINT);
+    VAR i: INTEGER;
+  BEGIN (*send byte*)
+    FOR i := 0 TO 7 DO
+      SYSTEM.PUT(gpio, x MOD 2 + 2); del(60); SYSTEM.PUT(gpio, x MOD 2); del(25); x := x DIV 2
+    END ;
+    SYSTEM.PUT(gpio, 0); del(100)
+  END Send;
+
+  PROCEDURE Receive*(VAR x: LONGINT);
+    VAR i, x0: INTEGER;
+  BEGIN (*receive byte*) x0 := 0;
+    REPEAT UNTIL ~SYSTEM.BIT(gpio, 2);
+    FOR i := 0 TO 7 DO
+      SYSTEM.PUT(gpio, 2); del(60);
+      IF SYSTEM.BIT(gpio, 2) THEN x0 := x0 + 100H END ;
+      SYSTEM.PUT(gpio, 0); del(25); x0 := ROR(x0, 1)
+    END ;
+    x := x0
+  END Receive;
+
+  PROCEDURE Reset*;
+  BEGIN SYSTEM.PUT(gpio, 0); SYSTEM.PUT(gpoc, 3)  (*set bit 0, 1 to output*)
+  END Reset;
+
+BEGIN Reset
+END PIO.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/RISC.Mod.txt

@@ -1,80 +1,80 @@
-MODULE RISC;     (*NW 22.9.07 / 1.11.2013*)
-  IMPORT SYSTEM, Texts, Oberon;
-  CONST
-    MOV = 0; LSL = 1; ASR = 2; ROR = 3; AND = 4; ANN = 5; IOR = 6; XOR = 7;
-    ADD = 8; SUB = 9;  MUL = 10; Div = 11;
-
-  VAR IR: LONGINT;   (*instruction register*)
-    PC: LONGINT;   (*program counter*)
-    N, Z: BOOLEAN;  (*condition flags*)
-    R: ARRAY 16 OF LONGINT;
-    H: LONGINT;  (*aux register for division*)
-    
-  PROCEDURE Execute*(VAR M: ARRAY OF LONGINT; pc: LONGINT;
-      VAR S: Texts.Scanner; VAR W: Texts.Writer);
-    VAR a, b, op, im: LONGINT;  (*instruction fields*)
-      adr, A, B, C, n: LONGINT;
-      MemSize: LONGINT;
-  BEGIN PC := 0; R[13] := pc * 4; R[14] := LEN(M)*4; n := 0;
-    REPEAT (*interpretation cycle*)
-      IR := M[PC]; INC(PC); INC(n);
-      a := IR DIV 1000000H MOD 10H;
-      b := IR DIV 100000H MOD 10H;
-      op := IR DIV 10000H MOD 10H;
-      im := IR MOD 10000H;
-      IF ~ODD(IR DIV 80000000H) THEN  (*~p:  register instruction*)
-        B := R[b];
-        IF ~ODD(IR DIV 40000000H) THEN (*~q*) C := R[IR MOD 10H]
-        ELSIF ~ODD(IR DIV 10000000H) THEN (*q&~v*) C := im
-        ELSE (*q&v*) C := im + 0FFFF0000H
-        END ;
-        CASE op OF
-            MOV: IF ~ODD(IR DIV 20000000H) THEN A := C ELSE A := H END |
-            LSL: A := SYSTEM.LSH(B, C) |
-            ASR: A := ASH(B, -C) |
-            ROR: A := SYSTEM.ROT(B, -C) |
-            AND: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) * SYSTEM.VAL(SET, C)) |
-            ANN: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) - SYSTEM.VAL(SET, C)) |
-            IOR: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) + SYSTEM.VAL(SET, C)) |
-            XOR: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) / SYSTEM.VAL(SET, C)) |
-            ADD: A := B + C |
-            SUB: A := B - C |
-            MUL: A := B * C |
-            Div: A := B DIV C; H := B MOD C
-         END ;
-         R[a] := A; N := A < 0; Z := A = 0
-      ELSIF ~ODD(IR DIV 40000000H) THEN (*p & ~q: memory instruction*)
-        adr := (R[b] + IR MOD 100000H) DIV 4;
-        IF ~ODD(IR DIV 20000000H) THEN
-          IF adr >= 0 THEN (*load*) R[a] := M[adr]; N := A < 0; Z := A = 0
-          ELSE (*input*)
-            IF adr = -1 THEN (*ReadInt*) Texts.Scan(S); R[a] := S.i;
-            ELSIF adr = -2 THEN (*eot*)  Z := S.class # Texts.Int
-            END 
-          END
-        ELSE
-          IF adr >= 0 THEN (*store*) M[adr] := R[a];
-          ELSE (*output*)
-            IF adr = -1 THEN Texts.WriteInt(W, R[a], 4)
-            ELSIF adr = -2 THEN Texts.Write(W, CHR(R[a] MOD 80H))
-            ELSIF adr = -3 THEN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-            END
-          END
-        END
-      ELSE (* p & q: branch instruction*)
-        IF (a = 0) & N OR (a = 1) & Z OR (a = 5) & N OR (a = 6) & (N OR Z) OR (a = 7) OR
-            (a = 8) & ~N OR (a = 9) & ~Z OR (a = 13) & ~N OR (a = 14) & ~(N OR Z) THEN
-          IF ODD(IR DIV 10000000H) THEN R[15] := PC * 4 END ;
-          IF ODD(IR DIV 20000000H) THEN PC := (PC + (IR MOD 1000000H)) MOD 40000H 
-          ELSE PC := R[IR MOD 10H] DIV 4
-          END
-        END
-      END
-    UNTIL (PC = 0) OR (n = 100000);
-    Texts.WriteInt(W, n, 8);
-    IF n = 100000 THEN Texts.WriteString(W, " aborted") END ;
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END Execute;
-END RISC.
-
-
+MODULE RISC;     (*NW 22.9.07 / 1.11.2013*)
+  IMPORT SYSTEM, Texts, Oberon;
+  CONST
+    MOV = 0; LSL = 1; ASR = 2; ROR = 3; AND = 4; ANN = 5; IOR = 6; XOR = 7;
+    ADD = 8; SUB = 9;  MUL = 10; Div = 11;
+
+  VAR IR: LONGINT;   (*instruction register*)
+    PC: LONGINT;   (*program counter*)
+    N, Z: BOOLEAN;  (*condition flags*)
+    R: ARRAY 16 OF LONGINT;
+    H: LONGINT;  (*aux register for division*)
+    
+  PROCEDURE Execute*(VAR M: ARRAY OF LONGINT; pc: LONGINT;
+      VAR S: Texts.Scanner; VAR W: Texts.Writer);
+    VAR a, b, op, im: LONGINT;  (*instruction fields*)
+      adr, A, B, C, n: LONGINT;
+      MemSize: LONGINT;
+  BEGIN PC := 0; R[13] := pc * 4; R[14] := LEN(M)*4; n := 0;
+    REPEAT (*interpretation cycle*)
+      IR := M[PC]; INC(PC); INC(n);
+      a := IR DIV 1000000H MOD 10H;
+      b := IR DIV 100000H MOD 10H;
+      op := IR DIV 10000H MOD 10H;
+      im := IR MOD 10000H;
+      IF ~ODD(IR DIV 80000000H) THEN  (*~p:  register instruction*)
+        B := R[b];
+        IF ~ODD(IR DIV 40000000H) THEN (*~q*) C := R[IR MOD 10H]
+        ELSIF ~ODD(IR DIV 10000000H) THEN (*q&~v*) C := im
+        ELSE (*q&v*) C := im + 0FFFF0000H
+        END ;
+        CASE op OF
+            MOV: IF ~ODD(IR DIV 20000000H) THEN A := C ELSE A := H END |
+            LSL: A := SYSTEM.LSH(B, C) |
+            ASR: A := ASH(B, -C) |
+            ROR: A := SYSTEM.ROT(B, -C) |
+            AND: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) * SYSTEM.VAL(SET, C)) |
+            ANN: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) - SYSTEM.VAL(SET, C)) |
+            IOR: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) + SYSTEM.VAL(SET, C)) |
+            XOR: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) / SYSTEM.VAL(SET, C)) |
+            ADD: A := B + C |
+            SUB: A := B - C |
+            MUL: A := B * C |
+            Div: A := B DIV C; H := B MOD C
+         END ;
+         R[a] := A; N := A < 0; Z := A = 0
+      ELSIF ~ODD(IR DIV 40000000H) THEN (*p & ~q: memory instruction*)
+        adr := (R[b] + IR MOD 100000H) DIV 4;
+        IF ~ODD(IR DIV 20000000H) THEN
+          IF adr >= 0 THEN (*load*) R[a] := M[adr]; N := A < 0; Z := A = 0
+          ELSE (*input*)
+            IF adr = -1 THEN (*ReadInt*) Texts.Scan(S); R[a] := S.i;
+            ELSIF adr = -2 THEN (*eot*)  Z := S.class # Texts.Int
+            END 
+          END
+        ELSE
+          IF adr >= 0 THEN (*store*) M[adr] := R[a];
+          ELSE (*output*)
+            IF adr = -1 THEN Texts.WriteInt(W, R[a], 4)
+            ELSIF adr = -2 THEN Texts.Write(W, CHR(R[a] MOD 80H))
+            ELSIF adr = -3 THEN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+            END
+          END
+        END
+      ELSE (* p & q: branch instruction*)
+        IF (a = 0) & N OR (a = 1) & Z OR (a = 5) & N OR (a = 6) & (N OR Z) OR (a = 7) OR
+            (a = 8) & ~N OR (a = 9) & ~Z OR (a = 13) & ~N OR (a = 14) & ~(N OR Z) THEN
+          IF ODD(IR DIV 10000000H) THEN R[15] := PC * 4 END ;
+          IF ODD(IR DIV 20000000H) THEN PC := (PC + (IR MOD 1000000H)) MOD 40000H 
+          ELSE PC := R[IR MOD 10H] DIV 4
+          END
+        END
+      END
+    UNTIL (PC = 0) OR (n = 100000);
+    Texts.WriteInt(W, n, 8);
+    IF n = 100000 THEN Texts.WriteString(W, " aborted") END ;
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END Execute;
+END RISC.
+
+

people.inf.ethz.ch/wirth/ProjectOberon/Sources/RS232.Mod.txt

@@ -1,69 +1,69 @@
-MODULE RS232;   (*NW 3.1.2012*)
-  IMPORT SYSTEM;
-  CONST data = -56; stat = -52;
-
-  PROCEDURE Send*(x: INTEGER);
-  BEGIN
-    REPEAT UNTIL SYSTEM.BIT(stat, 1);
-    SYSTEM.PUT(data, x)
-  END Send;
-  
-  PROCEDURE Rec*(VAR x: INTEGER);
-  BEGIN
-    REPEAT UNTIL SYSTEM.BIT(stat, 0);
-    SYSTEM.GET(data, x)
-  END Rec;
-
-  PROCEDURE SendInt*(x: INTEGER);
-    VAR i: INTEGER;
-  BEGIN Send(1); i := 4;
-    REPEAT i := i-1; Send(x);  x := ROR(x, 8) UNTIL i = 0
-  END SendInt;
-
-  PROCEDURE SendHex*(x: INTEGER);
-    VAR i: INTEGER;
-  BEGIN Send(2); i := 4;
-    REPEAT i := i-1; Send(x);  x := ROR(x, 8) UNTIL i = 0
-  END SendHex;
-
-  PROCEDURE SendReal*(x: REAL);
-    VAR i, u: INTEGER;
-  BEGIN Send(3); u := ORD(x); i := 4;
-    REPEAT i := i-1; Send(u);  u := ROR(u, 8) UNTIL i = 0
-  END SendReal;
-
-  PROCEDURE SendStr*(x: ARRAY OF CHAR);
-    VAR i, k: INTEGER;
-  BEGIN Send(4); i := 0;
-    REPEAT k := ORD(x[i]); Send(k); INC(i) UNTIL k = 0
-  END SendStr;
-
-  PROCEDURE RecInt*(VAR x: INTEGER);
-    VAR i, x0, y: INTEGER;
-  BEGIN i := 4; x0 := 0;
-    REPEAT i := i-1; Rec(y); x0 := ROR(x0+y, 8) UNTIL i = 0;
-    x := x0
-  END RecInt;
-
-  PROCEDURE RecReal*(VAR x: REAL);
-    VAR i, x0, y: INTEGER;
-  BEGIN i := 4; x0 := 0;
-    REPEAT i := i-1; Rec(y); x0 := ROR(x0+y, 8) UNTIL i = 0;
-    x := SYSTEM.VAL(REAL, x0)
-  END RecReal;
-
-  PROCEDURE RecStr*(VAR x: ARRAY OF CHAR);
-    VAR i, k: INTEGER;
-  BEGIN i := 0;
-    REPEAT Rec(k); x[i] := CHR(k); INC(i) UNTIL k = 0
-  END RecStr;
-
-  PROCEDURE Line*;
-  BEGIN Send(6)
-  END Line;
-  
-  PROCEDURE End*;
-  BEGIN Send(7)
-  END End;
-
-BEGIN END RS232.
+MODULE RS232;   (*NW 3.1.2012*)
+  IMPORT SYSTEM;
+  CONST data = -56; stat = -52;
+
+  PROCEDURE Send*(x: INTEGER);
+  BEGIN
+    REPEAT UNTIL SYSTEM.BIT(stat, 1);
+    SYSTEM.PUT(data, x)
+  END Send;
+  
+  PROCEDURE Rec*(VAR x: INTEGER);
+  BEGIN
+    REPEAT UNTIL SYSTEM.BIT(stat, 0);
+    SYSTEM.GET(data, x)
+  END Rec;
+
+  PROCEDURE SendInt*(x: INTEGER);
+    VAR i: INTEGER;
+  BEGIN Send(1); i := 4;
+    REPEAT i := i-1; Send(x);  x := ROR(x, 8) UNTIL i = 0
+  END SendInt;
+
+  PROCEDURE SendHex*(x: INTEGER);
+    VAR i: INTEGER;
+  BEGIN Send(2); i := 4;
+    REPEAT i := i-1; Send(x);  x := ROR(x, 8) UNTIL i = 0
+  END SendHex;
+
+  PROCEDURE SendReal*(x: REAL);
+    VAR i, u: INTEGER;
+  BEGIN Send(3); u := ORD(x); i := 4;
+    REPEAT i := i-1; Send(u);  u := ROR(u, 8) UNTIL i = 0
+  END SendReal;
+
+  PROCEDURE SendStr*(x: ARRAY OF CHAR);
+    VAR i, k: INTEGER;
+  BEGIN Send(4); i := 0;
+    REPEAT k := ORD(x[i]); Send(k); INC(i) UNTIL k = 0
+  END SendStr;
+
+  PROCEDURE RecInt*(VAR x: INTEGER);
+    VAR i, x0, y: INTEGER;
+  BEGIN i := 4; x0 := 0;
+    REPEAT i := i-1; Rec(y); x0 := ROR(x0+y, 8) UNTIL i = 0;
+    x := x0
+  END RecInt;
+
+  PROCEDURE RecReal*(VAR x: REAL);
+    VAR i, x0, y: INTEGER;
+  BEGIN i := 4; x0 := 0;
+    REPEAT i := i-1; Rec(y); x0 := ROR(x0+y, 8) UNTIL i = 0;
+    x := SYSTEM.VAL(REAL, x0)
+  END RecReal;
+
+  PROCEDURE RecStr*(VAR x: ARRAY OF CHAR);
+    VAR i, k: INTEGER;
+  BEGIN i := 0;
+    REPEAT Rec(k); x[i] := CHR(k); INC(i) UNTIL k = 0
+  END RecStr;
+
+  PROCEDURE Line*;
+  BEGIN Send(6)
+  END Line;
+  
+  PROCEDURE End*;
+  BEGIN Send(7)
+  END End;
+
+BEGIN END RS232.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Rectangles.Mod.txt

@@ -1,118 +1,118 @@
-MODULE Rectangles;  (*NW 25.2.90 / 18.4.2013*)
-  IMPORT SYSTEM, Display, Files, Input, Texts, Oberon, Graphics, GraphicFrames;
-
-  TYPE
-    Rectangle* = POINTER TO RectDesc;
-    RectDesc* = RECORD (Graphics.ObjectDesc)
-        lw*, vers*: INTEGER
-      END ;
-
-  VAR method*: Graphics.Method;
-    tack*, grey*: INTEGER;
-
-  PROCEDURE New*;
-    VAR r: Rectangle;
-  BEGIN NEW(r); r.do := method; Graphics.New(r)
-  END New;
-
-  PROCEDURE Copy(src, dst: Graphics.Object);
-  BEGIN dst.x := src.x; dst.y := src.y; dst.w := src.w; dst.h := src.h; dst.col := src.col;
-    dst(Rectangle).lw := src(Rectangle).lw; dst(Rectangle).vers := src(Rectangle).vers
-  END Copy;
-
-  PROCEDURE mark(f: GraphicFrames.Frame; col, x, y: INTEGER);
-  BEGIN GraphicFrames.ReplConst(f, col, x+1, y+1, 4, 4, 0)
-  END mark;
-
-  PROCEDURE Draw(obj: Graphics.Object; VAR M: Graphics.Msg);
-    VAR x, y, w, h, lw, col: INTEGER; f: GraphicFrames.Frame;
-
-    PROCEDURE draw(f: GraphicFrames.Frame; col, x, y, w, h, lw: INTEGER);
-    BEGIN
-      GraphicFrames.ReplConst(f, col, x, y, w, lw, Display.replace);
-      GraphicFrames.ReplConst(f, col, x+w-lw, y, lw, h, Display.replace);
-      GraphicFrames.ReplConst(f, col, x, y+h-lw, w, lw, Display.replace);
-      GraphicFrames.ReplConst(f, col, x, y, lw, h, Display.replace)
-    END draw;
-
-  BEGIN
-    CASE M OF GraphicFrames.DrawMsg:
-      x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f;
-      lw := obj(Rectangle).lw;
-      IF (x < f.X1) & (x+w > f.X) & (y < f.Y1) & (y+h > f.Y) THEN
-        IF M.col = Display.black THEN col := obj.col ELSE col := M.col END ;
-        IF M.mode = 0 THEN
-          draw(f, col, x, y, w, h, lw);
-          IF obj.selected THEN mark(f, Display.white, x, y) END
-        ELSIF M.mode = 1 THEN mark(f, Display.white, x, y)  (*normal -> selected*)
-        ELSIF M.mode = 2 THEN mark(f, Display.black, x, y)   (*selected -> normal*)
-        ELSIF M.mode = 3 THEN draw(f, Display.black, x, y, w, h, lw); mark(f, Display.black, x, y)  (*erase*)
-        END
-      END
-    END
-  END Draw;
-
-  PROCEDURE Selectable(obj: Graphics.Object; x, y: INTEGER): BOOLEAN;
-  BEGIN
-    RETURN (obj.x <= x) & (x <= obj.x + 4) & (obj.y <= y) & (y <= obj.y + 4)
-  END Selectable;
-
-  PROCEDURE Change(obj: Graphics.Object; VAR M: Graphics.Msg);
-    VAR x0, y0, x1, y1, dx, dy: INTEGER; k: SET;
-  BEGIN
-    CASE M OF
-    Graphics.WidMsg: obj(Rectangle).lw := M.w |
-    Graphics.ColorMsg: obj.col := M.col
-    END
-  END Change;
-
-  PROCEDURE Read(obj: Graphics.Object; VAR R: Files.Rider; VAR C: Graphics.Context);
-    VAR b: BYTE; len: INTEGER;
-  BEGIN Files.ReadByte(R, b); (*len*);
-    Files.ReadByte(R, b); obj(Rectangle).lw := b;
-    Files.ReadByte(R, b); obj(Rectangle).vers := b;
-  END Read;
-
-  PROCEDURE Write(obj: Graphics.Object; cno: INTEGER; VAR W: Files.Rider; VAR C: Graphics.Context);
-  BEGIN Graphics.WriteObj(W, cno, obj); Files.WriteByte(W, 2);
-    Files.WriteByte(W, obj(Rectangle).lw); Files.WriteByte(W, obj(Rectangle).vers)
-  END Write;
-
-(* PROCEDURE Print(obj: Graphics.Object; x, y: INTEGER);
-    VAR w, h, lw, s: INTEGER;
-  BEGIN INC(x, obj.x * 4); INC(y, obj.y * 4); w := obj.w * 4; h := obj.h * 4;
-    lw := obj(Rectangle).lw * 2; s := obj(Rectangle).vers;
-    Printer.ReplConst(x, y, w, lw);
-    Printer.ReplConst(x+w-lw, y, lw, h);
-    Printer.ReplConst(x, y+h-lw, w, lw);
-    Printer.ReplConst(x, y, lw, h);
-    IF s > 0 THEN Printer.ReplPattern(x, y, w, h, s) END
-  END Print; *)
-
-  PROCEDURE Make*;  (*command*)
-    VAR x0, x1, y0, y1: INTEGER;
-      R: Rectangle;
-      G: GraphicFrames.Frame;
-  BEGIN G := GraphicFrames.Focus();
-    IF (G # NIL) & (G.mark.next # NIL) THEN
-      GraphicFrames.Deselect(G);
-      x0 := G.mark.x; y0 := G.mark.y; x1 := G.mark.next.x; y1 := G.mark.next.y;
-      NEW(R); R.col := Oberon.CurCol;
-      R.w := ABS(x1-x0); R.h := ABS(y1-y0);
-      IF x1 < x0 THEN x0 := x1 END ;
-      IF y1 < y0 THEN y0 := y1 END ;
-      R.x := x0 - G.x; R.y := y0 - G.y;
-      R.lw := Graphics.width; R.vers := 0; R.do := method;
-      Graphics.Add(G.graph, R);
-      GraphicFrames.Defocus(G); GraphicFrames.DrawObj(G, R)
-    END
-  END Make;
-
-BEGIN NEW(method);
-  method.module := "Rectangles"; method.allocator := "New";
-  method.new := New; method.copy := Copy; method.draw := Draw;
-  method.selectable := Selectable; method.change := Change;
-  method.read := Read; method.write := Write; (*method.print := Print*)
-  tack := SYSTEM.ADR($0707 4122 1408 1422 4100$);
-  grey := SYSTEM.ADR($2004 0000 1111 1111 0000 0000 4444 4444 0000 0000$)
-END Rectangles.
+MODULE Rectangles;  (*NW 25.2.90 / 18.4.2013*)
+  IMPORT SYSTEM, Display, Files, Input, Texts, Oberon, Graphics, GraphicFrames;
+
+  TYPE
+    Rectangle* = POINTER TO RectDesc;
+    RectDesc* = RECORD (Graphics.ObjectDesc)
+        lw*, vers*: INTEGER
+      END ;
+
+  VAR method*: Graphics.Method;
+    tack*, grey*: INTEGER;
+
+  PROCEDURE New*;
+    VAR r: Rectangle;
+  BEGIN NEW(r); r.do := method; Graphics.New(r)
+  END New;
+
+  PROCEDURE Copy(src, dst: Graphics.Object);
+  BEGIN dst.x := src.x; dst.y := src.y; dst.w := src.w; dst.h := src.h; dst.col := src.col;
+    dst(Rectangle).lw := src(Rectangle).lw; dst(Rectangle).vers := src(Rectangle).vers
+  END Copy;
+
+  PROCEDURE mark(f: GraphicFrames.Frame; col, x, y: INTEGER);
+  BEGIN GraphicFrames.ReplConst(f, col, x+1, y+1, 4, 4, 0)
+  END mark;
+
+  PROCEDURE Draw(obj: Graphics.Object; VAR M: Graphics.Msg);
+    VAR x, y, w, h, lw, col: INTEGER; f: GraphicFrames.Frame;
+
+    PROCEDURE draw(f: GraphicFrames.Frame; col, x, y, w, h, lw: INTEGER);
+    BEGIN
+      GraphicFrames.ReplConst(f, col, x, y, w, lw, Display.replace);
+      GraphicFrames.ReplConst(f, col, x+w-lw, y, lw, h, Display.replace);
+      GraphicFrames.ReplConst(f, col, x, y+h-lw, w, lw, Display.replace);
+      GraphicFrames.ReplConst(f, col, x, y, lw, h, Display.replace)
+    END draw;
+
+  BEGIN
+    CASE M OF GraphicFrames.DrawMsg:
+      x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f;
+      lw := obj(Rectangle).lw;
+      IF (x < f.X1) & (x+w > f.X) & (y < f.Y1) & (y+h > f.Y) THEN
+        IF M.col = Display.black THEN col := obj.col ELSE col := M.col END ;
+        IF M.mode = 0 THEN
+          draw(f, col, x, y, w, h, lw);
+          IF obj.selected THEN mark(f, Display.white, x, y) END
+        ELSIF M.mode = 1 THEN mark(f, Display.white, x, y)  (*normal -> selected*)
+        ELSIF M.mode = 2 THEN mark(f, Display.black, x, y)   (*selected -> normal*)
+        ELSIF M.mode = 3 THEN draw(f, Display.black, x, y, w, h, lw); mark(f, Display.black, x, y)  (*erase*)
+        END
+      END
+    END
+  END Draw;
+
+  PROCEDURE Selectable(obj: Graphics.Object; x, y: INTEGER): BOOLEAN;
+  BEGIN
+    RETURN (obj.x <= x) & (x <= obj.x + 4) & (obj.y <= y) & (y <= obj.y + 4)
+  END Selectable;
+
+  PROCEDURE Change(obj: Graphics.Object; VAR M: Graphics.Msg);
+    VAR x0, y0, x1, y1, dx, dy: INTEGER; k: SET;
+  BEGIN
+    CASE M OF
+    Graphics.WidMsg: obj(Rectangle).lw := M.w |
+    Graphics.ColorMsg: obj.col := M.col
+    END
+  END Change;
+
+  PROCEDURE Read(obj: Graphics.Object; VAR R: Files.Rider; VAR C: Graphics.Context);
+    VAR b: BYTE; len: INTEGER;
+  BEGIN Files.ReadByte(R, b); (*len*);
+    Files.ReadByte(R, b); obj(Rectangle).lw := b;
+    Files.ReadByte(R, b); obj(Rectangle).vers := b;
+  END Read;
+
+  PROCEDURE Write(obj: Graphics.Object; cno: INTEGER; VAR W: Files.Rider; VAR C: Graphics.Context);
+  BEGIN Graphics.WriteObj(W, cno, obj); Files.WriteByte(W, 2);
+    Files.WriteByte(W, obj(Rectangle).lw); Files.WriteByte(W, obj(Rectangle).vers)
+  END Write;
+
+(* PROCEDURE Print(obj: Graphics.Object; x, y: INTEGER);
+    VAR w, h, lw, s: INTEGER;
+  BEGIN INC(x, obj.x * 4); INC(y, obj.y * 4); w := obj.w * 4; h := obj.h * 4;
+    lw := obj(Rectangle).lw * 2; s := obj(Rectangle).vers;
+    Printer.ReplConst(x, y, w, lw);
+    Printer.ReplConst(x+w-lw, y, lw, h);
+    Printer.ReplConst(x, y+h-lw, w, lw);
+    Printer.ReplConst(x, y, lw, h);
+    IF s > 0 THEN Printer.ReplPattern(x, y, w, h, s) END
+  END Print; *)
+
+  PROCEDURE Make*;  (*command*)
+    VAR x0, x1, y0, y1: INTEGER;
+      R: Rectangle;
+      G: GraphicFrames.Frame;
+  BEGIN G := GraphicFrames.Focus();
+    IF (G # NIL) & (G.mark.next # NIL) THEN
+      GraphicFrames.Deselect(G);
+      x0 := G.mark.x; y0 := G.mark.y; x1 := G.mark.next.x; y1 := G.mark.next.y;
+      NEW(R); R.col := Oberon.CurCol;
+      R.w := ABS(x1-x0); R.h := ABS(y1-y0);
+      IF x1 < x0 THEN x0 := x1 END ;
+      IF y1 < y0 THEN y0 := y1 END ;
+      R.x := x0 - G.x; R.y := y0 - G.y;
+      R.lw := Graphics.width; R.vers := 0; R.do := method;
+      Graphics.Add(G.graph, R);
+      GraphicFrames.Defocus(G); GraphicFrames.DrawObj(G, R)
+    END
+  END Make;
+
+BEGIN NEW(method);
+  method.module := "Rectangles"; method.allocator := "New";
+  method.new := New; method.copy := Copy; method.draw := Draw;
+  method.selectable := Selectable; method.change := Change;
+  method.read := Read; method.write := Write; (*method.print := Print*)
+  tack := SYSTEM.ADR($0707 4122 1408 1422 4100$);
+  grey := SYSTEM.ADR($2004 0000 1111 1111 0000 0000 4444 4444 0000 0000$)
+END Rectangles.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/SCC.Mod.txt

@@ -1,181 +1,181 @@
-MODULE SCC; (*NW 13.11.87 / 22.8.90 Ceres-2; nRF24L01+ version PR 21.7.13 / 23.12.13*)
-  IMPORT SYSTEM, Kernel;
-
-  CONST
-    swi = -60; spiData = -48; spiCtrl = -44;
-    netSelect = 1; spiFast = 2; netEnable = 3;
-    HdrSize = 8; MaxPayload = 512; SubPacket = 32; Wait = 50; SendTries = 50;
-    MaxPacket = (HdrSize + MaxPayload + SubPacket-1) DIV SubPacket *
-SubPacket;
-
-  TYPE Header* =
-    RECORD valid*: BOOLEAN;
-      dadr*, sadr*, typ*: BYTE;
-      len*: INTEGER (*of data following header*)
-    END ;
-
-  VAR
-    filter*: BOOLEAN; Adr*: BYTE; rcvd: INTEGER;
-    rx: RECORD
-      hd: Header;
-      dat: ARRAY MaxPacket-HdrSize OF BYTE
-    END;
-
-  PROCEDURE SPICtrl(s: SET);
-  BEGIN SYSTEM.PUT(spiCtrl, s);
-    IF netEnable IN s THEN LED(55H) ELSE LED(0) END
-  END SPICtrl;
-
-  PROCEDURE SPI(n: INTEGER);
-  BEGIN (*send (& rcv into shift reg) one byte or word, at current speed*)
-    SYSTEM.PUT(spiData, n); REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0) (*wait until done*)
-  END SPI;
-
-  PROCEDURE StartCmd(cmd: INTEGER);
-  BEGIN SPICtrl({netSelect}); SPI(cmd)
-  END StartCmd;
-
-  PROCEDURE WriteReg1(reg, dat: INTEGER);  (*disables radio!*)
-  BEGIN StartCmd(reg + 20H); SPI(dat); SPICtrl({}) (*W_REGISTER*)
-  END WriteReg1;
-
-  PROCEDURE SubRcv(dst: INTEGER);
-    VAR i, dat: INTEGER;
-  BEGIN
-    StartCmd(061H); (*R_RX_PAYLOAD, disables radio*)
-    SPICtrl({netSelect, spiFast});
-    FOR i := 0 TO SubPacket-4 BY 4 DO
-      SPI(-1); SYSTEM.GET(spiData, dat); SYSTEM.PUT(dst+i, dat)
-    END;
-    SPICtrl({}); WriteReg1(7, 40H); (*done; STATUS <= clear RX_DR*)
-    SPICtrl({netEnable}) (*enable radio*)
-  END SubRcv;
-
-  PROCEDURE SubSnd(src: INTEGER; VAR timeout: BOOLEAN);
-    VAR i, dat, res, t1, try: INTEGER; x, status: BYTE;
-  BEGIN (*already in xmit mode*)
-    StartCmd(0A0H); (*W_TX_PAYLOAD*)
-    SPICtrl({netSelect, spiFast});
-    FOR i := 0 TO SubPacket-4 BY 4 DO
-      SYSTEM.GET(src+i, dat); SPI(dat)
-    END;
-    SPICtrl({}); (*end W_TX_PAYLOAD command*)
-    try := 0;
-    SPICtrl({netEnable, netSelect}); (*start xmit pulse, start NOP cmd*)
-    REPEAT
-      t1 := Kernel.Time() + Wait;
-      REPEAT (*wait for sent or retransmits exceeded*);
-        SPI(0FFH); SYSTEM.GET(spiData, status); (*NOP*)
-        res := status DIV 10H MOD 4;
-        SPICtrl({}); SPICtrl({netSelect}) (*end & restart NOP cmd, end =10us pulse on enable*)
-      UNTIL res # 0;
-      IF res = 2 THEN WriteReg1(7, 20H) (*TX_DS: sent, ack received; reset it*)
-      ELSIF res = 1 THEN WriteReg1(7, 10H); INC(try); (*MAX_RT: retransmits exceeded; reset it*)
-        IF try = SendTries THEN res := 0
-        ELSE REPEAT UNTIL Kernel.Time() >= t1;
-          SPICtrl({netEnable, netSelect}); (*start xmit pulse, start NOP cmd again*)
-        END
-      END
-    UNTIL res # 1;
-    timeout := (res # 2)
-  END SubSnd;
-
-  PROCEDURE Flush();
-  BEGIN StartCmd(0E1H); SPICtrl({}); StartCmd(0E2H); SPICtrl({})
-(*FLUSH_TX, FLUSH_RX*)
-  END Flush;
-
-  PROCEDURE ResetRcv;
-  BEGIN SYSTEM.PUT(SYSTEM.ADR(rx), 0); rx.hd.len := 0; rcvd := 0
-  END ResetRcv;
-
-  PROCEDURE Listen(b: BOOLEAN);
-  BEGIN
-    WriteReg1(0, 07EH + ORD(b)); (*CONFIG <= mask ints; EN_CRC(2 byte), PWR_UP, PRX/PTX*)
-    WriteReg1(7, 70H); (*STATUS <= clear ints*)
-    IF b THEN SPICtrl({netEnable}) END (*turn radio on*)
-  END Listen;
-
-  PROCEDURE Start*(filt: BOOLEAN);
-    VAR n: INTEGER;
-  BEGIN filter := filt; Adr := 0;
-    SYSTEM.GET(swi, n); n := n DIV 4 MOD 10H * 10 + 5;
-    WriteReg1(5, n); (*RF_CH <= channel: 5, 15, 25...*)
-    WriteReg1(6, 07H); (*RF_SETUP <= 1Mb for better range, 0dBm*)
-    WriteReg1(11H, SubPacket); (*RX_PW_P0 <= pipe 0 payload width*)
-    Flush(); Listen(TRUE); ResetRcv
-  END Start;
-
-  PROCEDURE SendPacket*(VAR head: Header; dat: ARRAY OF BYTE);
-    VAR len, i, off: INTEGER; timeout: BOOLEAN; payload: ARRAY SubPacket
-OF BYTE;
-  BEGIN (*let any receive ack finish before turning radio off*)
-    i := Kernel.Time() + Wait;
-    REPEAT SPICtrl({netEnable, netSelect}); SPI(0FFH); SPICtrl({netEnable}) (*NOP*)
-    UNTIL Kernel.Time() >= i;
-    IF Adr = 0 THEN Adr := i MOD 100H END;
-    Listen(FALSE);
-    head.sadr := Adr; head.valid := TRUE;
-    SYSTEM.COPY(SYSTEM.ADR(head), SYSTEM.ADR(payload), HdrSize DIV 4);
-    i := HdrSize; off := 0; len := head.len;
-    WHILE (len > 0) & (i < SubPacket) DO payload[i] := dat[off]; INC(i); INC(off); DEC(len) END;
-    WHILE i < SubPacket DO payload[i] := 0; INC(i) END;
-    SubSnd(SYSTEM.ADR(payload), timeout);
-    WHILE ~timeout & (len # 0) DO i := 0; (*send the rest*)
-      WHILE (len > 0) & (i < SubPacket) DO payload[i] := dat[off]; INC(i); INC(off); DEC(len) END;
-      WHILE i < SubPacket DO payload[i] := 0; INC(i) END;
-      SubSnd(SYSTEM.ADR(payload), timeout)
-    END;
-    Listen(TRUE)
-  END SendPacket;
-
-  PROCEDURE Available*(): INTEGER;
-  BEGIN (*packet already rcvd*)
-    RETURN rx.hd.len - rcvd
-  END Available;
-
-  PROCEDURE Receive*(VAR x: BYTE);
-  BEGIN (*packet already rcvd*)
-    IF rcvd < rx.hd.len THEN x := rx.dat[rcvd]; INC(rcvd) ELSE x := 0 END
-  END Receive;
-
-  PROCEDURE Rcvd(time: INTEGER): BOOLEAN;
-    VAR status, fifoStatus: BYTE; rcvd: BOOLEAN;
-  BEGIN time := time + Kernel.Time();
-    REPEAT
-      SPICtrl({netEnable, netSelect}); SPI(17H); (*R_REGISTER FIFO_STATUS*)
-      SYSTEM.GET(spiData, status); SPI(-1); SYSTEM.GET(spiData, fifoStatus); SPICtrl({netEnable});
-      rcvd := ODD(status DIV 40H) OR ~ODD(fifoStatus) (*RX_DR (data ready) or RX FIFO not empty*)
-    UNTIL rcvd OR (Kernel.Time() >= time);
-    RETURN rcvd
-  END Rcvd;
-
-  PROCEDURE ReceiveHead*(VAR head: Header);  (*actually, recv whole packet*)
-    VAR adr, n: INTEGER;
-  BEGIN head.valid := FALSE;
-    IF Rcvd(0) THEN
-      ResetRcv; adr := SYSTEM.ADR(rx); SubRcv(adr);
-      n := (rx.hd.len + HdrSize - 1) DIV SubPacket;
-      IF (rx.hd.len <= MaxPayload)
-          & ((rx.hd.dadr = 0FFH) OR ~filter OR (Adr = 0) OR (rx.hd.dadr = Adr)) THEN
-        WHILE (n > 0) & Rcvd(Wait) DO
-          INC(adr, SubPacket); SubRcv(adr); DEC(n)
-        END;
-        rx.hd.valid := (n = 0)
-      ELSE WHILE Rcvd(Wait) DO SubRcv(adr) END; ResetRcv  (*discard packet*)
-      END;
-      head := rx.hd
-    END
-  END ReceiveHead;
-
-  PROCEDURE Skip*(m: INTEGER);
-    VAR dmy: BYTE;
-  BEGIN WHILE m # 0 DO Receive(dmy); DEC(m) END
-  END Skip;
-
-  PROCEDURE Stop*;
-  BEGIN SPICtrl({}); Flush(); ResetRcv
-  END Stop;
-
-BEGIN Start(TRUE)
-END SCC.
+MODULE SCC; (*NW 13.11.87 / 22.8.90 Ceres-2; nRF24L01+ version PR 21.7.13 / 23.12.13*)
+  IMPORT SYSTEM, Kernel;
+
+  CONST
+    swi = -60; spiData = -48; spiCtrl = -44;
+    netSelect = 1; spiFast = 2; netEnable = 3;
+    HdrSize = 8; MaxPayload = 512; SubPacket = 32; Wait = 50; SendTries = 50;
+    MaxPacket = (HdrSize + MaxPayload + SubPacket-1) DIV SubPacket *
+SubPacket;
+
+  TYPE Header* =
+    RECORD valid*: BOOLEAN;
+      dadr*, sadr*, typ*: BYTE;
+      len*: INTEGER (*of data following header*)
+    END ;
+
+  VAR
+    filter*: BOOLEAN; Adr*: BYTE; rcvd: INTEGER;
+    rx: RECORD
+      hd: Header;
+      dat: ARRAY MaxPacket-HdrSize OF BYTE
+    END;
+
+  PROCEDURE SPICtrl(s: SET);
+  BEGIN SYSTEM.PUT(spiCtrl, s);
+    IF netEnable IN s THEN LED(55H) ELSE LED(0) END
+  END SPICtrl;
+
+  PROCEDURE SPI(n: INTEGER);
+  BEGIN (*send (& rcv into shift reg) one byte or word, at current speed*)
+    SYSTEM.PUT(spiData, n); REPEAT UNTIL SYSTEM.BIT(spiCtrl, 0) (*wait until done*)
+  END SPI;
+
+  PROCEDURE StartCmd(cmd: INTEGER);
+  BEGIN SPICtrl({netSelect}); SPI(cmd)
+  END StartCmd;
+
+  PROCEDURE WriteReg1(reg, dat: INTEGER);  (*disables radio!*)
+  BEGIN StartCmd(reg + 20H); SPI(dat); SPICtrl({}) (*W_REGISTER*)
+  END WriteReg1;
+
+  PROCEDURE SubRcv(dst: INTEGER);
+    VAR i, dat: INTEGER;
+  BEGIN
+    StartCmd(061H); (*R_RX_PAYLOAD, disables radio*)
+    SPICtrl({netSelect, spiFast});
+    FOR i := 0 TO SubPacket-4 BY 4 DO
+      SPI(-1); SYSTEM.GET(spiData, dat); SYSTEM.PUT(dst+i, dat)
+    END;
+    SPICtrl({}); WriteReg1(7, 40H); (*done; STATUS <= clear RX_DR*)
+    SPICtrl({netEnable}) (*enable radio*)
+  END SubRcv;
+
+  PROCEDURE SubSnd(src: INTEGER; VAR timeout: BOOLEAN);
+    VAR i, dat, res, t1, try: INTEGER; x, status: BYTE;
+  BEGIN (*already in xmit mode*)
+    StartCmd(0A0H); (*W_TX_PAYLOAD*)
+    SPICtrl({netSelect, spiFast});
+    FOR i := 0 TO SubPacket-4 BY 4 DO
+      SYSTEM.GET(src+i, dat); SPI(dat)
+    END;
+    SPICtrl({}); (*end W_TX_PAYLOAD command*)
+    try := 0;
+    SPICtrl({netEnable, netSelect}); (*start xmit pulse, start NOP cmd*)
+    REPEAT
+      t1 := Kernel.Time() + Wait;
+      REPEAT (*wait for sent or retransmits exceeded*);
+        SPI(0FFH); SYSTEM.GET(spiData, status); (*NOP*)
+        res := status DIV 10H MOD 4;
+        SPICtrl({}); SPICtrl({netSelect}) (*end & restart NOP cmd, end =10us pulse on enable*)
+      UNTIL res # 0;
+      IF res = 2 THEN WriteReg1(7, 20H) (*TX_DS: sent, ack received; reset it*)
+      ELSIF res = 1 THEN WriteReg1(7, 10H); INC(try); (*MAX_RT: retransmits exceeded; reset it*)
+        IF try = SendTries THEN res := 0
+        ELSE REPEAT UNTIL Kernel.Time() >= t1;
+          SPICtrl({netEnable, netSelect}); (*start xmit pulse, start NOP cmd again*)
+        END
+      END
+    UNTIL res # 1;
+    timeout := (res # 2)
+  END SubSnd;
+
+  PROCEDURE Flush();
+  BEGIN StartCmd(0E1H); SPICtrl({}); StartCmd(0E2H); SPICtrl({})
+(*FLUSH_TX, FLUSH_RX*)
+  END Flush;
+
+  PROCEDURE ResetRcv;
+  BEGIN SYSTEM.PUT(SYSTEM.ADR(rx), 0); rx.hd.len := 0; rcvd := 0
+  END ResetRcv;
+
+  PROCEDURE Listen(b: BOOLEAN);
+  BEGIN
+    WriteReg1(0, 07EH + ORD(b)); (*CONFIG <= mask ints; EN_CRC(2 byte), PWR_UP, PRX/PTX*)
+    WriteReg1(7, 70H); (*STATUS <= clear ints*)
+    IF b THEN SPICtrl({netEnable}) END (*turn radio on*)
+  END Listen;
+
+  PROCEDURE Start*(filt: BOOLEAN);
+    VAR n: INTEGER;
+  BEGIN filter := filt; Adr := 0;
+    SYSTEM.GET(swi, n); n := n DIV 4 MOD 10H * 10 + 5;
+    WriteReg1(5, n); (*RF_CH <= channel: 5, 15, 25...*)
+    WriteReg1(6, 07H); (*RF_SETUP <= 1Mb for better range, 0dBm*)
+    WriteReg1(11H, SubPacket); (*RX_PW_P0 <= pipe 0 payload width*)
+    Flush(); Listen(TRUE); ResetRcv
+  END Start;
+
+  PROCEDURE SendPacket*(VAR head: Header; dat: ARRAY OF BYTE);
+    VAR len, i, off: INTEGER; timeout: BOOLEAN; payload: ARRAY SubPacket
+OF BYTE;
+  BEGIN (*let any receive ack finish before turning radio off*)
+    i := Kernel.Time() + Wait;
+    REPEAT SPICtrl({netEnable, netSelect}); SPI(0FFH); SPICtrl({netEnable}) (*NOP*)
+    UNTIL Kernel.Time() >= i;
+    IF Adr = 0 THEN Adr := i MOD 100H END;
+    Listen(FALSE);
+    head.sadr := Adr; head.valid := TRUE;
+    SYSTEM.COPY(SYSTEM.ADR(head), SYSTEM.ADR(payload), HdrSize DIV 4);
+    i := HdrSize; off := 0; len := head.len;
+    WHILE (len > 0) & (i < SubPacket) DO payload[i] := dat[off]; INC(i); INC(off); DEC(len) END;
+    WHILE i < SubPacket DO payload[i] := 0; INC(i) END;
+    SubSnd(SYSTEM.ADR(payload), timeout);
+    WHILE ~timeout & (len # 0) DO i := 0; (*send the rest*)
+      WHILE (len > 0) & (i < SubPacket) DO payload[i] := dat[off]; INC(i); INC(off); DEC(len) END;
+      WHILE i < SubPacket DO payload[i] := 0; INC(i) END;
+      SubSnd(SYSTEM.ADR(payload), timeout)
+    END;
+    Listen(TRUE)
+  END SendPacket;
+
+  PROCEDURE Available*(): INTEGER;
+  BEGIN (*packet already rcvd*)
+    RETURN rx.hd.len - rcvd
+  END Available;
+
+  PROCEDURE Receive*(VAR x: BYTE);
+  BEGIN (*packet already rcvd*)
+    IF rcvd < rx.hd.len THEN x := rx.dat[rcvd]; INC(rcvd) ELSE x := 0 END
+  END Receive;
+
+  PROCEDURE Rcvd(time: INTEGER): BOOLEAN;
+    VAR status, fifoStatus: BYTE; rcvd: BOOLEAN;
+  BEGIN time := time + Kernel.Time();
+    REPEAT
+      SPICtrl({netEnable, netSelect}); SPI(17H); (*R_REGISTER FIFO_STATUS*)
+      SYSTEM.GET(spiData, status); SPI(-1); SYSTEM.GET(spiData, fifoStatus); SPICtrl({netEnable});
+      rcvd := ODD(status DIV 40H) OR ~ODD(fifoStatus) (*RX_DR (data ready) or RX FIFO not empty*)
+    UNTIL rcvd OR (Kernel.Time() >= time);
+    RETURN rcvd
+  END Rcvd;
+
+  PROCEDURE ReceiveHead*(VAR head: Header);  (*actually, recv whole packet*)
+    VAR adr, n: INTEGER;
+  BEGIN head.valid := FALSE;
+    IF Rcvd(0) THEN
+      ResetRcv; adr := SYSTEM.ADR(rx); SubRcv(adr);
+      n := (rx.hd.len + HdrSize - 1) DIV SubPacket;
+      IF (rx.hd.len <= MaxPayload)
+          & ((rx.hd.dadr = 0FFH) OR ~filter OR (Adr = 0) OR (rx.hd.dadr = Adr)) THEN
+        WHILE (n > 0) & Rcvd(Wait) DO
+          INC(adr, SubPacket); SubRcv(adr); DEC(n)
+        END;
+        rx.hd.valid := (n = 0)
+      ELSE WHILE Rcvd(Wait) DO SubRcv(adr) END; ResetRcv  (*discard packet*)
+      END;
+      head := rx.hd
+    END
+  END ReceiveHead;
+
+  PROCEDURE Skip*(m: INTEGER);
+    VAR dmy: BYTE;
+  BEGIN WHILE m # 0 DO Receive(dmy); DEC(m) END
+  END Skip;
+
+  PROCEDURE Stop*;
+  BEGIN SPICtrl({}); Flush(); ResetRcv
+  END Stop;
+
+BEGIN Start(TRUE)
+END SCC.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Sierpinski.Mod.txt

@@ -1,111 +1,111 @@
-MODULE Sierpinski;  (*NW 15.1.2013*)
-  IMPORT Display, Viewers, Oberon, MenuViewers, TextFrames;
-
-  CONST Menu = "System.Close  System.Copy  System.Grow";
-
-  VAR x, y, d: INTEGER;
-    A, B, C, D: PROCEDURE (i: INTEGER);
-
-  PROCEDURE E;
-  BEGIN Display.ReplConst(Display.white, x, y, d, 1, Display.paint); INC(x, d)
-  END E;
-
-  PROCEDURE N;
-  BEGIN Display.ReplConst(Display.white, x, y, 1, d, Display.paint); INC(y, d)
-  END N;
-
-  PROCEDURE W;
-  BEGIN DEC(x, d); Display.ReplConst(Display.white, x, y, d, 1, Display.paint)
-  END W;
-
-  PROCEDURE S;
-  BEGIN DEC(y, d); Display.ReplConst(Display.white, x, y, 1, d, Display.paint)
-  END S;
-
-  PROCEDURE NE;
-    VAR i: INTEGER;
-  BEGIN i := d;
-    REPEAT Display.Dot(Display.white, x, y, Display.paint); INC(x); INC(y); DEC(i) UNTIL i = 0
-  END NE;
-
-  PROCEDURE NW;
-    VAR i: INTEGER;
-  BEGIN i := d;
-    REPEAT Display.Dot(Display.white, x, y, Display.paint); DEC(x); INC(y); DEC(i) UNTIL i = 0
-  END NW;
-
-  PROCEDURE SW;
-    VAR i: INTEGER;
-  BEGIN i := d;
-    REPEAT Display.Dot(Display.white, x, y, Display.paint); DEC(x); DEC(y); DEC(i) UNTIL i = 0
-  END SW;
-
-  PROCEDURE SE;
-    VAR i: INTEGER;
-  BEGIN i := d;
-    REPEAT Display.Dot(Display.white, x, y, Display.paint); INC(x); DEC(y); DEC(i) UNTIL i = 0
-  END SE;
-
-  PROCEDURE SA(i: INTEGER);
-  BEGIN
-    IF i > 0 THEN A(i-1); SE; B(i-1); E; E; D(i-1); NE; A(i-1) END
-  END SA;
-
-  PROCEDURE SB(i: INTEGER);
-  BEGIN
-    IF i > 0 THEN B(i-1); SW; C(i-1); S; S; A(i-1); SE; B(i-1) END
-  END SB;
-
-  PROCEDURE SC(i: INTEGER);
-  BEGIN
-    IF i > 0 THEN C(i-1); NW; D(i-1); W; W; B(i-1); SW; C(i-1) END
-  END SC;
-
-  PROCEDURE SD(i: INTEGER);
-  BEGIN
-    IF i > 0 THEN D(i-1); NE; A(i-1); N; N; C(i-1); NW; D(i-1) END
-  END SD;
-
-  PROCEDURE DrawSierpinski(F: Display.Frame);
-    VAR k, n, w, x0, y0: INTEGER;
-  BEGIN; k := 0; d := 4;
-    IF F.W < F.H THEN w := F.W ELSE w := F.H END ;
-    WHILE d*8 < w DO d := d*2; INC(k) END ;
-    Display.ReplConst(Display.black, F.X, F.Y, F.W, F.H, Display.replace);
-    x0 := F.W DIV 2; y0 := F.H DIV 2 + d; n := 0;
-    WHILE n < k DO
-      INC(n); DEC(x0, d); d := d DIV 2; INC(y0, d);
-      x := F.X + x0; y := F.Y + y0;
-      SA(n); SE; SB(n); SW; SC(n); NW; SD(n); NE
-    END
-  END DrawSierpinski;
-
-  PROCEDURE Handler(F: Display.Frame; VAR M: Display.FrameMsg);
-    VAR F1: Display.Frame;
-  BEGIN
-    IF M IS Oberon.InputMsg THEN
-      IF M(Oberon.InputMsg).id = Oberon.track THEN
-        Oberon.DrawMouseArrow(M(Oberon.InputMsg).X, M(Oberon.InputMsg).Y)
-      END
-    ELSIF M IS MenuViewers.ModifyMsg THEN
-      F.Y := M(MenuViewers.ModifyMsg).Y; F.H := M(MenuViewers.ModifyMsg).H; DrawSierpinski(F)
-    ELSIF M IS Oberon.ControlMsg THEN
-      IF M(Oberon.ControlMsg).id = Oberon.neutralize THEN Oberon.RemoveMarks(F.X, F.Y, F.W, F.H) END
-    ELSIF M IS Oberon.CopyMsg THEN
-       NEW(F1); F1^ := F^; M(Oberon.CopyMsg).F := F1
-    END
-  END Handler;
-
-  PROCEDURE New(): Display.Frame;
-    VAR F: Display.Frame;
-  BEGIN NEW(F); F.handle := Handler; RETURN F
-  END New;
-
-  PROCEDURE Draw*;
-    VAR V: Viewers.Viewer; X, Y: INTEGER;
-  BEGIN Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
-    V := MenuViewers.New(TextFrames.NewMenu("Sierpinski", Menu), New(), TextFrames.menuH, X, Y)
-  END Draw;
-
-BEGIN A := SA; B := SB; C := SC; D := SD
-END Sierpinski.
+MODULE Sierpinski;  (*NW 15.1.2013*)
+  IMPORT Display, Viewers, Oberon, MenuViewers, TextFrames;
+
+  CONST Menu = "System.Close  System.Copy  System.Grow";
+
+  VAR x, y, d: INTEGER;
+    A, B, C, D: PROCEDURE (i: INTEGER);
+
+  PROCEDURE E;
+  BEGIN Display.ReplConst(Display.white, x, y, d, 1, Display.paint); INC(x, d)
+  END E;
+
+  PROCEDURE N;
+  BEGIN Display.ReplConst(Display.white, x, y, 1, d, Display.paint); INC(y, d)
+  END N;
+
+  PROCEDURE W;
+  BEGIN DEC(x, d); Display.ReplConst(Display.white, x, y, d, 1, Display.paint)
+  END W;
+
+  PROCEDURE S;
+  BEGIN DEC(y, d); Display.ReplConst(Display.white, x, y, 1, d, Display.paint)
+  END S;
+
+  PROCEDURE NE;
+    VAR i: INTEGER;
+  BEGIN i := d;
+    REPEAT Display.Dot(Display.white, x, y, Display.paint); INC(x); INC(y); DEC(i) UNTIL i = 0
+  END NE;
+
+  PROCEDURE NW;
+    VAR i: INTEGER;
+  BEGIN i := d;
+    REPEAT Display.Dot(Display.white, x, y, Display.paint); DEC(x); INC(y); DEC(i) UNTIL i = 0
+  END NW;
+
+  PROCEDURE SW;
+    VAR i: INTEGER;
+  BEGIN i := d;
+    REPEAT Display.Dot(Display.white, x, y, Display.paint); DEC(x); DEC(y); DEC(i) UNTIL i = 0
+  END SW;
+
+  PROCEDURE SE;
+    VAR i: INTEGER;
+  BEGIN i := d;
+    REPEAT Display.Dot(Display.white, x, y, Display.paint); INC(x); DEC(y); DEC(i) UNTIL i = 0
+  END SE;
+
+  PROCEDURE SA(i: INTEGER);
+  BEGIN
+    IF i > 0 THEN A(i-1); SE; B(i-1); E; E; D(i-1); NE; A(i-1) END
+  END SA;
+
+  PROCEDURE SB(i: INTEGER);
+  BEGIN
+    IF i > 0 THEN B(i-1); SW; C(i-1); S; S; A(i-1); SE; B(i-1) END
+  END SB;
+
+  PROCEDURE SC(i: INTEGER);
+  BEGIN
+    IF i > 0 THEN C(i-1); NW; D(i-1); W; W; B(i-1); SW; C(i-1) END
+  END SC;
+
+  PROCEDURE SD(i: INTEGER);
+  BEGIN
+    IF i > 0 THEN D(i-1); NE; A(i-1); N; N; C(i-1); NW; D(i-1) END
+  END SD;
+
+  PROCEDURE DrawSierpinski(F: Display.Frame);
+    VAR k, n, w, x0, y0: INTEGER;
+  BEGIN; k := 0; d := 4;
+    IF F.W < F.H THEN w := F.W ELSE w := F.H END ;
+    WHILE d*8 < w DO d := d*2; INC(k) END ;
+    Display.ReplConst(Display.black, F.X, F.Y, F.W, F.H, Display.replace);
+    x0 := F.W DIV 2; y0 := F.H DIV 2 + d; n := 0;
+    WHILE n < k DO
+      INC(n); DEC(x0, d); d := d DIV 2; INC(y0, d);
+      x := F.X + x0; y := F.Y + y0;
+      SA(n); SE; SB(n); SW; SC(n); NW; SD(n); NE
+    END
+  END DrawSierpinski;
+
+  PROCEDURE Handler(F: Display.Frame; VAR M: Display.FrameMsg);
+    VAR F1: Display.Frame;
+  BEGIN
+    IF M IS Oberon.InputMsg THEN
+      IF M(Oberon.InputMsg).id = Oberon.track THEN
+        Oberon.DrawMouseArrow(M(Oberon.InputMsg).X, M(Oberon.InputMsg).Y)
+      END
+    ELSIF M IS MenuViewers.ModifyMsg THEN
+      F.Y := M(MenuViewers.ModifyMsg).Y; F.H := M(MenuViewers.ModifyMsg).H; DrawSierpinski(F)
+    ELSIF M IS Oberon.ControlMsg THEN
+      IF M(Oberon.ControlMsg).id = Oberon.neutralize THEN Oberon.RemoveMarks(F.X, F.Y, F.W, F.H) END
+    ELSIF M IS Oberon.CopyMsg THEN
+       NEW(F1); F1^ := F^; M(Oberon.CopyMsg).F := F1
+    END
+  END Handler;
+
+  PROCEDURE New(): Display.Frame;
+    VAR F: Display.Frame;
+  BEGIN NEW(F); F.handle := Handler; RETURN F
+  END New;
+
+  PROCEDURE Draw*;
+    VAR V: Viewers.Viewer; X, Y: INTEGER;
+  BEGIN Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
+    V := MenuViewers.New(TextFrames.NewMenu("Sierpinski", Menu), New(), TextFrames.menuH, X, Y)
+  END Draw;
+
+BEGIN A := SA; B := SB; C := SC; D := SD
+END Sierpinski.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/SmallPrograms.Mod.txt

@@ -1,233 +1,233 @@
-ORP.Compile @/s  Blink.Run  BlinkStop
-
-MODULE Blink;   (*NW 30.5.2013  use of a Task; blinks LED every second*)
-  IMPORT SYSTEM, Oberon;
-  VAR z: INTEGER;
-    T: Oberon.Task;
-  
-  PROCEDURE Run*;
-  BEGIN Oberon.Install(T)
-  END Run;
-
-  PROCEDURE Stop*;
-  BEGIN Oberon.Remove(T)
-  END Stop;
-
-  PROCEDURE Tick;
-  BEGIN z := 1-z; LED(z)
-  END Tick;
-
-BEGIN z := 0; T := Oberon.NewTask(Tick, 500)
-END Blink.
-
-ORP.Compile @/s  Permutations.Generate 2 3 4~
-
-MODULE Permutations;  (*NW 22.1.2013*)
-  IMPORT Texts, Oberon;
-  VAR n: INTEGER;
-    a: ARRAY 10 OF INTEGER;
-    S: Texts.Scanner;
-    W: Texts.Writer;
-
-  PROCEDURE perm(k: INTEGER);
-    VAR i, x: INTEGER;
-  BEGIN
-    IF k = 0 THEN i := 0;
-      WHILE i < n DO Texts.WriteInt(W, a[i], 5); i := i+1 END ;
-      Texts.WriteLn(W)
-    ELSE perm(k-1); i := 0;
-      WHILE i < k-1 DO
-        x := a[i]; a[i] := a[k-1]; a[k-1] := x;
-        perm(k-1);
-        x := a[i]; a[i] := a[k-1]; a[k-1] := x;
-        i := i+1
-      END
-    END
-  END perm;
-
-  PROCEDURE Generate*;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); n := 0;
-    WHILE S.class = Texts.Int DO a[n] := S.i; INC(n); Texts.Scan(S) END ;
-    perm(n);
-    Texts.Append(Oberon.Log, W.buf)
-  END Generate;
-
-BEGIN Texts.OpenWriter(W)
-END Permutations.
-
-ORP.Compile @/s  MagicSquares.Generate 3
-
-MODULE MagicSquares;   (*NW 11.8.97*)
-  IMPORT Texts, Oberon;
-
-  VAR W: Texts.Writer;
-
-  PROCEDURE Generate*;  (*magic square of order 3, 5, 7, ... *)
-    VAR i, j, x, nx, nsq, n: INTEGER;
-      M: ARRAY 13, 13 OF INTEGER;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Int THEN
-      n := S.i; nsq := n*n; x := 0;
-      i := n DIV 2; j := n-1;
-      WHILE x < nsq DO
-        nx := n + x; j := (j-1) MOD n; INC(x); M[i, j] := x;
-        WHILE x < nx DO
-          i := (i+1) MOD n; j := (j+1) MOD n;
-          INC(x); M[i, j] := x
-        END
-      END ;
-      FOR i := 0 TO n-1 DO
-        FOR j := 0 TO n-1 DO Texts.WriteInt(W, M[i, j], 6) END ;
-        Texts.WriteLn(W)
-      END ;
-      Texts.Append(Oberon.Log, W.buf)
-    END
-  END Generate;
-
-BEGIN Texts.OpenWriter(W)
-END MagicSquares.
-
-ORP.Compile @/s  PrimeNumbers.Generate 12
-
-MODULE PrimeNumbers;  (*NW 6.9.07; Tabulate prime numbers; for Oberon-07  NW 25.1.2013*)
-  IMPORT Texts, Oberon;
-  
-  VAR n: INTEGER;
-    W: Texts.Writer;
-    p: ARRAY 400 OF INTEGER;
-    v: ARRAY 20 OF INTEGER;
-
-  PROCEDURE Primes(n: INTEGER);
-    VAR i, k, m, x, inc, lim, sqr: INTEGER; prim: BOOLEAN;
-  BEGIN x := 1; inc := 4; lim := 1; sqr := 4; m := 0;
-    FOR i := 3 TO n DO
-      REPEAT x := x + inc; inc := 6 - inc;
-        IF sqr <= x THEN  (*sqr = p[lim]^2*)
-          v[lim] := sqr; INC(lim); sqr := p[lim]*p[lim]
-        END ;
-        k := 2; prim := TRUE;
-        WHILE prim & (k < lim) DO
-          INC(k);;
-          IF v[k] < x THEN v[k] := v[k] + p[k] END ;
-          prim := x # v[k]
-        END
-      UNTIL prim;
-      p[i] := x; Texts.WriteInt(W, x, 5);
-      IF m = 10 THEN Texts.WriteLn(W); m := 0 ELSE INC(m) END
-    END ;
-    IF m > 0 THEN Texts.WriteLn(W) END
-  END Primes;
-
-  PROCEDURE Generate*;
-    VAR S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.i < 400 THEN
-      Primes(S.i); Texts.Append(Oberon.Log, W.buf)
-    END
-  END Generate;
-
-BEGIN Texts.OpenWriter(W);
-END PrimeNumbers.
-
-ORP.Compile @/s  Fractions.Generate 16
-
-MODULE Fractions;  (*NW  10.10.07;  Tabulate fractions 1/n*)
-  IMPORT Texts, Oberon;
-  
-  CONST Base = 10; N = 32;
-  VAR W: Texts.Writer;
-  
-  PROCEDURE Generate*;
-    VAR i, j, m, r: INTEGER;
-      d: ARRAY N OF INTEGER;  (*digits*)
-      x: ARRAY N OF INTEGER;  (*index*)
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF (S.class = Texts.Int) & (S.i < N) THEN
-      i := 2;
-      WHILE i <= S.i DO j := 0;
-        WHILE j < i DO x[j] := 0; INC(j) END ;
-        m := 0; r := 1;
-        WHILE x[r] = 0 DO
-          x[r] := m; r := Base*r; d[m] := r DIV i; r := r MOD i; INC(m)
-        END ;
-        Texts.WriteInt(W, i, 5); Texts.Write(W, 9X); Texts.Write(W, "."); j := 0;
-        WHILE j < x[r] DO Texts.Write(W, CHR(d[j] + 48)); INC(j) END ;
-        Texts.Write(W, "'");
-        WHILE j < m DO Texts.Write(W, CHR(d[j] + 48)); INC(j) END ;
-        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); INC(i)
-      END
-    END
-  END Generate;
-
-BEGIN Texts.OpenWriter(W)
-END Fractions.
-
-ORP.Compile @/s  Powers.Generate 16
-
-MODULE Powers;  (*NW  10.10.07; Tabulate positive and negative powers of 2*)
-  IMPORT Texts, Oberon;
-
-  CONST N = 32; M = 11;  (*M ~ N*log2*)
-  VAR W: Texts.Writer;
-  
-  PROCEDURE Generate*;
-    VAR i, k, n, exp: INTEGER;
-      c, r, t: INTEGER;
-      d: ARRAY M OF INTEGER;
-      f: ARRAY N OF INTEGER;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF (S.class = Texts.Int) & (S.i <= N) THEN
-      n := S.i; d[0] := 1; k := 1; exp := 1;
-      WHILE exp < n DO
-        (*compute d = 2^exp*)
-        c := 0;  (*carry*) i := 0;
-        WHILE i < k DO
-          t := 2*d[i] + c;
-          IF t < 10 THEN d[i] := t; c := 0 ELSE d[i] := t - 10; c := 1 END ;
-          i := i+1
-        END ;
-        IF c = 1 THEN d[k] := 1; k := k+1 END ;
-        (*write d*) i := M;
-        WHILE i > k DO i := i-1; Texts.Write(W, " ") END ;
-        WHILE i > 0 DO i := i-1; Texts.Write(W, CHR(d[i] + 30H)) END ;
-        Texts.WriteInt(W, exp, M);
-        (*compute  f = 2^-exp*)
-        Texts.WriteString(W, "  0."); r := 0; i := 1;
-        WHILE i < exp DO
-          r := 10*r + f[i]; f[i] := r DIV 2; r := r MOD 2;
-          Texts.Write(W, CHR(f[i] + 30H)); i := i+1
-        END ;
-        f[exp] := 5; Texts.Write(W, "5"); Texts.WriteLn(W); exp := exp + 1
-      END ;
-      Texts.Append(Oberon.Log, W.buf)
-    END
-  END Generate;
-
-BEGIN Texts.OpenWriter(W)
-END Powers.
-
-ORP.Compile @/s  Harmonic.Compute 200
-
-MODULE Harmonic;   (*NW 27.1.2013*)
-  IMPORT Texts, Oberon;
-  VAR W: Texts.Writer;
-  
-  PROCEDURE Compute*;
-      VAR n: INTEGER;
-        x0, x1, u: REAL;
-        S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF (S.class = Texts.Int) & (S.i > 0) THEN
-      n := 0; u := 0.0; x0 := 0.0; x1 := 0.0;
-      WHILE n < S.i DO INC(n); u := u + 1.0; x0 := x0 + 1.0/u END ;
-      WHILE n > 0 DO x1 := x1 + 1.0/u; u := u - 1.0; DEC(n) END ;
-      Texts.WriteInt(W, S.i, 6); Texts.WriteReal(W, x0, 15); Texts.WriteReal(W, x1, 15);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
-    END
-  END Compute;
-
-BEGIN Texts.OpenWriter(W)
-END Harmonic.
+ORP.Compile @/s  Blink.Run  BlinkStop
+
+MODULE Blink;   (*NW 30.5.2013  use of a Task; blinks LED every second*)
+  IMPORT SYSTEM, Oberon;
+  VAR z: INTEGER;
+    T: Oberon.Task;
+  
+  PROCEDURE Run*;
+  BEGIN Oberon.Install(T)
+  END Run;
+
+  PROCEDURE Stop*;
+  BEGIN Oberon.Remove(T)
+  END Stop;
+
+  PROCEDURE Tick;
+  BEGIN z := 1-z; LED(z)
+  END Tick;
+
+BEGIN z := 0; T := Oberon.NewTask(Tick, 500)
+END Blink.
+
+ORP.Compile @/s  Permutations.Generate 2 3 4~
+
+MODULE Permutations;  (*NW 22.1.2013*)
+  IMPORT Texts, Oberon;
+  VAR n: INTEGER;
+    a: ARRAY 10 OF INTEGER;
+    S: Texts.Scanner;
+    W: Texts.Writer;
+
+  PROCEDURE perm(k: INTEGER);
+    VAR i, x: INTEGER;
+  BEGIN
+    IF k = 0 THEN i := 0;
+      WHILE i < n DO Texts.WriteInt(W, a[i], 5); i := i+1 END ;
+      Texts.WriteLn(W)
+    ELSE perm(k-1); i := 0;
+      WHILE i < k-1 DO
+        x := a[i]; a[i] := a[k-1]; a[k-1] := x;
+        perm(k-1);
+        x := a[i]; a[i] := a[k-1]; a[k-1] := x;
+        i := i+1
+      END
+    END
+  END perm;
+
+  PROCEDURE Generate*;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); n := 0;
+    WHILE S.class = Texts.Int DO a[n] := S.i; INC(n); Texts.Scan(S) END ;
+    perm(n);
+    Texts.Append(Oberon.Log, W.buf)
+  END Generate;
+
+BEGIN Texts.OpenWriter(W)
+END Permutations.
+
+ORP.Compile @/s  MagicSquares.Generate 3
+
+MODULE MagicSquares;   (*NW 11.8.97*)
+  IMPORT Texts, Oberon;
+
+  VAR W: Texts.Writer;
+
+  PROCEDURE Generate*;  (*magic square of order 3, 5, 7, ... *)
+    VAR i, j, x, nx, nsq, n: INTEGER;
+      M: ARRAY 13, 13 OF INTEGER;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Int THEN
+      n := S.i; nsq := n*n; x := 0;
+      i := n DIV 2; j := n-1;
+      WHILE x < nsq DO
+        nx := n + x; j := (j-1) MOD n; INC(x); M[i, j] := x;
+        WHILE x < nx DO
+          i := (i+1) MOD n; j := (j+1) MOD n;
+          INC(x); M[i, j] := x
+        END
+      END ;
+      FOR i := 0 TO n-1 DO
+        FOR j := 0 TO n-1 DO Texts.WriteInt(W, M[i, j], 6) END ;
+        Texts.WriteLn(W)
+      END ;
+      Texts.Append(Oberon.Log, W.buf)
+    END
+  END Generate;
+
+BEGIN Texts.OpenWriter(W)
+END MagicSquares.
+
+ORP.Compile @/s  PrimeNumbers.Generate 12
+
+MODULE PrimeNumbers;  (*NW 6.9.07; Tabulate prime numbers; for Oberon-07  NW 25.1.2013*)
+  IMPORT Texts, Oberon;
+  
+  VAR n: INTEGER;
+    W: Texts.Writer;
+    p: ARRAY 400 OF INTEGER;
+    v: ARRAY 20 OF INTEGER;
+
+  PROCEDURE Primes(n: INTEGER);
+    VAR i, k, m, x, inc, lim, sqr: INTEGER; prim: BOOLEAN;
+  BEGIN x := 1; inc := 4; lim := 1; sqr := 4; m := 0;
+    FOR i := 3 TO n DO
+      REPEAT x := x + inc; inc := 6 - inc;
+        IF sqr <= x THEN  (*sqr = p[lim]^2*)
+          v[lim] := sqr; INC(lim); sqr := p[lim]*p[lim]
+        END ;
+        k := 2; prim := TRUE;
+        WHILE prim & (k < lim) DO
+          INC(k);;
+          IF v[k] < x THEN v[k] := v[k] + p[k] END ;
+          prim := x # v[k]
+        END
+      UNTIL prim;
+      p[i] := x; Texts.WriteInt(W, x, 5);
+      IF m = 10 THEN Texts.WriteLn(W); m := 0 ELSE INC(m) END
+    END ;
+    IF m > 0 THEN Texts.WriteLn(W) END
+  END Primes;
+
+  PROCEDURE Generate*;
+    VAR S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.i < 400 THEN
+      Primes(S.i); Texts.Append(Oberon.Log, W.buf)
+    END
+  END Generate;
+
+BEGIN Texts.OpenWriter(W);
+END PrimeNumbers.
+
+ORP.Compile @/s  Fractions.Generate 16
+
+MODULE Fractions;  (*NW  10.10.07;  Tabulate fractions 1/n*)
+  IMPORT Texts, Oberon;
+  
+  CONST Base = 10; N = 32;
+  VAR W: Texts.Writer;
+  
+  PROCEDURE Generate*;
+    VAR i, j, m, r: INTEGER;
+      d: ARRAY N OF INTEGER;  (*digits*)
+      x: ARRAY N OF INTEGER;  (*index*)
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF (S.class = Texts.Int) & (S.i < N) THEN
+      i := 2;
+      WHILE i <= S.i DO j := 0;
+        WHILE j < i DO x[j] := 0; INC(j) END ;
+        m := 0; r := 1;
+        WHILE x[r] = 0 DO
+          x[r] := m; r := Base*r; d[m] := r DIV i; r := r MOD i; INC(m)
+        END ;
+        Texts.WriteInt(W, i, 5); Texts.Write(W, 9X); Texts.Write(W, "."); j := 0;
+        WHILE j < x[r] DO Texts.Write(W, CHR(d[j] + 48)); INC(j) END ;
+        Texts.Write(W, "'");
+        WHILE j < m DO Texts.Write(W, CHR(d[j] + 48)); INC(j) END ;
+        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); INC(i)
+      END
+    END
+  END Generate;
+
+BEGIN Texts.OpenWriter(W)
+END Fractions.
+
+ORP.Compile @/s  Powers.Generate 16
+
+MODULE Powers;  (*NW  10.10.07; Tabulate positive and negative powers of 2*)
+  IMPORT Texts, Oberon;
+
+  CONST N = 32; M = 11;  (*M ~ N*log2*)
+  VAR W: Texts.Writer;
+  
+  PROCEDURE Generate*;
+    VAR i, k, n, exp: INTEGER;
+      c, r, t: INTEGER;
+      d: ARRAY M OF INTEGER;
+      f: ARRAY N OF INTEGER;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF (S.class = Texts.Int) & (S.i <= N) THEN
+      n := S.i; d[0] := 1; k := 1; exp := 1;
+      WHILE exp < n DO
+        (*compute d = 2^exp*)
+        c := 0;  (*carry*) i := 0;
+        WHILE i < k DO
+          t := 2*d[i] + c;
+          IF t < 10 THEN d[i] := t; c := 0 ELSE d[i] := t - 10; c := 1 END ;
+          i := i+1
+        END ;
+        IF c = 1 THEN d[k] := 1; k := k+1 END ;
+        (*write d*) i := M;
+        WHILE i > k DO i := i-1; Texts.Write(W, " ") END ;
+        WHILE i > 0 DO i := i-1; Texts.Write(W, CHR(d[i] + 30H)) END ;
+        Texts.WriteInt(W, exp, M);
+        (*compute  f = 2^-exp*)
+        Texts.WriteString(W, "  0."); r := 0; i := 1;
+        WHILE i < exp DO
+          r := 10*r + f[i]; f[i] := r DIV 2; r := r MOD 2;
+          Texts.Write(W, CHR(f[i] + 30H)); i := i+1
+        END ;
+        f[exp] := 5; Texts.Write(W, "5"); Texts.WriteLn(W); exp := exp + 1
+      END ;
+      Texts.Append(Oberon.Log, W.buf)
+    END
+  END Generate;
+
+BEGIN Texts.OpenWriter(W)
+END Powers.
+
+ORP.Compile @/s  Harmonic.Compute 200
+
+MODULE Harmonic;   (*NW 27.1.2013*)
+  IMPORT Texts, Oberon;
+  VAR W: Texts.Writer;
+  
+  PROCEDURE Compute*;
+      VAR n: INTEGER;
+        x0, x1, u: REAL;
+        S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF (S.class = Texts.Int) & (S.i > 0) THEN
+      n := 0; u := 0.0; x0 := 0.0; x1 := 0.0;
+      WHILE n < S.i DO INC(n); u := u + 1.0; x0 := x0 + 1.0/u END ;
+      WHILE n > 0 DO x1 := x1 + 1.0/u; u := u - 1.0; DEC(n) END ;
+      Texts.WriteInt(W, S.i, 6); Texts.WriteReal(W, x0, 15); Texts.WriteReal(W, x1, 15);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
+    END
+  END Compute;
+
+BEGIN Texts.OpenWriter(W)
+END Harmonic.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Stars.Mod.txt

@@ -1,109 +1,109 @@
-MODULE Stars;   (*NW 15.1.2013, 15.11.2013*)
-  IMPORT SYSTEM, Display, Viewers, Texts, Oberon, MenuViewers, TextFrames;
-
-  CONST N = 6;  (*nof stars*)
-    w = 16;   (*width of star*)
-    interval = 200;  (*millisec*)
-
-  TYPE Frame = POINTER TO FrameDesc;
-    Pos = RECORD x, y, dx, dy: INTEGER END ;
-    FrameDesc = RECORD (Display.FrameDesc) s: ARRAY N OF Pos END ;
-    RestoreMsg = RECORD (Display.FrameMsg) END ;
-    StepMsg = RECORD (Display.FrameMsg) END ;
-
-  VAR T: Oberon.Task;
-    W: Texts.Writer;
-
-  PROCEDURE Draw(x, y: INTEGER);
-  BEGIN Display.CopyPattern(Display.white, Display.star, x, y, Display.invert)
-  END Draw;
-
-  PROCEDURE Restore(F: Frame);
-    VAR x0, y0: INTEGER;
-  BEGIN Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
-    Display.ReplConst(0, F.X+1, F.Y, F.W-1, F.H, 0);
-    x0 := F.W DIV 2 + F.X; y0 := F.H DIV 2 + F.Y;
-    F.s[0].x := x0; F.s[0].y := y0; F.s[0].dx := 2; F.s[0].dy := 4; Draw(F.s[0].x, F.s[0].y);
-    F.s[1].x := x0; F.s[1].y := y0; F.s[1].dx := 3; F.s[1].dy := 9; Draw(F.s[1].x, F.s[1].y);
-    F.s[2].x := x0; F.s[2].y := y0; F.s[2].dx := -5; F.s[2].dy := -2; Draw(F.s[2].x, F.s[2].y);
-    F.s[3].x := x0; F.s[3].y := y0; F.s[3].dx := -10; F.s[3].dy := 8; Draw(F.s[3].x, F.s[3].y);
-    F.s[4].x := x0; F.s[4].y := y0; F.s[4].dx := -7; F.s[4].dy := -4; Draw(F.s[4].x, F.s[4].y);
-    F.s[5].x := x0; F.s[5].y := y0; F.s[5].dx := 8; F.s[5].dy := -10; Draw(F.s[5].x, F.s[5].y)
-  END Restore;
-
-  PROCEDURE Move(F: Frame; VAR p: Pos);
-    VAR X1, Y1: INTEGER;
-  BEGIN X1 := F.X + F.W - w; Y1 := F.Y + F.H - w;
-    Draw(p.x, p.y); INC(p.x, p.dx); INC(p.y, p.dy);
-    IF p.x < F.X THEN p.x := 2*F.X - p.x; p.dx := -p.dx ELSIF p.x >= X1 THEN p.x := 2*X1 - p.x; p.dx := -p.dx END ;
-    IF p.y < F.Y THEN p.y := 2*F.Y - p.y; p.dy := -p.dy ELSIF p.y  >= Y1 THEN p.y := 2*Y1 - p.y; p.dy := -p.dy END ;
-    Draw(p.x, p.y)
-  END Move;
-
-  PROCEDURE Steps(F: Frame);
-    VAR i: INTEGER; 
-  BEGIN i := 0;
-    WHILE i < N DO Move(F, F.s[i]); INC(i) END
-  END Steps;
-
-  PROCEDURE Handle(F: Display.Frame; VAR M: Display.FrameMsg);
-    VAR F1: Frame;
-  BEGIN
-    CASE F OF Frame:
-      CASE M OF
-        Oberon.InputMsg:
-          IF M(Oberon.InputMsg).id = Oberon.track THEN
-            Oberon.DrawMouseArrow(M(Oberon.InputMsg).X, M(Oberon.InputMsg).Y)
-          END
-      | StepMsg: Steps(F)
-      | RestoreMsg: Restore(F)
-      | Oberon.CopyMsg: Oberon.Remove(T); NEW(F1); F1^ := F^; M.F := F1
-      | MenuViewers.ModifyMsg:
-        IF (M.Y # F.Y) OR (M.H # F.H) THEN F.Y := M.Y; F.H := M.H; Restore(F) END
-      END
-    END
-  END Handle;
-
-  PROCEDURE Step*;
-    VAR k: INTEGER; M: StepMsg;
-  BEGIN
-    IF Oberon.Par.vwr.dsc = Oberon.Par.frame THEN Steps(Oberon.Par.frame.next(Frame))
-    ELSE Viewers.Broadcast(M)
-    END
-  END Step;
-
-  PROCEDURE Open*;
-    VAR F: Frame; V: Viewers.Viewer; X, Y: INTEGER;
-  BEGIN NEW(F); F.handle := Handle;
-    Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
-    V := MenuViewers.New(
-      TextFrames.NewMenu("Stars", "Stars.Close  System.Grow  System.Copy  Stars.Step  Stars.Run  Stars.Stop"),
-      F, TextFrames.menuH, X, Y)
-  END Open;
-
-  PROCEDURE Run*;
-  BEGIN Oberon.Install(T)
-  END Run;
-
-  PROCEDURE Stop*;
-  BEGIN Oberon.Remove(T)
-  END Stop;
-
-  PROCEDURE Close*;
-  BEGIN
-    IF Oberon.Par.vwr.dsc = Oberon.Par.frame THEN Stop; Viewers.Close(Oberon.Par.vwr) END
-  END Close;
-
-  PROCEDURE Step1;
-    VAR M: StepMsg;
-  BEGIN Viewers.Broadcast(M)
-  END Step1;
-
-  PROCEDURE SetPeriod*;
-    VAR S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Int THEN T.period := S.i END
-  END SetPeriod;
-
-BEGIN Texts.OpenWriter(W); T := Oberon.NewTask(Step1, interval);
-END Stars.
+MODULE Stars;   (*NW 15.1.2013, 15.11.2013*)
+  IMPORT SYSTEM, Display, Viewers, Texts, Oberon, MenuViewers, TextFrames;
+
+  CONST N = 6;  (*nof stars*)
+    w = 16;   (*width of star*)
+    interval = 200;  (*millisec*)
+
+  TYPE Frame = POINTER TO FrameDesc;
+    Pos = RECORD x, y, dx, dy: INTEGER END ;
+    FrameDesc = RECORD (Display.FrameDesc) s: ARRAY N OF Pos END ;
+    RestoreMsg = RECORD (Display.FrameMsg) END ;
+    StepMsg = RECORD (Display.FrameMsg) END ;
+
+  VAR T: Oberon.Task;
+    W: Texts.Writer;
+
+  PROCEDURE Draw(x, y: INTEGER);
+  BEGIN Display.CopyPattern(Display.white, Display.star, x, y, Display.invert)
+  END Draw;
+
+  PROCEDURE Restore(F: Frame);
+    VAR x0, y0: INTEGER;
+  BEGIN Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
+    Display.ReplConst(0, F.X+1, F.Y, F.W-1, F.H, 0);
+    x0 := F.W DIV 2 + F.X; y0 := F.H DIV 2 + F.Y;
+    F.s[0].x := x0; F.s[0].y := y0; F.s[0].dx := 2; F.s[0].dy := 4; Draw(F.s[0].x, F.s[0].y);
+    F.s[1].x := x0; F.s[1].y := y0; F.s[1].dx := 3; F.s[1].dy := 9; Draw(F.s[1].x, F.s[1].y);
+    F.s[2].x := x0; F.s[2].y := y0; F.s[2].dx := -5; F.s[2].dy := -2; Draw(F.s[2].x, F.s[2].y);
+    F.s[3].x := x0; F.s[3].y := y0; F.s[3].dx := -10; F.s[3].dy := 8; Draw(F.s[3].x, F.s[3].y);
+    F.s[4].x := x0; F.s[4].y := y0; F.s[4].dx := -7; F.s[4].dy := -4; Draw(F.s[4].x, F.s[4].y);
+    F.s[5].x := x0; F.s[5].y := y0; F.s[5].dx := 8; F.s[5].dy := -10; Draw(F.s[5].x, F.s[5].y)
+  END Restore;
+
+  PROCEDURE Move(F: Frame; VAR p: Pos);
+    VAR X1, Y1: INTEGER;
+  BEGIN X1 := F.X + F.W - w; Y1 := F.Y + F.H - w;
+    Draw(p.x, p.y); INC(p.x, p.dx); INC(p.y, p.dy);
+    IF p.x < F.X THEN p.x := 2*F.X - p.x; p.dx := -p.dx ELSIF p.x >= X1 THEN p.x := 2*X1 - p.x; p.dx := -p.dx END ;
+    IF p.y < F.Y THEN p.y := 2*F.Y - p.y; p.dy := -p.dy ELSIF p.y  >= Y1 THEN p.y := 2*Y1 - p.y; p.dy := -p.dy END ;
+    Draw(p.x, p.y)
+  END Move;
+
+  PROCEDURE Steps(F: Frame);
+    VAR i: INTEGER; 
+  BEGIN i := 0;
+    WHILE i < N DO Move(F, F.s[i]); INC(i) END
+  END Steps;
+
+  PROCEDURE Handle(F: Display.Frame; VAR M: Display.FrameMsg);
+    VAR F1: Frame;
+  BEGIN
+    CASE F OF Frame:
+      CASE M OF
+        Oberon.InputMsg:
+          IF M(Oberon.InputMsg).id = Oberon.track THEN
+            Oberon.DrawMouseArrow(M(Oberon.InputMsg).X, M(Oberon.InputMsg).Y)
+          END
+      | StepMsg: Steps(F)
+      | RestoreMsg: Restore(F)
+      | Oberon.CopyMsg: Oberon.Remove(T); NEW(F1); F1^ := F^; M.F := F1
+      | MenuViewers.ModifyMsg:
+        IF (M.Y # F.Y) OR (M.H # F.H) THEN F.Y := M.Y; F.H := M.H; Restore(F) END
+      END
+    END
+  END Handle;
+
+  PROCEDURE Step*;
+    VAR k: INTEGER; M: StepMsg;
+  BEGIN
+    IF Oberon.Par.vwr.dsc = Oberon.Par.frame THEN Steps(Oberon.Par.frame.next(Frame))
+    ELSE Viewers.Broadcast(M)
+    END
+  END Step;
+
+  PROCEDURE Open*;
+    VAR F: Frame; V: Viewers.Viewer; X, Y: INTEGER;
+  BEGIN NEW(F); F.handle := Handle;
+    Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
+    V := MenuViewers.New(
+      TextFrames.NewMenu("Stars", "Stars.Close  System.Grow  System.Copy  Stars.Step  Stars.Run  Stars.Stop"),
+      F, TextFrames.menuH, X, Y)
+  END Open;
+
+  PROCEDURE Run*;
+  BEGIN Oberon.Install(T)
+  END Run;
+
+  PROCEDURE Stop*;
+  BEGIN Oberon.Remove(T)
+  END Stop;
+
+  PROCEDURE Close*;
+  BEGIN
+    IF Oberon.Par.vwr.dsc = Oberon.Par.frame THEN Stop; Viewers.Close(Oberon.Par.vwr) END
+  END Close;
+
+  PROCEDURE Step1;
+    VAR M: StepMsg;
+  BEGIN Viewers.Broadcast(M)
+  END Step1;
+
+  PROCEDURE SetPeriod*;
+    VAR S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Int THEN T.period := S.i END
+  END SetPeriod;
+
+BEGIN Texts.OpenWriter(W); T := Oberon.NewTask(Step1, interval);
+END Stars.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/System.Mod.txt

@@ -1,418 +1,418 @@
-MODULE System; (*JG 3.10.90 / NW 12.10.93 / NW 20.6.2016*)
-  IMPORT SYSTEM, Kernel, FileDir, Files, Modules,
-    Input, Display, Viewers, Fonts, Texts, Oberon, MenuViewers, TextFrames;
-
-  CONST
-    StandardMenu = "System.Close System.Copy System.Grow Edit.Search Edit.Store";
-    LogMenu = "Edit.Locate Edit.Search System.Copy System.Grow System.Clear";
-
-  VAR W: Texts.Writer;
-    pat: ARRAY 32 OF CHAR;
-
-  PROCEDURE GetArg(VAR S: Texts.Scanner);
-    VAR T: Texts.Text; beg, end, time: LONGINT;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF (S.class = Texts.Char) & (S.c = "^") THEN
-      Oberon.GetSelection(T, beg, end, time);
-      IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
-    END
-  END GetArg;
-
-  PROCEDURE EndLine;
-  BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-  END EndLine;
-
-  (* ------------- Toolbox for system control ---------------*)
-
-  PROCEDURE SetUser*;
-    VAR i: INTEGER; ch: CHAR;
-      user: ARRAY 8 OF CHAR;
-      password: ARRAY 16 OF CHAR;
-  BEGIN i := 0; Input.Read(ch);
-    WHILE (ch # "/") & (i < 7) DO user[i] := ch; INC(i); Input.Read(ch) END;
-    user[i] := 0X; i := 0; Input.Read(ch);
-    WHILE (ch > " ") & (i < 15) DO password[i] := ch; INC(i); Input.Read(ch) END;
-    password[i] := 0X; Oberon.SetUser(user, password)
-  END SetUser;
-
-  PROCEDURE SetFont*;
-    VAR S: Texts.Scanner;
-  BEGIN GetArg(S);
-    IF S.class = Texts.Name THEN Oberon.SetFont(Fonts.This(S.s)) END
-  END SetFont;
-
-  PROCEDURE SetColor*;
-    VAR S: Texts.Scanner;
-  BEGIN GetArg(S);
-    IF S.class = Texts.Int THEN Oberon.SetColor(S.i) END
-  END SetColor;
-
-  PROCEDURE SetOffset*;
-    VAR S: Texts.Scanner;
-  BEGIN GetArg(S);
-    IF S.class = Texts.Int THEN Oberon.SetOffset(S.i) END
-  END SetOffset;
-  
-  PROCEDURE Date*;
-    VAR S: Texts.Scanner;
-      dt, hr, min, sec, yr, mo, day: LONGINT;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Int THEN (*set clock*)
-      day := S.i; Texts.Scan(S); mo := S.i; Texts.Scan(S); yr := S.i; Texts.Scan(S);
-      hr := S.i; Texts.Scan(S); min := S.i; Texts.Scan(S); sec := S.i;
-      dt := ((((yr*16 + mo)*32 + day)*32 + hr)*64 + min)*64 + sec;
-      Kernel.SetClock(dt)
-    ELSE (*read clock*) Texts.WriteString(W, "System.Clock");
-      dt := Oberon.Clock(); Texts.WriteClock(W, dt); EndLine
-    END
-  END Date;
-
-  PROCEDURE Collect*;
-  BEGIN Oberon.Collect(0)
-  END Collect;
-
-  (* ------------- Toolbox for standard display ---------------*)
-
-  PROCEDURE Open*;  (*open viewer in system track*)
-    VAR X, Y: INTEGER;
-      V: Viewers.Viewer;
-      S: Texts.Scanner;
-  BEGIN GetArg(S);
-    IF S.class = Texts.Name THEN
-      Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y);
-      V := MenuViewers.New(
-        TextFrames.NewMenu(S.s, StandardMenu),
-        TextFrames.NewText(TextFrames.Text(S.s), 0), TextFrames.menuH, X, Y)
-    END
-  END Open;
-
-  PROCEDURE Clear*;  (*clear Log*)
-    VAR T: Texts.Text; F: Display.Frame; buf: Texts.Buffer;
-  BEGIN F := Oberon.Par.frame;
-    IF (F # NIL) & (F.next IS TextFrames.Frame) & (F = Oberon.Par.vwr.dsc) THEN
-      NEW(buf); Texts.OpenBuf(buf); T := F.next(TextFrames.Frame).text; Texts.Delete(T, 0, T.len, buf)
-    END
-  END Clear;
-
-  PROCEDURE Close*;
-    VAR V: Viewers.Viewer;
-  BEGIN
-    IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN V := Oberon.Par.vwr
-    ELSE V := Oberon.MarkedViewer()
-    END;
-    Viewers.Close(V)
-  END Close;
-
-  PROCEDURE CloseTrack*;
-    VAR V: Viewers.Viewer;
-  BEGIN V := Oberon.MarkedViewer(); Viewers.CloseTrack(V.X)
-  END CloseTrack;
-
-  PROCEDURE Recall*;
-    VAR V: Viewers.Viewer; M: Viewers.ViewerMsg;
-  BEGIN Viewers.Recall(V);
-    IF (V#NIL) & (V.state = 0) THEN
-      Viewers.Open(V, V.X, V.Y + V.H); M.id := Viewers.restore; V.handle(V, M)
-    END
-  END Recall;
-
-  PROCEDURE Copy*;
-    VAR V, V1: Viewers.Viewer; M: Oberon.CopyMsg; N: Viewers.ViewerMsg;
-  BEGIN V := Oberon.Par.vwr; V.handle(V, M); V1 := M.F(Viewers.Viewer);
-    Viewers.Open(V1, V.X, V.Y + V.H DIV 2);
-    N.id := Viewers.restore; V1.handle(V1, N)
-  END Copy;
-
-  PROCEDURE Grow*;
-    VAR V, V1: Viewers.Viewer; M: Oberon.CopyMsg; N: Viewers.ViewerMsg;
-      DW, DH: INTEGER;
-  BEGIN V := Oberon.Par.vwr;
-    DW := Oberon.DisplayWidth(V.X); DH := Oberon.DisplayHeight(V.X);
-    IF V.H < DH - Viewers.minH THEN Oberon.OpenTrack(V.X, V.W)
-    ELSIF V.W < DW THEN Oberon.OpenTrack(Oberon.UserTrack(V.X), DW)
-    END;
-    IF (V.H < DH - Viewers.minH) OR (V.W < DW) THEN
-      V.handle(V, M); V1 := M.F(Viewers.Viewer);
-      Viewers.Open(V1, V.X, DH);;
-      N.id := Viewers.restore; V1.handle(V1, N)
-    END
-  END Grow;
-
-  (* ------------- Toolbox for module management ---------------*)
-
-  PROCEDURE Free1(VAR S: Texts.Scanner);
-  BEGIN Texts.WriteString(W, S.s); Texts.WriteString(W, " unloading");
-    Modules.Free(S.s);
-    IF Modules.res # 0 THEN Texts.WriteString(W, " failed") END;
-    EndLine
-  END Free1;
-
-  PROCEDURE Free*;
-    VAR T: Texts.Text;
-      beg, end, time: LONGINT;
-      S: Texts.Scanner;
-  BEGIN Texts.WriteString(W, "System.Free"); EndLine;
-    Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF (S.class = Texts.Char) & (S.c = "^") THEN
-      Oberon.GetSelection(T, beg, end, time);
-      IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S);
-        IF S.class = Texts.Name THEN Free1(S) END
-      END
-    ELSE
-      WHILE S.class = Texts.Name DO Free1(S); Texts.Scan(S) END
-    END ;
-    Oberon.Collect(0)
-  END Free;
-
-  PROCEDURE FreeFonts*;
-  BEGIN Texts.WriteString(W, "System.FreeFonts"); Fonts.Free; EndLine
-  END FreeFonts;
-
-  (* ------------- Toolbox of file system ---------------*)
-
-  PROCEDURE List(name: FileDir.FileName; adr: LONGINT; VAR cont: BOOLEAN);
-    VAR i0, i, j0, j: INTEGER; hp: FileDir.FileHeader;
-  BEGIN
-    i := 0;
-    WHILE (pat[i] > "*") & (pat[i] = name[i]) DO INC(i) END ;
-    IF (pat[i] = 0X) & (name[i] = 0X) THEN i0 := i; j0 := i
-    ELSIF pat[i] = "*" THEN
-      i0 := i; j0 := i+1;
-      WHILE name[i0] # 0X DO
-        i := i0; j := j0;
-        WHILE (name[i] # 0X) & (name[i] = pat[j]) DO INC(i); INC(j) END ;
-        IF pat[j] = 0X THEN
-          IF name[i] = 0X THEN (*match*) j0 := j ELSE INC(i0) END
-        ELSIF pat[j] = "*" THEN i0 := i; j0 := j+1
-        ELSE INC(i0)
-        END
-      END
-    END ;
-    IF (name[i0] = 0X) & (pat[j0] = 0X) THEN (*found*)
-      Texts.WriteString(W, name);
-      IF pat[j0+1] = "!" THEN (*option*)
-        Kernel.GetSector(adr, hp);
-        Texts.Write(W, 9X); Texts.WriteClock(W, hp.date);
-        Texts.WriteInt(W, hp.aleng*FileDir.SectorSize + hp.bleng - FileDir.HeaderSize, 8); (*length*)
-        (*Texts.WriteHex(W, adr)*)
-      END ;
-      Texts.WriteLn(W)
-    END
-  END List;
-
-  PROCEDURE Directory*;
-    VAR X, Y, i: INTEGER; ch: CHAR;
-      R: Texts.Reader;
-      T, t: Texts.Text;
-      V: Viewers.Viewer;
-      beg, end, time: LONGINT;
-      pre: ARRAY 32 OF CHAR;
-  BEGIN Texts.OpenReader(R, Oberon.Par.text, Oberon.Par.pos); Texts.Read(R, ch);
-    WHILE ch = " " DO Texts.Read(R, ch) END;
-    IF (ch = "^") OR (ch = 0DX) THEN
-      Oberon.GetSelection(T, beg, end, time);
-      IF time >= 0 THEN
-        Texts.OpenReader(R, T, beg); Texts.Read(R, ch);
-        WHILE ch <= " " DO Texts.Read(R, ch) END
-      END
-    END ;
-    i := 0;
-    WHILE ch > "!" DO pat[i] := ch; INC(i); Texts.Read(R, ch) END;
-    pat[i] := 0X;
-    IF ch = "!" THEN pat[i+1] := "!" END ;  (*directory option*)
-    i := 0;
-    WHILE pat[i] > "*" DO pre[i] := pat[i]; INC(i) END;
-    pre[i] := 0X;
-    Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y); t := TextFrames.Text("");
-    V := MenuViewers.New(
-      TextFrames.NewMenu("System.Directory", StandardMenu),
-      TextFrames.NewText(t, 0), TextFrames.menuH, X, Y);
-    FileDir.Enumerate(pre, List); Texts.Append(t, W.buf)
-  END Directory;
-
-  PROCEDURE CopyFiles*;
-    VAR f, g: Files.File; Rf, Rg: Files.Rider; ch: CHAR;
-      name: ARRAY 32 OF CHAR;
-      S: Texts.Scanner;
-  BEGIN GetArg(S);
-    Texts.WriteString(W, "System.CopyFiles"); EndLine;
-    WHILE S.class = Texts.Name DO
-      name := S.s; Texts.Scan(S);
-      IF (S.class = Texts.Char) & (S.c = "=") THEN Texts.Scan(S);
-        IF (S.class = Texts.Char) & (S.c = ">") THEN Texts.Scan(S);
-          IF S.class = Texts.Name THEN
-            Texts.WriteString(W, name); Texts.WriteString(W, " => "); Texts.WriteString(W, S.s);
-            Texts.WriteString(W, " copying"); Texts.Append(Oberon.Log, W.buf);
-            f := Files.Old(name);
-            IF f # NIL THEN g := Files.New(S.s);
-              Files.Set(Rf, f, 0); Files.Set(Rg, g, 0); Files.Read(Rf, ch);
-              WHILE ~Rf.eof DO Files.Write(Rg, ch); Files.Read(Rf, ch) END;
-              Files.Register(g)
-            ELSE Texts.WriteString(W, " failed")
-            END ;
-            EndLine
-          END
-        END
-      END ;
-      Texts.Scan(S)
-    END
-  END CopyFiles;
-
-  PROCEDURE RenameFiles*;
-    VAR res: INTEGER;
-      name: ARRAY 32 OF CHAR;
-      S: Texts.Scanner;
-  BEGIN GetArg(S);
-    Texts.WriteString(W, "System.RenameFiles"); EndLine;
-    WHILE S.class = Texts.Name DO
-      name := S.s; Texts.Scan(S);
-      IF (S.class = Texts.Char) & (S.c = "=") THEN Texts.Scan(S);
-        IF (S.class = Texts.Char) & (S.c = ">") THEN Texts.Scan(S);
-          IF S.class = Texts.Name THEN
-            Texts.WriteString(W, name); Texts.WriteString(W, " => "); Texts.WriteString(W, S.s);
-            Texts.WriteString(W, " renaming"); Files.Rename(name, S.s, res);
-            IF res > 1 THEN Texts.WriteString(W, " failed") END;
-            EndLine
-          END
-        END
-      END ;
-      Texts.Scan(S)
-    END
-  END RenameFiles;
-
-  PROCEDURE DeleteFiles*;
-    VAR res: INTEGER; S: Texts.Scanner;
-  BEGIN GetArg(S);
-    Texts.WriteString(W, "System.DeleteFiles"); EndLine;
-    WHILE S.class = Texts.Name DO
-      Texts.WriteString(W, S.s); Texts.WriteString(W, " deleting");
-      Files.Delete(S.s, res);
-      IF res # 0 THEN Texts.WriteString(W, " failed") END;
-      EndLine; Texts.Scan(S)
-    END
-  END DeleteFiles;
-
-  (* ------------- Toolbox for system inspection ---------------*)
-
-  PROCEDURE Watch*;
-  BEGIN Texts.WriteString(W, "System.Watch"); Texts.WriteLn(W);
-    Texts.WriteString(W, "  Modules space (bytes)"); Texts.WriteInt(W, Modules.AllocPtr, 8);
-    Texts.WriteInt(W, Modules.AllocPtr * 100 DIV Kernel.heapOrg, 4); Texts.Write(W, "%"); EndLine;
-    Texts.WriteString(W, "  Heap speace"); Texts.WriteInt(W, Kernel.allocated, 8);
-    Texts.WriteInt(W, Kernel.allocated * 100 DIV (Kernel.heapLim - Kernel.heapOrg), 4); Texts.Write(W, "%"); EndLine;
-    Texts.WriteString(W, "  Disk sectors "); Texts.WriteInt(W, Kernel.NofSectors, 4);
-    Texts.WriteInt(W, Kernel.NofSectors * 100 DIV 10000H, 4); Texts.Write(W, "%"); EndLine;
-    Texts.WriteString(W, "  Tasks"); Texts.WriteInt(W, Oberon.NofTasks, 4); EndLine
-  END Watch;
-
-  PROCEDURE ShowModules*;
-    VAR T: Texts.Text;
-      V: Viewers.Viewer;
-      M: Modules.Module;
-      X, Y: INTEGER;
-  BEGIN T := TextFrames.Text("");
-    Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y);
-    V := MenuViewers.New(TextFrames.NewMenu("System.ShowModules", StandardMenu),
-        TextFrames.NewText(T, 0), TextFrames.menuH, X, Y);
-    M := Modules.root;
-    WHILE M # NIL DO
-      IF M.name[0] # 0X THEN
-        Texts.WriteString(W, M.name); Texts.Write(W, 9X); Texts.WriteHex(W, ORD(M));
-        Texts.WriteHex(W, M.code); Texts.WriteInt(W, M.refcnt, 4)
-      ELSE Texts.WriteString(W, "---")
-      END ;
-      Texts.WriteLn(W); M := M.next
-    END;
-    Texts.Append(T, W.buf)
-  END ShowModules;
-
-  PROCEDURE ShowCommands*;
-    VAR M: Modules.Module;
-      comadr: LONGINT; ch: CHAR;
-      T: Texts.Text;
-      S: Texts.Scanner;
-      V: Viewers.Viewer;
-      X, Y: INTEGER;
-  BEGIN GetArg(S);
-    IF S.class = Texts.Name THEN
-      Modules.Load(S.s, M);
-      IF M # NIL THEN
-        Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y); T := TextFrames.Text("");
-        V := MenuViewers.New(TextFrames.NewMenu("System.Commands", StandardMenu),
-            TextFrames.NewText(T, 0), TextFrames.menuH, X, Y);
-        comadr := M.cmd; SYSTEM.GET(comadr, ch); INC(comadr);
-        WHILE ch # 0X DO
-          Texts.WriteString(W, S.s); Texts.Write(W, ".");
-          REPEAT Texts.Write(W, ch); SYSTEM.GET(comadr, ch); INC(comadr)
-          UNTIL ch = 0X;
-          WHILE comadr MOD 4 # 0 DO INC(comadr) END ;
-          Texts.WriteLn(W); INC(comadr, 4); SYSTEM.GET(comadr, ch); INC(comadr)
-        END ;
-        Texts.Append(T, W.buf)
-      END
-    END
-  END ShowCommands;
-
-  PROCEDURE ShowFonts*;
-    VAR fnt: Fonts.Font;
-  BEGIN Texts.WriteString(W, "System.ShowFonts"); Texts.WriteLn(W); fnt := Fonts.root;
-    WHILE fnt # NIL DO
-      Texts.Write(W, 9X); Texts.WriteString(W, fnt.name); Texts.WriteLn(W); fnt := fnt.next
-    END ;
-    Texts.Append(Oberon.Log, W.buf)
-  END ShowFonts;
-
-  PROCEDURE OpenViewers;
-    VAR logV, toolV: Viewers.Viewer;
-      menu, main: Display.Frame;
-      d: LONGINT; X, Y: INTEGER;
-  BEGIN d := Kernel.Clock(); Texts.WriteString(W, "Oberon V5  NW 14.4.2013"); EndLine;
-    Oberon.AllocateSystemViewer(0, X, Y);
-    menu := TextFrames.NewMenu("System.Log", LogMenu);
-    main := TextFrames.NewText(Oberon.Log, 0);
-    logV := MenuViewers.New(menu, main, TextFrames.menuH, X, Y);
-    Oberon.AllocateSystemViewer(0, X, Y);
-    menu := TextFrames.NewMenu("System.Tool", StandardMenu);
-    main := TextFrames.NewText(TextFrames.Text("System.Tool"), 0);
-    toolV := MenuViewers.New(menu, main, TextFrames.menuH, X, Y)
-  END OpenViewers;
-
-  PROCEDURE ExtendDisplay*;
-    VAR V: Viewers.Viewer;
-      X, Y, DX, DW, DH: INTEGER;
-      S: Texts.Scanner;
-  BEGIN GetArg(S);
-    IF S.class = Texts.Name THEN
-      DX := Viewers.curW; DW := Oberon.DisplayWidth(DX); DH := Oberon.DisplayHeight(DX);
-      Oberon.OpenDisplay(DW DIV 8 * 5, DW DIV 8 * 3, DH);
-      Oberon.AllocateSystemViewer(DX, X, Y);
-      V := MenuViewers.New(
-        TextFrames.NewMenu(S.s, StandardMenu),
-        TextFrames.NewText(TextFrames.Text(S.s), 0),
-        TextFrames.menuH, X, Y)
-    END
-  END ExtendDisplay;
-
-  PROCEDURE Trap(VAR a: INTEGER; b: INTEGER);
-    VAR u, v, w: INTEGER; mod: Modules.Module;
-  BEGIN u := SYSTEM.REG(15); SYSTEM.GET(u - 4, v); w := v DIV 10H MOD 10H; (*trap number*)
-    IF w = 0 THEN Kernel.New(a, b)
-    ELSE (*trap*) Texts.WriteLn(W); Texts.WriteString(W, "  pos "); Texts.WriteInt(W, v DIV 100H MOD 10000H, 4);
-      Texts.WriteString(W, "  TRAP"); Texts.WriteInt(W, w, 4); mod := Modules.root;
-      WHILE (mod # NIL) & ((u < mod.code) OR (u >= mod.imp)) DO mod := mod.next END ;
-      IF mod # NIL THEN Texts.WriteString(W, " in "); Texts.WriteString(W, mod.name) END ;
-      Texts.WriteString(W, " at"); Texts.WriteHex(W, u);
-      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Oberon.Reset
-    END
-  END Trap;
-
-  PROCEDURE Abort;
-    VAR n: INTEGER;
-  BEGIN n := SYSTEM.REG(15); Texts.WriteString(W, "  ABORT  "); Texts.WriteHex(W, n);
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Oberon.Reset
-  END Abort;
-  
-BEGIN Texts.OpenWriter(W);
-  Oberon.OpenLog(TextFrames.Text("")); OpenViewers;
-  Kernel.Install(SYSTEM.ADR(Trap), 20H); Kernel.Install(SYSTEM.ADR(Abort), 0);
-END System.
+MODULE System; (*JG 3.10.90 / NW 12.10.93 / NW 20.6.2016*)
+  IMPORT SYSTEM, Kernel, FileDir, Files, Modules,
+    Input, Display, Viewers, Fonts, Texts, Oberon, MenuViewers, TextFrames;
+
+  CONST
+    StandardMenu = "System.Close System.Copy System.Grow Edit.Search Edit.Store";
+    LogMenu = "Edit.Locate Edit.Search System.Copy System.Grow System.Clear";
+
+  VAR W: Texts.Writer;
+    pat: ARRAY 32 OF CHAR;
+
+  PROCEDURE GetArg(VAR S: Texts.Scanner);
+    VAR T: Texts.Text; beg, end, time: LONGINT;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF (S.class = Texts.Char) & (S.c = "^") THEN
+      Oberon.GetSelection(T, beg, end, time);
+      IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
+    END
+  END GetArg;
+
+  PROCEDURE EndLine;
+  BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+  END EndLine;
+
+  (* ------------- Toolbox for system control ---------------*)
+
+  PROCEDURE SetUser*;
+    VAR i: INTEGER; ch: CHAR;
+      user: ARRAY 8 OF CHAR;
+      password: ARRAY 16 OF CHAR;
+  BEGIN i := 0; Input.Read(ch);
+    WHILE (ch # "/") & (i < 7) DO user[i] := ch; INC(i); Input.Read(ch) END;
+    user[i] := 0X; i := 0; Input.Read(ch);
+    WHILE (ch > " ") & (i < 15) DO password[i] := ch; INC(i); Input.Read(ch) END;
+    password[i] := 0X; Oberon.SetUser(user, password)
+  END SetUser;
+
+  PROCEDURE SetFont*;
+    VAR S: Texts.Scanner;
+  BEGIN GetArg(S);
+    IF S.class = Texts.Name THEN Oberon.SetFont(Fonts.This(S.s)) END
+  END SetFont;
+
+  PROCEDURE SetColor*;
+    VAR S: Texts.Scanner;
+  BEGIN GetArg(S);
+    IF S.class = Texts.Int THEN Oberon.SetColor(S.i) END
+  END SetColor;
+
+  PROCEDURE SetOffset*;
+    VAR S: Texts.Scanner;
+  BEGIN GetArg(S);
+    IF S.class = Texts.Int THEN Oberon.SetOffset(S.i) END
+  END SetOffset;
+  
+  PROCEDURE Date*;
+    VAR S: Texts.Scanner;
+      dt, hr, min, sec, yr, mo, day: LONGINT;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Int THEN (*set clock*)
+      day := S.i; Texts.Scan(S); mo := S.i; Texts.Scan(S); yr := S.i; Texts.Scan(S);
+      hr := S.i; Texts.Scan(S); min := S.i; Texts.Scan(S); sec := S.i;
+      dt := ((((yr*16 + mo)*32 + day)*32 + hr)*64 + min)*64 + sec;
+      Kernel.SetClock(dt)
+    ELSE (*read clock*) Texts.WriteString(W, "System.Clock");
+      dt := Oberon.Clock(); Texts.WriteClock(W, dt); EndLine
+    END
+  END Date;
+
+  PROCEDURE Collect*;
+  BEGIN Oberon.Collect(0)
+  END Collect;
+
+  (* ------------- Toolbox for standard display ---------------*)
+
+  PROCEDURE Open*;  (*open viewer in system track*)
+    VAR X, Y: INTEGER;
+      V: Viewers.Viewer;
+      S: Texts.Scanner;
+  BEGIN GetArg(S);
+    IF S.class = Texts.Name THEN
+      Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y);
+      V := MenuViewers.New(
+        TextFrames.NewMenu(S.s, StandardMenu),
+        TextFrames.NewText(TextFrames.Text(S.s), 0), TextFrames.menuH, X, Y)
+    END
+  END Open;
+
+  PROCEDURE Clear*;  (*clear Log*)
+    VAR T: Texts.Text; F: Display.Frame; buf: Texts.Buffer;
+  BEGIN F := Oberon.Par.frame;
+    IF (F # NIL) & (F.next IS TextFrames.Frame) & (F = Oberon.Par.vwr.dsc) THEN
+      NEW(buf); Texts.OpenBuf(buf); T := F.next(TextFrames.Frame).text; Texts.Delete(T, 0, T.len, buf)
+    END
+  END Clear;
+
+  PROCEDURE Close*;
+    VAR V: Viewers.Viewer;
+  BEGIN
+    IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN V := Oberon.Par.vwr
+    ELSE V := Oberon.MarkedViewer()
+    END;
+    Viewers.Close(V)
+  END Close;
+
+  PROCEDURE CloseTrack*;
+    VAR V: Viewers.Viewer;
+  BEGIN V := Oberon.MarkedViewer(); Viewers.CloseTrack(V.X)
+  END CloseTrack;
+
+  PROCEDURE Recall*;
+    VAR V: Viewers.Viewer; M: Viewers.ViewerMsg;
+  BEGIN Viewers.Recall(V);
+    IF (V#NIL) & (V.state = 0) THEN
+      Viewers.Open(V, V.X, V.Y + V.H); M.id := Viewers.restore; V.handle(V, M)
+    END
+  END Recall;
+
+  PROCEDURE Copy*;
+    VAR V, V1: Viewers.Viewer; M: Oberon.CopyMsg; N: Viewers.ViewerMsg;
+  BEGIN V := Oberon.Par.vwr; V.handle(V, M); V1 := M.F(Viewers.Viewer);
+    Viewers.Open(V1, V.X, V.Y + V.H DIV 2);
+    N.id := Viewers.restore; V1.handle(V1, N)
+  END Copy;
+
+  PROCEDURE Grow*;
+    VAR V, V1: Viewers.Viewer; M: Oberon.CopyMsg; N: Viewers.ViewerMsg;
+      DW, DH: INTEGER;
+  BEGIN V := Oberon.Par.vwr;
+    DW := Oberon.DisplayWidth(V.X); DH := Oberon.DisplayHeight(V.X);
+    IF V.H < DH - Viewers.minH THEN Oberon.OpenTrack(V.X, V.W)
+    ELSIF V.W < DW THEN Oberon.OpenTrack(Oberon.UserTrack(V.X), DW)
+    END;
+    IF (V.H < DH - Viewers.minH) OR (V.W < DW) THEN
+      V.handle(V, M); V1 := M.F(Viewers.Viewer);
+      Viewers.Open(V1, V.X, DH);;
+      N.id := Viewers.restore; V1.handle(V1, N)
+    END
+  END Grow;
+
+  (* ------------- Toolbox for module management ---------------*)
+
+  PROCEDURE Free1(VAR S: Texts.Scanner);
+  BEGIN Texts.WriteString(W, S.s); Texts.WriteString(W, " unloading");
+    Modules.Free(S.s);
+    IF Modules.res # 0 THEN Texts.WriteString(W, " failed") END;
+    EndLine
+  END Free1;
+
+  PROCEDURE Free*;
+    VAR T: Texts.Text;
+      beg, end, time: LONGINT;
+      S: Texts.Scanner;
+  BEGIN Texts.WriteString(W, "System.Free"); EndLine;
+    Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF (S.class = Texts.Char) & (S.c = "^") THEN
+      Oberon.GetSelection(T, beg, end, time);
+      IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S);
+        IF S.class = Texts.Name THEN Free1(S) END
+      END
+    ELSE
+      WHILE S.class = Texts.Name DO Free1(S); Texts.Scan(S) END
+    END ;
+    Oberon.Collect(0)
+  END Free;
+
+  PROCEDURE FreeFonts*;
+  BEGIN Texts.WriteString(W, "System.FreeFonts"); Fonts.Free; EndLine
+  END FreeFonts;
+
+  (* ------------- Toolbox of file system ---------------*)
+
+  PROCEDURE List(name: FileDir.FileName; adr: LONGINT; VAR cont: BOOLEAN);
+    VAR i0, i, j0, j: INTEGER; hp: FileDir.FileHeader;
+  BEGIN
+    i := 0;
+    WHILE (pat[i] > "*") & (pat[i] = name[i]) DO INC(i) END ;
+    IF (pat[i] = 0X) & (name[i] = 0X) THEN i0 := i; j0 := i
+    ELSIF pat[i] = "*" THEN
+      i0 := i; j0 := i+1;
+      WHILE name[i0] # 0X DO
+        i := i0; j := j0;
+        WHILE (name[i] # 0X) & (name[i] = pat[j]) DO INC(i); INC(j) END ;
+        IF pat[j] = 0X THEN
+          IF name[i] = 0X THEN (*match*) j0 := j ELSE INC(i0) END
+        ELSIF pat[j] = "*" THEN i0 := i; j0 := j+1
+        ELSE INC(i0)
+        END
+      END
+    END ;
+    IF (name[i0] = 0X) & (pat[j0] = 0X) THEN (*found*)
+      Texts.WriteString(W, name);
+      IF pat[j0+1] = "!" THEN (*option*)
+        Kernel.GetSector(adr, hp);
+        Texts.Write(W, 9X); Texts.WriteClock(W, hp.date);
+        Texts.WriteInt(W, hp.aleng*FileDir.SectorSize + hp.bleng - FileDir.HeaderSize, 8); (*length*)
+        (*Texts.WriteHex(W, adr)*)
+      END ;
+      Texts.WriteLn(W)
+    END
+  END List;
+
+  PROCEDURE Directory*;
+    VAR X, Y, i: INTEGER; ch: CHAR;
+      R: Texts.Reader;
+      T, t: Texts.Text;
+      V: Viewers.Viewer;
+      beg, end, time: LONGINT;
+      pre: ARRAY 32 OF CHAR;
+  BEGIN Texts.OpenReader(R, Oberon.Par.text, Oberon.Par.pos); Texts.Read(R, ch);
+    WHILE ch = " " DO Texts.Read(R, ch) END;
+    IF (ch = "^") OR (ch = 0DX) THEN
+      Oberon.GetSelection(T, beg, end, time);
+      IF time >= 0 THEN
+        Texts.OpenReader(R, T, beg); Texts.Read(R, ch);
+        WHILE ch <= " " DO Texts.Read(R, ch) END
+      END
+    END ;
+    i := 0;
+    WHILE ch > "!" DO pat[i] := ch; INC(i); Texts.Read(R, ch) END;
+    pat[i] := 0X;
+    IF ch = "!" THEN pat[i+1] := "!" END ;  (*directory option*)
+    i := 0;
+    WHILE pat[i] > "*" DO pre[i] := pat[i]; INC(i) END;
+    pre[i] := 0X;
+    Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y); t := TextFrames.Text("");
+    V := MenuViewers.New(
+      TextFrames.NewMenu("System.Directory", StandardMenu),
+      TextFrames.NewText(t, 0), TextFrames.menuH, X, Y);
+    FileDir.Enumerate(pre, List); Texts.Append(t, W.buf)
+  END Directory;
+
+  PROCEDURE CopyFiles*;
+    VAR f, g: Files.File; Rf, Rg: Files.Rider; ch: CHAR;
+      name: ARRAY 32 OF CHAR;
+      S: Texts.Scanner;
+  BEGIN GetArg(S);
+    Texts.WriteString(W, "System.CopyFiles"); EndLine;
+    WHILE S.class = Texts.Name DO
+      name := S.s; Texts.Scan(S);
+      IF (S.class = Texts.Char) & (S.c = "=") THEN Texts.Scan(S);
+        IF (S.class = Texts.Char) & (S.c = ">") THEN Texts.Scan(S);
+          IF S.class = Texts.Name THEN
+            Texts.WriteString(W, name); Texts.WriteString(W, " => "); Texts.WriteString(W, S.s);
+            Texts.WriteString(W, " copying"); Texts.Append(Oberon.Log, W.buf);
+            f := Files.Old(name);
+            IF f # NIL THEN g := Files.New(S.s);
+              Files.Set(Rf, f, 0); Files.Set(Rg, g, 0); Files.Read(Rf, ch);
+              WHILE ~Rf.eof DO Files.Write(Rg, ch); Files.Read(Rf, ch) END;
+              Files.Register(g)
+            ELSE Texts.WriteString(W, " failed")
+            END ;
+            EndLine
+          END
+        END
+      END ;
+      Texts.Scan(S)
+    END
+  END CopyFiles;
+
+  PROCEDURE RenameFiles*;
+    VAR res: INTEGER;
+      name: ARRAY 32 OF CHAR;
+      S: Texts.Scanner;
+  BEGIN GetArg(S);
+    Texts.WriteString(W, "System.RenameFiles"); EndLine;
+    WHILE S.class = Texts.Name DO
+      name := S.s; Texts.Scan(S);
+      IF (S.class = Texts.Char) & (S.c = "=") THEN Texts.Scan(S);
+        IF (S.class = Texts.Char) & (S.c = ">") THEN Texts.Scan(S);
+          IF S.class = Texts.Name THEN
+            Texts.WriteString(W, name); Texts.WriteString(W, " => "); Texts.WriteString(W, S.s);
+            Texts.WriteString(W, " renaming"); Files.Rename(name, S.s, res);
+            IF res > 1 THEN Texts.WriteString(W, " failed") END;
+            EndLine
+          END
+        END
+      END ;
+      Texts.Scan(S)
+    END
+  END RenameFiles;
+
+  PROCEDURE DeleteFiles*;
+    VAR res: INTEGER; S: Texts.Scanner;
+  BEGIN GetArg(S);
+    Texts.WriteString(W, "System.DeleteFiles"); EndLine;
+    WHILE S.class = Texts.Name DO
+      Texts.WriteString(W, S.s); Texts.WriteString(W, " deleting");
+      Files.Delete(S.s, res);
+      IF res # 0 THEN Texts.WriteString(W, " failed") END;
+      EndLine; Texts.Scan(S)
+    END
+  END DeleteFiles;
+
+  (* ------------- Toolbox for system inspection ---------------*)
+
+  PROCEDURE Watch*;
+  BEGIN Texts.WriteString(W, "System.Watch"); Texts.WriteLn(W);
+    Texts.WriteString(W, "  Modules space (bytes)"); Texts.WriteInt(W, Modules.AllocPtr, 8);
+    Texts.WriteInt(W, Modules.AllocPtr * 100 DIV Kernel.heapOrg, 4); Texts.Write(W, "%"); EndLine;
+    Texts.WriteString(W, "  Heap speace"); Texts.WriteInt(W, Kernel.allocated, 8);
+    Texts.WriteInt(W, Kernel.allocated * 100 DIV (Kernel.heapLim - Kernel.heapOrg), 4); Texts.Write(W, "%"); EndLine;
+    Texts.WriteString(W, "  Disk sectors "); Texts.WriteInt(W, Kernel.NofSectors, 4);
+    Texts.WriteInt(W, Kernel.NofSectors * 100 DIV 10000H, 4); Texts.Write(W, "%"); EndLine;
+    Texts.WriteString(W, "  Tasks"); Texts.WriteInt(W, Oberon.NofTasks, 4); EndLine
+  END Watch;
+
+  PROCEDURE ShowModules*;
+    VAR T: Texts.Text;
+      V: Viewers.Viewer;
+      M: Modules.Module;
+      X, Y: INTEGER;
+  BEGIN T := TextFrames.Text("");
+    Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y);
+    V := MenuViewers.New(TextFrames.NewMenu("System.ShowModules", StandardMenu),
+        TextFrames.NewText(T, 0), TextFrames.menuH, X, Y);
+    M := Modules.root;
+    WHILE M # NIL DO
+      IF M.name[0] # 0X THEN
+        Texts.WriteString(W, M.name); Texts.Write(W, 9X); Texts.WriteHex(W, ORD(M));
+        Texts.WriteHex(W, M.code); Texts.WriteInt(W, M.refcnt, 4)
+      ELSE Texts.WriteString(W, "---")
+      END ;
+      Texts.WriteLn(W); M := M.next
+    END;
+    Texts.Append(T, W.buf)
+  END ShowModules;
+
+  PROCEDURE ShowCommands*;
+    VAR M: Modules.Module;
+      comadr: LONGINT; ch: CHAR;
+      T: Texts.Text;
+      S: Texts.Scanner;
+      V: Viewers.Viewer;
+      X, Y: INTEGER;
+  BEGIN GetArg(S);
+    IF S.class = Texts.Name THEN
+      Modules.Load(S.s, M);
+      IF M # NIL THEN
+        Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y); T := TextFrames.Text("");
+        V := MenuViewers.New(TextFrames.NewMenu("System.Commands", StandardMenu),
+            TextFrames.NewText(T, 0), TextFrames.menuH, X, Y);
+        comadr := M.cmd; SYSTEM.GET(comadr, ch); INC(comadr);
+        WHILE ch # 0X DO
+          Texts.WriteString(W, S.s); Texts.Write(W, ".");
+          REPEAT Texts.Write(W, ch); SYSTEM.GET(comadr, ch); INC(comadr)
+          UNTIL ch = 0X;
+          WHILE comadr MOD 4 # 0 DO INC(comadr) END ;
+          Texts.WriteLn(W); INC(comadr, 4); SYSTEM.GET(comadr, ch); INC(comadr)
+        END ;
+        Texts.Append(T, W.buf)
+      END
+    END
+  END ShowCommands;
+
+  PROCEDURE ShowFonts*;
+    VAR fnt: Fonts.Font;
+  BEGIN Texts.WriteString(W, "System.ShowFonts"); Texts.WriteLn(W); fnt := Fonts.root;
+    WHILE fnt # NIL DO
+      Texts.Write(W, 9X); Texts.WriteString(W, fnt.name); Texts.WriteLn(W); fnt := fnt.next
+    END ;
+    Texts.Append(Oberon.Log, W.buf)
+  END ShowFonts;
+
+  PROCEDURE OpenViewers;
+    VAR logV, toolV: Viewers.Viewer;
+      menu, main: Display.Frame;
+      d: LONGINT; X, Y: INTEGER;
+  BEGIN d := Kernel.Clock(); Texts.WriteString(W, "Oberon V5  NW 14.4.2013"); EndLine;
+    Oberon.AllocateSystemViewer(0, X, Y);
+    menu := TextFrames.NewMenu("System.Log", LogMenu);
+    main := TextFrames.NewText(Oberon.Log, 0);
+    logV := MenuViewers.New(menu, main, TextFrames.menuH, X, Y);
+    Oberon.AllocateSystemViewer(0, X, Y);
+    menu := TextFrames.NewMenu("System.Tool", StandardMenu);
+    main := TextFrames.NewText(TextFrames.Text("System.Tool"), 0);
+    toolV := MenuViewers.New(menu, main, TextFrames.menuH, X, Y)
+  END OpenViewers;
+
+  PROCEDURE ExtendDisplay*;
+    VAR V: Viewers.Viewer;
+      X, Y, DX, DW, DH: INTEGER;
+      S: Texts.Scanner;
+  BEGIN GetArg(S);
+    IF S.class = Texts.Name THEN
+      DX := Viewers.curW; DW := Oberon.DisplayWidth(DX); DH := Oberon.DisplayHeight(DX);
+      Oberon.OpenDisplay(DW DIV 8 * 5, DW DIV 8 * 3, DH);
+      Oberon.AllocateSystemViewer(DX, X, Y);
+      V := MenuViewers.New(
+        TextFrames.NewMenu(S.s, StandardMenu),
+        TextFrames.NewText(TextFrames.Text(S.s), 0),
+        TextFrames.menuH, X, Y)
+    END
+  END ExtendDisplay;
+
+  PROCEDURE Trap(VAR a: INTEGER; b: INTEGER);
+    VAR u, v, w: INTEGER; mod: Modules.Module;
+  BEGIN u := SYSTEM.REG(15); SYSTEM.GET(u - 4, v); w := v DIV 10H MOD 10H; (*trap number*)
+    IF w = 0 THEN Kernel.New(a, b)
+    ELSE (*trap*) Texts.WriteLn(W); Texts.WriteString(W, "  pos "); Texts.WriteInt(W, v DIV 100H MOD 10000H, 4);
+      Texts.WriteString(W, "  TRAP"); Texts.WriteInt(W, w, 4); mod := Modules.root;
+      WHILE (mod # NIL) & ((u < mod.code) OR (u >= mod.imp)) DO mod := mod.next END ;
+      IF mod # NIL THEN Texts.WriteString(W, " in "); Texts.WriteString(W, mod.name) END ;
+      Texts.WriteString(W, " at"); Texts.WriteHex(W, u);
+      Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Oberon.Reset
+    END
+  END Trap;
+
+  PROCEDURE Abort;
+    VAR n: INTEGER;
+  BEGIN n := SYSTEM.REG(15); Texts.WriteString(W, "  ABORT  "); Texts.WriteHex(W, n);
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Oberon.Reset
+  END Abort;
+  
+BEGIN Texts.OpenWriter(W);
+  Oberon.OpenLog(TextFrames.Text("")); OpenViewers;
+  Kernel.Install(SYSTEM.ADR(Trap), 20H); Kernel.Install(SYSTEM.ADR(Abort), 0);
+END System.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/System.Tool.txt

@@ -1,24 +1,24 @@
-System.Open ^  System.Recall  System.Watch  System.Collect
-Edit.Open ^  Edit.Recall
-Edit.ChangeFont Oberon10i.Scn.Fnt
-Edit.ChangeFont Oberon10b.Scn.Fnt
-
-System.Directory ^
-  *.Mod  *.Bak  *.Tool  *.Text  *.Scn.Fnt  *.smb  *.rsc
-
-ORP.Compile @  ORP.Compile @/s  ORP.Compile name~
-System.Free ~
-System.Open Draw.Tool
-System.CopyFiles ~
-System.RenameFiles ~
-System.DeleteFiles ~
-
-System.ShowModules  System.ShowCommands ^ 
-
-PCLink1.Run
-Hilbert.Draw  Sierpinski.Draw  Blink.Run  Stars.Open
-
-Tools.Inspect 0
-Tools.Sector 1
-Tools.ShowFile 
-Tools.Recall  Tools.Clear
+System.Open ^  System.Recall  System.Watch  System.Collect
+Edit.Open ^  Edit.Recall
+Edit.ChangeFont Oberon10i.Scn.Fnt
+Edit.ChangeFont Oberon10b.Scn.Fnt
+
+System.Directory ^
+  *.Mod  *.Bak  *.Tool  *.Text  *.Scn.Fnt  *.smb  *.rsc
+
+ORP.Compile @  ORP.Compile @/s  ORP.Compile name~
+System.Free ~
+System.Open Draw.Tool
+System.CopyFiles ~
+System.RenameFiles ~
+System.DeleteFiles ~
+
+System.ShowModules  System.ShowCommands ^ 
+
+PCLink1.Run
+Hilbert.Draw  Sierpinski.Draw  Blink.Run  Stars.Open
+
+Tools.Inspect 0
+Tools.Sector 1
+Tools.ShowFile 
+Tools.Recall  Tools.Clear

people.inf.ethz.ch/wirth/ProjectOberon/Sources/TextFrames.Mod.txt

@@ -1,856 +1,856 @@
-MODULE TextFrames; (*JG 8.10.90 / NW 10.5.2013 / 11.2.2017*)
-  IMPORT Modules, Input, Display, Viewers, Fonts, Texts, Oberon, MenuViewers;
-
-  CONST replace* = 0; insert* = 1; delete* = 2; unmark* = 3; (*message id*)
-    BS = 8X; TAB = 9X; CR = 0DX; DEL = 7FX;
-
-  TYPE Line = POINTER TO LineDesc;
-    LineDesc = RECORD
-      len: LONGINT;
-      wid: INTEGER;
-      eot: BOOLEAN;
-      next: Line
-    END;
-
-    Location* = RECORD
-      org*, pos*: LONGINT;
-      dx*, x*, y*: INTEGER;
-      lin: Line
-    END;
-
-    Frame* = POINTER TO FrameDesc;
-    FrameDesc* = RECORD
-      (Display.FrameDesc)
-      text*: Texts.Text;
-      org*: LONGINT;
-      col*: INTEGER;
-      lsp*: INTEGER;
-      left*, right*, top*, bot*: INTEGER;
-      markH*: INTEGER;
-      time*: LONGINT;
-      hasCar*, hasSel*, hasMark: BOOLEAN;
-      carloc*: Location;
-      selbeg*, selend*: Location;
-      trailer: Line
-    END;
-
-    UpdateMsg* = RECORD (Display.FrameMsg)
-      id*: INTEGER;
-      text*: Texts.Text;
-      beg*, end*: LONGINT
-    END;
-
-    CopyOverMsg = RECORD (Display.FrameMsg)
-      text: Texts.Text;
-      beg, end: LONGINT
-    END;
-
-  VAR TBuf*, DelBuf: Texts.Buffer;
-    menuH*, barW*, left*, right*, top*, bot*, lsp*: INTEGER; (*standard sizes*)
-    asr, dsr, selH, markW, eolW: INTEGER;
-    nextCh: CHAR;
-    ScrollMarker: Oberon.Marker;
-    W, KW: Texts.Writer; (*keyboard writer*)
-
-  PROCEDURE Min (i, j: INTEGER): INTEGER;
-  BEGIN IF i < j THEN j := i END ;
-    RETURN j
-  END Min;
-
-  (*------------------display support------------------------*)
-
-  PROCEDURE ReplConst (col: INTEGER; F: Frame; X, Y, W, H: INTEGER; mode: INTEGER);
-  BEGIN
-    IF X + W <= F.X + F.W THEN Display.ReplConst(col, X, Y, W, H, mode)
-    ELSIF X < F.X + F.W THEN Display.ReplConst(col, X, Y, F.X + F.W - X, H, mode)
-    END
-  END ReplConst;
-
-  PROCEDURE FlipSM(X, Y: INTEGER);
-    VAR DW, DH, CL: INTEGER;
-  BEGIN DW := Display.Width; DH := Display.Height; CL := DW;
-    IF X < CL THEN
-      IF X < 3 THEN X := 3 ELSIF X > DW - 4 THEN X := DW - 4 END
-    ELSE
-      IF X < CL + 3 THEN X := CL + 4 ELSIF X > CL + DW - 4 THEN X := CL + DW - 4 END
-    END ;
-    IF Y < 6 THEN Y := 6 ELSIF Y > DH - 6 THEN Y := DH - 6 END;
-    Display.CopyPattern(Display.white, Display.updown, X-4, Y-4, Display.invert)
-  END FlipSM;
-
-  PROCEDURE UpdateMark (F: Frame);  (*in scroll bar*)
-    VAR oldH: INTEGER;
-  BEGIN oldH := F.markH; F.markH := F.org * F.H DIV (F.text.len + 1);
-    IF F.hasMark & (F.left >= barW) & (F.markH # oldH) THEN
-      Display.ReplConst(Display.white, F.X + 1, F.Y + F.H - 1 - oldH, markW, 1, Display.invert);
-      Display.ReplConst(Display.white, F.X + 1, F.Y + F.H - 1 - F.markH, markW, 1, Display.invert)
-    END
-  END UpdateMark;
-
-  PROCEDURE SetChangeMark (F: Frame; on: BOOLEAN);  (*in corner*)
-  BEGIN
-    IF F.H > menuH THEN
-      IF on THEN  Display.CopyPattern(Display.white, Display.block, F.X+F.W-12, F.Y+F.H-12, Display.paint)
-      ELSE Display.ReplConst(F.col, F.X+F.W-12, F.Y+F.H-12, 8, 8, Display.replace)
-      END
-    END
-  END SetChangeMark;
-
-  PROCEDURE Width (VAR R: Texts.Reader; len: LONGINT): INTEGER;
-    VAR patadr, pos: LONGINT; ox, dx, x, y, w, h: INTEGER;
-  BEGIN pos := 0; ox := 0;
-    WHILE pos < len DO
-      Fonts.GetPat(R.fnt, nextCh, dx, x, y, w, h, patadr);
-      ox := ox + dx; INC(pos); Texts.Read(R, nextCh)
-    END;
-    RETURN ox
-  END Width;
-
-  PROCEDURE DisplayLine (F: Frame; L: Line;
-    VAR R: Texts.Reader; X, Y: INTEGER; len: LONGINT);
-    VAR patadr, NX,  dx, x, y, w, h: INTEGER;
-  BEGIN NX := F.X + F.W;
-    WHILE (nextCh # CR) & (R.fnt # NIL) DO
-      Fonts.GetPat(R.fnt, nextCh, dx, x, y, w, h, patadr);
-      IF (X + x + w <= NX) & (h # 0) THEN
-        Display.CopyPattern(R.col, patadr, X + x, Y + y, Display.invert)
-      END;
-      X := X + dx; INC(len); Texts.Read(R, nextCh)
-    END;
-    L.len := len + 1; L.wid := X + eolW - (F.X + F.left);
-    L.eot := R.fnt = NIL; Texts.Read(R, nextCh)
-  END DisplayLine;
-
-  PROCEDURE Validate (T: Texts.Text; VAR pos: LONGINT);
-    VAR R: Texts.Reader;
-  BEGIN
-    IF pos > T.len THEN pos := T.len
-    ELSIF pos > 0 THEN
-      DEC(pos); Texts.OpenReader(R, T, pos);
-      REPEAT Texts.Read(R, nextCh); INC(pos) UNTIL R.eot OR (nextCh = CR)
-    ELSE pos := 0
-    END
-  END Validate;
-
-  PROCEDURE Mark* (F: Frame; on: BOOLEAN);
-  BEGIN
-    IF (F.H > 0) & (F.left >= barW) & ((F.hasMark & ~on) OR (~F.hasMark & on)) THEN
-      Display.ReplConst(Display.white, F.X + 1, F.Y + F.H - 1 - F.markH, markW, 1, Display.invert)
-    END;
-    F.hasMark := on
-  END Mark;
-
-  PROCEDURE Restore* (F: Frame);
-    VAR R: Texts.Reader; L, l: Line; curY, botY: INTEGER;
-  BEGIN  Display.ReplConst(F.col, F.X, F.Y, F.W, F.H, Display.replace);
-    IF F.left >= barW THEN
-      Display.ReplConst(Display.white, F.X + barW - 1, F.Y, 1, F.H, Display.invert)
-    END;
-    Validate(F.text, F.org);
-    botY := F.Y + F.bot + dsr;
-    Texts.OpenReader(R, F.text, F.org); Texts.Read(R, nextCh);
-    L := F.trailer; curY := F.Y + F.H - F.top - asr;
-    WHILE ~L.eot & (curY >= botY) DO
-      NEW(l);
-      DisplayLine(F, l, R, F.X + F.left, curY, 0);
-      L.next := l; L := l; curY := curY - lsp
-    END;
-    L.next := F.trailer;
-    F.markH := F.org * F.H DIV (F.text.len + 1)
-  END Restore;
-
-  PROCEDURE Suspend* (F: Frame);
-  BEGIN  F.trailer.next := F.trailer
-  END Suspend;
-
-  PROCEDURE Extend* (F: Frame; newY: INTEGER);
-    VAR R: Texts.Reader; L, l: Line;
-    org: LONGINT; curY, botY: INTEGER;
-  BEGIN Display.ReplConst(F.col, F.X, newY, F.W, F.Y - newY, Display.replace);
-    IF F.left >= barW THEN
-      Display.ReplConst(Display.white, F.X + barW - 1, newY, 1, F.Y - newY, Display.invert)
-    END;
-    botY := F.Y + F.bot + dsr; F.H := F.H + F.Y - newY; F.Y := newY;
-    IF F.trailer.next = F.trailer THEN Validate(F.text, F.org) END;
-    L := F.trailer; org := F.org; curY := F.Y + F.H - F.top - asr;
-    WHILE (L.next # F.trailer) & (curY >= botY) DO
-      L := L.next; org := org + L.len; curY := curY - lsp
-    END;
-    botY := F.Y + F.bot + dsr;
-    Texts.OpenReader(R, F.text, org); Texts.Read(R, nextCh);
-    WHILE ~L.eot & (curY >= botY) DO
-      NEW(l);
-      DisplayLine(F, l, R, F.X + F.left, curY, 0);
-      L.next := l; L := l; curY := curY - lsp
-    END;
-    L.next := F.trailer;
-    F.markH := F.org * F.H DIV (F.text.len + 1)
-  END Extend;
-
-  PROCEDURE Reduce* (F: Frame; newY: INTEGER);
-    VAR L: Line; curY, botY: INTEGER;
-  BEGIN F.H := F.H + F.Y - newY; F.Y := newY;
-    botY := F.Y + F.bot + dsr;
-    L := F.trailer; curY := F.Y + F.H - F.top - asr;
-    WHILE (L.next # F.trailer) & (curY >= botY) DO
-      L := L.next; curY := curY - lsp
-    END;
-    L.next := F.trailer;
-    IF curY + asr > F.Y THEN
-      Display.ReplConst(F.col, F.X + F.left, F.Y, F.W - F.left, curY + asr - F.Y, Display.replace)
-    END;
-    F.markH := F.org * F.H DIV (F.text.len + 1); Mark(F, TRUE)
-  END Reduce;
-
-  PROCEDURE Show* (F: Frame; pos: LONGINT);
-    VAR R: Texts.Reader; L, L0: Line;
-      org: LONGINT; curY, botY, Y0: INTEGER;
-  BEGIN
-    IF F.trailer.next # F.trailer THEN
-      Validate(F.text, pos);
-      IF pos < F.org THEN Mark(F, FALSE);
-        Display.ReplConst(F.col, F.X + F.left, F.Y, F.W - F.left, F.H, Display.replace);
-        botY := F.Y; F.Y := F.Y + F.H; F.H := 0;
-        F.org := pos; F.trailer.next := F.trailer; Extend(F, botY); Mark(F, TRUE)
-      ELSIF pos > F.org THEN
-        org := F.org; L := F.trailer.next; curY := F.Y + F.H - F.top - asr;
-        WHILE (L.next # F.trailer) & (org # pos) DO
-          org := org + L.len; L := L.next; curY := curY - lsp;
-        END;
-        IF org = pos THEN
-          F.org := org; F.trailer.next := L; Y0 := curY;
-          WHILE L.next # F.trailer DO (*!*)
-            org := org + L.len; L := L.next; curY := curY - lsp
-          END;
-          Display.CopyBlock (F.X + F.left, curY - dsr, F.W - F.left, Y0 + asr - (curY - dsr),
-              F.X + F.left, curY - dsr + F.Y + F.H - F.top - asr - Y0, 0);
-          curY := curY + F.Y + F.H - F.top - asr - Y0;
-          Display.ReplConst(F.col, F.X + F.left, F.Y, F.W - F.left, curY - dsr - F.Y, Display.replace);
-          botY := F.Y + F.bot + dsr;
-          org := org + L.len; curY := curY - lsp;
-          Texts.OpenReader(R, F.text, org); Texts.Read(R, nextCh);
-          WHILE ~L.eot & (curY >= botY) DO
-            NEW(L0); DisplayLine(F, L0, R, F.X + F.left, curY, 0);
-            L.next := L0; L := L0; curY := curY - lsp
-          END;
-          L.next := F.trailer; UpdateMark(F)
-        ELSE Mark(F, FALSE);
-          Display.ReplConst(F.col, F.X + F.left, F.Y, F.W - F.left, F.H, Display.replace);
-          botY := F.Y; F.Y := F.Y + F.H; F.H := 0;
-          F.org := pos; F.trailer.next := F.trailer; Extend(F, botY);
-          Mark(F, TRUE)
-        END
-      END
-    END ;
-    SetChangeMark(F, F.text.changed)
-  END Show;
-
-  PROCEDURE LocateLine (F: Frame; y: INTEGER; VAR loc: Location);
-    VAR L: Line; org: LONGINT; cury: INTEGER;
-  BEGIN org := F.org; L := F.trailer.next; cury := F.H - F.top - asr; 
-    WHILE (L.next # F.trailer) & (cury > y + dsr) DO
-      org := org + L.len; L := L.next; cury := cury - lsp
-    END;
-    loc.org := org; loc.lin := L; loc.y := cury
-  END LocateLine;
-
-  PROCEDURE LocateString (F: Frame; x, y: INTEGER; VAR loc: Location);
-    VAR R: Texts.Reader;
-      patadr, bpos, pos, lim: LONGINT;
-      bx, ex, ox, dx, u, v, w, h: INTEGER;
-  BEGIN LocateLine(F, y, loc);
-    lim := loc.org + loc.lin.len - 1;
-    bpos := loc.org; bx := F.left;
-    pos := loc.org; ox := F.left;
-    Texts.OpenReader(R, F.text, loc.org); Texts.Read(R, nextCh);
-    REPEAT
-      WHILE (pos # lim) & (nextCh > " ") DO (*scan string*)
-        Fonts.GetPat(R.fnt, nextCh, dx, u, v, w, h, patadr);
-        INC(pos); ox := ox + dx; Texts.Read(R, nextCh)
-      END;
-      ex := ox;
-      WHILE (pos # lim) & (nextCh <= " ") DO (*scan gap*)
-        Fonts.GetPat(R.fnt, nextCh, dx, u, v, w, h, patadr);
-        INC(pos); ox := ox + dx; Texts.Read(R, nextCh)
-      END;
-      IF (pos # lim) & (ox <= x) THEN
-        Fonts.GetPat(R.fnt, nextCh, dx, u, v, w, h, patadr);
-        bpos := pos; bx := ox;
-        INC(pos); ox := ox + dx; Texts.Read(R, nextCh)
-      ELSE pos := lim
-      END
-    UNTIL pos = lim;
-    loc.pos := bpos; loc.dx := ex - bx; loc.x := bx
-  END LocateString;
-
-  PROCEDURE LocateChar (F: Frame; x, y: INTEGER; VAR loc: Location);
-    VAR R: Texts.Reader;
-      patadr, pos, lim: LONGINT;
-      ox, dx, u, v, w, h: INTEGER;
-  BEGIN LocateLine(F, y, loc);
-    lim := loc.org + loc.lin.len - 1;
-    pos := loc.org; ox := F.left; dx := eolW;
-    Texts.OpenReader(R, F.text, loc.org);
-    WHILE pos # lim DO
-      Texts.Read(R, nextCh);
-      Fonts.GetPat(R.fnt, nextCh, dx, u, v, w, h, patadr);
-      IF ox + dx <= x THEN
-        INC(pos); ox := ox + dx;
-        IF pos = lim THEN dx := eolW END
-      ELSE lim := pos
-      END
-    END ;
-    loc.pos := pos; loc.dx := dx; loc.x := ox
-  END LocateChar;
-
-  PROCEDURE LocatePos (F: Frame; pos: LONGINT; VAR loc: Location);
-    VAR T: Texts.Text; R: Texts.Reader; L: Line;
-      org: LONGINT; cury: INTEGER;  
-  BEGIN T := F.text;
-    org := F.org; L := F.trailer.next; cury := F.H - F.top - asr;
-    IF pos < org THEN pos := org END;
-    WHILE (L.next # F.trailer) & (pos >= org + L.len) DO
-      org := org + L.len; L := L.next; cury := cury - lsp
-    END;
-    IF pos >= org + L.len THEN pos := org + L.len - 1 END;    
-    Texts.OpenReader(R, T, org); Texts.Read(R, nextCh);
-    loc.org := org; loc.pos := pos; loc.lin := L;
-    loc.x := F.left + Width(R, pos - org); loc.y := cury
-  END LocatePos;
-
-  PROCEDURE Pos* (F: Frame; X, Y: INTEGER): LONGINT;
-    VAR loc: Location;
-  BEGIN LocateChar(F, X - F.X, Y - F.Y, loc); RETURN loc.pos
-  END Pos;
-
-  PROCEDURE FlipCaret (F: Frame);
-  BEGIN
-    IF (F.carloc.x < F.W) & (F.carloc.y >= 10) & (F.carloc.x + 12 < F.W) THEN
-      Display.CopyPattern(Display.white, Display.hook, F.X + F.carloc.x, F.Y + F.carloc.y - 10, Display.invert)
-    END
-  END FlipCaret;
-
-  PROCEDURE SetCaret* (F: Frame; pos: LONGINT);
-  BEGIN LocatePos(F, pos, F.carloc); FlipCaret(F); F.hasCar := TRUE
-  END SetCaret;
-
-  PROCEDURE TrackCaret* (F: Frame; X, Y: INTEGER; VAR keysum: SET);
-    VAR loc: Location; keys: SET;
-  BEGIN
-    IF F.trailer.next # F.trailer THEN
-      LocateChar(F, X - F.X, Y - F.Y, F.carloc);
-      FlipCaret(F); keysum := {};
-      REPEAT Input.Mouse(keys, X, Y); keysum := keysum + keys;
-        Oberon.DrawMouseArrow(X, Y); LocateChar(F, X - F.X, Y - F.Y, loc);
-        IF loc.pos # F.carloc.pos THEN FlipCaret(F); F.carloc := loc; FlipCaret(F) END
-      UNTIL keys = {};
-      F.hasCar := TRUE
-    END
-  END TrackCaret;
-
-  PROCEDURE RemoveCaret* (F: Frame);
-  BEGIN IF F.hasCar THEN FlipCaret(F); F.hasCar := FALSE END
-  END RemoveCaret;
-
-  PROCEDURE FlipSelection (F: Frame; VAR beg, end: Location);
-    VAR L: Line; Y: INTEGER;
-  BEGIN L := beg.lin; Y := F.Y + beg.y - 2;
-    IF L = end.lin THEN ReplConst(Display.white, F, F.X + beg.x, Y, end.x - beg.x, selH, Display.invert)
-    ELSE
-      ReplConst(Display.white, F, F.X + beg.x, Y, F.left + L.wid - beg.x, selH, Display.invert);
-      L := L.next; Y := Y - lsp;
-      WHILE L # end.lin DO
-        ReplConst(Display.white, F, F.X + F.left, Y, L.wid, selH, Display.invert);
-        L := L.next; Y := Y - lsp
-      END;
-      ReplConst(Display.white, F, F.X + F.left, Y, end.x - F.left, selH, Display.invert)
-    END
-  END FlipSelection;
-
-  PROCEDURE SetSelection* (F: Frame; beg, end: LONGINT);
-  BEGIN
-    IF F.hasSel THEN FlipSelection(F, F.selbeg, F.selend) END;
-    LocatePos(F, beg, F.selbeg); LocatePos(F, end, F.selend);
-    IF F.selbeg.pos < F.selend.pos THEN
-      FlipSelection(F, F.selbeg, F.selend); F.time := Oberon.Time(); F.hasSel := TRUE
-    END
-  END SetSelection;
-
-  PROCEDURE TrackSelection* (F: Frame; X, Y: INTEGER; VAR keysum: SET);
-    VAR loc: Location; keys: SET;
-  BEGIN
-    IF F.trailer.next # F.trailer THEN
-      IF F.hasSel THEN FlipSelection(F, F.selbeg, F.selend) END;
-      LocateChar(F, X - F.X, Y - F.Y, loc);
-      IF F.hasSel & (loc.pos = F.selbeg.pos) & (F.selend.pos = F.selbeg.pos + 1) THEN
-        LocateChar(F, F.left, Y - F.Y, F.selbeg)
-      ELSE F.selbeg := loc
-      END;
-      INC(loc.pos); loc.x := loc.x + loc.dx; F.selend := loc;
-      FlipSelection(F, F.selbeg, F.selend); keysum := {};
-      REPEAT
-        Input.Mouse(keys, X, Y);
-        keysum := keysum + keys;
-        Oberon.DrawMouseArrow(X, Y);
-        LocateChar(F, X - F.X, Y - F.Y, loc);
-        IF loc.pos < F.selbeg.pos THEN loc := F.selbeg END;
-        INC(loc.pos); loc.x := loc.x + loc.dx;
-        IF loc.pos < F.selend.pos THEN FlipSelection(F, loc, F.selend); F.selend := loc
-        ELSIF loc.pos > F.selend.pos THEN FlipSelection(F, F.selend, loc); F.selend := loc
-        END
-      UNTIL keys = {};
-      F.time := Oberon.Time(); F.hasSel := TRUE
-    END
-  END TrackSelection;
-
-  PROCEDURE RemoveSelection* (F: Frame);
-  BEGIN IF F.hasSel THEN FlipSelection(F, F.selbeg, F.selend); F.hasSel := FALSE END
-  END RemoveSelection;
-
-  PROCEDURE TrackLine* (F: Frame; X, Y: INTEGER; VAR org: LONGINT; VAR keysum: SET);
-    VAR old, new: Location; keys: SET;
-  BEGIN
-    IF F.trailer.next # F.trailer THEN
-      LocateLine(F, Y - F.Y, old);
-      ReplConst(Display.white, F, F.X + F.left, F.Y + old.y - dsr, old.lin.wid, 2, Display.invert);
-      keysum := {};
-      REPEAT Input.Mouse(keys, X, Y);
-        keysum := keysum + keys;
-        Oberon.DrawMouse(ScrollMarker, X, Y);
-        LocateLine(F, Y - F.Y, new);
-        IF new.org # old.org THEN
-          ReplConst(Display.white, F, F.X + F.left, F.Y + old.y - dsr, old.lin.wid, 2, Display.invert);
-          ReplConst(Display.white, F, F.X + F.left, F.Y + new.y - dsr, new.lin.wid, 2, Display.invert);
-          old := new
-        END
-       UNTIL keys = {};
-       ReplConst(Display.white, F, F.X + F.left, F.Y + new.y - dsr, new.lin.wid, 2, Display.invert);
-       org := new.org
-    ELSE org := 0   (*<----*)
-    END
-  END TrackLine;
-
-  PROCEDURE TrackWord* (F: Frame; X, Y: INTEGER; VAR pos: LONGINT; VAR keysum: SET);
-    VAR old, new: Location; keys: SET;
-  BEGIN
-    IF F.trailer.next # F.trailer THEN
-      LocateString(F, X - F.X, Y - F.Y, old);
-      ReplConst(Display.white, F, F.X + old.x, F.Y + old.y - dsr, old.dx, 2, Display.invert);
-      keysum := {};
-      REPEAT
-        Input.Mouse(keys, X, Y); keysum := keysum + keys;
-        Oberon.DrawMouseArrow(X, Y);
-        LocateString(F, X - F.X, Y - F.Y, new);
-        IF new.pos # old.pos THEN
-          ReplConst(Display.white, F, F.X + old.x, F.Y + old.y - dsr, old.dx, 2, Display.invert);
-          ReplConst(Display.white, F, F.X + new.x, F.Y + new.y - dsr, new.dx, 2, Display.invert);
-          old := new
-        END
-      UNTIL keys = {};
-      ReplConst(Display.white, F, F.X + new.x, F.Y + new.y - dsr, new.dx, 2, Display.invert);
-      pos := new.pos
-    ELSE pos := 0  (*<----*)
-    END
-  END TrackWord;
-  
-  PROCEDURE Replace* (F: Frame; beg, end: LONGINT);
-    VAR R: Texts.Reader; L: Line;
-      org, len: LONGINT; curY, wid: INTEGER;
-  BEGIN
-    IF end > F.org THEN
-      IF beg < F.org THEN beg := F.org END;
-      org := F.org; L := F.trailer.next; curY := F.Y + F.H - F.top - asr; 
-      WHILE (L # F.trailer) & (org + L.len <= beg) DO
-        org := org + L.len; L := L.next; curY := curY - lsp
-      END;
-      IF L # F.trailer THEN
-        Texts.OpenReader(R, F.text, org); Texts.Read(R, nextCh);
-        len := beg - org; wid := Width(R, len);
-        ReplConst(F.col, F, F.X + F.left + wid, curY - dsr, L.wid - wid, lsp, Display.replace);
-        DisplayLine(F, L, R, F.X + F.left + wid, curY, len);
-        org := org + L.len; L := L.next; curY := curY - lsp;
-        WHILE (L # F.trailer) & (org <= end) DO
-          Display.ReplConst(F.col, F.X + F.left, curY - dsr, F.W - F.left, lsp, Display.replace);
-          DisplayLine(F, L, R, F.X + F.left, curY, 0);
-          org := org + L.len; L := L.next; curY := curY - lsp
-        END
-      END
-    END;
-    UpdateMark(F)
-  END Replace;
-
-  PROCEDURE Insert* (F: Frame; beg, end: LONGINT);
-    VAR R: Texts.Reader; L, L0, l: Line;
-      org, len: LONGINT; curY, botY, Y0, Y1, Y2, dY, wid: INTEGER;
-  BEGIN
-    IF beg < F.org THEN F.org := F.org + (end - beg)
-    ELSE
-      org := F.org; L := F.trailer.next; curY := F.Y + F.H - F.top - asr; 
-      WHILE (L # F.trailer) & (org + L.len <= beg) DO
-        org := org + L.len; L := L.next; curY := curY - lsp
-      END;
-      IF L # F.trailer THEN
-        botY := F.Y + F.bot + dsr;
-        Texts.OpenReader(R, F.text, org); Texts.Read(R, nextCh);
-        len := beg - org; wid := Width(R, len);
-        ReplConst (F.col, F, F.X + F.left + wid, curY - dsr, L.wid - wid, lsp, Display.replace);
-        DisplayLine(F, L, R, F.X + F.left + wid, curY, len);
-        org := org + L.len; curY := curY - lsp;
-        Y0 := curY; L0 := L.next;
-        WHILE (org <= end) & (curY >= botY) DO
-          NEW(l);
-          Display.ReplConst(F.col, F.X + F.left, curY - dsr, F.W - F.left, lsp, Display.replace);
-          DisplayLine(F, l, R, F.X + F.left, curY, 0);
-          L.next := l; L := l;
-          org := org + L.len; curY := curY - lsp
-        END;
-        IF L0 # L.next THEN Y1 := curY;
-          L.next := L0;
-          WHILE (L.next # F.trailer) & (curY >= botY) DO
-            L := L.next; curY := curY - lsp
-          END;
-          L.next := F.trailer;
-          dY := Y0 - Y1;
-          IF Y1 > curY + dY THEN
-            Display.CopyBlock(F.X + F.left, curY + dY + lsp - dsr, F.W - F.left, Y1 - curY - dY,
-              F.X + F.left, curY + lsp - dsr, 0);
-            Y2 := Y1 - dY
-          ELSE Y2 := curY
-          END;
-          curY := Y1; L := L0;
-          WHILE curY # Y2 DO
-            Display.ReplConst(F.col, F.X + F.left, curY - dsr, F.W - F.left, lsp, Display.replace);
-            DisplayLine(F, L, R, F.X + F.left, curY, 0);
-            L := L.next; curY := curY - lsp
-          END
-        END
-      END 
-    END;
-    UpdateMark(F)
-  END Insert;
-
-  PROCEDURE Delete* (F: Frame; beg, end: LONGINT);
-    VAR R: Texts.Reader; L, L0, l: Line;
-      org, org0, len: LONGINT; curY, botY, Y0, Y1, wid: INTEGER;
-  BEGIN
-    IF end <= F.org THEN F.org := F.org - (end - beg)
-    ELSE
-      IF beg < F.org THEN
-        F.trailer.next.len := F.trailer.next.len + (F.org - beg);
-        F.org := beg
-      END;
-      org := F.org; L := F.trailer.next; curY := F.Y + F.H - F.top - asr;
-      WHILE (L # F.trailer) & (org + L.len <= beg) DO
-        org := org + L.len; L := L.next; curY := curY - lsp
-      END;
-      IF L # F.trailer THEN
-        botY := F.Y + F.bot + dsr;
-        org0 := org; L0 := L; Y0 := curY;
-        WHILE (L # F.trailer) & (org <= end) DO
-          org := org + L.len; L := L.next; curY := curY - lsp
-        END;
-        Y1 := curY;
-        Texts.OpenReader(R, F.text, org0); Texts.Read(R, nextCh);
-        len := beg - org0; wid := Width(R, len);
-        ReplConst (F.col, F, F.X + F.left + wid, Y0 - dsr, L0.wid - wid, lsp, Display.replace);
-        DisplayLine(F, L0, R, F.X + F.left + wid, Y0, len);
-        Y0 := Y0 - lsp;
-        IF L # L0.next THEN
-          L0.next := L;
-          L := L0; org := org0 + L0.len;
-          WHILE L.next # F.trailer DO
-            L := L.next; org := org + L.len; curY := curY - lsp
-          END;
-          Display.CopyBlock(F.X + F.left, curY + lsp - dsr, F.W - F.left, Y1 - curY,
-              F.X + F.left, curY + lsp - dsr + (Y0 - Y1), 0);
-          curY := curY + (Y0 - Y1);
-          Display.ReplConst (F.col, F.X + F.left, F.Y, F.W - F.left, curY + lsp - (F.Y + dsr), Display.replace);
-          Texts.OpenReader(R, F.text, org); Texts.Read(R, nextCh);
-          WHILE ~L.eot & (curY >= botY) DO
-            NEW(l);
-            DisplayLine(F, l, R, F.X + F.left, curY, 0);
-            L.next := l; L := l; curY := curY - lsp
-          END;
-          L.next := F.trailer
-        END
-      END
-    END;
-    UpdateMark(F)
-  END Delete;
-
-  PROCEDURE Recall*(VAR B: Texts.Buffer);
-  BEGIN B := TBuf; NEW(TBuf); Texts.OpenBuf(TBuf)
-  END Recall;
-
-  (*------------------message handling------------------------*)
-
-  PROCEDURE RemoveMarks (F: Frame);
-  BEGIN RemoveCaret(F); RemoveSelection(F)
-  END RemoveMarks;
-
-  PROCEDURE NotifyDisplay* (T: Texts.Text; op: INTEGER; beg, end: LONGINT);
-    VAR M: UpdateMsg;
-  BEGIN M.id := op; M.text := T; M.beg := beg; M.end := end; Viewers.Broadcast(M)
-  END NotifyDisplay;
-
-  PROCEDURE Call* (F: Frame; pos: LONGINT; new: BOOLEAN);
-    VAR S: Texts.Scanner; res: INTEGER;
-  BEGIN
-    Texts.OpenScanner(S, F.text, pos); Texts.Scan(S);
-    IF (S.class = Texts.Name) & (S.line = 0) THEN
-      Oberon.SetPar(F, F.text, pos + S.len); Oberon.Call(S.s, res);
-      IF res > 0 THEN
-        Texts.WriteString(W, "Call error: "); Texts.WriteString(W, Modules.importing);
-        IF res = 1 THEN Texts.WriteString(W, " module not found")
-        ELSIF res = 2 THEN  Texts.WriteString(W, " bad version")
-        ELSIF res = 3 THEN Texts.WriteString(W, " imports ");
-          Texts.WriteString(W, Modules.imported); Texts.WriteString(W, " with bad key");
-        ELSIF res = 4 THEN Texts.WriteString(W, " corrupted obj file")
-        ELSIF res = 5 THEN Texts.WriteString(W, " command not found")
-        ELSIF res = 7 THEN Texts.WriteString(W, " insufficient space")
-        END;
-        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
-      END
-    END
-  END Call;
-
-  PROCEDURE Write* (F: Frame; ch: CHAR; fnt: Fonts.Font; col, voff: INTEGER);
-    VAR buf: Texts.Buffer;
-  BEGIN (*F.hasCar*)
-    IF ch = BS THEN  (*backspace*)
-      IF F.carloc.pos > F.org THEN
-        Texts.Delete(F.text, F.carloc.pos - 1, F.carloc.pos, DelBuf); SetCaret(F, F.carloc.pos - 1)
-      END
-    ELSIF ch = 3X THEN (* ctrl-c  copy*)
-      IF F.hasSel THEN
-        NEW(TBuf); Texts.OpenBuf(TBuf); Texts.Save(F.text, F.selbeg.pos, F.selend.pos, TBuf)
-      END
-    ELSIF ch = 16X THEN (*ctrl-v  paste*)
-      NEW(buf); Texts.OpenBuf(buf); Texts.Copy(TBuf, buf); Texts.Insert(F.text, F.carloc.pos, buf);
-      SetCaret(F, F.carloc.pos + TBuf.len)
-    ELSIF ch = 18X THEN (*ctrl-x,  cut*)
-      IF F.hasSel THEN
-        NEW(TBuf); Texts.OpenBuf(TBuf); Texts.Delete(F.text, F.selbeg.pos, F.selend.pos, TBuf)
-      END
-    ELSIF (20X <= ch) & (ch <= DEL) OR (ch = CR) OR (ch = TAB) THEN
-      KW.fnt := fnt; KW.col := col; KW.voff := voff; Texts.Write(KW, ch);
-      Texts.Insert(F.text, F.carloc.pos, KW.buf);
-      SetCaret(F, F.carloc.pos + 1)
-    END
-  END Write;
-
-  PROCEDURE Defocus* (F: Frame);
-  BEGIN RemoveCaret(F)
-  END Defocus;
-
-  PROCEDURE Neutralize* (F: Frame);
-  BEGIN RemoveMarks(F)
-  END Neutralize;
-
-  PROCEDURE Modify* (F: Frame; id, dY, Y, H: INTEGER);
-  BEGIN
-    Mark(F, FALSE); RemoveMarks(F); SetChangeMark(F,  FALSE);
-    IF id = MenuViewers.extend THEN
-      IF dY > 0 THEN Display.CopyBlock(F.X, F.Y, F.W, F.H, F.X, F.Y + dY, 0); F.Y := F.Y + dY END;
-      Extend(F, Y)
-    ELSIF id = MenuViewers.reduce THEN
-      Reduce(F, Y + dY);
-      IF dY > 0 THEN Display.CopyBlock(F.X, F.Y, F.W, F.H, F.X, Y, 0); F.Y := Y END
-    END;
-    IF F.H > 0 THEN Mark(F, TRUE); SetChangeMark(F,  F.text.changed) END
-  END Modify;
-
-  PROCEDURE Open* (F: Frame; H: Display.Handler; T: Texts.Text; org: LONGINT;
-        col, left, right, top, bot, lsp: INTEGER);
-    VAR L: Line;
-  BEGIN NEW(L);
-    L.len := 0; L.wid := 0; L.eot := FALSE; L.next := L;
-    F.handle := H; F.text := T; F.org := org; F.trailer := L;
-    F.left := left; F.right := right; F.top := top; F.bot := bot;
-    F.lsp := lsp; F.col := col; F.hasMark := FALSE; F.hasCar := FALSE; F.hasSel := FALSE
-  END Open;
-
-  PROCEDURE Copy* (F: Frame; VAR F1: Frame);
-  BEGIN NEW(F1);
-    Open(F1, F.handle, F.text, F.org, F.col, F.left, F.right, F.top, F.bot, F.lsp)
-  END Copy;
-
-  PROCEDURE CopyOver(F: Frame; text: Texts.Text; beg, end: LONGINT);
-    VAR buf: Texts.Buffer;
-  BEGIN
-    IF F.hasCar THEN
-      NEW(buf); Texts.OpenBuf(buf);
-      Texts.Save(text, beg, end, buf); Texts.Insert(F.text, F.carloc.pos, buf);
-      SetCaret(F, F.carloc.pos + (end - beg))
-    END
-  END CopyOver;
-
-  PROCEDURE GetSelection* (F: Frame; VAR text: Texts.Text; VAR beg, end, time: LONGINT);
-  BEGIN
-    IF F.hasSel THEN
-      IF F.text = text THEN
-        IF F.selbeg.pos < beg THEN beg := F.selbeg.pos END ;  (*leftmost*)
-        IF F.time > time THEN end := F.selend.pos; time := F.time END ; (*last selected*)
-      ELSIF F.time > time THEN
-        text := F.text; beg := F.selbeg.pos; end := F.selend.pos; time := F.time
-      END
-    END
-  END GetSelection;
-
-  PROCEDURE Update* (F: Frame; VAR M: UpdateMsg);
-  BEGIN (*F.text = M.text*) SetChangeMark(F, FALSE);
-    RemoveMarks(F); Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
-    IF M.id = replace THEN Replace(F, M.beg, M.end)
-    ELSIF M.id = insert THEN Insert(F, M.beg, M.end)
-    ELSIF M.id = delete THEN Delete(F, M.beg, M.end)
-    END ;
-    SetChangeMark(F,  F.text.changed)
-  END Update;
-
-  PROCEDURE Edit* (F: Frame; X, Y: INTEGER; Keys: SET);
-    VAR M: CopyOverMsg;
-      text: Texts.Text;
-      buf: Texts.Buffer;
-      v: Viewers.Viewer;
-      beg, end, time, pos: LONGINT;
-      keysum: SET;
-      fnt: Fonts.Font;
-      col, voff: INTEGER;
-  BEGIN
-    IF X < F.X + Min(F.left, barW) THEN  (*scroll bar*)
-      Oberon.DrawMouse(ScrollMarker, X, Y); keysum := Keys;
-      IF Keys = {2} THEN   (*ML, scroll up*)
-        TrackLine(F, X, Y, pos, keysum);
-        IF (pos >= 0) & (keysum = {2}) THEN
-          SetChangeMark(F, FALSE);
-          RemoveMarks(F); Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
-          Show(F, pos)
-        END
-      ELSIF Keys = {1} THEN   (*MM*)  keysum := Keys;
-        REPEAT Input.Mouse(Keys, X, Y); keysum := keysum + Keys;
-          Oberon.DrawMouse(ScrollMarker, X, Y)
-        UNTIL Keys = {};
-        IF keysum # {0, 1, 2} THEN
-          IF 0 IN keysum THEN pos := 0
-          ELSIF 2 IN keysum THEN pos := F.text.len - 100
-          ELSE pos := (F.Y + F.H - Y) * (F.text.len) DIV F.H
-          END ;
-          SetChangeMark(F, FALSE);
-          RemoveMarks(F); Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
-          Show(F, pos)
-        END
-      ELSIF Keys = {0} THEN   (*MR, scroll down*)
-        TrackLine(F, X, Y, pos, keysum);
-        IF keysum = {0} THEN
-          SetChangeMark(F, FALSE);
-          RemoveMarks(F); Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
-          Show(F, F.org*2 - pos - 100)
-        END
-      END
-    ELSE  (*text area*)
-      Oberon.DrawMouseArrow(X, Y);
-      IF 0 IN Keys THEN  (*MR: select*)
-        TrackSelection(F, X, Y, keysum);
-        IF F.hasSel THEN
-          IF keysum = {0, 2} THEN (*MR, ML: delete text*)
-            Oberon.GetSelection(text, beg, end, time);
-            Texts.Delete(text, beg, end, TBuf);
-            Oberon.PassFocus(Viewers.This(F.X, F.Y)); SetCaret(F, beg)
-          ELSIF keysum = {0, 1} THEN  (*MR, MM: copy to caret*)
-            Oberon.GetSelection(text, beg, end, time);
-            M.text := text; M.beg := beg; M.end := end;
-            Oberon.FocusViewer.handle(Oberon.FocusViewer, M)
-          END
-        END
-      ELSIF 1 IN Keys THEN  (*MM: call*)
-        TrackWord(F, X, Y, pos, keysum);
-        IF (pos >= 0) & ~(0 IN keysum) THEN Call(F, pos, 2 IN keysum) END
-      ELSIF 2 IN Keys THEN  (*ML: set caret*)
-        Oberon.PassFocus(Viewers.This(F.X, F.Y));
-        TrackCaret(F, X, Y, keysum);
-        IF keysum = {2, 1} THEN (*ML, MM: copy from selection to caret*)
-          Oberon.GetSelection(text, beg, end, time);
-           IF time >= 0 THEN
-            NEW(TBuf); Texts.OpenBuf(TBuf);
-            Texts.Save(text, beg, end, TBuf); Texts.Insert(F.text, F.carloc.pos, TBuf);
-            SetSelection(F, F.carloc.pos, F.carloc.pos + (end  - beg));
-            SetCaret(F, F.carloc.pos + (end - beg))
-          ELSIF TBuf # NIL THEN
-            NEW(buf); Texts.OpenBuf(buf);
-            Texts.Copy(TBuf, buf); Texts.Insert(F.text, F.carloc.pos, buf);
-            SetCaret(F, F.carloc.pos + buf.len)
-          END
-        ELSIF keysum = {2, 0} THEN (*ML, MR: copy looks*)
-          Oberon.GetSelection(text, beg, end, time);
-          IF time >= 0 THEN
-            Texts.Attributes(F.text, F.carloc.pos, fnt, col, voff);
-            IF fnt # NIL THEN Texts.ChangeLooks(text, beg, end, {0,1,2}, fnt, col, voff) END
-          END
-        END
-      END
-    END
-  END Edit;
-
-  PROCEDURE Handle* (F: Display.Frame; VAR M: Display.FrameMsg);
-    VAR F1: Frame; buf: Texts.Buffer;
-  BEGIN
-    CASE F OF Frame:
-      CASE M OF
-      Oberon.InputMsg:
-        IF M.id = Oberon.track THEN Edit(F, M.X, M.Y, M.keys)
-        ELSIF M.id = Oberon.consume THEN
-          IF F.hasCar THEN Write(F, M.ch, M.fnt, M.col, M.voff) END
-        END |
-      Oberon.ControlMsg:
-        IF M.id = Oberon.defocus THEN Defocus(F)
-        ELSIF M.id = Oberon.neutralize THEN Neutralize(F)
-        END |
-      Oberon.SelectionMsg:
-        GetSelection(F, M.text, M.beg, M.end, M.time) |
-      Oberon.CopyMsg: Copy(F, F1); M.F := F1 |
-      MenuViewers.ModifyMsg: Modify(F, M.id, M.dY, M.Y, M.H) |
-      CopyOverMsg: CopyOver(F, M.text, M.beg, M.end) |
-      UpdateMsg: IF F.text = M.text THEN Update(F, M) END
-      END
-    END
-  END Handle;
-
-  (*creation*)
-
-  PROCEDURE Menu (name, commands: ARRAY OF CHAR): Texts.Text;
-    VAR T: Texts.Text;
-  BEGIN NEW(T); T.notify := NotifyDisplay;  Texts.Open(T, "");
-    Texts.WriteString(W, name); Texts.WriteString(W, " | ");  Texts.WriteString(W, commands);
-    Texts.Append(T, W.buf); RETURN T
-  END Menu;
-
-  PROCEDURE Text* (name: ARRAY OF CHAR): Texts.Text;
-    VAR T: Texts.Text;
-  BEGIN NEW(T); T.notify := NotifyDisplay; Texts.Open(T, name); RETURN T
-  END Text;
-
-  PROCEDURE NewMenu* (name, commands: ARRAY OF CHAR): Frame;
-    VAR F: Frame; T: Texts.Text;
-  BEGIN NEW(F); T := Menu(name, commands);
-    Open(F, Handle, T, 0, Display.white, left DIV 4, 0, 0, 0, lsp); RETURN F
-  END NewMenu;
-
-  PROCEDURE NewText* (text: Texts.Text; pos: LONGINT): Frame;
-    VAR F: Frame;
-  BEGIN NEW(F);
-    Open(F, Handle, text, pos, Display.black, left, right, top, bot, lsp); RETURN F
-  END NewText;
-
-BEGIN NEW(TBuf); NEW(DelBuf);
-  Texts.OpenBuf(TBuf); Texts.OpenBuf(DelBuf);
-  lsp := Fonts.Default.height; menuH := lsp + 2; barW := menuH;
-  left := barW + lsp DIV 2;
-  right := lsp DIV 2;
-  top := lsp DIV 2; bot := lsp DIV 2;
-  asr := Fonts.Default.maxY;
-  dsr := -Fonts.Default.minY;
-  selH := lsp; markW := lsp DIV 2;
-  eolW := lsp DIV 2;
-  ScrollMarker.Fade := FlipSM; ScrollMarker.Draw := FlipSM;
-  Texts.OpenWriter(W); Texts.OpenWriter(KW)
-END TextFrames.
+MODULE TextFrames; (*JG 8.10.90 / NW 10.5.2013 / 11.2.2017*)
+  IMPORT Modules, Input, Display, Viewers, Fonts, Texts, Oberon, MenuViewers;
+
+  CONST replace* = 0; insert* = 1; delete* = 2; unmark* = 3; (*message id*)
+    BS = 8X; TAB = 9X; CR = 0DX; DEL = 7FX;
+
+  TYPE Line = POINTER TO LineDesc;
+    LineDesc = RECORD
+      len: LONGINT;
+      wid: INTEGER;
+      eot: BOOLEAN;
+      next: Line
+    END;
+
+    Location* = RECORD
+      org*, pos*: LONGINT;
+      dx*, x*, y*: INTEGER;
+      lin: Line
+    END;
+
+    Frame* = POINTER TO FrameDesc;
+    FrameDesc* = RECORD
+      (Display.FrameDesc)
+      text*: Texts.Text;
+      org*: LONGINT;
+      col*: INTEGER;
+      lsp*: INTEGER;
+      left*, right*, top*, bot*: INTEGER;
+      markH*: INTEGER;
+      time*: LONGINT;
+      hasCar*, hasSel*, hasMark: BOOLEAN;
+      carloc*: Location;
+      selbeg*, selend*: Location;
+      trailer: Line
+    END;
+
+    UpdateMsg* = RECORD (Display.FrameMsg)
+      id*: INTEGER;
+      text*: Texts.Text;
+      beg*, end*: LONGINT
+    END;
+
+    CopyOverMsg = RECORD (Display.FrameMsg)
+      text: Texts.Text;
+      beg, end: LONGINT
+    END;
+
+  VAR TBuf*, DelBuf: Texts.Buffer;
+    menuH*, barW*, left*, right*, top*, bot*, lsp*: INTEGER; (*standard sizes*)
+    asr, dsr, selH, markW, eolW: INTEGER;
+    nextCh: CHAR;
+    ScrollMarker: Oberon.Marker;
+    W, KW: Texts.Writer; (*keyboard writer*)
+
+  PROCEDURE Min (i, j: INTEGER): INTEGER;
+  BEGIN IF i < j THEN j := i END ;
+    RETURN j
+  END Min;
+
+  (*------------------display support------------------------*)
+
+  PROCEDURE ReplConst (col: INTEGER; F: Frame; X, Y, W, H: INTEGER; mode: INTEGER);
+  BEGIN
+    IF X + W <= F.X + F.W THEN Display.ReplConst(col, X, Y, W, H, mode)
+    ELSIF X < F.X + F.W THEN Display.ReplConst(col, X, Y, F.X + F.W - X, H, mode)
+    END
+  END ReplConst;
+
+  PROCEDURE FlipSM(X, Y: INTEGER);
+    VAR DW, DH, CL: INTEGER;
+  BEGIN DW := Display.Width; DH := Display.Height; CL := DW;
+    IF X < CL THEN
+      IF X < 3 THEN X := 3 ELSIF X > DW - 4 THEN X := DW - 4 END
+    ELSE
+      IF X < CL + 3 THEN X := CL + 4 ELSIF X > CL + DW - 4 THEN X := CL + DW - 4 END
+    END ;
+    IF Y < 6 THEN Y := 6 ELSIF Y > DH - 6 THEN Y := DH - 6 END;
+    Display.CopyPattern(Display.white, Display.updown, X-4, Y-4, Display.invert)
+  END FlipSM;
+
+  PROCEDURE UpdateMark (F: Frame);  (*in scroll bar*)
+    VAR oldH: INTEGER;
+  BEGIN oldH := F.markH; F.markH := F.org * F.H DIV (F.text.len + 1);
+    IF F.hasMark & (F.left >= barW) & (F.markH # oldH) THEN
+      Display.ReplConst(Display.white, F.X + 1, F.Y + F.H - 1 - oldH, markW, 1, Display.invert);
+      Display.ReplConst(Display.white, F.X + 1, F.Y + F.H - 1 - F.markH, markW, 1, Display.invert)
+    END
+  END UpdateMark;
+
+  PROCEDURE SetChangeMark (F: Frame; on: BOOLEAN);  (*in corner*)
+  BEGIN
+    IF F.H > menuH THEN
+      IF on THEN  Display.CopyPattern(Display.white, Display.block, F.X+F.W-12, F.Y+F.H-12, Display.paint)
+      ELSE Display.ReplConst(F.col, F.X+F.W-12, F.Y+F.H-12, 8, 8, Display.replace)
+      END
+    END
+  END SetChangeMark;
+
+  PROCEDURE Width (VAR R: Texts.Reader; len: LONGINT): INTEGER;
+    VAR patadr, pos: LONGINT; ox, dx, x, y, w, h: INTEGER;
+  BEGIN pos := 0; ox := 0;
+    WHILE pos < len DO
+      Fonts.GetPat(R.fnt, nextCh, dx, x, y, w, h, patadr);
+      ox := ox + dx; INC(pos); Texts.Read(R, nextCh)
+    END;
+    RETURN ox
+  END Width;
+
+  PROCEDURE DisplayLine (F: Frame; L: Line;
+    VAR R: Texts.Reader; X, Y: INTEGER; len: LONGINT);
+    VAR patadr, NX,  dx, x, y, w, h: INTEGER;
+  BEGIN NX := F.X + F.W;
+    WHILE (nextCh # CR) & (R.fnt # NIL) DO
+      Fonts.GetPat(R.fnt, nextCh, dx, x, y, w, h, patadr);
+      IF (X + x + w <= NX) & (h # 0) THEN
+        Display.CopyPattern(R.col, patadr, X + x, Y + y, Display.invert)
+      END;
+      X := X + dx; INC(len); Texts.Read(R, nextCh)
+    END;
+    L.len := len + 1; L.wid := X + eolW - (F.X + F.left);
+    L.eot := R.fnt = NIL; Texts.Read(R, nextCh)
+  END DisplayLine;
+
+  PROCEDURE Validate (T: Texts.Text; VAR pos: LONGINT);
+    VAR R: Texts.Reader;
+  BEGIN
+    IF pos > T.len THEN pos := T.len
+    ELSIF pos > 0 THEN
+      DEC(pos); Texts.OpenReader(R, T, pos);
+      REPEAT Texts.Read(R, nextCh); INC(pos) UNTIL R.eot OR (nextCh = CR)
+    ELSE pos := 0
+    END
+  END Validate;
+
+  PROCEDURE Mark* (F: Frame; on: BOOLEAN);
+  BEGIN
+    IF (F.H > 0) & (F.left >= barW) & ((F.hasMark & ~on) OR (~F.hasMark & on)) THEN
+      Display.ReplConst(Display.white, F.X + 1, F.Y + F.H - 1 - F.markH, markW, 1, Display.invert)
+    END;
+    F.hasMark := on
+  END Mark;
+
+  PROCEDURE Restore* (F: Frame);
+    VAR R: Texts.Reader; L, l: Line; curY, botY: INTEGER;
+  BEGIN  Display.ReplConst(F.col, F.X, F.Y, F.W, F.H, Display.replace);
+    IF F.left >= barW THEN
+      Display.ReplConst(Display.white, F.X + barW - 1, F.Y, 1, F.H, Display.invert)
+    END;
+    Validate(F.text, F.org);
+    botY := F.Y + F.bot + dsr;
+    Texts.OpenReader(R, F.text, F.org); Texts.Read(R, nextCh);
+    L := F.trailer; curY := F.Y + F.H - F.top - asr;
+    WHILE ~L.eot & (curY >= botY) DO
+      NEW(l);
+      DisplayLine(F, l, R, F.X + F.left, curY, 0);
+      L.next := l; L := l; curY := curY - lsp
+    END;
+    L.next := F.trailer;
+    F.markH := F.org * F.H DIV (F.text.len + 1)
+  END Restore;
+
+  PROCEDURE Suspend* (F: Frame);
+  BEGIN  F.trailer.next := F.trailer
+  END Suspend;
+
+  PROCEDURE Extend* (F: Frame; newY: INTEGER);
+    VAR R: Texts.Reader; L, l: Line;
+    org: LONGINT; curY, botY: INTEGER;
+  BEGIN Display.ReplConst(F.col, F.X, newY, F.W, F.Y - newY, Display.replace);
+    IF F.left >= barW THEN
+      Display.ReplConst(Display.white, F.X + barW - 1, newY, 1, F.Y - newY, Display.invert)
+    END;
+    botY := F.Y + F.bot + dsr; F.H := F.H + F.Y - newY; F.Y := newY;
+    IF F.trailer.next = F.trailer THEN Validate(F.text, F.org) END;
+    L := F.trailer; org := F.org; curY := F.Y + F.H - F.top - asr;
+    WHILE (L.next # F.trailer) & (curY >= botY) DO
+      L := L.next; org := org + L.len; curY := curY - lsp
+    END;
+    botY := F.Y + F.bot + dsr;
+    Texts.OpenReader(R, F.text, org); Texts.Read(R, nextCh);
+    WHILE ~L.eot & (curY >= botY) DO
+      NEW(l);
+      DisplayLine(F, l, R, F.X + F.left, curY, 0);
+      L.next := l; L := l; curY := curY - lsp
+    END;
+    L.next := F.trailer;
+    F.markH := F.org * F.H DIV (F.text.len + 1)
+  END Extend;
+
+  PROCEDURE Reduce* (F: Frame; newY: INTEGER);
+    VAR L: Line; curY, botY: INTEGER;
+  BEGIN F.H := F.H + F.Y - newY; F.Y := newY;
+    botY := F.Y + F.bot + dsr;
+    L := F.trailer; curY := F.Y + F.H - F.top - asr;
+    WHILE (L.next # F.trailer) & (curY >= botY) DO
+      L := L.next; curY := curY - lsp
+    END;
+    L.next := F.trailer;
+    IF curY + asr > F.Y THEN
+      Display.ReplConst(F.col, F.X + F.left, F.Y, F.W - F.left, curY + asr - F.Y, Display.replace)
+    END;
+    F.markH := F.org * F.H DIV (F.text.len + 1); Mark(F, TRUE)
+  END Reduce;
+
+  PROCEDURE Show* (F: Frame; pos: LONGINT);
+    VAR R: Texts.Reader; L, L0: Line;
+      org: LONGINT; curY, botY, Y0: INTEGER;
+  BEGIN
+    IF F.trailer.next # F.trailer THEN
+      Validate(F.text, pos);
+      IF pos < F.org THEN Mark(F, FALSE);
+        Display.ReplConst(F.col, F.X + F.left, F.Y, F.W - F.left, F.H, Display.replace);
+        botY := F.Y; F.Y := F.Y + F.H; F.H := 0;
+        F.org := pos; F.trailer.next := F.trailer; Extend(F, botY); Mark(F, TRUE)
+      ELSIF pos > F.org THEN
+        org := F.org; L := F.trailer.next; curY := F.Y + F.H - F.top - asr;
+        WHILE (L.next # F.trailer) & (org # pos) DO
+          org := org + L.len; L := L.next; curY := curY - lsp;
+        END;
+        IF org = pos THEN
+          F.org := org; F.trailer.next := L; Y0 := curY;
+          WHILE L.next # F.trailer DO (*!*)
+            org := org + L.len; L := L.next; curY := curY - lsp
+          END;
+          Display.CopyBlock (F.X + F.left, curY - dsr, F.W - F.left, Y0 + asr - (curY - dsr),
+              F.X + F.left, curY - dsr + F.Y + F.H - F.top - asr - Y0, 0);
+          curY := curY + F.Y + F.H - F.top - asr - Y0;
+          Display.ReplConst(F.col, F.X + F.left, F.Y, F.W - F.left, curY - dsr - F.Y, Display.replace);
+          botY := F.Y + F.bot + dsr;
+          org := org + L.len; curY := curY - lsp;
+          Texts.OpenReader(R, F.text, org); Texts.Read(R, nextCh);
+          WHILE ~L.eot & (curY >= botY) DO
+            NEW(L0); DisplayLine(F, L0, R, F.X + F.left, curY, 0);
+            L.next := L0; L := L0; curY := curY - lsp
+          END;
+          L.next := F.trailer; UpdateMark(F)
+        ELSE Mark(F, FALSE);
+          Display.ReplConst(F.col, F.X + F.left, F.Y, F.W - F.left, F.H, Display.replace);
+          botY := F.Y; F.Y := F.Y + F.H; F.H := 0;
+          F.org := pos; F.trailer.next := F.trailer; Extend(F, botY);
+          Mark(F, TRUE)
+        END
+      END
+    END ;
+    SetChangeMark(F, F.text.changed)
+  END Show;
+
+  PROCEDURE LocateLine (F: Frame; y: INTEGER; VAR loc: Location);
+    VAR L: Line; org: LONGINT; cury: INTEGER;
+  BEGIN org := F.org; L := F.trailer.next; cury := F.H - F.top - asr; 
+    WHILE (L.next # F.trailer) & (cury > y + dsr) DO
+      org := org + L.len; L := L.next; cury := cury - lsp
+    END;
+    loc.org := org; loc.lin := L; loc.y := cury
+  END LocateLine;
+
+  PROCEDURE LocateString (F: Frame; x, y: INTEGER; VAR loc: Location);
+    VAR R: Texts.Reader;
+      patadr, bpos, pos, lim: LONGINT;
+      bx, ex, ox, dx, u, v, w, h: INTEGER;
+  BEGIN LocateLine(F, y, loc);
+    lim := loc.org + loc.lin.len - 1;
+    bpos := loc.org; bx := F.left;
+    pos := loc.org; ox := F.left;
+    Texts.OpenReader(R, F.text, loc.org); Texts.Read(R, nextCh);
+    REPEAT
+      WHILE (pos # lim) & (nextCh > " ") DO (*scan string*)
+        Fonts.GetPat(R.fnt, nextCh, dx, u, v, w, h, patadr);
+        INC(pos); ox := ox + dx; Texts.Read(R, nextCh)
+      END;
+      ex := ox;
+      WHILE (pos # lim) & (nextCh <= " ") DO (*scan gap*)
+        Fonts.GetPat(R.fnt, nextCh, dx, u, v, w, h, patadr);
+        INC(pos); ox := ox + dx; Texts.Read(R, nextCh)
+      END;
+      IF (pos # lim) & (ox <= x) THEN
+        Fonts.GetPat(R.fnt, nextCh, dx, u, v, w, h, patadr);
+        bpos := pos; bx := ox;
+        INC(pos); ox := ox + dx; Texts.Read(R, nextCh)
+      ELSE pos := lim
+      END
+    UNTIL pos = lim;
+    loc.pos := bpos; loc.dx := ex - bx; loc.x := bx
+  END LocateString;
+
+  PROCEDURE LocateChar (F: Frame; x, y: INTEGER; VAR loc: Location);
+    VAR R: Texts.Reader;
+      patadr, pos, lim: LONGINT;
+      ox, dx, u, v, w, h: INTEGER;
+  BEGIN LocateLine(F, y, loc);
+    lim := loc.org + loc.lin.len - 1;
+    pos := loc.org; ox := F.left; dx := eolW;
+    Texts.OpenReader(R, F.text, loc.org);
+    WHILE pos # lim DO
+      Texts.Read(R, nextCh);
+      Fonts.GetPat(R.fnt, nextCh, dx, u, v, w, h, patadr);
+      IF ox + dx <= x THEN
+        INC(pos); ox := ox + dx;
+        IF pos = lim THEN dx := eolW END
+      ELSE lim := pos
+      END
+    END ;
+    loc.pos := pos; loc.dx := dx; loc.x := ox
+  END LocateChar;
+
+  PROCEDURE LocatePos (F: Frame; pos: LONGINT; VAR loc: Location);
+    VAR T: Texts.Text; R: Texts.Reader; L: Line;
+      org: LONGINT; cury: INTEGER;  
+  BEGIN T := F.text;
+    org := F.org; L := F.trailer.next; cury := F.H - F.top - asr;
+    IF pos < org THEN pos := org END;
+    WHILE (L.next # F.trailer) & (pos >= org + L.len) DO
+      org := org + L.len; L := L.next; cury := cury - lsp
+    END;
+    IF pos >= org + L.len THEN pos := org + L.len - 1 END;    
+    Texts.OpenReader(R, T, org); Texts.Read(R, nextCh);
+    loc.org := org; loc.pos := pos; loc.lin := L;
+    loc.x := F.left + Width(R, pos - org); loc.y := cury
+  END LocatePos;
+
+  PROCEDURE Pos* (F: Frame; X, Y: INTEGER): LONGINT;
+    VAR loc: Location;
+  BEGIN LocateChar(F, X - F.X, Y - F.Y, loc); RETURN loc.pos
+  END Pos;
+
+  PROCEDURE FlipCaret (F: Frame);
+  BEGIN
+    IF (F.carloc.x < F.W) & (F.carloc.y >= 10) & (F.carloc.x + 12 < F.W) THEN
+      Display.CopyPattern(Display.white, Display.hook, F.X + F.carloc.x, F.Y + F.carloc.y - 10, Display.invert)
+    END
+  END FlipCaret;
+
+  PROCEDURE SetCaret* (F: Frame; pos: LONGINT);
+  BEGIN LocatePos(F, pos, F.carloc); FlipCaret(F); F.hasCar := TRUE
+  END SetCaret;
+
+  PROCEDURE TrackCaret* (F: Frame; X, Y: INTEGER; VAR keysum: SET);
+    VAR loc: Location; keys: SET;
+  BEGIN
+    IF F.trailer.next # F.trailer THEN
+      LocateChar(F, X - F.X, Y - F.Y, F.carloc);
+      FlipCaret(F); keysum := {};
+      REPEAT Input.Mouse(keys, X, Y); keysum := keysum + keys;
+        Oberon.DrawMouseArrow(X, Y); LocateChar(F, X - F.X, Y - F.Y, loc);
+        IF loc.pos # F.carloc.pos THEN FlipCaret(F); F.carloc := loc; FlipCaret(F) END
+      UNTIL keys = {};
+      F.hasCar := TRUE
+    END
+  END TrackCaret;
+
+  PROCEDURE RemoveCaret* (F: Frame);
+  BEGIN IF F.hasCar THEN FlipCaret(F); F.hasCar := FALSE END
+  END RemoveCaret;
+
+  PROCEDURE FlipSelection (F: Frame; VAR beg, end: Location);
+    VAR L: Line; Y: INTEGER;
+  BEGIN L := beg.lin; Y := F.Y + beg.y - 2;
+    IF L = end.lin THEN ReplConst(Display.white, F, F.X + beg.x, Y, end.x - beg.x, selH, Display.invert)
+    ELSE
+      ReplConst(Display.white, F, F.X + beg.x, Y, F.left + L.wid - beg.x, selH, Display.invert);
+      L := L.next; Y := Y - lsp;
+      WHILE L # end.lin DO
+        ReplConst(Display.white, F, F.X + F.left, Y, L.wid, selH, Display.invert);
+        L := L.next; Y := Y - lsp
+      END;
+      ReplConst(Display.white, F, F.X + F.left, Y, end.x - F.left, selH, Display.invert)
+    END
+  END FlipSelection;
+
+  PROCEDURE SetSelection* (F: Frame; beg, end: LONGINT);
+  BEGIN
+    IF F.hasSel THEN FlipSelection(F, F.selbeg, F.selend) END;
+    LocatePos(F, beg, F.selbeg); LocatePos(F, end, F.selend);
+    IF F.selbeg.pos < F.selend.pos THEN
+      FlipSelection(F, F.selbeg, F.selend); F.time := Oberon.Time(); F.hasSel := TRUE
+    END
+  END SetSelection;
+
+  PROCEDURE TrackSelection* (F: Frame; X, Y: INTEGER; VAR keysum: SET);
+    VAR loc: Location; keys: SET;
+  BEGIN
+    IF F.trailer.next # F.trailer THEN
+      IF F.hasSel THEN FlipSelection(F, F.selbeg, F.selend) END;
+      LocateChar(F, X - F.X, Y - F.Y, loc);
+      IF F.hasSel & (loc.pos = F.selbeg.pos) & (F.selend.pos = F.selbeg.pos + 1) THEN
+        LocateChar(F, F.left, Y - F.Y, F.selbeg)
+      ELSE F.selbeg := loc
+      END;
+      INC(loc.pos); loc.x := loc.x + loc.dx; F.selend := loc;
+      FlipSelection(F, F.selbeg, F.selend); keysum := {};
+      REPEAT
+        Input.Mouse(keys, X, Y);
+        keysum := keysum + keys;
+        Oberon.DrawMouseArrow(X, Y);
+        LocateChar(F, X - F.X, Y - F.Y, loc);
+        IF loc.pos < F.selbeg.pos THEN loc := F.selbeg END;
+        INC(loc.pos); loc.x := loc.x + loc.dx;
+        IF loc.pos < F.selend.pos THEN FlipSelection(F, loc, F.selend); F.selend := loc
+        ELSIF loc.pos > F.selend.pos THEN FlipSelection(F, F.selend, loc); F.selend := loc
+        END
+      UNTIL keys = {};
+      F.time := Oberon.Time(); F.hasSel := TRUE
+    END
+  END TrackSelection;
+
+  PROCEDURE RemoveSelection* (F: Frame);
+  BEGIN IF F.hasSel THEN FlipSelection(F, F.selbeg, F.selend); F.hasSel := FALSE END
+  END RemoveSelection;
+
+  PROCEDURE TrackLine* (F: Frame; X, Y: INTEGER; VAR org: LONGINT; VAR keysum: SET);
+    VAR old, new: Location; keys: SET;
+  BEGIN
+    IF F.trailer.next # F.trailer THEN
+      LocateLine(F, Y - F.Y, old);
+      ReplConst(Display.white, F, F.X + F.left, F.Y + old.y - dsr, old.lin.wid, 2, Display.invert);
+      keysum := {};
+      REPEAT Input.Mouse(keys, X, Y);
+        keysum := keysum + keys;
+        Oberon.DrawMouse(ScrollMarker, X, Y);
+        LocateLine(F, Y - F.Y, new);
+        IF new.org # old.org THEN
+          ReplConst(Display.white, F, F.X + F.left, F.Y + old.y - dsr, old.lin.wid, 2, Display.invert);
+          ReplConst(Display.white, F, F.X + F.left, F.Y + new.y - dsr, new.lin.wid, 2, Display.invert);
+          old := new
+        END
+       UNTIL keys = {};
+       ReplConst(Display.white, F, F.X + F.left, F.Y + new.y - dsr, new.lin.wid, 2, Display.invert);
+       org := new.org
+    ELSE org := 0   (*<----*)
+    END
+  END TrackLine;
+
+  PROCEDURE TrackWord* (F: Frame; X, Y: INTEGER; VAR pos: LONGINT; VAR keysum: SET);
+    VAR old, new: Location; keys: SET;
+  BEGIN
+    IF F.trailer.next # F.trailer THEN
+      LocateString(F, X - F.X, Y - F.Y, old);
+      ReplConst(Display.white, F, F.X + old.x, F.Y + old.y - dsr, old.dx, 2, Display.invert);
+      keysum := {};
+      REPEAT
+        Input.Mouse(keys, X, Y); keysum := keysum + keys;
+        Oberon.DrawMouseArrow(X, Y);
+        LocateString(F, X - F.X, Y - F.Y, new);
+        IF new.pos # old.pos THEN
+          ReplConst(Display.white, F, F.X + old.x, F.Y + old.y - dsr, old.dx, 2, Display.invert);
+          ReplConst(Display.white, F, F.X + new.x, F.Y + new.y - dsr, new.dx, 2, Display.invert);
+          old := new
+        END
+      UNTIL keys = {};
+      ReplConst(Display.white, F, F.X + new.x, F.Y + new.y - dsr, new.dx, 2, Display.invert);
+      pos := new.pos
+    ELSE pos := 0  (*<----*)
+    END
+  END TrackWord;
+  
+  PROCEDURE Replace* (F: Frame; beg, end: LONGINT);
+    VAR R: Texts.Reader; L: Line;
+      org, len: LONGINT; curY, wid: INTEGER;
+  BEGIN
+    IF end > F.org THEN
+      IF beg < F.org THEN beg := F.org END;
+      org := F.org; L := F.trailer.next; curY := F.Y + F.H - F.top - asr; 
+      WHILE (L # F.trailer) & (org + L.len <= beg) DO
+        org := org + L.len; L := L.next; curY := curY - lsp
+      END;
+      IF L # F.trailer THEN
+        Texts.OpenReader(R, F.text, org); Texts.Read(R, nextCh);
+        len := beg - org; wid := Width(R, len);
+        ReplConst(F.col, F, F.X + F.left + wid, curY - dsr, L.wid - wid, lsp, Display.replace);
+        DisplayLine(F, L, R, F.X + F.left + wid, curY, len);
+        org := org + L.len; L := L.next; curY := curY - lsp;
+        WHILE (L # F.trailer) & (org <= end) DO
+          Display.ReplConst(F.col, F.X + F.left, curY - dsr, F.W - F.left, lsp, Display.replace);
+          DisplayLine(F, L, R, F.X + F.left, curY, 0);
+          org := org + L.len; L := L.next; curY := curY - lsp
+        END
+      END
+    END;
+    UpdateMark(F)
+  END Replace;
+
+  PROCEDURE Insert* (F: Frame; beg, end: LONGINT);
+    VAR R: Texts.Reader; L, L0, l: Line;
+      org, len: LONGINT; curY, botY, Y0, Y1, Y2, dY, wid: INTEGER;
+  BEGIN
+    IF beg < F.org THEN F.org := F.org + (end - beg)
+    ELSE
+      org := F.org; L := F.trailer.next; curY := F.Y + F.H - F.top - asr; 
+      WHILE (L # F.trailer) & (org + L.len <= beg) DO
+        org := org + L.len; L := L.next; curY := curY - lsp
+      END;
+      IF L # F.trailer THEN
+        botY := F.Y + F.bot + dsr;
+        Texts.OpenReader(R, F.text, org); Texts.Read(R, nextCh);
+        len := beg - org; wid := Width(R, len);
+        ReplConst (F.col, F, F.X + F.left + wid, curY - dsr, L.wid - wid, lsp, Display.replace);
+        DisplayLine(F, L, R, F.X + F.left + wid, curY, len);
+        org := org + L.len; curY := curY - lsp;
+        Y0 := curY; L0 := L.next;
+        WHILE (org <= end) & (curY >= botY) DO
+          NEW(l);
+          Display.ReplConst(F.col, F.X + F.left, curY - dsr, F.W - F.left, lsp, Display.replace);
+          DisplayLine(F, l, R, F.X + F.left, curY, 0);
+          L.next := l; L := l;
+          org := org + L.len; curY := curY - lsp
+        END;
+        IF L0 # L.next THEN Y1 := curY;
+          L.next := L0;
+          WHILE (L.next # F.trailer) & (curY >= botY) DO
+            L := L.next; curY := curY - lsp
+          END;
+          L.next := F.trailer;
+          dY := Y0 - Y1;
+          IF Y1 > curY + dY THEN
+            Display.CopyBlock(F.X + F.left, curY + dY + lsp - dsr, F.W - F.left, Y1 - curY - dY,
+              F.X + F.left, curY + lsp - dsr, 0);
+            Y2 := Y1 - dY
+          ELSE Y2 := curY
+          END;
+          curY := Y1; L := L0;
+          WHILE curY # Y2 DO
+            Display.ReplConst(F.col, F.X + F.left, curY - dsr, F.W - F.left, lsp, Display.replace);
+            DisplayLine(F, L, R, F.X + F.left, curY, 0);
+            L := L.next; curY := curY - lsp
+          END
+        END
+      END 
+    END;
+    UpdateMark(F)
+  END Insert;
+
+  PROCEDURE Delete* (F: Frame; beg, end: LONGINT);
+    VAR R: Texts.Reader; L, L0, l: Line;
+      org, org0, len: LONGINT; curY, botY, Y0, Y1, wid: INTEGER;
+  BEGIN
+    IF end <= F.org THEN F.org := F.org - (end - beg)
+    ELSE
+      IF beg < F.org THEN
+        F.trailer.next.len := F.trailer.next.len + (F.org - beg);
+        F.org := beg
+      END;
+      org := F.org; L := F.trailer.next; curY := F.Y + F.H - F.top - asr;
+      WHILE (L # F.trailer) & (org + L.len <= beg) DO
+        org := org + L.len; L := L.next; curY := curY - lsp
+      END;
+      IF L # F.trailer THEN
+        botY := F.Y + F.bot + dsr;
+        org0 := org; L0 := L; Y0 := curY;
+        WHILE (L # F.trailer) & (org <= end) DO
+          org := org + L.len; L := L.next; curY := curY - lsp
+        END;
+        Y1 := curY;
+        Texts.OpenReader(R, F.text, org0); Texts.Read(R, nextCh);
+        len := beg - org0; wid := Width(R, len);
+        ReplConst (F.col, F, F.X + F.left + wid, Y0 - dsr, L0.wid - wid, lsp, Display.replace);
+        DisplayLine(F, L0, R, F.X + F.left + wid, Y0, len);
+        Y0 := Y0 - lsp;
+        IF L # L0.next THEN
+          L0.next := L;
+          L := L0; org := org0 + L0.len;
+          WHILE L.next # F.trailer DO
+            L := L.next; org := org + L.len; curY := curY - lsp
+          END;
+          Display.CopyBlock(F.X + F.left, curY + lsp - dsr, F.W - F.left, Y1 - curY,
+              F.X + F.left, curY + lsp - dsr + (Y0 - Y1), 0);
+          curY := curY + (Y0 - Y1);
+          Display.ReplConst (F.col, F.X + F.left, F.Y, F.W - F.left, curY + lsp - (F.Y + dsr), Display.replace);
+          Texts.OpenReader(R, F.text, org); Texts.Read(R, nextCh);
+          WHILE ~L.eot & (curY >= botY) DO
+            NEW(l);
+            DisplayLine(F, l, R, F.X + F.left, curY, 0);
+            L.next := l; L := l; curY := curY - lsp
+          END;
+          L.next := F.trailer
+        END
+      END
+    END;
+    UpdateMark(F)
+  END Delete;
+
+  PROCEDURE Recall*(VAR B: Texts.Buffer);
+  BEGIN B := TBuf; NEW(TBuf); Texts.OpenBuf(TBuf)
+  END Recall;
+
+  (*------------------message handling------------------------*)
+
+  PROCEDURE RemoveMarks (F: Frame);
+  BEGIN RemoveCaret(F); RemoveSelection(F)
+  END RemoveMarks;
+
+  PROCEDURE NotifyDisplay* (T: Texts.Text; op: INTEGER; beg, end: LONGINT);
+    VAR M: UpdateMsg;
+  BEGIN M.id := op; M.text := T; M.beg := beg; M.end := end; Viewers.Broadcast(M)
+  END NotifyDisplay;
+
+  PROCEDURE Call* (F: Frame; pos: LONGINT; new: BOOLEAN);
+    VAR S: Texts.Scanner; res: INTEGER;
+  BEGIN
+    Texts.OpenScanner(S, F.text, pos); Texts.Scan(S);
+    IF (S.class = Texts.Name) & (S.line = 0) THEN
+      Oberon.SetPar(F, F.text, pos + S.len); Oberon.Call(S.s, res);
+      IF res > 0 THEN
+        Texts.WriteString(W, "Call error: "); Texts.WriteString(W, Modules.importing);
+        IF res = 1 THEN Texts.WriteString(W, " module not found")
+        ELSIF res = 2 THEN  Texts.WriteString(W, " bad version")
+        ELSIF res = 3 THEN Texts.WriteString(W, " imports ");
+          Texts.WriteString(W, Modules.imported); Texts.WriteString(W, " with bad key");
+        ELSIF res = 4 THEN Texts.WriteString(W, " corrupted obj file")
+        ELSIF res = 5 THEN Texts.WriteString(W, " command not found")
+        ELSIF res = 7 THEN Texts.WriteString(W, " insufficient space")
+        END;
+        Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+      END
+    END
+  END Call;
+
+  PROCEDURE Write* (F: Frame; ch: CHAR; fnt: Fonts.Font; col, voff: INTEGER);
+    VAR buf: Texts.Buffer;
+  BEGIN (*F.hasCar*)
+    IF ch = BS THEN  (*backspace*)
+      IF F.carloc.pos > F.org THEN
+        Texts.Delete(F.text, F.carloc.pos - 1, F.carloc.pos, DelBuf); SetCaret(F, F.carloc.pos - 1)
+      END
+    ELSIF ch = 3X THEN (* ctrl-c  copy*)
+      IF F.hasSel THEN
+        NEW(TBuf); Texts.OpenBuf(TBuf); Texts.Save(F.text, F.selbeg.pos, F.selend.pos, TBuf)
+      END
+    ELSIF ch = 16X THEN (*ctrl-v  paste*)
+      NEW(buf); Texts.OpenBuf(buf); Texts.Copy(TBuf, buf); Texts.Insert(F.text, F.carloc.pos, buf);
+      SetCaret(F, F.carloc.pos + TBuf.len)
+    ELSIF ch = 18X THEN (*ctrl-x,  cut*)
+      IF F.hasSel THEN
+        NEW(TBuf); Texts.OpenBuf(TBuf); Texts.Delete(F.text, F.selbeg.pos, F.selend.pos, TBuf)
+      END
+    ELSIF (20X <= ch) & (ch <= DEL) OR (ch = CR) OR (ch = TAB) THEN
+      KW.fnt := fnt; KW.col := col; KW.voff := voff; Texts.Write(KW, ch);
+      Texts.Insert(F.text, F.carloc.pos, KW.buf);
+      SetCaret(F, F.carloc.pos + 1)
+    END
+  END Write;
+
+  PROCEDURE Defocus* (F: Frame);
+  BEGIN RemoveCaret(F)
+  END Defocus;
+
+  PROCEDURE Neutralize* (F: Frame);
+  BEGIN RemoveMarks(F)
+  END Neutralize;
+
+  PROCEDURE Modify* (F: Frame; id, dY, Y, H: INTEGER);
+  BEGIN
+    Mark(F, FALSE); RemoveMarks(F); SetChangeMark(F,  FALSE);
+    IF id = MenuViewers.extend THEN
+      IF dY > 0 THEN Display.CopyBlock(F.X, F.Y, F.W, F.H, F.X, F.Y + dY, 0); F.Y := F.Y + dY END;
+      Extend(F, Y)
+    ELSIF id = MenuViewers.reduce THEN
+      Reduce(F, Y + dY);
+      IF dY > 0 THEN Display.CopyBlock(F.X, F.Y, F.W, F.H, F.X, Y, 0); F.Y := Y END
+    END;
+    IF F.H > 0 THEN Mark(F, TRUE); SetChangeMark(F,  F.text.changed) END
+  END Modify;
+
+  PROCEDURE Open* (F: Frame; H: Display.Handler; T: Texts.Text; org: LONGINT;
+        col, left, right, top, bot, lsp: INTEGER);
+    VAR L: Line;
+  BEGIN NEW(L);
+    L.len := 0; L.wid := 0; L.eot := FALSE; L.next := L;
+    F.handle := H; F.text := T; F.org := org; F.trailer := L;
+    F.left := left; F.right := right; F.top := top; F.bot := bot;
+    F.lsp := lsp; F.col := col; F.hasMark := FALSE; F.hasCar := FALSE; F.hasSel := FALSE
+  END Open;
+
+  PROCEDURE Copy* (F: Frame; VAR F1: Frame);
+  BEGIN NEW(F1);
+    Open(F1, F.handle, F.text, F.org, F.col, F.left, F.right, F.top, F.bot, F.lsp)
+  END Copy;
+
+  PROCEDURE CopyOver(F: Frame; text: Texts.Text; beg, end: LONGINT);
+    VAR buf: Texts.Buffer;
+  BEGIN
+    IF F.hasCar THEN
+      NEW(buf); Texts.OpenBuf(buf);
+      Texts.Save(text, beg, end, buf); Texts.Insert(F.text, F.carloc.pos, buf);
+      SetCaret(F, F.carloc.pos + (end - beg))
+    END
+  END CopyOver;
+
+  PROCEDURE GetSelection* (F: Frame; VAR text: Texts.Text; VAR beg, end, time: LONGINT);
+  BEGIN
+    IF F.hasSel THEN
+      IF F.text = text THEN
+        IF F.selbeg.pos < beg THEN beg := F.selbeg.pos END ;  (*leftmost*)
+        IF F.time > time THEN end := F.selend.pos; time := F.time END ; (*last selected*)
+      ELSIF F.time > time THEN
+        text := F.text; beg := F.selbeg.pos; end := F.selend.pos; time := F.time
+      END
+    END
+  END GetSelection;
+
+  PROCEDURE Update* (F: Frame; VAR M: UpdateMsg);
+  BEGIN (*F.text = M.text*) SetChangeMark(F, FALSE);
+    RemoveMarks(F); Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
+    IF M.id = replace THEN Replace(F, M.beg, M.end)
+    ELSIF M.id = insert THEN Insert(F, M.beg, M.end)
+    ELSIF M.id = delete THEN Delete(F, M.beg, M.end)
+    END ;
+    SetChangeMark(F,  F.text.changed)
+  END Update;
+
+  PROCEDURE Edit* (F: Frame; X, Y: INTEGER; Keys: SET);
+    VAR M: CopyOverMsg;
+      text: Texts.Text;
+      buf: Texts.Buffer;
+      v: Viewers.Viewer;
+      beg, end, time, pos: LONGINT;
+      keysum: SET;
+      fnt: Fonts.Font;
+      col, voff: INTEGER;
+  BEGIN
+    IF X < F.X + Min(F.left, barW) THEN  (*scroll bar*)
+      Oberon.DrawMouse(ScrollMarker, X, Y); keysum := Keys;
+      IF Keys = {2} THEN   (*ML, scroll up*)
+        TrackLine(F, X, Y, pos, keysum);
+        IF (pos >= 0) & (keysum = {2}) THEN
+          SetChangeMark(F, FALSE);
+          RemoveMarks(F); Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
+          Show(F, pos)
+        END
+      ELSIF Keys = {1} THEN   (*MM*)  keysum := Keys;
+        REPEAT Input.Mouse(Keys, X, Y); keysum := keysum + Keys;
+          Oberon.DrawMouse(ScrollMarker, X, Y)
+        UNTIL Keys = {};
+        IF keysum # {0, 1, 2} THEN
+          IF 0 IN keysum THEN pos := 0
+          ELSIF 2 IN keysum THEN pos := F.text.len - 100
+          ELSE pos := (F.Y + F.H - Y) * (F.text.len) DIV F.H
+          END ;
+          SetChangeMark(F, FALSE);
+          RemoveMarks(F); Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
+          Show(F, pos)
+        END
+      ELSIF Keys = {0} THEN   (*MR, scroll down*)
+        TrackLine(F, X, Y, pos, keysum);
+        IF keysum = {0} THEN
+          SetChangeMark(F, FALSE);
+          RemoveMarks(F); Oberon.RemoveMarks(F.X, F.Y, F.W, F.H);
+          Show(F, F.org*2 - pos - 100)
+        END
+      END
+    ELSE  (*text area*)
+      Oberon.DrawMouseArrow(X, Y);
+      IF 0 IN Keys THEN  (*MR: select*)
+        TrackSelection(F, X, Y, keysum);
+        IF F.hasSel THEN
+          IF keysum = {0, 2} THEN (*MR, ML: delete text*)
+            Oberon.GetSelection(text, beg, end, time);
+            Texts.Delete(text, beg, end, TBuf);
+            Oberon.PassFocus(Viewers.This(F.X, F.Y)); SetCaret(F, beg)
+          ELSIF keysum = {0, 1} THEN  (*MR, MM: copy to caret*)
+            Oberon.GetSelection(text, beg, end, time);
+            M.text := text; M.beg := beg; M.end := end;
+            Oberon.FocusViewer.handle(Oberon.FocusViewer, M)
+          END
+        END
+      ELSIF 1 IN Keys THEN  (*MM: call*)
+        TrackWord(F, X, Y, pos, keysum);
+        IF (pos >= 0) & ~(0 IN keysum) THEN Call(F, pos, 2 IN keysum) END
+      ELSIF 2 IN Keys THEN  (*ML: set caret*)
+        Oberon.PassFocus(Viewers.This(F.X, F.Y));
+        TrackCaret(F, X, Y, keysum);
+        IF keysum = {2, 1} THEN (*ML, MM: copy from selection to caret*)
+          Oberon.GetSelection(text, beg, end, time);
+           IF time >= 0 THEN
+            NEW(TBuf); Texts.OpenBuf(TBuf);
+            Texts.Save(text, beg, end, TBuf); Texts.Insert(F.text, F.carloc.pos, TBuf);
+            SetSelection(F, F.carloc.pos, F.carloc.pos + (end  - beg));
+            SetCaret(F, F.carloc.pos + (end - beg))
+          ELSIF TBuf # NIL THEN
+            NEW(buf); Texts.OpenBuf(buf);
+            Texts.Copy(TBuf, buf); Texts.Insert(F.text, F.carloc.pos, buf);
+            SetCaret(F, F.carloc.pos + buf.len)
+          END
+        ELSIF keysum = {2, 0} THEN (*ML, MR: copy looks*)
+          Oberon.GetSelection(text, beg, end, time);
+          IF time >= 0 THEN
+            Texts.Attributes(F.text, F.carloc.pos, fnt, col, voff);
+            IF fnt # NIL THEN Texts.ChangeLooks(text, beg, end, {0,1,2}, fnt, col, voff) END
+          END
+        END
+      END
+    END
+  END Edit;
+
+  PROCEDURE Handle* (F: Display.Frame; VAR M: Display.FrameMsg);
+    VAR F1: Frame; buf: Texts.Buffer;
+  BEGIN
+    CASE F OF Frame:
+      CASE M OF
+      Oberon.InputMsg:
+        IF M.id = Oberon.track THEN Edit(F, M.X, M.Y, M.keys)
+        ELSIF M.id = Oberon.consume THEN
+          IF F.hasCar THEN Write(F, M.ch, M.fnt, M.col, M.voff) END
+        END |
+      Oberon.ControlMsg:
+        IF M.id = Oberon.defocus THEN Defocus(F)
+        ELSIF M.id = Oberon.neutralize THEN Neutralize(F)
+        END |
+      Oberon.SelectionMsg:
+        GetSelection(F, M.text, M.beg, M.end, M.time) |
+      Oberon.CopyMsg: Copy(F, F1); M.F := F1 |
+      MenuViewers.ModifyMsg: Modify(F, M.id, M.dY, M.Y, M.H) |
+      CopyOverMsg: CopyOver(F, M.text, M.beg, M.end) |
+      UpdateMsg: IF F.text = M.text THEN Update(F, M) END
+      END
+    END
+  END Handle;
+
+  (*creation*)
+
+  PROCEDURE Menu (name, commands: ARRAY OF CHAR): Texts.Text;
+    VAR T: Texts.Text;
+  BEGIN NEW(T); T.notify := NotifyDisplay;  Texts.Open(T, "");
+    Texts.WriteString(W, name); Texts.WriteString(W, " | ");  Texts.WriteString(W, commands);
+    Texts.Append(T, W.buf); RETURN T
+  END Menu;
+
+  PROCEDURE Text* (name: ARRAY OF CHAR): Texts.Text;
+    VAR T: Texts.Text;
+  BEGIN NEW(T); T.notify := NotifyDisplay; Texts.Open(T, name); RETURN T
+  END Text;
+
+  PROCEDURE NewMenu* (name, commands: ARRAY OF CHAR): Frame;
+    VAR F: Frame; T: Texts.Text;
+  BEGIN NEW(F); T := Menu(name, commands);
+    Open(F, Handle, T, 0, Display.white, left DIV 4, 0, 0, 0, lsp); RETURN F
+  END NewMenu;
+
+  PROCEDURE NewText* (text: Texts.Text; pos: LONGINT): Frame;
+    VAR F: Frame;
+  BEGIN NEW(F);
+    Open(F, Handle, text, pos, Display.black, left, right, top, bot, lsp); RETURN F
+  END NewText;
+
+BEGIN NEW(TBuf); NEW(DelBuf);
+  Texts.OpenBuf(TBuf); Texts.OpenBuf(DelBuf);
+  lsp := Fonts.Default.height; menuH := lsp + 2; barW := menuH;
+  left := barW + lsp DIV 2;
+  right := lsp DIV 2;
+  top := lsp DIV 2; bot := lsp DIV 2;
+  asr := Fonts.Default.maxY;
+  dsr := -Fonts.Default.minY;
+  selH := lsp; markW := lsp DIV 2;
+  eolW := lsp DIV 2;
+  ScrollMarker.Fade := FlipSM; ScrollMarker.Draw := FlipSM;
+  Texts.OpenWriter(W); Texts.OpenWriter(KW)
+END TextFrames.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Texts.Mod.txt

@@ -1,534 +1,534 @@
-MODULE Texts; (*JG 21.11.90 / NW 11.7.90 / 24.12.95 / 22.11.10 / 18.11.2014 / 7.1.2019*)
-  IMPORT Files, Fonts;
-
-  CONST (*scanner symbol classes*)
-    Inval* = 0;         (*invalid symbol*)
-    Name* = 1;          (*name s (length len)*)
-    String* = 2;        (*literal string s (length len)*)
-    Int* = 3;           (*integer i (decimal or hexadecimal)*)
-    Real* = 4;          (*real number x*)
-    Char* = 6;          (*special character c*)
-
-    (* TextBlock = TextTag "1" offset run {run} "0" len {AsciiCode}.
-      run = fnt [name] col voff len. *)
-
-    TAB = 9X; CR = 0DX; maxD = 9;
-    TextTag = 0F1X;
-    replace* = 0; insert* = 1; delete* = 2; unmark* = 3;  (*op-codes*)
-
-  TYPE Piece = POINTER TO PieceDesc;
-    PieceDesc = RECORD
-      f: Files.File;
-      off, len: LONGINT;
-      fnt: Fonts.Font;
-      col, voff: INTEGER;
-      prev, next: Piece
-    END;
-
-    Text* = POINTER TO TextDesc;
-    Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT);
-    TextDesc* = RECORD
-      len*: LONGINT;
-      changed*: BOOLEAN;
-      notify*: Notifier;
-      trailer: Piece;
-      pce: Piece;  (*cache*)
-      org: LONGINT; (*cache*)
-    END;
-
-    Reader* = RECORD
-      eot*: BOOLEAN;
-      fnt*: Fonts.Font;
-      col*, voff*: INTEGER;
-      ref: Piece;
-      org: LONGINT;
-      off: LONGINT;
-      rider: Files.Rider
-    END;
-
-    Scanner* = RECORD (Reader)
-      nextCh*: CHAR;
-      line*, class*: INTEGER;
-      i*: LONGINT;
-      x*: REAL;
-      y*: LONGREAL;
-      c*: CHAR;
-      len*: INTEGER;
-      s*: ARRAY 32 OF CHAR
-    END;
-
-    Buffer* = POINTER TO BufDesc;
-    BufDesc* = RECORD
-      len*: LONGINT;
-      header, last: Piece
-    END;
-
-    Writer* = RECORD
-      buf*: Buffer;
-      fnt*: Fonts.Font;
-      col*, voff*: INTEGER;
-      rider: Files.Rider
-    END;     
-
-  VAR TrailerFile: Files.File;
-
-  (* -------------------- Filing ------------------------*)
-
-  PROCEDURE Trailer(): Piece;
-    VAR Q: Piece;
-  BEGIN NEW(Q);
-    Q.f := TrailerFile; Q.off := -1; Q.len := 1; Q.fnt := NIL; Q.col := 0; Q.voff := 0; RETURN Q
-  END Trailer;
-
-  PROCEDURE Load* (VAR R: Files.Rider; T: Text);
-    VAR Q, q, p: Piece;
-      off: LONGINT;
-      N, fno: INTEGER; bt: BYTE;
-      f: Files.File;
-      FName: ARRAY 32 OF CHAR;
-      Dict: ARRAY 32 OF Fonts.Font;
-  BEGIN f := Files.Base(R); N := 1; Q := Trailer(); p := Q;
-    Files.ReadInt(R, off); Files.ReadByte(R, bt); fno := bt;
-    WHILE fno # 0 DO
-      IF fno = N THEN
-        Files.ReadString(R, FName);
-        Dict[N] := Fonts.This(FName); INC(N)
-      END;
-      NEW(q); q.fnt := Dict[fno];
-      Files.ReadByte(R, bt); q.col := bt;
-      Files.ReadByte(R, bt); q.voff := ASR(LSL(bt, -24), 24);
-      Files.ReadInt(R, q.len);
-      Files.ReadByte(R, bt); fno := bt;
-      q.f := f; q.off := off; off := off + q.len;
-      p.next := q; q.prev := p; p := q
-    END;
-    p.next := Q; Q.prev := p;
-    T.trailer := Q; Files.ReadInt(R, T.len); (*Files.Set(R, f, Files.Pos(R) + T.len)*)
-  END Load;
-
-  PROCEDURE Open* (T: Text; name: ARRAY OF CHAR);
-    VAR f: Files.File; R: Files.Rider; Q, q: Piece;
-      tag: CHAR; len: LONGINT;
-  BEGIN f := Files.Old(name);
-    IF f # NIL THEN
-      Files.Set(R, f, 0); Files.Read(R, tag); 
-      IF tag = TextTag THEN Load(R, T)
-      ELSE (*Ascii file*)
-        len := Files.Length(f); Q := Trailer();
-        NEW(q); q.fnt := Fonts.Default; q.col := 1; q.voff := 0; q.f := f; q.off := 0; q.len := len;
-        Q.next := q; q.prev := Q; q.next := Q; Q.prev := q; T.trailer := Q; T.len := len
-      END
-    ELSE (*create new text*)
-      Q := Trailer(); Q.next := Q; Q.prev := Q; T.trailer := Q; T.len := 0
-    END ;
-    T.changed := FALSE; T.org := -1; T.pce := T.trailer (*init cache*)
-  END Open;
-
-  PROCEDURE Store* (VAR W: Files.Rider; T: Text);
-    VAR p, q: Piece;
-      R: Files.Rider;
-      off, rlen, pos: LONGINT;
-      N, n: INTEGER;
-      ch: CHAR;
-      Dict: ARRAY 32, 32 OF CHAR;
-  BEGIN pos := Files.Pos(W); Files.WriteInt(W, 0); (*place holder*)
-    N := 1; p := T.trailer.next;
-    WHILE p # T.trailer DO
-      rlen := p.len; q := p.next;
-      WHILE (q # T.trailer) & (q.fnt = p.fnt) & (q.col = p.col) & (q.voff = p.voff) DO
-        rlen := rlen + q.len; q := q.next
-      END;
-      Dict[N] := p.fnt.name;
-      n := 1;
-      WHILE Dict[n] # p.fnt.name DO INC(n) END;
-      Files.WriteByte(W, n);
-      IF n = N THEN Files.WriteString(W, p.fnt.name); INC(N) END;
-      Files.WriteByte(W, p.col); Files.WriteByte(W, p.voff); Files.WriteInt(W, rlen);
-      p := q
-    END;
-    Files.WriteByte(W, 0); Files.WriteInt(W, T.len);
-    off := Files.Pos(W); p := T.trailer.next;
-    WHILE p # T.trailer DO
-      rlen := p.len; Files.Set(R, p.f, p.off);
-      WHILE rlen > 0 DO Files.Read(R, ch); Files.Write(W, ch); DEC(rlen) END ;
-      p := p.next
-    END ;
-    Files.Set(W, Files.Base(W), pos); Files.WriteInt(W, off); (*fixup*)
-    T.changed := FALSE;
-    IF T.notify # NIL THEN T.notify(T, unmark, 0, 0) END
-  END Store;
-
-  PROCEDURE Close*(T: Text; name: ARRAY OF CHAR);
-    VAR f: Files.File; w: Files.Rider;
-  BEGIN f := Files.New(name); Files.Set(w, f, 0);
-    Files.Write(w, TextTag); Store(w, T); Files.Register(f)
-  END Close;
-
-  (* -------------------- Editing ----------------------- *)
-
-  PROCEDURE OpenBuf* (B: Buffer);
-  BEGIN NEW(B.header); (*null piece*)
-    B.last := B.header; B.len := 0
-  END OpenBuf;
-
-  PROCEDURE FindPiece (T: Text; pos: LONGINT; VAR org: LONGINT; VAR pce: Piece);
-    VAR p: Piece; porg: LONGINT;
-  BEGIN p := T.pce; porg := T.org;
-    IF pos >= porg THEN
-      WHILE pos >= porg + p.len DO INC(porg, p.len); p := p.next END
-    ELSE p := p.prev; DEC(porg, p.len);
-      WHILE pos < porg DO p := p.prev; DEC(porg, p.len) END
-    END ;
-    T.pce := p; T.org := porg;  (*update cache*)
-    pce := p; org := porg
-  END FindPiece;
-
-  PROCEDURE SplitPiece (p: Piece; off: LONGINT; VAR pr: Piece);
-    VAR q: Piece;
-  BEGIN
-    IF off > 0 THEN NEW(q);
-      q.fnt := p.fnt; q.col := p.col; q.voff := p.voff;
-      q.len := p.len - off;
-      q.f := p.f; q.off := p.off + off;
-      p.len := off;
-      q.next := p.next; p.next := q;
-      q.prev := p; q.next.prev := q;
-      pr := q
-    ELSE pr := p
-    END
-  END SplitPiece;
-
-  PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer);
-    VAR p, q, qb, qe: Piece; org: LONGINT;
-  BEGIN
-    IF end > T.len THEN end := T.len END;
-    FindPiece(T, beg, org, p);
-    NEW(qb); qb^ := p^;
-    qb.len := qb.len - (beg - org);
-    qb.off := qb.off + (beg - org);
-    qe := qb;
-    WHILE end > org + p.len DO 
-      org := org + p.len; p := p.next;
-      NEW(q); q^ := p^; qe.next := q; q.prev := qe; qe := q
-    END;
-    qe.next := NIL; qe.len := qe.len - (org + p.len - end);
-    B.last.next := qb; qb.prev := B.last; B.last := qe;
-    B.len := B.len + (end - beg)
-  END Save;
-
-  PROCEDURE Copy* (SB, DB: Buffer);
-    VAR Q, q, p: Piece;
-  BEGIN p := SB.header; Q := DB.last;
-    WHILE p # SB.last DO p := p.next;
-      NEW(q); q^ := p^; Q.next := q; q.prev := Q; Q := q
-    END;
-    DB.last := Q; DB.len := DB.len + SB.len
-  END Copy;
-
-  PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer);
-    VAR pl, pr, p, qb, qe: Piece; org, end: LONGINT;
-  BEGIN
-    FindPiece(T, pos, org, p); SplitPiece(p, pos - org, pr);
-    IF T.org >= org THEN T.org := org - p.prev.len; T.pce := p.prev END ;
-    pl := pr.prev; qb := B.header.next;
-    IF (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len)
-        & (qb.fnt = pl.fnt) & (qb.col = pl.col) & (qb.voff = pl.voff) THEN
-      pl.len := pl.len + qb.len; qb := qb.next
-    END;
-    IF qb # NIL THEN qe := B.last;
-      qb.prev := pl; pl.next := qb; qe.next := pr; pr.prev := qe
-    END;
-    T.len := T.len + B.len; end := pos + B.len;
-    B.last := B.header; B.last.next := NIL; B.len := 0;
-    T.changed := TRUE;
-    IF T.notify # NIL THEN  T.notify(T, insert, pos, end) END
-  END Insert;
-
-  PROCEDURE Append* (T: Text; B: Buffer);
-  BEGIN Insert(T, T.len, B)
-  END Append;
-
-  PROCEDURE Delete* (T: Text; beg, end: LONGINT; B: Buffer);
-    VAR pb, pe, pbr, per: Piece; orgb, orge: LONGINT;
-  BEGIN
-    IF end > T.len THEN end := T.len END;
-    FindPiece(T, beg, orgb, pb); SplitPiece(pb, beg - orgb, pbr);
-    FindPiece(T, end, orge, pe);
-    SplitPiece(pe, end - orge, per);
-    IF T.org >= orgb THEN (*adjust cache*)
-      T.org := orgb - pb.prev.len; T.pce := pb.prev
-    END;
-    B.header.next := pbr; B.last := per.prev;
-    B.last.next := NIL; B.len := end - beg;
-    per.prev := pbr.prev; pbr.prev.next := per;
-    T.len := T.len - B.len;
-    T.changed := TRUE;
-    IF T.notify # NIL THEN T.notify(T, delete, beg, end) END
-  END Delete;
-
-  PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: Fonts.Font; col, voff: INTEGER);
-    VAR pb, pe, p: Piece; org: LONGINT;
-  BEGIN
-    IF end > T.len THEN end := T.len END;
-    FindPiece(T, beg, org, p); SplitPiece(p, beg - org, pb);
-    FindPiece(T, end, org, p); SplitPiece(p, end - org, pe);
-    p := pb;
-    REPEAT
-      IF 0 IN sel THEN p.fnt := fnt END;
-      IF 1 IN sel THEN p.col := col END;
-      IF 2 IN sel THEN p.voff := voff END;
-      p := p.next
-    UNTIL p = pe;
-    T.changed := TRUE;
-    IF T.notify # NIL THEN T.notify(T, replace, beg, end) END
-  END ChangeLooks;
-
-  PROCEDURE Attributes*(T: Text; pos: LONGINT; VAR fnt: Fonts.Font; VAR col, voff: INTEGER);
-    VAR p: Piece; org: LONGINT;
-  BEGIN FindPiece(T, pos, org, p); fnt := p.fnt; col := p.col; voff := p.voff
-  END Attributes;
-
-  (* ------------------ Access: Readers ------------------------- *)
-
-  PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
-    VAR p: Piece; org: LONGINT;
-  BEGIN FindPiece(T, pos, org, p);
-    R.ref := p; R.org := org; R.off := pos - org;
-    Files.Set(R.rider, p.f, p.off + R.off); R.eot := FALSE
-  END OpenReader;
-
-  PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR);
-  BEGIN Files.Read(R.rider, ch);
-    R.fnt := R.ref.fnt; R.col := R.ref.col; R.voff := R.ref.voff;
-    INC(R.off);
-    IF R.off = R.ref.len THEN
-      IF R.ref.f = TrailerFile THEN R.eot := TRUE END;
-      R.ref := R.ref.next; R.org := R.org + R.off; R.off := 0;
-      Files.Set(R.rider, R.ref.f, R.ref.off)
-    END
-  END Read;
-
-  PROCEDURE Pos* (VAR R: Reader): LONGINT;
-  BEGIN RETURN R.org + R.off
-  END Pos;  
-
-  (* ------------------ Access: Scanners (NW) ------------------------- *)
-
-  PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
-  BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " "
-  END OpenScanner;
-
-  (*floating point formats:
-    x = 1.m * 2^(e-127)   bit 0: sign, bits 1- 8: e, bits  9-31: m
-    x = 1.m * 2^(e-1023)  bit 0: sign, bits 1-11: e, bits 12-63: m *)
-
-  PROCEDURE Ten(n: INTEGER): REAL;
-    VAR t, p: REAL;
-  BEGIN t := 1.0; p := 10.0;   (*compute 10^n *)
-    WHILE n > 0 DO
-      IF ODD(n) THEN t := p * t END ;
-      p := p*p; n := n DIV 2
-    END ;
-    RETURN t
-  END Ten;
-
-  PROCEDURE Scan* (VAR S: Scanner);
-    CONST maxExp = 38; maxM = 16777216; (*2^24*)
-    VAR ch, term: CHAR;
-      neg, negE, hex: BOOLEAN;
-      i, j, h, d, e, n, s: INTEGER;
-      k: LONGINT;
-      x: REAL;
-  BEGIN ch := S.nextCh; i := 0;
-    WHILE (ch = " ") OR (ch = TAB) OR (ch = CR) DO
-      IF ch = CR THEN INC(S.line) END ;
-      Read(S, ch)
-    END ;
-    IF ("A" <= ch) & (ch <= "Z") OR ("a" <= ch) & (ch <= "z") THEN (*name*)
-      REPEAT S.s[i] := ch; INC(i); Read(S, ch)
-      UNTIL ((ch < "0") & (ch # ".") OR ("9" < ch) & (ch < "A") OR ("Z" < ch) & (ch < "a") OR ("z" < ch)) OR (i = 31);
-      S.s[i] := 0X; S.len := i; S.class := Name
-    ELSIF ch = 22X THEN (*string*)
-      Read(S, ch);
-      WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO S.s[i] := ch; INC(i); Read(S, ch) END;
-      S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := String
-    ELSE hex := FALSE;
-      IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ;
-      IF ("0" <= ch) & (ch <= "9") THEN (*number*)
-        n := ORD(ch) - 30H; h := n; Read(S, ch);
-        WHILE ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") DO
-          IF ch <= "9" THEN d := ORD(ch) - 30H ELSE d := ORD(ch) - 37H; hex := TRUE END ;
-          n := 10*n + d; h := 10H*h + d; Read(S, ch)
-        END ;
-        IF ch = "H" THEN (*hex integer*) Read(S, ch); S.i := h; S.class := Int  (*neg?*)
-        ELSIF ch = "." THEN (*real number*)
-          Read(S, ch); x := 0.0; e := 0; j := 0;
-          WHILE ("0" <= ch) & (ch <= "9") DO  (*fraction*)
-            h := 10*n + (ORD(ch) - 30H);
-            IF h < maxM THEN n := h; INC(j) END ;
-            Read(S, ch)
-          END ;
-          IF ch = "E" THEN (*scale factor*)
-            s := 0; Read(S, ch);
-            IF ch = "-" THEN negE := TRUE; Read(S, ch)
-            ELSE negE := FALSE;
-              IF ch = "+" THEN Read(S, ch) END
-            END ;
-            WHILE ("0" <= ch) & (ch <= "9") DO
-              s := s*10 + ORD(ch) - 30H; Read(S, ch)
-            END ;
-            IF negE THEN DEC(e, s) ELSE INC(e, s) END ;
-          END ;
-          x := FLT(n); DEC(e, j);
-          IF e < 0 THEN
-            IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END
-          ELSIF e > 0 THEN
-            IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0 END
-          END ;
-          IF neg THEN S.x := -x ELSE S.x := x END ;
-          IF hex THEN S.class := 0 ELSE S.class := Real END
-        ELSE (*decimal integer*)
-          IF neg THEN S.i := -n ELSE S.i := n END;
-          IF hex THEN S.class := Inval ELSE S.class := Int END
-        END
-      ELSE (*spectal character*) S.class := Char;
-        IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END
-      END
-    END ;
-    S.nextCh := ch
-  END Scan;
-
-  (* --------------- Access: Writers (NW) ------------------ *)
-
-  PROCEDURE OpenWriter* (VAR W: Writer);
-  BEGIN NEW(W.buf);
-    OpenBuf(W.buf); W.fnt := Fonts.Default; W.col := 15; W.voff := 0;
-    Files.Set(W.rider, Files.New(""), 0)
-  END OpenWriter;
-
-  PROCEDURE SetFont* (VAR W: Writer; fnt: Fonts.Font);
-  BEGIN W.fnt := fnt
-  END SetFont;
-
-  PROCEDURE SetColor* (VAR W: Writer; col: INTEGER);
-  BEGIN W.col := col
-  END SetColor;
-
-  PROCEDURE SetOffset* (VAR W: Writer; voff: INTEGER);
-  BEGIN W.voff := voff
-  END SetOffset;
-
-  PROCEDURE Write* (VAR W: Writer; ch: CHAR);
-    VAR p: Piece;
-  BEGIN
-    IF (W.buf.last.fnt # W.fnt) OR (W.buf.last.col # W.col) OR (W.buf.last.voff # W.voff) THEN
-      NEW(p); p.f := Files.Base(W.rider); p.off := Files.Pos(W.rider); p.len := 0;
-      p.fnt := W.fnt; p.col := W.col; p.voff:= W.voff;
-      p.next := NIL; W.buf.last.next := p;
-      p.prev := W.buf.last; W.buf.last := p
-    END;
-    Files.Write(W.rider, ch);
-    INC(W.buf.last.len); INC(W.buf.len)
-  END Write;
-
-  PROCEDURE WriteLn* (VAR W: Writer);
-  BEGIN Write(W, CR)
-  END WriteLn;
-
-  PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR);
-    VAR i: INTEGER;
-  BEGIN i := 0;
-    WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END
-  END WriteString;
-
-  PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT);
-    VAR i: INTEGER; x0: LONGINT;
-      a: ARRAY 10 OF CHAR;
-  BEGIN
-    IF ROR(x, 31) = 1 THEN WriteString(W, " -2147483648")
-    ELSE i := 0;
-      IF x < 0 THEN DEC(n); x0 := -x ELSE x0 := x END;
-      REPEAT
-        a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i)
-      UNTIL x0 = 0;
-      WHILE n > i DO Write(W, " "); DEC(n) END;
-      IF x < 0 THEN Write(W, "-") END;
-      REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
-    END
-  END WriteInt;
-
-  PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
-    VAR i: INTEGER; y: LONGINT;
-      a: ARRAY 10 OF CHAR;
-  BEGIN i := 0; Write(W, " ");
-    REPEAT y := x MOD 10H;
-      IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
-      x := x DIV 10H; INC(i)
-    UNTIL i = 8;
-    REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
-  END WriteHex;
-
- PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER);
-    VAR e, i, m: INTEGER;
-      d: ARRAY 16 OF CHAR;
-  BEGIN e := ASR(ORD(x), 23) MOD 100H;  (*binary exponent*)
-    IF e = 0 THEN
-      WriteString(W, "  0 ");
-      WHILE n >= 3 DO Write(W, " "); DEC(n) END
-    ELSIF e = 255 THEN WriteString(W, " NaN ")
-    ELSE Write(W, " ");
-      WHILE n >= 15 DO DEC(n); Write(W, " ") END ;
-      (* 2 < n < 9 digits to be written*)
-      IF x < 0.0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END ;
-      e := (e - 127) * 77 DIV 256 - 6;  (*decimal exponent*)
-      IF e >= 0 THEN x := x / Ten(e) ELSE x := Ten(-e) * x END ;
-      m := FLOOR(x + 0.5); i := 0;
-      IF m >= 10000000 THEN INC(e); m := m DIV 10 END ;
-      REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0;
-      DEC(i); Write(W, d[i]); Write(W, ".");
-      IF i < n-7 THEN n := 0 ELSE n := 14 - n END ;
-      WHILE i > n DO DEC(i); Write(W, d[i]) END ;
-      Write(W, "E"); INC(e, 6);
-       IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END ;
-      Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H))
-    END
-  END WriteReal;
-
-  PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER);
-    VAR i, m: INTEGER; neg: BOOLEAN;
-      d: ARRAY 12 OF CHAR;
-  BEGIN
-    IF x = 0.0 THEN WriteString(W, "  0")
-    ELSE
-      IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ;
-      IF k > 7 THEN k := 7 END ;
-      x := Ten(k) * x; m := FLOOR(x + 0.5);
-      i := 0;
-      REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0;
-      Write(W, " ");
-      WHILE n > i+3 DO  Write(W, " "); DEC(n) END ;
-      IF neg THEN Write(W, "-"); DEC(n) ELSE Write(W, " ") END ;
-      WHILE i > k DO DEC(i); Write(W, d[i]) END ;
-      Write(W, ".");
-      WHILE k > i DO DEC(k); Write(W, "0") END ;
-      WHILE i > 0 DO DEC(i); Write(W, d[i]) END
-    END
-  END WriteRealFix;
-
-  PROCEDURE WritePair(VAR W: Writer; ch: CHAR; x: LONGINT);
-  BEGIN Write(W, ch);
-    Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H))
-  END WritePair;
-
-  PROCEDURE WriteClock* (VAR W: Writer; d: LONGINT);
-  BEGIN
-    WritePair(W, " ", d DIV 20000H MOD 20H);   (*day*)
-    WritePair(W, ".", d DIV 400000H MOD 10H); (*month*)
-    WritePair(W, ".", d DIV 4000000H MOD 40H);   (*year*)
-    WritePair(W, " ", d DIV 1000H MOD 20H);   (*hour*)
-    WritePair(W, ":", d DIV 40H MOD 40H);  (*min*)
-    WritePair(W, ":", d MOD 40H)  (*sec*)
-  END WriteClock;
-
-BEGIN TrailerFile := Files.New("")
-END Texts.
+MODULE Texts; (*JG 21.11.90 / NW 11.7.90 / 24.12.95 / 22.11.10 / 18.11.2014 / 7.1.2019*)
+  IMPORT Files, Fonts;
+
+  CONST (*scanner symbol classes*)
+    Inval* = 0;         (*invalid symbol*)
+    Name* = 1;          (*name s (length len)*)
+    String* = 2;        (*literal string s (length len)*)
+    Int* = 3;           (*integer i (decimal or hexadecimal)*)
+    Real* = 4;          (*real number x*)
+    Char* = 6;          (*special character c*)
+
+    (* TextBlock = TextTag "1" offset run {run} "0" len {AsciiCode}.
+      run = fnt [name] col voff len. *)
+
+    TAB = 9X; CR = 0DX; maxD = 9;
+    TextTag = 0F1X;
+    replace* = 0; insert* = 1; delete* = 2; unmark* = 3;  (*op-codes*)
+
+  TYPE Piece = POINTER TO PieceDesc;
+    PieceDesc = RECORD
+      f: Files.File;
+      off, len: LONGINT;
+      fnt: Fonts.Font;
+      col, voff: INTEGER;
+      prev, next: Piece
+    END;
+
+    Text* = POINTER TO TextDesc;
+    Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT);
+    TextDesc* = RECORD
+      len*: LONGINT;
+      changed*: BOOLEAN;
+      notify*: Notifier;
+      trailer: Piece;
+      pce: Piece;  (*cache*)
+      org: LONGINT; (*cache*)
+    END;
+
+    Reader* = RECORD
+      eot*: BOOLEAN;
+      fnt*: Fonts.Font;
+      col*, voff*: INTEGER;
+      ref: Piece;
+      org: LONGINT;
+      off: LONGINT;
+      rider: Files.Rider
+    END;
+
+    Scanner* = RECORD (Reader)
+      nextCh*: CHAR;
+      line*, class*: INTEGER;
+      i*: LONGINT;
+      x*: REAL;
+      y*: LONGREAL;
+      c*: CHAR;
+      len*: INTEGER;
+      s*: ARRAY 32 OF CHAR
+    END;
+
+    Buffer* = POINTER TO BufDesc;
+    BufDesc* = RECORD
+      len*: LONGINT;
+      header, last: Piece
+    END;
+
+    Writer* = RECORD
+      buf*: Buffer;
+      fnt*: Fonts.Font;
+      col*, voff*: INTEGER;
+      rider: Files.Rider
+    END;     
+
+  VAR TrailerFile: Files.File;
+
+  (* -------------------- Filing ------------------------*)
+
+  PROCEDURE Trailer(): Piece;
+    VAR Q: Piece;
+  BEGIN NEW(Q);
+    Q.f := TrailerFile; Q.off := -1; Q.len := 1; Q.fnt := NIL; Q.col := 0; Q.voff := 0; RETURN Q
+  END Trailer;
+
+  PROCEDURE Load* (VAR R: Files.Rider; T: Text);
+    VAR Q, q, p: Piece;
+      off: LONGINT;
+      N, fno: INTEGER; bt: BYTE;
+      f: Files.File;
+      FName: ARRAY 32 OF CHAR;
+      Dict: ARRAY 32 OF Fonts.Font;
+  BEGIN f := Files.Base(R); N := 1; Q := Trailer(); p := Q;
+    Files.ReadInt(R, off); Files.ReadByte(R, bt); fno := bt;
+    WHILE fno # 0 DO
+      IF fno = N THEN
+        Files.ReadString(R, FName);
+        Dict[N] := Fonts.This(FName); INC(N)
+      END;
+      NEW(q); q.fnt := Dict[fno];
+      Files.ReadByte(R, bt); q.col := bt;
+      Files.ReadByte(R, bt); q.voff := ASR(LSL(bt, -24), 24);
+      Files.ReadInt(R, q.len);
+      Files.ReadByte(R, bt); fno := bt;
+      q.f := f; q.off := off; off := off + q.len;
+      p.next := q; q.prev := p; p := q
+    END;
+    p.next := Q; Q.prev := p;
+    T.trailer := Q; Files.ReadInt(R, T.len); (*Files.Set(R, f, Files.Pos(R) + T.len)*)
+  END Load;
+
+  PROCEDURE Open* (T: Text; name: ARRAY OF CHAR);
+    VAR f: Files.File; R: Files.Rider; Q, q: Piece;
+      tag: CHAR; len: LONGINT;
+  BEGIN f := Files.Old(name);
+    IF f # NIL THEN
+      Files.Set(R, f, 0); Files.Read(R, tag); 
+      IF tag = TextTag THEN Load(R, T)
+      ELSE (*Ascii file*)
+        len := Files.Length(f); Q := Trailer();
+        NEW(q); q.fnt := Fonts.Default; q.col := 1; q.voff := 0; q.f := f; q.off := 0; q.len := len;
+        Q.next := q; q.prev := Q; q.next := Q; Q.prev := q; T.trailer := Q; T.len := len
+      END
+    ELSE (*create new text*)
+      Q := Trailer(); Q.next := Q; Q.prev := Q; T.trailer := Q; T.len := 0
+    END ;
+    T.changed := FALSE; T.org := -1; T.pce := T.trailer (*init cache*)
+  END Open;
+
+  PROCEDURE Store* (VAR W: Files.Rider; T: Text);
+    VAR p, q: Piece;
+      R: Files.Rider;
+      off, rlen, pos: LONGINT;
+      N, n: INTEGER;
+      ch: CHAR;
+      Dict: ARRAY 32, 32 OF CHAR;
+  BEGIN pos := Files.Pos(W); Files.WriteInt(W, 0); (*place holder*)
+    N := 1; p := T.trailer.next;
+    WHILE p # T.trailer DO
+      rlen := p.len; q := p.next;
+      WHILE (q # T.trailer) & (q.fnt = p.fnt) & (q.col = p.col) & (q.voff = p.voff) DO
+        rlen := rlen + q.len; q := q.next
+      END;
+      Dict[N] := p.fnt.name;
+      n := 1;
+      WHILE Dict[n] # p.fnt.name DO INC(n) END;
+      Files.WriteByte(W, n);
+      IF n = N THEN Files.WriteString(W, p.fnt.name); INC(N) END;
+      Files.WriteByte(W, p.col); Files.WriteByte(W, p.voff); Files.WriteInt(W, rlen);
+      p := q
+    END;
+    Files.WriteByte(W, 0); Files.WriteInt(W, T.len);
+    off := Files.Pos(W); p := T.trailer.next;
+    WHILE p # T.trailer DO
+      rlen := p.len; Files.Set(R, p.f, p.off);
+      WHILE rlen > 0 DO Files.Read(R, ch); Files.Write(W, ch); DEC(rlen) END ;
+      p := p.next
+    END ;
+    Files.Set(W, Files.Base(W), pos); Files.WriteInt(W, off); (*fixup*)
+    T.changed := FALSE;
+    IF T.notify # NIL THEN T.notify(T, unmark, 0, 0) END
+  END Store;
+
+  PROCEDURE Close*(T: Text; name: ARRAY OF CHAR);
+    VAR f: Files.File; w: Files.Rider;
+  BEGIN f := Files.New(name); Files.Set(w, f, 0);
+    Files.Write(w, TextTag); Store(w, T); Files.Register(f)
+  END Close;
+
+  (* -------------------- Editing ----------------------- *)
+
+  PROCEDURE OpenBuf* (B: Buffer);
+  BEGIN NEW(B.header); (*null piece*)
+    B.last := B.header; B.len := 0
+  END OpenBuf;
+
+  PROCEDURE FindPiece (T: Text; pos: LONGINT; VAR org: LONGINT; VAR pce: Piece);
+    VAR p: Piece; porg: LONGINT;
+  BEGIN p := T.pce; porg := T.org;
+    IF pos >= porg THEN
+      WHILE pos >= porg + p.len DO INC(porg, p.len); p := p.next END
+    ELSE p := p.prev; DEC(porg, p.len);
+      WHILE pos < porg DO p := p.prev; DEC(porg, p.len) END
+    END ;
+    T.pce := p; T.org := porg;  (*update cache*)
+    pce := p; org := porg
+  END FindPiece;
+
+  PROCEDURE SplitPiece (p: Piece; off: LONGINT; VAR pr: Piece);
+    VAR q: Piece;
+  BEGIN
+    IF off > 0 THEN NEW(q);
+      q.fnt := p.fnt; q.col := p.col; q.voff := p.voff;
+      q.len := p.len - off;
+      q.f := p.f; q.off := p.off + off;
+      p.len := off;
+      q.next := p.next; p.next := q;
+      q.prev := p; q.next.prev := q;
+      pr := q
+    ELSE pr := p
+    END
+  END SplitPiece;
+
+  PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer);
+    VAR p, q, qb, qe: Piece; org: LONGINT;
+  BEGIN
+    IF end > T.len THEN end := T.len END;
+    FindPiece(T, beg, org, p);
+    NEW(qb); qb^ := p^;
+    qb.len := qb.len - (beg - org);
+    qb.off := qb.off + (beg - org);
+    qe := qb;
+    WHILE end > org + p.len DO 
+      org := org + p.len; p := p.next;
+      NEW(q); q^ := p^; qe.next := q; q.prev := qe; qe := q
+    END;
+    qe.next := NIL; qe.len := qe.len - (org + p.len - end);
+    B.last.next := qb; qb.prev := B.last; B.last := qe;
+    B.len := B.len + (end - beg)
+  END Save;
+
+  PROCEDURE Copy* (SB, DB: Buffer);
+    VAR Q, q, p: Piece;
+  BEGIN p := SB.header; Q := DB.last;
+    WHILE p # SB.last DO p := p.next;
+      NEW(q); q^ := p^; Q.next := q; q.prev := Q; Q := q
+    END;
+    DB.last := Q; DB.len := DB.len + SB.len
+  END Copy;
+
+  PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer);
+    VAR pl, pr, p, qb, qe: Piece; org, end: LONGINT;
+  BEGIN
+    FindPiece(T, pos, org, p); SplitPiece(p, pos - org, pr);
+    IF T.org >= org THEN T.org := org - p.prev.len; T.pce := p.prev END ;
+    pl := pr.prev; qb := B.header.next;
+    IF (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len)
+        & (qb.fnt = pl.fnt) & (qb.col = pl.col) & (qb.voff = pl.voff) THEN
+      pl.len := pl.len + qb.len; qb := qb.next
+    END;
+    IF qb # NIL THEN qe := B.last;
+      qb.prev := pl; pl.next := qb; qe.next := pr; pr.prev := qe
+    END;
+    T.len := T.len + B.len; end := pos + B.len;
+    B.last := B.header; B.last.next := NIL; B.len := 0;
+    T.changed := TRUE;
+    IF T.notify # NIL THEN  T.notify(T, insert, pos, end) END
+  END Insert;
+
+  PROCEDURE Append* (T: Text; B: Buffer);
+  BEGIN Insert(T, T.len, B)
+  END Append;
+
+  PROCEDURE Delete* (T: Text; beg, end: LONGINT; B: Buffer);
+    VAR pb, pe, pbr, per: Piece; orgb, orge: LONGINT;
+  BEGIN
+    IF end > T.len THEN end := T.len END;
+    FindPiece(T, beg, orgb, pb); SplitPiece(pb, beg - orgb, pbr);
+    FindPiece(T, end, orge, pe);
+    SplitPiece(pe, end - orge, per);
+    IF T.org >= orgb THEN (*adjust cache*)
+      T.org := orgb - pb.prev.len; T.pce := pb.prev
+    END;
+    B.header.next := pbr; B.last := per.prev;
+    B.last.next := NIL; B.len := end - beg;
+    per.prev := pbr.prev; pbr.prev.next := per;
+    T.len := T.len - B.len;
+    T.changed := TRUE;
+    IF T.notify # NIL THEN T.notify(T, delete, beg, end) END
+  END Delete;
+
+  PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: Fonts.Font; col, voff: INTEGER);
+    VAR pb, pe, p: Piece; org: LONGINT;
+  BEGIN
+    IF end > T.len THEN end := T.len END;
+    FindPiece(T, beg, org, p); SplitPiece(p, beg - org, pb);
+    FindPiece(T, end, org, p); SplitPiece(p, end - org, pe);
+    p := pb;
+    REPEAT
+      IF 0 IN sel THEN p.fnt := fnt END;
+      IF 1 IN sel THEN p.col := col END;
+      IF 2 IN sel THEN p.voff := voff END;
+      p := p.next
+    UNTIL p = pe;
+    T.changed := TRUE;
+    IF T.notify # NIL THEN T.notify(T, replace, beg, end) END
+  END ChangeLooks;
+
+  PROCEDURE Attributes*(T: Text; pos: LONGINT; VAR fnt: Fonts.Font; VAR col, voff: INTEGER);
+    VAR p: Piece; org: LONGINT;
+  BEGIN FindPiece(T, pos, org, p); fnt := p.fnt; col := p.col; voff := p.voff
+  END Attributes;
+
+  (* ------------------ Access: Readers ------------------------- *)
+
+  PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
+    VAR p: Piece; org: LONGINT;
+  BEGIN FindPiece(T, pos, org, p);
+    R.ref := p; R.org := org; R.off := pos - org;
+    Files.Set(R.rider, p.f, p.off + R.off); R.eot := FALSE
+  END OpenReader;
+
+  PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR);
+  BEGIN Files.Read(R.rider, ch);
+    R.fnt := R.ref.fnt; R.col := R.ref.col; R.voff := R.ref.voff;
+    INC(R.off);
+    IF R.off = R.ref.len THEN
+      IF R.ref.f = TrailerFile THEN R.eot := TRUE END;
+      R.ref := R.ref.next; R.org := R.org + R.off; R.off := 0;
+      Files.Set(R.rider, R.ref.f, R.ref.off)
+    END
+  END Read;
+
+  PROCEDURE Pos* (VAR R: Reader): LONGINT;
+  BEGIN RETURN R.org + R.off
+  END Pos;  
+
+  (* ------------------ Access: Scanners (NW) ------------------------- *)
+
+  PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
+  BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " "
+  END OpenScanner;
+
+  (*floating point formats:
+    x = 1.m * 2^(e-127)   bit 0: sign, bits 1- 8: e, bits  9-31: m
+    x = 1.m * 2^(e-1023)  bit 0: sign, bits 1-11: e, bits 12-63: m *)
+
+  PROCEDURE Ten(n: INTEGER): REAL;
+    VAR t, p: REAL;
+  BEGIN t := 1.0; p := 10.0;   (*compute 10^n *)
+    WHILE n > 0 DO
+      IF ODD(n) THEN t := p * t END ;
+      p := p*p; n := n DIV 2
+    END ;
+    RETURN t
+  END Ten;
+
+  PROCEDURE Scan* (VAR S: Scanner);
+    CONST maxExp = 38; maxM = 16777216; (*2^24*)
+    VAR ch, term: CHAR;
+      neg, negE, hex: BOOLEAN;
+      i, j, h, d, e, n, s: INTEGER;
+      k: LONGINT;
+      x: REAL;
+  BEGIN ch := S.nextCh; i := 0;
+    WHILE (ch = " ") OR (ch = TAB) OR (ch = CR) DO
+      IF ch = CR THEN INC(S.line) END ;
+      Read(S, ch)
+    END ;
+    IF ("A" <= ch) & (ch <= "Z") OR ("a" <= ch) & (ch <= "z") THEN (*name*)
+      REPEAT S.s[i] := ch; INC(i); Read(S, ch)
+      UNTIL ((ch < "0") & (ch # ".") OR ("9" < ch) & (ch < "A") OR ("Z" < ch) & (ch < "a") OR ("z" < ch)) OR (i = 31);
+      S.s[i] := 0X; S.len := i; S.class := Name
+    ELSIF ch = 22X THEN (*string*)
+      Read(S, ch);
+      WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO S.s[i] := ch; INC(i); Read(S, ch) END;
+      S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := String
+    ELSE hex := FALSE;
+      IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ;
+      IF ("0" <= ch) & (ch <= "9") THEN (*number*)
+        n := ORD(ch) - 30H; h := n; Read(S, ch);
+        WHILE ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") DO
+          IF ch <= "9" THEN d := ORD(ch) - 30H ELSE d := ORD(ch) - 37H; hex := TRUE END ;
+          n := 10*n + d; h := 10H*h + d; Read(S, ch)
+        END ;
+        IF ch = "H" THEN (*hex integer*) Read(S, ch); S.i := h; S.class := Int  (*neg?*)
+        ELSIF ch = "." THEN (*real number*)
+          Read(S, ch); x := 0.0; e := 0; j := 0;
+          WHILE ("0" <= ch) & (ch <= "9") DO  (*fraction*)
+            h := 10*n + (ORD(ch) - 30H);
+            IF h < maxM THEN n := h; INC(j) END ;
+            Read(S, ch)
+          END ;
+          IF ch = "E" THEN (*scale factor*)
+            s := 0; Read(S, ch);
+            IF ch = "-" THEN negE := TRUE; Read(S, ch)
+            ELSE negE := FALSE;
+              IF ch = "+" THEN Read(S, ch) END
+            END ;
+            WHILE ("0" <= ch) & (ch <= "9") DO
+              s := s*10 + ORD(ch) - 30H; Read(S, ch)
+            END ;
+            IF negE THEN DEC(e, s) ELSE INC(e, s) END ;
+          END ;
+          x := FLT(n); DEC(e, j);
+          IF e < 0 THEN
+            IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END
+          ELSIF e > 0 THEN
+            IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0 END
+          END ;
+          IF neg THEN S.x := -x ELSE S.x := x END ;
+          IF hex THEN S.class := 0 ELSE S.class := Real END
+        ELSE (*decimal integer*)
+          IF neg THEN S.i := -n ELSE S.i := n END;
+          IF hex THEN S.class := Inval ELSE S.class := Int END
+        END
+      ELSE (*spectal character*) S.class := Char;
+        IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END
+      END
+    END ;
+    S.nextCh := ch
+  END Scan;
+
+  (* --------------- Access: Writers (NW) ------------------ *)
+
+  PROCEDURE OpenWriter* (VAR W: Writer);
+  BEGIN NEW(W.buf);
+    OpenBuf(W.buf); W.fnt := Fonts.Default; W.col := 15; W.voff := 0;
+    Files.Set(W.rider, Files.New(""), 0)
+  END OpenWriter;
+
+  PROCEDURE SetFont* (VAR W: Writer; fnt: Fonts.Font);
+  BEGIN W.fnt := fnt
+  END SetFont;
+
+  PROCEDURE SetColor* (VAR W: Writer; col: INTEGER);
+  BEGIN W.col := col
+  END SetColor;
+
+  PROCEDURE SetOffset* (VAR W: Writer; voff: INTEGER);
+  BEGIN W.voff := voff
+  END SetOffset;
+
+  PROCEDURE Write* (VAR W: Writer; ch: CHAR);
+    VAR p: Piece;
+  BEGIN
+    IF (W.buf.last.fnt # W.fnt) OR (W.buf.last.col # W.col) OR (W.buf.last.voff # W.voff) THEN
+      NEW(p); p.f := Files.Base(W.rider); p.off := Files.Pos(W.rider); p.len := 0;
+      p.fnt := W.fnt; p.col := W.col; p.voff:= W.voff;
+      p.next := NIL; W.buf.last.next := p;
+      p.prev := W.buf.last; W.buf.last := p
+    END;
+    Files.Write(W.rider, ch);
+    INC(W.buf.last.len); INC(W.buf.len)
+  END Write;
+
+  PROCEDURE WriteLn* (VAR W: Writer);
+  BEGIN Write(W, CR)
+  END WriteLn;
+
+  PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR);
+    VAR i: INTEGER;
+  BEGIN i := 0;
+    WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END
+  END WriteString;
+
+  PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT);
+    VAR i: INTEGER; x0: LONGINT;
+      a: ARRAY 10 OF CHAR;
+  BEGIN
+    IF ROR(x, 31) = 1 THEN WriteString(W, " -2147483648")
+    ELSE i := 0;
+      IF x < 0 THEN DEC(n); x0 := -x ELSE x0 := x END;
+      REPEAT
+        a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i)
+      UNTIL x0 = 0;
+      WHILE n > i DO Write(W, " "); DEC(n) END;
+      IF x < 0 THEN Write(W, "-") END;
+      REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
+    END
+  END WriteInt;
+
+  PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
+    VAR i: INTEGER; y: LONGINT;
+      a: ARRAY 10 OF CHAR;
+  BEGIN i := 0; Write(W, " ");
+    REPEAT y := x MOD 10H;
+      IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
+      x := x DIV 10H; INC(i)
+    UNTIL i = 8;
+    REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
+  END WriteHex;
+
+ PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER);
+    VAR e, i, m: INTEGER;
+      d: ARRAY 16 OF CHAR;
+  BEGIN e := ASR(ORD(x), 23) MOD 100H;  (*binary exponent*)
+    IF e = 0 THEN
+      WriteString(W, "  0 ");
+      WHILE n >= 3 DO Write(W, " "); DEC(n) END
+    ELSIF e = 255 THEN WriteString(W, " NaN ")
+    ELSE Write(W, " ");
+      WHILE n >= 15 DO DEC(n); Write(W, " ") END ;
+      (* 2 < n < 9 digits to be written*)
+      IF x < 0.0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END ;
+      e := (e - 127) * 77 DIV 256 - 6;  (*decimal exponent*)
+      IF e >= 0 THEN x := x / Ten(e) ELSE x := Ten(-e) * x END ;
+      m := FLOOR(x + 0.5); i := 0;
+      IF m >= 10000000 THEN INC(e); m := m DIV 10 END ;
+      REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0;
+      DEC(i); Write(W, d[i]); Write(W, ".");
+      IF i < n-7 THEN n := 0 ELSE n := 14 - n END ;
+      WHILE i > n DO DEC(i); Write(W, d[i]) END ;
+      Write(W, "E"); INC(e, 6);
+       IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END ;
+      Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H))
+    END
+  END WriteReal;
+
+  PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER);
+    VAR i, m: INTEGER; neg: BOOLEAN;
+      d: ARRAY 12 OF CHAR;
+  BEGIN
+    IF x = 0.0 THEN WriteString(W, "  0")
+    ELSE
+      IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ;
+      IF k > 7 THEN k := 7 END ;
+      x := Ten(k) * x; m := FLOOR(x + 0.5);
+      i := 0;
+      REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0;
+      Write(W, " ");
+      WHILE n > i+3 DO  Write(W, " "); DEC(n) END ;
+      IF neg THEN Write(W, "-"); DEC(n) ELSE Write(W, " ") END ;
+      WHILE i > k DO DEC(i); Write(W, d[i]) END ;
+      Write(W, ".");
+      WHILE k > i DO DEC(k); Write(W, "0") END ;
+      WHILE i > 0 DO DEC(i); Write(W, d[i]) END
+    END
+  END WriteRealFix;
+
+  PROCEDURE WritePair(VAR W: Writer; ch: CHAR; x: LONGINT);
+  BEGIN Write(W, ch);
+    Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H))
+  END WritePair;
+
+  PROCEDURE WriteClock* (VAR W: Writer; d: LONGINT);
+  BEGIN
+    WritePair(W, " ", d DIV 20000H MOD 20H);   (*day*)
+    WritePair(W, ".", d DIV 400000H MOD 10H); (*month*)
+    WritePair(W, ".", d DIV 4000000H MOD 40H);   (*year*)
+    WritePair(W, " ", d DIV 1000H MOD 20H);   (*hour*)
+    WritePair(W, ":", d DIV 40H MOD 40H);  (*min*)
+    WritePair(W, ":", d MOD 40H)  (*sec*)
+  END WriteClock;
+
+BEGIN TrailerFile := Files.New("")
+END Texts.

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Tools.Mod.txt

@@ -1,116 +1,116 @@
-MODULE Tools;   (*NW 22.2.2014*)
-  IMPORT SYSTEM, Kernel, Files, Modules, Input, Texts, Viewers, MenuViewers, TextFrames, Oberon;
-  VAR T: Texts.Text; V: MenuViewers.Viewer; W: Texts.Writer;
-
-  PROCEDURE OpenViewer(T: Texts.Text; title: ARRAY OF CHAR);
-    VAR X, Y: INTEGER;
-  BEGIN 
-    Oberon.AllocateUserViewer(0, X, Y);
-    V := MenuViewers.New(
-        TextFrames.NewMenu(title, "System.Close  System.Copy  System.Grow  Edit.Search  Edit.Store"),
-        TextFrames.NewText(T, 0), TextFrames.menuH, X, Y)
-  END OpenViewer;
-
-  PROCEDURE Clear*;  (*used to clear output*)
-    VAR buf: Texts.Buffer;
-  BEGIN NEW(buf); Texts.OpenBuf(buf); Texts.Delete(T, 0, T.len, buf)
-  END Clear;
-
-  PROCEDURE Recall*;
-    VAR M: Viewers.ViewerMsg;
-  BEGIN
-    IF (V # NIL) & (V.state = 0) THEN
-      Viewers.Open(V, V.X, V.Y + V.H); M.id := Viewers.restore; V.handle(V, M)
-    END
-  END Recall;
-
-  PROCEDURE Inspect*;
-    VAR m, n, adr, data: INTEGER;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Int THEN
-      adr := S.i DIV 20H * 20H; Texts.Scan(S);
-      IF S.class = Texts.Int THEN n := S.i ELSE n := 8 END ;
-      REPEAT DEC(n); Texts.WriteLn(W); Texts.WriteHex(W, adr); Texts.Write(W, 9X); m := 8;
-        REPEAT SYSTEM.GET(adr, data); INC(adr, 4); Texts.WriteHex(W, data); DEC(m)
-        UNTIL m = 0
-      UNTIL n = 0;
-      Texts.WriteLn(W); Texts.Append(T, W.buf)
-    END
-  END Inspect;
-
-  PROCEDURE Sector*;
-    VAR k, m, n, secno: INTEGER;
-      S: Texts.Scanner;
-      buf: ARRAY 256 OF INTEGER;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Int THEN
-      secno := S.i; Texts.Scan(S);
-      IF S.class = Texts.Int THEN n := S.i ELSE n := 8 END ;
-      Kernel.GetSector(secno*29, buf); Texts.WriteString(W, "Sector "); Texts.WriteInt(W, S.i, 4);
-      k := 0;
-      REPEAT DEC(n); m := 8; Texts.WriteLn(W); Texts.WriteHex(W, k*4); Texts.Write(W, 9X);
-        REPEAT Texts.WriteHex(W, buf[k]); INC(k); DEC(m) UNTIL m = 0;
-      UNTIL n = 0;
-      Texts.WriteLn(W); Texts.Append(T, W.buf)
-    END
-  END Sector;
-
-  PROCEDURE ShowFile*;
-    VAR x, n: INTEGER;
-      F: Files.File; R: Files.Rider;
-      S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-    IF S.class = Texts.Name THEN
-      Texts.WriteString(W, S.s); F := Files.Old(S.s);
-      IF F # NIL THEN
-        n := 0; Files.Set(R, F, 0); Files.ReadInt(R, x);
-        WHILE ~R.eof DO
-          IF n MOD 20H = 0 THEN Texts.WriteLn(W); Texts.WriteHex(W, n); Texts.Write(W, 9X) END ;
-          Texts.WriteHex(W, x); INC(n, 4); Files.ReadInt(R, x)
-        END ;
-        Texts.WriteHex(W, x)
-      ELSE Texts.WriteString(W, " not found")
-      END ;
-      Texts.WriteLn(W); Texts.Append(T, W.buf)
-    END
-  END ShowFile;
-
-  PROCEDURE Convert*;   (*convert selected text to txt-format*)
-    VAR beg, end, time: LONGINT
-      ; ch: CHAR;
-      T: Texts.Text; R: Texts.Reader;  (*input*)
-      F: Files.File; Q: Files.Rider;   (*output*)
-      S: Texts.Scanner;
-  BEGIN Oberon.GetSelection(T, beg, end, time);
-    IF time >= 0 THEN
-      Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
-      Texts.WriteString(W, "converting to "); Texts.WriteString(W, S.s);
-      F := Files.New(S.s); Files.Set(Q, F, 0); Texts.OpenReader(R, T, beg); Texts.Read(R, ch);
-      WHILE ~R.eot DO
-        IF ch = 0DX THEN Files.Write(Q, 0DX); Files.Write(Q, 0AX)
-        ELSIF ch = 9X THEN  (*TAB*) Files.Write(Q, " "); Files.Write(Q, " ")
-        ELSE Files.Write(Q, ch)
-        END ;
-        Texts.Read(R, ch)
-      END ;
-      Files.Register(F); Texts.WriteString(W, " done")
-    ELSE Texts.WriteString(W, " not found")
-    END ;
-    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S)
-  END Convert;
-
-  PROCEDURE Id*;
-  BEGIN Texts.WriteHex(W, SYSTEM.H(1)); Texts.WriteLn(W); Texts.Append(T, W.buf)
-  END Id;
-
-BEGIN Texts.OpenWriter(W); T := TextFrames.Text(""); OpenViewer(T, "Tools.Text")
-END Tools.
-
-Tools.Clear  (clear tool viewer)
-Tools.Recall   (recall closed tool viewer)
-Tools.Inspect adr len
-Tools.Sector secno
-Tools.ShowFile filename  (in hex)
-Tools.Convert filename  (selected text to txt-format)
-Tools.Id   (processor id)
+MODULE Tools;   (*NW 22.2.2014*)
+  IMPORT SYSTEM, Kernel, Files, Modules, Input, Texts, Viewers, MenuViewers, TextFrames, Oberon;
+  VAR T: Texts.Text; V: MenuViewers.Viewer; W: Texts.Writer;
+
+  PROCEDURE OpenViewer(T: Texts.Text; title: ARRAY OF CHAR);
+    VAR X, Y: INTEGER;
+  BEGIN 
+    Oberon.AllocateUserViewer(0, X, Y);
+    V := MenuViewers.New(
+        TextFrames.NewMenu(title, "System.Close  System.Copy  System.Grow  Edit.Search  Edit.Store"),
+        TextFrames.NewText(T, 0), TextFrames.menuH, X, Y)
+  END OpenViewer;
+
+  PROCEDURE Clear*;  (*used to clear output*)
+    VAR buf: Texts.Buffer;
+  BEGIN NEW(buf); Texts.OpenBuf(buf); Texts.Delete(T, 0, T.len, buf)
+  END Clear;
+
+  PROCEDURE Recall*;
+    VAR M: Viewers.ViewerMsg;
+  BEGIN
+    IF (V # NIL) & (V.state = 0) THEN
+      Viewers.Open(V, V.X, V.Y + V.H); M.id := Viewers.restore; V.handle(V, M)
+    END
+  END Recall;
+
+  PROCEDURE Inspect*;
+    VAR m, n, adr, data: INTEGER;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Int THEN
+      adr := S.i DIV 20H * 20H; Texts.Scan(S);
+      IF S.class = Texts.Int THEN n := S.i ELSE n := 8 END ;
+      REPEAT DEC(n); Texts.WriteLn(W); Texts.WriteHex(W, adr); Texts.Write(W, 9X); m := 8;
+        REPEAT SYSTEM.GET(adr, data); INC(adr, 4); Texts.WriteHex(W, data); DEC(m)
+        UNTIL m = 0
+      UNTIL n = 0;
+      Texts.WriteLn(W); Texts.Append(T, W.buf)
+    END
+  END Inspect;
+
+  PROCEDURE Sector*;
+    VAR k, m, n, secno: INTEGER;
+      S: Texts.Scanner;
+      buf: ARRAY 256 OF INTEGER;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Int THEN
+      secno := S.i; Texts.Scan(S);
+      IF S.class = Texts.Int THEN n := S.i ELSE n := 8 END ;
+      Kernel.GetSector(secno*29, buf); Texts.WriteString(W, "Sector "); Texts.WriteInt(W, S.i, 4);
+      k := 0;
+      REPEAT DEC(n); m := 8; Texts.WriteLn(W); Texts.WriteHex(W, k*4); Texts.Write(W, 9X);
+        REPEAT Texts.WriteHex(W, buf[k]); INC(k); DEC(m) UNTIL m = 0;
+      UNTIL n = 0;
+      Texts.WriteLn(W); Texts.Append(T, W.buf)
+    END
+  END Sector;
+
+  PROCEDURE ShowFile*;
+    VAR x, n: INTEGER;
+      F: Files.File; R: Files.Rider;
+      S: Texts.Scanner;
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+    IF S.class = Texts.Name THEN
+      Texts.WriteString(W, S.s); F := Files.Old(S.s);
+      IF F # NIL THEN
+        n := 0; Files.Set(R, F, 0); Files.ReadInt(R, x);
+        WHILE ~R.eof DO
+          IF n MOD 20H = 0 THEN Texts.WriteLn(W); Texts.WriteHex(W, n); Texts.Write(W, 9X) END ;
+          Texts.WriteHex(W, x); INC(n, 4); Files.ReadInt(R, x)
+        END ;
+        Texts.WriteHex(W, x)
+      ELSE Texts.WriteString(W, " not found")
+      END ;
+      Texts.WriteLn(W); Texts.Append(T, W.buf)
+    END
+  END ShowFile;
+
+  PROCEDURE Convert*;   (*convert selected text to txt-format*)
+    VAR beg, end, time: LONGINT
+      ; ch: CHAR;
+      T: Texts.Text; R: Texts.Reader;  (*input*)
+      F: Files.File; Q: Files.Rider;   (*output*)
+      S: Texts.Scanner;
+  BEGIN Oberon.GetSelection(T, beg, end, time);
+    IF time >= 0 THEN
+      Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
+      Texts.WriteString(W, "converting to "); Texts.WriteString(W, S.s);
+      F := Files.New(S.s); Files.Set(Q, F, 0); Texts.OpenReader(R, T, beg); Texts.Read(R, ch);
+      WHILE ~R.eot DO
+        IF ch = 0DX THEN Files.Write(Q, 0DX); Files.Write(Q, 0AX)
+        ELSIF ch = 9X THEN  (*TAB*) Files.Write(Q, " "); Files.Write(Q, " ")
+        ELSE Files.Write(Q, ch)
+        END ;
+        Texts.Read(R, ch)
+      END ;
+      Files.Register(F); Texts.WriteString(W, " done")
+    ELSE Texts.WriteString(W, " not found")
+    END ;
+    Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S)
+  END Convert;
+
+  PROCEDURE Id*;
+  BEGIN Texts.WriteHex(W, SYSTEM.H(1)); Texts.WriteLn(W); Texts.Append(T, W.buf)
+  END Id;
+
+BEGIN Texts.OpenWriter(W); T := TextFrames.Text(""); OpenViewer(T, "Tools.Text")
+END Tools.
+
+Tools.Clear  (clear tool viewer)
+Tools.Recall   (recall closed tool viewer)
+Tools.Inspect adr len
+Tools.Sector secno
+Tools.ShowFile filename  (in hex)
+Tools.Convert filename  (selected text to txt-format)
+Tools.Id   (processor id)

people.inf.ethz.ch/wirth/ProjectOberon/Sources/Viewers.Mod.txt

@@ -1,206 +1,206 @@
-MODULE Viewers; (*JG 14.9.90 / NW 15.9.2013*)
-  IMPORT Display;
-
-  CONST restore* = 0; modify* = 1; suspend* = 2; (*message ids*)
-    inf = 65535;
-
-  TYPE Viewer* = POINTER TO ViewerDesc;
-    ViewerDesc* = RECORD (Display.FrameDesc) state*: INTEGER END;
-
-    (*state > 1: displayed; state = 1: filler; state = 0: closed; state < 0: suspended*)
-
-    ViewerMsg* = RECORD (Display.FrameMsg)
-        id*: INTEGER;
-        X*, Y*, W*, H*: INTEGER;
-        state*: INTEGER
-      END;
-
-    Track = POINTER TO TrackDesc;
-    TrackDesc = RECORD (ViewerDesc) under: Display.Frame END;
-
-  VAR curW*, minH*, DH: INTEGER;
-    FillerTrack: Track; FillerViewer,
-    backup: Viewer; (*last closed viewer*)
-
-  PROCEDURE Open* (V: Viewer; X, Y: INTEGER);
-    VAR T, u, v: Display.Frame; M: ViewerMsg;
-  BEGIN
-    IF (V.state = 0) & (X < inf) THEN
-      IF Y > DH THEN Y := DH END;
-      T := FillerTrack.next;
-      WHILE X >= T.X + T.W DO T := T.next END;
-      u := T.dsc; v := u.next;
-      WHILE Y > v.Y + v.H DO u := v; v := u.next END;
-      IF Y < v.Y + minH THEN Y := v.Y + minH END;
-      IF (v.next.Y # 0) & (Y > v.Y + v.H - minH) THEN
-        V.X := T.X; V.W := T.W; V.Y := v.Y; V.H := v.H;
-        M.id := suspend; M.state := 0;
-        v.handle(v, M); v(Viewer).state := 0;
-        V.next := v.next; u.next := V; V.state := 2
-      ELSE V.X := T.X; V.W := T.W; V.Y := v.Y; V.H := Y - v.Y;
-        M.id := modify; M.Y := Y; M.H := v.Y + v.H - Y;
-        v.handle(v, M); v.Y := M.Y; v.H := M.H;
-        V.next := v; u.next := V; V.state := 2
-      END
-    END
-  END Open;
-
-  PROCEDURE Change* (V: Viewer; Y: INTEGER);
-    VAR v: Display.Frame; M: ViewerMsg;
-  BEGIN
-    IF V.state > 1 THEN
-      IF Y > DH THEN Y := DH END;
-      v := V.next;
-      IF (v.next.Y # 0) & (Y > v.Y + v.H - minH) THEN Y := v.Y + v.H - minH END;
-      IF Y >= V.Y + minH THEN
-        M.id := modify; M.Y := Y; M.H := v.Y + v.H - Y;
-        v.handle(v, M); v.Y := M.Y; v.H := M.H; V.H := Y - V.Y
-      END
-    END
-  END Change;
-
-  PROCEDURE RestoreTrack (S: Display.Frame);
-    VAR T, t, v: Display.Frame; M: ViewerMsg;
-  BEGIN t := S.next;
-    WHILE t.next # S DO t := t.next END;
-    T := S(Track).under;
-    WHILE T.next # NIL DO T := T.next END;
-    t.next := S(Track).under; T.next := S.next; M.id := restore;
-    REPEAT t := t.next; v := t.dsc;
-      REPEAT v := v.next; v.handle(v, M); v(Viewer).state := - v(Viewer).state
-      UNTIL v = t.dsc
-    UNTIL t = T
-  END RestoreTrack;
-
-  PROCEDURE Close* (V: Viewer);
-    VAR T, U: Display.Frame; M: ViewerMsg;
-  BEGIN
-    IF V.state > 1 THEN
-      U := V.next; T := FillerTrack;
-      REPEAT T := T.next UNTIL V.X < T.X + T.W;
-      IF (T(Track).under = NIL) OR (U.next # V) THEN
-        M.id := suspend; M.state := 0;
-        V.handle(V, M); V.state := 0; backup := V;
-        M.id := modify; M.Y := V.Y; M.H := V.H + U.H;
-        U.handle(U, M); U.Y := M.Y; U.H := M.H;
-        WHILE U.next # V DO U := U.next END;
-        U.next := V.next
-      ELSE (*close track*)
-        M.id := suspend; M.state := 0;
-        V.handle(V, M); V.state := 0; backup := V;
-        U.handle(U, M); U(Viewer).state := 0;
-        RestoreTrack(T)
-      END
-    END
-  END Close;
-
-  PROCEDURE Recall* (VAR V: Viewer);
-  BEGIN V := backup
-  END Recall;
-
-  PROCEDURE This* (X, Y: INTEGER): Viewer;
-    VAR T, V: Display.Frame;
-  BEGIN
-    IF (X < inf) & (Y < DH) THEN
-      T := FillerTrack;
-      REPEAT T := T.next UNTIL X < T.X + T.W;
-      V := T.dsc;
-      REPEAT V := V.next UNTIL Y < V.Y + V.H
-    ELSE V := NIL
-    END ;
-    RETURN V(Viewer)
-  END This;
-
-  PROCEDURE Next* (V: Viewer): Viewer;
-  BEGIN RETURN V.next(Viewer)
-  END Next;
-
-  PROCEDURE Locate* (X, H: INTEGER; VAR fil, bot, alt, max: Display.Frame);
-    VAR T, V: Display.Frame;
-  BEGIN
-    IF X < inf THEN
-      T := FillerTrack;
-      REPEAT T := T.next UNTIL X < T.X + T.W;
-      fil := T.dsc; bot := fil.next;
-      IF bot.next # fil THEN
-        alt := bot.next; V := alt.next;
-        WHILE (V # fil) & (alt.H < H) DO
-          IF V.H > alt.H THEN alt := V END;
-          V := V.next
-        END
-      ELSE alt := bot
-      END;
-      max := T.dsc; V := max.next;
-      WHILE V # fil DO
-        IF V.H > max.H THEN max := V END;
-        V := V.next
-      END
-    END
-  END Locate;
-
-  PROCEDURE InitTrack* (W, H: INTEGER; Filler: Viewer);
-    VAR S: Display.Frame; T: Track;
-  BEGIN
-    IF Filler.state = 0 THEN
-      Filler.X := curW; Filler.W := W; Filler.Y := 0; Filler.H := H;
-      Filler.state := 1; Filler.next := Filler;
-      NEW(T); T.X := curW; T.W := W; T.Y := 0; T.H := H; T.dsc := Filler; T.under := NIL;
-      FillerViewer.X := curW + W; FillerViewer.W := inf - FillerViewer.X;
-      FillerTrack.X := FillerViewer.X; FillerTrack.W := FillerViewer.W;
-      S := FillerTrack;
-      WHILE S.next # FillerTrack DO S := S.next END;
-      S.next := T; T.next := FillerTrack; curW := curW + W
-    END
-  END InitTrack;
-
-  PROCEDURE OpenTrack* (X, W: INTEGER; Filler: Viewer);
-    VAR newT: Track; S, T, t, v: Display.Frame; M: ViewerMsg; v0: Viewer;
-  BEGIN
-    IF (X < inf) & (Filler.state = 0) THEN
-      S := FillerTrack; T := S.next;
-      WHILE X >= T.X + T.W DO S := T; T := S.next END;
-      WHILE X + W > T.X + T.W DO T := T.next END;
-      M.id := suspend; t := S;
-      REPEAT t := t.next; v := t.dsc;
-        REPEAT v := v.next; M.state := -v(Viewer).state; v.handle(v, M); v(Viewer).state := M.state
-        UNTIL v = t.dsc
-      UNTIL t = T;
-      Filler.X := S.next.X; Filler.W := T.X + T.W - S.next.X; Filler.Y := 0; Filler.H := DH;
-      Filler.state := 1; Filler.next := Filler;
-      NEW(newT); newT.X := Filler.X; newT.W := Filler.W; newT.Y := 0; newT.H := DH;
-      newT.dsc := Filler; newT.under := S.next; S.next := newT;
-      newT.next := T.next; T.next := NIL
-    END
-  END OpenTrack;
-
-  PROCEDURE CloseTrack* (X: INTEGER);
-    VAR T, V: Display.Frame; M: ViewerMsg;
-  BEGIN
-    IF X < inf THEN
-      T := FillerTrack;
-      REPEAT T := T.next UNTIL X < T.X + T.W;
-      IF T(Track).under # NIL THEN
-        M.id := suspend; M.state := 0; V := T.dsc;
-        REPEAT V := V.next; V.handle(V, M); V(Viewer).state := 0 UNTIL V = T.dsc;
-        RestoreTrack(T)
-      END
-    END
-  END CloseTrack;
-
-  PROCEDURE Broadcast* (VAR M: Display.FrameMsg);
-    VAR T, V: Display.Frame;
-  BEGIN T := FillerTrack.next;
-    WHILE T # FillerTrack DO
-      V := T.dsc; 
-      REPEAT V := V.next; V.handle(V, M) UNTIL V = T.dsc;
-      T := T.next
-    END
-  END Broadcast;
-
-BEGIN backup := NIL; curW := 0; minH := 1; DH := Display.Height;
-  NEW(FillerViewer); FillerViewer.X := 0; FillerViewer.W := inf; FillerViewer.Y := 0; FillerViewer.H := DH;
-  FillerViewer.next := FillerViewer;
-  NEW(FillerTrack);
-  FillerTrack.X := 0; FillerTrack.W := inf; FillerTrack.Y := 0; FillerTrack.H := DH;
-  FillerTrack.dsc := FillerViewer; FillerTrack.next := FillerTrack
-END Viewers.
+MODULE Viewers; (*JG 14.9.90 / NW 15.9.2013*)
+  IMPORT Display;
+
+  CONST restore* = 0; modify* = 1; suspend* = 2; (*message ids*)
+    inf = 65535;
+
+  TYPE Viewer* = POINTER TO ViewerDesc;
+    ViewerDesc* = RECORD (Display.FrameDesc) state*: INTEGER END;
+
+    (*state > 1: displayed; state = 1: filler; state = 0: closed; state < 0: suspended*)
+
+    ViewerMsg* = RECORD (Display.FrameMsg)
+        id*: INTEGER;
+        X*, Y*, W*, H*: INTEGER;
+        state*: INTEGER
+      END;
+
+    Track = POINTER TO TrackDesc;
+    TrackDesc = RECORD (ViewerDesc) under: Display.Frame END;
+
+  VAR curW*, minH*, DH: INTEGER;
+    FillerTrack: Track; FillerViewer,
+    backup: Viewer; (*last closed viewer*)
+
+  PROCEDURE Open* (V: Viewer; X, Y: INTEGER);
+    VAR T, u, v: Display.Frame; M: ViewerMsg;
+  BEGIN
+    IF (V.state = 0) & (X < inf) THEN
+      IF Y > DH THEN Y := DH END;
+      T := FillerTrack.next;
+      WHILE X >= T.X + T.W DO T := T.next END;
+      u := T.dsc; v := u.next;
+      WHILE Y > v.Y + v.H DO u := v; v := u.next END;
+      IF Y < v.Y + minH THEN Y := v.Y + minH END;
+      IF (v.next.Y # 0) & (Y > v.Y + v.H - minH) THEN
+        V.X := T.X; V.W := T.W; V.Y := v.Y; V.H := v.H;
+        M.id := suspend; M.state := 0;
+        v.handle(v, M); v(Viewer).state := 0;
+        V.next := v.next; u.next := V; V.state := 2
+      ELSE V.X := T.X; V.W := T.W; V.Y := v.Y; V.H := Y - v.Y;
+        M.id := modify; M.Y := Y; M.H := v.Y + v.H - Y;
+        v.handle(v, M); v.Y := M.Y; v.H := M.H;
+        V.next := v; u.next := V; V.state := 2
+      END
+    END
+  END Open;
+
+  PROCEDURE Change* (V: Viewer; Y: INTEGER);
+    VAR v: Display.Frame; M: ViewerMsg;
+  BEGIN
+    IF V.state > 1 THEN
+      IF Y > DH THEN Y := DH END;
+      v := V.next;
+      IF (v.next.Y # 0) & (Y > v.Y + v.H - minH) THEN Y := v.Y + v.H - minH END;
+      IF Y >= V.Y + minH THEN
+        M.id := modify; M.Y := Y; M.H := v.Y + v.H - Y;
+        v.handle(v, M); v.Y := M.Y; v.H := M.H; V.H := Y - V.Y
+      END
+    END
+  END Change;
+
+  PROCEDURE RestoreTrack (S: Display.Frame);
+    VAR T, t, v: Display.Frame; M: ViewerMsg;
+  BEGIN t := S.next;
+    WHILE t.next # S DO t := t.next END;
+    T := S(Track).under;
+    WHILE T.next # NIL DO T := T.next END;
+    t.next := S(Track).under; T.next := S.next; M.id := restore;
+    REPEAT t := t.next; v := t.dsc;
+      REPEAT v := v.next; v.handle(v, M); v(Viewer).state := - v(Viewer).state
+      UNTIL v = t.dsc
+    UNTIL t = T
+  END RestoreTrack;
+
+  PROCEDURE Close* (V: Viewer);
+    VAR T, U: Display.Frame; M: ViewerMsg;
+  BEGIN
+    IF V.state > 1 THEN
+      U := V.next; T := FillerTrack;
+      REPEAT T := T.next UNTIL V.X < T.X + T.W;
+      IF (T(Track).under = NIL) OR (U.next # V) THEN
+        M.id := suspend; M.state := 0;
+        V.handle(V, M); V.state := 0; backup := V;
+        M.id := modify; M.Y := V.Y; M.H := V.H + U.H;
+        U.handle(U, M); U.Y := M.Y; U.H := M.H;
+        WHILE U.next # V DO U := U.next END;
+        U.next := V.next
+      ELSE (*close track*)
+        M.id := suspend; M.state := 0;
+        V.handle(V, M); V.state := 0; backup := V;
+        U.handle(U, M); U(Viewer).state := 0;
+        RestoreTrack(T)
+      END
+    END
+  END Close;
+
+  PROCEDURE Recall* (VAR V: Viewer);
+  BEGIN V := backup
+  END Recall;
+
+  PROCEDURE This* (X, Y: INTEGER): Viewer;
+    VAR T, V: Display.Frame;
+  BEGIN
+    IF (X < inf) & (Y < DH) THEN
+      T := FillerTrack;
+      REPEAT T := T.next UNTIL X < T.X + T.W;
+      V := T.dsc;
+      REPEAT V := V.next UNTIL Y < V.Y + V.H
+    ELSE V := NIL
+    END ;
+    RETURN V(Viewer)
+  END This;
+
+  PROCEDURE Next* (V: Viewer): Viewer;
+  BEGIN RETURN V.next(Viewer)
+  END Next;
+
+  PROCEDURE Locate* (X, H: INTEGER; VAR fil, bot, alt, max: Display.Frame);
+    VAR T, V: Display.Frame;
+  BEGIN
+    IF X < inf THEN
+      T := FillerTrack;
+      REPEAT T := T.next UNTIL X < T.X + T.W;
+      fil := T.dsc; bot := fil.next;
+      IF bot.next # fil THEN
+        alt := bot.next; V := alt.next;
+        WHILE (V # fil) & (alt.H < H) DO
+          IF V.H > alt.H THEN alt := V END;
+          V := V.next
+        END
+      ELSE alt := bot
+      END;
+      max := T.dsc; V := max.next;
+      WHILE V # fil DO
+        IF V.H > max.H THEN max := V END;
+        V := V.next
+      END
+    END
+  END Locate;
+
+  PROCEDURE InitTrack* (W, H: INTEGER; Filler: Viewer);
+    VAR S: Display.Frame; T: Track;
+  BEGIN
+    IF Filler.state = 0 THEN
+      Filler.X := curW; Filler.W := W; Filler.Y := 0; Filler.H := H;
+      Filler.state := 1; Filler.next := Filler;
+      NEW(T); T.X := curW; T.W := W; T.Y := 0; T.H := H; T.dsc := Filler; T.under := NIL;
+      FillerViewer.X := curW + W; FillerViewer.W := inf - FillerViewer.X;
+      FillerTrack.X := FillerViewer.X; FillerTrack.W := FillerViewer.W;
+      S := FillerTrack;
+      WHILE S.next # FillerTrack DO S := S.next END;
+      S.next := T; T.next := FillerTrack; curW := curW + W
+    END
+  END InitTrack;
+
+  PROCEDURE OpenTrack* (X, W: INTEGER; Filler: Viewer);
+    VAR newT: Track; S, T, t, v: Display.Frame; M: ViewerMsg; v0: Viewer;
+  BEGIN
+    IF (X < inf) & (Filler.state = 0) THEN
+      S := FillerTrack; T := S.next;
+      WHILE X >= T.X + T.W DO S := T; T := S.next END;
+      WHILE X + W > T.X + T.W DO T := T.next END;
+      M.id := suspend; t := S;
+      REPEAT t := t.next; v := t.dsc;
+        REPEAT v := v.next; M.state := -v(Viewer).state; v.handle(v, M); v(Viewer).state := M.state
+        UNTIL v = t.dsc
+      UNTIL t = T;
+      Filler.X := S.next.X; Filler.W := T.X + T.W - S.next.X; Filler.Y := 0; Filler.H := DH;
+      Filler.state := 1; Filler.next := Filler;
+      NEW(newT); newT.X := Filler.X; newT.W := Filler.W; newT.Y := 0; newT.H := DH;
+      newT.dsc := Filler; newT.under := S.next; S.next := newT;
+      newT.next := T.next; T.next := NIL
+    END
+  END OpenTrack;
+
+  PROCEDURE CloseTrack* (X: INTEGER);
+    VAR T, V: Display.Frame; M: ViewerMsg;
+  BEGIN
+    IF X < inf THEN
+      T := FillerTrack;
+      REPEAT T := T.next UNTIL X < T.X + T.W;
+      IF T(Track).under # NIL THEN
+        M.id := suspend; M.state := 0; V := T.dsc;
+        REPEAT V := V.next; V.handle(V, M); V(Viewer).state := 0 UNTIL V = T.dsc;
+        RestoreTrack(T)
+      END
+    END
+  END CloseTrack;
+
+  PROCEDURE Broadcast* (VAR M: Display.FrameMsg);
+    VAR T, V: Display.Frame;
+  BEGIN T := FillerTrack.next;
+    WHILE T # FillerTrack DO
+      V := T.dsc; 
+      REPEAT V := V.next; V.handle(V, M) UNTIL V = T.dsc;
+      T := T.next
+    END
+  END Broadcast;
+
+BEGIN backup := NIL; curW := 0; minH := 1; DH := Display.Height;
+  NEW(FillerViewer); FillerViewer.X := 0; FillerViewer.W := inf; FillerViewer.Y := 0; FillerViewer.H := DH;
+  FillerViewer.next := FillerViewer;
+  NEW(FillerTrack);
+  FillerTrack.X := 0; FillerTrack.W := inf; FillerTrack.Y := 0; FillerTrack.H := DH;
+  FillerTrack.dsc := FillerViewer; FillerTrack.next := FillerTrack
+END Viewers.

people.inf.ethz.ch/wirth/ProjectOberon/SourcesVerilog/Divider.v

@@ -1,28 +1,28 @@
-`timescale 1ns / 1ps  // NW 20.9.2015
-
-module Divider(
-  input clk, run, u,
-  output stall,
-  input [31:0] x, y,  // y > 0
-  output [31:0] quot, rem);
-
-reg [5:0] S;  // state
-reg [63:0] RQ;
-wire sign;
-wire [31:0] x0, w0, w1;
-
-assign stall = run & ~(S == 33);
-assign sign = x[31] & u;
-assign x0 = sign ? -x : x;
-assign w0 = RQ[62: 31];
-assign w1 = w0 - y;
-assign quot = ~sign ? RQ[31:0] :
-  (RQ[63:32] == 0) ? -RQ[31:0] : -RQ[31:0] - 1;
-assign rem = ~sign ? RQ[63:32] :
-  (RQ[63:32] == 0) ? 0 : y - RQ[63:32];
-
-always @ (posedge(clk)) begin
-  RQ <= (S == 0) ? {32'b0, x0} : {(w1[31] ? w0 : w1), RQ[30:0], ~w1[31]};
-  S <= run ? S+1 : 0;
-end
-endmodule
+`timescale 1ns / 1ps  // NW 20.9.2015
+
+module Divider(
+  input clk, run, u,
+  output stall,
+  input [31:0] x, y,  // y > 0
+  output [31:0] quot, rem);
+
+reg [5:0] S;  // state
+reg [63:0] RQ;
+wire sign;
+wire [31:0] x0, w0, w1;
+
+assign stall = run & ~(S == 33);
+assign sign = x[31] & u;
+assign x0 = sign ? -x : x;
+assign w0 = RQ[62: 31];
+assign w1 = w0 - y;
+assign quot = ~sign ? RQ[31:0] :
+  (RQ[63:32] == 0) ? -RQ[31:0] : -RQ[31:0] - 1;
+assign rem = ~sign ? RQ[63:32] :
+  (RQ[63:32] == 0) ? 0 : y - RQ[63:32];
+
+always @ (posedge(clk)) begin
+  RQ <= (S == 0) ? {32'b0, x0} : {(w1[31] ? w0 : w1), RQ[30:0], ~w1[31]};
+  S <= run ? S+1 : 0;
+end
+endmodule

people.inf.ethz.ch/wirth/ProjectOberon/SourcesVerilog/Divider0.v

@@ -1,28 +1,28 @@
-`timescale 1ns / 1ps  // NW 31.10.10
-
-module Divider(
-  input clk, run,
-  output stall,
-  input [31:0] x, y,  // x >= 0, y > 0
-  output [31:0] quot, rem);
-
-reg [4:0] S;  // state
-reg [31:0] R, Q;
-wire [31:0] r0, r1, r2, q0, q1, d;
-
-assign stall = run & ~(S == 31);
-assign r0 = (S == 0) ? 0 : R;
-assign d = r1 - y;
-assign r1 = {r0[30:0], q0[31]};
-assign r2 = d[31] ? r1 : d;
-assign q0 = (S == 0) ? x : Q;
-assign q1 = {q0[30:0], ~d[31]};
-assign rem = r2;
-assign quot = q1;
-
-always @ (posedge(clk)) begin
-  R <= r2; Q <= q1;
-  S <= run ? S+1 : 0;
-end
-
-endmodule
+`timescale 1ns / 1ps  // NW 31.10.10
+
+module Divider(
+  input clk, run,
+  output stall,
+  input [31:0] x, y,  // x >= 0, y > 0
+  output [31:0] quot, rem);
+
+reg [4:0] S;  // state
+reg [31:0] R, Q;
+wire [31:0] r0, r1, r2, q0, q1, d;
+
+assign stall = run & ~(S == 31);
+assign r0 = (S == 0) ? 0 : R;
+assign d = r1 - y;
+assign r1 = {r0[30:0], q0[31]};
+assign r2 = d[31] ? r1 : d;
+assign q0 = (S == 0) ? x : Q;
+assign q1 = {q0[30:0], ~d[31]};
+assign rem = r2;
+assign quot = q1;
+
+always @ (posedge(clk)) begin
+  R <= r2; Q <= q1;
+  S <= run ? S+1 : 0;
+end
+
+endmodule

people.inf.ethz.ch/wirth/ProjectOberon/SourcesVerilog/FPAdder.v

@@ -1,132 +1,132 @@
-`timescale 1ns / 1ps  // NW 4.10.2016  pipelined
-// u = 1: FLT; v = 1: FLOOR
-
-module FPAdder(
-  input clk, run, u, v,
-  input [31:0] x, y,
-  output stall,
-  output [31:0] z);
-
-reg [1:0] State;
-
-wire xs, ys, xn, yn;  // signs, null
-wire [7:0] xe, ye;
-wire [24:0] xm, ym;
-
-wire [8:0] dx, dy, e0, e1;
-wire [7:0] sx, sy;  // shift counts
-wire [1:0] sx0, sx1, sy0, sy1;
-wire sxh, syh;
-wire [24:0] x0, x1, x2, y0, y1, y2;
-reg [24:0] x3, y3;
-
-reg [26:0] Sum;
-wire [26:0] s;
-
-wire z24, z22, z20, z18, z16, z14, z12, z10, z8, z6, z4, z2;
-wire [4:0] sc;  // shift count
-wire [1:0] sc0, sc1;
-wire [24:0] t1, t2;
-reg [24:0] t3;
-
-assign xs = x[31];  // sign x
-assign xe = u ? 8'h96 : x[30:23];  // expo x
-assign xm = {~u|x[23], x[22:0], 1'b0};  //mant x
-assign xn = (x[30:0] == 0);
-assign ys = y[31];  // sign y
-assign ye = y[30:23];  // expo y
-assign ym = {~u&~v, y[22:0], 1'b0};  //mant y
-assign yn = (y[30:0] == 0);
-
-assign dx = xe - ye;
-assign dy = ye - xe;
-assign e0 = (dx[8]) ? ye : xe;
-assign sx = dy[8] ? 0 : dy;
-assign sy = dx[8] ? 0 : dx;
-assign sx0 = sx[1:0];
-assign sx1 = sx[3:2];
-assign sy0 = sy[1:0];
-assign sy1 = sy[3:2];
-assign sxh = sx[7] | sx[6] | sx[5];
-assign syh = sy[7] | sy[6] | sy[5];
-
-// denormalize, shift right
-assign x0 = xs&~u ? -xm : xm;
-assign x1 = (sx0 == 3) ? {{3{xs}}, x0[24:3]} :
-  (sx0 == 2) ? {{2{xs}}, x0[24:2]} : (sx0 == 1) ? {xs, x0[24:1]} : x0;
-assign x2 = (sx1 == 3) ? {{12{xs}}, x1[24:12]} :
-  (sx1 == 2) ? {{8{xs}}, x1[24:8]} : (sx1 == 1) ? {{4{xs}}, x1[24:4]} : x1;
-always @ (posedge(clk))
-  x3 <= sxh ? {25{xs}} : (sx[4] ? {{16{xs}}, x2[24:16]} : x2);
-
-assign y0 = ys&~u ? -ym : ym;
-assign y1 = (sy0 == 3) ? {{3{ys}}, y0[24:3]} :
-  (sy0 == 2) ? {{2{ys}}, y0[24:2]} : (sy0 == 1) ? {ys, y0[24:1]} : y0;
-assign y2 = (sy1 == 3) ? {{12{ys}}, y1[24:12]} :
-  (sy1 == 2) ? {{8{ys}}, y1[24:8]} : (sy1 == 1) ? {{4{ys}}, y1[24:4]} : y1;
-always @ (posedge(clk))
-	y3 <= syh ? {25{ys}} : (sy[4] ? {{16{ys}}, y2[24:16]} : y2);
-	
-// add
-always @ (posedge(clk)) Sum <= {xs, xs, x3} + {ys, ys, y3};
-assign s = (Sum[26] ? -Sum : Sum) + 1;
-
-// post-normalize
-assign z24 = ~s[25] & ~ s[24];
-assign z22 = z24 & ~s[23] & ~s[22];
-assign z20 = z22 & ~s[21] & ~s[20];
-assign z18 = z20 & ~s[19] & ~s[18];
-assign z16 = z18 & ~s[17] & ~s[16];
-assign z14 = z16 & ~s[15] & ~s[14];
-assign z12 = z14 & ~s[13] & ~s[12];
-assign z10 = z12 & ~s[11] & ~s[10];
-assign z8 = z10 & ~s[9] & ~s[8];
-assign z6 = z8 & ~s[7] & ~s[6];
-assign z4 = z6 & ~s[5] & ~s[4];
-assign z2 = z4 & ~s[3] & ~s[2];
-
-assign sc[4] = z10;  // sc = shift count of post normalization
-assign sc[3] = z18 & (s[17] | s[16] | s[15] | s[14] | s[13] | s[12] | s[11] | s[10])
-      | z2;
-assign sc[2] = z22 & (s[21] | s[20] | s[19] | s[18])
-      | z14 & (s[13] | s[12] | s[11] | s[10])
-      | z6 & (s[5] | s[4] | s[3] | s[2]);
-assign sc[1] = z24 & (s[23] | s[22])
-      | z20 & (s[19] | s[18])
-      | z16 & (s[15] | s[14])
-      | z12 & (s[11] | s[10])
-      | z8 & (s[7] | s[6])
-      | z4 & (s[3] | s[2]);
-assign sc[0] = ~s[25] & s[24]
-      | z24 & ~s[23] & s[22]
-      | z22 & ~s[21] & s[20]
-      | z20 & ~s[19] & s[18]
-      | z18 & ~s[17] & s[16]
-      | z16 & ~s[15] & s[14]
-      | z14 & ~s[13] & s[12]
-      | z12 & ~s[11] & s[10]
-      | z10 & ~s[9] & s[8]
-      | z8 & ~s[7] & s[6]
-      | z6 & ~s[5] & s[4]
-      | z4 & ~s[3] & s[2];
-
-assign e1 = e0 - sc + 1;
-assign sc0 = sc[1:0];
-assign sc1 = sc[3:2];
-
-assign t1 = (sc0 == 3) ? {s[22:1], 3'b0} :
-  (sc0 == 2) ? {s[23:1], 2'b0} : (sc0 == 1) ? {s[24:1], 1'b0} : s[25:1];
-assign t2 = (sc1 == 3) ? {t1[12:0], 12'b0} :
-  (sc1 == 2) ? {t1[16:0], 8'b0} : (sc1 == 1) ? {t1[20:0], 4'b0} : t1;
-always @ (posedge(clk)) t3 <= sc[4] ? {t2[8:0], 16'b0} : t2;
-
-assign stall = run & ~(State == 3);
-always @ (posedge(clk)) State <= run ? State + 1 : 0;
-
-assign z = v ? {{7{Sum[26]}}, Sum[25:1]} :  // FLOOR
-    xn ? (u|yn ? 0 : y) :   // FLT or x = y = 0
-    yn ? x :
-    ((t3 == 0) | e1[8]) ? 0 : 
-	 {Sum[26], e1[7:0], t3[23:1]};
-endmodule
-
+`timescale 1ns / 1ps  // NW 4.10.2016  pipelined
+// u = 1: FLT; v = 1: FLOOR
+
+module FPAdder(
+  input clk, run, u, v,
+  input [31:0] x, y,
+  output stall,
+  output [31:0] z);
+
+reg [1:0] State;
+
+wire xs, ys, xn, yn;  // signs, null
+wire [7:0] xe, ye;
+wire [24:0] xm, ym;
+
+wire [8:0] dx, dy, e0, e1;
+wire [7:0] sx, sy;  // shift counts
+wire [1:0] sx0, sx1, sy0, sy1;
+wire sxh, syh;
+wire [24:0] x0, x1, x2, y0, y1, y2;
+reg [24:0] x3, y3;
+
+reg [26:0] Sum;
+wire [26:0] s;
+
+wire z24, z22, z20, z18, z16, z14, z12, z10, z8, z6, z4, z2;
+wire [4:0] sc;  // shift count
+wire [1:0] sc0, sc1;
+wire [24:0] t1, t2;
+reg [24:0] t3;
+
+assign xs = x[31];  // sign x
+assign xe = u ? 8'h96 : x[30:23];  // expo x
+assign xm = {~u|x[23], x[22:0], 1'b0};  //mant x
+assign xn = (x[30:0] == 0);
+assign ys = y[31];  // sign y
+assign ye = y[30:23];  // expo y
+assign ym = {~u&~v, y[22:0], 1'b0};  //mant y
+assign yn = (y[30:0] == 0);
+
+assign dx = xe - ye;
+assign dy = ye - xe;
+assign e0 = (dx[8]) ? ye : xe;
+assign sx = dy[8] ? 0 : dy;
+assign sy = dx[8] ? 0 : dx;
+assign sx0 = sx[1:0];
+assign sx1 = sx[3:2];
+assign sy0 = sy[1:0];
+assign sy1 = sy[3:2];
+assign sxh = sx[7] | sx[6] | sx[5];
+assign syh = sy[7] | sy[6] | sy[5];
+
+// denormalize, shift right
+assign x0 = xs&~u ? -xm : xm;
+assign x1 = (sx0 == 3) ? {{3{xs}}, x0[24:3]} :
+  (sx0 == 2) ? {{2{xs}}, x0[24:2]} : (sx0 == 1) ? {xs, x0[24:1]} : x0;
+assign x2 = (sx1 == 3) ? {{12{xs}}, x1[24:12]} :
+  (sx1 == 2) ? {{8{xs}}, x1[24:8]} : (sx1 == 1) ? {{4{xs}}, x1[24:4]} : x1;
+always @ (posedge(clk))
+  x3 <= sxh ? {25{xs}} : (sx[4] ? {{16{xs}}, x2[24:16]} : x2);
+
+assign y0 = ys&~u ? -ym : ym;
+assign y1 = (sy0 == 3) ? {{3{ys}}, y0[24:3]} :
+  (sy0 == 2) ? {{2{ys}}, y0[24:2]} : (sy0 == 1) ? {ys, y0[24:1]} : y0;
+assign y2 = (sy1 == 3) ? {{12{ys}}, y1[24:12]} :
+  (sy1 == 2) ? {{8{ys}}, y1[24:8]} : (sy1 == 1) ? {{4{ys}}, y1[24:4]} : y1;
+always @ (posedge(clk))
+	y3 <= syh ? {25{ys}} : (sy[4] ? {{16{ys}}, y2[24:16]} : y2);
+	
+// add
+always @ (posedge(clk)) Sum <= {xs, xs, x3} + {ys, ys, y3};
+assign s = (Sum[26] ? -Sum : Sum) + 1;
+
+// post-normalize
+assign z24 = ~s[25] & ~ s[24];
+assign z22 = z24 & ~s[23] & ~s[22];
+assign z20 = z22 & ~s[21] & ~s[20];
+assign z18 = z20 & ~s[19] & ~s[18];
+assign z16 = z18 & ~s[17] & ~s[16];
+assign z14 = z16 & ~s[15] & ~s[14];
+assign z12 = z14 & ~s[13] & ~s[12];
+assign z10 = z12 & ~s[11] & ~s[10];
+assign z8 = z10 & ~s[9] & ~s[8];
+assign z6 = z8 & ~s[7] & ~s[6];
+assign z4 = z6 & ~s[5] & ~s[4];
+assign z2 = z4 & ~s[3] & ~s[2];
+
+assign sc[4] = z10;  // sc = shift count of post normalization
+assign sc[3] = z18 & (s[17] | s[16] | s[15] | s[14] | s[13] | s[12] | s[11] | s[10])
+      | z2;
+assign sc[2] = z22 & (s[21] | s[20] | s[19] | s[18])
+      | z14 & (s[13] | s[12] | s[11] | s[10])
+      | z6 & (s[5] | s[4] | s[3] | s[2]);
+assign sc[1] = z24 & (s[23] | s[22])
+      | z20 & (s[19] | s[18])
+      | z16 & (s[15] | s[14])
+      | z12 & (s[11] | s[10])
+      | z8 & (s[7] | s[6])
+      | z4 & (s[3] | s[2]);
+assign sc[0] = ~s[25] & s[24]
+      | z24 & ~s[23] & s[22]
+      | z22 & ~s[21] & s[20]
+      | z20 & ~s[19] & s[18]
+      | z18 & ~s[17] & s[16]
+      | z16 & ~s[15] & s[14]
+      | z14 & ~s[13] & s[12]
+      | z12 & ~s[11] & s[10]
+      | z10 & ~s[9] & s[8]
+      | z8 & ~s[7] & s[6]
+      | z6 & ~s[5] & s[4]
+      | z4 & ~s[3] & s[2];
+
+assign e1 = e0 - sc + 1;
+assign sc0 = sc[1:0];
+assign sc1 = sc[3:2];
+
+assign t1 = (sc0 == 3) ? {s[22:1], 3'b0} :
+  (sc0 == 2) ? {s[23:1], 2'b0} : (sc0 == 1) ? {s[24:1], 1'b0} : s[25:1];
+assign t2 = (sc1 == 3) ? {t1[12:0], 12'b0} :
+  (sc1 == 2) ? {t1[16:0], 8'b0} : (sc1 == 1) ? {t1[20:0], 4'b0} : t1;
+always @ (posedge(clk)) t3 <= sc[4] ? {t2[8:0], 16'b0} : t2;
+
+assign stall = run & ~(State == 3);
+always @ (posedge(clk)) State <= run ? State + 1 : 0;
+
+assign z = v ? {{7{Sum[26]}}, Sum[25:1]} :  // FLOOR
+    xn ? (u|yn ? 0 : y) :   // FLT or x = y = 0
+    yn ? x :
+    ((t3 == 0) | e1[8]) ? 0 : 
+	 {Sum[26], e1[7:0], t3[23:1]};
+endmodule
+

people.inf.ethz.ch/wirth/ProjectOberon/SourcesVerilog/FPDivider.v

@@ -1,45 +1,45 @@
-`timescale 1ns / 1ps   // NW 16.9.2016
-
-module FPDivider(
-    input clk, run,
-    input [31:0] x,
-    input [31:0] y,
-    output stall,
-    output [31:0] z);
-
-reg [4:0] S;  // state
-reg [23:0] R;
-reg [25:0] Q;
-
-wire sign;
-wire [7:0] xe, ye;
-wire [8:0] e0, e1;
-wire [24:0] r0, r1, d;
-wire [25:0] q0;
-wire [24:0] z0, z1;
-
-assign sign = x[31]^y[31];
-assign xe = x[30:23];
-assign ye = y[30:23];
-assign e0 = {1'b0, xe} - {1'b0, ye};
-assign e1 = e0 + 126 + Q[25];
-assign stall = run & ~(S == 26);
-
-assign r0 = (S == 0) ? {2'b01, x[22:0]} : {R, 1'b0};
-assign r1 = d[24] ? r0 : d;
-assign d = r0 - {2'b01, y[22:0]};
-assign q0 = (S == 0) ? 0 : Q;
-
-assign z0 = Q[25] ? Q[25:1] : Q[24:0];
-assign z1 = z0 + 1;
-assign z = (xe == 0) ? 0 :
-  (ye == 0) ? {sign, 8'b11111111, 23'b0} :  // div by 0
-  (~e1[8]) ? {sign, e1[7:0], z1[23:1]} :
-  (~e1[7]) ? {sign, 8'b11111111, z0[23:1]} : 0;  // NaN
-
-always @ (posedge(clk)) begin
-  R <= r1[23:0];
-  Q <= {q0[24:0], ~d[24]};
-  S <= run ? S+1 : 0;
-end
-endmodule
+`timescale 1ns / 1ps   // NW 16.9.2016
+
+module FPDivider(
+    input clk, run,
+    input [31:0] x,
+    input [31:0] y,
+    output stall,
+    output [31:0] z);
+
+reg [4:0] S;  // state
+reg [23:0] R;
+reg [25:0] Q;
+
+wire sign;
+wire [7:0] xe, ye;
+wire [8:0] e0, e1;
+wire [24:0] r0, r1, d;
+wire [25:0] q0;
+wire [24:0] z0, z1;
+
+assign sign = x[31]^y[31];
+assign xe = x[30:23];
+assign ye = y[30:23];
+assign e0 = {1'b0, xe} - {1'b0, ye};
+assign e1 = e0 + 126 + Q[25];
+assign stall = run & ~(S == 26);
+
+assign r0 = (S == 0) ? {2'b01, x[22:0]} : {R, 1'b0};
+assign r1 = d[24] ? r0 : d;
+assign d = r0 - {2'b01, y[22:0]};
+assign q0 = (S == 0) ? 0 : Q;
+
+assign z0 = Q[25] ? Q[25:1] : Q[24:0];
+assign z1 = z0 + 1;
+assign z = (xe == 0) ? 0 :
+  (ye == 0) ? {sign, 8'b11111111, 23'b0} :  // div by 0
+  (~e1[8]) ? {sign, e1[7:0], z1[23:1]} :
+  (~e1[7]) ? {sign, 8'b11111111, z0[23:1]} : 0;  // NaN
+
+always @ (posedge(clk)) begin
+  R <= r1[23:0];
+  Q <= {q0[24:0], ~d[24]};
+  S <= run ? S+1 : 0;
+end
+endmodule

people.inf.ethz.ch/wirth/ProjectOberon/SourcesVerilog/FPMultiplier.v

@@ -1,34 +1,34 @@
-`timescale 1ns / 1ps  // NW 15.9.2015  8.8.2016
-module FPMultiplier(
-  input clk, run,
-  input [31:0] x, y,
-  output stall,
-  output [31:0] z);
-
-reg [4:0] S;  // state
-reg [47:0] P; // product
-
-wire sign;
-wire [7:0] xe, ye;
-wire [8:0] e0, e1;
-wire [24:0] w1, z0;
-wire [23:0] w0;
-
-assign sign = x[31] ^ y[31];
-assign xe = x[30:23];
-assign ye = y[30:23];
-assign e0 = xe + ye;
-assign e1 = e0 - 127 + P[47];
-
-assign stall = run & ~(S == 25);
-assign w0 = P[0] ? {1'b1, y[22:0]} : 0;
-assign w1 = {1'b0, P[47:24]} + {1'b0, w0};
-assign z0 = P[47] ? P[47:23]+1 : P[46:22]+1;  // round and normalize
-assign z = (xe == 0) | (ye == 0) ? 0 :
-   (~e1[8]) ? {sign, e1[7:0], z0[23:1]} :
-   (~e1[7]) ? {sign, 8'b11111111, z0[23:1]} : 0;
-always @ (posedge(clk)) begin
-    P <= (S == 0) ? {24'b0, 1'b1, x[22:0]} : {w1, P[23:1]};
-    S <= run ? S+1 : 0;
-end
-endmodule
+`timescale 1ns / 1ps  // NW 15.9.2015  8.8.2016
+module FPMultiplier(
+  input clk, run,
+  input [31:0] x, y,
+  output stall,
+  output [31:0] z);
+
+reg [4:0] S;  // state
+reg [47:0] P; // product
+
+wire sign;
+wire [7:0] xe, ye;
+wire [8:0] e0, e1;
+wire [24:0] w1, z0;
+wire [23:0] w0;
+
+assign sign = x[31] ^ y[31];
+assign xe = x[30:23];
+assign ye = y[30:23];
+assign e0 = xe + ye;
+assign e1 = e0 - 127 + P[47];
+
+assign stall = run & ~(S == 25);
+assign w0 = P[0] ? {1'b1, y[22:0]} : 0;
+assign w1 = {1'b0, P[47:24]} + {1'b0, w0};
+assign z0 = P[47] ? P[47:23]+1 : P[46:22]+1;  // round and normalize
+assign z = (xe == 0) | (ye == 0) ? 0 :
+   (~e1[8]) ? {sign, e1[7:0], z0[23:1]} :
+   (~e1[7]) ? {sign, 8'b11111111, z0[23:1]} : 0;
+always @ (posedge(clk)) begin
+    P <= (S == 0) ? {24'b0, 1'b1, x[22:0]} : {w1, P[23:1]};
+    S <= run ? S+1 : 0;
+end
+endmodule

people.inf.ethz.ch/wirth/ProjectOberon/SourcesVerilog/LeftShifter.v

@@ -1,22 +1,22 @@
-`timescale 1ns / 1ps  // NW 9.11.2016
-
-module LeftShifter(
-input [31:0] x,
-input [4:0] sc,
-output [31:0] y);
-
-// shifter for LSL
-wire [1:0] sc0, sc1;
-wire [31:0] t1, t2;
-
-assign sc0 = sc[1:0];
-assign sc1 = sc[3:2];
-
-assign t1 = (sc0 == 3) ? {x[28:0], 3'b0} :
-    (sc0 == 2) ? {x[29:0], 2'b0} :
-    (sc0 == 1) ? {x[30:0], 1'b0} : x;
-assign t2 = (sc1 == 3) ? {t1[19:0], 12'b0} :
-    (sc1 == 2) ? {t1[23:0], 8'b0} :
-    (sc1 == 1) ? {t1[27:0], 4'b0} : t1;
-assign y = sc[4] ? {t2[15:0], 16'b0} : t2;
+`timescale 1ns / 1ps  // NW 9.11.2016
+
+module LeftShifter(
+input [31:0] x,
+input [4:0] sc,
+output [31:0] y);
+
+// shifter for LSL
+wire [1:0] sc0, sc1;
+wire [31:0] t1, t2;
+
+assign sc0 = sc[1:0];
+assign sc1 = sc[3:2];
+
+assign t1 = (sc0 == 3) ? {x[28:0], 3'b0} :
+    (sc0 == 2) ? {x[29:0], 2'b0} :
+    (sc0 == 1) ? {x[30:0], 1'b0} : x;
+assign t2 = (sc1 == 3) ? {t1[19:0], 12'b0} :
+    (sc1 == 2) ? {t1[23:0], 8'b0} :
+    (sc1 == 1) ? {t1[27:0], 4'b0} : t1;
+assign y = sc[4] ? {t2[15:0], 16'b0} : t2;
 endmodule

people.inf.ethz.ch/wirth/ProjectOberon/SourcesVerilog/MouseP.v

@@ -1,44 +1,44 @@
-`timescale 1ns / 1ps  // PS/2 Logitech mouse PDR 14.10.2013 / 8.9.2015
-module MouseP(
-  input clk, rst,
-  inout msclk, msdat,
-  output [27:0] out);
-
-  reg [9:0] x, y;
-  reg [2:0] btns;
-  reg Q0, Q1, run;
-  reg [31:0] shreg;
-  wire shift, endbit, reply;
-  wire [9:0] dx, dy;
-
-// 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1                 bit
-// 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
-// ===============================================================
-// p y y y y y y y y 0 1 p x x x x x x x x 0 1 p Y X t s 1 M R L 0 normal
-// ---------------------------------------------------------------
-// p ----response--- 0 1 --InitBuf echoed--- 1 1 1 1 1 1 1 1 1 1 1 init
-// ---------------------------------------------------------------
-// p = parity (ignored); X, Y = overflow; s, t = x, y sign bits
-
-  // initially need to send F4 cmd (start reporting); add start and parity bits
-  localparam InitBuf = 32'b11111111111111111111110_11110100_0;
-  assign msclk = ~rst ? 0 : 1'bz;  // initial drive clock low
-  assign msdat = ~run & ~shreg[0] ? 0 : 1'bz;
-  assign shift = Q1 & ~Q0;  // falling edge detector
-  assign reply = ~run & ~shreg[11];  // start bit of echoed InitBuf, if response
-  assign endbit = run & ~shreg[0];  // normal packet received
-  assign dx = {{2{shreg[5]}}, shreg[7] ? 8'b0 : shreg[19:12]};  //sign+overfl
-  assign dy = {{2{shreg[6]}}, shreg[8] ? 8'b0 : shreg[30:23]};  //sign+overfl
-  assign out = {run, btns, 2'b0, y, 2'b0, x};
-
-  always @ (posedge clk) begin
-    run <= rst & (reply | run); Q0 <= msclk; Q1 <= Q0;
-    shreg <= ~rst ? InitBuf : (endbit | reply) ? -1 : shift ? {msdat,
-shreg[31:1]} : shreg;
-    x <= ~rst ? 0 : endbit ? x + dx : x;  y <= ~rst ? 0 : endbit ? y + dy
-: y;
-    btns <= ~rst ? 0 : endbit ? {shreg[1], shreg[3], shreg[2]} : btns;
-  end
-
-endmodule
-
+`timescale 1ns / 1ps  // PS/2 Logitech mouse PDR 14.10.2013 / 8.9.2015
+module MouseP(
+  input clk, rst,
+  inout msclk, msdat,
+  output [27:0] out);
+
+  reg [9:0] x, y;
+  reg [2:0] btns;
+  reg Q0, Q1, run;
+  reg [31:0] shreg;
+  wire shift, endbit, reply;
+  wire [9:0] dx, dy;
+
+// 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1                 bit
+// 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
+// ===============================================================
+// p y y y y y y y y 0 1 p x x x x x x x x 0 1 p Y X t s 1 M R L 0 normal
+// ---------------------------------------------------------------
+// p ----response--- 0 1 --InitBuf echoed--- 1 1 1 1 1 1 1 1 1 1 1 init
+// ---------------------------------------------------------------
+// p = parity (ignored); X, Y = overflow; s, t = x, y sign bits
+
+  // initially need to send F4 cmd (start reporting); add start and parity bits
+  localparam InitBuf = 32'b11111111111111111111110_11110100_0;
+  assign msclk = ~rst ? 0 : 1'bz;  // initial drive clock low
+  assign msdat = ~run & ~shreg[0] ? 0 : 1'bz;
+  assign shift = Q1 & ~Q0;  // falling edge detector
+  assign reply = ~run & ~shreg[11];  // start bit of echoed InitBuf, if response
+  assign endbit = run & ~shreg[0];  // normal packet received
+  assign dx = {{2{shreg[5]}}, shreg[7] ? 8'b0 : shreg[19:12]};  //sign+overfl
+  assign dy = {{2{shreg[6]}}, shreg[8] ? 8'b0 : shreg[30:23]};  //sign+overfl
+  assign out = {run, btns, 2'b0, y, 2'b0, x};
+
+  always @ (posedge clk) begin
+    run <= rst & (reply | run); Q0 <= msclk; Q1 <= Q0;
+    shreg <= ~rst ? InitBuf : (endbit | reply) ? -1 : shift ? {msdat,
+shreg[31:1]} : shreg;
+    x <= ~rst ? 0 : endbit ? x + dx : x;  y <= ~rst ? 0 : endbit ? y + dy
+: y;
+    btns <= ~rst ? 0 : endbit ? {shreg[1], shreg[3], shreg[2]} : btns;
+  end
+
+endmodule
+

people.inf.ethz.ch/wirth/ProjectOberon/SourcesVerilog/Multiplier.v

@@ -1,25 +1,25 @@
-`timescale 1ns / 1ps   // NW 14.9.2015
-
-module Multiplier(
-  input clk, run, u,
-  output stall,
-  input [31:0] x, y,
-  output [63:0] z);
-
-reg [5:0] S;    // state
-reg [63:0] P;   // product
-wire [31:0] w0;
-wire [32:0] w1;
-
-assign stall = run & ~(S == 33);
-assign w0 = P[0] ? y : 0;
-assign w1 = (S == 32) & u ? {P[63], P[63:32]} - {w0[31], w0} :
-       {P[63], P[63:32]} + {w0[31], w0};
-assign z = P;
-
-always @ (posedge(clk)) begin
-  P <= (S == 0) ? {32'b0, x} : {w1[32:0], P[31:1]};
-  S <= run ? S+1 : 0;
-end
-
-endmodule
+`timescale 1ns / 1ps   // NW 14.9.2015
+
+module Multiplier(
+  input clk, run, u,
+  output stall,
+  input [31:0] x, y,
+  output [63:0] z);
+
+reg [5:0] S;    // state
+reg [63:0] P;   // product
+wire [31:0] w0;
+wire [32:0] w1;
+
+assign stall = run & ~(S == 33);
+assign w0 = P[0] ? y : 0;
+assign w1 = (S == 32) & u ? {P[63], P[63:32]} - {w0[31], w0} :
+       {P[63], P[63:32]} + {w0[31], w0};
+assign z = P;
+
+always @ (posedge(clk)) begin
+  P <= (S == 0) ? {32'b0, x} : {w1[32:0], P[31:1]};
+  S <= run ? S+1 : 0;
+end
+
+endmodule

people.inf.ethz.ch/wirth/ProjectOberon/SourcesVerilog/Multiplier1.v

@@ -1,28 +1,28 @@
-`timescale 1ns / 1ps  // NW 29.4.2011
-module Multiplier1(
-  input clk, run, u,
-  output stall,
-  input [31:0] x, y,
-  output [63:0] z);
-	 
-reg S;  // state
-reg [15:0] z0;
-reg [47:0] z1, z2;
-wire [35:0] p0, p1, p2, p3;
-
-assign stall = run & ~S;
-assign z[15:0] = z0;
-assign z[63:16] = z1 + z2;
-
-MULT18X18 mult0(.P(p0), .A({2'b0, x[15:0]}), .B({2'b0, y[15:0]}));
-MULT18X18 mult1(.P(p1), .A({{2{u&x[31]}}, x[31:16]}), .B({2'b0, y[15:0]}));
-MULT18X18 mult2(.P(p2), .A({2'b0, x[15:0]}), .B({{2{u&y[31]}}, y[31:16]}));
-MULT18X18 mult3(.P(p3), .A({{2{u&x[31]}}, x[31:16]}), .B({{2{u&y[31]}}, y[31:16]}));
-
-always @(posedge clk) begin
-  S <= stall;
-  z0 <= p0[15:0];
-  z1 <= {{32'b0}, p0[31:16]} + {{16{u&p1[31]}}, p1[31:0]};
-  z2 <= {{16{u&p2[31]}}, p2[31:0]} + {p3[31:0], 16'b0};
-end
-endmodule
+`timescale 1ns / 1ps  // NW 29.4.2011
+module Multiplier1(
+  input clk, run, u,
+  output stall,
+  input [31:0] x, y,
+  output [63:0] z);
+	 
+reg S;  // state
+reg [15:0] z0;
+reg [47:0] z1, z2;
+wire [35:0] p0, p1, p2, p3;
+
+assign stall = run & ~S;
+assign z[15:0] = z0;
+assign z[63:16] = z1 + z2;
+
+MULT18X18 mult0(.P(p0), .A({2'b0, x[15:0]}), .B({2'b0, y[15:0]}));
+MULT18X18 mult1(.P(p1), .A({{2{u&x[31]}}, x[31:16]}), .B({2'b0, y[15:0]}));
+MULT18X18 mult2(.P(p2), .A({2'b0, x[15:0]}), .B({{2{u&y[31]}}, y[31:16]}));
+MULT18X18 mult3(.P(p3), .A({{2{u&x[31]}}, x[31:16]}), .B({{2{u&y[31]}}, y[31:16]}));
+
+always @(posedge clk) begin
+  S <= stall;
+  z0 <= p0[15:0];
+  z1 <= {{32'b0}, p0[31:16]} + {{16{u&p1[31]}}, p1[31:0]};
+  z2 <= {{16{u&p2[31]}}, p2[31:0]} + {p3[31:0], 16'b0};
+end
+endmodule

people.inf.ethz.ch/wirth/ProjectOberon/SourcesVerilog/PROM.v

@@ -1,12 +1,12 @@
-`timescale 1ns / 1ps // 32-bit PROM initialised from hex file  PDR 23.12.13
-
-module PROM (input clk,
-  input [8:0] adr,
-  output reg [31:0] data);
-  
-reg [31:0] mem [511: 0];
-initial $readmemh("../prom.mem", mem);
-always @(posedge clk) data <= mem[adr];
-
-endmodule
-
+`timescale 1ns / 1ps // 32-bit PROM initialised from hex file  PDR 23.12.13
+
+module PROM (input clk,
+  input [8:0] adr,
+  output reg [31:0] data);
+  
+reg [31:0] mem [511: 0];
+initial $readmemh("../prom.mem", mem);
+always @(posedge clk) data <= mem[adr];
+
+endmodule
+