PACKET trace DEFINES trace:
(**************************************************************)
(* Autor: G. Szalay *)
(* E U M E L 0 - T R A C E *)
(* Stand: 87-04-23 *)
(**************************************************************)
LET packet area = 0, stack area = 1, text opd maxlen = 14,
stdds = 0, info lines = 4, crlf = ""13""10"",
beep = ""7"", carriage return = ""13"", cursor up = ""3"",
std charset = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ123456
7890<>.,:;-_+*!""�$%&/()=?'äÄöÖüÜ#^",
blanks = " ",
startindent = 10, indentincr = 2;
BOOL VAR trap set := FALSE, trapped, initial call := TRUE, quit,
single step := FALSE, protocol := FALSE, cond br follows,
prot just started := FALSE, prot stopped := TRUE,
users error := FALSE, users stpdis, prot operands := TRUE,
nontraceable found, errorstop processing := FALSE,
std procs traceable := id (1) = 4 (* processor = 68000 *),
longcall to trace flag;
INT VAR aret hi := 0, aret lo := 0, ic hi, ic lo, ic h, ic l, i,
atrap hi, atrap lo, nail1 hi, nail1 lo, nail2 hi, nail2 lo,
no of nails := 1, saved instr, saved instr w2,
saved1, saved1 w2, saved2, saved2 w2,
call to trace, call2 to trace, length of call to trace,
cmd, ilen, iclass, ilen1, iclass1, indentpos,
code addr modif, pbase, lbase, users lbase,
users errcode, users errline, old flags, flags,
module no, word, word1, word2, case, xpos, ypos,
cond br hi, cond br lo, maxlines:=12, lines,
opad hiword, opad hi, opad lo, opdds, br param, brcomp index,
ic off, opd ptr, int opd, text opd len, text opd tr len,
heap link, root word 2, no of results:=0,
no of nontraceables := 0, no of long nontraceables := 0,
pproc modno, pproc call, pproc ic lo := 0;
ROW 3 INT VAR res ds, res opadh, res opadl;
INT CONST lo byte mask := dec ("00ff"),
hi byte mask := dec ("ff00"),
branch param mask := dec ("87ff"),
opcode mask0 := dec ("83ff"),
opcode mask1 := dec ("7c00"),
bf mask1 := dec ("0040"),
ln br mask1 := dec ("7800"),
stpdis mask0 := dec ("ffbf"),
stpdis mask1 := dec ("0040"),
aritu mask1 := dec ("0010"),
error mask1 := dec ("0080"),
flags mask1 := dec ("00fc"),
mask 8000 := dec ("8000"),
mask 7fff := dec ("7fff"),
mask 7ffe := dec ("7ffe"),
mask 7f00 := dec ("7f00"),
mask 0400 := dec ("0400"),
mask fbff := dec ("fbff"),
mask 0007 := dec ("0007"),
mask fff8 := dec ("fff8"),
m l t start := dec ("0200"),
ln opcode := dec ("0000"),
br opcode := dec ("7000"),
rtn opcode := dec ("7f00"),
call opcode := dec ("7800"),
longcall opcode := dec ("ff78"),
pproc opcode := dec ("7f1e"),
estop opcode := dec ("7f4b"),
dstop opcode := dec ("7f4c");
TEXT VAR buf, char, command, iname, iname1, ioplist, ioplist1, opd type,
opd buf, text opd, res types, users errmsg;
(********* following OPs and PROCs may be used by TRACE only ***********)
PROC put (TEXT CONST a):
out (a); out (" ")
ENDPROC put;
PROC putline (TEXT CONST a):
out (a); out (crlf)
ENDPROC putline;
(***********************************************************************)
PROC eval br addr (INT CONST br para hi, br para lo,
INT VAR br addr hi, br addr lo):
br param := dsgetw (stdds, br para hi, br para lo)
AND branch param mask;
br addr hi := br para hi;
br addr lo := (br para lo AND hi byte mask)
OR (br param AND lo byte mask);
IF NOT br within page
THEN rotate (br param, 8);
br param := br param AND lo byte mask;
rotate (br param, 1);
IF br param > 255
THEN br param INCR 1;
br param := br param AND 255
FI;
rotate (br param, 8);
br addr lo INCR br param;
word := br addr lo AND hi byte mask; rotate (word, 8);
IF word >= code addr modif
THEN br addr lo DECR dec("1000")
FI
FI.
br within page:
br param = (br param AND lo byte mask).
ENDPROC eval br addr;
PROC eval opd addr (INT CONST ic offset):
word := dsgetw (stdds, ic hi, ic lo PLUS ic offset);
IF ic offset = 0
THEN word := word AND opcode mask0
FI;
IF global
THEN eval global addr
ELIF local
THEN eval local addr
ELSE eval ref addr
FI.
global: (word AND mask 8000) = 0.
local: (word AND 1) = 0.
eval global addr:
opdds := stdds;
opad hi := packet area;
opad hiword := opad hi;
opad lo := pbase PLUS word;
perhaps put opad.
eval local addr:
opdds := stdds;
opad hi := stack area;
opad hiword := opad hi;
word := word AND mask 7ffe; rotate (word, -1);
opad lo := users lbase PLUS word;
perhaps put opad.
eval ref addr:
eval local addr;
opad hiword := dsgetw (stdds, stack area, opad lo PLUS 1);
opad lo := dsgetw (stdds, stack area, opad lo);
opdds := opad hiword AND hi byte mask; rotate (opdds, 8);
opad hi := opad hiword AND lo byte mask;
perhaps put opad.
perhaps put opad:
(* put("opad=" CT hex(opad hiword) CT hex(opad lo)) *) . (*for tests*)
ENDPROC eval opd addr;
PROC out int opd:
out (txt (int opd));
IF int opd < 0 OR int opd > 9
THEN out ("("); out (hex (int opd)); out (")")
FI
ENDPROC out int opd;
PROC fetch text opd:
root word 2 := dsgetw (opdds, opad hi, opad lo PLUS 1);
opd buf := subtext (blanks, 1, text opd maxlen + 2);
IF text on heap
THEN eval text from heap
ELSE eval text from root
FI;
convert nonstd chars;
text opd := """";
text opd CAT subtext (opd buf, 1, text opd tr len);
text opd CAT """";
IF text opd len > text opd tr len
THEN text opd CAT "(...";
text opd CAT txt (text opd len);
text opd CAT "B)"
FI.
text on heap:
(root word 2 AND lo byte mask) = 255.
eval text from root:
text opd len := root word 2 AND lo byte mask;
text opd tr len := min (text opd len, text opd maxlen);
FOR i FROM 1 UPTO text opd tr len DIV 2 + 1 REP
replace (opd buf, i, dsgetw (opdds, opad hi, opad lo PLUS i))
PER;
opd buf := subtext (opd buf, 2, text opd tr len + 1).
eval text from heap:
rotate (root word 2, 8);
text opd len := root word 2 AND lo byte mask
OR (dsget2b (opdds, opad hi, opad lo PLUS 2) AND hi byte mask);
text opd tr len := min (text opd len, text opd maxlen);
heap link := dsgetw (opdds, opad hi, opad lo);
rotate (heap link, 15);
opad hi := heap link AND mask 0007;
opad lo := heap link AND mask fff8;
IF opdds = stdds THEN opad lo INCR 2 FI;
FOR i FROM 1 UPTO text opd tr len DIV 2 REP
replace (opd buf, i, dsgetw (opdds, opad hi, opad lo PLUS i))
PER;
opd buf := subtext (opd buf, 1, text opd tr len).
convert nonstd chars:
i := 1;
WHILE i <= LENGTH opd buf REP
char := opd buf SUB i;
IF pos (std charset, char) = 0
THEN buf := txt (code (char));
opd buf := subtext (opd buf, 1, i-1) CT
"""" CT buf CT """" CT
subtext (opd buf, i+1);
i INCR 2 + length (buf);
ELIF char = """"
THEN opd buf := subtext (opd buf, 1, i-1) CT """""" CT
subtext (opd buf, i+1);
i INCR 2
ELSE i INCR 1
FI
PER;
text opd tr len := LENGTH opd buf.
END PROC fetch text opd;
INT OP PLUS (INT CONST a, b):
unsigned arith;
a + b
ENDOP PLUS;
PROC trace:
ROW 40 INT VAR dummy space for 20 pps;
get return address;
IF initial call
THEN save call to trace
ELSE process regular call
FI.
get return address:
lbase:=local base;
users lbase := dsgetw (stdds, stack area, lbase);
aret lo := dsgetw (stdds, stack area, lbase+1);
word := dsgetw (stdds, stack area, lbase+2);
aret hi := word AND 3;
flags := word AND flags mask1;
ic hi := aret hi; ic lo := aret lo.
save call to trace:
call to trace := dsgetw (stdds, aret hi, aret lo - 1);
IF (call to trace AND opcode mask1) = call opcode
THEN length of call to trace := 1;
longcall to trace flag := FALSE
ELSE call2 to trace := call to trace;
call to trace := dsgetw (stdds, aret hi, aret lo - 2);
length of call to trace := 2;
longcall to trace flag := TRUE;
putline ("WARNING: call to trace needs 2 words!!!")
FI;
initial call := FALSE.
process regular call:
IF protocol
THEN pull old nails
ELSE indentpos := startindent; cond br follows := FALSE
FI;
get users error state and set modes for trace;
IF NOT errorstop processing
THEN normal processing of instructions
ELSE errorstop processing := FALSE
FI;
handle possible trace errors;
IF NOT protocol THEN restore users error state FI.
normal processing of instructions:
trapped := trap set AND atrap lo = ic lo - length of call to trace
AND atrap hi = ic hi;
IF protocol THEN postprocess protocol FI;
IF trapped THEN handle trap FI;
IF protocol OR trapped
THEN ic lo DECR length of call to trace;
update icount on stack
FI;
IF trapped OR NOT protocol OR single step OR incharety <> ""
OR lines >= maxlines
THEN quit := FALSE; protocol := FALSE; single step := FALSE; lines := 0;
REP ask for next action;
execute command
UNTIL quit PER
FI;
IF protocol THEN protocol instruction and set nails FI.
get users error state and set modes for trace:
signed arith;
IF NOT protocol
THEN users error := (flags AND error mask1) <> 0;
users stpdis := (flags AND stpdis mask1) <> 0;
IF users error
THEN save users error state; clear error;
line; putline ("trace called with user error " CT
txt (users errcode) CT ": " CT users errmsg)
ELSE disable stop
FI
ELIF is error
THEN IF first occurrence
THEN users error := TRUE;
save users error state;
line;
putline ("trace detected user error " CT
txt (users errcode) CT ": " CT users errmsg);
IF users stpdis
THEN out ("(stop disabled)")
ELSE errorstop processing := TRUE; stop op;
IF protocol THEN set nail1 FI
FI
ELSE line;
putline ("trace detected user error " CT
txt (error code) CT ": " CT error message);
out ("(ignored because of previous error(s)) ");
FI;
clear error
ELSE IF (flags AND stpdis mask1) = 0
THEN set stpdis flag on stack; disable stop
FI
FI.
first occurrence: NOT users error.
save users error state:
users errmsg := error message;
users errline := error line;
users errcode := error code.
handle possible trace errors:
IF is error
THEN line;
putline ("TRACE error " CT txt (error code)
CT " at line " CT txt (error line)
CT ": " CT error message);
clear error
FI.
restore users error state:
IF users error
THEN error stop (users errcode, users errmsg);
users error := FALSE
FI;
restore users stpdis flag on stack.
handle trap:
put trap message;
restore instruction;
trap set := FALSE.
put trap message:
putline ("trap at address " CT txt (atrap hi) CT hex (atrap lo)).
restore instruction:
dsputw (stdds, atrap hi, atrap lo, saved instr);
IF longcall to trace flag
THEN dsputw (stdds, atrap hi, atrap lo PLUS 1, saved instr w2)
FI.
postprocess protocol:
IF prot operands THEN protocol result operands FI;
line; lines INCR 1;
IF cond br follows THEN protocol cond br op; cond br follows := FALSE FI.
protocol cond br op:
outsubtext (blanks, 1, indentpos);
out (txt (cond br hi)); out (hex (cond br lo)); out (": ");
word := dsget2b (stdds, cond br hi, cond br lo);
IF (word AND bf mask1) <> 0
THEN out ("BF ")
ELSE out ("BT ")
FI;
putline (hex (word)); lines INCR 1.
pull old nails:
dsputw (stdds, nail1 hi, nail1 lo, saved1);
IF longcall to trace flag
THEN dsputw (stdds, nail1 hi, nail1 lo PLUS 1, saved1 w2)
FI;
IF no of nails = 2
THEN dsputw (stdds, nail2 hi, nail2 lo, saved2);
IF longcall to trace flag
THEN dsputw (stdds, nail2 hi, nail2 lo PLUS 1, saved2 w2)
FI;
no of nails := 1
FI.
update icount on stack:
dsputw (stdds, 1, lbase + 1, ic lo).
ask for next action:
putline (""15"" CT
"TRACE: step, more, trap, regs, lines, info, disasm, or quit"14"");
inchar (command).
execute command:
cmd := pos ("tidqmsrl", command);
SELECT cmd OF
CASE 1: set address trap; prot stopped := TRUE
CASE 2: info (stdds, ic hi, ic lo, info lines); prot stopped := TRUE
CASE 3: disasm (ic hi, ic lo); prot stopped := TRUE
CASE 4: quit := TRUE; prot stopped := TRUE
CASE 5: initialize protocol; single step := FALSE;
quit := TRUE
CASE 6: initialize protocol; single step := TRUE;
quit := TRUE
CASE 7: show registers; prot stopped := TRUE
CASE 8: set new line count; prot stopped := TRUE
OTHERWISE out(beep CT carriage return CT cursor up)
ENDSELECT.
set new line count:
out ("lines="); gethex (buf); maxlines := dec (buf).
set address trap:
IF trap set
THEN putline ("current trap address: " CT txt (atrap hi) CT hex (atrap lo));
out ("type <CR> to confirm, or ")
ELSE out ("type ")
FI;
out ("new trap addr (");
IF std procs traceable THEN out ("2") ELSE out ("3") FI;
out ("0000...3ffff), or 0 for no trap:");
gethex (buf);
IF buf <> ""
THEN IF trap set THEN restore instruction; trap set := FALSE FI;
buf:="0000" CT buf;
atrap hi := dec (subtext (buf, LENGTH buf-7, LENGTH buf-4));
atrap lo := dec (subtext (buf, LENGTH buf-3));
IF atrap hi=3 OR atrap hi=2 AND std procs traceable
THEN saved instr := dsgetw (stdds, atrap hi, atrap lo);
dsputw (stdds, atrap hi, atrap lo, call to trace);
IF longcall to trace flag
THEN saved instr w2 := dsgetw (stdds, atrap hi, atrap lo PLUS 1);
dsputw (stdds, atrap hi, atrap lo PLUS 1, call2 to trace);
FI;
trap set := TRUE
ELIF NOT (atrap hi=0 AND atrap lo=0)
THEN out (beep); putline ("address not in above range")
FI
ELSE IF NOT trap set THEN out (beep); putline ("no trap specified") FI
FI.
initialize protocol:
pbase := dsgetw (stdds, stack area, lbase + 2) AND hi byte mask;
code addr modif := dsgetw (stdds, stack area, lbase + 3)
AND lo byte mask;
set stpdis flag on stack;
prot just started := TRUE;
protocol := TRUE.
set stpdis flag on stack:
word := dsgetw (stdds, stack area, lbase + 2);
dsputw (stdds, stack area, lbase + 2, word OR stpdis mask1).
restore users stpdis flag on stack:
word := dsgetw (stdds, stack area, lbase + 2) AND stpdis mask0;
IF users stpdis THEN word := word OR stpdis mask1 FI;
dsputw (stdds, stack area, lbase + 2, word).
protocol instruction and set nails:
protocol instr;
SELECT iclass OF
CASE 0: standard ops
CASE 1: cond branch ops
CASE 2: branch ops
CASE 3: comp branch op
CASE 4: call op
CASE 5: exec op
CASE 6: pcall op
CASE 7: return ops
CASE 8: penter op
CASE 9: pp ops
CASE 10: line ops
CASE 11: stop ops
CASE 12: ke op
CASE 13: clrerr op
OTHERWISE: wrong ops
ENDSELECT;
IF protocol THEN set nail1 FI.
protocol instr:
word1 := dsgetw (stdds, ic hi, ic lo);
disa (ic hi, ic lo, iname, ioplist, ilen, iclass);
protocol this instr.
protocol this instr:
possibly delete command line;
outsubtext (blanks, 1, indentpos);
ic h := ic hi; ic l := ic lo;
out (txt (ic h)); out (hex (ic l)); out (": ");
out (iname); out (" ");
IF ilen > 0
THEN FOR i FROM 1 UPTO ilen
REP out (hex (dsget2b (stdds, ic h, ic l))); out (" ");
ic l INCR 1 PER
ELSE out (hex (dsget2b (stdds, ic h, ic l))); out (" ")
FI;
IF prot operands THEN protocol operands FI.
possibly delete command line:
IF prot just started
THEN prot just started := FALSE;
IF prot stopped
THEN prot stopped := FALSE
ELSE delete command line
FI
FI.
delete command line:
get cursor (xpos, ypos); cursor (1, ypos-1); out(""4"").
protocol operands:
out (" ");
IF (word1 AND mask 7f00) = mask 7f00
THEN ic off := 1
ELSE ic off := 0
FI;
res types := "";
no of results := 0;
FOR opd ptr FROM 1 UPTO LENGTH ioplist REP
opd type := ioplist SUB opd ptr;
IF opd type <> " "
THEN case := pos ("irtdpahIRTDPEH", opd type);
IF case > 0
THEN eval opd addr (ic off);
SELECT case OF
CASE 1: prot int rd opd
CASE 2: prot real rd opd
CASE 3: prot text rd opd
CASE 4: prot dataspace rd opd
CASE 5: prot task rd opd
CASE 6: prot virt addr
CASE 7: prot hex rd opd
OTHERWISE save res type
ENDSELECT
FI;
ic off INCR 1
FI
UNTIL opd type = " " PER.
save res type:
res types CAT opd type;
no of results INCR 1;
res ds (no of results) := opdds;
res opadh (no of results) := opad hi;
res opadl (no of results) := opad lo.
protocol result operands:
FOR opd ptr FROM 1 UPTO no of results REP prot this result PER.
prot this result:
opdds := res ds (opd ptr);
opad hi := res opadh (opd ptr);
opad lo := res opadl (opd ptr);
opd type := res types SUB opd ptr;
SELECT pos ("IRTDPEH", opd type) OF
CASE 1: prot int result
CASE 2: prot real result
CASE 3: prot text result
CASE 4: prot dataspace result
CASE 5: prot task result
CASE 6: prot eva result
CASE 7: prot hex result
OTHERWISE out (opd type CT "(???) ")
ENDSELECT.
prot int rd opd:
int opd := dsgetw (opdds, opad hi, opad lo);
out (">"); out int opd; out (" ").
prot int result:
int opd := dsgetw (opdds, opad hi, opad lo);
out int opd; out ("> ").
prot hex rd opd:
int opd := dsgetw (opdds, opad hi, opad lo);
out (">"); out (hex (int opd)); out (" ").
prot hex result:
int opd := dsgetw (opdds, opad hi, opad lo);
out (hex (int opd)); out ("> ").
prot real rd opd:
out (">");
out (hex (dsget2b (opdds, opad hi, opad lo)));
out (hex (dsget2b (opdds, opad hi, opad lo PLUS 1)));
out (hex (dsget2b (opdds, opad hi, opad lo PLUS 2)));
out (hex (dsget2b (opdds, opad hi, opad lo PLUS 3))); out (" ").
prot real result:
out (hex (dsget2b (opdds, opad hi, opad lo)));
out (hex (dsget2b (opdds, opad hi, opad lo PLUS 1)));
out (hex (dsget2b (opdds, opad hi, opad lo PLUS 2)));
out (hex (dsget2b (opdds, opad hi, opad lo PLUS 3)));
out ("> ").
prot text rd opd:
fetch text opd;
out (">"); out (text opd); out (" ").
prot text result:
fetch text opd;
out (text opd); out ("> ").
prot dataspace rd opd:
int opd := dsgetw (opdds, opad hi, opad lo);
out (">"); out (hex (int opd)); out (" ").
prot dataspace result:
int opd := dsgetw (opdds, opad hi, opad lo);
out (hex (int opd)); out ("> ").
prot task rd opd:
out (">"); out (hex (dsgetw (opdds, opad hi, opad lo)));
out ("/"); out (hex (dsgetw (opdds, opad hi, opad lo PLUS 1))); out (" ").
prot task result:
out (hex (dsgetw (opdds, opad hi, opad lo))); out ("/");
out (hex (dsgetw (opdds, opad hi, opad lo PLUS 1))); out ("> ").
prot virt addr:
out (">"); out (hex (opad hiword)); out (hex (opad lo)); out (" ").
prot eva result:
out (hex (dsgetw (opdds, opad hi, opad lo PLUS 1)));
out (hex (dsgetw (opdds, opad hi, opad lo)));
out (">").
standard ops:
nail1 hi := ic hi; nail1 lo := ic lo PLUS ilen.
set nail1:
saved1 := dsgetw (stdds, nail1 hi, nail1 lo);
dsputw (stdds, nail1 hi, nail1 lo, call to trace);
IF longcall to trace flag
THEN saved1 w2 := dsgetw (stdds, nail1 hi, nail1 lo PLUS 1);
dsputw (stdds, nail1 hi, nail1 lo PLUS 1, call2 to trace)
FI.
set nail2:
saved2 := dsgetw (stdds, nail2 hi, nail2 lo);
dsputw (stdds, nail2 hi, nail2 lo, call to trace);
IF longcall to trace flag
THEN saved2 w2 := dsgetw (stdds, nail2 hi, nail2 lo PLUS 1);
dsputw (stdds, nail2 hi, nail2 lo PLUS 1, call2 to trace)
FI.
cond branch ops:
cond br follows := TRUE;
cond br hi := ic hi; cond br lo := ic lo PLUS ilen;
nail1 hi := cond br hi; nail1 lo := cond br lo PLUS 1;
eval br addr (cond br hi, cond br lo, nail2 hi, nail2 lo);
no of nails := 2; set nail2.
branch ops:
eval br addr (ic hi, ic lo, nail1 hi, nail1 lo).
comp branch op:
eval opd addr (1);
brcomp index := dsgetw (stdds, opad hi, opad lo);
IF brcomp index < 0 OR brcomp index >= dsgetw (stdds, ic hi, ic lo PLUS 2)
THEN brcomp index := -1
FI;
nail1 hi := ic hi;
nail1 lo := ic lo PLUS ilen PLUS brcomp index PLUS 1.
call op:
eval module no;
call or exec.
call or exec:
IF module no < 1280 AND NOT std procs traceable
THEN possibly append proc head;
out (" (*n.t.*)");
nontraceable found := TRUE
ELSE check for nontraceable
FI;
IF NOT nontraceable found
THEN restore users stpdis flag on stack;
get proc address via module link table;
possibly append proc head;
indentpos INCR indentincr;
nail1 hi := ic hi; nail1 lo := ic lo PLUS 1 (*nail behind head*)
ELIF call to trace found
THEN skip instruction
ELIF possibly call to bool proc
THEN cond branch ops
ELSE standard ops
FI.
eval module no:
IF word1 = longcall opcode
THEN module no := dsgetw (stdds, ic hi, ic lo PLUS 1)
ELSE module no := word1 AND opcode mask0;
IF (module no AND mask 8000) <> 0
THEN module no := module no AND mask 7fff OR mask 0400
FI
FI.
check for nontraceable:
nontraceable found := FALSE;
IF word1 = longcall opcode
THEN word2 := dsgetw (stdds, ic hi, ic lo PLUS 1);
FOR j FROM 1 UPTO no of long nontraceables REP
IF word 2 = call2 to nontraceables (j)
THEN out (names of long nontraceables (j));
nontraceable found := TRUE
FI
UNTIL nontraceable found PER
ELSE FOR j FROM 1 UPTO no of nontraceables REP
IF word1 = calls to nontraceables (j)
THEN out (names of short nontraceables (j));
nontraceable found := TRUE
FI
UNTIL nontraceable found PER
FI.
get proc address via module link table:
IF module no < 1280 THEN ic hi := 2 ELSE ic hi := 3 FI;
ic lo := dsgetw (stdds, packet area, m l t start + module no).
possibly append proc head:
out (proc head (module no)).
skip instruction:
ic lo INCR ilen; update icount on stack;
nail1 hi := ic hi; nail1 lo := ic lo.
possibly call to bool proc:
word := dsgetw (stdds, ic hi, ic lo PLUS ilen) AND ln br mask1;
word = ln opcode OR word = br opcode.
exec op:
eval opd addr (1);
module no := dsgetw (stdds, opad hi, opad lo);
call or exec.
pcall op:
eval opd addr (1);
IF opad lo = 2 AND NOT std procs traceable
THEN out (" (*n.t.*)");
nontraceable found := TRUE
ELSE check for nontraceable pproc
FI;
IF NOT nontraceable found
THEN restore users stpdis flag on stack;
possibly append proc head for pproc;
indentpos INCR indentincr;
nail1 hi := opad hi; nail1 lo := opad lo PLUS 1 (*nail behind head*)
(*ELIF word1 = call to trace
THEN skip instruction *)
ELIF possibly call to bool proc
THEN cond branch ops
ELSE standard ops
FI.
check for nontraceable pproc:
nontraceable found := FALSE;
IF opad lo = pproc ic lo
THEN FOR j FROM 1 UPTO no of nontraceables REP
IF pproc call = calls to nontraceables (j)
THEN out (names of nontraceables (j));
nontraceable found := TRUE
FI
UNTIL nontraceable found PER
ELSE nontraceable found := TRUE (*to be on the secure side*)
FI.
possibly append proc head for pproc:
IF opad lo = pproc ic lo
THEN out (proc head (pproc modno))
FI.
return ops:
fetch eumel0 regs of caller from users stack;
out ("--> ");
put users flags;
IF (old flags AND aritu mask1) <> 0
THEN put ("ARITU")
ELSE put ("ARITS")
FI;
IF nontraceable caller
THEN line; putline ("trace ended by returning to nontraceable caller");
protocol := FALSE; prot stopped := TRUE
ELIF users error AND NOT users stpdis
THEN stop op
ELSE set nail for return ops
FI.
set nail for return ops:
IF word1 = rtn opcode
THEN nail1 hi := ic hi; nail1 lo := ic lo
ELSE nail1 hi := ic hi; nail1 lo := ic lo PLUS 1;
eval br addr (ic hi, ic lo, nail2 hi, nail2 lo);
no of nails := 2; set nail2
FI.
penter op:
pbase := word1 AND lo byte mask; rotate (pbase, 8);
standard ops.
line ops:
standard ops.
stop ops:
IF word1 = estop opcode
THEN users stpdis := FALSE;
IF users error THEN stop op ELSE standard ops FI
ELIF word1 = dstop opcode
THEN users stpdis := TRUE; standard ops
ELSE stop op
FI.
clrerr op:
users error := FALSE; standard ops.
ke op:
skip instruction;
line; putline ("INFO: ke");
info (stdds, ic hi, ic lo, info lines);
single step := TRUE.
pp ops:
save modno and ic lo if pproc;
look at next instr;
WHILE iclass1 = 9 REP
ic lo INCR ilen; iname := iname1; ioplist := ioplist1;
ilen := ilen1; iclass := iclass1;
line; lines INCR 1;
protocol this instr;
save modno and ic lo if pproc; (*only the first one will be saved!!!*)
look at next instr
PER;
standard ops.
save modno and ic lo if pproc:
IF word1 = pproc opcode
THEN pproc modno := dsgetw (stdds, ic hi, ic lo PLUS 1);
IF pproc modno < 256
THEN putline ("*** this looks like a compiler error ***");
protocol := FALSE; prot stopped := TRUE; users error := TRUE;
users errcode := 0; users errmsg := ("maybe a compiler error");
LEAVE normal processing of instructions
ELIF (pproc modno AND mask 0400) <> 0
THEN word := (pproc modno AND mask fbff) OR mask 8000
ELSE word := pproc modno
FI;
pproc call := word OR opcode mask1;
pproc ic lo := dsgetw (stdds, packet area, m l t start + pproc modno)
FI.
look at next instr:
word1 := dsgetw (stdds, ic hi, ic lo PLUS ilen);
disa (ic hi, ic lo PLUS ilen, iname1, ioplist1, ilen1, iclass1).
wrong ops:
putline ("**** das kann ich (noch) nicht!!! ***");
info (stdds, ic hi, ic lo, info lines);
protocol := FALSE.
show registers:
pbase := dsgetw (stdds, stack area, lbase + 2) AND hi byte mask;
code addr modif := dsgetw (stdds, stack area, lbase + 3)
AND lo byte mask;
putline ("----------------- EUMEL0-registers: ------------------");
put ("icount=" CT txt (ic hi) CT hex (ic lo) CT
" lbase=1" CT hex (users lbase) CT " pbase=" CT hex (pbase));
put users flags;
IF (flags AND aritu mask1) <> 0
THEN putline ("ARITU")
ELSE putline ("ARITS")
FI.
put users flags:
IF users stpdis
THEN put ("STPDIS")
ELSE put ("STOPEN")
FI;
IF users error
THEN put ("ERROR")
ELSE put ("NOERR")
FI.
ENDPROC trace;
PROC stop op:
line;
suppress result protocolling;
REP outsubtext (blanks, 1, indentpos);
fetch eumel0 regs of caller from users stack;
out ("stop/error induced return to addr ");
out (txt (ic hi)); out (hex (ic lo));
IF users stpdis
THEN putline (" (STPDIS)")
ELSE putline (" (STOPEN)")
FI;
lines INCR 1;
IF nontraceable caller
THEN putline ("trace ended by returning to nontraceable caller");
protocol := FALSE; prot stopped := TRUE
ELIF users stpdis
THEN copy stack of disabled caller to tracers stack
ELSE users lbase := dsgetw (stdds, stack area, users lbase)
FI
UNTIL users stpdis OR NOT protocol PER;
nail1 hi := ic hi; nail1 lo := ic lo.
suppress result protocolling:
no of results := 0.
copy stack of disabled caller to tracers stack:
FOR i FROM 1 UPTO 4 REP
word := dsgetw (stdds, stack area, users lbase + i - 1);
dsputw (stdds, stack area, lbase + i - 1, word)
PER.
ENDPROC stop op;
i n i t i a l i z e t r a c e.
nontraceable caller:
ic hi = 2 AND NOT std procs traceable
OR (old flags AND aritu mask1) <> 0 AND (flags AND aritu mask1) = 0.
fetch eumel0 regs of caller from users stack:
indentpos DECR indentincr;
ic lo := dsgetw (stdds, stack area, users lbase + 1);
word := dsgetw (stdds, stack area, users lbase + 2);
ic hi := word AND 3;
old flags := word AND flags mask1;
users stpdis := (old flags AND stpdis mask1) <> 0;
pbase := word AND hi byte mask;
code addr modif := dsgetw (stdds, stack area, users lbase + 3)
AND lo byte mask.
initialize trace:
LET maxno of nontraceables = 20;
INT VAR int, j;
TEXT VAR text;
ROW maxno of nontraceables TEXT VAR names of nontraceables;
ROW maxno of nontraceables TEXT VAR names of short nontraceables;
ROW maxno of nontraceables TEXT VAR names of long nontraceables;
ROW maxno of nontraceables INT VAR calls to nontraceables;
ROW maxno of nontraceables INT VAR call2 to nontraceables;
putline("initializing ""trace"" ...");
names of nontraceables (1) := "disa (I,I,T,T,I,I) (*n.t.*)";
names of nontraceables (2) := "disasm (I,I) (*n.t.*)";
names of nontraceables (3) := "info (I,I,I,I) (*n.t.*)";
names of nontraceables (4) := "dec (T) (*n.t.*)";
names of nontraceables (5) := "hex (I) (*n.t.*)";
names of nontraceables (6) := "dsget2b (I,I,I) (*n.t.*)";
names of nontraceables (7) := "trace (*ignored*)";
trace; (* initialize 'call to trace', 'ic hi' and 'ic lo' *)
IF FALSE THEN
disa (int, int, text, text, int, int);
disasm (int, int);
info (int, int, int, int);
int := dec (text);
text := hex (int);
int := dsget2b (int, int, int);
trace (****** must be the last one !!! *****)
FI;
FOR j FROM 1 UPTO maxno of nontraceables REP
REP ic lo INCR 1;
word1 := dsgetw (stdds, ic hi, ic lo)
UNTIL call opcode found PER;
IF word1 <> longcall opcode
THEN no of nontraceables INCR 1;
calls to nontraceables (no of nontraceables) := word1;
names of short nontraceables (no of nontraceables) :=
names of nontraceables (j)
ELSE no of long nontraceables INCR 1;
word2 := dsgetw (stdds, ic hi, ic lo PLUS 1); ic lo INCR 1;
call2 to nontraceables (no of long nontraceables) := word2;
names of long nontraceables (no of long nontraceables) :=
names of nontraceables (j)
FI
UNTIL call to trace found
OR no of nontraceables = maxno of nontraceables
OR no of long nontraceables = maxno of nontraceables PER;
putline ("""trace"" initialized:");
putline (" " CT txt (no of nontraceables)
CT " nontraceable shortcalls");
putline (" " CT txt (no of long nontraceables)
CT " nontraceable longcalls");
IF no of nontraceables = maxno of nontraceables
OR no of long nontraceables = maxno of nontraceables
THEN errorstop ("too many nontraceables")
ELSE test trace
FI.
call opcode found:
(word1 AND opcode mask1) = call opcode OR word1 = longcall opcode.
call to trace found:
IF word1 = call to trace
THEN IF longcall to trace flag
THEN word2 = call2 to trace
ELSE TRUE
FI
ELSE FALSE
FI.
test trace:.
END PACKET trace;