Merge branch 'new_walker' of git://factorcode.org/git/factor

core/continuations/continuations-docs.factor

@@ -199,6 +199,3 @@ $low-level-note ;
 
 HELP: init-error-handler
 { $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ;
-
-HELP: break
-{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;

core/continuations/continuations.factor

@@ -91,14 +91,8 @@ C: <continuation> continuation
 
 PRIVATE>
 
-: set-walker-hook ( quot -- ) 3 setenv ; inline
-
-: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
-
 : continue-with ( obj continuation -- )
-    [
-        walker-hook [ >r 2array r> ] when* (continue-with)
-    ] 2 (throw) ;
+    [ (continue-with) ] 2 (throw) ;
 
 : continue ( continuation -- )
     f swap continue-with ;
@@ -185,20 +179,3 @@ M: condition compute-restarts
     "kernel-error" 6 setenv ;
 
 PRIVATE>
-
-! Debugging support
-: with-walker-hook ( continuation -- )
-    [ swap set-walker-hook (continue) ] curry callcc1 ;
-
-SYMBOL: break-hook
-
-: break ( -- )
-    continuation callstack
-    over set-continuation-call
-    walker-hook [ (continue-with) ] [ break-hook get call ] if* ;
-
-GENERIC: (step-into) ( obj -- )
-
-M: wrapper (step-into) wrapped break ;
-M: object (step-into) break ;
-M: callable (step-into) \ break add* break ;

core/prettyprint/prettyprint.factor

@@ -95,42 +95,42 @@ SYMBOL: ->
 "word-style" set-word-prop
 
 ! This code is ugly and could probably be simplified
-: remove-step-into
-    building get dup empty? [
-        drop \ (step-into) ,
-    ] [
-        pop dup wrapper? [
-            wrapped dup \ break eq?
-            [ drop ] [ , ] if
-        ] [
-            ,
-        ] if
-    ] if ;
-
-: (remove-breakpoints) ( quot -- newquot )
-    [
-        [
-            {
-                { break [ ] }
-                { (step-into) [ remove-step-into ] }
-                [ , ]
-            } case
-        ] each
-    ] [ ] make ;
-
-: remove-breakpoints ( quot pos -- quot' )
-    over quotation? [
-        1+ cut [ (remove-breakpoints) ] 2apply
-        [ -> ] swap 3append
-    ] [
-        drop
-    ] if ;
+! : remove-step-into
+!     building get dup empty? [
+!         drop \ (step-into) ,
+!     ] [
+!         pop dup wrapper? [
+!             wrapped dup \ break eq?
+!             [ drop ] [ , ] if
+!         ] [
+!             ,
+!         ] if
+!     ] if ;
+! 
+! : (remove-breakpoints) ( quot -- newquot )
+!     [
+!         [
+!             dup {
+!                 { break [ drop ] }
+!                 { (step-into) [ remove-step-into ] }
+!                 [ , ]
+!             } case
+!         ] each
+!     ] [ ] make ;
+! 
+! : remove-breakpoints ( quot pos -- quot' )
+!     over quotation? [
+!         1+ cut [ (remove-breakpoints) ] 2apply
+!         [ -> ] swap 3append
+!     ] [
+!         drop
+!     ] if ;
 
 PRIVATE>
 
 : callstack. ( callstack -- )
     callstack>array 2 <groups> [
-        remove-breakpoints
+        ! remove-breakpoints
         2 nesting-limit [ . ] with-variable
     ] assoc-each ;
 

extra/channels/remote/remote.factor

@@ -29,14 +29,14 @@ MATCH-VARS: ?from ?tag ?id ?value ;
 SYMBOL: no-channel
 
 : channel-process ( -- )
-    receive [
+    [
         {
             { { to ?id ?value  }
             [ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
             { { from ?id }
             [ ?id get-channel [ from ] [ no-channel ] if* ] }
         } match-cond
-    ] keep reply-synchronous ;
+    ] handle-synchronous ;
 
 PRIVATE>
 

extra/concurrency/messaging/messaging.factor

@@ -97,7 +97,7 @@ M: thread send ( message thread -- )
     mailbox mailbox-get? ?linked ; inline
 
 : rethrow-linked ( error process supervisor -- )
-    >r <linked> r> send ;
+    pick thread-death? [ 3drop ] [ >r <linked> r> send ] if ;
 
 : spawn-linked-to ( quot name mailbox -- thread )
     [ >r <linked> r> mailbox-put ] curry <thread>
@@ -117,17 +117,26 @@ TUPLE: reply data tag ;
     synchronous-tag \ reply construct-boa ;
 
 : send-synchronous ( message thread -- reply )
-    >r <synchronous> dup r> send [
-        over reply? [
-            >r reply-tag r> synchronous-tag =
-        ] [
-            2drop f
-        ] if
-    ] curry receive-if reply-data ;
+    dup self eq? [
+        "Cannot synchronous send to myself" throw
+    ] [
+        >r <synchronous> dup r> send [
+            over reply? [
+                >r reply-tag r> synchronous-tag =
+            ] [
+                2drop f
+            ] if
+        ] curry receive-if reply-data
+    ] if ;
 
 : reply-synchronous ( message synchronous -- )
     [ <reply> ] keep synchronous-sender send ;
 
+: handle-synchronous ( quot -- )
+    receive [
+        synchronous-data swap call
+    ] keep reply-synchronous ; inline
+
 <PRIVATE
 
 : remote-processes ( -- hash )