steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2008-02-22 11:56:42 -06:00
parent d1e5fddbed aae3913b59
commit 014e94aafc
86 changed files with 932 additions and 745 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitignore vendored
View File

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

8
Makefile
View File

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

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

@ -11,69 +11,72 @@ $nl
{ $subsection min-heap? }
{ $subsection <min-heap> }
"Max-heaps sort their elements so that the maximum element is first:"
{ $subsection min-heap }
{ $subsection min-heap? }
{ $subsection <min-heap> }
{ $subsection max-heap }
{ $subsection max-heap? }
{ $subsection <max-heap> }
"Both obey a protocol."
$nl
"Queries:"
{ $subsection heap-empty? }
{ $subsection heap-length }
{ $subsection heap-size }
{ $subsection heap-peek }
"Insertion:"
{ $subsection heap-push }
{ $subsection heap-push* }
{ $subsection heap-push-all }
"Removal:"
{ $subsection heap-pop* }
{ $subsection heap-pop } ;
{ $subsection heap-pop }
{ $subsection heap-delete } ;
ABOUT: "heaps"
HELP: <min-heap>
{ $values { "min-heap" min-heap } }
{ $description "Create a new " { $link min-heap } "." }
{ $see-also <max-heap> } ;
{ $description "Create a new " { $link min-heap } "." } ;
HELP: <max-heap>
{ $values { "max-heap" max-heap } }
{ $description "Create a new " { $link max-heap } "." }
{ $see-also <min-heap> } ;
{ $description "Create a new " { $link max-heap } "." } ;
HELP: heap-push
{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } }
{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
{ $side-effects "heap" }
{ $see-also heap-push-all heap-pop } ;
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
{ $side-effects "heap" } ;
HELP: heap-push*
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
{ $side-effects "heap" } ;
HELP: heap-push-all
{ $values { "assoc" assoc } { "heap" heap } }
{ $values { "assoc" assoc } { "heap" "a heap" } }
{ $description "Push every key/value pair of an assoc onto a heap." }
{ $side-effects "heap" }
{ $see-also heap-push heap-pop } ;
{ $side-effects "heap" } ;
HELP: heap-peek
{ $values { "heap" heap } { "key" object } { "value" object } }
{ $description "Outputs the first element in the heap, leaving it in the heap." }
{ $see-also heap-pop heap-pop* } ;
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $description "Output the first element in the heap, leaving it in the heap." } ;
HELP: heap-pop*
{ $values { "heap" heap } }
{ $description "Removes the first element from the heap." }
{ $side-effects "heap" }
{ $see-also heap-pop heap-push heap-peek } ;
{ $values { "heap" "a heap" } }
{ $description "Remove the first element from the heap." }
{ $side-effects "heap" } ;
HELP: heap-pop
{ $values { "heap" heap } { "key" object } { "value" object } }
{ $description "Outputs the first element in the heap and removes it from the heap." }
{ $side-effects "heap" }
{ $see-also heap-pop* heap-push heap-peek } ;
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $description "Output and remove the first element in the heap." }
{ $side-effects "heap" } ;
HELP: heap-empty?
{ $values { "heap" heap } { "?" "a boolean" } }
{ $description "Tests if a " { $link heap } " has no nodes." }
{ $see-also heap-length heap-peek } ;
{ $values { "heap" "a heap" } { "?" "a boolean" } }
{ $description "Tests if a heap has no nodes." } ;
HELP: heap-length
{ $values { "heap" heap } { "n" integer } }
{ $description "Returns the number of key/value pairs in the heap." }
{ $see-also heap-empty? } ;
HELP: heap-size
{ $values { "heap" "a heap" } { "n" integer } }
{ $description "Returns the number of key/value pairs in the heap." } ;
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.
USING: arrays kernel math namespaces tools.test
heaps heaps.private ;
heaps heaps.private math.parser random assocs sequences sorting ;
IN: temporary
[ <min-heap> heap-pop ] must-fail
@ -15,16 +15,8 @@ IN: temporary
! Binary Min Heap
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test
{ f } [ { 5 t } { 3 t } 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 } [ t 5 <entry> t 3 <entry> T{ min-heap } heap-compare ] unit-test
{ f } [ t 5 <entry> t 3 <entry> T{ max-heap } heap-compare ] unit-test
[ t 2 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test
@ -32,18 +24,51 @@ IN: temporary
[ t 400 ] [ <max-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
[ 0 ] [ <max-heap> heap-length ] unit-test
[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test
[ 0 ] [ <max-heap> heap-size ] unit-test
[ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
[ { { 1 2 } { 3 4 } { 5 6 } } ] [
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
[ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make
] unit-test
[ { { 1 2 } } ] [
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
[ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make
] unit-test
[ { } ] [
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
[ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make
] unit-test
: heap-sort ( alist -- keys )
<min-heap> [ heap-push-all ] keep heap-pop-all ;
: random-alist ( n -- alist )
[
[
(random) dup number>string swap set
] times
] H{ } make-assoc ;
: test-heap-sort ( n -- ? )
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.
USING: kernel math sequences arrays assocs ;
USING: kernel math sequences arrays assocs sequences.private
growable ;
IN: heaps
MIXIN: priority-queue
GENERIC: heap-push ( value key heap -- )
GENERIC: heap-push* ( value key heap -- entry )
GENERIC: heap-peek ( heap -- value key )
GENERIC: heap-pop* ( heap -- )
GENERIC: heap-pop ( heap -- value key )
GENERIC: heap-delete ( key heap -- )
GENERIC: heap-delete* ( key heap -- old ? )
GENERIC: heap-delete ( entry heap -- )
GENERIC: heap-empty? ( heap -- ? )
GENERIC: heap-length ( heap -- n )
GENERIC# heap-pop-while 2 ( heap pred quot -- )
GENERIC: heap-size ( heap -- n )
<PRIVATE
TUPLE: heap data ;
: heap-data delegate ; inline
: <heap> ( class -- heap )
>r V{ } clone heap construct-boa r>
construct-delegate ; inline
>r V{ } clone r> construct-delegate ; inline
TUPLE: entry value key index ;
: <entry> ( value key -- entry ) f entry construct-boa ;
PRIVATE>
TUPLE: min-heap ;
@ -34,23 +39,67 @@ TUPLE: max-heap ;
INSTANCE: min-heap priority-queue
INSTANCE: max-heap priority-queue
M: priority-queue heap-empty? ( heap -- ? )
heap-data empty? ;
M: priority-queue heap-size ( heap -- n )
heap-data length ;
<PRIVATE
: left ( n -- m ) 2 * 1+ ; inline
: right ( n -- m ) 2 * 2 + ; inline
: up ( n -- m ) 1- 2 /i ; inline
: left-value ( n heap -- obj ) >r left r> nth ; inline
: right-value ( n heap -- obj ) >r right r> nth ; inline
: up-value ( n vec -- obj ) >r up r> nth ; inline
: swap-up ( n vec -- ) >r dup up r> exchange ; inline
: last-index ( vec -- n ) length 1- ; inline
: left ( n -- m ) 1 shift 1 + ; inline
: right ( n -- m ) 1 shift 2 + ; inline
: up ( n -- m ) 1- 2/ ; inline
: data-nth ( n heap -- entry )
heap-data nth-unsafe ; inline
: up-value ( n heap -- entry )
>r up r> data-nth ; inline
: left-value ( n heap -- entry )
>r left r> data-nth ; inline
: right-value ( n heap -- entry )
>r right r> data-nth ; inline
: data-set-nth ( entry n heap -- )
>r [ swap set-entry-index ] 2keep r>
heap-data set-nth-unsafe ;
: data-push ( entry heap -- n )
dup heap-size [
swap 2dup heap-data ensure 2drop data-set-nth
] keep ; inline
: data-pop ( heap -- entry )
heap-data pop ; inline
: data-pop* ( heap -- )
heap-data pop* ; inline
: data-peek ( heap -- entry )
heap-data peek ; inline
: data-first ( heap -- entry )
heap-data first ; inline
: data-exchange ( m n heap -- )
[ tuck data-nth >r data-nth r> ] 3keep
tuck >r >r data-set-nth r> r> data-set-nth ; inline
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
: (heap-compare) drop [ first ] compare 0 ; inline
: (heap-compare) drop [ entry-key ] compare 0 ; inline
M: min-heap heap-compare (heap-compare) > ;
M: max-heap heap-compare (heap-compare) < ;
: heap-bounds-check? ( m heap -- ? )
heap-data length >= ; inline
heap-size >= ; inline
: left-bounds-check? ( m heap -- ? )
>r left r> heap-bounds-check? ; inline
@ -58,41 +107,44 @@ M: max-heap heap-compare (heap-compare) < ;
: right-bounds-check? ( m heap -- ? )
>r right r> heap-bounds-check? ; inline
: up-heap-continue? ( vec heap -- ? )
>r [ last-index ] keep [ up-value ] keep peek r>
: continue? ( m up[m] heap -- ? )
[ data-nth swap ] keep [ data-nth ] keep
heap-compare ; inline
: up-heap ( vec heap -- )
2dup up-heap-continue? [
>r dup last-index [ over swap-up ] keep
up 1+ head-slice r> up-heap
DEFER: up-heap
: (up-heap) ( n heap -- )
>r dup up r>
3dup continue? [
[ data-exchange ] 2keep up-heap
] [
2drop
3drop
] if ;
: up-heap ( n heap -- )
over 0 > [ (up-heap) ] [ 2drop ] if ;
: (child) ( m heap -- n )
dupd
[ heap-data left-value ] 2keep
[ heap-data right-value ] keep heap-compare
2dup right-value
>r 2dup left-value r>
rot heap-compare
[ right ] [ left ] if ;
: child ( m heap -- n )
2dup right-bounds-check? [ drop left ] [ (child) ] if ;
2dup right-bounds-check?
[ drop left ] [ (child) ] if ;
: swap-down ( m heap -- )
[ child ] 2keep heap-data exchange ;
[ child ] 2keep data-exchange ;
DEFER: down-heap
: down-heap-continue? ( heap m heap -- m heap ? )
[ heap-data nth ] 2keep child pick
dupd [ heap-data nth swapd ] keep heap-compare ;
: (down-heap) ( m heap -- )
2dup down-heap-continue? [
-rot [ swap-down ] keep down-heap
] [
[ child ] 2keep swapd
3dup continue? [
3drop
] [
[ data-exchange ] 2keep down-heap
] if ;
: down-heap ( m heap -- )
@ -100,40 +152,37 @@ DEFER: down-heap
PRIVATE>
M: priority-queue heap-push ( value key heap -- )
>r swap 2array r>
[ heap-data push ] keep
[ heap-data ] keep
up-heap ;
M: priority-queue heap-push* ( value key heap -- entry )
>r <entry> dup r> [ data-push ] keep up-heap ;
: heap-push ( value key heap -- ) heap-push* drop ;
: heap-push-all ( assoc heap -- )
[ swapd heap-push ] curry assoc-each ;
: >entry< ( entry -- key value )
{ entry-value entry-key } get-slots ;
M: priority-queue heap-peek ( heap -- value key )
heap-data first first2 swap ;
data-first >entry< ;
M: priority-queue heap-delete ( entry heap -- )
>r entry-index r>
2dup heap-size 1- = [
nip data-pop*
] [
[ nip data-pop ] 2keep
[ data-set-nth ] 2keep
down-heap
] if ;
M: priority-queue heap-pop* ( heap -- )
dup heap-data length 1 > [
[ heap-data pop ] keep
[ heap-data set-first ] keep
0 swap down-heap
] [
heap-data pop*
] if ;
dup data-first swap heap-delete ;
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? ;
M: priority-queue heap-length ( heap -- n ) heap-data length ;
: (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) ;
: heap-pop-all ( heap -- alist )
[ dup heap-empty? not ]
[ dup heap-pop swap 2array ]
[ ] unfold nip ;

7
core/inference/class/class-tests.factor
View File

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

8
core/io/files/files.factor
View File

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

4
core/io/streams/c/c-tests.factor
View File

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

2
core/io/streams/c/c.factor
View File

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

2
core/io/thread/thread.factor
View File

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

4
core/layouts/layouts.factor
View File

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

1
core/math/integers/integers-docs.factor
View File

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

1
core/math/integers/integers.factor
View File

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

1
core/math/math.factor
View File

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

2
core/optimizer/math/math.factor
View File

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

15
core/threads/threads-docs.factor
View File

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

52
core/threads/threads.factor
View File

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

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"

143
extra/alarms/alarms.factor
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.
USING: arrays calendar combinators concurrency.messaging
threads generic init kernel math namespaces sequences ;
USING: arrays calendar combinators generic init kernel math
namespaces sequences heaps boxes threads debugger quotations ;
IN: alarms
TUPLE: alarm time quot ;
C: <alarm> alarm
TUPLE: alarm quot time interval entry ;
<PRIVATE
! for now a V{ }, eventually a min-heap to store alarms
SYMBOL: alarms
SYMBOL: alarm-receiver
SYMBOL: alarm-looper
SYMBOL: alarm-thread
: add-alarm ( alarm -- )
alarms get-global push ;
: notify-alarm-thread ( -- )
alarm-thread get-global interrupt ;
: remove-alarm ( alarm -- )
alarms get-global delete ;
: check-alarm
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 -- )
dup delegate {
{ "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>
: <alarm> ( quot time frequency -- alarm )
check-alarm <box> alarm construct-boa ;
: 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 -- )
"unregister" send-alarm ;
: alarm-expired? ( alarm now -- ? )
>r alarm-time r> <=> 0 <= ;
: change-alarm ( alarm-old alarm-new -- )
"register" send-alarm
"unregister" send-alarm ;
: reschedule-alarm ( alarm -- )
dup alarm-time over alarm-interval +dt
over set-alarm-time
register-alarm ;
! Example:
! 5 seconds from-now [ "hi" print flush ] <alarm> register-alarm
: call-alarm ( 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 ;

2
extra/benchmark/mandel/mandel.factor
View File

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

2
extra/benchmark/raytracer/raytracer.factor
View File

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

6
extra/benchmark/reverse-complement/reverse-complement.factor
View File

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

8
extra/builder/util/util.factor
View File

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

2
extra/bunny/bunny.factor
View File

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

12
extra/calendar/calendar.factor
View File

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

2
extra/concurrency/combinators/combinators-tests.factor
View File

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

23
extra/concurrency/conditions/conditions.factor
View File

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

2
extra/concurrency/count-downs/count-downs.factor
View File

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

6
extra/concurrency/futures/futures.factor
View File

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

51
extra/concurrency/locks/locks-tests.factor
View File

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

19
extra/concurrency/locks/locks.factor
View File

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

75
extra/concurrency/mailboxes/mailboxes-docs.factor Executable file
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 } ;

40
extra/concurrency/mailboxes/mailboxes-tests.factor Executable file
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

76
extra/concurrency/mailboxes/mailboxes.factor Executable file
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 ;

81
extra/concurrency/messaging/messaging-docs.factor
View File

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

42
extra/concurrency/messaging/messaging-tests.factor
View File

@ -3,48 +3,10 @@
!
USING: kernel threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words
match quotations concurrency.messaging ;
match quotations concurrency.messaging concurrency.mailboxes ;
IN: temporary
[ ] [ mailbox mailbox-data dlist-delete-all ] unit-test
[ 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
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
[ "received" ] [
[

122
extra/concurrency/messaging/messaging.factor
View File

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

6
extra/concurrency/promises/promises.factor
View File

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

21
extra/concurrency/semaphores/semaphores-docs.factor
View File

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

20
extra/concurrency/semaphores/semaphores.factor
View File

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

32
extra/factory/factory-menus
View File

@ -25,14 +25,14 @@ apps-menu> not [ new-wm-menu >apps-menu ] when
{ { "Emacs" [ "emacs &" system drop ] }
{ "KMail" [ "kmail &" system drop ] }
{ "Akregator" [ "akregator &" system drop ] }
{ "Amarok" [ "amarok &" system drop ] }
{ "K3b" [ "k3b &" system drop ] }
{ "xchat" [ "xchat &" system drop ] }
{ "Amarok" [ "amarok &" system drop ] }
{ "K3b" [ "k3b &" system drop ] }
{ "xchat" [ "xchat &" system drop ] }
{ "Nautilus" [ "nautilus --no-desktop &" system drop ] }
{ "synaptic" [ "gksudo synaptic &" system drop ] }
{ "synaptic" [ "gksudo synaptic &" system drop ] }
{ "Volume control" [ "gnome-volume-control &" system drop ] }
{ "Azureus" [ "~/azureus/azureus &" system drop ] }
{ "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] }
{ "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] }
{ "Stop Xephyr" [ "pkill Xephyr &" system drop ] }
{ "Stop Firefox" [ "pkill firefox &" system drop ] }
} apps-menu> set-menu-items
@ -95,8 +95,8 @@ factory-menu> not [ new-wm-menu >factory-menu ] when
{ { "Maximize" [ maximize ] }
{ "Maximize Vertical" [ maximize-vertical ] }
{ "Restore" [ restore ] }
{ "Hide" [ minimize ] }
{ "Tile Master" [ tile-master ] }
{ "Hide" [ minimize ] }
{ "Tile Master" [ tile-master ] }
}
factory-menu> set-menu-items
@ -106,17 +106,17 @@ factory-menu> set-menu-items
! VAR: root-menu
{ { "xterm" [ "urxvt -bd grey +sb &" system drop ] }
{ "Firefox" [ "firefox &" system drop ] }
{ "xclock" [ "xclock &" system drop ] }
{ "Apps >" [ apps-menu> <- popup ] }
{ "Firefox" [ "firefox &" system drop ] }
{ "xclock" [ "xclock &" system drop ] }
{ "Apps >" [ apps-menu> <- popup ] }
{ "Factor >" [ factor-menu> <- popup ] }
{ "Unmapped frames >" [ unmapped-frames-menu> <- popup ] }
{ "Emacs >" [ emacs-menu> <- popup ] }
{ "Mail >" [ mail-menu> <- popup ] }
{ "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &"
system drop ] }
{ "Edit menus" [ edit-factory-menus ] }
{ "Emacs >" [ emacs-menu> <- popup ] }
{ "Mail >" [ mail-menu> <- popup ] }
{ "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &"
system drop ] }
{ "Edit menus" [ edit-factory-menus ] }
{ "Reload menus" [ load-factory-menus ] }
{ "Factory >" [ factory-menu> <- popup ] }
{ "Factory >" [ factory-menu> <- popup ] }
} root-menu> set-menu-items

1
extra/help/handbook/handbook.factor
View File

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

6
extra/http/client/client.factor
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.
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting continuations assocs.lib ;
splitting continuations assocs.lib calendar ;
IN: http.client
: parse-host ( url -- host port )
@ -47,7 +47,7 @@ DEFER: http-get-stream
dispose "location" swap peek-at nip http-get-stream
] when ;
: default-timeout 60 1000 * over set-timeout ;
: default-timeout 1 minutes over set-timeout ;
: http-get-stream ( url -- code headers stream )
#! Opens a stream for reading from an HTTP URL.

4
extra/http/server/server.factor
View File

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

5
extra/io/launcher/launcher-docs.factor
View File

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

8
extra/io/launcher/launcher.factor
View File

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

11
extra/io/nonblocking/nonblocking.factor
View File

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

18
extra/io/timeouts/timeouts-docs.factor
View File

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

76
extra/io/timeouts/timeouts.factor
View File

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

2
extra/io/unix/backend/backend.factor
View File

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

3
extra/io/unix/kqueue/kqueue.factor
View File

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

2
extra/io/unix/select/select.factor
View File

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

6
extra/io/unix/unix-tests.factor
View File

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

4
extra/io/windows/ce/backend/backend.factor
View File

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

12
extra/io/windows/launcher/launcher.factor
View File

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

3
extra/io/windows/nt/backend/backend.factor
View File

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

4
extra/locals/locals-tests.factor
View File

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

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

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

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

19
extra/models/models.factor
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.
USING: generic kernel math sequences timers arrays assocs ;
USING: generic kernel math sequences arrays assocs alarms
calendar ;
IN: models
TUPLE: model value connections dependencies ref locked? ;
@ -174,7 +175,7 @@ TUPLE: history back forward ;
dup history-forward delete-all
dup history-back (add-history) ;
TUPLE: delay model timeout ;
TUPLE: delay model timeout alarm ;
: update-delay-model ( delay -- )
dup delay-model model-value swap set-model ;
@ -185,12 +186,18 @@ TUPLE: delay model timeout ;
[ set-delay-model ] 2keep
[ add-dependency ] keep ;
M: delay model-changed nip 0 over delay-timeout add-timer ;
: cancel-delay ( delay -- )
delay-alarm [ cancel-alarm ] when* ;
: start-delay ( delay -- )
dup [ f over set-delay-alarm update-delay-model ] curry
over delay-timeout later
swap set-delay-alarm ;
M: delay model-changed nip dup cancel-delay start-delay ;
M: delay model-activated update-delay-model ;
M: delay tick dup remove-timer update-delay-model ;
GENERIC: range-value ( model -- value )
GENERIC: range-page-value ( model -- value )
GENERIC: range-min-value ( model -- value )

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-td player-yuv } get-slots theora_decode_YUVout drop
dup player-rgb over player-yuv yuv>rgb
dup player-gadget find-world dup draw-world
dup player-gadget find-world draw-world
] when ;
: num-audio-buffers-processed ( player -- player n )

2
extra/smtp/server/server.factor
View File

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

9
extra/space-invaders/space-invaders.factor
View File

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

1
extra/timers/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

1
extra/timers/summary.txt
View File

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

36
extra/timers/timers-docs.factor
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"

30
extra/timers/timers.factor
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 ;

13
extra/tools/threads/threads.factor
View File

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

3
extra/ui/gadgets/buttons/buttons.factor
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.
USING: arrays ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme
@ -88,6 +88,7 @@ TUPLE: repeat-button ;
repeat-button H{
{ T{ drag } [ button-clicked ] }
{ T{ button-down } [ button-clicked ] }
} set-gestures
: <repeat-button> ( label quot -- button )

6
extra/ui/gadgets/gadgets.factor
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.
USING: arrays hashtables kernel models math namespaces sequences
timers quotations math.vectors combinators sorting vectors
dlists models ;
quotations math.vectors combinators sorting vectors dlists
models ;
IN: ui.gadgets
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.
USING: models sequences ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel ;
ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel
calendar ;
IN: ui.gadgets.status-bar
: <status-bar> ( model -- gadget )
100 <delay> [ "" like ] <filter> <label-control>
1/10 seconds <delay> [ "" like ] <filter> <label-control>
dup reverse-video-theme
t over set-gadget-root? ;

18
extra/ui/gestures/gestures.factor
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.
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
math.vectors tuples classes ui.gadgets timers combinators.lib ;
math.vectors tuples classes ui.gadgets combinators.lib boxes
calendar alarms ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
@ -107,20 +108,21 @@ SYMBOL: double-click-timeout
: drag-gesture ( -- )
hand-buttons get-global first <drag> button-gesture ;
TUPLE: drag-timer ;
SYMBOL: drag-timer
M: drag-timer tick drop drag-gesture ;
drag-timer construct-empty drag-timer set-global
<box> drag-timer set-global
: start-drag-timer ( -- )
hand-buttons get-global empty? [
drag-timer get-global 100 300 add-timer
[ drag-gesture ]
300 milliseconds from-now
100 milliseconds
add-alarm drag-timer get-global >box
] when ;
: stop-drag-timer ( -- )
hand-buttons get-global empty? [
drag-timer get-global remove-timer
drag-timer get-global box> cancel-alarm
] when ;
: fire-motion ( -- )

5
extra/ui/tools/interactor/interactor.factor
View File

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

4
extra/ui/tools/listener/listener-tests.factor
View File

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

3
extra/ui/tools/listener/listener.factor
View File

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

7
extra/ui/tools/search/search-tests.factor
View File

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

6
extra/ui/tools/search/search.factor
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.
USING: assocs ui.tools.interactor ui.tools.listener
ui.tools.workspace help help.topics io.files io.styles kernel
@ -7,7 +7,7 @@ source-files strings tools.completion tools.crossref tuples
ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
tools.browser unicode.case ;
tools.browser unicode.case calendar ;
IN: ui.tools.search
TUPLE: live-search field list ;
@ -45,7 +45,7 @@ search-field H{
} set-gestures
: <search-model> ( producer -- model )
>r g live-search-field gadget-model 200 <delay>
>r g live-search-field gadget-model 1/5 seconds <delay>
[ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget )

4
extra/ui/tools/tools-tests.factor
View File

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

3
extra/ui/ui-docs.factor
View File

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

6
extra/ui/ui.factor
View File

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

5
extra/ui/windows/windows.factor
View File

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

4
extra/windows/windows.factor
View File

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

9
vm/debug.c
View File

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