From 3351391e50024902e8b53eb3d2dbad174f9e3561 Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Sat, 22 Aug 2009 16:46:45 +0200
Subject: [PATCH] added send-synchronous-timeout word and tests

---
 .../concurrency/messaging/messaging-tests.factor  | 15 ++++++++++++++-
 basis/concurrency/messaging/messaging.factor      |  9 +++++++++
 2 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/basis/concurrency/messaging/messaging-tests.factor b/basis/concurrency/messaging/messaging-tests.factor
index dd94ad15b3..7cbe2b21ff 100644
--- a/basis/concurrency/messaging/messaging-tests.factor
+++ b/basis/concurrency/messaging/messaging-tests.factor
@@ -3,7 +3,7 @@
 USING: kernel threads vectors arrays sequences namespaces make
 tools.test continuations deques strings math words match
 quotations concurrency.messaging concurrency.mailboxes
-concurrency.count-downs accessors ;
+concurrency.count-downs concurrency.conditions accessors calendar ;
 IN: concurrency.messaging.tests
 
 [ ] [ my-mailbox data>> clear-deque ] unit-test
@@ -15,6 +15,19 @@ IN: concurrency.messaging.tests
     "sent" swap send-synchronous
 ] unit-test
 
+[ "received" ] [ 
+    [
+        receive "received" swap reply-synchronous
+    ] "Synchronous test" spawn
+    [ 100 milliseconds "sent" ] dip send-synchronous-timeout
+] unit-test
+
+[ [ 100 milliseconds sleep
+    receive "received" swap reply-synchronous ] "Synchronous test" spawn
+  [ 50 milliseconds "sent" ] dip send-synchronous-timeout
+] [ wait-timeout? ] must-fail-with
+
+
 [ 1 3 2 ] [
     1 self send
     2 self send
diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor
index ce7f7d6110..8438f7effe 100644
--- a/basis/concurrency/messaging/messaging.factor
+++ b/basis/concurrency/messaging/messaging.factor
@@ -61,6 +61,15 @@ M: cannot-send-synchronous-to-self summary
         data>>
     ] if ;
 
+: send-synchronous-timeout ( timeout message thread -- reply ) 
+    dup self eq? [
+        cannot-send-synchronous-to-self
+    ] [
+        [ <synchronous> dup ] dip send
+        '[ _ synchronous-reply? ] receive-if-timeout
+        data>>
+    ] if ;   
+    
 : reply-synchronous ( message synchronous -- )
     [ <reply> ] keep sender>> send ;