DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / bbcp.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Port, TODO
[bbcp.git] / Trurl-based / Std / Mod / Debug.txt
1 MODULE StdDebug;
2
3 (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Debug.odc *)
4 (* DO NOT EDIT *)
5
6 IMPORT SYSTEM,
7 Kernel, Strings, Fonts, Services, Ports, Views, Properties, Dialog, Containers, StdFolds,
8 TextModels, TextMappers, TextViews, TextRulers;
9
10 CONST
11 refViewSize = 9 * Ports.point;
12
13 heap = 1; source = 2; module = 3; modules = 4; (* RefView types *)
14
15 TYPE
16 Name = Kernel.Name;
17
18 ArrayPtr = POINTER TO RECORD
19 last, t, first: INTEGER; (* gc header *)
20 len: ARRAY 16 OF INTEGER (* dynamic array length table *)
21 END;
22
23 RefView = POINTER TO RefViewDesc;
24
25 RefViewDesc = RECORD
26 type: SHORTINT;
27 command: SHORTINT;
28 back: RefView;
29 adr: INTEGER;
30 desc: Kernel.Type;
31 ptr: ArrayPtr;
32 name: Name
33 END;
34
35 Action = POINTER TO RECORD (Services.Action)
36 text: TextModels.Model
37 END;
38
39 Cluster = POINTER TO RECORD [untagged] (* must correspond to Kernel.Cluster *)
40 size: INTEGER;
41 next: Cluster
42 END;
43
44
45 VAR
46 out: TextMappers.Formatter;
47 path: ARRAY 4 OF Ports.Point;
48 empty: Name;
49
50
51 PROCEDURE NewRuler (): TextRulers.Ruler;
52 CONST mm = Ports.mm;
53 VAR r: TextRulers.Ruler;
54 BEGIN
55 r := TextRulers.dir.New(NIL);
56 TextRulers.SetRight(r, 140 * mm);
57 TextRulers.AddTab(r, 4 * mm); TextRulers.AddTab(r, 34 * mm); TextRulers.AddTab(r, 80 * mm);
58 RETURN r
59 END NewRuler;
60
61 PROCEDURE OpenViewer (t: TextModels.Model; title: Views.Title; ruler:TextRulers.Ruler);
62 VAR v: TextViews.View; c: Containers.Controller;
63 BEGIN
64 Dialog.MapString(title, title);
65 v := TextViews.dir.New(t);
66 v.SetDefaults(ruler, TextViews.dir.defAttr);
67 c := v.ThisController();
68 IF c # NIL THEN
69 c.SetOpts(c.opts - {Containers.noFocus, Containers.noSelection} + {Containers.noCaret})
70 END;
71 Views.OpenAux(v, title)
72 END OpenViewer;
73
74 PROCEDURE OpenFold (hidden: ARRAY OF CHAR);
75 VAR fold: StdFolds.Fold; t: TextModels.Model; w: TextMappers.Formatter;
76 BEGIN
77 Dialog.MapString(hidden, hidden);
78 t := TextModels.dir.New();
79 w.ConnectTo(t); w.WriteString(hidden);
80 fold := StdFolds.dir.New(StdFolds.expanded, "", t);
81 out.WriteView(fold)
82 END OpenFold;
83
84 PROCEDURE CloseFold (collaps: BOOLEAN);
85 VAR fold: StdFolds.Fold; m: TextModels.Model;
86 BEGIN
87 fold := StdFolds.dir.New(StdFolds.expanded, "", NIL);
88 out.WriteView(fold);
89 IF collaps THEN fold.Flip(); m := out.rider.Base(); out.SetPos(m.Length()) END
90 END CloseFold;
91
92 PROCEDURE WriteHex (n: INTEGER);
93 BEGIN
94 out.WriteIntForm(n, TextMappers.hexadecimal, 9, "0", TextMappers.showBase)
95 END WriteHex;
96
97 PROCEDURE WriteString (adr, len, base: INTEGER; zterm, unicode: BOOLEAN);
98 CONST beg = 0; char = 1; code = 2;
99 VAR ch: CHAR; sc: SHORTCHAR; val, mode: INTEGER; str: ARRAY 16 OF CHAR;
100 BEGIN
101 mode := beg;
102 IF base = 2 THEN SYSTEM.GET(adr, ch); val := ORD(ch) ELSE SYSTEM.GET(adr, sc); val := ORD(sc) END;
103 IF zterm & (val = 0) THEN out.WriteSString('""')
104 ELSE
105 REPEAT
106 IF (val >= ORD(" ")) & (val < 7FH) OR (val > 0A0H) & (val < 100H) OR unicode & (val >= 100H) THEN
107 IF mode # char THEN
108 IF mode = code THEN out.WriteSString(", ") END;
109 out.WriteChar(22X); mode := char
110 END;
111 out.WriteChar(CHR(val))
112 ELSE
113 IF mode = char THEN out.WriteChar(22X) END;
114 IF mode # beg THEN out.WriteSString(", ") END;
115 mode := code; Strings.IntToStringForm(val, Strings.hexadecimal, 1, "0", FALSE, str);
116 IF str[0] > "9" THEN out.WriteChar("0") END;
117 out.WriteString(str); out.WriteChar("X")
118 END;
119 INC(adr, base); DEC(len);
120 IF base = 2 THEN SYSTEM.GET(adr, ch); val := ORD(ch) ELSE SYSTEM.GET(adr, sc); val := ORD(sc) END
121 UNTIL (len = 0) OR zterm & (val = 0)
122 END;
123 IF mode = char THEN out.WriteChar(22X) END
124 END WriteString;
125
126 PROCEDURE OutString (s: ARRAY OF CHAR);
127 VAR str: Dialog.String;
128 BEGIN
129 Dialog.MapString(s, str);
130 out.WriteString(str)
131 END OutString;
132
133 (* ------------------- variable display ------------------- *)
134
135 PROCEDURE FormOf (t: Kernel.Type): SHORTCHAR;
136 BEGIN
137 IF SYSTEM.VAL(INTEGER, t) DIV 256 = 0 THEN
138 RETURN SHORT(CHR(SYSTEM.VAL(INTEGER, t)))
139 ELSE
140 RETURN SHORT(CHR(16 + t.id MOD 4))
141 END
142 END FormOf;
143
144 PROCEDURE LenOf (t: Kernel.Type; ptr: ArrayPtr): INTEGER;
145 BEGIN
146 IF t.size # 0 THEN RETURN t.size
147 ELSIF ptr # NIL THEN RETURN ptr.len[t.id DIV 16 MOD 16 - 1]
148 ELSE RETURN 0
149 END
150 END LenOf;
151
152 PROCEDURE SizeOf (t: Kernel.Type; ptr: ArrayPtr): INTEGER;
153 BEGIN
154 CASE FormOf(t) OF
155 | 0BX: RETURN 0
156 | 1X, 2X, 4X: RETURN 1
157 | 3X, 5X: RETURN 2
158 | 8X, 0AX: RETURN 8
159 | 11X: RETURN t.size
160 | 12X: RETURN LenOf(t, ptr) * SizeOf(t.base[0], ptr)
161 ELSE RETURN 4
162 END
163 END SizeOf;
164
165 PROCEDURE WriteName (t: Kernel.Type; ptr: ArrayPtr);
166 VAR name: Kernel.Name; f: SHORTCHAR;
167 BEGIN
168 f := FormOf(t);
169 CASE f OF
170 | 0X: OutString("#Dev:Unknown")
171 | 1X: out.WriteSString("BOOLEAN")
172 | 2X: out.WriteSString("SHORTCHAR")
173 | 3X: out.WriteSString("CHAR")
174 | 4X: out.WriteSString("BYTE")
175 | 5X: out.WriteSString("SHORTINT")
176 | 6X: out.WriteSString("INTEGER")
177 | 7X: out.WriteSString("SHORTREAL")
178 | 8X: out.WriteSString("REAL")
179 | 9X: out.WriteSString("SET")
180 | 0AX: out.WriteSString("LONGINT")
181 | 0BX: out.WriteSString("ANYREC")
182 | 0CX: out.WriteSString("ANYPTR")
183 | 0DX: out.WriteSString("POINTER")
184 | 0EX: out.WriteSString("PROCEDURE")
185 | 0FX: out.WriteSString("STRING")
186 | 10X..13X:
187 Kernel.GetTypeName(t, name);
188 IF name = "!" THEN
189 IF f = 11X THEN out.WriteSString("RECORD")
190 ELSIF f = 12X THEN out.WriteSString("ARRAY")
191 ELSE OutString("#Dev:Unknown")
192 END
193 ELSIF (t.id DIV 256 # 0) & (t.mod.refcnt >= 0) THEN
194 out.WriteSString(t.mod.name); out.WriteChar("."); out.WriteSString(name)
195 ELSIF f = 11X THEN
196 out.WriteSString(t.mod.name); out.WriteSString(".RECORD")
197 ELSIF f = 12X THEN
198 out.WriteSString("ARRAY "); out.WriteInt(LenOf(t, ptr)); t := t.base[0];
199 WHILE (FormOf(t) = 12X) & ((t.id DIV 256 = 0) OR (t.mod.refcnt < 0)) DO
200 out.WriteSString(", "); out.WriteInt(LenOf(t, ptr)); t := t.base[0]
201 END;
202 out.WriteSString(" OF "); WriteName(t, ptr)
203 ELSIF f = 13X THEN
204 out.WriteSString("POINTER")
205 ELSE
206 out.WriteSString("PROCEDURE")
207 END
208 | 20X: out.WriteSString("COM.IUnknown")
209 | 21X: out.WriteSString("COM.GUID")
210 | 22X: out.WriteSString("COM.RESULT")
211 ELSE OutString("#Dev:UnknownFormat"); out.WriteInt(ORD(f))
212 END
213 END WriteName;
214
215 PROCEDURE WriteGuid (a: INTEGER);
216
217 PROCEDURE Hex (a: INTEGER);
218 VAR x: SHORTCHAR;
219 BEGIN
220 SYSTEM.GET(a, x);
221 out.WriteIntForm(ORD(x), TextMappers.hexadecimal, 2, "0", FALSE)
222 END Hex;
223
224 BEGIN
225 out.WriteChar("{");
226 Hex(a + 3); Hex(a + 2); Hex(a + 1); Hex(a);
227 out.WriteChar("-");
228 Hex(a + 5); Hex(a + 4);
229 out.WriteChar("-");
230 Hex(a + 7); Hex(a + 6);
231 out.WriteChar("-");
232 Hex(a + 8);
233 Hex(a + 9);
234 out.WriteChar("-");
235 Hex(a + 10);
236 Hex(a + 11);
237 Hex(a + 12);
238 Hex(a + 13);
239 Hex(a + 14);
240 Hex(a + 15);
241 out.WriteChar("}")
242 END WriteGuid;
243
244 PROCEDURE^ ShowVar (ad, ind: INTEGER; f, c: SHORTCHAR; desc: Kernel.Type; ptr: ArrayPtr;
245 back: RefView; VAR name, sel: Name);
246
247 PROCEDURE ShowRecord (a, ind: INTEGER; desc: Kernel.Type; back: RefView; VAR sel: Name);
248 VAR dir: Kernel.Directory; obj: Kernel.Object; name: Kernel.Name; i, j, n: INTEGER; base: Kernel.Type;
249 BEGIN
250 WriteName(desc, NIL); out.WriteTab;
251 IF desc.mod.refcnt >= 0 THEN
252 OpenFold("#Dev:Fields");
253 n := desc.id DIV 16 MOD 16; j := 0;
254 WHILE j <= n DO
255 base := desc.base[j];
256 IF base # NIL THEN
257 dir := base.fields; i := 0;
258 WHILE i < dir.num DO
259 obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(dir.obj[i]));
260 Kernel.GetObjName(base.mod, obj, name);
261 ShowVar(a + obj.offs, ind, FormOf(obj.struct), 1X, obj.struct, NIL, back, name, sel);
262 INC(i)
263 END
264 END;
265 INC(j)
266 END;
267 out.WriteSString(" "); CloseFold((ind > 1) OR (sel # ""))
268 ELSE
269 OutString("#Dev:Unloaded")
270 END
271 END ShowRecord;
272
273 PROCEDURE ShowArray (a, ind: INTEGER; desc: Kernel.Type; ptr: ArrayPtr; back: RefView; VAR sel: Name);
274 VAR f: SHORTCHAR; i, n, m, size, len: INTEGER; name: Kernel.Name; eltyp, t: Kernel.Type;
275 vi: SHORTINT; vs: BYTE; str: Dialog.String; high: BOOLEAN;
276 BEGIN
277 WriteName(desc, ptr); out.WriteTab;
278 len := LenOf(desc, ptr); eltyp := desc.base[0]; f := FormOf(eltyp); size := SizeOf(eltyp, ptr);
279 IF (f = 2X) OR (f = 3X) THEN (* string *)
280 n := 0; m := len; high := FALSE;
281 IF f = 2X THEN
282 REPEAT SYSTEM.GET(a + n, vs); INC(n) UNTIL (n = 32) OR (n = len) OR (vs = 0);
283 REPEAT DEC(m); SYSTEM.GET(a + m, vs) UNTIL (m = 0) OR (vs # 0)
284 ELSE
285 REPEAT
286 SYSTEM.GET(a + n * 2, vi); INC(n);
287 IF vi DIV 256 # 0 THEN high := TRUE END
288 UNTIL (n = len) OR (vi = 0);
289 n := MIN(n, 32);
290 REPEAT DEC(m); SYSTEM.GET(a + m * 2, vi) UNTIL (m = 0) OR (vi # 0)
291 END;
292 WriteString(a, n, size, TRUE, TRUE);
293 INC(m, 2);
294 IF m > len THEN m := len END;
295 IF high OR (m > n) THEN
296 out.WriteSString(" "); OpenFold("...");
297 out.WriteLn;
298 IF high & (n = 32) THEN
299 WriteString(a, m, size, TRUE, TRUE);
300 out.WriteLn; out.WriteLn
301 END;
302 WriteString(a, m, size, FALSE, FALSE);
303 IF m < len THEN out.WriteSString(", ..., 0X") END;
304 out.WriteSString(" "); CloseFold(TRUE)
305 END
306 ELSE
307 t := eltyp;
308 WHILE FormOf(t) = 12X DO t := t.base[0] END;
309 IF FormOf(t) # 0X THEN
310 OpenFold("#Dev:Elements");
311 i := 0;
312 WHILE i < len DO
313 Strings.IntToString(i, str);
314 name := "[" + SHORT(str$) + "]";
315 ShowVar(a, ind, f, 1X, eltyp, ptr, back, name, sel);
316 INC(i); INC(a, size)
317 END;
318 out.WriteSString(" "); CloseFold(TRUE)
319 END
320 END
321 END ShowArray;
322
323 PROCEDURE ShowProcVar (a: INTEGER);
324 VAR vli, n, ref: INTEGER; m: Kernel.Module; name: Kernel.Name;
325 BEGIN
326 SYSTEM.GET(a, vli);
327 Kernel.SearchProcVar(vli, m, vli);
328 IF m = NIL THEN
329 IF vli = 0 THEN out.WriteSString("NIL")
330 ELSE WriteHex(vli)
331 END
332 ELSE
333 IF m.refcnt >= 0 THEN
334 out.WriteSString(m.name); ref := m.refs;
335 REPEAT Kernel.GetRefProc(ref, n, name) UNTIL (n = 0) OR (vli < n);
336 IF vli < n THEN out.WriteChar("."); out.WriteSString(name) END
337 ELSE
338 OutString("#Dev:ProcInUnloadedMod");
339 out.WriteSString(m.name); out.WriteSString(" !!!")
340 END
341 END
342 END ShowProcVar;
343
344 PROCEDURE ShowPointer (a: INTEGER; f: SHORTCHAR; desc: Kernel.Type; back: RefView; VAR sel: Name);
345 VAR adr, x: INTEGER; ptr: ArrayPtr; c: Cluster; btyp: Kernel.Type;
346 BEGIN
347 SYSTEM.GET(a, adr);
348 IF f = 13X THEN btyp := desc.base[0] ELSE btyp := NIL END;
349 IF adr = 0 THEN out.WriteSString("NIL")
350 ELSIF f = 20X THEN
351 out.WriteChar("["); WriteHex(adr); out.WriteChar("]");
352 out.WriteChar(" "); c := SYSTEM.VAL(Cluster, Kernel.Root());
353 WHILE (c # NIL) & ((adr < SYSTEM.VAL(INTEGER, c)) OR (adr >= SYSTEM.VAL(INTEGER, c) + c.size)) DO c := c.next END;
354 IF c # NIL THEN
355 ptr := SYSTEM.VAL(ArrayPtr, adr)
356 END
357 ELSE
358 IF (f = 13X) OR (f = 0CX) THEN x := adr - 4 ELSE x := adr END;
359 IF ((adr < -4) OR (adr >= 65536)) & Kernel.IsReadable(x, adr + 16) THEN
360 out.WriteChar("["); WriteHex(adr); out.WriteChar("]");
361 IF (f = 13X) OR (f = 0CX) THEN
362 out.WriteChar(" "); c := SYSTEM.VAL(Cluster, Kernel.Root());
363 WHILE (c # NIL) & ((adr < SYSTEM.VAL(INTEGER, c)) OR (adr >= SYSTEM.VAL(INTEGER, c) + c.size)) DO
364 c := c.next
365 END;
366 IF c # NIL THEN
367 ptr := SYSTEM.VAL(ArrayPtr, adr);
368 IF (f = 13X) & (FormOf(btyp) = 12X) THEN (* array *)
369 adr := SYSTEM.ADR(ptr.len[btyp.id DIV 16 MOD 16])
370 END
371 ELSE OutString("#Dev:IllegalPointer")
372 END
373 END
374 ELSE OutString("#Dev:IllegalAddress"); WriteHex(adr)
375 END
376 END
377 END ShowPointer;
378
379 PROCEDURE ShowSelector (ref: RefView);
380 VAR b: RefView; n: SHORTINT; a, a0: TextModels.Attributes;
381 BEGIN
382 b := ref.back; n := 1;
383 IF b # NIL THEN
384 WHILE (b.name = ref.name) & (b.back # NIL) DO INC(n); b := b.back END;
385 ShowSelector(b);
386 IF n > 1 THEN out.WriteChar("(") END;
387 out.WriteChar(".")
388 END;
389 out.WriteSString(ref.name);
390 IF ref.type = heap THEN out.WriteChar("^") END;
391 IF n > 1 THEN
392 out.WriteChar(")");
393 a0 := out.rider.attr; a := TextModels.NewOffset(a0, 2 * Ports.point);
394 out.rider.SetAttr(a);
395 out.WriteInt(n); out.rider.SetAttr(a0)
396 END
397 END ShowSelector;
398
399 PROCEDURE ShowVar (ad, ind: INTEGER; f, c: SHORTCHAR; desc: Kernel.Type; ptr: ArrayPtr; back: RefView;
400 VAR name, sel: Name);
401 VAR i, j, vli, a: INTEGER; tsel: Name; a0: TextModels.Attributes;
402 vc: SHORTCHAR; vsi: BYTE; vi: SHORTINT; vr: SHORTREAL; vlr: REAL; vs: SET;
403 BEGIN
404 out.WriteLn; out.WriteTab; i := 0;
405 WHILE i < ind DO out.WriteSString(" "); INC(i) END;
406 a := ad; i := 0; j := 0;
407 IF sel # "" THEN
408 WHILE sel[i] # 0X DO tsel[i] := sel[i]; INC(i) END;
409 IF (tsel[i-1] # ":") & (name[0] # "[") THEN tsel[i] := "."; INC(i) END
410 END;
411 WHILE name[j] # 0X DO tsel[i] := name[j]; INC(i); INC(j) END;
412 tsel[i] := 0X;
413 a0 := out.rider.attr;
414 IF c = 3X THEN (* varpar *)
415 SYSTEM.GET(ad, a);
416 out.rider.SetAttr(TextModels.NewStyle(a0, {Fonts.italic}))
417 END;
418 IF name[0] # "[" THEN out.WriteChar(".") END;
419 out.WriteSString(name);
420 out.rider.SetAttr(a0); out.WriteTab;
421 IF (c = 3X) & (a >= 0) & (a < 65536) THEN
422 out.WriteTab; out.WriteSString("NIL VARPAR")
423 ELSIF f = 11X THEN
424 Kernel.GetTypeName(desc, name);
425 IF (c = 3X) & (name[0] # "!") THEN SYSTEM.GET(ad + 4, desc) END; (* dynamic type *)
426 ShowRecord(a, ind + 1, desc, back, tsel)
427 ELSIF (c = 3X) & (f = 0BX) THEN (* VAR anyrecord *)
428 SYSTEM.GET(ad + 4, desc);
429 ShowRecord(a, ind + 1, desc, back, tsel)
430 ELSIF f = 12X THEN
431 IF (desc.size = 0) & (ptr = NIL) THEN SYSTEM.GET(ad, a) END; (* dyn array val par *)
432 IF ptr = NIL THEN ptr := SYSTEM.VAL(ArrayPtr, ad - 8) END;
433 ShowArray(a, ind + 1, desc, ptr, back, tsel)
434 ELSE
435 IF desc = NIL THEN desc := SYSTEM.VAL(Kernel.Type, ORD(f)) END;
436 WriteName(desc, NIL); out.WriteTab;
437 CASE f OF
438 | 0X: (* SYSTEM.GET(a, vli); WriteHex(vli) *)
439 | 1X: SYSTEM.GET(a, vc);
440 IF vc = 0X THEN out.WriteSString("FALSE")
441 ELSIF vc = 1X THEN out.WriteSString("TRUE")
442 ELSE OutString("#Dev:Undefined"); out.WriteInt(ORD(vc))
443 END
444 | 2X: WriteString(a, 1, 1, FALSE, FALSE)
445 | 3X: WriteString(a, 1, 2, FALSE, TRUE);
446 SYSTEM.GET(a, vi);
447 IF vi DIV 256 # 0 THEN out.WriteString(" "); WriteString(a, 1, 2, FALSE, FALSE) END
448 | 4X: SYSTEM.GET(a, vsi); out.WriteInt(vsi)
449 | 5X: SYSTEM.GET(a, vi); out.WriteInt(vi)
450 | 6X: SYSTEM.GET(a, vli); out.WriteInt(vli)
451 | 7X: SYSTEM.GET(a, vr); out.WriteReal(vr)
452 | 8X: SYSTEM.GET(a, vlr); out.WriteReal(vlr)
453 | 9X: SYSTEM.GET(a, vs); out.WriteSet(vs)
454 | 0AX: SYSTEM.GET(a, vli); SYSTEM.GET(a + 4, i);
455 IF (vli >= 0) & (i = 0) OR (vli < 0) & (i = -1) THEN out.WriteInt(vli)
456 ELSE out.WriteIntForm(i, TextMappers.hexadecimal, 8, "0", TextMappers.hideBase); WriteHex(vli)
457 END
458 | 0CX, 0DX, 13X, 20X: ShowPointer(a, f, desc, back, tsel)
459 | 0EX, 10X: ShowProcVar(a)
460 | 0FX: WriteString(a, 256, 1, TRUE, FALSE)
461 | 21X: WriteGuid(a)
462 | 22X: SYSTEM.GET(a, vli); WriteHex(vli)
463 ELSE
464 END
465 END
466 END ShowVar;
467
468
469 PROCEDURE ShowStack;
470 VAR ref, end, i, j, x, a, b, c: INTEGER; m, f: SHORTCHAR; mod: Kernel.Module; name, sel: Kernel.Name;
471 d: Kernel.Type;
472 BEGIN
473 a := Kernel.pc; b := Kernel.fp; c := 100;
474 REPEAT
475 mod := Kernel.modList;
476 WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
477 IF mod # NIL THEN
478 DEC(a, mod.code);
479 IF mod.refcnt >= 0 THEN
480 out.WriteChar(" "); out.WriteSString(mod.name); ref := mod.refs;
481 REPEAT Kernel.GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
482 IF a < end THEN
483 out.WriteChar("."); out.WriteSString(name);
484 sel := mod.name$; i := 0;
485 WHILE sel[i] # 0X DO INC(i) END;
486 sel[i] := "."; INC(i); j := 0;
487 WHILE name[j] # 0X DO sel[i] := name[j]; INC(i); INC(j) END;
488 sel[i] := ":"; sel[i+1] := 0X;
489 out.WriteSString(" ["); WriteHex(a);
490 out.WriteSString("] ");
491 i := Kernel.SourcePos(mod, 0);
492 IF name # "$$" THEN
493 Kernel.GetRefVar(ref, m, f, d, x, name);
494 WHILE m # 0X DO
495 IF name[0] # "@" THEN ShowVar(b + x, 0, f, m, d, NIL, NIL, name, sel) END;
496 Kernel.GetRefVar(ref, m, f, d, x, name)
497 END
498 END;
499 out.WriteLn
500 ELSE out.WriteSString(".???"); out.WriteLn
501 END
502 ELSE
503 out.WriteChar("("); out.WriteSString(mod.name);
504 out.WriteSString(") (pc="); WriteHex(a);
505 out.WriteSString(", fp="); WriteHex(b); out.WriteChar(")");
506 out.WriteLn
507 END
508 ELSE
509 out.WriteSString("<system> (pc="); WriteHex(a);
510 out.WriteSString(", fp="); WriteHex(b); out.WriteChar(")");
511 out.WriteLn
512 END;
513 IF (b >= Kernel.fp) & (b < Kernel.stack) THEN
514 SYSTEM.GET(b+4, a); (* stacked pc *)
515 SYSTEM.GET(b, b); (* dynamic link *)
516 DEC(a); DEC(c)
517 ELSE c := 0
518 END
519 UNTIL c = 0
520 END ShowStack;
521
522 PROCEDURE (a: Action) Do; (* delayed trap window open *)
523 BEGIN
524 Kernel.SetTrapGuard(TRUE);
525 OpenViewer(a.text, "#Dev:Trap", NewRuler());
526 Kernel.SetTrapGuard(FALSE);
527 END Do;
528
529 PROCEDURE GetTrapMsg(OUT msg: ARRAY OF CHAR);
530 VAR ref, end, a: INTEGER; mod: Kernel.Module; name: Kernel.Name; head, tail, errstr: ARRAY 32 OF CHAR;
531 key: ARRAY 128 OF CHAR;
532 BEGIN
533 a := Kernel.pc; mod := Kernel.modList;
534 WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
535 IF mod # NIL THEN
536 DEC(a, mod.code); ref := mod.refs;
537 REPEAT Kernel.GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
538 IF a < end THEN
539 Kernel.SplitName (mod.name$, head, tail);
540 IF head = "" THEN head := "System" END;
541 Strings.IntToString(Kernel.err, errstr);
542 key := tail + "." + name + "." + errstr;
543 Dialog.MapString("#" + head + ":" + key, msg);
544 (* IF key # msg THEN out.WriteString(" " + msg) END; *)
545 IF key = msg THEN msg := "" END;
546 END
547 END
548 END GetTrapMsg;
549
550 PROCEDURE Trap;
551 VAR a0: TextModels.Attributes; action: Action; msg: ARRAY 512 OF CHAR;
552 BEGIN
553 out.ConnectTo(TextModels.dir.New());
554 a0 := out.rider.attr;
555 out.rider.SetAttr(TextModels.NewWeight(a0, Fonts.bold));
556 IF Kernel.err = 129 THEN out.WriteSString("invalid WITH")
557 ELSIF Kernel.err = 130 THEN out.WriteSString("invalid CASE")
558 ELSIF Kernel.err = 131 THEN out.WriteSString("function without RETURN")
559 ELSIF Kernel.err = 132 THEN out.WriteSString("type guard")
560 ELSIF Kernel.err = 133 THEN out.WriteSString("implied type guard")
561 ELSIF Kernel.err = 134 THEN out.WriteSString("value out of range")
562 ELSIF Kernel.err = 135 THEN out.WriteSString("index out of range")
563 ELSIF Kernel.err = 136 THEN out.WriteSString("string too long")
564 ELSIF Kernel.err = 137 THEN out.WriteSString("stack overflow")
565 ELSIF Kernel.err = 138 THEN out.WriteSString("integer overflow")
566 ELSIF Kernel.err = 139 THEN out.WriteSString("division by zero")
567 ELSIF Kernel.err = 140 THEN out.WriteSString("infinite real result")
568 ELSIF Kernel.err = 141 THEN out.WriteSString("real underflow")
569 ELSIF Kernel.err = 142 THEN out.WriteSString("real overflow")
570 ELSIF Kernel.err = 143 THEN out.WriteSString("undefined real result")
571 ELSIF Kernel.err = 144 THEN out.WriteSString("not a number")
572 ELSIF Kernel.err = 200 THEN out.WriteSString("keyboard interrupt")
573 ELSIF Kernel.err = 201 THEN
574 out.WriteSString("NIL dereference")
575 ELSIF Kernel.err = 202 THEN
576 out.WriteSString("illegal instruction: ");
577 out.WriteIntForm(Kernel.val, TextMappers.hexadecimal, 5, "0", TextMappers.showBase)
578 ELSIF Kernel.err = 203 THEN
579 IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL dereference (read)")
580 ELSE out.WriteSString("illegal memory read (ad = "); WriteHex(Kernel.val); out.WriteChar(")")
581 END
582 ELSIF Kernel.err = 204 THEN
583 IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL dereference (write)")
584 ELSE out.WriteSString("illegal memory write (ad = "); WriteHex(Kernel.val); out.WriteChar(")")
585 END
586 ELSIF Kernel.err = 205 THEN
587 IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL procedure call")
588 ELSE out.WriteSString("illegal execution (ad = "); WriteHex(Kernel.val); out.WriteChar(")")
589 END
590 ELSIF Kernel.err = 257 THEN out.WriteSString("out of memory")
591 ELSIF Kernel.err = 10001H THEN out.WriteSString("bus error")
592 ELSIF Kernel.err = 10002H THEN out.WriteSString("address error")
593 ELSIF Kernel.err = 10007H THEN out.WriteSString("fpu error")
594 ELSIF Kernel.err < 0 THEN
595 out.WriteSString("Exception "); out.WriteIntForm(-Kernel.err, TextMappers.hexadecimal, 3, "0", TextMappers.showBase)
596 ELSE
597 out.WriteSString("TRAP "); out.WriteInt(Kernel.err);
598 IF Kernel.err = 126 THEN out.WriteSString(" (not yet implemented)")
599 ELSIF Kernel.err = 125 THEN out.WriteSString(" (call of obsolete procedure)")
600 ELSIF Kernel.err >= 100 THEN out.WriteSString(" (invariant violated)")
601 ELSIF Kernel.err >= 60 THEN out.WriteSString(" (postcondition violated)")
602 ELSIF Kernel.err >= 20 THEN out.WriteSString(" (precondition violated)")
603 END
604 END;
605 GetTrapMsg(msg);
606 IF msg # "" THEN out.WriteLn; out.WriteString(msg) END;
607 out.WriteLn; out.rider.SetAttr(a0);
608 out.WriteLn; ShowStack;
609 NEW(action); action.text := out.rider.Base();
610 Services.DoLater(action, Services.now);
611 out.ConnectTo(NIL)
612 END Trap;
613
614 BEGIN
615 Kernel.InstallTrapViewer(Trap);
616 empty := "";
617 path[0].x := refViewSize DIV 2; path[0].y := 0;
618 path[1].x := refViewSize; path[1].y := refViewSize DIV 2;
619 path[2].x := refViewSize DIV 2; path[2].y := refViewSize;
620 path[3].x := 0; path[3].y := refViewSize DIV 2;
621 END StdDebug.
[FORK] BlackBox Cross-Platform (Windows, GNU/Linux, OpenBSD, FreeBSD)
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024