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-26 02:06:56 -06:00
parent b7bb604d1b 18a96f87ee
commit 9cf3ecf04d
37 changed files with 234 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/compiler/tests/curry.factor
View File

@ -1,5 +1,5 @@
USING: tools.test compiler quotations math kernel sequences USING: tools.test quotations math kernel sequences
assocs namespaces ; assocs namespaces compiler.units ;
IN: temporary IN: temporary
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test

2
core/compiler/tests/float.factor
View File

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: compiler kernel kernel.private memory math USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ; math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test [ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test

13
core/compiler/tests/intrinsics.factor
View File

@ -1,10 +1,11 @@
IN: temporary IN: temporary
USING: arrays compiler kernel kernel.private math math.constants USING: arrays compiler.units kernel kernel.private math
math.private sequences strings tools.test words continuations math.constants math.private sequences strings tools.test words
sequences.private hashtables.private byte-arrays strings.private continuations sequences.private hashtables.private byte-arrays
system random layouts vectors.private sbufs.private strings.private system random layouts vectors.private
strings.private slots.private alien alien.accessors sbufs.private strings.private slots.private alien
alien.c-types alien.syntax namespaces libc sequences.private ; alien.accessors alien.c-types alien.syntax namespaces libc
sequences.private ;
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test

2
core/compiler/tests/simple.factor
View File

@ -1,4 +1,4 @@
USING: compiler tools.test kernel kernel.private USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings sequences.private math.private math combinators strings
alien arrays memory ; alien arrays memory ;
IN: temporary IN: temporary

2
core/compiler/tests/tuples.factor
View File

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: kernel tools.test compiler ; USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ; TUPLE: color red green blue ;

9
core/compiler/units/units.factor
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: kernel continuations assocs namespaces sequences words USING: kernel continuations assocs namespaces sequences words
vocabs definitions hashtables ; vocabs definitions hashtables init ;
IN: compiler.units IN: compiler.units
SYMBOL: old-definitions SYMBOL: old-definitions
@ -37,12 +37,13 @@ SYMBOL: recompile-hook
SYMBOL: definition-observers SYMBOL: definition-observers
definition-observers global [ V{ } like ] change-at
GENERIC: definitions-changed ( assoc obj -- ) GENERIC: definitions-changed ( assoc obj -- )
[ V{ } clone definition-observers set-global ]
"compiler.units" add-init-hook
: add-definition-observer ( obj -- ) : add-definition-observer ( obj -- )
definition-observers get push-new ; definition-observers get push ;
: remove-definition-observer ( obj -- ) : remove-definition-observer ( obj -- )
definition-observers get delete ; definition-observers get delete ;

2
core/inference/state/state-tests.factor
View File

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: tools.test inference.state ; USING: tools.test inference.state words ;
SYMBOL: a SYMBOL: a
SYMBOL: b SYMBOL: b

2
core/optimizer/optimizer-tests.factor
View File

@ -1,4 +1,4 @@
USING: arrays compiler generic hashtables inference kernel USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private optimizer.backend classes inference.dataflow tuples.private

2
core/parser/parser.factor
View File

@ -468,7 +468,7 @@ SYMBOL: interactive-vocabs
#! If a class word had a compound definition which was #! If a class word had a compound definition which was
#! removed, it must go back to being a symbol. #! removed, it must go back to being a symbol.
new-definitions get first2 diff new-definitions get first2 diff
[ nip define-symbol ] assoc-each ; [ nip dup reset-generic define-symbol ] assoc-each ;
: forget-smudged ( -- ) : forget-smudged ( -- )
smudged-usage forget-all smudged-usage forget-all

37
core/threads/threads.factor
View File

@ -86,6 +86,13 @@ PRIVATE>
f over set-thread-state f over set-thread-state
check-registered 2array run-queue push-front ; check-registered 2array run-queue push-front ;
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
{ [ t ] [ sleep-queue heap-peek nip millis [-] ] }
} cond ;
<PRIVATE <PRIVATE
: schedule-sleep ( thread ms -- ) : schedule-sleep ( thread ms -- )
@ -106,23 +113,27 @@ PRIVATE>
[ ] while [ ] while
drop ; drop ;
: next ( -- ) : next ( -- * )
expire-sleep-loop expire-sleep-loop
run-queue pop-back run-queue dup dlist-empty? [
dup array? [ first2 ] [ f swap ] if dup set-self ! We should never be in a state where the only threads
f over set-thread-state ! are sleeping; the I/O wait thread is always runnable.
thread-continuation box> ! However, if it dies, we handle this case
continue-with ; ! semi-gracefully.
!
! And if sleep-time outputs f, there are no sleeping
! threads either... so WTF.
drop sleep-time [ die 0 ] unless* (sleep) next
] [
pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
thread-continuation box>
continue-with
] if ;
PRIVATE> PRIVATE>
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
{ [ t ] [ sleep-queue heap-peek nip millis [-] ] }
} cond ;
: stop ( -- ) : stop ( -- )
self dup thread-exit-handler call self dup thread-exit-handler call
unregister-thread next ; unregister-thread next ;

