diff options
| author | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:19 +0100 |
|---|---|---|
| committer | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:39 +0100 |
| commit | 98cab31fc3659e33aef260efca55bf9f1753164c (patch) | |
| tree | f1affa84049ef9b268e6c4f521f000478b0f3a8e /devel/misc/unknown/src/0DISASS.ELA | |
| parent | 71e2b36ccd05ea678e62e32ee6245df2b8d6ac17 (diff) | |
| download | eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.gz eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.bz2 eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.zip | |
Add source files from Michael
Diffstat (limited to 'devel/misc/unknown/src/0DISASS.ELA')
| -rw-r--r-- | devel/misc/unknown/src/0DISASS.ELA | 1110 |
1 files changed, 1110 insertions, 0 deletions
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 " <LOCAL>"
+ 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 ;
|