ð Syntax10.Scn.FntSyntax10b.Scn.Fnt ÿCourier10.Scn.Fnt"eüÿÿÿÀÔ°­MarkElemsAllocu‰Ý/üÿÿÿÀÔ°­v‰ÝÑüÿÿÿÀÔ°­ò#2Syntax10i.Scn.FntSyntax12.Scn.Fnt€üÿÿÿÀÔ°­x‰Ýo 0 a ¦5 3 5 5<5üÿÿÿÀÔ°­w‰ÝÌüÿÿÿÀÔ°­ó# qMMODULE ShowError; (* CS, 25.08.96 *) IMPORT S := SYSTEM, Kernel, C := Console; CONST allocateBuffer = 100H; (* FORMAT_MESSAGE_ALLOCATE_BUFFER *) fromSystem = 1000H; (* FORMAT_MESSAGE_FROM_SYSTEM *) neutral = 0; (* LANG_NEUTRAL *) default = 1; (* SUBLANG_DEFAULT *) VAR FormatMessage: PROCEDURE (flags, source, msgId, langId, buffer, size, args: LONGINT): LONGINT; GetLastError: PROCEDURE (): LONGINT; PROCEDURE MakeLangID (primaryLangID, subLangID: INTEGER): INTEGER; BEGIN RETURN SHORT(ASH(subLangID, 10) + primaryLangID) END MakeLangID; PROCEDURE Do* (callingProc: ARRAY OF CHAR); VAR ret: LONGINT; str: ARRAY 1024 OF CHAR; BEGIN C.Ln; C.Str(callingProc); C.Str(": "); ret := FormatMessage(fromSystem, 0, GetLastError(), MakeLangID(neutral, default), S.ADR(str), LEN(str), 0); IF ret = 0 THEN ret := GetLastError(); C.Str("last error code: "); C.Int(ret) ELSE C.Str(str) END END Do; PROCEDURE ReadNum (VAR pos: LONGINT; VAR i: LONGINT); VAR n: LONGINT; s: SHORTINT; x: CHAR; BEGIN s := 0; n := 0; S.GET(pos, x); INC(pos); WHILE ORD(x) >= 128 DO INC(n, ASH(ORD(x) - 128, s)); INC(s, 7); S.GET(pos, x); INC(pos) END ; i := n + ASH(ORD(x) MOD 64 - ORD(x) DIV 64 * 64, s) END ReadNum; PROCEDURE ReadString (VAR pos: LONGINT; VAR s: ARRAY OF CHAR); VAR i: LONGINT; ch: CHAR; BEGIN i := 0; REPEAT S.GET(pos, ch); s[i] := ch; INC(i); INC(pos) UNTIL ch <= 2X; s[i - 1] := 0X END ReadString; PROCEDURE OverReadTypes (VAR pos: LONGINT; VAR ch: CHAR); (* MK *) VAR n: LONGINT; ch2: CHAR; BEGIN S.GET (pos, ch); INC (pos); IF ch = CHR (14) THEN ReadNum (pos, n) ELSIF ch = 0FX THEN ReadNum (pos, n); ReadNum (pos, n); OverReadTypes (pos, ch2) ELSIF ch = 10X THEN INC (pos); ReadNum (pos, n) ELSIF ch = 11X THEN ReadNum (pos, n); OverReadTypes (pos, ch2) ELSIF ch = CHR (13) THEN OverReadTypes (pos, ch2) END END OverReadTypes; PROCEDURE DumpVars* (VAR pos: LONGINT; base: LONGINT); CONST VarTag = 1X; VarParTag = 2X; VAR ch, form: CHAR; sintval: SHORTINT; intval: INTEGER; lintval: LONGINT; realval: REAL; lrealval: LONGREAL; adr, offs: LONGINT; name: ARRAY 128 OF CHAR; BEGIN S.GET(pos, ch); INC(pos); WHILE (ch = VarTag) OR (ch = VarParTag) DO ReadString(pos, name); ReadNum (pos, offs); OverReadTypes (pos, form); adr := base + offs; IF ch = VarParTag THEN S.GET(adr, adr) END ; IF (ORD(form) <= 0FH) & (ORD(form) IN {1H, 2H, 3H, 4H, 5H, 6H, 7H, 8H, 9H, 0DH, 0FH}) THEN C.Str(" "); C.Str(name); C.Str(" = "); CASE ORD(form) OF | 1H: (* Byte *) S.GET(adr, ch); C.Int(ORD(ch)); | 2H: (* Boolean *) S.GET(adr, ch); IF ORD(ch) = 0 THEN C.Str("FALSE") ELSE C.Str("TRUE") END ; | 3H: (* Char *) S.GET(adr, ch); IF (" " <= ch) & (ch <= "~") THEN C.Ch(22X); C.Ch(ch); C.Ch(22X); ELSE C.Str("CHR("); C.Int(ORD(ch)); C.Ch(")"); END ; | 4H: (* Shortint *) S.GET(adr, sintval); C.Int(sintval); | 5H: (* Integer *) S.GET(adr, intval); C.Int(intval); | 6H: (* Longint *) S.GET(adr, lintval); C.Int(lintval); | 7H: (* Real *) S.GET(adr, realval); C.Real(realval) | 8H: (* Longreal *) S.GET(adr, lrealval); C.Real(lrealval) | 9H, 0DH: (* Set, Pointer*) S.GET(adr, lintval); C.Int(lintval) | 0FH: (* Array of char *) C.Ch(22X); S.GET(adr, ch); INC(adr); WHILE (" " <= ch) & (ch <= "~") DO C.Ch(ch); S.GET(adr, ch); INC(adr) END ; C.Ch(22X); ELSE (* MK up to now a not viewable type*) END ; C.Ln END ; S.GET(pos, ch); INC(pos); END END DumpVars; PROCEDURE FindProc* (pc: LONGINT; VAR mod: Kernel.Module; VAR refpos, refend: LONGINT); CONST ProcRefTag = 0F8X; VAR m: Kernel.Module; codebase, pos, beg, offs: LONGINT; ch, ch2: CHAR; name: ARRAY 128 OF CHAR; BEGIN m := Kernel.modules; mod := NIL; refpos := -1; codebase := S.ADR(m.code[0]); WHILE (m # NIL) & ((pc < codebase) OR ((codebase + LEN(m.code^)) < pc)) DO m := m.next; IF m # NIL THEN codebase := S.ADR(m.code[0]) END ; END ; IF m # NIL THEN mod := m; pc := pc - codebase; pos := S.ADR(m.refs[0]); refend := pos + LEN(mod.refs^); S.GET(pos, ch); INC(pos); beg := pos; refpos := -1; WHILE (pos <= refend) & (ch = ProcRefTag) DO refpos := beg; beg := pos; ReadNum(pos, offs); IF offs >= pc THEN RETURN END ; ReadString(pos, name); S.GET(pos, ch); INC(pos); WHILE (pos <= refend) & (ch # ProcRefTag) DO ReadString(pos, name); ReadNum(pos, offs); OverReadTypes (pos, ch2); S.GET(pos, ch); INC(pos); END END ; refpos := beg; END END FindProc; PROCEDURE CallStack* (showVars: BOOLEAN); VAR pc, bp, sp, ref, refend, offs: LONGINT; mod: Kernel.Module; name: ARRAY 128 OF CHAR; BEGIN S.GETREG(5, bp); S.GETREG(4, sp); REPEAT S.GET(bp + 4, pc); S.GET(bp, bp); FindProc(pc, mod, ref, refend); IF mod # NIL THEN C.Ln; C.Str(mod.name); C.Ch("."); ReadNum(ref, offs); ReadString(ref, name); C.Str(name); C.Str(" (FP = "); C.Int(bp); C.Str(", PC = "); C.Hex(pc); C.Str("H, relative PC: "); C.Hex(pc - S.ADR(mod.code^)); C.Str("H"); IF showVars THEN C.Ln; IF name = "$$" THEN DumpVars(ref, mod.sb) ELSE DumpVars(ref, bp) END END END UNTIL mod = NIL END CallStack; PROCEDURE Init; VAR mod: LONGINT; BEGIN mod := Kernel.LoadLibrary("Kernel32"); Kernel.GetAdr(mod, "FormatMessageA", S.VAL(LONGINT, FormatMessage)); Kernel.GetAdr(mod, "GetLastError", S.VAL(LONGINT, GetLastError)) END Init; BEGIN Init END ShowError.