├── Math.Def ├── README.md ├── MathL.Def ├── Printmaps.Def ├── Reals.Def ├── Kernel.Def ├── C2.V24.Mod ├── 00_README ├── C2.Input.Mod ├── Display.Def ├── Users.Mod ├── Fonts.Mod ├── Backup.Mod ├── Core.Mod ├── Rectangles.Mod ├── C2.SCC.Mod ├── MFiles.Mod ├── Printer.Mod ├── BTree.Mod ├── Viewers.Mod ├── MenuViewers.Mod ├── Modules.Mod ├── Splines.Mod ├── GraphicElems.Mod ├── MenuElems.Mod ├── OBS.Mod ├── Curves.Mod ├── C2.Diskette.Mod ├── Draw.Mod ├── Oberon.Mod ├── FileDir.Mod ├── NetServer.Mod └── PrintServer.Mod /Math.Def: -------------------------------------------------------------------------------- 1 | MODULE Math; (*NW 21.6.86*) CONST pi* = 3.14159265; e* = 2.71828182; PROCEDURE sqrt*(x: REAL): REAL; END sqrt; PROCEDURE exp*(x: REAL): REAL; END exp; PROCEDURE ln*(x: REAL): REAL; END ln; PROCEDURE sin*(x: REAL): REAL; END sin; PROCEDURE cos*(x: REAL): REAL; END cos; PROCEDURE arctan*(x: REAL): REAL; END arctan; END Math. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ProjectOberonV4 2 | =============== 3 | 4 | PROJECT OBERON, The Design of an Operating system and Compiler 5 | N. Wirth, J. Gutknecht 6 | ACM Press and Addison-Weseley Publishing Company, 1992 7 | ISBN 0-201-54428-8 8 | ______________________________________________________________ 9 | http://www.inf.ethz.ch/personal/wirth/books/ProjectOberon.pdf 10 | -------------------------------------------------------------------------------- /MathL.Def: -------------------------------------------------------------------------------- 1 | MODULE MathL; (*NW 25.7.86*) CONST pi* = 3.141592653589793D0; e* = 2.718281828459045D0; PROCEDURE sqrt*(x: LONGREAL): LONGREAL; END sqrt; PROCEDURE exp*(x: LONGREAL): LONGREAL; END exp; PROCEDURE ln*(x: LONGREAL): LONGREAL; END ln; PROCEDURE sin*(x: LONGREAL): LONGREAL; END sin; PROCEDURE cos*(x: LONGREAL): LONGREAL; END cos; PROCEDURE arctan*(x: LONGREAL): LONGREAL; END arctan; END MathL. -------------------------------------------------------------------------------- /Printmaps.Def: -------------------------------------------------------------------------------- 1 | MODULE Printmaps; (*NW 9.7.89 / 16.11.89*) VAR Pat*: ARRAY 10 OF LONGINT; PROCEDURE Map*(): LONGINT; END Map; PROCEDURE ClearPage*; END ClearPage; PROCEDURE CopyPattern*(pat: LONGINT; X, Y: INTEGER); END CopyPattern; PROCEDURE ReplPattern*(pat: LONGINT; X, Y, W, H: INTEGER); END ReplPattern; PROCEDURE ReplConst*(X, Y, W, H: INTEGER); END ReplConst; PROCEDURE Dot*(X, Y: LONGINT); END Dot; END Printmaps. -------------------------------------------------------------------------------- /Reals.Def: -------------------------------------------------------------------------------- 1 | MODULE Reals; (*NW 9.2.89 / 6.12.91*) PROCEDURE Expo*(x: REAL): INTEGER; END Expo; PROCEDURE ExpoL*(x: LONGREAL): INTEGER; END ExpoL; PROCEDURE SetExpo*(e: INTEGER; VAR x: REAL); END SetExpo; PROCEDURE SetExpoL*(e: INTEGER; VAR x: LONGREAL); END SetExpoL; PROCEDURE Ten*(e: INTEGER): REAL; END Ten; PROCEDURE TenL*(e: INTEGER): LONGREAL; END TenL; PROCEDURE Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR); END Convert; PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); END ConvertL; PROCEDURE ConvertH*(x: REAL; VAR d: ARRAY OF CHAR); END ConvertH; PROCEDURE ConvertHL*(x: LONGREAL; VAR d: ARRAY OF CHAR); END ConvertHL; PROCEDURE FSR*(): LONGINT; END FSR; PROCEDURE SetFSR*(status: LONGINT); END SetFSR; END Reals. -------------------------------------------------------------------------------- /Kernel.Def: -------------------------------------------------------------------------------- 1 | MODULE Kernel; (*NW 11.4.86 / 24.8.92*) TYPE Sector* = RECORD END ; VAR ModList*: LONGINT; NofPages*, NofSectors*, allocated*: LONGINT; StackOrg*, HeapLimit*: LONGINT; FileRoot*, FontRoot*: LONGINT; SectNo*, PrAdr*: LONGINT; pc*, fp*, eia*, err*: LONGINT; (*status upon trap*) (* Block storage management*) PROCEDURE- AllocBlock*(VAR adr: LONGINT; size: LONGINT) 2; PROCEDURE- FreeBlock*(adr: LONGINT) 3; (* Block storage management - garbage collector*) PROCEDURE- GC* 4; (* Disk storage management*) PROCEDURE- AllocSector*(hint: LONGINT; VAR sec: LONGINT) 5; PROCEDURE- MarkSector*(sec: LONGINT) 6; PROCEDURE- FreeSector*(sec: LONGINT) 7; PROCEDURE- GetSector*(src: LONGINT; VAR dest: Sector) 8; PROCEDURE- PutSector*(dest: LONGINT; VAR src: Sector) 9; PROCEDURE- ResetDisk* 10; (* Miscellaneous procedures*) PROCEDURE- InstallIP*(P: PROCEDURE; chan: INTEGER) 11; PROCEDURE- InstallTrap*(P: PROCEDURE) 12; PROCEDURE- SetICU*(n: CHAR) 13; PROCEDURE- GetClock*(VAR time, date: LONGINT) 14; PROCEDURE- SetClock*(time, date: LONGINT) 15; PROCEDURE- MovePage*(src, dst, n: LONGINT) 16; END Kernel. -------------------------------------------------------------------------------- /C2.V24.Mod: -------------------------------------------------------------------------------- 1 | MODULE V24; (*NW 18.3.89 / 19.1.91*) (*interrupt-driven UART channel B*) IMPORT SYSTEM, Kernel; CONST BufLen = 512; UART = 0FFFFC000H; ICU = 0FFFF9000H; VAR in, out: INTEGER; buf: ARRAY BufLen OF SYSTEM.BYTE; PROCEDURE+ Int; BEGIN SYSTEM.GET(UART+44, buf[in]); in := (in+1) MOD BufLen END Int; PROCEDURE Start*(CSR, MR1, MR2: CHAR); BEGIN in := 0; out := 0; Kernel.InstallIP(Int, 2); SYSTEM.PUT(UART+40, 30X); (*CRB reset transmitter*) SYSTEM.PUT(UART+40, 20X); (*CRB reset receiver*) SYSTEM.PUT(UART+36, CSR); (*CSRB clock rate*) SYSTEM.PUT(UART+40, 15X); (*CRB enable Tx and Rx, pointer to MR1*) SYSTEM.PUT(UART+32, MR1); (*MR1B, parity, nof bits*) SYSTEM.PUT(UART+32, MR2); (*MR2B stop bits*) SYSTEM.PUT(UART+20, 20X); (*IMR RxRdy Int enable*) SYSTEM.PUT(ICU + 4, 1AX); (*ICU IMR and IRR bit 2*) END Start; PROCEDURE SetOP*(s: SET); BEGIN SYSTEM.PUT(UART+56, s) END SetOP; PROCEDURE ClearOP*(s: SET); BEGIN SYSTEM.PUT(UART+60, s) END ClearOP; PROCEDURE IP*(n: INTEGER): BOOLEAN; BEGIN RETURN SYSTEM.BIT(UART+52, n) END IP; PROCEDURE SR*(n: INTEGER): BOOLEAN; BEGIN RETURN SYSTEM.BIT(UART+36, n) END SR; PROCEDURE Available*(): INTEGER; BEGIN RETURN (in - out) MOD BufLen END Available; PROCEDURE Receive*(VAR x: SYSTEM.BYTE); BEGIN REPEAT UNTIL in # out; x := buf[out]; out := (out+1) MOD BufLen END Receive; PROCEDURE Send*(x: SYSTEM.BYTE); BEGIN REPEAT UNTIL SYSTEM.BIT(UART+36, 2); SYSTEM.PUT(UART+44, x) END Send; PROCEDURE Break*; VAR i: LONGINT; BEGIN SYSTEM.PUT(UART+40, 60X); i := 500000; REPEAT DEC(i) UNTIL i = 0; SYSTEM.PUT(UART+40, 70X) END Break; PROCEDURE Stop*; BEGIN SYSTEM.PUT(UART+20, 0); (*IMR disable Rx-Int*) SYSTEM.PUT(ICU + 4, 3AX) (*ICU chan 2*) END Stop; END V24. -------------------------------------------------------------------------------- /00_README: -------------------------------------------------------------------------------- 1 | --------------------------- 2 | Oberon(TM) V4 Sources 3 | --------------------------- 4 | 5 | Copyright 1991-94, ETH Zuerich 6 | 7 | 8 | 9 | Oberon is a trademark of Institut fuer Computersysteme, ETH Zurich 10 | 11 | Permission to use, copy, modify and distribute this software and its 12 | documentation for any purpose is hereby granted without fee, provided that 13 | the above copyright notice appear in all copies and that both that copyright 14 | notice and this permission notice appear in supporting documentation, and 15 | that the name of ETH not be used in advertising or publicity pertaining to 16 | distribution of the software without specific, written prior permission. 17 | ETH makes no representations about the suitability of this software for any 18 | purpose. It is provided "as is" without express or implied warranty. 19 | 20 | ETH DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ETH BE 22 | LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 23 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION 24 | OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN 25 | CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 26 | 27 | ---------------------------------------------------------------------------- 28 | 29 | This directory contains the sources of the Oberon System version 4 for 30 | Ceres-2 Workstations. They replace the earlier version 1 sources described 31 | in the book "Project Oberon" from N. Wirth & J. Gutknecht. 32 | 33 | In version 2 Text-Elements were introduced and the main visible difference 34 | between version 2 and version 4 is "Edit", the document editor, previously 35 | called "Write" in version 2 36 | 37 | For more information about the differences between version 2 and version 4, 38 | read the Postscript file 00_V4.docu.ps in this directory. 39 | 40 | 41 | 42 | ------------------------------- 43 | Institut fuer Computersysteme 44 | ETH Zurich 45 | Switzerland. 46 | ------------------------------- 47 | 48 | -------------------------------------------------------------------------------- /C2.Input.Mod: -------------------------------------------------------------------------------- 1 | MODULE Input; (*NW 5.10.86 / 15.11.90 Ceres-2*) IMPORT SYSTEM, Kernel; CONST N = 32; MOUSE = 0FFFFB000H; UART = 0FFFFC000H; ICU = 0FFFF9000H; VAR MW, MH: INTEGER; (*mouse limits*) T: LONGINT; (*time counter*) n, in, out: INTEGER; buf: ARRAY N OF CHAR; PROCEDURE Available*(): INTEGER; BEGIN RETURN n END Available; PROCEDURE Read*(VAR ch: CHAR); BEGIN REPEAT UNTIL n > 0; DEC(n); ch := buf[out]; out := (out+1) MOD N END Read; PROCEDURE Mouse*(VAR keys: SET; VAR x, y: INTEGER); VAR u: LONGINT; BEGIN SYSTEM.GET(MOUSE, u); keys := {0,1,2} - SYSTEM.VAL(SET, u DIV 1000H MOD 8); x := SHORT(u MOD 1000H) MOD MW; y := SHORT(u DIV 10000H) MOD 819; IF y >= MH THEN y := 0 END END Mouse; PROCEDURE SetMouseLimits*(w, h: INTEGER); BEGIN MW := w; MH := h END SetMouseLimits; PROCEDURE Time*(): LONGINT; VAR lo, lo1, hi: CHAR; t: LONGINT; BEGIN REPEAT SYSTEM.GET(UART+28, lo); SYSTEM.GET(UART+24, hi); t := T - LONG(ORD(hi))*256 - ORD(lo); SYSTEM.GET(UART+28, lo1) UNTIL lo1 = lo; RETURN t END Time; PROCEDURE+ KBINT; VAR ch: CHAR; BEGIN SYSTEM.GET(UART+12, ch); (*RHRA*) IF ch = 0FFX THEN HALT(24) END ; IF (n < N) & ((ch < 0C8X) OR (ch > 0CCX)) THEN buf[in] := ch; in := (in+1) MOD N; INC(n) END END KBINT; PROCEDURE+ CTInt; VAR dmy: CHAR; BEGIN SYSTEM.GET(UART+60, dmy); (*stop timer*) INC(T, 0FFFFH); SYSTEM.GET(UART+56, dmy) END CTInt; BEGIN MW := 1024; MH := 800; n := 0; in := 0; out := 0; T := 0FFFFH; Kernel.InstallIP(KBINT, 4); Kernel.InstallIP(CTInt, 0); SYSTEM.PUT(UART+16, 90X); (*ACR*) SYSTEM.PUT(UART+ 8, 15X); (*CRA enable*) SYSTEM.PUT(UART, 13X); (*MR1A, RxRdy -Int, no parity, 8 bits*) SYSTEM.PUT(UART, 7X); (*MR2A 1 stop bit*) SYSTEM.PUT(UART+ 4, 44X); (*CSRA, rate = 300 bps*) SYSTEM.PUT(UART+52, 14X); (*OPCR OP4 = KB and OP3 = C/T int*) SYSTEM.PUT(UART+28, 0FFX); (*CTLR*) SYSTEM.PUT(UART+24, 0FFX); (*CTUR*) SYSTEM.GET(UART+56, buf[0]); (*start timer*) SYSTEM.PUT(ICU + 4, 18X); (*clear ICU IMR and IRR bits 0*) SYSTEM.PUT(ICU + 4, 1CX); (*clear ICU IMR and IRR bits 4*) END Input. -------------------------------------------------------------------------------- /Display.Def: -------------------------------------------------------------------------------- 1 | MODULE Display; (*NW 3.3.89 / 19.1.91 / 22.11.92*) IMPORT SYSTEM; CONST black* = 0; white* = 15; replace* = 0; paint* = 1; invert* = 2; TYPE Frame* = POINTER TO FrameDesc; FrameMsg* = RECORD END; Pattern* = LONGINT; Font* = POINTER TO Bytes; Bytes* = RECORD END; Handler* = PROCEDURE (f: Frame; VAR msg: FrameMsg); FrameDesc* = RECORD dsc*, next*: Frame; X*, Y*, W*, H*: INTEGER; handle*: Handler END; VAR Unit*: LONGINT; (*RasterUnit = Unit/36000 mm*) Left*, ColLeft*, Bottom*, UBottom*, Width*, Height*: INTEGER; arrow*, star*, hook*, cross*, downArrow*: Pattern; grey0*, grey1*, grey2*, ticks*: Pattern; PROCEDURE Map*(X: INTEGER): LONGINT; END Map; PROCEDURE SetMode*(X: INTEGER; s: SET); END SetMode; PROCEDURE SetColor*(col, red, green, blue: INTEGER); (*col < 0: overlay color*) END SetColor; PROCEDURE GetColor*(col: INTEGER; VAR red, green, blue: INTEGER); END GetColor; PROCEDURE SetCursor*(mode: SET); (*color cursor; 0: crosshair, 1: arrow*) END SetCursor; PROCEDURE DefCC*(x, y, w, h: INTEGER); (*crosshair window*) END DefCC; PROCEDURE DefCP*(VAR raster: ARRAY OF SYSTEM.BYTE); (*cursor pattern*) END DefCP; PROCEDURE DrawCX*(x, y: INTEGER); END DrawCX; PROCEDURE FadeCX*(x, y: INTEGER); END FadeCX; PROCEDURE GetChar*(f: Font; ch: CHAR; VAR dx, x, y, w, h: INTEGER; VAR p: LONGINT); (*get raster data of character ch*) END GetChar; PROCEDURE NewPattern*(VAR image: ARRAY OF SET; w, h: INTEGER): Pattern; END NewPattern; (*raster operations*) PROCEDURE CopyBlock*(sx, sy, w, h, dx, dy, mode: INTEGER); END CopyBlock; PROCEDURE CopyPattern*(col: INTEGER; pat: Pattern; x, y, mode: INTEGER); END CopyPattern; PROCEDURE ReplPattern*(col: INTEGER; pat: Pattern; x, y, w, h, mode: INTEGER); END ReplPattern; PROCEDURE ReplConst*(col, x, y, w, h, mode: INTEGER); END ReplConst; PROCEDURE Dot*(col, x, y, mode: INTEGER); END Dot; (*raster operations with clipping*) PROCEDURE CopyBlockC*(F: Frame; sx, sy, w, h, dx, dy, mode: INTEGER); END CopyBlockC; PROCEDURE CopyPatternC*(F: Frame; col: INTEGER; pat: Pattern; x, y, mode: INTEGER); END CopyPatternC; PROCEDURE ReplPatternC*(F: Frame; col: INTEGER; pat: Pattern; x, y, w, h, xp, yp, mode: INTEGER); END ReplPatternC; PROCEDURE ReplConstC*(F: Frame; col, x, y, w, h, mode: INTEGER); END ReplConstC; PROCEDURE DotC*(F: Frame; col, x, y, mode: INTEGER); END DotC; END Display. -------------------------------------------------------------------------------- /Users.Mod: -------------------------------------------------------------------------------- 1 | MODULE Users; (*NW 2.2.89 / 25.8.91*) IMPORT Texts, Viewers, Oberon, MenuViewers, TextFrames, Core; CONST TAB = 9X; VAR W: Texts.Writer; PROCEDURE List*; VAR x, y, i: INTEGER; protected: BOOLEAN; count: LONGINT; T: Texts.Text; V: Viewers.Viewer; id: Core.ShortName; name: Core.LongName; BEGIN i := 0; T := TextFrames.Text(""); Oberon.AllocateUserViewer(Oberon.Par.frame.X, x, y); V := MenuViewers.New( TextFrames.NewMenu("Users.Text", "System.Close Edit.Store"), TextFrames.NewText(T, 0), TextFrames.menuH, x, y); WHILE i < Core.NofUsers() DO Core.GetUser(i, id, name, count, protected); Texts.WriteInt(W, i, 4); Texts.Write(W, TAB); IF protected THEN Texts.Write(W, "#") END ; Texts.WriteString(W, id); Texts.Write(W, TAB); Texts.WriteString(W, name); Texts.WriteInt(W, count, 8); Texts.WriteLn(W); INC(i) END ; Texts.Append(T, W.buf) END List; PROCEDURE Insert*; VAR id: Core.ShortName; name: Core.LongName; S: Texts.Scanner; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); IF S.class = Texts.Name THEN COPY(S.s, id); Texts.Scan(S); IF S.class = Texts.Name THEN COPY(S.s, name); Core.InsertUser(id, name) END END ; Core.BackupUsers END Insert; PROCEDURE Delete*; VAR id: Core.ShortName; S: Texts.Scanner; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); IF S.class = Texts.Name THEN COPY(S.s, id); Core.DeleteUser(id) END ; Core.BackupUsers END Delete; PROCEDURE ClearPassword*; VAR id: Core.ShortName; S: Texts.Scanner; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); IF S.class = Texts.Name THEN COPY(S.s, id); Core.ClearPassword(id) END ; Core.BackupUsers END ClearPassword; PROCEDURE ClearCounts*; BEGIN Core.SetCounts(0); Core.BackupUsers END ClearCounts; PROCEDURE Init*; VAR id: Core.ShortName; name: Core.LongName; S: Texts.Scanner; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Core.PurgeUsers(0); LOOP Texts.Scan(S); IF S.class # Texts.Name THEN EXIT END ; COPY(S.s, id); Texts.Scan(S); IF S.class # Texts.Name THEN EXIT END ; COPY(S.s, name); Core.InsertUser(id, name) END ; Core.BackupUsers END Init; BEGIN Texts.OpenWriter(W) END Users. -------------------------------------------------------------------------------- /Fonts.Mod: -------------------------------------------------------------------------------- 1 | MODULE Fonts; (*JG 27.8.90*) IMPORT SYSTEM, Kernel, Display, Files; CONST FontFileId = 0DBX; TYPE Name* = ARRAY 32 OF CHAR; Font* = POINTER TO FontDesc; FontDesc* = RECORD next: Font; name*: Name; height*, minX*, maxX*, minY*, maxY*: INTEGER; raster*: Display.Font END; VAR Default*, First: Font; PROCEDURE This* (name: ARRAY OF CHAR): Font; TYPE RunRec = RECORD beg, end: INTEGER END; BoxRec = RECORD dx, x, y, w, h: INTEGER END; VAR F: Font; f: Files.File; R: Files.Rider; NofBytes, RasterBase, A, a: LONGINT; NofRuns, NofBoxes: INTEGER; k, l, m, n: INTEGER; ch: CHAR; run: ARRAY 16 OF RunRec; box: ARRAY 256 OF BoxRec; PROCEDURE Enter (d: LONGINT); BEGIN SYSTEM.PUT(A, d MOD 256); INC(A); SYSTEM.PUT(A, d DIV 256); INC(A) END Enter; BEGIN F := First; LOOP IF F = NIL THEN EXIT END; IF name = F.name THEN EXIT END; F := F.next END; IF F = NIL THEN f := Files.Old(name); IF f # NIL THEN Files.Set(R, f, 0); Files.Read(R, ch); IF ch = FontFileId THEN Files.Read(R, ch); (*abstraction*) Files.Read(R, ch); (*family*) Files.Read(R, ch); (*variant*) NEW(F); Files.ReadBytes(R, F.height, 2); Files.ReadBytes(R, F.minX, 2); Files.ReadBytes(R, F.maxX, 2); Files.ReadBytes(R, F.minY, 2); Files.ReadBytes(R, F.maxY, 2); Files.ReadBytes(R, NofRuns, 2); NofBoxes := 0; k := 0; WHILE k # NofRuns DO Files.ReadBytes(R, run[k].beg, 2); Files.ReadBytes(R, run[k].end, 2); NofBoxes := NofBoxes + run[k].end - run[k].beg; INC(k) END; NofBytes := 512 + 5; l := 0; WHILE l # NofBoxes DO Files.ReadBytes(R, box[l].dx, 2); Files.ReadBytes(R, box[l].x, 2); Files.ReadBytes(R, box[l].y, 2); Files.ReadBytes(R, box[l].w, 2); Files.ReadBytes(R, box[l].h, 2); NofBytes := NofBytes + 5 + (box[l].w + 7) DIV 8 * box[l].h; INC(l) END; SYSTEM.NEW(F.raster, NofBytes); RasterBase := SYSTEM.VAL(LONGINT, F.raster); A := RasterBase; a := A + 512; SYSTEM.PUT(a, 0X); INC(a); (*dummy ch*) SYSTEM.PUT(a, 0X); INC(a); SYSTEM.PUT(a, 0X); INC(a); SYSTEM.PUT(a, 0X); INC(a); SYSTEM.PUT(a, 0X); INC(a); k := 0; l := 0; m := 0; WHILE k < NofRuns DO WHILE m < run[k].beg DO Enter(515); INC(m) END; WHILE m < run[k].end DO Enter(a + 3 - RasterBase); SYSTEM.PUT(a, box[l].dx MOD 256); INC(a); SYSTEM.PUT(a, box[l].x MOD 256); INC(a); SYSTEM.PUT(a, box[l].y MOD 256); INC(a); SYSTEM.PUT(a, box[l].w MOD 256); INC(a); SYSTEM.PUT(a, box[l].h MOD 256); INC(a); n := (box[l].w + 7) DIV 8 * box[l].h; WHILE n # 0 DO Files.Read(R, ch); SYSTEM.PUT(a, ch); INC(a); DEC(n) END; INC(l); INC(m) END; INC(k) END; WHILE m < 256 DO Enter(515); INC(m) END; COPY(name, F.name); F.next := First; First := F ELSE F := Default END ELSE F := Default END END; RETURN F END This; BEGIN First := NIL; Kernel.FontRoot := SYSTEM.ADR(First); Default := This("Syntax10.Scn.Fnt") END Fonts. -------------------------------------------------------------------------------- /Backup.Mod: -------------------------------------------------------------------------------- 1 | MODULE Backup; (*JG 26.8.90*) IMPORT Diskette, Viewers, MenuViewers, Oberon, Texts, TextFrames; CONST StandardMenu = "System.Close System.Copy System.Grow Edit.Search Edit.Store"; VAR T: Texts.Text; W: Texts.Writer; diroption: CHAR; PROCEDURE Format*; BEGIN Texts.WriteString(W, "Backup.Format"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Diskette.Format; Diskette.InitDir; Diskette.WriteDir END Format; PROCEDURE Init*; BEGIN Texts.WriteString(W, "Backup.Init"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Diskette.InitDir; Diskette.WriteDir END Init; PROCEDURE List (name: ARRAY OF CHAR; date, time: LONGINT; size: LONGINT); BEGIN Texts.WriteString(W, name); IF diroption = "d" THEN Texts.WriteDate(W, time, date); Texts.Write(W, " "); Texts.WriteInt(W, size, 1) END; Texts.WriteLn(W) END List; PROCEDURE Directory*; VAR par: Oberon.ParList; R: Texts.Reader; V: Viewers.Viewer; date, time: LONGINT; nofEntries, nofClusters, X, Y: INTEGER; ch: CHAR; BEGIN par := Oberon.Par; Texts.OpenReader(R, par.text, par.pos); Texts.Read(R, ch); WHILE ch = " " DO Texts.Read(R, ch) END; IF ch = "/" THEN Texts.Read(R, diroption) ELSE diroption := 0X END; T := TextFrames.Text(""); Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y); V := MenuViewers.New( TextFrames.NewMenu("Backup.Directory", StandardMenu), TextFrames.NewText(T, 0), TextFrames.menuH, X, Y); Diskette.ReadDir; Diskette.GetData(date, time, nofEntries, nofClusters); Texts.WriteInt(W, nofEntries, 1); Texts.WriteString(W, " entries/ "); Texts.WriteInt(W, nofClusters, 1); Texts.WriteString(W, " clusters"); Texts.WriteLn(W); Diskette.Enumerate(List); Texts.Append(T, W.buf) END Directory; PROCEDURE ReadAll*; BEGIN Texts.WriteString(W, "Backup.ReadAll reading"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Diskette.ReadAll END ReadAll; PROCEDURE ReadFile (VAR name: ARRAY OF CHAR); BEGIN Texts.WriteString(W, name); Texts.WriteString(W, " reading"); Texts.Append(Oberon.Log, W.buf); Diskette.ReadFile(name); IF Diskette.res # 0 THEN Texts.WriteString(W, " failed") END; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END ReadFile; PROCEDURE ReadFiles*; VAR par: Oberon.ParList; S: Texts.Scanner; T: Texts.Text; beg, end, time: LONGINT; BEGIN par := Oberon.Par; Texts.WriteString(W, "Backup.ReadFiles"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Diskette.ReadDir; par := Oberon.Par; Texts.OpenScanner(S, par.text, par.pos); Texts.Scan(S); WHILE S.class = Texts.Name DO ReadFile(S.s); Texts.Scan(S) END; 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 ReadFile(S.s) END END END END ReadFiles; PROCEDURE WriteFile (VAR name: ARRAY OF CHAR); BEGIN Texts.WriteString(W, name); Texts.WriteString(W, " writing"); Texts.Append(Oberon.Log, W.buf); Diskette.WriteFile(name); IF Diskette.res # 0 THEN Texts.WriteString(W, " failed") END; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END WriteFile; PROCEDURE WriteFiles*; VAR par: Oberon.ParList; S: Texts.Scanner; T: Texts.Text; beg, end, time: LONGINT; BEGIN par := Oberon.Par; Texts.WriteString(W, "Backup.WriteFiles"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Diskette.ReadDir; Texts.OpenScanner(S, par.text, par.pos); Texts.Scan(S); WHILE S.class = Texts.Name DO WriteFile(S.s); Texts.Scan(S) END; 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 WriteFile(S.s) END END END; Diskette.WriteDir END WriteFiles; PROCEDURE DeleteFile (VAR name: ARRAY OF CHAR); BEGIN Texts.WriteString(W, name); Texts.WriteString(W, " deleting"); Texts.Append(Oberon.Log, W.buf); Diskette.DeleteFile(name); IF Diskette.res # 0 THEN Texts.WriteString(W, " failed") END; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END DeleteFile; PROCEDURE DeleteFiles*; VAR par: Oberon.ParList; S: Texts.Scanner; beg, end, time: LONGINT; BEGIN par := Oberon.Par; Texts.WriteString(W, "Backup.DeleteFiles"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Diskette.ReadDir; Texts.OpenScanner(S, par.text, par.pos); Texts.Scan(S); WHILE S.class = Texts.Name DO DeleteFile(S.s); Texts.Scan(S) END; 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 DeleteFile(S.s) END END END; Diskette.WriteDir END DeleteFiles; BEGIN Texts.OpenWriter(W); Diskette.Reset END Backup. -------------------------------------------------------------------------------- /Core.Mod: -------------------------------------------------------------------------------- 1 | MODULE Core; (*NW 17.4.89 / 6.1.90*) IMPORT Kernel, Files; CONST UTsize = 64; (*max nof registered users*) UTsec0 = 60*29; (*adr of user table on disk*) UTsec1 = 61*29; TYPE ShortName* = ARRAY 8 OF CHAR; LongName* = ARRAY 16 OF CHAR; Name* = ARRAY 32 OF CHAR; MailEntry* = RECORD pos*, next*: INTEGER; len*: LONGINT; time*, date*: INTEGER; originator*: ARRAY 20 OF CHAR END ; MResTab* = ARRAY 8 OF SET; MailDir* = ARRAY 31 OF MailEntry; User = RECORD id: ShortName; name: LongName; password, count: LONGINT END ; SectorBuf = RECORD (Kernel.Sector) u: ARRAY 32 OF User END ; Task = POINTER TO TaskDesc; TaskDesc = RECORD file: Files.File; uno, class: INTEGER; name: ShortName; next: Task END ; Queue = RECORD n*: INTEGER; first, last: Task END ; VAR PrintQueue*, MailQueue*, LineQueue*: Queue; NUsers: INTEGER; UT: ARRAY UTsize OF User; PROCEDURE RestoreUsers*; VAR i: INTEGER; SB: SectorBuf; BEGIN i := 0; Kernel.GetSector(UTsec0, SB); WHILE (i < 32) & (SB.u[i].id[0] > 0X) DO UT[i] := SB.u[i]; INC(i) END ; IF i = 32 THEN Kernel.GetSector(UTsec1, SB); WHILE (i < 64) & (SB.u[i-32].id[0] > 0X) DO UT[i] := SB.u[i-32]; INC(i) END END ; NUsers := i END RestoreUsers; PROCEDURE BackupUsers*; VAR i: INTEGER; SB: SectorBuf; BEGIN i := NUsers; IF i >= 32 THEN IF i < 64 THEN SB.u[i-32].id[0] := 0X END ; WHILE i > 32 DO DEC(i); SB.u[i-32] := UT[i] END ; Kernel.PutSector(UTsec1, SB) END ; IF i < 32 THEN SB.u[i].id[0] := 0X END ; WHILE i > 0 DO DEC(i); SB.u[i] := UT[i] END ; Kernel.PutSector(UTsec0, SB) END BackupUsers; PROCEDURE Uno(VAR id: ShortName): INTEGER; VAR i: INTEGER; BEGIN i := 0; WHILE (i < NUsers) & (UT[i].id # id) DO INC(i) END ; RETURN i END Uno; PROCEDURE NofUsers*(): INTEGER; BEGIN RETURN NUsers END NofUsers; PROCEDURE UserNo*(VAR id: ShortName; pw: LONGINT): INTEGER; VAR i: INTEGER; (* -1 = user is protected or not registered*) BEGIN i := Uno(id); IF (i = NUsers) OR (UT[i].password # pw) & (UT[i].password # 0) THEN i := -1 END ; RETURN i END UserNo; PROCEDURE UserNum*(VAR name: ARRAY OF CHAR): INTEGER; VAR i, j: INTEGER; BEGIN i := 0; LOOP IF i = UTsize THEN i := -1; EXIT END ; j := 0; WHILE (j < 4) & (CAP(name[j]) = CAP(UT[i].name[j])) DO INC(j) END ; IF j = 4 THEN EXIT END ; INC(i) END ; RETURN i END UserNum; PROCEDURE GetUserName*(uno: INTEGER; VAR name: LongName); BEGIN name := UT[uno].name END GetUserName; PROCEDURE GetFileName*(uno: INTEGER; VAR name: ARRAY OF CHAR); VAR i: INTEGER; ch: CHAR; BEGIN i := 0; LOOP ch := UT[uno].name[i]; IF ch = 0X THEN EXIT END ; name[i] := ch; INC(i) END ; name[i] := "."; name[i+1] := "M"; name[i+2] := "a"; name[i+3] := "i"; name[i+4] := "l"; name[i+5] := 0X END GetFileName; PROCEDURE GetUser*(uno: INTEGER; VAR id: ShortName; VAR name: LongName; VAR count: LONGINT; VAR protected: BOOLEAN); BEGIN id := UT[uno].id; name := UT[uno].name; count := UT[uno].count; protected := UT[uno].password # 0 END GetUser; PROCEDURE InsertUser*(VAR id: ShortName; VAR name: LongName); VAR i: INTEGER; BEGIN i := Uno(id); IF (i = NUsers) & (i < UTsize-1) THEN UT[i].id := id; UT[i].name := name; UT[i].password := 0; UT[i].count := 0; INC(NUsers) END END InsertUser; PROCEDURE DeleteUser*(VAR id: ShortName); VAR i: INTEGER; BEGIN i := Uno(id); IF i < NUsers THEN DEC(NUsers); WHILE i < NUsers DO UT[i] := UT[i+1]; INC(i) END END END DeleteUser; PROCEDURE ClearPassword*(VAR id: ShortName); BEGIN UT[Uno(id)].password := 0 END ClearPassword; PROCEDURE SetPassword*(uno: INTEGER; npw: LONGINT); BEGIN UT[uno].password := npw; BackupUsers END SetPassword; PROCEDURE IncPageCount*(uno: INTEGER; n: LONGINT); BEGIN INC(UT[uno].count, n); BackupUsers END IncPageCount; PROCEDURE SetCounts*(n: LONGINT); VAR i: INTEGER; BEGIN i := 0; WHILE i < NUsers DO UT[i].count := n; INC(i) END END SetCounts; PROCEDURE PurgeUsers*(n: INTEGER); BEGIN NUsers := 0 END PurgeUsers; PROCEDURE InsertTask*(VAR Q: Queue; F: Files.File; VAR id: ARRAY OF CHAR; uno: INTEGER); VAR T: Task; BEGIN NEW(T); T.file := F; COPY(id, T.name); T.uno := uno; T.next := NIL; IF Q.last # NIL THEN Q.last.next := T ELSE Q.first := T END ; Q.last := T; INC(Q.n) END InsertTask; PROCEDURE GetTask*(VAR Q: Queue; VAR F: Files.File; VAR id: ShortName; VAR uno: INTEGER); BEGIN (*Q.first # NIL*) F := Q.first.file; id := Q.first.name; uno := Q.first.uno END GetTask; PROCEDURE RemoveTask*(VAR Q: Queue); BEGIN (*Q.first # NIL*) Files.Purge(Q.first.file); Q.first := Q.first.next; DEC(Q.n); IF Q.first = NIL THEN Q.last := NIL END END RemoveTask; PROCEDURE Reset(VAR Q: Queue); BEGIN Q.n := 0; Q.first := NIL; Q.last := NIL END Reset; PROCEDURE Collect*; BEGIN IF Kernel.allocated > 300000 THEN Kernel.GC END END Collect; BEGIN RestoreUsers; Reset(PrintQueue); Reset(MailQueue); Reset(LineQueue) END Core. -------------------------------------------------------------------------------- /Rectangles.Mod: -------------------------------------------------------------------------------- 1 | MODULE Rectangles; (*NW 25.2.90 / 1.2.92*) IMPORT Display, Files, Input, Printer, Texts, Oberon, Graphics, GraphicFrames; TYPE Rectangle* = POINTER TO RectDesc; RectDesc* = RECORD (Graphics.ObjectDesc) lw*, vers*: INTEGER END ; VAR method*: Graphics.Method; shade: 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 Display.ReplConstC(f, col, x-4, y, 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(col: INTEGER); BEGIN Display.ReplConstC(f, col, x, y, w, lw, 0); Display.ReplConstC(f, col, x+w-lw, y, lw, h, 0); Display.ReplConstC(f, col, x, y+h-lw, w, lw, 0); Display.ReplConstC(f, col, x, y, lw, h, 0) END draw; BEGIN WITH M: GraphicFrames.DrawMsg DO 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(col); IF obj.selected THEN mark(f, Display.white, x+w-lw, y+lw) END ; IF obj(Rectangle).vers # 0 THEN Display.ReplPatternC(f, col, Display.grey0, x, y, w, h, x, y, 1) END ELSIF M.mode = 1 THEN mark(f, Display.white, x+w-lw, y+lw) ELSIF M.mode = 2 THEN mark(f, Display.black, x+w-lw, y+lw) ELSIF obj(Rectangle).vers = 0 THEN draw(f.col); mark(f, f.col, x+w-lw, y+lw) ELSE Display.ReplConstC(f, f.col, x, y, w, h, 0) END END END END Draw; PROCEDURE Selectable(obj: Graphics.Object; x, y: INTEGER): BOOLEAN; BEGIN RETURN (obj.x + obj.w - 4 <= x) & (x <= obj.x + obj.w) & (obj.y <= y) & (y <= obj.y + 4) END Selectable; PROCEDURE Handle(obj: Graphics.Object; VAR M: Graphics.Msg); VAR x0, y0, x1, y1, dx, dy: INTEGER; k: SET; BEGIN IF M IS Graphics.WidMsg THEN obj(Rectangle).lw := M(Graphics.WidMsg).w ELSIF M IS Graphics.ColorMsg THEN obj.col := M(Graphics.ColorMsg).col ELSIF M IS GraphicFrames.CtrlMsg THEN WITH M: GraphicFrames.CtrlMsg DO WITH obj: Rectangle DO M.res := 1; x0 := obj.x + obj.w + M.f.x; y0 := obj.y + M.f.y; mark(M.f, Display.white, x0 - obj.lw, y0 + obj.lw); REPEAT Input.Mouse(k, x1, y1); DEC(x1, (x1-M.f.x) MOD 4); DEC(y1, (y1-M.f.y) MOD 4); Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, x1, y1) UNTIL k = {}; mark(M.f, Display.black, x0 - obj.lw, y0 + obj.lw); IF (x0 - obj.w < x1) & (y1 < y0+ obj.h) THEN GraphicFrames.EraseObj(M.f, obj); dx := x1 - x0; dy := y1 - y0; INC(obj.y, dy); INC(obj.w, dx); DEC(obj.h, dy); GraphicFrames.DrawObj(M.f, obj) END END END END END Handle; PROCEDURE Read(obj: Graphics.Object; VAR R: Files.Rider; VAR C: Graphics.Context); VAR w, v: SHORTINT; len: INTEGER; BEGIN Files.ReadInt(R, len); Files.Read(R, w); Files.Read(R, v); obj(Rectangle).lw := w; obj(Rectangle).vers := v END Read; PROCEDURE Write(obj: Graphics.Object; cno: SHORTINT; VAR W: Files.Rider; VAR C: Graphics.Context); BEGIN Graphics.WriteObj(W, cno, obj); Files.WriteInt(W, 2); Files.Write(W, SHORT(obj(Rectangle).lw)); Files.Write(W, SHORT(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 := shade; R.do := method; Graphics.Add(G.graph, R); GraphicFrames.Defocus(G); GraphicFrames.DrawObj(G, R) END END Make; PROCEDURE SetShade*; VAR S: Texts.Scanner; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); IF S.class = Texts.Int THEN shade := SHORT(S.i) END END SetShade; BEGIN shade := 0; NEW(method); method.module := "Rectangles"; method.allocator := "New"; method.new := New; method.copy := Copy; method.draw := Draw; method.selectable := Selectable; method.handle := Handle; method.read := Read; method.write := Write; method.print := Print END Rectangles. -------------------------------------------------------------------------------- /C2.SCC.Mod: -------------------------------------------------------------------------------- 1 | MODULE SCC; (*NW 13.11.87 / 25.8.91 Ceres-2*) IMPORT SYSTEM, Kernel; CONST BufLen = 2048; com = 0FFFFD008H; (*commands and status, SCC channel A*) dat = 0FFFFD00CH; DIPS = 0FFFFFC00H; ICU = 0FFFF9004H; RxCA = 0; (*R0: Rx Char Available*) TxBE = 2; (*R0: Tx Buffer Empty*) Hunt = 4; (*R0: Sync/Hunt*) TxUR = 6; (*R0: Tx UnderRun*) RxOR = 5; (*R1: Rx OverRun*) CRC = 6; (*R1: CRC error*) EOF = 7; (*R1: End Of Frame*) TYPE Header* = RECORD valid*: BOOLEAN; dadr*, sadr*, typ*: SHORTINT; len*: INTEGER; (*of data following header*) destLink*, srcLink*: INTEGER (*link numbers*) END ; VAR in, out: INTEGER; crcerr, samplerr: LONGINT; Adr: SHORTINT; SCCR3: CHAR; buf: ARRAY BufLen OF CHAR; PROCEDURE PUT(r: SHORTINT; x: SYSTEM.BYTE); BEGIN SYSTEM.PUT(com, r); SYSTEM.PUT(com, x) END PUT; PROCEDURE+ Int1; VAR del, oldin: INTEGER; stat: SET; dmy: CHAR; BEGIN SYSTEM.GET(dat, buf[in]); PUT(1, 0X); (*disable interrupts*) oldin := in; in := (in+1) MOD BufLen; del := 16; LOOP IF SYSTEM.BIT(com, RxCA) THEN del := 16; IF in # out THEN SYSTEM.GET(dat, buf[in]); in := (in+1) MOD BufLen ELSE SYSTEM.GET(dat, dmy) END ELSE SYSTEM.PUT(com, 1X); DEC(del); IF SYSTEM.BIT(com, EOF) & (del <= 0) OR (del <= -16) THEN EXIT END END END ; SYSTEM.PUT(com, 1X); SYSTEM.GET(com, stat); IF (RxOR IN stat) OR (CRC IN stat) OR (in = out) THEN in := oldin; INC(crcerr) (*reset buffer*) ELSE in := (in-2) MOD BufLen (*remove CRC*) END ; SYSTEM.PUT(com, 30X); (*error reset*) SYSTEM.PUT(com, 10X); (*reset ext/stat interrupts*) PUT( 1, 8X); (*enable Rx-Int on 1st char*) SYSTEM.PUT(com, 20X); (*enable Rx-Int on next char*) PUT( 3, SCCR3); (*enter hunt mode*) END Int1; PROCEDURE Start*(filter: BOOLEAN); BEGIN in := 0; out := 0; IF filter THEN SCCR3 := 0DDX ELSE SCCR3 := 0D9X END ; SYSTEM.GET(DIPS, Adr); Adr := Adr MOD 40H; Kernel.InstallIP(Int1, 1); PUT( 9, 80X); (*reset A, disable all interrupts*) PUT( 4, 20X); (*SDLC mode*) PUT( 1, 0X); (*disable all interrupts*) PUT( 2, 0X); (*interrupt vector*) PUT( 3, SCCR3); (*8bit, hunt mode, Rx-CRC on, adr search, Rx off*) PUT( 5, 0E1X); (*8bit, SDLC, Tx-CRC on, Tx off*) PUT( 6, Adr); (*SDLC-address*) PUT( 7, 7EX); (*SDLC flag*) PUT( 9, 6X); (*master int on, no vector*) PUT(10, 0E0X); (*FM0*) PUT(11, 0F7X); (*Xtal, RxC = DPLL TxC = rate genL*) PUT(12, 6X); (*lo byte of rate gen: Xtal DIV 16*) PUT(13, 0X); (*hi byte of rate gen*) PUT(14, 0A0X); (*DPLL = Xtal*) PUT(14, 0C0X); (*FM mode*) PUT( 3, SCCR3); (*Rx enable, enter hunt mode*) SYSTEM.PUT(com, 80X); (*TxCRC reset*) PUT(15, 0X); (*mask ext interrupts*) SYSTEM.PUT(com, 10X); SYSTEM.PUT(com, 10X); (*reset ext/status*) PUT( 1, 0X); (*Rx-Int on 1st char off*) PUT( 9, 0EX); (*no A reset, enable int, disable daisy chain*) PUT( 1, 8X); (*enable Rx Int*) PUT(14, 21X); (*enter search mode*) SYSTEM.PUT(ICU, 19X); (*clear IRR and IMR bits, channel 1*) END Start; PROCEDURE SendPacket*(VAR head, buf: ARRAY OF SYSTEM.BYTE); VAR i, j, len: INTEGER; BEGIN head[2] := Adr; len := ORD(head[5])*100H + ORD(head[4]); j := 200; LOOP (*sample line*) i := 480; REPEAT DEC(i) UNTIL SYSTEM.BIT(com, Hunt) OR (i = 0); IF i > 0 THEN (*line idle*) EXIT END ; DEC(j); IF j = 0 THEN INC(samplerr); Start(TRUE); j := 100 END ; i := LONG(Adr)*128 + 800; (*delay*) REPEAT DEC(i) UNTIL i = 0 END ; Kernel.SetICU(0A2X); (*disable interrupts!*) PUT( 5, 63X); (*RTS, send 1s*) PUT( 5, 6BX); (*RTS, Tx enable*) SYSTEM.PUT(com, 80X); (*reset Tx-CRC*) SYSTEM.PUT(dat, ORD(head[1])); (*send dest*) SYSTEM.PUT(com, 0C0X); (*reset underrun/EOM flag*) REPEAT UNTIL SYSTEM.BIT(com, TxBE); i := 2; REPEAT SYSTEM.PUT(dat, head[i]); INC(i); REPEAT UNTIL SYSTEM.BIT(com, TxBE) UNTIL i = 10; i := 0; WHILE i < len DO SYSTEM.PUT(dat, buf[i]); INC(i); (*send data*) REPEAT UNTIL SYSTEM.BIT(com, TxBE) END ; REPEAT UNTIL SYSTEM.BIT(com, TxUR) & SYSTEM.BIT(com, TxBE); PUT( 5, 63X); (*RTS, Tx disable, send 1s*) i := 240; REPEAT DEC(i) UNTIL i = 0; PUT( 5, 0E1X); (*~RTS*) PUT( 1, 8X); (*enable Rx-Int on 1st char*) PUT(14, 21X); (*enter search mode*) SYSTEM.PUT(com, 20X); (*enable Rx-Int on next char*) PUT( 3, SCCR3); (*enter hunt mode*) Kernel.SetICU(0A1X) (*enable interrupts*) END SendPacket; PROCEDURE Available*(): INTEGER; BEGIN RETURN (in - out) MOD BufLen END Available; PROCEDURE Receive*(VAR x: SYSTEM.BYTE); BEGIN REPEAT UNTIL in # out; x := buf[out]; out := (out+1) MOD BufLen END Receive; PROCEDURE ReceiveHead*(VAR head: ARRAY OF SYSTEM.BYTE); VAR i: INTEGER; BEGIN IF (in - out) MOD BufLen >= 9 THEN head[0] := 1; i := 1; REPEAT Receive(head[i]); INC(i) UNTIL i = 10 ELSE head[0] := 0 END END ReceiveHead; PROCEDURE Skip*(m: INTEGER); BEGIN IF m <= (in - out) MOD BufLen THEN out := (out+m) MOD BufLen ELSE out := in END END Skip; PROCEDURE Stop*; BEGIN PUT(9, 80X); (*reset SCCA*) SYSTEM.PUT(ICU, 39X); SYSTEM.PUT(ICU, 59X); (*reset IMR and IRR*) END Stop; BEGIN samplerr := 0; crcerr := 0; Start(TRUE) END SCC. -------------------------------------------------------------------------------- /MFiles.Mod: -------------------------------------------------------------------------------- 1 | MODULE MFiles; (*NW 24.8.90 / 12.10.90 Ceres-3*) IMPORT SYSTEM, Kernel, FileDir; (*A file consists of a sequence of sectors. The first sector contains the header. Part of the header is the sector table, an array of addresses to the sectors. A file is referenced through riders. A rider indicates a current position and refers to a file*) CONST HS = FileDir.HeaderSize; SS = FileDir.SectorSize; STS = FileDir.SecTabSize; XS = FileDir.IndexSize; TYPE File* = POINTER TO Header; Index = POINTER TO FileDir.IndexSector; Rider* = RECORD eof*: BOOLEAN; res*: LONGINT; file: File; pos: LONGINT; unused: File; adr: LONGINT; END ; Header = RECORD mark: LONGINT; name: FileDir.FileName; len, time, date: LONGINT; ext: ARRAY FileDir.ExTabSize OF Index; sec: FileDir.SectorTable END ; PROCEDURE Old*(name: ARRAY OF CHAR): File; VAR head: LONGINT; namebuf: FileDir.FileName; BEGIN COPY(name, namebuf); FileDir.Search(namebuf, head); RETURN SYSTEM.VAL(File, head) END Old; PROCEDURE New*(name: ARRAY OF CHAR): File; VAR f: File; head: LONGINT; BEGIN f := NIL; Kernel.AllocSector(0, head); IF head # 0 THEN f := SYSTEM.VAL(File, head); f.mark := FileDir.HeaderMark; f.len := HS; COPY(name, f.name); Kernel.GetClock(f.time, f.date); f.sec[0] := head END ; RETURN f END New; PROCEDURE Register*(f: File); BEGIN IF (f # NIL) & (f.name[0] > 0X) THEN FileDir.Insert(f.name, f.sec[0]) END ; END Register; PROCEDURE Length*(f: File): LONGINT; BEGIN RETURN f.len - HS END Length; PROCEDURE GetDate*(f: File; VAR t, d: LONGINT); BEGIN t := f.time; d := f.date END GetDate; PROCEDURE Set*(VAR r: Rider; f: File; pos: LONGINT); VAR m: INTEGER; n: LONGINT; BEGIN r.eof := FALSE; r.res := 0; r.unused := NIL; IF f # NIL THEN IF pos < 0 THEN r.pos := 0 ELSIF pos > f.len-HS THEN r.pos := f.len ELSE r.pos := pos+HS END ; r.file := f; m := SHORT(r.pos DIV SS); n := r.pos MOD SS; IF m < STS THEN r.adr := f.sec[m] + n ELSE r.adr := f.ext[(m-STS) DIV XS].x[(m-STS) MOD XS] + n END END END Set; PROCEDURE Read*(VAR r: Rider; VAR x: SYSTEM.BYTE); VAR m: INTEGER; BEGIN IF r.pos < r.file.len THEN SYSTEM.GET(r.adr, x); INC(r.adr); INC(r.pos); IF r.adr MOD SS = 0 THEN m := SHORT(r.pos DIV SS); IF m < STS THEN r.adr := r.file.sec[m] ELSE r.adr := r.file.ext[(m-STS) DIV XS].x[(m-STS) MOD XS] END END ELSE x := 0X; r.eof := TRUE END END Read; PROCEDURE ReadBytes*(VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT); VAR src, dst, m: LONGINT; k: INTEGER; BEGIN m := r.pos - r.file.len + n; IF m > 0 THEN DEC(n, m); r.res := m; r.eof := TRUE END ; src := r.adr; dst := SYSTEM.ADR(x); m := (-r.pos) MOD SS; LOOP IF n <= 0 THEN EXIT END ; IF n <= m THEN SYSTEM.MOVE(src, dst, n); INC(r.pos, n); r.adr := src+n; EXIT END ; SYSTEM.MOVE(src, dst, m); INC(r.pos, m); INC(dst,m); DEC(n, m); k := SHORT(r.pos DIV SS); m := SS; IF k < STS THEN src := r.file.sec[k] ELSE src := r.file.ext[(k-STS) DIV SS].x[(k-STS) MOD XS] END END END ReadBytes; PROCEDURE Write*(VAR r: Rider; x: SYSTEM.BYTE); VAR k, m, n: INTEGER; ix: LONGINT; BEGIN IF r.pos < r.file.len THEN m := SHORT(r.pos DIV SS); INC(r.pos); IF m < STS THEN r.adr := r.file.sec[m] ELSE r.adr := r.file.ext[(m-STS) DIV XS].x[(m-STS) MOD XS] END ELSE IF r.adr MOD SS = 0 THEN m := SHORT(r.pos DIV SS); IF m < STS THEN Kernel.AllocSector(0, r.adr); r.file.sec[m] := r.adr ELSE n := (m-STS) DIV XS; k := (m-STS) MOD XS; IF k = 0 THEN (*new index*) Kernel.AllocSector(0, ix); r.file.ext[n] := SYSTEM.VAL(Index, ix) END ; Kernel.AllocSector(0, r.adr); r.file.ext[n].x[k] := r.adr END END ; INC(r.pos); r.file.len := r.pos END ; SYSTEM.PUT(r.adr, x); INC(r.adr) END Write; PROCEDURE WriteBytes*(VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT); VAR src, dst, m, ix: LONGINT; k, lim, h0, h1: INTEGER; BEGIN src := SYSTEM.ADR(x); dst := r.adr; m := (-r.pos) MOD SS; lim := SHORT(r.file.len DIV SS); LOOP IF n <= 0 THEN EXIT END ; IF m = 0 THEN k := SHORT(r.pos DIV SS); m := SS; IF k > lim THEN Kernel.AllocSector(0, dst); IF k < STS THEN r.file.sec[k] := dst ELSE h1 := (k-STS) DIV XS; h0 := (k-STS) MOD XS; IF h0 = 0 THEN (*new extension index*) Kernel.AllocSector(0, ix); r.file.ext[h1] := SYSTEM.VAL(Index, ix) END ; r.file.ext[h1].x[h0] := dst END ELSIF k < STS THEN dst := r.file.sec[k] ELSE dst := r.file.ext[(k-STS) DIV XS].x[(k-STS) MOD XS] END ; END ; IF n < m THEN SYSTEM.MOVE(src, dst, n); INC(r.pos, n); r.adr := dst + n; IF r.pos >= r.file.len THEN r.file.len := r.pos END ; EXIT END ; SYSTEM.MOVE(src, dst, m); INC(r.pos, m); IF r.pos >= r.file.len THEN r.file.len := r.pos END ; INC(src, m); DEC(n, m); m := 0 END END WriteBytes; PROCEDURE Pos*(VAR r: Rider): LONGINT; BEGIN RETURN r.pos - HS END Pos; PROCEDURE Base*(VAR r: Rider): File; BEGIN RETURN r.file END Base; END MFiles. -------------------------------------------------------------------------------- /Printer.Mod: -------------------------------------------------------------------------------- 1 | MODULE Printer; (*NW 27.6.88 / 10.12.92*) IMPORT SYSTEM, Input, SCC; CONST maxfonts = 16; PakSize = 512; Broadcast = -1; T0 = 300; T1 = 1200; ACK = 10H; NAK = 25H; NRQ = 34H; NRS = 35H; PRT = 43H; FAX = 4FH; NPR = 26H; TOT = 7FH; VAR res*: INTEGER; (*0 = done, 1 = not done*) PageWidth*, PageHeight*: INTEGER; nofonts: INTEGER; seqno: SHORTINT; head0: SCC.Header; (*sender*) head1: SCC.Header; (*receiver*) in: INTEGER; PrinterName: ARRAY 10 OF CHAR; fontname: ARRAY maxfonts, 32 OF CHAR; buf: ARRAY PakSize OF SYSTEM.BYTE; PROCEDURE ReceiveHead; VAR time: LONGINT; BEGIN time := Input.Time() + T0; LOOP SCC.ReceiveHead(head1); IF head1.valid THEN IF head1.sadr = head0.dadr THEN EXIT ELSE SCC.Skip(head1.len) END ELSIF Input.Time() >= time THEN head1.typ := TOT; EXIT END END END ReceiveHead; PROCEDURE FindPrinter(VAR name: ARRAY OF CHAR); VAR time: LONGINT; id: ARRAY 10 OF CHAR; BEGIN head0.typ := NRQ; head0.dadr := Broadcast; head0.len := 10; head0.destLink := 0; COPY(name, id); id[8] := 6X; id[9] := 0X; SCC.Skip(SCC.Available()); SCC.SendPacket(head0, id); time := Input.Time() + T1; LOOP SCC.ReceiveHead(head1); IF head1.valid THEN IF head1.typ = NRS THEN head0.dadr := head1.sadr; res := 0; EXIT ELSE SCC.Skip(head1.len) END ELSIF Input.Time() >= time THEN res := 1; EXIT END END END FindPrinter; PROCEDURE SendPacket; BEGIN head0.typ := seqno; head0.len := in; REPEAT SCC.SendPacket(head0, buf); ReceiveHead; UNTIL head1.typ # seqno + ACK; seqno := (seqno+1) MOD 8; IF head1.typ # seqno + ACK THEN res := 1 END END SendPacket; PROCEDURE Send(x: SYSTEM.BYTE); BEGIN buf[in] := x; INC(in); IF in = PakSize THEN SendPacket; in := 0 END END Send; PROCEDURE SendInt(k: INTEGER); BEGIN Send(SHORT(k MOD 100H)); Send(SHORT(k DIV 100H)) END SendInt; PROCEDURE SendBytes(VAR x: ARRAY OF SYSTEM.BYTE; n: INTEGER); VAR i: INTEGER; BEGIN i := 0; WHILE i < n DO Send(x[i]); INC(i) END END SendBytes; PROCEDURE SendString(VAR s: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := 0; WHILE s[i] > 0X DO Send(s[i]); INC(i) END ; Send(0) END SendString; PROCEDURE Open* (VAR name, user: ARRAY OF CHAR; password: LONGINT); VAR i: INTEGER; typ: SHORTINT; BEGIN nofonts := 0; in := 0; seqno := 0; i := 0; WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END; IF name[i] # 0X THEN typ := FAX; name[i] := 0X ELSE typ := PRT END; SCC.Skip(SCC.Available()); IF name # PrinterName THEN FindPrinter(name) ELSE res := 0 END; IF res = 0 THEN SendString(user); SendBytes(password, 4); IF typ = FAX THEN INC(i); REPEAT Send(name[i]); INC(i) UNTIL name[i-1] = 0X END; head0.typ := typ; head0.len := in; SCC.SendPacket(head0, buf); in := 0; ReceiveHead; IF head1.typ = ACK THEN Send(0FCX); (*printfileid*) ELSIF head1.typ = NPR THEN res := 4 (*no permission*) ELSE res := 2 (*no printer*) END END END Open; PROCEDURE ReplConst*(x, y, w, h: INTEGER); BEGIN Send(2); Send(0); SendInt(x); SendInt(y); SendInt(w); SendInt(h) END ReplConst; PROCEDURE fontno(VAR name: ARRAY OF CHAR): SHORTINT; VAR i, j: INTEGER; BEGIN i := 0; WHILE (i < nofonts) & (fontname[i] # name) DO INC(i) END ; IF i = nofonts THEN IF nofonts < maxfonts THEN COPY(name, fontname[i]); INC(nofonts); Send(3); Send(SHORT(i)); j := 0; WHILE name[j] >= "0" DO Send(name[j]); INC(j) END ; Send(0) ELSE i := 0 END END ; RETURN SHORT(i) END fontno; PROCEDURE UseListFont*(VAR name: ARRAY OF CHAR); VAR i: INTEGER; listfont: ARRAY 10 OF CHAR; BEGIN listfont := "Gacha10l"; i := 0; WHILE (i < nofonts) & (fontname[i] # name) DO INC(i) END ; IF i = nofonts THEN COPY(name, fontname[i]); INC(nofonts); Send(3); Send(SHORT(i)); SendBytes(listfont, 9) END ; END UseListFont; PROCEDURE String*(x, y: INTEGER; VAR s, fname: ARRAY OF CHAR); VAR fno: SHORTINT; BEGIN fno := fontno(fname); Send(1); Send(fno); SendInt(x); SendInt(y); SendString(s) END String; PROCEDURE ContString*(VAR s, fname: ARRAY OF CHAR); VAR fno: SHORTINT; BEGIN fno := fontno(fname); Send(0); Send(fno); SendString(s) END ContString; PROCEDURE ReplPattern*(x, y, w, h, col: INTEGER); BEGIN Send(5); Send(SHORT(col)); SendInt(x); SendInt(y); SendInt(w); SendInt(h) END ReplPattern; PROCEDURE Line*(x0, y0, x1, y1: INTEGER); BEGIN Send(6); Send(0); SendInt(x0); SendInt(y0); SendInt(x1); SendInt(y1) END Line; PROCEDURE Circle*(x0, y0, r: INTEGER); BEGIN Send(9); Send(0); SendInt(x0); SendInt(y0); SendInt(r) END Circle; PROCEDURE Ellipse*(x0, y0, a, b: INTEGER); BEGIN Send(7); Send(0); SendInt(x0); SendInt(y0); SendInt(a); SendInt(b) END Ellipse; PROCEDURE Spline*(x0, y0, n, open: INTEGER; VAR X, Y: ARRAY OF INTEGER); VAR i: INTEGER; BEGIN Send(10); Send(SHORT(open)); SendInt(x0); SendInt(y0); SendInt(n); i := 0; WHILE i < n DO SendInt(X[i]); SendInt(Y[i]); INC(i) END END Spline; PROCEDURE Picture*(x, y, w, h, mode: INTEGER; adr: LONGINT); VAR a0, a1: LONGINT; b: SHORTINT; BEGIN Send(8); Send(SHORT(mode)); SendInt(x); SendInt(y); SendInt(w); SendInt(h); a0 := adr; a1 := LONG((w+7) DIV 8) * h + a0; WHILE (a0 < a1) & (res = 0) DO SYSTEM.GET(a0, b); Send(b); INC(a0) END END Picture; PROCEDURE Page*(nofcopies: INTEGER); BEGIN Send(4); Send(SHORT(nofcopies)) END Page; PROCEDURE Close*; BEGIN SendPacket; WHILE nofonts > 0 DO DEC(nofonts); fontname[nofonts, 0] := " " END END Close; PROCEDURE UseColor* (red,green,blue : INTEGER); BEGIN Send(11); Send(CHR(red)); Send(CHR(green)); Send(CHR(blue)) END UseColor; BEGIN PageWidth := 2336; PageHeight := 3425; in := 0; PrinterName[0] := 0X END Printer. -------------------------------------------------------------------------------- /BTree.Mod: -------------------------------------------------------------------------------- 1 | MODULE BTree; IMPORT Texts, Oberon; CONST N = 3; TYPE Page = POINTER TO PageRec; Entry = RECORD key, count: INTEGER; p: Page END; PageRec = RECORD m: INTEGER; (*no. of entries on page*) p0: Page; e: ARRAY 2*N OF Entry END; VAR root: Page; W: Texts.Writer; PROCEDURE search(x: INTEGER; a: Page; VAR cnt: INTEGER); VAR i, L, R: INTEGER; BEGIN (*a # NIL*) LOOP L := 0; R := a.m; (*binary search*) WHILE L < R DO i := (L+R) DIV 2; IF x <= a.e[i].key THEN R := i ELSE L := i+1 END END ; IF (R < a.m) & (a.e[R].key = x) THEN (*found*) INC(a.e[R].count); cnt := a.e[R].count; EXIT END ; IF R = 0 THEN a := a.p0 ELSE a := a.e[R-1].p END ; IF a = NIL THEN (*not found*) cnt := 0; EXIT END END END search; PROCEDURE insert(x: INTEGER; a: Page; VAR h: BOOLEAN; VAR v: Entry); (*a # NIL. Search key x in B-tree with root a; if found, increment counter. Otherwise insert new item with key x. If an entry is to be passed up, assign it to v. h := "tree has become higher"*) VAR i, L, R: INTEGER; b: Page; u: Entry; BEGIN (*a # NIL & ~h*) L := 0; R := a.m; (*binary search*) WHILE L < R DO i := (L+R) DIV 2; IF x <= a.e[i].key THEN R := i ELSE L := i+1 END END ; IF (R < a.m) & (a.e[R].key = x) THEN (*found*) INC(a.e[R].count) ELSE (*item not on this page*) IF R = 0 THEN b := a.p0 ELSE b := a.e[R-1].p END ; IF b = NIL THEN (*not in tree, insert*) u.count := 0; u.p := NIL; h := TRUE; u.key := x ELSE insert(x, b, h, u) END ; IF h THEN (*insert u to the left of a.e[R]*) IF a.m < 2*N 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 NEW(b); (*overflow; split a into a,b and assign the middle entry to v*) IF R < N THEN (*insert in left page a*) i := N-1; v := a.e[i]; WHILE i > R DO DEC(i); a.e[i+1] := a.e[i] END ; a.e[R] := u; i := 0; WHILE i < N DO b.e[i] := a.e[i+N]; INC(i) END ELSE (*insert in right page b*) DEC(R, N); i := 0; IF R = 0 THEN v := u ELSE v := a.e[N]; WHILE i < R-1 DO b.e[i] := a.e[i+N+1]; INC(i) END ; b.e[i] := u; INC(i) END ; WHILE i < N DO b.e[i] := a.e[i+N]; INC(i) END END ; a.m := N; b.m := N; b.p0 := v.p; v.p := b END END END END insert; PROCEDURE underflow(c, a: Page; s: INTEGER; VAR h: BOOLEAN); (*a = underflowing page, c = ancestor page, s = index of deleted entry in c*) VAR b: Page; i, k: INTEGER; BEGIN (*h & (a.m = N-1) & (c.e[s-1].p = a) *) IF s < c.m THEN (*b := page to the right of a*) b := c.e[s].p; k := (b.m-N+1) DIV 2; (*k = nof items available on page b*) a.e[N-1] := c.e[s]; a.e[N-1].p := b.p0; IF k > 0 THEN (*balance by moving k-1 items from b to a*) i := 0; WHILE i < k-1 DO a.e[i+N] := b.e[i]; INC(i) END ; c.e[s] := b.e[k-1]; b.p0 := c.e[s].p; c.e[s].p := b; DEC(b.m, k); i := 0; WHILE i < b.m DO b.e[i] := b.e[i+k]; INC(i) END ; 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 ELSE (*b := page to the left of a*) DEC(s); IF s = 0 THEN b := c.p0 ELSE b := c.e[s-1].p END ; k := (b.m-N+1) DIV 2; (*k = nof 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*) DEC(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 := a; a.m := N-1+k; h := FALSE 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 END END underflow; PROCEDURE delete(x: INTEGER; a: Page; VAR h: BOOLEAN); (*search and delete key x in B-tree a; if a page underflow arises, balance with adjacent page or merge; h := "page a is undersize"*) VAR i, L, R: INTEGER; q: Page; PROCEDURE del(p: Page; VAR h: BOOLEAN); VAR k: INTEGER; q: Page; (*global a, R*) BEGIN k := p.m-1; q := p.e[k].p; IF q # NIL THEN del(q, h); IF h THEN underflow(p, q, p.m, h) END ELSE p.e[k].p := a.e[R].p; a.e[R] := p.e[k]; DEC(p.m); h := p.m < N END END del; BEGIN (*a # NIL*) L := 0; R := a.m; (*binary search*) WHILE L < R DO i := (L+R) DIV 2; IF x <= a.e[i].key THEN R := i ELSE L := i+1 END END ; IF R = 0 THEN q := a.p0 ELSE q := a.e[R-1].p END ; IF (R < a.m) & (a.e[R].key = x) THEN (*found*) IF q = NIL THEN (*a is 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(q, h); IF h THEN underflow(a, q, R, h) END END ELSE delete(x, q, h); IF h THEN underflow(a, q, R, h) END END END delete; PROCEDURE PrintTree(p: Page; level: INTEGER); VAR i: INTEGER; BEGIN IF p # NIL THEN i := 0; WHILE i < level DO Texts.WriteString(W, " "); INC(i) END ; i := 0; WHILE i < p.m DO Texts.WriteInt(W, p.e[i].key, 5); INC(i) END ; Texts.WriteLn(W); PrintTree(p.p0, level+1); i := 0; WHILE i < p.m DO PrintTree(p.e[i].p, level+1); INC(i) END END END PrintTree; PROCEDURE Search*; VAR cnt: INTEGER; S: Texts.Scanner; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.WriteString(W, "search"); Texts.Scan(S); WHILE S.class = Texts.Int DO Texts.WriteInt(W, S.i, 4); search(SHORT(S.i), root, cnt); Texts.WriteInt(W, cnt, 4) END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END Search; PROCEDURE Insert*; VAR S: Texts.Scanner; h: BOOLEAN; u: Entry; q: Page; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.WriteString(W, "insert"); Texts.Scan(S); WHILE S.class = Texts.Int DO Texts.WriteInt(W, S.i, 4); h := FALSE; insert(SHORT(S.i), root, h, u); IF h THEN (*insert new base page*) q := root; NEW(root); root.m := 1; root.p0 := q; root.e[0] := u END ; Texts.Scan(S) END ; Texts.WriteLn(W); PrintTree(root, 0); Texts.Append(Oberon.Log, W.buf) END Insert; PROCEDURE Delete*; VAR S: Texts.Scanner; h: BOOLEAN; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.WriteString(W, "delete"); Texts.Scan(S); WHILE S.class = Texts.Int DO Texts.WriteInt(W, S.i, 4); h := FALSE; delete(SHORT(S.i), root, h); IF h THEN (*base page size underflow*) IF root.m = 0 THEN root := root.p0 END END ; Texts.Scan(S) END ; Texts.WriteLn(W); PrintTree(root, 0); Texts.Append(Oberon.Log, W.buf) END Delete; PROCEDURE Init*; BEGIN NEW(root); root.m := 0 END Init; BEGIN Init; Texts.OpenWriter(W) END BTree. -------------------------------------------------------------------------------- /Viewers.Mod: -------------------------------------------------------------------------------- 1 | MODULE Viewers; (*JG 14.9.90*) IMPORT Display; CONST restore* = 0; modify* = 1; suspend* = 2; (*message ids*) inf = MAX(INTEGER); 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*, DW, DH: INTEGER; FillerTrack: Track; FillerViewer, buf: Viewer; (*for closed viewers*) 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 WITH v: Viewer DO 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.state := 0; buf := v; V.next := v.next; u.next := V; V.state := 2 END 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 WITH S: Track DO t := S.next; WHILE t.next.X # S.X DO t := t.next END; T := S.under; WHILE T.next # NIL DO T := T.next END; t.next := S.under; T.next := S.next; M.id := restore; REPEAT t := t.next; v := t.dsc; REPEAT v := v.next; v.handle(v, M); WITH v: Viewer DO v.state := - v.state END UNTIL v = t.dsc UNTIL t = T END 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; buf := 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; buf := V; U.handle(U, M); U(Viewer).state := 0; RestoreTrack(T) END END END Close; PROCEDURE Recall* ( VAR V: Viewer); BEGIN V := buf 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; RETURN V(Viewer) ELSE RETURN NIL END 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; 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; WITH v: Viewer DO M.state := -v.state; v.handle(v, M); v.state := M.state END 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 buf := NIL; 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; curW := 0; minH := 1; DW := Display.Width; DH := Display.Height END Viewers. -------------------------------------------------------------------------------- /MenuViewers.Mod: -------------------------------------------------------------------------------- 1 | MODULE MenuViewers; (*JG 26.8.90 / 16.9.93*) IMPORT Input, Display, Viewers, Oberon; CONST extend* = 0; reduce* = 1; FrameColor = 15; TYPE Viewer* = POINTER TO ViewerDesc; ViewerDesc* = RECORD (Viewers.ViewerDesc) menuH*: INTEGER END; ModifyMsg* = RECORD (Display.FrameMsg) id*: INTEGER; dY*, Y*, H*: INTEGER END; VAR Ancestor*: Viewer; 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, 0); Display.ReplConst(FrameColor, V.X + V.W - 1, V.Y, 1, V.H, 0); Display.ReplConst(FrameColor, V.X + 1, V.Y, V.W - 2, 1, 0); Display.ReplConst(FrameColor, V.X + 1, V.Y + V.H - 1, V.W - 2, 1, 0) 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, 0); Display.ReplConst(FrameColor, V.X, newY, 1, dH, 0); Display.ReplConst(FrameColor, V.X + V.W - 1, newY, 1, dH, 0); Display.ReplConst(FrameColor, V.X + 1, newY, V.W - 2, 1, 0) END END Extend; PROCEDURE Reduce (V: Viewer; newY: INTEGER); BEGIN Display.ReplConst(FrameColor, V.X + 1, newY, V.W - 2, 1, 0) 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, 0); Display.ReplConst(FrameColor, V.X + V.W - 1, V.Y + oldH, 1, dH, 0); Display.ReplConst(FrameColor, V.X + 1, V.Y + V.H - 1, V.W - 2, 1, 0) END END Grow; PROCEDURE Shrink (V: Viewer; newH: INTEGER); BEGIN Display.ReplConst(FrameColor, V.X + 1, V.Y + newH - 1, V.W - 2, 1, 0) 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.DrawCursor(Oberon.Mouse, Oberon.Arrow, X, Y); Display.ReplConst(Display.white, V.X + 1, V.Y + V.H - 1 - V.dsc.H, V.W - 2, V.dsc.H, 2); Y0 := Y; keysum := Keys; LOOP Input.Mouse(Keys, X, Y); IF Keys = {} THEN EXIT END; keysum := keysum + Keys; Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, X, Y) END; Display.ReplConst(Display.white, V.X + 1, V.Y + V.H - 1 - V.dsc.H, V.W - 2, V.dsc.H, 2); 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; 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 IF V1 IS Viewer THEN IF V1.H < V1(Viewer).menuH + 2 THEN dY := 0 ELSIF V1.H < V1(Viewer).menuH + 2 + dY THEN dY := V1.H - V1(Viewer).menuH - 2 END ELSIF V1.H < 1 + dY THEN dY := V1.H - 1 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 Menu, Main: Display.Frame; V1: Viewer; BEGIN WITH V: Viewer DO Ancestor := V; Menu := V.dsc; Main := V.dsc.next; IF M IS Oberon.InputMsg THEN WITH M: Oberon.InputMsg DO IF M.id = Oberon.track THEN IF M.Y < V.Y + 1 THEN Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, M.X, M.Y) ELSIF M.Y < V.Y + V.H - V.menuH THEN Main.handle(Main, M) ELSIF M.Y < V.Y + V.H - V.menuH + 2 THEN Menu.handle(Menu, M) ELSIF M.Y < V.Y + V.H - 1 THEN IF 2 IN M.keys THEN Change(V, M.X, M.Y, M.keys) ELSE Menu.handle(Menu, M) END ELSE Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, M.X, M.Y) END ELSE Menu.handle(Menu, M); Main.handle(Main, M) END END ELSIF M IS Oberon.ControlMsg THEN WITH M: Oberon.ControlMsg DO IF M.id = Oberon.mark THEN Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, M.X, M.Y); Oberon.DrawCursor(Oberon.Pointer, Oberon.Star, M.X, M.Y) ELSE Menu.handle(Menu, M); Main.handle(Main, M) END END ELSIF M IS Oberon.CopyMsg THEN WITH M: Oberon.CopyMsg DO Copy(V(Viewer), V1); M.F := V1 END ELSIF M IS Viewers.ViewerMsg THEN WITH M: Viewers.ViewerMsg DO IF M.id = Viewers.restore THEN Restore(V) ELSIF M.id = Viewers.modify THEN Modify(V, M.Y, M.H) ELSIF M.id = Viewers.suspend THEN Suspend(V) END END ELSE Menu.handle(Menu, M); Main.handle(Main, M) END 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. -------------------------------------------------------------------------------- /Modules.Mod: -------------------------------------------------------------------------------- 1 | MODULE Modules; (*NW 16.2.86 / 22.9.92*) IMPORT SYSTEM, Kernel, Files; CONST ModNameLen* = 24; ObjMark = 0F5X; maximps = 32; headersize = 64; TYPE Module* = POINTER TO ModDesc; Command* = PROCEDURE; ModuleName* = ARRAY ModNameLen OF CHAR; ModDesc* = RECORD next*: Module; size*, IB*, EB*, RB*, CB*, PB*, refcnt*, key*: LONGINT; name*: ModuleName END ; VAR res*: INTEGER; importing*, imported*: ModuleName; loop: Command; (*Exported procedures: ThisMod, Free, ThisProc*) PROCEDURE ReadName(VAR R: Files.Rider; VAR s: ModuleName); VAR ch: CHAR; i: INTEGER; BEGIN i := 0; REPEAT Files.Read(R, ch); s[i] := ch; INC(i) UNTIL ch = 0X END ReadName; PROCEDURE OpenFile(VAR F: Files.File; VAR name: ARRAY OF CHAR); VAR i: INTEGER; ch: CHAR; Fname: ARRAY 32 OF CHAR; BEGIN i := 0; ch := name[0]; (*make file name*) WHILE ch > 0X DO Fname[i] := ch; INC(i); ch := name[i] END ; Fname[i] := "."; Fname[i+1] := "o"; Fname[i+2] := "b"; Fname[i+3] := "j"; Fname[i+4] := 0X; F := Files.Old(Fname) END OpenFile; PROCEDURE disp(a: LONGINT): LONGINT; VAR d: LONGINT; i: INTEGER; BEGIN d := 0; a := a MOD 40000000H + 0C0000000H; i := 0; REPEAT d := SYSTEM.LSH(d, 8) + (a MOD 100H); a := SYSTEM.LSH(a, -8); INC(i) UNTIL i = 4; RETURN d END disp; PROCEDURE ThisMod*(name: ARRAY OF CHAR): Module; (*search module in list; if not found, load module*) VAR mod, impmod, desc: Module; ch: CHAR; k: SHORTINT; i, j, offset, align, tdsize, tdadr: INTEGER; nofimps, nofentries, nofptrs, comsize, constsize, codesize, nofrecs: INTEGER; size, varsize, key, impkey, p, q, pb, eb: LONGINT; init: Command; F: Files.File; R: Files.Rider; impname, modname: ModuleName; import: ARRAY maximps OF Module; PROCEDURE err(n: INTEGER); BEGIN res := n; COPY(name, importing) END err; BEGIN res := 0; mod := SYSTEM.VAL(Module, Kernel.ModList); LOOP IF name = mod.name THEN EXIT END ; mod := mod.next; IF mod = NIL THEN EXIT END END ; IF mod = NIL THEN (*load*) OpenFile(F, name); IF F # NIL THEN Files.Set(R, F, 0); Files.Read(R, ch); (*header*) IF ch # ObjMark THEN err(2); RETURN NIL END ; Files.Read(R, ch); Files.ReadBytes(R, varsize, 4); (*skip*) Files.ReadBytes(R, nofimps, 2); Files.ReadBytes(R, nofentries, 2); Files.ReadBytes(R, nofptrs, 2); Files.ReadBytes(R, comsize, 2); Files.ReadBytes(R, constsize, 2); Files.ReadBytes(R, varsize, 4); Files.ReadBytes(R, codesize, 2); Files.ReadBytes(R, nofrecs, 2); Files.ReadBytes(R, key, 4); ReadName(R, modname); align := (-((nofentries + nofptrs)*2 + comsize)) MOD 4; (*imports*) res := 0; i := 0; WHILE (i < nofimps) & (res = 0) DO Files.ReadBytes(R, impkey, 4); ReadName(R, impname); impmod := ThisMod(impname); IF res = 0 THEN IF impmod.key = impkey THEN import[i] := impmod; INC(i); INC(impmod.refcnt) ELSE err(3); imported := impname END END END ; IF res # 0 THEN (*undo*) WHILE i > 0 DO DEC(i); DEC(import[i].refcnt) END ; RETURN NIL END ; size := headersize + (nofentries + nofptrs)*2 + nofimps*4 + comsize + varsize + codesize + constsize + align; Kernel.AllocBlock(p, size); mod := SYSTEM.VAL(Module, p); IF p = 0 THEN err(7); RETURN NIL END ; mod.size := size; mod.IB := p + headersize; mod.EB := mod.IB + nofimps*4; mod.RB := mod.EB + nofentries*2; mod.CB := mod.RB + nofptrs*2; mod.PB := mod.CB + comsize + align + constsize + varsize; mod.refcnt := 0; mod.key := key; COPY(modname, mod.name); p := mod.IB; i := 0; WHILE i < nofimps DO SYSTEM.PUT(p, import[i]); INC(p, 4); INC(i) END ; (*entries*) q := nofentries*2 + p; WHILE p < q DO Files.ReadBytes(R, i, 2); SYSTEM.PUT(p, i); INC(p, 2) END ; (*pointer references*) q := nofptrs*2 + p; WHILE p < q DO Files.ReadBytes(R, i, 2); SYSTEM.PUT(p, i); INC(p, 2) END ; (*commands*) q := p + comsize; WHILE p < q DO Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p) END ; p := p + align; (*constants*) q := p + constsize; WHILE p < q DO Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p) END ; (*variables*) q := p + varsize; WHILE p < q DO SYSTEM.PUT(p, 0); INC(p) END ; (*code*) q := p + codesize; WHILE p < q DO Files.Read(R, ch); SYSTEM.PUT(p, ch); INC(p) END ; (*link*) i := 0; WHILE i < nofimps DO pb := import[i].PB; eb := import[i].EB; Files.ReadBytes(R, offset, 2); p := offset; WHILE p # 0 DO (*abs chain*) INC(p, mod.PB); SYSTEM.GET(p, q); SYSTEM.GET((q DIV 100H) MOD 100H * 2 + eb, offset); SYSTEM.PUT(p, disp(pb + offset)); p := q DIV 10000H END ; Files.ReadBytes(R, offset, 2); p := offset; WHILE p # 0 DO (*pc-rel chain*) INC(p, mod.PB); SYSTEM.GET(p, q); SYSTEM.GET((q DIV 100H) MOD 100H * 2 + eb, offset); SYSTEM.PUT(p, disp((pb + offset) - (p - 1))); p := q DIV 10000H END ; INC(i) END ; (*type descriptors*) i := 0; WHILE i < nofrecs DO Files.ReadBytes(R, tdsize, 2); Files.ReadBytes(R, tdadr, 2); SYSTEM.NEW(desc, tdsize); SYSTEM.PUT(mod.PB + tdadr, desc); p := SYSTEM.VAL(LONGINT, desc); Files.ReadBytes(R, size, 4); SYSTEM.PUT(p, size); INC(p, 4); (*header*) Files.Read(R, k); j := 0; WHILE j < k DO (*base tags*) Files.Read(R, ch); Files.ReadBytes(R, q, 4); (*offset or eno*) IF ch = 0X THEN INC(q, mod.PB) ELSE SYSTEM.GET(import[ORD(ch)-1].EB + q*2, offset); q := import[ORD(ch)-1].PB + offset END ; SYSTEM.GET(q, q); SYSTEM.PUT(p, q); INC(p, 4); INC(j) END ; WHILE j < 7 DO q := 0; SYSTEM.PUT(p, q); INC(p, 4); INC(j) END ; Files.Read(R, k); j := 0; WHILE j < k DO (*offsets*) Files.ReadBytes(R, offset, 2); SYSTEM.PUT(p, offset); INC(p, 2); INC(j) END ; INC(i) END ; init := SYSTEM.VAL(Command, mod.PB); init; res := 0 ELSE COPY(name, imported); err(1) END END ; RETURN mod END ThisMod; PROCEDURE ThisCommand*(mod: Module; name: ARRAY OF CHAR): Command; VAR i: INTEGER; ch: CHAR; comadr: LONGINT; com: Command; BEGIN com := NIL; IF mod # NIL THEN comadr := mod.CB; res := 5; LOOP SYSTEM.GET(comadr, ch); INC(comadr); IF ch = 0X THEN (*not found*) EXIT END ; i := 0; LOOP IF ch # name[i] THEN EXIT END ; INC(i); IF ch = 0X THEN res := 0; EXIT END ; SYSTEM.GET(comadr, ch); INC(comadr) END ; IF res = 0 THEN (*match*) SYSTEM.GET(comadr, i); com := SYSTEM.VAL(Command, mod.PB + i); EXIT ELSE WHILE ch > 0X DO SYSTEM.GET(comadr, ch); INC(comadr) END ; INC(comadr, 2) END END END ; RETURN com END ThisCommand; PROCEDURE unload(mod: Module; all: BOOLEAN); VAR p: LONGINT; imp: Module; BEGIN p := mod.IB; WHILE p < mod.EB DO (*scan imports*) SYSTEM.GET(p, imp); IF imp # NIL THEN DEC(imp.refcnt); IF all & (imp.refcnt = 0) THEN unload(imp, all) END END ; INC(p, 4) END ; Kernel.FreeBlock(SYSTEM.VAL(LONGINT, mod)) END unload; PROCEDURE Free*(name: ARRAY OF CHAR; all: BOOLEAN); VAR mod: Module; BEGIN mod := SYSTEM.VAL(Module, Kernel.ModList); LOOP IF mod = NIL THEN res := 1; EXIT END ; IF name = mod.name THEN IF mod.refcnt = 0 THEN unload(mod, all); res := 0 ELSE res := 2 END ; EXIT END ; mod := mod.next END END Free; BEGIN IF Kernel.err = 0 THEN loop := ThisCommand(ThisMod("Oberon"), "Loop") END ; loop END Modules. -------------------------------------------------------------------------------- /Splines.Mod: -------------------------------------------------------------------------------- 1 | MODULE Splines; (*NW 3.11.90 / 1.2.92*) IMPORT Display, Files, Printer, Oberon, Graphics, GraphicFrames; CONST N = 20; TYPE Spline* = POINTER TO SplineDesc; SplineDesc* = RECORD (Graphics.ObjectDesc) n*: INTEGER; open*: BOOLEAN; u*, v*: ARRAY N OF INTEGER END ; RealVector = ARRAY N OF REAL; Poly = RECORD a, b, c, d, t: REAL END ; PolyVector = ARRAY N OF Poly; VAR method*: Graphics.Method; PROCEDURE mark(f: GraphicFrames.Frame; col, x0, y0: INTEGER; sp: Spline); VAR i, n, x, y: INTEGER; BEGIN i := 1; IF sp.open THEN n := sp.n ELSE n := sp.n-1 END ; WHILE i < n DO INC(i); Display.ReplConstC(f, col, sp.u[i] + x0, sp.v[i] + y0, 4, 4, 0) END END mark; PROCEDURE markOrg(f: GraphicFrames.Frame; col, x, y: INTEGER; sp: Spline); BEGIN INC(x, sp.u[0]); INC(y, sp.v[0]); Display.ReplConstC(f, col, x, y, 4, 4, 0) END markOrg; PROCEDURE ShowPoly(f: GraphicFrames.Frame; col: INTEGER; VAR p, q: Poly; lim: REAL); VAR t: REAL; x, y: LONGINT; BEGIN t := 0; REPEAT Display.DotC(f, col, SHORT(ENTIER(((p.a * t + p.b) * t + p.c) * t + p.d)), SHORT(ENTIER(((q.a * t + q.b) * t + q.c) * t + q.d)), 0); t := t + 1.0 UNTIL t >= lim END ShowPoly; PROCEDURE SolveTriDiag(VAR a, b, c, y: RealVector; n: INTEGER); VAR i: INTEGER; BEGIN (*a, b, c of tri-diag matrix T; solve Ty' = y for y', assign y' to y*) i := 1; WHILE i < n DO y[i] := y[i] - c[i-1]*y[i-1]; INC(i) END ; i := n-1; y[i] := y[i]/a[i]; WHILE i > 0 DO DEC(i); y[i] := (y[i] - b[i]*y[i+1])/a[i] END END SolveTriDiag; PROCEDURE OpenSpline(VAR x, y, d: RealVector; n: INTEGER); VAR i: INTEGER; d1, d2: REAL; a, b, c: RealVector; BEGIN (*from x, y compute d = y'*) b[0] := 1.0/(x[1] - x[0]); a[0] := 2.0*b[0]; c[0] := b[0]; d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := d1; i := 1; WHILE i < n-1 DO b[i] := 1.0/(x[i+1] - x[i]); a[i] := 2.0*(c[i-1] + b[i]); c[i] := b[i]; d2 := (y[i+1] - y[i])*3.0*b[i]*b[i]; d[i] := d1 + d2; d1 := d2; INC(i) END ; a[i] := 2.0*b[i-1]; d[i] := d1; i := 0; WHILE i < n-1 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ; SolveTriDiag(a, b, c, d, n) END OpenSpline; PROCEDURE ClosedSpline(VAR x, y, d: RealVector; n: INTEGER); VAR i: INTEGER; d1, d2, hn, dn: REAL; a, b, c, w: RealVector; BEGIN (*from x, y compute d = y'*) hn := 1.0/(x[n-1] - x[n-2]); dn := (y[n-1] - y[n-2])*3.0*hn*hn; b[0] := 1.0/(x[1] - x[0]); a[0] := 2.0*b[0] + hn; c[0] := b[0]; d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := dn + d1; w[0] := 1.0; i := 1; WHILE i < n-2 DO b[i] := 1.0/(x[i+1] - x[i]); a[i] := 2.0*(c[i-1] + b[i]); c[i] := b[i]; d2 := (y[i+1] - y[i])*3.0*b[i]*b[i]; d[i] := d1 + d2; d1 := d2; w[i] := 0; INC(i) END ; a[i] := 2.0*b[i-1] + hn; d[i] := d1 + dn; w[i] := 1.0; i := 0; WHILE i < n-2 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ; SolveTriDiag(a, b, c, d, n-1); SolveTriDiag(a, b, c, w, n-1); d1 := (d[0] + d[i])/(w[0] + w[i] + x[i+1] - x[i]); i := 0; WHILE i < n-1 DO d[i] := d[i] - d1*w[i]; INC(i) END ; d[i] := d[0] END ClosedSpline; PROCEDURE CompSpline(f: GraphicFrames.Frame; col, x0, y0: INTEGER; sp: Spline); VAR i, n: INTEGER; dx, dy, ds: REAL; x, xd, y, yd, s: RealVector; p, q: PolyVector; BEGIN (*from u, v compute x, y, s*) x[0] := sp.u[0] + x0; y[0] := sp.v[0] + y0; s[0] := 0; n := sp.n; i := 1; WHILE i < n DO x[i] := sp.u[i] + x0; dx := x[i] - x[i-1]; y[i] := sp.v[i] + y0; dy := y[i] - y[i-1]; s[i] := ABS(dx) + ABS(dy) + s[i-1]; INC(i) END ; IF sp.open THEN OpenSpline(s, x, xd, n); OpenSpline(s, y, yd, n) ELSE ClosedSpline(s, x, xd, n); ClosedSpline(s, y, yd, n) END ; (*compute coefficients from x, y, xd, yd, s*) i := 0; WHILE i < n-1 DO ds := 1.0/(s[i+1] - s[i]); dx := (x[i+1] - x[i])*ds; p[i].a := ds*ds*(xd[i] + xd[i+1] - 2.0*dx); p[i].b := ds*(3.0*dx - 2.0*xd[i] -xd[i+1]); p[i].c := xd[i]; p[i].d := x[i]; p[i].t := s[i]; dy := ds*(y[i+1] - y[i]); q[i].a := ds*ds*(yd[i] + yd[i+1] - 2.0*dy); q[i].b := ds*(3.0*dy - 2.0*yd[i] - yd[i+1]); q[i].c := yd[i]; q[i].d := y[i]; q[i].t := s[i]; INC(i) END ; p[i].t := s[i]; q[i].t := s[i]; (*display polynomials*) i := 0; WHILE i < n-1 DO ShowPoly(f, col, p[i], q[i], p[i+1].t - p[i].t); INC(i) END END CompSpline; PROCEDURE New*; VAR sp: Spline; BEGIN NEW(sp); sp.do := method; Graphics.new := sp END New; PROCEDURE Copy(src, dst: Graphics.Object); BEGIN dst(Spline)^ := src(Spline)^ END Copy; PROCEDURE Draw(obj: Graphics.Object; VAR M: Graphics.Msg); VAR x, y, w, h, col: INTEGER; f: GraphicFrames.Frame; BEGIN WITH M: GraphicFrames.DrawMsg DO x := obj.x + M.x; y := obj.y + M.y; w := obj.w; h := obj.h; f := M.f; IF (x < f.X1) & (f.X <= x+w) & (y < f.Y1) & (f.Y <= y+h) THEN IF M.col = Display.black THEN col := obj.col ELSE col := M.col END ; WITH obj: Spline DO IF M.mode = 0 THEN IF obj.selected THEN mark(f, Display.white, x, y, obj) END ; CompSpline(f, col, x, y, obj); markOrg(f, Display.white, x, y, obj) ELSIF M.mode = 1 THEN mark(f, Display.white, x, y, obj) ELSIF M.mode = 2 THEN mark(f, f.col, x, y, obj); markOrg(f, Display.white, x, y, obj) ELSE mark(f, f.col, x, y, obj); CompSpline(f, f.col, x, y, obj); markOrg(f, f.col, x, y, obj) END END END END END Draw; PROCEDURE Selectable(obj: Graphics.Object; x, y: INTEGER): BOOLEAN; VAR x0, y0: INTEGER; BEGIN x0 := obj.x + obj(Spline).u[0]; y0 := obj.y + obj(Spline).v[0]; RETURN (x0 - 4 <= x) & (x <= x0 + 4) & (y0 - 4 <= y) & (y <= y0 + 4) END Selectable; PROCEDURE Handle(obj: Graphics.Object; VAR M: Graphics.Msg); BEGIN IF M IS Graphics.ColorMsg THEN obj.col := M(Graphics.ColorMsg).col END END Handle; PROCEDURE Read(obj: Graphics.Object; VAR R: Files.Rider; VAR C: Graphics.Context); VAR i, j, len: INTEGER; s: SHORTINT; BEGIN i := 0; j := 0; Files.ReadInt(R, len); WITH obj: Spline DO obj.n := (len-1) DIV 4; Files.Read(R, s); obj.open := s=1; WHILE i < obj.n DO Files.ReadInt(R, obj.u[i]); INC(i) END; WHILE j < obj.n DO Files.ReadInt(R, obj.v[j]); INC(j) END END END Read; PROCEDURE Write(obj: Graphics.Object; cno: SHORTINT; VAR W: Files.Rider; VAR C: Graphics.Context); VAR i, j: INTEGER; BEGIN i := 0; j := 0; WITH obj: Spline DO Graphics.WriteObj(W, cno, obj); Files.WriteInt(W, obj.n * 4 + 1); IF obj.open THEN Files.Write(W, 1) ELSE Files.Write(W, 0) END ; WHILE i < obj.n DO Files.WriteInt(W, obj.u[i]); INC(i) END; WHILE j < obj.n DO Files.WriteInt(W, obj.v[j]); INC(j) END END END Write; PROCEDURE Print(obj: Graphics.Object; x, y: INTEGER); VAR i, j, n, open: INTEGER; u, v: ARRAY N OF INTEGER; BEGIN WITH obj: Spline DO IF obj.open THEN open := 1 ELSE open := 0 END ; n := obj.n; i := 0; WHILE i < n DO u[i] := obj.u[i]*4; v[i] := obj.v[i]*4; INC(i) END ; Printer.Spline(obj.x*4 + x, obj.y*4 + y, n, open, u, v) END END Print; PROCEDURE MakeSpline(open: BOOLEAN); VAR x0, x1, x2, y0, y1, y2, i, n: INTEGER; spl: Spline; G: GraphicFrames.Frame; L: GraphicFrames.Location; BEGIN G := GraphicFrames.Focus(); IF (G # NIL) & (G.mark.next # NIL) THEN GraphicFrames.Deselect(G); NEW(spl); x0 := G.mark.x; y0 := G.mark.y; x1 := x0; y1 := y0; spl.u[0] := x0; spl.v[0] := y0; L := G.mark.next; i := 0; n := 1; WHILE (L # NIL) & (n < N-1) DO x2 := L.x; spl.u[n] := x2; y2 := L.y; spl.v[n] := y2; IF x2 < x0 THEN x0 := x2 END ; IF x1 < x2 THEN x1 := x2 END ; IF y2 < y0 THEN y0 := y2 END ; IF y1 < y2 THEN y1 := y2 END ; INC(n); L := L.next END ; WHILE i < n DO DEC(spl.u[i], x0); DEC(spl.v[i], y0); INC(i) END ; IF ~open THEN spl.u[n] := spl.u[0]; spl.v[n] := spl.v[0]; INC(n) END ; spl.x := x0 - G.x; spl.y := y0 - G.y; spl.w := x1 - x0 + 1; spl.h := y1 - y0 + 1; spl.open := open; spl.n := n; spl.col := Oberon.CurCol; spl.do := method; Graphics.Add(G.graph, spl); GraphicFrames.Defocus(G); GraphicFrames.DrawObj(G, spl) END END MakeSpline; PROCEDURE MakeOpen*; BEGIN MakeSpline(TRUE) END MakeOpen; PROCEDURE MakeClosed*; BEGIN MakeSpline(FALSE) END MakeClosed; BEGIN NEW(method); method.module := "Splines"; method.allocator := "New"; method.new := New; method.copy := Copy; method.draw := Draw; method.selectable := Selectable; method.handle := Handle; method.read := Read; method.write := Write; method.print := Print END Splines. -------------------------------------------------------------------------------- /GraphicElems.Mod: -------------------------------------------------------------------------------- 1 | MODULE GraphicElems; (** CAS **) (*mod NW 19.3.91/ HM 27.9.93*) IMPORT Input, Display, Files, Oberon, Viewers, MenuViewers, Texts, TextFrames, Graphics, GraphicFrames, TextPrinter; CONST Menu = "System.Close System.Copy System.Grow Draw.Delete GraphicElems.Update "; mm = TextFrames.mm; Scale = mm DIV 10; unit = TextFrames.Unit; Unit = TextPrinter.Unit; MinW = 3*mm; MinH = MinW; GripW = 15*Scale DIV unit; GripH = GripW; rightKey = 0; middleKey = 1; leftKey = 2; TYPE Elem* = POINTER TO ElemDesc; ElemDesc* = RECORD(Texts.ElemDesc) SW*, SH*, PW*, PH*: LONGINT; (**screen, printer box**) graph*: Graphics.Graph; Xg*, Yg*: INTEGER; empty*: BOOLEAN END; Frame = POINTER TO FrameDesc; FrameDesc = RECORD (GraphicFrames.FrameDesc) elem: Elem END; VAR x0, x1, y0, y1: INTEGER; W: Texts.Writer; PROCEDURE MarkMenu (F: Frame); VAR R: Texts.Reader; V: Viewers.Viewer; T: Texts.Text; ch: CHAR; BEGIN V := Viewers.This(F.X, F.Y); IF V IS MenuViewers.Viewer THEN T := V.dsc(TextFrames.Frame).text; IF T.len > 0 THEN Texts.OpenReader(R, T, T.len - 1); Texts.Read(R, ch) ELSE ch := 0X END; IF ch # "!" THEN Texts.Write(W, "!"); Texts.Append(T, W.buf) END END END MarkMenu; PROCEDURE Changed (E: Elem); VAR T: Texts.Text; pos: LONGINT; BEGIN T := Texts.ElemBase(E); pos := Texts.ElemPos(E); T.notify(T, Texts.replace, pos-1, pos) END Changed; PROCEDURE FlipGrip (x0, y0, w, h: INTEGER); BEGIN Display.ReplConst(Display.white, x0 + w - GripW, y0, GripW, GripH, Display.invert) END FlipGrip; (* operations on elements *) PROCEDURE SetSize* (E: Elem; w, h: LONGINT); BEGIN IF w < MinW THEN w := MinW END; IF h < MinH THEN h := MinH END; E.W := w; E.H := h; E.SW := w; E.SH := h; E.PW := 4 * (w DIV unit) * Unit; E.PH := 4 * (h DIV unit) * Unit END SetSize; PROCEDURE box(obj: Graphics.Object; VAR done: BOOLEAN); BEGIN IF obj.x < x0 THEN x0 := obj.x END ; IF x1 < obj.x + obj.w THEN x1 := obj.x + obj.w END ; IF obj.y < y0 THEN y0 := obj.y END ; IF y1 < obj.y + obj.h THEN y1 := obj.y + obj.h END END box; PROCEDURE Open* (E: Elem; G: Graphics.Graph; Xg, Yg: INTEGER; adjust: BOOLEAN); BEGIN E.graph := G; x0 := MAX(INTEGER); x1 := MIN(INTEGER); y0 := MAX(INTEGER); y1 := MIN(INTEGER); Graphics.Enumerate(G, box); IF x0 = MAX(INTEGER) THEN E.empty := TRUE; E.Xg := 0; E.Yg := 0; SetSize(E, 0, 0) ELSE E.empty := FALSE; IF adjust THEN E.Xg := -x0; E.Yg := -y1; SetSize(E, LONG(x1-x0) * unit, LONG(y1-y0) * unit) ELSE E.Xg := Xg; E.Yg := Yg; SetSize(E, E.W, E.H) END END END Open; PROCEDURE CopyGraph (G: Graphics.Graph): Graphics.Graph; VAR g: Graphics.Graph; BEGIN Graphics.SelectArea(G, MIN(INTEGER), MIN(INTEGER), MAX(INTEGER), MAX(INTEGER)); NEW(g); Graphics.Copy(G, g, 0, 0); Graphics.Deselect(g); RETURN g END CopyGraph; PROCEDURE Copy* (SE, DE: Elem); BEGIN SE.W := SE.SW; SE.H := SE.SH; Texts.CopyElem(SE, DE); Open(DE, CopyGraph(SE.graph), SE.Xg, SE.Yg, FALSE) END Copy; PROCEDURE HandleFrame (f: Display.Frame; VAR msg: Display.FrameMsg); VAR F: Frame; F1: Frame; BEGIN F := f(Frame); (*IF msg IS GraphicFrames.UpdateMsg THEN use when UpdateMsg gets exported*) IF msg IS Oberon.InputMsg THEN GraphicFrames.Handle(F, msg); WITH msg: Oberon.InputMsg DO IF (msg.id = Oberon.consume) OR (msg.id = Oberon.track) & (msg.keys # {}) THEN MarkMenu(F) END END ELSIF msg IS Oberon.CopyMsg THEN NEW(F1); GraphicFrames.Open(F1, F.graph, F.Xg, F.Yg, F.col, F.ticked); F1.handle := F.handle; F1.elem := F.elem; msg(Oberon.CopyMsg).F := F1 ELSE GraphicFrames.Handle(F, msg) END END HandleFrame; PROCEDURE OpenViewer* (E: Elem); VAR v: Viewers.Viewer; f: Frame; x, y: INTEGER; BEGIN NEW(f); GraphicFrames.Open(f, CopyGraph(E.graph), 0, 0, Display.black, TRUE); f.elem := E; f.handle := HandleFrame; Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y); v := MenuViewers.New(TextFrames.NewMenu("GraphicElems.Graph", Menu), f, TextFrames.menuH, x, y) END OpenViewer; PROCEDURE Track (E: Elem; keys: SET; x, y, x0, y0: INTEGER); VAR keysum: SET; x1, y1, w, h: INTEGER; hit: BOOLEAN; BEGIN IF middleKey IN keys THEN x1 := x - x0; y1 := y - y0; keysum := keys; w := SHORT(E.W DIV unit); h := SHORT(E.H DIV unit); hit := ~E.empty & (x1 >= w-GripW) & (0 <= y1) & (y1 < GripH); IF hit THEN FlipGrip(x0, y0, w, h) END; REPEAT Input.Mouse(keys, x, y); Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, x, y); keysum := keysum + keys UNTIL keys = {}; IF hit THEN FlipGrip(x0, y0, w, h) END; IF keysum = {middleKey} THEN IF hit THEN INC(w, (x - x0) - x1); DEC(h, (y - y0) - y1); SetSize(E, LONG(w) * unit, LONG(h) * unit); Changed(E) ELSE OpenViewer(E) END END END END Track; (* handle elements *) PROCEDURE Handle* (e: Texts.Elem; VAR msg: Texts.ElemMsg); VAR E, E1: Elem; x, y, w, h: INTEGER; f: GraphicFrames.Frame; g: Graphics.Graph; version: CHAR; BEGIN E := e(Elem); IF msg IS TextFrames.DisplayMsg THEN WITH msg: TextFrames.DisplayMsg DO IF msg.prepare THEN E.W := E.SW; E.H := E.SH ELSE x := msg.X0; y := msg.Y0; w := SHORT(E.W DIV unit); h := SHORT(E.H DIV unit); IF E.empty THEN Display.ReplPattern(Display.white, Display.grey1, x, y, w, h, Display.replace) ELSE NEW(f); GraphicFrames.Open(f, E.graph, E.Xg, E.Yg, Display.black, FALSE); f.X := x; f.Y := y; f.W := w; f.H := h; GraphicFrames.Restore(f); FlipGrip(x, y, w, h); msg.elemFrame := f END END END ELSIF msg IS TextPrinter.PrintMsg THEN WITH msg: TextPrinter.PrintMsg DO IF msg.prepare THEN E.W := E.PW; E.H := E.PH ELSE Graphics.Print(E.graph, E.Xg*4 + msg.X0, E.Yg*4 + msg.Y0 + SHORT(E.PH DIV Unit)); E.W := E.SW; E.H := E.SH END END ELSIF msg IS Texts.IdentifyMsg THEN WITH msg: Texts.IdentifyMsg DO msg.mod := "GraphicElems"; msg.proc := "Alloc" END ELSIF msg IS Texts.FileMsg THEN WITH msg: Texts.FileMsg DO IF msg.id = Texts.load THEN Files.Read(msg.r, version); NEW(g); Graphics.Load(g, msg.r); IF version = 1X THEN Open(E, g, 0, 0, TRUE) ELSE Files.ReadInt(msg.r, E.Xg); Files.ReadInt(msg.r, E.Yg); Open(E, g, E.Xg, E.Yg, FALSE) END ELSIF msg.id = Texts.store THEN E.W := E.SW; E.H := E.SH; Files.Write(msg.r, 2X); Graphics.Store(E.graph, msg.r); Files.WriteInt(msg.r, E.Xg); Files.WriteInt(msg.r, E.Yg) END END ELSIF msg IS Texts.CopyMsg THEN NEW(E1); Copy(E, E1); msg(Texts.CopyMsg).e := E1 ELSIF msg IS TextFrames.TrackMsg THEN WITH msg: TextFrames.TrackMsg DO Track(E, msg.keys, msg.X, msg.Y, msg.X0, msg.Y0) END ELSIF msg IS TextFrames.FocusMsg THEN WITH msg: TextFrames.FocusMsg DO f := msg.elemFrame(GraphicFrames.Frame); f.ticked := msg.focus; GraphicFrames.Restore(f); IF ~msg.focus THEN FlipGrip(f.X, f.Y, f.W, f.H) END END END END Handle; PROCEDURE Alloc*; VAR e: Elem; BEGIN NEW(e); e.handle := Handle; Texts.new := e END Alloc; (* commands *) PROCEDURE Insert*; (** ["^" | "*" | name] **) VAR S: Texts.Scanner; text: Texts.Text; beg, end, time: LONGINT; V: Viewers.Viewer; G, g: Graphics.Graph; e: Elem; msg: TextFrames.InsertElemMsg; 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, time); IF time >= 0 THEN Texts.OpenScanner(S, text, beg); Texts.Scan(S) END END; NEW(g); IF (S.class = Texts.Char) & (S.c = "*") THEN V := Oberon.MarkedViewer(); IF (V.dsc # NIL) & (V.dsc.next # NIL) & (V.dsc.next IS GraphicFrames.Frame) THEN G := V.dsc.next(GraphicFrames.Frame).graph; IF G.sel = NIL THEN g := CopyGraph(G) ELSE Graphics.Copy(G, g, 0, 0) END END ELSIF S.class = Texts.Name THEN Graphics.Open(g, S.s) END; NEW(e); e.handle := Handle; Open(e, g, 0, 0, TRUE); msg.e := e; Oberon.FocusViewer.handle(Oberon.FocusViewer, msg) END Insert; PROCEDURE Update*; VAR V: Viewers.Viewer; F: Frame; R: Texts.Reader; T: Texts.Text; ch: CHAR; BEGIN V := Oberon.Par.vwr; F := V.dsc.next(Frame); T := V.dsc(TextFrames.Frame).text; GraphicFrames.Deselect(F); Open(F.elem, CopyGraph(F.graph), 0, 0, TRUE); Changed(F.elem); Texts.OpenReader(R, T, T.len - 1); Texts.Read(R, ch); IF ch = "!" THEN Texts.Delete(T, T.len - 1, T.len) END END Update; BEGIN Texts.OpenWriter(W) END GraphicElems. -------------------------------------------------------------------------------- /MenuElems.Mod: -------------------------------------------------------------------------------- 1 | MODULE MenuElems; (*NW 4.7.93 / HM 8.12.93*) IMPORT Display, Viewers, Input, Fonts, Files, Texts, TextFrames, MenuViewers, Oberon; CONST left = 2; middle = 1; right = 0; (*mouse keys*) YBottom = -223; TYPE Menu = POINTER TO MenuDesc; MenuDesc = RECORD (Texts.ElemDesc) text: Texts.Text; nofcom, lastcom, mpos, mw, mh, lsp, dsc: INTEGER END ; EditFrame = POINTER TO EditFrameDesc; EditFrameDesc = RECORD (TextFrames.FrameDesc) menu: Menu END ; VAR buf: Texts.Buffer; (*copy buffer*) PROCEDURE WriteTitle(M: Menu; x, y: INTEGER); VAR dx, x1, y1, w, h: INTEGER; ch: CHAR; pat: Display.Pattern; R: Texts.Reader; BEGIN Texts.OpenReader(R, M.text, 0); Texts.Read(R, ch); IF R.eot THEN ch := Texts.ElemChar; R.fnt := Fonts.Default END; DEC(y, R.fnt.minY); REPEAT Display.GetChar(R.fnt.raster, ch, dx, x1, y1, w, h, pat); Display.CopyPattern(R.col, pat, x + x1, y + y1, Display.invert); INC(x, dx); Texts.Read(R, ch) UNTIL R.eot OR (ch <= " ") END WriteTitle; PROCEDURE DrawMenu(M: Menu; col, x, y, w, h: INTEGER); VAR x0, x1, y1, dx: INTEGER; ch: CHAR; pat: Display.Pattern; R: Texts.Reader; BEGIN Display.ReplConst(Display.black, x, y, w, h, 0); Display.ReplConst(col, x, y, w, 1, 0); Display.ReplConst(col, x+w-1, y, 1, h, 0); Display.ReplConst(col, x, y+h-1, w, 1, 0); Display.ReplConst(col, x, y, 1, h, 0); Texts.OpenReader(R, M.text, M.mpos); Texts.Read(R, ch); x0 := x + 4; x := x0; y := y + h - M.lsp - M.dsc - 4; WHILE ~R.eot DO IF ch = 0DX THEN DEC(y, M.lsp); x := x0 ELSE Display.GetChar(R.fnt.raster, ch, dx, x1, y1, w, h, pat); Display.CopyPattern(R.col, pat, x+x1, y+y1, 0); INC(x, dx) END ; Texts.Read(R, ch) END END DrawMenu; PROCEDURE HandleEdit(F: Display.Frame; VAR M: Display.FrameMsg); VAR F1: EditFrame; BEGIN TextFrames.Handle(F, M); WITH F: EditFrame DO IF M IS Oberon.CopyMsg THEN NEW(F1); TextFrames.Open(F1, F.text, F.org); F1.handle := F.handle; F1.menu := F.menu; M(Oberon.CopyMsg).F := F1 END END END HandleEdit; PROCEDURE Edit(M: Menu); VAR V: Viewers.Viewer; F: EditFrame; T: Texts.Text; x, y: INTEGER; BEGIN T := TextFrames.Text(""); Texts.Save(M.text, 0, M.text.len, buf); Texts.Append(T, buf); Oberon.AllocateUserViewer(Oberon.Par.vwr.X, x, y); NEW(F); F.menu := M; TextFrames.Open(F, T, 0); F.handle := HandleEdit; V := MenuViewers.New(TextFrames.NewMenu("Menu", "System.Close MenuElems.Update "), F, TextFrames.menuH, x, y) END Edit; PROCEDURE TrackMenu(M: Menu; x, y: INTEGER; VAR cmd: INTEGER; VAR edit: BOOLEAN); VAR mx, my, xbar, wbar, lsp, top, com, old, dy, i: INTEGER; keys: SET; cancel: BOOLEAN; BEGIN lsp := M.lsp; xbar := x + 4; wbar := M.mw - 8; top := y + M.mh - 4; my := y + M.mh - (M.lastcom+1) * lsp; Input.Mouse(keys, mx, i); dy := my - i; keys := {middle}; cancel := FALSE; edit := FALSE; old := -1; LOOP IF (x < mx) & (mx < x + M.mw) & (y + 4 < my) & (my < top) THEN com := (top - my) DIV lsp; Oberon.FadeCursor(Oberon.Mouse) ELSE com := -1; Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, mx, my) END; IF com # old THEN IF old >= 0 THEN Display.ReplConst(Display.white, xbar, top-(old+1)*lsp, wbar, lsp, Display.invert) END; IF com >= 0 THEN Display.ReplConst(Display.white, xbar, top-(com+1)*lsp, wbar, lsp, Display.invert) END; old := com END; IF keys = {} THEN EXIT ELSIF keys = {left, middle, right} THEN cancel := TRUE ELSIF left IN keys THEN edit := TRUE END; Input.Mouse(keys, mx, my); my := (my + dy) MOD Display.Height END; IF cancel THEN com := -1; edit := FALSE END; Oberon.FadeCursor(Oberon.Mouse); cmd := com END TrackMenu; PROCEDURE Popup(M: Menu; col, x, y: INTEGER); VAR i, j, cmd, res: INTEGER; ch: CHAR; keys: SET; cmdStr: ARRAY 32 OF CHAR; R: Texts.Reader; edit: BOOLEAN; v: Viewers.Viewer; BEGIN cmd := M.lastcom; v := Viewers.This(x, y); IF x + M.mw > v.X + v.W THEN x := v.X + v.W - M.mw END ; IF y + M.mh > v.Y + v.H THEN y := v.Y + v.H - M.mh END ; Oberon.RemoveMarks(x, y, M.mw, M.mh); Oberon.FadeCursor(Oberon.Mouse); Display.CopyBlock(x, y, M.mw, M.mh, x, YBottom, 0); (*save*) DrawMenu(M, col, x, y, M.mw, M.mh); TrackMenu(M, x, y, cmd, edit); Display.CopyBlock(x, YBottom, M.mw, M.mh, x, y, 0); (*restore*) IF edit THEN Edit(M) ELSIF cmd >= 0 THEN M.lastcom := cmd; j := 0; Texts.OpenReader(R, M.text, M.mpos); Texts.Read(R, ch); WHILE j < cmd DO IF ch = 0DX THEN INC(j) END ; Texts.Read(R, ch) END; i := 0; WHILE (ch > " ") & (i < 31) DO cmdStr[i] := ch; INC(i); Texts.Read(R, ch) END; cmdStr[i] := 0X; Oberon.Par.vwr := v; Oberon.Par.frame := v.dsc; Oberon.Par.text := M.text; Oberon.Par.pos := Texts.Pos(R); Oberon.Call(cmdStr, Oberon.Par, FALSE, res) END END Popup; PROCEDURE Load(VAR R: Files.Rider; M: Menu); VAR n: LONGINT; BEGIN Files.ReadNum(R, n); M.nofcom := SHORT(n); M.lastcom := 0; Files.ReadNum(R, n); M.mpos := SHORT(n); Files.ReadNum(R, n); M.mw := SHORT(n); Files.ReadNum(R, n); M.mh := SHORT(n); Files.ReadNum(R, n); M.lsp := SHORT(n); Files.ReadNum(R, n); M.dsc := SHORT(n); M.text := TextFrames.Text(""); Texts.Load(R, M.text) END Load; PROCEDURE Store(VAR R: Files.Rider; M: Menu); BEGIN Files.WriteNum(R, M.nofcom); Files.WriteNum(R, M.mpos); Files.WriteNum(R, M.mw); Files.WriteNum(R, M.mh); Files.WriteNum(R, M.lsp); Files.WriteNum(R, M.dsc); Texts.Store(R, M.text) END Store; PROCEDURE Handle(E: Texts.Elem; VAR msg: Texts.ElemMsg); VAR M: Menu; BEGIN WITH E: Menu DO IF msg IS TextFrames.DisplayMsg THEN WITH msg: TextFrames.DisplayMsg DO IF ~msg.prepare THEN WriteTitle(E, msg.X0, msg.Y0) END END ELSIF msg IS Texts.CopyMsg THEN WITH msg: Texts.CopyMsg DO NEW(M); Texts.CopyElem(E, M); M.nofcom := E.nofcom; M.lastcom := E.lastcom; M.mpos := E.mpos; M.mw := E.mw; M.mh := E.mh; M.lsp := E.lsp; M.dsc := E.dsc; M.text := TextFrames.Text(""); Texts.Save(E.text, 0, E.text.len, buf); Texts.Append(M.text, buf); msg.e := M END ELSIF msg IS Texts.IdentifyMsg THEN WITH msg: Texts.IdentifyMsg DO msg.mod := "MenuElems"; msg.proc := "Alloc" END ELSIF msg IS Texts.FileMsg THEN WITH msg: Texts.FileMsg DO IF msg.id = Texts.load THEN Load(msg.r, E) ELSIF msg.id = Texts.store THEN Store(msg.r, E) END END ELSIF msg IS TextFrames.TrackMsg THEN WITH msg: TextFrames.TrackMsg DO IF msg.keys = {middle} THEN Popup(E, msg.col, msg.X0, msg.Y0) END END END END END Handle; PROCEDURE Alloc*; VAR M: Menu; BEGIN NEW(M); M.handle := Handle; Texts.new := M END Alloc; PROCEDURE Update*; VAR M: Menu; pos: LONGINT; len, dx, x1, y1, w, w1, h, h1: INTEGER; ch: CHAR; pat: Display.Pattern; F: EditFrame; T: Texts.Text; R: Texts.Reader; BEGIN IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN F := Oberon.Par.frame.next(EditFrame); M := F.menu; T := F.text; Texts.OpenReader(R, T, 0); len := 1; w := 0; h := 0; Texts.Read(R, ch); WHILE ~R.eot & (ch > " ") DO Display.GetChar(R.fnt.raster, ch, dx, x1, y1, w1, h1, pat); INC(w, dx); INC(len); IF h < R.fnt.height THEN h := R.fnt.height END ; Texts.Read(R, ch) END ; Texts.Read(R, ch); M.W := LONG(w)*Display.Unit; M.H := LONG(h)*Display.Unit; M.mpos := len; M.nofcom := 0; M.lastcom := 0; M.mw := 0; M.lsp := 0; M.dsc := 0; w := 0; WHILE ~R.eot DO IF ch = 0DX THEN IF M.mw < w THEN M.mw := w END ; w := 0; INC(M.nofcom) ELSE IF M.lsp < R.fnt.height THEN M.lsp := R.fnt.height END ; IF M.dsc > R.fnt.minY THEN M.dsc := R.fnt.minY END ; Display.GetChar(R.fnt.raster, ch, dx, x1, y1, w1, h1, pat); INC(w, dx) END ; Texts.Read(R, ch) END ; IF w > 0 THEN INC(M.nofcom); IF M.mw < w THEN M.mw := w END END ; M.mh := M.lsp * M.nofcom + 8; INC(M.mw, 8); M.text := T; T := Texts.ElemBase(M); pos := Texts.ElemPos(M); T.notify(T, Texts.replace, pos, pos+1); T := Oberon.Par.frame(TextFrames.Frame).text; Texts.OpenReader(R, T, T.len - 1); Texts.Read(R, ch); IF ch = "!" THEN Texts.Delete(T, T.len - 1, T.len) END END END Update; PROCEDURE Insert*; VAR M: Menu; insert: TextFrames.InsertElemMsg; BEGIN NEW(M); M.W := 8*Display.Unit; M.H := M.W; M.lsp := 8; M.mw := 8; M.mh := 8; M.text := TextFrames.Text(""); M.handle := Handle; insert.e := M; Viewers.Broadcast(insert) END Insert; BEGIN NEW(buf); Texts.OpenBuf(buf) END MenuElems. -------------------------------------------------------------------------------- /OBS.Mod: -------------------------------------------------------------------------------- 1 | MODULE OBS; (*NW 7.6.87 / 18.3.93*) IMPORT Reals, Texts, Oberon; (*symbols: | 0 1 2 3 4 ---|-------------------------------------------------------- 0 | null * / DIV MOD 5 | & + - OR = 10 | # < <= > >= 15 | IN IS ^ . , 20 | : .. ) ] } 25 | OF THEN DO TO ( 30 | [ { ~ := number 35 | NIL string ident ; | 40 | END ELSE ELSIF UNTIL IF 45 | CASE WHILE REPEAT LOOP WITH 50 | EXIT RETURN FOR BY ARRAY 55 | RECORD POINTER BEGIN CONST TYPE 60 | VAR PROCEDURE IMPORT MODULE eof *) CONST KW = 47; (*size of hash table*) maxDig = 32; maxExp = 308; maxStrLen = 128; (*name, numtyp, intval, realval, lrlval are implicit results of Get*) VAR numtyp* : INTEGER; (* 1 = char, 2 = integer, 3 = real, 4 = longreal*) intval* : LONGINT; realval*: REAL; lrlval* : LONGREAL; scanerr*: BOOLEAN; name* : ARRAY maxStrLen OF CHAR; R: Texts.Reader; W: Texts.Writer; ch, prev: CHAR; (*current and previous characters*) lastpos: LONGINT; (*error position in source file*) i: INTEGER; keyTab : ARRAY KW OF RECORD symb, alt: INTEGER; id: ARRAY 12 OF CHAR END; PROCEDURE Mark*(n: INTEGER); VAR pos: LONGINT; BEGIN pos := Texts.Pos(R); IF lastpos + 8 < pos THEN Texts.WriteLn(W); Texts.WriteString(W, " pos"); Texts.WriteInt(W, pos, 6); IF n < 0 THEN Texts.WriteString(W, " warning") ELSE Texts.WriteString(W, " err"); scanerr := TRUE; lastpos := pos END ; Texts.WriteInt(W, ABS(n), 4); Texts.Append(Oberon.Log, W.buf) END END Mark; PROCEDURE String(VAR sym: INTEGER); VAR i: INTEGER; BEGIN i := 0; LOOP IF ch = 22X THEN EXIT END ; IF ch < " " THEN Mark(3); EXIT END ; IF i < maxStrLen-1 THEN name[i] := ch; INC(i) ELSE Mark(212); i := 0 END ; Texts.Read(R, ch) END ; Texts.Read(R, ch); IF i = 1 THEN sym := 34; numtyp := 1; intval := ORD(name[0]) ELSE sym := 36; name[i] := 0X (*string*) END END String; PROCEDURE Identifier(VAR sym: INTEGER); VAR i, k: INTEGER; BEGIN name[0] := prev; i := 1; k := ORD(prev); WHILE (CAP(ch) >= "A") & (CAP(ch) <= "Z") OR (ch >= "0") & (ch <= "9") DO IF i < 31 THEN name[i] := ch; INC(i); INC(k, ORD(ch)) END ; Texts.Read(R, ch) END ; name[i] := 0X; k := (k+i) MOD KW; (*hash function*) IF (keyTab[k].symb # 0) & (keyTab[k].id = name) THEN sym := keyTab[k].symb ELSE k := keyTab[k].alt; IF (keyTab[k].symb # 0) & (keyTab[k].id = name) THEN sym := keyTab[k].symb ELSE sym := 37 (*ident*) END END END Identifier; PROCEDURE Number; VAR i, j, c, e, s: INTEGER; k: LONGINT; x: LONGREAL; lastCh, expch: CHAR; negE, hex: BOOLEAN; d: ARRAY maxDig OF INTEGER; BEGIN c := ORD(prev) - 30H; hex := FALSE; i := 0; LOOP d[i] := c; INC(i); IF ch < "0" THEN EXIT END ; IF ch <= "9" THEN c := ORD(ch) - 30H ELSIF ("A" <= ch) & (ch <= "F") THEN c := ORD(ch) - 37H; hex := TRUE ELSE EXIT END ; Texts.Read(R, ch) END ; lastCh := ch; j := 0; k := 0; IF ch = "." THEN Texts.Read(R, ch); IF ch = "." THEN lastCh := 0X; ch := 7FX END END ; IF lastCh = "." THEN (*decimal point*) IF hex THEN Mark(2) END ; x := 0; e := 0; REPEAT x := x * 10 + d[j]; INC(j) UNTIL j = i; (*integer part*) WHILE ("0" <= ch) & (ch <= "9") DO x := x * 10 + (ORD(ch) - 30H); DEC(e); Texts.Read(R, ch) (*fraction*) END ; expch := ch; IF (ch = "E") OR (ch = "D") THEN (*scale factor*) s := 0; Texts.Read(R, ch); IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch) ELSE negE := FALSE; IF ch = "+" THEN Texts.Read(R, ch) END END ; IF ("0" <= ch) & (ch <= "9") THEN REPEAT s := s*10 + ORD(ch)-30H; Texts.Read(R, ch) UNTIL (ch < "0") OR (ch >"9"); IF negE THEN DEC(e, s) ELSE INC(e, s) END ELSE Mark(2) END END ; IF e < 0 THEN IF e >= -maxExp THEN x := x / Reals.TenL(-e) ELSE x := 0 END ELSIF e > 0 THEN IF e <= maxExp THEN x := Reals.TenL(e) * x ELSE x := 0; Mark(203) END END ; IF expch = "D" THEN numtyp := 4; lrlval := x ELSE numtyp := 3; IF x <= MAX(REAL) THEN realval := SHORT(x) ELSE x := 0; Mark(203) END END ELSIF lastCh = "H" THEN Texts.Read(R, ch); WHILE d[j] = 0 DO INC(j) END ; IF i-j <= 8 THEN IF (i-j = 8) & (d[j] >= 8) THEN DEC(d[j], 16) END ; WHILE j < i DO k := k * 10H + d[j]; INC(j) END ELSE Mark(203) END ; numtyp := 2; intval := k ELSIF lastCh = "X" THEN Texts.Read(R, ch); WHILE j < i DO k := k * 10H + d[j]; INC(j); IF k > 0FFH THEN Mark(203); k := 0 END END ; numtyp := 1; intval := k ELSE (*decimal integer*) IF hex THEN Mark(2) END ; WHILE j < i DO IF k <= (MAX(LONGINT) - d[j]) DIV 10 THEN k := k*10 + d[j] ELSE Mark(203); k := 0 END ; INC(j) END ; numtyp := 2; intval := k END END Number; PROCEDURE Get*(VAR sym: INTEGER); VAR s: INTEGER; PROCEDURE Comment; (* do not read after end of file *) BEGIN Texts.Read(R, ch); LOOP LOOP WHILE ch = "(" DO Texts.Read(R, ch); IF ch = "*" THEN Comment END END ; IF ch = "*" THEN Texts.Read(R, ch); EXIT END ; IF ch = 0X THEN EXIT END ; Texts.Read(R, ch) END ; IF ch = ")" THEN Texts.Read(R, ch); EXIT END ; IF ch = 0X THEN Mark(5); EXIT END END END Comment; BEGIN LOOP (*ignore control characters*) IF ch <= " " THEN IF ch = 0X THEN ch := " "; EXIT ELSE Texts.Read(R, ch) END ELSIF ch > 7FX THEN Texts.Read(R, ch) ELSE EXIT END END ; prev := ch; Texts.Read(R, ch); CASE prev OF (* " " <= prev <= 7FX *) " " : s := 62; ch := 0X (*eof*) | "!", "$", "%", "'", "?", "@", "\", "_", "`": s := 0 | 22X : String(s) | "#" : s := 10 | "&" : s := 5 | "(" : IF ch = "*" THEN Comment; Get(s) ELSE s := 29 END | ")" : s := 22 | "*" : s := 1 | "+" : s := 6 | "," : s := 19 | "-" : s := 7 | "." : IF ch = "." THEN Texts.Read(R, ch); s := 21 ELSE s := 18 END | "/" : s := 2 | "0".."9": Number; s := 34 | ":" : IF ch = "=" THEN Texts.Read(R, ch); s := 33 ELSE s := 20 END | ";" : s := 38 | "<" : IF ch = "=" THEN Texts.Read(R, ch); s := 12 ELSE s := 11 END | "=" : s := 9 | ">" : IF ch = "=" THEN Texts.Read(R, ch); s := 14 ELSE s := 13 END | "A".."Z": Identifier(s) | "[" : s := 30 | "]" : s := 23 | "^" : s := 17 | "a".."z": Identifier(s) | "{" : s := 31 | "|" : s := 39 | "}" : s := 24 | "~" : s := 32 | 7FX : s := 21 END ; sym := s END Get; PROCEDURE Init*(source: Texts.Text; pos: LONGINT); BEGIN ch := " "; scanerr := FALSE; lastpos := -8; Texts.OpenReader(R, source, pos) END Init; PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR); VAR j, k: INTEGER; BEGIN j := 0; k := 0; REPEAT INC(k, ORD(name[j])); INC(j) UNTIL name[j] = 0X; k := (k+j) MOD KW; (*hash function*) IF keyTab[k].symb # 0 THEN j := k; REPEAT INC(k) UNTIL keyTab[k].symb = 0; keyTab[j].alt := k END ; keyTab[k].symb := sym; COPY(name, keyTab[k].id) END EnterKW; BEGIN Texts.OpenWriter(W); i := KW; WHILE i > 0 DO DEC(i); keyTab[i].symb := 0; keyTab[i].alt := 0 END ; keyTab[0].id := ""; EnterKW(53, "BY"); EnterKW(27, "DO"); EnterKW(44, "IF"); EnterKW(15, "IN"); EnterKW(16, "IS"); EnterKW(25, "OF"); EnterKW( 8, "OR"); EnterKW(28, "TO"); EnterKW(40, "END"); EnterKW(52, "FOR"); EnterKW( 4, "MOD"); EnterKW(35, "NIL"); EnterKW(60, "VAR"); EnterKW(45, "CASE"); EnterKW(41, "ELSE"); EnterKW(50, "EXIT"); EnterKW(26, "THEN"); EnterKW(59, "TYPE"); EnterKW(49, "WITH"); EnterKW(54, "ARRAY"); EnterKW(57, "BEGIN"); EnterKW(58, "CONST"); EnterKW(42, "ELSIF"); EnterKW(62, "IMPORT"); EnterKW(43, "UNTIL"); EnterKW(46, "WHILE"); EnterKW(55, "RECORD"); EnterKW(47, "REPEAT"); EnterKW(51, "RETURN"); EnterKW(56, "POINTER"); EnterKW(61, "PROCEDURE"); EnterKW( 3, "DIV"); EnterKW(48, "LOOP"); EnterKW(63, "MODULE"); END OBS. -------------------------------------------------------------------------------- /Curves.Mod: -------------------------------------------------------------------------------- 1 | MODULE Curves; (*NW 8.11.90 / 1.2.91*) IMPORT Display, Files, Printer, 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 mark(f: GraphicFrames.Frame; col, x, y: INTEGER); BEGIN Display.ReplConstC(f, col, x, y, 4, 4, 0) 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 Display.DotC(f, col, SHORT(x), SHORT(y), 0); 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 Display.DotC(f, col, SHORT(x), SHORT(y), 0); 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 Display.DotC(f, col, SHORT(x0+x), SHORT(y0+y), 0); Display.DotC(f, col, SHORT(x0+y), SHORT(y0+x), 0); Display.DotC(f, col, SHORT(x0-y), SHORT(y0+x), 0); Display.DotC(f, col, SHORT(x0-x), SHORT(y0+y), 0); Display.DotC(f, col, SHORT(x0-x), SHORT(y0-y), 0); Display.DotC(f, col, SHORT(x0-y), SHORT(y0-x), 0); Display.DotC(f, col, SHORT(x0+y), SHORT(y0-x), 0); Display.DotC(f, col, SHORT(x0+x), SHORT(y0-y), 0); 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 Display.DotC(f, col, SHORT(x0+x), SHORT(y0+y), 0); Display.DotC(f, col, SHORT(x0-x), SHORT(y0+y), 0); Display.DotC(f, col, SHORT(x0-x), SHORT(y0-y), 0); Display.DotC(f, col, SHORT(x0+x), SHORT(y0-y), 0); 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 Display.DotC(f, col, SHORT(x0+x), SHORT(y0+y), 0); Display.DotC(f, col, SHORT(x0-x), SHORT(y0+y), 0); Display.DotC(f, col, SHORT(x0-x), SHORT(y0-y), 0); Display.DotC(f, col, SHORT(x0+x), SHORT(y0-y), 0); 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 WITH M: GraphicFrames.DrawMsg DO 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) ELSE mark(f, f.col, x, y); line(f, f.col, 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) ELSE mark(f, f.col, x, y+h); line(f, f.col, 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-4) END ; circle(f, col, x+w, y+w, w) ELSIF M.mode = 1 THEN mark(f, Display.white, x+w, y-4) ELSIF M.mode = 2 THEN mark(f, f.col, x+w, y-4) ELSE mark(f, f.col, x+w, y-4); circle(f, f.col, 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-4) END ; ellipse(f, col, x+w, y+h, w, h) ELSIF M.mode = 1 THEN mark(f, Display.white, x+w, y-4) ELSIF M.mode = 2 THEN mark(f, f.col, x+w, y-4) ELSE mark(f, f.col, x+w, y-4); ellipse(f, f.col, 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; 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 ; RETURN (obj.x <= x) & (x < obj.x + w) & (ABS(LONG(y-y0)*w - LONG(x-obj.x)*h) < w*4) ELSE (*circle or ellipse*) xm := obj.w DIV 2 + obj.x; RETURN (xm - 4 <= x) & (x <= xm + 4) & (obj.y - 4 <= y) & (y <= obj.y + 4) END END Selectable; PROCEDURE Handle(obj: Graphics.Object; VAR M: Graphics.Msg); BEGIN IF M IS Graphics.ColorMsg THEN obj.col := M(Graphics.ColorMsg).col END END Handle; PROCEDURE Read(obj: Graphics.Object; VAR R: Files.Rider; VAR C: Graphics.Context); VAR len: INTEGER; BEGIN Files.ReadInt(R, len); Files.ReadInt(R, obj(Curve).kind); Files.ReadInt(R, obj(Curve).lw) END Read; PROCEDURE Write(obj: Graphics.Object; cno: SHORTINT; VAR W: Files.Rider; VAR C: Graphics.Context); BEGIN Graphics.WriteObj(W, cno, obj); Files.WriteInt(W, 4); Files.WriteInt(W, obj(Curve).kind); Files.WriteInt(W, obj(Curve).lw) END Write; PROCEDURE Print(obj: Graphics.Object; x, y: INTEGER); VAR x0, y0: INTEGER; BEGIN IF obj(Curve).kind = 0 THEN x0 := obj.x * 4 + x; y0 := obj.y * 4 + y; Printer.Line(x0, y0, obj.w * 4 + x0, obj.h * 4 + y0) ELSIF obj(Curve).kind = 1 THEN x0 := obj.x * 4 + x; y0 := obj.y * 4 + y; Printer.Line(x0, obj.h * 4 + y0, obj.w * 4 + x0, y0) ELSIF obj(Curve).kind = 2 THEN Printer.Circle((obj.x*2 + obj.w)*2 + x, (obj.y*2 + obj.h)*2 + y, obj.w*2) ELSE Printer.Ellipse((obj.x*2 + obj.w)*2 + x, (obj.y*2 + obj.h)*2 + y, obj.w*2, obj.h*2) END END Print; 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.handle := Handle; method.read := Read; method.write := Write; method.print := Print END Curves. -------------------------------------------------------------------------------- /C2.Diskette.Mod: -------------------------------------------------------------------------------- 1 | MODULE Diskette; (*JG Ceres-2 version/14.2.90*) IMPORT SYSTEM, Kernel, Files; CONST Oberon* = 0E9X; MSDOS* = 0F9X; (*WD1002-05 registers*) DRdata = 0FFFF8000H; (*R/W data*) DRerrst = 0FFFF8004H; (*R error status*) DRprecomp = 0FFFF8004H; (*W write precomp*) DRseccnt = 0FFFF8008H; (*R/W sector count*) DRsecno = 0FFFF800CH; (*R/W sector number*) DRcyllo = 0FFFF8010H; (*R/W cylinder low byte*) DRcylhi = 0FFFF8014H; (*R/W cylinder high byte*) DRsdh = 0FFFF8018H; (*R/W side/drive/head*) DRstatus = 0FFFF801CH; (*R status*) DRcommand = 0FFFF801CH; (*W command*) (*bits in DRstatus, bits in DRerrst*) DSbusy = 7; DEbadblk = 7; (*bad block mark*) DSready = 6; DEuncorr = 6; (*unreadable sector*) DSwrfault = 5; DEcrcID = 5; (*unreadable ID field*) DSseekcompl = 4; DEnoID = 4; (*specified ID not found*) DSdatareq = 3; DEaborted = 2; (*command aborted*) DScorrected = 2; DETR000 = 1; (*track 0 not reached*) DSerror = 0; DEnoDAM = 0; (*data adr mark not found*) (*WD1002-05 commands*) DCread = 20X; DCwrite = 30X; (*FD command and drive spex*) restore = 13X; format = 50X; surfaces = 2; tracks = 80; (*per surface*) sectors = 9; (*per track*) sectorsize = 512; steprate = 3; (* MS-DOS format 0F9H for 3.5 inch diskettes: parameters sector allocation surfaces 2 0 descriptor tracks/surface 80 1..3 FAT sectors/track 9 4..6 FAT copy bytes/sector 512 7..13 directory sectors/cluster 2 14..1439 file data directory entries 112*) TYPE FileDesc = RECORD (*image of dir entry*) name: ARRAY 22 OF CHAR; time, date: INTEGER; head: INTEGER; size: LONGINT END; File = POINTER TO FileHandle; FileHandle = RECORD prev, next: File; file: FileDesc END; EntryHandler* = PROCEDURE (name: ARRAY OF CHAR; date, time, size: LONGINT); VAR SecSize*: INTEGER; res*: INTEGER; err*: SHORTINT; sect*: LONGINT; busy*: BOOLEAN; dir: File; trailer: FileDesc; d, t: LONGINT; usedF, usedC: INTEGER; FAT: ARRAY 720 OF INTEGER; (*driver*) PROCEDURE wait; BEGIN REPEAT UNTIL ~SYSTEM.BIT(DRstatus, DSbusy) END wait; PROCEDURE SetPars (sec, cnt: INTEGER; cmd: CHAR); VAR secno, track, cyl, surf: INTEGER; BEGIN secno := sec MOD sectors + 1; track := sec DIV sectors; cyl := track DIV surfaces; surf := track MOD surfaces; SYSTEM.PUT(DRsecno, secno); SYSTEM.PUT(DRcyllo, cyl MOD 256); SYSTEM.PUT(DRcylhi, cyl DIV 256); SYSTEM.PUT(DRsdh, surf + 38H); SYSTEM.PUT(DRseccnt, cnt); SYSTEM.PUT(DRcommand, cmd) END SetPars; PROCEDURE Reset*; END Reset; PROCEDURE GetSector* (sec: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE; off: INTEGER); VAR retry, I, i: INTEGER; BEGIN retry := 3; busy := TRUE; LOOP SetPars(sec, 1, DCread); wait; i := off; I := off + 512; REPEAT SYSTEM.GET(DRdata, buf[i]); INC(i) UNTIL i = I; IF ~SYSTEM.BIT(DRstatus, DSerror) THEN busy := FALSE; EXIT END ; SYSTEM.GET(DRerrst, err); sect := sec; DEC(retry); IF retry = 0 THEN busy := FALSE; HALT(28) END END END GetSector; PROCEDURE PutSector* (sec: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE; off: INTEGER); VAR retry, I, i: INTEGER; BEGIN retry := 3; busy := TRUE; LOOP SetPars(sec, 1, DCwrite); i := off; I := off + 512; REPEAT SYSTEM.PUT(DRdata, buf[i]); INC(i) UNTIL i = I; wait; IF ~SYSTEM.BIT(DRstatus, DSerror) THEN busy := FALSE; EXIT END ; SYSTEM.GET(DRerrst, err); sect := sec; DEC(retry); IF retry = 0 THEN busy := FALSE; HALT(28) END END END PutSector; PROCEDURE Format*; VAR track, i: INTEGER; BEGIN track := 0; REPEAT i := 0; SetPars(track*sectors, sectors, format); REPEAT SYSTEM.PUT(DRdata, 0); SYSTEM.PUT(DRdata, i MOD sectors + 1); INC(i, 2) UNTIL i = 2 * sectors; REPEAT SYSTEM.PUT(DRdata, 0); INC(i) UNTIL i = sectorsize; wait; INC(track) UNTIL track = surfaces * tracks END Format; (*directory*) PROCEDURE InitDir*; VAR i: INTEGER; BEGIN NEW(dir); dir.file.name[0] := 0FFX; dir.file.name[11] := 8X; (*def as vol label*) dir.next := dir; dir.prev := dir; usedF := 1; usedC := 7; FAT[0] := -1; FAT[1] := -1; i := 2; REPEAT FAT[i] := 0; FAT[i+1] := 0; i := i+2 UNTIL i = 720 END InitDir; PROCEDURE Clusters (size: LONGINT): INTEGER; BEGIN RETURN SHORT((size + 1023) DIV 1024) END Clusters; PROCEDURE findFile (name: ARRAY OF CHAR; VAR f: File); BEGIN f := dir.next; WHILE f.file.name < name DO f := f.next END END findFile; PROCEDURE ReadDir*; VAR f, g: File; n: LONGINT; s, i, j, n0, n1: INTEGER; buf: ARRAY 1536 OF CHAR; dBuf: ARRAY 16 OF FileDesc; BEGIN (*read boot sector*) GetSector(0, buf, 0); IF (buf[21] # 0F9X) & (buf[21] # 0E9X) THEN HALT(54) END; GetSector(7, dBuf, 0); (*read volume label*) NEW(f); f.file := dBuf[0]; IF f.file.name[11] # 8X THEN HALT(54) END; (*not vol label*) IF (f.file.name[0] < 0E5X) & (f.file.name[0] # 0X) THEN HALT(55) END; (*not Oberon format*) f.file.name[0] := 0FFX; (*read dir*) f.prev := f; f.next := f; dir := f; usedF := 1; usedC := 7; s := 7; j := 1; LOOP IF (dBuf[j].name[0] = 0X) OR (dBuf[j].name[0] = 0E5X) THEN EXIT END; NEW(f); f.file := dBuf[j]; findFile(f.file.name, g); f.next := g; g.prev.next := f; f.prev := g.prev; g.prev := f; INC(usedF); usedC := usedC + Clusters(f.file.size); INC(j); IF j = 16 THEN INC(s); j := 0; IF s = 14 THEN EXIT END; GetSector(s, dBuf, 0) END END; (*read FAT*) GetSector(1, buf, 0); GetSector(2, buf, 512); GetSector(3, buf, 1024); FAT[0] := -1; FAT[1] := -1; i := 2; j := 3; REPEAT n := ORD(buf[j+2]); n := n*256; n := n + ORD(buf[j+1]); n := n*256; n := n + ORD(buf[j]); n0 := SHORT(n MOD 4096); n1 := SHORT(n DIV 4096); IF n0 > 2047 THEN n0 := n0 - 4096 END; IF n1 > 2047 THEN n1 := n1 - 4096 END; FAT[i] := n0; FAT[i+1] := n1; i := i + 2; j := j + 3 UNTIL i = 720 END ReadDir; PROCEDURE WriteDir*; VAR f: File; n: LONGINT; s, i, j, n0, n1: INTEGER; buf: ARRAY 1536 OF CHAR; dBuf: ARRAY 16 OF FileDesc; BEGIN (*write boot sector*) buf[21] := 0F9X; PutSector(0, buf, 0); (*write FAT*) buf[0] := 0F9X; buf[1] := 0FFX; buf[2] := 0FFX; i := 2; j := 3; REPEAT n0 := FAT[i]; n1 := FAT[i+1]; IF n0 < 0 THEN n0 := n0 + 4096 END; IF n1 < 0 THEN n1 := n1 + 4096 END; n := n1; n := n*4096 + n0; buf[j] := CHR(SHORT(n MOD 256)); n := n DIV 256; buf[j+1] := CHR(SHORT(n MOD 256)); n := n DIV 256; buf[j+2] := CHR(SHORT(n)); i := i + 2; j := j + 3 UNTIL i = 720; PutSector(1, buf, 0); PutSector(2, buf, 512); PutSector(3, buf, 1024); (*write dir*) s := 7; j := 0; f := dir; REPEAT dBuf[j] := f.file; INC(j); IF j = 16 THEN PutSector(s, dBuf, 0); INC(s); j := 0 END; f := f.next UNTIL f = dir; IF s # 14 THEN dBuf[j] := trailer; PutSector(s, dBuf, 0) END END WriteDir; PROCEDURE GetData* (VAR date, time: LONGINT; VAR nofFiles, nofClusters: INTEGER); BEGIN date := dir.file.date; time := LONG(dir.file.time)*2; nofFiles := usedF; nofClusters := usedC END GetData; PROCEDURE Enumerate* (proc: EntryHandler); VAR f: File; BEGIN f := dir.next; WHILE f # dir DO proc(f.file.name, f.file.date, LONG(f.file.time)*2, f.file.size); f := f.next END END Enumerate; PROCEDURE readFile (f: File; g: Files.File); VAR Wg: Files.Rider; size: LONGINT; i: INTEGER; buf: ARRAY 1024 OF CHAR; BEGIN Files.Set(Wg, g, 0); size := f.file.size; IF size # 0 THEN i := f.file.head; LOOP GetSector(10 + 2*i, buf, 0); GetSector(11 + 2*i, buf, 512); IF FAT[i] = -1 THEN EXIT END; Files.WriteBytes(Wg, buf, 1024); size := size - 1024; i := FAT[i] END; Files.WriteBytes(Wg, buf, SHORT(size)) END END readFile; PROCEDURE deleteFile (f: File); VAR i, j: INTEGER; BEGIN f.prev.next := f.next; f.next.prev := f.prev; i := f.file.head; REPEAT j := FAT[i]; FAT[i] := 0; i := j UNTIL i = -1 END deleteFile; PROCEDURE addFile (f: Files.File; g, h: File); VAR Rf: Files.Rider; need, i, j: INTEGER; buf: ARRAY 1024 OF CHAR; BEGIN Files.Set(Rf, f, 0); need := Clusters(g.file.size); IF need # 0 THEN j := 2; WHILE FAT[j] # 0 DO INC(j) END; g.file.head := j; LOOP i := j; Files.ReadBytes(Rf, buf, 1024); PutSector(10 + 2*i, buf, 0); PutSector(11 + 2*i, buf, 512); DEC(need); IF need = 0 THEN EXIT END; INC(j); WHILE FAT[j] # 0 DO INC(j) END; FAT[i] := j END; FAT[i] := -1 END; g.next := h; h.prev.next := g; g.prev := h.prev; h.prev := g END addFile; PROCEDURE ReadAll*; VAR f: File; g: Files.File; BEGIN ReadDir; f := dir.next; WHILE f # dir DO g := Files.New(f.file.name); readFile(f, g); Files.Register(g); f := f.next END END ReadAll; PROCEDURE ReadFile* (name: ARRAY OF CHAR); VAR f: File; g: Files.File; BEGIN findFile(name, f); IF f.file.name = name THEN g := Files.New(name); readFile(f, g); Files.Register(g); res := 0 ELSE res := 1 END END ReadFile; PROCEDURE WriteFile* (name: ARRAY OF CHAR); VAR f: Files.File; g, h: File; d, t: LONGINT; needC: INTEGER; BEGIN res := 0; NEW(g); g.file.name[11] := 0X; (*attributes*) COPY(name, g.file.name); f := Files.Old(name); IF f # NIL THEN g.file.size := Files.Length(f); Kernel.GetClock(t, d); g.file.date := SHORT(d); g.file.time := SHORT(t DIV 2); findFile(g.file.name, h); IF h.file.name = g.file.name THEN needC := Clusters(g.file.size) - Clusters(h.file.size); IF usedC + needC <= 720 THEN deleteFile(h); addFile(f, g, h.next); usedC := usedC + needC ELSE res := 2 END ELSE needC := Clusters(g.file.size); IF (usedF < 112) & (usedC + needC <= 720) THEN addFile(f, g, h); INC(usedF); usedC := usedC + needC ELSE res := 2 END END ELSE res := 1 END END WriteFile; PROCEDURE DeleteFile* (name: ARRAY OF CHAR); VAR g: File; BEGIN findFile(name, g); IF g.file.name = name THEN deleteFile(g); DEC(usedF); usedC := usedC - Clusters(g.file.size); res := 0 ELSE res := 1 END END DeleteFile; BEGIN trailer.name[0] := 0X END Diskette. -------------------------------------------------------------------------------- /Draw.Mod: -------------------------------------------------------------------------------- 1 | MODULE Draw; (*NW 29.6.88 / 12.11.94*) IMPORT Files, Fonts, Viewers, Printer, Texts, Oberon, TextFrames, MenuViewers, Graphics, GraphicFrames; CONST Menu = "^Draw.Menu.Text System.Close System.Copy System.Grow Draw.Delete Draw.Store"; VAR W: Texts.Writer; (*Exported commands: Open, Delete, SetWidth, ChangeColor, ChangeWidth, ChangeFont, ChangeBackgroundColor, ToggleTicks, Store, Print, Macro, OpenMacro, MakeMacro, StoreLibrary*) 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, -1, 0, 0, TRUE); 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.width := SHORT(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 := SHORT(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 := SHORT(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 ChangeBackgroundColor*; VAR S: Texts.Scanner; v: Viewers.Viewer; G: GraphicFrames.Frame; BEGIN v := Oberon.MarkedViewer(); IF (v.dsc # NIL) & (v.dsc.next IS GraphicFrames.Frame) THEN GetArg(S); G := v.dsc.next(GraphicFrames.Frame); IF S.class = Texts.Int THEN G.col := SHORT(S.i) MOD 16; GraphicFrames.Restore(G) END END END ChangeBackgroundColor; PROCEDURE ToggleTicks*; VAR v: Viewers.Viewer; G: GraphicFrames.Frame; BEGIN v := Oberon.MarkedViewer(); IF (v.dsc # NIL) & (v.dsc.next IS GraphicFrames.Frame) THEN G := v.dsc.next(GraphicFrames.Frame); G.ticked := ~G.ticked; GraphicFrames.Restore(G) END END ToggleTicks; 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 par: Oberon.ParList; S: Texts.Scanner; Menu: TextFrames.Frame; G: GraphicFrames.Frame; v: Viewers.Viewer; BEGIN par := Oberon.Par; IF par.frame = par.vwr. dsc THEN Menu := 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); Graphics.WriteFile(G.graph, S.s) END ELSE Texts.OpenScanner(S, par.text, 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); Graphics.WriteFile(G.graph, S.s) END END END END Store; PROCEDURE Print*; VAR nofcopies: INTEGER; S: Texts.Scanner; G: Graphics.Graph; F: TextFrames.Frame; V: Viewers.Viewer; PROCEDURE Copies; VAR ch: CHAR; BEGIN nofcopies := 1; IF S.nextCh = "/" THEN Texts.Read(S, ch); IF (ch >= "0") & (ch <= "9") THEN nofcopies := ORD(ch) - 30H END ; WHILE ch > " " DO Texts.Read(S, ch) END ; S.nextCh := ch END END Copies; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); IF S.class = Texts.Name THEN Printer.Open(S.s, Oberon.User, Oberon.Password); IF Printer.res = 0 THEN IF Oberon.Par.frame = Oberon.Par.vwr.dsc THEN F := Oberon.Par.frame(TextFrames.Frame); IF F.next IS GraphicFrames.Frame THEN Texts.OpenScanner(S, F.text, 0); Texts.Scan(S); Texts.WriteString(W, S.s); Texts.WriteString(W, " printing"); Texts.Append(Oberon.Log, W.buf); Graphics.Print(F.next(GraphicFrames.Frame).graph, 0, Printer.PageHeight-128); Printer.Page(1) END ELSE Texts.Scan(S); IF (S.class = Texts.Char) & (S.c = "*") THEN Copies; V := Oberon.MarkedViewer(); IF (V.dsc # NIL) & (V.dsc.next IS GraphicFrames.Frame) THEN Texts.OpenScanner(S, V.dsc(TextFrames.Frame).text, 0); Texts.Scan(S); IF S.class = Texts.Name THEN Texts.WriteString(W, S.s); Texts.WriteString(W, " printing"); Texts.WriteInt(W, nofcopies, 3); Texts.Append(Oberon.Log, W.buf); Graphics.Print(V.dsc.next(GraphicFrames.Frame).graph, 0, Printer.PageHeight-128); Printer.Page(nofcopies) END END ELSE WHILE S.class = Texts.Name DO Texts.WriteString(W, S.s); Copies; NEW(G); Graphics.Open(G, S.s); IF Graphics.res = 0 THEN Texts.WriteString(W, " printing"); Texts.WriteInt(W, nofcopies, 3); Texts.Append(Oberon.Log, W.buf); Graphics.Print(G, 0, Printer.PageHeight-128); Printer.Page(nofcopies) ELSE Texts.WriteString(W, " not found") END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S) END END END ; Printer.Close ELSIF Printer.res = 1 THEN Texts.WriteString(W, " no printer") ELSIF Printer.res = 2 THEN Texts.WriteString(W, " no link") ELSIF Printer.res = 3 THEN Texts.WriteString(W, " bad response") ELSIF Printer.res = 4 THEN Texts.WriteString(W, " no permission") END END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END Print; 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 COPY(S.s, Lname); 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) OR (S.class = Texts.String) THEN GraphicFrames.Macro(Lname, S.s) END END END Macro; 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 new: BOOLEAN; F: GraphicFrames.Frame; S: Texts.Scanner; Lname: ARRAY 32 OF CHAR; PROCEDURE MakeMac; VAR x0, y0, x1, y1, w, h: INTEGER; mh: Graphics.MacHead; L: Graphics.Library; BEGIN L := Graphics.ThisLib(Lname, FALSE); IF L = NIL THEN L := Graphics.NewLib(Lname) END ; x0 := F.mark.x; y0 := F.mark.y; x1 := F.mark.next.x; y1 := F.mark.next.y; w := ABS(x1-x0); h := ABS(y1-y0); IF x0 < x1 THEN x0 := x0 - F.x ELSE x0 := x1 - F.x END ; IF y0 < y1 THEN y0 := y0 - F.y ELSE y0 := y1 - F.y END ; mh := Graphics.MakeMac(F.graph, x0, y0, w, h, S.s); Graphics.InsertMac(mh, L, new) END MakeMac; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); IF S.class = Texts.Name THEN COPY(S.s, Lname); Texts.Scan(S); IF (S.class = Texts.Name) OR (S.class = Texts.String) & (S.len <= 8) THEN F := GraphicFrames.Focus(); IF (F # NIL) & (F.graph.sel # NIL) THEN MakeMac; Texts.WriteString(W, S.s); IF new THEN Texts.WriteString(W, " inserted in ") ELSE Texts.WriteString(W, " replaced in ") END ; Texts.WriteString(W, Lname); 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 L := Graphics.ThisLib(S.s, TRUE); Texts.WriteString(W, S.s); Texts.WriteString(W, " loaded"); 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; Lname: ARRAY 32 OF CHAR; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); IF S.class = Texts.Name THEN i := 0; WHILE S.s[i] >= "0" DO Lname[i] := S.s[i]; INC(i) END ; Lname[i] := 0X; L := Graphics.ThisLib(Lname, FALSE); IF L # NIL THEN Texts.WriteString(W, S.s); Texts.WriteString(W, " storing"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Graphics.StoreLib(L, S.s) END END END StoreLibrary; BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "Draw - NW 2.12.93"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END Draw. -------------------------------------------------------------------------------- /Oberon.Mod: -------------------------------------------------------------------------------- 1 | MODULE Oberon; (*JG 6.9.90 / 23.9.93 / 13.8.94*) IMPORT Kernel, Modules, Input, Display, Fonts, Viewers, Texts; CONST (*message ids*) consume* = 0; track* = 1; defocus* = 0; neutralize* = 1; mark* = 2; BasicCycle = 20; ESC = 1BX; SETUP = 0A4X; TYPE Painter* = PROCEDURE (x, y: INTEGER); Marker* = RECORD Fade*, Draw*: Painter END; Cursor* = RECORD marker*: Marker; on*: BOOLEAN; X*, Y*: INTEGER END; ParList* = POINTER TO ParRec; ParRec* = RECORD vwr*: Viewers.Viewer; frame*: Display.Frame; text*: Texts.Text; pos*: LONGINT END; InputMsg* = RECORD (Display.FrameMsg) id*: INTEGER; keys*: SET; X*, Y*: INTEGER; ch*: CHAR; fnt*: Fonts.Font; col*, voff*: SHORTINT END; SelectionMsg* = RECORD (Display.FrameMsg) time*: LONGINT; text*: Texts.Text; beg*, end*: LONGINT END; ControlMsg* = RECORD (Display.FrameMsg) id*, X*, Y*: INTEGER END; CopyOverMsg* = RECORD (Display.FrameMsg) text*: Texts.Text; beg*, end*: LONGINT END; CopyMsg* = RECORD (Display.FrameMsg) F*: Display.Frame END; Task* = POINTER TO TaskDesc; Handler* = PROCEDURE; TaskDesc* = RECORD next: Task; safe*: BOOLEAN; time*: LONGINT; handle*: Handler END; VAR User*: ARRAY 8 OF CHAR; Password*: LONGINT; Arrow*, Star*: Marker; Mouse*, Pointer*: Cursor; FocusViewer*: Viewers.Viewer; Log*: Texts.Text; Par*: ParList; (*actual parameters*) CurTask*, NextTask: Task; CurFnt*: Fonts.Font; CurCol*, CurOff*: SHORTINT; DW, DH, CL, H0, H1, H2, H3: INTEGER; unitW: 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 COPY(user, User); Password := Code(password) END SetUser; (*clocks*) PROCEDURE GetClock* (VAR t, d: LONGINT); BEGIN Kernel.GetClock(t, d) END GetClock; PROCEDURE SetClock* (t, d: LONGINT); BEGIN Kernel.SetClock(t, d) END SetClock; PROCEDURE Time* (): LONGINT; BEGIN RETURN Input.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, 2) 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, 2) 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; VAR 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; (*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 WITH V: Viewers.Viewer DO IF M IS InputMsg THEN WITH M: InputMsg DO IF M.id = track THEN DrawCursor(Mouse, Arrow, M.X, M.Y) END END; ELSIF M IS ControlMsg THEN WITH M: ControlMsg DO IF M.id = mark THEN DrawCursor(Pointer, Star, M.X, M.Y) END END ELSIF M IS Viewers.ViewerMsg THEN WITH M: Viewers.ViewerMsg DO 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, 0) 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, 0) END END 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, 0); 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 fil, bot, alt, max: Display.Frame; BEGIN Viewers.Locate(X, 0, fil, bot, alt, max); IF fil.H >= DH DIV 8 THEN RETURN DH END; RETURN max.Y + max.H DIV 2 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 fil, bot, alt, max: Display.Frame; BEGIN Viewers.Locate(X, DH, fil, bot, alt, max); IF fil.H >= DH DIV 8 THEN RETURN DH END; IF max.H >= DH - H0 THEN RETURN max.Y + H3 END; IF max.H >= H3 - H0 THEN RETURN max.Y + H2 END; IF max.H >= H2 - H0 THEN RETURN max.Y + H1 END; IF max # bot THEN RETURN max.Y + max.H DIV 2 END; IF bot.H >= H1 THEN RETURN bot.H DIV 2 END; RETURN alt.Y + alt.H DIV 2 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; (*command interpretation*) PROCEDURE Call* (name: ARRAY OF CHAR; par: ParList; new: BOOLEAN; VAR res: INTEGER); VAR Mod: Modules.Module; P: Modules.Command; i, j: INTEGER; BEGIN res := 1; i := 0; j := 0; WHILE name[j] # 0X DO IF name[j] = "." THEN i := j END; INC(j) END; IF i > 0 THEN name[i] := 0X; IF new THEN Modules.Free(name, FALSE) END; Mod := Modules.ThisMod(name); IF Modules.res = 0 THEN INC(i); j := i; WHILE name[j] # 0X DO name[j - i] := name[j]; INC(j) END; name[j - i] := 0X; P := Modules.ThisCommand(Mod, name); IF Modules.res = 0 THEN Par := par; Par.vwr := Viewers.This(par.frame.X, par.frame.Y); P; res := 0 ELSE res := -1 END ELSE res := Modules.res END ELSE res := -1 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; BEGIN IF ActCnt <= 0 THEN Kernel.GC; ActCnt := BasicCycle END END GC; PROCEDURE Install* (T: Task); VAR t: Task; BEGIN t := NextTask; WHILE (t.next # NextTask) & (t.next # T) DO t := t.next END; IF t.next # T THEN T.next := t.next; t.next := T END END Install; PROCEDURE Remove* (T: Task); VAR t: Task; BEGIN t := NextTask; WHILE (t.next # NextTask) & (t.next # T) DO t := t.next END; IF t.next = T THEN t.next := T.next; IF NextTask = T THEN NextTask := T.next END 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: SHORTINT); BEGIN CurCol := col END SetColor; PROCEDURE SetOffset* (voff: SHORTINT); BEGIN CurOff := voff END SetOffset; PROCEDURE Loop*; VAR V: Viewers.Viewer; M: InputMsg; N: ControlMsg; prevX, prevY, X, Y: INTEGER; keys: SET; ch: CHAR; BEGIN IF (CurTask # NIL) & ~CurTask.safe THEN Remove(CurTask) END ; LOOP Input.Mouse(keys, X, Y); IF Input.Available() > 0 THEN Input.Read(ch); IF ch < 0F0X THEN IF ch = ESC THEN N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer) ELSIF ch = SETUP THEN N.id := mark; N.X := X; N.Y := Y; V := Viewers.This(X, Y); V.handle(V, N) ELSE IF ch < " " THEN IF ch = 1X THEN ch := 83X (*ƒ*) ELSIF ch = 0FX THEN ch := 84X (*„*) ELSIF ch = 15X THEN ch := 85X (*…*) END ELSIF ch > "~" THEN IF ch = 81X THEN ch := 80X (*€*) ELSIF ch = 8FX THEN ch := 81X (**) ELSIF ch = 95X THEN ch := 82X (*‚*) END END; M.id := consume; M.ch := ch; M.fnt := CurFnt; M.col := CurCol; M.voff := CurOff; FocusViewer.handle(FocusViewer, M); DEC(ActCnt) END ELSIF ch = 0F1X THEN Display.SetMode(0, {}) (*on*) ELSIF ch = 0F2X THEN Display.SetMode(0, {0}) (*off*) ELSIF ch = 0F3X THEN Display.SetMode(0, {2}) (*inv*) ELSIF ch = 0F4X THEN Display.SetMode(0, {1}) (*alt*) 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; M.Y := Y; M.keys := keys; V := Viewers.This(X, Y); V.handle(V, M); prevX := X; prevY := Y END; CurTask := NextTask; NextTask := CurTask.next; IF CurTask.time <= Input.Time() THEN CurTask.handle; CurTask := NIL END END END END Loop; 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 := Display.ColLeft; H3 := DH - DH DIV 3; H2 := H3 - H3 DIV 2; H1 := DH DIV 5; H0 := DH DIV 10; unitW := DW DIV 8; OpenDisplay(unitW * 5, unitW * 3, DH); FocusViewer := Viewers.This(0, 0); CurFnt := Fonts.Default; CurCol := Display.white; CurOff := 0; Collect(BasicCycle); NEW(NextTask); NextTask.handle := GC; NextTask.safe := TRUE; NextTask.time := 0; NextTask.next := NextTask; Display.SetMode(0, {}); Mod := Modules.ThisMod("System"); END Oberon. -------------------------------------------------------------------------------- /FileDir.Mod: -------------------------------------------------------------------------------- 1 | MODULE FileDir; (*NW 12.1.86 / 23.8.90*) 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 = LONGINT; 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 (Kernel.Sector) (*allocated in the first page of each file on disk*) mark*: LONGINT; name*: FileName; aleng*, bleng*: INTEGER; date*, time*: LONGINT; ext*: ExtensionTable; sec*: SectorTable; fill: ARRAY SectorSize - HeaderSize OF CHAR; END ; IndexSector* = RECORD (Kernel.Sector) x*: ARRAY IndexSize OF DiskAdr END; DataSector* = RECORD (Kernel.Sector) B*: ARRAY SectorSize OF SYSTEM.BYTE END; DirEntry* = RECORD (*B-tree node*) name*: FileName; adr*: DiskAdr; (*sec no of file header*) p*: DiskAdr (*sec no of descendant in directory*) END ; DirPage* = RECORD (Kernel.Sector) mark*: LONGINT; m*: INTEGER; p0*: DiskAdr; (*sec no of left descendant in directory*) fill: ARRAY FillerSize OF CHAR; e*: ARRAY DirPgSize OF DirEntry END ; (*Exported procedures: Search, Insert, Delete, Enumerate, Init*) PROCEDURE Search*(VAR name: FileName; VAR A: DiskAdr); VAR i, L, R: INTEGER; dadr: DiskAdr; a: DirPage; BEGIN dadr := DirRootAdr; LOOP Kernel.GetSector(dadr, a); 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; EXIT (*found*) END ; IF R = 0 THEN dadr := a.p0 ELSE dadr := a.e[R-1].p END ; IF dadr = 0 THEN A := 0; EXIT (*not found*) END END END Search; PROCEDURE insert(VAR 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); 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*(VAR 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); 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); (*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); 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; DEC(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); 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*) DEC(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(VAR 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(dpg1: DiskAdr; VAR h: BOOLEAN); VAR dpg2: DiskAdr; (*global: a, R*) b: DirPage; BEGIN Kernel.GetSector(dpg1, b); dpg2 := b.e[b.m-1].p; IF dpg2 # 0 THEN del(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); 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(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*(VAR 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); IF (a.m = 0) & (a.p0 # 0) THEN newroot := a.p0; Kernel.GetSector(newroot, a); Kernel.PutSector(DirRootAdr, a) (*discard newroot*) END END END Delete; PROCEDURE enumerate(VAR prefix: ARRAY OF CHAR; dpg: DiskAdr; proc: EntryHandler; VAR continue: BOOLEAN); VAR i, j, diff: INTEGER; dpg1: DiskAdr; a: DirPage; BEGIN Kernel.GetSector(dpg, a); i := 0; WHILE (i < a.m) & continue DO j := 0; LOOP IF prefix[j] = 0X THEN diff := 0; EXIT END ; diff := ORD(a.e[i].name[j]) - ORD(prefix[j]); IF diff # 0 THEN EXIT END ; INC(j) END ; IF i = 0 THEN dpg1 := a.p0 ELSE dpg1 := a.e[i-1].p END ; IF diff >= 0 THEN (*matching prefix*) IF dpg1 # 0 THEN enumerate(prefix, dpg1, proc, continue) END ; IF diff = 0 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; PROCEDURE Init; VAR k: INTEGER; A: ARRAY 2000 OF DiskAdr; PROCEDURE MarkSectors; VAR L, R, i, j, n: INTEGER; x: DiskAdr; hd: FileHeader; B: IndexSector; PROCEDURE sift(L, R: INTEGER); VAR i, j: INTEGER; x: DiskAdr; BEGIN j := L; x := A[j]; LOOP i := j; j := 2*j + 1; IF (j+1 < R) & (A[j] < A[j+1]) THEN INC(j) END ; IF (j >= R) OR (x > A[j]) THEN EXIT END ; A[i] := A[j] END ; A[i] := x END sift; BEGIN L := k DIV 2; R := k; (*heapsort*) WHILE L > 0 DO DEC(L); sift(L, R) END ; WHILE R > 0 DO DEC(R); x := A[0]; A[0] := A[R]; A[R] := x; sift(L, R) END ; WHILE L < k DO Kernel.GetSector(A[L], hd); 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.x[j]) UNTIL j = 0; INC(i) END END ; INC(L) END END MarkSectors; PROCEDURE TraverseDir(dpg: DiskAdr); VAR i: INTEGER; a: DirPage; BEGIN Kernel.GetSector(dpg, a); 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; k := 0 END END ; IF a.p0 # 0 THEN TraverseDir(a.p0); i := 0; WHILE i < a.m DO TraverseDir(a.e[i].p); INC(i) END END END TraverseDir; BEGIN Kernel.ResetDisk; k := 0; TraverseDir(DirRootAdr); MarkSectors END Init; BEGIN Init END FileDir. -------------------------------------------------------------------------------- /NetServer.Mod: -------------------------------------------------------------------------------- 1 | MODULE NetServer; (*NW 15.2.90 / 15.9.93*) IMPORT SYSTEM, SCC, Core, FileDir, Files, Texts, Oberon; CONST PakSize = 512; T0 = 300; T1 = 1000; (*timeouts*) maxFileLen = 100000H; ACK = 10H; NAK = 25H; NPR = 26H; (*acknowledgements*) NRQ = 34H; NRS = 35H; (*name request, response*) SND = 41H; REC = 42H; (*send / receive request*) FDIR = 45H; DEL = 49H; (*directory and delete file requests*) PRT = 43H; (*receive to print request*) TRQ = 46H; TIM = 47H; (*time requests*) MSG = 44H; NPW = 48H; (*new password request*) TOT = 7FH; (*timeout*) MDIR = 4AH; SML = 4BH; RML = 4CH; DML = 4DH; VAR W: Texts.Writer; handler: Oberon.Task; head0, head1: SCC.Header; seqno: SHORTINT; K, mailuno: INTEGER; protected: BOOLEAN; MF: Files.File; (*last mail file accessed*) buf: ARRAY 1024 OF CHAR; (*used by FDIR*) dmy: ARRAY 4 OF CHAR; PROCEDURE EOL; BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END EOL; PROCEDURE SetPartner(VAR name: ARRAY OF CHAR); BEGIN head0.dadr := head1.sadr; head0.destLink := head1.srcLink END SetPartner; PROCEDURE Send(t: SHORTINT; L: INTEGER; VAR data: ARRAY OF CHAR); 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; LOOP SCC.ReceiveHead(head1); IF head1.valid THEN IF head1.sadr = head0.dadr THEN EXIT ELSE SCC.Skip(head1.len) END ELSIF Oberon.Time() >= time THEN head1.typ := TOT; EXIT END END END ReceiveHead; PROCEDURE AppendS(VAR s, d: ARRAY OF CHAR; VAR k: INTEGER); VAR i: INTEGER; ch: CHAR; BEGIN i := 0; REPEAT ch := s[i]; d[k] := ch; INC(i); INC(k) UNTIL ch = 0X END AppendS; PROCEDURE AppendW(s: LONGINT; VAR d: ARRAY OF CHAR; n: INTEGER; VAR k: INTEGER); VAR i: INTEGER; BEGIN i := 0; REPEAT d[k] := CHR(s); s := s DIV 100H; INC(i); INC(k) UNTIL i = n END AppendW; PROCEDURE AppendN(x: LONGINT; VAR d: ARRAY OF CHAR; VAR k: INTEGER); VAR i: INTEGER; u: ARRAY 8 OF CHAR; BEGIN i := 0; REPEAT u[i] := CHR(x MOD 10 + 30H); INC(i); x := x DIV 10 UNTIL x = 0; REPEAT DEC(i); d[k] := u[i]; INC(k) UNTIL i = 0 END AppendN; PROCEDURE AppendDate(t, d: INTEGER; VAR buf: ARRAY OF CHAR; VAR k: INTEGER); PROCEDURE Pair(ch: CHAR; x: LONGINT); BEGIN buf[k] := ch; INC(k); buf[k] := CHR(x DIV 10 + 30H); INC(k); buf[k] := CHR(x MOD 10 + 30H); INC(k) END Pair; BEGIN Pair(" ", d MOD 20H); Pair(".", d DIV 20H MOD 10H); Pair(".", d DIV 200H MOD 80H); Pair(" ", t DIV 800H MOD 20H); Pair(":", t DIV 20H MOD 40H); Pair(":", t MOD 20H * 2) END AppendDate; PROCEDURE SendBuffer(len: INTEGER; VAR done: BOOLEAN); VAR kd, ks: INTEGER; BEGIN REPEAT Send(seqno, len, buf); ReceiveHead(T1) UNTIL head1.typ # seqno + 10H; seqno := (seqno+1) MOD 8; kd := 0; ks := PakSize; WHILE ks < K DO buf[kd] := buf[ks]; INC(kd); INC(ks) END ; K := kd; done := head1.typ = seqno + 10H END SendBuffer; PROCEDURE AppendDirEntry(name: FileDir.FileName; adr: LONGINT; VAR done: BOOLEAN); VAR i: INTEGER; ch: CHAR; BEGIN i := 0; ch := name[0]; WHILE ch > 0X DO buf[K] := ch; INC(i); INC(K); ch := name[i] END ; buf[K] := 0DX; INC(K); IF K >= PakSize THEN SendBuffer(PakSize, done) END END AppendDirEntry; PROCEDURE PickS(VAR s: ARRAY OF CHAR); VAR i, n: INTEGER; ch: CHAR; BEGIN i := 0; n := SHORT(LEN(s))-1; SCC.Receive(ch); WHILE ch > 0X DO IF i < n THEN s[i] := ch; INC(i) END ; SCC.Receive(ch) END ; s[i] := 0X END PickS; PROCEDURE PickQ(VAR w: LONGINT); VAR c0, c1, c2: CHAR; s: SHORTINT; BEGIN SCC.Receive(c0); SCC.Receive(c1); SCC.Receive(c2); SCC.Receive(s); w := s; w := ((w * 100H + LONG(c2)) * 100H + LONG(c1)) * 100H + LONG(c0) END PickQ; PROCEDURE PickW(VAR w: INTEGER); VAR c0: CHAR; s: SHORTINT; BEGIN SCC.Receive(c0); SCC.Receive(s); w := s; w := w * 100H + ORD(c0) END PickW; PROCEDURE SendData(F: Files.File); VAR k: INTEGER; x: CHAR; len: LONGINT; R: Files.Rider; BEGIN Files.Set(R, F, 0); len := 0; seqno := 0; LOOP k := 0; LOOP Files.Read(R, x); IF R.eof THEN EXIT END ; buf[k] := x; INC(k); IF k = PakSize THEN EXIT END END ; REPEAT Send(seqno, k, buf); ReceiveHead(T1) UNTIL head1.typ # seqno + 10H; seqno := (seqno + 1) MOD 8; len := len + k; IF head1.typ # seqno + 10H THEN EXIT END ; IF k < PakSize THEN EXIT END END END SendData; PROCEDURE ReceiveData(F: Files.File; VAR done: BOOLEAN); VAR k, retry: INTEGER; x: CHAR; len: LONGINT; R: Files.Rider; BEGIN Files.Set(R, F, 0); seqno := 0; len := 0; retry := 4; LOOP IF head1.typ = seqno THEN seqno := (seqno + 1) MOD 8; len := len + head1.len; IF len > maxFileLen THEN Send(NAK, 0, dmy); done := FALSE; Files.Close(F); Files.Purge(F); EXIT END ; retry := 4; Send(seqno + 10H, 0, dmy); k := 0; WHILE k < head1.len DO SCC.Receive(x); Files.Write(R, x); INC(k) END ; IF k < PakSize THEN done := TRUE; EXIT END ELSE DEC(retry); IF retry = 0 THEN done := FALSE; EXIT END ; Send(seqno + 10H, 0, dmy) END ; ReceiveHead(T0) END END ReceiveData; PROCEDURE SendMail(VAR R: Files.Rider; len: LONGINT); VAR k: INTEGER; x: CHAR; BEGIN seqno := 0; LOOP k := 0; LOOP Files.Read(R, x); IF k = len THEN EXIT END ; buf[k] := SYSTEM.ROT(x, 3); INC(k); IF k = PakSize THEN EXIT END END ; REPEAT Send(seqno, k, buf); ReceiveHead(T1) UNTIL head1.typ # seqno + 10H; seqno := (seqno + 1) MOD 8; len := len - k; IF head1.typ # seqno + 10H THEN EXIT END ; IF k < PakSize THEN EXIT END END END SendMail; PROCEDURE Serve; VAR i, j, k0, k1, n, uno: INTEGER; ch: CHAR; typ: SHORTINT; done: BOOLEAN; F: Files.File; R: Files.Rider; t, d, pw, npw, pos, len: LONGINT; Id: Core.ShortName; fname: Core.Name; mdir: Core.MailDir; mrtab: Core.MResTab; BEGIN SCC.ReceiveHead(head1); IF ~head1.valid THEN RETURN END ; typ := head1.typ; IF typ = SND THEN PickS(Id); PickQ(pw); PickS(fname); SetPartner(Id); IF Core.UserNo(Id, pw) >= 0 THEN F := Files.Old(fname); IF F # NIL THEN SendData(F) ELSE Send(NAK, 0, dmy) END ELSE Send(NPR, 0, dmy) END ELSIF typ = REC THEN PickS(Id); PickQ(pw); PickS(fname); SetPartner(Id); IF ~protected & (Core.UserNo(Id, pw) >= 0) THEN F := Files.New(fname); Send(ACK, 0, dmy); ReceiveHead(T0); IF head1.valid THEN ReceiveData(F, done); IF done THEN Files.Register(F) END END ELSE Send(NPR, 0, dmy) END ELSIF typ = PRT THEN PickS(Id); PickQ(pw); SetPartner(Id); uno := Core.UserNo(Id, pw); IF uno >= 0 THEN F := Files.New(""); Send(ACK, 0, dmy); ReceiveHead(T0); IF head1.valid THEN ReceiveData(F, done); IF done THEN Files.Close(F); Core.InsertTask(Core.PrintQueue, F, Id, uno) END END ELSE Send(NPR, 0, dmy) END ELSIF typ = DEL THEN PickS(Id); PickQ(pw); PickS(fname); SetPartner(Id); IF ~protected & (Core.UserNo(Id, pw) >= 0) THEN Files.Delete(fname, i); IF i = 0 THEN Send(ACK, 0, dmy) ELSE Send(NAK, 0, dmy) END ELSE Send(NPR, 0, dmy) END ELSIF typ = FDIR THEN PickS(Id); PickQ(pw); PickS(fname); SetPartner(Id); uno := Core.UserNo(Id, pw); IF uno >= 0 THEN K := 0; seqno := 0; FileDir.Enumerate(fname, AppendDirEntry); SendBuffer(K, done) ELSE Send(NPR, 0, dmy) END ELSIF typ = MDIR THEN PickS(Id); PickQ(pw); SetPartner(Id); uno := Core.UserNo(Id, pw); IF uno >= 0 THEN IF uno # mailuno THEN Core.GetFileName(uno, fname); MF := Files.Old(fname); mailuno := uno END ; K := 0; seqno := 0; IF MF # NIL THEN Files.Set(R, MF, 32); Files.ReadBytes(R, mdir, SIZE(Core.MailDir)); i := mdir[0].next; j := 30; done := TRUE; WHILE (i # 0) & (j > 0) & done DO AppendN(i, buf, K); AppendDate(mdir[i].time, mdir[i].date, buf, K); buf[K] := " "; INC(K); AppendS(mdir[i].originator, buf, K); buf[K-1] := " "; AppendN(mdir[i].len, buf, K); buf[K] := 0DX; INC(K); IF K >= PakSize THEN SendBuffer(PakSize, done) END ; i := mdir[i].next; DEC(j) END END ; SendBuffer(K, done) ELSE Send(NPR, 0, dmy) END ELSIF typ = SML THEN (*send mail*) PickS(Id); PickQ(pw); PickW(n); SetPartner(Id); uno := Core.UserNo(Id, pw); IF uno >= 0 THEN IF uno # mailuno THEN Core.GetFileName(uno, fname); MF := Files.Old(fname); mailuno := uno END ; IF (MF # NIL) & (n > 0) & (n < 31) THEN Files.Set(R, MF, (n+1)*32); Files.ReadInt(R, i); Files.ReadInt(R, j); pos := LONG(i) * 100H; Files.ReadLInt(R, len); IF len > 0 THEN Files.Set(R, MF, pos); SendMail(R, len) ELSE Send(NAK, 0, dmy) END ELSE Send(NAK, 0, dmy) END ELSE Send(NPR, 0, dmy) END ELSIF typ = RML THEN (*receive mail*) PickS(Id); PickQ(pw); SetPartner(Id); uno := Core.UserNo(Id, pw); IF uno >= 0 THEN F := Files.New(""); Send(ACK, 0, dmy); ReceiveHead(T0); IF head1.valid THEN ReceiveData(F, done); IF done THEN Files.Close(F); Core.InsertTask(Core.MailQueue, F, Id, uno) END END ELSE Send(NPR, 0, dmy) END ELSIF typ = DML THEN (*delete mail*) PickS(Id); PickQ(pw); PickW(n); SetPartner(Id); uno := Core.UserNo(Id, pw); IF uno >= 0 THEN IF uno # mailuno THEN Core.GetFileName(uno, fname); MF := Files.Old(fname); mailuno := uno END ; IF (MF # NIL) & (n > 0) & (n < 31) THEN Files.Set(R, MF, 0); Files.ReadBytes(R, mrtab, 32); Files.ReadBytes(R, mdir, SIZE(Core.MailDir)); i := 0; k1 := 30; LOOP k0 := mdir[i].next; DEC(k1); IF (k0 = 0) OR (k1 = 0) THEN Send(NAK, 0, buf); EXIT END ; IF k0 = n THEN j := mdir[n].pos; k0 := SHORT((mdir[n].len + 255) DIV 256) + j; REPEAT INCL(mrtab[j DIV 32], j MOD 32); INC(j) UNTIL j = k0; mdir[n].len := 0; mdir[i].next := mdir[n].next; Files.Set(R, MF, 0); Files.WriteBytes(R, mrtab, 32); Files.WriteBytes(R, mdir, SIZE(Core.MailDir)); Files.Close(MF); Send(ACK, 0, dmy); EXIT END ; i := k0 END ELSE Send(NAK, 0, dmy) END ELSE Send(NPR, 0, dmy) END ELSIF typ = TRQ THEN Oberon.GetClock(t, d); SetPartner(Id); i := 0; AppendW(t, fname, 4, i); AppendW(d, fname, 4, i); Send(TIM, 8, fname) ELSIF typ = NRQ THEN i := 0; LOOP SCC.Receive(ch); Id[i] := ch; INC(i); IF ch = 0X THEN EXIT END ; IF i = 7 THEN Id[7] := 0X; EXIT END END ; WHILE i < head1.len DO SCC.Receive(ch); INC(i) END ; IF Id = Oberon.User THEN head1.dadr := head1.sadr; head1.typ := NRS; head1.len := 0; SCC.SendPacket(head1, dmy) END ELSIF typ = MSG THEN i := 0; WHILE i < head1.len DO SCC.Receive(ch); Texts.Write(W, ch); INC(i) END ; SetPartner(Id); Send(ACK, 0, dmy); EOL ELSIF typ = NPW THEN PickS(Id); PickQ(pw); uno := Core.UserNo(Id, pw); IF uno >= 0 THEN SetPartner(Id); Send(ACK, 0, dmy); ReceiveHead(T0); IF head1.typ = 0 THEN PickQ(npw); Core.SetPassword(uno, npw); Send(ACK, 0, dmy) ELSE Send(NAK, 0, dmy) END ELSE Send(NPR, 0, dmy) END ELSE SCC.Skip(head1.len) END ; Core.Collect END Serve; (*----------------------- Commands -------------------*) PROCEDURE Start*; BEGIN Oberon.Remove(handler); Oberon.Install(handler); MF := NIL; mailuno := -2; Texts.WriteString(W, "Net started (NW 15.9.93)"); EOL END Start; PROCEDURE State*; VAR RR0, RR1: SHORTINT; BEGIN SYSTEM.GET(0FFFD88H, RR0); SYSTEM.PUT(0FFFD88H, 1); SYSTEM.GET(0FFFD88H, RR1); Texts.WriteString(W, "Net state"); Texts.WriteHex(W, RR0); Texts.WriteHex(W, RR1); EOL END State; PROCEDURE Reset*; BEGIN SCC.Start(TRUE) END Reset; PROCEDURE Stop*; BEGIN Oberon.Remove(handler); Texts.WriteString(W, "Net stopped"); EOL END Stop; PROCEDURE Protect*; BEGIN protected := TRUE END Protect; PROCEDURE Unprotect*; BEGIN protected := FALSE END Unprotect; BEGIN Texts.OpenWriter(W); NEW(handler); handler.handle := Serve END NetServer. -------------------------------------------------------------------------------- /PrintServer.Mod: -------------------------------------------------------------------------------- 1 | MODULE PrintServer; (*NW 17.4.89 / 12.12.92*) IMPORT SYSTEM, Kernel, Core, Display, Printmaps, Files, Fonts, Texts, Oberon; CONST maxFnt = 32; N = 32; (*max dim of splines*) PR0 = 0FFF600H; proff = 0; prdy = 1; sbusy = 2; end = 3; (*printer status*) BMwidth = 2336; BMheight = 3425; TYPE RealVector = ARRAY N OF REAL; Poly = RECORD a, b, c, d, t: REAL END ; PolyVector = ARRAY N OF Poly; VAR W: Texts.Writer; handler: Oberon.Task; uno, nofcopies, nofpages: INTEGER; abort: BOOLEAN; process, print, wait: Oberon.Handler; PR: Files.Rider; (*print rider*) font: ARRAY maxFnt OF Fonts.Font; map: ARRAY 256 OF INTEGER; PROCEDURE circle(x0, y0, r: LONGINT); VAR x, y, u: LONGINT; BEGIN u := 1 - r; x := r; y := 0; WHILE y <= x DO Printmaps.Dot(x0+x, y0+y); Printmaps.Dot(x0+y, y0+x); Printmaps.Dot(x0-y, y0+x); Printmaps.Dot(x0-x, y0+y); Printmaps.Dot(x0-x, y0-y); Printmaps.Dot(x0-y, y0-x); Printmaps.Dot(x0+y, y0-x); Printmaps.Dot(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(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 Printmaps.Dot(x0+x, y0+y); Printmaps.Dot(x0-x, y0+y); Printmaps.Dot(x0-x, y0-y); Printmaps.Dot(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 Printmaps.Dot(x0+x, y0+y); Printmaps.Dot(x0-x, y0+y); Printmaps.Dot(x0-x, y0-y); Printmaps.Dot(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 ShowPoly(VAR p, q: Poly; lim: REAL); VAR t: REAL; BEGIN t := 0; REPEAT Printmaps.Dot(ENTIER(((p.a * t + p.b) * t + p.c) * t + p.d), ENTIER(((q.a * t + q.b) * t + q.c) * t + q.d)); t := t + 1.0 UNTIL t >= lim END ShowPoly; PROCEDURE SolveTriDiag(VAR a, b, c, y: RealVector; n: INTEGER); VAR i: INTEGER; BEGIN (*a, b, c of tri-diag matrix T; solve Ty' = y for y', assign y' to y*) i := 1; WHILE i < n DO y[i] := y[i] - c[i-1]*y[i-1]; INC(i) END ; i := n-1; y[i] := y[i]/a[i]; WHILE i > 0 DO DEC(i); y[i] := (y[i] - b[i]*y[i+1])/a[i] END END SolveTriDiag; PROCEDURE OpenSpline(VAR x, y, d: RealVector; n: INTEGER); VAR i: INTEGER; d1, d2: REAL; a, b, c: RealVector; BEGIN (*from x, y compute d = y'*) b[0] := 1.0/(x[1] - x[0]); a[0] := 2.0*b[0]; c[0] := b[0]; d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := d1; i := 1; WHILE i < n-1 DO b[i] := 1.0/(x[i+1] - x[i]); a[i] := 2.0*(c[i-1] + b[i]); c[i] := b[i]; d2 := (y[i+1] - y[i])*3.0*b[i]*b[i]; d[i] := d1 + d2; d1 := d2; INC(i) END ; a[i] := 2.0*b[i-1]; d[i] := d1; i := 0; WHILE i < n-1 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ; SolveTriDiag(a, b, c, d, n) END OpenSpline; PROCEDURE ClosedSpline(VAR x, y, d: RealVector; n: INTEGER); VAR i: INTEGER; d1, d2, hn, dn: REAL; a, b, c, w: RealVector; BEGIN (*from x, y compute d = y'*) hn := 1.0/(x[n-1] - x[n-2]); dn := (y[n-1] - y[n-2])*3.0*hn*hn; b[0] := 1.0/(x[1] - x[0]); a[0] := 2.0*b[0] + hn; c[0] := b[0]; d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := dn + d1; w[0] := 1.0; i := 1; WHILE i < n-2 DO b[i] := 1.0/(x[i+1] - x[i]); a[i] := 2.0*(c[i-1] + b[i]); c[i] := b[i]; d2 := (y[i+1] - y[i])*3.0*b[i]*b[i]; d[i] := d1 + d2; d1 := d2; w[i] := 0; INC(i) END ; a[i] := 2.0*b[i-1] + hn; d[i] := d1 + dn; w[i] := 1.0; i := 0; WHILE i < n-2 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ; SolveTriDiag(a, b, c, d, n-1); SolveTriDiag(a, b, c, w, n-1); d1 := (d[0] + d[i])/(w[0] + w[i] + x[i+1] - x[i]); i := 0; WHILE i < n-1 DO d[i] := d[i] - d1*w[i]; INC(i) END ; d[i] := d[0] END ClosedSpline; PROCEDURE CompSpline(x0, y0, n, open: INTEGER); VAR i, k: INTEGER; dx, dy, ds: REAL; x, xd, y, yd, s: RealVector; p, q: PolyVector; BEGIN (*from u, v compute x, y, s*) Files.ReadInt(PR, k); x[0] := k + x0; Files.ReadInt(PR, k); y[0] := k + y0; s[0] := 0; i := 1; WHILE i < n DO Files.ReadInt(PR, k); x[i] := k + x0; dx := x[i] - x[i-1]; Files.ReadInt(PR, k); y[i] := k + y0; dy := y[i] - y[i-1]; s[i] := ABS(dx) + ABS(dy) + s[i-1]; INC(i) END ; IF open = 1 THEN OpenSpline(s, x, xd, n); OpenSpline(s, y, yd, n) ELSE ClosedSpline(s, x, xd, n); ClosedSpline(s, y, yd, n) END ; (*compute coefficients from x, y, xd, yd, s*) i := 0; WHILE i < n-1 DO ds := 1.0/(s[i+1] - s[i]); dx := (x[i+1] - x[i])*ds; p[i].a := ds*ds*(xd[i] + xd[i+1] - 2.0*dx); p[i].b := ds*(3.0*dx - 2.0*xd[i] -xd[i+1]); p[i].c := xd[i]; p[i].d := x[i]; p[i].t := s[i]; dy := ds*(y[i+1] - y[i]); q[i].a := ds*ds*(yd[i] + yd[i+1] - 2.0*dy); q[i].b := ds*(3.0*dy - 2.0*yd[i] - yd[i+1]); q[i].c := yd[i]; q[i].d := y[i]; q[i].t := s[i]; INC(i) END ; p[i].t := s[i]; q[i].t := s[i]; (*display polynomials*) i := 0; WHILE i < n-1 DO ShowPoly(p[i], q[i], p[i+1].t - p[i].t); INC(i) END END CompSpline; PROCEDURE Terminate; VAR i: INTEGER; BEGIN Core.RemoveTask(Core.PrintQueue); i := 0; REPEAT font[i] := NIL; INC(i) UNTIL i = maxFnt (*release fonts*) END Terminate; PROCEDURE Append(src: ARRAY OF CHAR; VAR dst: ARRAY OF SYSTEM.BYTE; VAR k: INTEGER); VAR i: INTEGER; ch: CHAR; BEGIN i := 0; REPEAT ch := src[i]; dst[k] := ch; INC(i); INC(k) UNTIL ch = 0X END Append; PROCEDURE PickTask; VAR F: Files.File; Id: Core.ShortName; tag: CHAR; BEGIN IF (Core.PrintQueue.n > 0) & ~SYSTEM.BIT(PR0, proff) & SYSTEM.BIT(PR0, prdy) THEN Core.GetTask(Core.PrintQueue, F, Id, uno); nofpages := 0; abort := FALSE; Files.Set(PR, F, 0); Files.Read(PR, tag); IF tag = 0FCX THEN handler.handle := process ELSE Texts.WriteString(W, Id); Texts.WriteString(W, " not a print file"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Terminate END END END PickTask; PROCEDURE ProcessPage; VAR i, x, y, w, h, x0, x1, y0, y1: INTEGER; a, a0, a1: LONGINT; d, u: INTEGER; typ, sp: SHORTINT; ch: CHAR; fnt: Fonts.Font; fname: Core.Name; PROCEDURE String; VAR ch: CHAR; dx, x0, y0, w, h: INTEGER; fnt: Fonts.Font; pat: LONGINT; BEGIN fnt := font[sp MOD maxFnt]; IF (x >= 0) & (y >= 0) & (fnt # NIL) & (y + fnt.height < BMheight) THEN LOOP Files.Read(PR, ch); IF ch = 0X THEN EXIT END ; Display.GetChar(fnt.raster, ch, dx, x0, y0, w, h, pat); IF (x + x0 + w <= BMwidth) & (h > 0) THEN Printmaps.CopyPattern(pat, x+x0, y+y0) END ; INC(x, dx) END END END String; BEGIN Printmaps.ClearPage; LOOP Files.Read(PR, typ); IF PR.eof THEN Core.IncPageCount(uno, nofpages); Terminate; handler.handle := PickTask; EXIT END ; Files.Read(PR, sp); IF typ = 0 THEN String ELSIF typ = 1 THEN Files.ReadInt(PR, x); Files.ReadInt(PR, y); String ELSIF typ = 2 THEN Files.ReadInt(PR, x); Files.ReadInt(PR, y); Files.ReadInt(PR, w); Files.ReadInt(PR, h); IF x < 0 THEN INC(w, x); x := 0 END ; IF x+w > BMwidth THEN w := BMwidth - x END ; IF y < 0 THEN INC(h, y); y := 0 END ; IF y+h > BMheight THEN h := BMheight - y END ; Printmaps.ReplConst(x, y, w, h) ELSIF typ = 3 THEN i := 0; REPEAT Files.Read(PR, fname[i]); INC(i) UNTIL fname[i-1] < "0"; DEC(i); Append(".Pr3.Fnt", fname, i); fnt := Fonts.This(fname); IF fnt = Fonts.Default THEN fnt := Fonts.This("Syntax10.Pr3.Fnt") END ; font[sp MOD maxFnt] := fnt ELSIF typ = 4 THEN nofcopies := sp; handler.handle := print; EXIT ELSIF typ = 5 THEN (*shaded area*) IF (sp < 0) OR (sp > 9) THEN sp := 2 END ; Files.ReadInt(PR, x); Files.ReadInt(PR, y); Files.ReadInt(PR, w); Files.ReadInt(PR, h); IF x < 0 THEN INC(w, x); x := 0 END ; IF x+w > BMwidth THEN w := BMwidth - x END ; IF y < 0 THEN INC(h, y); y := 0 END ; IF y+h > BMheight THEN h := BMheight - y END ; Printmaps.ReplPattern(Printmaps.Pat[sp], x, y, w, h) ELSIF typ = 6 THEN (*line*) Files.ReadInt(PR, x0); Files.ReadInt(PR, y0); Files.ReadInt(PR, x1); Files.ReadInt(PR, y1); w := ABS(x1-x0); h := ABS(y1-y0); IF h <= w THEN IF x1 < x0 THEN u := x0; x0 := x1; x1 := u; u := y0; y0 := y1; y1 := u END ; IF y0 <= y1 THEN d := 1 ELSE d := -1 END ; u := (h-w) DIV 2; WHILE x0 < x1 DO Printmaps.Dot(x0, y0); INC(x0); IF u < 0 THEN INC(u, h) ELSE INC(u, h-w); INC(y0, d) END END ELSE IF y1 < y0 THEN u := x0; x0 := x1; x1 := u; u := y0; y0 := y1; y1 := u END ; IF x0 <= x1 THEN d := 1 ELSE d := -1 END ; u := (w-h) DIV 2; WHILE y0 < y1 DO Printmaps.Dot(x0, y0); INC(y0); IF u < 0 THEN INC(u, w) ELSE INC(u, w-h); INC(x0, d) END END END ELSIF typ = 7 THEN (*ellipse*) Files.ReadInt(PR, x); Files.ReadInt(PR, y); Files.ReadInt(PR, w); Files.ReadInt(PR, h); ellipse(x, y, w, h) ELSIF typ = 8 THEN (*picture*) Files.ReadInt(PR, x); Files.ReadInt(PR, y); Files.ReadInt(PR, w); Files.ReadInt(PR, h); IF sp = 1 THEN (*enlarge factor 2*) IF (x >= 0) & (w+x < BMwidth DIV 2) & (y >= 0) & (h+y < BMheight DIV 2) THEN a := Printmaps.Map() + LONG(BMheight -1 - y)*(BMwidth DIV 8) + (x DIV 4); w := (w + 7) DIV 8 * 2; WHILE h > 0 DO a0 := a; a1 := a + w; WHILE a0 < a1 DO Files.Read(PR, ch); SYSTEM.PUT(a0, map[ORD(ch)]); SYSTEM.PUT(a0 + (BMwidth DIV 8), map[ORD(ch)]); INC(a0, 2) END ; DEC(a, BMwidth DIV 4); DEC(h) END END ELSIF (x >= 0) & (w+x < BMwidth) & (y >= 0) & (h+y < BMheight) THEN a := Printmaps.Map() + LONG(BMheight -1 - y)*(BMwidth DIV 8) + (x DIV 8); w := (w + 7) DIV 8; WHILE h > 0 DO a0 := a; a1 := a + w; WHILE a0 < a1 DO Files.Read(PR, ch); SYSTEM.PUT(a0, ch); INC(a0) END ; DEC(a, BMwidth DIV 8); DEC(h) END END ELSIF typ = 9 THEN (*circle*) Files.ReadInt(PR, x); Files.ReadInt(PR, y); Files.ReadInt(PR, w); circle(x, y, w) ELSIF typ = 10 THEN (*spline*) Files.ReadInt(PR, x); Files.ReadInt(PR, y); Files.ReadInt(PR, u); IF (u >= 0) & (u <= N) THEN CompSpline(x, y, u, sp) ELSE Files.Set(PR, Files.Base(PR), Files.Pos(PR) + 4*u) (*skip*) END ELSIF typ = 11 THEN (*set color*) Files.Read(PR, ch); Files.Read(PR, ch) ELSE Texts.WriteString(W, " error in print file at"); Texts.WriteInt(W, Files.Pos(PR), 6); Texts.WriteInt(W, typ, 5); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Terminate; handler.handle := PickTask; EXIT END END END ProcessPage; PROCEDURE PrintPage; BEGIN IF SYSTEM.BIT(PR0, prdy) THEN SYSTEM.PUT(PR0, Kernel.PrAdr); handler.handle := wait; REPEAT UNTIL SYSTEM.BIT(PR0, end) END END PrintPage; PROCEDURE WaitForCompletion; BEGIN IF ~SYSTEM.BIT(PR0, end) THEN DEC(nofcopies); INC(nofpages); IF abort THEN Terminate; handler.handle := PickTask; Texts.WriteString(W, " print task aborted"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); ELSIF nofcopies > 0 THEN handler.handle := print; DEC(nofcopies) ELSE handler.handle := ProcessPage END END END WaitForCompletion; (*------------------------ Commands -------------------------*) PROCEDURE Start*; BEGIN IF ~SYSTEM.BIT(PR0, proff) THEN handler.handle := PickTask; Oberon.Remove(handler); Oberon.Install(handler); Texts.WriteString(W, "Printer started (NW 12.12.92)") ELSE Texts.WriteString(W, "Printer off") END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END Start; PROCEDURE State*; BEGIN Texts.WriteString(W, "Printer Queue:"); Texts.WriteInt(W, Core.PrintQueue.n, 4); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END State; PROCEDURE Reset*; BEGIN handler.handle := PickTask; END Reset; PROCEDURE Abort*; BEGIN abort := TRUE END Abort; PROCEDURE Stop*; BEGIN Oberon.Remove(handler); Texts.WriteString(W, "Printer stopped"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END Stop; PROCEDURE RemoveTask*; VAR F: Files.File; id: Core.ShortName; uno: INTEGER; BEGIN IF Core.PrintQueue.n > 0 THEN Core.GetTask(Core.PrintQueue, F, id, uno); Core.RemoveTask(Core.PrintQueue); Texts.WriteString(W, id); Texts.WriteString(W, " print task removed"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END END RemoveTask; PROCEDURE InitMap; (*map for picture enlargement and patterns*) VAR i, k, s, t: INTEGER; BEGIN i := 0; REPEAT k := i; s := 0; t := 3; WHILE k > 0 DO IF ODD(k) THEN INC(s, t) END ; t := 4*t; k := k DIV 2 END ; map[i] := s; INC(i) UNTIL i = 256 END InitMap; BEGIN Texts.OpenWriter(W); InitMap; NEW(handler); process := ProcessPage; print := PrintPage; wait := WaitForCompletion END PrintServer. --------------------------------------------------------------------------------