updated to 25.06.2014

BlackBox/Po/Files/ORB.Mod.txt

@@ -1,4 +1,4 @@
-MODULE ORB;   (*NW 7.10.2013   in Oberon-07*)
+MODULE ORB;   (*NW 25.6.2014   in Oberon-07*)
   IMPORT Files, ORS;
   (*Definition of data types Object and Type, which together form the data structure
     called "symbol table". Contains procedures for creation of Objects, and for search:
@@ -193,7 +193,7 @@ MODULE ORB;   (*NW 7.10.2013   in Oberon-07*)
         IF obj # NIL THEN T := obj.type   (*type object found in object list of mod*)
         ELSE (*insert new type object in object list of mod*)
           NEW(obj); obj.name := name; obj.class := Typ; obj.next := mod.dsc; mod.dsc := obj; obj.type := t;
-          t.mno := mod.lev; T := t
+          t.mno := mod.lev; t.typobj := obj; T := t
         END ;
         typtab[ref] := T
       END
@@ -239,7 +239,7 @@ MODULE ORB;   (*NW 7.10.2013   in Oberon-07*)
   (*-------------------------------- Export ---------------------------------*)
 
   PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
-  BEGIN Files.WriteByte(R, x)  (* -128 <= x < 128 *)
+  BEGIN Files.WriteByte(R, x)
   END Write;
 
   PROCEDURE OutType(VAR R: Files.Rider; t: Type);
@@ -272,11 +272,7 @@ MODULE ORB;   (*NW 7.10.2013   in Oberon-07*)
     ELSE obj := t.typobj;
       IF obj # NIL THEN Write(R, Ref); t.ref := Ref; INC(Ref) ELSE (*anonymous*) Write(R, 0) END ;
       Write(R, t.form);
-      IF t.form = Pointer THEN
-        IF t.base.ref > 0 THEN Write(R, -t.base.ref)
-        ELSIF (t.base.typobj = NIL) OR ~t.base.typobj.expo THEN (*base not exported*) Write(R, -1)
-        ELSE OutType(R, t.base)
-        END
+      IF t.form = Pointer THEN OutType(R, t.base)
       ELSIF t.form = Array THEN OutType(R, t.base); Files.WriteNum(R, t.len); Files.WriteNum(R, t.size)
       ELSIF t.form = Record THEN
         IF t.base # NIL THEN OutType(R, t.base) ELSE OutType(R, noType) END ;
@@ -286,11 +282,11 @@ MODULE ORB;   (*NW 7.10.2013   in Oberon-07*)
         WHILE fld # NIL DO  (*fields*)
           IF fld.expo THEN
             Write(R, Fld); Files.WriteString(R, fld.name); OutType(R, fld.type); Files.WriteNum(R, fld.val)
-          ELSE FindHiddenPointers(R, fld.type, fld.val)
+          ELSE FindHiddenPointers(R, fld.type, fld.val)  (*offset*)
           END ;
           fld := fld.next
         END ;
-         Write(R, 0)
+        Write(R, 0)
       ELSIF t.form = Proc THEN OutType(R, t.base); OutPar(R, t.dsc, t.nofpar); Write(R, 0)
       END ;
       IF (t.mno > 0) & (obj # NIL) THEN  (*re-export, output name*)
@@ -344,13 +340,13 @@ MODULE ORB;   (*NW 7.10.2013   in Oberon-07*)
     END ;
     REPEAT Write(R, 0) UNTIL Files.Length(F) MOD 4 = 0;
     FOR Ref := Record+1 TO maxTypTab-1 DO typtab[Ref] := NIL END ;
-    Files.Set(R, F, 0); sum := 0;  (* compute key (checksum) *)
-    WHILE ~R.eof DO Files.ReadInt(R, x); sum := sum + x END ;
+    Files.Set(R, F, 0); sum := 0; Files.ReadInt(R, x);  (* compute key (checksum) *)
+    WHILE ~R.eof DO sum := sum + x; Files.ReadInt(R, x) END ;
     F1 := Files.Old(filename); (*sum is new key*)
     IF F1 # NIL THEN Files.Set(R1, F1, 4); Files.ReadInt(R1, oldkey) ELSE oldkey := sum+1 END ;
     IF sum # oldkey THEN
-      IF newSF THEN
-        key := sum; Files.Set(R, F, 4); Files.WriteInt(R, sum); Files.Register(F)  (*insert checksum*)
+      IF newSF OR (F1 = NIL) THEN
+        key := sum; newSF := TRUE; Files.Set(R, F, 4); Files.WriteInt(R, sum); Files.Register(F)  (*insert checksum*)
       ELSE ORS.Mark("new symbol file inhibited")
       END
     ELSE newSF := FALSE; key := sum
@@ -387,7 +383,7 @@ BEGIN
     
   (*initialize universe with data types and in-line procedures;
     LONGINT is synonym to INTEGER, LONGREAL to REAL.
-    LED, ADC, SBC; LDPSR, LDREG, REG, COND, MSK are not in language definition*)
+    LED, ADC, SBC; LDPSR, LDREG, REG, COND are not in language definition*)
   system := NIL;  (*n = procno*10 + nofpar*)
   enter("UML", SFunc, intType, 132);  (*functions*)
   enter("SBC", SFunc, intType, 122);

BlackBox/Po/Files/ORG.Mod.txt

@@ -1,4 +1,4 @@
-MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
+MODULE ORG; (* NW  24.6.2014  code generator in Oberon-07 for RISC*)
   IMPORT SYSTEM, Files, ORS, ORB;
   (*Code generator for Oberon compiler for RISC processor.
      Procedural interface to Parser OSAP; result in array "code".
@@ -10,7 +10,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
     maxCode = 8000; maxStrx = 2400; maxTD = 120; C24 = 1000000H;
     Reg = 10; RegI = 11; Cond = 12;  (*internal item modes*)
 
-  (*frequently used opcodes*)  U = 2000H;
+  (*frequently used opcodes*)  U = 2000H; V = 1000H;
     Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7;
     Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11;
     Fad = 12; Fsb = 13; Fml = 14; Fdv = 15;
@@ -28,7 +28,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
   (* Item forms and meaning of fields:
     mode    r      a       b
     --------------------------------
-    Const   -     value (proc adr)   (immediate value)
+    Const   -     value (proc adr)  (immediate value)
     Var     base   off     -               (direct adr)
     Par      -     off0     off1         (indirect adr)
     Reg    regno
@@ -40,8 +40,9 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
     entry: LONGINT;   (*main entry point*)
     RH: LONGINT;  (*available registers R[0] ... R[H-1]*)
     curSB: LONGINT;  (*current static base in SB*)
+    frame: LONGINT;  (*frame offset changed in SaveRegs and RestoreRegs*)
     fixorgP, fixorgD, fixorgT: LONGINT;   (*origins of lists of locations to be fixed up by loader*)
-    check, inhibitCalls: BOOLEAN;  (*emit run-time checks*)
+    check: BOOLEAN;  (*emit run-time checks*)
     version: INTEGER;  (* 0 = RISC-0, 1 = RISC-5 *)
     
     relmap: ARRAY 6 OF INTEGER;  (*condition codes for relations*)
@@ -58,7 +59,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
 
   PROCEDURE Put1(op, a, b, im: LONGINT);
   BEGIN (*emit format-1 instruction,  -10000H <= im < 10000H*)
-    IF im < 0 THEN INC(op, 1000H) END ;  (*set v-bit*)
+    IF im < 0 THEN INC(op, V) END ;
     code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc)
   END Put1;
 
@@ -83,36 +84,21 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
 
   PROCEDURE incR;
   BEGIN
-    IF RH < MT THEN INC(RH) ELSE ORS.Mark("register stack overflow") END
+    IF RH < MT-1 THEN INC(RH) ELSE ORS.Mark("register stack overflow") END
   END incR;
 
   PROCEDURE CheckRegs*;
   BEGIN
     IF RH # 0 THEN ORS.Mark("Reg Stack"); RH := 0 END ;
-    IF pc >= maxCode - 40 THEN ORS.Mark("Program too long"); END
+    IF pc >= maxCode - 40 THEN ORS.Mark("Program too long") END
   END CheckRegs;
 
-  PROCEDURE SaveRegs(r: LONGINT); (* R[0 .. r-1] to be saved; R[r .. RH-1] to be moved down*)
-    VAR rs, rd: LONGINT;  (*r > 0*)
-  BEGIN rs := r; rd := 0;
-    REPEAT DEC(rs); Put1(Sub, SP, SP, 4); Put2(Str, rs, SP, 0) UNTIL rs = 0;
-    rs := r; rd := 0;
-    WHILE rs < RH DO Put0(Mov, rd, 0, rs); INC(rs); INC(rd) END ;
-    RH := rd
-  END SaveRegs;
-
-  PROCEDURE RestoreRegs(r: LONGINT; VAR x: Item); (*R[0 .. r-1] to be restored*)
-    VAR rd: LONGINT;  (*r > 0*)
-  BEGIN Put0(Mov, r, 0, 0); rd := 0;
-    REPEAT Put2(Ldr, rd, SP, 0); Put1(Add, SP, SP, 4); INC(rd) UNTIL rd = r
-  END RestoreRegs;
-
   PROCEDURE SetCC(VAR x: Item; n: LONGINT);
   BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n
   END SetCC;
 
   PROCEDURE Trap(cond, num: LONGINT);
-  BEGIN Put3(BLR, cond, ORS.Pos()*100H + num*10H + MT)
+  BEGIN num := ORS.Pos()*100H + num*10H + MT; Put3(BLR, cond, num)
   END Trap;
 
   (*handling of forward reference, fixups of branch addresses and constant tables*)
@@ -174,13 +160,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
   BEGIN
     IF x.type.size = 1 THEN op := Ldr+1 ELSE op := Ldr END ;
     IF x.mode # Reg THEN
-      IF x.mode = ORB.Var THEN
-        IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a)
-        ELSE GetSB(x.r); Put2(op, RH, SB, x.a)
-        END ;
-        x.r := RH; incR
-      ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a); Put2(op, RH, RH, x.b); x.r := RH; incR
-      ELSIF x.mode = ORB.Const THEN
+      IF x.mode = ORB.Const THEN
         IF x.type.form = ORB.Proc THEN
           IF x.r > 0 THEN ORS.Mark("not allowed")
           ELSIF x.r = 0 THEN Put3(BL, 7, 0); Put1a(Sub, RH, LNK, pc*4 - x.a)
