\ DEBUG.SEQ     A high level debugger      Enhancements by Tom Zimmer

\ The debugger is designed to let the user single step the
\ execution of a high level definition.  To invoke the
\ debugger, type DEBUG XXX where XXX is the name of the
\ word you wish to trace.  When XXX executes, you will get
\ a single step trace showing you the word within XXX that
\ is about to execute, and the contents of the parameter
\ stack. This debugger works by patching the NEXT routine,
\ so it is highly machine and implementation dependent.

ONLY FORTH ALSO DEFINITIONS

VARIABLE DBSEG
VARIABLE 'DEBUG   ( Code field for high level trace )
VARIABLE CNT      ( How many times thru debug next )
DEFER DBG.S     ' .S IS DBG.S   \ default DBG.S to the systems .S

HEX

LABEL FNEXT   ( Fix the >NEXT code back to normal )
        MOV AX, # AD26          \ ES: LODSW
        MOV >NEXT AX
        MOV AX, # E0FF          \ JMP AX
        MOV >NEXT 2+ AX
        RET END-CODE

LABEL DNEXT   ( The Debugger version of a normal >NEXT )
    ES: LODSW JMP AX
        END-CODE

DECIMAL

HEX LABEL DEBNEXT
        MOV AX, ES
        CMP AX, DBSEG
        0= IF   MOV AX, CNT
                INC AX
                MOV CNT AX
                CMP AX, # 2
                0= IF   SUB AX, AX
                        MOV CNT AX
                        CALL FNEXT
                        PUSH IP
                        MOV AX, 'DEBUG
                        JMP AX
                THEN
        THEN    JMP DNEXT
        END-CODE

CODE PNEXT   ( -- )
        MOV AL, # 0E9
        MOV >NEXT AL
        MOV AX, # DEBNEXT  >NEXT 3 + -
        MOV >NEXT 1+ AX
        NEXT   C;

FORTH DEFINITIONS

CODE UNBUG    ( -- )
        CALL FNEXT
        NEXT   C;   DECIMAL

BUG ALSO DEFINITIONS

CREATE DSTK 100 ALLOT DSTK 100 ERASE

VARIABLE SLOWLY   VARIABLE DCNT
VARIABLE SFLG

' >NAME.ID @REL>ABS CONSTANT 'DOCOL
' KEY      @REL>ABS CONSTANT 'UDEFER
' BDOS     @REL>ABS CONSTANT 'DEFER

: D.ID          ( -- )                      \ DEBUGGER ID DOT
                CCR DBSEG  @ DUP 6 U.R
                    PFASAV @ DUP 3 U.R @L
                DUP @REL>ABS DUP 'DOCOL =
                OVER 'UDEFER = OR SWAP 'DEFER = OR
                SFLG @ IF DUP 0= SLOWLY ! THEN
                >R DCNT @ 0 MAX 2/ 16 MOD SPACES R>
                IF   DUP @REL>ABS 'DOCOL =
                     IF ."  :  " ELSE DUP @REL>ABS 'UDEFER =
                        IF  ."  Ud " ELSE ."  d  " THEN THEN
                ELSE 4 SPACES   THEN
                16 SWAP >NAME.ID  NLEN @ - SPACES ;

: (DBG)         ( BEGIN_OF_LIST_RELATIVE -- )
                XSEG @ + DBSEG !
                SFLG OFF SLOWLY OFF 1 CNT ! ;

: DSTK0 DSTK 100 ERASE DCNT OFF ;

: >DS   DCNT @ DSTK + !  2 DCNT +! ;

: DS>   DCNT @ 2 < 0= IF -2 DCNT +! THEN DCNT @ DSTK + @ ;

: >DSTK ( A1-)  DBSEG @ PFASAV @ @L DUP @REL>ABS 'DOCOL =
        IF      ."  Nesting "  DBSEG @ >DS
                DEFCFA @ >DS DUP DEFCFA !
                >BODY @ (DBG) EXIT
        THEN    DUP @REL>ABS 'UDEFER =
                OVER >BODY @ UP @ + @ @REL>ABS 'DOCOL = AND
        IF      ."  UDefering to " DBSEG @ >DS
                >BODY @ UP @ + @
                DEFCFA @ >DS DUP DEFCFA !
                DUP >NAME.ID >BODY @ (DBG) EXIT
        THEN    DUP @REL>ABS 'DEFER =
                OVER >BODY @ @REL>ABS 'DOCOL = AND
        IF      ."  Defering to "  DBSEG @ >DS
                >BODY @
                DEFCFA @ >DS DUP DEFCFA !
                DUP >NAME.ID >BODY @ (DBG) EXIT
        THEN    DROP ."  Can't, NOT a : def " ;

