( Start of DEBUG utility file -- 8 July 88 -- MFB )
On REDEFINE
OFF PRINTLOAD


DATA[ BYTE 0 ] DMFB
1 BLOCK %DST
DATA[ BYTE 0 ] TSTATE ( trace in effect if not zero)
DATA[ 0 ] TRCADR ( address to start trace or 0 for off)
2 BLOCK %DCSP  ( save for csp at time of trace start)
DATA[ 0 ] DCSPOFFSET
DATA[ 0 ] TAGADR ( trace again address )
DATA[ 0 ] DDHSTART
DATA[ 0 ] TRACE
DATA[ 0 ] TAGL

( : ]] 0 HIMODE ! ; IMMEDIATE ( words to toggle hi-mode)
: [[ 1 HIMODE ! ; IMMEDIATE
)

CODE TCOLON  DI, ( COLON for execution during trace)
  ' PSHBC# CALL, B POP, ( just like real word COLON)
  '' TRCADR LHLD, A H MOV, B CMP, IFZ
    A L MOV, C CMP, IFZ ( if debug start adr found)
      A 0FFH MVI, '' TSTATE STA, ( turn on trace)
      '' CSP LHLD, '' %DCSP SHLD, ( save csp)
    THEN
  THEN EI,
;

CODE TSRET  DI, ( SRET for execution during trace)
  '' TSTATE LDA, A ORA, IFNZ ( if trace on)
    '' %DCSP LHLD, XCHG, ( check return level)
    '' CSP LHLD, A D MOV, H CMP, IFZ
      A E MOV, L CMP, IFZ  ( if level same as trace start's)
        A XRA, '' TSTATE STA, ( turn off trace)
      THEN
    THEN
  THEN
  EI, ' POPBC# CALL,   ( rest just like real SRET)
;

CODE '?# ( find dictionary entry addr for defadr (de) in dict (hl))
  B 0 MVI,   ( hl=adr of dict to search, de=defadr)
  BEGIN
    A M MOV, C A MOV, A ORA, IFNZ ( end of dict=0)
      H PUSH, B DAD, H INX, H INX, ( hl=defadr of entry)
      A M MOV, E CMP, IFZ
        H INX, A M MOV, D CMP, IFZ
          STC, ( defadr matches. set carry to exit)
        ELSE
          H INX, DI, XTHL, EI, A ORA, ( else move to next entry)
        THEN
      ELSE
        H INX, H INX, DI, XTHL, EI, A ORA, ( same)
      THEN
    ELSE
      H INX, A M MOV, H INX, 
( MFB H M MOV,) D PUSH, D M MOV, H D MOV, D POP,  L A MOV, H ORA, IFZ
        STC,
      THEN
      H PUSH,
    THEN
    H POP, ( adr of entry, next entry, or 0)
  ENDC
  RET, 
;NOTHREAD

( : SPC ( print a space )
  20H .C
;

: SPCS ( print multiple spaces
         input:  tos=number of spaces to print )
  1 DO
      SPC 
    LOOP
; now in 7disp )

: %TDS
  SP@ CLISP @ SWAP - 2 / DUP 5 > IF
    BEGIN
      DUP 1+ PICK .H
      1- DUP 5 =
    END
    DROP
  ELSE
    5 = IF
      " STACK EMPTY" ."
    ELSE
      " STACK UNDERFLOW..RESETTING STACK" 1 ERMSG EXEC
    THEN
  THEN
  CRLF 4 PICK 2 - .H SPC
;

CODE GTWRD# ( print word of defadr (hl))
  B PUSH, D PUSH, H PUSH, ( save regs)
  '' DCSPOFFSET LHLD, XCHG, '' %DCSP LHLD, D DAD, XCHG,
  '' CSP LHLD, XCHG, 
  A D MOV, H CMP, IFZ
    A E MOV, L CMP, IFZ
      H POP, H PUSH, D H MOV, E L MOV, ( fetch defadr to look up)
      '' LAST LHLD, ( and dictionary address)
      ' '?# CALL, ( search current dict.)
      H PUSH, :ENTER
        DUP 0= IF DROP " TOOPS" THEN ( defadr was not found)
        %DST B@ DUP 14 >= IF DROP 1 ELSE 14 SWAP - THEN
        1 DO 32 .C LOOP %TDS DUPB@ %DST B! ."
        GETSTS IF
          GETCHR 27 = IF CRLF 0 TSTATE B! 0 TRCADR ! 0 DCSPOFFSET ! THEN
        THEN
      :EXIT
    THEN
  THEN
  H POP, D POP, B POP, RET, 
;NOTHREAD

: TRACEL ( change trace level
           input:  TOS=trace level )
  DUP -1 = IF ( user wants to see trace level )
    DROP DCSPOFFSET @ 2 / .
  ELSE
    2 * DUP DCSPOFFSET ! TAGL !
  THEN
;

CODE TTHREAD  ( THREAD for execution during trace)
(  H A MOV, )
  B INX, ( hl is defadr, just like real THREAD)
  '' TSTATE LDA, A ORA, ( if trace in effect)
  ' GTWRD# CNZ, ( look up and print 4th pc)
  PCHL, 
;NOTHREAD

: TERMSG
   0 TRCADR ! 0 TSTATE B! 0 DCSPOFFSET !
;

: TRACEON ( turns the trace facility on)
	( input:  word to be traced follows this word)
	( example:  TRACEON DISPLAY - this will trace word DISPLAY)
  GTDFA ( get defadr of following word)
  DUPB@ ( MFB 0CDH) 0E8H = IF ( if 1st inst is a call inst)
    3 +  ( skip over call inst)
  THEN
  DUP TRCADR ! ( store trace starting address)
      TAGADR ! ( store trace again address)
(  ]] HEAD @ base @ - TRACE ! [[)
  ]] HEAD @ base @ - ' TRACE base @ + 2 - ! [[
  :EXIT
     DI, ( no interrupts)
    ( MFB 0C3H) A 0E9H MVI, ( get a jmp instruction op code)
    ' COLON STA, ( replace COLON)
    ' SRET STA,  ( replace SRET)

