Merge OneEyed's patch

[factor.git] / basis / tools / walker / walker.factor

diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor
old mode 100755 (executable)
new mode 100644 (file)
index 9c6b87b..f0d9a08
--- a/basis/tools/walker/walker.factor
+++ b/basis/tools/walker/walker.factor
@@ -3,8 +3,8 @@
 USING: threads kernel namespaces continuations combinators
 sequences math namespaces.private continuations.private
 concurrency.messaging quotations kernel.private words
-sequences.private assocs models models.filter arrays accessors
-generic generic.standard definitions ;
+sequences.private assocs models models.arrow arrays accessors
+generic generic.standard definitions make sbufs ;
 IN: tools.walker
 
 SYMBOL: show-walker-hook ! ( status continuation thread -- )
@@ -64,6 +64,12 @@ 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) ;
@@ -83,7 +89,7 @@ M: object add-breakpoint ;
 : (step-into-continuation) ( -- )
     continuation callstack >>call break ;
 
-: (step-into-call-next-method) ( class generic -- )
+: (step-into-call-next-method) ( method -- )
     next-method-quot (step-into-quot) ;
 
 ! Messages sent to walker thread
@@ -103,25 +109,25 @@ SYMBOL: +stopped+
 : change-frame ( continuation quot -- continuation' )
     #! Applies quot to innermost call frame of the
     #! continuation.
-    >r clone r> [
-        >r clone r>
+    [ clone ] dip [
+        [ clone ] dip
         [
-            >r
-            [ innermost-frame-scan 1+ ]
-            [ innermost-frame-quot ] bi
-            r> call
+            [
+                [ innermost-frame-scan 1+ ]
+                [ innermost-frame-quot ] bi
+            ] dip call
         ]
         [ drop set-innermost-frame-quot ]
         [ drop ]
         2tri
     ] curry change-call ; inline
 
-: step-msg ( continuation -- continuation' )
+: step-msg ( continuation -- continuation' ) USE: io
     [
-        2dup nth \ break = [
-            nip
-        ] [
-            swap 1+ cut [ break ] swap 3append
+        2dup length = [ nip [ break ] append ] [
+            2dup nth \ break = [ nip ] [
+                swap 1+ cut [ break ] glue 
+            ] if
         ] if
     ] change-frame ;
 
@@ -130,6 +136,9 @@ SYMBOL: +stopped+
 
 {
     { call [ (step-into-quot) ] }
+    { dip [ (step-into-dip) ] }
+    { 2dip [ (step-into-2dip) ] }
+    { 3dip [ (step-into-3dip) ] }
     { (throw) [ drop (step-into-quot) ] }
     { execute [ (step-into-execute) ] }
     { if [ (step-into-if) ] }
@@ -138,6 +147,7 @@ SYMBOL: +stopped+
     { (call-next-method) [ (step-into-call-next-method) ] }
 } [ "step-into" set-word-prop ] assoc-each
 
+! Never step into these words
 {
     >n ndrop >c c>
     continue continue-with
@@ -152,13 +162,16 @@ SYMBOL: +stopped+
 : step-into-msg ( continuation -- continuation' )
     [
         swap cut [
-            swap % unclip {
-                { [ dup \ break eq? ] [ , ] }
-                { [ dup quotation? ] [ add-breakpoint , \ break , ] }
-                { [ dup array? ] [ add-breakpoint , \ break , ] }
-                { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
-                [ , \ break , ]
-            } cond %
+            swap %
+            [ \ break , ] [
+                unclip {
+                    { [ dup \ break eq? ] [ , ] }
+                    { [ dup quotation? ] [ add-breakpoint , \ break , ] }
+                    { [ dup array? ] [ add-breakpoint , \ break , ] }
+                    { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
+                    [ , \ break , ]
+                } cond %
+            ] if-empty
         ] [ ] make
     ] change-frame ;
 
@@ -192,12 +205,12 @@ SYMBOL: +stopped+
                 ]
             } case
         ] handle-synchronous
-    ] [ ] while ;
+    ] while ;
 
 : step-back-msg ( continuation -- continuation' )
     walker-history tget
     [ pop* ]
-    [ dup empty? [ drop ] [ nip pop ] if ] bi ;
+    [ [ nip pop ] unless-empty ] bi ;
 
 : walker-suspended ( continuation -- continuation' )
     +suspended+ set-status
@@ -215,16 +228,16 @@ SYMBOL: +stopped+
                 { step-into-all [ step-into-all-loop ] }
                 { abandon [ drop f keep-running ] }
                 ! Pass quotation to debugged thread
-                { call-in [ nip keep-running ] }
+                { call-in [ keep-running ] }
                 ! Pass previous continuation to debugged thread
                 { step-back [ step-back-msg ] }
             } case f
         ] handle-synchronous
-    ] [ ] while ;
+    ] while ;
 
 : walker-loop ( -- )
     +running+ set-status
-    [ status +stopped+ eq? not ] [
+    [ status +stopped+ eq? ] [
         [
             {
                 ! ignore these commands while the thread is
@@ -243,7 +256,7 @@ SYMBOL: +stopped+
                 [ walker-suspended ]
             } case
         ] handle-synchronous
-    ] [ ] while ;
+    ] until ;
 
 : associate-thread ( walker -- )
     walker-thread tset