From 84016a36c0f1da46f26efe6eee08194c708b0289 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Feb 2008 19:37:43 -0600 Subject: [PATCH] Regression fixes --- core/compiler/tests/curry.factor | 4 +- core/compiler/tests/float.factor | 2 +- core/compiler/tests/intrinsics.factor | 13 +++-- core/compiler/tests/simple.factor | 2 +- core/compiler/tests/tuples.factor | 2 +- core/compiler/units/units.factor | 9 +-- core/inference/state/state-tests.factor | 2 +- core/optimizer/optimizer-tests.factor | 2 +- core/parser/parser.factor | 2 +- core/words/words-tests.factor | 8 ++- extra/cocoa/cocoa-tests.factor | 3 +- extra/concurrency/flags/flags.factor | 21 +++++++ extra/concurrency/mailboxes/mailboxes.factor | 2 +- extra/html/elements/elements.factor | 4 +- extra/io/unix/unix-tests.factor | 60 +++++++++----------- extra/ui/gadgets/gadgets.factor | 11 +--- extra/ui/tools/search/search.factor | 5 +- extra/ui/ui.factor | 31 ++++++---- 18 files changed, 103 insertions(+), 80 deletions(-) create mode 100644 extra/concurrency/flags/flags.factor 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/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/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/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/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/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/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index c6cb5bc14a..ed3631bca5 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -2,17 +2,12 @@ ! 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 concurrency.messaging ; +models threads concurrency.flags ; IN: ui.gadgets -SYMBOL: ui-thread +SYMBOL: ui-notify-flag -: notify-ui-thread ( -- ) - self ui-thread get-global eq? [ - "notify" ui-thread get-global send - ] unless ; - -: stop-ui-thread ( -- ) "stop" ui-thread get-global send ; +: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; TUPLE: rect loc dim ; 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.factor b/extra/ui/ui.factor index 1bd84df518..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 concurrency.messaging ; +hashtables concurrency.flags ; IN: ui ! Assoc mapping aliens to gadgets @@ -138,18 +138,25 @@ SYMBOL: ui-hook : 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 ( -- ) - receive { { "notify" [ ] } { "stop" [ stop ] } } case - [ update-ui ] ui-try - 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 ( -- ) - [ update-ui-loop ] - "UI update" spawn ui-thread set-global ; + [ 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 ; @@ -173,17 +180,17 @@ M: object close-window find-world [ ungraft ] when* ; : start-ui ( -- ) - start-ui-thread restore-windows? [ restore-windows ] [ init-ui ui-hook get call - ] if update-ui ; + ] if + notify-ui-thread start-ui-thread ; -: 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 ( -- )