422 lines
13 KiB
Forth
422 lines
13 KiB
Forth
\ *****************************************************************************
|
|
\ * 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
|
|
;
|