diff --git a/Makefile b/Makefile index 60091d44ea..6f12633871 100755 --- a/Makefile +++ b/Makefile @@ -145,7 +145,8 @@ wince-arm: macosx.app: factor mkdir -p $(BUNDLE)/Contents/MacOS - cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor + mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor + ln -s Factor.app/Contents/MacOS/factor ./factor cp $(ENGINE) $(BUNDLE)/Contents/Frameworks install_name_tool \ 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 5fcf7b3047..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,10 +37,11 @@ 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 ; 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 d8e9157b84..16298a8bbd 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-docs.factor b/core/threads/threads-docs.factor index fa79906cdf..d157907cc2 100755 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -19,8 +19,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads" { $subsection yield } "Sleeping for a period of time:" { $subsection sleep } -"Interruptible sleep:" -{ $subsection nap } +"Interrupting sleep:" { $subsection interrupt } "Threads can be suspended and woken up at some point in the future when a condition is satisfied:" { $subsection suspend } @@ -106,14 +105,17 @@ HELP: stop HELP: yield { $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ; +HELP: sleep-until +{ $values { "time/f" "a non-negative integer or " { $link f } } } +{ $description "Suspends the current thread until the given time, or indefinitely if a value of " { $link f } " is passed in." +$nl +"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ; + HELP: sleep { $values { "ms" "a non-negative integer" } } -{ $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." } ; +{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." +$nl +"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ; HELP: interrupt { $values { "thread" thread } } diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 70ed44e539..e045f15bdb 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -75,14 +75,24 @@ PRIVATE> : sleep-queue 43 getenv ; : resume ( thread -- ) + f over set-thread-state check-registered run-queue push-front ; : resume-now ( thread -- ) + f over set-thread-state check-registered run-queue push-back ; : resume-with ( obj thread -- ) + 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 ; @@ -131,34 +145,27 @@ PRIVATE> self swap call next ] callcc1 2nip ; inline -: yield ( -- ) [ resume ] "yield" suspend drop ; +: yield ( -- ) [ resume ] f suspend drop ; -GENERIC: nap-until ( time -- ? ) +GENERIC: sleep-until ( time/f -- ) -M: integer nap-until [ schedule-sleep ] curry "sleep" suspend ; +M: integer sleep-until + [ schedule-sleep ] curry "sleep" suspend drop ; -M: f nap-until drop [ drop ] "interrupt" suspend ; +M: f sleep-until + drop [ drop ] "interrupt" suspend drop ; -GENERIC: nap ( time -- ? ) +GENERIC: sleep ( ms -- ) -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 ; +M: real sleep + millis + >integer sleep-until ; : interrupt ( thread -- ) - dup self eq? [ - drop - ] [ + dup thread-state [ dup thread-sleep-entry [ sleep-queue heap-delete ] when* f over set-thread-sleep-entry - t swap resume-with - ] if ; + dup resume + ] when drop ; : (spawn) ( thread -- ) [ @@ -204,6 +211,7 @@ M: f nap nap-until ; initial-thread global [ drop f "Initial" [ die ] ] cache over set-thread-continuation + f over set-thread-state dup register-thread set-self ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 9ea38c9cff..9c74ce644b 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/alarms/alarms.factor b/extra/alarms/alarms.factor index 92a7c488ef..7f43dbd612 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -62,7 +62,7 @@ SYMBOL: alarm-thread : alarm-thread-loop ( -- ) alarms get-global - dup next-alarm nap-until drop + dup next-alarm sleep-until dup trigger-alarms alarm-thread-loop ; diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index b123b9c428..2b51f8603e 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -65,15 +65,8 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: factor-binary ( -- name ) - os - { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } - { "winnt" [ "./factor-nt.exe" ] } - [ drop "./factor" ] } - case ; - : bootstrap-cmd ( -- cmd ) - { factor-binary { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; + { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; : bootstrap ( -- desc ) @@ -85,7 +78,7 @@ IN: builder >desc ; : builder-test-cmd ( -- cmd ) - { factor-binary "-run=builder.test" } to-strings ; + { "./factor" "-run=builder.test" } to-strings ; : builder-test ( -- desc ) @@ -147,7 +140,11 @@ SYMBOL: build-status show-benchmark-deltas - "../benchmarks" "../../benchmarks" copy-file + "../benchmarks" "../../benchmarks" copy-file + + ".." cd + + maybe-release ] with-file-writer @@ -168,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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,11 +174,11 @@ SYMBOL: builder-recipients { "bzip2" my-boot-image-name } to-strings run-process drop ; : build ( -- ) - [ (build) ] [ drop ] recover - maybe-release + [ (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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -216,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/calendar/calendar.factor b/extra/calendar/calendar.factor index d1d7246a58..d834698d08 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -473,9 +473,9 @@ M: timestamp year. ( timestamp -- ) : seconds-since-midnight ( timestamp -- x ) dup beginning-of-day timestamp- ; -M: timestamp nap-until timestamp>millis nap-until ; +M: timestamp sleep-until timestamp>millis sleep-until ; -M: dt nap from-now nap-until ; +M: dt sleep from-now sleep-until ; { { [ unix? ] [ "calendar.unix" ] } 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/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index e5bb3b0695..154a330913 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -161,7 +161,7 @@ M: postgresql-db create-sql-statement ( class -- seq ) [ [ create-table-sql , ] keep dup db-columns find-primary-key native-id? - [ create-function-sql , ] [ 2drop ] if + [ create-function-sql , ] [ drop ] if ] { } make ; : drop-function-sql ( class -- statement ) @@ -176,13 +176,13 @@ M: postgresql-db create-sql-statement ( class -- seq ) : drop-table-sql ( table -- statement ) [ "drop table " 0% 0% ";" 0% drop - ] postgresql-make dup . ; + ] postgresql-make ; M: postgresql-db drop-sql-statement ( class -- seq ) [ [ drop-table-sql , ] keep dup db-columns find-primary-key native-id? - [ drop-function-sql , ] [ 2drop ] if + [ drop-function-sql , ] [ drop ] if ] { } make ; M: postgresql-db ( class -- statement ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 82bc96e156..6a0d0378b2 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -16,29 +16,37 @@ TUPLE: person the-id the-name the-number the-real ; : ( id name number the-real -- obj ) [ set-person-the-id ] keep ; -SYMBOL: the-person +SYMBOL: the-person1 +SYMBOL: the-person2 : test-tuples ( -- ) [ person drop-table ] [ drop ] recover [ ] [ person create-table ] unit-test - [ ] [ the-person get insert-tuple ] unit-test + [ ] [ the-person1 get insert-tuple ] unit-test - [ 1 ] [ the-person get person-the-id ] unit-test + [ 1 ] [ the-person1 get person-the-id ] unit-test - 200 the-person get set-person-the-number + 200 the-person1 get set-person-the-number - [ ] [ the-person get update-tuple ] unit-test + [ ] [ the-person1 get update-tuple ] unit-test [ T{ person f 1 "billy" 200 3.14 } ] [ T{ person f 1 } select-tuple ] unit-test + [ ] [ the-person2 get insert-tuple ] unit-test + [ + { + T{ person f 1 "billy" 200 3.14 } + T{ person f 2 "johnny" 10 3.14 } + } + ] [ T{ person f f f f 3.14 } select-tuples ] unit-test - ! [ ] [ the-person get delete-tuple ] unit-test - ! [ ] [ person drop-table ] unit-test - ; + [ ] [ the-person1 get delete-tuple ] unit-test + [ f ] [ T{ person f 1 } select-tuple ] unit-test + [ ] [ person drop-table ] unit-test ; : test-sqlite ( -- ) - "tuples-test.db" resource-path [ + "tuples-test.db" resource-path sqlite-db [ test-tuples ] with-db ; @@ -55,23 +63,25 @@ person "PERSON" { "the-real" "REAL" DOUBLE { +default+ 0.3 } } } define-persistent -"billy" 10 3.14 the-person set +"billy" 10 3.14 the-person1 set +"johnny" 10 3.14 the-person2 set ! test-sqlite test-postgresql -! person "PERSON" -! { - ! { "the-id" "ID" INTEGER +assigned-id+ } - ! { "the-name" "NAME" { VARCHAR 256 } +not-null+ } - ! { "the-number" "AGE" INTEGER { +default+ 0 } } - ! { "the-real" "REAL" DOUBLE { +default+ 0.3 } } -! } define-persistent +person "PERSON" +{ + { "the-id" "ID" INTEGER +assigned-id+ } + { "the-name" "NAME" { VARCHAR 256 } +not-null+ } + { "the-number" "AGE" INTEGER { +default+ 0 } } + { "the-real" "REAL" DOUBLE { +default+ 0.3 } } +} define-persistent -! 1 "billy" 20 6.28 the-person set +1 "billy" 10 3.14 the-person1 set +2 "johnny" 10 3.14 the-person2 set ! test-sqlite -! test-postgresql +test-postgresql TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; @@ -98,11 +108,11 @@ annotation "ANNOTATION" { "contents" "CONTENTS" TEXT } } define-persistent -! "localhost" "postgres" "" "factor-test" [ - ! [ paste drop-table ] [ drop ] recover - ! [ annotation drop-table ] [ drop ] recover - ! [ paste drop-table ] [ drop ] recover - ! [ annotation drop-table ] [ drop ] recover - ! [ ] [ paste create-table ] unit-test - ! [ ] [ annotation create-table ] unit-test -! ] with-db +{ "localhost" "postgres" "" "factor-test" } postgresql-db [ + [ paste drop-table ] [ drop ] recover + [ annotation drop-table ] [ drop ] recover + [ paste drop-table ] [ drop ] recover + [ annotation drop-table ] [ drop ] recover + [ ] [ paste create-table ] unit-test + [ ] [ annotation create-table ] unit-test +] with-db diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index a7f2abf8b8..4e8b8ec9d0 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -50,10 +50,7 @@ HOOK: insert-tuple* db ( tuple statement -- ) : query-tuples ( statement -- seq ) [ statement-out-params ] keep query-results [ - ! out-parms result-set - [ - sql-row swap resulting-tuple - ] with query-map + [ sql-row swap resulting-tuple ] with query-map ] with-disposal ; : query-modify-tuple ( tuple statement -- ) @@ -91,13 +88,13 @@ HOOK: insert-tuple* db ( tuple statement -- ) : update-tuples ( seq -- ) execute-statement ; -: persist ( tuple -- ) - dup class db-columns find-primary-key ; - +: delete-tuple ( tuple -- ) + dup class + [ bind-tuple ] keep execute-statement ; : setup-select ( tuple -- statement ) dup dup class [ bind-tuple ] keep ; : select-tuples ( tuple -- tuple ) setup-select query-tuples ; -: select-tuple ( tuple -- tuple ) select-tuples first ; +: select-tuple ( tuple -- tuple/f ) select-tuples ?first ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 0c86c788a7..053cc1ccb3 100755 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -204,4 +204,3 @@ SYMBOL: model ] [ drop ] if ; - diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 579e5a607e..cf03fee6b1 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -1,5 +1,5 @@ USING: assocs calendar init kernel math.parser -namespaces random boxes alarms ; +namespaces random boxes alarms combinators.lib ; IN: furnace.sessions SYMBOL: sessions @@ -11,9 +11,8 @@ SYMBOL: sessions ] "furnace.sessions" add-init-hook : new-session-id ( -- str ) - 4 big-random >hex - dup sessions get-global key? - [ drop new-session-id ] when ; + [ 4 big-random >hex ] + [ sessions get-global key? not ] generate ; TUPLE: session id namespace alarm user-agent ; 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/http/basic-authentication/basic-authentication.factor b/extra/http/basic-authentication/basic-authentication.factor index e15ba9db16..dfe04dc4b5 100644 --- a/extra/http/basic-authentication/basic-authentication.factor +++ b/extra/http/basic-authentication/basic-authentication.factor @@ -61,5 +61,5 @@ SYMBOL: realms #! Check if the user is authenticated in the given realm #! to run the specified quotation. If not, use Basic #! Authentication to ask for authorization details. - over "Authorization" header-param authorization-ok? + over "authorization" header-param authorization-ok? [ nip call ] [ drop authentication-error ] if ; diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index 70507f002b..ac317e2605 100755 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -77,7 +77,7 @@ SYMBOL: max-post-request 1024 256 * max-post-request set-global : content-length ( header -- n ) - "content-length" peek at string>number dup [ + "content-length" swap peek-at string>number dup [ dup max-post-request get > [ "Content-Length > max-post-request" throw ] when 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 7fa210d5da..998168ddaa 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -4,12 +4,12 @@ sequences prettyprint system io.encodings.binary io.encodings.ascii ; IN: temporary ! Unix domain stream sockets -[ - [ - "unix-domain-socket-test" temp-file delete-file - ] ignore-errors +: socket-server "unix-domain-socket-test" temp-file ; - "unix-domain-socket-test" temp-file +[ + [ socket-server delete-file ] ignore-errors + + socket-server ascii [ accept [ "Hello world" print flush @@ -17,15 +17,15 @@ IN: temporary ] with-stream ] with-disposal - "unix-domain-socket-test" temp-file delete-file + socket-server delete-file ] "Test" spawn drop yield [ { "Hello world" "FOO" } ] [ [ - "unix-domain-socket-test" temp-file - ascii [ + socket-server ascii + [ readln , "XYZ" print flush readln , @@ -33,17 +33,16 @@ yield ] { } make ] unit-test -! Unix domain datagram sockets -[ - "unix-domain-datagram-test" temp-file 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,59 +66,53 @@ yield "Done" print - "unix-domain-datagram-test" temp-file delete-file + datagram-server delete-file ] with-scope ] "Test" spawn drop yield -[ - "unix-domain-datagram-test-2" temp-file delete-file -] ignore-errors +[ datagram-client delete-file ] ignore-errors -client-addr -"Four" print +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" temp-file 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 @@ -127,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 diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 58e3c0ba69..708dc1dc38 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -146,8 +146,8 @@ M: windows-io kill-process* ( handle -- ) : wait-loop ( -- ) processes get dup assoc-empty? - [ drop f nap drop ] - [ wait-for-processes [ 100 nap drop ] when ] if ; + [ drop f sleep-until ] + [ wait-for-processes [ 100 sleep ] when ] if ; SYMBOL: wait-thread diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor index dab8474d92..2a685eccd1 100755 --- a/extra/ogg/player/player.factor +++ b/extra/ogg/player/player.factor @@ -15,7 +15,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays namespaces threads shuffle opengl arrays ui.gadgets.worlds combinators math.parser ui.gadgets ui.render opengl.gl ui continuations io.files hints combinators.lib sequences.lib - io.encodings.binary ; + io.encodings.binary debugger ; IN: ogg.player @@ -150,7 +150,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 draw-world + dup player-gadget relayout-1 yield ] when ; : num-audio-buffers-processed ( player -- player n ) @@ -178,7 +178,7 @@ HINTS: yuv>rgb byte-array byte-array ; : append-audio ( player -- player bool ) num-audio-buffers-processed { { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] } - { [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] } + { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] } { [ t ] [ fill-processed-audio-buffer t ] } } cond ; @@ -603,8 +603,7 @@ M: theora-gadget draw-gadget* ( gadget -- ) parse-remaining-headers initialize-decoder dup player-gadget [ initialize-gui ] when* - [ decode ] [ drop ] recover -! decode + [ decode ] try wait-for-sound cleanup drop ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 59a8b63c14..8298814017 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -306,9 +306,15 @@ MEMO: range ( min max -- parser ) : seq ( seq -- parser ) seq-parser construct-boa init-parser ; +: seq* ( quot -- paser ) + { } make seq ; inline + : choice ( seq -- parser ) choice-parser construct-boa init-parser ; +: choice* ( quot -- paser ) + { } make choice ; inline + MEMO: repeat0 ( parser -- parser ) repeat0-parser construct-boa init-parser ; diff --git a/extra/random-tester/random-tester.factor b/extra/random-tester/random-tester.factor index 8704687e34..7fb1714860 100755 --- a/extra/random-tester/random-tester.factor +++ b/extra/random-tester/random-tester.factor @@ -1,5 +1,6 @@ USING: compiler continuations io kernel math namespaces -prettyprint quotations random sequences vectors ; +prettyprint quotations random sequences vectors +compiler.units ; USING: random-tester.databank random-tester.safe-words ; IN: random-tester diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 1a8c1096a5..99a708d2de 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/tools/threads/threads.factor b/extra/tools/threads/threads.factor index 3313a56964..552247e2c4 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -8,7 +8,10 @@ heaps.private system math math.parser ; : thread. ( thread -- ) dup thread-id pprint-cell dup thread-name over [ write-object ] with-cell - dup thread-state "running" or [ write ] with-cell + dup thread-state [ + [ dup self eq? "running" "yield" ? ] unless* + write + ] with-cell [ thread-sleep-entry [ entry-key millis [-] number>string write diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 53ed62252d..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 10 sleep ] 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 37c5684cc9..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 ; +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 @@ -184,7 +188,7 @@ M: array gadget-text* #! When unit testing gadgets without the UI running, the #! invalid queue is not initialized and we simply ignore #! invalidation requests. - layout-queue [ push-front ] [ drop ] if* ; + layout-queue [ push-front notify-ui-thread ] [ drop ] if* ; DEFER: relayout @@ -256,11 +260,11 @@ M: gadget layout* drop ; : queue-graft ( gadget -- ) { f t } over set-gadget-graft-state - graft-queue push-front ; + graft-queue push-front notify-ui-thread ; : queue-ungraft ( gadget -- ) { t f } over set-gadget-graft-state - graft-queue push-front ; + graft-queue push-front notify-ui-thread ; : graft-later ( gadget -- ) dup gadget-graft-state { 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 1de0dac6f0..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,11 +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> @@ -159,16 +184,13 @@ M: object close-window 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 ( -- ) @@ -181,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 80c03a3f5d..45da2706f4 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -15,8 +15,11 @@ TUPLE: windows-ui-backend ; : lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ; : enum-clipboard ( -- seq ) - 0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ] - { } unfold nip ; + 0 + [ EnumClipboardFormats win32-error dup dup 0 > ] + [ ] + [ drop ] + unfold nip ; : with-clipboard ( quot -- ) f OpenClipboard win32-error=0/f @@ -40,13 +43,12 @@ TUPLE: windows-ui-backend ; : copy ( str -- ) lf>crlf [ string>u16-alien - f OpenClipboard win32-error=0/f EmptyClipboard win32-error=0/f GMEM_MOVEABLE over length 1+ GlobalAlloc dup win32-error=0/f dup GlobalLock dup win32-error=0/f - rot dup length memcpy + swapd byte-array>memory dup GlobalUnlock win32-error=0/f CF_UNICODETEXT swap SetClipboardData win32-error=0/f ] with-clipboard ; @@ -72,30 +74,28 @@ SYMBOL: mouse-captured : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline -: adjust-RECT ( RECT -- ) - style 0 ex-style AdjustWindowRectEx win32-error=0/f ; - -: make-RECT ( width height -- RECT ) - "RECT" [ set-RECT-bottom ] keep [ set-RECT-right ] keep ; - -: make-adjusted-RECT ( width height -- RECT ) - make-RECT dup adjust-RECT ; - -: get-RECT-dimensions ( RECT -- width height ) - [ RECT-right ] keep [ RECT-left - ] keep - [ RECT-bottom ] keep RECT-top - ; - : get-RECT-top-left ( RECT -- x y ) [ RECT-left ] keep RECT-top ; +: get-RECT-dimensions ( RECT -- x y width height ) + [ get-RECT-top-left ] keep + [ RECT-right ] keep [ RECT-left - ] keep + [ RECT-bottom ] keep RECT-top - ; + : 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 -- ) - [ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip - dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ; + 2nip + [ lo-word ] keep hi-word 2array + dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ; + +: handle-wm-move ( hWnd uMsg wParam lParam -- ) + 2nip + [ lo-word ] keep hi-word 2array + swap window set-world-loc ; : wm-keydown-codes ( -- key ) H{ @@ -240,7 +240,7 @@ M: windows-ui-backend (close-window) : mouse-absolute>relative ( lparam handle -- array ) >r >lo-hi r> - 0 0 make-RECT [ GetWindowRect win32-error=0/f ] keep + "RECT" [ GetWindowRect win32-error=0/f ] keep get-RECT-top-left 2array v- ; : mouse-event>gesture ( uMsg -- button ) @@ -317,6 +317,7 @@ M: windows-ui-backend (close-window) { [ dup WM_PAINT = ] [ drop 4dup handle-wm-paint DefWindowProc ] } { [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] } + { [ dup WM_MOVE = ] [ drop handle-wm-move 0 ] } ! Keyboard events { [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ] @@ -352,14 +353,12 @@ M: windows-ui-backend (close-window) : event-loop ( msg -- ) { { [ windows get empty? ] [ drop ] } - { [ dup peek-message? ] [ - >r [ ui-step 10 sleep ] 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 ; @@ -383,13 +382,26 @@ M: windows-ui-backend (close-window) RegisterClassEx dup win32-error=0/f ] when ; -: create-window ( width height -- hwnd ) +: adjust-RECT ( RECT -- ) + style 0 ex-style AdjustWindowRectEx win32-error=0/f ; + +: make-RECT ( world -- RECT ) + dup world-loc { 40 40 } vmax dup rot rect-dim v+ + "RECT" + over first over set-RECT-right + swap second over set-RECT-bottom + over first over set-RECT-left + swap second over set-RECT-top ; + +: make-adjusted-RECT ( rect -- RECT ) + make-RECT dup adjust-RECT ; + +: create-window ( rect -- hwnd ) make-adjusted-RECT >r class-name-ptr get-global f r> >r >r >r ex-style r> r> { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags - CW_USEDEFAULT dup r> - get-RECT-dimensions + r> get-RECT-dimensions f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ; : show-window ( hWnd -- ) @@ -424,7 +436,7 @@ M: windows-ui-backend (close-window) get-dc dup setup-pixel-format dup get-rc ; M: windows-ui-backend (open-window) ( world -- ) - [ rect-dim first2 create-window dup setup-gl ] keep + [ create-window dup setup-gl ] keep [ f ] keep [ swap win-hWnd register-window ] 2keep dupd set-world-handle @@ -445,8 +457,8 @@ M: windows-ui-backend raise-window* ( world -- ) M: windows-ui-backend set-title ( string world -- ) world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep dup win-title [ free ] when* - >r malloc-u16-string r> - dupd set-win-title alien-address + >r malloc-u16-string dup r> + set-win-title alien-address SendMessage drop ; M: windows-ui-backend ui diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 9156089a2f..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 10 sleep wait-event + ui-wait wait-event ] if ; : do-events ( -- ) diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor index 2bad0c871d..1308de4547 100755 --- a/extra/webapps/cgi/cgi.factor +++ b/extra/webapps/cgi/cgi.factor @@ -31,13 +31,13 @@ SYMBOL: cgi-root "method" get >upper "REQUEST_METHOD" set "raw-query" get "QUERY_STRING" set - "Cookie" header-param "HTTP_COOKIE" set + "cookie" header-param "HTTP_COOKIE" set - "User-Agent" header-param "HTTP_USER_AGENT" set - "Accept" header-param "HTTP_ACCEPT" set + "user-agent" header-param "HTTP_USER_AGENT" set + "accept" header-param "HTTP_ACCEPT" set post? [ - "Content-Type" header-param "CONTENT_TYPE" set + "content-type" header-param "CONTENT_TYPE" set "raw-response" get length number>string "CONTENT_LENGTH" set ] when ] H{ } make-assoc ; diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor index 80677e4173..876ff03195 100755 --- a/extra/webapps/file/file.factor +++ b/extra/webapps/file/file.factor @@ -25,7 +25,7 @@ SYMBOL: doc-root : last-modified-matches? ( filename -- bool ) file-http-date dup [ - "If-Modified-Since" header-param = + "if-modified-since" header-param = ] when ; : not-modified-response ( -- ) diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index 56ecb3f546..cf01bf63db 100755 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -25,7 +25,7 @@ IN: webapps.fjsc : compile-url ( url -- ) #! Compile the factor code at the given url, return the javascript. dup "http:" head? [ "Unable to access remote sites." throw ] when - "http://" "Host" header-param rot 3append http-get compile "();" write flush ; + "http://" "host" header-param rot 3append http-get compile "();" write flush ; \ compile-url { { "url" v-required } diff --git a/misc/factor.sh b/misc/factor.sh index 44feb329fb..4f503f427b 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -186,8 +186,8 @@ find_word_size() { set_factor_binary() { case $OS in - winnt) FACTOR_BINARY=factor-nt;; - macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; + # winnt) FACTOR_BINARY=factor-nt;; + # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; *) FACTOR_BINARY=factor;; esac } 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