\ ***************************************************************************** \ * 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 @ = 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 <> 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 OF cell+ dup @ over + cell+ (u.) (see-my-type) " " (see-my-type) ENDOF OF cell+ dup @ (u.) (see-my-type) " " (see-my-type) ENDOF OF cell+ dup @ (u.) (see-my-type) " " (see-my-type) ENDOF OF cell+ dup @ xt>name (see-my-type) " " (see-my-type) ENDOF OF cell+ dup @ (u.) (see-my-type) " " (see-my-type) ENDOF OF cell+ dup @ (u.) (see-my-type) " " (see-my-type) ENDOF OF cell+ dup @ over + cell+ (u.) (see-my-type) " " (see-my-type) ENDOF OF cell+ dup @ over + cell+ (u.) (see-my-type) " " (see-my-type) ENDOF 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 OF dup cell+ cell+ @ . ." INSTANCE VALUE " ENDOF OF ." INSTANCE VARIABLE " ENDOF dup OF ." CREATE " ENDOF ENDCASE (.xt) ; \ Decompile Forth command whose execution token is xt : (see) ( xt -- ) cr dup dup @ CASE OF ." VARIABLE " (.xt) ENDOF OF dup execute . ." VALUE " (.xt) ENDOF OF dup execute . ." CONSTANT " (.xt) ENDOF OF dup cell+ @ swap ." DEFER " (.xt) ." is " (.xt) ENDOF OF dup cell+ @ swap ." ALIAS " (.xt) ." " (.xt) ENDOF OF ." BUFFER: " (.xt) ENDOF OF (see-create) ENDOF 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 = 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 @ @ = 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 : 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 OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF OF drop forth-ip cell+ @ cell fip-add ENDOF OF drop forth-ip cell+ @ cell fip-add ENDOF 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 OF drop 2dup <> IF swap >r >r cell fip-add ELSE forth-ip cell+ @ cell+ fip-add 2drop THEN ENDOF OF drop forth-ip cell+ @ cell+ fip-add ENDOF OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF OF drop IF r> r> 2drop forth-ip cell+ @ cell+ fip-add ELSE cell fip-add THEN ENDOF OF drop r> 1+ r> 2dup = IF 2drop cell fip-add ELSE >r >r forth-ip cell+ @ cell+ fip-add THEN ENDOF OF drop r> + r> 2dup >= IF 2drop cell fip-add ELSE >r >r forth-ip cell+ @ cell+ fip-add THEN ENDOF OF trace>depth 0> IF trace-depth- 1 to trace>recurse stepping drop r> recurse ELSE drop exit THEN ENDOF 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 <> 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 ;