home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FFA.ZIP / DEBUG.SEQ < prev    next >
Encoding:
Text File  |  1988-01-02  |  7.3 KB  |  201 lines
  1. \ DEBUG.SEQ     A high level debugger      Enhancements by Tom Zimmer
  2.  
  3. \ The debugger is designed to let the user single step the
  4. \ execution of a high level definition.  To invoke the
  5. \ debugger, type DEBUG XXX where XXX is the name of the
  6. \ word you wish to trace.  When XXX executes, you will get
  7. \ a single step trace showing you the word within XXX that
  8. \ is about to execute, and the contents of the parameter
  9. \ stack. This debugger works by patching the NEXT routine,
  10. \ so it is highly machine and implementation dependent.
  11.  
  12. ONLY FORTH ALSO DEFINITIONS
  13.  
  14. VARIABLE 'DEBUG   ( Code field for high level trace )
  15. VARIABLE <IP      ( Lower limit of IP )
  16. VARIABLE IP>      ( Upper limit of IP )
  17. VARIABLE CNT      ( How many times thru debug next )
  18.  
  19. HEX
  20.  
  21. LABEL FNEXT   ( Fix the >NEXT code back to normal )
  22.         MOV AX, # AD26          \ ES: LODSW
  23.         MOV >NEXT AX
  24.         MOV AX, # E0FF          \ JMP AX
  25.         MOV >NEXT 2+ AX
  26.         RET END-CODE
  27.  
  28. LABEL DNEXT   ( The Debugger version of a normal >NEXT )
  29.     ES: LODSW JMP AX
  30.         END-CODE
  31.  
  32. DECIMAL
  33.  
  34. HEX LABEL DEBNEXT
  35.         CMP IP, <IP
  36.         U> IF   CMP  IP, IP>
  37.                 U<= IF  MOV AX, CNT
  38.                         INC AX
  39.                         MOV CNT AX
  40.                         CMP AX, # 2
  41.                         0= IF   SUB AX, AX
  42.                                 MOV CNT AX
  43.                                 CALL FNEXT
  44.                                 PUSH IP
  45.                                 MOV AX, 'DEBUG
  46.                                 JMP AX
  47.                         THEN
  48.                 THEN
  49.         THEN    JMP DNEXT
  50.         END-CODE
  51.  
  52. CODE PNEXT   ( -- )
  53.         MOV AL, # 0E9
  54.         MOV >NEXT AL
  55.         MOV AX, # DEBNEXT  >NEXT 3 + -
  56.         MOV >NEXT 1+ AX
  57.         NEXT   C;
  58.  
  59. FORTH DEFINITIONS
  60.  
  61. CODE UNBUG    ( -- )
  62.         CALL FNEXT
  63.         NEXT   C;   DECIMAL
  64.  
  65. BUG ALSO DEFINITIONS
  66.  
  67. CREATE DSTK 100 ALLOT DSTK 100 ERASE
  68.  
  69. VARIABLE SLOWLY   VARIABLE DCNT
  70. VARIABLE SFLG
  71.  
  72. ' >NAME.ID @REL>ABS CONSTANT 'DOCOL
  73. ' KEY      @REL>ABS CONSTANT 'UDEFER
  74. ' BDOS     @REL>ABS CONSTANT 'DEFER
  75.  
  76. : D.ID          ( -- )                      \ DEBUGGER ID DOT
  77.                 CCR PFASAV @ DUP 6 U.R X@ DUP @REL>ABS DUP 'DOCOL =
  78.                 OVER 'UDEFER = OR SWAP 'DEFER = OR
  79.                 SFLG @ IF DUP 0= SLOWLY ! THEN
  80.                 >R DCNT @ 0 MAX 2/ 16 MOD SPACES R>
  81.                 IF   DUP @REL>ABS 'DOCOL =
  82.                      IF ."  :  " ELSE DUP @REL>ABS 'UDEFER =
  83.                         IF  ."  Ud " ELSE ."  d  " THEN THEN
  84.                 ELSE 4 SPACES   THEN
  85.                 16 SWAP >NAME.ID  NLEN @ - SPACES ;
  86.  
  87. : (DBG)         ( CFA -- )
  88.                 1- DUP
  89.                 BEGIN   1+ DUP X@ ['] UNNEST =
  90.                 UNTIL   IP> ! <IP !
  91.                 SFLG OFF SLOWLY OFF 1 CNT ! ;
  92.  
  93. : DSTK0 DSTK 100 ERASE DCNT OFF ;
  94.  
  95. : >DS   DCNT @ DSTK + !  2 DCNT +! ;
  96.  
  97. : DS>   DCNT @ 2 < 0= IF -2 DCNT +! THEN DCNT @ DSTK + @ ;
  98.  
  99. : >DSTK ( A1-)  PFASAV @ X@ DUP @REL>ABS 'DOCOL =
  100.         IF      ."  Nesting "  <IP @ >DS
  101.                 DEFCFA @ >DS DUP DEFCFA !
  102.                 >BODY @ (DBG) EXIT
  103.         THEN    DUP @REL>ABS 'UDEFER =
  104.                 OVER >BODY @ UP @ + @ @REL>ABS 'DOCOL = AND
  105.         IF      ."  UDefering to " <IP @ >DS
  106.                 >BODY @ UP @ + @
  107.                 DEFCFA @ >DS DUP DEFCFA !
  108.                 DUP >NAME.ID >BODY @ (DBG) EXIT
  109.         THEN    DUP @REL>ABS 'DEFER =
  110.                 OVER >BODY @ @REL>ABS 'DOCOL = AND
  111.         IF      ."  Defering to "  <IP @ >DS
  112.                 >BODY @
  113.                 DEFCFA @ >DS DUP DEFCFA !
  114.                 DUP >NAME.ID >BODY @ (DBG) EXIT
  115.         THEN    DROP ."  Can't, NOT a : def " ;
  116.  
  117. : ?DST>         ( A1- F1 )
  118.                 PFASAV @ X@ ['] UNNEST =
  119.                 DCNT @ 2 > AND
  120.                 IF      DS> DEFCFA ! DS> (DBG) THEN    ;
  121.  
  122.  
  123. \ Type "?" while in the debugger to display the following line;
  124.  
  125. \       C-cont, F-forth, Q-quit, N-nest, U-unnest, Z-zip:
  126.  
  127. \ The commands are available while debugging, as follows;
  128.  
  129. \       C-cont          Continuous, scrolls through words as they
  130. \                       are executed, stop by pressing <return>.
  131. \       F-forth         Allow entry of Forth commands, until a <return>
  132. \                       is pressed on an empty command line.
  133. \                       P.S. don't make any typing errors or you will
  134. \                       fall out of the debugger.
  135. \       Q-quit          Quit the debugger, and unpatch the debug word.
  136. \                       Returns to Forth.
  137. \       N-nest          Nest into the current definition the debugger
  138. \                       is sitting on, if it is a ":" definition, else
  139. \                       issue an error message but don't abort.
  140. \       U-unnest        Unnest from the current word being debugged, the
  141. \                       debugger will re-enter when the word finishes
  142. \                       executing, and pops up one level to the word that
  143. \                       called it. You cannot Unnest without Nesting.
  144. \       Z-zip           Zip through definitions, like C-cont, but only
  145. \                       zips through code definitions, still pauses on
  146. \                       ":" definitions.
  147.  
  148. : GET-COMMAND   ( --- c1 )
  149.                 BEGIN   ." ?> " .DEFSRC
  150.                         (KEY)   UPC 0 ASCII ? 2 PICK =
  151.                         IF      CCR
  152.                         ." C-cont, F-forth, Q-quit, N-nest, U-unnest, Z-zip:"
  153.                                 0=
  154.                         THEN    ASCII F 2 PICK =
  155.                         IF      >R >R
  156.                                 BEGIN   CCR .S ." ->"
  157.                                         QUERY #TIB @
  158.                                 WHILE   RUN
  159.                                 REPEAT  R> R> 0=
  160.                         THEN
  161.                 WHILE  DROP D.ID REPEAT ;
  162.  
  163. : TRACE   ( Ip - ) PFASAV ! .S D.ID ?DST> SLOWLY @ 0= (KEY?) OR
  164.         IF      SLOWLY OFF GET-COMMAND
  165.                 ASCII C OVER = IF SFLG OFF SLOWLY ON THEN
  166.                 ASCII Z OVER = IF SFLG @ 0= SFLG ! THEN
  167.                 ASCII N OVER = IF   >DSTK THEN
  168.                 ASCII X OVER = IF   ['] NOOP IS .DEFSRC  ['] CRLF IS CCR
  169.                                THEN
  170.                 ASCII U OVER = IF DCNT @ 2 >
  171.                                   IF DS> DEFCFA ! DS> (DBG)
  172.                                   ELSE  DROP EXIT THEN
  173.                                THEN
  174.                 ASCII Q OVER = ABORT" Unbug" DROP
  175.         ELSE    3 SPACES
  176.         THEN    PNEXT ;
  177.  
  178. ' TRACE 'DEBUG !
  179.  
  180. FORTH DEFINITIONS
  181.  
  182. : ADEBUG        ( A1 --- ) DUP DEFCFA !
  183.                 DSTK0   DUP @REL>ABS 'DOCOL =
  184.                 IF      [ BUG ] >BODY @ (DBG) PNEXT  EXIT
  185.                 THEN    DUP @REL>ABS 'UDEFER =
  186.                         OVER >BODY @ UP @ + @
  187.                         @REL>ABS 'DOCOL = AND
  188.                 IF      >BODY @ UP @ + @ DUP >NAME.ID
  189.                         >BODY @ (DBG) PNEXT EXIT
  190.                 THEN    DUP @REL>ABS 'DEFER =
  191.                         OVER @ @REL>ABS 'DOCOL = AND
  192.                 IF      >BODY @ DUP >NAME.ID
  193.                         >BODY @ (DBG) PNEXT EXIT
  194.                 THEN    ABORT" Can't, NOT a : def " ;
  195.  
  196. : DEBUG         ' ADEBUG ;
  197. \ : #DEBUG        >R DEBUG R> ABS NEGATE CNT ! ;
  198. \ : DEBUG>        R@ @ ADEBUG ;
  199. : DBG           >IN @  DEBUG  >IN !  ;
  200.  
  201.