( MFB) ' THPAT STA, ( replace INX H before PCHL in THREAD)
       H ' TTHREAD ' THPAT 3 + - LXI, ' THPAT 1 + SHLD,

( MFB)    H ' TCOLON ' COLON 3 + - LXI, ' COLON 1+ SHLD,
( MFB)    H ' TSRET ' SRET 3 + - LXI, ' SRET 1+ SHLD,

( MFB)    H ' TERMSG ' DEBUGERMSG 3 + - LXI, ' DEBUGERMSG 1+ SHLD,
     EI, ( allow interrupts)
; IMMEDIATE 

: TRACEOFF ( turns the trace facility off )
  0 TRCADR ! ( set trace address to zero )
  0 DCSPOFFSET  ! ( set trace offset to zero)
  :EXIT
     DI, ( no ints)
    A ( MFB CDH) 0E8H MVI,
    ' COLON STA, 
( MFB) H ' PSHBC# ' COLON 3 + - LXI, ' COLON 1+ SHLD,
    ' SRET  STA, 
( MFB) H ' POPBC# ' SRET 3 + - LXI, ' SRET  1+ SHLD,

( MFB) H ' THPAT LXI, M 41H MVI, H INX, M FFH MVI, H INX, M E3H MVI,

    H ' THREAD ' DEBUGERMSG 3 + - LXI, ' DEBUGERMSG 1+ SHLD,
     EI, ( allow interrupts)
; IMMEDIATE

: DMF ( toggle the flag DMFB to change to format of DM)
  DMFB B@ 0= DMFB B!
;

: DHB ( print one byte without leading space)
  255 AND 1 SWAP 0 SWAP 0 16 DOUT 0 1 DOUT 3 KILL
;

: DM ( dump memory in hex and ascii - 16 bytes)
     ( input:  tos=address to start dump)
     ( output: tos=address+16)
  DMFB B@ IF
    DUP 15 AND - DUP 15 + SWAP OVER SWAP DUP .H ( print address)
  ELSE
    DUP 15 + SWAP OVER SWAP DUP .H SPC ( print address)
  THEN
  DO
    I 3 AND 0= IF 
      SPC
    THEN 
    I B@ DHB ( then character)
  LOOP
  "     *" ." ( print sentinel)
  DUP DUP 15 - DO ( print ascii of memory)
    I B@ DUP IF[ 0 THRU 1FH 7FH THRU FFH ]
      DROP "."
    THEN
    .C
  LOOP
  "*" .C ( print sentinel)
  1+ CRLF
;

: 8DM ( dump 8 lines of memory)
  DM DM  DM DM  DM DM  DM DM
;

: 16DM ( dump 16 lines of memory)
  8DM  8DM
;

: %PDICT ( print an entry of the dictionary)
        ( input:  tos=address of dictionary entry)
        ( format: FF AAAA XXXXXXXXXXXXXXXXXXXXX)
        (   FF=flag AAAA=defadr XXX..=string)
  DUP .H ( print address of dictionary entry)
  DUP DUPB@ + 1+ ( point to flag byte)
  DUPB@ .HB ( print flag byte)
  1+ @ .H   ( print defadr)
  SPC ." ( print string)
;

: %DDICTA ( dump all entries in a dictionary)
         ( input:  tos=starting address of a dictionary)
         ( output: TOS=last address of dictionary (points to zero byte))
  REPEAT
    DUPB@ GETSTS 0= *
  WHILE
    CRLF DUP %PDICT
    DUPB@ + 4 +
  ENDWHILE
;

