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 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;