path: root/devel/debugger/src/DEBUGGER.ELA

(*************************************************************************) 
(**                                                                     **) 
(*  EUMEL - Debugger: (C) Michael Staubermann, Oktober/November '86      *) 
(*  Ab EUMEL 1.7.5.4                                                     *)
(*  Stand: 01.12.86, 1.8.2: 26.07.88                                     *)
(*  Noch keine BOUND-Variablen-Zugriffe implementiert                    *)
(**                                                                     **) 
(*************************************************************************) 
 
 
PACKET address  DEFINES ADD,                      (* 1.7.5  861006 *) 
                        SUB,                      (* 1.8.0  861022 *)
                        MUL,                      (* M. Staubermann*)
                        INC, 
                        DEC, 
                        ulseq,
 
                        split word , 
                        make word , 

                        hex16, 
                        hex8 , 
                        integer , 
 
                        cdbint , 
                        cdbtext , 
 
                        get word , 
                        put word : 
 
 
(*********************** Hex-Konvertierung ********************************) 
 
LET hex digits = "0123456789ABCDEF" ; 
 
PROC paket initialisierung : 
 (* Paketinitialisierung, wird nur einmal durchlaufen *)
 INT CONST ulseq addr :: getword (0, 512 + 
     mod nr (BOOL PROC (INT CONST, INT CONST) ulseq)) ADD 2 ; 
 IF getword (3, ulseq addr) = integer ("B009") (* bei checkoff LSEQ *) 
    THEN putword (3, ulseq addr, integer ("D409")) (* ULSEQ <LR 4> *)
 ELIF getword (3, ulseq addr ADD 1) = integer ("B009") (* bei checkon *) 
    THEN putword (3, ulseq addr ADD 1, integer ("D409"))  
 FI 
 
ENDPROC paket initialisierung ; 
 
INT PROC integer (TEXT CONST hex) : 
 INT VAR summe := 0, i ; 
 FOR i FROM 1 UPTO min (4, LENGTH hex) REP 
  rotate (summe, 4) ; 
  summe INCR digit 
 PER ; 
 summe .
 
digit : 
 TEXT CONST char := hex 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 digits SUB ((wert DIV 16) +1)) +
 (hex digits SUB ((wert AND 15) +1))
 
ENDPROC hex8 ; 
 
TEXT PROC hex16 (INT CONST wert) :
 TEXT VAR result := "" ; 
 INT VAR i, w := wert ;
 FOR i FROM 1 UPTO 4 REP 
  rotate (w, 4) ; 
  result CAT (hex digits SUB ((w AND 15)+1))
 PER ; 
 result  
 
ENDPROC hex16 ;
 
(***************************** Adressarithmetik ***************************)

PROC arith 15 : 
 
 EXTERNAL 91 
 
ENDPROC arith 15 ; 
 
 
PROC arith 16 : 
 
 EXTERNAL 92 
 
ENDPROC arith 16 ; 
 
 
OP INC (INT VAR a) : 
 arith 16 ; 
 a INCR 1
 
ENDOP INC ; 
 

OP DEC (INT VAR a) : 
 arith 16 ; 
 a DECR 1
 
ENDOP DEC ; 
 
 
INT OP ADD (INT CONST left, right) : 
 arith 16 ; 
 left + right  
 
ENDOP ADD ; 
 
INT OP SUB (INT CONST left, right) : 
 arith16 ; 
 left - right 
 
ENDOP SUB ; 
 
INT OP MUL (INT CONST left, right) : 
 arith 16 ; 
 left * right    (* Multiplikation MOD 65536 im Gegensatz zu IMULT *)
 
ENDOP MUL ; 
 
BOOL PROC ulseq (INT CONST left, right) : 
 left <= right   (* Mu� leider(!!) auf ULSEQ Code gepatcht werden *)
ENDPROC ulseq ; 

(*************************** Wortoperationen ******************************) 
 
PROC split word (INT VAR word and high byte, low byte) : 
 
 EXTERNAL 15 
 
ENDPROC split word ; 
 

PROC make word (INT VAR highbyte and resultword, INT CONST low byte) : 
 
 EXTERNAL 16 

ENDPROC make word ; 
 
 
(************************** DS4-Access ***********************************)
 
INT PROC cdbint (INT CONST adr) : 
 
 EXTERNAL 116 
 
ENDPROC cdbint ; 
 
 
TEXT PROC cdbtext (INT CONST adr) : 
 
 EXTERNAL 117 

ENDPROC cdbtext ; 
 
 
PROC putword (INT CONST segment, adr, value) : 
 
 EXTERNAL 119 
 
ENDPROC put word ; 
 
 
INT PROC getword (INT CONST segment, adr) : 
 
 EXTERNAL 120 
 
ENDPROC getword ; 
 

INT PROC mod nr (BOOL PROC (INT CONST, INT CONST) proc) : 

 EXTERNAL 35 

ENDPROC mod nr ; 


paket initialisierung 

ENDPACKET address ; 
 
(**************************************************************************) 
 
PACKET table routines DEFINES                (* F�r eumel decoder 861017 *)
                                             (* 1.8.0 by M.Staubermann   *)
                              code segment , 
                              code address ,
                              packet name , 
                              module name and specifications ,
                              get module number ,
                              storage , 
                              hash ,
                              init module table, 
                              add modules ,
                              dump tables :
 
 
LET end of hash table                 = 1023 , 
    begin of permanent table          = 22784 , 
    begin of pt minus ptt limit       = 12784 ,
    end of permanent table            = 32767 , 
 
    permanent param const             = 10000 ,
    permanent param var               = 20000 ,
    permanent proc op                 = 30000 ,
    permanent type                    = 30000 ,
    permanent row                     =    10 ,
    permanent struct                  =    11 ,
    permanent param proc              =    12 ,
    permanent struct end              =     0 ,

    ptt limit                         = 10000 ,
 
    void                              =     0 ,
    
    const                             =     1 , 
    var                               =     2 ,

    sysgenoff module number           = 1280 , 
    start of module number link table = 512 ,   
    highest module number 1           = 2048 , 
    max packets                       = 128 ,
    max types                         = 64 ;
 
 
LET MODULETABLE = ROW highest module number 1 
                      STRUCT (TEXT name, specifications, INT packet link) , 
    PACKETTABLE = ROW max packets STRUCT (TEXT name, INT permanent address), 
    TYPETABLE   = STRUCT (THESAURUS names, ROW max types INT storage),
    TABLETYPE   = BOUND STRUCT (MODULETABLE module, PACKETTABLE packet,
                                TYPETABLE types, INT number of packets, 
                                end of permanent table) ; 
 
TABLETYPE VAR table ; 
 
TEXT VAR type and mode, result ; 
BOOL VAR end of params ; 
INT VAR mode, paramlink, index ;
 
(************************* Module- und Packettablezugriff **************) 
 
PROC init module table (TEXT CONST table name) :
 forget (table name, quiet) ; 
 table := new (table name) ; 
 table.number of packets := 0 ; 
 table.end of permanent table := begin of permanent table ;

 table.types.names := empty thesaurus ;
 insert (table.types.names, "INT", index) ; 
 table.types.storage (index) := 1 ; 
 insert (table.types.names, "REAL", index) ; 
 table.types.storage (index) := 4 ; 
 insert (table.types.names, "BOOL", index) ; 
 table.types.storage (index) := 1 ; 
 insert (table.types.names, "TEXT", index) ; 
 table.types.storage (index) := 8 ; 
 insert (table.types.names, "DATASPACE", index) ; 
 table.types.storage (index) := 1 ; 

 scan permanent table (table.end of permanent table) ; 
 scan hash table (begin of permanent table) ; 
 
ENDPROC init module table ; 
 
 
PROC add modules :
 INT CONST old end of permanent table := table.end of permanent table ;
 IF cdbint (table.end of permanent table) <> -3 
    THEN scan permanent table (table.end of permanent table) ; 
         scan hash table (old end of permanent table)
 FI  

ENDPROC add modules ; 
 
 
PROC scan hash table (INT CONST minimum permanent address) : 
 INT VAR hash table pointer ; 
 FOR hash table pointer FROM 0 UPTO end of hash table REP 
  IF cdbint (hash table pointer) <> 0 
  THEN cout (hash table pointer) ; 
       list all name table objects with this hash code (hash table pointer,
                     minimum permanent address)
  FI 
 PER 
 
ENDPROC scan hash table ; 
 
 
PROC list all name table objects with this hash code (INT CONST link,
                   minimum permanent address) :
 TEXT VAR object name ;
 INT VAR name table pointer := first link word, module nr, 
         permanent pointer ; 
 WHILE NOT end of name table chain REPEAT
  permanent pointer := cdb int (nametable pointer + 1) ;
  WHILE permanent pointer >= minimum permanent address REP
   object name := cdbtext (name table pointer + 2) ; 
   IF permanent type definition 
    THEN insert (table.types.names, object name, index) ;
         table.types.storage (index) := cdb int (permanent pointer + 2) 
    ELSE get specifications (permanent pointer) ; 
         module nr := cdb int (param link + 1) + 1;
         table.module (module nr).name := object name ; 
         table.module (module nr).specifications := result;
         table.module (module nr).packet link := packetlink(permanentpointer) 
   FI ; 
   permanent pointer := cdb int (permanent pointer)
  PER ; 
  name table pointer := cdb int (name table pointer)  
 END REPEAT . 
 
first link word : 
 cdb int (link) .
 
end of name table chain : 
 name table pointer = 0 . 
 
permanent type definition : 
 (object name SUB 1) <= "Z" AND (object name SUB 1) >= "A" AND 
  cdbint (permanent pointer + 1) = permanent type 

END PROC list all name table objects with this hash code ; 
 
 
INT PROC packet link (INT CONST permanent address) : 
 INT VAR packet pointer ; 
 FOR packet pointer FROM 1 UPTO table.number of packets REP 
     IF table.packet (packet pointer).permanent address > permanent address 
        THEN LEAVE packet link WITH packet pointer -1
     FI 
 PER ; 
 table.number of packets 

ENDPROC packet link ; 
 

PROC scan permanent table (INT VAR permanent pointer) : 
 FOR permanent pointer FROM permanent pointer UPTO end of permanent table 
     WHILE cdbint (permanent pointer) <> -3 REP 
  IF cdbint (permanent pointer) = -2 
     THEN cout (permanent pointer) ;
          table.number of packets INCR 1 ; 
          table.packet (table.number of packets).name := 
               cdbtext (cdbint (permanent pointer +1) +2) ; 
          table.packet (table.number of packets).permanent address := 
               permanent pointer
  FI 
 PER 

ENDPROC scan permanent table ; 
 

PROC dump tables (TEXT CONST file name) : 
 INT VAR i ; 
 forget (filename, quiet) ; 
 FILE VAR f := sequentialfile (output, filename) ; 
 maxline length (f, 1000) ;
  
 putline (f, "PACKETTABLE:") ; 
 put (f, "End of Permanenttable:") ; 
 put (f, hex16 (table.end of permanent table)) ; 
 line (f) ; 
 putline (f, "Nr. Packetname") ;
 FOR i FROM 1 UPTO table.number of packets REP 
  cout (i) ; 
  put (f, text (i, 3)) ; 
  put (f, hex16 (table.packet (i).permanent address)) ; 
  putline (f, table.packet (i).name) 
 PER ; 
 line (f, 2) ; 
 putline (f, "TYPETABLE:") ; 
 putline (f, " Size Name") ; 
 index := 0 ; 
 get (table.types.names, type and mode, index) ; 
 WHILE index > 0 REP 
  put (f, text (table.types.storage (index), 5)) ; 
  putline (f, type and mode) ; 
  get (table.types.names, type and mode, index) 
 PER ; 
 line (f, 2) ; 
 putline (f, "MODULETABLE:") ; 
 putline (f, "Modnr.PNr.Name and Parameters") ; 
 FOR i FROM 1 UPTO highest module number 1 REP 
  IF table.module (i).packet link <> -1 
     THEN cout (i) ;
          put (f, text (i-1, 5)) ; 
          put (f, text (table.module (i).packet link, 3)) ;
          put (f, table.module (i).name) ; 
          putline (f, table.module (i).specifications) ; 
  FI 
 PER  
 
ENDPROC dump tables ; 
 

INT PROC storage (TEXT CONST typename) : 
 index := link (table.types.names, typename) ; 
 IF index = 0 
    THEN 0 
    ELSE table.types.storage (index) 
 FI 

ENDPROC storage ; 
 
 
TEXT PROC module name and specifications (INT CONST module number) : 
 IF LENGTH table.module (module number + 1).name > 0 
    THEN table.module (module number + 1).name + " " + 
         table.module (module number + 1).specifications
    ELSE "" 
 FI

ENDPROC module name and specifications ; 
 
 
TEXT PROC packet name (INT CONST module number) :
 IF table.module (module number + 1).packet link > 0 
    THEN table.packet (table.module (module number + 1).packet link).name 
    ELSE FOR index FROM module number DOWNTO 1 REP
           IF table.module (index).packet link > 0 
              THEN LEAVE packet name WITH table.packet (table.module 
                   (index).packet link).name
           FI 
         PER ; 
         "" 
 FI
 