@@ -191,6 +171,12 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
           IF x.a MOD 10000H # 0 THEN Put1(Ior, RH, RH, x.a MOD 10000H) END
         END ;
         x.r := RH; incR
+      ELSIF x.mode = ORB.Var THEN
+        IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a + frame)
+        ELSE GetSB(x.r); Put2(op, RH, SB, x.a)
+        END ;
+        x.r := RH; incR
+      ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, RH, RH, x.b); x.r := RH; incR
       ELSIF x.mode = RegI THEN Put2(op, x.r, x.r, x.a)
       ELSIF x.mode = Cond THEN
         Put3(BC, negated(x.r), 2);
@@ -204,16 +190,16 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
   PROCEDURE loadAdr(VAR x: Item);
   BEGIN
     IF x.mode = ORB.Var THEN
-      IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a)
+      IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a + frame)
       ELSE GetSB(x.r); Put1a(Add, RH, SB, x.a)
       END ;
       x.r := RH; incR
-    ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a);
+    ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame);
       IF x.b # 0 THEN Put1a(Add, RH, RH, x.b) END ;
       x.r := RH; incR
     ELSIF x.mode = RegI THEN
       IF x.a # 0 THEN Put1a(Add, x.r, x.r, x.a) END
-    ELSE ORS.Mark("address error") 
+    ELSE ORS.Mark("address error")
     END ;
     x.mode := Reg
   END loadAdr;
