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

.gitignore

@@ -15,5 +15,7 @@ factor
 .gdb_history
 *.*.marks
 .*.swp
-reverse-complement-in.txt
+temp
-reverse-complement-out.txt
+logs
+work
+misc/wordsize

Makefile

@@ -45,7 +45,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 
 EXE_OBJS = $(PLAF_EXE_OBJS)
 
-default:
+default: misc/wordsize
+	make `./misc/target`
+
+help:
 	@echo "Run 'make' with one of the following parameters:"
 	@echo ""
 	@echo "freebsd-x86-32"
@@ -158,6 +161,9 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
 	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
 		$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
 
+misc/wordsize: misc/wordsize.c
+	gcc misc/wordsize.c -o misc/wordsize
+
 clean:
 	rm -f vm/*.o
 	rm -f factor*.dll libfactor*.*

core/heaps/heaps-docs.factor

@@ -11,69 +11,72 @@ $nl
 { $subsection min-heap? }
 { $subsection <min-heap> }
 "Max-heaps sort their elements so that the maximum element is first:"
-{ $subsection min-heap }
+{ $subsection max-heap }
-{ $subsection min-heap? }
+{ $subsection max-heap? }
-{ $subsection <min-heap> }
+{ $subsection <max-heap> }
 "Both obey a protocol."
 $nl
 "Queries:"
 { $subsection heap-empty? }
-{ $subsection heap-length }
+{ $subsection heap-size }
 { $subsection heap-peek }
 "Insertion:"
 { $subsection heap-push }
+{ $subsection heap-push* }
 { $subsection heap-push-all }
 "Removal:"
 { $subsection heap-pop* }
-{ $subsection heap-pop } ;
+{ $subsection heap-pop }
+{ $subsection heap-delete } ;
 
 ABOUT: "heaps"
 
 HELP: <min-heap>
 { $values { "min-heap" min-heap } }
-{ $description "Create a new " { $link min-heap } "." }
+{ $description "Create a new " { $link min-heap } "." } ;
-{ $see-also <max-heap> } ;
 
 HELP: <max-heap>
 { $values { "max-heap" max-heap } }
-{ $description "Create a new " { $link max-heap } "." }
+{ $description "Create a new " { $link max-heap } "." } ;
-{ $see-also <min-heap> } ;
 
 HELP: heap-push
-{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } }
+{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
-{ $description "Push an pair onto a heap.  The key must be comparable with all other keys by the " { $link <=> } " generic word." }
+{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
-{ $side-effects "heap" }
+{ $side-effects "heap" } ;
-{ $see-also heap-push-all heap-pop } ;
+
+HELP: heap-push*
+{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
+{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
+{ $side-effects "heap" } ;
 
 HELP: heap-push-all
-{ $values { "assoc" assoc } { "heap" heap } }
+{ $values { "assoc" assoc } { "heap" "a heap" } }
 { $description "Push every key/value pair of an assoc onto a heap." }
-{ $side-effects "heap" }
+{ $side-effects "heap" } ;
-{ $see-also heap-push heap-pop } ;
 
 HELP: heap-peek
-{ $values { "heap" heap } { "key" object } { "value" object } }
+{ $values { "heap" "a heap" } { "key" object } { "value" object } }
-{ $description "Outputs the first element in the heap, leaving it in the heap." }
+{ $description "Output the first element in the heap, leaving it in the heap." } ;
-{ $see-also heap-pop heap-pop* } ;
 
 HELP: heap-pop*
-{ $values { "heap" heap } }
+{ $values { "heap" "a heap" } }
-{ $description "Removes the first element from the heap." }
+{ $description "Remove the first element from the heap." }
-{ $side-effects "heap" }
+{ $side-effects "heap" } ;
-{ $see-also heap-pop heap-push heap-peek } ;
 
 HELP: heap-pop
-{ $values { "heap" heap } { "key" object } { "value" object } }
+{ $values { "heap" "a heap" } { "key" object } { "value" object } }
-{ $description "Outputs the first element in the heap and removes it from the heap." }
+{ $description "Output and remove the first element in the heap." }
-{ $side-effects "heap" }
+{ $side-effects "heap" } ;
-{ $see-also heap-pop* heap-push heap-peek } ;
 
 HELP: heap-empty?
-{ $values { "heap" heap } { "?" "a boolean" } }
+{ $values { "heap" "a heap" } { "?" "a boolean" } }
-{ $description "Tests if a " { $link heap } " has no nodes." }
+{ $description "Tests if a heap has no nodes." } ;
-{ $see-also heap-length heap-peek } ;
 
-HELP: heap-length
+HELP: heap-size
-{ $values { "heap" heap } { "n" integer } }
+{ $values { "heap" "a heap" } { "n" integer } }
-{ $description "Returns the number of key/value pairs in the heap." }
+{ $description "Returns the number of key/value pairs in the heap." } ;
-{ $see-also heap-empty? } ;
+
+HELP: heap-delete
+{ $values { "heap" "a heap" } { "key" object } { "value" object } }
+{ $description "Output and remove the first element in the heap." }
+{ $side-effects "heap" } ;

core/heaps/heaps-tests.factor

@@ -1,8 +1,8 @@
-! Copyright 2007 Ryan Murphy
+! Copyright 2007, 2008 Ryan Murphy, Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: arrays kernel math namespaces tools.test
-heaps heaps.private ;
+heaps heaps.private math.parser random assocs sequences sorting ;
 IN: temporary
 
 [ <min-heap> heap-pop ] must-fail
@@ -15,16 +15,8 @@ IN: temporary
 
 ! Binary Min Heap
 { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
-{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test
+{ t } [ t 5 <entry> t 3 <entry> T{ min-heap } heap-compare ] unit-test
-{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test
+{ f } [ t 5 <entry> t 3 <entry> T{ max-heap } heap-compare ] unit-test
-
-[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ]
-[ <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test
-
-[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [
-    <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all
-    3 [ dup heap-pop* ] times
-] unit-test
 
 [ t 2 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test
 
@@ -32,18 +24,51 @@ IN: temporary
 
 [ t 400 ] [ <max-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
 
-[ 0 ] [ <max-heap> heap-length ] unit-test
+[ 0 ] [ <max-heap> heap-size ] unit-test
-[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test
+[ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
 
-[ { { 1 2 } { 3 4 } { 5 6 } } ] [
+: heap-sort ( alist -- keys )
-    T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
+    <min-heap> [ heap-push-all ] keep heap-pop-all ;
-    [ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make
+
-] unit-test
+: random-alist ( n -- alist )
-[ { { 1 2 } } ] [
+    [
-    T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
+        [
-    [ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make
+            (random) dup number>string swap set
-] unit-test
+        ] times
-[ { } ] [
+    ] H{ } make-assoc ;
-    T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
+
-    [ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make
+: test-heap-sort ( n -- ? )
-] unit-test
+    random-alist dup >alist sort-keys swap heap-sort = ;
+
+14 [
+    [ t ] swap [ 2^ test-heap-sort ] curry unit-test
+] each
+
+: test-entry-indices ( n -- ? )
+    random-alist
+    <min-heap> [ heap-push-all ] keep
+    heap-data dup length swap [ entry-index ] map sequence= ;
+
+14 [
+    [ t ] swap [ 2^ test-entry-indices ] curry unit-test
+] each
+
+: delete-random ( seq -- elt )
+    dup length random dup pick nth >r swap delete-nth r> ;
+
+: sort-entries ( entries -- entries' )
+    [ [ entry-key ] compare ] sort ;
+
+: delete-test ( n -- ? )
+    [
+        random-alist
+        <min-heap> [ heap-push-all ] keep
+        dup heap-data clone swap
+    ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
+    heap-data
+    [ [ entry-key ] map ] 2apply
+    [ natural-sort ] 2apply ;
+
+11 [
+    [ t ] swap [ 2^ delete-test sequence= ] curry unit-test
+] each

core/heaps/heaps.factor

@@ -1,26 +1,31 @@
-! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
+! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
+! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences arrays assocs ;
+USING: kernel math sequences arrays assocs sequences.private
+growable ;
 IN: heaps
 
 MIXIN: priority-queue
 
-GENERIC: heap-push ( value key heap -- )
+GENERIC: heap-push* ( value key heap -- entry )
 GENERIC: heap-peek ( heap -- value key )
 GENERIC: heap-pop* ( heap -- )
 GENERIC: heap-pop ( heap -- value key )
-GENERIC: heap-delete ( key heap -- )
+GENERIC: heap-delete ( entry heap -- )
-GENERIC: heap-delete* ( key heap -- old ? )
 GENERIC: heap-empty? ( heap -- ? )
-GENERIC: heap-length ( heap -- n )
+GENERIC: heap-size ( heap -- n )
-GENERIC# heap-pop-while 2 ( heap pred quot -- )
 
 <PRIVATE
-TUPLE: heap data ;
+
+: heap-data delegate ; inline
 
 : <heap> ( class -- heap )
-    >r V{ } clone heap construct-boa r>
+    >r V{ } clone r> construct-delegate ; inline
-    construct-delegate ; inline
+
+TUPLE: entry value key index ;
+
+: <entry> ( value key -- entry ) f entry construct-boa ;
+
 PRIVATE>
 
 TUPLE: min-heap ;
@@ -34,23 +39,67 @@ TUPLE: max-heap ;
 INSTANCE: min-heap priority-queue
 INSTANCE: max-heap priority-queue
 
+M: priority-queue heap-empty? ( heap -- ? )
+    heap-data empty? ;
+
+M: priority-queue heap-size ( heap -- n )
+    heap-data length ;
+
 <PRIVATE
-: left ( n -- m ) 2 * 1+ ; inline
+
-: right ( n -- m ) 2 * 2 + ; inline
+: left ( n -- m ) 1 shift 1 + ; inline
-: up ( n -- m ) 1- 2 /i ; inline
+
-: left-value ( n heap -- obj ) >r left r> nth ; inline
+: right ( n -- m ) 1 shift 2 + ; inline
-: right-value ( n heap -- obj ) >r right r> nth ; inline
+
-: up-value ( n vec -- obj ) >r up r> nth ; inline
+: up ( n -- m ) 1- 2/ ; inline
-: swap-up ( n vec -- ) >r dup up r> exchange ; inline
+
-: last-index ( vec -- n ) length 1- ; inline
+: data-nth ( n heap -- entry )
+    heap-data nth-unsafe ; inline
+
+: up-value ( n heap -- entry )
+    >r up r> data-nth ; inline
+
+: left-value ( n heap -- entry )
+    >r left r> data-nth ; inline
+
+: right-value ( n heap -- entry )
+    >r right r> data-nth ; inline
+
+: data-set-nth ( entry n heap -- )
+    >r [ swap set-entry-index ] 2keep r>
+    heap-data set-nth-unsafe ;
+
+: data-push ( entry heap -- n )
+    dup heap-size [
+        swap 2dup heap-data ensure 2drop data-set-nth
+    ] keep ; inline
+
+: data-pop ( heap -- entry )
+    heap-data pop ; inline
+
+: data-pop* ( heap -- )
+    heap-data pop* ; inline
+
+: data-peek ( heap -- entry )
+    heap-data peek ; inline
+
+: data-first ( heap -- entry )
+    heap-data first ; inline
+
+: data-exchange ( m n heap -- )
+    [ tuck data-nth >r data-nth r> ] 3keep
+    tuck >r >r data-set-nth r> r> data-set-nth ; inline
 
 GENERIC: heap-compare ( pair1 pair2 heap -- ? )
-: (heap-compare) drop [ first ] compare 0 ; inline
+
+: (heap-compare) drop [ entry-key ] compare 0 ; inline
+
 M: min-heap heap-compare (heap-compare) > ;
+
 M: max-heap heap-compare (heap-compare) < ;
 
 : heap-bounds-check? ( m heap -- ? )
-    heap-data length >= ; inline
+    heap-size >= ; inline
 
 : left-bounds-check? ( m heap -- ? )
     >r left r> heap-bounds-check? ; inline
@@ -58,41 +107,44 @@ M: max-heap heap-compare (heap-compare) < ;
 : right-bounds-check? ( m heap -- ? )
     >r right r> heap-bounds-check? ; inline
 
-: up-heap-continue? ( vec heap -- ? )
+: continue? ( m up[m] heap -- ? )
-    >r [ last-index ] keep [ up-value ] keep peek r>
+    [ data-nth swap ] keep [ data-nth ] keep
     heap-compare ; inline
 
-: up-heap ( vec heap -- )
+DEFER: up-heap
-    2dup up-heap-continue?  [
+
-        >r dup last-index [ over swap-up ] keep
+: (up-heap) ( n heap -- )
-        up 1+ head-slice r> up-heap
+    >r dup up r>
+    3dup continue? [
+        [ data-exchange ] 2keep up-heap
     ] [
-        2drop
+        3drop
     ] if ;
 
+: up-heap ( n heap -- )
+    over 0 > [ (up-heap) ] [ 2drop ] if ;
+
 : (child) ( m heap -- n )
-    dupd
+    2dup right-value
-    [ heap-data left-value ] 2keep
+    >r 2dup left-value r>
-    [ heap-data right-value ] keep heap-compare
+    rot heap-compare
     [ right ] [ left ] if ;
 
 : child ( m heap -- n )
-    2dup right-bounds-check? [ drop left ] [ (child) ] if ;
+    2dup right-bounds-check?
+    [ drop left ] [ (child) ] if ;
 
 : swap-down ( m heap -- )
-    [ child ] 2keep heap-data exchange ;
+    [ child ] 2keep data-exchange ;
 
 DEFER: down-heap
 
-: down-heap-continue? ( heap m heap -- m heap ? )
-    [ heap-data nth ] 2keep child pick
-    dupd [ heap-data nth swapd ] keep heap-compare ;
-
 : (down-heap) ( m heap -- )
-    2dup down-heap-continue? [
+    [ child ] 2keep swapd
-        -rot [ swap-down ] keep down-heap
+    3dup continue? [
-    ] [
         3drop
+    ] [
+        [ data-exchange ] 2keep down-heap
     ] if ;
 
 : down-heap ( m heap -- )
@@ -100,40 +152,37 @@ DEFER: down-heap
 
 PRIVATE>
 
-M: priority-queue heap-push ( value key heap -- )
+M: priority-queue heap-push* ( value key heap -- entry )
-    >r swap 2array r>
+    >r <entry> dup r> [ data-push ] keep up-heap ;
-    [ heap-data push ] keep
+
-    [ heap-data ] keep
+: heap-push ( value key heap -- ) heap-push* drop ;
-    up-heap ;
 
 : heap-push-all ( assoc heap -- )
     [ swapd heap-push ] curry assoc-each ;
 
+: >entry< ( entry -- key value )
+    { entry-value entry-key } get-slots ;
+
 M: priority-queue heap-peek ( heap -- value key )
-    heap-data first first2 swap ;
+    data-first >entry< ;
+
+M: priority-queue heap-delete ( entry heap -- )
+    >r entry-index r>
+    2dup heap-size 1- = [
+        nip data-pop*
+    ] [
+        [ nip data-pop ] 2keep
+        [ data-set-nth ] 2keep
+        down-heap
+    ] if ;
 
 M: priority-queue heap-pop* ( heap -- )
-    dup heap-data length 1 > [
+    dup data-first swap heap-delete ;
-        [ heap-data pop ] keep
-        [ heap-data set-first ] keep
-        0 swap down-heap
-    ] [
-        heap-data pop*
-    ] if ;
 
-M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
+M: priority-queue heap-pop ( heap -- value key )
+    dup data-first [ swap heap-delete ] keep >entry< ;
 
-M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ;
+: heap-pop-all ( heap -- alist )
-
+    [ dup heap-empty? not ]
-M: priority-queue heap-length ( heap -- n ) heap-data length ;
+    [ dup heap-pop swap 2array ]
-
+    [ ] unfold nip ;
-: (heap-pop-while) ( heap pred quot -- )
-    pick heap-empty? [
-        3drop
-    ] [
-        [ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep
-        roll [ (heap-pop-while) ] [ 3drop ] if
-    ] if ;
-
-M: priority-queue heap-pop-while ( heap pred quot -- )
-    [ heap-pop ] swap [ t ] 3compose (heap-pop-while) ;

core/inference/class/class-tests.factor

@@ -288,3 +288,10 @@ cell-bits 32 = [
     [ HEX: ff bitand 0 HEX: ff between? ]
     \ >= inlined?
 ] unit-test
+
+[ t ] [
+    [ HEX: ff swap HEX: ff bitand >= ]
+    \ >= inlined?
+] unit-test
+
+

core/io/files/files.factor

@@ -154,3 +154,11 @@ M: pathname <=> [ pathname-string ] compare ;
 
 : with-file-appender ( path quot -- )
     >r <file-appender> r> with-stream ; inline
+
+: temp-directory ( -- path )
+    "temp" resource-path
+    dup exists? not
+      [ dup make-directory ]
+    when ;
+
+: temp-file ( name -- path ) temp-directory swap path+ ;

core/io/streams/c/c-tests.factor

@@ -2,9 +2,9 @@ USING: tools.test io.files io io.streams.c ;
 IN: temporary
 
 [ "hello world" ] [
-    "test.txt" resource-path [
+    "test.txt" temp-file [
         "hello world" write
     ] with-file-writer
 
-    "test.txt" resource-path "rb" fopen <c-reader> contents
+    "test.txt" temp-file "rb" fopen <c-reader> contents
 ] unit-test

core/io/streams/c/c.factor

@@ -64,7 +64,7 @@ M: object init-stdio
     stdin-handle stdout-handle <duplex-c-stream> stdio set-global
     stderr-handle <c-writer> <plain-writer> stderr set-global ;
 
-M: object io-multiplex (sleep) ;
+M: object io-multiplex 60 60 * 1000 * or (sleep) ;
 
 M: object <file-reader>
     "rb" fopen <c-reader> <line-reader> ;

core/io/thread/thread.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.thread
-USING: threads io.backend namespaces init ;
+USING: threads io.backend namespaces init math ;
 
 : io-thread ( -- )
     sleep-time io-multiplex yield ;

core/layouts/layouts.factor

@@ -32,3 +32,7 @@ SYMBOL: type-numbers
 
 : most-negative-fixnum ( -- n )
     first-bignum neg ;
+
+M: real >integer
+    dup most-negative-fixnum most-positive-fixnum between?
+    [ >fixnum ] [ >bignum ] if ;

core/math/integers/integers-docs.factor

@@ -14,6 +14,7 @@ $nl
 { $subsection fixnum? }
 { $subsection bignum? }
 { $subsection >fixnum }
+{ $subsection >integer }
 { $subsection >bignum }
 { $see-also "prettyprint-numbers" "modular-arithmetic" "bitwise-arithmetic" "integer-functions" "syntax-integers" } ;
 

core/math/integers/integers.factor

@@ -6,6 +6,7 @@ IN: math.integers.private
 
 M: integer numerator ;
 M: integer denominator drop 1 ;
+M: integer >integer ;
 
 M: fixnum >fixnum ;
 M: fixnum >bignum fixnum>bignum ;

core/math/math.factor

@@ -5,6 +5,7 @@ IN: math
 
 GENERIC: >fixnum ( x -- y ) foldable
 GENERIC: >bignum ( x -- y ) foldable
+GENERIC: >integer ( x -- y ) foldable
 GENERIC: >float ( x -- y ) foldable
 
 MATH: number= ( x y -- ? ) foldable

core/optimizer/math/math.factor

@@ -379,7 +379,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
     >r dup dup node-in-d first node-interval
     swap dup node-in-d second node-literal r> execute ; inline
 
-: foldable-comparison? ( #call word -- )
+: foldable-comparison? ( #call word -- ? )
     >r dup known-comparison? [
         r> perform-comparison incomparable eq? not
     ] [

core/threads/threads-docs.factor

@@ -17,7 +17,11 @@ ARTICLE: "threads-start/stop" "Starting and stopping threads"
 ARTICLE: "threads-yield" "Yielding and suspending threads"
 "Yielding to other threads:"
 { $subsection yield }
+"Sleeping for a period of time:"
 { $subsection sleep }
+"Interruptible sleep:"
+{ $subsection nap }
+{ $subsection interrupt }
 "Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
 { $subsection suspend }
 { $subsection resume }
@@ -104,7 +108,16 @@ HELP: yield
 
 HELP: sleep
 { $values { "ms" "a non-negative integer" } }
-{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds. It will not get woken up before this time period elapses, but since the multitasker is co-operative, the precise wakeup time is dependent on when other threads yield." } ;
+{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." }
+{ $errors "Throws an error if another thread interrupted the sleep with " { $link interrupt } "." } ;
+
+HELP: nap
+{ $values { "ms/f" "a non-negative integer or " { $link f } } { "?" "a boolean indicating whether the thread was interrupted" } }
+{ $description "Suspends the current thread until another thread interrupts it with " { $link interrupt } ". If the input parameter is not " { $link f } ", then the thread will also wake up if the timeout expires before an interrupt is received." } ;
+
+HELP: interrupt
+{ $values { "thread" thread } }
+{ $description "Interrupts a sleeping thread." } ;
 
 HELP: suspend
 { $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } }

core/threads/threads.factor

@@ -13,7 +13,7 @@ TUPLE: thread
 name quot error-handler exit-handler
 id
 continuation state
-mailbox variables ;
+mailbox variables sleep-entry ;
 
 : self ( -- thread ) 40 getenv ; inline
 
@@ -86,19 +86,25 @@ PRIVATE>
 <PRIVATE
 
 : schedule-sleep ( thread ms -- )
-    >r check-registered r> sleep-queue heap-push ;
+    >r check-registered dup r> sleep-queue heap-push*
+    swap set-thread-sleep-entry ;
 
-: wake-up? ( heap -- ? )
+: expire-sleep? ( heap -- ? )
     dup heap-empty?
     [ drop f ] [ heap-peek nip millis <= ] if ;
 
-: wake-up ( -- )
+: expire-sleep ( thread -- )
+    f over set-thread-sleep-entry resume ;
+
+: expire-sleep-loop ( -- )
     sleep-queue
-    [ dup wake-up? ] [ dup heap-pop drop resume ] [ ] while
+    [ dup expire-sleep? ]
+    [ dup heap-pop drop expire-sleep ]
+    [ ] while
     drop ;
 
 : next ( -- )
-    wake-up
+    expire-sleep-loop
     run-queue pop-back
     dup array? [ first2 ] [ f swap ] if dup set-self
     f over set-thread-state
@@ -107,7 +113,7 @@ PRIVATE>
 
 PRIVATE>
 
-: sleep-time ( -- ms )
+: sleep-time ( -- ms/f )
     {
         { [ run-queue dlist-empty? not ] [ 0 ] }
         { [ sleep-queue heap-empty? ] [ f ] }
@@ -127,14 +133,36 @@ PRIVATE>
 
 : yield ( -- ) [ resume ] "yield" suspend drop ;
 
-: sleep ( ms -- )
+GENERIC: nap-until ( time -- ? )
-    >fixnum millis +
+
-    [ schedule-sleep ] curry
+M: integer nap-until [ schedule-sleep ] curry "sleep" suspend ;
-    "sleep" suspend drop ;
+
+M: f nap-until drop [ drop ] "interrupt" suspend ;
+
+GENERIC: nap ( time -- ? )
+
+M: real nap millis + >integer nap-until ;
+
+M: f nap nap-until ;
+
+: sleep-until ( time -- )
+    nap-until [ "Sleep interrupted" throw ] when ;
+
+: sleep ( time -- )
+    nap [ "Sleep interrupted" throw ] when ;
+
+: interrupt ( thread -- )
+    dup self eq? [
+        drop
+    ] [
+        dup thread-sleep-entry [ sleep-queue heap-delete ] when*
+        f over set-thread-sleep-entry
+        t swap resume-with
+    ] if ;
 
 : (spawn) ( thread -- )
     [
-        resume [
+        resume-now [
             dup set-self
             dup register-thread
             init-namespaces

cp_dir

@@ -1,5 +0,0 @@
-#!/bin/sh
-
-echo $1
-mkdir -p "`dirname \"$2\"`"
-cp "$1" "$2"

extra/alarms/alarms-docs.factor

@@ -0,0 +1,27 @@
+IN: alarms
+USING: help.markup help.syntax calendar quotations ;
+
+HELP: alarm
+{ $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ;
+
+HELP: add-alarm
+{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link dt } " or " { $link f } } { "alarm" alarm } }
+{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
+
+HELP: later
+{ $values { "quot" quotation } { "time" dt } { "alarm" alarm } }
+{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ;
+
+HELP: cancel-alarm
+{ $values { "alarm" alarm } }
+{ $description "Cancels an alarm." }
+{ $errors "Throws an error if the alarm is not active." } ;
+
+ARTICLE: "alarms" "Alarms"
+"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
+{ $subsection alarm }
+{ $subsection add-alarm }
+{ $subsection later }
+{ $subsection cancel-alarm } ;
+
+ABOUT: "alarms"

extra/alarms/alarms.factor

@@ -1,87 +1,86 @@
-! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar combinators concurrency.messaging
+USING: arrays calendar combinators generic init kernel math
-threads generic init kernel math namespaces sequences ;
+namespaces sequences heaps boxes threads debugger quotations ;
 IN: alarms
 
-TUPLE: alarm time quot ;
+TUPLE: alarm quot time interval entry ;
-
-C: <alarm> alarm
 
 <PRIVATE
 
-! for now a V{ }, eventually a min-heap to store alarms
 SYMBOL: alarms
-SYMBOL: alarm-receiver
+SYMBOL: alarm-thread
-SYMBOL: alarm-looper
 
-: add-alarm ( alarm -- )
+: notify-alarm-thread ( -- )
-    alarms get-global push ;
+    alarm-thread get-global interrupt ;
 
-: remove-alarm ( alarm -- )
+: check-alarm
-    alarms get-global delete ;
+    dup dt? over not or [ "Not a dt" throw ] unless
+    over timestamp? [ "Not a timestamp" throw ] unless
+    pick callable? [ "Not a quotation" throw ] unless ; inline
 
-: handle-alarm ( alarm -- )
+: <alarm> ( quot time frequency -- alarm )
-    dup delegate {
+    check-alarm <box> alarm construct-boa ;
-        { "register" [ add-alarm ] }
-        { "unregister" [ remove-alarm  ] }
-    } case ;
-
-: expired-alarms ( -- seq )
-    now alarms get-global
-    [ alarm-time <=> 0 > ] with subset ;
-
-: unexpired-alarms ( -- seq )
-    now alarms get-global
-    [ alarm-time <=> 0 <= ] with subset ;
-
-: call-alarm ( alarm -- )
-    alarm-quot "Alarm invocation" spawn drop ;
-
-: do-alarms ( -- )
-    expired-alarms [ call-alarm ] each
-    unexpired-alarms alarms set-global ;
-
-: alarm-receive-loop ( -- )
-    receive dup alarm? [ handle-alarm ] [ drop ] if
-    alarm-receive-loop ;
-
-: start-alarm-receiver ( -- )
-    [
-        alarm-receive-loop
-    ] "Alarm receiver" spawn alarm-receiver set-global ;
-
-: alarm-loop ( -- )
-    alarms get-global empty? [
-        do-alarms
-    ] unless 100 sleep alarm-loop ;
-
-: start-alarm-looper ( -- )
-    [
-        alarm-loop
-    ] "Alarm looper" spawn alarm-looper set-global ;
-
-: send-alarm ( str alarm -- )
-    over set-delegate
-    alarm-receiver get-global send ;
-
-: start-alarm-daemon ( -- )
-    alarms get-global [ V{ } clone alarms set-global ] unless
-    start-alarm-looper
-    start-alarm-receiver ;
-
-[ start-alarm-daemon ] "alarms" add-init-hook
-PRIVATE>
 
 : register-alarm ( alarm -- )
-    "register" send-alarm ;
+    dup dup alarm-time alarms get-global heap-push*
+    swap alarm-entry >box
+    notify-alarm-thread ;
 
-: unregister-alarm ( alarm -- )
+: alarm-expired? ( alarm now -- ? )
-    "unregister" send-alarm ;
+    >r alarm-time r> <=> 0 <= ;
 
-: change-alarm ( alarm-old alarm-new -- )
+: reschedule-alarm ( alarm -- )
-    "register" send-alarm
+    dup alarm-time over alarm-interval +dt
-    "unregister" send-alarm ;
+    over set-alarm-time
+    register-alarm ;
 
-! Example:
+: call-alarm ( alarm -- )
-! 5 seconds from-now [ "hi" print flush ] <alarm> register-alarm
+    dup alarm-quot try
+    dup alarm-entry box> drop
+    dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
+
+: (trigger-alarms) ( alarms now -- )
+    over heap-empty? [
+        2drop
+    ] [
+        over heap-peek drop over alarm-expired? [
+            over heap-pop drop call-alarm
+            (trigger-alarms)
+        ] [
+            2drop
+        ] if
+    ] if ;
+
+: trigger-alarms ( alarms -- )
+    now (trigger-alarms) ;
+
+: next-alarm ( alarms -- ms )
+    dup heap-empty?
+    [ drop f ]
+    [ heap-peek drop alarm-time now timestamp- 1000 * 0 max ]
+    if ;
+
+: alarm-thread-loop ( -- )
+    alarms get-global
+    dup next-alarm nap drop
+    dup trigger-alarms
+    alarm-thread-loop ;
+
+: init-alarms ( -- )
+    <min-heap> alarms set-global
+    [ alarm-thread-loop ] "Alarms" spawn
+    alarm-thread set-global ;
+
+[ init-alarms ] "alarms" add-init-hook
+
+PRIVATE>
+
+: add-alarm ( quot time frequency -- alarm )
+    <alarm> [ register-alarm ] keep ;
+
+: later ( quot dt -- alarm )
+    from-now f add-alarm ;
+
+: cancel-alarm ( alarm -- )
+    alarm-entry box> alarms get-global heap-delete ;

extra/benchmark/mandel/mandel.factor

@@ -65,7 +65,7 @@ SYMBOL: cols
     ] with-scope ;
 
 : mandel-main ( -- )
-    "mandel.ppm" resource-path
+    "mandel.ppm" temp-file
     [ mandel write ] with-file-writer ;
 
 MAIN: mandel-main

extra/benchmark/raytracer/raytracer.factor

@@ -170,7 +170,7 @@ DEFER: create ( level c r -- scene )
     ] "" make ;
 
 : raytracer-main
-    "raytracer.pnm" resource-path
+    "raytracer.pnm" temp-file
     [ run write ] with-file-writer ;
 
 MAIN: raytracer-main

extra/benchmark/reverse-complement/reverse-complement.factor

@@ -41,12 +41,10 @@ HINTS: do-line vector string ;
     ] with-disposal ;
 
 : reverse-complement-in
-    "extra/benchmark/reverse-complement/reverse-complement-in.txt"
+    "reverse-complement-in.txt" temp-file ;
-    resource-path ;
 
 : reverse-complement-out
-    "extra/benchmark/reverse-complement/reverse-complement-out.txt"
+    "reverse-complement-out.txt" temp-file ;
-    resource-path ;
 
 : reverse-complement-main ( -- )
     reverse-complement-in

extra/builder/util/util.factor

@@ -99,3 +99,9 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
   [ file-lines ] [ ] bi*
   maybe-tail*
   [ print ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: prettyprint
+
+: to-file ( object file -- ) [ . ] with-file-writer ;

extra/bunny/bunny.factor

@@ -1,6 +1,6 @@
 USING: alien alien.c-types arrays sequences math
 math.vectors math.matrices math.parser io io.files kernel opengl
-opengl.gl opengl.glu shuffle http.client vectors timers
+opengl.gl opengl.glu shuffle http.client vectors
 namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
 combinators tools.time system combinators.lib combinators.cleave
 float-arrays continuations opengl.demo-support multiline

extra/calendar/calendar.factor

@@ -5,7 +5,7 @@ USING: arrays hashtables io io.streams.string kernel math
 math.vectors math.functions math.parser namespaces sequences
 strings tuples system debugger combinators vocabs.loader
 calendar.backend structs alien.c-types math.vectors
-math.ranges shuffle ;
+shuffle threads ;
 IN: calendar
 
 TUPLE: timestamp year month day hour minute second gmt-offset ;
@@ -225,6 +225,12 @@ M: timestamp <=> ( ts1 ts2 -- n )
 : unix-1970 ( -- timestamp )
     1970 1 1 0 0 0 0 <timestamp> ;
 
+: millis>timestamp ( n -- timestamp )
+    >r unix-1970 r> 1000 /f seconds +dt ;
+
+: timestamp>millis ( timestamp -- n )
+    unix-1970 timestamp- 1000 * >integer ;
+
 : unix-time>timestamp ( n -- timestamp )
     >r unix-1970 r> seconds +dt ;
 
@@ -467,6 +473,10 @@ M: timestamp year. ( timestamp -- )
 : seconds-since-midnight ( timestamp -- x )
     dup beginning-of-day timestamp- ;
 
+M: timestamp nap-until timestamp>millis nap-until ;
+
+M: dt nap from-now nap-until ;
+
 {
     { [ unix? ] [ "calendar.unix" ] }
     { [ windows? ] [ "calendar.windows" ] }

extra/concurrency/combinators/combinators-tests.factor

@@ -1,6 +1,6 @@
 IN: temporary
 USING: concurrency.combinators tools.test random kernel math 
-concurrency.messaging threads sequences ;
+concurrency.mailboxes threads sequences ;
 
 [ [ drop ] parallel-each ] must-infer
 [ [ ] parallel-map ] must-infer

extra/concurrency/conditions/conditions.factor

@@ -1,14 +1,27 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: dlists threads kernel arrays sequences ;
+USING: dlists dlists.private threads kernel arrays sequences
+alarms ;
 IN: concurrency.conditions
 
 : notify-1 ( dlist -- )
-    dup dlist-empty?
+    dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;
-    [ drop ] [ pop-back second resume-now ] if ;
 
 : notify-all ( dlist -- )
-    [ second resume-now ] dlist-slurp yield ;
+    [ resume-now ] dlist-slurp yield ;
+
+: queue-timeout ( queue timeout -- alarm )
+    #! Add an alarm which removes the current thread from the
+    #! queue, and resumes it, passing it a value of t.
+    >r self over push-front* [
+        tuck delete-node
+        dlist-node-obj t swap resume-with
+    ] 2curry r> later ;
 
 : wait ( queue timeout status -- )
-    >r [ 2array swap push-front ] r> suspend 3drop ; inline
+    over [
+        >r queue-timeout [ drop ] r> suspend
+        [ "Timeout" throw ] [ cancel-alarm ] if
+    ] [
+        >r drop [ push-front ] curry r> suspend drop
+    ] if ;

extra/concurrency/count-downs/count-downs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: dlists kernel math concurrency.promises
-concurrency.messaging ;
+concurrency.mailboxes ;
 IN: concurrency.count-downs
 
 ! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html

extra/concurrency/futures/futures.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: concurrency.promises concurrency.messaging kernel arrays
+USING: concurrency.promises concurrency.mailboxes kernel arrays
 continuations ;
 IN: concurrency.futures
 
@@ -11,7 +11,7 @@ IN: concurrency.futures
     ] keep ; inline
 
 : ?future-timeout ( future timeout -- value )
-    ?promise-timeout ;
+    ?promise-timeout ?linked ;
 
 : ?future ( future -- value )
-    ?promise ;
+    ?promise ?linked ;

extra/concurrency/locks/locks-tests.factor

@@ -1,6 +1,7 @@
 IN: temporary
 USING: tools.test concurrency.locks concurrency.count-downs
-locals kernel threads sequences ;
+concurrency.messaging concurrency.mailboxes locals kernel
+threads sequences calendar ;
 
 :: lock-test-0 | |
     [let | v [ V{ } clone ]
@@ -32,7 +33,7 @@ locals kernel threads sequences ;
            c [ 2 <count-down> ] |
 
            [
-               l f [
+               l [
                    yield
                    1 v push
                    yield
@@ -42,7 +43,7 @@ locals kernel threads sequences ;
            ] "Lock test 1" spawn drop
 
            [
-               l f [
+               l [
                    yield
                    3 v push
                    yield
@@ -59,8 +60,8 @@ locals kernel threads sequences ;
 [ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
 
 [ 3 ] [
-    <reentrant-lock> dup f [
+    <reentrant-lock> dup [
-        f [
+        [
             3
         ] with-lock
     ] with-lock
@@ -68,15 +69,15 @@ locals kernel threads sequences ;
 
 [ ] [ <rw-lock> drop ] unit-test
 
-[ ] [ <rw-lock> f [ ] with-read-lock ] unit-test
+[ ] [ <rw-lock> [ ] with-read-lock ] unit-test
 
-[ ] [ <rw-lock> dup f [ f [ ] with-read-lock ] with-read-lock ] unit-test
+[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test
 
-[ ] [ <rw-lock> f [ ] with-write-lock ] unit-test
+[ ] [ <rw-lock> [ ] with-write-lock ] unit-test
 
-[ ] [ <rw-lock> dup f [ f [ ] with-write-lock ] with-write-lock ] unit-test
+[ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test
 
-[ ] [ <rw-lock> dup f [ f [ ] with-read-lock ] with-write-lock ] unit-test
+[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
 
 :: rw-lock-test-1 | |
     [let | l [ <rw-lock> ]
@@ -86,7 +87,7 @@ locals kernel threads sequences ;
            v [ V{ } clone ] |
 
            [
-               l f [
+               l [
                    1 v push
                    c count-down
                    yield
@@ -97,7 +98,7 @@ locals kernel threads sequences ;
 
            [
                c await
-               l f [
+               l [
                    4 v push
                    1000 sleep
                    5 v push
@@ -107,7 +108,7 @@ locals kernel threads sequences ;
 
            [
                c await
-               l f [
+               l [
                    2 v push
                    c' count-down
                ] with-read-lock
@@ -116,7 +117,7 @@ locals kernel threads sequences ;
 
            [
                c' await
-               l f [
+               l [
                    6 v push
                ] with-write-lock
                c'' count-down
@@ -135,7 +136,7 @@ locals kernel threads sequences ;
            v [ V{ } clone ] |
 
            [
-               l f [
+               l [
                    1 v push
                    c count-down
                    1000 sleep
@@ -146,7 +147,7 @@ locals kernel threads sequences ;
 
            [
                c await
-               l f [
+               l [
                    3 v push
                ] with-read-lock
                c' count-down
@@ -157,3 +158,21 @@ locals kernel threads sequences ;
     ] ;
 
 [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
+
+! Test lock timeouts
+:: lock-timeout-test | |
+    [let | l [ <lock> ] |
+        [
+            l [ 1 seconds sleep ] with-lock
+        ] "Lock holder" spawn drop
+
+        [
+            l 1/10 seconds [ ] with-lock-timeout
+        ] "Lock timeout-er" spawn-linked drop
+
+        receive
+    ] ;
+
+[ lock-timeout-test ] [
+    linked-thread thread-name "Lock timeout-er" =
+] must-fail-with

extra/concurrency/locks/locks.factor

@@ -25,15 +25,15 @@ TUPLE: lock threads owner reentrant? ;
     lock-threads notify-1 ;
 
 : do-lock ( lock timeout quot acquire release -- )
-    >r swap compose pick >r 2curry r> r> curry [ ] cleanup ;
+    >r >r pick rot r> call ! use up  timeout acquire
-    inline
+    swap r> curry [ ] cleanup ; inline
 
 : (with-lock) ( lock timeout quot -- )
     [ acquire-lock ] [ release-lock ] do-lock ; inline
 
 PRIVATE>
 
-: with-lock ( lock timeout quot -- )
+: with-lock-timeout ( lock timeout quot -- )
     pick lock-reentrant? [
         pick lock-owner self eq? [
             2nip call
@@ -44,6 +44,9 @@ PRIVATE>
         (with-lock)
     ] if ; inline
 
+: with-lock ( lock quot -- )
+    f swap with-lock-timeout ; inline
+
 ! Many-reader/single-writer locks
 TUPLE: rw-lock readers writers reader# writer ;
 
@@ -79,12 +82,18 @@ TUPLE: rw-lock readers writers reader# writer ;
 
 PRIVATE>
 
-: with-read-lock ( lock timeout quot -- )
+: with-read-lock-timeout ( lock timeout quot -- )
     [
         [ acquire-read-lock ] [ release-read-lock ] do-lock
     ] do-reentrant-rw-lock ; inline
 
-: with-write-lock ( lock timeout quot -- )
+: with-read-lock ( lock quot -- )
+    f swap with-read-lock-timeout ; inline
+
+: with-write-lock-timeout ( lock timeout quot -- )
     [
         [ acquire-write-lock ] [ release-write-lock ] do-lock
     ] do-reentrant-rw-lock ; inline
+
+: with-write-lock ( lock quot -- )
+    f swap with-write-lock-timeout ; inline

extra/concurrency/mailboxes/mailboxes-docs.factor

@@ -0,0 +1,75 @@
+USING: help.markup help.syntax kernel arrays ;
+IN: concurrency.mailboxes
+
+HELP: <mailbox>
+{ $values { "mailbox" mailbox } }
+{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ;
+
+HELP: mailbox-empty?
+{ $values { "mailbox" mailbox } 
+          { "bool" "a boolean" }
+}
+{ $description "Return true if the mailbox is empty." } ;
+
+HELP: mailbox-put
+{ $values { "obj" object } 
+          { "mailbox" mailbox } 
+}
+{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;
+
+HELP: block-unless-pred
+{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } 
+          { "mailbox" mailbox }
+          { "timeout" "a timeout in milliseconds, or " { $link f } }
+}
+{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;
+
+HELP: block-if-empty
+{ $values { "mailbox" mailbox } 
+      { "timeout" "a timeout in milliseconds, or " { $link f } }
+}
+{ $description "Block the thread if the mailbox is empty." } ;
+
+HELP: mailbox-get
+{ $values { "mailbox" mailbox } 
+          { "obj" object }
+}
+{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ;
+
+HELP: mailbox-get-all
+{ $values { "mailbox" mailbox } 
+          { "array" array }
+}
+{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ;
+
+HELP: while-mailbox-empty
+{ $values { "mailbox" mailbox } 
+          { "quot" "a quotation with stack effect " { $snippet "( -- )" } }
+}
+{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
+
+HELP: mailbox-get?
+{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
+          { "mailbox" mailbox } 
+          { "obj" object }
+}
+{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;
+
+
+ARTICLE: "concurrency.mailboxes" "Mailboxes"
+"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error."
+{ $subsection mailbox }
+{ $subsection <mailbox> }
+"Removing the first element:"
+{ $subsection mailbox-get }
+{ $subsection mailbox-get-timeout }
+"Removing the first element matching a predicate:"
+{ $subsection mailbox-get? }
+{ $subsection mailbox-get-timeout? }
+"Emptying out a mailbox:"
+{ $subsection mailbox-get-all }
+"Adding an element:"
+{ $subsection mailbox-put }
+"Testing if a mailbox is empty:"
+{ $subsection mailbox-empty? }
+{ $subsection while-mailbox-empty } ;

extra/concurrency/mailboxes/mailboxes-tests.factor

@@ -0,0 +1,40 @@
+IN: temporary
+USING: concurrency.mailboxes vectors sequences threads
+tools.test math kernel strings ;
+
+[ V{ 1 2 3 } ] [
+    0 <vector>
+    <mailbox>
+    [ mailbox-get swap push ] in-thread
+    [ mailbox-get swap push ] in-thread
+    [ mailbox-get swap push ] in-thread
+    1 over mailbox-put
+    2 over mailbox-put
+    3 swap mailbox-put
+] unit-test
+
+[ V{ 1 2 3 } ] [
+    0 <vector>
+    <mailbox>
+    [ [ integer? ] swap mailbox-get? swap push ] in-thread
+    [ [ integer? ] swap mailbox-get? swap push ] in-thread
+    [ [ integer? ] swap mailbox-get? swap push ] in-thread
+    1 over mailbox-put
+    2 over mailbox-put
+    3 swap mailbox-put
+] unit-test
+
+[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
+    0 <vector>
+    <mailbox>
+    [ [ integer? ] swap mailbox-get? swap push ] in-thread
+    [ [ integer? ] swap mailbox-get? swap push ] in-thread
+    [ [ string? ] swap mailbox-get? swap push ] in-thread
+    [ [ string? ] swap mailbox-get? swap push ] in-thread
+    1 over mailbox-put
+    "junk" over mailbox-put
+    [ 456 ] over mailbox-put
+    3 over mailbox-put
+    "junk2" over mailbox-put
+    mailbox-get
+] unit-test

extra/concurrency/mailboxes/mailboxes.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: concurrency.mailboxes
+USING: dlists threads sequences continuations
+namespaces random math quotations words kernel arrays assocs
+init system concurrency.conditions ;
+
+TUPLE: mailbox threads data ;
+
+: <mailbox> ( -- mailbox )
+    <dlist> <dlist> mailbox construct-boa ;
+
+: mailbox-empty? ( mailbox -- bool )
+    mailbox-data dlist-empty? ;
+
+: mailbox-put ( obj mailbox -- )
+    [ mailbox-data push-front ] keep
+    mailbox-threads notify-all ;
+
+: block-unless-pred ( pred mailbox timeout -- )
+    2over mailbox-data dlist-contains? [
+        3drop
+    ] [
+        2dup >r mailbox-threads r> "mailbox" wait
+        block-unless-pred
+    ] if ; inline
+
+: block-if-empty ( mailbox timeout -- mailbox )
+    over mailbox-empty? [
+        2dup >r mailbox-threads r> "mailbox" wait
+        block-if-empty
+    ] [
+        drop
+    ] if ;
+
+: mailbox-peek ( mailbox -- obj )
+    mailbox-data peek-back ;
+
+: mailbox-get-timeout ( mailbox timeout -- obj )
+    block-if-empty mailbox-data pop-back ;
+
+: mailbox-get ( mailbox -- obj )
+    f mailbox-get-timeout ;
+
+: mailbox-get-all-timeout ( mailbox timeout -- array )
+    block-if-empty
+    [ dup mailbox-empty? ]
+    [ dup mailbox-data pop-back ]
+    [ ] unfold nip ;
+
+: mailbox-get-all ( mailbox -- array )
+    f mailbox-get-all-timeout ;
+
+: while-mailbox-empty ( mailbox quot -- )
+    over mailbox-empty? [
+        dup >r swap slip r> while-mailbox-empty
+    ] [
+        2drop
+    ] if ; inline
+
+: mailbox-get-timeout? ( pred mailbox timeout -- obj )
+    [ block-unless-pred ] 3keep drop
+    mailbox-data delete-node-if ; inline
+
+: mailbox-get? ( pred mailbox -- obj )
+    f mailbox-get-timeout? ; inline
+
+TUPLE: linked error thread ;
+
+C: <linked> linked
+
+: ?linked dup linked? [ rethrow ] when ;
+
+: spawn-linked-to ( quot name mailbox -- thread )
+    [ >r <linked> r> mailbox-put ] curry <thread>
+    [ (spawn) ] keep ;

extra/concurrency/messaging/messaging-docs.factor

@@ -4,70 +4,6 @@ USING: help.syntax help.markup concurrency.messaging.private
 threads kernel arrays quotations ;
 IN: concurrency.messaging
 
-HELP: <mailbox>
-{ $values { "mailbox" mailbox } 
-}
-{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } 
-{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
-
-HELP: mailbox-empty?
-{ $values { "mailbox" mailbox } 
-          { "bool" "a boolean" }
-}
-{ $description "Return true if the mailbox is empty." } 
-{ $see-also <mailbox> mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
-
-HELP: mailbox-put
-{ $values { "obj" object } 
-          { "mailbox" mailbox } 
-}
-{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } 
-{ $see-also <mailbox> mailbox-empty? mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
-
-HELP: block-unless-pred
-{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } 
-          { "mailbox" mailbox }
-          { "timeout" "a timeout in milliseconds, or " { $link f } }
-}
-{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } 
-{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
-
-HELP: block-if-empty
-{ $values { "mailbox" mailbox } 
-      { "timeout" "a timeout in milliseconds, or " { $link f } }
-}
-{ $description "Block the thread if the mailbox is empty." } 
-{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
-
-HELP: mailbox-get
-{ $values { "mailbox" mailbox } 
-          { "obj" object }
-}
-{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } 
-{ $see-also <mailbox> mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ;
-
-HELP: mailbox-get-all
-{ $values { "mailbox" mailbox } 
-          { "array" array }
-}
-{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } 
-{ $see-also <mailbox> mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ;
-
-HELP: while-mailbox-empty
-{ $values { "mailbox" mailbox } 
-          { "quot" "a quotation with stack effect " { $snippet "( -- )" } }
-}
-{ $description "Repeatedly call the quotation while there are no items in the mailbox." } 
-{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all mailbox-get? } ;
-
-HELP: mailbox-get?
-{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
-          { "mailbox" mailbox } 
-          { "obj" object }
-}
-{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } 
-{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ;
-
 HELP: send
 { $values { "message" object } 
           { "thread" "a thread object" } 
@@ -95,8 +31,8 @@ HELP: spawn-linked
 { $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } 
 { $see-also spawn } ;
 
-ARTICLE: { "concurrency" "mailboxes" } "Mailboxes"
+ARTICLE: { "concurrency" "messaging" } "Mailboxes"
-"Each thread has an associated message queue. Other threads can place items on this queue by sending the thread a message. A thread can check its queue for messages, blocking if none are pending, and thread them as they are queued."
+"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
 $nl
 "The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
 $nl
@@ -104,14 +40,9 @@ $nl
 { $subsection send }
 "A thread can get a message from its queue:"
 { $subsection receive }
-{ $subsection receive }
+{ $subsection receive-timeout }
 { $subsection receive-if }
-"Mailboxes can be created and used directly:"
+{ $subsection receive-if-timeout } ;
-{ $subsection mailbox }
-{ $subsection <mailbox> }
-{ $subsection mailbox-get }
-{ $subsection mailbox-put }
-{ $subsection mailbox-empty? } ;
 
 ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
 "The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
@@ -133,8 +64,6 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
 { $code "[ 1 0 / \"This will not print\" print ] spawn" } 
 "Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them."
 { $subsection spawn-linked }
-"A more flexible version of the above deposits the error in an arbitary mailbox:"
-{ $subsection spawn-linked-to }
 "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
 { $code "["
 "  [ 1 0 / \"This will not print\" print ] spawn-linked drop"
@@ -148,7 +77,7 @@ $nl
 "A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends."
 $nl
 "Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
-{ $subsection { "concurrency" "mailboxes" } }
+{ $subsection { "concurrency" "messaging" } }
 { $subsection { "concurrency" "synchronous-sends" } } 
 { $subsection { "concurrency" "exceptions" } } ;
 

extra/concurrency/messaging/messaging-tests.factor

@@ -3,48 +3,10 @@
 !
 USING: kernel threads vectors arrays sequences
 namespaces tools.test continuations dlists strings math words
-match quotations concurrency.messaging ;
+match quotations concurrency.messaging concurrency.mailboxes ;
 IN: temporary
 
-[ ] [ mailbox mailbox-data dlist-delete-all ] unit-test
+[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
-
-[ V{ 1 2 3 } ] [
-    0 <vector>
-    <mailbox>
-    [ mailbox-get swap push ] in-thread
-    [ mailbox-get swap push ] in-thread
-    [ mailbox-get swap push ] in-thread
-    1 over mailbox-put
-    2 over mailbox-put
-    3 swap mailbox-put
-] unit-test
-
-[ V{ 1 2 3 } ] [
-    0 <vector>
-    <mailbox>
-    [ [ integer? ] swap mailbox-get? swap push ] in-thread
-    [ [ integer? ] swap mailbox-get? swap push ] in-thread
-    [ [ integer? ] swap mailbox-get? swap push ] in-thread
-    1 over mailbox-put
-    2 over mailbox-put
-    3 swap mailbox-put
-] unit-test
-
-[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
-    0 <vector>
-    <mailbox>
-    [ [ integer? ] swap mailbox-get? swap push ] in-thread
-    [ [ integer? ] swap mailbox-get? swap push ] in-thread
-    [ [ string? ] swap mailbox-get? swap push ] in-thread
-    [ [ string? ] swap mailbox-get? swap push ] in-thread
-    1 over mailbox-put
-    "junk" over mailbox-put
-    [ 456 ] over mailbox-put
-    3 over mailbox-put
-    "junk2" over mailbox-put
-    mailbox-get
-] unit-test
-
 
 [ "received" ] [ 
     [

extra/concurrency/messaging/messaging.factor

@@ -1,80 +1,11 @@
 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-! Concurrency library for Factor based on Erlang/Termite style
+! Concurrency library for Factor, based on Erlang/Termite style
 ! concurrency.
+USING: kernel threads concurrency.mailboxes continuations
+namespaces assocs random ;
 IN: concurrency.messaging
-USING: dlists threads sequences continuations
-namespaces random math quotations words kernel arrays assocs
-init system concurrency.conditions ;
-
-TUPLE: mailbox threads data ;
-
-: <mailbox> ( -- mailbox )
-    <dlist> <dlist> \ mailbox construct-boa ;
-
-: mailbox-empty? ( mailbox -- bool )
-    mailbox-data dlist-empty? ;
-
-: mailbox-put ( obj mailbox -- )
-    [ mailbox-data push-front ] keep
-    mailbox-threads notify-all ;
-
-<PRIVATE
-
-: block-unless-pred ( pred mailbox timeout -- )
-    2over mailbox-data dlist-contains? [
-        3drop
-    ] [
-        2dup >r mailbox-threads r> "mailbox" wait
-        block-unless-pred
-    ] if ; inline
-
-: block-if-empty ( mailbox timeout -- mailbox )
-    over mailbox-empty? [
-        2dup >r mailbox-threads r> "mailbox" wait
-        block-if-empty
-    ] [
-        drop
-    ] if ;
-
-PRIVATE>
-
-: mailbox-peek ( mailbox -- obj )
-    mailbox-data peek-back ;
-
-: mailbox-get-timeout ( mailbox timeout -- obj )
-    block-if-empty mailbox-data pop-back ;
-
-: mailbox-get ( mailbox -- obj )
-    f mailbox-get-timeout ;
-
-: mailbox-get-all-timeout ( mailbox timeout -- array )
-    block-if-empty
-    [ dup mailbox-empty? ]
-    [ dup mailbox-data pop-back ]
-    [ ] unfold nip ;
-
-: mailbox-get-all ( mailbox -- array )
-    f mailbox-get-all-timeout ;
-
-: while-mailbox-empty ( mailbox quot -- )
-    over mailbox-empty? [
-        dup >r swap slip r> while-mailbox-empty
-    ] [
-        2drop
-    ] if ; inline
-
-: mailbox-timeout-get? ( pred mailbox timeout -- obj )
-    [ block-unless-pred ] 3keep drop
-    mailbox-data delete-node-if ; inline
-
-: mailbox-get? ( pred mailbox -- obj )
-    f mailbox-timeout-get? ; inline
-
-TUPLE: linked error thread ;
-
-C: <linked> linked
 
 GENERIC: send ( message process -- )
 
@@ -86,25 +17,25 @@ GENERIC: send ( message process -- )
 M: thread send ( message thread -- )
     check-registered mailbox-of mailbox-put ;
 
-: ?linked dup linked? [ rethrow ] when ;
+: my-mailbox self mailbox-of ;
-
-: mailbox self mailbox-of ;
 
 : receive ( -- message )
-    mailbox mailbox-get ?linked ;
+    my-mailbox mailbox-get ?linked ;
+
+: receive-timeout ( timeout -- message )
+    my-mailbox swap mailbox-get-timeout ?linked ;
 
 : receive-if ( pred -- message )
-    mailbox mailbox-get? ?linked ; inline
+    my-mailbox mailbox-get? ?linked ; inline
+
+: receive-if-timeout ( pred timeout -- message )
+    my-mailbox swap mailbox-get-timeout? ?linked ; inline
 
 : rethrow-linked ( error process supervisor -- )
     >r <linked> r> send ;
 
-: spawn-linked-to ( quot name mailbox -- thread )
-    [ >r <linked> r> mailbox-put ] curry <thread>
-    [ (spawn) ] keep ;
-
 : spawn-linked ( quot name -- thread )
-    mailbox spawn-linked-to ;
+    my-mailbox spawn-linked-to ;
 
 TUPLE: synchronous data sender tag ;
 
@@ -116,17 +47,18 @@ TUPLE: reply data tag ;
 : <reply> ( data synchronous -- reply )
     synchronous-tag \ reply construct-boa ;
 
+: synchronous-reply? ( response synchronous -- ? )
+    over reply?
+    [ >r reply-tag r> synchronous-tag = ]
+    [ 2drop f ] if ;
+
 : send-synchronous ( message thread -- reply )
     dup self eq? [
         "Cannot synchronous send to myself" throw
     ] [
-        >r <synchronous> dup r> send [
+        >r <synchronous> dup r> send
-            over reply? [
+        [ synchronous-reply? ] curry receive-if
-                >r reply-tag r> synchronous-tag =
+        reply-data
-            ] [
-                2drop f
-            ] if
-        ] curry receive-if reply-data
     ] if ;
 
 : reply-synchronous ( message synchronous -- )
@@ -139,18 +71,18 @@ TUPLE: reply data tag ;
 
 <PRIVATE
 
-: remote-processes ( -- hash )
+: registered-processes ( -- hash )
-   \ remote-processes get-global ;
+   \ registered-processes get-global ;
 
 PRIVATE>
 
 : register-process ( name process -- )
-    swap remote-processes set-at ;
+    swap registered-processes set-at ;
 
 : unregister-process ( name -- )
-    remote-processes delete-at ;
+    registered-processes delete-at ;
 
 : get-process ( name -- process )
-    dup remote-processes at [ ] [ thread ] ?if ;
+    dup registered-processes at [ ] [ thread ] ?if ;
 
-\ remote-processes global [ H{ } assoc-like ] change-at
+\ registered-processes global [ H{ } assoc-like ] change-at

extra/concurrency/promises/promises.factor

@@ -1,7 +1,6 @@
 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: concurrency.messaging concurrency.messaging.private
+USING: concurrency.mailboxes kernel continuations ;
-kernel ;
 IN: concurrency.promises
 
 TUPLE: promise mailbox ;
@@ -20,8 +19,7 @@ TUPLE: promise mailbox ;
     ] if ;
 
 : ?promise-timeout ( promise timeout -- result )
-    >r promise-mailbox r> block-if-empty
+    >r promise-mailbox r> block-if-empty mailbox-peek ;
-    mailbox-peek ?linked ;
 
 : ?promise ( promise -- result )
     f ?promise-timeout ;

extra/concurrency/semaphores/semaphores-docs.factor

@@ -1,5 +1,5 @@
 IN: concurrency.semaphores
-USING: help.markup help.syntax kernel quotations ;
+USING: help.markup help.syntax kernel quotations calendar ;
 
 HELP: semaphore
 { $class-description "The class of counting semaphores." } ;
@@ -8,14 +8,23 @@ HELP: <semaphore>
 { $values { "n" "a non-negative integer" } { "semaphore" semaphore } }
 { $description "Creates a counting semaphore with the specified initial count." } ;
 
+HELP: acquire-timeout
+{ $values { "semaphore" semaphore } { "timeout" "a " { $link dt } " or " { $link f } } { "value" object } }
+{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." }
+{ $errors "Throws an error if the timeout expires before the semaphore is released." } ;
+
 HELP: acquire
-{ $values { "semaphore" semaphore } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } }
+{ $values { "semaphore" semaphore } { "value" object } }
-{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits up to that number of milliseconds for the semaphore to be released." } ;
+{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, waits for it to be released." } ;
 
 HELP: release
 { $values { "semaphore" semaphore } }
 { $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ;
 
+HELP: with-semaphore-timeout
+{ $values { "semaphore" semaphore } { "timeout" "a " { $link dt } " or " { $link f } } { "quot" quotation } }
+{ $description "Calls the quotation with the semaphore held." } ;
+
 HELP: with-semaphore
 { $values { "semaphore" semaphore } { "quot" quotation } }
 { $description "Calls the quotation with the semaphore held." } ;
@@ -38,8 +47,10 @@ $nl
 { $subsection <semaphore> }
 "Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:"
 { $subsection acquire }
+{ $subsection acquire-timeout }
 { $subsection release }
-"A combinator which pairs acquisition and release:"
+"Combinators which pair acquisition and release:"
-{ $subsection with-semaphore } ;
+{ $subsection with-semaphore }
+{ $subsection with-semaphore-timeout } ;
 
 ABOUT: "concurrency.semaphores"

extra/concurrency/semaphores/semaphores.factor

@@ -13,17 +13,21 @@ TUPLE: semaphore count threads ;
 : wait-to-acquire ( semaphore timeout -- )
     >r semaphore-threads r> "semaphore" wait ;
 
-: acquire ( semaphore timeout -- )
+: acquire-timeout ( semaphore timeout -- )
-    dup semaphore-count zero? [
+    over semaphore-count zero?
-        wait-to-acquire
+    [ dupd wait-to-acquire ] [ drop ] if
-    ] [
+    dup semaphore-count 1- swap set-semaphore-count ;
-        drop
+
-        dup semaphore-count 1- swap set-semaphore-count
+: acquire ( semaphore -- )
-    ] if ;
+    f acquire-timeout ;
 
 : release ( semaphore -- )
     dup semaphore-count 1+ over set-semaphore-count
     semaphore-threads notify-1 ;
 
+: with-semaphore-timeout ( semaphore timeout quot -- )
+    pick rot acquire-timeout swap
+    [ release ] curry [ ] cleanup ; inline
+
 : with-semaphore ( semaphore quot -- )
-    over acquire [ release ] curry [ ] cleanup ; inline
+    over acquire swap [ release ] curry [ ] cleanup ; inline

extra/help/handbook/handbook.factor

@@ -99,6 +99,7 @@ $nl
 { $subsection "concurrency.combinators" }
 { $subsection "concurrency.promises" }
 { $subsection "concurrency.futures" }
+{ $subsection "concurrency.mailboxes" }
 { $subsection "concurrency.messaging" }
 "Shared-state abstractions:"
 { $subsection "concurrency.locks" }

extra/http/client/client.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs http kernel math math.parser namespaces sequences
 io io.sockets io.streams.string io.files io.timeouts strings
-splitting continuations assocs.lib ;
+splitting continuations assocs.lib calendar ;
 IN: http.client
 
 : parse-host ( url -- host port )
@@ -47,7 +47,7 @@ DEFER: http-get-stream
         dispose "location" swap peek-at nip http-get-stream
     ] when ;
 
-: default-timeout 60 1000 * over set-timeout ;
+: default-timeout 1 minutes over set-timeout ;
 
 : http-get-stream ( url -- code headers stream )
     #! Opens a stream for reading from an HTTP URL.

extra/http/server/server.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel namespaces io io.timeouts strings splitting
 threads http http.server.responders sequences prettyprint
-io.server logging ;
+io.server logging calendar ;
 
 IN: http.server
 
@@ -50,7 +50,7 @@ IN: http.server
 
 : httpd ( port -- )
     internet-server "http.server" [
-        60000 stdio get set-timeout
+        1 minutes stdio get set-timeout
         readln [ parse-request ] when*
     ] with-server ;
 

extra/io/launcher/launcher-docs.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax quotations kernel io math ;
+USING: help.markup help.syntax quotations kernel io math
+calendar ;
 IN: io.launcher
 
 HELP: +command+
@@ -77,7 +78,7 @@ $nl
 "This is used in situations where you want a spawn child process with some overridden environment variables." } ;
 
 HELP: +timeout+
-{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
+{ $description "Launch descriptor key. If set to a " { $link dt } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
 
 HELP: default-descriptor
 { $description "Association storing default values for launch descriptor keys." } ;

extra/io/launcher/launcher.factor

@@ -10,14 +10,14 @@ SYMBOL: processes
 
 [ H{ } clone processes set-global ] "io.launcher" add-init-hook
 
-TUPLE: process handle status killed? lapse ;
+TUPLE: process handle status killed? timeout ;
 
 HOOK: register-process io-backend ( process -- )
 
 M: object register-process drop ;
 
 : <process> ( handle -- process )
-    f f <lapse> process construct-boa
+    f f f process construct-boa
     V{ } clone over processes get set-at
     dup register-process ;
 
@@ -115,7 +115,9 @@ HOOK: kill-process* io-backend ( handle -- )
     t over set-process-killed?
     process-handle [ kill-process* ] when* ;
 
-M: process get-lapse process-lapse ;
+M: process timeout process-timeout ;
+
+M: process set-timeout set-process-timeout ;
 
 M: process timed-out kill-process ;
 

extra/io/nonblocking/nonblocking.factor

@@ -13,11 +13,12 @@ SYMBOL: default-buffer-size
 TUPLE: port
 handle
 error
-lapse
+timeout
 type eof? ;
 
-! Ports support the lapse protocol
+M: port timeout port-timeout ;
-M: port get-lapse port-lapse ;
+
+M: port set-timeout set-port-timeout ;
 
 SYMBOL: closed
 
@@ -28,12 +29,10 @@ GENERIC: init-handle ( handle -- )
 GENERIC: close-handle ( handle -- )
 
 : <port> ( handle buffer type -- port )
-    pick init-handle
+    pick init-handle {
-    <lapse> {
         set-port-handle
         set-delegate
         set-port-type
-        set-port-lapse
     } port construct ;
 
 : <buffered-port> ( handle type -- port )

extra/io/timeouts/timeouts-docs.factor

@@ -1,14 +1,13 @@
 IN: io.timeouts
-USING: help.markup help.syntax math kernel ;
+USING: help.markup help.syntax math kernel calendar ;
 
-HELP: get-lapse
+HELP: timeout
-{ $values { "obj" object } { "lapse" lapse } }
+{ $values { "obj" object } { "dt/f" "a " { $link dt } " or " { $link f } } }
-{ $contract "Outputs an object's timeout lapse descriptor." } ;
+{ $contract "Outputs an object's timeout." } ;
 
 HELP: set-timeout
-{ $values { "ms" integer } { "obj" object } }
+{ $values { "dt/f" "a " { $link dt } " or " { $link f } } { "obj" object } }
-{ $contract "Sets an object's timeout, in milliseconds." }
+{ $contract "Sets an object's timeout." } ;
-{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ;
 
 HELP: timed-out
 { $values { "obj" object } }
@@ -20,13 +19,12 @@ HELP: with-timeout
 
 ARTICLE: "io.timeouts" "I/O timeout protocol"
 "Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
+{ $subsection timeout }
 { $subsection set-timeout }
 "The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
-{ $subsection get-lapse }
 { $subsection timed-out }
 "A combinator to be used in operations which can time out:"
 { $subsection with-timeout }
-{ $see-also "stream-protocol" "io.launcher" }
+{ $see-also "stream-protocol" "io.launcher" } ;
-;
 
 ABOUT: "io.timeouts"

extra/io/timeouts/timeouts.factor

@@ -1,79 +1,27 @@
 ! Copyright (C) 2008 Slava Pestov, Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math system dlists namespaces assocs init
+USING: kernel calendar alarms io.streams.duplex ;
-threads io.streams.duplex ;
 IN: io.timeouts
 
-TUPLE: lapse entry timeout cutoff ;
-
-: <lapse> f 0 0 \ lapse construct-boa ;
-
 ! Won't need this with new slot accessors
-GENERIC: get-lapse ( obj -- lapse )
+GENERIC: timeout ( obj -- dt/f )
+GENERIC: set-timeout ( dt/f obj -- )
 
-GENERIC: set-timeout ( ms obj -- )
+M: duplex-stream set-timeout
-
+    2dup
-M: object set-timeout get-lapse set-timeout ;
-
-M: lapse set-timeout set-lapse-timeout ;
-
-: timeout ( obj -- ms ) get-lapse lapse-timeout ;
-: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
-: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ;
-: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
-: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
-
-! Won't need this with inheritance
-TUPLE: duplex-stream-lapse stream ;
-
-M: duplex-stream-lapse set-timeout
-    duplex-stream-lapse-stream 2dup
     duplex-stream-in set-timeout
     duplex-stream-out set-timeout ;
 
-M: duplex-stream get-lapse duplex-stream-lapse construct-boa ;
-
-SYMBOL: timeout-queue
-
-: timeout? ( lapse -- ? )
-    cutoff dup zero? not swap millis < and ;
-
-timeout-queue global [ [ <dlist> ] unless* ] change-at
-
-: unqueue-timeout ( obj -- )
-    entry [
-        timeout-queue get-global swap delete-node
-    ] when* ;
-
-: queue-timeout ( obj -- )
-    dup timeout-queue get-global push-front*
-    swap set-entry ;
-
 GENERIC: timed-out ( obj -- )
 
 M: object timed-out drop ;
 
-: expire-timeouts ( -- )
+: queue-timeout ( obj timeout -- alarm )
-    timeout-queue get-global dup dlist-empty? [ drop ] [
+    >r [ timed-out ] curry r> later ;
-        dup peek-back timeout?
-        [ pop-back timed-out expire-timeouts ] [ drop ] if
-    ] if ;
-
-: begin-timeout ( obj -- )
-    dup timeout dup zero? [
-        2drop
-    ] [
-        millis + over set-cutoff
-        dup unqueue-timeout queue-timeout
-    ] if ;
 
 : with-timeout ( obj quot -- )
-    over begin-timeout keep unqueue-timeout ; inline
+    over dup timeout dup [
-
+        queue-timeout slip cancel-alarm
-: expiry-thread ( -- )
+    ] [
-    expire-timeouts 5000 sleep expiry-thread ;
+        2drop call
-
+    ] if ; inline
-: start-expiry-thread ( -- )
-    [ expiry-thread ] "I/O expiry" spawn drop ;
-
-[ start-expiry-thread ] "io.timeouts" add-init-hook

extra/io/unix/backend/backend.factor

@@ -178,7 +178,7 @@ M: write-task do-io-task
 M: port port-flush ( port -- )
     dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
 
-M: unix-io io-multiplex ( ms -- )
+M: unix-io io-multiplex ( ms/f -- )
     mx get-global wait-for-events ;
 
 M: unix-io init-stdio ( -- )

extra/io/unix/kqueue/kqueue.factor

@@ -66,7 +66,8 @@ M: kqueue-mx unregister-io-task ( task mx -- )
     [ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
 
 M: kqueue-mx wait-for-events ( ms mx -- )
-    swap make-timespec dupd wait-kevent handle-kevents ;
+    swap dup [ make-timespec ] when
+    dupd wait-kevent handle-kevents ;
 
 : make-proc-kevent ( pid -- kevent )
     "kevent" <c-object>

extra/io/unix/select/select.factor

@@ -49,7 +49,7 @@ TUPLE: select-mx read-fdset write-fdset ;
     f ;
 
 M: select-mx wait-for-events ( ms mx -- )
-    swap >r dup init-fdsets r> make-timeval
+    swap >r dup init-fdsets r> dup [ make-timeval ] when
     select multiplexer-error
     dup read-fdset/tasks pick handle-fdset
     dup write-fdset/tasks rot handle-fdset ;

extra/io/unix/unix-tests.factor

@@ -38,8 +38,8 @@ yield
     "unix-domain-datagram-test" resource-path delete-file
 ] ignore-errors
 
-: server-addr "unix-domain-datagram-test" resource-path <local> ;
+: server-addr "unix-domain-datagram-test" temp-file <local> ;
-: client-addr "unix-domain-datagram-test-2" resource-path <local> ;
+: client-addr "unix-domain-datagram-test-2" temp-file <local> ;
 
 [
     [
@@ -112,7 +112,7 @@ client-addr <datagram>
     "unix-domain-datagram-test-3" resource-path delete-file
 ] ignore-errors
 
-"unix-domain-datagram-test-2" resource-path delete-file
+"unix-domain-datagram-test-2" temp-file delete-file
 
 [ ] [ client-addr <datagram> "d" set ] unit-test
 

extra/io/windows/ce/backend/backend.factor

@@ -7,7 +7,9 @@ IN: io.windows.ce.backend
 : port-errored ( port -- )
     win32-error-string swap set-port-error ;
 
-M: windows-ce-io io-multiplex ( ms -- ) (sleep) ;
+M: windows-ce-io io-multiplex ( ms -- )
+    60 60 * 1000 * or (sleep) ;
+
 M: windows-ce-io add-completion ( handle -- ) drop ;
 
 GENERIC: wince-read ( port port-handle -- )

extra/io/windows/launcher/launcher.factor

@@ -146,10 +146,16 @@ M: windows-io kill-process* ( handle -- )
 
 : wait-loop ( -- )
     processes get dup assoc-empty?
-    [ drop t ] [ wait-for-processes ] if
+    [ drop f nap drop ]
-    [ 250 sleep ] when ;
+    [ wait-for-processes [ 100 nap drop ] when ] if ;
+
+SYMBOL: wait-thread
 
 : start-wait-thread ( -- )
-    [ wait-loop t ] "Process wait" spawn-server drop ;
+    [ wait-loop t ] "Process wait" spawn-server
+    wait-thread set-global ;
+
+M: windows-io register-process
+    drop wait-thread get-global interrupt ;
 
 [ start-wait-thread ] "io.windows.launcher" add-init-hook

extra/io/windows/nt/backend/backend.factor

@@ -57,7 +57,8 @@ M: windows-nt-io add-completion ( handle -- )
     ] "I/O" suspend 3drop ;
 
 : wait-for-overlapped ( ms -- overlapped ? )
-    >r master-completion-port get-global r> ! port ms
+    >r master-completion-port get-global
+    r> INFINITE or ! timeout
     0 <int> ! bytes
     f <void*> ! key
     f <void*> ! overlapped

extra/locals/locals-tests.factor

@@ -122,3 +122,7 @@ SYMBOL: a
     USE: kernel ;
 
 [ t ] [ a symbol? ] unit-test
+
+:: let-let-test | n | [let | n [ n 3 + ] | n ] ;
+
+[ 13 ] [ 10 let-let-test ] unit-test

extra/math/ranges/ranges.factor

@@ -1,10 +1,6 @@
 USING: kernel layouts math namespaces sequences sequences.private ;
 IN: math.ranges
 
-: >integer ( n -- i )
-    dup most-negative-fixnum most-positive-fixnum between?
-    [ >fixnum ] [ >bignum ] if ;
-
 TUPLE: range from length step ;
 
 : <range> ( from to step -- range )

extra/models/models-docs.factor

@@ -1,4 +1,5 @@
-USING: help.syntax help.markup kernel math classes tuples ;
+USING: help.syntax help.markup kernel math classes tuples
+calendar ;
 IN: models
 
 HELP: model
@@ -142,18 +143,18 @@ HELP: delay
 { $examples
     "The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
     { $code
-        "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
+        "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;"
         ": <funny-slider>"
         "    0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
         "<funny-slider> dup gadget."
-        "gadget-model 500 <delay> [ number>string ] <filter>"
+        "gadget-model 1/2 seconds <delay> [ number>string ] <filter>"
         "<label-control> gadget."
     }
 } ;
 
 HELP: <delay>
-{ $values { "model" model } { "timeout" "a positive integer" } { "delay" delay } }
+{ $values { "model" model } { "timeout" dt } { "delay" delay } }
-{ $description "Creates a new instance of " { $link delay } ". A timer of " { $snippet "timeout" } " milliseconds must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
+{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
 { $examples "See the example in the documentation for " { $link delay } "." } ;
 
 HELP: range-value

extra/models/models.factor

@@ -1,6 +1,7 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: generic kernel math sequences timers arrays assocs ;
+USING: generic kernel math sequences arrays assocs alarms
+calendar ;
 IN: models
 
 TUPLE: model value connections dependencies ref locked? ;
@@ -174,7 +175,7 @@ TUPLE: history back forward ;
     dup history-forward delete-all
     dup history-back (add-history) ;
 
-TUPLE: delay model timeout ;
+TUPLE: delay model timeout alarm ;
 
 : update-delay-model ( delay -- )
     dup delay-model model-value swap set-model ;
@@ -185,12 +186,18 @@ TUPLE: delay model timeout ;
     [ set-delay-model ] 2keep
     [ add-dependency ] keep ;
 
-M: delay model-changed nip 0 over delay-timeout add-timer ;
+: cancel-delay ( delay -- )
+    delay-alarm [ cancel-alarm ] when* ;
+
+: start-delay ( delay -- )
+    dup [ f over set-delay-alarm update-delay-model ] curry
+    over delay-timeout later
+    swap set-delay-alarm ;
+
+M: delay model-changed nip dup cancel-delay start-delay ;
 
 M: delay model-activated update-delay-model ;
 
-M: delay tick dup remove-timer update-delay-model ;
-
 GENERIC: range-value ( model -- value )
 GENERIC: range-page-value ( model -- value )
 GENERIC: range-min-value ( model -- value )

extra/ogg/player/player.factor

@@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ;
     dup player-gadget [
         dup { player-td player-yuv } get-slots theora_decode_YUVout drop
         dup player-rgb over player-yuv yuv>rgb
-        dup player-gadget find-world dup draw-world
+        dup player-gadget find-world draw-world
     ] when ;
 
 : num-audio-buffers-processed ( player -- player n )

extra/smtp/server/server.factor

@@ -66,7 +66,7 @@ SYMBOL: data-mode
     "Starting SMTP server on port " write dup . flush
     "127.0.0.1" swap <inet4> <server> [
         accept [
-            60000 stdio get set-timeout
+            1 minutes stdio get set-timeout
             "220 hello\r\n" write flush
             process
             global [ flush ] bind

extra/space-invaders/space-invaders.factor

@@ -3,8 +3,9 @@
 !
 USING: cpu.8080 cpu.8080.emulator openal math alien.c-types
 sequences kernel shuffle arrays io.files combinators ui.gestures
-ui.gadgets ui.render opengl.gl system threads match
+ui.gadgets ui.render opengl.gl system match
-ui byte-arrays combinators.lib ;
+ui byte-arrays combinators.lib qualified ;
+QUALIFIED: threads
 IN: space-invaders
 
 TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
@@ -337,7 +338,7 @@ M: space-invaders update-video ( value addr cpu -- )
 : sync-frame ( millis -- millis )
   #! Sleep until the time for the next frame arrives.
   1000 60 / >fixnum + millis - dup 0 >
-  [ sleep ] [ drop yield ] if millis ;
+  [ threads:sleep ] [ drop threads:yield ] if millis ;
 
 : invaders-process ( millis gadget -- )
   #! Run a space invaders gadget inside a 
@@ -356,7 +357,7 @@ M: invaders-gadget graft* ( gadget -- )
   dup invaders-gadget-cpu init-sounds
   f over set-invaders-gadget-quit?
   [ millis swap invaders-process ] curry
-  "Space invaders" spawn drop ;
+  "Space invaders" threads:spawn drop ;
 
 M: invaders-gadget ungraft* ( gadget -- )
  t swap set-invaders-gadget-quit? ;

extra/timers/authors.txt

@@ -1 +0,0 @@
-Slava Pestov

extra/timers/summary.txt

@@ -1 +0,0 @@
-Simple low-resolution timers

extra/timers/timers-docs.factor

@@ -1,36 +0,0 @@
-USING: help.syntax help.markup classes kernel ;
-IN: timers
-
-HELP: init-timers
-{ $description "Initializes the timer code." }
-{ $notes "This word is automatically called when the UI is initialized, and it should only be called manually if timers are being used outside of the UI." } ;
-
-HELP: tick
-{ $values { "object" object } }
-{ $description "Called to notify an object registered with a timer that the timer has fired." } ;
-
-HELP: add-timer
-{ $values { "object" object } { "delay" "a positive integer" } { "initial" "a positive integer" } }
-{ $description "Registers a timer. Every " { $snippet "delay" } " milliseconds, " { $link tick } " will be called on the object. The initial delay from the time " { $link add-timer } " is called to when " { $link tick } " is first called is " { $snippet "initial" } " milliseconds." } ;
-
-HELP: remove-timer
-{ $values { "object" object } }
-{ $description "Unregisters a timer." } ;
-
-HELP: do-timers
-{ $description "Fires all registered timers which are due to fire." }
-{ $notes "This word is automatically called from the UI event loop, and it should only be called manually if timers are being used outside of the UI." } ;
-
-{ init-timers add-timer remove-timer tick do-timers } related-words
-
-ARTICLE: "timers" "Timers"
-"Timers can be added and removed:"
-{ $subsection add-timer }
-{ $subsection remove-timer }
-"Classes must implement a generic word so that their instances can handle timer ticks:"
-{ $subsection tick }
-"Timers can be used outside of the UI, however they must be initialized with an explicit call, and fired manually:"
-{ $subsection init-timers }
-{ $subsection do-timers } ;
-
-ABOUT: "timers"

extra/timers/timers.factor

@@ -1,30 +0,0 @@
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel math namespaces sequences system ;
-IN: timers
-
-TUPLE: timer object delay next ;
-
-: <timer> ( object delay initial -- timer )
-    millis + timer construct-boa ;
-
-GENERIC: tick ( object -- )
-
-: timers \ timers get-global ;
-
-: init-timers ( -- ) H{ } clone \ timers set-global ;
-
-: add-timer ( object delay initial -- )
-    pick >r <timer> r> timers set-at ;
-
-: remove-timer ( object -- ) timers delete-at ;
-
-: advance-timer ( ms timer -- )
-    [ timer-delay + ] keep set-timer-next ;
-
-: do-timer ( ms timer -- )
-    dup timer-next pick <=
-    [ [ advance-timer ] keep timer-object tick ] [ 2drop ] if ;
-
-: do-timers ( -- )
-    millis timers values [ do-timer ] with each ;

extra/tools/threads/threads.factor

@@ -2,17 +2,24 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: tools.threads
 USING: threads kernel prettyprint prettyprint.config
-io io.styles sequences assocs namespaces sorting boxes ;
+io io.styles sequences assocs namespaces sorting boxes
+heaps.private system math math.parser ;
 
 : thread. ( thread -- )
     dup thread-id pprint-cell
     dup thread-name over [ write-object ] with-cell
-    thread-state "running" or [ write ] with-cell ;
+    dup thread-state "running" or [ write ] with-cell
+    [
+        thread-sleep-entry [
+            entry-key millis [-] number>string write
+            " ms" write
+        ] when*
+    ] with-cell ;
 
 : threads. ( -- )
     standard-table-style [
         [
-            { "ID" "Name" "Waiting on" }
+            { "ID" "Name" "Waiting on" "Remaining sleep" }
             [ [ write ] with-cell ] each
         ] with-row
 

extra/ui/gadgets/buttons/buttons.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays ui.commands ui.gadgets ui.gadgets.borders
 ui.gadgets.labels ui.gadgets.theme
@@ -88,6 +88,7 @@ TUPLE: repeat-button ;
 
 repeat-button H{
     { T{ drag } [ button-clicked ] }
+    { T{ button-down } [ button-clicked ] }
 } set-gestures
 
 : <repeat-button> ( label quot -- button )

extra/ui/gadgets/gadgets.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables kernel models math namespaces sequences
-timers quotations math.vectors combinators sorting vectors
+quotations math.vectors combinators sorting vectors dlists
-dlists models ;
+models ;
 IN: ui.gadgets
 
 TUPLE: rect loc dim ;

extra/ui/gadgets/status-bar/status-bar.factor

@@ -1,11 +1,12 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: models sequences ui.gadgets.labels ui.gadgets.theme
-ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel ;
+ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel
+calendar ;
 IN: ui.gadgets.status-bar
 
 : <status-bar> ( model -- gadget )
-    100 <delay> [ "" like ] <filter> <label-control>
+    1/10 seconds <delay> [ "" like ] <filter> <label-control>
     dup reverse-video-theme
     t over set-gadget-root? ;
 

extra/ui/gestures/gestures.factor

@@ -1,8 +1,9 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs kernel math models namespaces
 sequences words strings system hashtables math.parser
-math.vectors tuples classes ui.gadgets timers combinators.lib ;
+math.vectors tuples classes ui.gadgets combinators.lib boxes
+calendar alarms ;
 IN: ui.gestures
 
 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
@@ -107,20 +108,21 @@ SYMBOL: double-click-timeout
 : drag-gesture ( -- )
     hand-buttons get-global first <drag> button-gesture ;
 
-TUPLE: drag-timer ;
+SYMBOL: drag-timer
 
-M: drag-timer tick drop drag-gesture ;
+<box> drag-timer set-global
-
-drag-timer construct-empty drag-timer set-global
 
 : start-drag-timer ( -- )
     hand-buttons get-global empty? [
-        drag-timer get-global 100 300 add-timer
+        [ drag-gesture ]
+        300 milliseconds from-now
+        100 milliseconds
+        add-alarm drag-timer get-global >box
     ] when ;
 
 : stop-drag-timer ( -- )
     hand-buttons get-global empty? [
-        drag-timer get-global remove-timer
+        drag-timer get-global box> cancel-alarm
     ] when ;
 
 : fire-motion ( -- )

extra/ui/tools/interactor/interactor.factor

@@ -6,7 +6,7 @@ math.vectors models namespaces parser prettyprint quotations
 sequences sequences.lib strings threads listener
 tuples ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions boxes ;
+definitions boxes calendar ;
 IN: ui.tools.interactor
 
 TUPLE: interactor
@@ -29,7 +29,8 @@ help ;
     ] if ;
 
 : init-caret-help ( interactor -- )
-    dup editor-caret 100 <delay> swap set-interactor-help ;
+    dup editor-caret 1/3 seconds <delay>
+    swap set-interactor-help ;
 
 : init-interactor-history ( interactor -- )
     V{ } clone swap set-interactor-history ;

extra/ui/tools/listener/listener-tests.factor

@@ -1,12 +1,10 @@
 USING: continuations documents ui.tools.interactor
 ui.tools.listener hashtables kernel namespaces parser sequences
-timers tools.test ui.commands ui.gadgets ui.gadgets.editors
+tools.test ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.panes vocabs words tools.test.ui slots.private
 threads ;
 IN: temporary
 
-timers [ init-timers ] unless
-
 [ f ] [ "word" source-editor command-map empty? ] unit-test
 
 [ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test

extra/ui/tools/listener/listener.factor

@@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands
 ui.gadgets ui.gadgets.editors ui.gadgets.labelled
 ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
 ui.gadgets.tracks ui.gestures ui.operations vocabs words
-prettyprint listener debugger threads ;
+prettyprint listener debugger threads boxes ;
 IN: ui.tools.listener
 
 TUPLE: listener-gadget input output stack ;
@@ -161,6 +161,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
 
 M: listener-gadget graft*
     dup delegate graft*
+    dup listener-gadget-input interactor-thread ?box 2drop
     restart-listener ;
 
 M: listener-gadget ungraft*

extra/ui/tools/search/search-tests.factor

@@ -1,11 +1,9 @@
 USING: assocs ui.tools.search help.topics io.files io.styles
-kernel namespaces sequences source-files threads timers
+kernel namespaces sequences source-files threads
 tools.test ui.gadgets ui.gestures vocabs
 vocabs.loader words tools.test.ui debugger ;
 IN: temporary
 
-timers get [ init-timers ] unless
-
 [ f ] [
     "no such word with this name exists, certainly"
     f f <definition-search>
@@ -16,7 +14,7 @@ timers get [ init-timers ] unless
 
 : update-live-search ( search -- seq )
     dup [
-        300 sleep do-timers
+        300 sleep
         live-search-list control-value
     ] with-grafted-gadget ;
 
@@ -33,7 +31,6 @@ timers get [ init-timers ] unless
     dup [
         { "set-word-prop" } over live-search-field set-control-value
         300 sleep
-        do-timers
         search-value \ set-word-prop eq?
     ] with-grafted-gadget
 ] unit-test

extra/ui/tools/search/search.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs ui.tools.interactor ui.tools.listener
 ui.tools.workspace help help.topics io.files io.styles kernel
@@ -7,7 +7,7 @@ source-files strings tools.completion tools.crossref tuples
 ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
 ui.gestures ui.operations vocabs words vocabs.loader
-tools.browser unicode.case ;
+tools.browser unicode.case calendar ;
 IN: ui.tools.search
 
 TUPLE: live-search field list ;
@@ -45,7 +45,7 @@ search-field H{
 } set-gestures
 
 : <search-model> ( producer -- model )
-    >r g live-search-field gadget-model 200 <delay>
+    >r g live-search-field gadget-model 1/5 seconds <delay>
     [ "\n" join ] r> append <filter> ;
 
 : <search-list> ( seq limited? presenter -- gadget )

extra/ui/tools/tools-tests.factor

@@ -1,6 +1,6 @@
 USING: ui.tools ui.tools.interactor ui.tools.listener
 ui.tools.search ui.tools.workspace kernel models namespaces
-sequences timers tools.test ui.gadgets ui.gadgets.buttons
+sequences tools.test ui.gadgets ui.gadgets.buttons
 ui.gadgets.labelled ui.gadgets.presentations
 ui.gadgets.scrollers vocabs tools.test.ui ui ;
 IN: temporary
@@ -12,8 +12,6 @@ IN: temporary
     ] unit-test
 ] with-scope
 
-timers get [ init-timers ] unless
-
 [ ] [ <workspace> "w" set ] unit-test
 [ ] [ "w" get com-scroll-up ] unit-test
 [ ] [ "w" get com-scroll-down ] unit-test

extra/ui/ui-docs.factor

@@ -167,7 +167,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop"
 { $subsection start-ui }
 "The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
 $nl
-"The event loop must not block. Instead, it should poll for pending events, then call " { $link ui-step } ", which performs pending layout, runs timers and sleeps for 10 milliseconds, or until a Factor thread wakes up." ;
+"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-step } ", which performs pending layout and sleeps for 10 milliseconds." ;
 
 ARTICLE: "ui-backend-windows" "UI backend window management"
 "The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
@@ -368,7 +368,6 @@ $nl
 { $subsection "ui-paint" }
 { $subsection "ui-control-impl" }
 { $subsection "clipboard-protocol" }
-{ $subsection "timers" }
 { $see-also "ui-layout-impl" } ;
 
 ARTICLE: "ui" "UI framework"

extra/ui/ui.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs io kernel math models namespaces
 prettyprint dlists sequences threads sequences words
-timers debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
+debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
 ui.gestures ui.backend ui.render continuations init combinators
 hashtables ;
 IN: ui
@@ -131,8 +131,7 @@ SYMBOL: ui-hook
     graft-queue [ notify ] dlist-slurp ;
 
 : ui-step ( -- )
-    [ do-timers notify-queued layout-queued redraw-worlds ]
+    [ notify-queued layout-queued redraw-worlds ] assert-depth ;
-    assert-depth ;
 
 : open-world-window ( world -- )
     dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
@@ -156,7 +155,6 @@ M: object close-window
     find-world [ ungraft ] when* ;
 
 : start-ui ( -- )
-    init-timers
     restore-windows? [
         restore-windows
     ] [

extra/ui/windows/windows.factor

@@ -5,9 +5,8 @@ ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
 math math.vectors namespaces prettyprint sequences strings
 vectors words windows.kernel32 windows.gdi32 windows.user32
 windows.opengl32 windows.messages windows.types windows.nt
-windows threads timers libc combinators
+windows threads libc combinators continuations command-line
-continuations command-line shuffle opengl ui.render unicode.case
+shuffle opengl ui.render unicode.case ascii math.bitfields ;
-ascii math.bitfields ;
 IN: ui.windows
 
 TUPLE: windows-ui-backend ;

extra/windows/windows.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.syntax alien.c-types arrays combinators
-io io.nonblocking kernel math namespaces parser prettyprint
+kernel math namespaces parser prettyprint sequences
-sequences windows.errors windows.types windows.kernel32 words ;
+windows.errors windows.types windows.kernel32 words ;
 IN: windows
 
 : lo-word ( wparam -- lo ) <short> *short ; inline

misc/target

@@ -0,0 +1,17 @@
+#!/bin/bash
+
+if [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
+then
+  echo macosx-ppc
+elif [ `uname -s` = Darwin ]
+then
+  echo macosx-x86-`./misc/wordsize`
+elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ]
+then
+  echo linux-x86-`./misc/wordsize`
+elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ]
+then
+  echo winnt-x86-`./misc/wordsize`
+else
+  echo help
+fi

misc/wordsize.c

@@ -0,0 +1,8 @@
+
+#include <stdio.h>
+
+int main ()
+{
+  printf("%d", 8*sizeof(void*));
+  return 0;
+}

vm/debug.c

@@ -37,15 +37,24 @@ void print_array(F_ARRAY* array, CELL nesting)
 {
 	CELL length = array_capacity(array);
 	CELL i;
+	bool trimmed;
 
 	if(length > 10)
+	{
+		trimmed = true;
 		length = 10;
+	}
+	else
+		trimmed = false;
 
 	for(i = 0; i < length; i++)
 	{
 		printf(" ");
 		print_nested_obj(array_nth(array,i),nesting);
 	}
+
+	if(trimmed)
+		printf("...");
 }
 
 void print_nested_obj(CELL obj, F_FIXNUM nesting)