ENDPROC packet name ; 
 

(************************ Modulnummern ***********************************) 
 
INT PROC code segment (INT CONST module number) : 
 IF module number < sysgen off module number 
    THEN 2 
    ELSE 3 
 FI 

ENDPROC code segment ; 
 

INT PROC code address (INT CONST module number) : 
 get word (0, start of module number link table + module number) 
ENDPROC code address ; 
 

PROC get module number (INT VAR module number) : 
 TEXT VAR object ;
 INT VAR anz objects, name table pointer, permanent pointer ;  
 put ("Name oder Modulnummer der PROC/OP:") ; 
 getline (object) ; 
 changeall (object, " ", "") ;
 IF object = "" 
    THEN LEAVE get module number 
 FI ; 
 disablestop ; 
 module number := int (object) ; 
 IF NOT iserror AND last conversion ok AND module number >= -1 AND 
                                           module number < 2048
    THEN LEAVE get module number 
 FI ; 
 clear error ; 
 enablestop ; 
 anz objects := 0 ; 
 FILE VAR f := notefile ; 
 maxlinelength (f, 1000) ; 
 note ("Modulnummer des gew�nschten Objekts merken und ESC q tippen.") ; 
 noteline ;
 noteline ;
 module number := -1 ;
 scan permanent table chain with object name ; 
 IF anz objects > 1 
    THEN note edit ; 
         put ("Modulnummer der PROC/OP:") ; 
         get (module number)  
    ELSE type (""27"q") ; 
         note edit
 FI . 
 
scan permanent table chain with object name : 
 name table pointer := first link word ; 
 WHILE NOT end of name table chain REP
  IF cdb text (name table pointer + 2) = object 
     THEN permanent pointer := cdb int (nametable pointer + 1) ;
          IF NOT permanent type definition 
             THEN run through permanent chain 
          FI ; 
  FI ; 
  name table pointer := cdb int (name table pointer)   
 PER . 
 
run through permanent chain : 
 WHILE permanent pointer <> 0 REP
   anz objects INCR 1 ; 
   cout (anz objects) ;
   get specifications (permanent pointer) ; 
   IF anz objects = 1 
      THEN module number := module nr 
   FI ;
   note (text (module nr, 4)) ; 
   note ("  ") ; 
   note (object) ; 
   note (" ") ;
   note (result) ; 
   noteline ;
   permanent pointer := cdbint (permanent pointer)
 PER . 
 
module nr : 
 cdb int (param link + 1) . 
         
first link word : 
 cdb int (hash (object)) .
 
end of name table chain : 
 name table pointer = 0 . 
 
permanent type definition : 
 (object SUB 1) <= "Z" AND (object SUB 1) >= "A" AND 
  cdbint (permanent pointer + 1) = permanent type 
 
ENDPROC get module number ; 
   

(************************* Permanenttabellenzugriffe **********************) 
 
INT PROC hash (TEXT CONST obj name) : 
 INT VAR i, hash code ; 
 hash code := 0 ; 
 FOR i FROM 1 UPTO LENGTH obj name REP 
  addmult cyclic 
 PER ; 
 hash code . 
 
addmult cyclic : 
 hash code INCR hash code ; 
 IF hash code > end of hash table THEN wrap around FI ; 
 hash code := (hash code + code (obj name SUB i)) AND end of hash table . 
 
wrap around : 
 hash code DECR end of hash table 

ENDPROC hash ; 


PROC next pt param :
 mode := cdb int (param link) MOD ptt limit ;
 param link INCR 1 ;
 IF mode = permanent row 
   THEN skip over permanent row 
 ELIF mode = permanent struct 
   THEN skip over permanent struct
 FI ;
 set end marker if end of list .
 
skip over permanent row :
 param link INCR 1 ; (* Skip row size *)
 next pt param .

skip over permanent struct :
 mode := cdbint (param link) ; 
 WHILE mode <> permanent struct end REP 
   next pt param ;
   mode := cdbint (param link) 
 PER ;
 param link INCR 1   (* skip permanent struct end *) 

ENDPROC next pt param ;


PROC set end marker if end of list :
 mode := cdb int (param link) ;
 end of params := mode >= permanent proc op OR mode <= 0 
 
ENDPROC set end marker if end of list ;


PROC get type and mode (INT VAR type) : 
 mode := cdb int (param link) ;
 IF mode = permanent param proc 
    THEN type of param proc 
    ELSE type of object
 FI .

type of param proc : 
 param link INCR 1 ;
 get type and mode (type) ;
 mode := permanent param proc .

type of object :
 IF mode < 0 
    THEN type := 2769 + (32767 + mode) ;
         mode := 0
    ELSE type := mode MOD ptt limit ;
         mode DECR type ;
         translate type if necessary ;
         translate mode if necessary 
 FI .

translate type if necessary :
 IF permanent row or struct THEN translate type FI .

translate type :
 type := param link - begin of pt minus ptt limit .

translate mode if necessary : 
 IF mode = permanent param const 
    THEN mode := const
 ELIF mode = permanent param var 
    THEN mode := var
 FI .

permanent row or struct :
 type = permanent row OR type = permanent struct

ENDPROC get type and mode ;
 

PROC get specifications (INT CONST permanent pointer) : 
 result := "" ;
 to first param ;
 IF NOT end of params THEN put param list FI ;
 get result . 
 
to first param :
 param link := permanent pointer + 1 ;
 set end marker if end of list .
 
get result :
 INT VAR type;
 get type and mode (type) ;
 IF type <> void 
    THEN type and mode := " --> " ;
         name of type (type) ;
         result CAT type and mode 
 FI

ENDPROC get specifications ;


PROC put param list : 
 result CAT "(" ;
 REP
   INT VAR type;
   get type and mode (type) ;
   put type and mode ;
   maybe param proc ;
   next pt param ;
   IF end of params 
      THEN result CAT ")" ;
           LEAVE put param list 
   FI ;
   result CAT ", " ;
 PER . 
 
put type and mode :
 INT CONST mode1 :: mode ;
 type and mode := "" ;
 name of type (type) ;
 type and mode CAT name of mode ;
 result CAT type and mode .
 
name of mode :
 IF   mode1 = const THEN " CONST"
 ELIF mode1 = var   THEN " VAR"
 ELIF type = void   THEN "PROC" 
                    ELSE " PROC" 
 FI .
 
maybe param proc :
 IF mode = permanent param proc THEN put virtual params FI .
 
put virtual params :
 skip over result type if complex type ;
 IF NOT end of virtual params 
    THEN result CAT " " ;
         put param list 
 FI .
 
skip over result type if complex type :
 next pt param .
 
end of virtual params :
 end of params

ENDPROC put param list ;
 

PROC name of type (INT CONST type) :
 LET int         = 1 ,
     real        = 2 ,
     string      = 3 ,
     bool        = 5 ,
     bool result = 6 ,
     dataspace   = 7 ; 
 
 SELECT type OF
   CASE void        :
   CASE int         : type and mode CAT "INT"
   CASE real        : type and mode CAT "REAL"
   CASE string      : type and mode CAT "TEXT"
   CASE bool,
        bool result : type and mode CAT "BOOL"
   CASE dataspace   : type and mode CAT "DATASPACE"
   OTHERWISE complex type
 ENDSELECT .
 
complex type :
 IF type > ptt limit THEN perhaps permanent struct or row
                     ELSE get complex type
 FI .
 
perhaps permanent struct or row :
 index := type + begin of pt minus ptt limit ;
 mode := cdb int (index) MOD ptt limit ;
 IF   mode = permanent row    THEN get permanent row 
 ELIF mode = permanent struct THEN get permanent struct
                              ELSE type and mode CAT "-"
 FI .
 
get complex type :
 index := type + begin of permanent table ;
 IF is complex type 
    THEN get name
    ELSE type and mode CAT "<HIDDEN>"
 FI .
 
is complex type :
 permanent type definition mode = permanent type . 
 
get name :
 type and mode CAT cdb text (link to type name + 2) .
 
link to type name :
 cdb int (index + 3) .
 
permanent type definition mode :
 cdb int (index + 1) .

get permanent row :
 INT VAR t; 
 type and mode CAT "ROW " ;
 type and mode CAT text (cdb int (index + 1)) ;
 type and mode CAT " " ;
 param link := index + 2 ;
 get type and mode (t) ;
 name of type (t) .
 
get permanent struct :
 type and mode CAT "STRUCT (" ; 
 param link := index + 1 ; 
 WHILE within permanent struct REP 
  get type and mode (t) ;
  name of type (t) ; 
  next pt param ; 
  IF within permanent struct
     THEN type and mode CAT ", " 
  FI 
 PER ; 
 type and mode CAT ")" . 
 
within permanent struct :
 cdbint (param link) <> permanent struct end . 
 
ENDPROC name of type ;
 
 
ENDPACKET table routines ; 
 

(*************************************************************************)
 
PACKET eumel decoder DEFINES        (* M. Staubermann, M�rz/April 86 *)
                                    (* 1.8.0 861201 *) 
                                    (* 1.8.2 880726 *)
       lbase , 
       pbase ,
       set parameters , 
       get parameters , 
       default no runtime ,
       bool result ,
       line number ,
       list file name ,
       last actual parameter ,
       with code words ,
       with object address ,

       next word ,
       next module header ,
       data representation ,
       object representation ,

       decode module ,
       decode : 


LET packet data segment  =      0 , 
    local  data segment  =      1 ,
    standard dataspace   =      0 , (* ds = 4 *)

    first elan address   = 13 584 , (* codeaddress (273) *)
    begin of stringtable =  1 024 , 
    begin of nametable   =  4 096 , 
    end of nametable     = 22 783 ; 
 
LET try type        =  0 , {?}
    int addr        = 10 , {I}
    real addr       = 19 , {R}
    text addr       = 20 , {S}
    dataspace addr  =  5 , {D}
    task addr       = 21 , {T}
    ref addr        =  1 , {@}
    mod addr        =  2 , {A}
    bool addr       =  3 , {B}
    int value       = 23 , {V}
    hexbyte value   =  9 , {H}
    module nr value = 14 ; {M}
 
LET OPN       = STRUCT (TEXT mnemonic, params, BOOL bool result) , 
    PRIMOP    = ROW  31 OPN ,
    SPECIALOP = ROW   6 OPN , 
    ESCOP     = ROW 130 OPN ,

    rtnt opcode = 32513 , 
    rtnf opcode = 32514 ; 
 
LET hex 3fff  = 16 383 ,
    hex 03ff  =  1 023 ,
    hex 0400  =  1 024 , 
    hex 7c    =    124 ,
    hex 7f    =    127 , 
    hex f0    =    240 ,
    hex fd    =    253 , 
    hex ff    =    255 ;
 
INT CONST hex 83ff  :: -31745 ,
          hex ff00  :: -256 ,
          hex fff8  :: -8 ,
          minus one :: -1 ;
 
FILE VAR list file ; 
TEXT VAR file name := "" , 
         text val := "" ;
INT VAR file number := 0 ,
        data base , 
        ln := minus one ,
        lbas := minus one ,
        cmod := minus one ;
   
BOOL VAR was bool result , 
         echo ,
         with statement line := TRUE ,
         with object and address := TRUE ;
 
 
INT PROC line number : 
 ln 
ENDPROC line number ; 
 

TEXT PROC last actual parameter : 
 text val 
ENDPROC last actual parameter ; 
 

PROC pbase (INT CONST i) : 
 data base := i ; 
 makeword (data base, 0)
ENDPROC pbase ; 
 

INT PROC pbase : 
 INT VAR lowbyte, highbyte := data base ; 
 split word (highbyte, lowbyte) ; 
 highbyte
ENDPROC pbase ; 
 

PROC lbase (INT CONST i) : 
 lbas := i 
ENDPROC lbase ; 
 

BOOL PROC bool result : 
 was bool result 
ENDPROC bool result ; 
 

BOOL PROC with object address : 
 with object and address 
ENDPROC with object address ; 
 

PROC with object address (BOOL CONST b) : 
 with object and address := b 
ENDPROC with object address ; 
 

PROC with codewords (BOOL CONST b) : 
 with statement line := b 
ENDPROC with codewords ; 
 

BOOL PROC with codewords : 
 with statement line 
ENDPROC with codewords ; 
 

PROC bool result (BOOL CONST b) : 
 was bool result := b 
ENDPROC bool result ; 
 

PROC list file name (TEXT CONST name) : 
 file name := name 
ENDPROC list file name ; 
 

PROC set parameters (INT CONST lbase, pbas, line number, codmod) : 
 lbas := lbase ; 
 pbase (pbas) ;
 ln := line number ; 
 cmod := codmod 
ENDPROC set parameters ; 
 

PROC get parameters (INT VAR lbase, pbas, line number, codmod) :
 lbase := lbas ; 
 pbas := pbase ; 
 line number := ln ; 
 codmod := cmod 
ENDPROC get parameters ; 
 

PROC default no runtime : 
 lbas := minus one ; 
 ln := minus one ; 
 database := minus one ; 
 cmod := minus one 
ENDPROC default no runtime ; 
 