: DDICT
  " \13\\10\---- USER'S DICTIONARY ----" ."
  LAST @ %DDICTA DUPB@ 0= IF
    0 SWAP REPEAT
      1+ SWAP 1+ SWAP @ DUP
    WHILE
      " \13\\10\\10\---- SYSTEM DICTIONARY" ."
      OVER . " ----" ."
      %DDICTA DUPB@  IF 2 KILL RETURN THEN
    ENDWHILE
    DROP
  THEN
  DROP
;

CODE '? ( find entry in dictionary (tos) that matches defadr (nos)
               output: tos=address of dictionary entry or
                           0 if not found)
  H POP, D POP, B PUSH,
  ' '?# CALL,
  B POP, H PUSH,
;

: PDICT ( print a single dictionary entry )
        ( input:  word=word to print dictionary entry for )
  GTDFA ( get defadr of word )
  LAST @ '? ( get address of dictionary entry )
  DUP IF
    %PDICT ( print dictionary entry )
  ELSE
    DROP
  THEN
;

: .' ( print mnemonic of defadr (tos))
  LAST @ '? DUP IF ( in user dictionary)
    ." 1
  THEN ;

: .'1 
  .' 0= IF    " OOPS" ."  THEN ;

data[ WORD 0 ] odefa
data[ BYTE 0 ] odef1
data[ WORD 0 ] odef2

: PD ( patch a dictionary entry so that all previous
       references to the old entry will refer to the
       new entry)
     ( input:  word=word to patch)
  GTDFA ( get defadr of word) 
( MFB  C3H) 0E9H OVER B! 1+  
  HEAD @ OVER - 2 - CROSS @ IF BASE @ + THEN SWAP !
;

2 block olkad
2 block olkad1
2 block olkad2

: link gtdfa ( from) dup olkad ! dup dup@ olkad1 ! 2+ @ olkad2 !
        gtdfa ( to) over - 3 - swap dup e9h swap b! 1+ ! ;

: unlink olkad1 @ olkad @ ! olkad2 @ olkad @ 2+ ! ;

: RPD ( reverse patch a dictionary entry so that all previous
       references to the old entry will refer to the
       new entry)
     ( input:  word=word to patch)
  GTDFA ( get defadr of word)   dup odefa ! ( defadr) 
                                dup b@ odef1 b! ( first byte)
( MFB  C3H) 0E9H OVER B! 1+     dup @  odef2  ! ( next two bytes)
  last @ dup b@ + 2 + @
  ( HEAD @ ) OVER - 2 - CROSS @ IF BASE @ + THEN SWAP !
  olast @ last !
;

: upd ( unpatch last dictionary patch)
  odefa @ dup odef1 b@ swap b! odef2 @ swap 1+ 
                 dup @ over + 2 + head ! ! ;

: SIZE1 ( return the size (tos) of a word given its defadr (tos))
  DUP LAST @ SWAP OVER '? DUP IF ( in user's dictionary)
    OVER OVER = IF ( last word defined)
      2 KILL HEAD @
    ELSE ( not last word defined)
      SWAP DROP 2 - @
    THEN
  ELSE
    2 KILL
    DUP SYSLAST SWAP OVER '? ( must be system dictionary)
    OVER OVER = IF ( last word defined)
      DROP
    ELSE
      SWAP DROP 2 - @
    THEN
  THEN
  SWAP -
;

: SIZE ( print the size of the word that follows)
  GTDFA SIZE1 DUP .H "H" .C . "D" .C
;

: .FCBR ( print the record buffer of an FCB )
        ( input:  TOS=address of FCB )
  CRLF
  RECOFS + CRLF 
  RECSIZE 16 / 1 DO
    DM
  LOOP
  DROP
;

: .FCB ( print the open FCBs )
  SYSFCB
  BEGIN
    CRLF DUP .H ( print address of FCB )
    DUPB@ IF ( FCB is open )
      SPC
      DUP 7 + 11 1 DO ( print filename )
        DUPB@ .C 1+
      LOOP
      DROP ( erroneous address )
      DUPB@ 1 = IF
        " input"
      ELSE
        " output"
      THEN
      SPC ."
      DUP .FCBR ( print record area )
    THEN
    1+ @ DUP 0= ( end of list )
  END
  DROP ( address )
;

: FMEM ( fill memory with any character )
       ( input:  TOS=start address )
       (         NOS=end address )
       (         3OS=character )
  SWAP OVER - SWAP FILL ;

: NOP ;

2 BLOCK PATADR
2 BLOCK PATDFA
: PNOP 
  DUP PATADR ! DUP@ PATDFA !
  ' NOP SWAP !
;

: PAT
  DUP PATADR ! DUP@ PATDFA !
  GTDFA SWAP !
;

: UNPAT
  PATDFA @ PATADR @ !
;

