Oberon-0: https://inf.ethz.ch/personal/wirth/CompilerConstruction/index.html

io.mod

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.

osg.mod

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.

osp.mod

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.

oss.mod

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.

risc.mod

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.

test_oberon0.mod

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.