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 ;