@@ -295,15 +281,15 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
       IF check THEN  (*check array bounds*)
         IF lim >= 0 THEN Put1a(Cmp, RH, y.r, lim)
         ELSE (*open array*)
-          IF x.mode IN {ORB.Var, ORB.Par} THEN Put2(Ldr, RH, SP, x.a+4); Put0(Cmp, RH, y.r, RH)
+          IF x.mode IN {ORB.Var, ORB.Par} THEN Put2(Ldr, RH, SP, x.a+4+frame); Put0(Cmp, RH, y.r, RH)
           ELSE ORS.Mark("error in Index")
           END
         END ;
-        Trap(10, 1)
+        Trap(10, 1)  (*BCC*)
       END ;
-      IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1(Mul, y.r, y.r, s) END ;
+      IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1a(Mul, y.r, y.r, s) END ;
       IF x.mode = ORB.Var THEN
-        IF x.r > 0 THEN Put0(Add, y.r, SP, y.r)
+        IF x.r > 0 THEN Put0(Add, y.r, SP, y.r); INC(x.a, frame)
         ELSE GetSB(x.r);
           IF x.r = 0 THEN Put0(Add, y.r, SB, y.r)
           ELSE Put1a(Add, RH, SB, x.a); Put0(Add, y.r, RH, y.r); x.a := 0
@@ -311,7 +297,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
         END ;
         x.r := y.r; x.mode := RegI
       ELSIF x.mode = ORB.Par THEN
-        Put2(Ldr, RH, SP, x.a);
+        Put2(Ldr, RH, SP, x.a + frame);
         Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r; x.a := x.b
       ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH)
       END
@@ -321,10 +307,10 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
   PROCEDURE DeRef*(VAR x: Item);
   BEGIN
     IF x.mode = ORB.Var THEN
-      IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a) ELSE GetSB(x.r); Put2(Ldr, RH, SB, x.a) END ;
+      IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a + frame) ELSE GetSB(x.r); Put2(Ldr, RH, SB, x.a) END ;
       NilCheck; x.r := RH; incR
     ELSIF x.mode = ORB.Par THEN
-      Put2(Ldr, RH, SP, x.a); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR
+      Put2(Ldr, RH, SP, x.a + frame); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR
     ELSIF x.mode = RegI THEN Put2(Ldr, x.r, x.r, x.a); NilCheck
     ELSIF x.mode # Reg THEN ORS.Mark("bad mode in DeRef")
     END ;
@@ -358,7 +344,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
     IF s <= 24 THEN s := 32 ELSIF s <= 56 THEN s := 64 ELSIF s <= 120 THEN s := 128
     ELSE s := (s+263) DIV 256 * 256
     END ;
-    data[dcw] := s; INC(dcw);
+    T.len := dc; data[dcw] := s; INC(dcw);
     k := T.nofpar;   (*extension level!*)
     IF k > 3 THEN ORS.Mark("ext level too large")
     ELSE Q(T, dcw);
@@ -369,13 +355,17 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
   END BuildTD;
 
   PROCEDURE TypeTest*(VAR x: Item; T: ORB.Type; varpar, isguard: BOOLEAN);
+    VAR pc0: LONGINT;
   BEGIN (*fetch tag into RH*)
-    IF varpar THEN Put2(Ldr, RH, SP, x.a+4)
-    ELSE load(x); NilCheck; Put2(Ldr, RH, x.r, -8)
+    IF varpar THEN Put2(Ldr, RH, SP, x.a+4+frame)
+    ELSE load(x);
+      pc0 := pc; Put3(BC, EQ, 0);  (*NIL belongs to every pointer type*)
+      Put2(Ldr, RH, x.r, -8)
     END ;
     Put2(Ldr, RH, RH, T.nofpar*4); incR;
     loadTypTagAdr(T);  (*tag of T*)
