first commit

BlackBox/Po/Files/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.

BlackBox/Po/Files/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.

BlackBox/Po/Files/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.

BlackBox/Po/Files/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.

BlackBox/Po/Files/Display.Mod.txt

@@ -0,0 +1,190 @@
+MODULE Display;  (*NW 5.11.2013*)
+  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
+    ELSE
+      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: SET;
+  BEGIN SYSTEM.GET(patadr, w); SYSTEM.GET(patadr+1, h); INC(patadr, 2);
+    a := base + (x DIV 32)*4 + y*128; 
+    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 MOD 32)) / pix)
+      ELSE SYSTEM.PUT(a0, SYSTEM.VAL(SET, LSL(pwd, x MOD 32)) + pix)
+      END ;
+      IF (x MOD 32) + w > 32 THEN (*spill over*)
+        SYSTEM.GET(a0+4, pix);
+        IF mode = invert THEN SYSTEM.PUT(a0+4, SYSTEM.VAL(SET, ASR(pwd, -(x MOD 32))) / pix)
+        ELSE SYSTEM.PUT(a0+4, SYSTEM.VAL(SET, ASR(pwd, -(x MOD 32))) + 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
+    ELSE
+      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.

BlackBox/Po/Files/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.

BlackBox/Po/Files/Draw.Tool

@@ -0,0 +1,8 @@
+Draw.Open XX.Graph  Draw.Store 
+Rectangles.Make  Curves.MakeCircle
+
+System.SetFont Syntax10.Scn.Fnt
+Draw.SetWidth 2
+Draw.ChangeFont Syntax8.Scn.Fnt
+Draw.ChangeWidth 2
+Draw.Macro TTL0 N02

BlackBox/Po/Files/Draw.Tool.txt

@@ -0,0 +1,8 @@
+Draw.Open XX.Graph  Draw.Store 
+Rectangles.Make  Curves.MakeCircle
+
+System.SetFont Syntax10.Scn.Fnt
+Draw.SetWidth 2
+Draw.ChangeFont Syntax8.Scn.Fnt
+Draw.ChangeWidth 2
+Draw.Macro TTL0 N02

BlackBox/Po/Files/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.
+~ 

BlackBox/Po/Files/Edit.Mod.txt

@@ -0,0 +1,232 @@
+MODULE Edit; (*JG 2.11.90 / NW 18.1.92 /30.12.95 / 10.10.10 / NW 10.1.2013*)
+  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.MarkedViewer() 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.MarkedViewer();
+    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.
+
+

BlackBox/Po/Files/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.

BlackBox/Po/Files/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.

BlackBox/Po/Files/Fonts.Mod.txt

@@ -0,0 +1,115 @@
+MODULE Fonts; (*JG 18.11.90; PDR 8.6.12; NW 25.3.2013*)
+  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;
+
+  (* 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;
+
+  TYPE RunRec = RECORD beg, end: BYTE END ;
+    BoxRec = RECORD dx, x, y, w, h: BYTE END ;
+    
+  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*)
+        NEW(F); F.name := name;
+        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, 2); a := a0+3; 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*)
+  VAR f: Font;
+BEGIN f := root.next;
+  IF f # NIL THEN f := f.next END ;
+  f.next := NIL
+END Free;
+
+BEGIN root := NIL; Default := This("Oberon10.Scn.Fnt")
+END Fonts.

BlackBox/Po/Files/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.

BlackBox/Po/Files/GraphicFrames.Mod.txt

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

BlackBox/Po/Files/Graphics.Mod.txt

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

BlackBox/Po/Files/Hilbert.Mod.txt

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

BlackBox/Po/Files/Input.Mod.txt

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

BlackBox/Po/Files/Kernel.Mod.txt

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

BlackBox/Po/Files/MacroTool.Mod.txt

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

BlackBox/Po/Files/Math.Mod.txt

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

BlackBox/Po/Files/MenuViewers.Mod.txt

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

BlackBox/Po/Files/Modules.Mod.txt

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

BlackBox/Po/Files/Net.Mod.txt

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

BlackBox/Po/Files/ORB.Mod.txt

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

BlackBox/Po/Files/ORC.Mod.txt

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

BlackBox/Po/Files/ORG.Mod.txt

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

BlackBox/Po/Files/ORP.Mod.txt

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

BlackBox/Po/Files/ORS.Mod.txt

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

BlackBox/Po/Files/ORTool.Mod.txt

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

BlackBox/Po/Files/Oberon.Mod.txt

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

BlackBox/Po/Files/OberonSyntax.Text

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

BlackBox/Po/Files/OberonSyntax.Text.txt

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

BlackBox/Po/Files/PCLink1.Mod.txt

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

BlackBox/Po/Files/RISC.Mod.txt

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

BlackBox/Po/Files/RS232.Mod.txt

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

BlackBox/Po/Files/Rectangles.Mod.txt

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

BlackBox/Po/Files/SCC.Mod.txt

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

BlackBox/Po/Files/Sierpinski.Mod.txt

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

BlackBox/Po/Files/SmallPrograms.Mod.txt

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

BlackBox/Po/Files/Stars.Mod.txt

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

BlackBox/Po/Files/System.Mod.txt

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

BlackBox/Po/Files/System.Tool

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

BlackBox/Po/Files/System.Tool.txt

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

BlackBox/Po/Files/TextFrames.Mod.txt

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

BlackBox/Po/Files/Texts.Mod.txt

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

BlackBox/Po/Files/Tools.Mod.txt

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

BlackBox/Po/Files/Viewers.Mod.txt

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