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 ++++++++++++++++++++++++++++++++++++ 1 file changed, 1110 insertions(+) create mode 100644 devel/misc/unknown/src/0DISASS.ELA (limited to 'devel/misc/unknown/src/0DISASS.ELA') 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, M„rz/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 ; -- cgit v1.2.3