-    Put0(Cmp, RH, RH-1, RH-2); DEC(RH, 2);
+    Put0(Cmp, RH-1, RH-1, RH-2); DEC(RH, 2);
+    IF ~varpar THEN fix(pc0, pc - pc0 - 1) END ;
     IF isguard THEN
       IF check THEN Trap(NE, 2) END
     ELSE SetCC(x, EQ);
@@ -523,10 +513,10 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
     IF (x.mode = ORB.Const) & ( y.mode = ORB.Const) THEN
       IF x.a <= y.a THEN x.a := LSL(2, y.a) - LSL(1, x.a) ELSE x.a := 0 END
     ELSE
-      IF (x.mode = ORB.Const) & (x.a < 10H) THEN x.a := LSL(-1, x.a)
+      IF (x.mode = ORB.Const) & (x.a < 16) THEN x.a := LSL(-1, x.a)
       ELSE load(x); Put1(Mov, RH, 0, -1); Put0(Lsl, x.r, RH, x.r)
       END ;
-      IF (y.mode = ORB.Const) & (y.a < 10H) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; INC(RH)
+      IF (y.mode = ORB.Const) & (y.a < 16) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; incR
       ELSE load(y); Put1(Mov, RH, 0, -2); Put0(Lsl, y.r, RH, y.r)
       END ;
       IF x.mode = ORB.Const THEN
@@ -628,36 +618,36 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
   BEGIN  load(y);
     IF x.type.size = 1 THEN op := Str+1 ELSE op := Str END ;
     IF x.mode = ORB.Var THEN
-      IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a)
+      IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a + frame)
       ELSE GetSB(x.r); Put2(op, y.r, SB, x.a)
       END
-    ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a); Put2(op, y.r, RH, x.b);
+    ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, y.r, RH, x.b);
     ELSIF x.mode = RegI THEN Put2(op, y.r, x.r, x.a); DEC(RH);
     ELSE ORS.Mark("bad mode in Store")
     END ;
     DEC(RH)
   END Store;
 
-  PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y *)
+  PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y, frame = 0 *)
     VAR s, pc0: LONGINT;
   BEGIN loadAdr(x); loadAdr(y);
     IF (x.type.form = ORB.Array) & (x.type.len > 0) THEN
       IF y.type.len >= 0 THEN 
-        IF x.type.len >= y.type.len THEN Put1(Mov, RH, 0, (y.type.size+3) DIV 4)
+        IF x.type.len >= y.type.len THEN Put1a(Mov, RH, 0, (y.type.size+3) DIV 4)
         ELSE ORS.Mark("source array too long")
         END
       ELSE (*y is open array*)
         Put2(Ldr, RH, SP, y.a+4); s := y.type.base.size;  (*element size*)
         pc0 := pc; Put3(BC, EQ, 0);
         IF s = 1 THEN Put1(Add, RH, RH, 3); Put1(Asr, RH, RH, 2)
-        ELSIF s # 4 THEN Put1(Mul, RH, RH, s DIV 4)
+        ELSIF s # 4 THEN Put1a(Mul, RH, RH, s DIV 4)
         END ;
         IF check THEN
-          Put1(Mov, RH+1, 0, (x.type.size+3) DIV 4); Put0(Cmp, RH+1, RH, RH+1); Trap(GT, 3)
+          Put1a(Mov, RH+1, 0, (x.type.size+3) DIV 4); Put0(Cmp, RH+1, RH, RH+1); Trap(GT, 3)
         END ;
         fix(pc0, pc + 5 - pc0)
       END
-    ELSIF x.type.form = ORB.Record THEN Put1(Mov, RH, 0, x.type.size DIV 4)
+    ELSIF x.type.form = ORB.Record THEN Put1a(Mov, RH, 0, x.type.size DIV 4)
     ELSE ORS.Mark("inadmissible assignment")
     END ;
     Put2(Ldr, RH+1, y.r, 0); Put1(Add, y.r, y.r, 4);
@@ -685,10 +675,10 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
     VAR xmd: INTEGER;
   BEGIN xmd := x.mode; loadAdr(x);
     IF (ftype.form = ORB.Array) & (ftype.len < 0) THEN (*open array*)
-      IF x.type.len >= 0 THEN Put1(Mov, RH, 0, x.type.len) ELSE  Put2(Ldr, RH, SP, x.a+4) END ;
+      IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE  Put2(Ldr, RH, SP, x.a+4+frame) END ;
       incR
     ELSIF ftype.form = ORB.Record THEN
-      IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4); incR ELSE loadTypTagAdr(x.type) END
+      IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4+frame); incR ELSE loadTypTagAdr(x.type) END
     END
   END VarParam;
 
@@ -698,7 +688,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
 
   PROCEDURE OpenArrayParam*(VAR x: Item);
   BEGIN loadAdr(x);
-    IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4) END ;
+    IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ;
     incR
   END OpenArrayParam;
 
@@ -759,38 +749,47 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
   BEGIN FixLink(x.a)
   END Fixup;
 
