--- /dev/null
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Get the name of Forth command whose execution token is xt
+
+: xt>name ( xt -- str len )
+ BEGIN
+ cell - dup c@ 0 2 within IF
+ dup 2+ swap 1+ c@ exit
+ THEN
+ AGAIN
+;
+
+cell -1 * CONSTANT -cell
+: cell- ( n -- n-cell-size )
+ [ cell -1 * ] LITERAL +
+;
+
+\ Search for xt of given address
+: find-xt-addr ( addr -- xt )
+ BEGIN
+ dup @ <colon> = IF
+ EXIT
+ THEN
+ cell-
+ AGAIN
+;
+
+: (.immediate) ( xt -- )
+ \ is it immediate?
+ xt>name drop 2 - c@ \ skip len and flags
+ immediate? IF
+ ." IMMEDIATE"
+ THEN
+;
+
+: (.xt) ( xt -- )
+ xt>name type
+;
+
+\ Trace back on current return stack.
+\ Start at 1, since 0 is return of trace-back itself
+
+: trace-back ( )
+ 1
+ BEGIN
+ cr dup dup . ." : " rpick dup . ." : "
+ ['] tib here within IF
+ dup rpick find-xt-addr (.xt)
+ THEN
+ 1+ dup rdepth 5 - >= IF cr drop EXIT THEN
+ AGAIN
+;
+
+VARIABLE see-my-type-column
+
+: (see-my-type) ( indent limit xt str len -- indent limit xt )
+ dup see-my-type-column @ + dup 50 >= IF
+ -rot over " " comp 0= IF
+ \ blank causes overflow: just enforce new line with next call
+ 2drop see-my-type-column !
+ ELSE
+ rot drop ( indent limit xt str len )
+ \ Need to copy string since we use (u.) again (kills internal buffer):
+ pocket swap 2dup >r >r ( indent limit xt str pk len R: len pk )
+ move r> r> ( indent limit xt pk len )
+ 2 pick (u.) dup -rot
+ cr type ( indent limit xt pk len xt-len )
+ " :" type 1+ ( indent limit xt pk len prefix-len )
+ 5 pick dup spaces + ( indent limit xt pk len prefix-len )
+ over + see-my-type-column ! ( indent limit xt pk len )
+ type
+ THEN ( indent limit xt )
+ ELSE
+ see-my-type-column ! type ( indent limit xt )
+ THEN
+;
+
+: (see-my-type-init) ( -- )
+ ffff see-my-type-column ! \ just enforce a new line
+;
+
+: (see-colon-body) ( indent limit xt -- indent limit xt )
+ (see-my-type-init) \ enforce new line
+ BEGIN ( indent limit xt )
+ cell+ 2dup <>
+ over @
+ dup <semicolon> <>
+ rot and ( indent limit xt @xt flag )
+ WHILE ( indent limit xt @xt )
+ xt>name (see-my-type) " " (see-my-type)
+ dup @ ( indent limit xt @xt)
+ CASE
+ <0branch> OF cell+ dup @
+ over + cell+ dup >r
+ (u.) (see-my-type) r> ( indent limit xt target)
+ 2dup < IF
+ over 4 pick 3 + -rot recurse
+ nip nip nip cell- ( indent limit xt )
+ ELSE
+ drop ( indent limit xt )
+ THEN
+ (see-my-type-init) ENDOF \ enforce new line
+ <branch> OF cell+ dup @ over + cell+ (u.)
+ (see-my-type) " " (see-my-type) ENDOF
+ <do?do> OF cell+ dup @ (u.) (see-my-type)
+ " " (see-my-type) ENDOF
+ <lit> OF cell+ dup @ (u.) (see-my-type)
+ " " (see-my-type) ENDOF
+ <dotick> OF cell+ dup @ xt>name (see-my-type)
+ " " (see-my-type) ENDOF
+ <doloop> OF cell+ dup @ (u.) (see-my-type)
+ " " (see-my-type) ENDOF
+ <do+loop> OF cell+ dup @ (u.) (see-my-type)
+ " " (see-my-type) ENDOF
+ <doleave> OF cell+ dup @ over + cell+ (u.)
+ (see-my-type) " " (see-my-type) ENDOF
+ <do?leave> OF cell+ dup @ over + cell+ (u.)
+ (see-my-type) " " (see-my-type) ENDOF
+ <sliteral> OF cell+ " """ (see-my-type) dup count dup >r
+ (see-my-type) " """ (see-my-type)
+ " " (see-my-type)
+ r> -cell and + ENDOF
+ ENDCASE
+ REPEAT
+ drop
+;
+
+: (see-colon) ( xt -- )
+ (see-my-type-init)
+ 1 swap 0 swap ( indent limit xt )
+ " : " (see-my-type) dup xt>name (see-my-type)
+ rot drop 4 -rot (see-colon-body) ( indent limit xt )
+ rot drop 1 -rot (see-my-type-init) " ;" (see-my-type)
+ 3drop
+;
+
+\ Create words are a bit tricky. We find out where their code points.
+\ If this code is part of SLOF, it is not a user generated CREATE.
+
+: (see-create) ( xt -- )
+ dup cell+ @
+ CASE
+ <2constant> OF
+ dup cell+ cell+ dup @ swap cell+ @ . . ." 2CONSTANT "
+ ENDOF
+
+ <instancevalue> OF
+ dup cell+ cell+ @ . ." INSTANCE VALUE "
+ ENDOF
+
+ <instancevariable> OF
+ ." INSTANCE VARIABLE "
+ ENDOF
+
+ dup OF
+ ." CREATE "
+ ENDOF
+ ENDCASE
+ (.xt)
+;
+
+\ Decompile Forth command whose execution token is xt
+
+: (see) ( xt -- )
+ cr dup dup @
+ CASE
+ <variable> OF ." VARIABLE " (.xt) ENDOF
+ <value> OF dup execute . ." VALUE " (.xt) ENDOF
+ <constant> OF dup execute . ." CONSTANT " (.xt) ENDOF
+ <defer> OF dup cell+ @ swap ." DEFER " (.xt) ." is " (.xt) ENDOF
+ <alias> OF dup cell+ @ swap ." ALIAS " (.xt) ." " (.xt) ENDOF
+ <buffer:> OF ." BUFFER: " (.xt) ENDOF
+ <create> OF (see-create) ENDOF
+ <colon> OF (see-colon) ENDOF
+ dup OF ." ??? PRIM " (.xt) ENDOF
+ ENDCASE
+ (.immediate) cr
+ ;
+
+\ Decompile Forth command old-name
+
+: see ( "old-name<>" -- )
+ ' (see)
+;
+
+\ Work in progress...
+
+0 value forth-ip
+true value trace>stepping?
+true value trace>print?
+true value trace>up?
+0 value trace>depth
+0 value trace>rdepth
+0 value trace>recurse
+: trace-depth+ ( -- ) trace>depth 1+ to trace>depth ;
+: trace-depth- ( -- ) trace>depth 1- to trace>depth ;
+
+: stepping ( -- )
+ true to trace>stepping?
+;
+
+: tracing ( -- )
+ false to trace>stepping?
+;
+
+: trace-print-on ( -- )
+ true to trace>print?
+;
+
+: trace-print-off ( -- )
+ false to trace>print?
+;
+
+
+\ Add n to ip
+
+: fip-add ( n -- )
+ forth-ip + to forth-ip
+;
+
+\ Save execution token address and content
+
+0 value debug-last-xt
+0 value debug-last-xt-content
+
+: trace-print ( -- )
+ forth-ip cr u. ." : "
+ forth-ip @
+ dup ['] breakpoint = IF drop debug-last-xt-content THEN
+ xt>name type ." "
+ ." ( " .s ." ) | "
+;
+
+: trace-interpret ( -- )
+ rdepth 1- to trace>rdepth
+ BEGIN
+ depth . [char] > dup emit emit space
+ source expect ( str len )
+ ['] interpret catch print-status
+ AGAIN
+;
+
+\ Main trace routine, trace a colon definition
+
+: trace-xt ( xt -- )
+ trace>recurse IF
+ r> drop \ Drop return of 'trace-xt call
+ cell+ \ Step over ":"
+ ELSE
+ debug-last-xt-content <colon> = IF
+ \ debug colon-definition
+ ['] breakpoint @ debug-last-xt ! \ Re-arm break point
+ r> drop \ Drop return of 'trace-xt call
+ cell+ \ Step over ":"
+ ELSE
+ ['] breakpoint debug-last-xt ! \ Re-arm break point
+ 2r> 2drop
+ THEN
+ THEN
+
+ to forth-ip
+ true to trace>print?
+ BEGIN
+ trace>print? IF trace-print THEN
+
+ forth-ip ( ip )
+ trace>stepping? IF
+ BEGIN
+ key
+ CASE
+ [char] d OF dup @ @ <colon> = IF \ recurse only into colon definitions
+ trace-depth+
+ 1 to trace>recurse
+ dup >r @ recurse
+ THEN true ENDOF
+ [char] u OF trace>depth IF tracing trace-print-off true ELSE false THEN ENDOF
+ [char] f OF drop cr trace-interpret ENDOF \ quit trace and start interpreter FIXME rstack
+ [char] c OF tracing true ENDOF
+ [char] t OF trace-back false ENDOF
+ [char] q OF drop cr quit ENDOF
+ 20 OF true ENDOF
+ dup OF cr ." Press d: Down into current word" cr
+ ." Press u: Up to caller" cr
+ ." Press f: Switch to forth interpreter, 'resume' will continue tracing" cr
+ ." Press c: Switch to tracing" cr
+ ." Press <space>: Execute current word" cr
+ ." Press q: Abort execution, switch to interpreter" cr
+ false ENDOF
+ ENDCASE
+ UNTIL
+ THEN ( ip' )
+ dup to forth-ip @ ( xt )
+ dup ['] breakpoint = IF drop debug-last-xt-content THEN
+ dup ( xt xt )
+
+ CASE
+ <sliteral> OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF
+ <dotick> OF drop forth-ip cell+ @ cell fip-add ENDOF
+ <lit> OF drop forth-ip cell+ @ cell fip-add ENDOF
+ <doto> OF drop forth-ip cell+ @ cell+ ! cell fip-add ENDOF
+ <(doito)> OF drop forth-ip cell+ @ cell+ cell+ @ >instance ! cell fip-add ENDOF
+ <0branch> OF drop IF
+ cell fip-add
+ ELSE
+ forth-ip cell+ @ cell+ fip-add THEN
+ ENDOF
+ <do?do> OF drop 2dup <> IF
+ swap >r >r cell fip-add
+ ELSE
+ forth-ip cell+ @ cell+ fip-add 2drop THEN
+ ENDOF
+ <branch> OF drop forth-ip cell+ @ cell+ fip-add ENDOF
+ <doleave> OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF
+ <do?leave> OF drop IF
+ r> r> 2drop forth-ip cell+ @ cell+ fip-add
+ ELSE
+ cell fip-add
+ THEN
+ ENDOF
+ <doloop> OF drop r> 1+ r> 2dup = IF
+ 2drop cell fip-add
+ ELSE >r >r
+ forth-ip cell+ @ cell+ fip-add THEN
+ ENDOF
+ <do+loop> OF drop r> + r> 2dup >= IF
+ 2drop cell fip-add
+ ELSE >r >r
+ forth-ip cell+ @ cell+ fip-add THEN
+ ENDOF
+
+ <semicolon> OF trace>depth 0> IF
+ trace-depth- 1 to trace>recurse
+ stepping drop r> recurse
+ ELSE
+ drop exit THEN
+ ENDOF
+ <exit> OF trace>depth 0> IF
+ trace-depth- stepping drop r> recurse
+ ELSE
+ drop exit THEN
+ ENDOF
+ dup OF execute ENDOF
+ ENDCASE
+ forth-ip cell+ to forth-ip
+ AGAIN
+;
+
+\ Resume execution from tracer
+: resume ( -- )
+ trace>rdepth rdepth!
+ forth-ip cell - trace-xt
+;
+
+\ Turn debug off, by erasing breakpoint
+
+: debug-off ( -- )
+ debug-last-xt IF
+ debug-last-xt-content debug-last-xt ! \ Restore overwritten token
+ 0 to debug-last-xt
+ THEN
+;
+
+
+
+\ Entry point for debug
+
+: (break-entry) ( -- )
+ debug-last-xt dup @ ['] breakpoint <> swap ( debug-addr? debug-last-xt )
+ debug-last-xt-content swap ! \ Restore overwritten token
+ r> drop \ Don't return to bp, but to caller
+ debug-last-xt-content <colon> <> and IF \ Execute non colon definition
+ debug-last-xt cr u. ." : "
+ debug-last-xt xt>name type ." "
+ ." ( " .s ." ) | "
+ key drop
+ debug-last-xt execute
+ ELSE
+ debug-last-xt 0 to trace>depth 0 to trace>recurse trace-xt \ Trace colon definition
+ THEN
+;
+
+\ Put entry point bp defer
+' (break-entry) to BP
+
+\ Mark an address for debugging
+
+: debug-address ( addr -- )
+ debug-off ( xt ) \ Remove active breakpoint
+ dup to debug-last-xt ( xt ) \ Save token for later debug
+ dup @ to debug-last-xt-content ( xt ) \ Save old value
+ ['] breakpoint swap !
+;
+
+\ Mark the command indicated by xt for debugging
+
+: (debug ( xt -- )
+ debug-off ( xt ) \ Remove active breakpoint
+ dup to debug-last-xt ( xt ) \ Save token for later debug
+ dup @ to debug-last-xt-content ( xt ) \ Save old value
+ ['] breakpoint @ swap !
+;
+
+\ Mark the command indicated by xt for debugging
+
+: debug ( "old-name<>" -- )
+ parse-word $find IF \ Get xt for old-name
+ (debug
+ ELSE
+ ." undefined word " type cr
+ THEN
+;
Code Review / kvmfornfv.git / blobdiff