extra/concurrency/semaphores/semaphores.factor

   1 ! Copyright (C) 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: dlists kernel threads math concurrency.conditions\r
   4 continuations ;\r
   5 IN: concurrency.semaphores\r
   6 \r
   7 TUPLE: semaphore count threads ;\r
   8 \r
   9 : <semaphore> ( n -- semaphore )\r
  10     dup 0 < [ "Cannot have semaphore with negative count" throw ] when\r
  11     <dlist> semaphore boa ;\r
  12 \r
  13 : wait-to-acquire ( semaphore timeout -- )\r
  14     >r semaphore-threads r> "semaphore" wait ;\r
  15 \r
  16 : acquire-timeout ( semaphore timeout -- )\r
  17     over semaphore-count zero?\r
  18     [ dupd wait-to-acquire ] [ drop ] if\r
  19     dup semaphore-count 1- swap set-semaphore-count ;\r
  20 \r
  21 : acquire ( semaphore -- )\r
  22     f acquire-timeout ;\r
  23 \r
  24 : release ( semaphore -- )\r
  25     dup semaphore-count 1+ over set-semaphore-count\r
  26     semaphore-threads notify-1 ;\r
  27 \r
  28 : with-semaphore-timeout ( semaphore timeout quot -- )\r
  29     pick rot acquire-timeout swap\r
  30     [ release ] curry [ ] cleanup ; inline\r
  31 \r
  32 : with-semaphore ( semaphore quot -- )\r
  33     over acquire swap [ release ] curry [ ] cleanup ; inline\r