summaryrefslogtreecommitdiff
path: root/devel/debug/1/src
diff options
context:
space:
mode:
authorLars-Dominik Braun <lars@6xq.net>2019-02-04 13:09:03 +0100
committerLars-Dominik Braun <lars@6xq.net>2019-02-04 13:09:03 +0100
commit04e68443040c7abad84d66477e98f93bed701760 (patch)
tree2b6202afae659e773bf6916157d23e83edfa44e3 /devel/debug/1/src
downloadeumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.gz
eumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.bz2
eumel-src-04e68443040c7abad84d66477e98f93bed701760.zip
Initial import
Diffstat (limited to 'devel/debug/1/src')
-rw-r--r--devel/debug/1/src/RUN dez <-> hex49
-rw-r--r--devel/debug/1/src/all tracer10
-rw-r--r--devel/debug/1/src/convert154
-rw-r--r--devel/debug/1/src/disa454
-rw-r--r--devel/debug/1/src/extended instr25
-rw-r--r--devel/debug/1/src/gen.bulletin536
-rw-r--r--devel/debug/1/src/gen.procheads89
-rw-r--r--devel/debug/1/src/gen.trace23
-rw-r--r--devel/debug/1/src/info371
-rw-r--r--devel/debug/1/src/trace1020
-rw-r--r--devel/debug/1/src/trace.dok387
11 files changed, 3118 insertions, 0 deletions
diff --git a/devel/debug/1/src/RUN dez <-> hex b/devel/debug/1/src/RUN dez <-> hex
new file mode 100644
index 0000000..041fcf1
--- /dev/null
+++ b/devel/debug/1/src/RUN dez <-> hex
@@ -0,0 +1,49 @@
+LET hexziffern = "123456789ABCDEF";
+ROW 4 INT CONST faktoren :: ROW 4 INT : (1, 16, 256, 4096);
+
+INT PROC dez (TEXT CONST hex):
+ INT VAR stellen := LENGTH hex;
+ IF stellen > 4
+ OR stellen > 3 AND (hex SUB 1) > "7"
+ THEN errorstop ("Zahl zu groß")
+ FI;
+ INT VAR i :: 0, stelle, ziffpos;
+ TEXT VAR ziffer;
+ FOR stelle FROM 1 UPTO stellen REP
+ ziffer := hex SUB (stellen - stelle + 1);
+ ziffpos := pos (hexziffern, ziffer);
+ IF ziffpos <> 0
+ THEN i INCR ziffpos * faktoren [stelle]
+ ELIF ziffer <> "0"
+ THEN errorstop ("Hexadezimalzahl fehlerhaft")
+ FI
+ PER;
+ i
+END PROC dez;
+{194 + 76 ; kann nicht durch `replace' zu Beginn verkleinert werden }
+TEXT PROC hex (TEXT CONST t dez):
+ IF t dez = "" THEN LEAVE hex WITH "" FI;
+ INT VAR stelle, hex ziffer, dez := int (t dez);
+ TEXT VAR hexzahl := "";
+ FOR stelle FROM 4 DOWNTO 1 REP
+ hexziffer := dez DIV faktoren [stelle];
+ IF hexziffer <> 0
+ THEN hexzahl CAT (hexziffern SUB hexziffer);
+ dez DECR hexziffer * faktoren [stelle]
+ ELSE hexzahl CAT "0"
+ FI
+ PER;
+ hexzahl
+END PROC hex;
+
+putline (""1""4"Dezimalzahlen schlicht, Hexadezimalzahlen mit schließendem ""h"" eingeben");
+line;
+TEXT VAR z;
+REP put ("Zahl:");
+ get (z);
+ IF (z SUB LENGTH z) = "h"
+ THEN put (dez (subtext (z, 1, LENGTH z - 1)))
+ ELSE put (hex (z))
+ FI
+UNTIL z = "" PER
+
diff --git a/devel/debug/1/src/all tracer b/devel/debug/1/src/all tracer
new file mode 100644
index 0000000..1e84b59
--- /dev/null
+++ b/devel/debug/1/src/all tracer
@@ -0,0 +1,10 @@
+gen.trace
+extended instr
+convert
+info
+disa
+trace
+gen.procheads
+gen.bulletin
+trace.dok
+
diff --git a/devel/debug/1/src/convert b/devel/debug/1/src/convert
new file mode 100644
index 0000000..426a5e5
--- /dev/null
+++ b/devel/debug/1/src/convert
@@ -0,0 +1,154 @@
+PACKET convert DEFINES dec, hex, dsget2b, exhilo, (* Stand: 87-01-13 *)
+ addc, subc, addl, subl, incl, (* Autor: G. Szalay *)
+ txt, CT, gethex, integ:
+
+LET dectab = "0123456789", hextab="0123456789abcdef", mask16=15;
+INT VAR number, digit, i;
+TEXT VAR buffer, char;
+INT CONST min 1 := dec ("ffff"),
+ min 2 := dec ("fffe"),
+ minint := dec ("8000"),
+ maxint := dec ("7fff"),
+ maxint min 1 := dec ("7ffe");
+
+INT PROC integ (TEXT CONST text): (*only digits allowed*)
+ number := 0;
+ FOR i FROM 1 UPTO LENGTH text REP
+ digit := pos (dectab, text SUB i);
+ IF digit > 0
+ THEN number := number * 10 + digit - 1
+ FI
+ UNTIL digit = 0 PER;
+ number
+END PROC integ;
+
+TEXT PROC hex (INT CONST n):
+ buffer := ""; number := n;
+ FOR i FROM 1 UPTO 4 REP
+ rotate (number,4);
+ digit := number AND mask16;
+ buffer CAT (hextab SUB (digit + 1))
+ PER;
+ buffer
+END PROC hex;
+
+INT PROC dec (TEXT CONST t):
+ IF LENGTH t > 4 THEN leave with message FI;
+ number := 0;
+ FOR i FROM 1 UPTO LENGTH t
+ REP char := t SUB i;
+ digit := pos (hextab, char) - 1;
+ IF digit<0 THEN leave with message FI;
+ rotate (number, 4);
+ number INCR digit
+ PER;
+ number.
+
+ leave with message:
+ error stop ("wrong param for dec");
+ LEAVE dec WITH 0.
+
+END PROC dec;
+
+INT PROC exhilo (INT CONST val):
+ INT VAR ex := val; rotate (ex, 8);
+ ex
+END PROC exhilo;
+
+INT PROC dsget2b (INT CONST drid, off hi, off lo):
+ INT VAR val := dsgetw (drid, off hi, off lo);
+ IF drid <> 1 THEN rotate (val, 8) FI;
+ val
+END PROC dsget2b;
+
+PROC addc (INT CONST a, b, INT VAR sum, BOOL VAR carry):
+ INT VAR s;
+ disable stop;
+ s := a + b;
+ IF a >= 0 AND b >= 0 THEN carry := FALSE
+ ELIF a < 0 AND b < 0 THEN carry := TRUE
+ ELSE carry := s >= 0
+ FI;
+ sum := s;
+ clear error
+END PROC addc;
+
+PROC subc (INT CONST a, b, INT VAR diff, BOOL VAR carry):
+ INT VAR d;
+ disable stop;
+ d := a - b;
+ IF a >= 0 AND b < 0 THEN carry := TRUE
+ ELIF a < 0 AND b >= 0 THEN carry := FALSE
+ ELSE carry := d < 0
+ FI;
+ diff := d;
+ clear error
+END PROC subc;
+
+PROC incl (INT VAR ah, al, INT CONST ainc):
+ BOOL VAR ov;
+ IF ainc = 1
+ THEN IF al = min1 THEN al := 0; ah INCR 1
+ ELIF al = maxint THEN al := minint
+ ELSE al INCR 1
+ FI
+ ELIF ainc = 2
+ THEN IF al = min2 THEN al := 0; ah INCR 1
+ ELIF al = maxint min1 THEN al := minint
+ ELSE al INCR 2
+ FI
+ ELSE addc (al, ainc, al, ov);
+ IF ov THEN addc (ah, 1, ah, ov) FI
+ FI
+END PROC incl;
+
+PROC addl (INT CONST ah, al, bh, bl, INT VAR sumh, suml, BOOL VAR carry):
+ BOOL VAR low carry, high carry;
+ addc (al, bl, suml, low carry);
+ addc (ah, bh, sumh, high carry);
+ IF low carry THEN addc (sumh, 1, sumh, low carry) FI;
+ carry := low carry OR high carry
+END PROC addl;
+
+PROC subl (INT CONST ah, al, bh, bl, INT VAR diffh, diffl, BOOL VAR carry):
+ BOOL VAR low carry, high carry;
+ subc (al, bl, diffl, low carry);
+ subc (ah, bh, diffh, high carry);
+ IF low carry THEN subc (diffh, 1, diffh, low carry) FI;
+ carry := low carry OR high carry
+END PROC subl;
+
+TEXT PROC txt (INT CONST num):
+ IF num = minint THEN "-32768"
+ ELIF num < 0 THEN "-" CT txt (-num)
+ ELIF num <= 9 THEN code (num + 48)
+ ELSE txt (num DIV 10) CT code (num MOD 10 + 48)
+ FI
+END PROC txt;
+
+TEXT OP CT (TEXT CONST left, right):
+ buffer := left; buffer CAT right; buffer
+END OP CT;
+
+PROC gethex (TEXT VAR hexline):
+ buffer := "";
+ REP inchar (char);
+ SELECT pos (""13""12"0123456789abcdef", char) OF
+ CASE 0: out(""7"")
+ CASE 1: hexline := buffer; out (""13""10""); LEAVE gethex
+ CASE 2: delete last char
+ OTHERWISE buffer CAT char; out (char)
+ ENDSELECT
+ PER.
+
+delete last char:
+ IF buffer = ""
+ THEN out (""7"")
+ ELSE buffer := subtext (buffer, 1, LENGTH buffer - 1);
+ out (""8" "8"")
+ FI.
+
+ENDPROC gethex;
+
+END PACKET convert;
+
diff --git a/devel/debug/1/src/disa b/devel/debug/1/src/disa
new file mode 100644
index 0000000..8819e21
--- /dev/null
+++ b/devel/debug/1/src/disa
@@ -0,0 +1,454 @@
+PACKET dis DEFINES disasm, disa, proc head, (* Autor: G.Szalay *)
+ set proc heads: (* Stand: 87-04-23 *)
+
+LET INSTR = STRUCT (TEXT mnem, INT length, class),
+ clear to eop = ""4"", stdds = 0, no of lines = 4, beep = ""7"";
+INT VAR first word, opcode, cur x, cur y;
+INT CONST right 2 := -2;
+
+ROW 31 INSTR CONST primary list :: ROW 31 INSTR:
+ ( INSTR: ("LN - ",1,10),
+ INSTR: ("LN1 - ",1,10),
+ INSTR: ("MOV i- ",2,0),
+ INSTR: ("INC1 I ",1,0),
+ INSTR: ("DEC1 I ",1,0),
+ INSTR: ("INC Ii ",2,0),
+ INSTR: ("DEC Ii ",2,0),
+ INSTR: ("ADD iiI ",3,0),
+ INSTR: ("SUB iiI ",3,0),
+ INSTR: ("CLEAR I ",1,0),
+ INSTR: ("TEST i ",1,1),
+ INSTR: ("EQU ii ",2,1),
+ INSTR: ("LSEQ ii ",2,1),
+ INSTR: ("FMOV r- ",2,0),
+ INSTR: ("FADD rrR ",3,0),
+ INSTR: ("FSUB rrR ",3,0),
+ INSTR: ("FMUL rrR ",3,0),
+ INSTR: ("FDIV rrR ",3,0),
+ INSTR: ("FLSEQ rr ",2,1),
+ INSTR: ("TMOV t- ",2,0),
+ INSTR: ("TEQU tt ",2,1),
+ INSTR: ("ULSEQ ii ",2,1),
+ INSTR: ("DSACC dE ",2,0),
+ INSTR: ("REF a- ",2,0),
+ INSTR: ("SUBS vviaE",5,0),
+ INSTR: ("SEL avE ",3,0),
+ INSTR: ("PPV -i ",2,9),
+ INSTR: ("PP a ",1,9),
+ INSTR: ("B - ",1,2),
+ INSTR: ("B1 - ",1,2),
+ INSTR: ("CALL - ",1,4) );
+
+ROW 6 INSTR CONST special list :: ROW 6 INSTR:
+ ( INSTR: ("EQUIM vi ",2,1),
+ INSTR: ("MOVX vh- ",3,0),
+ INSTR: ("GETW ihI ",3,0),
+ INSTR: ("MOVI vI ",2,0),
+ INSTR: ("PUTW vhi ",3,0),
+ INSTR: ("PENTER v ",1,8) );
+
+ROW 157 INSTR CONST secondary list :: ROW 157 INSTR:
+ ( INSTR: ("RTN ",1,7),
+ INSTR: ("RTNT ",1,7),
+ INSTR: ("RTNF ",1,7),
+ INSTR: ("RESTART ",1,0),
+ INSTR: ("STOP ",1,11),
+ (* INSTR: ("*057F* ",0,0), *)
+ INSTR: ("LBAS H ",2,0),
+ INSTR: ("KE ",1,12),
+ (* INSTR: ("*077F* ",0,0), *)
+ INSTR: ("DSGETW dhhH ",5,0),
+ INSTR: ("BCRD iI ",3,0),
+ INSTR: ("CRD II ",3,0),
+ INSTR: ("ECWR Iii ",4,0),
+ INSTR: ("CWR IIi ",4,0),
+ INSTR: ("CTT iE ",3,0),
+ INSTR: ("GETC tII ",4,1),
+ INSTR: ("FNONBL ItI ",4,1),
+ INSTR: ("DREM256 Ii ",3,0),
+ INSTR: ("AMUL256 Ii ",3,0),
+ (* INSTR: ("*117F* ",0,0), *)
+ INSTR: ("DSPUTW dhhh ",5,0),
+ INSTR: ("ISDIG i ",2,1),
+ INSTR: ("ISLD i ",2,1),
+ INSTR: ("ISLC i ",2,1),
+ INSTR: ("ISUC i ",2,1),
+ INSTR: ("GADDR -iI ",4,0),
+ INSTR: ("GCADDR iiI ",4,1),
+ INSTR: ("ISSHA a ",2,1),
+ INSTR: ("SYSG ",1,0),
+ INSTR: ("GETTAB ",1,0),
+ INSTR: ("PUTTAB ",1,0),
+ INSTR: ("ERTAB ",1,0),
+ INSTR: ("EXEC - ",2,5),
+ INSTR: ("PPROC - ",2,9),
+ INSTR: ("PCALL - ",2,6),
+ INSTR: ("BRCOMP iv ",3,3),
+ INSTR: ("MOVXX vh- ",4,0),
+ INSTR: ("ALIAS vdD ",4,0),
+ INSTR: ("MOVII vI ",3,0),
+ INSTR: ("FEQU rr ",3,1),
+ INSTR: ("TLSEQ tt ",3,1),
+ INSTR: ("FNEG rR ",3,0),
+ INSTR: ("NEG iI ",3,0),
+ INSTR: ("IMULT iiI ",4,0),
+ INSTR: ("MUL iiI ",4,0),
+ INSTR: ("DIV iiI ",4,0),
+ INSTR: ("MOD iiI ",4,0),
+ INSTR: ("ITSUB tiI ",4,0),
+ INSTR: ("ITRPL Tii ",4,0),
+ INSTR: ("DECOD tI ",3,0),
+ INSTR: ("ENCOD iT ",3,0),
+ INSTR: ("SUBT1 tiT ",4,0),
+ INSTR: ("SUBTFT tiiT ",5,0),
+ INSTR: ("SUBTF tiT ",4,0),
+ INSTR: ("REPLAC Tit ",4,0),
+ INSTR: ("CAT Tt ",3,0),
+ INSTR: ("TLEN tI ",3,0),
+ INSTR: ("POS ttI ",4,0),
+ INSTR: ("POSF ttiI ",5,0),
+ INSTR: ("POSFT ttiiI",6,0),
+ INSTR: ("STRAN -iitiiI",8,0),
+ INSTR: ("POSIF tiiiI",6,0),
+ INSTR: ("*3B7F* ",0,0),
+ INSTR: ("OUT t ",2,0),
+ INSTR: ("COUT i ",2,0),
+ INSTR: ("OUTF ti ",3,0),
+ INSTR: ("OUTFT tii ",4,0),
+ INSTR: ("INCHAR T ",2,0),
+ INSTR: ("INCETY T ",2,0),
+ INSTR: ("PAUSE i ",2,0),
+ INSTR: ("GCPOS II ",3,0),
+ INSTR: ("CATINP TT ",3,0),
+ INSTR: ("NILDS D ",2,0),
+ INSTR: ("DSCOPY Dd ",3,0),
+ INSTR: ("DSFORG d ",2,0),
+ INSTR: ("DSWTYP di ",3,0),
+ INSTR: ("DSRTYP dI ",3,0),
+ INSTR: ("DSHPSIZ dI ",3,0),
+ INSTR: ("ESTOP ",1,11),
+ INSTR: ("DSTOP ",1,11),
+ INSTR: ("SETERR i ",2,0),
+ INSTR: ("ISERR ",1,1),
+ INSTR: ("CLRERR ",1,13),
+ INSTR: ("RPCB iI ",3,0),
+ INSTR: ("INFOPW ttI ",4,0),
+ INSTR: ("TWCPU pr ",3,0),
+ INSTR: ("ROTATE Hi ",3,0),
+ INSTR: ("IOCNTL iiiI ",5,0),
+ INSTR: ("BLKOUT diiiI",6,0),
+ INSTR: ("BLKIN diiiI",6,0),
+ INSTR: ("BLKNXT diI ",4,0),
+ INSTR: ("DSSTOR dpI ",4,0),
+ INSTR: ("STORAGE II ",3,0),
+ INSTR: ("SYSOP i ",2,0),
+ INSTR: ("ARITS ",1,0),
+ INSTR: ("ARITU ",1,0),
+ INSTR: ("HPSIZE I ",2,0),
+ INSTR: ("GARB ",1,0),
+ INSTR: ("TCREATE ppia ",5,0),
+ INSTR: ("FSLD iRI ",4,0),
+ INSTR: ("GEXP rI ",3,0),
+ INSTR: ("SEXP iR ",3,0),
+ INSTR: ("FLOOR rR ",3,0),
+ INSTR: ("RTSUB tiR ",4,0),
+ INSTR: ("RTRPL Tir ",4,0),
+ INSTR: ("CLOCK iR ",3,0),
+ INSTR: ("SETNOW r ",2,0),
+ INSTR: ("TRPCB piI ",4,0),
+ INSTR: ("TWPCB pii ",4,0),
+ INSTR: ("TCPU pR ",3,0),
+ INSTR: ("TSTAT pI ",3,0),
+ INSTR: ("ACT p ",2,0),
+ INSTR: ("DEACT p ",2,0),
+ INSTR: ("THALT p ",2,0),
+ INSTR: ("TBEGIN pa ",3,0),
+ INSTR: ("TEND p ",2,0),
+ INSTR: ("SEND pidI ",5,0),
+ INSTR: ("WAIT DIP ",4,0),
+ INSTR: ("SWCALL piDI ",5,0),
+ INSTR: ("CDBINT hI ",3,0),
+ INSTR: ("CDBTXT hT ",3,0),
+ INSTR: ("PNACT P ",2,0),
+ INSTR: ("PW hhi ",4,0),
+ INSTR: ("GW hhI ",4,0),
+ INSTR: ("BITXOR hhH ",4,0),
+ INSTR: ("SNDWT piDI ",5,0),
+ INSTR: ("TEXIST p ",2,1),
+ INSTR: ("BITAND hhH ",4,0),
+ INSTR: ("BITOR hhH ",4,0),
+ INSTR: ("SESSION I ",2,0),
+ INSTR: ("SNDFROM ppiDI",6,0),
+ INSTR: ("DEFCOLL i ",2,0),
+ INSTR: ("IDENT iI ",3,0),
+ INSTR: ("*827F* ",0,0),
+ INSTR: ("*837F* ",0,0),
+ INSTR: ("*847F* ",0,0),
+ INSTR: ("*857F* ",0,0),
+ INSTR: ("*867F* ",0,0),
+ INSTR: ("*877F* ",0,0),
+ INSTR: ("*887F* ",0,0),
+ INSTR: ("*897F* ",0,0),
+ INSTR: ("*8a7F* ",0,0),
+ INSTR: ("*8b7F* ",0,0),
+ INSTR: ("*8c7F* ",0,0),
+ INSTR: ("*8d7F* ",0,0),
+ INSTR: ("*8e7F* ",0,0),
+ INSTR: ("*8f7F* ",0,0),
+ INSTR: ("*907F* ",0,0),
+ INSTR: ("*917F* ",0,0),
+ INSTR: ("*927F* ",0,0),
+ INSTR: ("*937F* ",0,0),
+ INSTR: ("*947F* ",0,0),
+ INSTR: ("*957F* ",0,0),
+ INSTR: ("*967F* ",0,0),
+ INSTR: ("*977F* ",0,0),
+ INSTR: ("*987F* ",0,0),
+ INSTR: ("*997F* ",0,0),
+ INSTR: ("DSGETW dhhH ",5,0),
+ INSTR: ("DSPUTW dhhh ",5,0),
+ INSTR: ("LBAS H ",2,0) );
+
+
+PROC disa (INT CONST icount h, icount l,
+ TEXT VAR mnemonic, oplist,
+ INT VAR instr length, instr class) :
+ fetch first instr word;
+ fetch opcode;
+ IF primary THEN process primary
+ ELIF secondary THEN process secondary
+ ELIF longprim THEN process longprim
+ ELSE process special
+ FI;
+ oplist := subtext (mnemonic, 9);
+ mnemonic := subtext (mnemonic, 1, 8).
+
+fetch first instr word:
+ first word := dsgetw (stdds, icount h, icount l).
+
+fetch opcode:
+ opcode := first word;
+ rotate (opcode,8);
+ opcode := opcode AND 255.
+
+primary: (opcode AND 124) <> 124.
+
+secondary: opcode = 127.
+
+longprim: opcode = 255.
+
+process primary:
+ opcode := opcode AND 124;
+ rotate (opcode, right 2);
+ mnemonic := primary list (opcode+1) . mnem;
+ instr length := primary list (opcode+1) . length;
+ instr class := primary list (opcode+1) . class.
+
+process secondary:
+ opcode := first word AND 255;
+ IF opcode <= 156
+ THEN mnemonic := secondary list (opcode+1) . mnem;
+ instr length := secondary list (opcode+1) . length;
+ instr class := secondary list (opcode+1) . class
+ ELSE mnemonic := "wrongopc";
+ instr length := 0; instr class := -1
+ FI.
+
+process longprim:
+ opcode := first word AND 255;
+ IF (opcode AND 124) = opcode
+ THEN rotate (opcode, -2);
+ mnemonic := primary list (opcode+1) . mnem;
+ instr length := primary list (opcode+1) . length + 1;
+ instr class := primary list (opcode+1) . class
+ ELSE mnemonic := "wrongopc";
+ instr length := 0; instr class := -1
+ FI.
+
+process special:
+ IF opcode < 128
+ THEN opcode := (opcode AND 3) + 1
+ ELSE opcode := (opcode AND 3) + 4
+ FI;
+ mnemonic := special list (opcode) .mnem;
+ instr length := special list (opcode) .length;
+ instr class := special list (opcode) . class.
+
+END PROC disa;
+
+(*********************************************************************)
+
+LET max modno = 3071;
+INT VAR word1, modno;
+TEXT VAR buf, mod decr;
+BOOL VAR proc heads file exists := FALSE;
+INITFLAG VAR initflag := FALSE;
+BOUND ROW max modno TEXT VAR proc heads;
+
+PROC set proc heads (TEXT CONST proc heads filename):
+ proc heads file exists := FALSE;
+ IF proc heads filename <> "" AND exists (proc heads filename)
+ THEN proc heads := old (proc heads filename);
+ put (proc heads (max modno)); (*to test type*)
+ proc heads file exists := TRUE
+ FI
+END PROC set proc heads;
+
+TEXT PROC proc head (INT CONST module no):
+ IF NOT initialized (initflag)
+ THEN provide proc heads file
+ FI;
+ INT VAR modno := module no;
+ IF modno >= 10000 THEN modno DECR 10000 FI;
+ IF proc heads file exists AND modno <= max modno
+ THEN IF modno = 0
+ THEN "(* mod no 0 *)"
+ ELSE buf := proc heads (modno);
+ IF subtext (buf, 1, 2) = "+>"
+ THEN mod decr := subtext (buf, 3);
+ buf := "(* " CT mod decr CT " +> "
+ CT proc head (modno - integ (mod decr)) CT " *)"
+ FI;
+ buf
+ FI
+ ELSE ""
+ FI.
+
+provide proc heads file:
+ IF NOT exists ("procheads")
+ THEN disable stop;
+ command dialogue (FALSE);
+ fetch ("procheads");
+ IF is error
+ THEN putline ("(*** proc heads file missing ***)");
+ out (beep); clear error
+ ELSE set proc heads ("procheads")
+ FI;
+ command dialogue (TRUE)
+ FI
+ENDPROC proc head;
+
+(***********************************************************************)
+
+INT VAR ic h:=2, ic l:=0, ilen, iclass, i, cmd, maxlines:=12, lines;
+INT CONST mask 8000 := dec ("8000"),
+ mask 7fff := dec ("7fff"),
+ mask 0400 := dec ("0400"),
+ bf mask1 := dec ("0040"),
+ opcode mask0 := dec ("83ff");
+BOOL VAR step mode := TRUE, quit;
+TEXT VAR iname, ioplist, char, input;
+
+PROC disasm :
+ out (""13"");
+ disasm (ic h, ic l)
+
+ENDPROC disasm;
+
+PROC disasm (INT CONST startaddr hi, startaddr lo):
+ ic h := startaddr hi;
+ ic l := startaddr lo;
+ lines := 0;
+ quit := FALSE;
+ REP
+ IF NOT (ic h = 3 OR ic h = 2)
+ THEN out ("*** icount out of code area ***"); line; out (beep);
+ step mode := TRUE
+ ELSE disa (ic h, ic l, iname, ioplist, ilen, iclass);
+ put icount mnemonic and instr words;
+ put proc head for call;
+ line; lines INCR 1;
+ IF iclass = 1 THEN put cond branch instr FI;
+ FI;
+ process command if necessary
+ UNTIL quit PER.
+
+put icount mnemonic and instr words:
+ put icount;
+ out (iname);
+ out (" ");
+ IF ilen > 0
+ THEN IF iclass = 4 THEN word1 := dsgetw (stdds, ic h, ic l) FI;
+ FOR i FROM 1 UPTO ilen REP
+ out (hex (dsget2b (stdds, ic h, ic l))); out (" ");
+ incl (ic h, ic l, 1)
+ PER
+ ELSE out (hex (dsget2b (stdds, ic h, ic l))); out (""7"");
+ incl (ic h, ic l, 1);
+ step mode := TRUE
+ FI.
+
+put cond branch instr:
+ put icount;
+ word1 := dsget2b (stdds, ic h, ic l);
+ IF (word1 AND bf mask1) <> 0
+ THEN out ("BF ")
+ ELSE out ("BT ")
+ FI;
+ putline (hex (word1));
+ lines INCR 1;
+ incl (ic h, ic l, 1).
+
+put icount:
+ out (txt (ic h));
+ out (hex (ic l));
+ out (": ").
+
+put proc head for call:
+ IF iclass = 4
+ THEN eval module no;
+ out (" ");
+ out (proc head (mod no))
+ FI.
+
+eval module no:
+ mod no := word1 AND opcode mask0;
+ IF (mod no AND mask 8000) <> 0
+ THEN mod no := mod no AND mask 7fff OR mask 0400
+ FI.
+
+process command if necessary:
+ IF step mode OR incharety <> "" OR lines >= maxlines
+ THEN process command;
+ lines := 0
+ FI.
+
+process command :
+ REP putline (""15"DISASM: step, more, address, lines, info, or quit"14"");
+ inchar (char);
+ cmd := pos ("smaliq",char);
+ IF cmd > 0
+ THEN SELECT cmd OF
+ CASE 1: step mode := TRUE; point to previous line
+ CASE 2: step mode := FALSE; point to previous line
+ CASE 3: set new ic
+ CASE 4: set new linecount
+ CASE 5: info (stdds, ic h, ic l, no of lines)
+ CASE 6: quit := TRUE
+ ENDSELECT
+ FI
+ UNTIL char <> "i" PER.
+
+point to previous line:
+ get cursor (cur x, cur y); cursor (1, cur y - 1); out (clear to eop).
+
+set new line count:
+ out ("lines="); gethex (buf); maxlines := dec (buf).
+
+set new ic :
+ REP
+ put ("type new ic (20000...3ffff)");
+ gethex (input);
+ input := "0000" CT input;
+ ic l := dec (subtext (input, LENGTH input-3));
+ ic h := dec (subtext (input, LENGTH input-7, LENGTH input-4));
+ IF ic h = 2 OR ic h = 3 THEN LEAVE set new ic FI;
+ out (beep); putline ("*** icount out of code area ***")
+ PER.
+
+ENDPROC disasm;
+
+(* disasm *) (*for test only*).
+
+END PACKET dis;
+
diff --git a/devel/debug/1/src/extended instr b/devel/debug/1/src/extended instr
new file mode 100644
index 0000000..93b3b9e
--- /dev/null
+++ b/devel/debug/1/src/extended instr
@@ -0,0 +1,25 @@
+(**************************************************************)
+(* Extended EUMEL0-instructions for TRACE G.Szalay *)
+(************************************************* 87-04-03 ***)
+
+PACKET extended instr DEFINES dsgetw, dsputw, local base,
+ signed arith, unsigned arith:
+
+INT PROC dsgetw (INT CONST drid, adr hi, adr lo):
+ EXTERNAL 154
+ENDPROC dsgetw;
+
+PROC dsputw (INT CONST drid, adr hi, adr lo, word):
+ EXTERNAL 155
+ENDPROC dsputw;
+
+INT PROC local base:
+ EXTERNAL 156
+ENDPROC local base;
+
+PROC signed arith: EXTERNAL 91 ENDPROC signed arith;
+
+PROC unsigned arith: EXTERNAL 92 ENDPROC unsigned arith;
+
+ENDPACKET extended instr;
+
diff --git a/devel/debug/1/src/gen.bulletin b/devel/debug/1/src/gen.bulletin
new file mode 100644
index 0000000..8c5b15b
--- /dev/null
+++ b/devel/debug/1/src/gen.bulletin
@@ -0,0 +1,536 @@
+PACKET eumel coder part 1 m DEFINES bulletin m : (* Author: U.Bartling *)
+ (* modif'd by G.Szalay*)
+ (* 87-03-31 *)
+
+(**************************************************************************)
+(* *)
+(* This program generates a file "bulletin" containing procedure heads *)
+(* and the module numbers, to be used by the debugging packet 'trace'. *)
+(* *)
+(**************************************************************************)
+
+
+ (***** Globale Variable *****)
+
+TEXT VAR object name;
+
+FILE VAR bulletin file;
+
+INT VAR hash table pointer, nt link, permanent pointer, param link,
+ index, mode, word, packet link;
+
+BOOL VAR found, end of params;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 1. Interface zum ELAN-Compiler 04.08.1986 *)
+(* 1.8.0 *)
+(* *)
+(* Beschreibung der Tabellen (-groessen), *)
+(* internen Vercodung von Typen *)
+(* und Kennungen . *)
+(* Initialisieren und Beenden des Compilers, *)
+(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+LET begin of hash table = 0 ,
+ end of hash table = 1023 ,
+
+ begin of permanent table = 22784 ,
+ before first pt entry = 22784 ,
+ first permanent entry = 22785 ,
+ end of permanent table = 32767 ,
+
+ wordlength = 1 , (* compile u n d run time *)
+ two word length = 2 ,
+ three word length = 3 ,
+
+ permanent param const = 10000 ,
+ permanent param var = 20000 ,
+ permanent proc op = 30000 ,
+ permanent type = 30000 ,
+ permanent row = 10 ,
+ permanent struct = 11 ,
+ permanent param proc = 12 ,
+(* permanent param proc end marker = 0 , *)
+ permanent type field = 0 ,
+
+ ptt limit = 10000 ,
+ begin of pt minus ptt limit = 12784 ,
+
+ void = 0 ,
+ int = 1 ,
+ real = 2 ,
+ string = 3 ,
+ bool = 5 ,
+ bool result = 6 ,
+ dataspace = 7 ,
+ row = 10 ,
+ struct = 11 ,
+
+ const = 1 ,
+ var = 2 ,
+(* proc = 3 , *)
+(* denoter = 5 , *)
+ bold = 2 ;
+
+
+INT CONST permanent packet := -2 ,
+ permanent end := -3 ;
+
+
+
+
+ (***** Hash/Namenstabelle *****)
+.
+next hash entry :
+ hash table pointer INCR wordlength .
+
+end of hash table reached :
+ hash table pointer > end of hash table .
+
+yet another nt entry :
+ nt link := cdb int (nt link) ;
+ nt link <> 0 . ;
+
+PROC to object (TEXT CONST searched object) :
+ hash ;
+ search nt entry .
+
+hash :
+ hash code := 0 ;
+ FOR index FROM 1 UPTO LENGTH searched object REP
+ addmult cyclic
+ ENDREP .
+
+addmult cyclic :
+ hash code INCR hash code ;
+ IF hash code > end of hash table THEN wrap around FI ;
+ hash code := (hash code + code (searched object SUB index)) MOD 1024 .
+
+wrap around :
+ hash code DECR end of hash table .
+
+hash code : nt link .
+
+search nt entry :
+ found := FALSE ;
+ WHILE yet another nt entry REP
+ read current entry ;
+ IF object name = searched object
+ THEN found := TRUE ;
+ LEAVE to object
+ FI
+ PER .
+
+read current entry :
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length)
+ENDPROC to object ;
+
+
+ (***** Permanent Tabelle *****)
+.
+next procedure :
+ permanent pointer := cdb int (permanent pointer) . ;
+
+PROC next pt param :
+ mode := cdb int (param link) MOD ptt limit ;
+ param link INCR wordlength ;
+ IF mode = permanent row THEN skip over permanent row
+ ELIF mode = permanent struct THEN skip over permanent struct
+ FI ;
+ set end marker if end of list .
+
+skip over permanent row :
+ param link INCR wordlength ;
+ next pt param .
+
+skip over permanent struct :
+ REP
+ next pt param ;
+ mode := cdb int (param link)
+ UNTIL mode = permanent type field PER ;
+ param link INCR wordlength
+ENDPROC next pt param ;
+
+PROC set end marker if end of list :
+ mode := cdb int (param link) ;
+ end of params := mode >= permanent proc op OR mode <= 0
+ENDPROC set end marker if end of list ;
+
+PROC get type and mode (INT VAR type) :
+ mode := cdb int (param link) ;
+ IF mode = permanent param proc THEN type of param proc
+ ELSE type of object
+ FI .
+
+type of param proc :
+ param link INCR wordlength ;
+ get type and mode (type) ;
+ mode := permanent param proc .
+
+type of object :
+ IF mode < 0 THEN type := 2769 + (32767 + mode) ;
+ mode := 0
+ ELSE type := mode MOD ptt limit ;
+ mode DECR type ;
+ translate type if necessary ;
+ translate mode if necessary
+ FI .
+
+translate type if necessary :
+ IF permanent row or struct THEN translate type FI .
+
+translate type :
+ type := param link - begin of pt minus ptt limit .
+
+translate mode if necessary :
+ IF mode = permanent param const THEN mode := const
+ ELIF mode = permanent param var THEN mode := var
+ FI .
+
+permanent row or struct :
+ type = permanent row OR type = permanent struct
+ENDPROC get type and mode ;
+
+
+ (***** Allgemeine Zugriffsprozeduren *****)
+
+INT PROC cdb int (INT CONST index) :
+ EXTERNAL 116
+ENDPROC cdb int ;
+
+TEXT PROC cdb text (INT CONST index) :
+ EXTERNAL 117
+ENDPROC cdb text ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 10. Inspector 01.08.1986 *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR line number, begin of packet,
+ last packet entry, indentation;
+
+TEXT VAR type and mode, pattern, buffer;
+
+PROC name of type (INT CONST type) :
+ SELECT type OF
+ CASE void :
+ CASE int : type and mode CAT "INT"
+ CASE real : type and mode CAT "REAL"
+ CASE string : type and mode CAT "TEXT"
+ CASE bool, bool result : type and mode CAT "BOOL"
+ CASE dataspace : type and mode CAT "DS"
+ CASE row : type and mode CAT "ROW "
+ CASE struct : type and mode CAT "STRUCT"
+ OTHERWISE : complex type
+ ENDSELECT .
+
+complex type :
+ IF type > ptt limit THEN perhaps permanent struct or row
+ ELSE get complex type
+ FI .
+
+perhaps permanent struct or row :
+ index := type + begin of pt minus ptt limit ;
+ mode := cdb int (index) MOD ptt limit ;
+ IF mode = permanent row THEN get permanent row
+ ELIF mode = permanent struct THEN get permanent struct
+ ELSE type and mode CAT "-"
+ FI .
+
+get complex type :
+ index := type + begin of permanent table ;
+ IF is complex type THEN get name
+ ELSE type and mode CAT "-"
+ FI .
+
+is complex type :
+ permanent type definition mode = permanent type .
+
+get name :
+ type and mode CAT cdb text (link to type name + two word length) .
+
+link to type name :
+ cdb int (index + three word length) .
+
+permanent type definition mode :
+ cdb int (index + wordlength) .
+
+get permanent row :
+ INT VAR t;
+ type and mode CAT "ROW " ;
+ type and mode CAT text (cdb int (index + wordlength)) ;
+ type and mode CAT " " ;
+ param link := index + two wordlength ;
+ get type and mode (t) ;
+ name of type (t) .
+
+get permanent struct :
+ type and mode CAT "STRUCT ( ... )"
+ENDPROC name of type ;
+
+
+BOOL PROC not end of chain :
+ permanent pointer <> 0
+ENDPROC not end of chain ;
+
+PROC put specifications (TEXT CONST proc name) :
+ put obj name (proc name) ;
+ to first param ;
+ IF NOT end of params THEN put param list FI ;
+ put result ;
+ write bulletin line (text(cdb int(param link+wordlength),5)) ;
+ writeline .
+
+to first param :
+ param link := permanent pointer + word length ;
+ set end marker if end of list .
+
+put result :
+ INT VAR type;
+ get type and mode (type) ;
+ IF type <> void THEN type and mode := " --> " ;
+ name of type (type) ;
+ write bulletin line (type and mode)
+ FI
+ENDPROC put specifications ;
+
+PROC put param list :
+ write bulletin line (" (") ;
+ REP
+ INT VAR type, param mode;
+ get type and mode (type) ;
+ param mode := mode ;
+ put type and mode ;
+ maybe param proc ;
+ next pt param ;
+ IF end of params THEN write bulletin line (")") ;
+ LEAVE put param list
+ FI ;
+ write bulletin line (", ") ;
+ PER .
+
+put type and mode :
+ type and mode := "" ;
+ name of type (type) ;
+ type and mode CAT name of mode ;
+ write bulletin line (type and mode) .
+
+name of mode :
+ IF param mode = const THEN " C"
+ ELIF param mode = var THEN " V"
+ ELSE " PROC"
+ FI .
+
+maybe param proc :
+ IF mode = permanent param proc THEN put virtual params FI .
+
+put virtual params :
+ skip over result type if complex type ;
+ IF NOT end of virtual params THEN put param list FI.
+
+skip over result type if complex type :
+ next pt param .
+
+end of virtual params :
+ end of params
+ENDPROC put param list ;
+
+PROC to packet (TEXT CONST packet name) :
+ to object ( packet name) ;
+ IF found THEN find start of packet objects FI .
+
+find start of packet objects :
+ last packet entry := 0 ;
+ packet link := before first pt entry ;
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word < 0 THEN IF word = permanent packet THEN packet found
+ ELIF word = permanent end THEN return
+ FI
+ FI
+ ENDREP .
+
+packet found :
+ IF cdb int (packet link + wordlength) = nt link
+ THEN last packet entry := packet link FI .
+
+return :
+ IF last packet entry <> 0 THEN found := TRUE ;
+ packet link := last packet entry
+ ELSE found := FALSE
+ FI ;
+ LEAVE to packet
+ENDPROC to packet ;
+
+PROC next packet :
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word = permanent packet THEN true return
+ ELIF end of permanents THEN false return
+ FI ;
+ ENDREP .
+
+true return :
+ found := TRUE ;
+ LEAVE next packet .
+
+false return :
+ found := FALSE ;
+ LEAVE next packet .
+
+end of permanents :
+ word = permanent end OR packet link > end of permanent table
+ENDPROC next packet ;
+
+PROC prep bulletin :
+ IF exists ("bulletin")
+ THEN IF yes("overwrite old file ""bulletin""")
+ THEN command dialogue (FALSE);
+ forget ("bulletin");
+ command dialogue (TRUE);
+ bulletin file := sequential file (output, new ("bulletin"))
+ ELSE bulletin file := sequential file (output, old ("bulletin"))
+ FI
+ ELSE bulletin file := sequential file (output, new ("bulletin"))
+ FI;
+ putline ("GENERATING ""bulletin"" ...");
+ line number := 0 ;
+ buffer := ""
+ENDPROC prep bulletin ;
+
+PROC write bulletin line (TEXT CONST line) :
+ (* IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ; *)
+ buffer CAT line
+ENDPROC write bulletin line ;
+
+PROC writeline :
+ write (bulletin file, buffer) ;
+ line (bulletin file) ;
+ line number INCR 1 ;
+ cout (line number) ;
+ buffer := ""
+ENDPROC writeline ;
+
+PROC writeline (INT CONST times) :
+ IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ;
+ writeline
+ ELSE index := times
+ FI ;
+ line (bulletin file, index) ;
+ line number INCR index;
+ indentation := 0 ;
+ cout (line number)
+ENDPROC writeline ;
+
+PROC bulletin m (TEXT CONST packet name) :
+ prep bulletin ;
+ scan (packet name) ;
+ next symbol (pattern) ;
+ to packet (pattern) ;
+ IF found THEN list packet
+ ELSE error stop (packet name + " ist kein Paketname")
+ FI .
+
+ENDPROC bulletin m;
+
+PROC list packet :
+ begin of packet := packet link + word length ;
+ find end of packet ;
+ run through nametab and list all packet objects .
+
+find end of packet :
+ last packet entry := begin of packet ;
+ REP
+ last packet entry INCR wordlength ;
+ word := cdb int (last packet entry) ;
+ UNTIL end of packet entries PER .
+
+end of packet entries :
+ word = permanent packet OR word = permanent end .
+
+run through nametab and list all packet objects :
+ hashtable pointer := begin of hashtable ;
+ REP
+ nt link := hashtable pointer ;
+ list objects of current packet in this chain ;
+ next hash entry
+ UNTIL end of hashtable reached ENDREP .
+
+list objects of current packet in this chain :
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ put objects of this name
+ PER .
+
+put objects of this name :
+ IF there is at least one object of this name in the current packet
+ THEN into bulletin FI .
+
+there is at least one object of this name in the current packet :
+ REP
+ IF permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ THEN LEAVE there is at least one object of this name
+ in the current packet WITH TRUE FI ;
+ next procedure
+ UNTIL permanent pointer = 0 PER ;
+ FALSE .
+
+into bulletin :
+ object name := cdb text (nt link + two word length) ;
+ object names into bulletin (BOOL PROC within packet)
+ENDPROC list packet ;
+
+BOOL PROC within packet :
+ permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ENDPROC within packet ;
+
+PROC object names into bulletin (BOOL PROC link ok) :
+ scan (object name) ;
+ next symbol (object name, mode) ;
+ IF NOT type definition THEN put object definitions FI .
+
+type definition :
+ mode = bold AND no params .
+
+no params :
+ cdb int (permanent pointer + word length) >= permanent type .
+
+put object definitions :
+ WHILE link ok REP
+ put specifications (object name) ;
+ next procedure
+ ENDREP
+ENDPROC object names into bulletin ;
+
+PROC bulletin m:
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ list packet ;
+ next packet
+ UNTIL NOT found PER
+ENDPROC bulletin m;
+
+PROC put obj name (TEXT CONST name) :
+ buffer := name.
+ENDPROC put obj name ;
+
+bulletin m;
+
+ENDPACKET eumel coder part 1 m;
+
diff --git a/devel/debug/1/src/gen.procheads b/devel/debug/1/src/gen.procheads
new file mode 100644
index 0000000..e2ab0ea
--- /dev/null
+++ b/devel/debug/1/src/gen.procheads
@@ -0,0 +1,89 @@
+(**********************************************************************)
+(* *)
+(* This program generates/updates a dataspace "procheads" from the *)
+(* file "bulletin", including the module numbers. "procheads" will *)
+(* be used by 'trace" and 'disasm" to show the name and the formal *)
+(* param list of a called procedure. *)
+(* *)
+(* GMD-Z2.P/G.Szalay/86-04-06 *)
+(* *)
+(**********************************************************************)
+
+LET digits = "1234567890", outname = "procheads",
+ maxno of procs = 3071, first compiled module no = 256;
+FILE VAR infile := sequential file (input, old ("bulletin"));
+TEXT VAR buf, linebuf, entry, answer;
+INT VAR i, j, module no, posit, max module no := 0;
+BOUND ROW maxno of procs TEXT VAR proc heads;
+
+putline ("generating """ + outname + """ ...");
+BOOL VAR oldfile := exists (outname);
+IF oldfile
+THEN ask for action to be taken;
+ IF answer = "r"
+ THEN forget (outname); oldfile := FALSE;
+ proc heads := new (outname)
+ ELSE proc heads := old (outname)
+ FI
+ELSE proc heads := new (outname)
+FI;
+
+IF NOT oldfile THEN init heads FI;
+getline (infile, linebuf);
+FOR i FROM 1 UPTO 1000 REP
+ process line;
+ cout (i);
+ getline (infile, linebuf)
+UNTIL eof (infile) PER;
+process missing heads.
+
+ask for action to be taken:
+ out ("replace or append to old file """+outname+""" (r/a) ? ");
+ REP inchar (answer);
+ IF answer <> "r" AND answer <> "a" THEN out(""7"") FI
+ UNTIL answer = "r" OR answer = "a" PER;
+ putline (answer).
+
+init heads:
+ proc heads (1) := "+>1";
+ FOR i FROM 2 UPTO maxno of procs REP proc heads (i) := "" PER.
+
+process line:
+ fetch module no and entry;
+ IF module no >= first compiled module no
+ THEN IF module no < 10000
+ THEN proc heads (module no) := entry
+ ELSE proc heads (module no - 10000) := entry
+ FI
+ FI.
+
+fetch module no and entry:
+ posit := LENGTH linebuf - 1;
+ WHILE pos (digits, linebuf SUB posit) <> 0
+ REP posit DECR 1 PER;
+ module no := int (subtext (linebuf, posit+1));
+ IF module no < 10000 AND module no > max module no
+ THEN max module no := module no
+ FI;
+ WHILE (linebuf SUB posit) = " " REP posit DECR 1 PER;
+ entry := subtext (linebuf, 1, posit).
+
+process missing heads:
+ putline ("max module no=" + text(max module no));
+ FOR i FROM 1 UPTO max module no REP
+ cout(i);
+ IF proc heads (i) = "" THEN put in offset to last head FI
+ PER.
+
+put in offset to last head:
+ FOR j FROM i-1 DOWNTO 1 REP
+ IF proc heads (j) <> ""
+ THEN IF subtext (proc heads (j), 1, 2) = "+>"
+ THEN proc heads (i) := "+>" + text (i - j
+ + int (subtext (proc heads (j), 3)))
+ ELSE proc heads (i) := "+>" + text (i - j)
+ FI;
+ LEAVE put in offset to last head
+ FI
+ PER.
+
diff --git a/devel/debug/1/src/gen.trace b/devel/debug/1/src/gen.trace
new file mode 100644
index 0000000..4dc8c53
--- /dev/null
+++ b/devel/debug/1/src/gen.trace
@@ -0,0 +1,23 @@
+checkoff;
+putline("inserting ""extended instr"" ...");
+insert("extended instr");
+putline("inserting ""convert"" ...");
+insert("convert");
+putline("inserting ""info"" ...");
+insert("info");
+putline("inserting ""disa"" ...");
+insert("disa");
+putline("inserting ""trace"" ...");
+insert("trace");
+putline("inserting ""gen.bulletin"" ...");
+insert("gen.bulletin");
+putline("compiling ""gen.procheads"" ...");
+run("gen.procheads");
+do("set procheads(""procheads"")");
+forget("bulletin",quiet);
+putline("task """+name(myself)+""" is now global manager");
+putline("press any key ...");
+pause; global manager
+
+
+
diff --git a/devel/debug/1/src/info b/devel/debug/1/src/info
new file mode 100644
index 0000000..31099c6
--- /dev/null
+++ b/devel/debug/1/src/info
@@ -0,0 +1,371 @@
+PACKET info DEFINES info:
+
+(**********************************************************************)
+(** **)
+(** M i n i - I N F O Autor: G. Szalay Stand: 87-04-03 **)
+(** **)
+(**********************************************************************)
+
+LET charset = "1234567890ß'qwertzuiopü+asdfghjklöä#<yxcvbnm,.-
+!""§$%&/()=?`QWERTZUIOPÜ*ASDFGHJKLÖÄ^>YXCVBNM;:_ ",
+ hextab = "0123456789abcdef", stdds = 0,
+ cr = ""13"", cr rubout = ""13""12"",
+ up down left right = ""3""10""8""2"";
+TEXT VAR buf, linebuf, bytes, hexbytes, char,
+ search param := ""255"", search buffer,
+ first byte, hex search param := "ff", search mode := "h";
+INT VAR drid := stdds, adr hi := 2, adr lo := 0, lines := 4,
+ begin hi := adr hi, begin lo := adr lo, first word,
+ saddr hi, saddr lo,
+ no of found bytes, cur xx, cur x, cur y, ymin, ymax,
+ xmin := 9, xmidlo := xmin + 21,
+ xmidhi := xmidlo + 5, xmax := xmidhi + 21,
+ word, byte, i, l;
+INT CONST mask 00ff := dec ("00ff"),
+ mask ff00 := dec ("ff00"),
+ offs mask := dec ("0007"),
+ addr mask := dec ("fff8");
+BOOL VAR found, low byte flag := TRUE, interrupted,
+ area 2 nonchangeable := id (1) <> 4 (*i.e. other than 68000*);
+
+PROC wait for (TEXT CONST chars):
+ inchar (char);
+ WHILE pos (chars, char) = 0
+ REP out (""7""); inchar (char) PER
+END PROC wait for;
+
+PROC info:
+ info (drid, begin hi, begin lo, lines)
+END PROC info;
+
+PROC info (INT CONST start drid, start addr hi, start addr lo, start len):
+ drid := start drid;
+ begin hi := start addr hi;
+ begin lo := start addr lo;
+ lines := start len;
+ line; line; show dump;
+ command loop.
+
+command loop:
+ REP
+ zeige kommandoliste;
+ kommando lesen und ausfuehren
+ PER.
+
+zeige kommandoliste:
+ putline (""15"INFO: more, address, dsid, lines, find, or quit"14"").
+
+kommando lesen und ausfuehren:
+ inchar (char);
+ SELECT pos ("damlfq"3"", char) OF
+ CASE 1: drid command
+ CASE 2: addr command
+ CASE 3: more command
+ CASE 4: len command
+ CASE 5: find command
+ CASE 6: quit command
+ CASE 7: up command
+ OTHERWISE more command
+ END SELECT.
+
+quit command: LEAVE command loop.
+
+drid command:
+ out ("dsid="); gethex (buf); drid := dec (buf);
+ IF drid > 0 AND drid < 4 OR drid > 255
+ THEN beep; drid := stdds
+ ELIF drid = 4
+ THEN drid := stdds
+ FI;
+ found := FALSE;
+ show dump.
+
+len command:
+ out ("lines="); gethex (buf); lines := dec (buf); show dump.
+
+addr command:
+ out ("address=");
+ gethex (buf);
+ IF LENGTH buf < 5
+ THEN begin hi := 0; begin lo := dec (buf)
+ ELSE begin hi := dec (subtext (buf, 1, LENGTH buf - 4));
+ begin lo := dec (subtext (buf, LENGTH buf - 3))
+ FI;
+ low byte flag := TRUE; found := FALSE;
+ show dump.
+
+more command:
+ begin hi := adr hi; begin lo := adr lo;
+ low byte flag := TRUE; found := FALSE;
+ line; show dump.
+
+show dump:
+ interrupted := FALSE;
+ get cursor (cur x, cur y);
+ cursor (1, cur y - 2);
+ out ("---------------------------- dsid=");
+ IF drid = stdds THEN out ("04") ELSE outsubtext (hex (drid), 3) FI;
+ putline (" --------------------");
+ adr hi := begin hi;
+ adr lo := begin lo AND addr mask;
+ FOR l FROM 1 UPTO lines REP
+ buf := " "; linebuf := " "; bytes := "";
+ out (txt (adr hi)); out (hex (adr lo) CT ": ");
+ IF adr hi = 8
+ THEN out ("_________e_n_d___o_f___d_a_t_a_s_p_a_c_e_________");
+ line; beep; LEAVE show dump
+ FI;
+ FOR i FROM 1 UPTO 8 REP
+ word := dsgetw (drid, adr hi, adr lo);
+ replace (buf, 1, word); rotate (word, 8); hexbytes := hex (word);
+ IF adr lo <> begin lo
+ THEN outsubtext (hexbytes, 1, 2); out (" ");
+ outsubtext (hexbytes, 3) ; out (" ")
+ ELIF low byte flag
+ THEN out (""8"-"); outsubtext (hexbytes, 1, 2); out ("-");
+ outsubtext (hexbytes, 3); out (" ")
+ ELSE outsubtext (hexbytes, 1, 2); out ("-");
+ outsubtext (hexbytes, 3); out ("-")
+ FI;
+ IF i = 4 THEN out (" ") FI;
+ bytes CAT buf;
+ incl (adr hi, adr lo, 1)
+ PER;
+ FOR i FROM 1 UPTO 16 REP
+ IF pos (charset, bytes SUB i) = 0 THEN replace (bytes, i, ".") FI
+ PER;
+ out (" "); outsubtext (bytes, 1, 8);
+ out (" "); outsubtext (bytes, 9); line;
+ IF incharety <> "" THEN interrupted := TRUE; LEAVE show dump FI
+ PER.
+
+up command:
+ IF change not allowed THEN beep; reposit cursor; LEAVE up command FI;
+ get cursor (cur x, cur y);
+ ymax := cur y - 2; ymin := ymax - lines + 1;
+ cur x := xmin + (begin lo AND offs mask) * 6;
+ IF cur x > xmidlo THEN cur x INCR 2 FI;
+ IF NOT low byte flag THEN cur x INCR 3 FI;
+ cur y := ymin;
+ cursor (cur x, cur y);
+ REP inchar (char);
+ IF pos (up down left right, char) > 0 THEN move cursor
+ ELIF pos (hextab, char) > 0 THEN read byte and move cursor
+ ELIF char <> cr THEN beep
+ FI
+ UNTIL char = cr PER;
+ cursor (1, ymax + 2); line; show dump.
+
+change not allowed:
+ interrupted OR area 2 nonchangeable AND area 2 of stdds in window.
+
+area 2 of stdds in window:
+ drid = stdds AND
+ (begin hi = 2 OR
+ begin hi = 1 AND begin lo < 0 AND lines * 8 + begin lo > 0).
+
+read byte and move cursor:
+ out (char); byte := pos (hextab, char) - 1;
+ wait for (hextab);
+ out (char); byte := pos (hextab, char) - 1 + 16 * byte;
+ out (""8""8"");
+ eval cursor address and modify word;
+ char := ""2""; move cursor.
+
+eval cursor address and modify word:
+ adr hi := begin hi; adr lo := begin lo AND addr mask;
+ incl (adr hi, adr lo, ((cur y - ymin)*8 + (cur x - xmin) DIV 6));
+ word := dsgetw (drid, adr hi, adr lo);
+ IF high byte read
+ THEN rotate (byte, 8); word := (word AND mask 00ff) OR byte
+ ELSE word := (word AND mask ff00) OR byte
+ FI;
+ dsputw (drid, adr hi, adr lo, word).
+
+high byte read:
+ cur xx := cur x; IF cur xx > xmidlo THEN cur xx DECR 2 FI;
+ cur xx MOD 6 < 3.
+
+move cursor:
+ SELECT pos (up down left right, char) OF
+ CASE 1: IF cur y = ymin THEN beep ELSE cur y DECR 1 FI
+ CASE 2: IF cur y = ymax THEN beep ELSE cur y INCR 1 FI
+ CASE 3: IF cur x = xmin THEN IF cur y = ymin THEN beep
+ ELSE cur y DECR 1; cur x := xmax
+ FI
+ ELIF cur x = xmidhi THEN cur x DECR 5
+ ELSE cur x DECR 3 FI
+ CASE 4: IF cur x = xmax THEN IF cur y = ymax THEN beep
+ ELSE cur y INCR 1; cur x := xmin
+ FI
+ ELIF cur x = xmidlo THEN cur x INCR 5
+ ELSE cur x INCR 3 FI
+ ENDSELECT;
+ cursor (cur x, cur y).
+
+beep: out (""7"").
+
+reposit cursor: out (""3"").
+
+find command:
+ out ("find: hex, char, or last param? (h/H/c/C/<CR>)");
+ wait for ("hHcC"13"");
+ saddr hi := begin hi; saddr lo := begin lo;
+ IF char = "c" OR char = "C"
+ THEN out (char); get char string; low byte flag := NOT low byte flag
+ ELIF char = "h" OR char = "H"
+ THEN out (char); get hex string; low byte flag := NOT low byte flag
+ ELSE out (search mode);
+ IF pos ("cC", search mode) > 0
+ THEN out (search param)
+ ELSE out (hex search param)
+ FI;
+ IF NOT found THEN low byte flag := NOT low byte flag
+ ELIF NOT low byte flag OR pos ("CH", search mode) > 0
+ THEN incl (saddr hi, saddr lo, 1)
+ FI
+ FI;
+ out (cr); (*acknowledge CR*)
+ search string;
+ line; show dump.
+
+get char string:
+ search mode := char;
+ search param := "";
+ REP inchar (char);
+ SELECT pos (cr rubout, char) OF
+ CASE 1: IF search param = "" THEN beep ELSE LEAVE get char string FI
+ CASE 2: delete last char
+ OTHERWISE search param CAT char; out (char)
+ ENDSELECT
+ PER.
+
+delete last char:
+ IF search param = ""
+ THEN beep
+ ELSE search param := subtext (search param, 1, LENGTH search param - 1);
+ out (""8" "8"")
+ FI.
+
+get hex string:
+ search mode := char;
+ search param := "";
+ REP wait for (hextab CT cr rubout);
+ SELECT pos (cr rubout, char) OF
+ CASE 1: IF NOT regular hex string THEN beep; char :="" FI
+ CASE 2: delete last char
+ OTHERWISE search param CAT char; out (char)
+ ENDSELECT
+ UNTIL char = cr PER;
+ hex search param := search param;
+ search param := "";
+ FOR i FROM 1 UPTO LENGTH hex search param DIV 2 REP
+ char := hex search param SUB i;
+ word := pos (hextab, hex search param SUB (2*i-1)) - 1;
+ word := word * 16 + pos (hextab, hex search param SUB (2*i)) - 1;
+ search param CAT code (word)
+ PER.
+
+regular hex string:
+ LENGTH search param > 0 AND (LENGTH search param AND 1) = 0.
+
+search string:
+ first byte := search param SUB 1; buf := " ";
+ IF LENGTH search param > 1 THEN first word := search param ISUB 1 FI;
+ REP IF pos ("ch", search mode) > 0
+ THEN search first byte or word
+ ELSE search first word
+ FI;
+ search rest if any;
+ IF found THEN begin hi := saddr hi; begin lo := saddr lo;
+ LEAVE search string
+ FI;
+ IF NOT low byte flag THEN incl (saddr hi, saddr lo, 1) FI
+ PER.
+
+search first byte or word:
+ REP
+ IF saddr hi = 8 THEN LEAVE search first byte or word FI;
+ word := dsgetw (drid, saddr hi, saddr lo);
+ replace (buf, 1, word);
+ IF NOT low byte flag AND (buf SUB 1) = first byte
+ THEN IF LENGTH search param = 1
+ THEN low byte flag := TRUE; no of found bytes := 1;
+ LEAVE search first byte or word
+ ELIF (buf SUB 2) = (search param SUB 2)
+ THEN low byte flag := TRUE; no of found bytes := 2;
+ LEAVE search first byte or word
+ ELSE look in high byte
+ FI
+ ELSE look in high byte
+ FI;
+ low byte flag := FALSE;
+ incr search address and provide for interaction
+ PER.
+
+search first word:
+ REP
+ IF saddr hi = 8 THEN LEAVE search first word FI;
+ word := dsgetw (drid, saddr hi, saddr lo);
+ IF LENGTH search param = 1
+ THEN replace (buf, 1, word);
+ IF (buf SUB 1) = first byte
+ THEN low byte flag := TRUE; no of found bytes := 1;
+ LEAVE search first word
+ FI
+ ELSE IF word = first word
+ THEN low byte flag := TRUE; no of found bytes := 2;
+ LEAVE search first word
+ FI
+ FI;
+ incr search address and provide for interaction
+ PER.
+
+look in high byte:
+ IF (buf SUB 2) = first byte
+ THEN low byte flag := FALSE; no of found bytes := 1;
+ LEAVE search first byte or word
+ FI.
+
+incr search address and provide for interaction:
+ incl (saddr hi, saddr lo, 1);
+ IF incharety <> ""
+ THEN cursor (64, 24); out ("--- interrupted"); line; line;
+ begin hi := saddr hi; begin lo := saddr lo;
+ LEAVE search string
+ FI.
+
+search rest if any:
+ found := TRUE;
+ IF LENGTH search param = no of found bytes OR saddr hi = 8
+ THEN LEAVE search rest if any
+ FI;
+ IF low byte flag
+ THEN search buffer := subtext (search param, 3)
+ ELSE search buffer := subtext (search param, 2)
+ FI;
+ adr hi := saddr hi; adr lo := saddr lo;
+ FOR i FROM 1 UPTO (LENGTH search param - no of found bytes) DIV 2 REP
+ incl (adr hi, adr lo, 1);
+ word := dsgetw (drid, adr hi, adr lo);
+ IF (search buffer ISUB i) = word
+ THEN no of found bytes INCR 2
+ ELSE found := FALSE
+ FI
+ UNTIL NOT found PER;
+ IF found AND LENGTH search param > no of found bytes
+ THEN search last byte
+ FI.
+
+search last byte:
+ incl (adr hi, adr lo, 1);
+ word := dsgetw (drid, adr hi, adr lo);
+ replace (buf, 1, word);
+ found := (buf SUB 1) = (search param SUB length (search param)).
+
+END PROC info;
+
+(* info *) (****)
+
+END PACKET info;
+
diff --git a/devel/debug/1/src/trace b/devel/debug/1/src/trace
new file mode 100644
index 0000000..773b5f2
--- /dev/null
+++ b/devel/debug/1/src/trace
@@ -0,0 +1,1020 @@
+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;
+
diff --git a/devel/debug/1/src/trace.dok b/devel/debug/1/src/trace.dok
new file mode 100644
index 0000000..7de46f8
--- /dev/null
+++ b/devel/debug/1/src/trace.dok
@@ -0,0 +1,387 @@
+#type ("trium8")##limit (13.0)#
+#start(3.0,1.5)#
+#pagelength(18.5)#
+#block#
+#type("trium36.b")#
+#free(3.5)#
+#center#EUMEL
+#center#DEBUG
+#type("trium18.b")#
+#free(1.4)#
+#center#Version 1
+#center#87-04-24
+
+#center#G. Szalay
+#page(1)#
+#type ("trium8")##limit (13.0)#
+#head#
+#center#- % -
+
+
+#end#
+#type ("trium14.b")#
+#center#E U M E L - D E B U G
+
+#type ("trium12.b")#
+#center#Task-local Debugging Tools for EUMEL:
+#center##type("trium12.bc")#info, disasm, #type("trium12.b")#and #type("trium12.bc")#trace
+
+
+#b("1. Features")#
+
+#it("info:")# display and modification of a dataspace on the users terminal in the conventional dump
+ format; search for a bytestring;
+
+#it("disasm:")# disassembly of EUMEL-0-code out of the standard dataspace using symbolic opcodes
+ and procedure heads;
+
+#it("trace:")# tracing of user programs, protocolling of executed instructions and their actual operands,
+ trap at a given code address, single-step-mode, multiple-step-mode (interruptable at
+ any time)
+
+The procedures have no effect outside the task. Especially no other task will be halted by using the
+single-step mode.
+
+
+#b("2. Installation")#
+
+The debugging tools need a suitable system kernel ("Urlader"). They can be used with kernels for
+processors Z80, 8086 and 80286 with versions 190 \#14, 181 \#347 \#1347, 180 \#347 \#1347 and higher,
+and with 68000-kernel version \#3600 and higher.
+
+The archive diskette "trace" contains all necessary files. The commands
+#inb#
+ archive ("trace");
+ fetchall (archive);
+ run ("gen.trace")
+#ine#
+insert all source files and generate a dataspace "procheads" containing procedure heads of all
+inserted procedures (including the standard ones). Then the current task becomes a local mana­
+ger. Now a son task may be created, in which the debugging tools are available.
+
+The first time when (in a son task) #it("disasm")# or #it("trace")# protocols a CALL-instruction the dataspace
+'procheads' will be fetched from the father task for subsequent usage. If for any reason (e.g. after
+inserting new packets, see below) the user will change or re-install 'procheads' he has to inform
+the debugging procedures by issuing the command
+#inb# set procheads ("procheads") #ine#
+
+Access to the dataspace "procheads" may be suppressed by
+#inb# set procheads ("") #ine#
+
+Procedures inserted at a later time by the user should be added to the dataspace "procheads" (in the
+current task!) by typing the commands
+#inb#
+ bulletin m ("<packetname>");
+ run ("gen.procheads")
+#ine#
+
+
+
+#b("3. Description of the debugging procedures")#
+
+#b1("3.1 PROC info ")#
+
+The standard output is a hexadecimal dump of a dataspace in the following format:
+
+#outb#
+---------------------------- dsid=xx --------------------
+xxxxx: -xx-xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx yyyyyyy.........
+xxxxx: xx xx xx ... .....
+xxxxx: xx xx ... ...
+xxxxx: xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx .........yyyyyyy
+#re("INFO: more, address, dsid, lines, find, or quit")#
+#oute#
+
+
+The first line displays the dataspace identifier (4 <= dsid <= ff, dsid=4 identifies the standard
+dataspace).
+The dump lines begin with the hexadecimal word (!) address of the first word on this line. The order
+of bytes is the same as on EUMEL-'Hintergrund': low byte, high byte. Following the hexadecimal
+display of 16 bytes they will be shown as ascii-characters, too. Non-ascii characters will be
+displayed as '.'.
+
+The last line shows (as with #it("disasm")# and #it("trace")#, too) possible commands which will be recognized by
+their first letter. If a parameter is needed, it has to be typed as a hexadecimal number followed by a
+<CR>. The <RUBOUT> key may be used to delete the last input character(s).
+Possible commands and their effect:
+
+m (more): continues displaying at the next higher address
+
+a (address): specifies a new address
+
+d (dsid): specifies a new dataspace identifier
+
+l (lines): specifies a new line count (=window height); this value may be larger than the
+ number of lines of the terminal screen.
+
+f (find): (tries to) find a hexadecimal or character bytestring. The prompting message
+#outb#
+ find: hex, char, or last param? (h/H/c/C/<CR>)
+#oute#
+ may be answered in several ways. Examples:
+
+ #inb#h41<CR>#ine# looks for a byte 41h, beginning at the actual position, marked by -xx-.
+
+ #inb#Hcafe<CR>#ine# searches the bytestring 0cafeh, beginning at the actual word address.
+ Only strings at word addresses will be concerned for a comparison.
+
+ #inb#challo<CR>#ine# searches the character string "hallo", beginning at the actual position.
+
+ #inb#Ca<CR>#ine# searches the letter "a", which has to be located at a word address.
+ #inb#H41<CR> #ine#has the same effect.
+
+ #inb#<CR>#ine# searches the last bytestring explicitly specified in a search command,
+ beginning #bo("behind")# the marked position. The last parameter will be shown
+ during the search.
+
+ The search can be interrupted at any time by pressing a key. It may then be conti­
+ nued by a new 'find' command and <CR>.
+
+q (quit): leaves #it("info")# .
+
+Instead of a command the dataspace can be modified within the displayed area by the key-
+sequence
+ <UP> positions the cursor to the first displayed byte;
+ <Cursorkey>... moves the cursor within the hexadecimal display;
+ <2 hexadecimal digits>... overwrite the byte under the cursor;
+ <CR> leaves the window.
+
+Note: in the standard dataspace changes within the address range 20000...2ffff are only allowed in
+ conjunction with a 68000-kernel (see also 3.3, note a.).
+
+
+
+#b1("3.2 PROC disasm ")#
+
+EUMEL-0-code in the address range 20000...3ffff of the standard dataspace will be disassem­
+bled. The code will be listed one instruction per line, using symbolic opcodes and (in case of a CALL
+instruction) procedure heads as found in the dataspace "procheads".
+
+The following example shows the disassembled code of the standard procedure
+
+REAL OP MOD (REAL CONST left, right):
+ REAL VAR result := left - floor (left/right) * right;
+ IF result < 0.0
+ THEN result + abs (right)
+ ELSE result
+ FI
+ENDOP MOD;
+
+#outb#
+23edd: LN 2000
+23ede: PENTER 15fe
+23edf: FDIV 09c4 0d80 2880
+23ee2: FLOOR 637f 2880 2880
+23ee5: FMUL 28c0 0d80 2880
+23ee8: FSUB 09bc 2880 1880
+23eeb: FLSEQ 6049 1880
+23eed: BT f700
+23eee: PP 0dec
+23eef: PP 28ec
+23ef0: CALL 5d79 abs (REAL C) --> REAL
+23ef1: FADD 18b8 2880 2880
+23ef4: REF 28dc 2080
+23ef6: B f970
+23ef7: REF 18dc 2080
+23ef9: FMOV 21b4 1180
+23efb: RTN 007f
+#re("DISASM: step, more, address, lines, info, or quit")#
+#oute#
+
+Possible commands:
+
+s (step): shows the next instruction on the terminal. The command line will be rewritten.
+
+m (more): shows the next instructions. The output will stop after 'lines' (standard=12) lines. It
+ can be interrupted at any time by pressing any key. The output list terminates, when
+ an invalid opcode has been detected or when the instruction count exceeds 3ffff.
+
+a (address): specifies a new code address. Disassembly continues at this address.
+
+l (lines): specifies a new line count; this value may be larger than the number of lines of the
+ terminal screen.
+
+i (info): calls #it("info")#. The first line of dump contains the first word of the next instruction not yet
+ disassembled. This word will be marked. (After leaving #it("info")# disassembly would
+ continue with this instruction.)
+
+q (quit): leaves #it("disasm")#.
+
+
+#b1("3.3 PROC trace ")#
+
+#it("trace")# allowes controlled execution of subsequent EUMEL-0-code. The effect of the trace-mode
+can be demonstrated by showing the protocol produced by
+
+ #inb#trace; putline ("hallo")<CR>
+
+ #ine##outb##re("TRACE: step, more, trap, regs, lines, info, disasm, or quit")#
+#oute##inb#
+ p
+
+#ine##outb#
+ 34afb: PP 006d >00009000
+ 34afc: CALL f37a putline (TEXT C)
+ 28d63: PENTER 38fe
+ 28d64: TEST c828 >0
+ 28d65: BF 6b70
+ 28d66: OUT 3c7f 0980 >"hallo" hallo
+ 28d68: OUT 3c7f 6c01 >""13""10""
+
+ 28d6a: B 6e70
+ 28d6e: RTN 007f --> STOPEN NOERR ARITS
+ 34afd: RTN 007f --> STOPEN NOERR ARITS
+ 20944: RTN 007f --> STPDIS NOERR ARITU
+ trace ended by returning to nontraceable caller
+#oute#
+
+Comments on this output:
+- the indentation of the protocol lines shows the call depth.
+- in order to get 1 line per instruction as often as possible, some abbreviations are used in the
+ procedure heads: 'C' for 'CONST', 'V' for 'VAR', 'DS' for 'DATASPACE'.
+- the first occurrence of the string 'hallo' is part of the protocol. The second one is a result of the
+ execution of the (first) OUT-instruction. The blank line is produced by the second OUT-instruc­
+ tion!
+- the flags given with a RTN-instruction reflect the flag settings #bo("after")# execution of the RTN:
+ STOPEN = stop enabled STPDIS = stop disabled
+ NOERR = no error ERROR = error occurred
+ ARITS = signed arith mode ARITU = unsigned arith mode
+
+
+Possible commands:
+
+s (step): executes and protocols one instruction (=single-step-mode). For reasons of the
+ implementation, consecutive PP-instructions will be executed as one single step. The
+ same holds for instructions followed by a conditional branch (e.g. EQU+BT).
+
+ The protocol contains also actual operand values. Example:
+#inb#
+
+ trace;INT VAR a:= 2 + 11
+#ine##outb#
+
+ 34afb: ADD 001d 0101 5400 >2 >11(000b) 13(000d)>
+#oute#
+
+ '>' in front of a value indicates input-operand;
+ '>' behind a value indicates output-operand. (For the instructions MOV, FMOV and
+ TMOV only 1 (output-)operand will be shown.)
+ INT-objects are shown decimal and (in parentheses) hexadecimal (4 digits). The
+ numbers 0 to 9 will be shown only decimal.
+ REAL-objects will be shown in the internal representation (e.g. 11.5 as
+ 0115000000000082)
+ TEXT-objects will be shown as text denoters. Non-ascii characters will be converted
+ (see example). For long texts only the first 14 characters will be shown, followed by
+ the (correct) number of characters.
+ All other objects (TASKs, DATASPACEs and effective virtual addresses) will be shown
+ hexadecimal (4 or 8 digits).
+
+m (more): executes and protocols up to 'line count' (standard=12) instructions. Execution can be
+ interrupted at any time by any key, and resumed by commands 's' or 'm'.
+
+t (trap): sets a trap on a code address. As soon as the instruction count reaches the specified
+ value, the message
+#outb#
+ trap at address .....
+#oute#
+ will be displayed and the execution stopped. (The instruction at the trap address is the
+ next one to be executed!) At the same time the trap is deleted.
+
+r (regs): shows the relevant EUMEL-0-registers 'icount' (address of the instruction to be
+ executed next), 'pbase' (=packet base, base address for packet data), 'lbase' (=local
+ base, base address for local data on stack) as well as flag registers
+ (STOPEN/STPDIS, NOERR/ERROR, ARITS/ARITU).
+
+l (lines): specifies a new line count; this value may be larger than the number of lines of the
+ terminal screen.
+
+i (info): calls #it("info")#, s. 3.1. The instruction word pointed to by the instruction count is the actual
+ position, marked on the first line.
+
+d (disasm): calls #it("disasm")#, s. 3.2. Disassembly begins at the next instruction not yet executed.
+
+q (quit): leaves the trace-mode. However, a trap (see above) may still be in effect! Tracing
+ will be #bo("implicitly")# finished as soon as a RTN-instruction returns to a procedure
+ running in the 'unsigned arithmetic'-mode. (Regularly this is the ELAN-Compiler.)
+
+
+#bo("Important Notes ")#
+
+Erroneous use of #it("info")# and #it("trace")# may destruct your task. Therefore read carefully and observe follow­
+ing notes:
+
+a. In order to gain control at proper points of the code area, #it("trace")# temporarily modifies the user code
+ by inserting instructions (CALLs to itself) into it. On EUMEL-hardware based on Z80, 8086, or
+ 80286, #it("trace")# does not allow modification of address range 20000...2ffff for reasons of storage
+ management strategy. Therefore calls to procedures occupying this address range will be marked
+ in the protocol by "(*n.t.*)" (for 'nontraceable') and executed normally, i.e. not protocolled.
+
+ WARNING: execution of a nontraceable procedure cannot be interrupted by <SV> and 'halt'. So
+ be careful!
+
+b. Traps may only be set on the first word of an instruction. In a sequence of consecutive PP-
+ instructions only the first one may be trapped. In the same manner, a conditional branch (BT / BF)
+ following another instruction (e.g. EQU) may not be trapped.
+
+c. On inserting #it("trace")# it may get a module number > 2047. In that case the CALL to #it("trace")# occupies
+ 2 words. The user will be informed of this fact at the time just after inserting #it("trace")#:
+ #outb#
+ WARNING: call to trace needs 2 words!
+ #oute#
+ In this situation special care has to be taken to set a trap, e.g.:
+
+#outb#
+ LSEQ xxxx xxxx
+ BT xxxx (*branch on true to address a*)
+ ...
+ ...
+ a-1: B xxxx
+ a: ...
+#oute#
+
+ In this example the branch instruction at address 'a-1' may not be trapped because the following
+ instruction (at 'a') would be destroyed by a 2-word-CALL to #it("trace")#. A jump to 'a' would have an
+ undefined effect. So be careful! First inspect the code environment by using #it("disasm")# and then set
+ a trap at a suitable address!
+
+d. In the current version of #it("trace")# a trap will be implicitly deleted as soon as it has become active. If
+ the user wants (e.g. in a loop) to trap a given address again and again, he has to choose a
+ second suitable address, too, and alternately set a trap at these addresses. (A trap may be
+ #bo("explicitly")# deleted by specifying 0 as trap address.)
+
+e. One may be tempted to trace the ELAN-compiler by writing
+ #inb#
+ trace; do ("..........")
+ #ine#
+ which seems to work indeed for dozens of lines but at some point it begins to deliver wrong
+ results even with such trivial instructions as an integer ADD. This trouble arises from a storage
+ assignment policy during compilation of the ELAN compiler: temporary storage (e.g. for calculating
+ the value of an expression) will be assigned above the stack top of a procedure if it does not call
+ any other one. An #bo("implicit")# CALL to #it("trace")# causes a further stack frame to be established thus
+ possibly overwriting some temporary values of a compiler procedure. (Of course, the compiler
+ cannot know anything about CALLs inserted by #it("trace")# into the code area!)
+
+f. Errors (e.g. overflow) in user programs will be detected by #it("trace")# at the point of their occurrence
+ and reported in the protocol. However, #it("trace")# has no influence on the error handling, i.e. it does
+ not turn off the error flag by itself, nor causes it an error stop on the users level. (#it("trace")# may be
+ seen as an extension of the virtual EUMEL-0-machine offering some additional features but still
+ fully controlled by the users program.)
+
+g. Each time when the user has control within #it("trace")#, the users code area contains no other patches
+ than a possible CALL at the trap address if specified.
+
+h. The procedures #it("trace, disasm, info")#, and some others used by them are nontraceable. The body of
+ these procedures will not be protocolled. CALLs to them will be marked as nontraceable. Explicit
+ CALLs to #it("trace")# (i.e. in addition to the first call to switch on the trace mode) will be ignored.
+
+i. In trace-mode the EUMEL-0-instruction KE has the same effect as an explicit call to #it("info")#.
+
+j. Protocolling the execution produces output in addition to output programmed by the user. This
+ may lead to unexpected results when the user program specifies cursor positioning. The cursor
+ will always be moved to the position (10,13) instead of the position specified by the user. This is
+ due to the fact that cursor positioning takes place in two steps. One OUT instruction sends the
+ escape character for 'cursor positioning' (=""6""), and a second one sends two bytes containing
+ the coordinate values. The protocol line containing the first OUT will be followed by a lf-cr-
+ sequence (""10""13"") before the next protocol line can be written.
+
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 06:29:23 +0000