: walk ( quot -- quot' )
\ break prefix [ break rethrow ] recover ;
- GENERIC: add-breakpoint ( quot -- quot' )
-
- M: callable add-breakpoint
- 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-dip) ( quot -- ) add-breakpoint dip ;
-
- : (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
-
- : (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
-
- : (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
-
- : (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
-
- : (step-into-execute) ( word -- )
- {
- { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
- { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
- { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
- { [ dup uses \ suspend swap member? ] [ execute break ] }
- { [ dup primitive? ] [ execute break ] }
- [ def>> (step-into-quot) ]
- } cond ;
-
- \ (step-into-execute) t "step-into?" set-word-prop
-
- : (step-into-continuation) ( -- )
- continuation callstack >>call break ;
-
- : (step-into-call-next-method) ( method -- )
- next-method-quot (step-into-quot) ;
+ break-hook [
+ [
+ get-walker-thread
+ [ show-walker-hook get call ] keep
+ send-synchronous
+ ]
+ ] initialize
+<< {
+ (step-into-quot)
+ (step-into-dip)
+ (step-into-2dip)
+ (step-into-3dip)
+ (step-into-if)
+ (step-into-dispatch)
+ (step-into-execute)
+ (step-into-continuation)
+ (step-into-call-next-method)
+} [ t "no-compile" set-word-prop ] each >>
+
! Messages sent to walker thread
SYMBOL: step
SYMBOL: step-out