blackbox-linux-console/BlackBox/Std/Mod/Debug.txt

MODULE StdDebug;

	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Debug.odc *)
	(* DO NOT EDIT *)

	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.