( : DFILE ( print a file )
        ( notice that no buffer is allocated, instead
          the system buffer is used )
        ( input:  TOS=addr of filename string )
  CRLF
  1 SYSOPEN DUP RECOFS +
  REPEAT
    RECSIZE OVER 4 PICK SYSREAD 
    DUP GETSTS 0= * 
  WHILE
    1- 0 DO
      DUP I + B@ DUP 1AH = IF
        DROP EXIT
      THEN
      .C
    LOOP
  ENDWHILE
  2 KILL
  SYSCLOSE
  CRLF
; )


: CLI1
  CURCHAN @ TSTATE B@ OR 0= IF
    CRLF " db " ."
    ATOM DUP ." B@ 3 + DUP 15 > IF
      DROP
    ELSE
      15 SWAP - SPCS
    THEN
    DS
  THEN
;

CODE DEBUG
 ' DEBUGCLI 1+ LHLD, H PUSH,
 H ' DEBUGCLI 3 + LXI, H PUSH,
  :ENTER + :EXIT H POP,

(  ' DEBUGCLI 1+ ' DEBUGCLI 3 + + LHLD, ( MFB) 
   A ' THREAD SHR8 MVI, H CMP, IFZ ( debug is off)
)
   A 1 MVI, H CMP, IFZ ( debug is off)
    H ' CLI1 ' DEBUGCLI 3 + - LXI, ( defadr of cli1)
  ELSE ( debug is on)
( MFB) H ' THREAD ' DEBUGCLI 3 + - LXI, 
  THEN
  ' DEBUGCLI 1+ SHLD,
;

( 6C8FH HEAD !  ( PATCH FOR CHECKING))

: TAG ( trace again )
  TAGADR @ DUP IF
    " traceon " ."
    DUP DUP .' IF
      DROP
    ELSE
      3 - .'1
    THEN
    TRCADR !
    "   trace level=" ." TAGL @ DUP DCSPOFFSET ! 2 / .
