Syntax10.Scn.Fnt@DqHistoryElemsNewHistory*Syntax10.Scn.FntEF16: System.Directory xyz: avoid trap if directory xyz does not exist 17: remove MayUnload again (not appropriate for programming exercises)]pVersionElemsAllocBeg#Syntax10.Scn.FntWindows PowerMacWindowsWindows PowerMac#Syntax10.Scn.FntINTEGERpVersionElemsAllocEnd|p#Syntax10.Scn.FntWindows PowerMacWindowsWindows PowerMac peMarkElemsAllocGHbIDJKL_MNzOPQR{STUMVOW:X58FoldElemsNewN8 Syntax10b.Scn.Fnt8=8)Syntax10i.Scn.FntR8+85cp#Syntax10.Scn.FntWindows PowerMac WithOutputWindowsWindows PowerMac#Syntax10.Scn.FntModulesWithOutput pE`p#Syntax10.Scn.FntWindows PowerMac WithOutputWindowsWindows PowerMac#Syntax10.Scn.Fnt m.SB, m.PCWithOutput p dp#Syntax10.Scn.FntWindows PowerMac WithOutputWindowsWindows PowerMac#Syntax10.Scn.Fntm.linkWithOutput p 8(8p#Syntax10.Scn.FntWindows PowerMacWindowsWindows PowerMac pp#Syntax10.Scn.FntWindows PowerMac WithOutputWindowsWindows PowerMacCSyntax10.Scn.FntlSyntax10b.Scn.FntIF kind IN {Platform.TObj, Platform.TArrP, Platform.TTypDesc} THEN IF ProcVarsIn(ptr, ptr + size) THEN RETURN TRUE END END;WithOutput z{xapo8fp#Syntax10.Scn.FntWindows PowerMac WithOutputWindowsWindows PowerMac#Syntax10.Scn.Fntm.PCWithOutput p`p#Syntax10.Scn.FntWindows PowerMac WithOutputWindowsWindows PowerMac#Syntax10.Scn.Fnt m.codesizeWithOutput  pQ8 886aap#Syntax10.Scn.FntWindows PowerMac WithOutputWindowsWindows PowerMac#Syntax10.Scn.Fnt m.nofimpsWithOutput p Np#Syntax10.Scn.FntWindows PowerMac WithOutputWindowsWindows PowerMac#Syntax10.Scn.FntS.GET(m.imports + 4*i, imp);WithOutput +pR"_88'!8Q8 d[\B!]^#)// ^MODULE System; (*JG/NW; MH 13.9.93 / 6.5.94 *)(* MAH 20.07.94 *) IMPORT S := SYSTEM, Win32, Kernel, Registry, Modules, Directories, Files, Input, Display, Viewers, MenuViewers, Oberon, Fonts, Texts, TextFrames, Console, Strings, CtrlC, Ref, RefElems, Types, Platform, In; CONST Version = "V4.0-2.3"; StandardMenu = "^Trap.Menu.Text"; (*System.Close System.Copy System.Grow Edit.Store ";*) dateOpt = 1; sizeOpt = 2; allPaths = 3; (* Directory Options *) delimiter = Directories.delimiter; VAR T: Texts.Text; Sx: Texts.Scanner; InSelection: BOOLEAN; SelEnd: LONGINT; W: Texts.Writer; pattern: ARRAY 256 OF CHAR; (* search pattern for Directory command *) options: SET; (*options in System.Directory*) startupDone: BOOLEAN; (* state in System.Directory *) oldTrapHandler: Win32.TrapHandler; fpuControl: INTEGER; (* TYPE Module = POINTER TO ModuleDesc; ModuleDesc = RECORD m: Modules.Module; refcnt: LONGINT; next: Module END ; VAR args: Module; (*arguments of System.Free*) back: Module; (*for restoring reference counts*) modTD: Types.Type; unloadAll: BOOLEAN; *) PROCEDURE WriteName (VAR w: Texts.Writer; name: ARRAY OF CHAR; extraChar: CHAR); VAR ch: CHAR; i: INTEGER; quote: CHAR; BEGIN ch := name[0]; i := 0; quote := '"'; WHILE (ch # 0X) & (("a" <= ch) & (ch <= "z") OR ("A" <= ch) & (ch <= "Z") OR (ch = ".") OR (ch = "/") OR (ch = "$") OR (i > 0) & (("0" <= ch) & (ch <= "9") OR (ch = ":") OR (ch = extraChar))) DO IF ch = '"' THEN quote := "'" ELSIF ch = "'" THEN quote := '"' END ; INC(i); ch := name[i] END ; IF ch # 0X THEN Texts.Write(w, quote) END ; Texts.WriteString(w, name); IF ch # 0X THEN Texts.Write(w, quote) END END WriteName; PROCEDURE OpenArgs (VAR S: Texts.Scanner); VAR beg, time: LONGINT; T: Texts.Text; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); InSelection := FALSE; IF (S.class = Texts.Char) & (S.c = "^") THEN InSelection := TRUE; Oberon.GetSelection(T, beg, SelEnd, time); IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) ELSE S.class := Texts.Inval; END END END OpenArgs; PROCEDURE Max (i, j: LONGINT): LONGINT; BEGIN IF i >= j THEN RETURN i ELSE RETURN j END END Max; PROCEDURE SysOpen (text: Texts.Text; name: ARRAY OF CHAR; at: INTEGER); VAR V: Viewers.Viewer; X, Y: INTEGER; M: TextFrames.Frame; BEGIN Oberon.AllocateSystemViewer(at, X, Y); M := TextFrames.NewMenu(name, "^System.Menu.Text"); V := MenuViewers.New(M, TextFrames.NewText(text, 0), TextFrames.menuH, X, Y) END SysOpen; PROCEDURE Open*; BEGIN OpenArgs(Sx); IF (Sx.class = Texts.Name) OR (Sx.class = Texts.String) THEN SysOpen(TextFrames.Text(Sx.s), Sx.s, Oberon.Par.vwr.X) END ; END Open; PROCEDURE LogHandler (F: Display.Frame; VAR M: Display.FrameMsg); VAR r: Texts.Reader; pos, oldpos, last: LONGINT; ch: CHAR; BEGIN WITH F: TextFrames.Frame DO TextFrames.Handle(F, M); IF M IS TextFrames.UpdateMsg THEN WITH M : TextFrames.UpdateMsg DO IF (M.id = TextFrames.insert) & (M.end = Oberon.Log.len) THEN last := TextFrames.Pos(F, MAX(INTEGER), F.Y); IF last < Oberon.Log.len-1 THEN Oberon.RemoveMarks(F.X, F.Y, F.W, F.H); TextFrames.RemoveSelection(F); TextFrames.RemoveCaret(F); pos := last; REPEAT oldpos := pos; IF last + 2 < M.beg THEN pos := M.beg; TextFrames.Show(F, pos) ELSE Texts.OpenReader(r, Oberon.Log, F.org); REPEAT Texts.Read(r, ch) UNTIL r.eot OR (ch = 0DX); pos := Texts.Pos(r); TextFrames.Show(F, pos) END ; last := TextFrames.Pos(F, MAX(INTEGER), F.Y) UNTIL (last >= Oberon.Log.len-1) OR (oldpos = pos) END END END END END END LogHandler; PROCEDURE OpenLog*; VAR logV: Viewers.Viewer; X, Y: INTEGER; F, M: TextFrames.Frame; BEGIN Oberon.AllocateSystemViewer(0, X, Y); F := TextFrames.NewText(Oberon.Log, Max(0, Oberon.Log.len - 200)); F.handle := LogHandler; M := TextFrames.NewMenu("System.Log", "^Log.Menu.Text"); logV := MenuViewers.New(M, F, TextFrames.menuH, X, Y) END OpenLog; PROCEDURE Close*; VAR par: Oberon.ParList; V: Viewers.Viewer; BEGIN par := Oberon.Par; V := NIL; IF par.frame = par.vwr.dsc THEN V := par.vwr ELSIF Oberon.Pointer.on THEN V := Oberon.MarkedViewer() END ; IF V # NIL THEN Viewers.Close(V) END ; END Close; PROCEDURE CloseTrack*; VAR V: Viewers.Viewer; BEGIN V := Oberon.MarkedViewer(); Viewers.CloseTrack(V.X) END CloseTrack; PROCEDURE Recall*; VAR V: Viewers.Viewer; M: Viewers.ViewerMsg; BEGIN Viewers.Recall(V); IF (V # NIL) & (V.state = 0) THEN Viewers.Open(V, V.X, V.Y + V.H); M.id := Viewers.restore; V.handle(V, M) END END Recall; PROCEDURE Copy*; VAR V, V1: Viewers.Viewer; M: Oberon.CopyMsg; N: Viewers.ViewerMsg; BEGIN V := Oberon.Par.vwr; V.handle(V, M); V1 := M.F(Viewers.Viewer); Viewers.Open(V1, V.X, V.Y + V.H DIV 2); N.id := Viewers.restore; V1.handle(V1, N) END Copy; PROCEDURE Grow*; VAR V, V1: Viewers.Viewer; M: Oberon.CopyMsg; N: Viewers.ViewerMsg; DW, DH: INTEGER; BEGIN V := Oberon.Par.vwr; DW := Oberon.DisplayWidth(V.X); DH := Oberon.DisplayHeight(V.X); IF V.H < DH - Viewers.minH THEN Oberon.OpenTrack(V.X, V.W) ELSIF V.W < DW THEN Oberon.OpenTrack(Oberon.UserTrack(V.X), DW) END ; IF (V.H < DH - Viewers.minH) OR (V.W < DW) THEN V.handle(V, M); V1 := M.F(Viewers.Viewer); Viewers.Open(V1, V.X, DH); N.id := Viewers.restore; V1.handle(V1, N) END END Grow; PROCEDURE SetFont*; BEGIN OpenArgs(Sx); IF Sx.class = Texts.Name THEN Oberon.SetFont(Fonts.This(Sx.s)) END END SetFont; PROCEDURE SetColor*; BEGIN OpenArgs(Sx); IF Sx.class = Texts.Int THEN Oberon.SetColor(SHORT(SHORT(Sx.i))) END ; END SetColor; PROCEDURE SetOffset*; BEGIN OpenArgs(Sx); IF Sx.class = Texts.Int THEN Oberon.SetOffset(SHORT(SHORT(Sx.i))) END ; END SetOffset; PROCEDURE Time*; VAR t, d, hr, min, sec, yr, mo, day: LONGINT; BEGIN OpenArgs(Sx); IF Sx.class = Texts.Int THEN (*set date*) day := Sx.i; Texts.Scan(Sx); mo := Sx.i; Texts.Scan(Sx); yr := Sx.i; Texts.Scan(Sx); hr := Sx.i; Texts.Scan(Sx); min := Sx.i; Texts.Scan(Sx); sec := Sx.i; IF Sx.class = Texts.Int THEN t := (hr*64 + min)*64 + sec; d := (yr*16 + mo)*32 + day; Kernel.SetClock(t, d) END ; ELSE (*read date*) Texts.WriteString(W, "System.Time"); Oberon.GetClock(t, d); Texts.WriteDate(W, t, d); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END END Time; PROCEDURE Watch*; VAR avail: LONGINT; BEGIN Texts.WriteString(W, "System.Watch"); Texts.WriteLn(W); avail := Kernel.Available(); Texts.WriteString(W, " heap size: "); Texts.WriteInt(W, Kernel.heapSize, 0); Texts.WriteLn(W); Texts.WriteString(W, " bytes allocated: "); Texts.WriteInt(W, Kernel.heapSize - avail, 0); Texts.WriteLn(W); Texts.WriteString(W, " available: "); Texts.WriteInt(W, avail, 0); Texts.WriteLn(W); Texts.WriteString(W, " largest available: "); Texts.WriteInt(W, Kernel.LargestAvailable(), 0); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END Watch; PROCEDURE Collect*; BEGIN Oberon.Collect(0) END Collect; PROCEDURE ShowMods (VAR W: Texts.Writer); CONST TAB = 09X; VAR m: Kernel.Module; copy: Texts.CopyMsg; parc: TextFrames.Parc; BEGIN TextFrames.defParc.handle(TextFrames.defParc, copy); parc := copy.e(TextFrames.Parc); parc.nofTabs := 3; parc.tab[0] := 1152000; parc.tab[1] := 2232000; parc.tab[2] := 3312000; Texts.WriteElem(W, parc); m := Kernel.modules; WHILE m # NIL DO Texts.WriteString(W, m.name); Texts.Write(W, TAB); Texts.WriteString(W, "codesize = "); Texts.WriteInt(W, LEN(m.code^), 0); Texts.Write(W, TAB); Texts.WriteString(W, "datasize = "); Texts.WriteInt(W, LEN(m.data^), 0); Texts.Write(W, TAB); Texts.WriteString(W, "refcnt = "); Texts.WriteInt(W, m.refcnt, 0); Texts.WriteLn(W); m := m.next; END ; END ShowMods; (* PROCEDURE MayUnload (m: Modules.Module): BOOLEAN;  VAR beg, end: LONGINT; PROCEDURE ProcVarsIn (from, to: LONGINT): BOOLEAN;  VAR p, i: LONGINT; r: Ref.Rider; BEGIN FOR i := from TO to-4 BY 4 DO S.GET(i, p); IF (p >= beg) & (p <= end) THEN Ref.OpenProc(p, r); IF (r.mode # Ref.End) & (r.pc = p) THEN Console.Str(r.mod); Console.Str("."); Console.Str(r.name); Console.Ln; RETURN TRUE END END END ; RETURN FALSE END ProcVarsIn;  PROCEDURE ProcVarsInSysBlock (from, to: LONGINT): BOOLEAN;  VAR mod: Platform.Module; BEGIN (* Do not check module blocks (which are also part of the Oberon heap under Windows). *) mod := Platform.GetModules(); WHILE (mod # NIL) & (from <= S.VAL(LONGINT, mod.code)) & (S.VAL(LONGINT, mod.code) <= to) DO mod := mod.next END ; IF mod = NIL THEN RETURN ProcVarsIn(from, to) ELSE RETURN FALSE END END ProcVarsInSysBlock;  PROCEDURE ProcVarsInGlobals (): BOOLEAN;  VAR m: Modules.Module; arg: Module; BEGIN m := Kernel.modules; WHILE m # NIL DO arg := args; WHILE (arg # NIL) & (m # arg.m) DO arg := arg.next END ; IF (arg = NIL) & ProcVarsIn(S.ADR(m.data^), m.sb) THEN RETURN TRUE END ; m := m.next END ; RETURN FALSE END ProcVarsInGlobals;  PROCEDURE ProcVarsInHeap (): BOOLEAN;  CONST Bminus1 = Platform.B - 1; VAR p, lastBlock: Platform.Blockm4Ptr; heapNo: INTEGER; ptr, tdesc, size: LONGINT; kind: INTEGER; td: Types.Type; BEGIN heapNo := 0; WHILE Platform.GetNextMemBlock(p, lastBlock, heapNo) DO WHILE p # lastBlock DO ptr := S.VAL(LONGINT, p) + 4; kind := Platform.GetObjType(S.VAL(S.PTR, ptr), S.VAL(Platform.Tag, tdesc), size); IF kind = Platform.TObj THEN S.GET(tdesc - 4, td); IF td # modTD THEN IF ProcVarsIn(ptr, ptr + size) THEN RETURN TRUE END (* ELSE do not check module descriptors as they have a pointer to the beginning of the code block and the termination handler *) END ; ELSIF kind IN {Platform.TArrP, Platform.TTypDesc} THEN IF ProcVarsIn(ptr, ptr + size) THEN RETURN TRUE END ELSIF kind = Platform.TSysBl THEN IF ProcVarsInSysBlock(ptr, ptr + size) THEN RETURN TRUE END END ; INC(S.VAL(LONGINT, p), S.VAL(LONGINT, S.VAL(SET, size + Bminus1) - S.VAL(SET, Bminus1))) END END ; RETURN FALSE END ProcVarsInHeap;  BEGIN beg := S.ADR(m.code^) + 1; end := beg + LEN(m.code^); RETURN unloadAll OR ~ ProcVarsInGlobals() & ~ ProcVarsInHeap() END MayUnload;  PROCEDURE Free*;  VAR par: Oberon.ParList; T: Texts.Text; s: Texts.Scanner; beg, end, time: LONGINT; F: TextFrames.Frame; line: INTEGER; tail: Module; PROCEDURE Add (m: Modules.Module; all: BOOLEAN);  VAR imp: Modules.Module; p, q: Module; i: LONGINT; m1: Platform.Module; (*blue changes only because PowerMac modules export refcnt as read only*) BEGIN IF m # NIL THEN NEW(p); p.m := m; IF args = NIL THEN args := p ELSE tail.next := p END ; tail := p; IF all THEN FOR i := 1 TO LEN(m.imports^) - 1 DO imp := S.VAL(Modules.Module, m.imports[i]); NEW(q); q.m := imp; q.refcnt := imp.refcnt; q.next := back; back := q; m1 := S.VAL(Platform.Module, imp); DEC(m1.refcnt); IF imp.refcnt = 0 THEN Add(imp, TRUE) END END END END END Add;  PROCEDURE FreeModules;  VAR p: Module; m: Platform.Module; BEGIN p := back; WHILE p # NIL DO m := S.VAL(Platform.Module, p.m); m.refcnt := p.refcnt; p := p.next END ; p := args; WHILE p # NIL DO Texts.WriteString(W, p.m.name); Texts.WriteString(W, " unloading"); Modules.Free(p.m.name, FALSE); CASE Modules.res OF Modules.done: | Modules.modNotFound: Texts.WriteString(W, " failed (module not found)") | Modules.refCntNotZero: Texts.WriteString(W, " failed (reference count not zero)") | Modules.codeReferenced: Texts.WriteString(W, " failed (code referenced, e.g. by procedure variables or methods)") ELSE Texts.WriteString(W, " failed") END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); p := p.next END END FreeModules;  BEGIN Texts.WriteString(W, "System.Free"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); args := NIL; back := NIL; par := Oberon.Par; IF par.vwr.dsc = par.frame THEN F := par.frame.next(TextFrames.Frame); IF F.hasSel THEN end := F.selend.pos; beg := F.selbeg.pos; Texts.OpenScanner(s, F.text, beg); Texts.Scan(s); WHILE (s.class = Texts.Name) & (beg < end) DO Add(Modules.ThisMod(s.s), FALSE); line := s.line; REPEAT beg := Texts.Pos(s); Texts.Scan(s) UNTIL (s.line # line) OR s.eot; END ; FreeModules; ShowMods(W); Texts.Delete(F.text, 0, F.text.len); Texts.Append(F.text, W.buf); ELSE RETURN END ; ELSE Texts.OpenScanner(s, par.text, 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 ; WHILE (s.class = Texts.Name) & (s.s # "System.Free") DO Add(Modules.ThisMod(s.s), s.nextCh = "*"); IF s.nextCh = "*" THEN Texts.Scan(s) END ; Texts.Scan(s) END ; FreeModules END ; args := NIL; back := NIL END Free;  PROCEDURE Unload*; VAR all: ARRAY 10 OF CHAR; BEGIN In.Open; In.Name(all); unloadAll := all = "all" END Unload; *) PROCEDURE FreeMod (VAR S: Texts.Scanner); BEGIN Texts.WriteString(W, S.s); Texts.WriteString(W, " unloading"); Texts.Append(Oberon.Log, W.buf); IF S.nextCh # "*" THEN Modules.Free(S.s, FALSE) ELSE Modules.Free(S.s, TRUE); Texts.Scan(S); Texts.WriteString(W, " all") END ; IF Modules.res # 0 THEN Texts.WriteString(W, " failed"); Modules.res := 0 END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END FreeMod; PROCEDURE Free*; VAR par: Oberon.ParList; T: Texts.Text; S: Texts.Scanner; beg, end, time: LONGINT; F: TextFrames.Frame; line: INTEGER; BEGIN Texts.WriteString(W, "System.Free"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); par := Oberon.Par; IF par.vwr.dsc = par.frame THEN F := par.frame.next(TextFrames.Frame); IF F.hasSel THEN end := F.selend.pos; Texts.OpenScanner(S, F.text, F.selbeg.pos); beg := Texts.Pos(S); Texts.Scan(S); WHILE (S.class = Texts.Name) & (beg < end) DO FreeMod(S); line := S.line; REPEAT beg := Texts.Pos(S); Texts.Scan(S); UNTIL (S.line # line) OR S.eot; END ; ShowMods(W); Texts.Delete(F.text, 0, F.text.len); Texts.Append(F.text, W.buf); ELSE RETURN END ; ELSE Texts.OpenScanner(S, par.text, par.pos); Texts.Scan(S); WHILE (S.class = Texts.Name) & (S.s # "System.Free") DO FreeMod(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 FreeMod(S) END END END END END Free; PROCEDURE ShowModules*; VAR T: Texts.Text; V: Viewers.Viewer; X, Y: INTEGER; BEGIN T := TextFrames.Text(""); Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y); V := MenuViewers.New(TextFrames.NewMenu("System.ShowModules", "System.Close System.Copy System.Free Edit.Search Edit.Replace Edit.Store"), TextFrames.NewText(T, 0), TextFrames.menuH, X, Y); ShowMods(W); Texts.Append(T, W.buf) END ShowModules; PROCEDURE ShowCommands*; VAR M: Kernel.Module; i: LONGINT; T: Texts.Text; (*V: Viewers.Viewer; X, Y: INTEGER;*) BEGIN OpenArgs(Sx); IF Sx.class = Texts.Name THEN i := 0; WHILE Sx.s[i] >= "0" DO INC(i) END ; Sx.s[i] := 0X; M := Modules.ThisMod(Sx.s); IF M # NIL THEN T := TextFrames.Text(""); SysOpen(T, "System.ShowCommands", Oberon.Mouse.X); (* Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y); V := MenuViewers.New( TextFrames.NewMenu("System.Commands", StandardMenu), TextFrames.NewText(T, 0), TextFrames.menuH, X, Y); *) i := 0; WHILE i < LEN(M.cmds^) DO Texts.WriteString(W, M.name); Texts.Write(W, "."); Texts.WriteString(W, M.cmds[i].name); Texts.WriteLn(W); INC(i) END ; Texts.Append(T, W.buf) END END END ShowCommands; PROCEDURE SetUser*; VAR i: INTEGER; ch: CHAR; user: ARRAY 8 OF CHAR; password: ARRAY 16 OF CHAR; BEGIN i := 0; Input.Read(ch); WHILE (ch # "/") & (i < 7) DO user[i] := ch; INC(i); Input.Read(ch) END ; user[i] := 0X; i := 0; Input.Read(ch); WHILE (ch > " ") & (i < 15) DO password[i] := ch; INC(i); Input.Read(ch) END ; password[i] := 0X; Oberon.SetUser(user, password) END SetUser; PROCEDURE ChangeDir*; VAR dir: Directories.Directory; BEGIN OpenArgs(Sx); Texts.WriteString(W, "System.ChangeDir"); IF Sx.class IN {Texts.Name, Texts.String} THEN dir := Directories.This(Sx.s); IF dir = NIL THEN Texts.WriteString(W, " "); WriteName(W, Sx.s, 0X); Texts.WriteString(W, " not found"); ELSE Texts.WriteString(W, " " ); WriteName(W, dir.path, 0X); Directories.Change(Sx.s); IF Directories.res # Directories.noErr THEN Texts.WriteString(W, " -- failed") END END ; ELSE Texts.WriteString(W, " failed"); END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); END ChangeDir; PROCEDURE CreateDir*; BEGIN OpenArgs(Sx); IF Sx.class IN {Texts.Name, Texts.String} THEN Texts.WriteString(W, "System.CreateDir "); WriteName(W, Sx.s, 0X); Directories.Create(Sx.s); IF Directories.res # Directories.noErr THEN Texts.WriteString(W, " failed") END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); END END CreateDir; PROCEDURE DeleteDir*; BEGIN OpenArgs(Sx); IF Sx.class IN {Texts.Name, Texts.String} THEN Texts.WriteString(W, "System.DeleteDir "); WriteName(W, Sx.s, 0X); Directories.Delete(Sx.s); IF Directories.res # Directories.noErr THEN Texts.WriteString(W, " failed") END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); END END DeleteDir; PROCEDURE CopyFile (name: ARRAY OF CHAR; VAR S: Texts.Scanner); CONST N = 2048; VAR f, g: Files.File; Rf, Rg: Files.Rider; buf: ARRAY N OF CHAR; n, remaining: LONGINT; BEGIN Texts.Scan(S); IF (S.class = Texts.Char) & (S.c = "=") THEN Texts.Scan(S); IF (S.class = Texts.Char) & (S.c = ">") THEN Texts.Scan(S); IF S.class IN {Texts.Name, Texts.String} THEN WriteName(W, name, 0X); Texts.WriteString(W, " => "); WriteName(W, S.s, 0X); Texts.WriteString(W, " copying"); Texts.Append(Oberon.Log, W.buf); f := Files.Old(name); IF f # NIL THEN g := Files.New(S.s); IF g # NIL THEN Files.Set(Rf, f, 0); Files.Set(Rg, g, 0); remaining := Files.Length(f); WHILE remaining > 0 DO IF remaining > N THEN n := N ELSE n := remaining END ; Files.ReadBytes(Rf, buf, n); Files.WriteBytes(Rg, buf, n); DEC(remaining, n); END ; Files.Register(g) ELSE Texts.WriteString(W, " failed") END ELSE Texts.WriteString(W, " failed") END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END END END END CopyFile; PROCEDURE CopyFiles*; BEGIN OpenArgs(Sx); Texts.WriteString(W, "System.CopyFiles"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); WHILE (Sx.class IN {Texts.Name, Texts.String}) & (~InSelection OR (Texts.Pos(Sx) <= SelEnd+1)) DO CopyFile(Sx.s, Sx); Texts.Scan(Sx) END END CopyFiles; PROCEDURE RenameFile (name: ARRAY OF CHAR; VAR S: Texts.Scanner); VAR res: INTEGER; BEGIN Texts.Scan(S); IF (S.class = Texts.Char) & (S.c = "=") THEN Texts.Scan(S); IF (S.class = Texts.Char) & (S.c = ">") THEN Texts.Scan(S); IF S.class IN {Texts.Name, Texts.String} THEN WriteName(W, name, 0X); Texts.WriteString(W, " => "); WriteName(W, S.s, 0X); Texts.WriteString(W, " renaming"); Texts.Append(Oberon.Log, W.buf); Files.Rename(name, S.s, res); IF res > 1 THEN Texts.WriteString(W, " failed") END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END END END END RenameFile; PROCEDURE RenameFiles*; BEGIN OpenArgs(Sx); Texts.WriteString(W, "System.RenameFiles"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); WHILE (Sx.class IN {Texts.Name, Texts.String}) & (~InSelection OR (Texts.Pos(Sx) <= SelEnd+1)) DO RenameFile(Sx.s, Sx); Texts.Scan(Sx) END END RenameFiles; PROCEDURE DeleteFile (VAR name: ARRAY OF CHAR); VAR res: INTEGER; BEGIN WriteName(W, name, 0X); Texts.WriteString(W, " deleting"); Texts.Append(Oberon.Log, W.buf); Files.Delete(name, res); IF res # 0 THEN Texts.WriteString(W, " failed") END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END DeleteFile; PROCEDURE DeleteFiles*; BEGIN OpenArgs(Sx); Texts.WriteString(W, "System.DeleteFiles"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); WHILE (Sx.class IN {Texts.Name, Texts.String}) & (~InSelection OR (Texts.Pos(Sx) <= SelEnd+1)) DO DeleteFile(Sx.s); Texts.Scan(Sx) END END DeleteFiles; PROCEDURE matches (VAR name, pat: ARRAY OF CHAR; i, j: INTEGER): BOOLEAN; BEGIN IF (name[i] = 0X) & (pat[j] = 0X) THEN RETURN TRUE ELSIF pat[j] # "*" THEN RETURN (name[i] = pat[j]) & matches(name, pat, i+1, j+1) ELSE (* pat[j] = "*", name[i] may be 0X *) RETURN matches(name, pat, i, j+1) OR ((name[i] # 0X) & matches(name, pat, i+1, j)) END END matches; PROCEDURE matches2 (VAR name, pat: ARRAY OF CHAR; i, j: INTEGER): BOOLEAN; (* as matches, but ignores case *) BEGIN IF (name[i] = 0X) & (pat[j] = 0X) THEN RETURN TRUE ELSIF pat[j] # "*" THEN RETURN (CAP(name[i]) = CAP(pat[j])) & matches2(name, pat, i+1, j+1) ELSE (* pat[j] = "*", name[i] may be 0X *) RETURN matches2(name, pat, i, j+1) OR ((name[i] # 0X) & matches2(name, pat, i+1, j)) END END matches2; PROCEDURE Match (VAR (*in*) s1, s2: ARRAY OF CHAR): BOOLEAN; VAR i: INTEGER; BEGIN i := 0; WHILE (s1[i] # 0X) & (s2[i] # 0X) & (CAP(s1[i]) = CAP(s2[i])) DO INC(i) END ; RETURN (s1[i] = 0X) & (s2[i] = 0X) END Match; PROCEDURE ShowFile (d: Directories.Directory; name: ARRAY OF CHAR; isDir: BOOLEAN; VAR continue: BOOLEAN); CONST blue = 3; VAR path, str: ARRAY 256 OF CHAR; time, date, size: LONGINT; i: INTEGER; f: Files.File; cur: Directories.Directory; oldFont: Fonts.Font; BEGIN IF ((name[0] = "&") & matches2(name, pattern, 0, 0)) OR matches(name, pattern, 0, 0) THEN COPY(d.path, path); i := 0; WHILE path[i] # 0X DO INC(i) END ; IF (i > 2) & (path[i - 1] # Directories.delimiter) THEN path[i] := Directories.delimiter; path[i + 1] := 0X END ; Strings.Append(name, path); cur := Directories.Current(); IF (allPaths IN options) OR ~Match(cur.path, d.path) THEN COPY(path, str) ELSE COPY(name, str) END ; IF isDir THEN Texts.SetColor(W, blue); Strings.Append(Directories.delimiter, str); Strings.Append("*", str) ELSE Texts.SetColor(W, Display.white) END ; WriteName(W, str, "*"); Texts.SetColor(W, Display.white); IF {dateOpt, sizeOpt} * options # {} THEN f := Files.Old(path); IF f # NIL THEN Files.GetDate(f, time, date); size := Files.Length(f); IF dateOpt IN options THEN Texts.Write(W, 9X); Texts.WriteDate(W, time, date) END ; IF sizeOpt IN options THEN Texts.Write(W, 9X); oldFont := W.fnt; Texts.SetFont(W, Fonts.This("Courier10.Scn.Fnt")); Texts.WriteInt(W, size, 8); Texts.SetFont(W, oldFont) END END END ; Texts.WriteLn(W); Texts.Append(T, W.buf) END END ShowFile; PROCEDURE ScanDirectory (path: ARRAY OF CHAR; VAR continue: BOOLEAN); VAR d, cur, startup: Directories.Directory; BEGIN d := Directories.This(path); cur := Directories.Current(); startup := Directories.Startup(); IF (d # NIL) & (d.path # cur.path) THEN Directories.Enumerate(d, ShowFile); IF Match(d.path, startup.path) THEN startupDone := TRUE END END END ScanDirectory; PROCEDURE Directory*; VAR r: Texts.Reader; t: Texts.Text; v: Viewers.Viewer; beg, end, time: LONGINT; x, y, i, j, pos: INTEGER; c, ch: CHAR; path: ARRAY 128 OF CHAR; dir, startup: Directories.Directory; copy: Texts.CopyMsg; parc: TextFrames.Parc; BEGIN Texts.OpenReader(r, Oberon.Par.text, Oberon.Par.pos); Texts.Read(r, ch); WHILE ((ch = " ") OR (ch = 09X)) & ~r.eot DO Texts.Read(r, ch) END ; IF ch = "^" THEN Oberon.GetSelection(t, beg, end, time); IF time >= 0 THEN Texts.OpenReader(r, t, beg); Texts.Read(r, ch); WHILE ((ch = " ") OR (ch = 09X)) & ~r.eot DO Texts.Read(r, ch) END END END ; i := 0; j := 0; pos := 0; IF (ch = "'") OR (ch = '"') THEN c := ch; Texts.Read(r, ch); WHILE (ch # c) & (ch >= " ") & ~r.eot DO path[i] := ch; pattern[j]:=ch; INC(j); IF ch = delimiter THEN pos := i; j := 0 END ; INC(i); Texts.Read(r, ch) END ; Texts.Read(r, ch) ELSIF (ch > " ") & (ch # "\") & (ch # "^") THEN WHILE (ch > " ") & (ch # "\") DO path[i] := ch; pattern[j]:=ch; INC(j); IF ch = delimiter THEN pos := i; j := 0 END ; INC(i); Texts.Read(r, ch) END ; END ; pattern[j] := 0X; IF pos = 0 THEN (* no path *) path[0] := 0X ELSIF (pos = 0) OR (pos = 2) & (path[1] = ":") THEN (* keep trailing \ *) path[pos+1] := 0X; ELSE (* cut last \ *) path[pos] := 0X; END ; options := {}; WHILE ((ch = " ") OR (ch = 09X)) & ~r.eot DO Texts.Read(r, ch) END ; IF ch = "\" THEN LOOP Texts.Read(r, ch); IF CAP(ch) = "D" THEN INCL(options, dateOpt) ELSIF CAP(ch) = "S" THEN INCL(options, sizeOpt) ELSIF CAP(ch) = "A" THEN INCL(options, allPaths) ELSE EXIT END END END ; IF pattern = "" THEN RETURN END ; T := TextFrames.Text(""); Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, x, y); v:= MenuViewers.New(TextFrames.NewMenu("System.Directory", "^System.Menu.Text"), TextFrames.NewText(T, 0), TextFrames.menuH, x, y); TextFrames.defParc.handle(TextFrames.defParc, copy); parc := copy.e(TextFrames.Parc); parc.nofTabs := 1; parc.tab[0] := 1584000; Texts.WriteElem(W, parc); startup := Directories.Startup(); IF path = "" THEN dir := Directories.Current() ELSE dir := Directories.This(path) END ; IF dir # NIL THEN Directories.Enumerate(dir, ShowFile); startupDone := Match(dir.path, startup.path); IF allPaths IN options THEN Directories.EnumeratePaths(ScanDirectory); IF ~startupDone THEN Directories.Enumerate(startup, ShowFile) END END END END Directory; PROCEDURE StartupDir*; VAR d: Directories.Directory; BEGIN d := Directories.Startup(); Directories.Change(d.path); WriteName(W, d.path, 0X); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END StartupDir; PROCEDURE ShowDir*; VAR d: Directories.Directory; BEGIN d := Directories.Current(); WriteName(W, d.path, 0X); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END ShowDir; PROCEDURE ParentDir*; VAR d: Directories.Directory; BEGIN Directories.Change(".."); IF Directories.res # Directories.noErr THEN Texts.WriteString(W, ".. -- failed") ELSE d := Directories.Current(); WriteName(W, d.path, 0X) END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END ParentDir; PROCEDURE Quit*; BEGIN Kernel.quitQ.Handle; Kernel.Exit(0) END Quit; PROCEDURE WriteRegistryError (VAR W: Texts.Writer); BEGIN IF Registry.res = Registry.RegistryNotFound THEN Texts.WriteString(W, "(no .ini file specified)"); ELSIF Registry.res = Registry.NotFound THEN Texts.WriteString(W, "(undefined section or key)") END ; END WriteRegistryError; PROCEDURE WriteTriple (VAR W: Texts.Writer; section, key, value: ARRAY OF CHAR; def: BOOLEAN); BEGIN Texts.WriteString(W, section); Texts.Write(W, " "); Texts.WriteString(W, key); IF def THEN Texts.WriteString(W, " := ") ELSE Texts.WriteString(W, " = ") END ; Texts.WriteString(W, value); END WriteTriple; PROCEDURE Set*; (* ^ | section key ":=" value *) (* put a value into the registry *) VAR section, key, value: ARRAY 256 OF CHAR; done: BOOLEAN; line: INTEGER; PROCEDURE ReadAssign(VAR done: BOOLEAN); BEGIN done := FALSE; Texts.Scan(Sx); IF (Sx.class = Texts.Char) & (Sx.c = ":") THEN Texts.Scan(Sx); done := (Sx.class = Texts.Char) & (Sx.c = "="); END ; END ReadAssign; BEGIN OpenArgs(Sx); IF Sx.class IN {Texts.Name, Texts.String} THEN COPY(Sx.s, section); Texts.Scan(Sx); IF Sx.class IN {Texts.Name, Texts.String} THEN COPY(Sx.s, key); ReadAssign(done); IF done THEN line := Sx.line; Texts.Scan(Sx); IF (Sx.class IN {Texts.Name, Texts.String}) & (line = Sx.line) THEN COPY(Sx.s, value) ELSE value := "" END ; Texts.WriteString(W, " "); Registry.Set(section, key, value); IF Registry.res = Registry.Done THEN WriteTriple(W, section, key, value, TRUE); ELSE Texts.WriteString(W, "System.Set failed "); WriteRegistryError(W); END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); END END END END Set; PROCEDURE KeyHandler (key, value: ARRAY OF CHAR); BEGIN Texts.WriteString(W, " "); WriteTriple(W, "", key, value, FALSE); Texts.WriteLn(W); END KeyHandler; PROCEDURE Get*; (* ^ | section key *) (* get a value from the registry *) VAR section, value: ARRAY 1024 OF CHAR; BEGIN OpenArgs(Sx); IF Sx.class IN {Texts.Name, Texts.String} THEN COPY(Sx.s, section); Texts.Scan(Sx); IF (Sx.class IN {Texts.Name, Texts.String}) & (Sx.line = 0) THEN Registry.Get(section, Sx.s, value); Texts.WriteString(W, " "); IF Registry.res = Registry.Done THEN WriteTriple(W, section, Sx.s, value, FALSE); ELSE Texts.WriteString(W, "System.Get failed "); WriteRegistryError(W); END ; Texts.WriteLn(W); ELSE Texts.Write(W, "["); Texts.WriteString(W, section); Texts.Write(W, "]"); Texts.WriteLn(W); Registry.Enumerate(section, KeyHandler); END ; Texts.Append(Oberon.Log, W.buf); END END Get; (* ------------------------ trap handling and memory dump -------------------------------- *) PROCEDURE State*; VAR T: Texts.Text; i: INTEGER; r: Ref.Rider; BEGIN OpenArgs(Sx); T := TextFrames.Text(""); SysOpen(T, "System.State", Oberon.Par.vwr.X); IF Sx.class = Texts.Name THEN i := 0; WHILE Sx.s[i] > "." DO INC(i) END ; Sx.s[i] := 0X; Ref.OpenVars(Sx.s, r); IF r.mod = "" THEN Texts.WriteString(W, " not loaded") ELSE Texts.WriteString(W, "MODULE "); Texts.WriteString(W, Sx.s); RefElems.WriteRider(W, r, 1); END ; Texts.Append(T, W.buf); END END State; PROCEDURE- FINIT 0DBH, 0E3H; PROCEDURE- FLDCW 0D9H, 06DH, 0FEH; (* fldcw -2[ebp] *) PROCEDURE Trap (p: Win32.ExceptionInfo): LONGINT; VAR cw: INTEGER; (* cw must be the first variable of this procedure *) V: Viewers.Viewer; X, Y: INTEGER; excode, pc, bp, sp, n: LONGINT; trapno: LONGINT; mod: Modules.Module; NilProcVar: BOOLEAN; EBX, ESI, EDI: LONGINT; r, r2: Ref.Rider; ret: LONGINT; retAdr: LONGINT; PROCEDURE Str(str: ARRAY OF CHAR); BEGIN Console.Str(str); Texts.WriteString(W, str) END Str; PROCEDURE Int(i: LONGINT); BEGIN Console.Int(i); Texts.WriteInt(W, i, 0) END Int; PROCEDURE Hex(i: LONGINT); BEGIN Console.Hex(i); Console.Ch("H"); Texts.WriteHex(W, i); Texts.Write(W, "H"); END Hex; PROCEDURE Ln; BEGIN Console.Ln; Texts.WriteLn(W) END Ln; BEGIN S.GETREG(3, EBX); S.GETREG(6, ESI); S.GETREG(7, EDI); IF Kernel.TrapHandlingLevel < 2 THEN INC(Kernel.TrapHandlingLevel); IF T # NIL THEN Texts.Append(T, W.buf) END ; T := TextFrames.Text(""); IF Oberon.Pointer.on & (Oberon.Pointer.X < Oberon.SystemTrack(0)) THEN Oberon.AllocateUserViewer(0, X, Y) ELSE Oberon.AllocateSystemViewer(0, X, Y) END ; V := MenuViewers.New(TextFrames.NewMenu("System.Trap", StandardMenu), TextFrames.NewText(T, 0), TextFrames.menuH, X, Y); IF V.state > 0 THEN IF Kernel.TrapHandlingLevel > 1 THEN Win32.SyncDisplay; Str("*** RECURSIVE TRAP: "); Ln; END ; excode := p.exc.code MOD 10000H; pc := p.exc.addr; bp := p.cont.Ebp; sp := p.cont.Esp; IF pc = 0 THEN (* assume call of procedure variable with value NIL *) NilProcVar := TRUE; S.GET(sp, pc); (* get return address on top of stack *) ELSE NilProcVar := FALSE END ; IF pc = CtrlC.pc THEN S.PUT(CtrlC.pc, CtrlC.instr); p.cont.Eax := 30; Str("Ctrl-C pressed"); Ln END ; Console.Ln; Console.Ln; Str("Trap "); IF excode = 29 THEN (* Illegal Instruction => Oberon traps *) trapno := p.cont.Eax; Int(trapno); CASE trapno OF | 0: Str(" (ASSERT failed)"); | 1: Str(" (Heap overflow)"); | 15: Str(" (invalid case in WITH statement)"); | 16: Str(" (invalid case in CASE statement)"); | 17: Str(" (function procedure with no return value)"); | 18: Str(" (type guard check)"); | 19: Str(" (implicit type guard check in record assignment)"); | 20: Str(" (integer overflow)"); | 21: Str(" (range overflow)"); | 22: Str(" (dimension trap)"); ELSE IF trapno >= 30 THEN Str(" (programmed HALT)"); ELSE Str(" (unknown trap)"); END END ; ELSE Int(excode); CASE excode OF | 5: IF NilProcVar THEN Str(" (NIL proccedure variable called)") ELSE Str(" (access violation)") END ; | 8EH .. 93H: Str(" (FPU: "); CASE excode OF | 8EH: Str(" divide by zero)"); | 91H: Str(" overflow)"); | 93H: Str(" underflow)"); ELSE Str(" exception "); Hex(p.exc.code); Str(")"); END ; FINIT; cw := fpuControl; FLDCW | 94H: Str(" (integer division by zero)"); | 95H: Str(" (integer overflow)"); | 96H: Str(" (privileged instruction)"); ELSE END ; END ; Str(" PC = "); Hex(pc); Ref.OpenProc(pc, r); mod := r.m; IF mod # NIL THEN Str(" ("); Hex(pc - S.ADR(mod.code[0])); Str(") ") END ; Texts.Append(T, W.buf); retAdr := pc; (* stack dump *) Ref.OpenStack(p, r); n := 0; WHILE (r.mode # Ref.End) & (n < 64) DO Ln; Str(r.mod); Str("."); Str(r.name); Str(" (Rel. PC: "); Hex(retAdr - S.ADR(r.m.code^)); Str(", FP: "); Hex(r.fp); Str(", abs. PC: "); Hex(r.pc); Str(")"); r.Zoom(r2); RefElems.WriteRider(W, r2, 1); Texts.Append(T, W.buf); S.GET(r.fp + 4, retAdr); r.Next; INC(n) END END ELSE IF Kernel.TrapHandlingLevel < 3 THEN ret := oldTrapHandler(p) END END ; Kernel.TrapHandlingLevel := 0; S.PUTREG(3, EBX); S.PUTREG(6, ESI); S.PUTREG(7, EDI); RETURN -1 END Trap; PROCEDURE- FSTCW 09BH, 0D9H, 7DH, 0FEH; (* FSTCW -2[ebp] *) PROCEDURE Init; VAR cw: INTEGER; (* cw must be the first variable of this procedure *) a: LONGINT; h: Win32.TrapHandler; BEGIN FSTCW; fpuControl := cw; Kernel.GetAdr(0, "HandleTrap", a); S.GET(a, oldTrapHandler); h := Trap; S.PUT(a, S.VAL(LONGINT, h)) END Init; PROCEDURE OpenViewers; VAR t, d: LONGINT; mod: Modules.Module; BEGIN Oberon.GetClock(t, d); Texts.WriteString(W, "Oberon for Windows"); Texts.SetFont(W, Fonts.This("Syntax8.Scn.Fnt")); Texts.SetOffset(W, 32); Texts.WriteString(W, "TM "); Texts.SetFont(W, Fonts.Default); Texts.SetOffset(W, 0); Texts.WriteString(W, Version); Texts.WriteString(W, " on "); CASE Win32.OS.platform OF | 1: Texts.WriteString(W, "Windows 95") | 2: Texts.WriteString(W, "Windows NT ") ELSE Texts.WriteString(W, "Windows 3.1x") END ; IF Win32.OS.platform IN {2} THEN Texts.WriteInt(W, Win32.OS.major, 0); Texts.Write(W, "."); Texts.WriteInt(W, Win32.OS.minor, 0) END ; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); mod := Modules.ThisMod("Configuration"); IF mod = NIL THEN OpenLog; SysOpen(TextFrames.Text("System.Tool"), "System.Tool", 0); END END OpenViewers; BEGIN Texts.OpenWriter(W); Console.Str("System before init."); Console.Ln; Init; Console.Str("System before openviewers."); Console.Ln; OpenViewers; (* (* for MayUnload *) args := NIL; back := NIL; modTD := Types.This(Modules.ThisMod("Kernel"), "ModuleDesc"); Modules.MayUnload := MayUnload *) END System.