MODULE StdDebug;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
changes = ""
issues = ""
**)
IMPORT SYSTEM,
Kernel, Strings, Fonts, Services, Ports, Views, Properties, Dialog, Containers, StdFolds,
TextModels, TextMappers, TextViews, TextRulers;
CONST
refViewSize = 9 * Ports.point;
heap = 1; source = 2; module = 3; modules = 4; (* RefView types *)
TYPE
Name = Kernel.Name;
ArrayPtr = POINTER TO RECORD
last, t, first: INTEGER; (* gc header *)
len: ARRAY 16 OF INTEGER (* dynamic array length table *)
END;
RefView = POINTER TO RefViewDesc;
RefViewDesc = RECORD
type: SHORTINT;
command: SHORTINT;
back: RefView;
adr: INTEGER;
desc: Kernel.Type;
ptr: ArrayPtr;
name: Name
END;
Action = POINTER TO RECORD (Services.Action)
text: TextModels.Model
END;
Cluster = POINTER TO RECORD [untagged] (* must correspond to Kernel.Cluster *)
size: INTEGER;
next: Cluster
END;
VAR
out: TextMappers.Formatter;
path: ARRAY 4 OF Ports.Point;
empty: Name;
PROCEDURE NewRuler (): TextRulers.Ruler;
CONST mm = Ports.mm;
VAR r: TextRulers.Ruler;
BEGIN
r := TextRulers.dir.New(NIL);
TextRulers.SetRight(r, 140 * mm);
TextRulers.AddTab(r, 4 * mm); TextRulers.AddTab(r, 34 * mm); TextRulers.AddTab(r, 80 * mm);
RETURN r
END NewRuler;
PROCEDURE OpenViewer (t: TextModels.Model; title: Views.Title; ruler:TextRulers.Ruler);
VAR v: TextViews.View; c: Containers.Controller;
BEGIN
Dialog.MapString(title, title);
v := TextViews.dir.New(t);
v.SetDefaults(ruler, TextViews.dir.defAttr);
c := v.ThisController();
IF c # NIL THEN
c.SetOpts(c.opts - {Containers.noFocus, Containers.noSelection} + {Containers.noCaret})
END;
Views.OpenAux(v, title)
END OpenViewer;
PROCEDURE OpenFold (hidden: ARRAY OF CHAR);
VAR fold: StdFolds.Fold; t: TextModels.Model; w: TextMappers.Formatter;
BEGIN
Dialog.MapString(hidden, hidden);
t := TextModels.dir.New();
w.ConnectTo(t); w.WriteString(hidden);
fold := StdFolds.dir.New(StdFolds.expanded, "", t);
out.WriteView(fold)
END OpenFold;
PROCEDURE CloseFold (collaps: BOOLEAN);
VAR fold: StdFolds.Fold; m: TextModels.Model;
BEGIN
fold := StdFolds.dir.New(StdFolds.expanded, "", NIL);
out.WriteView(fold);
IF collaps THEN fold.Flip(); m := out.rider.Base(); out.SetPos(m.Length()) END
END CloseFold;
PROCEDURE WriteHex (n: INTEGER);
BEGIN
out.WriteIntForm(n, TextMappers.hexadecimal, 9, "0", TextMappers.showBase)
END WriteHex;
PROCEDURE WriteString (adr, len, base: INTEGER; zterm, unicode: BOOLEAN);
CONST beg = 0; char = 1; code = 2;
VAR ch: CHAR; sc: SHORTCHAR; val, mode: INTEGER; str: ARRAY 16 OF CHAR;
BEGIN
mode := beg;
IF base = 2 THEN SYSTEM.GET(adr, ch); val := ORD(ch) ELSE SYSTEM.GET(adr, sc); val := ORD(sc) END;
IF zterm & (val = 0) THEN out.WriteSString('""')
ELSE
REPEAT
IF (val >= ORD(" ")) & (val < 7FH) OR (val > 0A0H) & (val < 100H) OR unicode & (val >= 100H) THEN
IF mode # char THEN
IF mode = code THEN out.WriteSString(", ") END;
out.WriteChar(22X); mode := char
END;
out.WriteChar(CHR(val))
ELSE
IF mode = char THEN out.WriteChar(22X) END;
IF mode # beg THEN out.WriteSString(", ") END;
mode := code; Strings.IntToStringForm(val, Strings.hexadecimal, 1, "0", FALSE, str);
IF str[0] > "9" THEN out.WriteChar("0") END;
out.WriteString(str); out.WriteChar("X")
END;
INC(adr, base); DEC(len);
IF base = 2 THEN SYSTEM.GET(adr, ch); val := ORD(ch) ELSE SYSTEM.GET(adr, sc); val := ORD(sc) END
UNTIL (len = 0) OR zterm & (val = 0)
END;
IF mode = char THEN out.WriteChar(22X) END
END WriteString;
PROCEDURE OutString (s: ARRAY OF CHAR);
VAR str: Dialog.String;
BEGIN
Dialog.MapString(s, str);
out.WriteString(str)
END OutString;
(* -------------------
variable display ------------------- *)
PROCEDURE FormOf (t: Kernel.Type): SHORTCHAR;
BEGIN
IF SYSTEM.VAL(INTEGER, t) DIV 256 = 0 THEN
RETURN SHORT(CHR(SYSTEM.VAL(INTEGER, t)))
ELSE
RETURN SHORT(CHR(16 + t.id MOD 4))
END
END FormOf;
PROCEDURE LenOf (t: Kernel.Type; ptr: ArrayPtr): INTEGER;
BEGIN
IF t.size # 0 THEN RETURN t.size
ELSIF ptr # NIL THEN RETURN ptr.len[t.id DIV 16 MOD 16 - 1]
ELSE RETURN 0
END
END LenOf;
PROCEDURE SizeOf (t: Kernel.Type; ptr: ArrayPtr): INTEGER;
BEGIN
CASE FormOf(t) OF
| 0BX: RETURN 0
| 1X, 2X, 4X: RETURN 1
| 3X, 5X: RETURN 2
| 8X, 0AX: RETURN 8
| 11X: RETURN t.size
| 12X: RETURN LenOf(t, ptr) * SizeOf(t.base[0], ptr)
ELSE RETURN 4
END
END SizeOf;
PROCEDURE WriteName (t: Kernel.Type; ptr: ArrayPtr);
VAR name: Kernel.Name; f: SHORTCHAR;
BEGIN
f := FormOf(t);
CASE f OF
| 0X: OutString("#Dev:Unknown")
| 1X: out.WriteSString("BOOLEAN")
| 2X: out.WriteSString("SHORTCHAR")
| 3X: out.WriteSString("CHAR")
| 4X: out.WriteSString("BYTE")
| 5X: out.WriteSString("SHORTINT")
| 6X: out.WriteSString("INTEGER")
| 7X: out.WriteSString("SHORTREAL")
| 8X: out.WriteSString("REAL")
| 9X: out.WriteSString("SET")
| 0AX: out.WriteSString("LONGINT")
| 0BX: out.WriteSString("ANYREC")
| 0CX: out.WriteSString("ANYPTR")
| 0DX: out.WriteSString("POINTER")
| 0EX: out.WriteSString("PROCEDURE")
| 0FX: out.WriteSString("STRING")
| 10X..13X:
Kernel.GetTypeName(t, name);
IF name = "!" THEN
IF f = 11X THEN out.WriteSString("RECORD")
ELSIF f = 12X THEN out.WriteSString("ARRAY")
ELSE OutString("#Dev:Unknown")
END
ELSIF (t.id DIV 256 # 0) & (t.mod.refcnt >= 0) THEN
out.WriteSString(t.mod.name); out.WriteChar("."); out.WriteSString(name)
ELSIF f = 11X THEN
out.WriteSString(t.mod.name); out.WriteSString(".RECORD")
ELSIF f = 12X THEN
out.WriteSString("ARRAY "); out.WriteInt(LenOf(t, ptr)); t := t.base[0];
WHILE (FormOf(t) = 12X) & ((t.id DIV 256 = 0) OR (t.mod.refcnt < 0)) DO
out.WriteSString(", "); out.WriteInt(LenOf(t, ptr)); t := t.base[0]
END;
out.WriteSString(" OF "); WriteName(t, ptr)
ELSIF f = 13X THEN
out.WriteSString("POINTER")
ELSE
out.WriteSString("PROCEDURE")
END
| 20X: out.WriteSString("COM.IUnknown")
| 21X: out.WriteSString("COM.GUID")
| 22X: out.WriteSString("COM.RESULT")
ELSE OutString("#Dev:UnknownFormat"); out.WriteInt(ORD(f))
END
END WriteName;
PROCEDURE WriteGuid (a: INTEGER);
PROCEDURE Hex (a: INTEGER);
VAR x: SHORTCHAR;
BEGIN
SYSTEM.GET(a, x);
out.WriteIntForm(ORD(x), TextMappers.hexadecimal, 2, "0", FALSE)
END Hex;
BEGIN
out.WriteChar("{");
Hex(a + 3); Hex(a + 2); Hex(a + 1); Hex(a);
out.WriteChar("-");
Hex(a + 5); Hex(a + 4);
out.WriteChar("-");
Hex(a + 7); Hex(a + 6);
out.WriteChar("-");
Hex(a + 8);
Hex(a + 9);
out.WriteChar("-");
Hex(a + 10);
Hex(a + 11);
Hex(a + 12);
Hex(a + 13);
Hex(a + 14);
Hex(a + 15);
out.WriteChar("}")
END WriteGuid;
PROCEDURE^ ShowVar (ad, ind: INTEGER; f, c: SHORTCHAR; desc: Kernel.Type; ptr: ArrayPtr;
back: RefView; VAR name, sel: Name);
PROCEDURE ShowRecord (a, ind: INTEGER; desc: Kernel.Type; back: RefView; VAR sel: Name);
VAR dir: Kernel.Directory; obj: Kernel.Object; name: Kernel.Name; i, j, n: INTEGER; base: Kernel.Type;
BEGIN
WriteName(desc, NIL); out.WriteTab;
IF desc.mod.refcnt >= 0 THEN
OpenFold("#Dev:Fields");
n := desc.id DIV 16 MOD 16; j := 0;
WHILE j <= n DO
base := desc.base[j];
IF base # NIL THEN
dir := base.fields; i := 0;
WHILE i < dir.num DO
obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(dir.obj[i]));
Kernel.GetObjName(base.mod, obj, name);
ShowVar(a + obj.offs, ind, FormOf(obj.struct), 1X, obj.struct, NIL, back, name, sel);
INC(i)
END
END;
INC(j)
END;
out.WriteSString(""); CloseFold((ind > 1) OR (sel # ""))
ELSE
OutString("#Dev:Unloaded")
END
END ShowRecord;
PROCEDURE ShowArray (a, ind: INTEGER; desc: Kernel.Type; ptr: ArrayPtr; back: RefView; VAR sel: Name);
VAR f: SHORTCHAR; i, n, m, size, len: INTEGER; name: Kernel.Name; eltyp, t: Kernel.Type;
vi: SHORTINT; vs: BYTE; str: Dialog.String; high: BOOLEAN;
BEGIN
WriteName(desc, ptr); out.WriteTab;
len := LenOf(desc, ptr); eltyp := desc.base[0]; f := FormOf(eltyp); size := SizeOf(eltyp, ptr);
IF (f = 2X) OR (f = 3X) THEN (* string *)
n := 0; m := len; high := FALSE;
IF f = 2X THEN
REPEAT SYSTEM.GET(a + n, vs); INC(n) UNTIL (n = 32) OR (n = len) OR (vs = 0);
REPEAT DEC(m); SYSTEM.GET(a + m, vs) UNTIL (m = 0) OR (vs # 0)
ELSE
REPEAT
SYSTEM.GET(a + n * 2, vi); INC(n);
IF vi DIV 256 # 0 THEN high := TRUE END
UNTIL (n = len) OR (vi = 0);
n := MIN(n, 32);
REPEAT DEC(m); SYSTEM.GET(a + m * 2, vi) UNTIL (m = 0) OR (vi # 0)
END;
WriteString(a, n, size, TRUE, TRUE);
INC(m, 2);
IF m > len THEN m := len END;
IF high OR (m > n) THEN
out.WriteSString(""); OpenFold("...");
out.WriteLn;
IF high & (n = 32) THEN
WriteString(a, m, size, TRUE, TRUE);
out.WriteLn; out.WriteLn
END;
WriteString(a, m, size, FALSE, FALSE);
IF m < len THEN out.WriteSString(", ..., 0X") END;
out.WriteSString(""); CloseFold(TRUE)
END
ELSE
t := eltyp;
WHILE FormOf(t) = 12X DO t := t.base[0] END;
IF FormOf(t) # 0X THEN
OpenFold("#Dev:Elements");
i := 0;
WHILE i < len DO
Strings.IntToString(i, str);
name := "[" + SHORT(str$) + "]";
ShowVar(a, ind, f, 1X, eltyp, ptr, back, name, sel);
INC(i); INC(a, size)
END;
out.WriteSString(""); CloseFold(TRUE)
END
END
END ShowArray;
PROCEDURE ShowProcVar (a: INTEGER);
VAR vli, n, ref: INTEGER; m: Kernel.Module; name: Kernel.Name;
BEGIN
SYSTEM.GET(a, vli);
Kernel.SearchProcVar(vli, m, vli);
IF m = NIL THEN
IF vli = 0 THEN out.WriteSString("NIL")
ELSE WriteHex(vli)
END
ELSE
IF m.refcnt >= 0 THEN
out.WriteSString(m.name); ref := m.refs;
REPEAT Kernel.GetRefProc(ref, n, name) UNTIL (n = 0) OR (vli < n);
IF vli < n THEN out.WriteChar("."); out.WriteSString(name) END
ELSE
OutString("#Dev:ProcInUnloadedMod");
out.WriteSString(m.name); out.WriteSString(" !!!")
END
END
END ShowProcVar;
PROCEDURE ShowPointer (a: INTEGER; f: SHORTCHAR; desc: Kernel.Type; back: RefView; VAR sel: Name);
VAR adr, x: INTEGER; ptr: ArrayPtr; c: Cluster; btyp: Kernel.Type;
BEGIN
SYSTEM.GET(a, adr);
IF f = 13X THEN btyp := desc.base[0] ELSE btyp := NIL END;
IF adr = 0 THEN out.WriteSString("NIL")
ELSIF f = 20X THEN
out.WriteChar("["); WriteHex(adr); out.WriteChar("]");
out.WriteChar(" "); c := SYSTEM.VAL(Cluster, Kernel.Root());
WHILE (c # NIL) & ((adr < SYSTEM.VAL(INTEGER, c)) OR (adr >= SYSTEM.VAL(INTEGER, c) + c.size)) DO c := c.next END;
IF c # NIL THEN
ptr := SYSTEM.VAL(ArrayPtr, adr)
END
ELSE
IF (f = 13X) OR (f = 0CX) THEN x := adr - 4 ELSE x := adr END;
IF ((adr < -4) OR (adr >= 65536)) & Kernel.IsReadable(x, adr + 16) THEN
out.WriteChar("["); WriteHex(adr); out.WriteChar("]");
IF (f = 13X) OR (f = 0CX) THEN
out.WriteChar(" "); c := SYSTEM.VAL(Cluster, Kernel.Root());
WHILE (c # NIL) & ((adr < SYSTEM.VAL(INTEGER, c)) OR (adr >= SYSTEM.VAL(INTEGER, c) + c.size)) DO
c := c.next
END;
IF c # NIL THEN
ptr := SYSTEM.VAL(ArrayPtr, adr);
IF (f = 13X) & (FormOf(btyp) = 12X) THEN (* array *)
adr := SYSTEM.ADR(ptr.len[btyp.id DIV 16 MOD 16])
END
ELSE OutString("#Dev:IllegalPointer")
END
END
ELSE OutString("#Dev:IllegalAddress"); WriteHex(adr)
END
END
END ShowPointer;
PROCEDURE ShowSelector (ref: RefView);
VAR b: RefView; n: SHORTINT; a, a0: TextModels.Attributes;
BEGIN
b := ref.back; n := 1;
IF b # NIL THEN
WHILE (b.name = ref.name) & (b.back # NIL) DO INC(n); b := b.back END;
ShowSelector(b);
IF n > 1 THEN out.WriteChar("(") END;
out.WriteChar(".")
END;
out.WriteSString(ref.name);
IF ref.type = heap THEN out.WriteChar("^") END;
IF n > 1 THEN
out.WriteChar(")");
a0 := out.rider.attr; a := TextModels.NewOffset(a0, 2 * Ports.point);
out.rider.SetAttr(a);
out.WriteInt(n); out.rider.SetAttr(a0)
END
END ShowSelector;
PROCEDURE ShowVar (ad, ind: INTEGER; f, c: SHORTCHAR; desc: Kernel.Type; ptr: ArrayPtr; back: RefView;
VAR name, sel: Name);
VAR i, j, vli, a: INTEGER; tsel: Name; a0: TextModels.Attributes;
vc: SHORTCHAR; vsi: BYTE; vi: SHORTINT; vr: SHORTREAL; vlr: REAL; vs: SET;
BEGIN
out.WriteLn; out.WriteTab; i := 0;
WHILE i < ind DO out.WriteSString(""); INC(i) END;
a := ad; i := 0; j := 0;
IF sel # "" THEN
WHILE sel[i] # 0X DO tsel[i] := sel[i]; INC(i) END;
IF (tsel[i-1] # ":") & (name[0] # "[") THEN tsel[i] := "."; INC(i) END
END;
WHILE name[j] # 0X DO tsel[i] := name[j]; INC(i); INC(j) END;
tsel[i] := 0X;
a0 := out.rider.attr;
IF c = 3X THEN (* varpar *)
SYSTEM.GET(ad, a);
out.rider.SetAttr(TextModels.NewStyle(a0, {Fonts.italic}))
END;
IF name[0] # "[" THEN out.WriteChar(".") END;
out.WriteSString(name);
out.rider.SetAttr(a0); out.WriteTab;
IF (c = 3X) & (a >= 0) & (a < 65536) THEN
out.WriteTab; out.WriteSString("NIL VARPAR")
ELSIF f = 11X THEN
Kernel.GetTypeName(desc, name);
IF (c = 3X) & (name[0] # "!") THEN SYSTEM.GET(ad + 4, desc) END; (* dynamic type *)
ShowRecord(a, ind + 1, desc, back, tsel)
ELSIF (c = 3X) & (f = 0BX) THEN (* VAR anyrecord *)
SYSTEM.GET(ad + 4, desc);
ShowRecord(a, ind + 1, desc, back, tsel)
ELSIF f = 12X THEN
IF (desc.size = 0) & (ptr = NIL) THEN SYSTEM.GET(ad, a) END; (* dyn array val par *)
IF ptr = NIL THEN ptr := SYSTEM.VAL(ArrayPtr, ad - 8) END;
ShowArray(a, ind + 1, desc, ptr, back, tsel)
ELSE
IF desc = NIL THEN desc := SYSTEM.VAL(Kernel.Type, ORD(f)) END;
WriteName(desc, NIL); out.WriteTab;
CASE f OF
| 0X: (* SYSTEM.GET(a, vli); WriteHex(vli) *)
| 1X: SYSTEM.GET(a, vc);
IF vc = 0X THEN out.WriteSString("FALSE")
ELSIF vc = 1X THEN out.WriteSString("TRUE")
ELSE OutString("#Dev:Undefined"); out.WriteInt(ORD(vc))
END
| 2X: WriteString(a, 1, 1, FALSE, FALSE)
| 3X: WriteString(a, 1, 2, FALSE, TRUE);
SYSTEM.GET(a, vi);
IF vi DIV 256 # 0 THEN out.WriteString(""); WriteString(a, 1, 2, FALSE, FALSE) END
| 4X: SYSTEM.GET(a, vsi); out.WriteInt(vsi)
| 5X: SYSTEM.GET(a, vi); out.WriteInt(vi)
| 6X: SYSTEM.GET(a, vli); out.WriteInt(vli)
| 7X: SYSTEM.GET(a, vr); out.WriteReal(vr)
| 8X: SYSTEM.GET(a, vlr); out.WriteReal(vlr)
| 9X: SYSTEM.GET(a, vs); out.WriteSet(vs)
| 0AX: SYSTEM.GET(a, vli); SYSTEM.GET(a + 4, i);
IF (vli >= 0) & (i = 0) OR (vli < 0) & (i = -1) THEN out.WriteInt(vli)
ELSE out.WriteIntForm(i, TextMappers.hexadecimal, 8, "0", TextMappers.hideBase); WriteHex(vli)
END
| 0CX, 0DX, 13X, 20X: ShowPointer(a, f, desc, back, tsel)
| 0EX, 10X: ShowProcVar(a)
| 0FX: WriteString(a, 256, 1, TRUE, FALSE)
| 21X: WriteGuid(a)
| 22X: SYSTEM.GET(a, vli); WriteHex(vli)
ELSE
END
END
END ShowVar;
PROCEDURE ShowStack;
VAR ref, end, i, j, x, a, b, c: INTEGER; m, f: SHORTCHAR; mod: Kernel.Module; name, sel: Kernel.Name;
d: Kernel.Type;
BEGIN
a := Kernel.pc; b := Kernel.fp; c := 100;
REPEAT
mod := Kernel.modList;
WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
IF mod # NIL THEN
DEC(a, mod.code);
IF mod.refcnt >= 0 THEN
out.WriteChar(" "); out.WriteSString(mod.name); ref := mod.refs;
REPEAT Kernel.GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
IF a < end THEN
out.WriteChar("."); out.WriteSString(name);
sel := mod.name$; i := 0;
WHILE sel[i] # 0X DO INC(i) END;
sel[i] := "."; INC(i); j := 0;
WHILE name[j] # 0X DO sel[i] := name[j]; INC(i); INC(j) END;
sel[i] := ":"; sel[i+1] := 0X;
out.WriteSString("["); WriteHex(a);
out.WriteSString("] ");
i := Kernel.SourcePos(mod, 0);
IF name # "$$" THEN
Kernel.GetRefVar(ref, m, f, d, x, name);
WHILE m # 0X DO
IF name[0] # "@" THEN ShowVar(b + x, 0, f, m, d, NIL, NIL, name, sel) END;
Kernel.GetRefVar(ref, m, f, d, x, name)
END
END;
out.WriteLn
ELSE out.WriteSString(".???"); out.WriteLn
END
ELSE
out.WriteChar("("); out.WriteSString(mod.name);
out.WriteSString(")(pc="); WriteHex(a);
out.WriteSString(",fp="); WriteHex(b); out.WriteChar(")");
out.WriteLn
END
ELSE
out.WriteSString("<system>(pc="); WriteHex(a);
out.WriteSString(",fp="); WriteHex(b); out.WriteChar(")");
out.WriteLn
END;
IF (b >= Kernel.fp) & (b < Kernel.stack) THEN
SYSTEM.GET(b+4, a); (* stacked pc *)
SYSTEM.GET(b, b); (* dynamic link *)
DEC(a); DEC(c)
ELSE c := 0
END
UNTIL c = 0
END ShowStack;
PROCEDURE (a: Action) Do; (* delayed trap window open *)
BEGIN
Kernel.SetTrapGuard(TRUE);
OpenViewer(a.text, "#Dev:Trap", NewRuler());
Kernel.SetTrapGuard(FALSE);
END Do;
PROCEDURE GetTrapMsg(OUT msg: ARRAY OF CHAR);
VAR ref, end, a: INTEGER; mod: Kernel.Module; name: Kernel.Name; head, tail, errstr: ARRAY 32 OF CHAR;
key: ARRAY 128 OF CHAR;
BEGIN
a := Kernel.pc; mod := Kernel.modList;
WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
IF mod # NIL THEN
DEC(a, mod.code); ref := mod.refs;
REPEAT Kernel.GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
IF a < end THEN
Kernel.SplitName (mod.name$, head, tail);
IF head = "" THEN head := "System" END;
Strings.IntToString(Kernel.err, errstr);
key := tail + "." + name + "." + errstr;
Dialog.MapString("#" + head + ":" + key, msg);
(* IF key # msg THEN out.WriteString(" " + msg) END; *)
IF key = msg THEN msg := "" END;
END
END
END GetTrapMsg;
PROCEDURE Trap;
VAR a0: TextModels.Attributes; action: Action; msg: ARRAY 512 OF CHAR;
BEGIN
out.ConnectTo(TextModels.dir.New());
a0 := out.rider.attr;
out.rider.SetAttr(TextModels.NewWeight(a0, Fonts.bold));
IF Kernel.err = 129 THEN out.WriteSString("invalid WITH")
ELSIF Kernel.err = 130 THEN out.WriteSString("invalid CASE")
ELSIF Kernel.err = 131 THEN out.WriteSString("function without RETURN")
ELSIF Kernel.err = 132 THEN out.WriteSString("type guard")
ELSIF Kernel.err = 133 THEN out.WriteSString("implied type guard")
ELSIF Kernel.err = 134 THEN out.WriteSString("value out of range")
ELSIF Kernel.err = 135 THEN out.WriteSString("index out of range")
ELSIF Kernel.err = 136 THEN out.WriteSString("string too long")
ELSIF Kernel.err = 137 THEN out.WriteSString("stack overflow")
ELSIF Kernel.err = 138 THEN out.WriteSString("integer overflow")
ELSIF Kernel.err = 139 THEN out.WriteSString("division by zero")
ELSIF Kernel.err = 140 THEN out.WriteSString("infinite real result")
ELSIF Kernel.err = 141 THEN out.WriteSString("real underflow")
ELSIF Kernel.err = 142 THEN out.WriteSString("real overflow")
ELSIF Kernel.err = 143 THEN out.WriteSString("undefined real result")
ELSIF Kernel.err = 144 THEN out.WriteSString("not a number")
ELSIF Kernel.err = 200 THEN out.WriteSString("keyboard interrupt")
ELSIF Kernel.err = 201 THEN
out.WriteSString("NIL dereference")
ELSIF Kernel.err = 202 THEN
out.WriteSString("illegal instruction: ");
out.WriteIntForm(Kernel.val, TextMappers.hexadecimal, 5, "0", TextMappers.showBase)
ELSIF Kernel.err = 203 THEN
IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL dereference (read)")
ELSE out.WriteSString("illegal memory read (ad = "); WriteHex(Kernel.val); out.WriteChar(")")
END
ELSIF Kernel.err = 204 THEN
IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL dereference (write)")
ELSE out.WriteSString("illegal memory write (ad = "); WriteHex(Kernel.val); out.WriteChar(")")
END
ELSIF Kernel.err = 205 THEN
IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL procedure call")
ELSE out.WriteSString("illegal execution (ad = "); WriteHex(Kernel.val); out.WriteChar(")")
END
ELSIF Kernel.err = 257 THEN out.WriteSString("out of memory")
ELSIF Kernel.err = 10001H THEN out.WriteSString("bus error")
ELSIF Kernel.err = 10002H THEN out.WriteSString("address error")
ELSIF Kernel.err = 10007H THEN out.WriteSString("fpu error")
ELSIF Kernel.err < 0 THEN
out.WriteSString("Exception "); out.WriteIntForm(-Kernel.err, TextMappers.hexadecimal, 3, "0", TextMappers.showBase)
ELSE
out.WriteSString("TRAP "); out.WriteInt(Kernel.err);
IF Kernel.err = 126 THEN out.WriteSString("(not yet implemented)")
ELSIF Kernel.err = 125 THEN out.WriteSString("(call of obsolete procedure)")
ELSIF Kernel.err >= 100 THEN out.WriteSString("(invariant violated)")
ELSIF Kernel.err >= 60 THEN out.WriteSString("(postcondition violated)")
ELSIF Kernel.err >= 20 THEN out.WriteSString("(precondition violated)")
END
END;
GetTrapMsg(msg);
IF msg # "" THEN out.WriteLn; out.WriteString(msg) END;
out.WriteLn; out.rider.SetAttr(a0);
out.WriteLn; ShowStack;
NEW(action); action.text := out.rider.Base();
Services.DoLater(action, Services.now);
out.ConnectTo(NIL)
END Trap;
BEGIN
Kernel.InstallTrapViewer(Trap);
empty := "";
path[0].x := refViewSize DIV 2; path[0].y := 0;
path[1].x := refViewSize; path[1].y := refViewSize DIV 2;
path[2].x := refViewSize DIV 2; path[2].y := refViewSize;
path[3].x := 0; path[3].y := refViewSize DIV 2;
END StdDebug.