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