libs/concurrency/concurrency-tests.factor

   1 ! Copyright (C) 2005 Chris Double. All Rights Reserved.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 USING: kernel concurrency threads vectors arrays sequences namespaces
   5 test errors dlists strings math words match ;
   6 IN: temporary
   7
   8 [ "junk" ] [
   9   <dlist>
  10   5 over dlist-push-end
  11   "junk" over dlist-push-end
  12   20 over dlist-push-end
  13   [ string? ] swap dlist-pop?
  14 ] unit-test
  15
  16 [ 5 20 ] [
  17   <dlist>
  18   5 over dlist-push-end
  19   "junk" over dlist-push-end
  20   20 over dlist-push-end
  21   [ string? ] over dlist-pop? drop
  22   [ ] dlist-each
  23 ] unit-test
  24
  25 [ "junk" ] [
  26   <dlist>
  27   5 over dlist-push-end
  28   "junk" over dlist-push-end
  29   20 over dlist-push-end
  30   [ integer? ] over dlist-pop? drop
  31   [ integer? ] over dlist-pop? drop
  32   [ ] dlist-each
  33 ] unit-test
  34
  35 [ t ] [
  36   <dlist>
  37   5 over dlist-push-end
  38   "junk" over dlist-push-end
  39   20 over dlist-push-end
  40   [ string? ] swap dlist-pred?
  41 ] unit-test
  42
  43 [ t ] [
  44   <dlist>
  45   5 over dlist-push-end
  46   "junk" over dlist-push-end
  47   20 over dlist-push-end
  48   [ integer? ] swap dlist-pred?
  49 ] unit-test
  50
  51 [ f ] [
  52   <dlist>
  53   5 over dlist-push-end
  54   "junk" over dlist-push-end
  55   20 over dlist-push-end
  56   [ string? ] over dlist-pop? drop
  57   [ string? ] swap dlist-pred?
  58 ] unit-test
  59
  60 [ V{ 1 2 3 } ] [
  61   0 <vector>
  62   make-mailbox
  63   2dup [ mailbox-get swap push ] curry curry in-thread
  64   2dup [ mailbox-get swap push ] curry curry in-thread
  65   2dup [ mailbox-get swap push ] curry curry in-thread
  66   1 over mailbox-put
  67   2 over mailbox-put
  68   3 swap mailbox-put
  69 ] unit-test
  70
  71 [ V{ 1 2 3 } ] [
  72   0 <vector>
  73   make-mailbox
  74   2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
  75   2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
  76   2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
  77   1 over mailbox-put
  78   2 over mailbox-put
  79   3 swap mailbox-put
  80 ] unit-test
  81
  82 [ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
  83   0 <vector>
  84   make-mailbox
  85   2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
  86   2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
  87   2dup [ [ string? ] swap mailbox-get? swap push ] curry curry in-thread
  88   2dup [ [ string? ] swap mailbox-get? swap push ] curry curry in-thread
  89   1 over mailbox-put
  90   "junk" over mailbox-put
  91   [ 456 ] over mailbox-put
  92   3 over mailbox-put
  93   "junk2" over mailbox-put
  94   mailbox-get
  95 ] unit-test
  96
  97 [ "test" ] [
  98   [ self ] "test" with-process
  99 ] unit-test
 100
 101
 102 [ "received" ] [
 103   [
 104     receive {
 105       { { ?from ?tag _ } [ ?tag "received" 2array ?from send ] }
 106     } match-cond
 107   ] spawn
 108   "sent" swap send-synchronous
 109 ] unit-test
 110
 111 [ 1 3 2 ] [
 112   1 self send
 113   2 self send
 114   3 self send
 115   receive
 116   [ 2 mod 0 = not ] receive-if
 117   receive
 118 ] unit-test
 119
 120
 121 [ "crash" ] [
 122   [
 123     [
 124       "crash" throw
 125     ] spawn-link drop
 126     receive
 127   ]
 128   catch
 129 ] unit-test
 130
 131 [ 50 ] [
 132   [ 50 ] future ?future
 133 ] unit-test
 134
 135 [ V{ 50 50 50 } ] [
 136   0 <vector>
 137   <promise>
 138   2dup [ ?promise swap push ] curry curry spawn drop
 139   2dup [ ?promise swap push ] curry curry spawn drop
 140   2dup [ ?promise swap push ] curry curry spawn drop
 141   50 swap fulfill
 142 ] unit-test
 143
 144 MATCH-VARS: ?value ;
 145 SYMBOL: increment
 146 SYMBOL: decrement
 147 SYMBOL: value
 148
 149 : counter ( value -- )
 150   receive {
 151     { { increment ?value } [ ?value + counter ] }
 152     { { decrement ?value } [ ?value - counter ] }
 153     { { value ?from }      [ dup ?from send counter ] }
 154   } match-cond ;
 155
 156 [ -5 ] [
 157   [ 0 counter ] spawn
 158   { increment 10 } over send
 159   { decrement 15 } over send
 160   [ value , self , ] { } make swap send
 161   receive
 162 ] unit-test