home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / LASER / FPC35_5.ZIP / FPCSRC.ZIP / DEBUG.SEQ < prev    next >
Encoding:
Text File  |  1989-09-26  |  13.1 KB  |  343 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 BUG ALSO
  13.  
  14. headerless
  15.  
  16. VARIABLE DBSEG
  17. VARIABLE DBOFF
  18. VARIABLE CNT
  19. VARIABLE 'DEBUG   ( Code field for high level trace )
  20. DEFER DBG.S     ' .S IS DBG.S           \ default DBG.S to the systems .S
  21. DEFER SKIP_TO   ' NOOP IS SKIP_TO       \ allow skipping to later point in
  22.                                         \ definition.
  23.  
  24. LABEL FNEXT   ( Fix the >NEXT code back to normal )
  25.         MOV AX, # $AD26                 \ ES: LODSW
  26.         MOV >NEXT AX
  27.         MOV AX, # $E0FF                 \ JMP AX
  28.         MOV >NEXT 2+ AX
  29.         RET END-CODE
  30.  
  31. LABEL DNEXT   ( The Debugger version of a normal >NEXT )
  32.     ES: LODSW JMP AX
  33.         END-CODE
  34.  
  35. LABEL DEBNEXT
  36.         MOV AX, ES
  37.         CMP AX, DBSEG                           \ does SEG match?
  38.         0= IF   MOV AX, IP
  39.                 CMP AX, DBOFF                   \ is offset greater
  40.                 >= IF   INC CNT
  41.                         CMP CNT # 2             \ gone through twice?
  42.                         0= IF   MOV CNT # 0
  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. headers
  60.  
  61. FORTH DEFINITIONS ALSO HIDDEN ALSO
  62.  
  63. CODE UNBUG    ( -- )
  64.         CALL FNEXT
  65.         NEXT   C;
  66.  
  67. BUG DEFINITIONS
  68.  
  69. headerless
  70.  
  71. CREATE DSTK 100 ALLOT DSTK 100 ERASE
  72.  
  73. variable slowly
  74. variable dcnt
  75. variable dbcfa
  76.  
  77. \ ' >NAME.ID @REL>ABS CONSTANT 'DOCOL
  78. ' KEY   @REL>ABS          CONSTANT 'UDEFER
  79. ' BDOS  @REL>ABS          CONSTANT 'DEFER
  80. ' FORTH @REL>ABS @REL>ABS CONSTANT 'DODOES
  81.  
  82. 0 value segabove                        \ segment of routine above current
  83.  
  84. : find_:        ( a1 n1 -- a2 n2 )   \ find any definition
  85.                 begin   $E9 ( jmp ) scan
  86.                         over @rel>abs 'docol <> over and
  87.                 while   3 -3 d+ 0 max
  88.                 repeat  ;
  89.  
  90. : find_dodoes   ( a1 n1 -- a2 n2 )   \ find any definition
  91.                 begin   $E8 ( call ) scan
  92.                         over @rel>abs @rel>abs 'dodoes <> over and
  93.                 while   3 -3 d+ 0 max
  94.                 repeat  ;
  95.  
  96. : seg>cfa       ( seg -- cfa f1 )       \ find cfa given the physical segment
  97.                 xseg @ - >r
  98.                 $100 here $100 -
  99.                 begin   find_: over >body @ r@ <> over and
  100.                 while   5 -5 d+ 0 max
  101.                 repeat  dup 0=
  102.                 if      2drop
  103.                         $100 here $100 -
  104.                         begin   find_dodoes over @rel>abs
  105.                                 >body @ r@ <> over and
  106.                         while   5 -5 d+ 0 max
  107.                         repeat
  108.                 then    r>drop ;
  109.  
  110. : n>name.id     ( cfa --- )
  111.                 on>  ?defattrib >name.id
  112.                 off> ?defattrib ;
  113.  
  114. : next_word@    ( -- cfa )
  115.                 dbseg @ pfasav @ @L ;
  116.  
  117. : d.id          ( -- )                      \ debugger id dot
  118.                 ccr
  119.                 save> base hex
  120.                 dbseg  @ 4 u.r
  121.                 pfasav @ 3 u.r
  122.                 restore> base
  123.                 dcnt @ 0max 16 mod spaces
  124.                 next_word@ dup @rel>abs
  125.                 case
  126.                         'docol  of      ."  :  "        endof
  127.                         'udefer of      ."  Ud "        endof
  128.                         'defer  of      ."  d  "        endof
  129.                                 over
  130.                                 case
  131.                                 ['] execute of  ."  e  "        endof
  132.                                 ['] perform of  ."  p  "        endof
  133.                                 ['] exec:   of  ."  e: "        endof
  134.                                                 4 spaces
  135.                                         drop
  136.                                 endcase
  137.                         drop
  138.                 endcase
  139.                 n>name.id 16 nlen @ - spaces ;
  140.  
  141. : setdebug      ( cfa1 cfa2 -- )        \ cfa1 is for name displaying
  142.                                         \ cfa2 is for debugging
  143.                 swap defcfa !
  144.                 dup dbcfa !
  145.                 >body @ +xseg dbseg !
  146.                 off> pfaline off> #empty
  147.                 slowly off 1 CNT ! DBOFF OFF ;
  148.  
  149. : >user@        ( cfa1 -- cfa2 )
  150.                 >body @ up @ + @ ;
  151.  
  152. : DSTK0 DSTK 100 ERASE DCNT OFF ;
  153.  
  154. : >DS   DCNT @ DSTK + !  2 DCNT +! ;
  155.  
  156. : DS>   DCNT @ 2 < 0= IF -2 DCNT +! THEN DCNT @ DSTK + @ ;
  157.  
  158. : nest1         ( cfa1 cfa2 -- )        \ save current debug and nest to
  159.                 ccr                     \ "cfa2". display "cfa1".
  160.                 over dup h. n>name.id
  161.                 ."  nesting "
  162.                 dbcfa @ >ds
  163.                 defcfa @ >ds
  164.                 setdebug ;
  165.  
  166. : ?docol        ( cfa -- f1 )
  167.                 @rel>abs 'docol = ;
  168.  
  169. : ?nest         ( cfa -- )      \ try to nest the word "cfa"
  170.                 recursive       \ this is a recursive definition
  171.                 dup @rel>abs
  172.                 case
  173.                 'docol  of      dup nest1               endof
  174.                 'udefer of      >user@  ?nest           endof
  175.                 'defer  of      >body @ ?nest           endof
  176.                                 >r
  177.                                 case
  178.                                 ['] execute of  dup   ?nest             endof
  179.                                 ['] perform of  dup @ ?nest             endof
  180.                                 ['] exec:   of  dup 1+ 2*
  181.                                                 dbseg @ pfasav @ rot +
  182.                                                 @L    ?nest             endof
  183.                                         \ *** DOES> test ***
  184.                                         dup        @rel>abs @rel>abs
  185.                                         ['] forth  @rel>abs @rel>abs =
  186.                                         if      dup dup @rel>abs nest1
  187.                                         else    ccr
  188.                                                 dup h. dup n>name.id
  189.                                                 ."  Is not debugable "
  190.                                         then
  191.                                         drop
  192.                                 endcase
  193.                                 r>drop
  194.                 endcase ;
  195.  
  196. : unnest1       ( -- )
  197.                 off> pfaline
  198.                 off> #empty
  199.                 slowly @
  200.                 if      .defsrc
  201.                 then    off> slowly
  202.                 dcnt @ 4 >=
  203.                 if      ds> ds> setdebug
  204.                 then    ;
  205.  
  206. : ?unnest1      ( -- )
  207.                 next_word@
  208.                 case
  209.                 ['] unnest of          unnest1          endof
  210.                 ['] exit   of          unnest1          endof
  211.                 ['] ?exit  of   dup if unnest1 then     endof
  212.                         drop
  213.                 endcase ;
  214.  
  215.  
  216. \ Type "?" while in the debugger to display the following line;
  217.  
  218. \       C-cont, D-done, F-forth, Q-quit, N-nest, U-unnest:
  219.  
  220. \ The commands are available while debugging, as follows;
  221.  
  222. \       C-cont          Continuous, scrolls through words as they
  223. \                       are executed, stop by pressing <return>.
  224. \       D-done          We are Done debugging, allow normal execution
  225. \                       to continue.
  226. \       F-forth         Allow entry of Forth commands, until a <return>
  227. \                       is pressed on an empty command line.
  228. \                       P.S. don't make any typing errors or you will
  229. \                       fall out of the debugger.
  230. \       Q-quit          Quit the debugger, and unpatch the debug word.
  231. \                       Returns to Forth.
  232. \       N-nest          Nest into the current definition the debugger
  233. \                       is sitting on, if it is a ":" definition, else
  234. \                       issue an error message but don't abort.
  235. \       U-unnest        Unnest from the current word being debugged, the
  236. \                       debugger will re-enter when the word finishes
  237. \                       executing, and pops up one level to the word that
  238. \                       called it. You cannot Unnest without Nesting.
  239.  
  240. : get-command   ( --- c1 )
  241.                 begin   ." ?> "
  242.                         (key)   upc 0 '?' 2 pick =
  243.                         if      ccr
  244. ." C-cont, D-done, F-forth, N-nest, Q-quit, S-skipto, U-unnest, X-source-on/off: "
  245.                                 0=
  246.                         then    'F' 2 pick =
  247.                         if      2>r
  248.                                 ccr
  249.         ." Press <Enter> on an empty command line to continue debugging."
  250.                                 begin   ccr dbg.s ." ->"
  251.                                         query #tib @
  252.                                 while   interpret
  253.                                 repeat  2r> 0=
  254.                         then
  255.                 while  drop d.id repeat ;
  256.  
  257. 0 VALUE SAVESEG
  258.  
  259. : trace         ( ip - )
  260.                 pfasav ! dbg.s d.id
  261.                 slowly @ 0= if .defsrc then
  262.                 2r> 2r> over =: segabove 2>r 2>r
  263.                 ?unnest1
  264.                 slowly @ 0= (key?) or
  265.                 if      slowly off get-command
  266.                         case
  267.                         'C' of  slowly on                       endof
  268.                         'N' of  next_word@ ?nest                endof
  269.                         'X' of  @> .defsrc ['] noop =
  270.                                 if      srcon else srcoff then  endof
  271.                         'D' of  off> pfaline off> #empty
  272.                                 -1 pfasav ! exit                endof
  273.                         'S' of  skip_to                         endof
  274.                         'U' of  dcnt @ 4 >=
  275.                                 if      ds> ds> setdebug
  276.                                 else    segabove seg>cfa        \ -- cfa f1
  277.                                         if      dup @rel>abs @rel>abs
  278.                                                 'dodoes =
  279.                                                 if      ccr
  280. ." Definition NAME may not be correct, this is one word of a class of words."
  281.                                                         ccr
  282.                                                         dup @rel>abs
  283.                                                         setdebug
  284.                                                 else    dup setdebug
  285.                                                 then
  286.                                         else    drop
  287.                                                 ccr ." Couldn't find CFA "
  288.                                         then
  289.                                 then                            endof
  290.                         'Q' of  -1 pfasav !
  291.                                 off> pfaline off> #empty
  292.                                 true abort" unbug"              endof
  293.                         drop
  294.                 endcase
  295.         else    3 spaces
  296.         then
  297.         pnext ;
  298.  
  299. ' TRACE 'DEBUG !
  300.  
  301. : %skip_to      ( -- )          \ set point to skip to
  302.                 save> pfasav
  303.                 0 split-l# at >attrib3
  304. ."  Use + and - to move the hilighted word to the point where you want to stop "
  305.                 eeol
  306.                 0 split-l# 1+ at >attrib3
  307. ."  Press Enter when done, or ESC to cancel skip " eeol >norm
  308.                 begin   .defsrc
  309.                         key upc
  310.                         case
  311.                         '+' of 2 pfasav +!               false endof
  312.                         '-' of pfasav @ 2- 0max pfasav ! false endof
  313. ( ESC )                 27  of                           true  endof
  314. ( Enter )               13  of pfasav @ 2- 0max DBOFF !  true  endof
  315.                                drop false beep
  316.                         endcase
  317.                 until
  318.                 restore> pfasav ;
  319.  
  320. ' %skip_to is skip_to
  321.  
  322. headers
  323.  
  324. FORTH DEFINITIONS
  325.  
  326. : adebug        ( a1 --- )
  327.                 debugable       \ convert inline next to jmp next for debugger.
  328.                 dstk0                           \ clear debugger stack
  329.                 ?nest                           \ try to nest into definition
  330.                 dcnt @ 0= abort" Aborting.. "
  331.                 dstk0                           \ clear debugger stack again
  332.                 ." Debugger ready."
  333.                 pnext ;                         \ set debugger active
  334.  
  335. : debug         ' adebug ;
  336. : dbg           >in @  debug  >in !  ;
  337.  
  338. behead
  339.  
  340. ONLY FORTH ALSO DEFINITIONS
  341.  
  342.  
  343.