: ?DST>         ( A1- F1 )
                DBSEG @ PFASAV @ @L ['] UNNEST =
                DCNT @ 2 > AND
                IF      DS> DEFCFA ! DS> XSEG @ - (DBG) THEN    ;


\ Type "?" while in the debugger to display the following line;

\       C-cont, F-forth, Q-quit, N-nest, U-unnest, Z-zip:

\ The commands are available while debugging, as follows;

\       C-cont          Continuous, scrolls through words as they
\                       are executed, stop by pressing <return>.
\       F-forth         Allow entry of Forth commands, until a <return>
\                       is pressed on an empty command line.
\                       P.S. don't make any typing errors or you will
\                       fall out of the debugger.
\       Q-quit          Quit the debugger, and unpatch the debug word.
\                       Returns to Forth.
\       N-nest          Nest into the current definition the debugger
\                       is sitting on, if it is a ":" definition, else
\                       issue an error message but don't abort.
\       U-unnest        Unnest from the current word being debugged, the
\                       debugger will re-enter when the word finishes
\                       executing, and pops up one level to the word that
\                       called it. You cannot Unnest without Nesting.
\       Z-zip           Zip through definitions, like C-cont, but only
\                       zips through code definitions, still pauses on
\                       ":" definitions.

: GET-COMMAND   ( --- c1 )
                BEGIN   ." ?> " .DEFSRC
                        (KEY)   UPC 0 ASCII ? 2 PICK =
                        IF      CCR
                        ." C-cont, F-forth, Q-quit, N-nest, U-unnest, Z-zip:"
                                0=
                        THEN    ASCII F 2 PICK =
                        IF      >R >R
                                BEGIN   CCR DBG.S ." ->"
                                        QUERY #TIB @
                                WHILE   RUN
                                REPEAT  R> R> 0=
                        THEN
                WHILE  DROP D.ID REPEAT ;

: TRACE   ( Ip - )
        ?CS: TYPESEG DUP @ >R !
        PFASAV ! DBG.S D.ID ?DST> SLOWLY @ 0= (KEY?) OR
        IF      SLOWLY OFF GET-COMMAND
                ASCII C OVER = IF SFLG OFF SLOWLY ON THEN
                ASCII Z OVER = IF SFLG @ 0= SFLG ! THEN
                ASCII N OVER = IF   >DSTK THEN
                ASCII X OVER = IF   ['] NOOP IS .DEFSRC  ['] CRLF IS CCR
                               THEN
                ASCII U OVER = IF DCNT @ 2 >
                                  IF DS> DEFCFA ! DS> XSEG @ - (DBG)
                                  ELSE  DROP EXIT THEN
                               THEN
                ASCII Q OVER = ABORT" Unbug" DROP
        ELSE    3 SPACES
        THEN
        R> TYPESEG !
        PNEXT ;

' TRACE 'DEBUG !

FORTH DEFINITIONS

: ADEBUG        ( A1 --- ) DUP DEFCFA !
                DSTK0   DUP @REL>ABS 'DOCOL =
                IF      [ BUG ] >BODY @ (DBG) PNEXT  EXIT
                THEN    DUP @REL>ABS 'UDEFER =
                        OVER >BODY @ UP @ + @
                        @REL>ABS 'DOCOL = AND
                IF      >BODY @ UP @ + @ DUP >NAME.ID
                        >BODY @ (DBG) PNEXT EXIT
                THEN    DUP @REL>ABS 'DEFER =
                        OVER @ @REL>ABS 'DOCOL = AND
                IF      >BODY @ DUP >NAME.ID
                        >BODY @ (DBG) PNEXT EXIT
                THEN    ABORT" Can't, NOT a : def " ;

: DEBUG         ' ADEBUG ;
\ : #DEBUG        >R DEBUG R> ABS NEGATE CNT ! ;
\ : DEBUG>        R@ @ ADEBUG ;
: DBG           >IN @  DEBUG  >IN !  ;