From 98cab31fc3659e33aef260efca55bf9f1753164c Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 11 Feb 2019 11:49:19 +0100 Subject: Add source files from Michael --- devel/misc/unknown/src/0DISASS.ELA | 1110 +++++++++++++++++++++++++++++++++++ devel/misc/unknown/src/ASSEMBLE.ELA | 387 ++++++++++++ devel/misc/unknown/src/COPYDS.ELA | 294 ++++++++++ devel/misc/unknown/src/DS4.ELA | 268 +++++++++ devel/misc/unknown/src/PRIVS.ELA | 485 +++++++++++++++ devel/misc/unknown/src/TABINFO.ELA | 117 ++++ devel/misc/unknown/src/TRACE.ELA | 552 +++++++++++++++++ devel/misc/unknown/src/XLIST.ELA | 143 +++++ devel/misc/unknown/src/XSTATUS.ELA | 188 ++++++ devel/misc/unknown/src/Z80.ELA | 495 ++++++++++++++++ 10 files changed, 4039 insertions(+) create mode 100644 devel/misc/unknown/src/0DISASS.ELA create mode 100644 devel/misc/unknown/src/ASSEMBLE.ELA create mode 100644 devel/misc/unknown/src/COPYDS.ELA create mode 100644 devel/misc/unknown/src/DS4.ELA create mode 100644 devel/misc/unknown/src/PRIVS.ELA create mode 100644 devel/misc/unknown/src/TABINFO.ELA create mode 100644 devel/misc/unknown/src/TRACE.ELA create mode 100644 devel/misc/unknown/src/XLIST.ELA create mode 100644 devel/misc/unknown/src/XSTATUS.ELA create mode 100644 devel/misc/unknown/src/Z80.ELA (limited to 'devel/misc') diff --git a/devel/misc/unknown/src/0DISASS.ELA b/devel/misc/unknown/src/0DISASS.ELA new file mode 100644 index 0000000..954fdf7 --- /dev/null +++ b/devel/misc/unknown/src/0DISASS.ELA @@ -0,0 +1,1110 @@ +PACKET eumel 0 code disassembler DEFINES (* M.Staubermann, Mrz/April 86 *) + disass 0 code, +(* disass object, + disass address, + disass module nr, *) + disass 0, + ADD, + hex16, + hex8 , + integer, + denoter, + opcode, + seg, + addr, + end addr, + local base , + bool result , + code word line : + +LET packet data segment = 0 , + local data segment = 1 , + first elan address = 13322 , + begin of stringtable = 1024 , + begin of nametable = 4096 , + end of nametable = 19455 , + begin of permanent table = 19456 ; + +INT VAR address, segment, lbas ; + +PROC local base (INT CONST i) : + lbas := i (* -1 = lbas unbekannt *) +ENDPROC local base ; + +TEXT PROC code word line : + code words +ENDPROC code word line ; + +PROC code word line (TEXT CONST text) : + code words := text +ENDPROC code word line ; + +PROC seg (INT CONST s) : + segment := s +ENDPROC seg ; + +PROC addr(INT CONST a) : + address := a +ENDPROC addr ; + +INT PROC addr : + address +ENDPROC addr ; + +BOOL PROC bool result : + was bool result +ENDPROC bool result ; + +PROC bool result (BOOL CONST b) : + was bool result := b +ENDPROC bool result ; + +PROC end addr (INT CONST e) : + end address := e +ENDPROC end addr ; + +PROC disass 0 code (INT CONST seg, INT VAR addr, PROC (TEXT CONST) writeln) : + TEXT VAR taste ; + BOOL VAR addr out := TRUE , + output permitted := TRUE, + is packet ; + INT VAR size, used, mod nr, a, b, m ; + storage (size, used) ; + echo := FALSE ; + init list file ; + segment := seg ; + address := addr ; + mod nr := -1 ; + was bool result := FALSE ; + REP + IF output permitted + THEN IF addr out + THEN out (" ") ; + out (hex16 (address)) ; + out (" "8""8""8""8""8""8"") ; + ELSE cout (ln) + FI + FI ; + taste := incharety ; + disass one statement ; + SELECT code (taste) OF +{l}CASE 108 : addr out := FALSE +{d}CASE 100 : get command ("gib kommando:") ; do command +{f}CASE 102 : out (""13""5"Filename: "+filename+ "." + text(filenumber)+" ") +{z}CASE 122 : out (""13""5"Fileline: "+text (lines (list file)) + " ") +{a}CASE 97 : addr out := TRUE +{e}CASE 101 : echo := NOT echo +{s}CASE 115 : storage(size,used);out(""13""5"System-Storage: "+text(used)+" ") +{h}CASE 104 : out (""13""5"Heapsize: " + text (heapsize) + " ") +{m}CASE 109 : out (""13""5"Modulnr: " + text (mod nr) + " ") +{W}CASE 87, 81: output permitted := TRUE +{S}CASE 83 : output permitted := FALSE + CASE 27 : IF incharety <> "" THEN taste := "" FI(* Wegen Steuertasten *) + ENDSELECT ; + arith 16 ; + address INCR 1 ; + arith 15 ; + IF (address AND 31) = 0 + THEN storage (size, used) ; + FI ; + BOOL CONST ende erreicht :: end address <> 0 CAND + real (address) >= real (end address) ; + UNTIL ende erreicht OR taste = ""27"" OR taste = ""129"" OR used > size PER ; + IF used > size + THEN writeln ("Abbruch wegen Speicherengpass!") + ELIF taste = ""27"" + THEN writeln ("Abbruch mit ESC") + FI ; + addr := address . + +code word : + get word (segment, address) . + +disass one statement : + a := address ; + divrem 256 (a, b) ; + IF segment = 2 + THEN m := pos (segment 2 adresses, ""0"" + code (b) + code (a) + ""0"") ; + IF m <= LENGTH segment 2 adresses - 4 + THEN IF code (segment 2 adresses SUB (m + 4)) <= a + THEN IF code (segment 2 adresses SUB (m + 4)) = a + THEN is packet := + code (segment 2 adresses SUB (m + 3)) <= b + ELSE is packet := TRUE + FI + ELSE is packet := FALSE + FI + ELSE is packet := FALSE + FI + ELSE m := pos (segment 3 adresses, ""0"" + code (b) + code (a) + ""0"") ; + IF m <= LENGTH segment 3 adresses - 4 + THEN IF code (segment 3 adresses SUB (m + 4)) <= a + THEN IF code (segment 3 adresses SUB (m + 4)) = a + THEN is packet := + code (segment 3 adresses SUB (m + 3)) <= b + ELSE is packet := TRUE + FI + ELSE is packet := FALSE + FI + ELSE is packet := FALSE + FI + FI ; + IF m > 0 AND end address = 0 AND addr <> address + THEN taste := ""129"" ; + LEAVE disass one statement + ELIF m > 0 + THEN m := (m - 1) DIV 3 + 1 ; + IF segment = 2 + THEN mod nr := segment 2 modules ISUB m + ELSE mod nr := segment 3 modules ISUB m + FI ; + writeln (" ") ; + writeln ("Modulnummer " + process module nr (mod nr, is packet)) ; + writeln ("Top of Stack: " + hex16 (codeword)) ; + arith 16 ; + address INCR 1 ; + arith 15 ; + writeln (" ") + FI ; + codewords := hex16 (address) + " " ; + codewords CAT hex16 (code word) + " " ; + TEXT CONST opc := opcode ; + WHILE length (codewords) < 30 REP + codewords CAT " " + PER ; + writeln (codewords + opc) . + +ENDPROC disass 0 code ; + +PROC init list file : + forget (filename + "." + text (filenumber), quiet) ; + list file := sequentialfile (output, filename + "." + text (filenumber)) ; + maxlinelength (list file, 9999) ; + list line ("Addr Opco Data Data Data Data Opcode Parameter") ; +ENDPROC init list file ; + +PROC list line (TEXT CONST zeile) : + IF lines (list file) > 4000 + THEN file number INCR 1 ; + init list file + FI ; + putline (list file, zeile) ; + IF echo + THEN putline (zeile) + FI +ENDPROC list line ; + +PROC disass object : + TEXT VAR object name ; + INT VAR nth object , code address ; + put ("Filename:") ; + getline (filename) ; + filenumber := 0 ; + end address := 0 ; + REP + clear error ; + enablestop ; + page ; + put ("Name des zu Disassemblierenden Objekts:") ; + getline (object name) ; + changeall(object name, " ", "") ; + putline ("Bitte Gewuenschtes Objekt von vorne an abzaehlen und ESC q druecken.") ; + pause (5) ; + disablestop ; + help (object name) ; + UNTIL NOT iserror PER ; + enablestop ; + page ; + put ("Nummer des Objekts:") ; + get (nth object) ; + code address := code start (object name, nth object) ; + lbas := -1 ; + disass 0 code (code segment, code address, PROC (TEXT CONST) list line) ; + edit (filename + ".0") +ENDPROC disass object ; + +PROC disass module nr : + INT VAR mod nr , code address ; + end address := 0 ; + put ("Filename:") ; + getline (filename) ; + filenumber := 0 ; + page ; + put ("Modulnummer:") ; + get (mod nr) ; + code address := code start (mod nr) ; + lbas := -1 ; + IF code address = -1 + THEN putline ("Unbelegte Modulnummer") + ELSE disass 0 code (code segment, code address, PROC (TEXT CONST) listline) ; + edit (filename + ".0") + FI +ENDPROC disass module nr ; + +PROC disass address : + INT VAR code segment, code address ; + TEXT VAR eingabe ; + put ("Filename:") ; + getline (filename) ; + file number := 0 ; + page ; + put ("Code Segment (2 o. 3):") ; + get (code segment) ; + put ("Startadresse (Hex) :") ; + getline (eingabe) ; + code address := integer (eingabe) ; + put ("Endadresse (Hex) :") ; + getline (eingabe) ; + end address := integer (eingabe) ; + lbas := -1 ; + disass 0 code (code segment, code address, PROC (TEXT CONST) listline) ; + edit (filename + ".0") +ENDPROC disass address ; + +FILE VAR list file ; +TEXT VAR file name ; +INT VAR op data, + file number , + first module line := 200 , + anzahl steuerzeichen, + anzahl zeros, + call data , + long data, + low, + op1, + op 2, + word, + ln := -1, + end address := 0, + high , + data base := 0 ; +BOOL VAR echo, was bool result := FALSE ; +TEXT VAR code words := "" , + segment 2 modules, + segment 2 adresses, + segment 3 modules, + segment 3 adresses; + +TEXT PROC opcode : + TEXT VAR temp := " " ; + word := get word (segment, address) ; + op1 := (word AND 31744) DIV 1024 ; + op2 := (word AND 768) DIV 128 ; + low := word AND 255 ; + ln := -1 ; + replace (temp, 1, address) ; + high := code (temp SUB 2) ; + op data := word AND -31745 ; + long data := (word AND 768) * 2 + (word AND 255) ; + call data := word AND 1023 ; + IF word < 0 + THEN IF word = -3 + THEN LEAVE opcode WITH "Block unlesbar" + ELIF word = -1 + THEN LEAVE opcode WITH "" + ELSE long data INCR 256 ; + op2 INCR 1 ; + call data INCR 1024 + FI + FI ; + IF op1 = 31 AND op2 = 7 + THEN op1 := (word AND 127) DIV 4 ; + op2 := (word AND 3) * 2 ; + low := -1 ; + long data := next word ; + call data := long data ; + op data := long data ; + IF (word AND 128) = 128 THEN op2 INCR 1 FI ; + "LONGA " + opc + ELSE opc + FI . +ENDPROC opcode ; + +TEXT PROC opc : + BOOL CONST previous bool result :: was bool result ; + was bool result := FALSE ; + SELECT op1 OF + CASE 0 : process ln + CASE 1 : process ln long + CASE 2 : "MOV " + two params (6,6) + CASE 3 : "INC1 " + one param (1) + CASE 4 : "DEC1 " + one param (1) + CASE 5 : "INC " + two params (1,1) + CASE 6 : "DEC " + two params (1,1) + CASE 7 : "ADD " + three params (1,1,1) + CASE 8 : "SUB " + three params (1,1,1) + CASE 9 : "CLEAR " + one param (6) + CASE 10 : was bool result := TRUE ; "TEST " + one param (6) + CASE 11 : was bool result := TRUE ; "EQU " + two params (1,1) + CASE 12 : was bool result := TRUE ; "LSEQ " + two params (1,1) + CASE 13 : "FMOV " + two params (2,2) + CASE 14 : "FADD " + three params (2,2,2) + CASE 15 : "FSUB " + three params (2,2,2) + CASE 16 : "FMULT " + three params (2,2,2) + CASE 17 : "FDIV " + three params (2,2,2) + CASE 18 : was bool result := TRUE ; "FLSEQ " + two params (2,2) + CASE 19 : "TMOV " + two params (3,3) + CASE 20 : was bool result := TRUE ; "TEQU " + two params (3,3) + CASE 21 : was bool result := TRUE ; "ULSEQ " + two params (1,1) + CASE 22 : process accds + CASE 23 : "REF " + two params (0,0) + CASE 24 : process subs + CASE 25 : process sel + CASE 26 : "PPV " + one param (0) + CASE 27 : "PP " + one param (0) + CASE 28 : process br + CASE 29 : process brlong + CASE 30 : "CALL " + process module nr (call data, FALSE) + OTHERWISE op 31 + ENDSELECT . + +process ln : + IF previous bool result + THEN "BT " + branch address + ELSE ln := long data ; + "LN " + text (long data) + FI . + +process ln long : + long data INCR 2048 ; + IF previous bool result + THEN "BTLONG " + branch address + ELSE ln := long data ; + "LNLONG " + text (long data) + FI . + +process br : + IF previous bool result + THEN "BF " + branch address + ELSE "BR " + branch address + FI . + +process brlong : + long data INCR 2048 ; + IF previous bool result + THEN "BFLONG " + branch address + ELSE "BRLONG " + branch address + FI . + +process accds : + "ACCDS (DSid:" + hex16 (op data) + denoter (opdata, 8) + ", BOUND-Result:" + + params ("0") . + +process subs : + INT CONST elem len :: long data, limit1 :: next word, index :: next word, + base :: next word, result :: next word ; + "SUBS (Elem.len:" + text (elem len) + ", Limit:" + text (limit1 + 1) + + ", Index:" + hex16 (index) + denoter (index, 1) + ", Base:" + hex16 (base) + + ", Result:" + hex16 (result) + denoter (result, 0) + ")". + +process sel : + INT CONST offset :: next word, result1 :: next word ; + "SEL (Base:" + hex16 (op data) + ", Offset:" + hex16 (offset) + + ", Result:" + hex16 (result1) + denoter (result1, 0) + ")". + +op31 : +SELECT op 2 OF + CASE 0 : was bool result := TRUE ; + "IS (""" + code (low) + """, " + params ("0") (* 7C *) + CASE 1 : "STIM (" + hex8 (low) + ", " + params ("6") (* FC *) + CASE 2 : "MOVX (" + hex8 (low) + ", " + params ("66") (* 7D *) + CASE 3 : "PUTW (" + hex8 (low) + ", " + params ("77") (* FD *) + CASE 4 : "GETW (" + hex8 (low) + ", " + params ("77") (* 7E *) + CASE 5 : data base := ((""0"" + code (low)) ISUB 1) ; + "PENTER (" + hex8 (low) +")" (* FE *) + CASE 6 : "ESC " + esc code (* 7F *) + OTHERWISE"???????" (* FF *) +ENDSELECT . + +ENDPROC opc ; + +TEXT PROC branch address : + INT VAR branch byte := long data DIV 256 ; + branch byte := (branch byte + high) AND 15 + (high AND 240) ; + hex8 (branch byte) + hex8 (long data AND 255) +ENDPROC branch address ; + +INT PROC next word : + arith 16 ; + address INCR 1 ; + arith 15 ; + INT CONST w :: get word (segment, address) ; + codewords CAT hex16 (w) + " " ; + w +ENDPROC next word ; + +TEXT PROC one param (INT CONST type) : + "(" + hex16 (op data) + denoter (op data, type) + ")" +ENDPROC one param ; + +TEXT PROC three params (INT CONST type a, type b, type c) : + INT CONST word b :: next word, word c :: next word ; + "(" + hex16 (op data) + denoter (op data, type a) + ", " + + hex16 (word b) + denoter (word b, type b) + ", " + + hex16 (word c) + denoter (word c, type c) + ")" +ENDPROC three params ; + +TEXT PROC two params (INT CONST type a, type b) : + INT CONST word b :: next word ; + "(" + hex16 (op data) + denoter (op data, type a) + ", " + + hex16 (word b) + denoter (word b, type b) + ")" +ENDPROC two params ; + +TEXT PROC denoter (INT CONST offset, type) : + IF offset < 0 AND lbas = -1 THEN LEAVE denoter WITH " " + ELIF type = 7 THEN LEAVE denoter WITH "" + ELIF type >= 2 AND type <= 5 OR type = 8 THEN + LEAVE denoter WITH " <" + + data object (offset, data base, type) + ">" + FI ; + INT VAR i, byte, word1, word ; + IF offset < 0 + THEN word := get word (local data segment, (offset AND 32767) ADD lbas) + ELSE word := get word (packet data segment, data base ADD offset) + FI ; + TEXT VAR x, t := " <" + hex16 (word) ; + IF address < first elan address + THEN IF word >= begin of stringtable CAND word <= end of nametable + THEN string pointer + ELIF word > 9 AND word < 32 + THEN t CAT ":""""" + text (word) + """""" + ELIF word >= 32 AND word < 127 + THEN t CAT ":""" + code (word) + """" + FI ; + FI ; + IF type = 0 COR type = 6 + THEN BOOL VAR text sinnvoll := FALSE , + real sinnvoll := FALSE , + bool sinnvoll := word = -1 OR word = 0 OR word = 1 ; + IF type = 0 + THEN IF offset < 0 + THEN word1 := get word (local data segment, + lbas ADD (offset AND 32767) ADD 1) + ELSE word1 := get word (packet data segment, + data base ADD offset ADD 1) ; + FI ; + text sinnvoll := keine steuerzeichen AND (word1 AND 255) < 80 ; + real sinnvoll := vorzeichen ok AND nur digits + FI ; + try type + FI ; + t + ">" . + +string pointer : + IF word >= begin of name table + THEN word INCR 2 + FI ; + IF (cdbint (word) AND 255) < 100 + THEN x := cdbtext (word) ; + IF pos (x, ""0"", ""31"", 1) = 0 CAND + pos (x, ""127"", ""213"", 1) = 0 CAND + pos (x, ""220"", code (255), 1) = 0 + THEN t CAT ":""" ; + t CAT x ; + t CAT """" + FI + FI . + +try type : + IF bool sinnvoll + THEN t CAT ":" ; + t CAT data object (offset, data base, 4) + FI ; + IF real sinnvoll + THEN t CAT ":" ; + t CAT x + FI ; + IF text sinnvoll + THEN t CAT ":" ; + t CAT text result + FI . + +keine steuerzeichen : + TEXT VAR text result := data object (offset, data base, 3) ; + anzahl steuerzeichen < 4 AND anzahl zeros < 2 AND word1 <> -1 . + +vorzeichen ok : + (word AND 240) = 0 OR (word AND 240) = 128 . + +nur digits : + IF (word AND 15) > 9 THEN FALSE + ELSE x := data object (offset, data base, 2) ; + FOR i FROM 2 UPTO 7 REP + byte := code (x SUB i) ; + IF (byte AND 240) > 249 OR (byte AND 15) > 9 + THEN LEAVE nur digits WITH FALSE + FI + PER ; + TRUE + FI . + +ENDPROC denoter ; + +TEXT PROC esc code : + SELECT low OF + CASE 0 : "RTN " + CASE 1 : "RTNT " + CASE 2 : "RTNF " + CASE 3 : "REPTXT?" + CASE 4 : "TERM " + CASE 5 : "??????" + CASE 6 : "KE " + CASE 7 : "??????" + CASE 8 : "CRD (" + params ("11") + CASE 9 : "BCRD (" + params ("11") + CASE 10 : "CWR (" + params ("111") + CASE 11 : "ECWR (" + params ("111") + CASE 12 : "CTT (" + params ("01") + CASE 13 : was bool result := TRUE ; "GETC (" + params ("311") + CASE 14 : was bool result := TRUE ; "FNONBL (" + params ("131") + CASE 15 : "DREM256 (" + params ("11") + CASE 16 : "AMUL256 (" + params ("11") + CASE 17 : "??????" + CASE 18 : was bool result := TRUE ; "ISDIG (" + params ("1") + CASE 19 : was bool result := TRUE ; "ISLD (" + params ("1") + CASE 20 : was bool result := TRUE ; "ISLCAS (" + params ("1") + CASE 21 : was bool result := TRUE ; "ISUCAS (" + params ("1") + CASE 22 : "GADDR (" + params ("111") + CASE 23 : was bool result := TRUE ; "GCADDR (" + params ("111") + CASE 24 : was bool result := TRUE ; "ISSHA (" + params ("1") + CASE 25 : "SYSGEN " + CASE 26 : "GETTAB " + CASE 27 : "PUTTAB " + CASE 28 : "ERTAB " + CASE 29 : "EXEC " + process module nr (next word, FALSE) + CASE 30 : "PPROC " + process module nr (next word, FALSE) + CASE 31 : "PCALL (" + params ("1") + CASE 32 : "CASE (" + params ("17") + CASE 33 : "MOVXX (" + params ("700") + CASE 34 : "ALIAS (" + params ("088") + CASE 35 : "MOVIM (" + params ("76") + CASE 36 : was bool result := TRUE ; "FEQU (" + params ("22") + CASE 37 : was bool result := TRUE ; "TLSEQ (" + params ("33") + CASE 38 : "FCOMPL (" + params ("22") + CASE 39 : "COMPL (" + params ("11") + CASE 40 : "IMULT (" + params ("111") + CASE 41 : "MULT (" + params ("111") + CASE 42 : "DIV (" + params ("111") + CASE 43 : "MOD (" + params ("111") + CASE 44 : "ISUB (" + params ("311") + CASE 45 : "replace (" + params ("311") + CASE 46 : "code (" + params ("31") + CASE 47 : "code (" + params ("13") + CASE 48 : "SUB (" + params ("313") + CASE 49 : "subtext (" + params ("3113") + CASE 50 : "subtext (" + params ("313") + CASE 51 : "replace (" + params ("313") + CASE 52 : "CAT (" + params ("33") + CASE 53 : "length (" + params ("31") + CASE 54 : "pos (" + params ("331") + CASE 55 : "pos (" + params ("3311") + CASE 56 : "pos (" + params ("33111") + CASE 57 : "stranalyze (" + params ("1113111") + CASE 58 : "pos (" + params ("33311") + CASE 59 : "??????" + CASE 60 : "out (" + params ("3") + CASE 61 : "cout (" + params ("1") + CASE 62 : "outsubtext (" + params ("31") + CASE 63 : "outsubtext (" + params ("311") + CASE 64 : "inchar (" + params ("3") + CASE 65 : "incharety (" + params ("3") + CASE 66 : "pause (" + params ("1") + CASE 67 : "getcursor (" + params ("11") + CASE 68 : "catinput (" + params ("33") + CASE 69 : "nilspace (" + params ("8") + CASE 70 : ":= DD (" + params ("88") + CASE 71 : "forget (" + params ("8") + CASE 72 : "typeDI (" + params ("81") + CASE 73 : "ItypeD (" + params ("81") + CASE 74 : "heapsize (" + params ("81") + CASE 75 : "enablestop " + CASE 76 : "disablestop " + CASE 77 : "seterrorstop (" + params ("1") + CASE 78 : was bool result := TRUE ; "iserror " + CASE 79 : "clearerror " + CASE 80 : "IpcbI (" + params ("11") + CASE 81 : "pcbII (" + params ("11") + CASE 82 : "setclock (" + params ("52") + CASE 83 : "??????" + CASE 84 : "control (" + params ("1111") + CASE 85 : "blockout (" + params ("81111") + CASE 86 : "blockin (" + params ("81111") + CASE 87 : "nextdspage (" + params ("811") + CASE 88 : "IpagesDT (" + params ("851") + CASE 89 : "storage (" + params ("11") + CASE 90 : "sysop (" + params ("1") + CASE 91 : "ARITH15 " + CASE 92 : "ARITH16 " + CASE 93 : "heapsize (" + params ("1") + CASE 94 : "collectheapgarbage " + CASE 95 : "??????" + CASE 96 : "FSLD (" + params ("121") + CASE 97 : "GEXP (" + params ("21") + CASE 98 : "SEXP (" + params ("12") + CASE 99 : "floor (" + params ("22") + CASE 100: "RSUB (" + params ("312") + CASE 101: "replace (" + params ("312") + CASE 102: "clock (" + params ("12") + CASE 103: "setclock (" + params ("2") + CASE 104: "pcb (" + params ("511") + CASE 105: "pcb (" + params ("511") + CASE 106: "clock (" + params ("52") + CASE 107: "status (" + params ("51") + CASE 108: "unblock (" + params ("5") + CASE 109: "block (" + params ("5") + CASE 110: "haltprocess (" + params ("5") + CASE 111: "createprocess (" + params ("55") + CASE 112: "eraseprocess (" + params ("5") + CASE 113: "send (" + params ("5181") + CASE 114: "wait (" + params ("518") + CASE 115: "call (" + params ("5181") + CASE 116: "cdbint (" + params ("11") + CASE 117: "cdbtext (" + params ("13") + CASE 118: "nextactive (" + params ("1") + CASE 119: "PW (" + params ("111") + CASE 120: "GW (" + params ("111") + CASE 121: "XOR (" + params ("111") + CASE 122: "pingpong (" + params ("5181") + CASE 123: was bool result := TRUE ; "exists (" + params ("5") + CASE 124: "AND (" + params ("111") + CASE 125: "OR (" + params ("111") + CASE 126: "session (" + params ("1") + CASE 127: "send (" + params ("55181") + CASE 128: "definecollector (" + params ("5") + CASE 129: "id (" + params ("11") + OTHERWISE "??????" + ENDSELECT . + +ENDPROC esc code ; + +TEXT PROC params (TEXT CONST types) : + INT VAR i , word ; + TEXT VAR t := "" ; + FOR i FROM 1 UPTO LENGTH types REP + word := next word ; + t CAT hex16 (word) ; + t CAT denoter (word, int (types SUB i)) ; + IF i <> LENGTH types THEN t CAT ", " FI + PER ; + t + ") " . + +ENDPROC params ; + +PROC init module tables : + INT VAR i, j ; + TEXT VAR t := " " ; + segment 2 modules := "" ; + segment 2 adresses := ""0"" ; + segment 3 modules := "" ; + segment 3 adresses := ""0"" ; + i := -1 ; + REP + i INCR 1 ; + cout (i) ; + j := getword (0, i + 512) ; + IF j <> -1 CAND i <> 216 CAND i <> 217 + THEN replace (t, 1, i) ; + segment 2 modules CAT t ; + replace (t, 1, j) ; + segment 2 adresses CAT t + ""0"" + ELIF i < 256 + THEN i := 255 + ELIF i < 320 + THEN i := 319 + FI + UNTIL j = -1 CAND i > 320 PER ; + FOR i FROM 1280 UPTO 2047 REP + cout (i) ; + j := getword (0, i + 512) ; + IF j <> -1 + THEN replace (t, 1, i) ; + segment 3 modules CAT t ; + replace (t, 1, j) ; + segment 3 adresses CAT t + ""0"" + FI + UNTIL j = -1 PER +ENDPROC init module tables ; + +TEXT PROC process module nr (INT CONST module number, BOOL CONST is packet) : + TEXT VAR object specification , mod nr := text (module number, 5) ; + IF module number < 0 + THEN IF lbas = -1 + THEN "LOCAL PROC" + ELSE "LOCAL:" + process module nr (getword (local data segment, lbas + (module number AND 32767)), is packet) + FI + ELSE + INT VAR code address := code start (module number) ; + IF one of compilers own module numbers + THEN object specification := "CDL" + ELIF elan defined internal + THEN SELECT module number OF + CASE 256 : object specification := "compiler (INT CONST, FILE VAR, TEXT CONST, INT VAR, BOOL CONST, BOOL CONST, BOOL CONST, BOOL CONST, BOOL CONST, BOOL CONST, BOOL CONST, BOOL CONST)" + CASE 257 : object specification := "outtext (TEXT CONST, INT CONST)" + CASE 258 : object specification := "outline (INT CONST)" + CASE 259 : object specification := "syntaxerror (TEXT CONST)" + CASE 260 : object specification := ":= (FILE VAR, FILE CONST)" + ENDSELECT + ELIF exists sorted module number table + THEN object specification := binary search (module number, is packet) + ELIF exists unsorted module number table + THEN FILE VAR f := sequentialfile (modify, "table.hash") ; + to firstrecord (f) ; + WHILE NOT eof (f) CAND subtext (f, 33, 37) <> mod nr REP + cout (lineno (f)) ; + down (f) + PER ; + IF eof (f) AND subtext (f, 33, 37) <> mod nr THEN + IF is packet + THEN object specification := "Paketinitialisierung" + ELSE object specification := "Hidden PROC/OP" + FI + ELSE object specification := compress (subtext (f, 1, 15)) + + specifications (begin of permanent table + int (subtext (f, 22, 25))) + FI + ELIF no elan module number + THEN object specification := "Objekt ohne Modulnummer!" + FI ; + was bool result := pos (object specification , "--> BOOL") <> 0 ; + text (module number) + " $" + hex8 (code segment) + + hex16 (code address) + " " + object specification + FI . + +one of compilers own module numbers : + module number < 256 . + +elan defined internal : + module number > 255 AND module number < 261 . + +exists sorted module number table : + exists ("table.module") AND module number > 319 . + +exists unsorted module number table: + exists ("table.hash") AND module number > 319 . + +no elan module number : + module number < 320 . + +ENDPROC process module nr ; + +TEXT PROC binary search (INT CONST nr, BOOL CONST is packet) : + TEXT VAR record , text nr := text (nr, 5) ; + INT VAR first line, last line , mid , i ; + FILE VAR f := sequentialfile (modify, "table.module") ; + first line := first module line ; + last line := lines (f) ; + REP + mid := (first line + last line) DIV 2 ; + to line (f, mid) ; + IF text nr > subtext (f, 33, 37) THEN first line := mid + 1 + ELSE last line := mid + FI + UNTIL first line = last line PER ; + to line (f, first line) ; + IF subtext (f, 33, 37) = text nr + THEN record := compress (subtext (f, 1, 15)) + + specifications (begin of permanent table + int (subtext (f, 22, 25))) + ELSE is hidden module + FI ; + record . + +is hidden module: + IF NOT is packet + THEN to line (f, first line - 1) + FI ; + FOR i FROM int (subtext (f, 22, 25)) + begin of permanent table DOWNTO begin of permanent table + WHILE cdbint (i) <> -2 REP PER ; + IF i <= begin of permanent table + THEN IF is packet + THEN record := "Paketinitialisierung" + ELSE record := "Hidden PROC/OP" + FI + ELSE IF is packet + THEN record := "Paketinitialisierung: " + + cdbtext (cdbint (i + 1) + 2) + ELSE record := "Hidden PROC/OP (Packet " + + cdbtext (cdbint (i + 1) + 2) + ")" + FI + FI . + +ENDPROC binary search ; + +TEXT PROC data object (INT CONST address, data base, denoter type) : + TEXT VAR t , result ; + INT VAR i , laenge , zeichen, index, version, segment, new address ; + IF address < 0 AND lbas = -1 + THEN LEAVE data object WITH "LOCAL" + ELIF address < 0 + THEN segment := local data segment ; + new address := (address AND 32767) ADD lbas + ELSE segment := packet data segment ; + new address := data base ADD address + FI ; + SELECT denoter type OF + CASE 1 : int denoter + CASE 2 : real denoter + CASE 3 : text denoter + CASE 4 : bool denoter + CASE 5 : task denoter + CASE 8 : dataspace denoter + OTHERWISE "DENOTERTYPE(" + text (denoter type) + ")?" + ENDSELECT . + +bool denoter : + IF get word (segment, new address) = 0 + THEN "TRUE" + ELSE "FALSE" + FI . + +int denoter : + hex16 (get word (segment, new address)) . + +real denoter : + t := "12345678" ; + FOR i FROM 0 UPTO 3 REP + replace (t, i + 1, get word (segment, new address ADD i)) + PER ; + disablestop ; + t := text (t RSUB 1) ; + IF iserror THEN clearerror ; + enablestop ; + "9.999999999999e126" + ELSE enablestop ; + t + FI . + +text denoter : + t := copied text var (segment, new address) ; + result := "" ; + anzahl steuerzeichen := 0 ; + anzahl zeros := 0 ; + FOR i FROM 1 UPTO length (t) REP + zeichen := code (t SUB i) ; + IF zeichen = 34 THEN result CAT """""" + ELIF zeichen = 251 OR zeichen > 31 AND zeichen < 127 OR + zeichen > 213 AND zeichen < 224 THEN result CAT code (zeichen) + ELSE result CAT """" ; + result CAT text (zeichen) ; + result CAT """" ; + anzahl steuerzeichen INCR 1 ; + IF zeichen = 0 + THEN anzahl zeros INCR 1 + FI + FI + PER ; + """" + result + """" . + +task denoter : + index := get word (segment, new address) ; + version := get word (segment, new address ADD 1) ; + hex16 (index) + " " + hex16 (version) + ":" + taskname (index, version) . + +dataspace denoter : + result := " " ; + replace (result, 1, get word (segment, new address)) ; + TEXT CONST two bytes :: hex8 (code (result SUB 2)) + " " + + hex8 (code (result SUB 1)) ; + IF result = ""255""255"" + THEN two bytes + ":Not Init" + ELIF result = ""0""0"" + THEN two bytes + ":nilspace" + ELSE two bytes + ":" + taskname (code (result SUB 2), -1) + FI . +ENDPROC data object ; + +TEXT PROC copied text var (INT CONST segment, address) : + TEXT VAR result ; + INT VAR i, laenge ; + result := " " ; + replace (result, 1, getword (segment, address ADD 1)) ; + laenge := code (result SUB 1) ; + IF laenge = 0 + THEN "" + ELIF laenge = 255 + THEN INT CONST basis :: -32765 ADD (getword (segment, address)-3) DIV 2 ; + laenge := ((result SUB 2) + code ((getword (segment, address + ADD 2) AND 255))) ISUB 1 ; + result := "" ; + FOR i FROM 1 UPTO laenge DIV 2 REP + result CAT " " ; + replace (result, i, getword (1, basis + i -1)) + PER ; + IF LENGTH result <> laenge + THEN result CAT code (getword (1, basis + laenge DIV 2)) + FI ; + result + ELSE TEXT CONST first char :: result SUB 2 ; + result := "" ; + FOR i FROM 1 UPTO (laenge-1) DIV 2 REP + result CAT " " ; + replace (result, i, getword (segment, address ADD (i + 1))) ; + PER ; + IF LENGTH result + 1 <> laenge + THEN first char + result + code (getword (segment, address ADD + ((laenge-1) DIV 2 + 2)) AND 255) + ELSE first char + result + FI + FI +ENDPROC copied text var ; + +TEXT PROC task name (INT CONST id, vers) : + TEXT VAR result ; + DATASPACE VAR ds := nilspace ; + BOUND STRUCT (INT index, version) VAR t1 := ds ; + BOUND TASK VAR t2 := ds ; + IF id = 0 + THEN result := "niltask" + ELSE t1.index := id AND 255 ; + IF vers = -1 + THEN t1.version := 0 ; + t1.version := pcb (t2, 10) + ELSE t1.version := vers + FI ; + disablestop ; + IF exists (t2) + THEN result := """" + name (t2) + """" + ELSE result := "-" + FI ; + FI ; + forget (ds) ; + enable stop ; + result +ENDPROC task name ; + +INT PROC integer (TEXT CONST hex addr) : + INT VAR i ; + REAL VAR summe := 0.0 ; + FOR i FROM 1 UPTO length (hex addr) REP + summe := summe * 16.0 ; + summe INCR real (digit) + PER ; + IF summe > 32767.0 THEN int (summe - 65536.0) + ELSE int (summe) + FI. + +digit : + TEXT CONST char := hex addr SUB i ; + IF char >= "a" THEN code (char) - 87 + ELIF char >= "A" THEN code (char) - 55 + ELSE code (char) - 48 + FI +ENDPROC integer ; + +TEXT PROC hex8 (INT CONST wert) : + hex digit (wert DIV 16) + + hex digit (wert AND 15) +ENDPROC hex8 ; + +TEXT PROC hex16 (INT CONST wert) : + TEXT VAR t := " " ; + replace (t, 1, wert) ; + hex digit (code (t SUB 2) DIV 16) + + hex digit (code (t SUB 2) AND 15) + + hex digit (code (t SUB 1) DIV 16) + + hex digit (code (t SUB 1) AND 15) +ENDPROC hex16 ; + +TEXT PROC hex digit (INT CONST wert) : + IF wert < 10 THEN code (wert + 48) + ELSE code (wert + 55) + FI +ENDPROC hex digit ; + +INT OP ADD (INT CONST left, right) : + arith 16 ; + INT CONST result :: left + right ; + arith 15 ; + result +ENDOP ADD ; + +PROC disass0 : +TEXT VAR key ; +IF exists ("table.module") + THEN FILE VAR f := sequentialfile (modify, "table.module") ; + tofirstrecord (f) ; + down (f, " 322 ") ; + first module line := lineno (f) ; +FI ; +REP + page ; + putline ("++++++++++++++++++++++++ EUMEL0 - Code Disassembler ++++++++++++++++++++") ; + line (3) ; + putline (" 0 ......... Ende") ; + putline (" 1 ......... Objekt nach Name auswaehlen und disassemblieren") ; + putline (" 2 ......... Nach Modulnummer auswaehlen und disassemblieren") ; + putline (" 3 ......... Adressbereich disassemblieren") ; + putline (" 4 ......... Denoter aus Staticarea (Segment 0) ausgeben") ; + putline (" 5 ......... Codestart zur Modulnummer errechnen") ; + putline (" 6 ......... Modultabelle ergaenzen") ; + line ; + put ("Wahl:") ; + REP inchar (key) UNTIL key >= "0" AND key <= "6" PER ; + out (key) ; + line (2) ; + SELECT int (key) OF + CASE 0 : LEAVE disass 0 + CASE 1 : disass object + CASE 2 : disass module nr + CASE 3 : disass address + CASE 4 : put denoter + CASE 5 : convert module number + CASE 6 : erweitere modul tabelle + ENDSELECT +PER . + +erweitere modul tabelle : + INT VAR i, j ; + key := " " ; + FOR i FROM LENGTH segment 3 modules DIV 2 + 1280 UPTO 2047 REP + cout (i) ; + j := get word (0, 512 + i) ; + IF j <> -1 + THEN replace (key, 1, i) ; + segment 3 modules CAT key ; + replace (key, 1, j) ; + segment 3 adresses CAT key + ""0"" ; + FI + UNTIL j = -1 PER. + +convert module number : + line (2) ; + INT VAR mod nr ; + put ("Modulnummer:") ; + get (mod nr) ; + mod nr := code start (mod nr) ; + IF mod nr = -1 + THEN putline ("Unbelegte Modulnummer") + ELSE put ("Adresse:") ; put (hex16 (mod nr)) ; line ; + put ("Segment:") ; put (code segment) ; line + FI ; + putline ("- Taste -") ; + pause. + +put denoter : + line (2) ; + put ("PENTER(xx) in Hex:") ; + getline (key) ; + INT VAR base :: integer (key), typ ; + put ("Offset in Hex:") ; + getline (key) ; + typ := integer (key) ; + put ("TYPE (INT, REAL, TEXT, BOOL, TASK, DATASPACE):") ; + getline (key) ; + IF key = "INT" THEN typ := 1 + ELIF key = "REAL" THEN typ := 2 + ELIF key = "TEXT" THEN typ := 3 + ELIF key = "BOOL" THEN typ := 4 + ELIF key = "TASK" THEN typ := 5 + ELIF key = "DATASPACE" THEN typ := 8 + ELSE typ := 0 + FI ; + lbas := -1 ; + putline (data object (typ, (""0"" + code (base)) ISUB 1, typ)) ; + putline ("- Taste -") ; + pause . + +ENDPROC disass 0 ; + +init module tables ; +disass 0 + +ENDPACKET eumel 0 code disassembler ; diff --git a/devel/misc/unknown/src/ASSEMBLE.ELA b/devel/misc/unknown/src/ASSEMBLE.ELA new file mode 100644 index 0000000..7675dc4 --- /dev/null +++ b/devel/misc/unknown/src/ASSEMBLE.ELA @@ -0,0 +1,387 @@ +(***Assembler fuer 8080,8085,Z80***) + +PROC regh: + IF pos(in,"A",4) = (pos(in,",")+1) THEN out(printer,"F"); +ELIF pos(in,"B",4) = (pos(in,",")+1) THEN out(printer,"8"); +ELIF pos(in,"C",4) = (pos(in,",")+1) THEN out(printer,"9"); +ELIF pos(in,"D",4) = (pos(in,",")+1) THEN out(printer,"A"); +ELIF pos(in,"E",4) = (pos(in,",")+1) THEN out(printer,"B"); +ELIF pos(in,"H",4) = (pos(in,",")+1) THEN out(printer,"C"); +ELIF pos(in,"L",4) = (pos(in,",")+1) THEN out(printer,"D"); +ELIF pos(in,"M",4) = (pos(in,",")+1) OR pos(in,"m") = (pos(in,",")+1) + THEN out(printer,"E") FI +ENDPROC regh. + +PROC regl: + IF pos(in,"A",4) > (pos(in,",")+0) THEN out(printer,"7"); +ELIF pos(in,"B",4) > (pos(in,",")+0) THEN out(printer,"0"); +ELIF pos(in,"C",4) > (pos(in,",")+0) THEN out(printer,"1"); +ELIF pos(in,"D",4) > (pos(in,",")+0) THEN out(printer,"2"); +ELIF pos(in,"E",4) > (pos(in,",")+0) THEN out(printer,"3"); +ELIF pos(in,"H",4) > (pos(in,",")+0) THEN out(printer,"4"); +ELIF pos(in,"L",4) > (pos(in,",")+0) THEN out(printer,"5"); +ELIF pos(in,"M",4) > (pos(in,",")+0) OR pos(in,"m") > (pos(in,",")+0) + THEN out(printer,"6") FI +ENDPROC regl. + (*************************) + (*Autor:M.Staubermann *) +BOOL VAR ad,number,falsch; (*Version:1.2.2 *) +ad:=FALSE; (*Datum:7.12.82 *) +number:=FALSE; (*************************) +falsch:=FALSE; +INT VAR count,fehler; +TEXT VAR hilf,in,startaddresse::"0000"; +hilf:=" "; +count:=0; +fehler:=0; +hilf:=" "; +commanddialogue(FALSE); +forget("maschinencode"); +FILE VAR printer:=sequentialfile(output,"maschinencode"); +forget("assemb"); +FILE VAR ass:=sequentialfile(modify,"assemb"); +forget("errors"); +FILE VAR fehlerliste:=sequentialfile(output,"errors"); +commanddialogue(TRUE); +line; +putline(" gib assembler kommando :"); +putline(" edit"); +pause(10); +edit("assemb"); +tofirstrecord(ass); +putline(" gib assembler kommando :"); +putline(" debug"); +pause(10); +line; +put (" "); +put(printer,"Line: Add: Code:"); +line(printer); +hexbeginn; + + REPEAT + fehler:=fehler+1; + out(printer,text(fehler,4)); + cout(fehler); + out(printer," "); + hex; + readrecord(ass,in); + forward(ass); + out(printer," "); + IF pos(in,"NOP") > 0 THEN out(printer,"00"); +ELIF pos(in,"HLT") > 0 THEN out(printer,"76"); +ELIF compress(in)="DI" THEN out(printer,"F3"); +ELIF pos(in,"EI") > 0 THEN out(printer,"FB"); +ELIF pos(in,"CMC") > 0 THEN out(printer,"3F"); +ELIF pos(in,"CMA") > 0 THEN out(printer,"2F"); +ELIF pos(in,"STC") > 0 THEN out(printer,"37"); +ELIF pos(in,"DAA") > 0 THEN out(printer,"27"); +ELIF pos(in,"RRC") > 0 THEN out(printer,"0F"); +ELIF pos(in,"RLC") > 0 THEN out(printer,"07"); +ELIF pos(in,"RAL") > 0 THEN out(printer,"17"); +ELIF pos(in,"RAR") > 0 THEN out(printer,"1F"); +ELIF pos(in,"XCHG")> 0 THEN out(printer,"EB"); +ELIF pos(in,"XTHL")> 0 THEN out(printer,"E3"); +ELIF pos(in,"SPHL")> 0 THEN out(printer,"F9"); +ELIF pos(in,"ADI") > 0 THEN out(printer,"C6");number:=TRUE; +ELIF pos(in,"ACI") > 0 THEN out(printer,"CE");number:=TRUE; +ELIF pos(in,"SUI") > 0 THEN out(printer,"D6");number:=TRUE; +ELIF pos(in,"SBI") > 0 THEN out(printer,"DE");number:=TRUE; +ELIF pos(in,"ANI") > 0 THEN out(printer,"E6");number:=TRUE; +ELIF pos(in,"XRI") > 0 THEN out(printer,"EE");number:=TRUE; +ELIF pos(in,"ORI") > 0 THEN out(printer,"F6");number:=TRUE; +ELIF pos(in,"CPI") > 0 THEN out(printer,"FE");number:=TRUE; +ELIF compress(in)="STA"THEN out(printer,"32");ad:=TRUE; +ELIF compress(in)="LDA"THEN out(printer,"3A");ad:=TRUE; +ELIF pos(in,"SHLD")> 0 THEN out(printer,"22");ad:=TRUE; +ELIF pos(in,"LHLD")> 0 THEN out(printer,"2A");ad:=TRUE; +ELIF pos(in,"PCHL")> 0 THEN out(printer,"E9"); +ELIF pos(in,"JMP") > 0 THEN out(printer,"C3");ad:=TRUE; +ELIF pos(in,"JC") > 0 THEN out(printer,"DA");ad:=TRUE; +ELIF pos(in,"JNC") > 0 THEN out(printer,"D2");ad:=TRUE; +ELIF pos(in,"JZ") > 0 THEN out(printer,"CA");ad:=TRUE; +ELIF pos(in,"JNZ") > 0 THEN out(printer,"C2");ad:=TRUE; +ELIF compress(in)="JM" THEN out(printer,"FA");ad:=TRUE; +ELIF compress(in)="JP" THEN out(printer,"F2");ad:=TRUE; +ELIF pos(in,"JPE") > 0 THEN out(printer,"EA");ad:=TRUE; +ELIF pos(in,"JPO") > 0 THEN out(printer,"E2");ad:=TRUE; +ELIF pos(in,"CALL")> 0 THEN out(printer,"CD");ad:=TRUE; +ELIF pos(in,"OUT") > 0 THEN out(printer,"D3");number:=TRUE; +ELIF pos(in,"CC") > 0 THEN out(printer,"DC");ad:=TRUE; +ELIF pos(in,"CNC") > 0 THEN out(printer,"D4");ad:=TRUE; +ELIF pos(in,"CZ") > 0 THEN out(printer,"CC");ad:=TRUE; +ELIF pos(in,"CNZ") > 0 THEN out(printer,"C4");ad:=TRUE; +ELIF pos(in,"CM") > 0 THEN out(printer,"FC");ad:=TRUE; +ELIF compress(in)="CP" THEN out(printer,"F4");ad:=TRUE; +ELIF pos(in,"CPE") > 0 THEN out(printer,"EC");ad:=TRUE; +ELIF pos(in,"CPO") > 0 THEN out(printer,"E4");ad:=TRUE; +ELIF pos(in,"RET") > 0 THEN out(printer,"C9"); +ELIF pos(in,"RC") > 0 THEN out(printer,"D8"); +ELIF pos(in,"RNC") > 0 THEN out(printer,"D0"); +ELIF pos(in,"RZ") > 0 THEN out(printer,"C8"); +ELIF pos(in,"RNZ") > 0 THEN out(printer,"C0"); +ELIF pos(in,"RM") > 0 THEN out(printer,"F8"); +ELIF compress(in)="RP" THEN out(printer,"F0"); +ELIF pos(in,"RPE") > 0 THEN out(printer,"E8"); +ELIF pos(in,"RPO") > 0 THEN out(printer,"E0"); +ELIF pos(in,"RST") > 0 AND pos(in,"0") > 3 THEN out(printer,"C7"); +ELIF pos(in,"RST") > 0 AND pos(in,"1") > 3 THEN out(printer,"CF"); +ELIF pos(in,"RST") > 0 AND pos(in,"2") > 3 THEN out(printer,"D7"); +ELIF pos(in,"RST") > 0 AND pos(in,"3") > 3 THEN out(printer,"DF"); +ELIF pos(in,"RST") > 0 AND pos(in,"4") > 3 THEN out(printer,"E7"); +ELIF pos(in,"RST") > 0 AND pos(in,"5") > 3 THEN out(printer,"EF"); +ELIF pos(in,"RST") > 0 AND pos(in,"6") > 3 THEN out(printer,"F7"); +ELIF pos(in,"RST") > 0 AND pos(in,"7") > 3 THEN out(printer,"FF"); +ELIF pos(in,"MOV") > 0 THEN + IF pos(in,"A") = (pos(in,",")-1) THEN out(printer,"7");regh; + ELIF pos(in,"B") = (pos(in,",")-1) THEN out(printer,"4");regl; + ELIF pos(in,"C") = (pos(in,",")-1) THEN out(printer,"4");regh; + ELIF pos(in,"D") = (pos(in,",")-1) THEN out(printer,"5");regl; + ELIF pos(in,"E") = (pos(in,",")-1) THEN out(printer,"5");regh; + ELIF pos(in,"H") = (pos(in,",")-1) THEN out(printer,"6");regl; + ELIF pos(in,"L") = (pos(in,",")-1) THEN out(printer,"6");regh; + ELIF pos(in,"M",4) = (pos(in,",")-1) OR pos(in,"m") = (pos(in,",")-1) + THEN out(printer,"4");regl FI; +ELIF pos(in,"MVI") > 0 THEN + IF pos(in,"A") = (pos(in,",")-1) THEN out(printer,"3E"); + ELIF pos(in,"B") = (pos(in,",")-1) THEN out(printer,"06"); + ELIF pos(in,"C") = (pos(in,",")-1) THEN out(printer,"0E"); + ELIF pos(in,"D") = (pos(in,",")-1) THEN out(printer,"16"); + ELIF pos(in,"E") = (pos(in,",")-1) THEN out(printer,"1E"); + ELIF pos(in,"H") = (pos(in,",")-1) THEN out(printer,"26"); + ELIF pos(in,"L") = (pos(in,",")-1) THEN out(printer,"2E"); + ELIF pos(in,"M",4) = (pos(in,",")-1) OR pos(in,"m") = (pos(in,",")-1) + THEN out(printer,"36") FI; +ELIF pos(in,"LXI") > 0 THEN ad:=TRUE; + IF pos(in,"B") > 4 THEN out(printer,"01");ad:=TRUE; + ELIF pos(in,"D") > 4 THEN out(printer,"11");ad:=TRUE; + ELIF pos(in,"H") > 4 THEN out(printer,"21");ad:=TRUE; + ELIF pos(in,"SP")> 4 THEN out(printer,"31");ad:=TRUE FI; +ELIF pos(in,"PUSH") > 0 THEN + IF pos(in,"B") > 4 THEN out(printer,"C5"); + ELIF pos(in,"D") > 4 THEN out(printer,"D5"); + ELIF pos(in,"H",5) > 4 THEN out(printer,"E5"); + ELIF pos(in,"A") > 4 OR pos(in,"PSW")> 4 THEN out(printer,"F5") FI; + ELIF pos(in,"POP") > 0 THEN + IF pos(in,"B") > 4 THEN out(printer,"C1"); + ELIF pos(in,"D") > 4 THEN out(printer,"D1"); + ELIF pos(in,"H") > 4 THEN out(printer,"E1"); + ELIF pos(in,"A") > 4 OR pos(in,"PSW")> 4 THEN out(printer,"F1") FI; +ELIF pos(in,"LDAX") > 0 THEN + IF pos(in,"B") > 4 THEN out(printer,"0A"); + ELIF pos(in,"D",5) > 4 THEN out(printer,"1A") FI; +ELIF pos(in,"STAX") > 0 THEN + IF pos(in,"B") > 4 THEN out(printer,"02"); + ELIF pos(in,"D") > 4 THEN out(printer,"12") FI; +ELIF pos(in,"INX") > 0 THEN + IF pos(in,"B") > 4 THEN out(printer,"03"); + ELIF pos(in,"D") > 4 THEN out(printer,"13"); + ELIF pos(in,"H") > 4 THEN out(printer,"2A"); + ELIF pos(in,"SP")> 4 THEN out(printer,"3A") FI; +ELIF pos(in,"DCX") > 0 THEN + IF pos(in,"B") > 4 THEN out(printer,"0B"); + ELIF pos(in,"D",4)>4 THEN out(printer,"1B"); + ELIF pos(in,"H") > 4 THEN out(printer,"2B"); + ELIF pos(in,"SP")> 4 THEN out(printer,"3B") FI; +ELIF pos(in,"DAD") > 0 THEN + IF pos(in,"B") > 4 THEN out(printer,"09"); + ELIF pos(in,"D",4)>4 THEN out(printer,"19"); + ELIF pos(in,"H") > 4 THEN out(printer,"29"); + ELIF pos(in,"SP")> 4 THEN out(printer,"39") FI; +ELIF pos(in,"ADD") > 0 THEN out(printer,"8");regl; +ELIF pos(in,"ADC") > 0 THEN out(printer,"8");regl; +ELIF pos(in,"SUB") > 0 THEN out(printer,"9");regl; +ELIF pos(in,"SBB") > 0 THEN out(printer,"9");regl; +ELIF pos(in,"ANA") > 0 THEN out(printer,"A");regl; +ELIF pos(in,"XRA") > 0 THEN out(printer,"A");regl; +ELIF pos(in,"ORA") > 0 THEN out(printer,"B");regl; +ELIF pos(in,"CMP") > 0 THEN out(printer,"B");regl; +ELIF pos(in,"INR") > 0 THEN + IFpos(in,"A") > 4 THEN out(printer,"3C") FI; +ELIF pos(in,"INR") > 0 THEN + IFpos(in,"B") > 4 THEN out(printer,"04") FI; +ELIF pos(in,"INR") > 0 THEN + IFpos(in,"C") > 4 THEN out(printer,"0C") FI; +ELIF pos(in,"INR") > 0 THEN + IFpos(in,"D") > 4 THEN out(printer,"14") FI; +ELIF pos(in,"INR") > 0 THEN + IFpos(in,"E") > 4 THEN out(printer,"1C") FI; +ELIF pos(in,"INR") > 0 THEN + IFpos(in,"H") > 4 THEN out(printer,"24") FI; +ELIF pos(in,"INR") > 0 THEN + IFpos(in,"L") > 4 THEN out(printer,"2C") FI; +ELIF pos(in,"INR") > 0 THEN + IFpos(in,"M") > 4 OR pos(in,"m") > 4 THEN out(printer,"34") FI; +ELIF pos(in, "IN") > 0 THEN out(printer,"DB"); number:=TRUE; +ELIF pos(in,"DCR") > 0 THEN + IFpos(in,"A") > 4 THEN out(printer,"3D") FI; +ELIF pos(in,"DCR") > 0 THEN + IFpos(in,"B") > 4 THEN out(printer,"05") FI; +ELIF pos(in,"DCR") > 0 THEN + IFpos(in,"C",4) > 4 THEN out(printer,"0D") FI; +ELIF pos(in,"DCR") > 0 THEN + IFpos(in,"D",4) > 4 THEN out(printer,"15") FI; +ELIF pos(in,"DCR") > 0 THEN + IFpos(in,"E") > 4 THEN out(printer,"1D") FI; +ELIF pos(in,"DCR") > 0 THEN + IFpos(in,"H") > 4 THEN out(printer,"25") FI; +ELIF pos(in,"DCR") > 0 THEN + IFpos(in,"L") > 4 THEN out(printer,"2D") FI; +ELIF pos(in,"DCR") > 0 THEN + IFpos(in,"M") > 4 OR pos(in,"m") > 4 THEN out(printer,"35") FI; +ELIF pos(in,"ORG") > 0 THEN hilf:=compress(subtext(in,4,7)); + putline(printer,hilf); + startaddresse:=hilf; + hexbeginn; +ELIF pos(in,"TITL") > 0 THEN putline(printer,subtext(in,6)); +ELIF pos(in,"#") > 0 THEN hilf:=subtext(in,pos(in,"#")+1); + out(printer,hilf) ; +ELSE putline("Fehler erkannt in Zeile "+text(fehler)+" bei '"+in+"' !"); + out(printer,in); + putline(fehlerliste,"Fehler in Zeile "+text(fehler)+" bei: "+in); + count:=count+1; + falsch:=TRUE +FI; +line(printer); +IF ad THEN ad:=FALSE; + fehler:=fehler+1; + out(printer,text(fehler,4)); + cout(fehler); + out(printer," "); + hex; + out(printer," "); + IF pos(in,",") > 3 THEN hilf:=subtext(in,(pos(in,",")+1),(pos(in,",")+4)); + fehler:=fehler+1; + out(printer,text(fehler,4)); + cout(fehler); + out(printer," "); + hex; + out(printer," "); + line(printer) + ELSE hilf:=compress(subtext(in,10,15)) FI; + fehler:=fehler+1; + out(printer,text(fehler,4)); + cout(fehler); + out(printer," "); + hex; + out(printer," "); + out(printer,subtext(hilf,3,4)); + fehler:=fehler+1; + out(printer,text(fehler,4)); + cout(fehler); + out(printer," "); + hex; + out(printer," "); + out(printer,subtext(hilf,1,2)); + line(printer); + +ELIF number THEN number:=FALSE; + fehler:=fehler+1; + out(printer,text(fehler,4)); + cout(fehler); + out(printer," "); + hex; + out(printer," "); + IF pos(in,",") > 2 THEN hilf:= subtext(in, + (pos(in,",") +1),(pos(in,",")+2)); + out(printer,hilf); + line(printer) + ELSE out(printer,compress(subtext(in,14,21))); + line(printer) FI +FI ; + +UNTIL compress(in) = "END" OR compress(in) = "end" OR eof(ass) ENDREPEAT; + + IF count<> 0 THEN putline(text(count)+" Fehler erkannt."); + falsch:=TRUE +ELSE putline(" Keine Fehler, "+text(fehler)+" Zeilen.") ; + falsch:=FALSE +FI; +putline(8*" "+7*"*"+" ENDE DER UEBERSETZUNG "+7*"*"+8*" "); +pause(20); +IF falsch THEN edit("errors","assemb") ELSE +edit("maschinencode") FI; +IF yes("Maschinencodelisting") THEN print("maschinencode") FI; +IF yes("runagain") THEN runagain FI. + +hexbeginn: +(*Hexadezimalzaehler*) +INT VAR a1,a2,a3,a4,subi; +TEXT VAR a1t,a2t,a3t,a4t,subt,counter; +a1t:=subtext(startaddresse,1,1); +a2t:=subtext(startaddresse,2,2); +a3t:=subtext(startaddresse,3,3); +a4t:=subtext(startaddresse,4,4). + +hex: +subt:=a1t; +decoder; +a1:=subi; + +subt:=a2t; +decoder; +a2:=subi; + +subt:=a3t; +decoder; +a3:=subi; + + +decoder; +a4:=subi; + +zaehl; + +IF a4 = 16 THEN a4:=0; + a3:=a3+1 FI; + +IF a3 = 16 THEN a3:=0; + a2:=a2+1 FI; + +IF a2 = 16 THEN a2:=0; + a1:=a1+1 FI; + +IF a1 = 16 THEN a1:=0; + put(printer,"Storageoverflow !") FI; + +subi:=a1; +encode; +a1t:=subt; + +subi:=a2; +encode; +a2t:=subt; + +subi:=a3; +encode; +a3t:=subt; + +subi:=a4; +encode; +a4t:=subt; + +counter:=a1t; +counter CAT a2t; +counter CAT a3t; +counter CAT a4t; +put(printer,counter). + +zaehl: +a4:=a4+1. + +decoder: +IF subt ="A" THEN subi:=10; +ELIF subt ="B" THEN subi:=11; +ELIF subt ="C" THEN subi:=12; +ELIF subt ="D" THEN subi:=13; +ELIF subt ="E" THEN subi:=14; +ELIF subt ="F" THEN subi:=15 +ELSE subi:=int(subt) FI. + +encode: +IF subi = 10 THEN subt:="A"; +ELIF subi = 11 THEN subt:="B"; +ELIF subi = 12 THEN subt:="C"; +ELIF subi = 13 THEN subt:="D"; +ELIF subi = 14 THEN subt:="E"; +ELIF subi = 15 THEN subt:="F" +ELSE subt:=text(subi) FI. diff --git a/devel/misc/unknown/src/COPYDS.ELA b/devel/misc/unknown/src/COPYDS.ELA new file mode 100644 index 0000000..c0bd83c --- /dev/null +++ b/devel/misc/unknown/src/COPYDS.ELA @@ -0,0 +1,294 @@ +LET systemanker = 2 , (* Wird bei 'blockin' durch 2 geteilt *) + channel field = 4 , + hg channel = 0 ; + +ROW 256 INT VAR block ; +INT VAR return ; + +PROC pcb (TASK CONST id, INT CONST field, value) : + EXTERNAL 105 +ENDPROC pcb ; + +PROC copy ds (INT CONST task nr, ds nr, TEXT CONST destination) : + DATASPACE VAR ds ; + ROW 8 INT VAR dr eintrag ; + INT VAR old channel := channel, link, i, seite ; + + system channel ; + zugriff ueber drdr ; + IF ist nilspace + THEN ds := nilspace + ELIF ist kleindatenraum + THEN lese kleindatenraum + ELSE lese grossdatenraum + FI ; + user channel ; + forget (destination, quiet) ; + copy (ds, destination) ; + forget (ds) . + +user channel : + disablestop ; + continue (old channel) ; + IF iserror + THEN forget (ds) ; + FI ; + enablestop . + +system channel : + break (quiet) ; (* Offiziell abmelden *) + pcb (myself, channel field, hg channel) . (* Inoffiziell anmelden *) + +zugriff ueber drdr : + systemanker lesen ; + drdr taskwurzel lesen ; + drdr dataspacewurzel lesen . + +erste seite im dreintrag : + link := 8 * (dsnr MOD 32) + 1 ; + FOR i FROM link UPTO link + 7 REP + IF block (i) <> -1 + THEN LEAVE erste seite im dreintrag WITH i + FI + PER ; + user channel ; + errorstop ("Der Datenraum existiert nicht (DR-Eintrag = 8 mal FFFF)") ; 0 . + +ist nilspace : + block (erste seite im dreintrag) = -255 . + +ist kleindatenraum : + block (link) > -255 AND block (link) < 0 . + +lese kleindatenraum : + ds := nilspace ; + IF seite eins existiert + THEN blockin (ds, 1, block (link + 1)) ; + IF return <> 0 + THEN user channel ; + putline ("Warnung: Seite 1 des Datenraums nicht lesbar: " + + text (return)) ; + system channel + FI + FI ; + IF seite zwei existiert + THEN blockin (ds, 2, block (link + 2)) ; + IF return <> 0 + THEN user channel ; + putline ("Warnung: Seite 2 des Datenraums nicht lesbar: " + + text (return)) ; + system channel + FI + FI ; + IF mehr als zwei seiten + THEN FOR i FROM 0 UPTO 4 REP + IF hoehere seite existiert + THEN blockin (ds, i + basisseite, block (link + i + 3)) ; + IF return <> 0 + THEN user channel ; + putline ("Warnung: Seite " + text (i + basisseite) + + " des Datenraums nicht lesbar: " + + text (return)) ; + system channel + FI + FI + PER + FI . + +seite eins existiert : + exists (block (link + 1)) . + +seite zwei existiert : + exists (block (link + 2)) . + +mehr als zwei seiten : + exists (block (link)) . + +hoehere seite existiert : + exists (block (link + i + 3)) . + +basisseite : + block (link) AND 255 . + +lese grossdatenraum : + ds := nilspace ; + dreintrag kopieren ; + seite := 0 ; + FOR i FROM 1 UPTO 8 REP + IF seitenblocktabelle existiert + THEN seitenblocktabelle lesen ; + seiten kopieren wenn sie in der seitenblocktabelle vorhanden sind + ELSE seite INCR 256 + FI + PER . + +seitenblocktabelle lesen : + blockin (dr eintrag (i)) ; + IF return <> 0 + THEN user channel ; + putline ("Warnung: Seitenblocktabelle " + text (i-1) + + " des Datenraums nicht lesbar: " + text (return)) ; + putline ("Damit fehlen die Seiten " + text (max (1, seite)) + + " bis " + text (seite + 255)) ; + system channel + FI . + +seiten kopieren wenn sie in der seitenblocktabelle vorhanden sind : + FOR link FROM 1 UPTO 256 REP + IF seite vorhanden + THEN blockin (ds, seite, block (link)) ; + IF return <> 0 + THEN user channel ; + putline ("Warnung: Seite " + text (seite) + + " des Datenraums nicht lesbar: " + text (return)) ; + system channel + FI ; + user channel ; + cout (seite) ; + system channel + FI ; + seite INCR 1 + PER . + +seite vorhanden : + exists (block (link)) . + +seitenblocktabelle existiert : + exists (dreintrag (i)) . + +dreintrag kopieren : + FOR i FROM 0 UPTO 7 REP + dreintrag (i + 1) := block (link + i) + PER . + +systemanker lesen : + blockin (systemanker) ; + IF return <> 0 + THEN user channel ; + errorstop ("Systemanker nicht lesbar: " + text (return)) + FI . + +drdr taskwurzel lesen : + link := block (tasknr DIV 32 + 1) ; + IF link = -1 + THEN user channel ; + errorstop ("Die Task existiert nicht") + FI ; + blockin (link) ; + IF return <> 0 + THEN user channel ; + errorstop ("Taskwurzel des DRDR nicht lesbar: " + text (return)) + FI . + +drdr dataspacewurzel lesen : + link := block (8 * (tasknr MOD 32) + dsnr DIV 32 + 1) ; + IF NOT exists (link) + THEN user channel ; + errorstop ("Der Datenraum (und weitere 31) existiert nicht") + FI ; + blockin (link) ; + IF return <> 0 + THEN user channel ; + errorstop ("Dataspacewurzel des DRDR nicht lesbar: " + + text (return)) + FI . + +ENDPROC copy ds ; + +BOOL PROC exists (INT CONST blocknr) : + blocknr <> -1 AND blocknr <> -255 +ENDPROC exists ; + +PROC blockin (INT CONST blocknr) : + blockin (block, 0, blocknr DIV 2, return) ; (* ggf COPBIT ausblenden *) +ENDPROC blockin ; + +PROC blockin (DATASPACE VAR ds, INT CONST page, blocknr) : + blockin (ds, page, 0, blocknr DIV 2, return) (* ggf COPBIT ausblenden *) +ENDPROC blockin ; + +PROC dump (TEXT CONST datei) : + edit dump (datei, FALSE) +ENDPROC dump ; + +PROC edit dump (TEXT CONST datei, BOOL CONST write access) : + BOUND STRUCT (ROW 252 INT page1, ROW 2047 ROW 256 INT blocks) VAR b ; + b := old (datei) ; + INT VAR blocknr := 1, i ; + TEXT VAR esc char, t ; + BOOL VAR clear := TRUE , modified ; + ROW 256 INT VAR page 1 ; + page 1 (1) := 0 ; + page 1 (2) := 0 ; + page 1 (3) := type (old (datei)) ; + page 1 (4) := -1 ; + page ; + put ("Info mit 'ESC ?'") ; + dump cursor (4, 3) ; + REP + out (""1""5"Datei: """) ; out (datei) ; put ("""") ; + put (", Page:") ; put (text (blocknr, 5)) ; + put (", Dspages:") ; put (text (dspages (old (datei)), 5)) ; + put (", Type:") ; put (type (old (datei))) ; + IF blocknr = 1 + THEN FOR i FROM 1 UPTO 252 REP + page1 (i + 4) := b.page1 (i) + PER ; + edit dump (page 1, 1, 256, clear, write access, modified, esc char); + IF modified + THEN FOR i FROM 1 UPTO 252 REP + b.page1 (i) := page 1 (i + 4) + PER ; + type (old (datei), page 1 (3)) + FI + ELSE edit dump (b.blocks (blocknr), 1, 256, clear, write access, modified, esc char) + FI ; + clear := TRUE ; + IF esc char = ""1""10"" + THEN blocknr INCR 1 + ELIF esc char = ""1""3"" + THEN IF blocknr > 1 + THEN blocknr DECR 1 + ELSE clear := FALSE ; + out (""1""15"E r s t e S e i t e "14""5"") + FI + ELIF esc char = ""27"q" + THEN LEAVE edit dump + ELIF esc char = ""27"?" + THEN clear := FALSE ; + putline (""1"ESC:?,p,q,w,F,0; HOP:HOP,LEFT,UP,DOWN,RIGHT; DEL,INS,LEFT,UP,RIGHT") ; + ELIF esc char = ""27"p" + THEN REP + put(""1""5"Neue Pagenr:") ; + t := text (blocknr) ; + editget (t) ; + blocknr := int (t) + UNTIL blocknr >= 0 AND blocknr < 2048 PER + ELSE clear := FALSE + FI ; + PER +ENDPROC edit dump ; + +INT VAR task index, ds nr ; +TEXT VAR task id ; +page ; +put ("""Taskname"" oder Taskindex:") ; +getline (task id) ; +IF pos (task id, """") > 0 + THEN scan (task id) ; + nextsymbol (task id) ; + task index := index (task (task id)) + ELSE task index := int (task id) +FI ; +put ("Dataspacenummer in der Task:") ; +get (ds nr) ; +IF ds nr < 4 + THEN errorstop ("Es gibt nur DATASPACE-Nummern >= 4") +FI ; +IF yes ("Soll vorher ein Fixpoint gesetzt werden") + THEN fixpoint +FI ; +forget ("new ds", quiet) ; +copy ds (task index, ds nr, "new ds") ; +putline ("Der kopierte Datenraum steht in der Datei ""new ds""") ; +dump ("new ds") diff --git a/devel/misc/unknown/src/DS4.ELA b/devel/misc/unknown/src/DS4.ELA new file mode 100644 index 0000000..6ebcf2d --- /dev/null +++ b/devel/misc/unknown/src/DS4.ELA @@ -0,0 +1,268 @@ +PACKET ds 4 access DEFINES ds 4 : + +PROC ds 4 : + INT VAR segment, block nr , i , adr , byte ; + TEXT VAR key , eingabe ; + BOOL VAR new headline ; + page ; + put ("Segment:") ; + get (segment) ; + ROW 256 INT VAR space ; + block nr := 0 ; + new headline := FALSE ; + REP + IF new headline THEN out (""1""5"") + ELSE page + FI ; + put (" Segment:") ; put (text(segment,5)) ; (* Cursor 1-16 *) + put (", Block:") ; put (text(block nr,5)) ; (* Cursor 17-31 *) + put (", Wortaddr:") ; out (hex8 (segment)) ; + put (text(hex16((""0""+code(blocknr))ISUB1),5)) ; + put ("Wahl : + - e s b w a h d o") ; (* ^ Cursor 32 - 51 *) + IF NOT new headline THEN + line ; (* ^ 52 - 77 *) + adr := (""0"" + code (block nr)) ISUB 1 ; + FOR i FROM 0 UPTO 255 REP + space (i+1) := get word (segment, i + adr) + PER ; + dump (space) + FI ; + out (""1"") ; + new headline := FALSE ; + inchar (key) ; + out (key) ; + IF key = "+" THEN IF block nr = 255 + THEN block nr := 0 ; + segment INCR 1 + ELSE block nr INCR 1 + FI + ELIF key = "-" THEN IF block nr = 0 AND segment > 0 + THEN block nr := 255 ; + segment DECR 1 + ELIF block nr > 0 THEN block nr DECR 1 + FI + ELIF key = "s" THEN cursor (11,1) ; + eingabe := text (segment) ; + editget (eingabe, 1000, 5) ; + segment := int (eingabe) + ELIF key = "b" THEN cursor (26,1) ; + eingabe := hex8 (block nr) ; + editget (eingabe, 1000, 5) ; + block nr := integer (eingabe) + ELIF key = "w" THEN cursor (44,1) ; + eingabe := hex16 (adr) ; + edit get (eingabe, 1000, 5) ; + adr := integer (eingabe) ; + eingabe := hex16 (get word (segment, adr)) ; + cursor (32,1) ; + put (",NeuesWort:") ; + editget (eingabe, 1000,5) ; + put word (segment, adr, integer (eingabe)) ; + ELIF key = "d" THEN cursor (32,1) ; + new headline := TRUE ; + put (", Dez->Hex:") ; + REAL VAR r ; + get (r) ; + cursor (32,1) ; + put (", - Taste - Hex:") ; + IF r < 256.0 AND r >= 0.0 THEN put (hex8 (int(r))) + ELIF r < 0.0 THEN put (hex16 (int (r))) + ELIF r < 32768.0 THEN put (hex16 (int(r))) + ELSE put (hex16 (int (r - 65536.0))) + FI ; pause + ELIF key = "h" THEN cursor (32,1) ; + new headline := TRUE ; + put (", Hex->Dez:") ; + getline (eingabe) ; + cursor (32,1) ; + put (", - Taste - Dez:") ; + put (integer (eingabe)) ; + IF integer (eingabe) < 0 THEN put (", Positiv:") ; + put (positiv (eingabe)) + FI ; pause + ELIF key = "a" THEN cursor (32,1) ; + new headline := TRUE ; + put (", ASCII->Hex (Taste)"5"") ; + inchar (eingabe) ; + put (" = ") ; put (hex8 (code (eingabe))) ; + put ("- Taste -") ; + pause + ELIF key = "o" THEN cursor (32,1) ; + new headline := TRUE ; + put (", Hex->0Opcde:") ; + getline (eingabe) ; + cursor (32,1) ; + put (", - Taste - :") ; + put (eumel0 opcode (integer (eingabe))) ; + pause + FI ; + UNTIL key = "e" PER ; + +ENDPROC ds 4 ; + +PROC dump (ROW 256 INT CONST page) : + INT VAR i,j ,k ; + TEXT VAR t := " " ; + k := 1 ; j := 1 ; + put ("00:") ; + FOR i FROM 1 UPTO 256 WHILE incharety <> ""27""REP + put hex16 (page (i)) ; + replace (t, j, ascii (page (i))) ; + j := j + 2 ; + IF ((j-1) MOD 8) = 0 THEN out (" ") FI ; + IF k = 22 AND j = 9 THEN j := 25 ; 34 TIMESOUT " " FI ; + IF j = 25 THEN + out (" ") ; out (t) ; + replace (t, 1, " ") ; + IF k < 22 THEN + line ; + out(hex8 (i)); put (":") + FI ; + k := k + 1 ; + j := 1 + FI ; +PER ; +ENDPROC dump ; + + +TEXT PROC ascii (INT CONST wert) : + TEXT VAR t := " " ; + replace (t, 1, wert) ; + IF (t SUB 1) < " " OR (t SUB 1) > ""126"" THEN replace (t, 1, ".") FI ; + IF (t SUB 2) < " " OR (t SUB 2) > ""126"" THEN replace (t, 2, ".") FI ; + t +ENDPROC ascii ; + +PROC put hex16 (INT CONST wert) : + TEXT VAR t := " " ; + replace (t, 1, wert) ; + out hex digit (code (t SUB 1) DIV 16) ; + out hex digit (code (t SUB 1) AND 15) ; + out hex digit (code (t SUB 2) DIV 16) ; + out hex digit (code (t SUB 2) AND 15) ; +ENDPROC put hex16 ; + +PROC out hex9 (INT CONST wert) : + out hex digit (wert DIV 256) ; + out hex digit (wert DIV 16 AND 15) ; + out hex digit (wert AND 15) +ENDPROC out hex9 ; + +TEXT PROC hex8 (INT CONST wert) : + hex digit (wert DIV 16) + + hex digit (wert AND 15) +ENDPROC hex8 ; + +TEXT PROC hex16 (INT CONST wert) : + TEXT VAR t := " " ; + replace (t, 1, wert) ; + hex digit (code (t SUB 2) DIV 16) + + hex digit (code (t SUB 2) AND 15) + + hex digit (code (t SUB 1) DIV 16) + + hex digit (code (t SUB 1) AND 15) +ENDPROC hex16 ; + +TEXT PROC hex digit (INT CONST wert) : + IF wert < 10 THEN code (wert + 48) + ELSE code (wert + 55) + FI +ENDPROC hex digit ; + +PROC out hex digit (INT CONST wert) : + IF wert < 10 THEN out (code (wert + 48)) + ELSE out (code (wert + 55)) + FI +ENDPROC out hex digit ; + +INT PROC integer (TEXT CONST hex addr) : + INT VAR i ; + REAL VAR summe := 0.0 ; + FOR i FROM 1 UPTO length (hex addr) REP + summe := summe * 16.0 ; + summe INCR real (digit) + PER ; + IF summe > 32767.0 THEN int (summe - 65536.0) + ELSE int (summe) + FI. + +digit : + TEXT CONST char := hex addr SUB i ; + IF char >= "a" THEN code (char) - 87 + ELIF char >= "A" THEN code (char) - 55 + ELSE code (char) - 48 + FI +ENDPROC integer ; + +REAL PROC positiv (TEXT CONST wert) : + INT VAR i ; + REAL VAR summe := 0.0 ; + FOR i FROM 1 UPTO length (wert) REP + summe := summe * 16.0 ; + summe INCR real (digit) + PER ; + summe . + +digit : + TEXT CONST char := wert SUB i ; + IF char >= "a" THEN code (char) - 87 + ELIF char >= "A" THEN code (char) - 55 + ELSE code (char) - 48 + FI +ENDPROC positiv ; + +TEXT PROC eumel0 opcode (INT CONST word) : + INT VAR op1 := (word AND 31744) DIV 1024 , + op2 := (word AND 768) DIV 128 , + low := word AND 255 , + long data := (word AND 768) * 2 + (word AND 255) ; + IF word < 0 THEN op2 INCR 1 ; long data INCR 256 FI ; + SELECT op1 OF + CASE 0 : "LN " + text (low) + CASE 1 : "LN " + text (long data) + CASE 2 : "MOV " + CASE 3 : "INC1 " + CASE 4 : "DEC1 " + CASE 5 : "INC " + CASE 6 : "DEC " + CASE 7 : "ADD " + CASE 8 : "SUB " + CASE 9 : "CLEAR " + CASE 10 : "TEST " + CASE 11 : "EQU " + CASE 12 : "LSEQ " + CASE 13 : "FMOV " + CASE 14 : "FADD " + CASE 15 : "FSUB " + CASE 16 : "FMULT " + CASE 17 : "FDIV " + CASE 18 : "FLSEQ " + CASE 19 : "TMOV " + CASE 20 : "TEQU " + CASE 21 : "LSEQU " + CASE 22 : "ACCDS " + CASE 23 : "REF " + CASE 24 : "SUBS " + CASE 25 : "SEL " + CASE 26 : "PPV " + CASE 27 : "PP " + CASE 28 : "BR " + hex8 (low) + CASE 29 : "BR " + hex16 (long data) + CASE 30 : "CALL " + OTHERWISE op 31 + ENDSELECT. + +op31 : +SELECT op 2 OF + CASE 0 : "IS """ + code (low) + """" + CASE 1 : "STIM " + hex8 (low) + CASE 2 : "MOVX " + CASE 3 : "PW " + CASE 4 : "GW " + CASE 5 : "PENTER " + hex8 (low) + CASE 6 : "ESC " + text (low) + CASE 7 : "LONGA " + eumel 0 opcode ((low AND 124) * 256) + OTHERWISE "?????" +ENDSELECT +ENDPROC eumel 0 opcode + +ENDPACKET ds 4 access diff --git a/devel/misc/unknown/src/PRIVS.ELA b/devel/misc/unknown/src/PRIVS.ELA new file mode 100644 index 0000000..dfed695 --- /dev/null +++ b/devel/misc/unknown/src/PRIVS.ELA @@ -0,0 +1,485 @@ +PACKET privs DEFINES pcb, + pages, + internal pause, + set error stop, + sld, + next active task index, + create process, + sysgen off, + (* cdb int , + cdb text , *) + block, + unblock, + sys op, + set clock, + fixpoint, + save system, + internal shutup, + collect garbage blocks, + send, + define collector, + erase process, + halt process , + + return false , + return true , + term , + char read , + begin char read , + char write , + end char write , + get char , + find non blank , + div rem 256 , + add mul 256 , + is digit , + is lowercase or digit , + is lowercase , + is uppercase , + gen addr , + gen code addr , + is short address, + sysgen , + get tables , + put tables , + erase tables , + exec , + (* pproc , + pcall , *) + case , + move , + address , + alias , + IMULT , + arith 15 , + arith 16 , + put word , + get word : + + +PROC pcb (TASK CONST id, INT CONST field, value) : + + EXTERNAL 105 + +ENDPROC pcb ; + + +PROC pages (DATASPACE CONST ds, TASK CONST id) : + + EXTERNAL 88 + +ENDPROC pages ; + + +PROC internal pause (INT CONST time limit) : + + EXTERNAL 66 + +ENDPROC internal pause ; + + +PROC set error stop (INT CONST code) : + + EXTERNAL 77 + +ENDPROC set error stop ; + + +PROC sld (INT CONST in, REAL VAR real, INT VAR out) : + + EXTERNAL 96 + +ENDPROC sld ; + + +PROC next active task index (TASK VAR id) : + + EXTERNAL 118 + +ENDPROC next active task index ; + + +PROC create process (TASK CONST id, PROC start) : + + create (id, PROC start) + +ENDPROC create process ; + + +PROC create (TASK CONST id, PROC start) : + + EXTERNAL 111 + +ENDPROC create ; + + +PROC sysgen off : + + INT VAR x := 0 ; + elan (3, x,x,x,x,x,x,x,x,x,x,x) + +ENDPROC sysgen off ; + + +PROC elan (INT CONST mode, INT VAR a,b,c,d,e,f,g,h,i,j,k) : + + EXTERNAL 256 + +ENDPROC elan ; + + +INT PROC cdbint (INT CONST adr) : + + EXTERNAL 116 + +ENDPROC cdbint ; + + +TEXT PROC cdbtext (INT CONST adr) : + + EXTERNAL 117 + +ENDPROC cdbtext ; + + +PROC block (TASK CONST id) : + + EXTERNAL 109 + +ENDPROC block ; + + +PROC unblock (TASK CONST id) : + + EXTERNAL 108 + +ENDPROC unblock ; + + +PROC sys op (INT CONST function) : + + EXTERNAL 90 + +ENDPROC sys op ; + + +PROC set clock (TASK CONST id, REAL CONST value) : + + EXTERNAL 82 + +ENDPROC set clock ; + + +PROC set clock (REAL CONST value) : + + EXTERNAL 103 + +ENDPROC set clock ; + + +PROC fixpoint : + + sys op (2) + +ENDPROC fixpoint ; + + +PROC collect garbage blocks : + + sys op (1) + +ENDPROC collect garbage blocks ; + + +PROC internal shutup : + + sys op (4) + +ENDPROC internal shutup ; + + +PROC save system : + + sys op (12) + +ENDPROC save system ; + + +PROC send (TASK CONST from, to, INT CONST order, DATASPACE VAR ds, + INT VAR receipt) : + + EXTERNAL 127 + +ENDPROC send ; + + +PROC define collector (TASK CONST task) : + + EXTERNAL 128 + +ENDPROC define collector ; + + +PROC erase process (TASK CONST id) : + + EXTERNAL 112 + +ENDPROC erase process ; + + +PROC halt process (TASK CONST id) : + + EXTERNAL 110 + +ENDPROC halt process ; + + +(****************************** undokumentiert **************************) + + +BOOL PROC return false : + + EXTERNAL 1 + +ENDPROC return false ; + + +BOOL PROC return true : + + EXTERNAL 2 + +ENDPROC return true ; + + +PROC term : + + EXTERNAL 4 + +ENDPROC term ; + + +PROC char read (INT CONST pos) : + + EXTERNAL 8 + +ENDPROC char read ; + + +INT PROC begin char read (INT VAR pos) : + + EXTERNAL 9 + +ENDPROC begin char read ; + + +PROC char write (INT VAR next, INT CONST char, int) : + + EXTERNAL 10 + +ENDPROC char write ; + + +PROC end char write (INT VAR a, b, INT CONST char) : + + EXTERNAL 11 + +ENDPROC end char write ; + + +PROC ctt (INT CONST adr, INT VAR result) : + + EXTERNAL 12 + +ENDPROC ctt ; + + +BOOL PROC get char (TEXT CONST text, INT VAR pos, char) : + + EXTERNAL 13 + +ENDPROC get char ; + + +BOOL PROC find non blank (INT VAR non blank char, TEXT CONST string, + INT VAR pos) : + + EXTERNAL 14 + +ENDPROC find non blank ; + + +PROC divrem 256 (INT VAR a, b) : + + EXTERNAL 15 + +ENDPROC divrem 256 ; + + +PROC addmul 256 (INT VAR a, b) : + + EXTERNAL 16 + +ENDPROC addmul 256 ; + + +BOOL PROC is digit (INT CONST char) : + + EXTERNAL 18 + +ENDPROC is digit ; + + +BOOL PROC is lowercase or digit (INT CONST char) : + + EXTERNAL 19 + +ENDPROC is lowercase or digit ; + + +BOOL PROC is lowercase (INT CONST char) : + + EXTERNAL 20 + +ENDPROC is lowercase ; + + +BOOL PROC is uppercase (INT CONST char) : + + EXTERNAL 21 + +ENDPROC is uppercase ; + + +PROC gen addr (INT CONST word1, word2, INT VAR result) : + + EXTERNAL 22 + +ENDPROC gen addr ; + + +BOOL PROC gen code addr (INT CONST word1, word2, INT VAR result) : + + EXTERNAL 23 + +ENDPROC gen code addr ; + + +BOOL PROC is short address (INT CONST address) : + + EXTERNAL 24 + +ENDPROC is short address ; + + +PROC sysgen : + + EXTERNAL 25 + +ENDPROC sysgen ; + + +PROC get tables : + + EXTERNAL 26 + +ENDPROC get tables ; + + +PROC put tables : + + EXTERNAL 27 + +ENDPROC put tables ; + + +PROC erase tables : + + EXTERNAL 28 + +ENDPROC erase tables ; + + +PROC exec (INT CONST module number) : + + EXTERNAL 29 + +ENDPROC exec ; + +(* +PROC pproc (PROC proc) : + + EXTERNAL 30 + +ENDPROC pproc ; + + +PROC pcall (PROC proc) : + + EXTERNAL 31 + +ENDPROC pcall ; +*) + +BOOL PROC case (INT CONST switch, limit) : + + EXTERNAL 32 + +ENDPROC case ; + + +PROC move (PROC len, INT VAR from area, to area) : + + EXTERNAL 33 + +ENDPROC move ; + + +INT PROC alias (DATASPACE CONST ds, INT VAR result) : + + EXTERNAL 34 + +ENDPROC alias ; + + +INT PROC address (INT CONST object) : + + EXTERNAL 35 + +ENDPROC address ; + + +INT OP IMULT (INT CONST a, b) : + + EXTERNAL 40 + +ENDOP IMULT ; + + +PROC arith 15 : + + EXTERNAL 91 + +ENDPROC arith 15 ; + + +PROC arith 16 : + + EXTERNAL 92 + +ENDPROC arith 16 ; + + +PROC put word (INT CONST segment, address, word) : + + EXTERNAL 119 + +ENDPROC put word ; + + +INT PROC get word (INT CONST segment, address) : + + EXTERNAL 120 + +ENDPROC get word + +ENDPACKET privs diff --git a/devel/misc/unknown/src/TABINFO.ELA b/devel/misc/unknown/src/TABINFO.ELA new file mode 100644 index 0000000..af419bb --- /dev/null +++ b/devel/misc/unknown/src/TABINFO.ELA @@ -0,0 +1,117 @@ +PACKET table info DEFINES table info : (* Michael Staubermann *) + (* 02.12.86 *) +LET insert flag addr = 4654 , + +(* prev modnr addr = 4662 , *) + cur modnr addr = 4806 , + + prev code end addr = 4775 , + cur code end addr = 4807 , + + prev name tab end addr = 4688 , + cur name tab end addr = 4693 , + + prev permanent tab end addr = 4704 , + cur permanent tab end addr = 4707 , + + prev denoter end addr = 4815 , + cur denoter end addr = 4809 , + + prev static data end addr = 4816 , + cur static data end addr = 4810 , + prev static data begin addr = 4817 , + cur static data begin addr = 4811 , +(* + begin of hash table = 0 , + end of hash table = 1023 , + + begin of string table = 1024 , + end of string table = 4093 , +*) + begin of name table = 4096 , + end of name table = 22783 , + + begin of permanent table = 22784 , + end of permanent table = 32767 , + + begin of code = 4096 , + + begin of data = 4096 ; + +INT CONST end of code :: -1 , + end of data :: -1 ; + +BOOL VAR was insert ; + +INT PROC getword (INT CONST segment, address) : + EXTERNAL 120 +ENDPROC getword ; + +PROC arith16 : + EXTERNAL 92 +ENDPROC arith16 ; + +INT OP SUB (INT CONST left, right) : + arith 16 ; + left - right +ENDOP SUB ; + +PROC entry (TEXT CONST name, BOOL CONST size, + INT CONST begin, cur, prev, end) : + put (subtext (name + " ....................", 1, 20) + ":") ; + IF size + THEN put (card (end SUB begin)) ; + put (card (end SUB cur)) ; + put (card (cur SUB begin)) ; + put (card (int (positiv (cur SUB begin) / + positiv (end SUB begin) * 100.0))) ; + ELSE put (" ") + FI ; + IF NOT was insert + THEN put (card (prev - cur)) + FI ; + line +ENDPROC entry ; + +PROC table info : + was insert := getword (0, insert flag addr) = 0 ; + line ; + put ("Nchste Modulenr.:") ; + put (getword (0, cur modnr addr)) ; line (2) ; + put ("Name Size Free Used Used%") ; + IF NOT was insert + THEN put ("LastRun") + FI ; + line ; + entry ("Permanenttable", TRUE, begin of permanent table, + getword (0, cur permanent tab end addr), + getword (0, prev permanent tab end addr), end of permanent table) ; + entry ("Nametable", TRUE, begin of name table, + getword (0, cur name tab end addr), + getword (0, prev name tab end addr), end of name table) ; + entry ("Code", TRUE, begin of code, + getword (0, cur code end addr), + getword (0, prev code end addr), end of code) ; + entry ("Data", TRUE, begin of data, + getword (0, cur static data end addr), + getword (0, prev static data end addr), end of data) ; + line ; +ENDPROC table info ; + +REAL PROC positiv (INT CONST value) : + IF value < 0 + THEN real (value) + 65536.0 + ELSE real (value) + FI +ENDPROC positiv ; + +TEXT PROC card (INT CONST i) : + IF i = minint + THEN "32768" + ELIF i < 0 + THEN subtext (text (real (i) + 65536.0), 1, 5) + ELSE text (i, 5) + FI +ENDPROC card + +ENDPACKET table info ; diff --git a/devel/misc/unknown/src/TRACE.ELA b/devel/misc/unknown/src/TRACE.ELA new file mode 100644 index 0000000..63c1455 --- /dev/null +++ b/devel/misc/unknown/src/TRACE.ELA @@ -0,0 +1,552 @@ +PACKET tracer DEFINES breakpoint handler , (* M. Staubermann *) + handlers module nr , (* 20.04.86 *) + list breakpoints , + set breakpoint , + reset breakpoint , + source file , + trace , + reset breakpoints : + +LET local base field = 25 , + packet data segment = 0 , + local data segment = 1 , + + begin of module nr link table = 512 , + + previous local base offset = 0 , + return address offset = 1 , + return segment offset = 2 , + c8k offset = 3 , + + opcode mask = 31744 , + bt opcode = 0 , + btlong opcode = 1024 , + bf opcode = 28672 , + bflong opcode = 29696 , + br opcode = 28672 , + brlong opcode = 29696 , + + ln opcode = 0 , + ln long opcode = 1024 , + call opcode = 30720 , + pcall opcode = 32543 ; + +LET nr of breakpoints = 2 , + BREAKPOINT = STRUCT (BOOL set, + INT segment, + address, + saved word) ; + +ROW nr of breakpoints BREAKPOINT VAR breakpoints ; +BREAKPOINT CONST init breakpoint :: BREAKPOINT:(FALSE, 3, -5, 0) ; + +FOR i FROM 1 UPTO nr of breakpoints REP + breakpoints (i) := init breakpoint +PER ; + +BOOL VAR auto trace := FALSE , + zweizeilig ; +INT VAR next instruction address , + next instruction segment , + next instruction , + return segment, + return address, + breakpoint address , + breakpoint segment , + breakpoint nr , + lbas , + this local base , + branch address , + c8k , + packet base , + op word, + saved word , + i, x, y , + actual line number := -1 , + handler module := 395 ; (* PROC stop *) + +TEXT VAR key := "" , + previous key := "" , + statement line := "" , + source line := "" , + source file name := "" ; + +FILE VAR source ; + +PROC trace (BOOL CONST b) : + auto trace := b +ENDPROC trace ; + +PROC source file (TEXT CONST file name) : + IF exists (file name) + THEN source := sequentialfile (modify, file name) + FI ; + IF actual line number >= 0 CAND actual line number <= lines (source) + THEN toline (source, actual line number) ; + readrecord (source, source line) + ELSE source line := "" + FI +ENDPROC source file ; + +TEXT PROC source file : + source file name +ENDPROC source file ; + +PROC breakpoint handler : + determine return address ; + determine breakpoint nr ; + reset breakpoints ; + getcursor (x, y) ; + REP + ueberschrift schreiben ; + IF auto trace + THEN IF incharety = "" + THEN key := "s" + ELSE auto trace := FALSE + FI + FI ; + IF NOT auto trace + THEN REP + inchar (key) + UNTIL pos (""13"acdefgst", key) > 0 PER ; + IF key = "a" + THEN auto trace := TRUE ; + key := "s" + ELIF key = "f" + THEN out (""13""5"Sourcefile:") ; + getline (source file name) ; + out (""3"") ; + source file (source file name) + ELIF key = ""13"" + THEN key := "s" + FI + FI ; + previous key := key + UNTIL pos ("gst", key) > 0 PER ; + cursor (1, 7) ; + out (""5"") ; + IF key <> "t" + THEN execute saved instruction + FI ; + IF key = "t" + THEN resetbreakpoints ; + term + ELIF key = "s" + THEN singlestep + FI ; + cursor (x, y) . + +ueberschrift schreiben : + feld loeschen ; + put (""1"Breakpoint") ; put (breakpoint nr) ; + put ("lbas:") ; put (hex16 (lbas)) ; + put ("pbas:") ; put (hex8 (packet base)) ; + put ("c8k:") ; put (hex8 (c8k)) ; + IF valid source + THEN out ("""") ; out (source file name) ; put ("""") + FI ; + line ; + IF valid source AND source line <> "" + THEN put (text (actual line number, 5)) ; put ("|") ; + outsubtext (source line, 1, 71) ; + line ; + IF LENGTH source line < 72 + THEN put (text (actual line number +1, 5)) ; put ("|") ; + toline (source, actual line number +1) ; + out (subtext (source, 1, 71)) ; + toline (source, actual line number) ; + line + ELSE put ("______|") ; + outsubtext (source line, 72, 143) ; + line + FI + ELSE line (2) + FI ; + out (text (return segment AND 3)) ; + put (hex16 (return address)) ; + put ("|") ; + seg (breakpoint segment) ; + addr (breakpoint address) ; + zweizeilig := TRUE ; + disassemble one statement ; + IF auto trace + THEN pause (5) + FI ; + next instruction segment := breakpoint segment ; + next instruction address := addr ADD 1 ; + next instruction := getword (next instruction segment, + next instruction address) ; + line ; + put ("a)uto, s)tep, g)o, t)erm, d)stop, e)stop, c)lrerr, f)ile:") . + +feld loeschen : + out (""1"") ; + 7 TIMESOUT ""5""10"" ; + 79 TIMESOUT "-" . + +valid source : + exists (source file name) . + +disassemble one statement : + statement line := hex16 (get word (breakpoint segment, addr)) ; + statement line CAT " " ; + code word line (statement line) ; +(* local base (lbas + offset) ; *) + statement line := opcode ; + local base (-1) ; + put (code word line) ; +(* i := max (0, 26 - length (code word line)) ; + i TIMESOUT " " ; *) +i:=0; i := 71 - LENGTH codeword line - i ; + outsubtext (statement line, 1, i) ; + line ; + IF zweizeilig + THEN put (" |") ; + outsubtext (statement line, i + 1, i + 72) ; + line + FI ; + codeword line ("") . + +singlestep : + IF is return opcode + THEN set breakpoint behind previous call + ELIF bool result + THEN set first breakpoint behind branch instruction ; + set second breakpoint at branch address ; + bool result (FALSE) ; + ELIF is bool return opcode + THEN set first breakpoint behind branch instruction at return address ; + set second breakpoint at branch address of branch instruction at + return address ; + ELIF is branch instruction + THEN set breakpoint at branch address + ELIF is call opcode AND NOT auto trace CAND segment 3 module CAND + yes (""3"Subroutine Trace") + THEN out (""3""13""5"") ; + calculate subroutine segment and address ; + set breakpoint behind next instruction + ELSE set breakpoint behind next instruction + FI . + +is call opcode : + (saved word AND opcode mask) = call opcode OR +(* saved word = pcall opcode OR //einbauen, wenn local zugriffe ok sind// *) + saved word = -136 . (* LONGA CALL *) + +is line number : + (saved word AND opcode mask) = ln opcode OR + (saved word AND opcode mask) = lnlong opcode . + +is branch instruction : + (saved word AND opcode mask) = br opcode OR + (saved word AND opcode mask) = brlong opcode . + +is return opcode : + saved word = 32512 . + +is bool return opcode : + saved word = 32513 OR saved word = 32514 . + +read source line : + actual line number := ((saved word AND 768) * 2) OR (saved word AND 255); + IF saved word < 0 + THEN actual line number INCR 256 + FI ; + IF (saved word AND opcode mask) = lnlong opcode + THEN actual line number INCR 2048 + FI ; + actual line number DECR 1 ; + IF valid source + THEN IF lineno (source) = actual line number CAND source line <> "" + THEN (* nichts*) + ELIF actual line number >= 0 AND actual line number <= lines(source) + THEN toline (source, actual line number) ; + readrecord (source, source line) + ELSE source line := "" + FI + ELSE source line := "" + FI . + +set first breakpoint behind branch instruction : + op word := next instruction AND opcode mask ; + IF op word = bf opcode OR op word = bflong opcode OR + op word = bt opcode OR op word = btlong opcode + THEN seg (next instruction segment) ; + addr (next instruction address) ; + out (""3"") ; + out (text (next instruction segment)) ; + put (hex16 (next instruction address)) ; + put ("|") ; + zweizeilig := FALSE ; + bool result (TRUE) ; + disassemble one statement ; (* Branch instruction *) + IF NOT auto trace + THEN pause (30) + ELSE pause (5) + FI ; + next free breakpoint ; + set breakpoint (i, next instruction segment, + next instruction address ADD 1) ; + ELSE putline (""3""7"Interner Fehler: Nach BOOL-Result folgt kein Branch"); + LEAVE singlestep + FI . + +set second breakpoint at branch address : + calculate branch address ; + next free breakpoint ; + set breakpoint (i, next instruction segment, branch address) . + +set breakpoint at branch address : + next instruction := saved word ; + next instruction address := breakpoint address ; + calculate branch address ; + set breakpoint (breakpoint nr, next instruction segment, branch address) . + +set first breakpoint behind branch instruction at return address : + next instruction address := getword (local data segment, + lbas + return address offset) ; + next instruction segment := getword (local data segment, + lbas + return segment offset) AND 3 ; + next instruction := getword (next instruction segment, + next instruction address) ; + IF next instruction segment = 3 + THEN set first breakpoint behind branch instruction + ELSE putline ("Trace beendet.") + FI . + +set second breakpoint at branch address of branch instruction at return address : + set second breakpoint at branch address . + +determine return address : + pause (0) ; (* Local Base fixieren *) + this local base := getword (local data segment, pcb (local base field)) ; + pause (0) ; + lbas := getword (local data segment, this local base + + previous local base offset) ; + c8k := getword (local data segment, this local base + + c8k offset) AND 255 ; + return segment := getword (local data segment, this local base + + return segment offset) ; + return address := getword (local data segment, this local base + + return address offset) ; + packet base := HIGH return segment ; + arith 16 ; + return address DECR 1 ; + arith 15 . + +segment 3 module : + IF saved word = -136 (* LONGA CALL *) + THEN op word := getword (breakpoint segment, breakpoint address ADD 1) + ELSE op word := saved word AND 1023 ; + IF saved word < 0 + THEN op word INCR 1024 + FI ; + FI ; + op word >= 1280 . + +calculate subroutine segment and address : + next instruction segment := 3 ; (* Laeuft nur in Segment 3 ! *) + next instruction address := getword (packet data segment, + begin of module nr link table + op word) ADD 1. + +determine breakpoint nr : + FOR i FROM 1 UPTO nr of breakpoints REP + IF breakpoints (i).set CAND + breakpoints (i).segment = (return segment AND 3) CAND + breakpoints (i).address = return address + THEN breakpoint nr := i ; + breakpoint address := breakpoints (i).address ; + breakpoint segment := breakpoints (i).segment ; + saved word := breakpoints (i).saved word ; + LEAVE determine breakpoint nr + FI + PER ; + put ("Returnaddresse:") ; + out (text (return segment AND 3)) ; + putline (hex16 (return address)) ; + list breakpoints ; + reset breakpoints ; + enablestop ; + errorstop ("Falsche Returnaddresse") . + +calculate branch address : + IF lowbyte replacement possible + THEN branch address := (next instruction address AND -256) OR + (next instruction AND 255) ; + LEAVE calculate branch address + FI ; + branch address := next instruction AND 768 ; + IF branch long + THEN branch address INCR 2048 + FI ; + branch address INCR branch address ; + IF next instruction < 0 + THEN branch address INCR 256 + FI ; + arith 16 ; + branch address INCR (next instruction address AND -256) ; + IF HIGH branch address >= c8k + THEN branch address DECR 4096 + FI ; + arith 15 ; + branch address := (branch address AND -256) OR (next instruction AND 255) . + +lowbyte replacement possible : + (next instruction AND -32000) = 0 . + +branch long : + bit (next instruction, 10) . + +execute saved instruction : + perhaps change error flags ; + putword (local data segment, this local base + return address offset, + return address) ; + putword (local data segment, this local base + return segment offset, + return segment) . + +perhaps change error flags : + IF bit (return segment, 7) AND previous key = "c" + THEN reset bit (return segment, 7) + FI ; + IF bit (return segment, 6) AND previous key = "e" + THEN reset bit (return segment, 6) + ELIF NOT bit (return segment, 6) AND previous key = "d" + THEN set bit (return segment, 6) + FI . + +set breakpoint behind next instruction : + IF is linenumber + THEN read source line + FI ; + set breakpoint (breakpoint nr, next instruction segment, + next instruction address) . + +set breakpoint behind previous call : + return segment := getword (local data segment, + lbas + return segment offset) AND 3 ; + return address := getword (local data segment, + lbas + return address offset) ; + IF return segment = 3 + THEN set breakpoint (breakpoint nr, return segment, return address) + ELSE putline ("Trace beendet.") + FI . + +next free breakpoint : + FOR i FROM 1 UPTO nr of breakpoints REP + IF NOT breakpoints (i).set + THEN LEAVE next free breakpoint + FI + PER ; + putline (""3""7"Alle " + text(nr of breakpoints) + " Breakpoints sind belegt") ; + LEAVE singlestep . + +ENDPROC breakpoint handler ; + +INT OP HIGH (INT CONST word) : + TEXT VAR t := " " ; + replace (t, 1, word) ; + code (t SUB 2) +ENDOP HIGH ; + +PROC reset breakpoints : + FOR i FROM 1 UPTO nr of breakpoints REP + IF breakpoints (i).set + THEN reset breakpoint (i) + ELSE breakpoints (i) := init breakpoint + FI + PER +ENDPROC reset breakpoints ; + +PROC reset breakpoint (INT CONST nr) : + IF nr < 1 OR nr > nr of breakpoints + THEN errorstop ("Unzulaessige Breakpoint Nummer") + ELIF NOT breakpoints (nr).set + THEN display ("Warnung: Breakpoint " + text (nr) + " war nicht gesetzt") + ELSE putword (breakpoints (nr).segment, breakpoints (nr).address, + breakpoints (nr).saved word) ; + breakpoints (nr) := init breakpoint + FI +ENDPROC reset breakpoint ; + +PROC set breakpoint (INT CONST nr, segment, address) : + INT VAR new word ; + IF nr < 1 OR nr > nr of breakpoints + THEN errorstop ("Unzulaessige Breakpoint Nummer") + ELIF breakpoints (nr).set + THEN errorstop ("Breakpoint " + text (nr) + " ist bereits gesetzt") + ELIF segment < 2 OR segment > 3 + THEN errorstop ("Segment " + text (segment) + " ist kein Codesegment") + ELSE breakpoints (nr).segment := segment ; + breakpoints (nr).address := address ; + breakpoints (nr).saved word := get word (segment, address) ; + new word := call opcode + (handler module AND 1023) ; + IF handler module >= 1024 + THEN setbit (new word, 15) + FI ; + putword (segment, address, new word) ; + IF getword (segment, address) <> new word + THEN errorstop ("Addresse Schreibgeschuetzt") + ELSE breakpoints (nr).set := TRUE + FI + FI +ENDPROC set breakpoint ; + +PROC handlers module nr (INT CONST module nr) : + handler module := module nr +ENDPROC handlers module nr ; + +INT PROC handlers module nr : + handler module +ENDPROC handlers module nr ; + +PROC set breakpoint : + handlers module nr (module number ("breakpointhandler", 1)) ; + auto trace := FALSE ; + source file name := "" ; + actual line number := -1 ; + page ; + TEXT VAR object ; + INT VAR object nr ; + put ("Object Name:") ; + getline (object) ; + changeall (object, " ", "") ; + putline ("Objekt von Anfang an abzaehlen") ; + pause (5) ; + help (object) ; + put ("Objekt Nr:") ; + get (object nr) ; + INT VAR code address := code start (object, object nr) ADD 1 ; + naechsten freien breakpoint setzen ; + put ("Breakpoint") ; + put (i) ; + putline ("wurde gesetzt.") . + +naechsten freien breakpoint setzen : + FOR i FROM 1 UPTO nr of breakpoints REP + IF NOT breakpoints (i).set + THEN set breakpoint (i, code segment, code address) ; + LEAVE naechsten freien breakpoint setzen + FI + PER ; + errorstop ("Alle " + text (nr of breakpoints) + " Breakpoints sind belegt"). + +ENDPROC set breakpoint ; + +PROC list breakpoints : + line ; + putline (" No Set Address Word") ; + FOR i FROM 1 UPTO nr of breakpoints REP + put (text (i, 3)) ; + IF breakpoints (i).set + THEN put (" Y ") + ELSE put (" N ") + FI ; + out (text (breakpoints (i).segment)) ; + put (hex16 (breakpoints (i).address)) ; + put(" ") ; + put (hex16 (breakpoints (i).saved word)) ; + line + PER +ENDPROC list breakpoints ; + +ENDPACKET tracer diff --git a/devel/misc/unknown/src/XLIST.ELA b/devel/misc/unknown/src/XLIST.ELA new file mode 100644 index 0000000..4897dab --- /dev/null +++ b/devel/misc/unknown/src/XLIST.ELA @@ -0,0 +1,143 @@ +PACKET xlist DEFINES xlist : (* M. Staubermann, 1.8.0 861203 *) + (* Heapsize korrigiert 870711 *) +DATASPACE VAR ds, act ; + +PROC x list : + ds := nilspace ; + FILE VAR f := sequentialfile (output, ds) ; + headline (f, "Dataspaces:" + text (dataspaces) + + " Speicher:" + text (storage (myself))) ; + disablestop ; + xlist (f) ; + show (f) ; + forget (ds) ; +ENDPROC x list ; + +PROC x list (FILE VAR f) : + INT VAR i, acttype, heapsiz, seiten ; + TEXT VAR name, status ; + FILE VAR f2 ; + ROW 255 STRUCT (TEXT name, status) VAR names ; + + enablestop ; + FOR i FROM 1 UPTO 255 REP + names (i).name := "" ; + names (i).status := "" + PER ; + begin list ; + get list entry (name, status) ; + WHILE name <> "" REP + makeid (old (name)) ; + names (dsnr).name := name ; + names (dsnr).status := status ; + get list entry (name, status) + PER ; + maxlinelength (f, 1000) ; + putline (f, "Datum Status Ds kB Type HeapLines Segs S/L ""Name""/'Headline'"); + line (f) ; + putline (f, " 4 " + text ((pages (4, myself)+1) DIV 2, 5) + + " " + text (heapsize, 3) + " - - -") ; + disablestop ; + FOR i FROM 5 UPTO 255 REP + cout (i) ; + makeid (i) ; + act := reveal ds ; + IF iserror + THEN clearerror + ELSE name := names (i).name ; + status := names (i).status ; + acttype := type (act) ; + names (i).name := "" ; + names (i).status := "" ; + put (f, stat + id + " " + speicher + " " + typ + " " + heap) ; + putline (f, zeilen + " " + segmente + " " + sl percent + dsname) ; + FI ; + forget (act) ; + IF iserror THEN puterror ; clearerror FI + PER . + +dsname : + IF name = "" + THEN IF act type = 1003 + THEN " '" + headline (f2) + "'" + ELSE "" + FI + ELSE " """ + name + """" + FI . + +stat : + IF status = "" + THEN " " + ELSE status + FI . + +typ: + text (act type, 5) . + +id : + text (i, 3) . + +speicher : + seiten := ds pages (act) ; + text ((seiten+1) DIV 2, 5) . + +zeilen : + IF act type <> 1003 THEN " -" + ELSE f2 := sequentialfile (modify, act) ; + text (lines (f2), 4) + FI . + +segmente : + IF act type <> 1003 THEN " -" + ELSE INT CONST segs :: segments (f2) ; + text (segs, 4) + FI . + +sl percent: + IF act type <> 1003 THEN " - " + ELIF segs = 1 THEN " " + ELSE text (int (real (segs) * 100.0 / real (lines (f2))+0.5), 2) + "%" + FI . + +heap : + heapsiz:= heapsize (act) * 2 ; + IF heapsiz >= 2046 + THEN " -" + ELIF act type = 1003 + THEN IF heapsiz < 192 + THEN " 0" + ELSE text ((heapsiz-192) DIV 2, 4) + FI + ELSE INT CONST next page :: next ds page (act, seiten) ; + IF next page < 0 + THEN " 0" + ELIF heapsiz = next page + THEN " 1" + ELSE text ((heapsiz + 1 - next page) DIV 2, 4) + FI + FI . + +ENDPROC x list ; + +PROC make id (DATASPACE CONST ds) : + BOUND INT VAR i := ds +ENDPROC make id ; + +INT PROC dsnr : + INT VAR id ; + id AND 255 +ENDPROC dsnr ; + +PROC makeid (INT CONST nr) : + INT VAR dsid := nr + 256 * index (myself) +ENDPROC makeid ; + +DATASPACE PROC reveal ds : + DATASPACE VAR ds ; ds +ENDPROC reveal ds ; + +INT PROC pages (INT CONST dsnr, TASK CONST task) : + EXTERNAL 88 +ENDPROC pages ; + +ENDPACKET x list ; diff --git a/devel/misc/unknown/src/XSTATUS.ELA b/devel/misc/unknown/src/XSTATUS.ELA new file mode 100644 index 0000000..36abc23 --- /dev/null +++ b/devel/misc/unknown/src/XSTATUS.ELA @@ -0,0 +1,188 @@ +PACKET x taskinfo DEFINES x task status , (* M.Staubermann 1.8.0, 861009*) + x task info : + +INT PROC pcf (TASK CONST t, INT CONST byte) : + TEXT VAR word := " " ; + replace (word, 1, pcb (t, byte DIV 2 + 17)) ; + IF (byte AND 1) = 0 THEN code (word SUB 1) + ELSE code (word SUB 2) + FI +ENDPROC pcf ; + +TEXT PROC xstatus (TASK CONST task, INT CONST depth) : + TEXT VAR zeile := ".................." , + task name := name (task) ; + change (zeile, 1, length (task name) + depth , depth * " " + task name) ; + task name := zeile ; + zeile CAT " " + hex16 (pcb (task, 9)) + "-" + hex8 (pcb (task, 10)) ; + IF bit (pcf (task, 5), 7) (* ^ tasknr & version *) + THEN zeile CAT "x" + ELSE zeile CAT " " + FI ; + IF bit (pcf (task, 5), 0) + THEN zeile CAT "h" (* comflg *) + ELSE zeile CAT " " (* haltprocess liegt an *) + FI ; + zeile CAT status (pcf (task, 6)) ; (* status *) + zeile CAT " " + bin (pcf (task, 7), 3, 7) ; (* statusflags rstflg *) + INT CONST pcf 11 :: pcf (task, 11) ; + IF bit (pcf 11, 7) (* iserror *) + THEN zeile CAT " e" + ELSE zeile CAT " n" + FI ; + IF bit (pcf 11, 6) (* disablestop *) + THEN zeile CAT "d" + ELSE zeile CAT "e" + FI ; + IF bit (pcf 11, 5) (* unbelegt *) + THEN zeile CAT "*" + ELSE zeile CAT " " + FI ; + IF bit (pcf 11, 4) (* arith 16 *) + THEN zeile CAT "u" (* unsigned *) + ELSE zeile CAT "s" (* signed *) + FI ; + zeile CAT " " + text (pcf 11 AND 3) ; (* codesegment *) + zeile CAT hex8 (pcf (task, 10)) + hex8 (pcf (task, 9)) ; (* icount *) + zeile CAT " " + text (pcb (task, 28) AND 15) ; (* heapsegment *) + zeile CAT hex16 (pcb (task, 28) AND -16) ; (* heaptop *) + zeile CAT " " + hex16 (pcb (task, 23)) ; (* mod *) + zeile CAT text (pcb (task, 4), 4) ; (* channel *) + zeile CAT text (pcb (task, 1), 4) ; (* linenr *) + zeile CAT text (pcb (task, 2), 4) ; (* errorline *) + zeile CAT text (pcb (task, 3), 4) ; (* errorcode *) + zeile CAT text (pcb (task, 7), 4) ; (* msgcode *) + zeile CAT " " + hex16 (pcb (task, 8)) ; (* msgds *) + zeile CAT " " + hex16 (pcb (task, 11)) + "-" + hex8 (pcb (task, 12)) ; + zeile CAT " " + hex8 (pcf (task, 29)) ; (* priv *) + zeile CAT " " + hex8 (pcf (task, 14)) ; (* pbas *) (* ^ fromid *) + zeile CAT " " + hex8 (pcf (task, 15)) ; (* c8k *) + zeile CAT " " + hex16 (pcb (task, 25)) ; (* lbas *) + zeile CAT " " + hex16 (pcb (task, 26)) ; (* ltop *) + zeile CAT " " + hex16 (pcb (task, 27)) ; (* ls_top *) + zeile CAT text (pcb (task, 6), 3) ; (* prio *) + zeile CAT " " + hex8 (pcf (task, 28)) ; (* priclk *) + zeile CAT " " + hex8 (pcf (task, 8)) ; (* pricnt *) + zeile CAT " " + hex16(pcb (task, 17)) + hex16 (pcb (task, 18)) ; + zeile CAT " " + hex8 (pcf (task, 4)) ; (* millis *) (* ^ wstate *) + zeile +ENDPROC xstatus ; + +TEXT PROC status (INT CONST wert) : + stat + blocked . + +stat: + SELECT (wert AND 60) DIV 4 OF + CASE 0 : "INTER" + CASE 1 : "OUT " + CASE 2 : "INCHR" + CASE 3 : "PAUSE" + CASE 4 : "RTN T" + CASE 5 : "RTN F" + CASE 6 : "CALL " + CASE 7 : "RTN " + CASE 8 : "CHGB1" + CASE 9 : "CHGB2" + CASE 10: "CHGB3" + CASE 15: IF wert = 255 THEN "-DEAD" ELSE "WAIT " FI + OTHERWISE "?? "+hex8 (wert AND 252) + ENDSELECT . + +blocked: + IF (wert AND 1) = 1 + THEN "-B" + ELSE " " + FI +ENDPROC status ; + +TEXT PROC hex8 (INT CONST wert) : + hex digit (wert DIV 16) + + hex digit (wert AND 15) +ENDPROC hex8 ; + +TEXT PROC hex16 (INT CONST wert) : + TEXT VAR t := " " ; + replace (t, 1, wert) ; + hex digit (code (t SUB 2) DIV 16) + + hex digit (code (t SUB 2) AND 15) + + hex digit (code (t SUB 1) DIV 16) + + hex digit (code (t SUB 1) AND 15) +ENDPROC hex16 ; + +TEXT PROC hex digit (INT CONST wert) : + "0123456789ABCDEF" SUB (wert+1) +ENDPROC hex digit ; + +TEXT PROC bin (INT CONST wert, from, to) : + INT VAR i ; + TEXT VAR t := "" ; + FOR i FROM to DOWNTO from REP + IF bit (wert, i) THEN t CAT "1" + ELSE t CAT "0" + FI + PER ; + t +ENDPROC bin ; + +PROC x task info (FILE VAR list file) : + access catalogue ; + put (list file, date) ; + put (list file, " ") ; + put (list file, time of day) ; + put (list file, " Size:") ; + INT VAR size, used ; + storage (size, used) ; + put (list file, size) ; + put (list file, "K Used:") ; + put (list file, used) ; + put (list file, "K ") ; + line (list file) ; + put (list file, "TASK ") ; + put (list file, "taskid xhstatus rstflg edxa icount hptop mod chn") ; + write (list file, "lin eln ecd mcd mgds fromid prvpbs c8k lbs ltoplstop"); + put (list file, "pripck pct wstate mls") ; + line (list file) ; + list tree (list file, supervisor, 0) +ENDPROC x task info ; + +DATASPACE VAR ds ; +PROC x task info : + disable stop ; + ds := nilspace ; + FILE VAR list file := sequentialfile (output, ds) ; + max line length (list file, 1000) ; + x task info (list file) ; + edit (list file) ; + forget (ds) ; +ENDPROC x task info ; + +PROC list tree (FILE VAR list file, TASK CONST first son, INT CONST depth) : + enable stop ; + TASK VAR actual task := first son ; + WHILE NOT isniltask (actual task) REP + list actual task ; + list tree (list file, son (actual task), depth + 1) ; + actual task := brother (actual task) + PER . + +list actual task : + putline (list file, x status (actual task, depth)) + +ENDPROC list tree ; + +PROC x task status (TASK CONST t) : + TEXT VAR zeile := x status (t, 0) ; + line ; + put ("Task:") ; putline (name (t)) ; + putline ("taskid xhstatus rstflg edxa icount hptop mod chn lin eln ecd") ; + putline (subtext (zeile, 20, 80)) ; + putline ("mcd mgds fromid prvpbs c8k lbs ltoplstoppripck pct wstate mls") ; + putline (subtext (zeile, 81)) ; + line +ENDPROC x task status ; + +PROC x task status : + x task status (myself) +ENDPROC x task status ; + +ENDPACKET x task info ; diff --git a/devel/misc/unknown/src/Z80.ELA b/devel/misc/unknown/src/Z80.ELA new file mode 100644 index 0000000..58e31bf --- /dev/null +++ b/devel/misc/unknown/src/Z80.ELA @@ -0,0 +1,495 @@ +PACKET z80 disassembler DEFINES hex, dez, disassemble, disass , acht : + +LET max = 4096; (* Anzahl Bytes der ROW DIV 2 *) + +BOUND ROW max INT VAR row; + +INT VAR next byte, + next word, + byte, + div 8, + and 7, + and f, + div 10; +TEXT VAR index; + +belegen (0,0,0); + +INT PROC dez (TEXT CONST wert) : + TEXT VAR zahl := wert; + INT VAR i; + REAL VAR summe := 0.0; + IF (zahl SUB 1) = "!" THEN int(subtext(zahl, 2)) + ELIF (zahl SUB 1) = "%" THEN zahl := subtext(zahl, 2); + FOR i FROM length(zahl) DOWNTO 1 REP + summe INCR (2.0**(length(zahl) - i))* real(number) + PER; + IF summe > 32767.0 THEN int (summe - 65536.0) + ELSE int (summe) + FI + ELSE IF (zahl SUB 1) = "$" THEN zahl := subtext(zahl, 2) FI; + FOR i FROM length(zahl) DOWNTO 1 REP + summe INCR (16.0**(length(zahl) - i))* real(number) + PER; + IF summe > 32767.0 THEN int (summe - 65536.0) + ELSE int (summe) + FI + FI. + +number : + IF (zahl SUB i) > "9" + THEN code( zahl SUB i) -55 + ELSE int (zahl SUB i) + FI +ENDPROC dez; + +PROC disassemble (TEXT CONST source code) : + row := old(source code); + INT VAR counter, start, pc, b1, b2, b3, b4, ende; + TEXT VAR addr; + page; + out (" "15" Z80 - DISASSEMBLER "14""13""10""10""); + out ("F r Adressangaben: $ = hex, % = bin r, ! = dezimal."13""10""10""); + out ("Hexadezimale Eingaben mit den Zeichen 0 bis F."13""10""10""); + out ("Disassemblierung mit ESC abbrechen."13""10""10""); + out ("Addresse des ersten Eintrags der Liste:"); + addr:="$0000"; + editget(addr); + start := dez(addr); + REP + REP + out (""10""13""); + out ("Startaddresse f r Disassemblierung :"); + addr:="$0000"; + editget (addr); + pc := dez(addr); + UNTIL positive int (pc) >= positive int (start) PER; + REP + out (""10""13""); + out ("Endaddresse f r Disassemblierung :"); + addr:="$FFFF"; + editget (addr); + out (""10""13""); + ende := dez(addr); + UNTIL positive int (ende) >= positive int (pc) PER; + REP + berechne b1 bis b4; + put (text(hex(pc),4)); + put(""); + dump; + put (" "); + disass (b1, b2, b3, b4, pc); + line; + UNTIL isincharety (""27"") OR positiveint (pc) > positive int (ende) PER + UNTIL no ("Noch weitere Bereiche disassemblieren") PER. + +berechne b1 bis b4 : + counter := pc - start; + b1 := acht (counter ); + b2 := acht (counter + 1); + b3 := acht (counter + 2); + b4 := acht (counter + 3). + +dump : + put ( text(hex(b1),3)+ + text(hex(b2),3)+ + text(hex(b3),3)+ + text(hex(b4),3)); + put (""142"" + ascii(b1) + ascii(b2) + ascii(b3) + ascii(b4) + ""143""); + +ENDPROC disassemble; + +TEXT PROC ascii (INT CONST byte) : + IF (byte MOD 128) < 32 OR (byte MOD 128) = 127 THEN "." + ELSE code(byte) + FI +ENDPROC ascii; + +REAL PROC positive int (INT CONST wert) : + IF wert < 0 THEN real(wert) + 65536.0 + ELSE real(wert) + FI +ENDPROC positive int; + + +INT PROC acht (INT CONST pos) : + IF (pos DIV 2) + 1 > max THEN LEAVE acht WITH 0 FI; + INT CONST word := row (pos DIV 2 + 1); + TEXT VAR w := " "; + replace (w, 1, word) ; + IF (pos MOD 2) = 1 THEN code(w SUB 1) + ELSE code(w SUB 2) + FI +ENDPROC acht; + +TEXT PROC hex (INT CONST zahl) : + IF zahl < 0 + THEN digit (((zahl XOR -1) DIV 4096) XOR 15) + + hex (zahl MOD 4096) + ELIF zahl < 16 + THEN digit (zahl) + ELSE hex (zahl DIV 16) + digit (zahl MOD 16) + FI +ENDPROC hex; + +TEXT PROC digit (INT CONST d) : + IF d < 10 + THEN code(d + 48) + ELSE code(d + 55) + FI +ENDPROC digit; + +PROC belegen (INT CONST b1, b2, b3) : + byte := b1; + next byte := b2; + next word := (code(b3)+code(b2)) ISUB 1; + and 7 := byte AND 7; + and f := byte AND 15; + div 10:= byte DIV 16; + div 8 := byte DIV 8 AND 7; +ENDPROC belegen; + +PROC counter incr 1 (INT CONST b2, b3, b4) : + byte := b2; + next byte := b3; + next word := (code(b4)+code(b3)) ISUB 1; + and 7 := byte AND 7; + and f := byte AND 15; + div 10:= byte DIV 16; + div 8 := byte DIV 8 AND 7; +ENDPROC counter incr 1; + +PROC counter incr 2 (INT CONST b3, b4) : + byte := b3; + next byte := b4; + next word := b4; + and 7 := byte AND 7; + and f := byte AND 15; + div 10:= byte DIV 16; + div 8 := byte DIV 8 AND 7; +ENDPROC counter incr 2; + +PROC disass (INT CONST b1, b2, b3, b4, INT VAR counter): + counter INCR int disass (b1, b2, b3, b4, counter) +ENDPROC disass; + +TEXT PROC arith log : + SELECT div 8 OF + CASE 0 : "ADD" + CASE 1 : "ADC" + CASE 2 : "SUB" + CASE 3 : "SBC" + CASE 4 : "AND" + CASE 5 : "XOR" + CASE 6 : "OR" + CASE 7 : "CP" + OTHERWISE "???" + ENDSELECT + +ENDPROC arith log; + +TEXT PROC reg1 : + SELECT div8 OF + CASE 0 : "B" + CASE 1 : "C" + CASE 2 : "D" + CASE 3 : "E" + CASE 4 : "H" + CASE 5 : "L" + CASE 6 : "(HL)" + CASE 7 : "A" + OTHERWISE "???" + ENDSELECT + +ENDPROC reg1; + +TEXT PROC reg2 : + SELECT and7 OF + CASE 0 : "B" + CASE 1 : "C" + CASE 2 : "D" + CASE 3 : "E" + CASE 4 : "H" + CASE 5 : "L" + CASE 6 : "(HL)" + CASE 7 : "A" + OTHERWISE "???" + ENDSELECT + +ENDPROC reg2; + +TEXT PROC rp: + SELECT div10 AND 3 OF + CASE 0 : "BC" + CASE 1 : "DE" + CASE 2 : "HL" + CASE 3 : "SP" + OTHERWISE "???" + ENDSELECT + +ENDPROC rp; + + +INT PROC bitmanipulation : + SELECT byte DIV 32 OF + CASE 1 : write ("BIT "+text(div8)+","+reg2);2 + CASE 2 : write ("RES "+text(div8)+","+reg2);2 + CASE 3 : write ("SET "+text(div8)+","+reg2);2 + OTHERWISE write("??? $"+hex(next byte));1 + ENDSELECT + +ENDPROC bitmanipulation; + +BOOL PROC is special instruction : + byte > 192 AND (and 7 = 3 OR + and 7 = 6 OR + and f = 9 ) +OR byte < 64 AND (and 7 = 7 OR + and 7 = 0 OR + and 7 = 2 ) . + +ENDPROC is special instruction; + +INT PROC int disass (INT CONST b1, b2, b3, b4, counter) : + belegen (b1, b2, b3); + IF is special instruction + THEN disass special instruction + ELIF div 10 < 4 + THEN lower case instruction + ELIF div 10 < 128 + THEN ld instruction + ELIF div 10 < 192 + THEN arith log instruction + ELSE higher case instruction + FI. + +arith log instruction : + write (arith log+" "+reg 2);1 . + +ld instruction : + write ("LD "+reg 1+","+reg 2);1 . + +condition code : + SELECT div8 OF + CASE 0 : "NZ" + CASE 1 : "Z" + CASE 2 : "NC" + CASE 3 : "C" + CASE 4 : "PO" + CASE 5 : "PE" + CASE 6 : "P" + CASE 7 : "M" + OTHERWISE "???" + ENDSELECT. + +lower case instruction : + IF and f = 1 THEN write ("LD "+rp+",$"+hex(next word));3 + ELIF and 7 = 3 THEN write ("INC "+rp);1 + ELIF and 7 = 4 THEN write ("INC "+reg1);1 + ELIF and 7 = 5 THEN write ("DEC "+reg1);1 + ELIF and 7 = 6 THEN write ("LD "+reg1+",$"+hex(next byte));2 + ELIF and f = 9 THEN write ("ADD HL,"+rp);1 + ELIF and f =11 THEN write ("DEC "+rp);1 + ELSE write ("??? $"+hex(next byte));1 + FI. + +higher case instruction : + SELECT and 7 OF + CASE 0 : write ("RET "+condition code);1 + CASE 1 : write ("POP "+rp);1 + CASE 2 : write ("JP "+condition code+",$"+hex(next word));3 + CASE 4 : write ("CALL "+condition code+",$"+hex(next word));3 + CASE 5 : write ("PUSH "+rp);1 + CASE 7 : write ("RST "+text(div 8));1 + OTHERWISE write ("??? $"+hex(next byte));1 + ENDSELECT. + + +branchaddress : + "$" + hex(counter + displacement) . + +displacement : + IF next byte < 128 + THEN next byte + 2 + ELSE next byte - 254 + FI. + +cb instructions : + counter incr 1 (b2, b3, b4); + SELECT div 8 OF + CASE 0 : write ("RCC "+reg2);2 + CASE 1 : write ("RRC "+reg2);2 + CASE 2 : write ("RL "+reg2);2 + CASE 3 : write ("RR "+reg2);2 + CASE 4 : write ("SLA "+reg2);2 + CASE 5 : write ("SRA "+reg2);2 + CASE 6 : write ("SLL "+reg2);2 + CASE 7 : write ("SLR "+reg2);2 + OTHERWISE bitmanipulation + ENDSELECT . + +disass special instruction : + SELECT byte OF + CASE 0 : write ("NOP");1 + CASE 2 : write ("LD (BC),A");1 + CASE 7 : write ("RLCA");1 + CASE 8 : write ("EX AF,AF'");1 + CASE 10 : write ("LD A,(BC)");1 + CASE 15 : write ("RRCA");1 + CASE 16 : write ("DJNZ "+branchaddress);2 + CASE 18 : write ("LD (DE),A");1 + CASE 23 : write ("RLA");1 + CASE 24 : write ("JR "+branchaddress);2 + CASE 26 : write ("LD A,(DE)");1 + CASE 31 : write ("RRA");1 + CASE 32 : write ("JR NZ,"+branchaddress);2 + CASE 34 : write ("LD ($"+hex (next word)+"),HL");3 + CASE 39 : write ("DAA");1 + CASE 40 : write ("JR Z,"+branchaddress);2 + CASE 42 : write ("LD HL,($"+hex(next word)+")");3 + CASE 47 : write ("CPL");1 + CASE 48 : write ("JR NC,"+branchaddress);2 + CASE 50 : write ("LD ($"+hex(next word)+"),A");3 + CASE 55 : write ("SCF");1 + CASE 56 : write ("JR C,"+branchaddress);2 + CASE 58 : write ("LD A,($"+hex(next word)+")");3 + CASE 63 : write ("CCF");1 + CASE 118: write ("HALT");1 + CASE 195: write ("JP $"+hex(next word));3 + CASE 198: write ("ADD A,$"+hex(next byte));2 + CASE 201: write ("RET");1 + CASE 203: cb instructions + CASE 205: write ("CALL $"+hex(next word));3 + CASE 206: write ("ADC A,$"+hex(next byte));2 + CASE 211: write ("OUT ($"+hex(next byte)+")");2 + CASE 214: write ("SUB A,$"+hex(next byte));2 + CASE 217: write ("EXX");1 + CASE 219: write ("IN ($"+hex(next byte)+")");2 + CASE 221: index := "IX"; dd and fd instructions + CASE 222: write ("SBC A,$"+hex(next byte));2 + CASE 227: write ("EX (SP),HL");1 + CASE 230: write ("AND $"+hex(next byte));2 + CASE 233: write ("JP (HL)");1 + CASE 235: write ("EX DE,HL");1 + CASE 237: ed instructions + CASE 238: write ("XOR $"+hex(next byte));2 + CASE 243: write ("DI");1 + CASE 246: write ("OR $"+hex(next byte));2 + CASE 249: write ("LD SP,HL");2 + CASE 251: write ("EI");1 + CASE 253: index := "IY"; dd and fd instructions + CASE 254: write ("CP $"+hex(next byte));2 + OTHERWISE write ("??? $"+hex(byte));1 + ENDSELECT. + +dd and fd instructions : + counter incr 1 (b2, b3, b4); + SELECT byte OF + CASE 33 : write ("LD "+index+",$"+hex(next word));4 + CASE 34 : write ("LD ($"+hex(next word)+"),"+index);4 + CASE 35 : write ("INC "+index);2 + CASE 42 : write ("LD "+index+",($"+hex(next word)+")");4 + CASE 43 : write ("DEC "+index);2 + CASE 52 : write ("INC ("+index+"+$"+hex(next byte)+")");2 + CASE 53 : write ("DEC ("+index+"+$"+hex(next byte)+")");2 + CASE 203: dd and fd cb instructions + CASE 225: write ("POP "+index);2 + CASE 227: write ("EX (SP),"+index);2 + CASE 229: write ("PUSH "+index);2 + CASE 233: write ("JP ("+index+")");2 + CASE 249: write ("LD SP,"+index);2 + OTHERWISE calculated dd and fd instructions + ENDSELECT. + +calculated dd and fd instructions : + IF andf = 9 THEN write ("ADD "+index+","+rp);2 + ELIF and7 = 6 AND div 10 > 3 AND div 10 < 8 + THEN write ("LD "+reg1+",("+index+"+$"+hex(next byte)+")");3 + ELIF div 10 = 7 AND byte <> 118 + THEN write ("LD ("+index+"+$"+hex(next byte)+"),"+reg2);3 + ELIF and7 = 6 AND div 10 > 7 AND div 10 < 12 + THEN write (arith log+" ("+index+"+$"+hex(next byte)+")");3 + ELSE write ("??? $DD/FD "+hex(byte));2 + FI. + +dd and fd cb instructions : + counter incr 2 (b4, b3); + IF and7 <> 6 THEN write ("??? $DD/FD "+hex(byte));3 + ELSE SELECT div 8 OF + CASE 0 : write ("RLC ("+index+"+$"+hex(next byte)+")");4 + CASE 1 : write ("RRC ("+index+"+$"+hex(next byte)+")");4 + CASE 2 : write ("RL ("+index+"+$"+hex(next byte)+")");4 + CASE 3 : write ("RR ("+index+"+$"+hex(next byte)+")");4 + CASE 4 : write ("SLA ("+index+"+$"+hex(next byte)+")");4 + CASE 5 : write ("SRA ("+index+"+$"+hex(next byte)+")");4 + CASE 6 : write ("SLL ("+index+"+$"+hex(next byte)+")");4 + CASE 7 : write ("SRL ("+index+"+$"+hex(next byte)+")");4 + OTHERWISE dd and fd bitmanipulation + ENDSELECT + FI. + +dd and fd bitmanipulation : + SELECT byte DIV 32 OF + CASE 1 : write ("BIT "+text(div8)+",("+index+"+$"+hex(next byte)+")");4 + CASE 2 : write ("RES "+text(div8)+",("+index+"+$"+hex(next byte)+")");4 + CASE 3 : write ("SET "+text(div8)+",("+index+"+$"+hex(next byte)+")");4 + OTHERWISE write ("??? $DD/FD CB "+hex(next byte)+" "+hex(byte));4 + ENDSELECT. + +ed instructions : + counter incr 1 (b2, b3, b4); + SELECT byte OF + CASE 68 : write ("NEG");2 + CASE 69 : write ("RETN");2 + CASE 70 : write ("IM 0");2 + CASE 71 : write ("LD I,A");2 + CASE 77 : write ("RETI");2 + CASE 79 : write ("LD R,A");2 + CASE 86 : write ("IM 1");2 + CASE 87 : write ("LD A,I");2 + CASE 94 : write ("IM 2");2 + CASE 95 : write ("LD A,R");2 + CASE 103: write ("RRD");2 + CASE 111: write ("RLD");2 + CASE 171: write ("OUTD");2 + CASE 163: write ("OUTI");2 + CASE 179: write ("OTIR");2 + CASE 187: write ("OTDR");2 + OTHERWISE calculate ed instruction + ENDSELECT. + + +ENDPROC int disass ; + +INT PROC calculate ed instruction : + IF and7 = 0 AND is 40 to 7f THEN write ("IN "+reg1+",(C)");2 + ELIF and7 = 1 AND is 40 to 7f THEN write ("OUT "+reg1+",(C)");2 + ELIF andf = 2 AND is 40 to 7f THEN write ("SBC HL,"+rp);2 + ELIF andf = 3 AND is 40 to 7f THEN write ("LD ($"+hex(nextword)+"),"+rp);4 + ELIF andf =11 AND is 40 to 7f THEN write ("LD "+rp+",($"+hex(nextword)+")");4 + ELIF andf =10 AND is 40 to 7f THEN write ("ADC HL,"+rp);2 + ELIF div10 = 10 OR div10 = 11 THEN + IF and7 = 0 THEN write ("LD"+modification);2 + ELIF and7 = 1 THEN write ("CP"+modification);2 + ELIF and7 = 2 THEN write ("IN"+modification);2 + ELSE write ("??? $ED "+hex(next byte));2 + FI + ELSE write ("??? $ED "+hex(next byte));2 + FI. + +is 40 to 7f : + div 10 < 8 AND div 10 > 3. + +modification : + SELECT div8 OF + CASE 0 : "I" + CASE 1 : "D" + CASE 2 : "IR" + CASE 3 : "DR" + OTHERWISE "???" + ENDSELECT. + +ENDPROC calculate ed instruction; + +ENDPACKET z80 disassembler + -- cgit v1.2.3