steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Improve walker: step into on an array recursively sets breakpoint on each quotation nested in the array. Useful for cond, case, cleave, ...

db4
Slava Pestov 2008-04-02 00:03:04 -05:00
parent 92b0451e9b
commit a2971bd3be
1 changed files with 28 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
extra/tools/walker/walker.factor
View File

@ -3,7 +3,7 @@
USING: threads kernel namespaces continuations combinators USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words concurrency.messaging quotations kernel.private words
sequences.private assocs models ; sequences.private assocs models arrays accessors ;
IN: tools.walker IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- ) SYMBOL: show-walker-hook ! ( status continuation thread -- )
@ -51,9 +51,16 @@ DEFER: start-walker-thread
: walk ( quot -- quot' ) : walk ( quot -- quot' )
\ break prefix [ break rethrow ] recover ; \ break prefix [ break rethrow ] recover ;
: add-breakpoint ( quot -- quot' ) GENERIC: add-breakpoint ( quot -- quot' )
M: callable add-breakpoint
dup [ break ] head? [ \ break prefix ] unless ; dup [ break ] head? [ \ break prefix ] unless ;
M: array add-breakpoint
[ add-breakpoint ] map ;
M: object add-breakpoint ;
: (step-into-quot) ( quot -- ) add-breakpoint call ; : (step-into-quot) ( quot -- ) add-breakpoint call ;
: (step-into-if) ? (step-into-quot) ; : (step-into-if) ? (step-into-quot) ;
@ -74,7 +81,7 @@ DEFER: start-walker-thread
\ (step-into-execute) t "step-into?" set-word-prop \ (step-into-execute) t "step-into?" set-word-prop
: (step-into-continuation) : (step-into-continuation)
continuation callstack over set-continuation-call break ; continuation callstack >>call break ;
! Messages sent to walker thread ! Messages sent to walker thread
SYMBOL: step SYMBOL: step
@ -94,15 +101,18 @@ SYMBOL: +stopped+
: change-frame ( continuation quot -- continuation' ) : change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the #! Applies quot to innermost call frame of the
#! continuation. #! continuation.
>r clone r> >r clone r> [
over continuation-call clone >r clone r>
[ [
dup innermost-frame-scan 1+ >r
swap innermost-frame-quot [ innermost-frame-scan 1+ ]
rot call [ innermost-frame-quot ] bi
] keep r> call
[ set-innermost-frame-quot ] keep ]
over set-continuation-call ; inline [ drop set-innermost-frame-quot ]
[ drop ]
2tri
] curry change-call ; inline
: step-msg ( continuation -- continuation' ) : step-msg ( continuation -- continuation' )
[ [
@ -143,6 +153,7 @@ SYMBOL: +stopped+
swap % unclip { swap % unclip {
{ [ dup \ break eq? ] [ , ] } { [ dup \ break eq? ] [ , ] }
{ [ dup quotation? ] [ add-breakpoint , \ break , ] } { [ dup quotation? ] [ add-breakpoint , \ break , ] }
{ [ dup array? ] [ add-breakpoint , \ break , ] }
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] } { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
{ [ t ] [ , \ break , ] } { [ t ] [ , \ break , ] }
} cond % } cond %
@ -177,16 +188,17 @@ SYMBOL: +stopped+
{ step-back [ f ] } { step-back [ f ] }
{ f [ +stopped+ set-status f ] } { f [ +stopped+ set-status f ] }
[ [
dup walker-continuation tget set-model [ walker-continuation tget set-model ]
step-into-msg [ step-into-msg ] bi
] ]
} case } case
] handle-synchronous ] handle-synchronous
] [ ] while ; ] [ ] while ;
: step-back-msg ( continuation -- continuation' ) : step-back-msg ( continuation -- continuation' )
walker-history tget dup pop* walker-history tget
empty? [ drop walker-history tget pop ] unless ; [ pop* ]
[ dup empty? [ drop ] [ nip pop ] if ] bi ;
: walker-suspended ( continuation -- continuation' ) : walker-suspended ( continuation -- continuation' )
+suspended+ set-status +suspended+ set-status