\ < Copyright 1985-1990 Bradley Forthware

\ Debugger.  Thanks, Mike Perry, Henry Laxen, Mark Smeder.
\
\ The debugger lets you 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.
\ Debugging makes everything run slightly slower, even outside
\ the word being debugged.  see debug-off
\
\ debug name	Mark that word for debugging
\ stepping	Debug in single step mode
\ tracing	Debug in trace mode
\ debug-off	Turn off the debugger (makes the system run fast again)
\ resume	Exit from a pushed interpreter (see the f keystroke)
\
\ Keystroke commands while you're single-stepping
\   d		go down a level
\   u		go up a level
\   c		continue trace without single stepping
\   g		go  turn off stepping and continue execution
\   f		push a Forth interpreter,  execute "resume" to get back
\ > q		abort back to the top level

hex
only forth also definitions  system also  hidden also
bug also definitions

\needs slow-next ??cr .( Warning- a cpu specific debugger module must be loaded first) abort
needs interact lib/interact.fth

variable slow-next?  slow-next? off
variable step? step? on
variable res
: (debug)	(s low-adr hi-adr -- )
	unbug
	1 cnt !   ip> !   <ip !   pnext
	slow-next? @ 0=
	if	here  low-dictionary-adr  slow-next
		slow-next? on
	then
	step? on ;
: 'unnest	(s pfa -- pfa' )
	begin dup cell+ swap token@ ['] unnest =  until ;
: set-<ip	(s pfa -- )
	<ip !
	<ip @  ip> @  u>=
	if <ip @  'unnest  ip> !  then ;

false value first-time?
\ Enter and leave the debugger
forth definitions

: defer?	( acf -- flag )	word-type  ['] key word-type =  ;
: colon-cf?	( acf -- flag )	word-type  ['] defer? word-type = ;
: (debug	( acf -- )
	begin dup defer? while behavior repeat
	dup colon-cf? 0= abort" Not a colon definition"
	>body dup 'unnest (debug)
	true is first-time? ;
\ Debug the caller
: debug-me	(s -- )	ip@ find-cfa (debug  ;
: debug(	(s -- )	ip@ dup 'unnest (debug)  ;
: )debug	(s -- )	ip@ ip> !  ;
: debug-off	(s -- )	unbug  here low-dictionary-adr fast-next slow-next? off ;

bug also definitions
\ Go up the return stack until we find the return address left by our caller
: caller-ip	( rp -- ip )
	begin	cell+ dup @  dup  in-dictionary?
	if    ( rs-adr ip )
		ip>token token@
		dup ['] execute =  over defer? or  swap <ip @ body> =  or
	else	drop false
	then
	until                                     ( rs-adr )
	@ ip>token ;
: up1	( rp -- )
	caller-ip
	dup find-cfa   ( ip cfa )
	cr ." [ Up to " dup .name ." ]" cr  ( ip cfa )
	over token@ .name                   ( ip cfa )
	>body swap 'unnest (debug) ;

defer to-debug-window	' noop is to-debug-window
defer restore-window	' noop is restore-window

: .debug-short-help	( -- )
	." Stepper keys: <space> Down Up Continue Forth Go Help ? See $tring " [char] " emit ." string Quit" cr ;
: .debug-long-help	( -- )
	." Key     Action" cr
	." <space> Execute displayed word" cr
	." D       Down: Step down into displayed word" cr
	." U       Up: Finish current definition and step in its caller" cr
	." C       Continue: trace current definition without stopping" cr
	." F       Forth: enter a subordinate Forth interpreter" cr
	." G       Go: resume normal execution (stop debugging)" cr
	." H       Help: display this message" cr
	." ?       Display short list of debug commands" cr
	." R       RSTrace: Show contents of Forth return stack" cr
	." S       See: Decompile definition being debugged" cr
	." $       Display top of stack as adr,len text string" cr
	[char] " emit
	 ."        Display top of stack as counted string" cr
	." Q       Quit: abandon execution of the debugged word" cr ;

d# 24 constant cmd-column
0 value rp-mark
: to-cmd-column	( -- )	cmd-column to-column  ;

\ set-package is a hook for Open Firmware.  When Open Firmware is loaded,
\ set-package should be set to a word that sets the active package to the
\ package corresponding to the current instance.  set-package is called
\ by the "F" key, so the user will see the methods of the current instance.
defer set-package	' noop is   set-package
defer unset-package	' noop is unset-package

: try		( n acf -- okay? )
	catch ?dup if .error drop false else true then ;
: (trace  ( -- )
	first-time?
	if	??cr ip@  <ip @ =
		if  ." : "  else  ." Inside "  then
		<ip @ find-cfa .name
		false is first-time?
		rp@ is rp-mark
	then
	begin	step? @  if to-debug-window then
		cmd-column 2+ to-column  ." ( " .s ." )" cr   \ Show stack
		['] noop is indent
		ip@ .token  drop		  \ Show word name
		['] (indent) is indent
		to-cmd-column
		step? @ key? or
		if	step? on  res off
			key dup bl < if drop bl then dup emit upc
			restore-window
			reset-page
			case
			[char] D of ip@ token@  dup ['] execute  =  if  drop dup  then
				['] (debug try					endof \ Down
			[char] U of rp@ ['] up1 try				endof \ Up
			[char] C of step? @ 0= step? ! true			endof \ Continue
			[char] F of cr ." Type 'resume' to return to debugger" cr
				set-package interact unset-package false	endof						   \ Forth
			[char] G of debug-off  cr  exit				endof \ Go
			[char] H of cr .debug-long-help	false			endof \ Help
			[char] R of cr rp0 @ rp@ cell+ (rstrace false		endof \ RSTrace
			[char] S of cr <ip @ body> (see) false			endof \ See
			[char] ? of cr .debug-short-help false			endof \ Short Help
			[char] " of space dup ". cr    to-cmd-column false	endof \ counted string
			[char] $ of space 2dup type cr to-cmd-column false	endof \ String
			[char] Q of cr ." unbug" abort           true		endof \ Quit
			[char] ( of ip@ set-<ip                  false		endof
			[char] < of ip@ cell+ set-<ip 1 cnt !    false		endof
			[char] ) of ip@ ip> !  1 cnt !           false		endof
			[char] * of ip@ find-cfa dup <ip ! 'unnest ip> ! false	endof
			( default )  true swap
			endcase
		else	true
		then
	until
	ip@ token@  dup ['] unnest =  swap ['] exit =  or
	if cr  true is first-time? then
	pnext ;
' (trace  'debug token!

only forth bug also forth definitions

: debug  \ name (s -- )
   '
   .debug-short-help
   (debug
;
: debugging  ( -- )  ' .debug-short-help  dup (debug  execute  ;
: resume    (s -- )  true is exit-interact?  pnext  ;
: stepping  (s -- )  step? on  ;
: tracing   (s -- )  step? off ;

: (bye	unbug debug-off (bye ; ' (bye is bye
only forth also definitions  decimal
