diff --git a/core/compiler/tests/curry.factor b/core/compiler/tests/curry.factor index 77ac01e101..982b3cfb75 100755 --- a/core/compiler/tests/curry.factor +++ b/core/compiler/tests/curry.factor @@ -1,5 +1,5 @@ -USING: tools.test compiler quotations math kernel sequences -assocs namespaces ; +USING: tools.test quotations math kernel sequences +assocs namespaces compiler.units ; IN: temporary [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test diff --git a/core/compiler/tests/float.factor b/core/compiler/tests/float.factor index 10d3baea9b..11470f7102 100755 --- a/core/compiler/tests/float.factor +++ b/core/compiler/tests/float.factor @@ -1,5 +1,5 @@ IN: temporary -USING: compiler kernel kernel.private memory math +USING: compiler.units kernel kernel.private memory math math.private tools.test math.floats.private ; [ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index 5dfe447443..d1e6f7abf4 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -1,10 +1,11 @@ IN: temporary -USING: arrays compiler kernel kernel.private math math.constants -math.private sequences strings tools.test words continuations -sequences.private hashtables.private byte-arrays strings.private -system random layouts vectors.private sbufs.private -strings.private slots.private alien alien.accessors -alien.c-types alien.syntax namespaces libc sequences.private ; +USING: arrays compiler.units kernel kernel.private math +math.constants math.private sequences strings tools.test words +continuations sequences.private hashtables.private byte-arrays +strings.private system random layouts vectors.private +sbufs.private strings.private slots.private alien +alien.accessors alien.c-types alien.syntax namespaces libc +sequences.private ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 6deed6c756..7f23e28bec 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -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 alien arrays memory ; IN: temporary diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index a23b6739ad..7acd599cb8 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -1,5 +1,5 @@ IN: temporary -USING: kernel tools.test compiler ; +USING: kernel tools.test compiler.units ; TUPLE: color red green blue ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 9f1976bec4..9849ddca7d 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations assocs namespaces sequences words -vocabs definitions hashtables ; +vocabs definitions hashtables init ; IN: compiler.units SYMBOL: old-definitions @@ -37,12 +37,13 @@ SYMBOL: recompile-hook SYMBOL: definition-observers -definition-observers global [ V{ } like ] change-at - GENERIC: definitions-changed ( assoc obj -- ) +[ V{ } clone definition-observers set-global ] +"compiler.units" add-init-hook + : add-definition-observer ( obj -- ) - definition-observers get push-new ; + definition-observers get push ; : remove-definition-observer ( obj -- ) definition-observers get delete ; diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor index e9c31171ed..02a3c4fde0 100644 --- a/core/inference/state/state-tests.factor +++ b/core/inference/state/state-tests.factor @@ -1,5 +1,5 @@ IN: temporary -USING: tools.test inference.state ; +USING: tools.test inference.state words ; SYMBOL: a SYMBOL: b diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 66d3956dba..c63787ad52 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -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 strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private diff --git a/core/parser/parser.factor b/core/parser/parser.factor index bc129041e5..63d3f2e45f 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -468,7 +468,7 @@ SYMBOL: interactive-vocabs #! If a class word had a compound definition which was #! removed, it must go back to being a symbol. new-definitions get first2 diff - [ nip define-symbol ] assoc-each ; + [ nip dup reset-generic define-symbol ] assoc-each ; : forget-smudged ( -- ) smudged-usage forget-all diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 490c8dc740..e045f15bdb 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -86,6 +86,13 @@ PRIVATE> f over set-thread-state 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 ; + [ ] while drop ; -: next ( -- ) +: next ( -- * ) expire-sleep-loop - run-queue pop-back - dup array? [ first2 ] [ f swap ] if dup set-self - f over set-thread-state - thread-continuation box> - continue-with ; + run-queue dup dlist-empty? [ + ! We should never be in a state where the only threads + ! are sleeping; the I/O wait thread is always runnable. + ! However, if it dies, we handle this case + ! 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> -: sleep-time ( -- ms/f ) - { - { [ run-queue dlist-empty? not ] [ 0 ] } - { [ sleep-queue heap-empty? ] [ f ] } - { [ t ] [ sleep-queue heap-peek nip millis [-] ] } - } cond ; - : stop ( -- ) self dup thread-exit-handler call unregister-thread next ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 2d53ed82e2..8bdd9b902f 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -153,16 +153,18 @@ SYMBOL: load-help? [ load-error. nl ] each ; SYMBOL: blacklist +SYMBOL: failures : require-all ( vocabs -- failures ) [ V{ } clone blacklist set + V{ } clone failures set [ [ require ] - [ >r vocab-name r> 2array blacklist get push ] + [ swap vocab-name failures get set-at ] recover ] each - blacklist get + failures get ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) @@ -176,12 +178,17 @@ SYMBOL: blacklist : refresh-all ( -- ) "" refresh ; GENERIC: (load-vocab) ( name -- vocab ) -! + +: add-to-blacklist ( error vocab -- ) + vocab-name blacklist get dup [ set-at ] [ 3drop ] if ; + M: vocab (load-vocab) - dup vocab-root [ - dup vocab-source-loaded? [ dup load-source ] unless - dup vocab-docs-loaded? [ dup load-docs ] unless - ] when ; + [ + dup vocab-root [ + dup vocab-source-loaded? [ dup load-source ] unless + dup vocab-docs-loaded? [ dup load-docs ] unless + ] when + ] [ [ swap add-to-blacklist ] keep rethrow ] recover ; M: string (load-vocab) [ ".private" ?tail drop reload ] keep vocab ; @@ -189,24 +196,14 @@ M: string (load-vocab) M: vocab-link (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? [ - vocab-name blacklisted-vocab + dup vocab-name blacklist get at* [ + rethrow ] [ - [ - dup vocab [ ] [ ] ?if (load-vocab) - ] with-compiler-errors + drop + [ dup vocab swap or (load-vocab) ] with-compiler-errors ] if + ] load-vocab-hook set-global : vocab-where ( vocab -- loc ) diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index f29d21cd9f..63e30178f5 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -1,6 +1,6 @@ USING: arrays generic assocs kernel math namespaces sequences tools.test words definitions parser quotations -vocabs continuations tuples compiler.units ; +vocabs continuations tuples compiler.units io.streams.string ; IN: temporary [ 4 ] [ @@ -156,11 +156,13 @@ SYMBOL: quot-uses-b [ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test [ ] [ - "IN: temporary GENERIC: symbol-generic" eval + "IN: temporary GENERIC: symbol-generic" + "symbol-generic-test" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: symbol-generic ;" eval + "IN: temporary TUPLE: symbol-generic ;" + "symbol-generic-test" parse-stream drop ] unit-test [ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 4cd2613e8d..2b51f8603e 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -65,12 +65,6 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : factor-binary ( -- name ) -! os "macosx" = -! [ "./Factor.app/Contents/MacOS/factor" ] -! [ "./factor" ] -! if ; - : bootstrap-cmd ( -- cmd ) { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; @@ -146,7 +140,11 @@ SYMBOL: build-status show-benchmark-deltas - "../benchmarks" "../../benchmarks" copy-file + "../benchmarks" "../../benchmarks" copy-file + + ".." cd + + maybe-release ] with-file-writer @@ -167,7 +165,7 @@ SYMBOL: builder-recipients builder-from get >>from builder-recipients get >>to subject >>subject - "../report" file>string >>body + "./report" file>string >>body send ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -176,11 +174,11 @@ SYMBOL: builder-recipients { "bzip2" my-boot-image-name } to-strings run-process drop ; : build ( -- ) - [ (build) ] [ drop ] recover - build-status get [ maybe-release ] when + [ (build) ] failsafe + builds cd stamp> cd [ send-builder-email ] [ drop "not sending mail" . ] recover - ".." cd { "rm" "-rf" "factor" } run-process drop - [ compress-image ] [ drop ] recover ; + { "rm" "-rf" "factor" } run-process drop + [ compress-image ] failsafe ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -215,8 +213,7 @@ USE: bootstrap.image.download [ build ] when ] - [ drop ] - recover + failsafe 5 minutes sleep build-loop ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index eb947ff14f..c65241d922 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -64,6 +64,8 @@ USING: system sequences splitting ; : linux-release ( -- ) + "factor" cd + { "rm" "-rf" "Factor.app" } run-process drop { "rm" "-rf" common-files } to-strings run-process drop @@ -78,6 +80,8 @@ USING: system sequences splitting ; : windows-release ( -- ) + "factor" cd + { "rm" "-rf" "Factor.app" } run-process drop { "rm" "-rf" common-files } to-strings run-process drop @@ -92,6 +96,8 @@ USING: system sequences splitting ; : macosx-release ( -- ) + "factor" cd + { "rm" "-rf" common-files } to-strings run-process drop ".." cd @@ -120,8 +126,8 @@ USING: system sequences splitting ; : release? ( -- ? ) { - "../load-everything-vocabs" - "../test-all-vocabs" + "./load-everything-vocabs" + "./test-all-vocabs" } [ eval-file empty? ] all? ; diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 3d699d4ba8..a838eced6d 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -104,4 +104,8 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ; USE: prettyprint -: to-file ( object file -- ) [ . ] with-file-writer ; \ No newline at end of file +: to-file ( object file -- ) [ . ] with-file-writer ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: failsafe ( quot -- ) [ drop ] recover ; \ No newline at end of file diff --git a/extra/cocoa/cocoa-tests.factor b/extra/cocoa/cocoa-tests.factor index 1f94c051b7..44f0b50996 100644 --- a/extra/cocoa/cocoa-tests.factor +++ b/extra/cocoa/cocoa-tests.factor @@ -1,6 +1,7 @@ IN: temporary 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: { { +superclass+ "NSObject" } diff --git a/extra/concurrency/conditions/conditions.factor b/extra/concurrency/conditions/conditions.factor index 359ceaa9ae..b10aded671 100755 --- a/extra/concurrency/conditions/conditions.factor +++ b/extra/concurrency/conditions/conditions.factor @@ -8,7 +8,7 @@ IN: concurrency.conditions dup dlist-empty? [ drop ] [ pop-back resume-now ] if ; : notify-all ( dlist -- ) - [ resume-now ] dlist-slurp yield ; + [ resume-now ] dlist-slurp ; : queue-timeout ( queue timeout -- alarm ) #! Add an alarm which removes the current thread from the diff --git a/extra/concurrency/flags/flags-docs.factor b/extra/concurrency/flags/flags-docs.factor new file mode 100644 index 0000000000..cf37715c5c --- /dev/null +++ b/extra/concurrency/flags/flags-docs.factor @@ -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: +{ $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" diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor new file mode 100644 index 0000000000..d4e60d63ee --- /dev/null +++ b/extra/concurrency/flags/flags.factor @@ -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 ) f 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 ; diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index e5f12d5507..adfb5bac0a 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -15,7 +15,7 @@ TUPLE: mailbox threads data ; : mailbox-put ( obj mailbox -- ) [ mailbox-data push-front ] keep - mailbox-threads notify-all ; + mailbox-threads notify-all yield ; : block-unless-pred ( pred mailbox timeout -- ) 2over mailbox-data dlist-contains? [ diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index f12e0180b1..422d7ef1e8 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -86,7 +86,8 @@ concurrency.futures concurrency.locks concurrency.semaphores concurrency.count-downs -concurrency.exchangers ; +concurrency.exchangers +concurrency.flags ; 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." @@ -106,6 +107,7 @@ $nl { $subsection "concurrency.semaphores" } { $subsection "concurrency.count-downs" } { $subsection "concurrency.exchangers" } +{ $subsection "concurrency.flags" } "Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ; ARTICLE: "objects" "Objects" diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 101bc423b5..4f9a052032 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -87,14 +87,14 @@ SYMBOL: html #! word. foo> [ ">" write-html ] empty-effect html-word ; -: [ "" % ] "" make ; +: "" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. dup [ write-html ] curry empty-effect html-word ; -: [ "<" % % "/>" % ] "" make ; +: "<" swap "/>" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index d7ac18ee20..77e8e098b1 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -53,7 +53,7 @@ M: inet4 make-sockaddr ( inet -- sockaddr ) SYMBOL: port-override -: (port) port-override get [ ] [ ] ?if ; +: (port) port-override get swap or ; M: inet4 parse-sockaddr >r dup sockaddr-in-addr r> inet-ntop diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 6eb0b78955..af7417854e 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -4,12 +4,12 @@ sequences prettyprint system ; IN: temporary ! Unix domain stream sockets -[ - [ - "unix-domain-socket-test" resource-path delete-file - ] ignore-errors +: socket-server "unix-domain-socket-test" temp-file ; - "unix-domain-socket-test" resource-path +[ + [ socket-server delete-file ] ignore-errors + + socket-server [ stdio get accept [ "Hello world" print flush @@ -17,14 +17,14 @@ IN: temporary ] with-stream ] with-stream - "unix-domain-socket-test" resource-path delete-file + socket-server delete-file ] "Test" spawn drop yield [ { "Hello world" "FOO" } ] [ [ - "unix-domain-socket-test" resource-path + socket-server [ readln , "XYZ" print flush @@ -33,17 +33,16 @@ yield ] { } make ] unit-test -! Unix domain datagram sockets -[ - "unix-domain-datagram-test" resource-path delete-file -] ignore-errors +: datagram-server "unix-domain-datagram-test" temp-file ; +: datagram-client "unix-domain-datagram-test-2" temp-file ; -: server-addr "unix-domain-datagram-test" temp-file ; -: client-addr "unix-domain-datagram-test-2" temp-file ; +! Unix domain datagram sockets +[ datagram-server delete-file ] ignore-errors +[ datagram-client delete-file ] ignore-errors [ [ - server-addr "d" set + datagram-server "d" set "Receive 1" print @@ -67,58 +66,53 @@ yield "Done" print - "unix-domain-datagram-test" resource-path delete-file + datagram-server delete-file ] with-scope ] "Test" spawn drop yield -[ - "unix-domain-datagram-test-2" resource-path delete-file -] ignore-errors +[ datagram-client delete-file ] ignore-errors -client-addr +datagram-client "d" set [ ] [ "hello" >byte-array - server-addr + datagram-server "d" get send ] unit-test [ "olleh" t ] [ "d" get receive - server-addr = + datagram-server = >r >string r> ] unit-test [ ] [ "hello" >byte-array - server-addr + datagram-server "d" get send ] unit-test [ "hello world" t ] [ "d" get receive - server-addr = + datagram-server = >r >string r> ] unit-test [ ] [ "d" get dispose ] unit-test ! Test error behavior +: another-datagram "unix-domain-datagram-test-3" temp-file ; -[ - "unix-domain-datagram-test-3" resource-path delete-file -] ignore-errors +[ another-datagram delete-file ] ignore-errors -"unix-domain-datagram-test-2" temp-file delete-file +datagram-client delete-file -[ ] [ client-addr "d" set ] unit-test +[ ] [ datagram-client "d" set ] unit-test -[ - B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send -] must-fail +[ B{ 1 2 3 } another-datagram "d" get send ] must-fail [ ] [ "d" get dispose ] unit-test @@ -126,7 +120,7 @@ client-addr [ "d" get receive ] must-fail -[ B{ 1 2 } server-addr "d" get send ] must-fail +[ B{ 1 2 } datagram-server "d" get send ] must-fail ! Invalid parameter tests @@ -140,7 +134,7 @@ client-addr [ image [ - B{ 1 2 } server-addr + B{ 1 2 } datagram-server stdio get send ] with-file-reader ] must-fail diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor index 3307e921b8..e24cee748e 100755 --- a/extra/ogg/player/player.factor +++ b/extra/ogg/player/player.factor @@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ; dup player-gadget [ dup { player-td player-yuv } get-slots theora_decode_YUVout drop dup player-rgb over player-yuv yuv>rgb - dup player-gadget relayout yield + dup player-gadget relayout-1 yield ] when ; : num-audio-buffers-processed ( player -- player n ) diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index c74a6e72fb..184bd0c1cc 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -114,7 +114,7 @@ LOG: smtp-response DEBUG : extract-email ( recepient -- email ) #! This could be much smarter. - " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ; + " " last-split1 swap or "<" ?head drop ">" ?tail drop ; : message-id ( -- string ) [ diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index b719556cba..572e798bd0 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window? : 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 ] when ; diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor old mode 100644 new mode 100755 index feac09ffc4..5ab3ec28f3 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -298,7 +298,6 @@ CLASS: { [ [ 2drop dup view-dim swap window set-gadget-dim - ui-step ] ui-try ] } diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 3db3b9c270..ed3631bca5 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -2,9 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables kernel models math namespaces sequences quotations math.vectors combinators sorting vectors dlists -models threads ; +models threads concurrency.flags ; IN: ui.gadgets +SYMBOL: ui-notify-flag + +: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; + TUPLE: rect loc dim ; C: rect @@ -178,10 +182,6 @@ M: array gadget-text* : 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-later ( gadget -- ) diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index d828471609..7617b0f32d 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -133,7 +133,7 @@ M: stack-display tool-scroller : restart-listener ( listener -- ) dup com-end dup clear-output - [ init-namespaces listener-thread ] curry + [ listener-thread ] curry "Listener" spawn drop ; : init-listener ( listener -- ) diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index 8041db3c77..b37b4ca707 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -7,7 +7,7 @@ source-files definitions 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 calendar ; +tools.browser unicode.case calendar ui ; IN: ui.tools.search TUPLE: live-search field list ; @@ -45,7 +45,8 @@ search-field H{ } set-gestures : ( producer -- model ) - >r g live-search-field gadget-model 1/5 seconds + >r g live-search-field gadget-model + ui-running? [ 1/5 seconds ] when [ "\n" join ] r> append ; : ( seq limited? presenter -- gadget ) diff --git a/extra/ui/ui-docs.factor b/extra/ui/ui-docs.factor index 9b3a05e101..1b1e9d99f3 100755 --- a/extra/ui/ui-docs.factor +++ b/extra/ui/ui-docs.factor @@ -167,7 +167,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop" { $subsection start-ui } "The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down." $nl -"The event loop must not block, 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" "The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:" diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index adff223bc7..477fffe6af 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces prettyprint dlists sequences threads sequences words debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init combinators -hashtables ; +hashtables concurrency.flags ; IN: ui ! Assoc mapping aliens to gadgets @@ -130,14 +130,36 @@ SYMBOL: ui-hook : notify-queued ( -- ) graft-queue [ notify ] dlist-slurp ; -: ui-step ( -- ) +: update-ui ( -- ) [ notify-queued layout-queued redraw-worlds ] assert-depth ; : ui-wait ( -- ) 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 -- ) - 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 -- ) >r [ 1 track, ] { 0 1 } make-track r> @@ -158,21 +180,17 @@ M: object close-window find-world [ ungraft ] when* ; : start-ui ( -- ) - self ui-thread set-global restore-windows? [ restore-windows ] [ 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 ] [ ] cleanup ; inline - -: ui-running? ( -- ? ) - \ ui-running get-global ; - -[ f \ ui-running set-global ] "ui" add-init-hook +[ + f \ ui-running set-global + ui-notify-flag set-global +] "ui" add-init-hook HOOK: ui ui-backend ( -- ) @@ -185,5 +203,3 @@ MAIN: ui f windows set-global ui-hook [ ui ] with-variable ] if ; - -: ui-try ( quot -- ) [ ui-error ] recover ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index b7040c875d..45da2706f4 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -85,12 +85,12 @@ SYMBOL: mouse-captured : handle-wm-paint ( hWnd uMsg wParam lParam -- ) #! wParam and lParam are unused #! only paint if width/height both > 0 - 3drop window draw-world ; + 3drop window relayout-1 ; : handle-wm-size ( hWnd uMsg wParam lParam -- ) 2nip [ 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 -- ) 2nip @@ -353,14 +353,12 @@ M: windows-ui-backend (close-window) : event-loop ( msg -- ) { { [ windows get empty? ] [ drop ] } - { [ dup peek-message? ] [ - >r [ ui-step ui-wait ] ui-try - r> event-loop - ] } + { [ dup peek-message? ] [ ui-wait event-loop ] } { [ dup MSG-message WM_QUIT = ] [ drop ] } { [ t ] [ dup TranslateMessage drop dup DispatchMessage drop + yield event-loop ] } } cond ; diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index d56bd8e119..1fec668717 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -178,7 +178,7 @@ M: world client-event next-event dup None XFilterEvent zero? [ drop wait-event ] unless ] [ - ui-step ui-wait wait-event + ui-wait wait-event ] if ; : do-events ( -- ) diff --git a/vm/code_heap.c b/vm/code_heap.c index 4113e8abc8..e55188c6a8 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -229,7 +229,7 @@ CELL allot_code_block(CELL size) /* Insufficient room even after code GC, give up */ 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; diff --git a/vm/factor.c b/vm/factor.c index 826ad65324..20667a23f5 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -19,7 +19,7 @@ void default_parameters(F_PARAMETERS *p) p->rs_size = 32 * CELLS; p->gen_count = 3; - p->code_size = 4 * CELLS; + p->code_size = 8 * CELLS; p->young_size = 2 * CELLS; p->aging_size = 4 * CELLS; #endif