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

db4
Doug Coleman 2008-02-22 11:56:42 -06:00
commit 014e94aafc
86 changed files with 932 additions and 745 deletions

6
.gitignore vendored
View File

@ -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

View File

@ -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*.*

71
core/heaps/heaps-docs.factor Normal file → Executable file
View File

@ -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" } ;

77
core/heaps/heaps-tests.factor Normal file → Executable file
View File

@ -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

183
core/heaps/heaps.factor Normal file → Executable file
View File

@ -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) ;

View File

@ -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

View File

@ -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+ ;

View File

@ -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

View File

@ -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> ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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" } ;

View File

@ -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 ;

View File

@ -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

View File

@ -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
] [ ] [

View File

@ -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 } }

View File

@ -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

5
cp_dir
View File

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

27
extra/alarms/alarms-docs.factor Executable file
View File

@ -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"

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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" ] }

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 } ;

View File

@ -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

View File

@ -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 ;

View File

@ -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" } } ;

View File

@ -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" ] [
[ [

View File

@ -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

View File

@ -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 ;

View File

@ -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"

View File

@ -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

View File

@ -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" }

View File

@ -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.

View File

@ -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 ;

View File

@ -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." } ;

View File

@ -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 ;

View File

@ -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 )

View File

@ -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"

View File

@ -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

View File

@ -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 ( -- )

View File

@ -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>

View File

@ -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 ;

View File

@ -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

View File

@ -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 -- )

View File

@ -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

View File

@ -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

View File

@ -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

4
extra/math/ranges/ranges.factor Normal file → Executable file
View File

@ -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 )

View File

@ -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

View File

@ -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 )

2
extra/ogg/player/player.factor Normal file → Executable file
View File

@ -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 )

View File

@ -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

View File

@ -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? ;

View File

@ -1 +0,0 @@
Slava Pestov

View File

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

View File

@ -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"

View File

@ -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 ;

View File

@ -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

View File

@ -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 )

View File

@ -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 ;

7
extra/ui/gadgets/status-bar/status-bar.factor Normal file → Executable file
View File

@ -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? ;

View File

@ -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 ( -- )

View File

@ -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 ;

View File

@ -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

View File

@ -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*

View File

@ -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

View File

@ -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 )

View File

@ -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

View File

@ -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"

View File

@ -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
] [ ] [

View File

@ -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 ;

View File

@ -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

17
misc/target Executable file
View File

@ -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

8
misc/wordsize.c Normal file
View File

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

View File

@ -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)