+  PROCEDURE SaveRegs(r: LONGINT);  (* R[0 .. r-1]*)
+    VAR r0: LONGINT;
+  BEGIN (*r > 0*) r0 := 0;
+    Put1(Sub, SP, SP, r*4); INC(frame, 4*r);
+    REPEAT Put2(Str, r0, SP, (r-r0-1)*4); INC(r0) UNTIL r0 = r
+  END SaveRegs;
+
+  PROCEDURE RestoreRegs(r: LONGINT); (*R[0 .. r-1]*)
+    VAR r0: LONGINT;
+  BEGIN (*r > 0*) r0 := r;
+    REPEAT DEC(r0); Put2(Ldr, r0, SP, (r-r0-1)*4) UNTIL r0 = 0;
+    Put1(Add, SP, SP, r*4); DEC(frame, 4*r)
+  END RestoreRegs;
+
   PROCEDURE PrepCall*(VAR x: Item; VAR r: LONGINT);
-  BEGIN
-    IF x.type.form = ORB.Proc THEN
-      IF x.mode # ORB.Const THEN
-        load(x); code[pc-1] := code[pc-1] + 0B000000H; x.r := 11; DEC(RH); inhibitCalls := TRUE;
-        IF check THEN Trap(EQ, 5) END
-      END
-    ELSE ORS.Mark("not a procedure")
-    END ;
-    r := RH
+  BEGIN (*x.type.form = ORB.Proc*)
+    IF x.mode > ORB.Par THEN load(x) END ;
+    r := RH;
+    IF RH > 0 THEN SaveRegs(RH); RH := 0 END
   END PrepCall;
 
   PROCEDURE Call*(VAR x: Item; r: LONGINT);
-  BEGIN
-    IF inhibitCalls & (x.r # 11) THEN ORS.Mark("inadmissible call") ELSE inhibitCalls := FALSE END ;
-    IF r > 0 THEN SaveRegs(r) END ;
-    IF x.type.form = ORB.Proc THEN
-      IF x.mode = ORB.Const THEN
-        IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1)
-        ELSE (*imported*)
-          IF pc - fixorgP < 1000H THEN
-            Put3(BL, 7, ((-x.r) * 100H + x.a) * 1000H + pc-fixorgP); fixorgP := pc-1
-          ELSE ORS.Mark("fixup impossible")
-          END
+  BEGIN (*x.type.form = ORB.Proc*)
+    IF x.mode = ORB.Const THEN
+      IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1)
+      ELSE (*imported*)
+        IF pc - fixorgP < 1000H THEN
+          Put3(BL, 7, ((-x.r) * 100H + x.a) * 1000H + pc-fixorgP); fixorgP := pc-1
+        ELSE ORS.Mark("fixup impossible")
         END
-      ELSE Put3(BLR, 7, x.r)
       END
-    ELSE ORS.Mark("not a procedure")
-    END ;
-    IF x.type.base.form = ORB.NoTyp THEN RH := 0
     ELSE
-      IF r > 0 THEN RestoreRegs(r, x) END ;
+      IF x.mode <= ORB.Par THEN load(x); DEC(RH)
+      ELSE Put2(Ldr, RH, SP, 0); Put1(Add, SP, SP, 4); DEC(r); DEC(frame, 4)
+      END ;
+      IF check THEN Trap(EQ, 5) END ;
+      Put3(BLR, 7, RH)
+    END ;
+    IF x.type.base.form = ORB.NoTyp THEN (*procedure*) RH := 0
+    ELSE (*function*)
+      IF r > 0 THEN Put0(Mov, r, 0, 0); RestoreRegs(r) END ;
       x.mode := Reg; x.r := r; RH := r+1
     END ;
     invalSB
@@ -798,14 +797,14 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
 
   PROCEDURE Enter*(parblksize, locblksize: LONGINT; int: BOOLEAN);
     VAR a, r: LONGINT;
-  BEGIN invalSB;
+  BEGIN invalSB; frame := 0;
     IF ~int THEN (*procedure prolog*)
       a := 4; r := 0;
       Put1(Sub, SP, SP, locblksize); Put2(Str, LNK, SP, 0);
       WHILE a < parblksize DO Put2(Str, r, SP, a); INC(r); INC(a, 4) END
     ELSE (*interrupt procedure*)
-      Put1(Sub, SP, SP, 8); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4)
-      (*R0 and R1 saved, but NOT LNK*)
+      Put1(Sub, SP, SP, 12); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4); Put2(Str, SB, SP, 8)
+      (*R0, R1, SB saved os stack*)
     END
   END Enter;
 
@@ -814,8 +813,8 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
     IF form # ORB.NoTyp THEN load(x) END ;
     IF ~int THEN (*procedure epilog*)
       Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK)
-    ELSE (*interrupt*)
-      Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, 8); Put3(BR, 7, 10H)
+    ELSE (*interrupt return, restore SB, R1, R0*)
+      Put2(Ldr, SB, SP, 8); Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, 12); Put3(BR, 7, 10H)
     END ;
     RH := 0
   END Return;
@@ -824,31 +823,26 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
 
   PROCEDURE Increment*(upordown: LONGINT; VAR x, y: Item);
     VAR op, zr, v: LONGINT;
-  BEGIN
+  BEGIN (*frame = 0*)
     IF upordown = 0 THEN op := Add ELSE op := Sub END ;
     IF x.type = ORB.byteType THEN v := 1 ELSE v := 0 END ;
     IF y.type.form = ORB.NoTyp THEN y.mode := ORB.Const; y.a := 1 END ;
     IF (x.mode = ORB.Var) & (x.r > 0) THEN
       zr := RH; Put2(Ldr+v, zr, SP, x.a); incR;
