| \ ***************************************************************************** |
| \ * 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 |
| <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 overwriten 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 overwriten 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 |
| ; |