PRIMOP CONST primop := PRIMOP :( 
  OPN :("LN   ", "V",   FALSE),    (* 1 *)
  OPN :("LN1  ", "V",   FALSE),
  OPN :("MOV  ", "II",  FALSE), 
  OPN :("INC1 ", "I",   FALSE), 
  OPN :("DEC1 ", "I",   FALSE), 
  OPN :("INC  ", "II",  FALSE), 
  OPN :("DEC  ", "II",  FALSE), 
  OPN :("ADD  ", "III", FALSE), 
  OPN :("SUB  ", "III", FALSE), 
  OPN :("CLEAR", "I",   FALSE),     (* 10 *)
  OPN :("TEST ", "I",   TRUE), 
  OPN :("EQU  ", "II",  TRUE), 
  OPN :("LSEQ ", "II",  TRUE), 
  OPN :("FMOV ", "RR",  FALSE), 
  OPN :("FADD ", "RRR", FALSE), 
  OPN :("FSUB ", "RRR", FALSE), 
  OPN :("FMUL ", "RRR", FALSE), 
  OPN :("FDIV ", "RRR", FALSE), 
  OPN :("FLSEQ", "RR",  TRUE), 
  OPN :("TMOV ", "SS",  FALSE), 
  OPN :("TEQU ", "SS",  TRUE), 
  OPN :("ULSEQ", "II",  TRUE), 
  OPN :("DSACC", "D?",  FALSE), 
  OPN :("REF  ", "?@",  FALSE), 
  OPN :("SUBS ", "VVI?@", FALSE),  (* 25 *)
  OPN :("SEL  ", "?V@", FALSE),    (* 26 *)
  OPN :("PPV  ", "?",   FALSE), 
  OPN :("PP   ", "?",   FALSE), 
  OPN :("B    ", "V",   FALSE), 
  OPN :("B1   ", "V",   FALSE), 
  OPN :("CALL ", "M",   FALSE)) ;
 
SPECIALOP CONST special op := SPECIALOP :( 
  OPN :("EQUIM  ", "HI",   TRUE),
  OPN :("MOVi   ", "HI",   FALSE),
  OPN :("MOVx   ", "HII",  FALSE), 
  OPN :("PUTW   ", "HII",  FALSE),
  OPN :("GETW   ", "HII",  FALSE), 
  OPN :("PENTER ", "H",    FALSE)) ; (* 7F = ESC, FF = LONGA *)
 
ESCOP CONST esc op := ESCOP :( 
  OPN :("RTN    ", "",      FALSE),   (* 0 *)
  OPN :("RTNT   ", "",      FALSE), 
  OPN :("RTNF   ", "",      FALSE), 
  OPN :("???????", "",      FALSE),   (* was repair text 1.7.1 *)
  OPN :("STOP   ", "",      FALSE),   (* TERM *)
  OPN :("GOSUB  ", "V",     FALSE),   (* 1 ist Branch Address *) 
  OPN :("KE     ", "",      FALSE), 
  OPN :("GORET  ", "",      FALSE),
  OPN :("BCRD   ", "II",    FALSE),   (* begin char read (pointer, length) *) 
  OPN :("CRD    ", "II",    FALSE),   (* char read (char, pointer) *)
  OPN :("ECWR   ", "III",   FALSE),   (* end char write (pointer, length, next entry) *) 
  OPN :("CWR    ", "III",   FALSE),   (* char write (hash code, pointer, char) *) 
  OPN :("CTT    ", "?S",    FALSE),   (* REF d2:=REF compiler table text <d1>) *)
  OPN :("GETC   ", "SII",   TRUE),    (* INT <d3> := code (TEXT <d1> SUB INT<d2>), TRUE wenn INT<ds> <= length (TEXT) *) 
  OPN :("FNONBL ", "ISI",   TRUE),    (* find non blank (char, line, pointer) *) 
  OPN :("DREM256", "II",    FALSE),   (* <d2> := <d1> MOD 256, <d1> := <d1> DIV 256 *) 
  OPN :("AMUL256", "II",    FALSE),   (* <d1> := <d1> * 256 + <d2> *) 
  OPN :("???????", "",      FALSE), 
  OPN :("ISDIG  ", "I",     TRUE), 
  OPN :("ISLD   ", "I",     TRUE), 
  OPN :("ISLCAS ", "I",     TRUE), 
  OPN :("ISUCAS ", "I",     TRUE), 
  OPN :("GADDR  ", "III",   FALSE),   (* IF <d2> >= 0 (Global) THEN <d3> := <d2> - <d1> (<d1>=pbase) ELIF bit (<d2>, 14) (Local Ref) THEN <d3> := (<d2> AND $3FFF)*2 + 1 ELSE (Local) <d3> := (<d2> AND $3FFF)*2 FI *)
  OPN :("GCADDR ", "III",   TRUE), 
  OPN :("ISSHA  ", "I",     TRUE), 
  OPN :("SYSG   ", "",      FALSE),   (* 25 *)
  OPN :("GETTAB ", "",      FALSE), 
  OPN :("PUTTAB ", "",      FALSE), 
  OPN :("ERTAB  ", "",      FALSE), 
  OPN :("EXEC   ", "M",     FALSE),
  OPN :("PPROC  ", "M",     FALSE),
  OPN :("PCALL  ", "A",     FALSE),   (* : icount Segment/Address *) 
  OPN :("BRCOMP ", "IV",    FALSE),
  OPN :("MOVxx  ", "V??",   FALSE), 
  OPN :("ALIAS  ", "VDD",   FALSE), 
  OPN :("MOVii  ", "VI",    FALSE), 
  OPN :("FEQU   ", "RR",    TRUE), 
  OPN :("TLSEQ  ", "SS",    TRUE), 
  OPN :("FNEG   ", "RR",    FALSE), 
  OPN :("NEG    ", "II",    FALSE),
  OPN :("IMULT  ", "III",   FALSE), 
  OPN :("MUL    ", "III",   FALSE), 
  OPN :("DIV    ", "III",   FALSE), 
  OPN :("MOD    ", "III",   FALSE), 
  OPN :("ITSUB  ", "SII",   FALSE), 
  OPN :("ITRPL  ", "SII",   FALSE), 
  OPN :("DECOD  ", "SI",    FALSE), 
  OPN :("ENCOD  ", "IS",    FALSE), 
  OPN :("SUBT1  ", "SIS",   FALSE), 
  OPN :("SUBTFT ", "SIIS",  FALSE), 
  OPN :("SUBTF  ", "SIS",   FALSE), 
  OPN :("REPLAC ", "SIS",   FALSE), 
  OPN :("CAT    ", "SS",    FALSE), 
  OPN :("TLEN   ", "SI",    FALSE), 
  OPN :("POS    ", "SSI",   FALSE), 
  OPN :("POSF   ", "SSII",  FALSE),
  OPN :("POSFT  ", "SSIII", FALSE), 
  OPN :("STRANL ", "IIISIII", FALSE), 
  OPN :("POSIF  ", "SSSII", FALSE), 
  OPN :("???????", "",      FALSE), 
  OPN :("OUT    ", "S",     FALSE),   (* 60 *)
  OPN :("COUT   ", "I",     FALSE), 
  OPN :("OUTF   ", "SI",    FALSE), 
  OPN :("OUTFT  ", "SII",   FALSE), 
  OPN :("INCHAR ", "S",     FALSE), 
  OPN :("INCETY ", "S",     FALSE), 
  OPN :("PAUSE  ", "I",     FALSE), 
  OPN :("GCPOS  ", "II",    FALSE), 
  OPN :("CATINP ", "SS",    FALSE), 
  OPN :("NILDS  ", "D",     FALSE), 
  OPN :("DSCOPY ", "DD",    FALSE), 
  OPN :("DSFORG ", "D",     FALSE), 
  OPN :("DSWTYP ", "DI",    FALSE), 
  OPN :("DSRTYP ", "DI",    FALSE), 
  OPN :("DSHEAP ", "DI",    FALSE), 
  OPN :("ESTOP  ", "",      FALSE), 
  OPN :("DSTOP  ", "",      FALSE), 
  OPN :("SETERR ", "I",     FALSE), 
  OPN :("ISERR  ", "",      TRUE), 
  OPN :("CLRERR ", "",      FALSE), 
  OPN :("RPCB   ", "II",    FALSE), 
  OPN :("INFOPW ", "SSI",   FALSE),  (* War vorher Writepcb *)
  OPN :("TWCPU  ", "TR",    FALSE), 
  OPN :("ROTATE ", "II",    FALSE), 
  OPN :("CONTRL ", "IIII",  FALSE), 
  OPN :("BLKOUT ", "DIIII", FALSE), 
  OPN :("BLKIN  ", "DIIII", FALSE), 
  OPN :("NXTDSP ", "DII",   FALSE), 
  OPN :("DSPAGS ", "ITI",   FALSE), 
  OPN :("STORAGE", "II",    FALSE), 
  OPN :("SYSOP  ", "I",     FALSE),   (* 90 *)
  OPN :("ARITHS ", "",      FALSE), 
  OPN :("ARITHU ", "",      FALSE), 
  OPN :("HPSIZE ", "I",     FALSE), 
  OPN :("GARB   ", "",      FALSE), 
  OPN :("TPBEGIN", "TTIA",  FALSE),   (* 1.8.0: privileged begin *)
  OPN :("FSLD   ", "IRI",   FALSE), 
  OPN :("GEXP   ", "RI",    FALSE), 
  OPN :("SEXP   ", "IR",    FALSE), 
  OPN :("FLOOR  ", "RR",    FALSE), 
  OPN :("RTSUB  ", "SIR",   FALSE), 
  OPN :("RTRPL  ", "SIR",   FALSE), 
  OPN :("CLOCK  ", "IR",    FALSE), 
  OPN :("SETNOW ", "R",     FALSE), 
  OPN :("TRPCB  ", "TII",   FALSE), 
  OPN :("TWPCB  ", "TII",   FALSE),   (* 105 *)
  OPN :("TCPU   ", "TR",    FALSE), 
  OPN :("TSTAT  ", "TI",    FALSE), 
  OPN :("ACT    ", "T",     FALSE), 
  OPN :("DEACT  ", "T",     FALSE), 
  OPN :("THALT  ", "T",     FALSE), 
  OPN :("TBEGIN ", "TA",    FALSE),   (* seg/addr icount *)
  OPN :("TEND   ", "T",     FALSE), 
  OPN :("SEND   ", "TIDI",  FALSE), 
  OPN :("WAIT   ", "TID",   FALSE), 
  OPN :("SWCALL ", "TIDI",  FALSE), 
  OPN :("CDBINT ", "II",    FALSE),   (* 116 *)
  OPN :("CDBTXT ", "IS",    FALSE),   (* 117 *)
  OPN :("PNACT  ", "I",     FALSE), 
  OPN :("PW     ", "III",   FALSE), 
  OPN :("GW     ", "III",   FALSE), 
  OPN :("XOR    ", "III",   FALSE), 
  OPN :("PPCALL ", "TIDI",  FALSE),   (* pingpong call *) 
  OPN :("EXTASK ", "T",     TRUE), 
  OPN :("AND    ", "III",   FALSE), 
  OPN :("OR     ", "III",   FALSE), 
  OPN :("SESSION", "I",     FALSE), 
  OPN :("SENDFT ", "TTIDI", FALSE), 
  OPN :("DEFCOL ", "T",     FALSE), 
  OPN :("ID     ", "II",    FALSE)) ; (* 129 *)


PROC decode : 
 INT VAR mod nr ; 
 get module number (mod nr) ; 
 IF mod nr >= minus one 
    THEN decode (mod nr) 
 FI
ENDPROC decode ; 
 

PROC decode module : 
 INT VAR mod nr ; 
 get module number (mod nr) ; 
 IF mod nr >= minus one 
    THEN decode module (mod nr) 
 FI
ENDPROC decode module ; 
 

PROC decode module (INT CONST mod nr) :
 INT VAR address :: code address (mod nr) ;
 default no runtime ; 
 decode (code segment (mod nr), address, minus one, TRUE) 
ENDPROC decode module ; 
 

PROC decode (INT CONST mod nr) : 
 INT VAR address :: code address (mod nr) ;
 default no runtime ;
 decode (code segment (mod nr), address, minus one, FALSE) 
ENDPROC decode ; 
 

PROC decode (INT CONST seg, from) : 
 INT VAR address := from ; 
 default no runtime ;
 decode (seg, address, minus one, FALSE) 
ENDPROC decode ; 
 

PROC decode (INT CONST seg, INT VAR addr, INT CONST to addr, 
             BOOL CONST only one module) : 

 TEXT VAR taste, opcode, codewords, hex addr ; 
 BOOL VAR addr out := TRUE , 
          output permitted := TRUE ;
 INT VAR size, used, mod nr, header address, start address := addr ; 

 add modules ;
 storage (size, used) ;
 echo := TRUE ; 
 file number := 0 ;
 cmod := minus one ; 
 init list file ; 
 next module header (seg, addr, header address, mod nr) ; 
 was bool result := FALSE ; 

 WHILE ulseq (addr, to addr) REP 
  protocoll ; 
  taste := incharety ; 
  decode one statement ;
  analyze key ; 
  IF (addr AND 31) = 0 
   THEN storage (size, used) ; 
  FI ; 
 UNTIL taste = ""27"" OR used > size PER ; 

 IF used > size 
    THEN list line ("Abbruch wegen Speicherengpass!") 
 FI .
 
