diff options
Diffstat (limited to 'devel')
| -rw-r--r-- | devel/debug-copy/1986.07.11/source-disk | 1 | ||||
| -rw-r--r-- | devel/debug-copy/1986.07.11/src/copy files | 2977 | ||||
| -rw-r--r-- | devel/debug-ds4/1989/source-disk | 1 | ||||
| -rw-r--r-- | devel/debug-ds4/1989/src/RUN load ds4 | 246 | ||||
| -rw-r--r-- | devel/debug-ds4/1989/src/RUN save ds4 | 223 | ||||
| -rw-r--r-- | devel/debug/1/source-disk | 1 | ||||
| -rw-r--r-- | devel/debug/1/src/RUN dez <-> hex | 49 | ||||
| -rw-r--r-- | devel/debug/1/src/all tracer | 10 | ||||
| -rw-r--r-- | devel/debug/1/src/convert | 154 | ||||
| -rw-r--r-- | devel/debug/1/src/disa | 454 | ||||
| -rw-r--r-- | devel/debug/1/src/extended instr | 25 | ||||
| -rw-r--r-- | devel/debug/1/src/gen.bulletin | 536 | ||||
| -rw-r--r-- | devel/debug/1/src/gen.procheads | 89 | ||||
| -rw-r--r-- | devel/debug/1/src/gen.trace | 23 | ||||
| -rw-r--r-- | devel/debug/1/src/info | 371 | ||||
| -rw-r--r-- | devel/debug/1/src/trace | 1020 | ||||
| -rw-r--r-- | devel/debug/1/src/trace.dok | 387 |
17 files changed, 6567 insertions, 0 deletions
diff --git a/devel/debug-copy/1986.07.11/source-disk b/devel/debug-copy/1986.07.11/source-disk new file mode 100644 index 0000000..cafd9fe --- /dev/null +++ b/devel/debug-copy/1986.07.11/source-disk @@ -0,0 +1 @@ +debug/debug-copy.img diff --git a/devel/debug-copy/1986.07.11/src/copy files b/devel/debug-copy/1986.07.11/src/copy files new file mode 100644 index 0000000..83b6f68 --- /dev/null +++ b/devel/debug-copy/1986.07.11/src/copy files @@ -0,0 +1,2977 @@ +PACKET copy worker DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + copy worker, (* 11.07.86 *) + ds page nr feld, + block nr feld, + anzahl feld, + size feld, + check pointer feld, + check vektor start feld, + check vektor laenge: + +LET continue channel code = 200, + archive blocks code = 201, + format disk code = 202, + read code = 203, + write code = 204, + check read code = 205, + init rerun test code = 206; + +INT CONST ds page nr feld :: 1, + block nr feld :: 2, + anzahl feld :: 3, + size feld :: 4, + check pointer feld :: 9, + check vektor start feld :: 10, + + check vektor laenge :: 19; + +LET ack = 0; + +BOUND ROW 252 INT VAR align; + +BOUND STRUCT (ALIGN dummy, ROW 256 INT check row) VAR check struct; +DATASPACE VAR check ds; +INITFLAG VAR check ds initialisiert := FALSE; + +INT VAR old session; + +PROC copy worker: + access catalogue; + global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) copy worker) + +END PROC copy worker; + +PROC copy worker (DATASPACE VAR ds, INT CONST order, phase, TASK CONST order task): + enable stop; + INT VAR dummy; dummy := phase; (* so schalte ich eine warnung ab *) + ueberpruefe zugriffsberechtigung von order task; + SELECT order OF + CASE continue channel code: do continue channel (ds, order task) + CASE archive blocks code: do archive blocks (ds, order task) + CASE format disk code: do format disk (ds, order task) + CASE read code: do read (ds, order task) + CASE write code: do write (ds, order task) + CASE check read code: do check read (ds, order task) + CASE init rerun test code: do init rerun test (ds, order task) + OTHERWISE error stop ("falscher Auftrag") + END SELECT. + +ueberpruefe zugriffsberechtigung von order task: + IF NOT (order task = father (myself)) + THEN error stop ("Unerlaubter Zugriff") + FI. + +END PROC copy worker; + +PROC do continue channel (DATASPACE VAR ds, TASK CONST order task): + BOUND INT VAR channel nr := ds; + continue channel (channel nr + 0); (* + 0 --> keine Seiteneffekte *) + send (order task, ack, ds). + +END PROC do continue channel; + +PROC do archive blocks (DATASPACE VAR ds, TASK CONST order task): + enable stop; + check rerun; + BOUND INT VAR archive size := ds; + archive size := size (archive size); + send (order task, ack, ds). + +END PROC do archive blocks; + +PROC do init rerun test (DATASPACE VAR ds, TASK CONST order task): + old session := session; + send (order task, ack, ds). + +END PROC do init rerun test; + +PROC do format disk (DATASPACE VAR ds, TASK CONST order task): + enable stop; + check rerun; + BOUND INT VAR format code := ds; + format archive (format code); + send (order task, ack, ds). + +END PROC do format disk; + +PROC do read (DATASPACE VAR ds, TASK CONST order task): + enable stop; + align := ds; + INT CONST ds start :: align [ds page nr feld], + disk start :: align [block nr feld], + anzahl :: align [anzahl feld]; + INT VAR return code, index; + FOR index FROM 0 UPTO anzahl - 1 REP + check rerun; + read block (ds, ds page nr, disk block nr, return code); + pruefe ob lesefehler + PER; + send (order task, ack, ds). + +pruefe ob lesefehler: + IF return code <> 0 + THEN fehler melden + FI. + +fehler melden: + SELECT return code OF + CASE 1: errorstop ("Laufwerk nicht betriebsbereit") + CASE 2: errorstop ("Lesefehler bei Block " + text (disk block nr)) + CASE 3: errorstop ("Blocknummer zu hoch " + text (disk block nr)) + CASE 4: errorstop ("Block nicht lesbar " + text (disk block nr)) + OTHERWISE errorstop ("Lesefehler " + text (return code)) + END SELECT. + +ds page nr: + ds start + index. + +disk block nr: + disk start + index. + +END PROC do read; + +PROC do write (DATASPACE VAR ds, TASK CONST order task): + enable stop; + align := ds; + INT CONST ds start :: align [ds page nr feld], + disk start :: align [block nr feld], + anzahl :: align [anzahl feld]; + INT VAR return code, index; + FOR index FROM 0 UPTO anzahl - 1 REP + check rerun; + write block (ds, ds page nr, 0, disk block nr, return code); + pruefe ob schreibfehler + PER; + send (order task, ack, ds). + +pruefe ob schreibfehler: + IF return code <> 0 + THEN fehler melden + FI. + +fehler melden: + SELECT return code OF + CASE 1: errorstop ("Laufwerk nicht betriebsbereit") + CASE 2: errorstop ("Schreibfehler bei Block " + text (disk block nr)) + CASE 3: errorstop ("Blocknummer zu hoch " + text (disk block nr)) + OTHERWISE errorstop ("Schreibfehler " + text (return code)) + END SELECT. + +ds page nr: + ds start + index. + +disk block nr: + disk start + index. + +END PROC do write; + +PROC do check read (DATASPACE VAR ds, TASK CONST order task): + enable stop; + IF NOT initialized (check ds initialisiert) + THEN check ds := nilspace; + check struct := check ds + FI; + align := ds; + INT CONST disk start :: align [block nr feld], + anzahl :: align [anzahl feld]; + INT VAR index; + INT VAR return code; + FOR index FROM 0 UPTO anzahl - 1 REP + check rerun; + read block (check ds, 2, disk block nr, return code); + pruefe ob lesefehler; + do check block + PER; + send (order task, ack, ds). + +pruefe ob lesefehler: + IF return code <> 0 + THEN fehler melden + FI. + +fehler melden: + SELECT return code OF + CASE 1: errorstop ("Laufwerk nicht betriebsbereit") + CASE 2: errorstop ("Lesefehler bei Block " + text (disk block nr)) + CASE 3: errorstop ("Blocknummer zu hoch " + text (disk block nr)) + CASE 4: errorstop ("Block nicht lesbar " + text (disk block nr)) + OTHERWISE errorstop ("Lesefehler " + text (return code)) + END SELECT. + +disk block nr: + disk start + index. + +do check block: + INT VAR block index; + FOR block index FROM 1 UPTO 256 REP + check vektor eintrag := check vektor eintrag XOR block eintrag; + incr check vektor pointer + PER. + +check vektor eintrag: + align [check vektor start feld + check pointer]. + +check pointer: + align [check pointer feld]. + +block eintrag: + check struct.check row [block index]. + +incr check vektor pointer: + check pointer INCR 1; + IF check pointer = check vektor laenge + THEN check pointer := 0 + FI. + +END PROC do check read; + +PROC check rerun: + IF session <> old session + THEN error stop ("Abbruch wegen RERUN") + FI. + +END PROC check rerun; + +END PACKET copy worker; +PACKET copy io interface DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + (* 21.11.86 *) + copy channel, + start copy worker, + initialisiere rerun test, + initialisiere diskettenzugriff, + formatiere diskette, + read, + check read, + write, + stop copy worker: + +LET ack = 0, + error nak = 2, + free code = 20; + +LET continue channel code = 200, + archive blocks code = 201, + format disk code = 202, + read code = 203, + write code = 204, + check read code = 205, + init rerun test code = 206; + +INT VAR reply; +DATASPACE VAR ds := nilspace; forget (ds); + +BOUND ROW 252 INT VAR align; + +TASK VAR worker := niltask; +INT VAR worker channel := 31; + +INT PROC copy channel: + worker channel + +END PROC copy channel; + +PROC copy channel (INT CONST channel nr): + worker channel := channel nr + +END PROC copy channel; + +PROC initialisiere rerun test: + forget (ds); + ds := nilspace; + call (worker, init rerun test code, ds, reply); + forget (ds). + +END PROC initialisiere rerun test; + +PROC start copy worker: + stop copy worker; + bestimme worker name; + starte worker; + kopple worker an kanal. + +bestimme worker name: + TEXT VAR worker name := "copy worker"; + access catalogue; + BOUND THESAURUS CONST system catalogue :: syscat; + WHILE system catalogue CONTAINS worker name REP + worker name CAT "." + PER. + +starte worker: + begin (worker name, PROC copy worker, worker). + +kopple worker an kanal: + kanal freigeben falls diese task copy channel belegt; + forget (ds); + ds := nilspace; + BOUND INT VAR nr := ds; + nr := worker channel; + call (worker, continue channel code, ds, reply); + IF reply = error nak + THEN end (worker); + worker := niltask; + show error (ds) + ELIF reply <> ack + THEN end (worker); + worker := niltask; + forget (ds); + error stop ("copy worker nicht an Kanal " + text (worker channel) + + " ankoppelbar") + FI; + forget (ds). + +kanal freigeben falls diese task copy channel belegt: + TASK CONST channel owner := task (copy channel); + IF NOT is niltask (channel owner) AND NOT (myself = channel owner) + THEN forget (ds); + ds := nilspace; + pingpong (channel owner, free code, ds, reply); + forget (ds) + FI. + +END PROC start copy worker; + +PROC initialisiere diskettenzugriff: + INT VAR dummy; + initialisiere diskettenzugriff (dummy) + +END PROC initialisiere diskettenzugriff; + +PROC initialisiere diskettenzugriff (INT VAR size): + initialisiere diskettenzugriff (0, size) + +END PROC initialisiere diskettenzugriff; + +PROC initialisiere diskettenzugriff (INT CONST mode, INT VAR size): + enable stop; + size := 0; + forget (ds); + ds := nilspace; + BOUND INT VAR i := ds; + i := mode; + call (worker, archive blocks code, ds, reply); + IF reply = error nak + THEN show error (ds) + ELSE i := ds; + size := i + FI; + forget (ds). + +END PROC initialisiere diskettenzugriff; + +PROC formatiere diskette (INT CONST modus): + enable stop; + forget (ds); + ds := nilspace; + BOUND INT VAR format param := ds; + format param := modus; + call (worker, format disk code, ds, reply); + IF reply = error nak + THEN show error (ds) + FI; + forget (ds). + + +END PROC formatiere diskette; + +PROC read (DATASPACE VAR in ds, INT CONST erste ds seite, erster disk block, + anzahl bloecke): + enable stop; + align := in ds; + align [ds page nr feld] := erste ds seite; + align [block nr feld] := erster disk block; + align [anzahl feld] := anzahl bloecke; + call (worker, read code, in ds, reply); + IF reply = error nak + THEN show error (in ds) + FI. + +END PROC read; + +PROC write (DATASPACE VAR aus ds, INT CONST erste ds seite, erster disk block, + anzahl bloecke): + enable stop; + align := aus ds; + align [ds page nr feld] := erste ds seite; + align [block nr feld] := erster disk block; + align [anzahl feld] := anzahl bloecke; + call (worker, write code, aus ds, reply); + IF reply = error nak + THEN show error (aus ds) + FI. + +END PROC write; + +PROC check read (DATASPACE VAR in ds, INT CONST erster disk block, + anzahl bloecke): + enable stop; + align := in ds; + align [block nr feld] := erster disk block; + align [anzahl feld] := anzahl bloecke; + call (worker, check read code, in ds, reply); + IF reply = error nak + THEN show error (in ds) + FI. + +END PROC check read; + +PROC stop copy worker: + IF NOT (worker = niltask) + THEN disable stop; + end (worker); + worker := niltask; + clear error + FI. + +END PROC stop copy worker; + +PROC show error (DATASPACE CONST error ds): + BOUND TEXT VAR error msg := error ds; + error stop (error msg). + +END PROC show error; + +END PACKET copy io interface; +PACKET copy utilities DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + (* 21.11.86 *) + ds start, + hg type, + disk type, + urlader type, + diskette anfordern, + disketten groesse zeigen, + ds name eingabe, + initialisiere check read, + check summe abspeichern, + check summen vergleichen, + some, + list, + evtl diskette formatieren, + read and retry, + write and retry, + check read and retry: + +INT CONST hg type :: 801, + disk type :: 802, + urlader type :: 803; + +INT CONST ds start :: 2; + +DATASPACE VAR list ds := nilspace; forget (list ds); +DATASPACE VAR save ds := nilspace; forget (save ds); + +PROC diskette anfordern (TEXT CONST prompt): + WHILE NOT online REP pause (20) PER; + command dialogue (TRUE); + IF no (prompt) + THEN error stop ("Diskette nicht eingelegt") + FI; + line. + +END PROC diskette anfordern; + +PROC disketten groesse zeigen (INT CONST blocks): + putline ("die eingelegte Diskette enthält " + text (blocks DIV 2) + " KB"); + line. + +END PROC disketten groesse zeigen; + +PROC ds name eingabe (TEXT VAR name, TEXT CONST name pre, + BOOL CONST soll existieren, + TEXT CONST type vektor): + enable stop; + IF soll existieren + THEN name eines existierenden ds bestimmen + ELSE name eines neuen ds bestimmen + FI. + +name eines existierenden ds bestimmen: + IF NOT name gueltig + THEN name := name pre + FI; + editget (name); + line; + WHILE NOT name gueltig REP + fehler zeigen; + IF yes ("neuen Namen angeben (sonst Abbruch)") + THEN put ("Eingabe:"); + editget (name); + line + ELSE errorstop ("Abbruch, da Name fehlerhaft") + FI; + PER. + +name gueltig: + (name <> "") CAND (exists (name)) CAND type ok. + +type ok: + IF LENGTH type vektor = 0 + THEN TRUE + ELSE INT CONST ds type := type (old (name)); + INT VAR p; + FOR p FROM 1 UPTO length (type vektor) DIV 2 REP + IF ds type = (type vektor ISUB p) + THEN LEAVE type ok WITH TRUE + FI + PER; + FALSE + FI. + +fehler zeigen: + IF name = "" + THEN putline ("Kein Name angegeben") + ELIF NOT exists (name) + THEN putline ("""" + name + """ gibt es nicht") + ELSE putline ("""" + name + """ hat falschen Typ") + FI. + +name eines neuen ds bestimmen: + name := name pre; + editget (name); + line; + WHILE exists (name) OR (name = "") REP + IF name = "" + THEN put ("Kein Name eingegeben, Eingabe:"); + editget (name); + line + ELIF yes ("alten Datenraum """ + name + """ löschen") + THEN forget (name, quiet) + ELIF yes ("neuen Namen angeben (sonst Abbruch)") + THEN put ("bitte Datenraumnamen angeben:"); + editget (name); + line + ELSE error stop ("""" + name + """ existiert schon") + FI + PER. + +END PROC ds name eingabe; + +PROC initialisiere check read (DATASPACE VAR check read ds): + enable stop; + BOUND ROW 252 INT VAR align; + align := check read ds; + align [check pointer feld] := check vektor start feld; + INT VAR i; + FOR i FROM 0 UPTO check vektor laenge - 1 REP + align [check vektor start feld + i] := i + PER. + +END PROC initialisiere check read; + +PROC check summe abspeichern (TEXT CONST file name, DATASPACE CONST ds): + BOUND ROW 252 INT VAR align := ds; + FILE VAR f := sequential file (output, file name); + putline (f, "Prüfsumme"); + INT VAR i; + FOR i FROM 0 UPTO check vektor laenge - 1 REP + putline (f, text (align [check vektor start feld + i])) + PER. + +END PROC check summe abspeichern; + +TEXT VAR edit type vektor := " "; replace (edit type vektor, 1, 1003); + +PROC check summen vergleichen: + enable stop; + datei namen erfragen; + dateien vergleichen. + +datei namen erfragen: + TEXT VAR name1 := "prüf.", + name2 := "prüf."; + put ("Bitte Dateinamen der ersten Prüfsummendatei eingeben:"); + ds name eingabe (name1, "prüf.", TRUE, edit type vektor); + line; + put ("Bitte Dateinamen der zweiten Prüfsummendatei eingeben:"); + ds name eingabe (name2, "prüf.", TRUE, edit type vektor); + line. + +dateien vergleichen: + FILE VAR f1 := sequential file (modify, name1); + FILE VAR f2 := sequential file (modify, name2); + INT VAR i; + FOR i FROM 1 UPTO check vektor laenge + 1 REP + vergleiche zeilen + PER; + putline ("Die Prüfsummen stimmen überein"). + +vergleiche zeilen: + TEXT VAR zeile1, zeile2; + to line (f1, i); + to line (f2, i); + read record (f1, zeile1); + read record (f2, zeile2); + IF zeile1 <> zeile2 + THEN putline (""7"FEHLER: UNTERSCHIEDLICHE PRÜFSUMMEN"); + LEAVE check summen vergleichen + FI. + +END PROC check summen vergleichen; + +THESAURUS PROC some (THESAURUS CONST ur, INT CONST ds type): + THESAURUS VAR ziel := empty thesaurus; + TEXT VAR name; + INT VAR index := 0; + get (ur, name, index); + WHILE index > 0 REP + IF type (old (name)) = ds type + THEN insert (ziel, name) + FI; + get (ur, name, index); + PER; + ziel. + +END PROC some; + +PROC list (THESAURUS CONST list thes, TEXT CONST head text): + disable stop; + forget (list ds); + list ds := nilspace; + FILE VAR list file := sequential file (output, list ds); + headline (list file, head text); + INT VAR index := 0; + TEXT VAR name; + get (list thes, name, index); + WHILE index > 0 REP + putline (list file, name); + get (list thes, name, index); + PER; + show (list file); + forget (list ds). + +END PROC list; + +PROC read and retry (DATASPACE VAR in ds, INT CONST erste ds seite, erster disk block, + anzahl bloecke): + disable stop; + forget (save ds); + save ds := in ds; + read (in ds, erste ds seite, erster disk block, anzahl bloecke); + WHILE is error REP + putline (""4"" + error message); + forget (in ds); + in ds := save ds; + IF yes ("noch ein Versuch") + THEN clear error; + read (in ds, erste ds seite, erster disk block, anzahl bloecke); + ELSE forget (save ds); enable stop + FI; + line + PER; + forget (save ds). + + +END PROC read and retry; + +PROC write and retry (DATASPACE VAR out ds, INT CONST erste ds seite, erster disk block, + anzahl bloecke): + disable stop; + forget (save ds); + save ds := out ds; + write (out ds, erste ds seite, erster disk block, anzahl bloecke); + WHILE is error REP + putline (""4"" + error message); + forget (out ds); + out ds := save ds; + IF yes ("noch ein Versuch") + THEN clear error; + write (out ds, erste ds seite, erster disk block, anzahl bloecke); + ELSE forget (save ds); enable stop + FI; + line + PER; + forget (save ds). + +END PROC write and retry; + +PROC check read and retry (DATASPACE VAR in ds, INT CONST erster disk block, + anzahl bloecke): + disable stop; + forget (save ds); + save ds := in ds; + check read (in ds, erster disk block, anzahl bloecke); + WHILE is error REP + putline (""4"" + error message); + forget (in ds); + in ds := save ds; + IF yes ("noch ein Versuch") + THEN clear error; + check read (in ds, erster disk block, anzahl bloecke); + ELSE enable stop + FI; + line + PER. + +END PROC check read and retry; + +TEXT VAR formatierschluessel := "0"; + +PROC evtl diskette formatieren: + command dialogue (TRUE); + IF yes ("Diskette zuerst formatieren") + THEN disable stop; + put ("Formatiercode:"); edit get (formatierschluessel); + formatiere diskette (int (formatierschluessel)); + line; + WHILE is error REP + putline (""4"" + error message); + IF yes ("noch ein Versuch") + THEN clear error; + put ("Formatiercode:"); edit get (formatierschluessel); + formatiere diskette (int (formatierschluessel)); + line + ELSE enable stop + FI; + PER; + enable stop; + FI; + line. + +END PROC evtl diskette formatieren; + +END PACKET copy utilities; +PACKET info DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + (* 20.08.86 *) + informationen ausgeben, + urlader informationen von diskette ausgeben, + urlader informationen von datenraum ausgeben, + hg informationen von diskette ausgeben, + hg informationen von datenraum ausgeben: + +TEXT VAR hg vektor := " "; replace (hg vektor, 1, hg type); + +TEXT VAR hg urlader vektor := " "; replace (hg urlader vektor, 1, hg type); + replace (hg urlader vektor, 2, urlader type); + + +BOUND STRUCT (ROW 252 INT align, ROW 10240 INT row) VAR ds struct; +DATASPACE VAR ds work := nilspace; forget (ds work); + +INT VAR disk size; + +TEXT VAR versions nr; + +TEXT CONST eumel kennzeichen :: "EUMEL-"; +INT CONST eumel kennzeichen wort 0 :: eumel kennzeichen ISUB 1, + eumel kennzeichen wort 1 :: eumel kennzeichen ISUB 2, + eumel kennzeichen wort 2 :: (eumel kennzeichen ISUB 3) AND 255; + +TEXT VAR ds name := ""; + +PROC hg informationen von diskette ausgeben: + disable stop; + enable hg informationen von diskette ausgeben; + forget (ds work). + +END PROC hg informationen von diskette ausgeben; + +PROC enable hg informationen von diskette ausgeben: + enable stop; + initialisiere rerun test; + ds work := nilspace; + erste diskette anfordern; + relevante bloecke lesen; + informationen ausgeben (ds work, TRUE, TRUE). + +erste diskette anfordern: + command dialogue (TRUE); + diskette anfordern ("erste Hintergrunddiskette eingelegt"); + cursor (1, 19); out (""4""). + +relevante bloecke lesen: + initialisiere disketten zugriff (0, disk size); + read (ds work, ds start, 0, 1); + read (ds work, ds start + 10, 10, 1). + +END PROC enable hg informationen von diskette ausgeben; + +PROC urlader informationen von diskette ausgeben: + disable stop; + enable urlader informationen von diskette ausgeben; + forget (ds work). + +END PROC urlader informationen von diskette ausgeben; + +PROC enable urlader informationen von diskette ausgeben: + enable stop; + initialisiere rerun test; + ds work := nilspace; + erste diskette anfordern; + relevante bloecke lesen; + informationen ausgeben (ds work, FALSE, TRUE). + +erste diskette anfordern: + diskette anfordern ("Urlader-Diskette eingelegt"); + cursor (1, 19); out (""4""). + +relevante bloecke lesen: + initialisiere disketten zugriff (0, disk size); + read (ds work, ds start + 10, 10, 1). + +END PROC enable urlader informationen von diskette ausgeben; + +PROC hg informationen von datenraum ausgeben: + disable stop; + hg ds namen bestimmen; + ds work := old (ds name); + informationen ausgeben (ds work, TRUE, TRUE); + forget (ds work). + +hg ds namen bestimmen: + put ("Bitte Datenraumnamen eingeben:"); + ds name eingabe (ds name, "HG", TRUE, hg vektor); + cursor (1, 19); out (""4""). + +END PROC hg informationen von datenraum ausgeben; + +PROC urlader informationen von datenraum ausgeben: + disable stop; + urlader ds namen bestimmen; + ds work := old (ds name); + informationen ausgeben (ds work, FALSE, TRUE); + forget (ds work). + +urlader ds namen bestimmen: + put ("Bitte Datenraumnamen eingeben:"); + ds name eingabe (ds name, "", TRUE, hg urlader vektor); + cursor (1, 19); out (""4""). + +END PROC urlader informationen von datenraum ausgeben; + +PROC informationen ausgeben (DATASPACE CONST ds, + BOOL CONST hg info, urlader info): + enable stop; + ds struct := ds; + IF hg info + THEN hg info ausgeben + FI; + IF urlader info + THEN urlader info ausgeben + FI. + +hg info ausgeben: + teste eumelkennzeichen; + versionsnummer ausgeben; + hg groesse ausgeben. + +teste eumelkennzeichen: + IF (eumelkennzeichen wort 0 <> ds struct.row [1]) OR + (eumelkennzeichen wort 1 <> ds struct.row [2]) OR + (eumelkennzeichen wort 2 <> (ds struct.row [3] AND 255)) OR + (NOT no plus hg AND (ds struct.row [43] <> 0)) + (* ds struct.row [43] <--> Sequenznummer *) + THEN error stop ("die Diskette ist nicht die erste Diskette eines EUMEL Hintergrundes") + FI. + +versionsnummer ausgeben: + versions nr := 6 * " "; + replace (versions nr, 1, ds struct.row [4]); + replace (versions nr, 2, ds struct.row [5]); + replace (versions nr, 3, ds struct.row [6]); + put ("EUMEL Hintergrund-Versionsnummer: " + versions nr); + IF NOT no plus hg + THEN put (" (grosse Speicherverwaltung)"); + FI; + line. + +hg groesse ausgeben: + IF no plus hg + THEN putline (" Hintergrund-Größe: " + text (4 * ds struct.row [19]) + " KB") + ELSE putline (" Hintergrund-Größe: " + text ((ds struct.row [41] + 1) DIV 2) + " KB") + FI. + +no plus hg: + (ds struct.row [41] = 1) AND (ds struct.row [42] = 0). + +urladerinfo ausgeben: + IF diskette enthaelt urlader + THEN urlader informationen vorhanden + ELIF hg info + THEN putline ("Diskette enthält keinen Urlader") + ELSE error stop ("Diskette enthält keinen Urlader") + FI. + +diskette enthaelt urlader: + (eumelkennzeichen wort 0 = ds struct.row [2561]) AND + (eumelkennzeichen wort 1 = ds struct.row [2562]) AND + (eumelkennzeichen wort 2 = (ds struct.row [2563] AND 255)). + +urlader informationen vorhanden: + urlader format bestimmen; + put (" Urladerversion: "); put (urlader version); line; + put (" Urlader-CPU-Type:"); put (cpu type); line; + put (" SHardversion min:"); put (shard version min); line; + put (" SHardversion max:"); put (shard version max); + put (" "). + +urladerformat bestimmen: + BOOL VAR motorola format := (ds struct.row [2571] = 1024). + +urlader version: + INT VAR dummy := ds struct.row [2572]; + TEXT VAR ur ver := ""; + IF motorola format + THEN rotate (dummy, 8); + INT CONST monate :: dummy DIV 100, + tag :: dummy MOD 100; + ur ver := text (tag); + ur ver CAT "."; + ur ver CAT text (m68000 monat); + ur ver CAT "."; + ur ver CAT text (84 + (monate - 1) DIV 12) + ELSE ur ver := "#" + text (dummy) + FI; + ur ver. + +m68000 monat: + IF monate MOD 12 = 0 + THEN 12 + ELSE monate MOD 12 + FI. + +shard version min: + IF motorola format + THEN dummy := ds struct.row [2573]; + rotate (dummy, 8) + ELSE dummy := ds struct.row [2574]; + FI; + dummy. + +shard version max: + IF motorola format + THEN dummy := ds struct.row [2574]; + rotate (dummy, 8) + ELSE dummy := ds struct.row [2575]; + FI; + dummy. + +cpu type: + INT CONST cpu int :: ds struct.row [2571]; + IF cpu int = 1 + THEN "Z 80" + ELIF cpu int = 3 + THEN "INTEL 8086 / 8088" + ELIF cpu int = 1024 + THEN "Motorola 68000" + ELSE text (cpu int) + FI. + +END PROC informationen ausgeben; + +END PACKET info; +PACKET gigads DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + GIGADS, (* 11.07.86 *) + + giga ds size, + :=, + old zuweisen, + main, + forget, + copy, + read and retry, + write and retry, + informationen ausgeben, + type: + +LET max ds no = 10; + +TYPE GIGADS = ROW max ds no DATASPACE; + +INT VAR xgigads size; + +PROC gigads size (INT CONST max block no): + xgigads size := max block no + +END PROC giga ds size; + +INT PROC last used ds: + (xgigads size DIV 2000) + 1 + +END PROC last used ds; + +INT PROC ds no (INT CONST page no): + (page no DIV 2000) + 1. + +END PROC ds no; + +INT PROC ds page no (INT CONST page no): + IF ds no (page no) = 1 + THEN page no + ELSE (page no MOD 2000) + 2 + FI. + +END PROC ds page no; + +TEXT PROC name (TEXT CONST pre, INT CONST no): + IF no = 1 + THEN pre + ELSE pre + ".hintergrund datenraum extension nummer " + text (no - 1) + FI. + +END PROC name; + +OP := (GIGADS VAR gig, DATASPACE CONST ds): + gig [1] := ds; + INT VAR count; + FOR count FROM 2 UPTO max ds no REP + gig [count] := nilspace + PER + +END OP :=; + +DATASPACE PROC main (GIGADS CONST gig): + gig [1] + +END PROC main; + +PROC type (GIGADS VAR gig, INT CONST value): + INT VAR count; + FOR count FROM 1 UPTO max ds no REP + type (gig [count], value) + PER. + +END PROC type; + +INT PROC type (GIGADS CONST gig): + INT CONST value :: type (gig [1]); + INT VAR count; + FOR count FROM 2 UPTO max ds no REP + IF type (gig [count]) <> value + THEN error stop ("GIGADS inconsistent") + FI + PER; + value. + +END PROC type; + +PROC forget (GIGADS VAR gig): + INT VAR count; + FOR count FROM 1 UPTO max ds no REP + forget (gig [count]) + PER. + +END PROC forget; + +PROC copy (GIGADS CONST gig, TEXT CONST name0): + IF exists (name 0) + THEN error stop ("""" + name0 + """ existiert schon") + FI; + INT VAR count; + FOR count FROM 1 UPTO last used ds REP + forget (name (name 0, count), quiet); + copy (gig [count], name (name 0, count)) + PER + +END PROC copy; + +PROC old zuweisen (GIGADS VAR gig, TEXT CONST name0): + gig [1] := old (name0); + INT VAR count; + FOR count FROM 2 UPTO max ds no REP + IF exists (name (name0, count)) + THEN gig [count] := old (name (name0, count)) + ELSE gig [count] := nilspace + FI + PER. + +END PROC old zuweisen; + +PROC read and retry (GIGADS VAR gig, + INT CONST erste ds seite, erster disk block, anzahl bloecke): + INT CONST no1 :: ds no (erste ds seite), + no2 :: ds no (erste ds seite + anzahl bloecke - 1); + IF no1 = no2 + THEN read and retry (gig [no1], ds page no (erste ds seite), + erster disk block, anzahl bloecke) + ELSE INT VAR count; + FOR count FROM 0 UPTO anzahl bloecke - 1 REP + read and retry (gig [ds no (erste ds seite + count)], + ds page no (erste ds seite + count), + erster disk block + count, 1); + PER + FI. + +END PROC read and retry; + +PROC write and retry (GIGADS VAR gig, INT CONST erste ds seite, erster disk block, + anzahl bloecke): + INT CONST no1 :: ds no (erste ds seite), + no2 :: ds no (erste ds seite + anzahl bloecke - 1); + IF no1 = no2 + THEN write and retry (gig [no1], ds page no (erste ds seite), + erster disk block, anzahl bloecke) + ELSE INT VAR count; + FOR count FROM 0 UPTO anzahl bloecke - 1 REP + write and retry (gig [ds no (erste ds seite + count)], + ds page no (erste ds seite + count), + erster disk block + count, 1) + PER + FI. + +END PROC write and retry; + +PROC informationen ausgeben (GIGADS CONST gig, BOOL CONST b1, b2): + informationen ausgeben (gig [1], b1, b2) + +END PROC informationen ausgeben; + +END PACKET gigads; + +PACKET copy hg DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + hg lesen, (* 11.07.86 *) + hg schreiben, + hg check sum: + +TEXT VAR hg vektor := " "; replace (hg vektor, 1, hg type); + +TEXT VAR ds name := ""; + +INT VAR disk size, + hg bloecke verarbeitet, + hg bloecke zu verarbeiten, + disk bloecke verarbeitet; + +BOUND STRUCT (ROW 252 INT align, ROW 10240 INT row) VAR ds work struct; +GIGADS VAR ds work := nilspace; forget (ds work); + +DATASPACE VAR check ds := nilspace; forget (check ds); + +PROC hg lesen: + disable stop; + enable hg lesen; + forget (ds work). + +END PROC hg lesen; + +PROC enable hg lesen: + enable stop; + initialisiere rerun test; + ds work := nilspace; + ds work struct := main (ds work); + type (ds work, hg type); + diskette anfordern ("erste zu lesende Hintergrunddiskette eingelegt"); + initialisiere disketten zugriff (0, disk size); + header bloecke lesen; + informationen ausgeben (ds work, TRUE, TRUE); + line (2); + ds work namen bestimmen; + IF plus version + THEN hintergrund rest lesen plus version + ELSE hintergrundrest lesen no plus version + FI; + copy (ds work, ds name). + +header bloecke lesen: + read and retry (ds work, ds start, 0, 1); + read and retry (ds work, ds start + 10, 10, 1); + hg bloecke verarbeitet := 1; + disk bloecke verarbeitet := 1. + +ds work namen bestimmen: + put ("bitte Datenraumnamen angeben:"); + ds name eingabe (ds name, "HG", FALSE, ""); + line. + +plus version: + NOT ((ds work struct.row [41] = 1) AND (ds work struct.row [42] = 0)). + +END PROC enable hg lesen; + +PROC hintergrund rest lesen no plus version: + disketten groesse zeigen (disk size); + hg bloecke zu verarbeiten := 8 * ds work struct.row [19]; + giga ds size (hg bloecke zu verarbeiten + ds start); + status zeigen; + WHILE hg bloecke verarbeitet < hg bloecke zu verarbeiten REP + IF disk bloecke verarbeitet = disk size + THEN neue diskette anfordern + FI; + naechsten satz bloecke lesen; + status zeigen + PER. + +neue diskette anfordern: + diskette anfordern (""4"nächste zu lesende Hintergrunddiskette eingelegt"); + initialisiere disketten zugriff (0, disk size); + line; + disketten groesse zeigen (disk size); + disk bloecke verarbeitet := 0. + +naechsten satz bloecke lesen: + bestimme anzahl zu lesender bloecke; + read and retry (ds work, ds start + hg bloecke verarbeitet, + disk bloecke verarbeitet, anzahl zu lesender bloecke); + hg bloecke verarbeitet INCR anzahl zu lesender bloecke; + disk bloecke verarbeitet INCR anzahl zu lesender bloecke. + +bestimme anzahl zu lesender bloecke: + INT CONST anzahl zulesender bloecke :: min (moegliche hg bloecke auf disk, 20). + +moegliche hg bloecke auf disk: + min (hg bloecke zu verarbeiten - hg bloecke verarbeitet, + disk size - disk bloecke verarbeitet). + +status zeigen: + IF online + THEN out (""13""); + putline ("Hintergrund: " + text (hg bloecke verarbeitet DIV 2, 4) + " KB gelesen"); + putline ("aktuelle Diskette: " + text (disk bloecke verarbeitet DIV 2, 4) + " KB gelesen"); + out (""3""3""13"") + FI. + +END PROC hintergrund rest lesen no plus version; + +PROC hintergrundrest lesen plus version: + BOOL VAR letzte diskette gelesen; + TEXT VAR sequenz nr map := 100 * " "; + INT VAR letzte sequenz nr; + hg bloecke zu verarbeiten := ds work struct.row [41] + 1; + giga ds size (hg bloecke zu verarbeiten + ds start); + hg bloecke verarbeitet := 1; + hg etikett merken; + lies diskette; + WHILE NOT ganzer hg gelesen REP + naechste diskette anfordern; + lies diskette + PER; + hg etikett herstellen. + +hg etikett merken: + TEXT VAR null etikett := 512 * " "; + INT VAR i; + FOR i FROM 1 UPTO 256 REP + replace (null etikett, i, ds work struct.row [i]) + PER. + +hg etikett herstellen: + FOR i FROM 1 UPTO 256 REP + ds work struct.row [i] := null etikett ISUB i + PER. + +ganzer hg gelesen: + letzte diskette gelesen CAND + (subtext (sequenz nr map, 1, letzte sequenz nr) = (letzte sequenz nr * "R")). + +naechste diskette anfordern: + diskette anfordern (""4"naechste zu lesende Hintergrunddiskette eingelegt"); + initialisiere diskettenzugriff (0, disk size); + line; + IF NOT etikett kompatibel zu null etikett + THEN error stop ("Diskette gehoert nicht zu dem bisher verarbeiteten Hintergrund") + FI. + +etikett kompatibel zu null etikett: + read and retry (ds work, ds start, 0, 1); + FOR i FROM 1 UPTO 40 REP + IF ds work struct.row [i] <> (null etikett ISUB i) + THEN LEAVE etikett kompatibel zu null etikett WITH FALSE + FI + PER; + FOR i FROM 46 UPTO 256 REP + IF ds work struct.row [i] <> (null etikett ISUB i) + THEN LEAVE etikett kompatibel zu null etikett WITH FALSE + FI + PER; + TRUE. + +lies diskette: + disketten groesse zeigen (disk size); + disk bloecke verarbeitet := 1; + INT CONST verschiebung :: ds work struct.row [44]; + INT CONST letzter disk block :: min (disk size - 1, hg bloecke zu verarbeiten - verschiebung - 1); + status zeigen; + WHILE disk bloecke verarbeitet <= letzter disk block REP + naechsten satz bloecke lesen; + status zeigen + PER; + INT CONST sequenz nr := ds work struct.row [43]; + replace (sequenz nr map, sequenz nr, "R"); + IF verschiebung + letzter disk block + 1 = hg bloecke zu verarbeiten + THEN letzte diskette gelesen := TRUE; + letzte sequenz nr := sequenz nr + FI. + +naechsten satz bloecke lesen: + read and retry (ds work, ds start + verschiebung + disk bloecke verarbeitet, + disk bloecke verarbeitet, anzahl zu lesender bloecke); + hg bloecke verarbeitet INCR anzahl zu lesender bloecke; + disk bloecke verarbeitet INCR anzahl zu lesender bloecke. + +anzahl zu lesender bloecke: + min (letzter disk block - disk bloecke verarbeitet + 1, 20). + +status zeigen: + IF online + THEN out (""13""); + putline ("Hintergrund: " + text (hg bloecke verarbeitet DIV 2, 4) + " KB gelesen"); + putline ("aktuelle Diskette: " + text (disk bloecke verarbeitet DIV 2, 4) + " KB gelesen"); + out (""3""3""13"") + FI. + +END PROC hintergrund rest lesen plus version; + +PROC hg schreiben: + disable stop; + enable hg schreiben; + forget (ds work). + +END PROC hg schreiben; + +PROC enable hg schreiben: + enable stop; + initialisiere rerun test; + hg ds namen bestimmen; + old zuweisen (ds work, ds name); + ds work struct := main (ds work); + BOOL CONST plus version :: NOT ((ds work struct.row [41] = 1) AND (ds work struct.row [42] = 0)); + informationen ausgeben (ds work, TRUE, TRUE); + line (2); + diskette anfordern ("erste zu beschreibende Diskette eingelegt"); + evtl diskette formatieren; + initialisiere diskettenzugriff (0, disk size); + disketten groesse zeigen (disk size); + hintergrund schreiben; + bei plus version ersten hg block restaurieren. + +bei plus version ersten hg block restaurieren: + ds work struct.row [43] := 0; + ds work struct.row [44] := 0; + ds work struct.row [45] := 0. + +hg ds namen bestimmen: + put ("Bitte Datenraumnamen eingeben:"); + ds name eingabe (ds name, "HG", TRUE, hg vektor); + line. + +hintergrund schreiben: + INT VAR sequenz nr := 0; + hg bloecke verarbeitet := 0; + disk bloecke verarbeitet := 0; + IF plus version + THEN hg bloecke zu verarbeiten := ds work struct.row [41] + 1 + ELSE hg bloecke zu verarbeiten := 8 * ds work struct.row [19] + FI; + giga ds size (hg bloecke zu verarbeiten + ds start); + status zeigen; + WHILE hg bloecke verarbeitet < hg bloecke zu verarbeiten REP + IF disk bloecke verarbeitet = disk size + THEN neue diskette anfordern; + bei plus version etikett schreiben + FI; + naechsten satz bloecke schreiben; + status zeigen + PER. + +neue diskette anfordern: + diskette anfordern (""4"nächste zu beschreibende Diskette eingelegt"); + evtl diskette formatieren; + initialisiere disketten zugriff (0, disk size); + disketten groesse zeigen (disk size); + disk bloecke verarbeitet := 0. + +bei plus version etikett schreiben: + IF plus version + THEN sequenz nr INCR 1; + ds work struct.row [43] := sequenz nr; + ds work struct.row [44] := hg bloecke verarbeitet - 1; + ds work struct.row [45] := 0; + write and retry (ds work, ds start, 0, 1); + disk bloecke verarbeitet := 1 + FI. + +naechsten satz bloecke schreiben: + bestimme anzahl zu schreibender bloecke; + write and retry (ds work, ds start + hg bloecke verarbeitet, + disk bloecke verarbeitet, anzahl zu schreibender bloecke); + hg bloecke verarbeitet INCR anzahl zu schreibender bloecke; + disk bloecke verarbeitet INCR anzahl zu schreibender bloecke. + +bestimme anzahl zu schreibender bloecke: + INT CONST anzahl zuschreibender bloecke :: min (moegliche hg bloecke auf disk, 20). + +moegliche hg bloecke auf disk: + min (hg bloecke zu verarbeiten - hg bloecke verarbeitet, + disk size - disk bloecke verarbeitet). + +status zeigen: + IF online + THEN out (""13""); + putline ("Hintergrund: " + text (hg bloecke verarbeitet DIV 2, 4) + " KB geschrieben"); + putline ("aktuelle Diskette: " + text (disk bloecke verarbeitet DIV 2, 4) + " KB geschrieben"); + out (""3""3""13"") + FI. + +END PROC enable hg schreiben; + +PROC hg check sum: + disable stop; + enable hg check sum; + forget (check ds). + +END PROC hg check sum; + +PROC enable hg check sum: + enable stop; + initialisiere rerun test; + check ds := nilspace; + ds work struct := check ds; + diskette anfordern ("erste Hintergrunddiskette eingelegt"); + initialisiere disketten zugriff (0, disk size); + relevante bloecke lesen; + hg etikett merken; + informationen ausgeben (check ds, TRUE, TRUE); + line (2); + check sum namen bestimmen; + hintergrund check sum berechnen; + check summe abspeichern (ds name, check ds). + +relevante bloecke lesen: + read and retry (check ds, ds start, 0, 1); + read and retry (check ds, ds start + 10, 10, 1). + +hg etikett merken: + TEXT VAR null etikett := 512 * " "; + INT VAR i; + FOR i FROM 1 UPTO 256 REP + replace (null etikett, i, ds work struct.row [i]) + PER. + +check sum namen bestimmen: + putline ("bitte Dateinamen zum abspeichern der Prüf-Summe angeben:"); + ds name eingabe (ds name, "prüf.HG", FALSE, ""); + line. + +hintergrund check sum berechnen: + BOOL CONST plus version :: NOT ((ds work struct.row [41] = 1) AND (ds work struct.row [42] = 0)); + IF plus version + THEN hg bloecke zu verarbeiten := ds work struct.row [41] + 1 + ELSE hg bloecke zu verarbeiten := 8 * ds work struct.row [19] + FI; + INT VAR sequenz nr := 0; + hg bloecke verarbeitet := 0; + disk bloecke verarbeitet := 0; + initialisiere check read (check ds); + disketten groesse zeigen (disk size); + status zeigen; + WHILE hg bloecke verarbeitet < hg bloecke zu verarbeiten REP + IF disk bloecke verarbeitet = disk size + THEN neue diskette anfordern + FI; + naechsten satz bloecke lesen; + status zeigen + PER. + +neue diskette anfordern: + diskette anfordern (""4"nächste Hintergrunddiskette eingelegt"); + initialisiere disketten zugriff (0, disk size); + line; + disketten groesse zeigen (disk size); + sequenz nr INCR 1; + IF plus version + THEN disk bloecke verarbeitet := 1; + read and retry (check ds, ds start, 0, 1); + IF NOT etikett kompatibel zu null etikett + THEN error stop ("Diskette gehoert nicht zu dem bisher verarbeiteten Hintergrund") + FI; + IF ds work struct.row [43] <> sequenz nr + THEN error stop ("Falsche Reihenfolge der HG Disketten") + FI + ELSE disk bloecke verarbeitet := 0 + FI. + +etikett kompatibel zu null etikett: + read and retry (check ds, ds start, 0, 1); + FOR i FROM 1 UPTO 40 REP + IF ds work struct.row [i] <> (null etikett ISUB i) + THEN LEAVE etikett kompatibel zu null etikett WITH FALSE + FI + PER; + FOR i FROM 46 UPTO 256 REP + IF ds work struct.row [i] <> (null etikett ISUB i) + THEN LEAVE etikett kompatibel zu null etikett WITH FALSE + FI + PER; + TRUE. + +naechsten satz bloecke lesen: + bestimme anzahl zu lesender bloecke; + check read and retry (check ds, disk bloecke verarbeitet, anzahl zu lesender bloecke); + hg bloecke verarbeitet INCR anzahl zu lesender bloecke; + disk bloecke verarbeitet INCR anzahl zu lesender bloecke. + +bestimme anzahl zu lesender bloecke: + INT CONST anzahl zulesender bloecke :: min (moegliche hg bloecke auf disk, 20). + +moegliche hg bloecke auf disk: + min (hg bloecke zu verarbeiten - hg bloecke verarbeitet, + disk size - disk bloecke verarbeitet). + +status zeigen: + IF online + THEN out (""13""); + putline ("Hintergrund: " + text (hg bloecke verarbeitet DIV 2, 4) + " KB verarbeitet"); + putline ("aktuelle Diskette: " + text (disk bloecke verarbeitet DIV 2, 4) + " KB verarbeitet"); + out (""3""3""13"") + FI. + +END PROC enable hg check sum; + +END PACKET copy hg; +PACKET urlader copy DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + (* 22.08.86 *) + urlader check sum, + urlader von datenraum auf leere diskette schreiben, + urlader von datenraum auf hg diskette schreiben, + urlader von diskette in hg datenraum lesen, + urlader von diskette in leeren datenraum lesen: + +TEXT VAR ds name := ""; + +TEXT VAR hg urlader vektor := " "; replace (hg urlader vektor, 1, hg type); + replace (hg urlader vektor, 2, urlader type); + +INT VAR disk size; + +BOUND STRUCT (ROW 252 INT align, ROW 10240 INT row) VAR ds struct; +DATASPACE VAR ds work := nilspace; forget (ds work); +DATASPACE VAR ds test := nilspace; forget (ds test); + +PROC urlader von diskette in hg datenraum lesen: + urlader lesen (FALSE) + +END PROC urlader von diskette in hg datenraum lesen; + +PROC urlader von diskette in leeren datenraum lesen: + urlader lesen (TRUE) + +END PROC urlader von diskette in leeren datenraum lesen; + +PROC urlader lesen (BOOL CONST in leeren ds): + disable stop; + enable urlader lesen (in leeren ds); + forget (ds work). + +END PROC urlader lesen; + +PROC enable urlader lesen (BOOL CONST in leeren ds): + enable stop; + initialisiere rerun test; + diskette anfordern ("Urlader-Diskette eingelegt"); + ersten urlader block lesen; + informationen ausgeben (ds work, FALSE, TRUE); + INT VAR urlader blocks := ds struct.row [2569]; + IF motorola format + THEN rotate (urlader blocks, 8) + FI; + line (2); + ds work namen bestimmen; + ds work neu initialisieren; + urlader rest lesen; + IF exists (ds name) THEN forget (ds name, quiet) FI; + copy (ds work, ds name). + +ersten urlader block lesen: + ds work := nilspace; + ds struct := ds work; + initialisiere disketten zugriff (0, disk size); + read (ds work, ds start + 10, 10, 1). + +motorola format: + ds struct.row [2571] = 1024. + +ds work namen bestimmen: + put ("bitte Datenraumnamen angeben:"); + IF in leeren ds + THEN ds name eingabe (ds name, "URLADER", FALSE, "") + ELSE ds name eingabe (ds name, "", TRUE, hg urlader vektor) + FI; + line. + +ds work neu initialisieren: + IF NOT in leeren ds + THEN forget (ds work); + ds work := old (ds name); + ds struct := ds work; + INT VAR space := ds struct.row [2569]; + IF motorola format + THEN rotate (space, 8) + FI; + IF space < urlader blocks + THEN error stop ("Lücke für Urlader im Datenraum zu klein") + FI + ELSE type (ds work, urlader type) + FI. + +urlader rest lesen: + INT VAR urlader bloecke verarbeitet := 0; + status zeigen; + WHILE urlader bloecke verarbeitet < urlader blocks REP + naechsten satz bloecke lesen; + status zeigen + PER. + +naechsten satz bloecke lesen: + read and retry (ds work, ds start + 10 + urlader bloecke verarbeitet, + 10 + urlader bloecke verarbeitet, anzahl zu lesender bloecke); + urlader bloecke verarbeitet INCR anzahl zu lesender bloecke. + +anzahl zu lesender bloecke: + min (urlader blocks - urlader bloecke verarbeitet, 20). + +status zeigen: + IF online + THEN out (""13""); + putline (text (urlader bloecke verarbeitet DIV 2, 4) + " KB gelesen"); + out (""3""13"") + FI. + +END PROC enable urlader lesen; + +PROC urlader von datenraum auf leere diskette schreiben: + urlader schreiben (TRUE) + +END PROC urlader von datenraum auf leere diskette schreiben; + +PROC urlader von datenraum auf hg diskette schreiben: + urlader schreiben (FALSE) + +END PROC urlader von datenraum auf hg diskette schreiben; + +PROC urlader schreiben (BOOL CONST auf leere disk): + disable stop; + enable urlader schreiben (auf leere disk); + forget (ds test); + forget (ds work). + +END PROC urlader schreiben; + +PROC enable urlader schreiben (BOOL CONST auf leere disk): + enable stop; + initialisiere rerun test; + urlader ds namen bestimmen; + ds work := old (ds name); + ds struct := ds work; + INT VAR urlader blocks := ds struct.row [2569]; + IF motorola format + THEN rotate (urlader blocks, 8) + FI; + informationen ausgeben (ds work, FALSE, TRUE); + line (2); + diskette anfordern ("zu beschreibende Diskette eingelegt"); + IF auf leere disk + THEN evtl diskette formatieren; + initialisiere diskettenzugriff (0, disk size) + ELSE initialisiere diskettenzugriff (0, disk size); + platz fuer urlader ueberpruefen + FI; + urlader schreiben. + +urlader ds namen bestimmen: + put ("Bitte Datenraumnamen eingeben:"); + ds name eingabe (ds name, "", TRUE, hg urlader vektor); + line. + +motorola format: + ds struct.row [2571] = 1024. + +platz fuer urlader ueberpruefen: + TEXT CONST eumel kennzeichen :: "EUMEL-"; + INT CONST eumel kennzeichen wort 0 :: eumel kennzeichen ISUB 1, + eumel kennzeichen wort 1 :: eumel kennzeichen ISUB 2, + eumel kennzeichen wort 2 :: (eumel kennzeichen ISUB 3) AND 255; + ds test := nilspace; + ds struct := ds test; + read and retry (ds test, 2, 0, 1); + IF plus hg CAND sequenznummer falsch + THEN error stop ("Die eingelegte Diskette ist nicht erste Diskette eines Hintergrundes") + FI; + read and retry (ds test, 2, 10, 1); + IF NOT diskette enthaelt urlader COR luecke zu klein + THEN error stop ("Nicht genug Platz auf der Diskette; Urlader kann nicht geschrieben werden.") + FI. + +plus hg: + NOT ((ds struct.row [41] = 1) AND (ds struct.row [42] = 0)). + +sequenznummer falsch: + ds struct.row [43] <> 0. + +diskette enthaelt urlader: + (eumelkennzeichen wort 0 = ds struct.row [1]) AND + (eumelkennzeichen wort 1 = ds struct.row [2]) AND + (eumelkennzeichen wort 2 = (ds struct.row [3] AND 255)). + +luecke zu klein: + urlader blocks > ds struct.row [9]. + +urlader schreiben: + INT VAR urlader bloecke verarbeitet := 0; + status zeigen; + WHILE urlader bloecke verarbeitet < urlader blocks REP + naechsten satz bloecke schreiben; + status zeigen + PER. + +naechsten satz bloecke schreiben: + write and retry (ds work, ds start + 10 + urlader bloecke verarbeitet, + 10 + urlader bloecke verarbeitet, anzahl zu schreibender bloecke); + + urlader bloecke verarbeitet INCR anzahl zu schreibender bloecke. + +anzahl zu schreibender bloecke: + min (urlader blocks - urlader bloecke verarbeitet, 20). + +status zeigen: + IF online + THEN out (""13""); + putline (text (urlader bloecke verarbeitet DIV 2, 4) + " KB geschrieben"); + out (""3""13"") + FI. + +END PROC enable urlader schreiben; + +PROC urlader check sum: + disable stop; + enable urlader check sum; + forget (ds work). + +END PROC urlader check sum; + +PROC enable urlader check sum: + enable stop; + initialisiere rerun test; + ds work := nilspace; + ds struct := ds work; + diskette anfordern ("zu überprüfende Diskette eingelegt"); + relevante bloecke lesen; + INT VAR urlader blocks := ds struct.row [2569]; + IF motorola format + THEN rotate (urlader blocks, 8) + FI; + informationen ausgeben (ds work, FALSE, TRUE); + line (2); + check sum namen bestimmen; + urlader check sum berechnen; + check summe abspeichern (ds name, ds work). + +motorola format: + ds struct.row [2571] = 1024. + +relevante bloecke lesen: + initialisiere disketten zugriff (0, disk size); + read (ds work, ds start + 10, 10, 1). + +check sum namen bestimmen: + putline ("bitte Dateinamen zum abspeichern der Prüf-Summe angeben:"); + ds name eingabe (ds name, "prüf.URLADER", FALSE, ""). + +urlader check sum berechnen: + line; + INT VAR urlader bloecke verarbeitet := 0; + initialisiere check read (ds work); + status zeigen; + WHILE urlader bloecke verarbeitet < urlader blocks REP + naechsten satz bloecke lesen; + status zeigen + PER. + +naechsten satz bloecke lesen: + check read and retry (ds work, 10 + urlader bloecke verarbeitet, + anzahl zu lesender bloecke); + urlader bloecke verarbeitet INCR anzahl zu lesender bloecke. + +anzahl zu lesender bloecke: + min (urlader blocks - urlader bloecke verarbeitet, 20). + +status zeigen: + IF online + THEN out (""13""); + putline (text (urlader bloecke verarbeitet DIV 2, 4) + " KB gelesen"); + out (""3""13"") + FI. + +END PROC enable urlader check sum; + +END PACKET urlader copy; +PACKET copy dump DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + show blocks: (* 11.07.86 *) + +TYPE BLOCK = BOUND STRUCT (ALIGN dummy, ROW 64 REAL block row); + +BLOCK VAR block; + +DATASPACE VAR block ds; + +TEXT VAR line text := 16 * "*"; + +INITFLAG VAR this packet := FALSE; + +INT VAR disk size; + +INT VAR block nr; + +TEXT VAR command; + +PROC show blocks: + enable stop; + initialisiere rerun test; + access block space; + block nr := 0; + diskette anfordern ("Diskette eingelegt"); + initialisiere diskettenzugriff (0, disk size); + disketten groesse zeigen (disk size); + REP get command; + execute command + UNTIL end command + PER. + +access block space: + IF NOT initialized (this packet) + THEN block ds := nilspace + FI. + +get command: + line; + putline ("'+' nächsten Block zeigen 'q' Dump-Modus verlassen"); + putline ("'-' vorhergehenden Block zeigen <nr> Block <nr> zeigen"); + put (">"); + get (command); + command := compress (command); + line. + +end command: + ((command SUB 1) = "q") OR ((command SUB 1) = "Q"). + +execute command: + IF (command SUB 1) = "+" + THEN block nr INCR 1; + block zeigen + ELIF (command SUB 1) = "-" + THEN block nr DECR 1; + block zeigen; + ELIF (command SUB 1) = "q" OR (command SUB 1) = "Q" + THEN (* no op *) + ELSE INT VAR dummy := int (command); + IF last conversion ok + THEN block nr := dummy; + block zeigen + ELSE putline ("unzulässiges Kommando"); + line + FI + FI. + +END PROC show blocks; + +PROC block zeigen: + block nr ueberpruefen; + block lesen; + CONCR (block) := block ds; + INT VAR zeile; + FOR zeile FROM 0 UPTO 31 REP + zeile zeigen + PER. + +block nr ueberpruefen: + IF block nr >= disk size + THEN putline ("Blocknummer zu hoch (maximal " + text (disk size -1) + ")"); + block nr := disk size - 1; + LEAVE block zeigen + ELIF block nr < 0 + THEN putline ("negative Blocknummer ist nicht erlaubt"); + block nr := 0; + LEAVE block zeigen + FI. + +block lesen: + read and retry (block ds, 2, block nr, 1). + +zeile zeigen: + replace (line text, 1, block.block row [2 * zeile + 1]); + replace (line text, 2, block.block row [2 * zeile + 2]); + TEXT VAR dump line := text (block nr, 4) + ":" + text (zeile * 16, 3) + " "; + TEXT VAR char line := ""; + INT VAR spalte; + FOR spalte FROM 1 UPTO 8 REP + cat char; + dump line CAT " " + PER; + dump line CAT " "; + FOR spalte FROM 9 UPTO 16 REP + cat char; + dump line CAT " " + PER; + dump line CAT " "; + dump line CAT charline; + IF incharety = ""27"" + THEN LEAVE block zeigen + FI; + putline (dump line). + +cat char: + INT CONST char code := code (char); + LET hex chars = "0123456789ABCDEF"; + dumpline CAT (hex chars SUB (char code DIV 16 + 1)); + dumpline CAT (hex chars SUB (char code MOD 16 + 1)); + charline CAT show char. + +show char: + IF (char code > 31 AND char code < 127) + THEN code (char code) + ELSE "." + FI. + +char: + line text SUB spalte. + +END PROC block zeigen; + +END PACKET copy dump; +PACKET copy diskette DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + diskette lesen, (* 11.07.86 *) + diskette schreiben, + diskette check sum: + +TEXT VAR disk type vektor := " "; replace (disk type vektor, 1, disk type); + +TEXT VAR ds name := ""; + +INT VAR disk size; + +BOUND ROW 252 INT VAR ds work row; +DATASPACE VAR ds work := nilspace; forget (ds work); + +PROC diskette lesen: + disable stop; + enable diskette lesen; + forget (ds work). + +END PROC diskette lesen; + +PROC enable diskette lesen: + enable stop; + initialisiere rerun test; + ds work := nilspace; + ds work row := ds work; + type (ds work, disk type); + diskette anfordern ("zu lesende Diskette eingelegt"); + initialisiere disketten zugriff (0, disk size); + disketten groesse zeigen (disk size); + ds work namen bestimmen; + diskette lesen; + size feld schreiben; + copy (ds work, ds name). + +size feld schreiben: + ds work row := ds work; + ds work row [size feld] := disk size. + +ds work namen bestimmen: + ds name := ""; + put ("bitte Datenraumnamen angeben:"); + ds name eingabe (ds name, "", FALSE, ""); + line. + +diskette lesen: + INT VAR disk bloecke verarbeitet := 0; + status zeigen; + WHILE disk bloecke verarbeitet < disk size REP + naechsten satz bloecke lesen; + status zeigen + PER. + +naechsten satz bloecke lesen: + read and retry (ds work, ds start + disk bloecke verarbeitet, disk bloecke verarbeitet, + anzahl zu lesender bloecke); + disk bloecke verarbeitet INCR anzahl zu lesender bloecke. + +anzahl zu lesender bloecke: + min (disk size - disk bloecke verarbeitet, 20). + +status zeigen: + IF online + THEN out (""13""); + putline (text (disk bloecke verarbeitet DIV 2, 4) + " KB gelesen"); + out (""3""13"") + FI. + +END PROC enable diskette lesen; + +PROC diskette schreiben: + disable stop; + enable diskette schreiben; + forget (ds work). + +END PROC diskette schreiben; + +PROC enable diskette schreiben: + enable stop; + initialisiere rerun test; + disk ds namen bestimmen; + ds work := old (ds name); + ds work row := ds work; + diskette anfordern ("zu beschreibende Diskette eingelegt"); + evtl diskette formatieren; + initialisiere diskettenzugriff (0, disk size); + disketten groesse zeigen (disk size); + diskettengroesse ueberpruefen; + diskette schreiben. + +disk ds namen bestimmen: + put ("Bitte Datenraumnamen eingeben:"); + ds name eingabe (ds name, "", TRUE, disk type vektor); + line. + +diskettengroesse ueberpruefen: + IF ds work row [size feld] <> disk size + THEN putline (""7"ERROR: Datenraum enthält nicht genau eine Diskette"); + putline (" evtl. Menuepunkt 'Teil einer Diskette kopieren' verwenden"); + pause (30); + error stop ("Datenraum enthält nicht genau eine Diskette") + FI. + +diskette schreiben: + INT VAR disk bloecke verarbeitet := 0; + status zeigen; + WHILE disk bloecke verarbeitet < ds work row [size feld] REP + naechsten satz bloecke schreiben; + status zeigen + PER. + +naechsten satz bloecke schreiben: + write and retry (ds work, ds start + disk bloecke verarbeitet, disk bloecke verarbeitet, + anzahl zu schreibender bloecke); + disk bloecke verarbeitet INCR anzahl zu schreibender bloecke. + +anzahl zu schreibender bloecke: + min (ds work row [size feld] - disk bloecke verarbeitet, 20). + +status zeigen: + IF online + THEN out (""13""); + putline (text (disk bloecke verarbeitet DIV 2, 4) + " KB geschrieben"); + out (""3""13"") + FI. + +END PROC enable diskette schreiben; + +PROC diskette check sum: + disable stop; + enable diskette check sum; + forget (ds work). + +END PROC diskette check sum; + +PROC enable diskette check sum: + enable stop; + ds work := nilspace; + ds work row := ds work; + TEXT VAR name := ""; + initialisiere rerun test; + diskette anfordern ("zu überprüfende Diskette eingelegt"); + check sum namen bestimmen; + initialisiere diskettenzugriff (0, disk size); + disketten groesse zeigen (disk size); + check summe berechnen; + check summe abspeichern (name, ds work). + +check sum namen bestimmen: + putline ("bitte Dateinamen zum abspeichern der Prüfsumme angeben:"); + ds name eingabe (name, "prüf.", FALSE, ""); + line. + +check summe berechnen: + INT VAR disk bloecke verarbeitet := 0; + status zeigen; + initialisiere check read (ds work); + WHILE disk bloecke verarbeitet < disk size REP + naechsten satz bloecke lesen; + status zeigen + PER. + +naechsten satz bloecke lesen: + check read and retry (ds work, disk bloecke verarbeitet, anzahl zu lesender bloecke); + disk bloecke verarbeitet INCR anzahl zu lesender bloecke. + +anzahl zu lesender bloecke: + min (disk size - disk bloecke verarbeitet, 20). + +status zeigen: + IF online + THEN out (""13""); + putline (text (disk bloecke verarbeitet DIV 2, 4) + " KB verarbeitet"); + out (""3""13"") + FI. + +END PROC enable diskette check sum; + +END PACKET copy diskette; +PACKET copy disk part DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + disk part lesen, (* 31.07.86 *) + disk part schreiben, + disk part check sum: + +TEXT VAR disk type vektor := " "; replace (disk type vektor, 1, disk type); + +TEXT VAR ds name := ""; + +INT VAR disk size; +INT VAR von sektor, bis sektor; + +BOUND ROW 252 INT VAR ds work row; +DATASPACE VAR ds work := nilspace; forget (ds work); + +PROC disk part lesen: + disable stop; + enable disk part lesen; + forget (ds work). + +END PROC disk part lesen; + +PROC enable disk part lesen: + enable stop; + initialisiere rerun test; + ds work := nilspace; + ds work row := ds work; + type (ds work, disk type); + diskette anfordern ("zu lesende Diskette eingelegt"); + initialisiere disketten zugriff (0, disk size); + disketten groesse zeigen (disk size); + grenzen bestimmen (disk size); + ds work namen bestimmen; + disk part lesen; + size feld schreiben; + copy (ds work, ds name). + +ds work namen bestimmen: + ds name := ""; + put ("bitte Datenraumnamen angeben:"); + ds name eingabe (ds name, "", FALSE, ""); + line. + +size feld schreiben: + ds work row := ds work; + ds work row [size feld] := bis sektor - von sektor + 1. + +disk part lesen: + INT VAR disk bloecke verarbeitet := 0; + status zeigen; + WHILE disk bloecke verarbeitet < bis sektor - von sektor + 1 REP + naechsten satz bloecke lesen; + status zeigen + PER. + +naechsten satz bloecke lesen: + read and retry (ds work, ds start + disk bloecke verarbeitet, von sektor + disk bloecke verarbeitet, + anzahl zu lesender bloecke); + disk bloecke verarbeitet INCR anzahl zu lesender bloecke. + +anzahl zu lesender bloecke: + min (bis sektor - von sektor + 1 - disk bloecke verarbeitet, 20). + +status zeigen: + IF online + THEN out (""13""); + putline (text (disk bloecke verarbeitet, 4) + " Sektoren gelesen"); + out (""3""13"") + FI. + +END PROC enable disk part lesen; + +PROC disk part schreiben: + disable stop; + enable disk part schreiben; + forget (ds work). + +END PROC disk part schreiben; + +PROC enable disk part schreiben: + enable stop; + initialisiere rerun test; + disk ds namen bestimmen; + ds work := old (ds name); + ds work row := ds work; + diskette anfordern ("zu beschreibende Diskette eingelegt"); + evtl diskette formatieren; + initialisiere diskettenzugriff (0, disk size); + disketten groesse zeigen (disk size); + grenzen bestimmen (ds work row [size feld]); + disk part schreiben. + +disk ds namen bestimmen: + put ("Bitte Datenraumnamen eingeben:"); + ds name eingabe (ds name, "", TRUE, disk type vektor); + line. + +disk part schreiben: + INT VAR disk bloecke verarbeitet := 0; + INT CONST disk bloecke zu verarbeiten :: bis sektor - von sektor + 1; + status zeigen; + WHILE disk bloecke verarbeitet < disk bloecke zu verarbeiten REP + naechsten satz bloecke schreiben; + status zeigen + PER. + +naechsten satz bloecke schreiben: + write and retry (ds work, ds start + disk bloecke verarbeitet, von sektor + disk bloecke verarbeitet, + anzahl zu schreibender bloecke); + disk bloecke verarbeitet INCR anzahl zu schreibender bloecke. + +anzahl zu schreibender bloecke: + min (disk bloecke zu verarbeiten - disk bloecke verarbeitet, 20). + +status zeigen: + IF online + THEN out (""13""); + putline (text (disk bloecke verarbeitet, 4) + " Sektoren geschrieben"); + out (""3""13"") + FI. + +END PROC enable disk part schreiben; + +PROC disk part check sum: + disable stop; + enable disk part check sum; + forget (ds work). + +END PROC disk part check sum; + +PROC enable disk part check sum: + enable stop; + initialisiere rerun test; + ds work := nilspace; + diskette anfordern ("zu überprüfende Diskette eingelegt"); + initialisiere disketten zugriff (0, disk size); + disketten groesse zeigen (disk size); + grenzen bestimmen (disk size); + check sum namen bestimmen; + check sum berechnen; + check summe abspeichern (ds name, ds work). + +check sum namen bestimmen: + putline ("bitte Dateinamen zum abspeichern der Prüf-Summe angeben:"); + ds name eingabe (ds name, "prüf.", FALSE, ""); + line. + +check sum berechnen: + INT VAR disk bloecke verarbeitet := 0; + initialisiere check read (ds work); + status zeigen; + WHILE disk bloecke verarbeitet < bis sektor - von sektor + 1 REP + naechsten satz bloecke lesen; + status zeigen + PER. + +naechsten satz bloecke lesen: + check read and retry (ds work, von sektor + disk bloecke verarbeitet, anzahl zu lesender bloecke); + disk bloecke verarbeitet INCR anzahl zu lesender bloecke. + +anzahl zu lesender bloecke: + min (bis sektor - von sektor + 1 - disk bloecke verarbeitet, 20). + +status zeigen: + IF online + THEN out (""13""); + putline (text (disk bloecke verarbeitet, 4) + " Sektoren gelesen"); + out (""3""13"") + FI. + +END PROC enable disk part check sum; + +PROC disketten groesse zeigen (INT CONST blocks): + putline ("die eingelegte Diskette enthält die Sektoren 0 bis " + text (blocks - 1)); + line. + +END PROC disketten groesse zeigen; + +PROC grenzen bestimmen (INT CONST max anz bloecke): + INT VAR x,y; + REP + TEXT VAR ein := "0"; + put ("erster Sektor:"); + get cursor (x, y); + editget (ein); + von sektor := max (0, int (ein)); + cursor (x, y); + out (""5""); + put (von sektor); + line; + put ("letzter Sektor:"); + get cursor (x, y); + ein := text (min (disk size - 1, von sektor + max anz bloecke - 1)); + editget (ein); +(**)bis sektor := min (von sektor + max anz bloecke - 1, int (ein)); +(**)bis sektor := min (disk size - 1, bis sektor); + cursor (x, y); + out (""5""); + put (bis sektor); + line + UNTIL yes ("Eingaben richtig") + PER; + line. + +END PROC grenzen bestimmen; + +END PACKET copy disk part; +PACKET menu handler DEFINES (* Autor: J.Liedtke *) + (* R.Ruland *) + (* Stand: 13.05.86 *) + menu monitor , + menu out , + next menu , + menu param , + set menu param , + additional param , + clear free lines , + show key functions : + + +LET menu width = 77 , + date pos = 50 , + time pos = 63 , + menu indent = 6 , + separate line = 18 , + first free line = 19 , + max number of menu cases = 17 , + + blank = " " , + left = ""8"" , + up = ""3"" , + down = ""10"" , + return= ""13"" , + hop = ""1"" , + bell = ""7"" , + quote = """" , + clear to end of line = ""5"" , + clear to end of page = ""4"" ; + +TEXT VAR param 1 := "" , param 2 , + menu case list := "" , + menu case := "", char := "", + last date := ""; + +BOOL VAR screen changed, show keys ; + + +PROC next menu : + + screen changed := TRUE + +ENDPROC next menu ; + +PROC next menu (TEXT CONST key list) : + + next menu (key list, "") + +ENDPROC next menu ; + +PROC next menu (TEXT CONST key list, std case) : + + IF pos (key list, code (33), code (255), 1) > 0 + OR pos (key list, code (0), code (31), 1) > 0 + THEN menu case list := subtext (key list, 1, max number of menu cases) ; + FI; + menu case := std case ; + screen changed := TRUE ; + +ENDPROC next menu ; + + +PROC clear free lines : + + cursor (1, first free line) ; + out (clear to end of page) . + +ENDPROC clear free lines; + + +PROC show key functions : + + show keys := TRUE; + +END PROC show key functions; + + +PROC menu monitor (PROC (TEXT CONST) board , + PROC (TEXT CONST) execute , + TEXT CONST escape char) : + + disable stop ; + page ; + next menu ; + show key functions; + REP + show menu (PROC (TEXT CONST) board) ; + screen changed := FALSE ; + show keys := FALSE; + select menu case (escape char) ; + clear free lines ; + IF is valid menu case AND char <> hop + THEN menu execute (PROC (TEXT CONST) execute) + FI + UNTIL menu escape occurred PER . + +is valid menu case : pos (menu case list, menu case) > 0 . + +menu escape occurred : menu case = escape char . + +ENDPROC menu monitor ; + + +PROC show menu (PROC (TEXT CONST) board) : + + IF is error + THEN show error ; + clear error + FI ; + IF screen changed + THEN show menu cases + FI ; + IF show keys + THEN explain keys; + FI . + +show error : + IF less than three lines left + THEN screen changed := TRUE + FI ; + clear free lines ; + put error . + +less than three lines left : + INT VAR x, y; + get cursor (x, y) ; + y >= 22 . + +show menu cases : + clear board ; + INT VAR i ; + FOR i FROM 1 UPTO LENGTH menu case list REP + cursor (menu indent, i) ; + IF (menu case list SUB i) <> " " THEN board (menu case list SUB i) FI; + PER ; + out (hop) ; + 4 TIMESOUT " " . + +clear board : + out (hop) ; + FOR i FROM 1 UPTO max number of menu cases REP + out (clear to end of line) ; + out (down) + PER ; + cursor (1, separate line); + out (clear to end of line) ; + menu width TIMESOUT "-" ; + put date ; + put time . + +ENDPROC show menu ; + +PROC menu out (TEXT CONST menu line) : + + tab cursor ; + INT VAR from := 1, to := pos (menu line, quote) - 1 ; + IF param 1 <> "" + THEN WHILE to >= 0 REP + menu outsubtext (menu line, from, to) ; + menu outsubtext (quote, 1, 1) ; + menu outsubtext (param 1, 1, LENGTH param 1) ; + menu outsubtext (quote, 1, 1) ; + from := to + 2 ; + to := pos (menu line, quote, from) - 1 + PER ; + FI; + menu outsubtext (menu line, from, LENGTH menu line) ; + out (blank) . + +tab cursor : + INT VAR x, y; + get cursor (x, y) ; + IF x > menu indent AND x < menu width - 15 + THEN cursor ( (x-menu indent+14) DIV 15 * 15 + menu indent, y) + FI . + +ENDPROC menu out ; + +PROC menu outsubtext (TEXT CONST t, INT CONST from, to) : + + outsubtext (t, from, min (menu width-cursor x, to-from) + from) . + +cursor x : + INT VAR x, y ; + get cursor (x, y) ; + x . + +ENDPROC menu outsubtext ; + +PROC put date : + + INT VAR x, y; + get cursor (x, y); + cursor (date pos, separate line); + last date := date; + out (" "); + out (date); + out (" "); + cursor (x, y); + +END PROC put date; + +PROC put time : + + INT VAR x, y; + get cursor (x, y); + cursor (time pos, separate line); + out (" "); + out (time of day); + out (" "); + IF last date <> date THEN put date FI; + cursor (x, y); + +END PROC put time; + +PROC select menu case (TEXT CONST escape char) : + + enable stop; + INT VAR menu index := pos (menu case list, menu case); + get default menu case ; + REP + REP UNTIL incharety = "" PER; + point to case ; + get char ; + IF char = blank OR char = down THEN menu down + ELIF char = up THEN menu up + ELIF char = return THEN leave and execute + ELIF char = hop THEN leave and show new board + ELIF char = escape char OR + pos (menu case list, char) > 0 THEN menu index := + pos (menu case list, char); + menu case := char ; + leave and execute + ELSE not allowed key + FI + PER . + +get default menu case : + IF LENGTH menu case <> 1 OR menu case = " " OR menu index = 0 + THEN menu index := 0; + WHILE menu index < LENGTH menu case list + REP menu index INCR 1; + menu case := menu case list SUB menu index; + IF menu case <> " " THEN LEAVE get default menu case FI; + PER; + FI . + +get char : + REP char := incharety (600) ; + put time ; + UNTIL char <> "" PER . + +menu down : + REP menu index := menu index MOD cases + 1; + menu case := menu case list SUB menu index; + UNTIL menu case <> " " PER . + +menu up : + REP menu index := (menu index - 2) MOD cases + 1; + menu case := menu case list SUB menu index; + UNTIL menu case <> " " PER . + +cases : LENGTH menu case list . + +point to case : + 4 TIMESOUT left ; 4 TIMESOUT blank ; + cursor (menu indent-4, menu index) ; + out ("--> ") . + +leave and execute : + point to case ; + cursor (menu indent, first free line) ; + LEAVE select menu case . + +leave and show new board : + next menu ; + show key functions; + LEAVE select menu case . + +not allowed key : + out (bell) ; + explain keys . + +ENDPROC select menu case ; + + +PROC explain keys : + clear free lines; + putline ("""-->"" - Funktion ausfuehren : <RETURN>") ; + putline ("andere Funktion anwaehlen : <UP> <DOWN> <BLANK>") ; + out ("direkt anwaehlen und ausfuehren :") ; + show menu case list ; + putline ("Menutafel neu aufbauen : <HOP>") ; + out (hop) ; + 4 TIMESOUT " " . + +show menu case list : + INT VAR i, j := 0; + FOR i FROM 1 UPTO LENGTH menu case list REP + IF j = 8 + THEN line ; 33 TIMESOUT blank; j INCR 1; + FI ; + show one menu case + PER ; + line . + +show one menu case : + IF (menu case list SUB i) > " " + THEN out (" <") ; out (menu case list SUB i) ; out (">") ; j INCR 1 + FI . + +END PROC explain keys; + + +PROC menu execute (PROC (TEXT CONST) execute) : + + enable stop ; + execute (menu case) + +ENDPROC menu execute ; + + +TEXT PROC menu param : + + param 1 + +ENDPROC menu param ; + +PROC set menu param (TEXT CONST param) : + + param 1 := param + +ENDPROC set menu param ; + +TEXT PROC menu param (TEXT CONST prompt) : + + get param (prompt, param 1) ; + param 1 + +ENDPROC menu param ; + +TEXT PROC additional param (TEXT CONST prompt) : + + param 2 := "" ; + get param (prompt, param 2) ; + param 2 + +ENDPROC additional param ; + +PROC additional param (TEXT CONST prompt, TEXT VAR param) : + + get param (prompt, param) ; + param 2 := param; + +ENDPROC additional param ; + +PROC get param (TEXT CONST prompt, TEXT VAR param) : + + cursor (menu indent, first free line) ; + out prompt ; + out (blank) ; + in param ; + cursor (menu indent, first free line) ; + out (clear to end of line) . + +out prompt : + INT CONST + prompt length := min (LENGTH prompt, menu width DIV 2 - menu indent) ; + outsubtext (prompt, 1, prompt length) . + +in param : + editget (param, 255, menu width - menu indent - prompt length - 2) . + +ENDPROC get param ; + +ENDPACKET menu handler ; +PACKET copy menu DEFINES copy: (* Copyright (C) 1986 *) + (* Frank Klapper *) +LET haupt menu = 1, (* 11.07.86 *) + copy hg menu = 2, + disk copy menu = 3, + disk part copy menu = 4, + urlader copy menu = 5; + +LET MENU = STRUCT (TEXT board keys, board); + +ROW 5 MENU VAR menu; + +menu [haupt menu] := MENU: ("hudtDke"9"", " hu dt D k e "9" "); +menu [copy hg menu] := MENU: ("lspPLiI"9"", " ls pP L iI "9" "); +menu [urlader copy menu] := MENU: ("lLsSpPziI"9"", " lL sS pP z iI "9""); +menu [disk copy menu] := MENU: ("lspPL"9"", " ls pP L "9" "); +menu [disk part copy menu] := MENU: ("lspPL"9"", " ls pP L "9" "); + +INT VAR board index; + +TEXT VAR kommando := ""; + +PROC copy: + enable stop; + start copy worker; + board index := haupt menu; + next menu (menu [board index].board, "h"); + menu monitor (PROC (TEXT CONST) menu board, + PROC (TEXT CONST) menu operations, ""9""). + +END PROC copy; + +PROC menu board (TEXT CONST input key): + SELECT board index OF + CASE haupt menu : main menu board (input key) + CASE urlader copy menu : urlader copy menu board (input key) + CASE copy hg menu : copy hg menu board (input key) + CASE disk copy menu : disk copy menu board (input key) + CASE disk part copy menu: disk part copy menu board (input key) + OTHERWISE + END SELECT. + +END PROC menu board; + +PROC main menu board (TEXT CONST input key): + SELECT pos (menu [board index].board keys, input key) OF + CASE 1: menu out ("h EUMEL-Hintergrund kopieren") + CASE 2: menu out ("u EUMEL-Urlader kopieren") + CASE 3: menu out ("d Diskette kopieren") + CASE 4: menu out ("t Teil einer Diskette kopieren") + CASE 5: menu out ("D Diskette dumpen") + CASE 6: menu out ("k Kopierkanal einstellen (zur Zeit " + text (copy channel) + ")") + CASE 7: menu out ("e beliebiges EUMEL-Kommando ausführen") + CASE 8: menu out ("TAB Kopiermenu verlassen") + OTHERWISE + END SELECT. + +END PROC main menu board; + +PROC copy hg menu board (TEXT CONST input key): + SELECT pos (menu [board index].board keys, input key) OF + CASE 1: menu out ("l EUMEL-Hintergrund von Diskette in Datenraum lesen") + CASE 2: menu out ("s EUMEL-Hintergrund vom Datenraum auf Diskette schreiben") + CASE 3: menu out ("p Prüfsumme über EUMEL-Hintergrunddisketten bilden") + CASE 4: menu out ("P Prüfsummen vergleichen") + CASE 5: menu out ("L Liste der Datenräume, die einen EUMEL-Hintergrund enthalten") + CASE 6: menu out ("i Informationen über EUMEL-Hintergrund auf Diskette") + CASE 7: menu out ("I Informationen über EUMEL-Hintergrund im Datenraum") + CASE 8: menu out ("TAB Hintergrund-Kopiermenu verlassen") + OTHERWISE + END SELECT. + +END PROC copy hg menu board; + +PROC urlader copy menu board (TEXT CONST input key): + SELECT pos (menu [board index].board keys, input key) OF + CASE 1: menu out ("l Urlader von Diskette in LEEREN Datenraum lesen") + CASE 2: menu out ("L Urlader von Diskette in Datenraum mit EUMEL-HG lesen") + CASE 3: menu out ("s Urlader vom Datenraum auf LEERE Diskette schreiben") + CASE 4: menu out ("S Urlader vom Datenraum auf Diskette mit EUMEL-HG schreiben") + CASE 5: menu out ("p Prüfsumme über Urlader auf Diskette bilden") + CASE 6: menu out ("P Prüfsummen vergleichen") + CASE 7: menu out ("z Liste der Datenräume, die einen EUMEL-Urlader enthalten") + CASE 8: menu out ("i Informationen über EUMEL-Urlader auf Diskette") + CASE 9: menu out ("I Informationen über EUMEL-Urlader im Datenraum") + CASE10: menu out ("TAB Urlader-Kopiermenu verlassen") + OTHERWISE + END SELECT. + +END PROC urlader copy menu board; + +PROC disk copy menu board (TEXT CONST input key): + SELECT pos (menu [board index].board keys, input key) OF + CASE 1: menu out ("l Diskette in Datenraum lesen") + CASE 2: menu out ("s Datenraum auf Diskette schreiben") + CASE 3: menu out ("p Prüfsumme über Diskette bilden") + CASE 4: menu out ("P Prüfsummen vergleichen") + CASE 5: menu out ("L Liste der Datenräume, die einen Disketteninhalt enthalten können") + CASE 6: menu out ("TAB Disketten-Kopiermenu verlassen") + OTHERWISE + END SELECT. + +END PROC disk copy menu board; + +PROC disk part copy menu board (TEXT CONST input key): + SELECT pos (menu [board index].board keys, input key) OF + CASE 1: menu out ("l Diskettenbereich in Datenraum lesen") + CASE 2: menu out ("s Datenraum in Diskettenbereich schreiben") + CASE 3: menu out ("p Prüfsumme über Diskettenbereich bilden") + CASE 4: menu out ("P Prüfsummen vergleichen") + CASE 5: menu out ("L Liste der Datenräume, die einen Diskettenbereich enthalten") + CASE 6: menu out ("TAB Disketten-Kopiermenu verlassen") + OTHERWISE + END SELECT. + +END PROC disk part copy menu board; + +PROC menu operations (TEXT CONST input key): + SELECT board index OF + CASE haupt menu : main menu operations (input key) + CASE urlader copy menu : urlader copy operations (input key) + CASE copy hg menu : copy hg menu operations (input key) + CASE disk copy menu : disk copy menu operations (input key) + CASE disk part copy menu: disk part copy menu operations (input key) + OTHERWISE + END SELECT. + +END PROC menu operations; + +PROC main menu operations (TEXT CONST input key): + SELECT pos (menu [board index].board keys, input key) OF + CASE 1: copy hg menu aufrufen + CASE 2: urlader copy menu aufrufen + CASE 3: disk copy menu aufrufen + CASE 4: disk part copy menu aufrufen + CASE 5: disable stop; show blocks; refresh + CASE 6: kopier kanal einstellen + CASE 7: eumel kommando ausfuehren + CASE 8: stop copy worker + OTHERWISE error stop ("noch nicht implementiert") + END SELECT. + +copy hg menu aufrufen: + board index := copy hg menu; + next menu (menu [board index].board, "L"). + +urlader copy menu aufrufen: + board index := urlader copy menu; + next menu (menu [board index].board, "z"). + +disk copy menu aufrufen: + board index := disk copy menu; + next menu (menu [board index].board, "L"). + +disk part copy menu aufrufen: + board index := disk part copy menu; + next menu (menu [board index].board, "L"). + +kopier kanal einstellen: + enable stop; + TEXT VAR kanal := text (copy channel); + put ("Kanalnummer für den Diskettenzugriff:"); + editget (kanal); + IF int (kanal) <> copy channel + THEN disable stop; + stop copy worker; + copy channel (int (kanal)); + start copy worker; + IF is error + THEN push (""9""); + line; + putline (""7"ERROR: " + error message); + clear error; + pause (100); + copy channel (31) + ELSE refresh + FI; + enable stop + FI. + +eumel kommando ausfuehren: + putline ("gib kommando:"); + editget (kommando); + line; + do (kommando); + IF NOT is error + THEN kommando := "" + FI; + next menu. + +END PROC main menu operations; + +PROC copy hg menu operations (TEXT CONST input key): + SELECT pos (menu [board index].board keys, input key) OF + CASE 1: disable stop; hg lesen; refresh + CASE 2: disable stop; hg schreiben; refresh + CASE 3: disable stop; hg check sum; refresh + CASE 4: check summen vergleichen + CASE 5: list (some (all, hg type), "EUMEL-Hintergrund-Datenräume"); refresh + CASE 6: hg informationen von diskette ausgeben + CASE 7: hg informationen von datenraum ausgeben + CASE 8: menu verlassen + OTHERWISE + END SELECT. + +menu verlassen: + board index := haupt menu; + next menu (menu [board index].board, "h"). + +END PROC copy hg menu operations; + +PROC urlader copy operations (TEXT CONST input key): + SELECT pos (menu [board index].board keys, input key) OF + CASE 1: disable stop; urlader von diskette in leeren datenraum lesen; refresh + CASE 2: disable stop; urlader von diskette in hg datenraum lesen; refresh + CASE 3: disable stop; urlader von datenraum auf leere diskette schreiben; refresh + CASE 4: disable stop; urlader von datenraum auf hg diskette schreiben; refresh + CASE 5: disable stop; urlader check sum; refresh + CASE 6: check summen vergleichen + CASE 7: list (some (all, hg type) + some (all, urlader type), "EUMEL-Urlader-Datenräume"); refresh + CASE 8: urlader informationen von diskette ausgeben + CASE 9: urlader informationen von datenraum ausgeben + CASE10: menu verlassen + OTHERWISE + END SELECT. + +menu verlassen: + board index := haupt menu; + next menu (menu [board index].board, "u"). + +END PROC urlader copy operations; + +PROC disk copy menu operations (TEXT CONST input key): + SELECT pos (menu [board index].board keys, input key) OF + CASE 1: disable stop; diskette lesen; refresh + CASE 2: disable stop; diskette schreiben; refresh + CASE 3: disable stop; diskette check sum; refresh + CASE 4: check summen vergleichen + CASE 5: list (some (all, disk type), "Datenräume mit Disketteninhalt"); refresh + CASE 6: menu verlassen + OTHERWISE + END SELECT. + +menu verlassen: + board index := haupt menu; + next menu (menu [board index].board, "d"). + +END PROC disk copy menu operations; + +PROC disk part copy menu operations (TEXT CONST input key): + SELECT pos (menu [board index].board keys, input key) OF + CASE 1: disable stop; disk part lesen; refresh + CASE 2: disable stop; disk part schreiben; refresh + CASE 3: disable stop; disk part check sum; refresh + CASE 4: check summen vergleichen + CASE 5: list (some (all, disk type), "Datenräume mit Disketteninhalt"); refresh + CASE 6: menu verlassen + OTHERWISE + END SELECT. + +menu verlassen: + board index := haupt menu; + next menu (menu [board index].board, "t"). + +END PROC disk part copy menu operations; + +PROC refresh: + clear free lines; + next menu. + +END PROC refresh; + +END PACKET copy menu; + + diff --git a/devel/debug-ds4/1989/source-disk b/devel/debug-ds4/1989/source-disk new file mode 100644 index 0000000..a1795f1 --- /dev/null +++ b/devel/debug-ds4/1989/source-disk @@ -0,0 +1 @@ +debug/debug-copy-std-ds.img diff --git a/devel/debug-ds4/1989/src/RUN load ds4 b/devel/debug-ds4/1989/src/RUN load ds4 new file mode 100644 index 0000000..51d9a1f --- /dev/null +++ b/devel/debug-ds4/1989/src/RUN load ds4 @@ -0,0 +1,246 @@ +(* COPYRIGHT: digitron GmbH, Bielefeld 1989 *) + +(* +EUMEL0: +modul: 2047 start: 3 0 code: 3 0 1 -257 32604 32588 32573 3 32666 1 +3 4 0 32667 2 3 4 0 3076 11268 5 28678 32573 6 32666 1 6 7 0 32667 2 6 7 0 +3079 11271 8 28694 32573 9 32666 1 9 10 0 32667 2 9 10 0 3082 11274 11 28710 +32573 12 32666 1 12 13 0 32667 2 12 13 0 3085 11277 14 28726 32573 15 32666 +1 16 17 18 32592 17 19 32666 1 22 18 0 32667 2 22 19 0 3090 3091 3092 11284 +21 28750 32587 32583 1 32512 endc pbase: -256 0 0 0 0 1792 -256 1 0 0 3 256 +0 5 0 -32768 9999 7 25 0 0 0 4 1 endp +*) +PACKET ds accesses DEFINES + do, + ds nr, + forget all but not, + set modul start ic, + read ds, + write ds, +: +INT CONST stdds := 4 + index(myself) * 256; +INT PROC read ds (INT CONST drid, add hi, add lo): + EXTERNAL 154 +END PROC read ds; +INT PROC read ds (DATASPACE CONST drid, INT CONST add hi, add lo): + EXTERNAL 154 +END PROC read ds; +PROC write ds (INT CONST drid, add hi, add lo, data): + EXTERNAL 155 +END PROC write ds; +PROC write ds (DATASPACE CONST drid, INT CONST add hi, add lo, data): + EXTERNAL 155 +END PROC write ds; +PROC forget (INT CONST ds): + EXTERNAL 71 +END PROC forget; +OP := (INT VAR left, DATASPACE CONST right): + EXTERNAL 260 +END OP :=; +PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line, + INT VAR modul nr, BOOL CONST ins, lst, rt check, ser): + EXTERNAL 256 +END PROC elan; +PROC do (INT CONST modul nr): + INT VAR modul no:= modul nr; + DATASPACE VAR source; + elan (4, source, "", modul no, FALSE, FALSE, FALSE, FALSE); +END PROC do; +INT PROC ds nr (TEXT CONST name): + INT VAR nr := old (name); nr +END PROC ds nr; +PROC forget all but not (INT CONST ds): + INT VAR i, a; + FOR i FROM 5 UPTO 255 REP + a := i + 256 * index (myself); + IF i <> ds MOD 256 THEN + cout (i); forget (a); + FI; + PER +END PROC forget all but not; +PROC set modul start ic (INT CONST modul nr, ic hi, ic lo): + IF ic hi < 2 OR ic hi > 3 THEN error stop ("Falscher Instruction Counter") FI; + IF (modul nr >= 1280 AND ic hi = 3) OR (modul nr <= 1280 AND ic hi = 2) THEN + write ds (stdds, 0, modul nr + 512, ic lo); + ELSE + error stop ("Falsche Modulnummer: " + text (modul nr)); + FI; +END PROC set modul start ic; +END PACKET ds accesses; +PACKET lader DEFINES + lade, +: +INT CONST stdds := 4 + index (myself) * 256; +PROC check task index (TEXT CONST name): + IF index (myself) = index copytask (old(name)) THEN + putline ("Leider haben sie den gleichen Taskindex wie bei der Quelltask erwischt!"); + errorstop("Bitte versuchen sie es mit einer neuen Task!"); + FI; +END PROC check task index; +INT PROC index copytask (DATASPACE CONST ds): + read ds (ds, 7, 9) +END PROC index copytask; +PROC get ic (FILE VAR f, INT VAR ic hi, ic lo): + find text (f,"start:"); + get int (f,ic hi); get int (f,ic lo); + IF ic hi <> 3 THEN error stop ("Falscher Start IC") FI; +END PROC get ic; +PROC get pbase (FILE VAR f, INT VAR ps): + find text (f, "pbase:"); + get int (f, ps); + IF ps MOD 256 <> 0 THEN error stop ("Falsche Packet Basis") FI; +END PROC get pbase; +PROC get modul (FILE VAR f, INT VAR modul nr): + find text (f, "modul:"); + get int (f, modul nr); +END PROC get modul; +PROC load code (FILE VAR f): + INT VAR add hi, add lo, code wert; + TEXT VAR code ende; + check end code (f); + get code add (f, add hi, add lo); + REP + get code (f, code wert, code ende); + IF code ende = "end" THEN LEAVE load code FI; + write ds (stdds, add hi, add lo, code wert); + add lo INCR 1; + PER +END PROC load code; +PROC load pbase (FILE VAR f): + INT VAR pbase add, pbase wert; + TEXT VAR pbase ende; + check end pbase (f); + get pbase (f, pbase add); + REP + get pbase (f, pbase wert, pbase ende); + IF pbase ende = "end" THEN LEAVE load pbase FI; + write ds (stdds, 0, pbase add, pbase wert); + pbase add INCR 1; + PER +END PROC load pbase; +INT PROC read pbase var (FILE VAR f, INT CONST index): + INT VAR pbase add; + get pbase (f, pbase add); + read ds (stdds, 0, pbase add+index) +END PROC read pbase var; +PROC write pbase var (FILE VAR f, INT CONST index, var): + INT VAR pbase add; + get pbase (f, pbase add); + write ds (stdds, 0, pbase add+index, var); +END PROC write pbase var; +PROC get code add (FILE VAR f, INT VAR add hi, add lo): + find text (f, "code:"); + get int (f, add hi); get int (f, add lo); + IF add hi <> 3 THEN error stop ("Falsche Code-Adresse") FI; +END PROC get code add; +PROC get int (FILE VAR f, INT VAR value): + IF eof (f) THEN error stop ("Daten fehlen") FI; + TEXT VAR daten; + get (f, daten); + IF daten = "-32768" THEN + value := -maxint-1; + ELSE + value := int (daten); + ENDIF; +END PROC get int; +PROC get code (FILE VAR f, INT VAR value, TEXT VAR ende ): + IF eof(f) THEN error stop ("'End Code'-Kennung fehlt") FI; + TEXT VAR daten ; + get (f, daten); + IF daten = "endc" THEN + ende := "end" + ELSE + IF daten = "-32768" THEN + value := -maxint-1; + ELSE + value := int (daten); + ENDIF; + ende := "no end" + FI; +END PROC get code; +PROC check end code (FILE VAR f): + find text (f, "endc"); +END PROC check end code; +PROC get pbase (FILE VAR f,INT VAR value, TEXT VAR ende): + IF eof (f) THEN error stop ("'End Pbase'-Kennung fehlt") FI; + TEXT VAR daten ; + get (f, daten); + IF daten = "endp" THEN + ende := "end" + ELSE + IF daten = "-32768" THEN + value := -maxint-1; + ELSE + value := int (daten); + ENDIF; + ende := "no end" + FI; +END PROC get pbase; +PROC check end pbase (FILE VAR f): + find text (f, "endp"); +END PROC check end pbase; +PROC find text (FILE VAR f, TEXT CONST suchtext): + TEXT VAR t; + go start (f); + WHILE NOT eof (f) REP + get (f, t); + IF t = suchtext THEN LEAVE find text FI; + PER; + error stop (suchtext + " fehlt") +END PROC find text; +PROC go start (FILE VAR f): + TEXT VAR t; + reset (f); + WHILE NOT eof (f) REP + get (f, t); + IF t = "EUMEL0:" THEN LEAVE go start FI + PER; + error stop ("EUMEL0-Code nicht gefunden"); +END PROC go start; +PROC run code (INT VAR ic hi, ic lo, modul nr): + set modul start ic (modul nr, ic hi, ic lo); + do push (modul nr); +END PROC run code; +PROC do push (INT CONST modul nr): + IF lbase < 30000 THEN + do push (modul nr); + ELSE + do (modul nr); LEAVE do push; + FI; +END PROC do push; +INT PROC lbase: + pcb (25) +END PROC lbase; +PROC lade (TEXT CONST datei name): + INT VAR ic hi, ic lo, modul nr; + line; + putline ("Achtung: ALLE bis jetzt insertierten Packete der Task gehen verloren!"); + IF NOT yes ("Wollen sie den Standarddatenraum ersetzen") THEN LEAVE lade FI; + check task index (datei name); + FILE VAR f := sequentialfile (input, dateiname); + get ic (f, ic hi, ic lo); + get modul (f, modul nr); + load code (f); + load pbase (f); + load pbase var (f); + run code (ic hi, ic lo, modul nr); +END PROC lade; +PROC load pbase var (FILE VAR f): + INT VAR dss, dst; TEXT VAR name := "STD DS4"; + line; + put ("Wie heißt der Quelldatenraum:"); + editget (name); + line; + IF NOT exists (name) THEN errorstop("Datei " + name + " gibt es nicht."); FI; + dst := 4 + 256 * index (myself); + dss := ds nr (name); + write pbase var (f, 1, dss); + write pbase var (f, 2, dst); + forget all but not (dss); +END PROC load pbase var; +PROC lade: + lade ("RUN load ds4"); +END PROC lade; +END PACKET lader; +lade; + diff --git a/devel/debug-ds4/1989/src/RUN save ds4 b/devel/debug-ds4/1989/src/RUN save ds4 new file mode 100644 index 0000000..1fd542b --- /dev/null +++ b/devel/debug-ds4/1989/src/RUN save ds4 @@ -0,0 +1,223 @@ +(* COPYRIGHT: digitron GmbH, Bielefeld 1989 *) + +(* +EUMEL0: +modul: 2047 start: 3 0 code: 3 0 1 -257 32604 32588 32573 3 32666 1 +3 4 0 32667 2 3 4 0 3076 11268 5 28678 32573 6 32666 1 6 7 0 32667 2 6 7 0 +3079 11271 8 28694 32573 9 32666 1 9 10 0 32667 2 9 10 0 3082 11274 11 28710 +32573 12 32666 1 12 13 0 32667 2 12 13 0 3085 11277 14 28726 32573 15 32592 +15 0 32667 2 17 15 0 3087 11279 16 28740 32587 32512 endc pbase: -256 0 0 0 +0 1792 -256 1 0 0 3 256 0 5 0 -32768 0 32 7 endp +*) +PACKET ds accesses DEFINES + do, + ds nr, + forget all but not, + set modul start ic, + read ds, + write ds, +: +INT CONST stdds := 4 + index(myself) * 256; +INT PROC read ds (INT CONST drid, add hi, add lo): + EXTERNAL 154 +END PROC read ds; +INT PROC read ds (DATASPACE CONST drid, INT CONST add hi, add lo): + EXTERNAL 154 +END PROC read ds; +PROC write ds (INT CONST drid, add hi, add lo, data): + EXTERNAL 155 +END PROC write ds; +PROC write ds (DATASPACE CONST drid, INT CONST add hi, add lo, data): + EXTERNAL 155 +END PROC write ds; +PROC forget (INT CONST ds): + EXTERNAL 71 +END PROC forget; +OP := (INT VAR left, DATASPACE CONST right): + EXTERNAL 260 +END OP :=; +PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line, + INT VAR modul nr, BOOL CONST ins, lst, rt check, ser): + EXTERNAL 256 +END PROC elan; +PROC do (INT CONST modul nr): + INT VAR modul no:= modul nr; + DATASPACE VAR source; + elan (4, source, "", modul no, FALSE, FALSE, FALSE, FALSE); +END PROC do; +INT PROC ds nr (TEXT CONST name): + INT VAR nr := old (name); nr +END PROC ds nr; +PROC forget all but not (INT CONST ds): + INT VAR i, a; + FOR i FROM 5 UPTO 255 REP + a := i + 256 * index (myself); + IF i <> ds MOD 256 THEN + cout (i); forget (a); + FI; + PER +END PROC forget all but not; +PROC set modul start ic (INT CONST modul nr, ic hi, ic lo): + IF ic hi < 2 OR ic hi > 3 THEN error stop ("Falscher Instruction Counter") FI; + IF (modul nr >= 1280 AND ic hi = 3) OR (modul nr <= 1280 AND ic hi = 2) THEN + write ds (stdds, 0, modul nr + 512, ic lo); + ELSE + error stop ("Falsche Modulnummer: " + text (modul nr)); + FI; +END PROC set modul start ic; +END PACKET ds accesses; +PACKET lader DEFINES + lade, +: +INT CONST stdds := 4 + index (myself) * 256; +PROC get ic (FILE VAR f, INT VAR ic hi, ic lo): + find text (f,"start:"); + get int (f,ic hi); get int (f,ic lo); + IF ic hi <> 3 THEN error stop ("Falscher Start IC") FI; +END PROC get ic; +PROC get pbase (FILE VAR f, INT VAR ps): + find text (f, "pbase:"); + get int (f, ps); + IF ps MOD 256 <> 0 THEN error stop ("Falsche Packet Basis") FI; +END PROC get pbase; +PROC get modul (FILE VAR f, INT VAR modul nr): + find text (f, "modul:"); + get int (f, modul nr); +END PROC get modul; +PROC load code (FILE VAR f): + INT VAR add hi, add lo, code wert; + TEXT VAR code ende; + check end code (f); + get code add (f, add hi, add lo); + REP + get code (f, code wert, code ende); + IF code ende = "end" THEN LEAVE load code FI; + write ds (stdds, add hi, add lo, code wert); + add lo INCR 1; + PER +END PROC load code; +PROC load pbase (FILE VAR f): + INT VAR pbase add, pbase wert; + TEXT VAR pbase ende; + check end pbase (f); + get pbase (f, pbase add); + REP + get pbase (f, pbase wert, pbase ende); + IF pbase ende = "end" THEN LEAVE load pbase FI; + write ds (stdds, 0, pbase add, pbase wert); + pbase add INCR 1; + PER +END PROC load pbase; +INT PROC read pbase var (FILE VAR f, INT CONST index): + INT VAR pbase add; + get pbase (f, pbase add); + read ds (stdds, 0, pbase add+index) +END PROC read pbase var; +PROC write pbase var (FILE VAR f, INT CONST index, var): + INT VAR pbase add; + get pbase (f, pbase add); + write ds (stdds, 0, pbase add+index, var); +END PROC write pbase var; +PROC get code add (FILE VAR f, INT VAR add hi, add lo): + find text (f, "code:"); + get int (f, add hi); get int (f, add lo); + IF add hi <> 3 THEN error stop ("Falsche Code-Adresse") FI; +END PROC get code add; +PROC get int (FILE VAR f, INT VAR value): + IF eof (f) THEN error stop ("Daten fehlen") FI; + TEXT VAR daten; + get (f, daten); + IF daten = "-32768" THEN + value := -maxint-1; + ELSE + value := int (daten); + ENDIF; +END PROC get int; +PROC get code (FILE VAR f, INT VAR value, TEXT VAR ende ): + IF eof(f) THEN error stop ("'End Code'-Kennung fehlt") FI; + TEXT VAR daten ; + get (f, daten); + IF daten = "endc" THEN + ende := "end" + ELSE + IF daten = "-32768" THEN + value := -maxint-1; + ELSE + value := int (daten); + ENDIF; + ende := "no end" + FI; +END PROC get code; +PROC check end code (FILE VAR f): + find text (f, "endc"); +END PROC check end code; +PROC get pbase (FILE VAR f,INT VAR value, TEXT VAR ende): + IF eof (f) THEN error stop ("'End Pbase'-Kennung fehlt") FI; + TEXT VAR daten ; + get (f, daten); + IF daten = "endp" THEN + ende := "end" + ELSE + IF daten = "-32768" THEN + value := -maxint-1; + ELSE + value := int (daten); + ENDIF; + ende := "no end" + FI; +END PROC get pbase; +PROC check end pbase (FILE VAR f): + find text (f, "endp"); +END PROC check end pbase; +PROC find text (FILE VAR f, TEXT CONST suchtext): + TEXT VAR t; + go start (f); + WHILE NOT eof (f) REP + get (f, t); + IF t = suchtext THEN LEAVE find text FI; + PER; + error stop (suchtext + " fehlt") +END PROC find text; +PROC go start (FILE VAR f): + TEXT VAR t; + reset (f); + WHILE NOT eof (f) REP + get (f, t); + IF t = "EUMEL0:" THEN LEAVE go start FI + PER; + error stop ("EUMEL0-Code nicht gefunden"); +END PROC go start; +PROC run code (INT VAR ic hi, ic lo, modul nr): + set modul start ic (modul nr, ic hi, ic lo); + do (modul nr); +END PROC run code; +PROC lade (TEXT CONST datei name): + INT VAR ic hi, ic lo, modul nr; + line; + IF NOT yes ("Wollen sie den Standarddatenraum kopieren") THEN LEAVE lade FI; + FILE VAR f := sequentialfile (input, dateiname); + get ic (f, ic hi, ic lo); + get modul (f, modul nr); + load code (f); + load pbase (f); + load pbase var (f); + run code (ic hi, ic lo, modul nr); +END PROC lade; +PROC load pbase var (FILE VAR f): + INT VAR dss, dst; TEXT VAR name := "STD DS4"; + line; + put ("Wohin soll der Standarddatenraum kopiert werden:"); + editget (name); + line; + IF NOT exists (name) THEN create (name); FI; + dss := 4 + 256 * index (myself); + dst := ds nr (name); + write pbase var (f, 1, dss); + write pbase var (f, 2, dst); +END PROC load pbase var; +PROC lade: + lade ("RUN save ds4"); +END PROC lade; +END PACKET lader; +lade; + diff --git a/devel/debug/1/source-disk b/devel/debug/1/source-disk new file mode 100644 index 0000000..e42b22b --- /dev/null +++ b/devel/debug/1/source-disk @@ -0,0 +1 @@ +debug/debug-1_1987-04-24.img 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. + + |