MODULE StdDebug;
(**
	project	= "BlackBox 2.0, new module"
	organizations	= "Oberon microsystems, BBWFC, OberonCore, BBCP Team"
	contributors	= "Oberon microsystems"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	changes	= "
	- 20070123, bh, WriteString, ShowArray, & ShowVar changed (Unicode support)
	- 20141027, center #19, full Unicode support for Component Pascal identifiers added
	- 20150929, center #72, speeding up the dump of large data structures by avoiding fold.Flip
	- 20170215, center #139, localization support for error messages
	- 20181207, center #195, support for long identifiers in trap handlers
	"
	issues	= "
	- ...
	"

**)

	IMPORT SYSTEM, Kernel,
		Utf, Strings, Fonts, Services, Ports, Views, Properties, Dialog, Containers, StdFolds,
		TextModels, TextMappers, TextViews, TextRulers, Librarian;
	
	CONST
		refViewSize = 9 * Ports.point;
		
		heap = 1; source = 2; module = 3; modules = 4;	(* RefView types *)
		
	TYPE
		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: Kernel.Utf8Name
		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;
		
		FoldContext = RECORD
			prevText: TextModels.Model;
			prevPos: INTEGER
		END;
		
	
	VAR
		out: TextMappers.Formatter;


	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 (OUT fc: FoldContext);
	BEGIN
		fc.prevText := out.rider.Base();
		fc.prevPos := out.Pos();
		out.ConnectTo(TextModels.dir.New())
	END OpenFold;

	PROCEDURE CloseFold (IN fc: FoldContext; collapsed: BOOLEAN; IN hidden: ARRAY OF CHAR);
		VAR fold: StdFolds.Fold; t: TextModels.Model; w: TextMappers.Formatter; hiddenx: ARRAY 32 OF CHAR;
	BEGIN
		Dialog.MapString(hidden, hiddenx);
		(* avoid expensive fold.Flip operation *)
		IF collapsed THEN
			fold := StdFolds.dir.New(StdFolds.collapsed, "", out.rider.Base());
			out.ConnectTo(fc.prevText);
			out.WriteView(fold);
			out.WriteString(hiddenx)
		ELSE
			t := TextModels.dir.New();
			w.ConnectTo(t); w.WriteString(hiddenx);
			fold := StdFolds.dir.New(StdFolds.expanded, "", t);
			t := out.rider.Base();
			out.ConnectTo(fc.prevText);
			out.WriteView(fold);
			fc.prevText.Insert(out.Pos(), t, 0, t.Length());
			out.SetPos(out.rider.Base().Length())
		END;
		fold := StdFolds.dir.New(collapsed, "", NIL);
		out.WriteView(fold)
	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.WriteString('""')
		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.WriteString(", ") 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.WriteString(", ") 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 (IN 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 modName, name: Kernel.Name; f: SHORTCHAR;
	BEGIN
		f := FormOf(t);
		CASE f OF
		| 0X: OutString("#Dev:Unknown")
		| 1X: out.WriteString("BOOLEAN")
		| 2X: out.WriteString("SHORTCHAR")
		| 3X: out.WriteString("CHAR")
		| 4X: out.WriteString("BYTE")
		| 5X: out.WriteString("SHORTINT")
		| 6X: out.WriteString("INTEGER")
		| 7X: out.WriteString("SHORTREAL")
		| 8X: out.WriteString("REAL")
		| 9X: out.WriteString("SET")
		| 0AX: out.WriteString("LONGINT")
		| 0BX: out.WriteString("ANYREC")
		| 0CX: out.WriteString("ANYPTR")
		| 0DX: out.WriteString("POINTER")
		| 0EX: out.WriteString("PROCEDURE")
		| 0FX: out.WriteString("STRING")
		| 10X..13X:
			Kernel.GetTypeName(t, name);
			IF name = "!" THEN
				IF f = 11X THEN out.WriteString("RECORD")
				ELSIF f = 12X THEN out.WriteString("ARRAY")
				ELSE OutString("#Dev:Unknown")
				END
			ELSIF (t.id DIV 256 # 0) & (t.mod.refcnt >= 0) THEN
				Kernel.GetModName(t.mod, modName); out.WriteString(modName); out.WriteChar("."); out.WriteString(name)
			ELSIF f = 11X THEN
				Kernel.GetModName(t.mod, modName); out.WriteString(modName); out.WriteString(".RECORD") 
			ELSIF f = 12X THEN
				out.WriteString("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.WriteString(", "); out.WriteInt(LenOf(t, ptr)); t := t.base[0]
				END;
				out.WriteString(" OF "); WriteName(t, ptr)
			ELSIF f = 13X THEN
				out.WriteString("POINTER")
			ELSE
				out.WriteString("PROCEDURE")
			END
		| 20X: out.WriteString("COM.IUnknown")
		| 21X: out.WriteString("COM.GUID")
		| 22X: out.WriteString("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: Kernel.Name);
	
	PROCEDURE ShowRecord (a, ind: INTEGER; desc: Kernel.Type; back: RefView; VAR sel: Kernel.Name);
		VAR dir: Kernel.Directory; obj: Kernel.Object; name: Kernel.Name; i, j, n: INTEGER; base: Kernel.Type;
			fc: FoldContext;
	BEGIN
		WriteName(desc, NIL); out.WriteTab;
		IF desc.mod.refcnt >= 0 THEN
			OpenFold(fc);
			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.WriteString("   ");
			CloseFold(fc, (ind > 1) OR (sel # ""), "#Dev:Fields")
		ELSE
			OutString("#Dev:Unloaded")
		END
	END ShowRecord;
	
	PROCEDURE ShowArray (a, ind: INTEGER; desc: Kernel.Type; ptr: ArrayPtr; back: RefView; VAR sel: Kernel.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;
			fc: FoldContext;
	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.WriteString("   ");
				OpenFold(fc);
				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.WriteString(", ..., 0X") END;
				out.WriteString("   ");
				CloseFold(fc, TRUE, "...")
			END
		ELSE
			t := eltyp;
			WHILE FormOf(t) = 12X DO t := t.base[0] END;
			IF FormOf(t) # 0X THEN
				OpenFold(fc);
				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.WriteString("   ");
				CloseFold(fc, StdFolds.collapsed, "#Dev:Elements")
			END
		END
	END ShowArray;
	
	PROCEDURE ShowProcVar (a: INTEGER);
		VAR vli, n, ref: INTEGER; m: Kernel.Module; modName, name: Kernel.Name; res: INTEGER; nn: Kernel.Utf8Name;
	BEGIN
		SYSTEM.GET(a, vli);
		Kernel.SearchProcVar(vli, m, vli);
		IF m = NIL THEN
			IF vli = 0 THEN out.WriteString("NIL")
			ELSE WriteHex(vli)
			END
		ELSE
			IF m.refcnt >= 0 THEN
				Kernel.GetModName(m, modName); out.WriteString(modName); ref := m.refs;
				REPEAT Kernel.GetRefProc(ref, n, nn) UNTIL (n = 0) OR (vli < n);
				IF vli < n THEN out.WriteChar("."); Utf.Utf8ToString(nn, name, res); out.WriteString(name) END
			ELSE
				OutString("#Dev:ProcInUnloadedMod");
				Kernel.GetModName(m, modName); out.WriteString(modName); out.WriteString(" !!!")
			END
		END
	END ShowProcVar;

	PROCEDURE ShowPointer (a: INTEGER; f: SHORTCHAR; desc: Kernel.Type; back: RefView; VAR sel: Kernel.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.WriteString("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; res: INTEGER; nn: Kernel.Name;
	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;
		Utf.Utf8ToString(ref.name, nn, res); out.WriteString(nn);
		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: Kernel.Name);
		VAR i, j, vli, a: INTEGER; tsel: Kernel.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.WriteString("  "); 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.WriteString(name);
		out.rider.SetAttr(a0); out.WriteTab;
		IF (c = 3X) & (a >= 0) & (a < 65536) THEN 
			out.WriteTab; out.WriteString("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.WriteString("FALSE")
				ELSIF vc = 1X THEN out.WriteString("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; modName, name, sel: Kernel.Name;
			d: Kernel.Type; res: INTEGER; nn: Kernel.Utf8Name;
	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
				Kernel.GetModName(mod, modName); out.WriteChar(" "); out.WriteString(modName); ref := mod.refs;
					REPEAT Kernel.GetRefProc(ref, end, nn) UNTIL (end = 0) OR (a < end);
					IF a < end THEN
						Utf.Utf8ToString(nn, name, res); out.WriteChar("."); out.WriteString(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.WriteString("   ["); WriteHex(a);
						out.WriteString("] ");
						i := Kernel.SourcePos(mod, 0);
						IF name # "$$" THEN
							Kernel.GetRefVar(ref, m, f, d, x, nn); Utf.Utf8ToString(nn, name, res);
							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, nn); Utf.Utf8ToString(nn, name, res)
							END
						END;
						out.WriteLn
					ELSE out.WriteString(".???"); out.WriteLn
					END
				ELSE
					Kernel.GetModName(mod, modName); out.WriteChar("("); out.WriteString(modName);
					out.WriteString(")   (pc="); WriteHex(a);
					out.WriteString(",  fp="); WriteHex(b); out.WriteChar(")");
					out.WriteLn
				END
			ELSE
				out.WriteString("<system>   (pc="); WriteHex(a);
				out.WriteString(",  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, res: INTEGER; mod: Kernel.Module; nn: Kernel.Utf8Name;
			name, head, tail: Kernel.Name; errstr: ARRAY 12 OF CHAR;
			key: ARRAY Kernel.nameLen * 3 + LEN(errstr) OF CHAR;
	BEGIN
		a := Kernel.pc; mod := Kernel.modList; msg := "";
		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, nn) UNTIL (end = 0) OR (a < end);
			Utf.Utf8ToString(nn, name, res);
			IF a < end THEN
				Kernel.GetModName(mod, head);
				Librarian.lib.SplitName(head, head, tail);
				Strings.IntToString(Kernel.err, errstr);
				key := tail + "." + name + "." + errstr;
				Dialog.MapString("#" + head + ":" + key, msg);
				IF msg = key THEN msg := "" END
			END
		END
	END GetTrapMsg;

	PROCEDURE OutAdr (adr: INTEGER);
	BEGIN
		out.WriteString(" ("); OutString("#System:adr"); out.WriteString(" = "); WriteHex(adr); out.WriteChar(")")
	END OutAdr;

	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 OutString("#System:invalid WITH")
		ELSIF Kernel.err = 130 THEN OutString("#System:invalid CASE")
		ELSIF Kernel.err = 131 THEN OutString("#System:function without RETURN")
		ELSIF Kernel.err = 132 THEN OutString("#System:type guard")
		ELSIF Kernel.err = 133 THEN OutString("#System:implied type guard")
		ELSIF Kernel.err = 134 THEN OutString("#System:value out of range")
		ELSIF Kernel.err = 135 THEN OutString("#System:index out of range")
		ELSIF Kernel.err = 136 THEN OutString("#System:string too long")
		ELSIF Kernel.err = 137 THEN OutString("#System:stack overflow")
		ELSIF Kernel.err = 138 THEN OutString("#System:integer overflow")
		ELSIF Kernel.err = 139 THEN OutString("#System:division by zero")
		ELSIF Kernel.err = 140 THEN OutString("#System:infinite real result")
		ELSIF Kernel.err = 141 THEN OutString("#System:real underflow")
		ELSIF Kernel.err = 142 THEN OutString("#System:real overflow")
		ELSIF Kernel.err = 143 THEN
			OutString("#System:undefined real result"); out.WriteString(" (");
			out.WriteIntForm(Kernel.val MOD 10000H, TextMappers.hexadecimal, 4, "0", TextMappers.hideBase); out.WriteString(", ");
			out.WriteIntForm(Kernel.val DIV 10000H, TextMappers.hexadecimal, 3, "0", TextMappers.hideBase); out.WriteChar(")")
		ELSIF Kernel.err = 144 THEN OutString("#System:not a number")
		ELSIF Kernel.err = 200 THEN OutString("#System:keyboard interrupt")
		ELSIF Kernel.err = 201 THEN
			OutString("#System:NIL dereference")
		ELSIF Kernel.err = 202 THEN
			OutString("#System:illegal instruction"); out.WriteString(": ");
			out.WriteIntForm(Kernel.val, TextMappers.hexadecimal, 5, "0", TextMappers.showBase)
		ELSIF Kernel.err = 203 THEN
			IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN OutString("#System:NIL dereference (read)")
			ELSE OutString("#System:illegal memory read"); OutAdr(Kernel.val)
			END
		ELSIF Kernel.err = 204 THEN
			IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN OutString("#System:NIL dereference (write)")
			ELSE OutString("#System:illegal memory write"); OutAdr(Kernel.val)
			END
		ELSIF Kernel.err = 205 THEN
			IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN OutString("#System:NIL procedure call")
			ELSE OutString("#System:illegal execution"); OutAdr(Kernel.val)
			END
		ELSIF Kernel.err = 257 THEN OutString("#System:out of memory")
		ELSIF Kernel.err = 10001H THEN OutString("#System:bus error")
		ELSIF Kernel.err = 10002H THEN OutString("#System:address error")
		ELSIF Kernel.err = 10007H THEN OutString("#System:fpu error")
		ELSIF Kernel.err < 0 THEN
			OutString("#System:Exception");  out.WriteChar(" ");
			out.WriteIntForm(-Kernel.err, TextMappers.hexadecimal, 3, "0", TextMappers.showBase)
		ELSE
			OutString("#System:TRAP"); out.WriteChar(" "); out.WriteInt(Kernel.err);
			IF Kernel.err = 126 THEN out.WriteString("  ("); OutString("#System:not yet implemented");  out.WriteChar(")")
			ELSIF Kernel.err = 125 THEN out.WriteString("  ("); OutString("#System:call of obsolete procedure");  out.WriteChar(")")
			ELSIF Kernel.err >= 100 THEN out.WriteString("  ("); OutString("#System:invariant violated");  out.WriteChar(")")
			ELSIF Kernel.err >= 60 THEN out.WriteString("  ("); OutString("#System:postcondition violated");  out.WriteChar(")")
			ELSIF Kernel.err >= 20 THEN out.WriteString("  ("); OutString("#System:precondition violated");  out.WriteChar(")")
			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);
END StdDebug.