protocoll : 
  IF output permitted AND NOT echo (* Falls Decoder im Hintergrund laufen soll *) 
     THEN IF addr out 
             THEN out (" ") ; 
                  out (hex16 (addr)) ; 
                  out (" "8""8""8""8""8""8"") ; 
             ELSE cout (ln) 
          FI 
  FI . 
  
analyze key : 
  SELECT code (taste) OF 
{l}  CASE 108 : addr out := FALSE  (* Zeilennummern ausgeben *)
{d}  CASE 100 : get command ("Gib Kommando:") ; do command 
{f}  CASE 102 : show filename and fileline 
{a}  CASE 97  : addr out := TRUE  (* Hexaddressen ausgeben *)
{e}  CASE 101 : echo := NOT echo  (* Bildschirmausgabe zus. *)
{s}  CASE 115 : storage (size,used) ; out(""13""5"System-Storage: " + text (used) + "  ") 
{m}  CASE 109 : out (""13""5"Modulnr: " + text (mod nr-1) + "  ") 
{Q,W}CASE 87,81:output permitted := TRUE (* L�uft nur im Vordergrund *) 
{S}  CASE 83  : output permitted := FALSE (* L�uft auch im Hintergrund *) 
{ESC}CASE 27  : IF incharety <> "" 
                   THEN taste := "" 
                   ELSE list line ("Abbruch mit ESC") 
                FI
                (* Wegen Steuertasten, wie ESC P *)
 ENDSELECT . 
 
show filename and fileline : 
 out (""13""5"Filename: " + filename + "." + text (filenumber) + 
      "  Fileline: " + text (lines (list file)) + "  ") . 
 
