Merge branch 'master' of git://factorcode.org/git/factor
commit
014e94aafc
|
@ -15,5 +15,7 @@ factor
|
||||||
.gdb_history
|
.gdb_history
|
||||||
*.*.marks
|
*.*.marks
|
||||||
.*.swp
|
.*.swp
|
||||||
reverse-complement-in.txt
|
temp
|
||||||
reverse-complement-out.txt
|
logs
|
||||||
|
work
|
||||||
|
misc/wordsize
|
8
Makefile
8
Makefile
|
@ -45,7 +45,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||||
|
|
||||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||||
|
|
||||||
default:
|
default: misc/wordsize
|
||||||
|
make `./misc/target`
|
||||||
|
|
||||||
|
help:
|
||||||
@echo "Run 'make' with one of the following parameters:"
|
@echo "Run 'make' with one of the following parameters:"
|
||||||
@echo ""
|
@echo ""
|
||||||
@echo "freebsd-x86-32"
|
@echo "freebsd-x86-32"
|
||||||
|
@ -158,6 +161,9 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
|
||||||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||||
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
||||||
|
|
||||||
|
misc/wordsize: misc/wordsize.c
|
||||||
|
gcc misc/wordsize.c -o misc/wordsize
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
rm -f vm/*.o
|
rm -f vm/*.o
|
||||||
rm -f factor*.dll libfactor*.*
|
rm -f factor*.dll libfactor*.*
|
||||||
|
|
|
@ -11,69 +11,72 @@ $nl
|
||||||
{ $subsection min-heap? }
|
{ $subsection min-heap? }
|
||||||
{ $subsection <min-heap> }
|
{ $subsection <min-heap> }
|
||||||
"Max-heaps sort their elements so that the maximum element is first:"
|
"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."
|
"Both obey a protocol."
|
||||||
$nl
|
$nl
|
||||||
"Queries:"
|
"Queries:"
|
||||||
{ $subsection heap-empty? }
|
{ $subsection heap-empty? }
|
||||||
{ $subsection heap-length }
|
{ $subsection heap-size }
|
||||||
{ $subsection heap-peek }
|
{ $subsection heap-peek }
|
||||||
"Insertion:"
|
"Insertion:"
|
||||||
{ $subsection heap-push }
|
{ $subsection heap-push }
|
||||||
|
{ $subsection heap-push* }
|
||||||
{ $subsection heap-push-all }
|
{ $subsection heap-push-all }
|
||||||
"Removal:"
|
"Removal:"
|
||||||
{ $subsection heap-pop* }
|
{ $subsection heap-pop* }
|
||||||
{ $subsection heap-pop } ;
|
{ $subsection heap-pop }
|
||||||
|
{ $subsection heap-delete } ;
|
||||||
|
|
||||||
ABOUT: "heaps"
|
ABOUT: "heaps"
|
||||||
|
|
||||||
HELP: <min-heap>
|
HELP: <min-heap>
|
||||||
{ $values { "min-heap" 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>
|
HELP: <max-heap>
|
||||||
{ $values { "max-heap" 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
|
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
|
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." }
|
{ $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
|
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*
|
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
|
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?
|
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" } ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright 2007 Ryan Murphy
|
! Copyright 2007, 2008 Ryan Murphy, Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
|
||||||
USING: arrays kernel math namespaces tools.test
|
USING: arrays kernel math namespaces tools.test
|
||||||
heaps heaps.private ;
|
heaps heaps.private math.parser random assocs sequences sorting ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
[ <min-heap> heap-pop ] must-fail
|
[ <min-heap> heap-pop ] must-fail
|
||||||
|
@ -15,16 +15,8 @@ IN: temporary
|
||||||
|
|
||||||
! Binary Min Heap
|
! Binary Min Heap
|
||||||
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
|
{ 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
|
[ 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
|
[ 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
|
||||||
|
|
|
@ -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.
|
! 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
|
IN: heaps
|
||||||
|
|
||||||
MIXIN: priority-queue
|
MIXIN: priority-queue
|
||||||
|
|
||||||
GENERIC: heap-push ( value key heap -- )
|
GENERIC: heap-push* ( value key heap -- entry )
|
||||||
GENERIC: heap-peek ( heap -- value key )
|
GENERIC: heap-peek ( heap -- value key )
|
||||||
GENERIC: heap-pop* ( heap -- )
|
GENERIC: heap-pop* ( heap -- )
|
||||||
GENERIC: heap-pop ( heap -- value key )
|
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-empty? ( heap -- ? )
|
||||||
GENERIC: heap-length ( heap -- n )
|
GENERIC: heap-size ( heap -- n )
|
||||||
GENERIC# heap-pop-while 2 ( heap pred quot -- )
|
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
TUPLE: heap data ;
|
|
||||||
|
: heap-data delegate ; inline
|
||||||
|
|
||||||
: <heap> ( class -- heap )
|
: <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>
|
PRIVATE>
|
||||||
|
|
||||||
TUPLE: min-heap ;
|
TUPLE: min-heap ;
|
||||||
|
@ -34,23 +39,67 @@ TUPLE: max-heap ;
|
||||||
INSTANCE: min-heap priority-queue
|
INSTANCE: min-heap priority-queue
|
||||||
INSTANCE: max-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
|
<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 -- ? )
|
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: min-heap heap-compare (heap-compare) > ;
|
||||||
|
|
||||||
M: max-heap heap-compare (heap-compare) < ;
|
M: max-heap heap-compare (heap-compare) < ;
|
||||||
|
|
||||||
: heap-bounds-check? ( m heap -- ? )
|
: heap-bounds-check? ( m heap -- ? )
|
||||||
heap-data length >= ; inline
|
heap-size >= ; inline
|
||||||
|
|
||||||
: left-bounds-check? ( m heap -- ? )
|
: left-bounds-check? ( m heap -- ? )
|
||||||
>r left r> heap-bounds-check? ; inline
|
>r left r> heap-bounds-check? ; inline
|
||||||
|
@ -58,41 +107,44 @@ M: max-heap heap-compare (heap-compare) < ;
|
||||||
: right-bounds-check? ( m heap -- ? )
|
: right-bounds-check? ( m heap -- ? )
|
||||||
>r right r> heap-bounds-check? ; inline
|
>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
|
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 ;
|
] if ;
|
||||||
|
|
||||||
|
: up-heap ( n heap -- )
|
||||||
|
over 0 > [ (up-heap) ] [ 2drop ] if ;
|
||||||
|
|
||||||
: (child) ( m heap -- n )
|
: (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 ;
|
[ right ] [ left ] if ;
|
||||||
|
|
||||||
: child ( m heap -- n )
|
: child ( m heap -- n )
|
||||||
2dup right-bounds-check? [ drop left ] [ (child) ] if ;
|
2dup right-bounds-check?
|
||||||
|
[ drop left ] [ (child) ] if ;
|
||||||
|
|
||||||
: swap-down ( m heap -- )
|
: swap-down ( m heap -- )
|
||||||
[ child ] 2keep heap-data exchange ;
|
[ child ] 2keep data-exchange ;
|
||||||
|
|
||||||
DEFER: down-heap
|
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 -- )
|
: (down-heap) ( m heap -- )
|
||||||
2dup down-heap-continue? [
|
[ child ] 2keep swapd
|
||||||
-rot [ swap-down ] keep down-heap
|
3dup continue? [
|
||||||
] [
|
|
||||||
3drop
|
3drop
|
||||||
|
] [
|
||||||
|
[ data-exchange ] 2keep down-heap
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: down-heap ( m heap -- )
|
: down-heap ( m heap -- )
|
||||||
|
@ -100,40 +152,37 @@ DEFER: down-heap
|
||||||
|
|
||||||
PRIVATE>
|
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 -- )
|
: heap-push-all ( assoc heap -- )
|
||||||
[ swapd heap-push ] curry assoc-each ;
|
[ swapd heap-push ] curry assoc-each ;
|
||||||
|
|
||||||
|
: >entry< ( entry -- key value )
|
||||||
|
{ entry-value entry-key } get-slots ;
|
||||||
|
|
||||||
M: priority-queue heap-peek ( heap -- value key )
|
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 -- )
|
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) ;
|
|
||||||
|
|
|
@ -288,3 +288,10 @@ cell-bits 32 = [
|
||||||
[ HEX: ff bitand 0 HEX: ff between? ]
|
[ HEX: ff bitand 0 HEX: ff between? ]
|
||||||
\ >= inlined?
|
\ >= inlined?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ HEX: ff swap HEX: ff bitand >= ]
|
||||||
|
\ >= inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -154,3 +154,11 @@ M: pathname <=> [ pathname-string ] compare ;
|
||||||
|
|
||||||
: with-file-appender ( path quot -- )
|
: with-file-appender ( path quot -- )
|
||||||
>r <file-appender> r> with-stream ; inline
|
>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+ ;
|
|
@ -2,9 +2,9 @@ USING: tools.test io.files io io.streams.c ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
[ "hello world" ] [
|
[ "hello world" ] [
|
||||||
"test.txt" resource-path [
|
"test.txt" temp-file [
|
||||||
"hello world" write
|
"hello world" write
|
||||||
] with-file-writer
|
] with-file-writer
|
||||||
|
|
||||||
"test.txt" resource-path "rb" fopen <c-reader> contents
|
"test.txt" temp-file "rb" fopen <c-reader> contents
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -64,7 +64,7 @@ M: object init-stdio
|
||||||
stdin-handle stdout-handle <duplex-c-stream> stdio set-global
|
stdin-handle stdout-handle <duplex-c-stream> stdio set-global
|
||||||
stderr-handle <c-writer> <plain-writer> stderr 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>
|
M: object <file-reader>
|
||||||
"rb" fopen <c-reader> <line-reader> ;
|
"rb" fopen <c-reader> <line-reader> ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: io.thread
|
IN: io.thread
|
||||||
USING: threads io.backend namespaces init ;
|
USING: threads io.backend namespaces init math ;
|
||||||
|
|
||||||
: io-thread ( -- )
|
: io-thread ( -- )
|
||||||
sleep-time io-multiplex yield ;
|
sleep-time io-multiplex yield ;
|
||||||
|
|
|
@ -32,3 +32,7 @@ SYMBOL: type-numbers
|
||||||
|
|
||||||
: most-negative-fixnum ( -- n )
|
: most-negative-fixnum ( -- n )
|
||||||
first-bignum neg ;
|
first-bignum neg ;
|
||||||
|
|
||||||
|
M: real >integer
|
||||||
|
dup most-negative-fixnum most-positive-fixnum between?
|
||||||
|
[ >fixnum ] [ >bignum ] if ;
|
||||||
|
|
|
@ -14,6 +14,7 @@ $nl
|
||||||
{ $subsection fixnum? }
|
{ $subsection fixnum? }
|
||||||
{ $subsection bignum? }
|
{ $subsection bignum? }
|
||||||
{ $subsection >fixnum }
|
{ $subsection >fixnum }
|
||||||
|
{ $subsection >integer }
|
||||||
{ $subsection >bignum }
|
{ $subsection >bignum }
|
||||||
{ $see-also "prettyprint-numbers" "modular-arithmetic" "bitwise-arithmetic" "integer-functions" "syntax-integers" } ;
|
{ $see-also "prettyprint-numbers" "modular-arithmetic" "bitwise-arithmetic" "integer-functions" "syntax-integers" } ;
|
||||||
|
|
||||||
|
|
|
@ -6,6 +6,7 @@ IN: math.integers.private
|
||||||
|
|
||||||
M: integer numerator ;
|
M: integer numerator ;
|
||||||
M: integer denominator drop 1 ;
|
M: integer denominator drop 1 ;
|
||||||
|
M: integer >integer ;
|
||||||
|
|
||||||
M: fixnum >fixnum ;
|
M: fixnum >fixnum ;
|
||||||
M: fixnum >bignum fixnum>bignum ;
|
M: fixnum >bignum fixnum>bignum ;
|
||||||
|
|
|
@ -5,6 +5,7 @@ IN: math
|
||||||
|
|
||||||
GENERIC: >fixnum ( x -- y ) foldable
|
GENERIC: >fixnum ( x -- y ) foldable
|
||||||
GENERIC: >bignum ( x -- y ) foldable
|
GENERIC: >bignum ( x -- y ) foldable
|
||||||
|
GENERIC: >integer ( x -- y ) foldable
|
||||||
GENERIC: >float ( x -- y ) foldable
|
GENERIC: >float ( x -- y ) foldable
|
||||||
|
|
||||||
MATH: number= ( x y -- ? ) foldable
|
MATH: number= ( x y -- ? ) foldable
|
||||||
|
|
|
@ -379,7 +379,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
||||||
>r dup dup node-in-d first node-interval
|
>r dup dup node-in-d first node-interval
|
||||||
swap dup node-in-d second node-literal r> execute ; inline
|
swap dup node-in-d second node-literal r> execute ; inline
|
||||||
|
|
||||||
: foldable-comparison? ( #call word -- )
|
: foldable-comparison? ( #call word -- ? )
|
||||||
>r dup known-comparison? [
|
>r dup known-comparison? [
|
||||||
r> perform-comparison incomparable eq? not
|
r> perform-comparison incomparable eq? not
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -17,7 +17,11 @@ ARTICLE: "threads-start/stop" "Starting and stopping threads"
|
||||||
ARTICLE: "threads-yield" "Yielding and suspending threads"
|
ARTICLE: "threads-yield" "Yielding and suspending threads"
|
||||||
"Yielding to other threads:"
|
"Yielding to other threads:"
|
||||||
{ $subsection yield }
|
{ $subsection yield }
|
||||||
|
"Sleeping for a period of time:"
|
||||||
{ $subsection sleep }
|
{ $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:"
|
"Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
|
||||||
{ $subsection suspend }
|
{ $subsection suspend }
|
||||||
{ $subsection resume }
|
{ $subsection resume }
|
||||||
|
@ -104,7 +108,16 @@ HELP: yield
|
||||||
|
|
||||||
HELP: sleep
|
HELP: sleep
|
||||||
{ $values { "ms" "a non-negative integer" } }
|
{ $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
|
HELP: suspend
|
||||||
{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } }
|
{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } }
|
||||||
|
|
|
@ -13,7 +13,7 @@ TUPLE: thread
|
||||||
name quot error-handler exit-handler
|
name quot error-handler exit-handler
|
||||||
id
|
id
|
||||||
continuation state
|
continuation state
|
||||||
mailbox variables ;
|
mailbox variables sleep-entry ;
|
||||||
|
|
||||||
: self ( -- thread ) 40 getenv ; inline
|
: self ( -- thread ) 40 getenv ; inline
|
||||||
|
|
||||||
|
@ -86,19 +86,25 @@ PRIVATE>
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: schedule-sleep ( thread ms -- )
|
: 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?
|
dup heap-empty?
|
||||||
[ drop f ] [ heap-peek nip millis <= ] if ;
|
[ drop f ] [ heap-peek nip millis <= ] if ;
|
||||||
|
|
||||||
: wake-up ( -- )
|
: expire-sleep ( thread -- )
|
||||||
|
f over set-thread-sleep-entry resume ;
|
||||||
|
|
||||||
|
: expire-sleep-loop ( -- )
|
||||||
sleep-queue
|
sleep-queue
|
||||||
[ dup wake-up? ] [ dup heap-pop drop resume ] [ ] while
|
[ dup expire-sleep? ]
|
||||||
|
[ dup heap-pop drop expire-sleep ]
|
||||||
|
[ ] while
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
: next ( -- )
|
: next ( -- )
|
||||||
wake-up
|
expire-sleep-loop
|
||||||
run-queue pop-back
|
run-queue pop-back
|
||||||
dup array? [ first2 ] [ f swap ] if dup set-self
|
dup array? [ first2 ] [ f swap ] if dup set-self
|
||||||
f over set-thread-state
|
f over set-thread-state
|
||||||
|
@ -107,7 +113,7 @@ PRIVATE>
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: sleep-time ( -- ms )
|
: sleep-time ( -- ms/f )
|
||||||
{
|
{
|
||||||
{ [ run-queue dlist-empty? not ] [ 0 ] }
|
{ [ run-queue dlist-empty? not ] [ 0 ] }
|
||||||
{ [ sleep-queue heap-empty? ] [ f ] }
|
{ [ sleep-queue heap-empty? ] [ f ] }
|
||||||
|
@ -127,14 +133,36 @@ PRIVATE>
|
||||||
|
|
||||||
: yield ( -- ) [ resume ] "yield" suspend drop ;
|
: 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 -- )
|
: (spawn) ( thread -- )
|
||||||
[
|
[
|
||||||
resume [
|
resume-now [
|
||||||
dup set-self
|
dup set-self
|
||||||
dup register-thread
|
dup register-thread
|
||||||
init-namespaces
|
init-namespaces
|
||||||
|
|
|
@ -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"
|
|
@ -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.
|
! 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
|
IN: alarms
|
||||||
|
|
||||||
TUPLE: alarm time quot ;
|
TUPLE: alarm quot time interval entry ;
|
||||||
|
|
||||||
C: <alarm> alarm
|
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
! for now a V{ }, eventually a min-heap to store alarms
|
|
||||||
SYMBOL: 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-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 ;
|
||||||
|
|
|
@ -65,7 +65,7 @@ SYMBOL: cols
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
: mandel-main ( -- )
|
: mandel-main ( -- )
|
||||||
"mandel.ppm" resource-path
|
"mandel.ppm" temp-file
|
||||||
[ mandel write ] with-file-writer ;
|
[ mandel write ] with-file-writer ;
|
||||||
|
|
||||||
MAIN: mandel-main
|
MAIN: mandel-main
|
||||||
|
|
|
@ -170,7 +170,7 @@ DEFER: create ( level c r -- scene )
|
||||||
] "" make ;
|
] "" make ;
|
||||||
|
|
||||||
: raytracer-main
|
: raytracer-main
|
||||||
"raytracer.pnm" resource-path
|
"raytracer.pnm" temp-file
|
||||||
[ run write ] with-file-writer ;
|
[ run write ] with-file-writer ;
|
||||||
|
|
||||||
MAIN: raytracer-main
|
MAIN: raytracer-main
|
||||||
|
|
|
@ -41,12 +41,10 @@ HINTS: do-line vector string ;
|
||||||
] with-disposal ;
|
] with-disposal ;
|
||||||
|
|
||||||
: reverse-complement-in
|
: reverse-complement-in
|
||||||
"extra/benchmark/reverse-complement/reverse-complement-in.txt"
|
"reverse-complement-in.txt" temp-file ;
|
||||||
resource-path ;
|
|
||||||
|
|
||||||
: reverse-complement-out
|
: reverse-complement-out
|
||||||
"extra/benchmark/reverse-complement/reverse-complement-out.txt"
|
"reverse-complement-out.txt" temp-file ;
|
||||||
resource-path ;
|
|
||||||
|
|
||||||
: reverse-complement-main ( -- )
|
: reverse-complement-main ( -- )
|
||||||
reverse-complement-in
|
reverse-complement-in
|
||||||
|
|
|
@ -99,3 +99,9 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
|
||||||
[ file-lines ] [ ] bi*
|
[ file-lines ] [ ] bi*
|
||||||
maybe-tail*
|
maybe-tail*
|
||||||
[ print ] each ;
|
[ print ] each ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
USE: prettyprint
|
||||||
|
|
||||||
|
: to-file ( object file -- ) [ . ] with-file-writer ;
|
|
@ -1,6 +1,6 @@
|
||||||
USING: alien alien.c-types arrays sequences math
|
USING: alien alien.c-types arrays sequences math
|
||||||
math.vectors math.matrices math.parser io io.files kernel opengl
|
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
|
namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
|
||||||
combinators tools.time system combinators.lib combinators.cleave
|
combinators tools.time system combinators.lib combinators.cleave
|
||||||
float-arrays continuations opengl.demo-support multiline
|
float-arrays continuations opengl.demo-support multiline
|
||||||
|
|
|
@ -5,7 +5,7 @@ USING: arrays hashtables io io.streams.string kernel math
|
||||||
math.vectors math.functions math.parser namespaces sequences
|
math.vectors math.functions math.parser namespaces sequences
|
||||||
strings tuples system debugger combinators vocabs.loader
|
strings tuples system debugger combinators vocabs.loader
|
||||||
calendar.backend structs alien.c-types math.vectors
|
calendar.backend structs alien.c-types math.vectors
|
||||||
math.ranges shuffle ;
|
shuffle threads ;
|
||||||
IN: calendar
|
IN: calendar
|
||||||
|
|
||||||
TUPLE: timestamp year month day hour minute second gmt-offset ;
|
TUPLE: timestamp year month day hour minute second gmt-offset ;
|
||||||
|
@ -225,6 +225,12 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
||||||
: unix-1970 ( -- timestamp )
|
: unix-1970 ( -- timestamp )
|
||||||
1970 1 1 0 0 0 0 <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 )
|
: unix-time>timestamp ( n -- timestamp )
|
||||||
>r unix-1970 r> seconds +dt ;
|
>r unix-1970 r> seconds +dt ;
|
||||||
|
|
||||||
|
@ -467,6 +473,10 @@ M: timestamp year. ( timestamp -- )
|
||||||
: seconds-since-midnight ( timestamp -- x )
|
: seconds-since-midnight ( timestamp -- x )
|
||||||
dup beginning-of-day timestamp- ;
|
dup beginning-of-day timestamp- ;
|
||||||
|
|
||||||
|
M: timestamp nap-until timestamp>millis nap-until ;
|
||||||
|
|
||||||
|
M: dt nap from-now nap-until ;
|
||||||
|
|
||||||
{
|
{
|
||||||
{ [ unix? ] [ "calendar.unix" ] }
|
{ [ unix? ] [ "calendar.unix" ] }
|
||||||
{ [ windows? ] [ "calendar.windows" ] }
|
{ [ windows? ] [ "calendar.windows" ] }
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
IN: temporary
|
IN: temporary
|
||||||
USING: concurrency.combinators tools.test random kernel math
|
USING: concurrency.combinators tools.test random kernel math
|
||||||
concurrency.messaging threads sequences ;
|
concurrency.mailboxes threads sequences ;
|
||||||
|
|
||||||
[ [ drop ] parallel-each ] must-infer
|
[ [ drop ] parallel-each ] must-infer
|
||||||
[ [ ] parallel-map ] must-infer
|
[ [ ] parallel-map ] must-infer
|
||||||
|
|
|
@ -1,14 +1,27 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: concurrency.conditions
|
||||||
|
|
||||||
: notify-1 ( dlist -- )
|
: 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 -- )
|
: 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 -- )
|
: 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 ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: dlists kernel math concurrency.promises
|
USING: dlists kernel math concurrency.promises
|
||||||
concurrency.messaging ;
|
concurrency.mailboxes ;
|
||||||
IN: concurrency.count-downs
|
IN: concurrency.count-downs
|
||||||
|
|
||||||
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
|
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: concurrency.promises concurrency.messaging kernel arrays
|
USING: concurrency.promises concurrency.mailboxes kernel arrays
|
||||||
continuations ;
|
continuations ;
|
||||||
IN: concurrency.futures
|
IN: concurrency.futures
|
||||||
|
|
||||||
|
@ -11,7 +11,7 @@ IN: concurrency.futures
|
||||||
] keep ; inline
|
] keep ; inline
|
||||||
|
|
||||||
: ?future-timeout ( future timeout -- value )
|
: ?future-timeout ( future timeout -- value )
|
||||||
?promise-timeout ;
|
?promise-timeout ?linked ;
|
||||||
|
|
||||||
: ?future ( future -- value )
|
: ?future ( future -- value )
|
||||||
?promise ;
|
?promise ?linked ;
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
IN: temporary
|
IN: temporary
|
||||||
USING: tools.test concurrency.locks concurrency.count-downs
|
USING: tools.test concurrency.locks concurrency.count-downs
|
||||||
locals kernel threads sequences ;
|
concurrency.messaging concurrency.mailboxes locals kernel
|
||||||
|
threads sequences calendar ;
|
||||||
|
|
||||||
:: lock-test-0 | |
|
:: lock-test-0 | |
|
||||||
[let | v [ V{ } clone ]
|
[let | v [ V{ } clone ]
|
||||||
|
@ -32,7 +33,7 @@ locals kernel threads sequences ;
|
||||||
c [ 2 <count-down> ] |
|
c [ 2 <count-down> ] |
|
||||||
|
|
||||||
[
|
[
|
||||||
l f [
|
l [
|
||||||
yield
|
yield
|
||||||
1 v push
|
1 v push
|
||||||
yield
|
yield
|
||||||
|
@ -42,7 +43,7 @@ locals kernel threads sequences ;
|
||||||
] "Lock test 1" spawn drop
|
] "Lock test 1" spawn drop
|
||||||
|
|
||||||
[
|
[
|
||||||
l f [
|
l [
|
||||||
yield
|
yield
|
||||||
3 v push
|
3 v push
|
||||||
yield
|
yield
|
||||||
|
@ -59,8 +60,8 @@ locals kernel threads sequences ;
|
||||||
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
|
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
|
||||||
|
|
||||||
[ 3 ] [
|
[ 3 ] [
|
||||||
<reentrant-lock> dup f [
|
<reentrant-lock> dup [
|
||||||
f [
|
[
|
||||||
3
|
3
|
||||||
] with-lock
|
] with-lock
|
||||||
] with-lock
|
] with-lock
|
||||||
|
@ -68,15 +69,15 @@ locals kernel threads sequences ;
|
||||||
|
|
||||||
[ ] [ <rw-lock> drop ] unit-test
|
[ ] [ <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 | |
|
:: rw-lock-test-1 | |
|
||||||
[let | l [ <rw-lock> ]
|
[let | l [ <rw-lock> ]
|
||||||
|
@ -86,7 +87,7 @@ locals kernel threads sequences ;
|
||||||
v [ V{ } clone ] |
|
v [ V{ } clone ] |
|
||||||
|
|
||||||
[
|
[
|
||||||
l f [
|
l [
|
||||||
1 v push
|
1 v push
|
||||||
c count-down
|
c count-down
|
||||||
yield
|
yield
|
||||||
|
@ -97,7 +98,7 @@ locals kernel threads sequences ;
|
||||||
|
|
||||||
[
|
[
|
||||||
c await
|
c await
|
||||||
l f [
|
l [
|
||||||
4 v push
|
4 v push
|
||||||
1000 sleep
|
1000 sleep
|
||||||
5 v push
|
5 v push
|
||||||
|
@ -107,7 +108,7 @@ locals kernel threads sequences ;
|
||||||
|
|
||||||
[
|
[
|
||||||
c await
|
c await
|
||||||
l f [
|
l [
|
||||||
2 v push
|
2 v push
|
||||||
c' count-down
|
c' count-down
|
||||||
] with-read-lock
|
] with-read-lock
|
||||||
|
@ -116,7 +117,7 @@ locals kernel threads sequences ;
|
||||||
|
|
||||||
[
|
[
|
||||||
c' await
|
c' await
|
||||||
l f [
|
l [
|
||||||
6 v push
|
6 v push
|
||||||
] with-write-lock
|
] with-write-lock
|
||||||
c'' count-down
|
c'' count-down
|
||||||
|
@ -135,7 +136,7 @@ locals kernel threads sequences ;
|
||||||
v [ V{ } clone ] |
|
v [ V{ } clone ] |
|
||||||
|
|
||||||
[
|
[
|
||||||
l f [
|
l [
|
||||||
1 v push
|
1 v push
|
||||||
c count-down
|
c count-down
|
||||||
1000 sleep
|
1000 sleep
|
||||||
|
@ -146,7 +147,7 @@ locals kernel threads sequences ;
|
||||||
|
|
||||||
[
|
[
|
||||||
c await
|
c await
|
||||||
l f [
|
l [
|
||||||
3 v push
|
3 v push
|
||||||
] with-read-lock
|
] with-read-lock
|
||||||
c' count-down
|
c' count-down
|
||||||
|
@ -157,3 +158,21 @@ locals kernel threads sequences ;
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
|
[ 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
|
||||||
|
|
|
@ -25,15 +25,15 @@ TUPLE: lock threads owner reentrant? ;
|
||||||
lock-threads notify-1 ;
|
lock-threads notify-1 ;
|
||||||
|
|
||||||
: do-lock ( lock timeout quot acquire release -- )
|
: 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 -- )
|
: (with-lock) ( lock timeout quot -- )
|
||||||
[ acquire-lock ] [ release-lock ] do-lock ; inline
|
[ acquire-lock ] [ release-lock ] do-lock ; inline
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: with-lock ( lock timeout quot -- )
|
: with-lock-timeout ( lock timeout quot -- )
|
||||||
pick lock-reentrant? [
|
pick lock-reentrant? [
|
||||||
pick lock-owner self eq? [
|
pick lock-owner self eq? [
|
||||||
2nip call
|
2nip call
|
||||||
|
@ -44,6 +44,9 @@ PRIVATE>
|
||||||
(with-lock)
|
(with-lock)
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
|
: with-lock ( lock quot -- )
|
||||||
|
f swap with-lock-timeout ; inline
|
||||||
|
|
||||||
! Many-reader/single-writer locks
|
! Many-reader/single-writer locks
|
||||||
TUPLE: rw-lock readers writers reader# writer ;
|
TUPLE: rw-lock readers writers reader# writer ;
|
||||||
|
|
||||||
|
@ -79,12 +82,18 @@ TUPLE: rw-lock readers writers reader# writer ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: with-read-lock ( lock timeout quot -- )
|
: with-read-lock-timeout ( lock timeout quot -- )
|
||||||
[
|
[
|
||||||
[ acquire-read-lock ] [ release-read-lock ] do-lock
|
[ acquire-read-lock ] [ release-read-lock ] do-lock
|
||||||
] do-reentrant-rw-lock ; inline
|
] 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
|
[ acquire-write-lock ] [ release-write-lock ] do-lock
|
||||||
] do-reentrant-rw-lock ; inline
|
] do-reentrant-rw-lock ; inline
|
||||||
|
|
||||||
|
: with-write-lock ( lock quot -- )
|
||||||
|
f swap with-write-lock-timeout ; inline
|
||||||
|
|
|
@ -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 } ;
|
|
@ -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
|
|
@ -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 ;
|
|
@ -4,70 +4,6 @@ USING: help.syntax help.markup concurrency.messaging.private
|
||||||
threads kernel arrays quotations ;
|
threads kernel arrays quotations ;
|
||||||
IN: concurrency.messaging
|
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
|
HELP: send
|
||||||
{ $values { "message" object }
|
{ $values { "message" object }
|
||||||
{ "thread" "a thread 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" }
|
{ $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 } ;
|
{ $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
|
$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."
|
"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
|
$nl
|
||||||
|
@ -104,14 +40,9 @@ $nl
|
||||||
{ $subsection send }
|
{ $subsection send }
|
||||||
"A thread can get a message from its queue:"
|
"A thread can get a message from its queue:"
|
||||||
{ $subsection receive }
|
{ $subsection receive }
|
||||||
{ $subsection receive }
|
{ $subsection receive-timeout }
|
||||||
{ $subsection receive-if }
|
{ $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"
|
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:"
|
"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" }
|
{ $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."
|
"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 }
|
{ $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:"
|
"This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
|
||||||
{ $code "["
|
{ $code "["
|
||||||
" [ 1 0 / \"This will not print\" print ] spawn-linked drop"
|
" [ 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."
|
"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
|
$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."
|
"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" "synchronous-sends" } }
|
||||||
{ $subsection { "concurrency" "exceptions" } } ;
|
{ $subsection { "concurrency" "exceptions" } } ;
|
||||||
|
|
||||||
|
|
|
@ -3,48 +3,10 @@
|
||||||
!
|
!
|
||||||
USING: kernel threads vectors arrays sequences
|
USING: kernel threads vectors arrays sequences
|
||||||
namespaces tools.test continuations dlists strings math words
|
namespaces tools.test continuations dlists strings math words
|
||||||
match quotations concurrency.messaging ;
|
match quotations concurrency.messaging concurrency.mailboxes ;
|
||||||
IN: temporary
|
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" ] [
|
[ "received" ] [
|
||||||
[
|
[
|
||||||
|
|
|
@ -1,80 +1,11 @@
|
||||||
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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.
|
! concurrency.
|
||||||
|
USING: kernel threads concurrency.mailboxes continuations
|
||||||
|
namespaces assocs random ;
|
||||||
IN: concurrency.messaging
|
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 -- )
|
GENERIC: send ( message process -- )
|
||||||
|
|
||||||
|
@ -86,25 +17,25 @@ GENERIC: send ( message process -- )
|
||||||
M: thread send ( message thread -- )
|
M: thread send ( message thread -- )
|
||||||
check-registered mailbox-of mailbox-put ;
|
check-registered mailbox-of mailbox-put ;
|
||||||
|
|
||||||
: ?linked dup linked? [ rethrow ] when ;
|
: my-mailbox self mailbox-of ;
|
||||||
|
|
||||||
: mailbox self mailbox-of ;
|
|
||||||
|
|
||||||
: receive ( -- message )
|
: 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 )
|
: 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 -- )
|
: rethrow-linked ( error process supervisor -- )
|
||||||
>r <linked> r> send ;
|
>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 )
|
: spawn-linked ( quot name -- thread )
|
||||||
mailbox spawn-linked-to ;
|
my-mailbox spawn-linked-to ;
|
||||||
|
|
||||||
TUPLE: synchronous data sender tag ;
|
TUPLE: synchronous data sender tag ;
|
||||||
|
|
||||||
|
@ -116,17 +47,18 @@ TUPLE: reply data tag ;
|
||||||
: <reply> ( data synchronous -- reply )
|
: <reply> ( data synchronous -- reply )
|
||||||
synchronous-tag \ reply construct-boa ;
|
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 )
|
: send-synchronous ( message thread -- reply )
|
||||||
dup self eq? [
|
dup self eq? [
|
||||||
"Cannot synchronous send to myself" throw
|
"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 ;
|
] if ;
|
||||||
|
|
||||||
: reply-synchronous ( message synchronous -- )
|
: reply-synchronous ( message synchronous -- )
|
||||||
|
@ -139,18 +71,18 @@ TUPLE: reply data tag ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: remote-processes ( -- hash )
|
: registered-processes ( -- hash )
|
||||||
\ remote-processes get-global ;
|
\ registered-processes get-global ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: register-process ( name process -- )
|
: register-process ( name process -- )
|
||||||
swap remote-processes set-at ;
|
swap registered-processes set-at ;
|
||||||
|
|
||||||
: unregister-process ( name -- )
|
: unregister-process ( name -- )
|
||||||
remote-processes delete-at ;
|
registered-processes delete-at ;
|
||||||
|
|
||||||
: get-process ( name -- process )
|
: 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
|
||||||
|
|
|
@ -1,7 +1,6 @@
|
||||||
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: concurrency.messaging concurrency.messaging.private
|
USING: concurrency.mailboxes kernel continuations ;
|
||||||
kernel ;
|
|
||||||
IN: concurrency.promises
|
IN: concurrency.promises
|
||||||
|
|
||||||
TUPLE: promise mailbox ;
|
TUPLE: promise mailbox ;
|
||||||
|
@ -20,8 +19,7 @@ TUPLE: promise mailbox ;
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: ?promise-timeout ( promise timeout -- result )
|
: ?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 )
|
: ?promise ( promise -- result )
|
||||||
f ?promise-timeout ;
|
f ?promise-timeout ;
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
IN: concurrency.semaphores
|
IN: concurrency.semaphores
|
||||||
USING: help.markup help.syntax kernel quotations ;
|
USING: help.markup help.syntax kernel quotations calendar ;
|
||||||
|
|
||||||
HELP: semaphore
|
HELP: semaphore
|
||||||
{ $class-description "The class of counting semaphores." } ;
|
{ $class-description "The class of counting semaphores." } ;
|
||||||
|
@ -8,14 +8,23 @@ HELP: <semaphore>
|
||||||
{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } }
|
{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } }
|
||||||
{ $description "Creates a counting semaphore with the specified initial count." } ;
|
{ $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
|
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
|
HELP: release
|
||||||
{ $values { "semaphore" semaphore } }
|
{ $values { "semaphore" semaphore } }
|
||||||
{ $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ;
|
{ $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
|
HELP: with-semaphore
|
||||||
{ $values { "semaphore" semaphore } { "quot" quotation } }
|
{ $values { "semaphore" semaphore } { "quot" quotation } }
|
||||||
{ $description "Calls the quotation with the semaphore held." } ;
|
{ $description "Calls the quotation with the semaphore held." } ;
|
||||||
|
@ -38,8 +47,10 @@ $nl
|
||||||
{ $subsection <semaphore> }
|
{ $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:"
|
"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 }
|
||||||
|
{ $subsection acquire-timeout }
|
||||||
{ $subsection release }
|
{ $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"
|
ABOUT: "concurrency.semaphores"
|
||||||
|
|
|
@ -13,17 +13,21 @@ TUPLE: semaphore count threads ;
|
||||||
: wait-to-acquire ( semaphore timeout -- )
|
: wait-to-acquire ( semaphore timeout -- )
|
||||||
>r semaphore-threads r> "semaphore" wait ;
|
>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 -- )
|
: release ( semaphore -- )
|
||||||
dup semaphore-count 1+ over set-semaphore-count
|
dup semaphore-count 1+ over set-semaphore-count
|
||||||
semaphore-threads notify-1 ;
|
semaphore-threads notify-1 ;
|
||||||
|
|
||||||
|
: with-semaphore-timeout ( semaphore timeout quot -- )
|
||||||
|
pick rot acquire-timeout swap
|
||||||
|
[ release ] curry [ ] cleanup ; inline
|
||||||
|
|
||||||
: with-semaphore ( semaphore quot -- )
|
: with-semaphore ( semaphore quot -- )
|
||||||
over acquire [ release ] curry [ ] cleanup ; inline
|
over acquire swap [ release ] curry [ ] cleanup ; inline
|
||||||
|
|
|
@ -99,6 +99,7 @@ $nl
|
||||||
{ $subsection "concurrency.combinators" }
|
{ $subsection "concurrency.combinators" }
|
||||||
{ $subsection "concurrency.promises" }
|
{ $subsection "concurrency.promises" }
|
||||||
{ $subsection "concurrency.futures" }
|
{ $subsection "concurrency.futures" }
|
||||||
|
{ $subsection "concurrency.mailboxes" }
|
||||||
{ $subsection "concurrency.messaging" }
|
{ $subsection "concurrency.messaging" }
|
||||||
"Shared-state abstractions:"
|
"Shared-state abstractions:"
|
||||||
{ $subsection "concurrency.locks" }
|
{ $subsection "concurrency.locks" }
|
||||||
|
|
|
@ -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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs http kernel math math.parser namespaces sequences
|
USING: assocs http kernel math math.parser namespaces sequences
|
||||||
io io.sockets io.streams.string io.files io.timeouts strings
|
io io.sockets io.streams.string io.files io.timeouts strings
|
||||||
splitting continuations assocs.lib ;
|
splitting continuations assocs.lib calendar ;
|
||||||
IN: http.client
|
IN: http.client
|
||||||
|
|
||||||
: parse-host ( url -- host port )
|
: parse-host ( url -- host port )
|
||||||
|
@ -47,7 +47,7 @@ DEFER: http-get-stream
|
||||||
dispose "location" swap peek-at nip http-get-stream
|
dispose "location" swap peek-at nip http-get-stream
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: default-timeout 60 1000 * over set-timeout ;
|
: default-timeout 1 minutes over set-timeout ;
|
||||||
|
|
||||||
: http-get-stream ( url -- code headers stream )
|
: http-get-stream ( url -- code headers stream )
|
||||||
#! Opens a stream for reading from an HTTP URL.
|
#! Opens a stream for reading from an HTTP URL.
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs kernel namespaces io io.timeouts strings splitting
|
USING: assocs kernel namespaces io io.timeouts strings splitting
|
||||||
threads http http.server.responders sequences prettyprint
|
threads http http.server.responders sequences prettyprint
|
||||||
io.server logging ;
|
io.server logging calendar ;
|
||||||
|
|
||||||
IN: http.server
|
IN: http.server
|
||||||
|
|
||||||
|
@ -50,7 +50,7 @@ IN: http.server
|
||||||
|
|
||||||
: httpd ( port -- )
|
: httpd ( port -- )
|
||||||
internet-server "http.server" [
|
internet-server "http.server" [
|
||||||
60000 stdio get set-timeout
|
1 minutes stdio get set-timeout
|
||||||
readln [ parse-request ] when*
|
readln [ parse-request ] when*
|
||||||
] with-server ;
|
] with-server ;
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: io.launcher
|
||||||
|
|
||||||
HELP: +command+
|
HELP: +command+
|
||||||
|
@ -77,7 +78,7 @@ $nl
|
||||||
"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
|
"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
|
||||||
|
|
||||||
HELP: +timeout+
|
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
|
HELP: default-descriptor
|
||||||
{ $description "Association storing default values for launch descriptor keys." } ;
|
{ $description "Association storing default values for launch descriptor keys." } ;
|
||||||
|
|
|
@ -10,14 +10,14 @@ SYMBOL: processes
|
||||||
|
|
||||||
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
|
[ 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 -- )
|
HOOK: register-process io-backend ( process -- )
|
||||||
|
|
||||||
M: object register-process drop ;
|
M: object register-process drop ;
|
||||||
|
|
||||||
: <process> ( handle -- process )
|
: <process> ( handle -- process )
|
||||||
f f <lapse> process construct-boa
|
f f f process construct-boa
|
||||||
V{ } clone over processes get set-at
|
V{ } clone over processes get set-at
|
||||||
dup register-process ;
|
dup register-process ;
|
||||||
|
|
||||||
|
@ -115,7 +115,9 @@ HOOK: kill-process* io-backend ( handle -- )
|
||||||
t over set-process-killed?
|
t over set-process-killed?
|
||||||
process-handle [ kill-process* ] when* ;
|
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 ;
|
M: process timed-out kill-process ;
|
||||||
|
|
||||||
|
|
|
@ -13,11 +13,12 @@ SYMBOL: default-buffer-size
|
||||||
TUPLE: port
|
TUPLE: port
|
||||||
handle
|
handle
|
||||||
error
|
error
|
||||||
lapse
|
timeout
|
||||||
type eof? ;
|
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
|
SYMBOL: closed
|
||||||
|
|
||||||
|
@ -28,12 +29,10 @@ GENERIC: init-handle ( handle -- )
|
||||||
GENERIC: close-handle ( handle -- )
|
GENERIC: close-handle ( handle -- )
|
||||||
|
|
||||||
: <port> ( handle buffer type -- port )
|
: <port> ( handle buffer type -- port )
|
||||||
pick init-handle
|
pick init-handle {
|
||||||
<lapse> {
|
|
||||||
set-port-handle
|
set-port-handle
|
||||||
set-delegate
|
set-delegate
|
||||||
set-port-type
|
set-port-type
|
||||||
set-port-lapse
|
|
||||||
} port construct ;
|
} port construct ;
|
||||||
|
|
||||||
: <buffered-port> ( handle type -- port )
|
: <buffered-port> ( handle type -- port )
|
||||||
|
|
|
@ -1,14 +1,13 @@
|
||||||
IN: io.timeouts
|
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
|
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
|
HELP: timed-out
|
||||||
{ $values { "obj" object } }
|
{ $values { "obj" object } }
|
||||||
|
@ -20,13 +19,12 @@ HELP: with-timeout
|
||||||
|
|
||||||
ARTICLE: "io.timeouts" "I/O timeout protocol"
|
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."
|
"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 }
|
{ $subsection set-timeout }
|
||||||
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
|
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
|
||||||
{ $subsection get-lapse }
|
|
||||||
{ $subsection timed-out }
|
{ $subsection timed-out }
|
||||||
"A combinator to be used in operations which can time out:"
|
"A combinator to be used in operations which can time out:"
|
||||||
{ $subsection with-timeout }
|
{ $subsection with-timeout }
|
||||||
{ $see-also "stream-protocol" "io.launcher" }
|
{ $see-also "stream-protocol" "io.launcher" } ;
|
||||||
;
|
|
||||||
|
|
||||||
ABOUT: "io.timeouts"
|
ABOUT: "io.timeouts"
|
||||||
|
|
|
@ -1,79 +1,27 @@
|
||||||
! Copyright (C) 2008 Slava Pestov, Doug Coleman
|
! Copyright (C) 2008 Slava Pestov, Doug Coleman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: io.timeouts
|
||||||
|
|
||||||
TUPLE: lapse entry timeout cutoff ;
|
|
||||||
|
|
||||||
: <lapse> f 0 0 \ lapse construct-boa ;
|
|
||||||
|
|
||||||
! Won't need this with new slot accessors
|
! 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-in set-timeout
|
||||||
duplex-stream-out 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 -- )
|
GENERIC: timed-out ( obj -- )
|
||||||
|
|
||||||
M: object timed-out drop ;
|
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 -- )
|
: 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
|
|
||||||
|
|
|
@ -178,7 +178,7 @@ M: write-task do-io-task
|
||||||
M: port port-flush ( port -- )
|
M: port port-flush ( port -- )
|
||||||
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
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 ;
|
mx get-global wait-for-events ;
|
||||||
|
|
||||||
M: unix-io init-stdio ( -- )
|
M: unix-io init-stdio ( -- )
|
||||||
|
|
|
@ -66,7 +66,8 @@ M: kqueue-mx unregister-io-task ( task mx -- )
|
||||||
[ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
|
[ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
|
||||||
|
|
||||||
M: kqueue-mx wait-for-events ( ms mx -- )
|
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 )
|
: make-proc-kevent ( pid -- kevent )
|
||||||
"kevent" <c-object>
|
"kevent" <c-object>
|
||||||
|
|
|
@ -49,7 +49,7 @@ TUPLE: select-mx read-fdset write-fdset ;
|
||||||
f ;
|
f ;
|
||||||
|
|
||||||
M: select-mx wait-for-events ( ms mx -- )
|
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
|
select multiplexer-error
|
||||||
dup read-fdset/tasks pick handle-fdset
|
dup read-fdset/tasks pick handle-fdset
|
||||||
dup write-fdset/tasks rot handle-fdset ;
|
dup write-fdset/tasks rot handle-fdset ;
|
||||||
|
|
|
@ -38,8 +38,8 @@ yield
|
||||||
"unix-domain-datagram-test" resource-path delete-file
|
"unix-domain-datagram-test" resource-path delete-file
|
||||||
] ignore-errors
|
] 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
|
"unix-domain-datagram-test-3" resource-path delete-file
|
||||||
] ignore-errors
|
] 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
|
[ ] [ client-addr <datagram> "d" set ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -7,7 +7,9 @@ IN: io.windows.ce.backend
|
||||||
: port-errored ( port -- )
|
: port-errored ( port -- )
|
||||||
win32-error-string swap set-port-error ;
|
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 ;
|
M: windows-ce-io add-completion ( handle -- ) drop ;
|
||||||
|
|
||||||
GENERIC: wince-read ( port port-handle -- )
|
GENERIC: wince-read ( port port-handle -- )
|
||||||
|
|
|
@ -146,10 +146,16 @@ M: windows-io kill-process* ( handle -- )
|
||||||
|
|
||||||
: wait-loop ( -- )
|
: wait-loop ( -- )
|
||||||
processes get dup assoc-empty?
|
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 ( -- )
|
: 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
|
[ start-wait-thread ] "io.windows.launcher" add-init-hook
|
||||||
|
|
|
@ -57,7 +57,8 @@ M: windows-nt-io add-completion ( handle -- )
|
||||||
] "I/O" suspend 3drop ;
|
] "I/O" suspend 3drop ;
|
||||||
|
|
||||||
: wait-for-overlapped ( ms -- overlapped ? )
|
: 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
|
0 <int> ! bytes
|
||||||
f <void*> ! key
|
f <void*> ! key
|
||||||
f <void*> ! overlapped
|
f <void*> ! overlapped
|
||||||
|
|
|
@ -122,3 +122,7 @@ SYMBOL: a
|
||||||
USE: kernel ;
|
USE: kernel ;
|
||||||
|
|
||||||
[ t ] [ a symbol? ] unit-test
|
[ t ] [ a symbol? ] unit-test
|
||||||
|
|
||||||
|
:: let-let-test | n | [let | n [ n 3 + ] | n ] ;
|
||||||
|
|
||||||
|
[ 13 ] [ 10 let-let-test ] unit-test
|
||||||
|
|
|
@ -1,10 +1,6 @@
|
||||||
USING: kernel layouts math namespaces sequences sequences.private ;
|
USING: kernel layouts math namespaces sequences sequences.private ;
|
||||||
IN: math.ranges
|
IN: math.ranges
|
||||||
|
|
||||||
: >integer ( n -- i )
|
|
||||||
dup most-negative-fixnum most-positive-fixnum between?
|
|
||||||
[ >fixnum ] [ >bignum ] if ;
|
|
||||||
|
|
||||||
TUPLE: range from length step ;
|
TUPLE: range from length step ;
|
||||||
|
|
||||||
: <range> ( from to step -- range )
|
: <range> ( from to step -- range )
|
||||||
|
|
|
@ -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
|
IN: models
|
||||||
|
|
||||||
HELP: model
|
HELP: model
|
||||||
|
@ -142,18 +143,18 @@ HELP: delay
|
||||||
{ $examples
|
{ $examples
|
||||||
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
|
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
|
||||||
{ $code
|
{ $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>"
|
": <funny-slider>"
|
||||||
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
|
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
|
||||||
"<funny-slider> dup gadget."
|
"<funny-slider> dup gadget."
|
||||||
"gadget-model 500 <delay> [ number>string ] <filter>"
|
"gadget-model 1/2 seconds <delay> [ number>string ] <filter>"
|
||||||
"<label-control> gadget."
|
"<label-control> gadget."
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: <delay>
|
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 } "." } ;
|
{ $examples "See the example in the documentation for " { $link delay } "." } ;
|
||||||
|
|
||||||
HELP: range-value
|
HELP: range-value
|
||||||
|
|
|
@ -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.
|
! 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
|
IN: models
|
||||||
|
|
||||||
TUPLE: model value connections dependencies ref locked? ;
|
TUPLE: model value connections dependencies ref locked? ;
|
||||||
|
@ -174,7 +175,7 @@ TUPLE: history back forward ;
|
||||||
dup history-forward delete-all
|
dup history-forward delete-all
|
||||||
dup history-back (add-history) ;
|
dup history-back (add-history) ;
|
||||||
|
|
||||||
TUPLE: delay model timeout ;
|
TUPLE: delay model timeout alarm ;
|
||||||
|
|
||||||
: update-delay-model ( delay -- )
|
: update-delay-model ( delay -- )
|
||||||
dup delay-model model-value swap set-model ;
|
dup delay-model model-value swap set-model ;
|
||||||
|
@ -185,12 +186,18 @@ TUPLE: delay model timeout ;
|
||||||
[ set-delay-model ] 2keep
|
[ set-delay-model ] 2keep
|
||||||
[ add-dependency ] keep ;
|
[ 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 model-activated update-delay-model ;
|
||||||
|
|
||||||
M: delay tick dup remove-timer update-delay-model ;
|
|
||||||
|
|
||||||
GENERIC: range-value ( model -- value )
|
GENERIC: range-value ( model -- value )
|
||||||
GENERIC: range-page-value ( model -- value )
|
GENERIC: range-page-value ( model -- value )
|
||||||
GENERIC: range-min-value ( model -- value )
|
GENERIC: range-min-value ( model -- value )
|
||||||
|
|
|
@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ;
|
||||||
dup player-gadget [
|
dup player-gadget [
|
||||||
dup { player-td player-yuv } get-slots theora_decode_YUVout drop
|
dup { player-td player-yuv } get-slots theora_decode_YUVout drop
|
||||||
dup player-rgb over player-yuv yuv>rgb
|
dup player-rgb over player-yuv yuv>rgb
|
||||||
dup player-gadget find-world dup draw-world
|
dup player-gadget find-world draw-world
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: num-audio-buffers-processed ( player -- player n )
|
: num-audio-buffers-processed ( player -- player n )
|
||||||
|
|
|
@ -66,7 +66,7 @@ SYMBOL: data-mode
|
||||||
"Starting SMTP server on port " write dup . flush
|
"Starting SMTP server on port " write dup . flush
|
||||||
"127.0.0.1" swap <inet4> <server> [
|
"127.0.0.1" swap <inet4> <server> [
|
||||||
accept [
|
accept [
|
||||||
60000 stdio get set-timeout
|
1 minutes stdio get set-timeout
|
||||||
"220 hello\r\n" write flush
|
"220 hello\r\n" write flush
|
||||||
process
|
process
|
||||||
global [ flush ] bind
|
global [ flush ] bind
|
||||||
|
|
|
@ -3,8 +3,9 @@
|
||||||
!
|
!
|
||||||
USING: cpu.8080 cpu.8080.emulator openal math alien.c-types
|
USING: cpu.8080 cpu.8080.emulator openal math alien.c-types
|
||||||
sequences kernel shuffle arrays io.files combinators ui.gestures
|
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
|
IN: space-invaders
|
||||||
|
|
||||||
TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
|
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 )
|
: sync-frame ( millis -- millis )
|
||||||
#! Sleep until the time for the next frame arrives.
|
#! Sleep until the time for the next frame arrives.
|
||||||
1000 60 / >fixnum + millis - dup 0 >
|
1000 60 / >fixnum + millis - dup 0 >
|
||||||
[ sleep ] [ drop yield ] if millis ;
|
[ threads:sleep ] [ drop threads:yield ] if millis ;
|
||||||
|
|
||||||
: invaders-process ( millis gadget -- )
|
: invaders-process ( millis gadget -- )
|
||||||
#! Run a space invaders gadget inside a
|
#! Run a space invaders gadget inside a
|
||||||
|
@ -356,7 +357,7 @@ M: invaders-gadget graft* ( gadget -- )
|
||||||
dup invaders-gadget-cpu init-sounds
|
dup invaders-gadget-cpu init-sounds
|
||||||
f over set-invaders-gadget-quit?
|
f over set-invaders-gadget-quit?
|
||||||
[ millis swap invaders-process ] curry
|
[ millis swap invaders-process ] curry
|
||||||
"Space invaders" spawn drop ;
|
"Space invaders" threads:spawn drop ;
|
||||||
|
|
||||||
M: invaders-gadget ungraft* ( gadget -- )
|
M: invaders-gadget ungraft* ( gadget -- )
|
||||||
t swap set-invaders-gadget-quit? ;
|
t swap set-invaders-gadget-quit? ;
|
||||||
|
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
|
@ -1 +0,0 @@
|
||||||
Simple low-resolution timers
|
|
|
@ -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"
|
|
|
@ -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 ;
|
|
|
@ -2,17 +2,24 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: tools.threads
|
IN: tools.threads
|
||||||
USING: threads kernel prettyprint prettyprint.config
|
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 -- )
|
: thread. ( thread -- )
|
||||||
dup thread-id pprint-cell
|
dup thread-id pprint-cell
|
||||||
dup thread-name over [ write-object ] with-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. ( -- )
|
: threads. ( -- )
|
||||||
standard-table-style [
|
standard-table-style [
|
||||||
[
|
[
|
||||||
{ "ID" "Name" "Waiting on" }
|
{ "ID" "Name" "Waiting on" "Remaining sleep" }
|
||||||
[ [ write ] with-cell ] each
|
[ [ write ] with-cell ] each
|
||||||
] with-row
|
] with-row
|
||||||
|
|
||||||
|
|
|
@ -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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays ui.commands ui.gadgets ui.gadgets.borders
|
USING: arrays ui.commands ui.gadgets ui.gadgets.borders
|
||||||
ui.gadgets.labels ui.gadgets.theme
|
ui.gadgets.labels ui.gadgets.theme
|
||||||
|
@ -88,6 +88,7 @@ TUPLE: repeat-button ;
|
||||||
|
|
||||||
repeat-button H{
|
repeat-button H{
|
||||||
{ T{ drag } [ button-clicked ] }
|
{ T{ drag } [ button-clicked ] }
|
||||||
|
{ T{ button-down } [ button-clicked ] }
|
||||||
} set-gestures
|
} set-gestures
|
||||||
|
|
||||||
: <repeat-button> ( label quot -- button )
|
: <repeat-button> ( label quot -- button )
|
||||||
|
|
|
@ -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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays hashtables kernel models math namespaces sequences
|
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
|
IN: ui.gadgets
|
||||||
|
|
||||||
TUPLE: rect loc dim ;
|
TUPLE: rect loc dim ;
|
||||||
|
|
|
@ -1,11 +1,12 @@
|
||||||
! Copyright (C) 2007 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: models sequences ui.gadgets.labels ui.gadgets.theme
|
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
|
IN: ui.gadgets.status-bar
|
||||||
|
|
||||||
: <status-bar> ( model -- gadget )
|
: <status-bar> ( model -- gadget )
|
||||||
100 <delay> [ "" like ] <filter> <label-control>
|
1/10 seconds <delay> [ "" like ] <filter> <label-control>
|
||||||
dup reverse-video-theme
|
dup reverse-video-theme
|
||||||
t over set-gadget-root? ;
|
t over set-gadget-root? ;
|
||||||
|
|
||||||
|
|
|
@ -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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays assocs kernel math models namespaces
|
USING: arrays assocs kernel math models namespaces
|
||||||
sequences words strings system hashtables math.parser
|
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
|
IN: ui.gestures
|
||||||
|
|
||||||
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
|
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
|
||||||
|
@ -107,20 +108,21 @@ SYMBOL: double-click-timeout
|
||||||
: drag-gesture ( -- )
|
: drag-gesture ( -- )
|
||||||
hand-buttons get-global first <drag> button-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 ( -- )
|
: start-drag-timer ( -- )
|
||||||
hand-buttons get-global empty? [
|
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 ;
|
] when ;
|
||||||
|
|
||||||
: stop-drag-timer ( -- )
|
: stop-drag-timer ( -- )
|
||||||
hand-buttons get-global empty? [
|
hand-buttons get-global empty? [
|
||||||
drag-timer get-global remove-timer
|
drag-timer get-global box> cancel-alarm
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: fire-motion ( -- )
|
: fire-motion ( -- )
|
||||||
|
|
|
@ -6,7 +6,7 @@ math.vectors models namespaces parser prettyprint quotations
|
||||||
sequences sequences.lib strings threads listener
|
sequences sequences.lib strings threads listener
|
||||||
tuples ui.commands ui.gadgets ui.gadgets.editors
|
tuples ui.commands ui.gadgets ui.gadgets.editors
|
||||||
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
|
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
|
||||||
definitions boxes ;
|
definitions boxes calendar ;
|
||||||
IN: ui.tools.interactor
|
IN: ui.tools.interactor
|
||||||
|
|
||||||
TUPLE: interactor
|
TUPLE: interactor
|
||||||
|
@ -29,7 +29,8 @@ help ;
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: init-caret-help ( interactor -- )
|
: 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 -- )
|
: init-interactor-history ( interactor -- )
|
||||||
V{ } clone swap set-interactor-history ;
|
V{ } clone swap set-interactor-history ;
|
||||||
|
|
|
@ -1,12 +1,10 @@
|
||||||
USING: continuations documents ui.tools.interactor
|
USING: continuations documents ui.tools.interactor
|
||||||
ui.tools.listener hashtables kernel namespaces parser sequences
|
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
|
ui.gadgets.panes vocabs words tools.test.ui slots.private
|
||||||
threads ;
|
threads ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
timers [ init-timers ] unless
|
|
||||||
|
|
||||||
[ f ] [ "word" source-editor command-map empty? ] unit-test
|
[ f ] [ "word" source-editor command-map empty? ] unit-test
|
||||||
|
|
||||||
[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
|
[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
|
||||||
|
|
|
@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands
|
||||||
ui.gadgets ui.gadgets.editors ui.gadgets.labelled
|
ui.gadgets ui.gadgets.editors ui.gadgets.labelled
|
||||||
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
|
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
|
||||||
ui.gadgets.tracks ui.gestures ui.operations vocabs words
|
ui.gadgets.tracks ui.gestures ui.operations vocabs words
|
||||||
prettyprint listener debugger threads ;
|
prettyprint listener debugger threads boxes ;
|
||||||
IN: ui.tools.listener
|
IN: ui.tools.listener
|
||||||
|
|
||||||
TUPLE: listener-gadget input output stack ;
|
TUPLE: listener-gadget input output stack ;
|
||||||
|
@ -161,6 +161,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
|
||||||
|
|
||||||
M: listener-gadget graft*
|
M: listener-gadget graft*
|
||||||
dup delegate graft*
|
dup delegate graft*
|
||||||
|
dup listener-gadget-input interactor-thread ?box 2drop
|
||||||
restart-listener ;
|
restart-listener ;
|
||||||
|
|
||||||
M: listener-gadget ungraft*
|
M: listener-gadget ungraft*
|
||||||
|
|
|
@ -1,11 +1,9 @@
|
||||||
USING: assocs ui.tools.search help.topics io.files io.styles
|
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
|
tools.test ui.gadgets ui.gestures vocabs
|
||||||
vocabs.loader words tools.test.ui debugger ;
|
vocabs.loader words tools.test.ui debugger ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
timers get [ init-timers ] unless
|
|
||||||
|
|
||||||
[ f ] [
|
[ f ] [
|
||||||
"no such word with this name exists, certainly"
|
"no such word with this name exists, certainly"
|
||||||
f f <definition-search>
|
f f <definition-search>
|
||||||
|
@ -16,7 +14,7 @@ timers get [ init-timers ] unless
|
||||||
|
|
||||||
: update-live-search ( search -- seq )
|
: update-live-search ( search -- seq )
|
||||||
dup [
|
dup [
|
||||||
300 sleep do-timers
|
300 sleep
|
||||||
live-search-list control-value
|
live-search-list control-value
|
||||||
] with-grafted-gadget ;
|
] with-grafted-gadget ;
|
||||||
|
|
||||||
|
@ -33,7 +31,6 @@ timers get [ init-timers ] unless
|
||||||
dup [
|
dup [
|
||||||
{ "set-word-prop" } over live-search-field set-control-value
|
{ "set-word-prop" } over live-search-field set-control-value
|
||||||
300 sleep
|
300 sleep
|
||||||
do-timers
|
|
||||||
search-value \ set-word-prop eq?
|
search-value \ set-word-prop eq?
|
||||||
] with-grafted-gadget
|
] with-grafted-gadget
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs ui.tools.interactor ui.tools.listener
|
USING: assocs ui.tools.interactor ui.tools.listener
|
||||||
ui.tools.workspace help help.topics io.files io.styles kernel
|
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.commands ui.gadgets ui.gadgets.editors
|
||||||
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
|
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
|
||||||
ui.gestures ui.operations vocabs words vocabs.loader
|
ui.gestures ui.operations vocabs words vocabs.loader
|
||||||
tools.browser unicode.case ;
|
tools.browser unicode.case calendar ;
|
||||||
IN: ui.tools.search
|
IN: ui.tools.search
|
||||||
|
|
||||||
TUPLE: live-search field list ;
|
TUPLE: live-search field list ;
|
||||||
|
@ -45,7 +45,7 @@ search-field H{
|
||||||
} set-gestures
|
} set-gestures
|
||||||
|
|
||||||
: <search-model> ( producer -- model )
|
: <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> ;
|
[ "\n" join ] r> append <filter> ;
|
||||||
|
|
||||||
: <search-list> ( seq limited? presenter -- gadget )
|
: <search-list> ( seq limited? presenter -- gadget )
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: ui.tools ui.tools.interactor ui.tools.listener
|
USING: ui.tools ui.tools.interactor ui.tools.listener
|
||||||
ui.tools.search ui.tools.workspace kernel models namespaces
|
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.labelled ui.gadgets.presentations
|
||||||
ui.gadgets.scrollers vocabs tools.test.ui ui ;
|
ui.gadgets.scrollers vocabs tools.test.ui ui ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
@ -12,8 +12,6 @@ IN: temporary
|
||||||
] unit-test
|
] unit-test
|
||||||
] with-scope
|
] with-scope
|
||||||
|
|
||||||
timers get [ init-timers ] unless
|
|
||||||
|
|
||||||
[ ] [ <workspace> "w" set ] unit-test
|
[ ] [ <workspace> "w" set ] unit-test
|
||||||
[ ] [ "w" get com-scroll-up ] unit-test
|
[ ] [ "w" get com-scroll-up ] unit-test
|
||||||
[ ] [ "w" get com-scroll-down ] unit-test
|
[ ] [ "w" get com-scroll-down ] unit-test
|
||||||
|
|
|
@ -167,7 +167,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop"
|
||||||
{ $subsection start-ui }
|
{ $subsection start-ui }
|
||||||
"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
|
"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
|
||||||
$nl
|
$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"
|
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:"
|
"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-paint" }
|
||||||
{ $subsection "ui-control-impl" }
|
{ $subsection "ui-control-impl" }
|
||||||
{ $subsection "clipboard-protocol" }
|
{ $subsection "clipboard-protocol" }
|
||||||
{ $subsection "timers" }
|
|
||||||
{ $see-also "ui-layout-impl" } ;
|
{ $see-also "ui-layout-impl" } ;
|
||||||
|
|
||||||
ARTICLE: "ui" "UI framework"
|
ARTICLE: "ui" "UI framework"
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays assocs io kernel math models namespaces
|
USING: arrays assocs io kernel math models namespaces
|
||||||
prettyprint dlists sequences threads sequences words
|
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
|
ui.gestures ui.backend ui.render continuations init combinators
|
||||||
hashtables ;
|
hashtables ;
|
||||||
IN: ui
|
IN: ui
|
||||||
|
@ -131,8 +131,7 @@ SYMBOL: ui-hook
|
||||||
graft-queue [ notify ] dlist-slurp ;
|
graft-queue [ notify ] dlist-slurp ;
|
||||||
|
|
||||||
: ui-step ( -- )
|
: ui-step ( -- )
|
||||||
[ do-timers notify-queued layout-queued redraw-worlds ]
|
[ notify-queued layout-queued redraw-worlds ] assert-depth ;
|
||||||
assert-depth ;
|
|
||||||
|
|
||||||
: open-world-window ( world -- )
|
: open-world-window ( world -- )
|
||||||
dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
|
dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
|
||||||
|
@ -156,7 +155,6 @@ M: object close-window
|
||||||
find-world [ ungraft ] when* ;
|
find-world [ ungraft ] when* ;
|
||||||
|
|
||||||
: start-ui ( -- )
|
: start-ui ( -- )
|
||||||
init-timers
|
|
||||||
restore-windows? [
|
restore-windows? [
|
||||||
restore-windows
|
restore-windows
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -5,9 +5,8 @@ ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
|
||||||
math math.vectors namespaces prettyprint sequences strings
|
math math.vectors namespaces prettyprint sequences strings
|
||||||
vectors words windows.kernel32 windows.gdi32 windows.user32
|
vectors words windows.kernel32 windows.gdi32 windows.user32
|
||||||
windows.opengl32 windows.messages windows.types windows.nt
|
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
|
IN: ui.windows
|
||||||
|
|
||||||
TUPLE: windows-ui-backend ;
|
TUPLE: windows-ui-backend ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005, 2006 Doug Coleman.
|
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.syntax alien.c-types arrays combinators
|
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
|
IN: windows
|
||||||
|
|
||||||
: lo-word ( wparam -- lo ) <short> *short ; inline
|
: lo-word ( wparam -- lo ) <short> *short ; inline
|
||||||
|
|
|
@ -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
|
|
@ -0,0 +1,8 @@
|
||||||
|
|
||||||
|
#include <stdio.h>
|
||||||
|
|
||||||
|
int main ()
|
||||||
|
{
|
||||||
|
printf("%d", 8*sizeof(void*));
|
||||||
|
return 0;
|
||||||
|
}
|
|
@ -37,15 +37,24 @@ void print_array(F_ARRAY* array, CELL nesting)
|
||||||
{
|
{
|
||||||
CELL length = array_capacity(array);
|
CELL length = array_capacity(array);
|
||||||
CELL i;
|
CELL i;
|
||||||
|
bool trimmed;
|
||||||
|
|
||||||
if(length > 10)
|
if(length > 10)
|
||||||
|
{
|
||||||
|
trimmed = true;
|
||||||
length = 10;
|
length = 10;
|
||||||
|
}
|
||||||
|
else
|
||||||
|
trimmed = false;
|
||||||
|
|
||||||
for(i = 0; i < length; i++)
|
for(i = 0; i < length; i++)
|
||||||
{
|
{
|
||||||
printf(" ");
|
printf(" ");
|
||||||
print_nested_obj(array_nth(array,i),nesting);
|
print_nested_obj(array_nth(array,i),nesting);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
if(trimmed)
|
||||||
|
printf("...");
|
||||||
}
|
}
|
||||||
|
|
||||||
void print_nested_obj(CELL obj, F_FIXNUM nesting)
|
void print_nested_obj(CELL obj, F_FIXNUM nesting)
|
||||||
|
|
Loading…
Reference in New Issue