41
core/vocabs/loader/loader.factor
View File

@ -153,16 +153,18 @@ SYMBOL: load-help?
[ load-error. nl ] each ; [ load-error. nl ] each ;
SYMBOL: blacklist SYMBOL: blacklist
SYMBOL: failures
: require-all ( vocabs -- failures ) : require-all ( vocabs -- failures )
[ [
V{ } clone blacklist set V{ } clone blacklist set
V{ } clone failures set
[ [
[ require ] [ require ]
[ >r vocab-name r> 2array blacklist get push ] [ swap vocab-name failures get set-at ]
recover recover
] each ] each
blacklist get failures get
] with-compiler-errors ; ] with-compiler-errors ;
: do-refresh ( modified-sources modified-docs -- ) : do-refresh ( modified-sources modified-docs -- )
@ -176,12 +178,17 @@ SYMBOL: blacklist
: refresh-all ( -- ) "" refresh ; : refresh-all ( -- ) "" refresh ;
GENERIC: (load-vocab) ( name -- vocab ) GENERIC: (load-vocab) ( name -- vocab )
!
: add-to-blacklist ( error vocab -- )
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
M: vocab (load-vocab) M: vocab (load-vocab)
dup vocab-root [ [
dup vocab-source-loaded? [ dup load-source ] unless dup vocab-root [
dup vocab-docs-loaded? [ dup load-docs ] unless dup vocab-source-loaded? [ dup load-source ] unless
] when ; dup vocab-docs-loaded? [ dup load-docs ] unless
] when
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
M: string (load-vocab) M: string (load-vocab)
[ ".private" ?tail drop reload ] keep vocab ; [ ".private" ?tail drop reload ] keep vocab ;
@ -189,24 +196,14 @@ M: string (load-vocab)
M: vocab-link (load-vocab) M: vocab-link (load-vocab)
vocab-name (load-vocab) ; vocab-name (load-vocab) ;
TUPLE: blacklisted-vocab name ;
: blacklisted-vocab ( name -- * )
\ blacklisted-vocab construct-boa throw ;
M: blacklisted-vocab error.
"This vocabulary depends on the " write
blacklisted-vocab-name write
" vocabulary which failed to load" print ;
[ [
dup vocab-name blacklist get key? [ dup vocab-name blacklist get at* [
vocab-name blacklisted-vocab rethrow
] [ ] [
[ drop
dup vocab [ ] [ ] ?if (load-vocab) [ dup vocab swap or (load-vocab) ] with-compiler-errors
] with-compiler-errors
] if ] if
] load-vocab-hook set-global ] load-vocab-hook set-global
: vocab-where ( vocab -- loc ) : vocab-where ( vocab -- loc )

8
core/words/words-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays generic assocs kernel math namespaces USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations sequences tools.test words definitions parser quotations
vocabs continuations tuples compiler.units ; vocabs continuations tuples compiler.units io.streams.string ;
IN: temporary IN: temporary
[ 4 ] [ [ 4 ] [
@ -156,11 +156,13 @@ SYMBOL: quot-uses-b
[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test [ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test
[ ] [ [ ] [
"IN: temporary GENERIC: symbol-generic" eval "IN: temporary GENERIC: symbol-generic" <string-reader>
"symbol-generic-test" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary TUPLE: symbol-generic ;" eval "IN: temporary TUPLE: symbol-generic ;" <string-reader>
"symbol-generic-test" parse-stream drop
] unit-test ] unit-test
[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test [ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test

25
extra/builder/builder.factor
View File

@ -65,12 +65,6 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : factor-binary ( -- name )
! os "macosx" =
! [ "./Factor.app/Contents/MacOS/factor" ]
! [ "./factor" ]
! if ;
: bootstrap-cmd ( -- cmd ) : bootstrap-cmd ( -- cmd )
{ "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
@ -146,7 +140,11 @@ SYMBOL: build-status
show-benchmark-deltas show-benchmark-deltas
"../benchmarks" "../../benchmarks" copy-file "../benchmarks" "../../benchmarks" copy-file
".." cd
maybe-release
] with-file-writer ] with-file-writer
@ -167,7 +165,7 @@ SYMBOL: builder-recipients
builder-from get >>from builder-from get >>from
builder-recipients get >>to builder-recipients get >>to
subject >>subject subject >>subject
"../report" file>string >>body "./report" file>string >>body
send ; send ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -176,11 +174,11 @@ SYMBOL: builder-recipients
{ "bzip2" my-boot-image-name } to-strings run-process drop ; { "bzip2" my-boot-image-name } to-strings run-process drop ;
: build ( -- ) : build ( -- )
[ (build) ] [ drop ] recover [ (build) ] failsafe
build-status get [ maybe-release ] when builds cd stamp> cd
[ send-builder-email ] [ drop "not sending mail" . ] recover [ send-builder-email ] [ drop "not sending mail" . ] recover
".." cd { "rm" "-rf" "factor" } run-process drop { "rm" "-rf" "factor" } run-process drop
[ compress-image ] [ drop ] recover ; [ compress-image ] failsafe ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -215,8 +213,7 @@ USE: bootstrap.image.download
[ build ] [ build ]
when when
] ]
[ drop ] failsafe
recover
5 minutes sleep 5 minutes sleep
build-loop ; build-loop ;

10
extra/builder/release/release.factor
View File

@ -64,6 +64,8 @@ USING: system sequences splitting ;
: linux-release ( -- ) : linux-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop { "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop { "rm" "-rf" common-files } to-strings run-process drop
@ -78,6 +80,8 @@ USING: system sequences splitting ;
: windows-release ( -- ) : windows-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop { "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop { "rm" "-rf" common-files } to-strings run-process drop
@ -92,6 +96,8 @@ USING: system sequences splitting ;
: macosx-release ( -- ) : macosx-release ( -- )
"factor" cd
{ "rm" "-rf" common-files } to-strings run-process drop { "rm" "-rf" common-files } to-strings run-process drop
".." cd ".." cd
@ -120,8 +126,8 @@ USING: system sequences splitting ;
: release? ( -- ? ) : release? ( -- ? )
{ {
"../load-everything-vocabs" "./load-everything-vocabs"
"../test-all-vocabs" "./test-all-vocabs"
} }
[ eval-file empty? ] [ eval-file empty? ]
all? ; all? ;

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

@ -104,4 +104,8 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
USE: prettyprint USE: prettyprint
: to-file ( object file -- ) [ . ] with-file-writer ; : to-file ( object file -- ) [ . ] with-file-writer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: failsafe ( quot -- ) [ drop ] recover ;

3
extra/cocoa/cocoa-tests.factor
View File

@ -1,6 +1,7 @@
IN: temporary IN: temporary
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory ; compiler kernel namespaces cocoa.classes tools.test memory
compiler.units ;
CLASS: { CLASS: {
{ +superclass+ "NSObject" } { +superclass+ "NSObject" }

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

@ -8,7 +8,7 @@ IN: concurrency.conditions
dup dlist-empty? [ drop ] [ pop-back resume-now ] if ; dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;
: notify-all ( dlist -- ) : notify-all ( dlist -- )
[ resume-now ] dlist-slurp yield ; [ resume-now ] dlist-slurp ;
: queue-timeout ( queue timeout -- alarm ) : queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the #! Add an alarm which removes the current thread from the

33
extra/concurrency/flags/flags-docs.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: concurrency.flags
HELP: flag
{ $class-description "A flag allows one thread to notify another when a condition is satisfied." } ;
HELP: <flag>
{ $values { "flag" flag } }
{ $description "Creates a new flag." } ;
HELP: raise-flag
{ $values { "flag" flag } }
{ $description "Raises a flag, notifying any threads waiting on it. Does nothing if the flag has already been raised." } ;
HELP: lower-flag
{ $values { "flag" flag } }
{ $description "Attempts to lower a flag. If the flag has been raised previously, returns immediately, otherwise waits for it to be raised first." } ;
ARTICLE: "concurrency.flags" "Flags"
"A " { $emphasis "flag" } " is a condition notification device which can be in one of two states: " { $emphasis "lowered" } " (the initial state) or " { $emphasis "raised" } "."
$nl
"The flag can be raised at any time; raising a raised flag does nothing. Lowering a flag if the flag has not been raised, it first waits for it to be raised."
$nl
"Essentially, a flag can be thought of as a counting semaphore where the count never goes above one."
{ $subsection flag }
{ $subsection flag? }
"Raising and lowering flags:"
{ $subsection raise-flag }
{ $subsection lower-flag } ;
ABOUT: "concurrency.flags"

21
extra/concurrency/flags/flags.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: boxes kernel threads ;
IN: concurrency.flags
TUPLE: flag value? thread ;
: <flag> ( -- flag ) f <box> flag construct-boa ;
: raise-flag ( flag -- )
dup flag-value? [
dup flag-thread ?box
[ resume ] [ drop t over set-flag-value? ] if
] unless drop ;
: lower-flag ( flag -- )
dup flag-value? [
f swap set-flag-value?
] [
[ flag-thread >box ] curry "flag" suspend drop
] if ;

2
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -15,7 +15,7 @@ TUPLE: mailbox threads data ;
: mailbox-put ( obj mailbox -- ) : mailbox-put ( obj mailbox -- )
[ mailbox-data push-front ] keep [ mailbox-data push-front ] keep
mailbox-threads notify-all ; mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- ) : block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [ 2over mailbox-data dlist-contains? [

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

@ -86,7 +86,8 @@ concurrency.futures
concurrency.locks concurrency.locks
concurrency.semaphores concurrency.semaphores
concurrency.count-downs concurrency.count-downs
concurrency.exchangers ; concurrency.exchangers
concurrency.flags ;
ARTICLE: "concurrency" "Concurrency" ARTICLE: "concurrency" "Concurrency"
"Factor supports a variety of concurrency abstractions, however they are mostly used to multiplex input/output operations since the thread scheduling is co-operative and only one CPU is used at a time." "Factor supports a variety of concurrency abstractions, however they are mostly used to multiplex input/output operations since the thread scheduling is co-operative and only one CPU is used at a time."
@ -106,6 +107,7 @@ $nl
{ $subsection "concurrency.semaphores" } { $subsection "concurrency.semaphores" }
{ $subsection "concurrency.count-downs" } { $subsection "concurrency.count-downs" }
{ $subsection "concurrency.exchangers" } { $subsection "concurrency.exchangers" }
{ $subsection "concurrency.flags" }
"Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ; "Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ;
ARTICLE: "objects" "Objects" ARTICLE: "objects" "Objects"

4
extra/html/elements/elements.factor
View File

@ -87,14 +87,14 @@ SYMBOL: html
#! word. #! word.
foo> [ ">" write-html ] empty-effect html-word ; foo> [ ">" write-html ] empty-effect html-word ;
: </foo> [ "</" % % ">" % ] "" make ; : </foo> "</" swap ">" 3append ;
: def-for-html-word-</foo> ( name -- ) : def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned #! Return the name and code for the </foo> patterned
#! word. #! word.
</foo> dup [ write-html ] curry empty-effect html-word ; </foo> dup [ write-html ] curry empty-effect html-word ;
: <foo/> [ "<" % % "/>" % ] "" make ; : <foo/> "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- ) : def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned #! Return the name and code for the <foo/> patterned

2
extra/io/sockets/impl/impl.factor
View File

@ -53,7 +53,7 @@ M: inet4 make-sockaddr ( inet -- sockaddr )
SYMBOL: port-override SYMBOL: port-override
: (port) port-override get [ ] [ ] ?if ; : (port) port-override get swap or ;
M: inet4 parse-sockaddr M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop >r dup sockaddr-in-addr <uint> r> inet-ntop

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

@ -4,12 +4,12 @@ sequences prettyprint system ;
IN: temporary IN: temporary
! Unix domain stream sockets ! Unix domain stream sockets
[ : socket-server "unix-domain-socket-test" temp-file ;
[
"unix-domain-socket-test" resource-path delete-file
] ignore-errors
"unix-domain-socket-test" resource-path <local> [
[ socket-server delete-file ] ignore-errors
socket-server <local>
<server> [ <server> [
stdio get accept [ stdio get accept [
"Hello world" print flush "Hello world" print flush
@ -17,14 +17,14 @@ IN: temporary
] with-stream ] with-stream
] with-stream ] with-stream
"unix-domain-socket-test" resource-path delete-file socket-server delete-file
] "Test" spawn drop ] "Test" spawn drop
yield yield
[ { "Hello world" "FOO" } ] [ [ { "Hello world" "FOO" } ] [
[ [
"unix-domain-socket-test" resource-path <local> <client> socket-server <local> <client>
[ [
readln , readln ,
"XYZ" print flush "XYZ" print flush
@ -33,17 +33,16 @@ yield
] { } make ] { } make
] unit-test ] unit-test
! Unix domain datagram sockets : datagram-server "unix-domain-datagram-test" temp-file ;
[ : datagram-client "unix-domain-datagram-test-2" temp-file ;
"unix-domain-datagram-test" resource-path delete-file
] ignore-errors
: server-addr "unix-domain-datagram-test" temp-file <local> ; ! Unix domain datagram sockets
: client-addr "unix-domain-datagram-test-2" temp-file <local> ; [ datagram-server delete-file ] ignore-errors
[ datagram-client delete-file ] ignore-errors
[ [
[ [
server-addr <datagram> "d" set datagram-server <local> <datagram> "d" set
"Receive 1" print "Receive 1" print
@ -67,58 +66,53 @@ yield
"Done" print "Done" print
"unix-domain-datagram-test" resource-path delete-file datagram-server delete-file
] with-scope ] with-scope
] "Test" spawn drop ] "Test" spawn drop
yield yield
[ [ datagram-client delete-file ] ignore-errors
"unix-domain-datagram-test-2" resource-path delete-file
] ignore-errors
client-addr <datagram> datagram-client <local> <datagram>
"d" set "d" set
[ ] [ [ ] [
"hello" >byte-array "hello" >byte-array
server-addr datagram-server <local>
"d" get send "d" get send
] unit-test ] unit-test
[ "olleh" t ] [ [ "olleh" t ] [
"d" get receive "d" get receive
server-addr = datagram-server <local> =
>r >string r> >r >string r>
] unit-test ] unit-test
[ ] [ [ ] [
"hello" >byte-array "hello" >byte-array
server-addr datagram-server <local>
"d" get send "d" get send
] unit-test ] unit-test
[ "hello world" t ] [ [ "hello world" t ] [
"d" get receive "d" get receive
server-addr = datagram-server <local> =
>r >string r> >r >string r>
] unit-test ] unit-test
[ ] [ "d" get dispose ] unit-test [ ] [ "d" get dispose ] unit-test
! Test error behavior ! Test error behavior
: another-datagram "unix-domain-datagram-test-3" temp-file ;
[ [ another-datagram delete-file ] ignore-errors
"unix-domain-datagram-test-3" resource-path delete-file
] ignore-errors
"unix-domain-datagram-test-2" temp-file delete-file datagram-client delete-file
[ ] [ client-addr <datagram> "d" set ] unit-test [ ] [ datagram-client <local> <datagram> "d" set ] unit-test
[ [ B{ 1 2 3 } another-datagram <local> "d" get send ] must-fail
B{ 1 2 3 } "unix-domain-datagram-test-3" <local> "d" get send
] must-fail
[ ] [ "d" get dispose ] unit-test [ ] [ "d" get dispose ] unit-test
@ -126,7 +120,7 @@ client-addr <datagram>
[ "d" get receive ] must-fail [ "d" get receive ] must-fail
[ B{ 1 2 } server-addr "d" get send ] must-fail [ B{ 1 2 } datagram-server <local> "d" get send ] must-fail
! Invalid parameter tests ! Invalid parameter tests
@ -140,7 +134,7 @@ client-addr <datagram>
[ [
image [ image [
B{ 1 2 } server-addr B{ 1 2 } datagram-server <local>
stdio get send stdio get send
] with-file-reader ] with-file-reader
] must-fail ] must-fail

2
extra/ogg/player/player.factor
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 relayout yield dup player-gadget relayout-1 yield
] when ; ] when ;
: num-audio-buffers-processed ( player -- player n ) : num-audio-buffers-processed ( player -- player n )

2
extra/smtp/smtp.factor
View File

@ -114,7 +114,7 @@ LOG: smtp-response DEBUG
: extract-email ( recepient -- email ) : extract-email ( recepient -- email )
#! This could be much smarter. #! This could be much smarter.
" " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ; " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
: message-id ( -- string ) : message-id ( -- string )
[ [

2
extra/ui/cocoa/cocoa.factor
View File

@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
: event-loop ( -- ) : event-loop ( -- )
event-loop? [ event-loop? [
[ [
[ NSApp do-events ui-step ui-wait ] ui-try [ NSApp do-events ui-wait ] ui-try
] with-autorelease-pool event-loop ] with-autorelease-pool event-loop
] when ; ] when ;

1
extra/ui/cocoa/views/views.factor Normal file → Executable file
View File

@ -298,7 +298,6 @@ CLASS: {
[ [
[ [
2drop dup view-dim swap window set-gadget-dim 2drop dup view-dim swap window set-gadget-dim
ui-step
] ui-try ] ui-try
] ]
} }

10
extra/ui/gadgets/gadgets.factor
View File

@ -2,9 +2,13 @@
! 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
quotations math.vectors combinators sorting vectors dlists quotations math.vectors combinators sorting vectors dlists
models threads ; models threads concurrency.flags ;
IN: ui.gadgets IN: ui.gadgets
SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
TUPLE: rect loc dim ; TUPLE: rect loc dim ;
C: <rect> rect C: <rect> rect
@ -178,10 +182,6 @@ M: array gadget-text*
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ; : forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
SYMBOL: ui-thread
: notify-ui-thread ( -- ) ui-thread get interrupt ;
: layout-queue ( -- queue ) \ layout-queue get ; : layout-queue ( -- queue ) \ layout-queue get ;
: layout-later ( gadget -- ) : layout-later ( gadget -- )

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

@ -133,7 +133,7 @@ M: stack-display tool-scroller
: restart-listener ( listener -- ) : restart-listener ( listener -- )
dup com-end dup clear-output dup com-end dup clear-output
[ init-namespaces listener-thread ] curry [ listener-thread ] curry
"Listener" spawn drop ; "Listener" spawn drop ;
: init-listener ( listener -- ) : init-listener ( listener -- )

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

@ -7,7 +7,7 @@ source-files definitions strings tools.completion tools.crossref
tuples ui.commands ui.gadgets ui.gadgets.editors tuples 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 calendar ; tools.browser unicode.case calendar ui ;
IN: ui.tools.search IN: ui.tools.search
TUPLE: live-search field list ; TUPLE: live-search field list ;
@ -45,7 +45,8 @@ search-field H{
} set-gestures } set-gestures
: <search-model> ( producer -- model ) : <search-model> ( producer -- model )
>r g live-search-field gadget-model 1/5 seconds <delay> >r g live-search-field gadget-model
ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ; [ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget ) : <search-list> ( seq limited? presenter -- gadget )

2
extra/ui/ui-docs.factor
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, 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." ; "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-wait } "." ;
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:"

46
extra/ui/ui.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words prettyprint dlists sequences threads sequences words
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 concurrency.flags ;
IN: ui IN: ui
! Assoc mapping aliens to gadgets ! Assoc mapping aliens to gadgets
@ -130,14 +130,36 @@ SYMBOL: ui-hook
: notify-queued ( -- ) : notify-queued ( -- )
graft-queue [ notify ] dlist-slurp ; graft-queue [ notify ] dlist-slurp ;
: ui-step ( -- ) : update-ui ( -- )
[ notify-queued layout-queued redraw-worlds ] assert-depth ; [ notify-queued layout-queued redraw-worlds ] assert-depth ;
: ui-wait ( -- ) : ui-wait ( -- )
10 sleep ; 10 sleep ;
: ui-try ( quot -- ) [ ui-error ] recover ;
SYMBOL: ui-thread
: ui-running ( quot -- )
t \ ui-running set-global
[ f \ ui-running set-global ] [ ] cleanup ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
: update-ui-loop ( -- )
ui-running? ui-thread get-global self eq? [
ui-notify-flag get lower-flag
[ update-ui ] ui-try
update-ui-loop
] when ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]
"UI update" spawn drop ;
: 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 ;
: open-window ( gadget title -- ) : open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r> >r [ 1 track, ] { 0 1 } make-track r>
@ -158,21 +180,17 @@ M: object close-window
find-world [ ungraft ] when* ; find-world [ ungraft ] when* ;
: start-ui ( -- ) : start-ui ( -- )
self ui-thread set-global
restore-windows? [ restore-windows? [
restore-windows restore-windows
] [ ] [
init-ui ui-hook get call init-ui ui-hook get call
] if ui-step ; ] if
notify-ui-thread start-ui-thread ;
: ui-running ( quot -- ) [
t \ ui-running set-global f \ ui-running set-global
[ f \ ui-running set-global ] [ ] cleanup ; inline <flag> ui-notify-flag set-global
] "ui" add-init-hook
: ui-running? ( -- ? )
\ ui-running get-global ;
[ f \ ui-running set-global ] "ui" add-init-hook
HOOK: ui ui-backend ( -- ) HOOK: ui ui-backend ( -- )
@ -185,5 +203,3 @@ MAIN: ui
f windows set-global f windows set-global
ui-hook [ ui ] with-variable ui-hook [ ui ] with-variable
] if ; ] if ;
: ui-try ( quot -- ) [ ui-error ] recover ;

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

@ -85,12 +85,12 @@ SYMBOL: mouse-captured
: handle-wm-paint ( hWnd uMsg wParam lParam -- ) : handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused #! wParam and lParam are unused
#! only paint if width/height both > 0 #! only paint if width/height both > 0
3drop window draw-world ; 3drop window relayout-1 ;
: handle-wm-size ( hWnd uMsg wParam lParam -- ) : handle-wm-size ( hWnd uMsg wParam lParam -- )
2nip 2nip
[ lo-word ] keep hi-word 2array [ lo-word ] keep hi-word 2array
dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ; dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ;
: handle-wm-move ( hWnd uMsg wParam lParam -- ) : handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip 2nip
@ -353,14 +353,12 @@ M: windows-ui-backend (close-window)
: event-loop ( msg -- ) : event-loop ( msg -- )
{ {
{ [ windows get empty? ] [ drop ] } { [ windows get empty? ] [ drop ] }
{ [ dup peek-message? ] [ { [ dup peek-message? ] [ ui-wait event-loop ] }
>r [ ui-step ui-wait ] ui-try
r> event-loop
] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] } { [ dup MSG-message WM_QUIT = ] [ drop ] }
{ [ t ] [ { [ t ] [
dup TranslateMessage drop dup TranslateMessage drop
dup DispatchMessage drop dup DispatchMessage drop
yield
event-loop event-loop
] } ] }
} cond ; } cond ;

2
extra/ui/x11/x11.factor
View File

@ -178,7 +178,7 @@ M: world client-event
next-event dup next-event dup
None XFilterEvent zero? [ drop wait-event ] unless None XFilterEvent zero? [ drop wait-event ] unless
] [ ] [
ui-step ui-wait wait-event ui-wait wait-event
] if ; ] if ;
: do-events ( -- ) : do-events ( -- )

2
vm/code_heap.c
View File

@ -229,7 +229,7 @@ CELL allot_code_block(CELL size)
/* Insufficient room even after code GC, give up */ /* Insufficient room even after code GC, give up */
if(start == 0) if(start == 0)
critical_error("Out of memory in add-compiled-block",0); fatal_error("Out of memory in add-compiled-block",0);
} }
return start; return start;

2
vm/factor.c
View File

@ -19,7 +19,7 @@ void default_parameters(F_PARAMETERS *p)
p->rs_size = 32 * CELLS; p->rs_size = 32 * CELLS;
p->gen_count = 3; p->gen_count = 3;
p->code_size = 4 * CELLS; p->code_size = 8 * CELLS;
p->young_size = 2 * CELLS; p->young_size = 2 * CELLS;
p->aging_size = 4 * CELLS; p->aging_size = 4 * CELLS;
#endif #endif