-      IF y.mode = ORB.Const THEN Put1(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
+      IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
       Put2(Str+v, zr, SP, x.a); DEC(RH)
     ELSE loadAdr(x); zr := RH; Put2(Ldr+v, RH, x.r, 0); incR;
-      IF y.mode = ORB.Const THEN Put1(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
+      IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
       Put2(Str+v, zr, x.r, 0); DEC(RH, 2)
     END
   END Increment;
 
   PROCEDURE Include*(inorex: LONGINT; VAR x, y: Item);
-    VAR zr: LONGINT;
+    VAR op, zr: LONGINT;
   BEGIN loadAdr(x); zr := RH; Put2(Ldr, RH, x.r, 0); incR;
-    IF inorex = 0 THEN (*include*)
-      IF y.mode = ORB.Const THEN Put1(Ior, zr, zr, LSL(1, y.a))
-      ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(Ior, zr, zr, y.r); DEC(RH)
-      END
-    ELSE (*exclude*)
-      IF y.mode = ORB.Const THEN Put1(And, zr, zr, -LSL(1, y.a)-1)
-      ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put1(Xor, y.r, y.r, -1); Put0(And, zr, zr, y.r); DEC(RH)
-      END
+    IF inorex = 0 THEN op := Ior ELSE op := Ann END ;
+    IF y.mode = ORB.Const THEN Put1a(op, zr, zr, LSL(1, y.a))
+    ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(op, zr, zr, y.r); DEC(RH)
     END ;
     Put2(Str, zr, x.r, 0); DEC(RH, 2)
   END Include;
@@ -933,7 +927,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
   END Odd;
 
   PROCEDURE Floor*(VAR x: Item);
-  BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+1000H, x.r, x.r, RH) 
+  BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+V, x.r, x.r, RH)
   END Floor;
 
   PROCEDURE Float*(VAR x: Item);
@@ -948,7 +942,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
   PROCEDURE Len*(VAR x: Item);
   BEGIN
     IF x.type.len >= 0 THEN x.mode := ORB.Const; x.a := x.type.len
-    ELSE (*open array*) Put2(Ldr, RH, SP, x.a + 4); x.mode := Reg; x.r := RH; incR
+    ELSE (*open array*) Put2(Ldr, RH, SP, x.a + 4 + frame); x.mode := Reg; x.r := RH; incR
     END 
   END Len;
 
@@ -988,7 +982,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
 
   PROCEDURE H*(VAR x: Item);
   BEGIN (*x.mode = Const*)
-    Put0(Mov + U + (x.a MOD 2 * 1000H), RH, 0, 0); x.mode := Reg; x.r := RH; incR
+    Put0(Mov + U + x.a MOD 2 * V, RH, 0, 0); x.mode := Reg; x.r := RH; incR
   END H;
 
   PROCEDURE Adr*(VAR x: Item);
@@ -1005,8 +999,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
   END Condition;
 
   PROCEDURE Open*(v: INTEGER);
-  BEGIN pc := 0; tdx := 0; strx := 0; RH := 0; fixorgP := 0; fixorgD := 0; fixorgT := 0;
-    check := v # 0; version := v; inhibitCalls := FALSE;
+  BEGIN pc := 0; tdx := 0; strx := 0; RH := 0; fixorgP := 0; fixorgD := 0; fixorgT := 0; check := v # 0; version := v;
     IF v = 0 THEN pc := 8 END
   END Open;
 
@@ -1016,7 +1009,7 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
 
   PROCEDURE Header*;
   BEGIN entry := pc*4;
-    IF version = 0 THEN code[0] := 0E7000000H-1 + pc; Put1(Mov, SB, 0, 16); Put1(Mov, SP, 0, StkOrg0)  (*RISC-0*)
+    IF version = 0 THEN code[0] := 0E7000000H-1 + pc; Put1a(Mov, SB, 0, VarOrg0); Put1a(Mov, SP, 0, StkOrg0)  (*RISC-0*)
     ELSE Put1(Sub, SP, SP, 4); Put2(Str, LNK, SP, 0); invalSB
     END
   END Header;
@@ -1122,4 +1115,4 @@ MODULE ORG; (* NW  10.10.2013  code generator in Oberon-07 for RISC*)
 
 BEGIN
   relmap[0] := 1; relmap[1] := 9; relmap[2] := 5; relmap[3] := 6; relmap[4] := 14; relmap[5] := 13
-END ORG.
+END ORG.

BlackBox/Po/Files/ORP.Mod.txt

@@ -1,6 +1,6 @@
-MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07*)
+MODULE ORP; (*N. Wirth 1.7.97 / 7.6.2014  Oberon compiler for RISC in Oberon-07*)
   IMPORT Texts, Oberon, ORS, ORB, ORG;
