Updating contrib/concurrency/ for latest changes (lightly tested)

contrib/concurrency/concurrency-examples.factor

@@ -23,8 +23,9 @@
 !
 ! Examples of using the concurrency library.
 IN: concurrency-examples
-USING: concurrency dlists errors gadgets-theme gadgets-panes io kernel lists
-math math-contrib namespaces opengl prettyprint sequences threads ;
+USING: concurrency dlists errors gadgets gadgets-labels
+gadgets-panes gadgets-theme io kernel math namespaces opengl
+prettyprint sequences threads ;
 
 : (logger) ( mailbox -- )
   #! Using the given mailbox, start a thread which
@@ -34,10 +35,10 @@ math math-contrib namespaces opengl prettyprint sequences threads ;
 : logger ( -- mailbox )
   #! Start a logging thread, which will log messages to the
   #! console that are put in the returned mailbox.
-  make-mailbox dup [ (logger) ] cons in-thread ;
+  make-mailbox dup [ (logger) ] curry in-thread ;
 
 : (pong-server0) ( -- )
-  receive uncons "ping" = [
+  receive second "ping" = [
     "pong" swap send (pong-server0)
   ] [
     "Pong server shutting down" swap send
@@ -146,28 +147,23 @@ M: crash-command run-rpc-command ( command -- shutdown? result )
 : test-add ( process -- )
   [ 
     "add" [ 1 2 3 ] <rpc-command> swap send-synchronous .
-  ] cons spawn drop ;
+  ] curry spawn drop ;
 
 : test-crash ( process -- )
   [ 
     "crash" f <rpc-command> swap send-synchronous .
-  ] cons spawn drop ;
+  ] curry spawn drop ;
   
 ! ******************************
 ! Experimental code below
 ! ******************************
-USE: gadgets
-USE: gadgets-labels
-USE: gadgets-presentations
-USE: gadgets-layouts
-USE: generic
 
 TUPLE: promised-label promise font color ;
 
 C: promised-label ( promise -- promised-label )
   dup delegate>gadget dup label-theme
   [ set-promised-label-promise ] keep 
