site relocation

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -0,0 +1,13 @@
+`timescale 1ns / 1ps
+module DRAM(input [10:0] adr,
+    input [31:0] din,
+    output reg [31:0] dout,
+    input we,
+    input clk);
+reg [31:0] mem [2047: 0];
+always @(posedge clk) begin
+    if (we) mem[adr] <= din;
+	 dout <= mem[adr];
+end	 
+endmodule
+

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

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

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

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

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

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

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

@@ -0,0 +1,10 @@
+`timescale 1ns / 1ps
+module PROM(
+    input [10:0] adr,
+    output reg [31:0] data,
+    input clk);
+reg [31:0] mem [2047: 0];
+initial $readmemh("../prom.mem", mem);
+always @(posedge clk) data <= mem[adr];
+endmodule
+

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

@@ -0,0 +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";

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

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

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

@@ -0,0 +1,57 @@
+`timescale 1ns / 1ps  // NW 27.5.09  LL 10.12.09  NW 28.7.2011
+
+module RISC0Top(
+  input CLK50M,
+  input rstIn,
+  input RxD,
+  input [7:0] swi,
+  output TxD,
+  output [7:0] leds);
+	 
+wire clk, clk50;
+reg rst, clk25;
+
+wire[5:0] ioadr;
+wire [3:0] iowadr;
+wire iowr;
+wire[31:0] inbus, outbus;
+
+wire [7:0] dataTx, dataRx;
+wire rdyRx, doneRx, startTx, rdyTx;
+wire limit;  // of cnt0
+
+reg [7:0] Lreg;
+reg [15:0] cnt0;
+reg [31:0] cnt1; // milliseconds
+
+RISC0 riscx(.clk(clk), .rst(rst), .iord(iord), .iowr(iowr),
+   .ioadr(ioadr), .inbus(inbus), .outbus(outbus));
+			
+RS232R receiver(.clk(clk), .rst(rst), .RxD(RxD), .done(doneRx), .data(dataRx), .rdy(rdyRx));
+RS232T transmitter(.clk(clk), .rst(rst), .start(startTx), .data(dataTx), .TxD(TxD), .rdy(rdyTx));
+
+assign iowadr = ioadr[5:2];
+assign inbus = (iowadr == 0) ? cnt1 :
+    (iowadr == 1) ? swi :
+    (iowadr == 2) ? {24'b0, dataRx} :
+    (iowadr == 3) ? {30'b0, rdyTx, rdyRx} : 0;
+    
+assign dataTx = outbus[7:0];
+assign startTx = iowr & (iowadr == 2);
+assign doneRx = iord & (iowadr == 2);
+assign limit = (cnt0 == 25000);
+assign leds = Lreg;
+
+always @(posedge clk) 
+begin
+  rst <= ~rstIn;
+  Lreg <= ~rst ? 0 : (iowr & (iowadr == 1)) ? outbus[7:0] : Lreg;
+  cnt0 <= limit ? 0 : cnt0 + 1;
+  cnt1 <= limit ? cnt1 + 1 : cnt1;
+end
+
+//The Clocks
+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

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

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

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

people.inf.ethz.ch/wirth/FPGA-relatedWork/StandalonePrograms.Mod.txt

@@ -0,0 +1,29 @@
+(* ORP.Compile @  ORTool.DecObj Counter.rsc
+  ORX.WriteFile Counter.rsc 2048 "D:/Verilog/RISC/prom.mem"~
+  ORX.WriteFile Shifter.rsc 2048 "D:/Verilog/RISC/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.
+

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -0,0 +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
+
+Blinkers.Make  Blinkers.Blink  Blinkers.Run  Blinkers.Stop

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

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

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

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

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

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

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

@@ -0,0 +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;
+
+END Files.

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

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

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

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