-  (*Author: Niklaus Wirth, 2011.
+  (*Author: Niklaus Wirth, 2014.
     Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens),
     ORB for definition of data structures and for handling import and export, and
     ORG to produce binary code. ORP performs type checking and data allocation.
@@ -206,7 +206,7 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
       ELSIF (x.type.form = ORB.Array) & (par.type.form = ORB.Array) &
           (x.type.base.form = par.type.base.form) & (par.type.len < 0) THEN
         ORG.OpenArrayParam(x);
-      ELSIF (x.type.form = ORB.String) & (par.class = ORB.Par) & (par.type.form = ORB.Array) & 
+      ELSIF (x.type.form = ORB.String) & varpar & par.rdo & (par.type.form = ORB.Array) & 
           (par.type.base.form = ORB.Char) & (par.type.len < 0) THEN ORG.StringParam(x)
       ELSIF (par.type.form = ORB.Array) & (par.type.base.form = ORB.Int) & (par.type.size = x.type.size) THEN
         ORG.VarParam(x, par.type)
@@ -313,11 +313,11 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
       IF obj.class = ORB.SFunc THEN StandFunc(x, obj.val, obj.type)
       ELSE ORG.MakeItem(x, obj, level); selector(x);
         IF sym = ORS.lparen THEN
-          ORS.Get(sym); ORG.PrepCall(x, rx); ParamList(x);
+          ORS.Get(sym);
           IF (x.type.form = ORB.Proc) & (x.type.base.form # ORB.NoTyp) THEN
-            ORG.Call(x, rx); x.type := x.type.base
-          ELSE ORS.Mark("not a function")
-          END ;
+            ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx); x.type := x.type.base
+          ELSE ORS.Mark("not a function"); ParamList(x)
+          END
         END
       END
     ELSIF sym = ORS.int THEN ORG.MakeConstItem(x, ORB.intType, ORS.ival); ORS.Get(sym)
@@ -501,9 +501,10 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
             END
           ELSIF sym = ORS.eql THEN ORS.Mark("should be :="); ORS.Get(sym); expression(y)
           ELSIF sym = ORS.lparen THEN (*procedure call*)
-            ORS.Get(sym); ORG.PrepCall(x, rx); ParamList(x);
-            IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN ORG.Call(x, rx)
-            ELSE ORS.Mark("not a procedure")
+            ORS.Get(sym);
+            IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN
+              ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx)
+            ELSE ORS.Mark("not a procedure"); ParamList(x)
             END
           ELSIF x.type.form = ORB.Proc THEN (*procedure call without parameters*)
             IF x.type.nofpar > 0 THEN ORS.Mark("missing parameters") END ;
@@ -569,6 +570,7 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
             Check(ORS.of, "OF expected"); SkipCase;
             WHILE sym = ORS.bar DO SkipCase END
           END
+        ELSE ORS.Mark("ident expected")
         END ;
         Check(ORS.end, "no END")
       END ;
@@ -619,10 +621,10 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
     VAR obj, obj0, new, bot, base: ORB.Object;
       typ, tp: ORB.Type;
       offset, off, n: LONGINT;
-  BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := level; typ.nofpar := 0;
-    offset := 0; bot := NIL;
+  BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := -level; typ.nofpar := 0; offset := 0; bot := NIL;
     IF sym = ORS.lparen THEN
       ORS.Get(sym); (*record extension*)
+      IF level # 0 THEN ORS.Mark("extension of local types not implemented") END ;
       IF sym = ORS.ident THEN
         qualident(base);
         IF base.class = ORB.Typ THEN
@@ -721,6 +723,11 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
     END
   END FormalType0;
 
+  PROCEDURE CheckRecLevel(lev: INTEGER);
+  BEGIN
+    IF lev # 0 THEN ORS.Mark("ptr base must be global") END
+  END CheckRecLevel;
+
   PROCEDURE Type0(VAR type: ORB.Type);
     VAR dmy: LONGINT; obj: ORB.Object; ptbase: PtrBase;
   BEGIN type := ORB.intType; (*sync*)
@@ -742,13 +749,16 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
       IF sym = ORS.ident THEN
         obj := ORB.thisObj(); ORS.Get(sym);
         IF obj # NIL THEN
-          IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN type.base := obj.type
+          IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN
+            CheckRecLevel(obj.lev); type.base := obj.type
           ELSE ORS.Mark("no valid base type")
           END
-        END ;
-        NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase
+        ELSE CheckRecLevel(level); (*enter into list of forward references to be fixed in Declarations*)
+          NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase
+        END
       ELSE Type(type.base);
-        IF type.base.form # ORB.Record THEN ORS.Mark("must point to record") END
+        IF type.base.form # ORB.Record THEN ORS.Mark("must point to record") END ;
+        CheckRecLevel(level)
       END
     ELSIF sym = ORS.procedure THEN
       ORS.Get(sym); ORB.OpenScope;
@@ -791,12 +801,9 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
         IF tp.form = ORB.Record THEN
           ptbase := pbsList;  (*check whether this is base of a pointer type; search and fixup*)
           WHILE ptbase # NIL DO
-            IF obj.name = ptbase.name THEN
-              IF ptbase.type.base = ORB.intType THEN ptbase.type.base := obj.type ELSE ORS.Mark("recursive record?") END
-            END ;
+            IF obj.name = ptbase.name THEN ptbase.type.base := obj.type END ;
             ptbase := ptbase.next
           END ;
-          tp.len := dc;
           IF level = 0 THEN ORG.BuildTD(tp, dc) END    (*type descriptor; len used as its address*)
         END ;
         Check(ORS.semicolon, "; missing")
