home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 5 / Amiga Tools 5.iso / tools / developer-tools / andere sprachen / oberonv4 / oberon-src / system / system.mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1996-04-10  |  29.3 KB  |  892 lines
  1. Syntax10.Scn.Fnt
  2. ParcElems
  3. Alloc
  4. Syntax24b.Scn.Fnt
  5. Syntax10i.Scn.Fnt
  6. StampElems
  7. Alloc
  8. 10 Apr 96
  9. Syntax10b.Scn.Fnt
  10. FoldElems
  11. (* AMIGA *)
  12. MODULE System;    (* JG 25.4.90 / NW 22.4.90, JT 21.01.93, CN/SHML 
  13.     IMPORT SYSTEM, Amiga, Kernel, Modules, Files, Input, Viewers, MenuViewers, Oberon, Fonts, Texts, TextFrames;
  14.     CONST
  15.         copyright = "(c) ETH-Zurich / Claudio Nieder, Stefan Ludwig & Ralf Degner";
  16.         SystemMenu = "System.Close System.Copy System.Grow Edit.Search Edit.Store ";
  17.         SystemMenuText = "System.Menu.Text";
  18.         LogMenu = "System.Close System.Grow Edit.Locate Edit.Store ";
  19.         LogMenuText = "Log.Menu.Text";
  20.         (* structure forms *)
  21.         (*Undef = 0; *) Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  22.         Real = 7; LReal = 8; Set = 9; (*String = 10;  NilTyp = 11; NoTyp = 12; *)
  23.         Pointer = 13; ProcTyp = 14; Comp = 15;
  24.         W: Texts.Writer;
  25.     PROCEDURE Str(s: ARRAY OF CHAR);    BEGIN Texts.WriteString(W, s) END Str;
  26.     PROCEDURE Ch(ch: CHAR);    BEGIN Texts.Write(W, ch) END Ch;
  27.     PROCEDURE Integer(i: LONGINT);    BEGIN Texts.Write(W, " "); Texts.WriteInt(W, i, 0) END Integer;
  28.     PROCEDURE Ln;    BEGIN Texts.WriteLn(W) END Ln;
  29.     PROCEDURE Append(t: Texts.Text);    BEGIN ASSERT(t#NIL); Texts.Append(t, W.buf) END Append;
  30.     PROCEDURE Hex(i: LONGINT);    BEGIN Texts.Write(W, " "); Texts.WriteHex(W, i) END Hex;
  31.     PROCEDURE ScanEnd(VAR s: Texts.Scanner; VAR end: LONGINT);    (* Scan first parameter *)
  32.         VAR sel: Texts.Text; beg, time: LONGINT;
  33.     BEGIN
  34.         Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
  35.         IF (s.class = Texts.Char) & (s.c = "^") THEN
  36.             Oberon.GetSelection(sel, beg, end, time);
  37.             IF time >= 0 THEN Texts.OpenScanner(s, sel, beg); Texts.Scan(s) END
  38.         ELSE end := Oberon.Par.text.len
  39.         END
  40.     END ScanEnd;
  41.     PROCEDURE ScanFirst(VAR s: Texts.Scanner);    (* Scan first parameter *)
  42.         VAR sel: Texts.Text; beg, end, time: LONGINT;
  43.     BEGIN
  44.         Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
  45.         IF (s.class = Texts.Char) & (s.c = "^") OR (s.line # 0) THEN
  46.             Oberon.GetSelection(sel, beg, end, time);
  47.             IF time >= 0 THEN Texts.OpenScanner(s, sel, beg); Texts.Scan(s) END
  48.         END
  49.     END ScanFirst;
  50.     PROCEDURE MenuFrame(name, fileName, defaultMenu: ARRAY OF CHAR): TextFrames.Frame;
  51.         VAR mf: TextFrames.Frame; t: Texts.Text; buf: Texts.Buffer;
  52.     BEGIN
  53.         IF Files.Old(fileName) = NIL THEN mf := TextFrames.NewMenu(name, defaultMenu)
  54.         ELSE
  55.             mf := TextFrames.NewMenu(name, "");
  56.             NEW(t); Texts.Open(t, fileName);
  57.             NEW(buf); Texts.OpenBuf(buf); Texts.Save(t, 0, t.len, buf); Texts.Append(mf.text, buf)
  58.         END;
  59.         RETURN mf
  60.     END MenuFrame;
  61.     PROCEDURE Strip(VAR s: ARRAY OF CHAR);
  62.         VAR i: INTEGER;
  63.     BEGIN i := -1; REPEAT INC(i) UNTIL (s[i] = 0X) OR (s[i] = "."); s[i] := 0X
  64.     END Strip;
  65.     PROCEDURE DumpVar(T:Texts.Text; VAR name: ARRAY OF CHAR; fp, f, vadr: LONGINT; varPar: BOOLEAN);
  66.         VAR ch: CHAR; sival: SHORTINT; ival, i: INTEGER; lival: LONGINT; rval: REAL; lrval: LONGREAL;
  67.     BEGIN
  68.         IF ((fp MOD 2) # 0) OR (fp<4096) THEN
  69.             Str(" -- invalid stack frame"); Ln; Append(T); RETURN
  70.         END ;
  71.         IF varPar THEN SYSTEM.GET(fp + vadr, vadr)
  72.         ELSE vadr := fp + vadr
  73.         END ;
  74.         Str("   "); Hex(vadr); Str(" "); Str(name); Str(" = ");
  75.         CASE f OF
  76.         | Byte: SYSTEM.GET(vadr, ch); Integer(ORD(ch))
  77.         | SInt: SYSTEM.GET(vadr, sival); Integer(sival)
  78.         | Int: SYSTEM.GET(vadr, ival); Integer(ival)
  79.         | LInt: SYSTEM.GET(vadr, lival); Integer(lival)
  80.         | Bool: SYSTEM.GET(vadr, sival);
  81.             IF sival = 0 THEN Str("FALSE") ELSE Str("TRUE") END
  82.         | Char: SYSTEM.GET(vadr, ch);
  83.             IF (ch < " ") OR (ch > "~") THEN Str("CHR("); Integer(ORD(ch)); Ch(")")
  84.             ELSE Ch(22X); Ch(ch); Ch(22X)
  85.             END
  86.         | Pointer, ProcTyp, Set: SYSTEM.GET(vadr, lival); Texts.WriteHex(W, lival); Ch("H")
  87.         | Real: SYSTEM.GET(vadr, rval); Texts.WriteReal(W, rval, 15)
  88.         | LReal: SYSTEM.GET(vadr, lrval); Texts.WriteLongReal(W, lrval, 24)
  89.         | Comp: Ch(22X); i := 0;
  90.             LOOP SYSTEM.GET(vadr+i, ch);
  91.                 IF (ch < " ") OR (ch >= 90X) THEN EXIT END ;
  92.                 Ch(ch); INC(i)
  93.             END ;
  94.             Ch(22X)
  95.         ELSE Str("unknown type")
  96.         END ;
  97.         Ln; Append(T)
  98.     END DumpVar;
  99.     PROCEDURE RInt(VAR refs: LONGINT; VAR k: LONGINT);
  100.         VAR n: LONGINT; shift: SHORTINT; x: CHAR;
  101.     BEGIN
  102.         shift := 0; n := 0; SYSTEM.GET(refs, x); INC(refs);
  103.         WHILE ORD(x) >= 128 DO
  104.             INC(n, ASH(ORD(x) MOD 128, shift));
  105.             INC(shift, 7); SYSTEM.GET(refs, x); INC(refs)
  106.         END ;
  107.         k := n + ASH(ORD(x) MOD 64, shift) - ASH(ORD(x) DIV 64, shift) * 64
  108.     END RInt;
  109.     PROCEDURE RName(VAR refs: LONGINT; VAR name: ARRAY OF CHAR);
  110.         VAR i: INTEGER; ch: CHAR;
  111.     BEGIN i := 0; REPEAT SYSTEM.GET(refs, ch); name[i] := ch; INC(i); INC(refs) UNTIL ch = 0X
  112.     END RName;
  113.     PROCEDURE DumpProc(T:Texts.Text; fp, pc: LONGINT);
  114.         VAR m: Kernel.Module; found: BOOLEAN;
  115.             refs, refsend, vadr, lastadr, adr: LONGINT;
  116.             name: ARRAY 64 OF CHAR;
  117.             f: SHORTINT; b: CHAR;
  118.     BEGIN
  119.         m := Kernel.modules;
  120.         WHILE m # NIL DO
  121.             IF (pc >= m.code) & (pc < m.refs) THEN (*module found*)
  122.                 refs := m^.refs + 1; refsend := m^.refs + m^.refSize; lastadr := 0;
  123.                 WHILE refs < refsend DO
  124.                     RInt(refs, adr);
  125.                     RName(refs, name);
  126.                     IF (pc < m.code + adr) & (pc >= m.code + lastadr) THEN found := TRUE;
  127.                         Str(m.name); Ch("."); Str(name);
  128.                         Ch(9X); Integer(pc - m.code); Ln; Append(T);
  129.                         IF name[0] = "$" THEN fp := m^.data END
  130.                     ELSE found := FALSE
  131.                     END ;
  132.                     LOOP
  133.                         IF refs >= refsend THEN EXIT END ;
  134.                         SYSTEM.GET(refs, b); INC(refs);
  135.                         IF ORD(b) = 0F8H THEN EXIT END ;
  136.                         SYSTEM.GET(refs, f); INC(refs);
  137.                         RInt(refs, vadr);
  138.                         RName(refs, name);
  139.                         IF found THEN DumpVar(T, name, fp, f, vadr, ORD(b) = 3) END
  140.                     END ;
  141.                     IF found THEN RETURN ELSE lastadr := adr END
  142.                 END
  143.             ELSE m := m.link
  144.             END
  145.         END ;
  146.         Str("unknown"); Ln; Append(T)
  147.     END DumpProc;
  148.     PROCEDURE -RTS 04EH, 075H;
  149.     PROCEDURE Trap;
  150.         VAR errorFrame: Amiga.ErrorFrame; x, y, s: INTEGER; v: Viewers.Viewer; PC, FP: LONGINT; t:Texts.Text;
  151.     BEGIN
  152.         Amiga.RestoreTrapHandler;
  153.         Amiga.GetErrorFrame(errorFrame);
  154.         Str("Trap occurred: PC ="); Integer(errorFrame.PC);
  155.         Str(" SP ="); Integer(errorFrame.SP);
  156.         Str(" type ="); Integer(errorFrame.type);
  157.         Str(" val ="); Integer(errorFrame.val);
  158.         Ln; Append(Oberon.Log);
  159.         t := TextFrames.Text("");
  160.         Oberon.AllocateSystemViewer(Oberon.Mouse.X, x, y);
  161.         v := MenuViewers.New(
  162.             MenuFrame("System.Trap", SystemMenuText, SystemMenu),
  163.             TextFrames.NewText(t, 0),
  164.             TextFrames.menuH, x, y
  165.         PC := errorFrame.PC;
  166.         FP := errorFrame.FP;
  167.         IF v.state > 0 THEN
  168.             Str("TRAP "); Integer(errorFrame.type);
  169.             Str("  code = "); Integer(errorFrame.val);
  170.             Str("  PC = "); Texts.WriteHex(W, PC);
  171.             Str("  FP = "); Texts.WriteHex(W, FP);
  172.             Str("  SP = "); Texts.WriteHex(W, errorFrame.SP);
  173.             Ln; Append(t);
  174.             IF errorFrame.type = Amiga.TrapErr THEN
  175.                 CASE errorFrame.val OF
  176.                 | 2: Str("Bus error")
  177.                 | 3: Str("Address error")
  178.                 | 4: Str("Illegal instruction")
  179.                 | 5: Str("Zero divide")
  180.                 | 6: Str("CHK, CHK2 instruction");
  181.                     Texts.WriteLn(W);
  182.                     Str("Oberon Trap: Index out of range / Invalid case in WITH statement")
  183.                 | 7: Str("TRAPV, TRAPcc, cpTRAPcc instruction");
  184.                     SYSTEM.GET(PC-2, s);
  185.                     Texts.WriteLn(W);
  186.                     Str("Oberon Trap ");Texts.WriteInt(W, s, 1);Str(" : ");
  187.                     CASE s OF
  188.                         0 : Str("ASSERT fault")
  189.                        |1 : Str("Parity error  (NMI)")
  190.                        |2 : Str("Illegal address (NIL-reference)")
  191.                        |3 : Str("FPU error  (inspect FSR)")
  192.                        |4 : Str("Illegal instruction")
  193.                        |5 : Str("Illegal SVC number")
  194.                        |6 : Str("Division by zero")
  195.                        |7 : Str("Flag trap, invalid index, integer overflow")
  196.                        |9 : Str("Trace trap")
  197.                        |10 : Str("Undefined instruction")
  198.                        |11 : Str("Restartable bus error")
  199.                        |12 : Str("Nonrestartable bus error")
  200.                        |13 : Str("Integer overflow trap or invalid index trap")
  201.                        |14 : Str("Debug trap")
  202.                        |15 : Str("Index out of range / Invalid case in WITH statement")
  203.                        |16 : Str("Invalid case in CASE statement")
  204.                        |17 : Str("Function procedure without RETURN statement")
  205.                        |18 : Str("Type guard check")
  206.                        |19 : Str("Implied type guard check in record assignment")
  207.                        |20 : Str("Disk drive error (unreadable sector)")
  208.                        |21 : Str("Parity error in sector address")
  209.                        |22 : Str("Disk full")
  210.                        |23 : Str("File too long  (> 2.5 MB)")
  211.                        |24 : Str("Abort from keyboard")
  212.                        |25 : Str("ReadBytes/WriteBytes(R, a, n):  LEN(a) < n")
  213.                        |27 : Str("Illegal function argument (Math or MathL)")
  214.                        |30..255 : Str("Programmed HALT")
  215.                     ELSE
  216.                         Str("unknown")
  217.                     END
  218.                 | 8: Str("Privilege violation")
  219.                 | 9: Str("Trace")
  220.                 | 10: Str("Line 1010 emulator")
  221.                 | 11: Str("Line 1111 emulator")
  222.                 | 13: Str("Coprocessor protocol violation")
  223.                 | 14: Str("Format error")
  224.                 | 32..47: Str("TRAP instruction"); Integer(errorFrame.val-32)
  225.                 ELSE Str("Some error"); Integer(errorFrame.val)
  226.                 END
  227.             ELSE Str("Some other error"); Integer(errorFrame.val)
  228.             END;
  229.             Ln; Append(t);
  230.             LOOP
  231.                 IF (FP<4096) OR (PC<4096) THEN EXIT; END;
  232.                 DumpProc(t, FP, PC);
  233.                 Append(t);
  234.                 IF FP >= Amiga.stackPtr THEN EXIT; END;
  235.                 SYSTEM.GET(FP+4, PC);
  236.                 SYSTEM.GET(FP, FP)
  237.             END
  238.         END;
  239.         Amiga.InstallTrapHandler(Trap);
  240.         SYSTEM.PUTREG(15, Amiga.stackPtr); RTS
  241.     END Trap;
  242.     PROCEDURE Max (i, j: LONGINT): LONGINT;
  243.     BEGIN IF i >= j THEN RETURN i ELSE RETURN j END
  244.     END Max;
  245.     PROCEDURE Open*;
  246.         VAR par: Oberon.ParList;
  247.             T: Texts.Text;
  248.             S: Texts.Scanner;
  249.             V: Viewers.Viewer;
  250.             X, Y: INTEGER;
  251.             beg, end, time: LONGINT;
  252.     BEGIN
  253.         par := Oberon.Par;
  254.         Texts.OpenScanner(S, par.text, par.pos); Texts.Scan(S);
  255.         IF (S.class = Texts.Char) & (S.c = "^") OR (S.line # 0) THEN
  256.             Oberon.GetSelection(T, beg, end, time);
  257.             IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S) END
  258.         END;
  259.         IF S.class = Texts.Name THEN
  260.             Oberon.AllocateSystemViewer(par.vwr.X, X, Y);
  261.             V := MenuViewers.New(
  262.                 MenuFrame(S.s, SystemMenuText, SystemMenu),
  263.                 TextFrames.NewText(TextFrames.Text(S.s), 0),
  264.                 TextFrames.menuH, X, Y
  265.         END
  266.     END Open;
  267.     PROCEDURE OpenLog*;
  268.         VAR logV: Viewers.Viewer; X, Y: INTEGER;
  269.     BEGIN
  270.         Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y);
  271.         logV := MenuViewers.New(
  272.             MenuFrame("System.Log", LogMenuText, LogMenu),
  273.             TextFrames.NewText(Oberon.Log, Max(0, Oberon.Log.len - 200)),
  274.             TextFrames.menuH, X, Y
  275.     END OpenLog;
  276.     PROCEDURE Close*;
  277.         VAR par: Oberon.ParList; V: Viewers.Viewer;
  278.     BEGIN
  279.         par := Oberon.Par;
  280.         IF par.frame = par.vwr.dsc THEN V := par.vwr
  281.         ELSE V := Oberon.MarkedViewer()
  282.         END;
  283.         Viewers.Close(V)
  284.     END Close;
  285.     PROCEDURE CloseTrack*;
  286.         VAR V: Viewers.Viewer;
  287.     BEGIN V := Oberon.MarkedViewer(); Viewers.CloseTrack(V.X)
  288.     END CloseTrack;
  289.     PROCEDURE Recall*;
  290.         VAR V: Viewers.Viewer; M: Viewers.ViewerMsg;
  291.     BEGIN
  292.         Viewers.Recall(V);
  293.         IF (V # NIL) & (V.state = 0) THEN
  294.             Viewers.Open(V, V.X, V.Y + V.H); M.id := Viewers.restore; V.handle(V, M)
  295.         END
  296.     END Recall;
  297.     PROCEDURE Copy*;
  298.         VAR V, V1: Viewers.Viewer; M: Oberon.CopyMsg; N: Viewers.ViewerMsg;
  299.     BEGIN
  300.         V := Oberon.Par.vwr; V.handle(V, M); V1 := M.F(Viewers.Viewer);
  301.         Viewers.Open(V1, V.X, V.Y + V.H DIV 2);
  302.         N.id := Viewers.restore; V1.handle(V1, N)
  303.     END Copy;
  304.     PROCEDURE Grow*;
  305.         VAR V, V1: Viewers.Viewer; M: Oberon.CopyMsg; N: Viewers.ViewerMsg;
  306.             DW, DH: INTEGER;
  307.     BEGIN V := Oberon.Par.vwr;
  308.         DW := Oberon.DisplayWidth(V.X); DH := Oberon.DisplayHeight(V.X);
  309.         IF V.H < DH - Viewers.minH THEN Oberon.OpenTrack(V.X, V.W)
  310.         ELSIF V.W < DW THEN Oberon.OpenTrack(Oberon.UserTrack(V.X), DW)
  311.         END;
  312.         IF (V.H < DH - Viewers.minH) OR (V.W < DW) THEN
  313.             V.handle(V, M); V1 := M.F(Viewers.Viewer);
  314.             Viewers.Open(V1, V.X, DH);
  315.             N.id := Viewers.restore; V1.handle(V1, N)
  316.         END
  317.     END Grow;
  318.     PROCEDURE SetFont*;
  319.         VAR s: Texts.Scanner;
  320.     BEGIN
  321.         ScanFirst(s);
  322.         IF s.class = Texts.Name THEN Oberon.SetFont(Fonts.This(s.s)) END
  323.     END SetFont;
  324.     PROCEDURE SetColor*;
  325.         VAR s: Texts.Scanner;
  326.     BEGIN
  327.         ScanFirst(s);
  328.         IF s.class = Texts.Int THEN Oberon.SetColor(SHORT(SHORT(s.i))) END
  329.     END SetColor;
  330.     PROCEDURE SetOffset*;
  331.         VAR s: Texts.Scanner;
  332.     BEGIN
  333.         ScanFirst(s);
  334.         IF s.class = Texts.Int THEN Oberon.SetOffset(SHORT(SHORT(s.i))) END
  335.     END SetOffset;
  336.     PROCEDURE Time*;
  337.         VAR par: Oberon.ParList;
  338.             S: Texts.Scanner;
  339.             t, d, hr, min, sec, yr, mo, day: LONGINT;
  340.     BEGIN par := Oberon.Par;
  341.         Texts.OpenScanner(S, par.text, par.pos); Texts.Scan(S);
  342.         IF S.class = Texts.Int THEN (*set date*)
  343.             day := S.i; Texts.Scan(S); mo := S.i; Texts.Scan(S); yr := S.i; Texts.Scan(S);
  344.             hr := S.i; Texts.Scan(S); min := S.i; Texts.Scan(S); sec := S.i;
  345.             t := (hr*64 + min)*64 + sec; d := (yr*16 + mo)*32 + day;
  346.             Kernel.SetClock(t, d)
  347.         ELSE (*read date*)
  348.             Str("System.Time");
  349.             Oberon.GetClock(t, d); Texts.WriteDate(W, t, d); Ln; Append(Oberon.Log)
  350.         END
  351.     END Time;
  352.     PROCEDURE Watch*;
  353.     BEGIN
  354.         Str("System.Watch"); Ln;
  355.         Integer(Kernel.allocated); Str(" bytes allocated from ");
  356.         Integer(Kernel.heapSize); Ln;
  357.         Integer(Kernel.nofiles); Str(" file(s) open"); Ln;
  358.         Append(Oberon.Log)
  359.     END Watch;
  360.     PROCEDURE Collect*;
  361.     BEGIN
  362.         Oberon.Collect(0);
  363.     END Collect;
  364.     PROCEDURE FreeMod(VAR S: Texts.Scanner);
  365.     BEGIN
  366.         Str(S.s); Str(" unloading");
  367.         Append(Oberon.Log);
  368.         IF S.nextCh # "*" THEN Modules.Free(S.s, FALSE)
  369.         ELSE Modules.Free(S.s, TRUE); Texts.Scan(S); Str(" all")
  370.         END;
  371.         IF Modules.res # 0 THEN Str(" failed"); Modules.res := 0 END;
  372.         Ln; Append(Oberon.Log)
  373.     END FreeMod;
  374.     PROCEDURE Free*;
  375.         VAR par: Oberon.ParList;
  376.             T: Texts.Text;
  377.             S: Texts.Scanner;
  378.             beg, end, time: LONGINT;
  379.     BEGIN
  380.         par := Oberon.Par;
  381.         Str("System.Free"); Ln; Append(Oberon.Log);
  382.         Texts.OpenScanner(S, par.text, par.pos); Texts.Scan(S);
  383.         WHILE S.class = Texts.Name DO FreeMod(S); Texts.Scan(S) END;
  384.         IF (S.class = Texts.Char) & (S.c = "^") THEN Oberon.GetSelection(T, beg, end, time);
  385.             IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S);
  386.                  IF S.class = Texts.Name THEN FreeMod(S) END
  387.             END
  388.         END
  389.     END Free;
  390.     PROCEDURE ShowModules*;
  391.         VAR T: Texts.Text;
  392.             V: Viewers.Viewer;
  393.             M: Kernel.Module;
  394.             X, Y: INTEGER;
  395.     BEGIN
  396.         T := TextFrames.Text("");
  397.         Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y);
  398.         V := MenuViewers.New(
  399.             MenuFrame("System.ShowModules", SystemMenuText, SystemMenu),
  400.             TextFrames.NewText(T, 0),
  401.             TextFrames.menuH, X, Y
  402.         M := Kernel.modules;
  403.         WHILE M # NIL DO
  404.             Str(M.name); Texts.WriteInt(W, M.refs - M.code, 8);
  405.             Texts.WriteInt(W, M.refcnt, 4); Ln;
  406.             M := M.link
  407.         END;
  408.         Append(T)
  409.     END ShowModules;
  410.     PROCEDURE ShowCommands*;
  411.         VAR M: Kernel.Module; S: Texts.Scanner; i: LONGINT;
  412.             T: Texts.Text; V: Viewers.Viewer; X, Y: INTEGER;
  413.             cmds: POINTER TO ARRAY 1000 OF RECORD
  414.                 name: ARRAY 24 OF CHAR;
  415.                 offset: LONGINT
  416.             END ;
  417.     BEGIN
  418.         ScanFirst(S);
  419.         IF S.class = Texts.Name THEN
  420.             Strip(S.s); M := Modules.ThisMod(S.s);
  421.             IF M # NIL THEN SYSTEM.GET(SYSTEM.ADR(M.commands), cmds); i := 0;
  422.                 Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y);
  423.                 T := TextFrames.Text("");
  424.                 V := MenuViewers.New(
  425.                     MenuFrame("System.Commands", SystemMenuText, SystemMenu),
  426.                     TextFrames.NewText(T, 0),
  427.                     TextFrames.menuH, X, Y
  428.                 );
  429.                 WHILE i < M.nofcoms DO
  430.                     Str(M.name); Ch("."); Str(cmds[i].name); Ln;
  431.                     INC(i)
  432.                 END ;
  433.                 Append(T)
  434.             END
  435.         END
  436.     END ShowCommands;
  437.     PROCEDURE State*;
  438.         VAR
  439.             t: Texts.Text;
  440.             S: Texts.Scanner;
  441.             V: Viewers.Viewer;
  442.             mod: Kernel.Module;
  443.             X, Y: INTEGER;
  444.             refs, refsend, adr: LONGINT;
  445.             f: SHORTINT; b: CHAR;
  446.             name: ARRAY 32 OF CHAR;
  447.     BEGIN
  448.         ScanFirst(S);
  449.         Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, X, Y);
  450.         t := TextFrames.Text("");
  451.         V := MenuViewers.New(
  452.             MenuFrame("System.State", SystemMenuText, SystemMenu),
  453.             TextFrames.NewText(t, 0),
  454.             TextFrames.menuH, X, Y
  455.         WHILE S.class = Texts.Name DO
  456.             Strip(S.s);    (*<<*)
  457.             Str(S.s);
  458.             mod := Kernel.modules;
  459.             WHILE (mod # NIL) & (mod.name # S.s) DO mod := mod.link END ;
  460.             IF mod # NIL THEN
  461.                 Ln;
  462.                 refs := mod^.refs + 1; refsend := mod^.refs + mod^.refSize;
  463.                 RInt(refs, adr); RName(refs, name);
  464.                 LOOP
  465.                     IF refs >= refsend THEN EXIT END ;
  466.                     SYSTEM.GET(refs, b); INC(refs);
  467.                     IF ORD(b) = 0F8H THEN EXIT END ;
  468.                     SYSTEM.GET(refs, f); INC(refs);
  469.                     RInt(refs, adr); RName(refs, name);
  470.                     IF adr < 0 THEN DumpVar(t, name, mod.data, f, adr, ORD(b) = 3) END
  471.                 END
  472.             ELSE Str(" not loaded")
  473.             END ;
  474.             Ln; Append(t); Texts.Scan(S)
  475.         END
  476.     END State;
  477.     PROCEDURE SetUser*;
  478.         VAR i: INTEGER; ch: CHAR;
  479.             user: ARRAY 8 OF CHAR;
  480.             password: ARRAY 16 OF CHAR;
  481.     BEGIN
  482.         i := 0; Input.Read(ch);
  483.         WHILE (ch # "/") & (i < 7) DO user[i] := ch; INC(i); Input.Read(ch) END;
  484.         user[i] := 0X;
  485.         i := 0; Input.Read(ch);
  486.         WHILE (ch > " ") & (i < 15) DO password[i] := ch; INC(i); Input.Read(ch) END;
  487.         password[i] := 0X;
  488.         Oberon.SetUser(user, password)
  489.     END SetUser;
  490.     PROCEDURE CurrentDirectory*;
  491.     BEGIN
  492.         Str("System.CurrentDirectory "); Str(Files.CurrentDir); Ln; Append(Oberon.Log)
  493.     END CurrentDirectory;
  494.     PROCEDURE ChangeDirectory*;
  495.         VAR
  496.             S: Texts.Scanner;
  497.             res: INTEGER;
  498.     BEGIN
  499.         ScanFirst(S);
  500.         IF (S.class = Texts.Name) & (S.line = 0) THEN
  501.             Str("System.ChangeDirectory "); Str(S.s);
  502.             Files.ChangeDirectory(S.s, res);
  503.             IF res # 0 THEN Str("  -- failed") END ;
  504.             Ln; Append(Oberon.Log)
  505.         END
  506.     END ChangeDirectory;
  507.     PROCEDURE CopyFile (name: ARRAY OF CHAR; VAR S: Texts.Scanner);
  508.         VAR f, g: Files.File; Rf, Rg: Files.Rider; ch: CHAR;
  509.     BEGIN Texts.Scan(S);
  510.         IF (S.class = Texts.Char) & (S.c = "=") THEN Texts.Scan(S);
  511.             IF (S.class = Texts.Char) & (S.c = ">") THEN Texts.Scan(S);
  512.                 IF S.class = Texts.Name THEN
  513.                     Str(name); Str(" => "); Str(S.s);
  514.                     Str(" copying");
  515.                     Append(Oberon.Log);
  516.                     f := Files.Old(name);
  517.                     IF f # NIL THEN g := Files.New(S.s);
  518.                         Files.Set(Rf, f, 0); Files.Set(Rg, g, 0);
  519.                         Files.Read(Rf, ch);
  520.                         WHILE ~Rf.eof DO Files.Write(Rg, ch); Files.Read(Rf, ch) END;
  521.                         Files.Register(g)
  522.                     ELSE Str(" failed")
  523.                     END;
  524.                     Ln; Append(Oberon.Log)
  525.                 END
  526.             END
  527.         END
  528.     END CopyFile;
  529.     PROCEDURE CopyFiles*;
  530.         VAR par: Oberon.ParList;
  531.         T: Texts.Text;
  532.         S: Texts.Scanner;
  533.         beg, end, time: LONGINT;
  534.     BEGIN
  535.         par := Oberon.Par;
  536.         Str("System.CopyFiles"); Ln; Append(Oberon.Log);
  537.         Texts.OpenScanner(S, par.text, par.pos); Texts.Scan(S);
  538.         WHILE S.class = Texts.Name DO CopyFile(S.s, S); Texts.Scan(S) END;
  539.         IF (S.class = Texts.Char) & (S.c = "^") THEN Oberon.GetSelection(T, beg, end, time);
  540.             IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S);
  541.                 IF S.class = Texts.Name THEN CopyFile(S.s, S) END
  542.             END
  543.         END
  544.     END CopyFiles;
  545.     PROCEDURE RenameFile (name: ARRAY OF CHAR; VAR S: Texts.Scanner);
  546.         VAR res: INTEGER;
  547.     BEGIN Texts.Scan(S);
  548.         IF (S.class = Texts.Char) & (S.c = "=") THEN Texts.Scan(S);
  549.             IF (S.class = Texts.Char) & (S.c = ">") THEN Texts.Scan(S);
  550.                 IF S.class = Texts.Name THEN
  551.                     Str(name); Str(" => "); Str(S.s); Str(" renaming"); Append(Oberon.Log);
  552.                     Files.Rename(name, S.s, res);
  553.                     IF res > 1 THEN Str(" failed") END;
  554.                     Ln; Append(Oberon.Log)
  555.                 END
  556.             END
  557.         END
  558.     END RenameFile;
  559.     PROCEDURE RenameFiles*;
  560.         VAR par: Oberon.ParList;
  561.             T: Texts.Text;
  562.             S: Texts.Scanner;
  563.             beg, end, time: LONGINT;
  564.     BEGIN
  565.         par := Oberon.Par;
  566.         Str("System.RenameFiles"); Ln; Append(Oberon.Log);
  567.         Texts.OpenScanner(S, par.text, par.pos); Texts.Scan(S);
  568.         WHILE S.class = Texts.Name DO RenameFile(S.s, S); Texts.Scan(S) END;
  569.             IF (S.class = Texts.Char) & (S.c = "^") THEN Oberon.GetSelection(T, beg, end, time);
  570.                 IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S);
  571.                     IF S.class = Texts.Name THEN RenameFile(S.s, S) END
  572.                 END
  573.             END
  574.     END RenameFiles;
  575.     PROCEDURE DeleteFiles*;    (** {name} "~" | "^"    Delete file name **)
  576.         VAR S: Texts.Scanner; end: LONGINT; res: INTEGER;
  577.     BEGIN
  578.         ScanEnd(S, end); Str("System.DeleteFiles"); Ln; Append(Oberon.Log);
  579.         LOOP
  580.             IF S.class # Texts.Name THEN EXIT END;
  581.             Str("deleting "); Files.Delete(S.s, res); Str(S.s);
  582.             IF res # 0 THEN Str(" failed") END;
  583.             Ln; Append(Oberon.Log);
  584.             IF Texts.Pos(S) >= end THEN EXIT END;
  585.             Texts.Scan(S)
  586.         END;
  587.         Append(Oberon.Log)
  588.     END DeleteFiles;
  589.     PROCEDURE Quit*;
  590.     BEGIN
  591.         Amiga.Terminate()
  592.     END Quit;
  593.     PROCEDURE ShowFile(title,name:ARRAY OF CHAR);
  594.     CONST
  595.         bufLen=4000;
  596.         blk:LONGINT;
  597.         buf:ARRAY bufLen OF CHAR;
  598.         ch:CHAR;
  599.         f:Files.File;
  600.         i:LONGINT;
  601.         len:LONGINT;
  602.         r:Files.Rider;
  603.         t:Texts.Text;
  604.         v:Viewers.Viewer;
  605.         x,y:INTEGER;
  606.     BEGIN
  607.         f:=Files.Old(name);
  608.         IF f#NIL THEN
  609.             t:=TextFrames.Text("");
  610.             Oberon.AllocateSystemViewer(Oberon.Par.vwr.X,x,y);
  611.             v:=MenuViewers.New(
  612.                 MenuFrame(title,SystemMenuText,SystemMenu),
  613.                 TextFrames.NewText(t,0),
  614.                 TextFrames.menuH,x,y
  615.             );
  616.             len:=Files.Length(f); blk:=len MOD bufLen; Files.Set(r,f,0);
  617.             WHILE len>0 DO
  618.                 Files.ReadBytes(r,buf,blk); DEC(len,blk);
  619.                 FOR i:=0 TO blk-1 DO
  620.                     ch:=buf[i];
  621.                     IF ch=0AX THEN ch:=0DX END;    (* LF -> CR *)
  622.                     Ch(ch);
  623.                 END;
  624.                 Append(t);
  625.                 blk:=bufLen;
  626.             END;
  627.             Files.Close(f);
  628.             Files.Purge(f)
  629.         END
  630.     END ShowFile;
  631.     PROCEDURE DeleteError(fileName: ARRAY OF CHAR);
  632.     BEGIN
  633.         Str("System.DosCall: Delete "); Str(fileName);
  634.         Str(" failed"); Ln; Append(Oberon.Log);
  635.     END DeleteError;
  636.     PROCEDURE DosCallError(fileName: ARRAY OF CHAR);
  637.     BEGIN
  638.         Str("System.DosCall: "); Str(fileName);
  639.         Str(" failed"); Ln; Append(Oberon.Log);
  640.     END DosCallError;
  641.     PROCEDURE DosCall(cmd,title:ARRAY OF CHAR; sort:BOOLEAN);
  642.     CONST
  643.         SortName="T:System.DosCall.Sort";
  644.         TempName="T:System.DosCall";
  645.         res:INTEGER;
  646.     BEGIN
  647.         Amiga.DosCmd(cmd,TempName,res);
  648.         IF res=0 THEN
  649.             IF (res=0) & sort THEN Amiga.DosCmd("sort T:System.DosCall T:System.DosCall.Sort","NIL:",res) END;
  650.             IF res = 0 THEN
  651.                 IF sort THEN ShowFile(title,SortName) ELSE ShowFile(title,TempName) END
  652.             END;
  653.             Kernel.GC(TRUE);
  654.             Files.Delete(TempName,res);
  655.             IF res#0 THEN DeleteError(TempName); END;
  656.             IF sort THEN
  657.                 Files.Delete(SortName,res);
  658.                 IF res#0 THEN DeleteError(SortName) END
  659.             END
  660.         ELSE
  661.             DosCallError(cmd)
  662.         END
  663.     END DosCall;
  664.     PROCEDURE Execute*;
  665.         VAR par: Oberon.ParList;
  666.             R: Texts.Reader; t: Texts.Text;
  667.             i, beg, end, time: LONGINT;
  668.             cmd: ARRAY 4096 OF CHAR;
  669.             ch: CHAR;
  670.     BEGIN
  671.         par := Oberon.Par;
  672.         Texts.OpenReader(R, par.text, par.pos);
  673.         i := 0; cmd := ""; Texts.Read(R, ch);
  674.         WHILE ch = " " DO Texts.Read(R, ch) END ;
  675.         WHILE (ch >= " ") & (ch # "^") DO cmd[i] := ch; INC(i); Texts.Read(R, ch) END ;
  676.         IF (i = 0) OR (ch = "^") THEN
  677.             Oberon.GetSelection(t, beg, end, time);
  678.             IF time >= 0 THEN Texts.OpenReader(R, t, beg);
  679.                 Texts.Read(R, ch);
  680.                 WHILE Texts.Pos(R) <= end DO
  681.                     IF ch = 0DX THEN ch := " " END ;
  682.                     cmd[i] := ch; INC(i); Texts.Read(R, ch)
  683.                 END
  684.             END
  685.         END ;
  686.         cmd[i] := 0X;
  687.         DosCall(cmd,"System.Execute",FALSE);
  688.         Kernel.GC(TRUE)
  689.     END Execute;
  690.     PROCEDURE Directory*;
  691.         CONST CmdText = "list lformat=%f%n "; CmdLen = 18;
  692.         VAR
  693.             text: Texts.Text; cmd: ARRAY 256 OF CHAR;
  694.             i: INTEGER; time, beg, end: LONGINT;
  695.         PROCEDURE ReadParameters(t: Texts.Text; pos: LONGINT);
  696.             VAR r: Texts.Reader; ch: CHAR;
  697.         BEGIN
  698.             Texts.OpenReader(r, t, pos); Texts.Read(r, ch);
  699.             WHILE ~r.eot & ((ch = " ") OR (ch = 09X)) DO Texts.Read(r, ch) END;
  700.             i := CmdLen;
  701.             WHILE ~r.eot & (i < LEN(cmd)-2) & (ch > " ") DO
  702.                 IF ch = "*" THEN cmd[i] := "#"; cmd[i+1] := "?"; INC(i, 2) ELSE cmd[i] := ch; INC(i) END;
  703.                 Texts.Read(r, ch)
  704.             END;
  705.             cmd[i] := 0X
  706.         END ReadParameters;
  707.     BEGIN
  708.         cmd := CmdText;
  709.         ReadParameters(Oberon.Par.text, Oberon.Par.pos);
  710.         IF (i = CmdLen) OR (cmd[CmdLen] = "^") THEN
  711.             Oberon.GetSelection(text, beg, end, time);
  712.             IF time >= 0 THEN
  713.                 ReadParameters(text, beg)
  714.             ELSE
  715.                 Str("No Selection !");Ln;Append(Oberon.Log); RETURN
  716.             END
  717.         END;
  718.         DosCall(cmd, "System.Directory", TRUE);
  719.         Kernel.GC(TRUE)
  720.     END Directory;
  721.     PROCEDURE ShowMode*;
  722.         VAR
  723.             displayID:LONGINT; x, y, height, width, depth: INTEGER; oscan:LONGINT; autoScroll:BOOLEAN;
  724.             t: Texts.Text; v: Viewers.Viewer;
  725.     BEGIN
  726.         Amiga.ReadScreenMode(displayID, height, width, depth, oscan, autoScroll);
  727.         t := TextFrames.Text("");
  728.         Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, x, y);
  729.         v := MenuViewers.New(
  730.             TextFrames.NewMenu("System.ShowMode", "System.Close System.Copy System.Grow System.ChangeMode ^ "),
  731.             TextFrames.NewText(t, 0),
  732.             TextFrames.menuH, x, y
  733.         Str("Width "); Integer(width); Ln;
  734.         Str("Height "); Integer(height); Ln;
  735.         Str("Depth "); Integer(depth); Ln;
  736.         Str("AutoScroll ");
  737.         IF autoScroll THEN Str("TRUE") ELSE Str("FALSE") END;
  738.         Ln; Append(t)
  739.     END ShowMode;
  740.     PROCEDURE ChangeMode*;
  741.         VAR
  742.             res: INTEGER; s: Texts.Scanner;
  743.             displayID:LONGINT; height, width, depth: INTEGER; oscan:LONGINT; autoScroll:BOOLEAN;
  744.         PROCEDURE GetInt(VAR val: INTEGER; min, max: INTEGER);
  745.         BEGIN
  746.             Texts.Scan(s);
  747.             IF (s.class = Texts.Int) & (min <= s.i) & (s.i <= max) THEN val := SHORT(s.i) END;
  748.             Texts.Scan(s)
  749.         END GetInt;
  750.     BEGIN
  751.         Amiga.ChangeMode(res);
  752.         IF res#0 THEN
  753.             Amiga.ReadScreenMode(displayID, height, width, depth, oscan, autoScroll);
  754.             ScanFirst(s);
  755.             WHILE s.class = Texts.Name DO
  756.                 IF s.s = "Width" THEN GetInt(width, 320, 16383)
  757.                 ELSIF s.s = "Height" THEN GetInt(height, 200, 16383)
  758.                 ELSIF s.s = "Depth" THEN GetInt(depth, 1, 8)
  759.                 ELSIF s.s = "AutoScroll" THEN
  760.                     Texts.Scan(s);
  761.                     IF s.class = Texts.Name THEN
  762.                         IF s.s = "TRUE" THEN autoScroll := TRUE; Texts.Scan(s)
  763.                         ELSIF s.s = "FALSE" THEN autoScroll := FALSE; Texts.Scan(s)
  764.                         END
  765.                     END
  766.                 ELSE Texts.Scan(s)
  767.                 END
  768.             END;
  769.             Amiga.WriteScreenMode(displayID, height, width, depth, oscan, autoScroll);
  770.             Str("changes take effect after restart!"); Ln;
  771.             Append(Oberon.Log)
  772.         END
  773.     END ChangeMode;
  774.     PROCEDURE ChangePri*;
  775.         VAR s: Texts.Scanner;
  776.         PROCEDURE GetInt(VAR val: SHORTINT; min, max: SHORTINT);
  777.         BEGIN
  778.             IF (s.class = Texts.Int) & (min <= s.i) & (s.i <= max) THEN val := SHORT(SHORT(s.i)) END;
  779.             Texts.Scan(s)
  780.         END GetInt;
  781.     BEGIN
  782.         ScanFirst(s);
  783.         GetInt(Amiga.idlePri, -128, -31);
  784.         GetInt(Amiga.normalPri, Amiga.idlePri, 5);
  785.         Str("System.ChangePri idle normal ="); Integer(Amiga.idlePri); Integer(Amiga.normalPri);
  786.         Ln; Append(Oberon.Log); Amiga.Turbo;
  787.     END ChangePri;
  788.     PROCEDURE AnsiInput*;
  789.     BEGIN
  790.         Amiga.dontConvert:=TRUE;
  791.     END AnsiInput;
  792.     PROCEDURE OberonInput*;
  793.     BEGIN
  794.         Amiga.dontConvert:=FALSE;
  795.     END OberonInput;
  796.     PROCEDURE TwoButtonMouse*;
  797.     BEGIN
  798.         Amiga.useLAltAsMouse:=TRUE;
  799.     END TwoButtonMouse;
  800.     PROCEDURE ThreeButtonMouse*;
  801.     BEGIN
  802.         Amiga.useLAltAsMouse:=FALSE;
  803.     END ThreeButtonMouse;
  804.     PROCEDURE AmigaLoop*;
  805.         VAR s: Texts.Scanner;
  806.     BEGIN
  807.         IF Amiga.TimerOpen THEN
  808.             Amiga.MainLoopType:=TRUE;
  809.             ScanFirst(s);
  810.             IF (s.class=Texts.Int) & (s.i>=1) & (s.i<1000) THEN Amiga.TicsToWait:=1000*s.i END;
  811.         END;
  812.     END AmigaLoop;
  813.     PROCEDURE OberonLoop*;
  814.     BEGIN
  815.         Amiga.MainLoopType:=FALSE;
  816.     END OberonLoop;
  817.     PROCEDURE UseQuitRequester*;
  818.     BEGIN
  819.         Amiga.UseQuitRequester:=TRUE;
  820.     END UseQuitRequester;
  821.     PROCEDURE PictPrintThresh*;
  822.         VAR s: Texts.Scanner;
  823.         PROCEDURE GetInt(VAR val: INTEGER; min, max: INTEGER);
  824.         BEGIN
  825.             IF (s.class = Texts.Int) & (min <= s.i) & (s.i <= max) THEN val := SHORT(s.i) END;
  826.             Texts.Scan(s)
  827.         END GetInt;
  828.     BEGIN
  829.         ScanFirst(s);
  830.         GetInt(Amiga.PictPrintThresh, 0, 255);
  831.     END PictPrintThresh;
  832.     PROCEDURE PrinterName*;
  833.         VAR S: Texts.Scanner;
  834.         (* get parameters from Menu, Text or Selection *)
  835.         PROCEDURE GetPar(VAR S: Texts.Scanner): BOOLEAN;
  836.             VAR
  837.                 text: Texts.Text;
  838.                 beg, end, time: LONGINT;
  839.         BEGIN
  840.             Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
  841.             Texts.Scan(S);
  842.             IF S.class=Texts.Char THEN
  843.                 IF S.c="^" THEN
  844.                     Oberon.GetSelection(text, beg, end, time);
  845.                     IF time=-1 THEN RETURN FALSE; END;
  846.                     Texts.OpenScanner(S, text, beg);
  847.                     Texts.Scan(S)
  848.                 END
  849.             END;
  850.             RETURN TRUE;
  851.         END GetPar;
  852.     BEGIN
  853.         IF GetPar(S) THEN
  854.             IF (S.class=Texts.Name) OR (S.class=Texts.String) THEN
  855.                 COPY(S.s, Amiga.PrinterName)
  856.             END
  857.         END;
  858.         Str("Printer Name: ");
  859.         Str(Amiga.PrinterName); Ln; Append(Oberon.Log)
  860.     END PrinterName;
  861.     PROCEDURE Init;
  862.         VAR t, d: LONGINT;
  863.     BEGIN
  864.         Amiga.InstallTrapHandler(Trap);
  865.         Oberon.User := "";
  866.         Oberon.GetClock(t, d);
  867.         Str(Amiga.version); Ln; Str(copyright); Ln;
  868.         Texts.WriteDate(W, t, d); Ln; Append(Oberon.Log);
  869.         CurrentDirectory
  870.     END Init;
  871.     PROCEDURE OpenViewers;
  872.         VAR logV, toolV: Viewers.Viewer; X, Y: INTEGER;
  873.     BEGIN
  874.         Oberon.AllocateSystemViewer(0, X, Y);
  875.         logV := MenuViewers.New(
  876.             MenuFrame("System.Log", LogMenuText, LogMenu),
  877.             TextFrames.NewText(Oberon.Log, 0),
  878.             TextFrames.menuH, X, Y
  879.         Oberon.AllocateSystemViewer(0, X, Y);
  880.         toolV := MenuViewers.New(
  881.             MenuFrame("System.Tool", SystemMenuText, SystemMenu),
  882.             TextFrames.NewText(TextFrames.Text("System.Tool"), 0),
  883.             TextFrames.menuH, X, Y
  884.     END OpenViewers;
  885. BEGIN
  886.     Texts.OpenWriter(W);
  887.     Oberon.Log := TextFrames.Text("");
  888.     Init;
  889.     IF Modules.ThisMod("Configuration") = NIL THEN OpenViewers END;
  890.     Amiga.SystemHere;
  891. END System.
  892.