MODULE Reflection;
IMPORT Modules,Streams,Machine,Heaps,Objects,SYSTEM, Trace;
CONST
ShowAllProcs = TRUE;
MaxFrames = 128;
MaxString = 64;
MaxArray = 8;
MaxCols = 70;
Sep = " ";
SepLen = 2;
TYPE
Variable* = RECORD
adr-: SYSTEM.ADDRESS;
type-, size-, n-, tdadr-: LONGINT
END;
VAR
modes: ARRAY 25 OF CHAR;
PROCEDURE WriteVar*(w: Streams.Writer; v: Variable; VAR col: LONGINT);
VAR ch: CHAR;
BEGIN
IF v.type = 15 THEN
w.Char(22X);
LOOP
IF (v.n = 0) OR (~CheckHeapAddress(v.adr)) THEN EXIT END;
SYSTEM.GET(v.adr, ch);
INC(v.adr);
IF (ch < " ") OR (ch > "~") THEN EXIT END;
w.Char(ch); INC(col); DEC(v.n)
END;
w.Char(22X); INC(col, 2);
IF ch # 0X THEN w.Char("!") END
ELSE
WHILE v.n > 0 DO
WriteSimpleVar(w, v.adr, v.type, v.tdadr, col);
DEC(v.n); INC(v.adr, v.size);
IF v.n > 0 THEN
w.String(", "); INC(col, 2)
END
END
END
END WriteVar;
PROCEDURE CheckHeapAddress(address: SYSTEM.ADDRESS): BOOLEAN;
VAR i: LONGINT; block{UNTRACED}: Machine.MemoryBlock; hit: BOOLEAN;
BEGIN
RETURN Machine.ValidHeapAddress(address);
END CheckHeapAddress;
PROCEDURE GetNum( refs: Modules.Bytes; VAR i, num: LONGINT );
VAR n, s: LONGINT; x: CHAR;
BEGIN
IF NewObjectFile(refs) THEN
num := SYSTEM.VAL(LONGINT,refs[i]); INC(i,4);
ELSE
s := 0; n := 0; x := refs[i]; INC( i );
WHILE ORD( x ) >= 128 DO INC( n, ASH( ORD( x ) - 128, s ) ); INC( s, 7 ); x := refs[i]; INC( i ) END;
num := n + ASH( ORD( x ) MOD 64 - ORD( x ) DIV 64 * 64, s )
END;
END GetNum;
PROCEDURE NextVar*(refs: Modules.Bytes; VAR refpos: LONGINT; base: SYSTEM.ADDRESS; VAR name: ARRAY OF CHAR; VAR v: Variable);
VAR x: Variable; j: LONGINT; ch, mode: CHAR;
BEGIN
name[0] := 0X;
IF refpos < LEN(refs^)-1 THEN
mode := refs[refpos]; INC(refpos);
IF (mode >= 1X) & (mode <= 3X) THEN
x.type := ORD(refs[refpos]); INC(refpos);
IF x.type > 80H THEN
IF x.type = 83H THEN x.type := 15 ELSE DEC(x.type, 80H) END;
GetNum(refs, refpos, x.n)
ELSIF (x.type = 16H) OR (x.type = 1DH) THEN
GetNum(refs, refpos, x.tdadr); x.n := 1
ELSE
IF x.type = 15 THEN x.n := MaxString ELSE x.n := 1 END
END;
GetNum(refs, refpos, j);
x.adr := base + j;
IF x.n = 0 THEN
SYSTEM.GET(x.adr+4, x.n)
END;
IF mode # 1X THEN SYSTEM.GET(x.adr, x.adr) END;
CASE x.type OF
1..4,15: x.size := 1
|5: x.size := 2
|6..7,9,13,14,29: x.size := 4
|8, 16: x.size := 8
|22: x.size := 0; ASSERT(x.n <= 1)
ELSE x.size := -1
END;
IF x.size >= 0 THEN
ch := refs[refpos]; INC(refpos); j := 0;
WHILE ch # 0X DO
IF j < LEN(name)-1 THEN name[j] := ch; INC(j) END;
ch := refs[refpos]; INC(refpos)
END;
name[j] := 0X; v := x
END
END
END
END NextVar;
PROCEDURE FindVar*(mod: Modules.Module; CONST name: ARRAY OF CHAR; VAR v: Variable): BOOLEAN;
VAR refs: Modules.Bytes; refpos: LONGINT; base: SYSTEM.ADDRESS; n: ARRAY 64 OF CHAR;
BEGIN
InitVar(mod, refs, refpos, base);
IF refpos # -1 THEN
LOOP
NextVar(refs, refpos, base, n, v);
IF n = "" THEN EXIT END;
IF n = name THEN RETURN TRUE END
END
END;
RETURN FALSE
END FindVar;
PROCEDURE InitVar*(mod: Modules.Module; VAR refs: Modules.Bytes; VAR refpos: LONGINT; VAR base: SYSTEM.ADDRESS);
VAR ch: CHAR; startpc: SYSTEM.ADDRESS;
BEGIN
refpos := -1;
IF mod # NIL THEN
refs := mod.refs; base := mod.sb;
IF (refs # NIL) & (LEN(refs) # 0) THEN
refpos := FindProc(refs, 0, startpc);
IF refpos # -1 THEN
ch := refs[refpos]; INC(refpos);
WHILE ch # 0X DO ch := refs[refpos]; INC(refpos) END
END
END
END
END InitVar;
PROCEDURE NewObjectFile(refs: Modules.Bytes): BOOLEAN;
BEGIN
RETURN (refs # NIL) & (LEN(refs) >0) & (refs[0]=0FFX);
END NewObjectFile;
PROCEDURE FindProc(refs: Modules.Bytes; modpc: SYSTEM.ADDRESS; VAR startpc: SYSTEM.ADDRESS): LONGINT;
VAR i, m, t, tstart, tend, proc: LONGINT; ch: CHAR; newObjectFile: BOOLEAN;
BEGIN
IF (refs=NIL) OR (LEN(refs) = 0) THEN RETURN -1 END;
newObjectFile := NewObjectFile(refs);
proc := -1; i := 0; m := LEN(refs^);
IF newObjectFile THEN INC(i) END;
ch := refs[i]; INC(i); tstart := 0;
WHILE (i < m) & ((ch = 0F8X) OR (ch = 0F9X)) DO
startpc := tstart;
GetNum(refs, i, tstart);
IF newObjectFile THEN GetNum(refs,i,tend) END;
IF ~newObjectFile & (tstart > modpc) THEN
ch := 0X
ELSE
IF ch = 0F9X THEN
GetNum(refs, i, t);
INC(i, 3) ;
IF newObjectFile THEN INC(i,6) END;
END;
proc := i;
REPEAT ch := refs[i]; INC(i) UNTIL ch = 0X;
IF i < m THEN
ch := refs[i]; INC(i);
WHILE (i < m) & (ch >= 1X) & (ch <= 3X) DO
ch := refs[i]; INC(i);
IF (ch >= 81X) OR (ch = 16X) OR (ch = 1DX) THEN
GetNum(refs, i, t)
END;
GetNum(refs, i, t);
REPEAT ch := refs[i]; INC(i) UNTIL ch = 0X;
IF i < m THEN ch := refs[i]; INC(i) END
END
END
END;
IF newObjectFile THEN
IF (tstart <=modpc) & (tend > modpc) THEN
ch := 0X; startpc := tstart;
ELSE
proc := -1
END;
END;
END;
IF ~newObjectFile THEN
IF (proc = -1) & (i # 0) THEN proc := i END;
END;
RETURN proc
END FindProc;
PROCEDURE Variables(w: Streams.Writer; refs: Modules.Bytes; refpos: LONGINT; base: SYSTEM.ADDRESS);
VAR v: Variable; j, col: LONGINT; name: ARRAY 64 OF CHAR; etc: BOOLEAN;
CONST dense = FALSE;
BEGIN
LOOP
NextVar(refs, refpos, base, name, v);
IF name[0] = 0X THEN EXIT END;
IF (col # 0 ) & (v.n > 1) & (v.type # 15) THEN
w.Ln; col := 0
END;
w.String(Sep); w.String(name); w.Char("=");
j := 0; WHILE name[j] # 0X DO INC(j) END;
INC(col, SepLen+1+j);
IF (v.adr >= -4) & (v.adr < 4096) THEN
w.String("NIL ("); w.Hex(v.adr, -8);
w.Char(")"); INC(col, 14)
ELSE
etc := FALSE;
IF v.type = 15 THEN
IF v.n > MaxString THEN etc := TRUE; v.n := MaxString END
ELSE
IF v.n > MaxArray THEN etc := TRUE; v.n := MaxArray END
END;
WriteVar(w, v, col);
IF etc THEN w.String("..."); INC(col, 3) END;
IF ~dense THEN
w.Ln; col := 0;
END;
END;
IF col > MaxCols THEN w.Ln; col := 0 END
END;
IF col # 0 THEN w.Ln END
END Variables;
PROCEDURE ModuleState*(w: Streams.Writer; mod: Modules.Module);
VAR refpos: LONGINT; base: SYSTEM.ADDRESS; refs: Modules.Bytes;
BEGIN
InitVar(mod, refs, refpos, base);
IF refpos # -1 THEN
w.String("State "); w.String(mod.name); w.Char(":"); w.Ln;
Variables(w, refs, refpos, base)
END
END ModuleState;
PROCEDURE WriteProc0(w: Streams.Writer; mod: Modules.Module; pc, fp: SYSTEM.ADDRESS; VAR refs: Modules.Bytes;
VAR refpos: LONGINT; VAR base: SYSTEM.ADDRESS);
VAR ch: CHAR; startpc: SYSTEM.ADDRESS;
BEGIN
refpos := -1;
IF mod = NIL THEN
IF pc = 0 THEN w.String("NIL")
ELSE
w.String("Unknown PC="); w.Address(pc); w.Char("H")
END;
IF fp # -1 THEN
w.String(" FP="); w.Address(fp); w.Char("H")
END
ELSE
w.String(mod.name);
IF ~NewObjectFile(mod.refs) THEN
DEC(pc, SYSTEM.ADR(mod.code[0]));
END;
refs := mod.refs;
IF (refs # NIL) & (LEN(refs) # 0) THEN
refpos := FindProc(refs, pc, startpc);
IF refpos # -1 THEN
w.Char(".");
ch := refs[refpos]; INC(refpos);
IF ch = "$" THEN base := mod.sb ELSE base := fp END;
WHILE ch # 0X DO w.Char(ch); ch := refs[refpos]; INC(refpos) END;
w.Char(":"); w.Int(LONGINT(pc-startpc),1);
END
END;
w.String(" pc="); w.Int(LONGINT(pc),1); w.String(" ["); w.Address (pc); w.String("H]");
w.String(" = "); w.Int(LONGINT(startpc),1); w.String(" + "); w.Int(LONGINT(pc-startpc),1);
END
END WriteProc0;
PROCEDURE WriteProc*(w: Streams.Writer; pc: SYSTEM.ADDRESS);
VAR refs: Modules.Bytes; refpos: LONGINT; base: SYSTEM.ADDRESS;
BEGIN
WriteProc0(w, Modules.ThisModuleByAdr(pc), pc, -1, refs, refpos, base)
END WriteProc;
PROCEDURE GetProcedureName*(pc: SYSTEM.ADDRESS; VAR name: ARRAY OF CHAR);
VAR
methadr, i: LONGINT;
ch: CHAR;
m: Modules.Module;
startpc: SYSTEM.ADDRESS;
BEGIN
m := Modules.ThisModuleByAdr(pc);
IF m # NIL THEN
IF ~NewObjectFile(m.refs) THEN
DEC(pc, SYSTEM.ADR(m.code[0]));
END;
methadr := FindProc(m.refs, pc, startpc);
IF methadr # -1 THEN
i := 0;
ch := m.refs[methadr]; INC(methadr);
WHILE ch # 0X DO
name[i] := ch;
ch := m.refs[methadr];
INC(methadr);
INC(i);
END;
END;
name[i] := 0X;
ELSE
name := "Unkown";
END;
END GetProcedureName;
PROCEDURE GetVariableAdr*(pc, fp: SYSTEM.ADDRESS; CONST varname: ARRAY OF CHAR): SYSTEM.ADDRESS;
VAR
m: Modules.Module;
v: Variable;
pos: LONGINT;
base: SYSTEM.ADDRESS;
name: ARRAY 256 OF CHAR;
ch: CHAR;
startpc: SYSTEM.ADDRESS;
BEGIN
pos := -1;
m := Modules.ThisModuleByAdr(pc);
IF m # NIL THEN
IF ~NewObjectFile(m.refs) THEN
DEC(pc, SYSTEM.ADR(m.code[0]));
END;
pos := FindProc(m.refs, pc, startpc);
IF pos # -1 THEN
ch := m.refs[pos]; INC(pos);
IF ch = "$" THEN
base := m.sb;
ELSE
base := fp;
END;
WHILE ch # 0X DO ch := m.refs[pos]; INC(pos) END;
NextVar(m.refs, pos, base, name, v);
WHILE name[0] # 0X DO
IF name = varname THEN
RETURN v.adr;
ELSE
NextVar(m.refs, pos, base, name, v);
END
END
END
END;
RETURN -1;
END GetVariableAdr;
PROCEDURE ThisTypeByAdr(adr: SYSTEM.ADDRESS; VAR m: Modules.Module; VAR t: Modules.TypeDesc);
BEGIN
IF adr # 0 THEN
SYSTEM.GET (adr + Heaps.TypeDescOffset, adr);
IF CheckHeapAddress(adr) THEN
t := SYSTEM.VAL(Modules.TypeDesc, adr);
m := t.mod;
ELSE
m := NIL; t := NIL
END
ELSE
m := NIL; t := NIL
END
END ThisTypeByAdr;
PROCEDURE WriteType*(w: Streams.Writer; adr: SYSTEM.ADDRESS);
VAR module: Modules.Module; typeDesc: Modules.TypeDesc;
BEGIN
IF CheckHeapAddress(adr) THEN
ThisTypeByAdr(adr, module, typeDesc);
IF module # NIL THEN
w.String(module.name);
ELSE
w.String("NIL"); RETURN
END;
w.String(".");
IF typeDesc # NIL THEN
IF typeDesc.name = "" THEN
w.String("ANONYMOUS")
ELSE
w.String(typeDesc.name);
END;
ELSE
w.String("NIL");
END;
ELSE
w.String("UNKNOWN");
END;
END WriteType;
PROCEDURE WriteSimpleVar( w: Streams.Writer; adr, type, tdadr: SYSTEM.ADDRESS; VAR col: LONGINT );
VAR ch: CHAR; sval: SHORTINT; ival: INTEGER; lval: LONGINT; rval: REAL; xval: LONGREAL; hval : HUGEINT;
address: SYSTEM.ADDRESS; pos0: LONGINT;
BEGIN
pos0 := w.Pos();
CASE type OF
1, 3:
SYSTEM.GET( adr, ch );
IF (ch > " ") & (ch <= "~") THEN w.Char( ch ); ELSE w.Hex( ORD( ch ), -2 ); w.Char( "X" ) END;
| 2:
SYSTEM.GET( adr, ch );
IF ch = 0X THEN w.String( "FALSE" )
ELSIF ch = 1X THEN w.String( "TRUE" )
ELSE w.Int( ORD( ch ), 1 );
END;
| 4:
SYSTEM.GET( adr, sval );
w.Int( sval, 1 );
IF sval > 0H THEN w.String(" ("); w.Hex(sval, -2); w.String("H)") END;
| 5:
SYSTEM.GET( adr, ival );
w.Int( ival, 1 );
IF ival > 0H THEN w.String(" (");w.Hex(ival,-4);w.Char("H");w.String(")"); END;
| 6:
SYSTEM.GET( adr, lval );
w.Int( lval, 1 );
IF lval > 0H THEN w.String( " (" ); w.Hex( lval,-8 ); w.String( "H)" ); END;
| 7:
SYSTEM.GET(adr,rval); SYSTEM.GET(adr,lval);
w.Float(rval,15);
IF lval > 0H THEN w.String(" ("); w.Hex(lval,-8);w.Char( "H" ); w.String(")"); END;
| 8:
SYSTEM.GET(adr,xval);SYSTEM.GET(adr,hval);
w.Float(xval,15);
IF hval > 0H THEN w.String( " (" ); w.Hex(hval,-16); w.String( "H)" ); END;
| 13,29:
SYSTEM.GET( adr, address ); w.Address( address ); w.String( "H" );
w.String(" (");
IF CheckHeapAddress(address) THEN
SYSTEM.GET(address + Heaps.TypeDescOffset, address);
WriteType(w,address);
ELSE w.String("NIL");
END;
w.String(")");
| 16:
SYSTEM.GET( adr , hval );
w.Hex(hval,1);
IF hval < 0 THEN w.String( "H (" ); w.Hex(hval,-16); w.String(")") END;
| 9:
SYSTEM.GET( adr, lval );
w.Set( SYSTEM.VAL( SET, lval ) );
| 22:
w.String( "Rec@" ); w.Hex( tdadr, -8 ); w.Char( "H" );
| 14:
SYSTEM.GET( adr, lval ); WriteProc( w, lval );
END;
INC(col,w.Pos()-pos0);
END WriteSimpleVar;
PROCEDURE StackTraceBack*(w: Streams.Writer; pc, bp: SYSTEM.ADDRESS; long, overflow: BOOLEAN);
VAR count, refpos: LONGINT; base: SYSTEM.ADDRESS; m: Modules.Module; refs: Modules.Bytes;
BEGIN
count := 0;
REPEAT
m := Modules.ThisModuleByAdr(pc);
IF ShowAllProcs OR (m # NIL) OR (count = 0) THEN
WriteProc0(w, m, pc, bp, refs, refpos, base); w.Ln; w.Update;
IF long & (~overflow OR (count > 0)) THEN
IF refpos # -1 THEN Variables(w, refs, refpos, base) END;
IF (m # NIL) & (base # m.sb) & (count = 0) THEN ModuleState(w, m) END
END;
IF bp # 0 THEN
SYSTEM.GET(bp + SYSTEM.SIZEOF(SYSTEM.ADDRESS), pc);
SYSTEM.GET(bp, bp);
END;
INC(count)
ELSE
bp := 0
END;
UNTIL (bp = 0) OR (count = MaxFrames);
IF bp # 0 THEN w.String("...") END
END StackTraceBack;
PROCEDURE WriteProcess*(w: Streams.Writer; p: Objects.Process);
VAR adr: SYSTEM.ADDRESS; mode: LONGINT; m: Modules.Module;
BEGIN
IF p # NIL THEN
w.Int(p.id, 5);
mode := p.mode;
IF (mode >= Objects.Ready) & (mode <= Objects.Terminated) THEN
adr := (mode-Objects.Ready)*4;
FOR adr := adr TO adr+3 DO w.Char(modes[adr]) END
ELSE
w.Char(" "); w.Int(mode, 1)
END;
w.Int(p.procID, 2);
w.Int(p.priority, 2);
w.Update;
w.Address (SYSTEM.VAL(SYSTEM.ADDRESS, p.obj));
IF p.obj # NIL THEN
SYSTEM.GET(SYSTEM.VAL(SYSTEM.ADDRESS, p.obj) - SYSTEM.SIZEOF(SYSTEM.ADDRESS), adr);
w.Char(":"); WriteType(w, adr)
END;
w.Update;
w.Char(" "); WriteProc(w, p.state.PC);
IF p.mode = Objects.AwaitingLock THEN
adr := SYSTEM.VAL(SYSTEM.ADDRESS, p.waitingOn);
w.Address (adr);
w.Update;
IF adr # 0 THEN
SYSTEM.GET(adr - SYSTEM.SIZEOF(SYSTEM.ADDRESS), adr);
IF adr = SYSTEM.TYPECODE(Modules.Module) THEN
w.Char("-");
m := SYSTEM.VAL(Modules.Module, adr);
w.String(m.name)
ELSE
w.Char(":"); WriteType(w, adr)
END;
w.Update;
END
ELSIF p.mode = Objects.AwaitingCond THEN
w.Char(" "); WriteProc(w, SYSTEM.VAL(SYSTEM.ADDRESS, p.condition));
w.Address (p.condFP)
END;
w.Char(" "); w.Set(p.flags)
END
END WriteProcess;
BEGIN
modes := " rdy run awl awc awe rip";
END Reflection.