decode one statement : 
 check if module head ; 
 hex addr  := hex16 (addr) ;
 codewords := "" ; 
 opcode    := "" ; 
 decode (seg, addr, codewords, opcode, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; 
 hex addr CAT " " ; 
 hex addr CAT opcode ; 
 IF with statement line 
    THEN hex addr CAT " " ;
         WHILE LENGTH hex addr < 80 REP 
          hex addr CAT " " 
         PER ; 
         hex addr CAT codewords ; 
 FI ;
 list line (hex addr) . 
 
check if module head : 
 IF addr = header address 
    THEN IF only one module AND addr <> start address 
            THEN LEAVE decode
         FI ;
         list line (" ") ; 
         list line ("Module " + process module nr (mod nr)) ; 
         list line (" ") ;
         IF output permitted AND NOT echo
            THEN put ("Module:") ; 
                 cout (mod nr) ; 
                 8 TIMESOUT ""8""
         FI ;
         calculate c8k ;
         codewords := "" ;
         hex addr := hex16 (addr) ;
         hex addr CAT " HEAD        " ; 
         hex addr CAT text (next word (seg, addr, codewords)) ; 
         IF with statement line 
            THEN hex addr CAT " " ; 
                 WHILE LENGTH hex addr < 80 REP
                  hex addr CAT " " 
                 PER ;
                 hex addr CAT code words ; 
         FI ;
         list line (hex addr) ; 
         next module header (seg, addr, header address, mod nr) ; 
 FI . 
 
calculate c8k : 
 INT VAR dummy ;
 cmod := addr ; 
 splitword (cmod, dummy) ; 
 cmod INCR 16 ; 
 cmod := cmod AND 255 .
         
ENDPROC decode ; 
 

PROC init list file : 
 forget (filename + "." + text (filenumber), quiet) ; 
 list file := sequentialfile (output, filename + "." + text (filenumber)) ; 
 maxlinelength (list file, 2000) ;
 list line ("Addr 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 outsubtext (zeile, 1, 79) ; line FI 
ENDPROC list line ; 


PROC decode (INT CONST segment, INT VAR address, TEXT VAR words, instruction,
             INT PROC (INT CONST, INT VAR, TEXT VAR) next word) : 
 
 INT VAR opcode, word, lowbyte, highbyte, 
         opcode address := address ;
 BOOL VAR shorta opcode ;

 ln := minus one ; (* Wenn kein LN Befehl vorkam -1 *)

 word := next word (segment, address, words) ;
 highbyte := word ;
 split word (highbyte, lowbyte) ; 
 opcode := highbyte AND hex 7c ;
 shorta opcode := TRUE ;

 IF opcode = hex 7c AND highbyte <> hex ff
    THEN esc or special instruction (* Kann kein LONGA sein *) 
    ELSE IF highbyte = hex ff 
            THEN longa instruction 
            ELSE word := word AND hex 83ff
         FI ; 
         primaer instruction
 FI . 
 
esc or special instruction : 
 IF highbyte = hex 7f 
    THEN esc instruction
    ELSE special instruction 
 FI . 
 
longa instruction : 
 IF lowbyte = hex ff 
    THEN instruction CAT "-" ; 
         LEAVE decode 
 ELIF lowbyte = hex fd 
    THEN instruction CAT "Block unlesbar" ; 
         LEAVE decode 
 ELSE instruction CAT "LONGA " ; 
      shorta opcode := FALSE ;
      opcode := lowbyte ; 
      word := next word (segment, address, words) ;
      highbyte := word ; 
      splitword (highbyte, lowbyte) 
 FI . 
 
special instruction : 
 opcode := (highbyte AND 3) * 2 + 1 ; 
 IF highbyte > hex 7f 
    THEN opcode INCR 1 
 FI ; 
 word := word AND hex ff ;
 instruction CAT special op (opcode).mnemonic ; 
 instruction CAT "     " ; (* ESC Ausgleich *)
 instruction CAT params0 (special op (opcode).params, word, segment, address, 
             words, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; 
 was bool result := special op (opcode).bool result ; 
 IF opcode = 6 (* PENTER *) 
    THEN database := lowbyte ; 
         makeword (database, 0) ; 
 FI . 
 
esc instruction : 
 opcode := lowbyte + 1 ; 
 IF opcode < 1 OR opcode > 131 
    THEN instruction CAT "???????" 
    ELSE instruction CAT "ESC " ; 
         instruction CAT esc op (opcode).mnemonic ; 
         instruction CAT " " ;
         instruction CAT params (esc op (opcode).params, segment, address, 
                     words, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; 
         was bool result := esc op (opcode).bool result  
 FI . 
 
primaer instruction : 
 rotate (opcode, -2) ; 
 SELECT opcode OF 
  CASE 0, 1   : process ln 
  CASE 28, 29 : process br 
  CASE 30 : process call
  OTHERWISE 
   opcode INCR 1 ; 
   instruction CAT prim op (opcode).mnemonic ; 
   IF shorta opcode 
      THEN instruction CAT "       " 
      ELSE instruction CAT " "
   FI ;
   instruction CAT params0 (prim op (opcode).params, word, segment, address, words,
               INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; 
   IF opcode = 25 (* SUBS *) 
      THEN instruction CAT "(ESiz,Lim-1,Idx,Base,Ref) " 
   ELIF opcode = 26 (* SEL *) 
      THEN instruction CAT "(Base,Offs,Ref) " 
   FI ;
   was bool result := prim op (opcode).bool result ; 
 ENDSELECT . 
 
process call : 
 opcode INCR 1 ; 
 word := word AND hex 03ff ;
 IF highbyte > hex 7f 
    THEN word INCR hex 0400 
 FI ;
 instruction CAT prim op (opcode).mnemonic ; 
 IF shorta opcode
    THEN instruction CAT "       " 
    ELSE instruction CAT " "
 FI ;
 was bool result := FALSE ; (* Wird von params0 ggf �berschrieben *) 
 instruction CAT params0 (prim op (opcode).params, word, segment, address, words,
             INT PROC (INT CONST, INT VAR, TEXT VAR) next word) . 
 
process ln : 
 IF shorta opcode 
    THEN word := short address (lowbyte, highbyte, opcode = 1) 
 FI ;
 IF was bool result 
    THEN instruction CAT "BT   " ; 
         IF shorta opcode
            THEN instruction CAT "       " 
         FI ; 
         instruction CAT hex16 (branch address)
    ELSE IF segment = 2 
            THEN instruction CAT "HEAD "
            ELSE ln := word ; 
                 instruction CAT "LN   " 
         FI ;
         IF shorta opcode 
            THEN instruction CAT "       " 
         FI ; 
         instruction CAT text (word) 
 FI ;
 was bool result := FALSE .
 
process br : 
  word := short address (lowbyte, highbyte, opcode = 29) ;
  IF was bool result
     THEN instruction CAT "BF   " ; 
     ELSE instruction CAT "B    " ; 
  FI ;    
  IF shorta opcode 
     THEN instruction CAT "       " 
  FI ; 
  instruction CAT hex16 (branch address) ;
  was bool result := FALSE .
 
branch address : 
 INT VAR high address byte := opcode address ; 
 split word (high address byte, lowbyte) ;
 highbyte := word ;
 split word (highbyte, lowbyte) ;
 high address byte INCR highbyte ; 
 IF cmod <> minus one AND high address byte >= cmod 
    THEN high address byte DECR 16 (* cms = 16 *) 
 FI ; 
 make word (high address byte, lowbyte) ; 
 high address byte . 
 
ENDPROC decode ; 
 

INT PROC short address (INT CONST lowbyte, highbyte, BOOL CONST bit12) : 
 (* Bit 7 des Highbytes in Bit 0 rotieren *) 
 INT VAR effective address := (highbyte * 2) AND 6 ; 
 IF highbyte > hex 7f         
    THEN effective address INCR 1 
 FI ; 
 make word (effective address, lowbyte) ; (* high and result, low *)
 IF bit12 
    THEN effective address INCR 2048 
 FI ; 
 effective address

ENDPROC short address ; 
 

INT PROC next word (INT CONST segment, INT VAR address, TEXT VAR words) : 
 INT CONST word :: get word (segment, address) ; 
 INC address ; 
 words CAT hex16 (word) ; 
 words CAT " " ; 
 word

ENDPROC next word ; 
 

PROC next module header (INT CONST segment, address, 
                         INT VAR header address, module number) : 
 INT VAR first, last, mid ; 
 IF segment = 2 
    THEN first := 0 ; 
         last := 1275 
    ELSE first := 1282 ; (* 1280/1281 MAIN doagain & runagain modaddr *)
         last := 2047 
 FI ; 
 REP 
  mid := (first + last) DIV 2 ; 
  IF ulseq (address, getword (0, 512 + mid)) 
     THEN last := mid
     ELSE first := mid + 1
  FI 
 UNTIL first = last PER ; 
 header address := getword (0, 512 + first) ; 
 module number := first

ENDPROC next module header ; 
 

TEXT PROC params (TEXT CONST types, INT CONST segment, INT VAR address, 
                  TEXT VAR words, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) : 
 
 INT VAR i, param addr, type ; 
 TEXT VAR result ; 
 
 IF types = "" 
    THEN LEAVE params WITH ""
 FI ;
 result := "" ;
 FOR i FROM 1 UPTO LENGTH types REP 
   param addr := next word (segment, address, words) ; 
   type := code (types SUB i)-63 ;
   result CAT data representation (param addr, segment, address, type) ; 
   IF i <> LENGTH types 
      THEN result CAT ", " 
   FI ;
 PER ; 
 result 

ENDPROC params ; 
 

TEXT PROC params0 (TEXT CONST types, INT CONST word, segment, INT VAR address, 
                   TEXT VAR words, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) : 
 
 INT VAR i, param addr, type ; 
 TEXT VAR result ; 
 
 IF types = "" 
    THEN LEAVE params0 WITH ""
 FI ;
 result := "" ;
 param addr := word ; 
 FOR i FROM 1 UPTO LENGTH types REP 
   type := code (types SUB i)-63 ;
   result CAT data representation (param addr, segment, address, type) ; 
   IF i <> LENGTH types 
      THEN result CAT ", " ; 
           param addr := next word (segment, address, words)
   FI 
 PER ; 
 result 

ENDPROC params0 ; 
 

TEXT PROC data representation (INT CONST data addr, segment, address, type) : 
 INT VAR stack offset, ds segment, ds number, ds address ; 
 TEXT VAR result ;
 IF is data address
    THEN IF local data address 
            THEN stack offset := data addr ;
                 rotate (stack offset, minus one) ;
                 stack offset := stack offset AND hex 3fff ; 
                 IF local reference address OR type = ref addr
                    THEN get referenced representation
                    ELSE get representation from stack 
                 FI 
            ELSE get representation from packet data
         FI
    ELSE object representation (minus one, data addr, segment, address, type)
 FI . 
 
is data address : 
 NOT (type = 23 OR type = 9 OR type = 14) .
 
local data address : 
 data addr < 0 . 
 
local reference address : 
 (data addr AND 1) = 1 . 
 
is runtime : 
 lbas <> minus one . 
 
get representation from packet data : 
 IF with object and address 
    THEN result := "<G " + hex16 (data addr) + "H>"  
    ELSE result := ""
 FI ; 
 result CAT object representation (packet data segment, data addr ADD data base, 
                                   segment, address, type) ; 
 result . 
 
get representation from stack : 
 result := "<L " + text (stack offset) + ">" ;
 IF is runtime 
    THEN IF NOT with object and address 
            THEN result := "" 
         FI ;
         result CAT object representation (local data segment, 
                    lbas ADD stack offset, segment, address, type) 
 FI ; 
 result . 
 
get referenced representation : 
 IF is runtime 
    THEN ds address := getword (local data segment, lbas ADD stack offset) ; 
         ds number  := getword (local data segment, lbas ADD stack offset ADD 1) ; 
         split word (ds number, ds segment) ; 
         IF ds number = standard dataspace 
            THEN IF with object and address 
                    THEN result := "<LR " + text (stack offset) ; 
                         result CAT " @" + text (ds segment AND 7) ; 
                         result CAT hex16 (ds address) + "H>" 
                    ELSE result := "" 
                 FI ; 
                 IF ds segment <= local data segment
                    THEN result CAT object representation (ds segment, 
                                    ds address, segment, address, type) 
                 
                 ELIF ds segment > 3 (* Illegal! *)
                    THEN result := "<LR " + text (stack offset) ; 
                         result CAT " @" + text (ds segment AND 7) ; 
                         result CAT "!!!" ;
                         result CAT hex16 (ds address) + "H>" 
                    ELSE (* PROC-Addresse *)
                         result CAT object representation (ds segment, 
                                    ds address, segment, address, mod addr)
                 FI ; 
                 result
            ELSE "<LR " + text (stack offset) + 
                 " DS:" + hex8 (ds number) + " @" + 
                 text (ds segment AND 7) + hex16 (ds address) + "H>"
         FI
    ELSE "<LR " + text (stack offset) + ">"
 FI . 
 
ENDPROC data representation ; 
 

INT VAR anzahl zeros, anzahl steuerzeichen ; 

TEXT PROC object representation (INT CONST data segment, data address, 
                                           segment, address, type) : 
 TEXT VAR t, result ; 
 INT VAR i, zeichen, highbyte, lowbyte, first word ;
 SELECT type OF 
  CASE try type,refaddr: try representation 
  CASE int addr        : int representation 
  CASE real addr       : real representation
  CASE text addr       : text representation 
  CASE dataspace addr  : dataspace representation
  CASE task addr       : task representation 
  CASE mod addr        : module address representation 
  CASE bool addr       : bool representation
  CASE int value       : integer value
  CASE hexbyte value   : integer hexbyte
  CASE module nr value : module nr representation
  OTHERWISE "unbek. Typ: " + code (type + 63)
 ENDSELECT . 
 
module nr representation : 
 text val := text (data address) ;
 process module nr (data address) . 

bool representation : 
 IF getword (data segment, data address) = 0 
    THEN text val := "TRUE" 
    ELSE text val := "FALSE" 
 FI ; 
 text val . 
 
reference address : 
 highbyte := getword (data segment, data address ADD 1) ; 
 splitword (highbyte, lowbyte) ; 
 result := "@" + hex8 (highbyte) + "-" + hex8 (lowbyte) ; 
 result CAT hex16 (getword (data segment, data address)) ; 
 text val := result ; 
 result . 
 
int representation : 
 i := get word (data segment, data address) ; 
 text val := text (i) ;
 result := text (i) ; 
 IF i < 0 
    THEN result CAT "|" ; 
         result CAT hex16 (i) ; 
         result CAT "H"
 ELIF i >= 256 
    THEN result CAT "|" ; 
         result CAT hex16 (i) ;
         result CAT "H" ;
 FI ;
 result . 

integer value : 
 text val := text (data address) ;
 text (data address) . 
 
integer hexbyte : 
 text val := text (data address) ;
 IF (data address AND hex ff00) = 0 
    THEN hex8 (data address) + "H"  
    ELSE hex16 (data address) + "H" 
 FI . 
 
real representation :
 result := "12345678" ; 
 FOR i FROM 0 UPTO 3 REP 
  replace (result, i + 1, get word (data segment, data address ADD i)) 
 PER ; 
 disablestop ; 
 result := compress (text (result RSUB 1, 20)) ;
 IF iserror 
    THEN clear error ;
         result := "undefined REAL"
 FI ; 
 text val := result ; 
 result . 
 
text representation : 
 t := copied text var (data segment, data 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 CAT """" ; 
 text val := result ;
 result . 
 
task representation : 
 INT CONST index   := get word (data segment, data address) , 
           version := get word (data segment, data address ADD 1) ; 
 IF index < 256 
    THEN result := hex8 (index)  
    ELSE result := hex16 (index) ; 
         insertchar (result, "-", 3) 
 FI ;
 result CAT "-" ; 
 result CAT hex16 (version) ; 
 result CAT "/" ; 
 result CAT taskname (index, version) ; 
 text val := result ;
 result . 
 
dataspace representation : 
 highbyte := get word (data segment, data address) ; 
 splitword (highbyte, lowbyte) ; 
 result := hex8 (highbyte) ; 
 result CAT "-" ; 
 result CAT hex8 (lowbyte) ; 
 IF (highbyte AND lowbyte) = 255
    THEN result CAT ":not init"
 ELIF (highbyte OR lowbyte) = 0 
    THEN result CAT ":nilspace" 
 FI ; 
 text val := result ;
 result . 
 
module address representation : 
 (* Hier: lowbyte = mod nr, highbyte = mod addr *)
 next module header (data segment, data address, highbyte, lowbyte) ; 
 IF highbyte <> data address 
    THEN linear search (* Adresse mu� doch zu finden sein *)
 FI ;
 text val := text (lowbyte) ;
 process module nr (lowbyte) .
 
linear search : 
 IF data segment = 2
    THEN FOR i FROM 512 UPTO 767 REP 
          IF getword (packet data segment, i) = data address
             THEN lowbyte := i-512 ; 
                  LEAVE linear search 
          FI 
         PER
    ELSE FOR i FROM 1792 UPTO 3839 REP
          IF getword (packet data segment, i) = data address
             THEN lowbyte := i-512 ; 
                  LEAVE linear search 
          FI 
         PER 
 FI ; (* Moduleaddress nicht gefunden, da stimmt doch was nicht! *)
 LEAVE module address representation WITH reference address . 
 
try representation : 
 first word := getword (data segment, data address) ; 
 result := text (first word) ;
 IF first word < 0 OR first word >= 256 
    THEN result CAT "|" ; 
         result CAT hex16 (first word) ; 
         result CAT "H"
 FI ;
 IF first word = 0 
    THEN result CAT "|TRUE"
 ELIF first word = 1 
    THEN result CAT "|FALSE" 
 FI ; 
 IF vorzeichen ok AND nur digits (* real *) 
    THEN result CAT "|" ; 
         disablestop ; 
         TEXT CONST txt :: compress (text (t RSUB 1, 20)) ; 
         IF is error 
            THEN clear error  
            ELSE result CAT txt 
         FI ; 
 FI ; 
 IF within compiler
    THEN IF first word >= begin of stringtable CAND first word <= end of nametable 
            THEN string pointer (* first word wird ggf veraendert! *)
         ELIF first word > 9 AND first word < 32 
            THEN result CAT "|""""" + text (first word) + """""" (* Char *)
         ELIF first word = 34 
            THEN result CAT "|"""""
         ELIF first word >= 32 AND first word < 127 
            THEN result CAT "|""" + code (first word) + """" (* Code-Char *)
         FI ; 
 ELIF text sinnvoll 
    THEN result CAT "|" ; 
         result CAT t  
 FI ; 
 text val := result ;
 result . 
 
text sinnvoll : 
 keine steuerzeichen AND
 (getword (data segment, data address ADD 1) AND 255) < 80 . 
 
within compiler : 
 segment = 2 AND ulseq (address, first elan address-1) . 
 
string pointer : 
 IF first word >= begin of name table 
    THEN first word INCR 2 
 FI ; 
 IF (cdbint (first word) AND 255) < 100 
    THEN t := cdbtext (first word) ; 
         IF pos (t,   ""0"",  ""31"", 1) = 0 CAND 
            pos (t, ""127"", ""213"", 1) = 0 CAND 
            pos (t, ""220"", ""255"", 1) = 0
            THEN result CAT "|""" ; 
                 result CAT t ; 
                 result CAT """" 
         FI 
 FI . 
 
keine steuerzeichen : 
 t := object representation (data segment, data address, 
                             segment, address, text addr) ;
 anzahl steuerzeichen < 4 AND anzahl zeros < 2 AND 
 getword (data segment, data address ADD 1) <> minus one . 
 
vorzeichen ok : 
 (first word AND hex f0) = 0 OR (first word AND hex f0) = 128 . 
 
nur digits : 
 t := "12345678" ; 
 FOR i FROM 0 UPTO 3 REP 
  replace (t, i + 1, get word (data segment, data address ADD i)) 
 PER ; 
 IF (first word AND 15) > 9 THEN FALSE 
 ELSE FOR i FROM 2 UPTO 7 REP 
       lowbyte := code (t SUB i) ; 
       IF (lowbyte AND hex f0) > 249 OR (lowbyte AND 15) > 9 
          THEN LEAVE nur digits WITH FALSE 
       FI 
      PER ; 
      TRUE 
 FI . 
 
ENDPROC object representation ; 
 

TEXT PROC process module nr (INT CONST module number) :
 TEXT VAR object specification ; 
 was bool result := modules last word is bool return ; 
 IF is elan module number 
    THEN object specification := module name and specifications (module number) ; 
         IF object specification = "" 
            THEN object specification := "Hidden: PACKET " ; 
                 object specification CAT packet name (module number) ; 
                 IF was bool result 
                    THEN object specification CAT " --> BOOL"
                 FI
            ELSE was bool result := pos (object specification, "--> BOOL") > 0 ;
         FI 
 ELIF one of compilers own module numbers 
    THEN object specification := "CDL (" ; 
         object specification CAT text ((getword (2, code address (module number)) - 4) DIV 2) ;
         object specification CAT ")" ;
         IF was bool result 
            THEN object specification CAT " --> BOOL" 
         FI
 ELIF elan defined internal
    THEN SELECT module number - 255 OF 
            CASE 1 : object specification := "compiler (INT CONST, FILE VAR, TEXT CONST, INT VAR, BOOL CONST ins, BOOL CONST lst, BOOL CONST rtc, BOOL CONST ser)"
            CASE 2 : object specification := "outtext (TEXT CONST, INT CONST)" 
            CASE 3 : object specification := "outline (INT CONST)" 
            CASE 4 : object specification := "syntaxerror (TEXT CONST)" 
            CASE 5 : object specification := ":= (FILE VAR, FILE CONST)" 
          OTHERWISE  object specification := "INTERNAL " + text (module number) 
         ENDSELECT 
 ELSE object specification := "Modulnummer ohne Code!" ; 
      was bool result := FALSE
 FI ; 
 IF with object and address OR one of compilers own module numbers
    THEN object specification CAT " (" ; 
         object specification CAT text (module number) ;
         object specification CAT ":$" ;
         object specification CAT text (code segment (module number)) ; 
         object specification CAT hex16 (code address (module number)) ; 
         object specification CAT ")" ; 
 FI ;
 object specification . 
 
modules last word is bool return : 
 INT CONST last word :: getword (code segment (module number), 
                                 code address (module number + 1) SUB 1) ; 
 last word = rtnt opcode OR last word = rtnf opcode .
 
one of compilers own module numbers : 
 module number < 244 . 
 
elan defined internal : 
 module number >= 256 AND module number < 272 . 
 
is elan module number : 
 module number >= 272 . 
 
ENDPROC process module nr ; 
 

TEXT PROC copied text var (INT CONST segment, addr) : 
 TEXT VAR result, t ; 
 INT VAR laenge, first char, address, heap segment ; 
 address := addr ADD 1 ;
 first char := getword (segment, address) ; 
 splitword (first char, laenge) ;
 IF laenge = 0 
    THEN "" 
 ELIF laenge = 255
    THEN copy text from heap 
    ELSE copy text from data segment 
 FI . 
 
copy text from data segment : 
 result := code (first char) ; 
 laenge DECR 1 ;
 t := "  " ;
 INC address ;
 WHILE laenge > 1 REP
   replace (t, 1, getword (segment, address)) ; 
   result CAT t ;
   laenge DECR 2 ; 
   INC address ; 
 PER ; 
 IF laenge = 1
    THEN result CAT code (getword (segment, address) AND 255) 
 FI ; 
 result . 
 
copy text from heap : 
 address := get word (segment, addr) ; 
 rotate (address, minus one) ;
 heap segment := address AND 7 ; 
 address := address AND hex fff8 ; (* In Vielfachen von 8 *)
 laenge := getword (segment, addr ADD 2) AND 255 ; 
 makeword (laenge, first char) ; (* 16 Bit Laenge �ber Wortgrenze *)
 laenge := min (laenge, 256) ; (* Mehr ist im Listing nicht sinnvoll *) 
 IF getword (heap segment, address) = minus one (* Standard DS *) 
    THEN address INCR 3 ; (* Kann nicht �ber 8000H Grenze gehen *)
    ELSE INC address (* Im Frei-Datenraum nur Wort Laenge *)
 FI ;
 result := "" ;
 WHILE laenge > 1 REP
   result CAT getword (heap segment, address) ;
   laenge DECR 2 ; 
   INC address
 PER ;
 IF laenge = 1
    THEN result CAT code (getword (heap segment, address) AND 255) 
 FI ; 
 result . 
 
ENDPROC copied text var ; 
 

PROC push (INT CONST a, b) : 
 INT VAR dummy1 := a, dummy2 := b 
ENDPROC push ; 
 

PROC pop (TASK VAR a, INT CONST dummy) : 
 TASK VAR x ; 
 a := x 
ENDPROC pop ; 
 

TEXT PROC task name (INT CONST id, vers) : 
 TASK VAR t ; 
 IF id = 0 
    THEN "niltask" 
    ELSE push (id, vers) ; 
         pop (t, 0) ; 
         IF exists (t) 
            THEN """" + name (t) + """" 
            ELSE "-" 
         FI 
 FI 
ENDPROC task name ; 
 

ENDPACKET eumel decoder ; 
 

(**************************************************************************) 
 
PACKET tracer DEFINES                          (* M. Staubermann      *) 
                                               (* 20.04.86            *)
                      list breakpoints ,       (* 1.8.0, 861107 15:45 *)
                      set breakpoint , 
                      reset breakpoint ,
                      source file , 
                      prot file ,
                      tracer channel ,
                      trace ,
                      reset breakpoints : 
 
LET local base field           = 25 , 
    packet data segment        = 0 , 
    local data segment         = 1 ,
    code segment 3             = 3 ,
 
    begin of module nr link table = 512 , 
 
    previous local base offset = 0 , 
    return address offset      = 1 , 
    return segment offset      = 2 , 
    c8k offset                 = 3 , 
 
    opcode mask                = 31744 , 
 
    bt opcode                  = 0 , 
    btlong opcode              = 1024 , 
    bf opcode                  = 28672 , 
    bflong opcode              = 29696 , 
    br opcode                  = 28672 , 
    brlong opcode              = 29696 , 
    brcomp opcode              = 32544 ,
 
    ln opcode                  = 0 , 
    ln long opcode             = 1024 , 
    call opcode                = 30720 , 
    pcall opcode               = 32543 , 
 
    pp opcode                  = 27648 , 
    ppv opcode                 = 26624 , 
    pproc opcode               = 32542 ,
 
    rtn opcode                 = 32512 , 
    rtnt opcode                = 32513 , 
    rtnf opcode                = 32514 , 
 
    hex 7f00                   = 32512 ;

INT CONST longa opcode        :: -256 ,
          longa ppv opcode    :: longa opcode + 104 ,
          longa pp opcode     :: longa opcode + 108 , 
          hex 83ff            :: -31745 ,
          minus one           :: -1 ;

LET nr of breakpoints = 2 , (* Max. Anzahl unvorhersehbare Verzweigungen/Branch *)
    BREAKPOINT = STRUCT (BOOL set, INT address, saved word) ; 
 
ROW nr of breakpoints BREAKPOINT VAR breakpoints ;
BREAKPOINT CONST init breakpoint :: BREAKPOINT:(FALSE, -5, 0) ;
 
FOR actual linenumber FROM 1 UPTO nr of breakpoints REP 
 breakpoints (actual line number) := init breakpoint 
PER ; 
 

BOOL VAR auto trace := FALSE , 
         forward trace := TRUE ,
         source lines neu := TRUE ;

INT VAR previous instruction address ,
        prot file number ,
        trace channel := minus one ,
        actual line number := minus one , 
        handler module := 339 ; (* Dummy: PROC stop *) 
 
TEXT VAR prot file name := "" ,
         source line := "" , 
         source file name := "" ;
 
FILE VAR source, protocoll ; 
 

INT PROC tracer channel :
 trace channel 
ENDPROC tracer channel ; 
 

PROC tracer channel (INT CONST c) : 
 IF c < 17 AND c > minus one 
    THEN trace channel := c 
    ELSE errorstop ("PROC tracer channel: Kanalnummer unzul�ssig") 
 FI
ENDPROC tracer channel ; 
 

PROC trace : 
 TEXT VAR name ;
 forward trace := TRUE ;
 set breakpoint ;
 get command ("PROC/OP-Aufruf eingeben:") ; 
 out (""13"") ;
 put ("      Sourcefilename (falls keine Sourcefile RETURN) :") ; 
 getline (name) ; 
 source file (name) ;
 put ("      Protokollfilename (falls kein Protokoll RETURN):") ; 
 getline (name) ; 
 prot file (name) ;
 put ("      Tracekanal (Ausf�hrung an diesem Kanal: RETURN):") ; 
 name := "0" ; 
 editget (name) ; 
 line ; 
 tracer channel (int (name)) ; 
 do command  
 
ENDPROC trace ; 
 

PROC source file (TEXT CONST file name) : 
 IF exists (file name) 
    THEN source := sequentialfile (modify, file name) ; 
         source file name := file name ;
         IF actual line number >= 0 CAND actual line number <= lines (source) 
            THEN toline (source, actual line number) ; 
                 readrecord (source, source line) 
            ELSE source line := ""
         FI
    ELSE source file name := ""
 FI
 
ENDPROC source file ; 
 

TEXT PROC source file : 
 source file name 
ENDPROC source file ; 
 

TEXT PROC prot file : 
 prot file name 
ENDPROC prot file ; 
 

PROC prot file (TEXT CONST file name) : 
 IF file name = "" 
    THEN prot file name := "" 
    ELSE forget (file name, quiet) ;
         prot file number := 0 ;
         protocoll := sequentialfile (output, file name) ; 
         max line length (protocoll, 1000) ;
         prot file name := file name ;
 FI
ENDPROC prot file ;
 

PROC protocoll line : 
 IF prot file name <> "" 
    THEN line (protocoll) ; 
         IF lines (protocoll) > 4000 
            THEN prot file number INCR 1 ; 
                 TEXT CONST file name :: prot file name + "." + 
                            text (prot file number) ;
                 putline (protocoll, "Fortsetzung in Datei " + file name) ; 
                 forget (file name, quiet) ;
                 protocoll := sequentialfile (output, file name) ;
                 max line length (protocoll, 1000)
         FI
 FI

ENDPROC protocoll line ; 
 

PROC write protocoll (TEXT CONST t) :
 IF prot file name <> "" 
    THEN write (protocoll, t) 
 FI 
ENDPROC write protocoll ; 
 

PROC breakpoint handler : 

 ROW 32 INT VAR offset fuer inter call stack variablen ; 
 BOOL VAR was bool result ,
          ueberschrift neu , 
          code lines neu ; 
 TEXT VAR key, previous key,
          old error message ,
          statement line, opcode, 
          previous opcode, next opcode ;
 INT VAR i, x, y ,
         actual opcode, actual word, op word, next instruction, 
         following word, saved word,
         lbas, this local base, st ptr,
         old channel, old error code, old error line,
         user address, branch address, address,
         lowbyte,
         c8k, packet base,
         actual instruction address, previous actual address, 
         next instruction address,
         return segment, return address, 
         breakpoint address, breakpoint nr ; 

 determine return address and breakpoint nr ;
 reset breakpoints ; 
 getcursor (x, y) ; 
 next instruction address := breakpoint address ; 
 IF NOT forward trace AND previous instruction address <> minus one 
    THEN decode instruction (previous instruction address, previous actual address, 
                             previous opcode, FALSE) ; 
    ELSE previous opcode := ""
 FI ;
 decode instruction (next instruction address, actual instruction address, 
                     next opcode, TRUE) ;
 was bool result := bool result ;
 IF forward trace 
    THEN write protocoll (" " + hex16 (actual instruction address) + " ") ;
         write protocoll (next opcode) ; 
         protocoll line  
    ELSE write protocoll ("*" + hex16 (previous actual address) + " ") ; 
         write protocoll (previous opcode) ; 
         protocoll line 
 FI ;
 actual word      := getword (code segment 3, actual instruction address) ; 
 actual opcode    := actual word AND opcode mask ;
 following word   := getword (code segment 3, actual instruction address ADD 1) ; 
 next instruction := getword (code segment 3, next instruction address) ; 
 out (""1""10""5""10""5"") ; 
 IF NOT auto trace 
    THEN out (""6""6""0"") ;
         putline ("Auto, Bpnt, Clrr, Dstp, Estp, File, Go, Prot, Rslt, Step(CR), Term, - + < >"5"") ; 
         putline ("------------------------------------------------------------------------------"5"") ; 
 FI ;
 ueberschrift neu := TRUE ; 
 code lines neu   := TRUE ; 
 previous key := "" ;
 REP 
   kopf schreiben ;
   IF auto trace 
      THEN IF incharety = "" 
              THEN key := "S" 
              ELSE auto trace := FALSE 
           FI 
   FI ; 
   IF NOT auto trace
      THEN REP 
            inchar (key) 
           UNTIL pos (""13"abcdefgprst +-<>", key) > 0 PER ; 
           IF key >= "a" 
              THEN key := code (code (key)-32)
           FI ;
           analyze key
   FI ;
   previous key := key 
 UNTIL pos ("GST!", key) > 0 PER ; 
 IF key <> "T" 
    THEN execute saved instruction 
 FI ;
 IF key = "T" 
    THEN write protocoll ("      Terminated") ; 
         protocoll line ;
         resetbreakpoints ; 
         term 
 ELIF key = "G" 
    THEN write protocoll ("      Go") ; 
         protocoll line
 ELIF key = "S" 
    THEN singlestep 
 FI ; 
 previous instruction address := breakpoint address ;
 cursor (x, y) ; 
 IF trace channel > 0 
    THEN IF old channel = 0 
            THEN break (quiet) 
            ELSE continue (old channel) 
         FI 
 FI ; 
 IF bit (return segment, 7) 
    THEN disablestop ; 
         set line nr (old error line) ; 
         error stop (old error code, old error message) ; 
         set line nr (0)
 FI .
           
analyze key : 
 IF previous key = "B" 
    THEN IF key = ""13"" OR key = "S" (* Sicherheitsabfrage *) 
            THEN key := "!" ;         (* Exit-Key *)
                 write protocoll ("      Skip") ;
                 protocoll line ;
                 write protocoll (" " + hex16 (user address) + " ") ; 
                 write protocoll (opcode) ; 
                 protocoll line ;
                 set breakpoint (breakpoint nr, user address)
            ELSE code lines neu := TRUE
         FI
 ELIF key = ""13"" 
      THEN key := "S" 
 ELIF key = " " 
      THEN code lines neu := TRUE ; 
           source lines neu := TRUE ; 
           ueberschrift neu := TRUE ; 
 ELSE SELECT code (key)-43 OF (* Um die Anzahl Branches klein zu halten*)
       CASE 0 {+}  : stptr := stptr ADD 2 ;
                     ueberschrift neu := TRUE  
       CASE 2 {-}  : stptr := stptr SUB 2 ; 
                     ueberschrift neu := TRUE
       CASE 17 {<} : with object address (TRUE) ; 
                     IF forward trace 
                        THEN decode instruction (breakpoint address,
                             actual instruction address, next opcode, FALSE) 
                     ELIF previous instruction address <> minus one 
                        THEN decode instruction (previous instruction address, 
                             previous actual address, previous opcode, FALSE) 
                     FI ;
                     code lines neu := TRUE
       CASE 19 {>} : with object address (FALSE) ; 
                     IF forward trace 
                        THEN decode instruction (breakpoint address,
                             actual instruction address, next opcode, FALSE) 
                     ELIF previous instruction address <> minus one 
                        THEN decode instruction (previous instruction address, 
                             previous actual address, previous opcode, FALSE) 
                     FI ;
                     code lines neu := TRUE ;
       CASE 22 {A} : auto trace := TRUE ; 
                     key := "S" 
       CASE 23 {B} : get breakpoint address from user
       CASE 24 {C} : resetbit (return segment, 7) ; 
                     ueberschrift neu := TRUE
       CASE 25 {D} : setbit (return segment, 6) ; 
                     ueberschrift neu := TRUE
       CASE 26 {E} : resetbit (return segment, 6) ; 
                     ueberschrift neu := TRUE
       CASE 27 {F} : out (""6""5""0"Sourcefile:"5"") ; 
                     editget (source file name) ; 
                     source file (source file name) ; 
                     ueberschrift neu := TRUE ;
                     source lines neu := TRUE
       CASE 37 {P} : out (""6""5""0"Protokollfile:"5"") ; 
                     editget (prot file name) ; 
                     prot file (prot file name)
       CASE 39 {R} : forward trace := NOT forward trace ; 
                     IF NOT forward trace AND previous opcode = "" AND 
                        previous instruction address <> minus one 
                        THEN decode instruction (previous instruction address, 
                             previous actual address, previous opcode, FALSE) 
                     FI ;
                     ueberschrift neu := TRUE ;
                     code lines neu := TRUE
      ENDSELECT
 FI .

kopf schreiben :
 out (""6""5""0""5"") ;
 IF ueberschrift neu 
    THEN schreibe ueberschrift ; 
         ueberschrift neu := FALSE
 FI ; 
 IF source lines neu
    THEN schreibe source lines ; 
         source lines neu := FALSE
 FI ;
 IF code lines neu
    THEN IF forward trace 
            THEN show decoded opcode (next opcode, 
                 actual instruction address, TRUE, TRUE) 
         ELIF previous instruction address <> minus one 
            THEN show decoded opcode (previous opcode, 
                 previous actual address, TRUE, TRUE) 
         ELSE out (""6""5""0"Kein vorhergehender Befehl")
         FI ; 
         code lines neu := FALSE
 FI . 

schreibe ueberschrift : 
 out (""1"") ;
 put (breakpoint nr) ;
 IF forward trace 
    THEN put ("F") (* forward *)
    ELSE put ("R") (* result *)
 FI ;
 IF bit (return segment, 4) 
    THEN out ("u") (* ARITHU *)
    ELSE out ("s") 
 FI ; 
 IF bit (return segment, 6) 
    THEN out ("d") (* Disablestop *)
    ELSE out ("e") 
 FI ; 
 IF bit (return segment, 7) 
    THEN put ("E") (* iserror *)
    ELSE put (" ") 
 FI ; 
 put ("lbas:") ; put (hex16 (lbas)) ; 
 out ("stack(") ; out (hex16 (stptr)) ; put ("):") ; 
 out (hex16 (getword (local data segment, stptr))) ; out ("-") ; 
 put (hex16 (getword (local data segment, stptr ADD 1))) ; 
 put ("pbas:") ; put (hex8 (packet base)) ; 
 put ("c8k:") ;  put (hex8 (c8k)) ; 
 IF valid source 
    THEN out ("""") ; outsubtext (source file name, 1, 19) ; put ("""") 
 FI ; 
 out (""5"") . 

schreibe source lines : 
 out (""1""10"") ; 
 IF valid source AND source line <> "" 
    THEN put (text (actual line number, 4)) ; 
         put ("|") ; 
         outsubtext (source line, 1, 72) ; 
         out (""5"") ;
         line ; 
         IF LENGTH source line <= 72 
            THEN put (text (actual line number +1, 4)) ; 
                 put ("|") ; 
                 toline (source, actual line number +1) ; 
                 out (subtext (source, 1, 72)) ; 
                 out (""5"") ;
                 toline (source, actual line number) ; 
                 line 
            ELSE put ("_____|") ; 
                 outsubtext (source line, 73, 144) ; 
                 out (""5"") ;
                 line 
         FI
 FI . 

valid source : 
 exists (source file name) . 
 
get breakpoint address from user : 
 put ("N�chste Breakpointaddresse (hex) in Segment 3:") ;
 statement line := hex16 (next instruction address) ;
 editget (statement line) ; 
 user address := integer (statement line) ;
 opcode := "" ; 
 statement line := "" ;
 address := user address ; 
 bool result (FALSE) ;
 decode (code segment 3, address, statement line,
         opcode, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; 
 show decoded opcode (opcode, user address, TRUE, TRUE) ;
 code lines neu := FALSE .

singlestep : 
 IF is return opcode
    THEN set breakpoint behind previous call
 ELIF was bool result AND NOT is call opcode 
    THEN set first breakpoint behind branch instruction ; 
         set second breakpoint at branch address
 ELIF is bool return opcode 
    THEN set first breakpoint behind branch instruction at return address ; 
         set second breakpoint at branch address of branch instruction at 
         return address  
 ELIF is brcomp opcode
    THEN set computed branch breakpoint  
 ELIF is branch instruction 
    THEN set breakpoint at branch address 
 ELIF is call opcode AND NOT auto trace CAND segment 3 module CAND 
      ask if subroutine trace
    THEN write protocoll ("      Subroutine Trace") ; 
         protocoll line ;
         calculate subroutine segment and address ; 
         set breakpoint behind next instruction
 ELSE set breakpoint behind next instruction
 FI . 
 
ask if subroutine trace : 
 IF forward trace 
    THEN yes (""6""5""0"Subroutine Trace") 
    ELSE show decoded opcode (next opcode, actual instruction address, FALSE, FALSE) ; 
         yes (""6""6""0"Subroutine Trace"5"") 
 FI . 
 
is line number : 
 actual opcode = ln opcode OR (* Kein LONGA, da ln < 4095 *)
 actual opcode = lnlong opcode . 

is branch instruction : 
 actual opcode = br opcode OR 
 actual opcode = brlong opcode . 
 
is conditional branch : 
 op word = bf opcode OR op word = bflong opcode OR 
 op word = bt opcode OR op word = btlong opcode .

is brcomp opcode : 
 actual word = brcomp opcode . 
 
is return opcode : 
 actual word = rtn opcode . 
 
is bool return opcode : 
 actual word = rtnt opcode OR 
 actual word = rtnf opcode . 
 
is call opcode : 
 actual opcode = call opcode OR 
 actual word   = pcall opcode .
   
read source line : 
 actual line number := actual word ; 
 split word (actual line number, lowbyte) ;
 actual line number := (actual line number * 2) AND 6 ; 
 IF actual word < 0 
    THEN actual line number INCR 1 
 FI ; 
 IF actual opcode = lnlong opcode
    THEN actual line number INCR 8 
 FI ; 
 makeword (actual line number, lowbyte) ; 
 actual line number DECR 1 ; 
 source lines neu := TRUE ;
 IF valid source 
    THEN IF lineno (source) = actual line number CAND source line <> "" 
            THEN (* nichts*) 
         ELIF actual line number >= 0 AND actual line number <= lines(source) 
            THEN toline (source, actual line number) ; 
                 readrecord (source, source line) 
         ELSE source line := "" 
         FI 
    ELSE source line := "" 
 FI . 
 
set first breakpoint behind branch instruction : 
 op word := next instruction AND opcode mask ; 
 IF is conditional branch
    THEN write protocoll (" ") ;
         write protocoll (hex16 (next instruction address) + " ") ; 
         bool result (TRUE) ;
         statement line := "" ; 
         opcode := "" ; 
         address := next instruction address ;
         decode (code segment 3, next instruction address, statement line, opcode, 
                 INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; 
         write protocoll (opcode) ; 
         protocoll line ;
         show decoded opcode (opcode, address, FALSE, FALSE) ;
         IF NOT auto trace
            THEN pause (20) 
         FI ;
         next free breakpoint ;
         set breakpoint (i, next instruction address) ;
    ELSE putline ("Interner Fehler: Nach BOOL-Result folgt kein Branch"5""); 
         LEAVE singlestep 
 FI . 
 
set second breakpoint at branch address : 
 calculate branch address ; 
 next free breakpoint ;
 set breakpoint (i, branch address) . 
 
set breakpoint at branch address : 
 next instruction := actual word ; 
 next instruction address := actual instruction address ; 
 calculate branch address ; 
 set breakpoint (breakpoint nr, branch address) . 
 
set first breakpoint behind branch instruction at return address : 
 IF (getword (local data segment, lbas + return segment offset) AND 7) = code segment 3
    THEN next instruction address := getword (local data segment, 
                                     lbas + return address offset) ; 
         next instruction := getword (code segment 3, next instruction address) ;
         c8k := getword (local data segment, lbas + c8k offset) AND 255 ; 
         set first breakpoint behind branch instruction 
    ELSE putline ("Trace bei Vorw�rtssprung beendet."5"") 
 FI . 
 
set second breakpoint at branch address of branch instruction at return address : 
 set second breakpoint at branch address . 
 
set computed branch breakpoint :
 address := following word ; 
 IF address < 0 (* Local/Local Ref *) 
    THEN rotate (address, minus one) ; 
         address := (address AND 16 383) ADD lbas ; 
         IF bit (following word, 0)
            THEN branch address := getword (getword (local data segment, 
                                            address ADD 1) AND 7, 
                                            getword (local data segment, 
                                            address))  
            ELSE branch address := getword (local data segment, address) 
         FI  
    ELSE branch address := getword (packet data segment, 
                                    address ADD packet base)
 FI ; 
 IF switch out of range 
    THEN branch address := actual instruction address ADD 3 
    ELSE branch address := actual instruction address ADD branch address ADD 4
 FI ; 
 set breakpoint (breakpoint nr, branch address) . 
 
switch out of range : 
 branch address < 0 OR 
 branch address > getword (code segment 3, actual instruction address ADD 2) .

determine return address and breakpoint nr : 
 FOR x FROM 1 UPTO 10 REP
  determine return address ;
  determine breakpoint nr ; 
 PER ; 
 line ;
 put ("Returnaddresse nicht gefunden:"5"") ; 
 out (text (return segment AND 3)) ; 
 putline (hex16 (return address)) ; 
 list breakpoints ;
 reset breakpoints ; 
 enablestop ;
 errorstop ("Falsche Returnaddresse") . 

determine return address : 
 fix local base ; (* Fix pcb's: RAM --> Leitblock *)
 this local base := getword (local data segment, pcb (local base field)) ; 
 lbas            := getword (local data segment, this local base + 
                             previous local base offset) ; 
 c8k             := getword (local data segment, this local base + 
                             c8k offset) AND 255 ; 
 return segment  := getword (local data segment, this local base + 
                             return segment offset) ; 
 return address  := getword (local data segment, this local base +
                             return address offset) ; 
 packet base     := HIGH return segment ; (* Wort besteht aus zwei Teilen!*)
 set parameters (lbas, packet base, minus one, c8k) ; 
 stptr := lbas ADD 4 ;
 DEC return address ; (* auf CALL breakpointhandler (ein Wort zur�ck) *)
 IF bit (return segment, 7) (* ISERR *)
   THEN old error line    := error line ; 
        old error code    := error code ; 
        old error message := error message
 FI ; 
 clear error ; 
 enablestop ;
 IF trace channel > 0 AND trace channel <> channel 
    THEN old channel := channel ; 
         disablestop ; 
         continue (trace channel) ; 
         clear error ; 
         enablestop 
 FI . 
 
determine breakpoint nr : 
 FOR i FROM 1 UPTO nr of breakpoints REP 
  IF breakpoints (i).set CAND 
     breakpoints (i).address = return address 
     THEN breakpoint nr := i ; 
          breakpoint address := breakpoints (i).address ; 
          saved word         := breakpoints (i).saved word ;
          LEAVE determine return address and breakpoint nr 
  FI 
 PER .

segment 3 module : 
 IF actual word = pcall opcode 
    THEN op word := following word ;
         rotate (op word, minus one) ;
         op word := (op word AND 16 383) ADD lbas ;
         LEAVE segment 3 module WITH (getword (local data segment, 
                                      op word ADD 1) AND 7) = code segment 3
 ELSE op word := actual word AND 1023 ; 
      IF actual word < 0 
         THEN op word INCR 1024 
      FI ; 
 FI ; 
 op word >= 1280 . 
 
calculate subroutine segment and address : 
 IF actual word = pcall opcode 
    THEN next instruction address := getword (local data segment, op word) 
    ELSE next instruction address := getword (packet data segment,
                          begin of module nr link table + op word)
 FI ; 
 INC next instruction address . (* Ab PENTER tracen *)
 
calculate branch address : 
 branch address := next instruction ; 
 split word (branch address, low byte) ; 
 branch address := (branch address * 2) AND 6 ; 
 IF next instruction < 0 
    THEN branch address INCR 1 
 FI ; 
 IF branch long
    THEN branch address INCR 8 
 FI ; 
 branch address INCR HIGH next instruction address ; 
 IF branch address >= c8k 
    THEN branch address DECR 16 
 FI ; 
 makeword (branch address, lowbyte) . 
 
branch long : 
 bit (next instruction, 10) . 
 
execute saved instruction : 
 putword (local data segment, this local base + return address offset,
          return address) ; 
 putword (local data segment, this local base + return segment offset, 
          return segment) . 
 

set breakpoint behind next instruction : 
 IF is line number THEN read source line FI ; 
 set breakpoint (breakpoint nr, next instruction address) . 
 

set breakpoint behind previous call : 
 return segment := getword (local data segment, 
                   lbas + return segment offset) AND 3 ;
 return address := getword (local data segment, 
                   lbas + return address offset) ; 
 IF return segment = code segment 3 
    THEN set breakpoint (breakpoint nr, return address) 
    ELSE putline ("Trace bei R�cksprung beendet."5"") 
 FI . 
 
next free breakpoint : 
 FOR i FROM 1 UPTO nr of breakpoints REP 
  IF NOT breakpoints (i).set
     THEN LEAVE next free breakpoint 
  FI 
 PER ; 
 putline ("Alle " + text(nr of breakpoints) + " Breakpoints sind belegt"5"") ; 
 LEAVE singlestep  
 
ENDPROC breakpoint handler ; 


PROC show decoded opcode (TEXT CONST opcode, INT CONST address, 
                          BOOL CONST zweizeilig, oben) : 
 IF oben 
    THEN out (""6""3""0"") 
    ELSE out (""6""5""0"")
 FI ;
 put (hex16 (address)) ; 
 put ("|") ; 
 outsubtext (opcode, 1, 72) ; 
 out (""5"") ;
 line ; 
 IF zweizeilig 
    THEN put ("     |") ; 
         outsubtext (opcode, 73, 144) ; 
         out (""5"") ;
         line 
 FI 
 
ENDPROC show decoded opcode ;
 

PROC decode instruction (INT VAR address, actual address, TEXT VAR opcode, 
                         BOOL CONST var) :

 INT VAR actual word, actual opcode, temp address ; 
 TEXT VAR statement line := "" ; 
 opcode := "" ;
 temp address := address ;
 actual address := address ; 
 actual word := getword (code segment 3, temp address) ; 
 actual opcode := actual word AND opcode mask ;
 bool result (FALSE) ;
 IF is param push opcode 
    THEN opcode := module with actual params (temp address, actual address) ; 
    ELSE decode (code segment 3, temp address, 
                 statement line, opcode, 
                 INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ;
 FI ; 
 IF var THEN address := temp address FI .
 
is param push opcode : 
 actual opcode = pp opcode OR 
 actual word   = pproc opcode OR 
 actual word   = longa pp opcode OR 
 actual word   = longa ppv opcode OR 
 actual opcode = ppv opcode . 

ENDPROC decode instruction ;
 

TEXT PROC module with actual params (INT VAR address, actual address) : 

 TEXT VAR result, statement line, symbol, type text ;
 INT VAR end address, start address := address, module nr, 
         actual word, actual opcode ;
 BOOL VAR known paramtypes, was bool result ;

 skip until next call opcode ; 
 determine module name and module nr ; 
 collect actual parameters ;
 perhaps result type ;
 bool result (was bool result) ;
 address := end address ;
 result . 
 
skip until next call opcode : 
 actual word := getword (code segment 3, address) ; 
 REP 
  IF (actual word AND hex 7f00) = hex 7f00 (* LONGA oder ESC *)
     THEN INC address
  FI ; 
  INC address ; 
  actual word := getword (code segment 3, address) ; 
  actual opcode := actual word AND opcode mask ;
 UNTIL is call opcode PER . 
 
determine module name and module nr : 
 result := "" ; 
 statement line := "" ; 
 actual address := address ; (* Addresse des CALL/PCALL Befehls *)
 decode (code segment 3, address, statement line, result, 
         INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; 
 was bool result := bool result ;
 bool result (FALSE) ;
 end address := address ;
 module nr := int (last actual parameter) ; 
 statement line := module name and specifications (module nr) ; 
 scan (statement line) ;
 IF statement line = "" 
    THEN symbol := "(" ;
         known paramtypes := FALSE ; 
         actual word := getword (code segment 3, start address) ; 
         actual opcode := actual word AND opcode mask ; 
         IF is call opcode (* Hidden ohen Result und Parameter *) 
            THEN LEAVE module with actual params WITH result 
            ELSE result CAT " (" (* Result wird als VAR Parameter betr.*)
         FI
     ELSE nextsymbol (symbol) ; (* Skip Name *) 
          nextsymbol (symbol) ;
          known paramtypes := TRUE ;
          IF symbol = "" (* Weder Parameter, noch Result *) 
             THEN LEAVE module with actual params WITH result 
          ELIF symbol = "(" 
             THEN result := subtext (result, 1, pos (result, "(")) ;
             ELSE result := subtext (result, 1, pos (result, "-->")-2)
          FI ;
 FI ;
 address := start address . (* R�cksetzen auf ersten param push *)
 
collect actual parameters :
 IF symbol <> "(" 
    THEN LEAVE collect actual parameters 
 FI ;
 REP 
  nextsymbol (symbol) ;
  IF symbol = "ROW" 
     THEN typetext := "ROW..." ;
          nextsymbol (symbol) ; (* ROW-Size *) 
          skip until end of type (symbol) ; 
  ELIF symbol = "STRUCT" 
     THEN typetext := "STRUCT..." ;
          nextsymbol (symbol) ;
          skip over brackets (symbol) ; 
  ELIF symbol = "<" (* HIDDEN *) 
     THEN typetext := "<HIDDEN>" ; 
          nextsymbol (symbol) ; 
          nextsymbol (symbol) ; 
          nextsymbol (symbol) ;
  ELIF symbol <> "PROC" 
     THEN typetext := symbol ; 
          nextsymbol (symbol)  
  FI ; (* symbol jetzt 'PROC', 'CONST' oder 'VAR' *)
  IF getword (code segment 3, address) = pproc opcode 
     THEN result CAT "PROC " ; 
          type text := "" ;
          decode (code segment 3, address, statement line, type text, 
                 INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; 
          result CAT subtext (type text, 13) ;
          next symbol (symbol) ;
          IF symbol = "(" THEN skip over brackets (symbol) FI 
     ELSE IF statement line <> "" (* Keine Hidden PROC *) 
             THEN result CAT typetext ; 
                  result CAT " " ; 
                  result CAT symbol ; (* CONST oder VAR *)
                  result CAT ":" ;
                  typetext := ":" + typetext ; (* F�r Pos-Suche *) 
                  nextsymbol (symbol) ; (* Jetzt auf ',' oder ')' *)
          FI ;
          IF (getword (code segment 3, address) AND hex 7f00) = hex 7f00 (* ESC OR LONGA *)
             THEN result CAT data representation (getword (code segment 3, 
                  address ADD 1), code segment 3, address, object type) ; 
                  INC address
             ELSE result CAT data representation (getword (code segment 3, address) 
                  AND hex 83ff, code segment 3, address, object type)  
          FI ; 
          INC address
  FI ; 
  actual word := getword (code segment 3, address) ; 
  actual opcode := actual word AND opcode mask ;
  IF symbol <> ")" AND NOT is call opcode 
     THEN result CAT ", " 
  FI  ; 
 UNTIL symbol = ")" OR is call opcode PER ; 
 result CAT ")" . 
 
perhaps result type :
 WHILE symbol <> "" REP nextsymbol (symbol) UNTIL symbol = ">" PER ; (* --> *) 
 IF symbol <> ""
    THEN nextsymbol (symbol) ;
         IF symbol = "ROW" 
            THEN symbol := "ROW..." ;
         ELIF symbol = "STRUCT" 
            THEN symbol := "STRUCT..." ;
         ELIF symbol = "<" (* HIDDEN *) 
            THEN symbol := "<HIDDEN>" ; 
         FI ;
         type text := ":" ; 
         type text CAT symbol ; 
         result CAT " --> " ; 
         result CAT symbol ;
         IF symbol = "BOOL" (* BOOl-Result nicht mit PP *)
            THEN LEAVE perhaps result type
         FI ;
         result CAT ":" ;
         IF (getword (code segment 3, address) AND hex 7f00) = hex 7f00 (* ESC OR LONGA *)
            THEN result CAT data representation (getword (code segment 3, 
                 address ADD 1), code segment 3, address, object type) ; 
                 INC address
            ELSE result CAT data representation (getword (code segment 3, address) 
                 AND hex 83ff, code segment 3, address, object type)  
         FI ; 
         INC address
 FI . 
 
object type : 
 IF known paramtypes 
    THEN INT CONST p := pos (types, type text) ; 
         IF p = 0 
            THEN 0 (* Try Type auch bei STRUCT/ROW *) 
            ELSE code (types SUB (p-1))-63 
         FI  
    ELSE 0 (* Try all types *) 
 FI . 
 
types : 
 "B:BOOL I:INT R:REAL S:TEXT T:TASK D:DATASPACE D:FILE S:THESAURUS" .

is call opcode : 
 actual opcode = call opcode OR 
 actual word   = pcall opcode .
   
ENDPROC module with actual params ; 
 

PROC skip until end of type (TEXT VAR symbol) : 
 nextsymbol (symbol) ;
 IF symbol = "ROW" 
    THEN nextsymbol (symbol) ; (* ROW-Size *) 
         skip until end of type (symbol) 
 ELIF symbol = "STRUCT" 
    THEN next symbol (symbol) ;
         skip over brackets (symbol) 
 ELSE nextsymbol (symbol) (* steht auf ',' oder ')' *) 
 FI
 
ENDPROC skip until end of type ; 
 

PROC skip over brackets (TEXT VAR symbol) : 
 REP 
  next symbol (symbol) ; 
  IF symbol = "(" THEN skip over brackets (symbol) FI 
 UNTIL symbol = ")" PER ; 
 nextsymbol (symbol) 

ENDPROC skip over brackets ; 
 

INT OP HIGH (INT CONST word) : 
 INT VAR highbyte := word, lowbyte ;
 split word (highbyte, lowbyte) ; 
 highbyte
 
ENDOP HIGH ; 
 
 
PROC fix local base : 
 (* Kein direkter EXTERNAL-Aufruf, da bei 'CALL' lbas auf Stack gelegt wird*)
 REP UNTIL incharety = "" PER ; (* Damit pause ausgef�hrt wird *)
 internal pause (0)             (* ^ War Grund f�r 'falsche Returnaddresse'*)

ENDPROC fix local base ; 
 

PROC reset breakpoints : 
 INT VAR i ;
 FOR i FROM 1 UPTO nr of breakpoints REP 
  IF breakpoints (i).set 
     THEN reset breakpoint (i) 
     ELSE breakpoints (i) := init breakpoint 
  FI 
 PER 
 
ENDPROC reset breakpoints ; 
 

PROC reset breakpoint (INT CONST nr) : 
 IF nr < 1 OR nr > nr of breakpoints 
    THEN errorstop ("Unzulaessige Breakpoint Nummer") 
 ELIF NOT breakpoints (nr).set 
    THEN display ("Warnung: Breakpoint " + text (nr) + " war nicht gesetzt")
 ELSE putword (code segment 3, breakpoints (nr).address, breakpoints (nr).saved word) ; 
      breakpoints (nr) := init breakpoint 
 FI 
 
ENDPROC reset breakpoint ; 
 

PROC set breakpoint (INT CONST nr, address) : 
 INT VAR new word ;
 IF nr < 1 OR nr > nr of breakpoints 
    THEN errorstop ("Unzulaessige Breakpoint Nummer") 
 ELIF breakpoints (nr).set 
    THEN errorstop ("Breakpoint " + text (nr) + " ist bereits gesetzt") 
 ELSE breakpoints (nr).address := address ; 
      breakpoints (nr).saved word := get word (code segment 3, address) ; 
      new word := call opcode + (handler module AND 1023) ; 
      IF handler module >= 1024 
         THEN setbit (new word, 15)
      FI ; 
      putword (code segment 3, address, new word) ; 
      IF getword (code segment 3, address) <> new word 
         THEN errorstop ("Addresse Schreibgeschuetzt")
         ELSE breakpoints (nr).set := TRUE
      FI 
 FI 
ENDPROC set breakpoint ; 
 

PROC handlers module nr (INT CONST module nr) : 
 handler module := module nr 
ENDPROC handlers module nr ; 
 

INT PROC handlers module nr : 
 handler module
ENDPROC handlers module nr ; 


INT PROC module number (PROC proc) : 
 
 EXTERNAL 35 
 
ENDPROC module number ; 
 
 
PROC internal pause (INT CONST time) : 
 
 EXTERNAL 66 
 
ENDPROC internal pause ; 
 
 
PROC term : 
 
 EXTERNAL 4 

ENDPROC term ; 


PROC set breakpoint : 
 INT VAR i ;
 handlers module nr (module number (PROC breakpointhandler)) ; 
 auto trace := FALSE ;
 source lines neu := TRUE ; (* Zum L�schen *) 
 source file ("") ; 
 prot file ("") ;
 actual line number := minus one ;
 previous instruction address := minus one ;
 with object address (FALSE) ;
 INT VAR module nr ; 
 add modules ;
 get module number (module nr) ; 
 IF code segment (module nr) <> code segment 3
    THEN errorstop ("PROC/OP liegt nicht im Codesegment 3") 
 FI ;
 naechsten freien breakpoint setzen ; 
 put ("Breakpoint") ; 
 put (i) ; 
 putline ("wurde gesetzt.") . 
 
naechsten freien breakpoint setzen : 
 FOR i FROM 1 UPTO nr of breakpoints REP 
  IF NOT breakpoints (i).set 
     THEN set breakpoint (i, code address (module nr) ADD 1) ; 
          LEAVE naechsten freien breakpoint setzen 
  FI 
 PER ; 
 errorstop ("Alle " + text (nr of breakpoints) + " Breakpoints sind belegt"). 
 
ENDPROC set breakpoint ; 
 

PROC list breakpoints : 
 INT VAR header address, mod nr, i ;

 line ; 
 putline (" Nr Set Address Word Module") ; 
 FOR i FROM 1 UPTO nr of breakpoints REP
  put (text (i, 2)) ; 
  IF breakpoints (i).set 
     THEN put (" Y  ")
     ELSE put (" N  ") 
  FI ; 
  out ("3") ; 
  put (hex16 (breakpoints (i).address)) ; 
  put (" ") ;
  put (hex16 (breakpoints (i).saved word)) ; 
  IF breakpoints (i).set 
     THEN next module header (code segment 3, breakpoints (i).address, 
                      header address, mod nr) ; 
          IF module name and specifications (modnr - 1) = "" 
             THEN put ("Hidden: PACKET") ; put (packet name (modnr -1)) ; 
             ELSE put (module name and specifications (modnr -1)) 
          FI
  FI ; 
  line
 PER 
 
ENDPROC list breakpoints ;
 
ENDPACKET tracer ; 

init module table ("table.module") ; 
type (""27"q") ; 
note ("") ;