@@ -837,7 +844,6 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
     IF sym = ORS.times THEN ORS.Get(sym); int := TRUE END ;
     IF sym = ORS.ident THEN
       ORS.CopyId(procid); ORS.Get(sym);
-      (*Texts.WriteLn(W); Texts.WriteString(W, procid); Texts.WriteInt(W, ORG.Here(), 7);*)
       ORB.NewObj(proc, ORS.id, ORB.Const); parblksize := 4;
       NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; proc.type := type;
       CheckExport(proc.expo);
@@ -918,13 +924,13 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
       ELSE ORS.Mark("identifier missing")
       END ;
       IF sym # ORS.period THEN ORS.Mark("period missing") END ;
-      IF ORS.errcnt = 0 THEN
+      IF (ORS.errcnt = 0) & (version # 0) THEN
         ORB.Export(modid, newSF, key);
-        IF newSF THEN Texts.WriteLn(W); Texts.WriteString(W, "new symbol file ") END
+        IF newSF THEN Texts.WriteString(W, " new symbol file") END
       END ;
       IF ORS.errcnt = 0 THEN
-        ORG.Close(modid, key, exno); Texts.WriteLn(W); Texts.WriteString(W, "compilation done ");
-        Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6)
+        ORG.Close(modid, key, exno);
+        Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteHex(W, key)
       ELSE Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED")
       END ;
       Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
@@ -945,8 +951,7 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
     VAR beg, end, time: LONGINT;
       T: Texts.Text;
       S: Texts.Scanner;
-  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
-    Texts.Scan(S);
+  BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
     IF S.class = Texts.Char THEN
       IF S.c = "@" THEN
         Option(S); Oberon.GetSelection(T, beg, end, time);
@@ -974,7 +979,7 @@ MODULE ORP; (*N. Wirth 1.7.97 / 12.2.2014  Oberon compiler for RISC in Oberon-07
     Oberon.Collect(0)
   END Compile;
 
-BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler  15.12.2013");
+BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler  7.6.2014");
   Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
   NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType;
   expression := expression0; Type := Type0; FormalType := FormalType0

BlackBox/Po/Files/Oberon.Mod.txt

@@ -1,4 +1,4 @@
-MODULE Oberon; (*JG 6.9.90 / 23.9.93 / 13.8.94 / NW 14.4.2013 / 15.9.2013*)
+MODULE Oberon; (*JG 6.9.90 / 23.9.93 / 13.8.94 / NW 14.4.2013 / 22.12.2013*)
   IMPORT SYSTEM, Kernel, Files, Modules, Input, Display, Viewers, Fonts, Texts;
 
   CONST (*message ids*)
@@ -322,12 +322,14 @@ MODULE Oberon; (*JG 6.9.90 / 23.9.93 / 13.8.94 / NW 14.4.2013 / 15.9.2013*)
 
   PROCEDURE NewTask*(h: Handler; period: INTEGER): Task;
     VAR t: Task;
-  BEGIN NEW(t); t.state := off; t.next := NIL; t.handle := h; t.period := period; t.nextTime := 0;
-    RETURN t
+  BEGIN NEW(t); t.state := off; t.next := t; t.handle := h; t.period := period; RETURN t
   END NewTask;
   
   PROCEDURE Install* (T: Task);
-  BEGIN T.next := CurTask.next; CurTask.next := T; T.state := idle; INC(NofTasks)
+  BEGIN
+    IF T.state = off THEN
+      T.next := CurTask.next; CurTask.next := T; T.state := idle; T.nextTime := 0; INC(NofTasks)
+    END
   END Install;
 
   PROCEDURE Remove* (T: Task);
@@ -404,8 +406,6 @@ BEGIN User[0] := 0X;
   FocusViewer := Viewers.This(0, 0);
   CurFnt := Fonts.Default; CurCol := Display.white; CurOff := 0;
 
-  ActCnt := BasicCycle;
-  NEW(CurTask); CurTask.handle := GC; CurTask.next := CurTask; NofTasks := 1;
-  CurTask.nextTime := 0; CurTask.period := 1000;
+  ActCnt := 0; CurTask := NewTask(GC, 1000); Install(CurTask);
   Modules.Load("System", Mod); Mod := NIL; Loop
 END Oberon.

BlackBox/Po/Files/SmallPrograms.Mod.txt

@@ -1,3 +1,25 @@
+ORP.Compile @/s  Blink.Run  BlinkStop
+
+MODULE Blink;   (*NW 30.5.2013  use of a Task; blinks LED every second*)
+  IMPORT SYSTEM, Oberon;
+  VAR z: INTEGER;
+    T: Oberon.Task;
+  
+  PROCEDURE Run*;
+  BEGIN Oberon.Install(T)
+  END Run;
+
+  PROCEDURE Stop*;
+  BEGIN Oberon.Remove(T)
+  END Stop;
+
+  PROCEDURE Tick;
+  BEGIN z := 1-z; LED(z)
+  END Tick;
+
+BEGIN z := 0; T := Oberon.NewTask(Tick, 500)
+END Blink.
+
 ORP.Compile @/s  Permutations.Generate 2 3 4~
 
 MODULE Permutations;  (*NW 22.1.2013*)