-  [ [ dup promised-label-promise ?promise drop relayout ] cons spawn drop ] keep ;
+  [ [ dup promised-label-promise ?promise drop relayout ] curry spawn drop ] keep ;
 
 : promised-label-text ( promised-label -- text )
   promised-label-promise dup promise-fulfilled? [
@@ -196,4 +192,4 @@ M: promised-label set-label-font set-promised-label-font ;
   1 sleep dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
   
 : test-promise-ui ( -- )
-  <promise> dup <promised-label> gadget. [ 15 fib unparse swap fulfill ] cons spawn drop ;
+  <promise> dup <promised-label> gadget. [ 15 fib unparse swap fulfill ] curry spawn drop ;

contrib/concurrency/concurrency-tests.factor

@@ -23,8 +23,7 @@
 !
 IN: concurrency
 USING: kernel concurrency concurrency-examples threads vectors 
-       sequences lists namespaces test errors dlists strings 
-       math words ;
+       sequences namespaces test errors dlists strings math words ;
 
 [ "junk" ] [ 
   <dlist> 
@@ -81,9 +80,9 @@ USING: kernel concurrency concurrency-examples threads vectors
 [ V{ 1 2 3 } ] [
   0 <vector>
   make-mailbox
-  2dup [ mailbox-get swap push ] cons cons in-thread
-  2dup [ mailbox-get swap push ] cons cons in-thread
-  2dup [ mailbox-get swap push ] cons cons in-thread
+  2dup [ mailbox-get swap push ] curry curry in-thread
+  2dup [ mailbox-get swap push ] curry curry in-thread
+  2dup [ mailbox-get swap push ] curry curry in-thread
   1 over mailbox-put
   2 over mailbox-put
   3 swap mailbox-put
@@ -92,9 +91,9 @@ USING: kernel concurrency concurrency-examples threads vectors
 [ V{ 1 2 3 } ] [
   0 <vector>
   make-mailbox
-  2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread
-  2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread
-  2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread
+  2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
+  2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
+  2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
   1 over mailbox-put
   2 over mailbox-put
   3 swap mailbox-put
@@ -103,10 +102,10 @@ USING: kernel concurrency concurrency-examples threads vectors
 [ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
   0 <vector>
   make-mailbox
-  2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread
-  2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread
-  2dup [ [ string? ] swap mailbox-get? swap push ] cons cons in-thread
-  2dup [ [ string? ] swap mailbox-get? swap push ] cons cons in-thread
+  2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
+  2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
+  2dup [ [ string? ] swap mailbox-get? swap push ] curry curry in-thread
+  2dup [ [ string? ] swap mailbox-get? swap push ] curry curry in-thread
   1 over mailbox-put
   "junk" over mailbox-put
   [ 456 ] over mailbox-put
@@ -174,8 +173,8 @@ USING: kernel concurrency concurrency-examples threads vectors
 [ V{ 50 50 50 } ] [
   0 <vector>
   <promise>
-  2dup [ ?promise swap push ] cons cons spawn drop
-  2dup [ ?promise swap push ] cons cons spawn drop
-  2dup [ ?promise swap push ] cons cons spawn drop
+  2dup [ ?promise swap push ] curry curry spawn drop
+  2dup [ ?promise swap push ] curry curry spawn drop
+  2dup [ ?promise swap push ] curry curry spawn drop
   50 swap fulfill
 ] unit-test  

contrib/concurrency/concurrency.factor

@@ -23,7 +23,7 @@
 !
 ! Concurrency library for Factor based on Erlang/Termite style
 ! concurrency.
-USING: kernel lists generic threads io namespaces errors words 
+USING: kernel generic threads io namespaces errors words 
        math sequences hashtables strings vectors dlists ;
 IN: concurrency
 
@@ -224,7 +224,7 @@ TUPLE: linked-exception error ;
   #! Same as spawn but if the quotation throws an error that
   #! is uncaught, that error gets propogated to the process
   #! performing the spawn-link.
-  [ catch [ rethrow-linked ] when* ] cons
+  [ catch [ rethrow-linked ] when* ] curry
   [ in-thread ] self make-linked-process [ with-process ] over slip ;
 
 #! A common operation is to send a message to a process containing
@@ -248,11 +248,7 @@ TUPLE: tagged-message data from tag ;
   #! 'match-quot' is a quotation with stack effect ( msg -- ). It
   #! will be called with the message on the top of the stack if
   #! the 'pred' word returned true.
-  uncons >r dupd execute [
-    r> car call
-  ] [
-    r> 2drop
-  ] if ;
+  [ first execute ] 2keep rot [ second call ] [ 2drop ] if ;
 
 : recv ( forms -- ) 
   #! Get a message from the processes mailbox. Compare it against the
@@ -289,7 +285,7 @@ TUPLE: tagged-message data from tag ;
   #! is matched up with the request by generating a message tag
   #! which should be sent back with the reply.
   >r tag-message [ tagged-message-tag ] keep r> send
-  unit [ car tag-match? ] cons receive-if tagged-message-data ;
+  unit [ first tag-match? ] curry receive-if tagged-message-data ;
 
 : reply ( tagged-message message -- )
   #! Replies to the tagged-message which should have been a result of a 
@@ -321,7 +317,7 @@ SYMBOL: quit-cc
   [  
     (spawn-server)
     "Exiting process: " write self process-pid print
-  ] cons spawn ;
+  ] curry spawn ;
 
 : spawn-linked-server ( quot -- process )
   #! Similar to 'spawn-server' but the parent process will be linked
@@ -329,7 +325,7 @@ SYMBOL: quit-cc
   [  
     (spawn-server)
     "Exiting process: " write self process-pid print
-  ] cons spawn-link ;
+  ] curry spawn-link ;
 
 : send-reply ( message pred quot -- )
   #! The intent of this word is to provde an easy way to
@@ -392,7 +388,7 @@ SYMBOL: quit-cc
   #! ?future. If the quotation has completed the result will be returned.
   #! If not, the process will block until the quotation completes.
   #! 'quot' must have stack effect ( -- X ).
-  [ call self send ] cons spawn ;
+  [ self send ] append spawn ;
 
 : ?future ( future -- result )
   #! Block the process until the future has completed and then place the
@@ -443,7 +439,7 @@ SYMBOL: lazy-quot
         [ tagged-message? [ [ drop t ] [ get call ] send-reply ] ]
       ] recv
     ] with-scope
-  ] cons spawn ;
+  ] curry spawn ;
 
 : ?lazy ( lazy -- result )
   #! Given a process spawned using 'lazy', evaluate it and return the result.