(    :EXIT ' PSHBC# CALL, B TRACE @ LXI, :ENTER )
    :EXIT ' PSHBC# CALL, B ' TRACE base @ + 2 - @ LXI, :ENTER 
  ELSE
    DROP " Unable to trace again" ."
  THEN
;

CODE DDT ( break to debugger if it appears one is present)
  38H LDA, ( MFB) C3H CPI, IFZ
    38H CALL,
  THEN
;

( SYNONYM SID DDT)

( 6D1EH HEAD !)

: TAB 9 .C ; 

1 BLOCK DDCONT ( 0=continue       1=
                 1=switch	   2=2 bytes 
                 2=stop            3=3 bytes	
				   4=special 
				   5=2 bytes with ,
				   6=3 bytes with , )

DATA[ NOLENGTH BYTE
" notim"   F0H 	 2 		" notim"   F0H 		2 
" notim"   F0H 	 2 		" notim"   F0H   	2  
" AD"      C9H ( ADI)	 2 	" ADD\9\A" D8H ( ADD AX) 6 
" PUSH\9\E" D3H ( PUSH ES)    	" POP\0\E" D3H ( POP ES)      
" notim"   F0H  	 2    	" notim"   F0H		2  
" notim"   F0H		 2 	" notim"   F0H		2
" OR"      C9H ( ORI)   2  	" OR\9\A"  D8H ( OR AX) 6 
" PUSH\9\C" D3H ( PUSH CS)    	" 0F"      BFH ( 0F?)

" notim"   F0H		 2    	" notim"   F0H		 2 
" notim"   F0H		 2 	" notim"   F0H		 2  
" AD"      C3H ( ADC)    2 	" ADC\9\A" D8H ( ADC AX) 6
" PUSH\9\S" D3H ( PUSH SS)    	" POP\9\S" D3H ( POP SS)      
" notim"   F0H		 2     	" notim"   F0H  2
" notim"   F0H 	 2	" notim"   F0H  2
" SB"      C2H ( SBB)   2  	" SBB\9\A" D8H ( SBB AX)  6 
" PUSH\9\D" D3H ( PUSH DS)    	" POP\9\D" D3H ( POP DS)
 
" notim"   F0H	2   	" notim"   F0H		 2
" notim"    F0H	2 	" notim"   F0H		 2
" AN"       C9H ( ANI) 2 	" AND\9\A" D8H ( AND AX) 6
" 26"       BFH ( 26?)    	" DA"      C1H ( DAA)      
" notim"   F0H		2      	" notim"   F0H		 2
" notim"   F0H		2  	" notim"   F0H		 2
" SU"   C9H ( SUI)  2  	" SUB\9\A" D8H ( SUB AX) 6  
" 2B"	    BFH ( 2B?)    	" DA"      D3H ( DAS)

" notim"   F0H	 	 2 	" notim"   F0H		 2
" notim"   F0H		 2    	" notim"   F0H		 2
" XR"      C9H ( XRI)    2 	" XOR\9\A" D8H ( XOR AX) 6 
" 36"      BFH ( 36?)    	" AA"      C1H ( AAA)      
" notim"   F0H		 2	" notim"   F0H		 2
" notim"   F0H		 2 	" notim"   F0H		 2
" CP"      C9H ( CPI)    2 	" CMP\9\A" D8H ( CMP AX) 6 
" 3E"      BFH ( 3E?)  	 	" AA"      D3H ( AAS)
] 0-3F

DATA[ NOLENGTH BYTE
" notim"   F0H	 	 3     	" notim"   F0H		 3
" RE"      D4H ( RET)	 	" C4"      BFH ( C4?)
" C5"      BFH 			" C5" 	   BFH ( C5?)
" notim"   F0H		 3 	" C7"	   BFH ( C7?)
( c8 IS A 4 BYTE INSTR)
" ?"       BFH ( ??)	 2	" C9"      DFH ( C9?)      
" RE"      D4H ( RET X)  3   	" RET"     C6H ( RETF)
" INT\9\"   B3H ( INT3)     	" IN"      D4H ( INT)     2
" INT"     DFH ( INTO)   	" IRE"   D4H ( IRET)

" RL"      C3H ( RLC)    		" notim"   F0H		 2
" notim"   F0H		 2 	" notim"   F0H		 2
" AA"      CDH ( AAM)    2   	" AA"      C4H ( AAD)    2
" D6"    BFH ( D6?)    	 	" XLA"     D4H ( XLAT)      
" notim"   F0H           2  	" notim"   F0H           2
" notim"   F0H		 2   	" notim"   F0H		 2
" notim"   F0H           2 	" notim"   F0H           2   
" notim"   F0H		 2 	" notim"   F0H		 2

" notim"   F0H           2  	" notim"   F0H           2
" notim"   F0H		 2   	" notim"   F0H		 2
" I"	   CEH ( IN)     2   	" IN\9\A"  D8H ( IN AX)  2   
" OU"      D4H ( OUT)	 2 	" OUT\9\A" D8H ( OUT AX) 2
" CAL"   CCH ( CALL)     4  	" JM"    D0H ( JMP)       4 
( EA IS 5 BYTE LONG JUMP  EB IS JUMP REL)
" notim"   F0H	         2   	" notim"   F0H           2
" IN\9\AL,D" D8H ( IN AL,DX)   " IN\9\AX,D" D8H ( IN AX,DX)        
" OUT\9\DX,A" CCH ( OUT DX,AL) " OUT\9\DX,A"  D8H ( OUT DX,AX)

" LOC"     CBH ( LOCK)       	" F1" 	 BFH ( F1?)   
" REPN"    DAH ( REPNZ)       	" REP"   DAH ( REPZ)       
" HL"     D4H ( HLT)       	" CM"    C3H ( CMC)
" notim"  F0H		 2 	" notim"   F0H		2
" CL"     CCH ( CLC)   	" ST"    C3H ( STC)      
" D"      C9H ( DI)         	" E"     C9H ( EI)
" CL"     C4H ( CLD)       	" ST"    C4H ( STD)        
" notim"  F0H		 2	" notim"  F0H		2
] C0-FF

CODE .VCA ( tos=defadr of v/c to search for
            tos=1 - found, nos=dict. entry address
                0 - not found )
  D POP, B PUSH, '' LAST LHLD, BEGIN ( search all dictionaries)
    REPEAT
      A M MOV, A ORA,
    WHILENZ ( not end of dictionary)
      H PUSH, ( save dict. entry) 
      C A MOV, B 0 MVI, B DAD, H INX, A M MOV, ( point to flag byte)
      10H ANI, IFNZ ( variable/constant bit set)
        H INX, H PUSH, A M MOV, H INX, H M MOV, L A MOV, ( get defadr)
        H INX, H INX, H INX, A M MOV, E CMP, IFZ ( datadrs match)
          H INX, A M MOV, D CMP, IFZ 
            H POP, H POP, ( get dict. entry) 
            B POP, ( restore 4th pc)
            H PUSH, ( return dict. entry )
            H 1 LXI, H PUSH, ( return found flag)
            ' THREAD JMP, ( return)
          THEN
        THEN 
        H POP, ( datadrs do not match, restore dict. entry of defadr)
      ELSE ( not a variable/constant)
        ( MFB) PSW PUSH, H INX, PSW POP, ( point to dict. entry of defadr)
      THEN
      ( MFB) PSW PUSH, H INX, H INX, PSW POP, ( point to next dict. entry) B POP, ( throw away)
    ENDWHILE
    H INX, A M MOV, H INX, H M MOV, L A MOV, H ORA, ( is there another dict.)
  ENDZ
  B POP, H 0 LXI, ( no, return not found flag)
;PUSH

: DHX ( print two bytes (word) without leading space)
  1 SWAP 0 SWAP 0 4096 DOUT 0 256 DOUT 0 16 DOUT 0 1 DOUT 3 KILL
;

: .VCB ( determine if datadr (tos) is a variable/constant and if so
         print the mnemonic else print an "L" label)
  DUP .VCA IF
    ." DROP
  ELSE
    "L" .C DHX
  THEN
;

CODE 8/  ( single byte divide by 8)
  H POP, A L MOV, RRC, RRC, RRC, L A MOV,
;PUSH
  
: REGS ( printer either first or second operand register mnemonic)
       ( tos=register mask, nos=opcode)
  DUP 7 = IF ( first register - SOURCE)
    AND
  ELSE ( second register - DEST)
    AND 8/
  THEN
(  " BCDEHLMA" 1+ + B@ .C)
  " ACEL-BDH" 1+ + B@ .C
;

: OPCMD@ ( fetch opcode flag from opcode table
           tos=opcode entry address
           tos=opcode flag)
  DUP REPEAT ( step to opcode flag)
    DUPB@ 80H AND 0=
  WHILE
    1+
  ENDWHILE
  1+ B@ ( get opcode flag)
;

: .OPCODE ( print opcode from opcode table
            tos=opcode entry address)
  REPEAT
    DUPB@ DUP 7FH AND .C
    80H AND 0=
  WHILE
    1+
  ENDWHILE
  DROP
;

: @OPCODE ( point to opcode in opcode table)
  SWAP DUP IF
    1 DO ( use opcode as pseudo index into table)
      REPEAT
        DUPB@ 80H AND 0=
      WHILE
        1+
      ENDWHILE
      1+ DUPB@ 20H < IF ( skip over opcode flag)
        1+
      THEN
    LOOP
  ELSE
    DROP
  THEN
;

: TWOBYTES ( print: one operand, tab, opcode mnemonic)
  OVER 
  1+ B@ .HB TAB TAB ( operand)
  .OPCODE 
  1+ DUPB@ 
  ( ( MFB) OVER ( return next byte)
  2+ +
  CROSS @ IF BASE @ + THEN --- HOW CAN 2 BYTES BE AN ADDRESS?)
;

: THREEBYTES ( print: two operands, tab, opcode mnemonic)
  OVER 
  1+ DUPB@ .HB 
  1+ B@ .HB TAB TAB 
  .OPCODE 
  1+ DUP@ ( MFB) OVER 
  2+ +
  CROSS @ IF BASE @ + THEN
;


DATA[ BYTE 14
      WORD ' BR         BYTE 1
      WORD ' BRZ        BYTE 1
      WORD ' XDO        BYTE 1
      WORD ' XLOOP      BYTE 1
      WORD ' X+LOOP     BYTE 1
      WORD ' LDI        BYTE 1
      WORD ' LDIS       BYTE 2
      WORD ' XDEFA      BYTE 2
      WORD ' XDATA      BYTE 2
      WORD ' LDIB       BYTE 3
      WORD ' ,LDI       BYTE 4
      WORD ' XIF[       BYTE 5
      WORD ' SRET       BYTE 6
      WORD ' X:EXIT     BYTE 7 ] D:TABLE

DATA[ BYTE 4
      WORD ' THREAD BYTE 1
      WORD ' X;PUSH BYTE 1
      WORD ' COLON  BYTE 2
      WORD ' VLOAD  BYTE 4
      ] DATABLE

: SPCLCODE@ ( determine if word needs special attention
              tos=table address, nos=defadr
              tos=0-no, <>0-yes (type))
  0 3 INSRT
  DUPB@ 1 DO ( search table)
    1+ DUP@ 3 PICK = IF ( defadr matches)
      2+ B@ 3 INSRT EXIT ( set return type)
    ELSE
      2+ ( point to next table entry)
    THEN
  LOOP
  2 KILL ( remove defadr & table addr)
;

: DACMT ( print addr label:    addr -- )
  TAB ";" .C DUP .' 0= IF
    DUP .VCB
  THEN
  DROP
;

: relb     DUP DUPB@ ( get relative data byte again )
            + 1+ DHX ( .H) ( add to current location and print)
	           ( 1+ ( increment address))
(         DUP ( to match drop) ) ;

: DA ( disassembler  tos=address)
          DUP .H ( print address)
	  DUPB@ .HB ( print byte at address)
	  DUPB@ ( get byte at TOS for disassembly - NOS=addr)
  CASE ( print current address & opcode -- main case )

    OF[ 0 THRU 3FH ] 0-3F @OPCODE OPCMD@ 
                                       ( ------- first table ---------)
        CASE ( point to table entry & get op flag)
            2 OF TWOBYTES TAB DHB 
                   ENDOF ( two byte instruction )
            3 OF THREEBYTES TAB DUP DHX DACMT 1+ 
                   ENDOF ( three byte instruction)
            5 OF TWOBYTES "," .C DHB 
                   ENDOF ( two byte inst. with a "," in operand)
            6 OF THREEBYTES "," .C DUP DHX DACMT 1+ 
                   ENDOF ( 3 byte inst. with a "," in operand)
	DROP TAB TAB .OPCODE ( one byte instruction)
	ENDCASE ( first table)
    ENDOF ( first table)

    OF[ 40H THRU 47H ]                         ( inx instructions)
	TAB TAB " INX" ." TAB 4 + 7 REGS 
    ENDOF

    OF[ 48H THRU 4FH ]                         ( dcx instructions)
	TAB TAB " DCX" ." TAB 4 + 7 REGS 
    ENDOF

    OF[ 50H THRU 57H ]                         ( push instructions)
	TAB TAB " PUSH" ." TAB 4 + 7 REGS 
    ENDOF

    OF[ 58H THRU 5FH ]                         ( pop instructions)
	TAB TAB " POP" ." TAB 4 + 7 REGS 
    ENDOF

    OF[ 60H THRU 71H ]
        TAB TAB " notimp" ." 
	DROP
    ENDOF
                                              ( conditional jumps)

         72H OF 1+ DUPB@ .HB TAB TAB " JC" ." TAB relb endof
         73H OF 1+ DUPB@ .HB TAB TAB " JNC" ." TAB relb endof
         74H OF 1+ DUPB@ .HB TAB TAB " JZ" ." TAB relb endof
         75H OF 1+ DUPB@ .HB TAB TAB " JNZ" ." TAB relb endof
	 76H OF    TAB TAB " notimp" ." endof
	 77H OF    TAB TAB " notimp" ." endof
         78H OF 1+ DUPB@ .HB TAB TAB " JM" ." TAB relb endof
         79H OF 1+ DUPB@ .HB TAB TAB " JP" ." TAB relb endof
         7aH OF 1+ DUPB@ .HB TAB TAB " JPE" ." TAB relb endof
         7bH OF 1+ DUPB@ .HB TAB TAB " JPO" ." TAB relb endof


    OF[ 7CH THRU 85H ]
        TAB TAB " notimp" ." 
	DROP
    ENDOF

        86H OF 1+ DUPB@ DUP .HB DUP E0H = IF 
               TAB TAB " XCHG" ." TAB " AL,AH" ."
		ELSE TAB TAB " notimp" ." DROP THEN
            ENDOF 

       87H OF 1+ DUPB@ DUP .HB DUP D3H = IF 
               TAB TAB " XCHG" ."
                ELSE TAB TAB " notimp" ." DROP THEN
           ENDOF 

                                   ( ------- move instructions ---------)

	  88H OF 1+ DUPB@ DUP .HB  TAB TAB " MOV " ." TAB
                DUP 7 REGS "," .C 38H REGS  ENDOF
	  89H OF 2+ ( assume byte is 1E Hex) DUPB@ .HB
                                             1+ DUPB@ .HB
                TAB TAB " SHLD " ." TAB 1- DUP@ DHX ( .H) 1+ ENDOF
	  8AH OF 1+ DUPB@ DUP .HB  TAB TAB " MOV " ." TAB
                DUP 38H REGS "," .C 7 REGS ENDOF
	  8BH OF 2+ ( assume byte is 1E Hex) DUPB@ .HB
					     1+ DUPB@ .HB
                TAB TAB " LHLD " ." TAB 1- DUP@ DHX ( .H) 1+ ENDOF

    OF[ 8CH THRU 9BH ]
        TAB TAB " notimp" ." 
	DROP
    ENDOF

    9CH OF TAB TAB " PUSHF" ." ENDOF
    9DH OF TAB TAB " POPF" ." ENDOF
    9EH OF TAB TAB " SAHF" ." ENDOF 
    9FH OF TAB TAB " LAHF" ." ENDOF 

    A0H OF 
      1+ DUPB@ .HB
      1+ DUPB@ .HB
      TAB TAB " LDA " ." TAB
      1- DUP@ DHX 1+ ENDOF

    A1H OF    TAB TAB " notimp" ." endof

    A2H OF 
      1+ DUPB@ .HB
      1+ DUPB@ .HB
      TAB TAB " STA " ." TAB
      1- DUP@ DHX 1+ ENDOF

    OF[ A3H THRU AFH ]
        TAB TAB " notimp" ." 
	DROP
    ENDOF

    OF[ B0H THRU B7H ] 
                             ( ------- 8 bit mvi instructions ---------)
	  OVER 1+ @ .HB TAB TAB " MVI " ." TAB
                7 REGS "," .C 1+ DUPB@ DHB ( .HB)
    ENDOF ( 8 bit mvi instructions)

    B8H OF    TAB TAB " notimp" ." endof

    OF[ B9H THRU BBH ]
                             ( ------- 8 bit lxi instructions ---------)
	  OVER 1+ DUPB@ .HB 1+ B@ .HB TAB TAB " LXI " ." TAB
                4 + 7 REGS "," .C 1+ DUP@ DHX ( .H ) 1+
    ENDOF                                      ( 8 bit lxi instructions)

    OF[ BCH THRU BFH  ]
        TAB TAB " notimp" ." 
	DROP
    ENDOF

   OF[ C0H THRU FFH ] C0H - C0-FF @OPCODE OPCMD@ 
                                      ( ------- second table ---------)
	CASE ( point to table entry & get op flag)
            2 OF TWOBYTES TAB DHB  	ENDOF ( two byte inst.)
            3 OF THREEBYTES TAB DHX 1+	ENDOF ( 3 byte inst.)
            4 OF ( call/jmp) THREEBYTES TAB DUP DHX DACMT
		1+ DUP 1- @ DATABLE ( MFB)    ROT ROT OVER 1+ + 
		CROSS @ IF BASE @ + THEN ROT
	        SPCLCODE@
          	CASE
                 1 OF 2 DDCONT B! 		ENDOF ( stop dump)
                 2 OF 1 DDCONT B! 		ENDOF ( continue dump, stop disassembly)
                 3 OF CRLF 1+ DUP .H DUPB@ .HB DUP 1+ B@ .HB 
						ENDOF ( print 4 bytes)
                 4 OF CRLF 1+ DUP .H DUPB@ .HB DUP 1+ B@ .HB 2 DDCONT B! 
		                  		ENDOF ( print 4 bytes & stop)
                 5 OF CRLF 1+ DUP .H DUPB@ .HB DUP 1+ B@ .HB 2+ 
		    DUPB@ .HB DUP 1+ B@ .HB 2 DDCONT B! 
				  		ENDOF ( print 6 bytes & stop)
            	DROP
	        ENDCASE
       					ENDOF ( call/jmp)
        DROP TAB TAB .OPCODE ( one byte inst.)
        ENDCASE ( second table)
    ENDOF ( second table)


 DROP
 ENDCASE
     1+
     CRLF
;

: DC: ( decompiler, tos=address)
  DUP 2+ SWAP ( tos=current dump address, nos=next dump address)
  DUP .H DUP@ .H TAB TAB ( print current address)
  @ DUP .'1 ( print high level word)
  D:TABLE SPCLCODE@ CASE ( process word according to it's type)
    0 OF ENDOF ( nothing special)
    1 OF DUP@ .H 2+ ENDOF ( print additional two bytes)
    2 OF SPC DUP ." DUPB@ + 1+ ENDOF ( print add. string)
    3 OF DUPB@ .HB 1+ ENDOF ( print add. one byte)
    4 OF DUP@ .H 2+ DUP@ .H 2+ ENDOF ( print add. four bytes)
    5 OF ( print imbedded code for IF[, END[, WHILE[, OF[ )
      REPEAT
        DUP 1+ SWAP B@ DUP ( at end of imbedded code ?)
      WHILE
        CASE
          1 OF DUP@ .H 2+ ENDOF ( single value)
          2 OF DUP 2+ DUP@ .H "  THRU" ." SWAP @ .H 2+ ENDOF ( range)
          DROP DUP ." DUPB@ + 1+ ( text)
        ENDCASE
      ENDWHILE
      DROP DUP@ .H 2+ ( point to next imbedded code item)
    ENDOF
    6 OF 2 DDCONT B! ENDOF ( stop dumping this definition)
    7 OF 1 DDCONT B! ENDOF ( stop decompiling this defintion - start disassembly)
    DROP
  ENDCASE
  CRLF
;

: DDL
  BEGIN
    " ============================== code  definition\13 10\" ."
    0 DDCONT B! BEGIN ( set continue flag and attempt to disassemble)
      DA GETSTS IF ( if character input at console, stop)
        2 DDCONT B!
      THEN
    DDCONT B@ END ( continue disassembly ?)
    DDCONT B@ 1 = IF ( attempt decompile ?)
(      ]] HEAD @ base @ - DDHSTART ! [[ ( save start address of the 
decompiler) )
      ]] HEAD @ base @ - ' DDHSTART base @ + 2 - ! [[ ( save start address of the decompiler)
      " ------------------------------ colon definition\13 10\" ."
      0 DDCONT B! BEGIN ( set continue flag & attempt to decompile)
        DC: GETSTS IF ( if character input at console, stop)
          2 DDCONT B!
        THEN
      DDCONT B@ END ( continue decompile ?)
    THEN
  DDCONT B@ 2 = END ( continue dump of the definition ?)
  DROP ( drop dump address)
;

CODE DDH
(  ' PSHBC# CALL, B DDHSTART @ LXI,)
  ' PSHBC# CALL, B ' DDHSTART base @ + 2 - @ LXI,
;

: DD
  GTDFA DDL
;