diff --git a/.gitignore b/.gitignore index 897825c826..19ace1f500 100644 --- a/.gitignore +++ b/.gitignore @@ -15,5 +15,7 @@ factor .gdb_history *.*.marks .*.swp -reverse-complement-in.txt -reverse-complement-out.txt +temp +logs +work +misc/wordsize \ No newline at end of file diff --git a/Makefile b/Makefile index 9776027a59..6f12633871 100755 --- a/Makefile +++ b/Makefile @@ -45,7 +45,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ EXE_OBJS = $(PLAF_EXE_OBJS) -default: +default: misc/wordsize + make `./misc/target` + +help: @echo "Run 'make' with one of the following parameters:" @echo "" @echo "freebsd-x86-32" @@ -142,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 \ @@ -158,6 +162,9 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) +misc/wordsize: misc/wordsize.c + gcc misc/wordsize.c -o misc/wordsize + clean: rm -f vm/*.o rm -f factor*.dll libfactor*.* diff --git a/README.txt b/README.txt old mode 100644 new mode 100755 index f92bfe25c7..12dade5ba1 --- a/README.txt +++ b/README.txt @@ -52,7 +52,9 @@ The Factor runtime is written in GNU C99, and is built with GNU make and gcc. Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc -3.3 or earlier. +3.3 or earlier. If you are using gcc 4.3, you might get an unusable +Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the +command-line arguments for make. Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of targets and build options. Then run 'make' with the appropriate target diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 19ee52b039..475cf72d28 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -87,7 +87,7 @@ $nl HELP: alien-invoke-error { $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "The symbol or library could not be found." } { "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." } @@ -103,7 +103,7 @@ HELP: alien-invoke HELP: alien-indirect-error { $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "One of the three inputs to " { $link alien-indirect } " is not a literal value." } } @@ -120,7 +120,7 @@ HELP: alien-indirect HELP: alien-callback-error { $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "One of the four inputs to " { $link alien-callback } " is not a literal value." } } @@ -199,9 +199,7 @@ ARTICLE: "alien-invoke" "Calling C from Factor" { $subsection alien-invoke } "Sometimes it is necessary to invoke a C function pointer, rather than a named C function:" { $subsection alien-indirect } -"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." -$nl -"Don't forget to compile your binding word after defining it; C library calls cannot be made from an interpreted definition. Words defined in source files are automatically compiled when the source file is loaded, but words defined in the listener are not; when interactively testing C libraries, use " { $link compile } " or " { $link recompile } " to compile binding words." ; +"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ; ARTICLE: "alien-callback-gc" "Callbacks and code GC" "A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body." diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 74c94c8edf..72feca27cd 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.tests USING: alien alien.accessors byte-arrays arrays kernel kernel.private namespaces tools.test sequences libc math system prettyprint ; diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 719068e031..843b0a826b 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc ; diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 876310cc5d..7e2e23726b 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.compiler.tests USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences inference words arrays parser quotations continuations inference.backend effects diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 3a41b80c2a..baab72036d 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator generator.registers generator.fixup hashtables kernel math namespaces sequences words @@ -367,7 +367,7 @@ TUPLE: callback-context ; ] if ; : do-callback ( quot token -- ) - init-error-handler + init-catchstack dup 2 setenv slip wait-to-return ; inline diff --git a/core/alien/remote-control/remote-control.factor b/core/alien/remote-control/remote-control.factor old mode 100644 new mode 100755 diff --git a/core/alien/structs/structs-tests.factor b/core/alien/structs/structs-tests.factor index b934cd56a3..a33a86d4b5 100644 --- a/core/alien/structs/structs-tests.factor +++ b/core/alien/structs/structs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.structs.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc words vocabs namespaces ; diff --git a/core/arrays/arrays-tests.factor b/core/arrays/arrays-tests.factor index e07f192197..a7801c7d74 100755 --- a/core/arrays/arrays-tests.factor +++ b/core/arrays/arrays-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel sequences sequences.private growable tools.test vectors layouts system math vectors.private ; -IN: temporary +IN: arrays.tests [ -2 { "a" "b" "c" } nth ] must-fail [ 10 { "a" "b" "c" } nth ] must-fail diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 8fabee06ef..a0a60e875a 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: assocs.tests USING: kernel math namespaces tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations ; diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index 5f89b90608..5774b86e45 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -1,6 +1,6 @@ USING: sequences arrays bit-arrays kernel tools.test math random ; -IN: temporary +IN: bit-arrays.tests [ 100 ] [ 100 length ] unit-test diff --git a/core/bit-vectors/bit-vectors-tests.factor b/core/bit-vectors/bit-vectors-tests.factor index 5838c1eb8d..dff9a8db37 100755 --- a/core/bit-vectors/bit-vectors-tests.factor +++ b/core/bit-vectors/bit-vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: bit-vectors.tests USING: tools.test bit-vectors vectors sequences kernel math ; [ 0 ] [ 123 length ] unit-test diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 608b5cb581..5ccde88e28 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -16,6 +16,14 @@ IN: bootstrap.compiler "cpu." cpu append require +: enable-compiler ( -- ) + [ optimized-recompile-hook ] recompile-hook set-global ; + +: disable-compiler ( -- ) + [ default-recompile-hook ] recompile-hook set-global ; + +enable-compiler + nl "Compiling some words to speed up bootstrap..." write flush @@ -74,12 +82,4 @@ nl malloc free memcpy } compile -: enable-compiler ( -- ) - [ compiled-usages recompile ] recompile-hook set-global ; - -: disable-compiler ( -- ) - [ default-recompile-hook ] recompile-hook set-global ; - -enable-compiler - " done" print flush diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor index 8c618a8f30..ae5c66a45c 100755 --- a/core/bootstrap/image/image-tests.factor +++ b/core/bootstrap/image/image-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: bootstrap.image.tests USING: bootstrap.image bootstrap.image.private tools.test ; \ ' must-infer diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 17b56458ce..35dae109cf 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -36,7 +36,7 @@ IN: bootstrap.image : data-base 1024 ; inline -: userenv-size 40 ; inline +: userenv-size 64 ; inline : header-size 10 ; inline diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 97712972f3..f3f233ea0b 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -30,7 +30,10 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set H{ } clone changed-words set -[ drop ] recompile-hook set + +! Trivial recompile hook. We don't want to touch the code heap +! during stage1 bootstrap, it would just waste time. +[ drop { } ] recompile-hook set call call diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 4f5bf6d69e..0e038d0a10 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: bootstrap.stage1 USING: arrays debugger generic hashtables io assocs kernel.private kernel math memory namespaces parser prettyprint sequences vectors words system splitting init io.files bootstrap.image bootstrap.image.private vocabs -vocabs.loader system ; +vocabs.loader system debugger continuations ; { "resource:core" } vocab-roots set @@ -31,6 +31,7 @@ vocabs.loader system ; "libc" require "io.streams.c" require + "io.thread" require "vocabs.loader" require "syntax" require @@ -39,7 +40,14 @@ vocabs.loader system ; [ "resource:core/bootstrap/stage2.factor" dup resource-exists? [ - run-file + [ run-file ] + [ + :c + dup print-error flush + "listener" vocab + [ restarts. vocab-main execute ] + [ die ] if* + ] recover ] [ "Cannot find " write write "." print "Please move " write image write " to the same directory as the Factor sources," print diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 3bc82bbe6a..63b5726ad7 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -29,9 +29,7 @@ SYMBOL: bootstrap-time : compile-remaining ( -- ) "Compiling remaining words..." print flush - vocabs [ - words "compile" "compiler" lookup execute - ] each ; + vocabs [ words [ compiled? not ] subset compile ] each ; : count-words ( pred -- ) all-words swap subset length number>string write ; @@ -53,66 +51,60 @@ SYMBOL: bootstrap-time ! Wrap everything in a catch which starts a listener so ! you can see what went wrong, instead of dealing with a ! fep -[ - ! We time bootstrap - millis >r - default-image-name "output-image" set-global +! We time bootstrap +millis >r - "math help handbook compiler tools ui ui.tools io" "include" set-global - "" "exclude" set-global +default-image-name "output-image" set-global - parse-command-line +"math help handbook compiler tools ui ui.tools io" "include" set-global +"" "exclude" set-global - "-no-crossref" cli-args member? [ do-crossref ] unless +parse-command-line - ! Set dll paths - wince? [ "windows.ce" require ] when - winnt? [ "windows.nt" require ] when +"-no-crossref" cli-args member? [ do-crossref ] unless - "deploy-vocab" get [ - "stage2: deployment mode" print - ] [ - "listener" require - "none" require - ] if +! Set dll paths +wince? [ "windows.ce" require ] when +winnt? [ "windows.nt" require ] when - [ - load-components - - run-bootstrap-init - - "bootstrap.compiler" vocab [ - compile-remaining - ] when - ] with-compiler-errors - :errors - - f error set-global - f error-continuation set-global - - "deploy-vocab" get [ - "tools.deploy.shaker" run - ] [ - [ - boot - do-init-hooks - [ - parse-command-line - run-user-init - "run" get run - stdio get [ stream-flush ] when* - ] [ print-error 1 exit ] recover - ] set-boot-quot - - millis r> - dup bootstrap-time set-global - print-report - - "output-image" get resource-path save-image-and-exit - ] if +"deploy-vocab" get [ + "stage2: deployment mode" print ] [ - :c - print-error restarts. - "listener" vocab-main execute - 1 exit -] recover + "listener" require + "none" require +] if + +[ + load-components + + run-bootstrap-init + + "bootstrap.compiler" vocab [ + compile-remaining + ] when +] with-compiler-errors +:errors + +f error set-global +f error-continuation set-global + +"deploy-vocab" get [ + "tools.deploy.shaker" run +] [ + [ + boot + do-init-hooks + [ + parse-command-line + run-user-init + "run" get run + stdio get [ stream-flush ] when* + ] [ print-error 1 exit ] recover + ] set-boot-quot + + millis r> - dup bootstrap-time set-global + print-report + + "output-image" get resource-path save-image-and-exit +] if diff --git a/core/boxes/boxes-docs.factor b/core/boxes/boxes-docs.factor new file mode 100755 index 0000000000..b3b91d06d9 --- /dev/null +++ b/core/boxes/boxes-docs.factor @@ -0,0 +1,38 @@ +USING: help.markup help.syntax kernel ; +IN: boxes + +HELP: box +{ $class-description "A data type holding a single value in the " { $link box-value } " slot. The " { $link box-full? } " slot indicates if the value is set." } ; + +HELP: +{ $values { "box" box } } +{ $description "Creates a new empty box." } ; + +HELP: >box +{ $values { "value" object } { "box" box } } +{ $description "Stores a value into a box." } +{ $errors "Throws an error if the box is full." } ; + +HELP: box> +{ $values { "box" box } { "value" "the value of the box" } } +{ $description "Removes a value from a box." } +{ $errors "Throws an error if the box is empty." } ; + +HELP: ?box +{ $values { "box" box } { "value" "the value of the box or " { $link f } } { "?" "a boolean" } } +{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ; + +ARTICLE: "boxes" "Boxes" +"A " { $emphasis "box" } " is a container which can either be empty or hold a single value." +{ $subsection box } +"Creating an empty box:" +{ $subsection } +"Testing if a box is full:" +{ $subsection box-full? } +"Storing a value and removing a value from a box:" +{ $subsection >box } +{ $subsection box> } +"Safely removing a value:" +{ $subsection ?box } ; + +ABOUT: "boxes" diff --git a/core/boxes/boxes-tests.factor b/core/boxes/boxes-tests.factor new file mode 100755 index 0000000000..76a6cfd8b1 --- /dev/null +++ b/core/boxes/boxes-tests.factor @@ -0,0 +1,24 @@ +IN: boxes.tests +USING: boxes namespaces tools.test ; + +[ ] [ "b" set ] unit-test + +[ ] [ 3 "b" get >box ] unit-test + +[ t ] [ "b" get box-full? ] unit-test + +[ 4 "b" >box ] must-fail + +[ 3 ] [ "b" get box> ] unit-test + +[ f ] [ "b" get box-full? ] unit-test + +[ "b" get box> ] must-fail + +[ f f ] [ "b" get ?box ] unit-test + +[ ] [ 12 "b" get >box ] unit-test + +[ 12 t ] [ "b" get ?box ] unit-test + +[ f ] [ "b" get box-full? ] unit-test diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor new file mode 100755 index 0000000000..a989e091bb --- /dev/null +++ b/core/boxes/boxes.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: boxes + +TUPLE: box value full? ; + +: ( -- box ) box construct-empty ; + +: >box ( value box -- ) + dup box-full? [ "Box already has a value" throw ] when + t over set-box-full? + set-box-value ; + +: box> ( box -- value ) + dup box-full? [ "Box empty" throw ] unless + dup box-value f pick set-box-value + f rot set-box-full? ; + +: ?box ( box -- value/f ? ) + dup box-full? [ box> t ] [ drop f f ] if ; + +: if-box? ( box quot -- ) + >r ?box r> [ drop ] if ; inline diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index b5b01c201b..07b82f6111 100755 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: byte-arrays.tests USING: tools.test byte-arrays ; [ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor index 2d9ca1f205..d457d6805e 100755 --- a/core/byte-vectors/byte-vectors-tests.factor +++ b/core/byte-vectors/byte-vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: byte-vectors.tests USING: tools.test byte-vectors vectors sequences kernel ; [ 0 ] [ 123 length ] unit-test diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 103c4eed09..38ca796384 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes io.streams.string classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units ; -IN: temporary +IN: classes.tests H{ } "s" set @@ -62,7 +62,7 @@ UNION: bah fixnum alien ; [ bah ] [ \ bah? "predicating" word-prop ] unit-test ! Test generic see and parsing -[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ] +[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] [ [ \ bah see ] with-string-writer ] unit-test ! Test redefinition of classes @@ -78,7 +78,7 @@ M: union-1 generic-update-test drop "union-1" ; [ union-1 ] [ fixnum float class-or ] unit-test -"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval +"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval [ t ] [ bignum union-1 class< ] unit-test [ f ] [ union-1 number class< ] unit-test @@ -86,7 +86,7 @@ M: union-1 generic-update-test drop "union-1" ; [ object ] [ fixnum float class-or ] unit-test -"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval +"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test @@ -126,7 +126,7 @@ INSTANCE: integer mx1 [ t ] [ mx1 integer class< ] unit-test [ t ] [ mx1 number class< ] unit-test -"IN: temporary USE: arrays INSTANCE: array mx1" eval +"IN: classes.tests USE: arrays INSTANCE: array mx1" eval [ t ] [ array mx1 class< ] unit-test [ f ] [ mx1 number class< ] unit-test @@ -157,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; [ t ] [ quotation redefine-bug-2 class< ] unit-test [ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test -[ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test +[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test [ t ] [ bignum redefine-bug-1 class< ] unit-test [ f ] [ fixnum redefine-bug-2 class< ] unit-test @@ -185,7 +185,7 @@ DEFER: mixin-forget-test-g [ ] [ { "USING: sequences ;" - "IN: temporary" + "IN: classes.tests" "MIXIN: mixin-forget-test" "INSTANCE: sequence mixin-forget-test" "GENERIC: mixin-forget-test-g ( x -- y )" @@ -200,7 +200,7 @@ DEFER: mixin-forget-test-g [ ] [ { "USING: hashtables ;" - "IN: temporary" + "IN: classes.tests" "MIXIN: mixin-forget-test" "INSTANCE: hashtable mixin-forget-test" "GENERIC: mixin-forget-test-g ( x -- y )" diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 70088f2b03..48ddb2adf5 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -255,8 +255,7 @@ PRIVATE> : (define-class) ( word props -- ) over reset-class - over reset-generic - over define-symbol + over deferred? [ over define-symbol ] when >r dup word-props r> union over set-word-props t "class" set-word-prop ; diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index ce8e180867..8abc53e43f 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: combinators.tests USING: alien strings kernel math tools.test io prettyprint namespaces combinators words ; diff --git a/core/command-line/command-line-tests.factor b/core/command-line/command-line-tests.factor index c4221b0d06..226765bafe 100644 --- a/core/command-line/command-line-tests.factor +++ b/core/command-line/command-line-tests.factor @@ -1,5 +1,5 @@ USING: namespaces tools.test kernel command-line ; -IN: temporary +IN: command-line.tests [ [ f ] [ "-no-user-init" cli-arg ] unit-test diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 17e6938a0c..7196a4b4fb 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -1,18 +1,14 @@ USING: generator help.markup help.syntax words io parser -assocs words.private sequences ; +assocs words.private sequences compiler.units ; IN: compiler ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly." $nl -"The main entry points to the optimizing compiler:" -{ $subsection compile } -{ $subsection recompile } -{ $subsection recompile-all } +"The main entry point to the optimizing compiler:" +{ $subsection optimized-recompile-hook } "Removing a word's optimized definition:" -{ $subsection decompile } -"The optimizing compiler can also compile and call a single quotation:" -{ $subsection compile-call } ; +{ $subsection decompile } ; ARTICLE: "compiler" "Optimizing compiler" "Factor is a fully compiled language implementation with two distinct compilers:" @@ -26,22 +22,6 @@ ARTICLE: "compiler" "Optimizing compiler" ABOUT: "compiler" -HELP: compile -{ $values { "seq" "a sequence of words" } } -{ $description "Compiles a set of words. Ignores words which are already compiled." } ; - -HELP: recompile -{ $values { "seq" "a sequence of words" } } -{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ; - -HELP: compile-call -{ $values { "quot" "a quotation" } } -{ $description "Compiles and runs a quotation." } -{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ; - -HELP: recompile-all -{ $description "Recompiles all words." } ; - HELP: decompile { $values { "word" word } } { $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ; @@ -50,3 +30,8 @@ HELP: (compile) { $values { "word" word } } { $description "Compile a single word." } { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; + +HELP: optimized-recompile-hook +{ $values { "words" "a sequence of words" } { "alist" "an association list" } } +{ $description "Compile a set of words." } +{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index f0caec7ad1..111d84cde0 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -4,14 +4,9 @@ USING: kernel namespaces arrays sequences io inference.backend inference.state generator debugger math.parser prettyprint words compiler.units continuations vocabs assocs alien.compiler dlists optimizer definitions math compiler.errors threads graphs -generic ; +generic inference ; IN: compiler -: compiled-usages ( words -- seq ) - [ [ dup ] H{ } map>assoc dup ] keep [ - compiled-usage [ nip +inlined+ eq? ] assoc-subset update - ] with each keys ; - : ripple-up ( word -- ) compiled-usage [ drop queue-compile ] assoc-each ; @@ -49,27 +44,17 @@ IN: compiler compile-loop ] if ; -: recompile ( words -- ) +: decompile ( word -- ) + f 2array 1array t modify-code-heap ; + +: optimized-recompile-hook ( words -- alist ) [ H{ } clone compile-queue set H{ } clone compiled set [ queue-compile ] each compile-queue get compile-loop compiled get >alist - dup [ drop crossref? ] assoc-contains? - modify-code-heap - ] with-scope ; inline - -: compile ( words -- ) - [ compiled? not ] subset recompile ; - -: compile-call ( quot -- ) - H{ } clone changed-words - [ define-temp dup 1array compile ] with-variable - execute ; + ] with-scope ; : recompile-all ( -- ) - [ all-words recompile ] with-compiler-errors ; - -: decompile ( word -- ) - f 2array 1array t modify-code-heap ; + forget-errors all-words compile ; diff --git a/core/compiler/tests/curry.factor b/core/compiler/tests/curry.factor index 77ac01e101..d2e7115f8f 100755 --- a/core/compiler/tests/curry.factor +++ b/core/compiler/tests/curry.factor @@ -1,6 +1,6 @@ -USING: tools.test compiler quotations math kernel sequences -assocs namespaces ; -IN: temporary +USING: tools.test quotations math kernel sequences +assocs namespaces compiler.units ; +IN: compiler.tests [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 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..0d457a8310 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 +IN: compiler.tests +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..dd9a453cfc 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 ; +IN: compiler.tests +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..13b7de6987 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -1,7 +1,7 @@ -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 +IN: compiler.tests ! Test empty word [ ] [ [ ] compile-call ] unit-test diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 137d86b489..f54ac62204 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: compiler.tests USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private words splitting sorting ; diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index 13d834a489..bdbc985078 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -1,5 +1,5 @@ ! Testing templates machinery without compiling anything -IN: temporary +IN: compiler.tests USING: compiler generator generator.registers generator.registers.private tools.test namespaces sequences words kernel math effects definitions compiler.units ; diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 4be700f221..1c19730ec0 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -4,7 +4,7 @@ hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators ; -IN: temporary +IN: compiler.tests ! Oops! [ 5000 ] [ [ 5000 ] compile-call ] unit-test diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index a23b6739ad..5843575eeb 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -1,5 +1,5 @@ -IN: temporary -USING: kernel tools.test compiler ; +IN: compiler.tests +USING: kernel tools.test compiler.units ; TUPLE: color red green blue ; diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index 99124d40ae..d30c5457d5 100755 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -61,3 +61,11 @@ HELP: modify-code-heap ( alist -- ) { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." } } } { $notes "This word is called at the end of " { $link with-compilation-unit } "." } ; + +HELP: compile +{ $values { "seq" "a sequence of words" } } +{ $description "Compiles a set of words." } ; + +HELP: compile-call +{ $values { "quot" "a quotation" } } +{ $description "Compiles and runs a quotation." } ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 225e1c17c6..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 ; @@ -63,24 +64,45 @@ GENERIC: definitions-changed ( assoc obj -- ) dup changed-words get update dup dup changed-vocabs update ; +: compile ( words -- ) + recompile-hook get call + dup [ drop crossref? ] assoc-contains? + modify-code-heap ; + +SYMBOL: post-compile-tasks + +: after-compilation ( quot -- ) + post-compile-tasks get push ; + +: call-recompile-hook ( -- ) + changed-words get keys + compiled-usages recompile-hook get call ; + +: call-post-compile-tasks ( -- ) + post-compile-tasks get [ call ] each ; + : finish-compilation-unit ( -- ) - changed-words get keys recompile-hook get call + call-recompile-hook + call-post-compile-tasks + dup [ drop crossref? ] assoc-contains? modify-code-heap changed-definitions notify-definition-observers ; : with-compilation-unit ( quot -- ) [ H{ } clone changed-words set H{ } clone forgotten-definitions set + V{ } clone post-compile-tasks set new-definitions set old-definitions set [ finish-compilation-unit ] [ ] cleanup ] with-scope ; inline -: default-recompile-hook - [ f ] { } map>assoc - dup [ drop crossref? ] assoc-contains? - modify-code-heap ; +: compile-call ( quot -- ) + [ define-temp ] with-compilation-unit execute ; + +: default-recompile-hook ( words -- alist ) + [ f ] { } map>assoc ; recompile-hook global [ [ default-recompile-hook ] or ] diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 7cf15394ef..9a26dbc67e 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private continuations.private parser vectors arrays namespaces -threads assocs words quotations ; +assocs words quotations ; IN: continuations ARTICLE: "errors-restartable" "Restartable errors" @@ -23,9 +23,10 @@ $nl "Two words raise an error in the innermost error handler for the current dynamic extent:" { $subsection throw } { $subsection rethrow } -"Two words for establishing an error handler:" +"Words for establishing an error handler:" { $subsection cleanup } { $subsection recover } +{ $subsection ignore-errors } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "errors-post-mortem" } ; @@ -44,11 +45,7 @@ ARTICLE: "continuations.private" "Continuation implementation details" { $subsection namestack } { $subsection set-namestack } { $subsection catchstack } -{ $subsection set-catchstack } -"The continuations implementation has hooks for single-steppers:" -{ $subsection walker-hook } -{ $subsection set-walker-hook } -{ $subsection (continue-with) } ; +{ $subsection set-catchstack } ; ARTICLE: "continuations" "Continuations" "At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation." @@ -110,10 +107,6 @@ HELP: callcc1 { $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } } { $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ; -HELP: (continue-with) -{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } } -{ $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ; - HELP: continue { $values { "continuation" continuation } } { $description "Resumes a continuation reified by " { $link callcc0 } "." } ; @@ -156,6 +149,10 @@ HELP: recover { $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } } { $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; +HELP: ignore-errors +{ $values { "try" quotation } } +{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ; + HELP: rethrow { $values { "error" object } } { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } @@ -196,9 +193,3 @@ HELP: save-error { $values { "error" "an error" } } { $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." } $low-level-note ; - -HELP: init-error-handler -{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ; - -HELP: break -{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index b7d580afe5..d5ede60086 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -1,7 +1,7 @@ USING: kernel math namespaces io tools.test sequences vectors continuations debugger parser memory arrays words kernel.private ; -IN: temporary +IN: continuations.tests : (callcc1-test) swap 1- tuck swap ?push diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 81f78f491d..13b31cfde6 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -6,6 +6,7 @@ IN: continuations SYMBOL: error SYMBOL: error-continuation +SYMBOL: error-thread SYMBOL: restarts : catchstack ( -- catchstack ) catchstack* clone ; inline @@ -91,14 +94,8 @@ C: continuation PRIVATE> -: set-walker-hook ( quot -- ) 3 setenv ; inline - -: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline - : continue-with ( obj continuation -- ) - [ - walker-hook [ >r 2array r> ] when* (continue-with) - ] 2 (throw) ; + [ (continue-with) ] 2 (throw) ; : continue ( continuation -- ) f swap continue-with ; @@ -113,13 +110,22 @@ GENERIC: compute-restarts ( error -- seq ) PRIVATE> +SYMBOL: thread-error-hook + : rethrow ( error -- * ) - catchstack* empty? [ die ] when - dup save-error c> continue-with ; + dup save-error + catchstack* empty? [ + thread-error-hook get-global + [ 1 (throw) ] [ die ] if* + ] when + c> continue-with ; : recover ( try recovery -- ) >r [ swap >c call c> drop ] curry r> ifcc ; inline +: ignore-errors ( quot -- ) + [ drop ] recover ; inline + : cleanup ( try cleanup-always cleanup-error -- ) over >r compose [ dip rethrow ] curry recover r> call ; inline @@ -166,34 +172,3 @@ M: condition compute-restarts condition-continuation [ ] curry { } assoc>map append ; - - - -! Debugging support -: with-walker-hook ( continuation -- ) - [ swap set-walker-hook (continue) ] curry callcc1 ; - -SYMBOL: break-hook - -: break ( -- ) - continuation callstack - over set-continuation-call - walker-hook [ (continue-with) ] [ break-hook get call ] if* ; - -GENERIC: (step-into) ( obj -- ) - -M: wrapper (step-into) wrapped break ; -M: object (step-into) break ; -M: callable (step-into) \ break add* break ; diff --git a/core/cpu/arm/assembler/assembler-tests.factor b/core/cpu/arm/assembler/assembler-tests.factor index 219015fae9..a30ab9f797 100644 --- a/core/cpu/arm/assembler/assembler-tests.factor +++ b/core/cpu/arm/assembler/assembler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: cpu.arm.assembler.tests USING: assembler-arm math test namespaces sequences kernel quotations ; diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index ecae55e69a..649cfbabab 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup generator system alien.compiler combinators command-line -compiler io vocabs.loader ; +compiler compiler.units io vocabs.loader ; IN: cpu.x86.32 PREDICATE: x86-backend x86-32-backend @@ -281,7 +281,10 @@ T{ x86-backend f 4 } compiler-backend set-global "-no-sse2" cli-args member? [ "Checking if your CPU supports SSE2..." print flush - [ sse2? ] compile-call [ + [ optimized-recompile-hook ] recompile-hook [ + [ sse2? ] compile-call + ] with-variable + [ " - yes" print "cpu.x86.sse2" require ] [ diff --git a/core/cpu/x86/assembler/assembler-tests.factor b/core/cpu/x86/assembler/assembler-tests.factor index 256bc57578..caa00bd618 100644 --- a/core/cpu/x86/assembler/assembler-tests.factor +++ b/core/cpu/x86/assembler/assembler-tests.factor @@ -1,5 +1,5 @@ USING: cpu.x86.assembler kernel tools.test namespaces ; -IN: temporary +IN: cpu.x86.assembler.tests [ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test [ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index b754856ee4..5e8b6df34a 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -1,6 +1,6 @@ USING: alien arrays generic generic.math help.markup help.syntax kernel math memory strings sbufs vectors io io.files classes -help generic.standard continuations system ; +help generic.standard continuations system debugger.private ; IN: debugger ARTICLE: "errors-assert" "Assertions" @@ -80,9 +80,6 @@ HELP: print-error HELP: restarts. { $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ; -HELP: debug-help -{ $description "Print a synopsis of useful debugger words." } ; - HELP: error-hook { $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." } { $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ; @@ -169,3 +166,6 @@ HELP: depth HELP: assert-depth { $values { "quot" "a quotation" } } { $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ; + +HELP: init-debugger +{ $description "Called on startup to set a pair of hooks which allow the " { $link throw } " word to function." } ; diff --git a/core/debugger/debugger-tests.factor b/core/debugger/debugger-tests.factor index 31c3e8a762..afa4aa1c28 100755 --- a/core/debugger/debugger-tests.factor +++ b/core/debugger/debugger-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: debugger.tests USING: debugger kernel continuations tools.test ; [ ] [ [ drop ] [ error. ] recover ] unit-test diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 776e2976d9..40bcbe78b1 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -5,7 +5,8 @@ math namespaces prettyprint sequences assocs sequences.private strings io.styles vectors words system splitting math.parser tuples continuations continuations.private combinators generic.math io.streams.duplex classes compiler.units -generic.standard vocabs ; +generic.standard vocabs threads threads.private init +kernel.private libc ; IN: debugger GENERIC: error. ( error -- ) @@ -31,6 +32,9 @@ M: string error. print ; : :get ( variable -- value ) error-continuation get continuation-name assoc-stack ; +: :vars ( -- ) + error-continuation get continuation-name namestack. ; + : :res ( n -- ) 1- restarts get-global nth f restarts set-global restart ; @@ -54,19 +58,6 @@ M: string error. print ; dup length [ restart. ] 2each ] if ; -: debug-help ( -- ) - nl - "Debugger commands:" print - nl - ":help - documentation for this error" print - ":s - data stack at exception time" print - ":r - retain stack at exception time" print - ":c - call stack at exception time" print - ":edit - jump to source location (parse errors only)" print - - ":get ( var -- value ) accesses variables at time of the error" print - flush ; - : print-error ( error -- ) [ error. flush ] curry [ global [ "Error in print-error!" print drop ] bind ] @@ -74,7 +65,12 @@ M: string error. print ; SYMBOL: error-hook -[ print-error restarts. debug-help ] error-hook set-global +[ + print-error + restarts. + nl + "Type :help for debugging help." print flush +] error-hook set-global : try ( quot -- ) [ error-hook get call ] recover ; @@ -257,3 +253,49 @@ M: no-compilation-unit error. M: no-vocab summary drop "Vocabulary does not exist" ; + +M: check-ptr summary + drop "Memory allocation failed" ; + +M: double-free summary + drop "Free failed since memory is not allocated" ; + +M: realloc-error summary + drop "Memory reallocation failed" ; + +: error-in-thread. ( -- ) + error-thread get-global + "Error in thread " write + [ + dup thread-id # + " (" % dup thread-name % + ", " % dup thread-quot unparse-short % ")" % + ] "" make swap write-object ":" print nl ; + +! Hooks +M: thread error-in-thread ( error thread -- ) + initial-thread get-global eq? [ + die drop + ] [ + global [ + error-in-thread. print-error flush + ] bind + ] if ; + + + +[ init-debugger ] "debugger" add-init-hook diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index f0b0888052..4e8fb255dd 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: definitions.tests USING: tools.test generic kernel definitions sequences compiler.units ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index ad261df7d4..01f9643cdd 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -43,7 +43,7 @@ M: object uses drop f ; : xref ( defspec -- ) dup uses crossref get add-vertex ; -: usage ( defspec -- seq ) crossref get at keys ; +: usage ( defspec -- seq ) \ f or crossref get at keys ; GENERIC: redefined* ( defspec -- ) diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index 203c975bb2..cd651bff2f 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -1,7 +1,7 @@ USING: dlists dlists.private kernel tools.test random assocs hashtables sequences namespaces sorting debugger io prettyprint math ; -IN: temporary +IN: dlists.tests [ t ] [ dlist-empty? ] unit-test diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 46037ba0d4..234f567f25 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: effects.tests USING: effects tools.test ; [ t ] [ 1 1 2 2 effect<= ] unit-test diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor index 0e0ab3feb6..0918eecd84 100755 --- a/core/float-arrays/float-arrays-tests.factor +++ b/core/float-arrays/float-arrays-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: float-arrays.tests USING: float-arrays tools.test ; [ F{ 1.0 1.0 1.0 } ] [ 3 1.0 ] unit-test diff --git a/core/float-vectors/float-vectors-tests.factor b/core/float-vectors/float-vectors-tests.factor index 68b8195eb7..383dd4bcf2 100755 --- a/core/float-vectors/float-vectors-tests.factor +++ b/core/float-vectors/float-vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: float-vectors.tests USING: tools.test float-vectors vectors sequences kernel ; [ 0 ] [ 123 length ] unit-test diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index e3fdbc7b46..2dc699f87b 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -3,7 +3,7 @@ generic.math assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes continuations layouts classes.union sorting compiler.units ; -IN: temporary +IN: generic.tests GENERIC: foobar ( x -- y ) M: object foobar drop "Hello world" ; @@ -87,11 +87,11 @@ M: number union-containment drop 2 ; [ 2 ] [ 1.0 union-containment ] unit-test ! Testing recovery from bad method definitions -"IN: temporary GENERIC: unhappy ( x -- x )" eval +"IN: generic.tests GENERIC: unhappy ( x -- x )" eval [ - "IN: temporary M: dictionary unhappy ;" eval + "IN: generic.tests M: dictionary unhappy ;" eval ] must-fail -[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test +[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test GENERIC# complex-combination 1 ( a b -- c ) M: string complex-combination drop ; @@ -192,12 +192,12 @@ SYMBOL: redefinition-test-generic TUPLE: redefinition-test-tuple ; -"IN: temporary M: redefinition-test-tuple redefinition-test-generic ;" eval +"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval [ t ] [ [ redefinition-test-generic , - "IN: temporary TUPLE: redefinition-test-tuple ;" eval + "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval redefinition-test-generic , ] { } make all-equal? ] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 4bdd1ae40d..35cc471033 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -102,11 +102,13 @@ M: method-body stack-effect ! Definition protocol M: method-spec where - dup first2 method [ method-loc ] [ second where ] ?if ; + dup first2 method [ method-word ] [ second ] ?if where ; -M: method-spec set-where first2 method set-method-loc ; +M: method-spec set-where + first2 method method-word set-where ; -M: method-spec definer drop \ M: \ ; ; +M: method-spec definer + drop \ M: \ ; ; M: method-spec definition first2 method dup [ method-def ] when ; @@ -114,9 +116,21 @@ M: method-spec definition : forget-method ( class generic -- ) check-method [ delete-at* ] with-methods - [ method-word forget ] [ drop ] if ; + [ method-word forget-word ] [ drop ] if ; -M: method-spec forget* first2 forget-method ; +M: method-spec forget* + first2 forget-method ; + +M: method-body definer + drop \ M: \ ; ; + +M: method-body definition + "method" word-prop method-def ; + +M: method-body forget* + "method" word-prop + { method-specializer method-generic } get-slots + forget-method ; : implementors* ( classes -- words ) all-words [ diff --git a/core/growable/growable-tests.factor b/core/growable/growable-tests.factor index a220ccc45e..7ba67fe97b 100755 --- a/core/growable/growable-tests.factor +++ b/core/growable/growable-tests.factor @@ -1,6 +1,6 @@ USING: math sequences classes growable tools.test kernel layouts ; -IN: temporary +IN: growable.tests ! erg found this one [ fixnum ] [ diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 31486372f2..a62b306378 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: hashtables.tests USING: kernel math namespaces tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations ; diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 8c935db859..359bedd041 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -16,7 +16,6 @@ IN: hashtables 2 fixnum+fast over wrap ; inline : (key@) ( key keys i -- array n ? ) - #! cond form expanded by hand for better interpreter speed 3dup swap array-nth dup ((tombstone)) eq? [ 2drop probe (key@) ] [ @@ -40,7 +39,6 @@ IN: hashtables swap over set-hash-array init-hash ; : (new-key@) ( key keys i -- keys n empty? ) - #! cond form expanded by hand for better interpreter speed 3dup swap array-nth dup ((empty)) eq? [ 2drop rot drop t ] [ diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor old mode 100644 new mode 100755 index 3605ec519a..1c641662a9 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -11,69 +11,72 @@ $nl { $subsection min-heap? } { $subsection } "Max-heaps sort their elements so that the maximum element is first:" -{ $subsection min-heap } -{ $subsection min-heap? } -{ $subsection } +{ $subsection max-heap } +{ $subsection max-heap? } +{ $subsection } "Both obey a protocol." $nl "Queries:" { $subsection heap-empty? } -{ $subsection heap-length } +{ $subsection heap-size } { $subsection heap-peek } "Insertion:" { $subsection heap-push } +{ $subsection heap-push* } { $subsection heap-push-all } "Removal:" { $subsection heap-pop* } -{ $subsection heap-pop } ; +{ $subsection heap-pop } +{ $subsection heap-delete } ; ABOUT: "heaps" HELP: { $values { "min-heap" min-heap } } -{ $description "Create a new " { $link min-heap } "." } -{ $see-also } ; +{ $description "Create a new " { $link min-heap } "." } ; HELP: { $values { "max-heap" max-heap } } -{ $description "Create a new " { $link max-heap } "." } -{ $see-also } ; +{ $description "Create a new " { $link max-heap } "." } ; HELP: heap-push -{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } } -{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } -{ $side-effects "heap" } -{ $see-also heap-push-all heap-pop } ; +{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } } +{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } +{ $side-effects "heap" } ; + +HELP: heap-push* +{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } } +{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." } +{ $side-effects "heap" } ; HELP: heap-push-all -{ $values { "assoc" assoc } { "heap" heap } } +{ $values { "assoc" assoc } { "heap" "a heap" } } { $description "Push every key/value pair of an assoc onto a heap." } -{ $side-effects "heap" } -{ $see-also heap-push heap-pop } ; +{ $side-effects "heap" } ; HELP: heap-peek -{ $values { "heap" heap } { "key" object } { "value" object } } -{ $description "Outputs the first element in the heap, leaving it in the heap." } -{ $see-also heap-pop heap-pop* } ; +{ $values { "heap" "a heap" } { "key" object } { "value" object } } +{ $description "Output the first element in the heap, leaving it in the heap." } ; HELP: heap-pop* -{ $values { "heap" heap } } -{ $description "Removes the first element from the heap." } -{ $side-effects "heap" } -{ $see-also heap-pop heap-push heap-peek } ; +{ $values { "heap" "a heap" } } +{ $description "Remove the first element from the heap." } +{ $side-effects "heap" } ; HELP: heap-pop -{ $values { "heap" heap } { "key" object } { "value" object } } -{ $description "Outputs the first element in the heap and removes it from the heap." } -{ $side-effects "heap" } -{ $see-also heap-pop* heap-push heap-peek } ; +{ $values { "heap" "a heap" } { "key" object } { "value" object } } +{ $description "Output and remove the first element in the heap." } +{ $side-effects "heap" } ; HELP: heap-empty? -{ $values { "heap" heap } { "?" "a boolean" } } -{ $description "Tests if a " { $link heap } " has no nodes." } -{ $see-also heap-length heap-peek } ; +{ $values { "heap" "a heap" } { "?" "a boolean" } } +{ $description "Tests if a heap has no nodes." } ; -HELP: heap-length -{ $values { "heap" heap } { "n" integer } } -{ $description "Returns the number of key/value pairs in the heap." } -{ $see-also heap-empty? } ; +HELP: heap-size +{ $values { "heap" "a heap" } { "n" integer } } +{ $description "Returns the number of key/value pairs in the heap." } ; + +HELP: heap-delete +{ $values { "heap" "a heap" } { "key" object } { "value" object } } +{ $description "Output and remove the first element in the heap." } +{ $side-effects "heap" } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor old mode 100644 new mode 100755 index 92b06b866c..61e09d894e --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -1,9 +1,9 @@ -! Copyright 2007 Ryan Murphy +! Copyright 2007, 2008 Ryan Murphy, Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces tools.test -heaps heaps.private ; -IN: temporary +heaps heaps.private math.parser random assocs sequences sorting ; +IN: heaps.tests [ heap-pop ] must-fail [ heap-pop ] must-fail @@ -15,16 +15,8 @@ IN: temporary ! Binary Min Heap { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test -{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test -{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test - -[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ] -[ { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test - -[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [ - { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all - 3 [ dup heap-pop* ] times -] unit-test +{ t } [ t 5 f t 3 f T{ min-heap } heap-compare ] unit-test +{ f } [ t 5 f t 3 f T{ max-heap } heap-compare ] unit-test [ t 2 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test @@ -32,18 +24,51 @@ IN: temporary [ t 400 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test -[ 0 ] [ heap-length ] unit-test -[ 1 ] [ t 1 pick heap-push heap-length ] unit-test +[ 0 ] [ heap-size ] unit-test +[ 1 ] [ t 1 pick heap-push heap-size ] unit-test -[ { { 1 2 } { 3 4 } { 5 6 } } ] [ - T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } - [ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make -] unit-test -[ { { 1 2 } } ] [ - T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } - [ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make -] unit-test -[ { } ] [ - T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } - [ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make -] unit-test +: heap-sort ( alist -- keys ) + [ heap-push-all ] keep heap-pop-all ; + +: random-alist ( n -- alist ) + [ + [ + (random) dup number>string swap set + ] times + ] H{ } make-assoc ; + +: test-heap-sort ( n -- ? ) + random-alist dup >alist sort-keys swap heap-sort = ; + +14 [ + [ t ] swap [ 2^ test-heap-sort ] curry unit-test +] each + +: test-entry-indices ( n -- ? ) + random-alist + [ heap-push-all ] keep + heap-data dup length swap [ entry-index ] map sequence= ; + +14 [ + [ t ] swap [ 2^ test-entry-indices ] curry unit-test +] each + +: delete-random ( seq -- elt ) + dup length random dup pick nth >r swap delete-nth r> ; + +: sort-entries ( entries -- entries' ) + [ [ entry-key ] compare ] sort ; + +: delete-test ( n -- ? ) + [ + random-alist + [ heap-push-all ] keep + dup heap-data clone swap + ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times + heap-data + [ [ entry-key ] map ] 2apply + [ natural-sort ] 2apply ; + +11 [ + [ t ] swap [ 2^ delete-test sequence= ] curry unit-test +] each diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor old mode 100644 new mode 100755 index cd00dc0db3..caab0d8f8e --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -1,26 +1,31 @@ -! Copyright (C) 2007 Ryan Murphy, Doug Coleman. +! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman, +! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences arrays assocs ; +USING: kernel math sequences arrays assocs sequences.private +growable ; IN: heaps MIXIN: priority-queue -GENERIC: heap-push ( value key heap -- ) +GENERIC: heap-push* ( value key heap -- entry ) GENERIC: heap-peek ( heap -- value key ) GENERIC: heap-pop* ( heap -- ) GENERIC: heap-pop ( heap -- value key ) -GENERIC: heap-delete ( key heap -- ) -GENERIC: heap-delete* ( key heap -- old ? ) +GENERIC: heap-delete ( entry heap -- ) GENERIC: heap-empty? ( heap -- ? ) -GENERIC: heap-length ( heap -- n ) -GENERIC# heap-pop-while 2 ( heap pred quot -- ) +GENERIC: heap-size ( heap -- n ) ( class -- heap ) - >r V{ } clone heap construct-boa r> - construct-delegate ; inline + >r V{ } clone r> construct-delegate ; inline + +TUPLE: entry value key heap index ; + +: ( value key heap -- entry ) f entry construct-boa ; + PRIVATE> TUPLE: min-heap ; @@ -34,23 +39,67 @@ TUPLE: max-heap ; INSTANCE: min-heap priority-queue INSTANCE: max-heap priority-queue +M: priority-queue heap-empty? ( heap -- ? ) + heap-data empty? ; + +M: priority-queue heap-size ( heap -- n ) + heap-data length ; + r left r> nth ; inline -: right-value ( n heap -- obj ) >r right r> nth ; inline -: up-value ( n vec -- obj ) >r up r> nth ; inline -: swap-up ( n vec -- ) >r dup up r> exchange ; inline -: last-index ( vec -- n ) length 1- ; inline + +: left ( n -- m ) 1 shift 1 + ; inline + +: right ( n -- m ) 1 shift 2 + ; inline + +: up ( n -- m ) 1- 2/ ; inline + +: data-nth ( n heap -- entry ) + heap-data nth-unsafe ; inline + +: up-value ( n heap -- entry ) + >r up r> data-nth ; inline + +: left-value ( n heap -- entry ) + >r left r> data-nth ; inline + +: right-value ( n heap -- entry ) + >r right r> data-nth ; inline + +: data-set-nth ( entry n heap -- ) + >r [ swap set-entry-index ] 2keep r> + heap-data set-nth-unsafe ; + +: data-push ( entry heap -- n ) + dup heap-size [ + swap 2dup heap-data ensure 2drop data-set-nth + ] keep ; inline + +: data-pop ( heap -- entry ) + heap-data pop ; inline + +: data-pop* ( heap -- ) + heap-data pop* ; inline + +: data-peek ( heap -- entry ) + heap-data peek ; inline + +: data-first ( heap -- entry ) + heap-data first ; inline + +: data-exchange ( m n heap -- ) + [ tuck data-nth >r data-nth r> ] 3keep + tuck >r >r data-set-nth r> r> data-set-nth ; inline GENERIC: heap-compare ( pair1 pair2 heap -- ? ) -: (heap-compare) drop [ first ] compare 0 ; inline + +: (heap-compare) drop [ entry-key ] compare 0 ; inline + M: min-heap heap-compare (heap-compare) > ; + M: max-heap heap-compare (heap-compare) < ; : heap-bounds-check? ( m heap -- ? ) - heap-data length >= ; inline + heap-size >= ; inline : left-bounds-check? ( m heap -- ? ) >r left r> heap-bounds-check? ; inline @@ -58,41 +107,44 @@ M: max-heap heap-compare (heap-compare) < ; : right-bounds-check? ( m heap -- ? ) >r right r> heap-bounds-check? ; inline -: up-heap-continue? ( vec heap -- ? ) - >r [ last-index ] keep [ up-value ] keep peek r> +: continue? ( m up[m] heap -- ? ) + [ data-nth swap ] keep [ data-nth ] keep heap-compare ; inline -: up-heap ( vec heap -- ) - 2dup up-heap-continue? [ - >r dup last-index [ over swap-up ] keep - up 1+ head-slice r> up-heap +DEFER: up-heap + +: (up-heap) ( n heap -- ) + >r dup up r> + 3dup continue? [ + [ data-exchange ] 2keep up-heap ] [ - 2drop + 3drop ] if ; +: up-heap ( n heap -- ) + over 0 > [ (up-heap) ] [ 2drop ] if ; + : (child) ( m heap -- n ) - dupd - [ heap-data left-value ] 2keep - [ heap-data right-value ] keep heap-compare + 2dup right-value + >r 2dup left-value r> + rot heap-compare [ right ] [ left ] if ; : child ( m heap -- n ) - 2dup right-bounds-check? [ drop left ] [ (child) ] if ; + 2dup right-bounds-check? + [ drop left ] [ (child) ] if ; : swap-down ( m heap -- ) - [ child ] 2keep heap-data exchange ; + [ child ] 2keep data-exchange ; DEFER: down-heap -: down-heap-continue? ( heap m heap -- m heap ? ) - [ heap-data nth ] 2keep child pick - dupd [ heap-data nth swapd ] keep heap-compare ; - : (down-heap) ( m heap -- ) - 2dup down-heap-continue? [ - -rot [ swap-down ] keep down-heap - ] [ + [ child ] 2keep swapd + 3dup continue? [ 3drop + ] [ + [ data-exchange ] 2keep down-heap ] if ; : down-heap ( m heap -- ) @@ -100,40 +152,43 @@ DEFER: down-heap PRIVATE> -M: priority-queue heap-push ( value key heap -- ) - >r swap 2array r> - [ heap-data push ] keep - [ heap-data ] keep - up-heap ; +M: priority-queue heap-push* ( value key heap -- entry ) + [ dup ] keep [ data-push ] keep up-heap ; + +: heap-push ( value key heap -- ) heap-push* drop ; : heap-push-all ( assoc heap -- ) [ swapd heap-push ] curry assoc-each ; +: >entry< ( entry -- key value ) + { entry-value entry-key } get-slots ; + M: priority-queue heap-peek ( heap -- value key ) - heap-data first first2 swap ; + data-first >entry< ; + +: entry>index ( entry heap -- n ) + over entry-heap eq? [ + "Invalid entry passed to heap-delete" throw + ] unless + entry-index ; + +M: priority-queue heap-delete ( entry heap -- ) + [ entry>index ] keep + 2dup heap-size 1- = [ + nip data-pop* + ] [ + [ nip data-pop ] 2keep + [ data-set-nth ] 2keep + down-heap + ] if ; M: priority-queue heap-pop* ( heap -- ) - dup heap-data length 1 > [ - [ heap-data pop ] keep - [ heap-data set-first ] keep - 0 swap down-heap - ] [ - heap-data pop* - ] if ; + dup data-first swap heap-delete ; -M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ; +M: priority-queue heap-pop ( heap -- value key ) + dup data-first [ swap heap-delete ] keep >entry< ; -M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ; - -M: priority-queue heap-length ( heap -- n ) heap-data length ; - -: (heap-pop-while) ( heap pred quot -- ) - pick heap-empty? [ - 3drop - ] [ - [ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep - roll [ (heap-pop-while) ] [ 3drop ] if - ] if ; - -M: priority-queue heap-pop-while ( heap pred quot -- ) - [ heap-pop ] swap [ t ] 3compose (heap-pop-while) ; +: heap-pop-all ( heap -- alist ) + [ dup heap-empty? not ] + [ dup heap-pop swap 2array ] + [ ] unfold nip ; diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 691010e9ca..df90ac2291 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: inference.class.tests USING: arrays math.private kernel math compiler inference inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien @@ -288,3 +288,10 @@ cell-bits 32 = [ [ HEX: ff bitand 0 HEX: ff between? ] \ >= inlined? ] unit-test + +[ t ] [ + [ HEX: ff swap HEX: ff bitand >= ] + \ >= inlined? +] unit-test + + diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index b841080c94..3c12e388c4 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -5,8 +5,8 @@ sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector tuples classes.union classes.predicate debugger threads.private io.streams.string io.timeouts -sequences.private ; -IN: temporary +io.thread sequences.private ; +IN: inference.tests { 0 2 } [ 2 "Hello" ] must-infer-as { 1 2 } [ dup ] must-infer-as @@ -440,7 +440,7 @@ DEFER: bar \ error. must-infer ! Test odds and ends -\ idle-thread must-infer +\ io-thread must-infer ! Incorrect stack declarations on inline recursive words should ! be caught diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor index e9c31171ed..84d72bdd9b 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 ; +IN: inference.state.tests +USING: tools.test inference.state words ; SYMBOL: a SYMBOL: b diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor index cf11ffc88a..a426f410e2 100755 --- a/core/inference/state/state.factor +++ b/core/inference/state/state.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs namespaces sequences kernel ; +USING: assocs namespaces sequences kernel words ; IN: inference.state ! Nesting state to solve recursion @@ -31,9 +31,6 @@ SYMBOL: current-node ! Words that the current dataflow IR depends on SYMBOL: dependencies -SYMBOL: +inlined+ -SYMBOL: +called+ - : depends-on ( word how -- ) swap dependencies get dup [ 2dup at +inlined+ eq? [ 3drop ] [ set-at ] if diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 0e5c3e231e..88aac780c1 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: inference.transforms.tests USING: sequences inference.transforms tools.test math kernel quotations inference ; diff --git a/core/init/init-tests.factor b/core/init/init-tests.factor new file mode 100644 index 0000000000..ce68a1d7ab --- /dev/null +++ b/core/init/init-tests.factor @@ -0,0 +1,7 @@ +IN: init.tests +USING: init namespaces sequences math tools.test kernel ; + +[ t ] [ + init-hooks get [ first "libc" = ] find drop + init-hooks get [ first "io.backend" = ] find drop < +] unit-test diff --git a/core/init/init.factor b/core/init/init.factor old mode 100644 new mode 100755 index 770655d990..6ee11c76fc --- a/core/init/init.factor +++ b/core/init/init.factor @@ -15,7 +15,7 @@ init-hooks global [ drop V{ } clone ] cache drop dup init-hooks get at [ over call ] unless init-hooks get set-at ; -: boot ( -- ) init-namespaces init-error-handler ; +: boot ( -- ) init-namespaces init-catchstack ; : boot-quot ( -- quot ) 20 getenv ; diff --git a/core/inspector/inspector-tests.factor b/core/inspector/inspector-tests.factor index fce0cc0c86..72c1a9a6bf 100644 --- a/core/inspector/inspector-tests.factor +++ b/core/inspector/inspector-tests.factor @@ -1,6 +1,6 @@ USING: kernel tools.test math namespaces prettyprint sequences inspector io.streams.string ; -IN: temporary +IN: inspector.tests [ 1 2 3 ] describe f describe diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor old mode 100644 new mode 100755 index 868cffb81c..449d34f05b --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables io kernel assocs math namespaces prettyprint sequences strings io.styles vectors words @@ -93,6 +93,15 @@ SYMBOL: +editable+ : describe ( obj -- ) H{ } describe* ; +: namestack. ( seq -- ) + [ + [ global eq? not ] subset + [ keys ] map concat prune + ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ; + +: .vars ( -- ) + namestack namestack. ; + SYMBOL: inspector-hook [ H{ { +number-rows+ t } } describe* ] inspector-hook set-global diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor index e295cc34dc..04f34068eb 100644 --- a/core/io/backend/backend-tests.factor +++ b/core/io/backend/backend-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.backend.tests USING: tools.test io.backend kernel ; [ ] [ "a" normalize-pathname drop ] unit-test diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 9aa1299871..c38b7355b1 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -19,8 +19,8 @@ HOOK: normalize-pathname io-backend ( str -- newstr ) M: object normalize-pathname ; -[ init-io embedded? [ init-stdio ] unless ] -"io.backend" add-init-hook - : set-io-backend ( backend -- ) io-backend set-global init-io init-stdio ; + +[ init-io embedded? [ init-stdio ] unless ] +"io.backend" add-init-hook diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor index 69e733b55a..f6d103b0d1 100755 --- a/core/io/binary/binary-tests.factor +++ b/core/io/binary/binary-tests.factor @@ -1,5 +1,5 @@ USING: io.binary tools.test ; -IN: temporary +IN: io.binary.tests [ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test [ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test diff --git a/core/io/encodings/authors.txt b/core/io/encodings/authors.txt index 1901f27a24..33616a2d6a 100755 --- a/core/io/encodings/authors.txt +++ b/core/io/encodings/authors.txt @@ -1 +1,2 @@ +Daniel Ehrenberg Slava Pestov diff --git a/core/io/encodings/tags.txt b/core/io/encodings/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/core/io/encodings/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 185fa1436b..9dc178ee57 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -1,41 +1,117 @@ USING: help.markup help.syntax io io.styles strings -io.backend io.files.private ; +io.backend io.files.private quotations ; IN: io.files ARTICLE: "file-streams" "Reading and writing files" +"File streams:" { $subsection } { $subsection } { $subsection } +"Utility combinators:" +{ $subsection with-file-reader } +{ $subsection with-file-writer } +{ $subsection with-file-appender } ; + +ARTICLE: "pathnames" "Pathname manipulation" "Pathname manipulation:" { $subsection parent-directory } { $subsection file-name } { $subsection last-path-separator } { $subsection path+ } -"File system meta-data:" +"Pathnames relative to Factor's install directory:" +{ $subsection resource-path } +{ $subsection ?resource-path } +"Pathnames relative to Factor's temporary files directory:" +{ $subsection temp-directory } +{ $subsection temp-file } +"Pathname presentations:" +{ $subsection pathname } +{ $subsection } ; + +ARTICLE: "directories" "Directories" +"Current and home directories:" +{ $subsection cwd } +{ $subsection cd } +{ $subsection with-directory } +{ $subsection home } +"Directory listing:" +{ $subsection directory } +{ $subsection directory* } +"Creating directories:" +{ $subsection make-directory } +{ $subsection make-directories } ; + +ARTICLE: "fs-meta" "File meta-data" { $subsection exists? } { $subsection directory? } { $subsection file-length } { $subsection file-modified } -{ $subsection stat } -"Directory listing:" -{ $subsection directory } -"File management:" +{ $subsection stat } ; + +ARTICLE: "delete-move-copy" "Deleting, moving, copying files" +"Operations for deleting and copying files come in two forms:" +{ $list + { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." } + { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." } +} +"The operations for moving and copying files come in three flavors:" +{ $list + { "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." } + { "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." } + { "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." } +} +"Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file." +$nl +"Deleting files:" { $subsection delete-file } -{ $subsection make-directory } { $subsection delete-directory } -"Current and home directories:" -{ $subsection home } -{ $subsection cwd } -{ $subsection cd } -"Pathnames relative to the Factor install directory:" -{ $subsection resource-path } -{ $subsection ?resource-path } -"Pathname presentations:" -{ $subsection pathname } -{ $subsection } +{ $subsection delete-tree } +"Moving files:" +{ $subsection move-file } +{ $subsection move-file-into } +{ $subsection move-files-into } +"Copying files:" +{ $subsection copy-file } +{ $subsection copy-file-into } +{ $subsection copy-files-into } +"Copying directory trees recursively:" +{ $subsection copy-tree } +{ $subsection copy-tree-into } +{ $subsection copy-trees-into } +"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ; + +ARTICLE: "io.files" "Basic file operations" +"The " { $vocab-link "io.files" } " vocabulary provides basic support for working with files." +{ $subsection "pathnames" } +{ $subsection "file-streams" } +{ $subsection "fs-meta" } +{ $subsection "directories" } +{ $subsection "delete-move-copy" } +{ $subsection "unique" } { $see-also "os" } ; -ABOUT: "file-streams" +ABOUT: "io.files" + +HELP: path-separator? +{ $values { "ch" "a code point" } { "?" "a boolean" } } +{ $description "Tests if the code point is a platform-specific path separator." } +{ $examples + "On Unix:" + { $example "USING: io.files prettyprint ;" "CHAR: / path-separator? ." "t" } +} ; + +HELP: parent-directory +{ $values { "path" "a pathname string" } { "parent" "a pathname string" } } +{ $description "Strips the last component off a pathname." } +{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ; + +HELP: file-name +{ $values { "path" "a pathname string" } { "string" string } } +{ $description "Outputs the last component of a pathname string." } +{ $examples + { "\"/usr/bin/gcc\" file-name ." "\"gcc\"" } + { "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } +} ; HELP: { $values { "path" "a pathname string" } { "stream" "an input stream" } } @@ -77,7 +153,12 @@ HELP: cd { $description "Changes the current working directory of the Factor process." } { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; -{ cd cwd } related-words +{ cd cwd with-directory } related-words + +HELP: with-directory +{ $values { "path" "a pathname string" } { "quot" quotation } } +{ $description "Changes the current working directory for the duration of a quotation's execution." } +{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; HELP: stat ( path -- directory? permissions length modified ) { $values { "path" "a pathname string" } { "directory?" "boolean indicating if the file is a directory" } { "permissions" "a Unix permission bitmap (0 on Windows)" } { "length" "the length in bytes as an integer" } { "modified" "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" } } @@ -108,6 +189,11 @@ HELP: directory { $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } } { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ; +HELP: directory* +{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ path dir? }" } " pairs" } } +{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } +{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ; + HELP: file-length { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } { $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ; @@ -116,19 +202,6 @@ HELP: file-modified { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ; -HELP: parent-directory -{ $values { "path" "a pathname string" } { "parent" "a pathname string" } } -{ $description "Strips the last component off a pathname." } -{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ; - -HELP: file-name -{ $values { "path" "a pathname string" } { "string" string } } -{ $description "Outputs the last component of a pathname string." } -{ $examples - { "\"/usr/bin/gcc\" file-name ." "\"gcc\"" } - { "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } -} ; - HELP: resource-path { $values { "path" "a pathname string" } { "newpath" "a pathname string" } } { $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ; @@ -168,7 +241,72 @@ HELP: make-directory { $description "Creates a directory." } { $errors "Throws an error if the directory could not be created." } ; +HELP: make-directories +{ $values { "path" "a pathname string" } } +{ $description "Creates a directory and any parent directories which do not yet exist." } +{ $errors "Throws an error if the directories could not be created." } ; + HELP: delete-directory { $values { "path" "a pathname string" } } { $description "Deletes a directory. The directory must be empty." } { $errors "Throws an error if the directory could not be deleted." } ; + +HELP: touch-file +{ $values { "path" "a pathname string" } } +{ $description "Updates the modification time of a file or directory. If the file does not exist, creates a new, empty file." } +{ $errors "Throws an error if the file could not be touched." } ; + +HELP: delete-tree +{ $values { "path" "a pathname string" } } +{ $description "Deletes a file or directory, recursing into subdirectories." } +{ $errors "Throws an error if the deletion fails." } +{ $warning "Misuse of this word can lead to catastrophic data loss." } ; + +HELP: move-file +{ $values { "from" "a pathname string" } { "to" "a pathname string" } } +{ $description "Moves or renames a file." } +{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; + +HELP: move-file-into +{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } +{ $description "Moves a file to another directory without renaming it." } +{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; + +HELP: move-files-into +{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } +{ $description "Moves a set of files to another directory." } +{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; + +HELP: copy-file +{ $values { "from" "a pathname string" } { "to" "a pathname string" } } +{ $description "Copies a file." } +{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." } +{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; + +HELP: copy-file-into +{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } +{ $description "Copies a file to another directory." } +{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; + +HELP: copy-files-into +{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } +{ $description "Copies a set of files to another directory." } +{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; + +HELP: copy-tree +{ $values { "from" "a pathname string" } { "to" "a pathname string" } } +{ $description "Copies a directory tree recursively." } +{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." } +{ $errors "Throws an error if the copy operation fails." } ; + +HELP: copy-tree-into +{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } +{ $description "Copies a directory tree to another directory, recursively." } +{ $errors "Throws an error if the copy operation fails." } ; + +HELP: copy-trees-into +{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } +{ $description "Copies a set of directory trees to another directory, recursively." } +{ $errors "Throws an error if the copy operation fails." } ; + + diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index d0f9737f19..6943163c5d 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.files.tests USING: tools.test io.files io threads kernel continuations ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test @@ -6,63 +6,120 @@ USING: tools.test io.files io threads kernel continuations ; [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ ] [ - "test-foo.txt" resource-path [ + "test-foo.txt" temp-file [ "Hello world." print ] with-file-writer ] unit-test [ ] [ - "test-foo.txt" resource-path [ + "test-foo.txt" temp-file [ "Hello appender." print ] with-stream ] unit-test [ ] [ - "test-bar.txt" resource-path [ + "test-bar.txt" temp-file [ "Hello appender." print ] with-stream ] unit-test [ "Hello world.\nHello appender.\n" ] [ - "test-foo.txt" resource-path file-contents + "test-foo.txt" temp-file file-contents ] unit-test [ "Hello appender.\n" ] [ - "test-bar.txt" resource-path file-contents + "test-bar.txt" temp-file file-contents ] unit-test -[ ] [ "test-foo.txt" resource-path delete-file ] unit-test +[ ] [ "test-foo.txt" temp-file delete-file ] unit-test -[ ] [ "test-bar.txt" resource-path delete-file ] unit-test +[ ] [ "test-bar.txt" temp-file delete-file ] unit-test -[ f ] [ "test-foo.txt" resource-path exists? ] unit-test +[ f ] [ "test-foo.txt" temp-file exists? ] unit-test -[ f ] [ "test-bar.txt" resource-path exists? ] unit-test +[ f ] [ "test-bar.txt" temp-file exists? ] unit-test -[ ] [ "test-blah" resource-path make-directory ] unit-test +[ ] [ "test-blah" temp-file make-directory ] unit-test [ ] [ - "test-blah/fooz" resource-path dispose + "test-blah/fooz" temp-file dispose ] unit-test [ t ] [ - "test-blah/fooz" resource-path exists? + "test-blah/fooz" temp-file exists? ] unit-test -[ ] [ "test-blah/fooz" resource-path delete-file ] unit-test +[ ] [ "test-blah/fooz" temp-file delete-file ] unit-test -[ ] [ "test-blah" resource-path delete-directory ] unit-test +[ ] [ "test-blah" temp-file delete-directory ] unit-test -[ f ] [ "test-blah" resource-path exists? ] unit-test +[ f ] [ "test-blah" temp-file exists? ] unit-test -[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test +[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test -[ ] [ "test-quux.txt" resource-path delete-file ] unit-test +[ ] [ "test-quux.txt" temp-file delete-file ] unit-test -[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test +[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test -[ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test -[ t ] [ "quux-test.txt" resource-path exists? ] unit-test +[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test +[ t ] [ "quux-test.txt" temp-file exists? ] unit-test -[ ] [ "quux-test.txt" resource-path delete-file ] unit-test +[ ] [ "quux-test.txt" temp-file delete-file ] unit-test +[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test + +[ ] [ + "delete-tree-test/a/b/c/d" temp-file + [ "Hi" print ] with-file-writer +] unit-test + +[ ] [ + "delete-tree-test" temp-file delete-tree +] unit-test + +[ ] [ + "copy-tree-test/a/b/c" temp-file make-directories +] unit-test + +[ ] [ + "copy-tree-test/a/b/c/d" temp-file + [ "Foobar" write ] with-file-writer +] unit-test + +[ ] [ + "copy-tree-test" temp-file + "copy-destination" temp-file copy-tree +] unit-test + +[ "Foobar" ] [ + "copy-destination/a/b/c/d" temp-file file-contents +] unit-test + +[ ] [ + "copy-destination" temp-file delete-tree +] unit-test + +[ ] [ + "copy-tree-test" temp-file + "copy-destination" temp-file copy-tree-into +] unit-test + +[ "Foobar" ] [ + "copy-destination/copy-tree-test/a/b/c/d" temp-file file-contents +] unit-test + +[ ] [ + "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into +] unit-test + +[ "Foobar" ] [ + "d" temp-file file-contents +] unit-test + +[ ] [ "d" temp-file delete-file ] unit-test + +[ ] [ "copy-destination" temp-file delete-tree ] unit-test + +[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test + +[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1824a47867..b51d767069 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,34 +1,14 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: io.files USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs continuations ; -HOOK: cd io-backend ( path -- ) - -HOOK: cwd io-backend ( -- path ) - -HOOK: io-backend ( path -- stream ) - -HOOK: io-backend ( path -- stream ) - -HOOK: io-backend ( path -- stream ) - -HOOK: delete-file io-backend ( path -- ) - -HOOK: rename-file io-backend ( from to -- ) - -HOOK: make-directory io-backend ( path -- ) - -HOOK: delete-directory io-backend ( path -- ) +IN: io.files +! Pathnames : path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; -HOOK: root-directory? io-backend ( path -- ? ) - -M: object root-directory? ( path -- ? ) path-separator? ; - : right-trim-separators ( str -- newstr ) [ path-separator? ] right-trim ; @@ -39,33 +19,15 @@ M: object root-directory? ( path -- ? ) path-separator? ; >r right-trim-separators "/" r> left-trim-separators 3append ; -: stat ( path -- directory? permissions length modified ) - normalize-pathname (stat) ; - -: file-length ( path -- n ) stat 4array third ; - -: file-modified ( path -- n ) stat >r 3drop r> ; inline - -: exists? ( path -- ? ) file-modified >boolean ; - -: directory? ( path -- ? ) stat 3drop ; - -: special-directory? ( name -- ? ) - { "." ".." } member? ; - -: fixup-directory ( path seq -- newseq ) - [ - dup string? - [ tuck path+ directory? 2array ] [ nip ] if - ] with map - [ first special-directory? not ] subset ; - -: directory ( path -- seq ) - normalize-directory dup (directory) fixup-directory ; - : last-path-separator ( path -- n ? ) [ length 1- ] keep [ path-separator? ] find-last* ; +HOOK: root-directory? io-backend ( path -- ? ) + +M: object root-directory? ( path -- ? ) path-separator? ; + +: special-directory? ( name -- ? ) { "." ".." } member? ; + TUPLE: no-parent-directory path ; : no-parent-directory ( path -- * ) @@ -89,15 +51,43 @@ TUPLE: no-parent-directory path ; { [ t ] [ drop ] } } cond ; -: resource-path ( path -- newpath ) - \ resource-path get [ image parent-directory ] unless* - swap path+ ; +TUPLE: file-info type size permissions modified ; -: ?resource-path ( path -- newpath ) - "resource:" ?head [ resource-path ] when ; +HOOK: file-info io-backend ( path -- info ) -: resource-exists? ( path -- ? ) - ?resource-path exists? ; +SYMBOL: +regular-file+ +SYMBOL: +directory+ +SYMBOL: +character-device+ +SYMBOL: +block-device+ +SYMBOL: +fifo+ +SYMBOL: +symbolic-link+ +SYMBOL: +socket+ +SYMBOL: +unknown+ + +! File metadata +: stat ( path -- directory? permissions length modified ) + normalize-pathname (stat) ; + +: file-length ( path -- n ) stat drop 2nip ; + +: file-modified ( path -- n ) stat >r 3drop r> ; + +: file-permissions ( path -- perm ) stat 2drop nip ; + +: exists? ( path -- ? ) file-modified >boolean ; + +: directory? ( path -- ? ) stat 3drop ; + +! Current working directory +HOOK: cd io-backend ( path -- ) + +HOOK: cwd io-backend ( -- path ) + +: with-directory ( path quot -- ) + cwd [ cd ] curry rot cd [ ] cleanup ; inline + +! Creating directories +HOOK: make-directory io-backend ( path -- ) : make-directories ( path -- ) normalize-pathname right-trim-separators { @@ -111,35 +101,107 @@ TUPLE: no-parent-directory path ; ] } } cond drop ; +! Directory listings +: fixup-directory ( path seq -- newseq ) + [ + dup string? + [ tuck path+ directory? 2array ] [ nip ] if + ] with map + [ first special-directory? not ] subset ; + +: directory ( path -- seq ) + normalize-directory dup (directory) fixup-directory ; + +: directory* ( path -- seq ) + dup directory [ first2 >r path+ r> 2array ] with map ; + +! Touching files +HOOK: touch-file io-backend ( path -- ) + +! Deleting files +HOOK: delete-file io-backend ( path -- ) + +HOOK: delete-directory io-backend ( path -- ) + +: (delete-tree) ( path dir? -- ) + [ + dup directory* [ (delete-tree) ] assoc-each + delete-directory + ] [ delete-file ] if ; + +: delete-tree ( path -- ) + dup directory? (delete-tree) ; + +: to-directory over file-name path+ ; + +! Moving and renaming files +HOOK: move-file io-backend ( from to -- ) + +: move-file-into ( from to -- ) + to-directory move-file ; + +: move-files-into ( files to -- ) + [ move-file-into ] curry each ; + +! Copying files HOOK: copy-file io-backend ( from to -- ) -M: object copy-file - dup parent-directory make-directories - [ - swap [ - swap stream-copy - ] with-disposal - ] with-disposal ; +: copy-file-into ( from to -- ) + to-directory copy-file ; -: copy-directory ( from to -- ) - dup make-directories - >r dup directory swap r> [ - >r >r first r> over path+ r> rot path+ copy-file - ] 2curry each ; +: copy-files-into ( files to -- ) + [ copy-file-into ] curry each ; -: home ( -- dir ) - { - { [ winnt? ] [ "USERPROFILE" os-env ] } - { [ wince? ] [ "" resource-path ] } - { [ unix? ] [ "HOME" os-env ] } - } cond ; +DEFER: copy-tree-into +: copy-tree ( from to -- ) + over directory? [ + >r dup directory swap r> [ + >r swap first path+ r> copy-tree-into + ] 2curry each + ] [ + copy-file + ] if ; + +: copy-tree-into ( from to -- ) + to-directory copy-tree ; + +: copy-trees-into ( files to -- ) + [ copy-tree-into ] curry each ; + +! Special paths +: resource-path ( path -- newpath ) + \ resource-path get [ image parent-directory ] unless* + swap path+ ; + +: ?resource-path ( path -- newpath ) + "resource:" ?head [ resource-path ] when ; + +: resource-exists? ( path -- ? ) + ?resource-path exists? ; + +: temp-directory ( -- path ) + "temp" resource-path + dup exists? not + [ dup make-directory ] + when ; + +: temp-file ( name -- path ) temp-directory swap path+ ; + +! Pathname presentations TUPLE: pathname string ; C: pathname M: pathname <=> [ pathname-string ] compare ; +! Streams +HOOK: io-backend ( path -- stream ) + +HOOK: io-backend ( path -- stream ) + +HOOK: io-backend ( path -- stream ) + : file-lines ( path -- seq ) lines ; : file-contents ( path -- str ) @@ -154,3 +216,11 @@ M: pathname <=> [ pathname-string ] compare ; : with-file-appender ( path quot -- ) >r r> with-stream ; inline + +! Home directory +: home ( -- dir ) + { + { [ winnt? ] [ "USERPROFILE" os-env ] } + { [ wince? ] [ "" resource-path ] } + { [ unix? ] [ "HOME" os-env ] } + } cond ; diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 9c73a3b2b1..0986196e8d 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -5,6 +5,8 @@ IN: io ARTICLE: "stream-protocol" "Stream protocol" "The stream protocol consists of a large number of generic words, many of which are optional." $nl +"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in a " { $link with-stream } ". This leads more simpler, more reusable and more robust code." +$nl "All streams must implement the " { $link dispose } " word in addition to the stream protocol." $nl "Three words are required for input streams:" @@ -25,7 +27,35 @@ $nl { $see-also "io.timeouts" } ; ARTICLE: "stdio" "The default stream" -"Various words take an implicit stream parameter from a variable to reduce stack shuffling." +"Most I/O code only operates on one stream at a time. The " { $emphasis "default stream" } " is an implicit parameter used by many I/O words designed for this particular use-case. Using this idiom improves code in three ways:" +{ $list + { "Code becomes simpler because there is no need to keep a stream around on the stack." } + { "Code becomes more robust because " { $link with-stream } " automatically closes the stream if there is an error." } + { "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-stream } " to specify the source or destination for I/O operations." } +} +"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:" +{ $code + "USING: continuations kernel io io.files math.parser splitting ;" + "\"data.txt\" " + "dup stream-readln number>string over stream-read 16 group" + "swap dispose" +} +"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:" +{ $code + "USING: continuations kernel io io.files math.parser splitting ;" + "\"data.txt\" [" + " dup stream-readln number>string over stream-read" + " 16 group" + "] with-disposal" +} +"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:" +{ $code + "USING: continuations kernel io io.files math.parser splitting ;" + "\"data.txt\" [" + " readln number>string read 16 group" + "] with-stream" +} +"The default stream is stored in a dynamically-scoped variable:" { $subsection stdio } "Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user." { $subsection read1 } @@ -65,6 +95,8 @@ $nl ARTICLE: "streams" "Streams" "Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium." +$nl +"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "." { $subsection "stream-protocol" } { $subsection "stdio" } { $subsection "stream-utils" } @@ -75,42 +107,50 @@ ABOUT: "streams" HELP: stream-readln { $values { "stream" "an input stream" } { "str" string } } { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link readln } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read1 { $values { "stream" "an input stream" } { "ch/f" "a character or " { $link f } } } { $contract "Reads a character of input from the stream. Outputs " { $link f } " on stream exhaustion." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read { $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } } { $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read-until { $values { "seps" string } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } } { $contract "Reads characters from the stream, until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link read-until } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-write1 { $values { "ch" "a character" } { "stream" "an output stream" } } { $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link write1 } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-write { $values { "str" string } { "stream" "an output stream" } } { $contract "Writes a string of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link write } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-flush { $values { "stream" "an output stream" } } { $contract "Waits for any pending output to complete." } { $notes "With many output streams, written output is buffered and not sent to the underlying resource until either the buffer is full, or this word is called." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link flush } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-nl { $values { "stream" "an output stream" } } { $contract "Writes a line terminator. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link nl } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-format @@ -118,6 +158,7 @@ HELP: stream-format { $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." $nl "The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." } $io-error ; HELP: make-block-stream @@ -127,7 +168,7 @@ $nl "Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output." $nl "The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." } -{ $notes "Instead of calling this word directly, use " { $link with-nesting } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-write-table @@ -135,13 +176,13 @@ HELP: stream-write-table { $contract "Prints a table of cells produced by " { $link with-cell } "." $nl "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } -{ $notes "Instead of calling this word directly, use " { $link tabular-output } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." } $io-error ; HELP: make-cell-stream { $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } } { $contract "Creates an output stream which writes to a table cell object." } -{ $notes "Instead of calling this word directly, use " { $link tabular-output } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." } $io-error ; HELP: make-span-stream @@ -149,12 +190,13 @@ HELP: make-span-stream { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." $nl "Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." } -{ $notes "Instead of calling this word directly, use " { $link with-style } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-print { $values { "str" string } { "stream" "an output stream" } } { $description "Writes a newline-terminated string." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link print } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-copy @@ -167,17 +209,17 @@ HELP: stdio HELP: readln { $values { "str/f" "a string or " { $link f } } } -{ $contract "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } +{ $description "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } $io-error ; HELP: read1 { $values { "ch/f" "a character or " { $link f } } } -{ $contract "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } +{ $description "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } $io-error ; HELP: read { $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } } -{ $contract "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } +{ $description "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } $io-error ; HELP: read-until @@ -192,26 +234,26 @@ $io-error ; HELP: write { $values { "str" string } } -{ $contract "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $description "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } $io-error ; HELP: flush -{ $contract "Waits for any pending output to the " { $link stdio } " stream to complete." } +{ $description "Waits for any pending output to the " { $link stdio } " stream to complete." } $io-error ; HELP: nl -{ $contract "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $description "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } $io-error ; HELP: format { $values { "str" string } { "style" "a hashtable" } } -{ $contract "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $description "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } { $notes "Details are in the documentation for " { $link stream-format } "." } $io-error ; HELP: with-nesting { $values { "style" "a hashtable" } { "quot" "a quotation" } } -{ $contract "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." } +{ $description "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." } { $notes "Details are in the documentation for " { $link make-block-stream } "." } $io-error ; diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 23686abab5..e3c249ec5d 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,10 +1,10 @@ USING: arrays io io.files kernel math parser strings system tools.test words namespaces ; -IN: temporary +IN: io.tests [ f ] [ "resource:/core/io/test/no-trailing-eol.factor" run-file - "foo" "temporary" lookup + "foo" "io.tests" lookup ] unit-test : ( resource -- stream ) diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 5ace929ceb..3da9f27646 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,10 +1,10 @@ USING: tools.test io.files io io.streams.c ; -IN: temporary +IN: io.streams.c.tests [ "hello world" ] [ - "test.txt" resource-path [ + "test.txt" temp-file [ "hello world" write ] with-file-writer - "test.txt" resource-path "rb" fopen contents + "test.txt" temp-file "rb" fopen contents ] unit-test diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 288ab212d1..48d6e6e430 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -64,7 +64,7 @@ M: object init-stdio stdin-handle stdout-handle stdio set-global stderr-handle stderr set-global ; -M: object io-multiplex (sleep) ; +M: object io-multiplex 60 60 * 1000 * or (sleep) ; M: object "rb" fopen ; diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor index 44542e05ce..65bad3de41 100755 --- a/core/io/streams/duplex/duplex-tests.factor +++ b/core/io/streams/duplex/duplex-tests.factor @@ -1,5 +1,5 @@ USING: io.streams.duplex io kernel continuations tools.test ; -IN: temporary +IN: io.streams.duplex.tests ! Test duplex stream close behavior TUPLE: closing-stream closed? ; diff --git a/core/io/streams/lines/lines-tests.factor b/core/io/streams/lines/lines-tests.factor index 64dc7bff3b..e8ecc65526 100755 --- a/core/io/streams/lines/lines-tests.factor +++ b/core/io/streams/lines/lines-tests.factor @@ -1,6 +1,6 @@ USING: io.streams.lines io.files io.streams.string io tools.test kernel ; -IN: temporary +IN: io.streams.lines.tests : ( resource -- stream ) resource-path ; diff --git a/core/io/streams/nested/nested-tests.factor b/core/io/streams/nested/nested-tests.factor index 7b26beb9c6..402cb19c3b 100644 --- a/core/io/streams/nested/nested-tests.factor +++ b/core/io/streams/nested/nested-tests.factor @@ -1,3 +1,3 @@ USING: io io.streams.string io.streams.nested kernel math namespaces io.styles tools.test ; -IN: temporary +IN: io.streams.nested.tests diff --git a/core/io/streams/string/string-tests.factor b/core/io/streams/string/string-tests.factor index 4bd31fe7d8..ca117534da 100644 --- a/core/io/streams/string/string-tests.factor +++ b/core/io/streams/string/string-tests.factor @@ -1,5 +1,5 @@ USING: io.streams.string io kernel arrays namespaces tools.test ; -IN: temporary +IN: io.streams.string.tests [ "line 1" CHAR: l ] [ diff --git a/core/io/test/no-trailing-eol.factor b/core/io/test/no-trailing-eol.factor index aa4d8b82d1..959f145bf5 100644 --- a/core/io/test/no-trailing-eol.factor +++ b/core/io/test/no-trailing-eol.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.tests USE: math : foo 2 2 + ; FORGET: foo \ No newline at end of file diff --git a/core/io/thread/thread.factor b/core/io/thread/thread.factor new file mode 100755 index 0000000000..fe86ba9e3d --- /dev/null +++ b/core/io/thread/thread.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: io.thread +USING: threads io.backend namespaces init math ; + +: io-thread ( -- ) + sleep-time io-multiplex yield ; + +: start-io-thread ( -- ) + [ io-thread t ] + "I/O wait" spawn-server + \ io-thread set-global ; + +[ start-io-thread ] "io.thread" add-init-hook diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index c828fcb0e9..2f80e3c368 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -139,10 +139,6 @@ ARTICLE: "equality" "Equality and comparison testing" ! Defined in handbook.factor ABOUT: "dataflow" -HELP: version -{ $values { "str" string } } -{ $description "Outputs the version number of the current Factor instance." } ; - HELP: eq? ( obj1 obj2 -- ? ) { $values { "obj1" object } { "obj2" object } { "?" "a boolean" } } { $description "Tests if two references point at the same object." } ; @@ -336,7 +332,7 @@ HELP: either? { $example "5 7 [ even? ] either? ." "f" } } ; -HELP: call ( quot -- ) +HELP: call ( callable -- ) { $values { "quot" callable } } { $description "Calls a quotation." $nl diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 2972cb2d5d..3c40984d7a 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs ; -IN: temporary +IN: kernel.tests [ 0 ] [ f size ] unit-test [ t ] [ [ \ = \ = ] all-equal? ] unit-test diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d1f3af4779..61574e406f 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -3,8 +3,6 @@ USING: kernel.private ; IN: kernel -: version ( -- str ) "0.92" ; foldable - ! Stack stuff : spin ( x y z -- z y x ) swap rot ; inline diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 2f8b158bbf..cba3532d9f 100755 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -32,3 +32,7 @@ SYMBOL: type-numbers : most-negative-fixnum ( -- n ) first-bignum neg ; + +M: real >integer + dup most-negative-fixnum most-positive-fixnum between? + [ >fixnum ] [ >bignum ] if ; diff --git a/core/libc/libc.factor b/core/libc/libc.factor old mode 100644 new mode 100755 index 2006850839..e82b244d6d --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -2,7 +2,7 @@ ! Copyright (C) 2007 Slava Pestov ! Copyright (C) 2007 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs continuations init inspector kernel namespaces ; +USING: alien assocs continuations init kernel namespaces ; IN: libc TUPLE: check-ptr ; -M: check-ptr summary drop "Memory allocation failed" ; - : check-ptr ( c-ptr -- c-ptr ) [ \ check-ptr construct-boa throw ] unless* ; TUPLE: double-free ; -M: double-free summary drop "Free failed since memory is not allocated" ; - : double-free ( -- * ) \ double-free construct-empty throw ; TUPLE: realloc-error ptr size ; -M: realloc-error summary drop "Memory reallocation failed" ; - : realloc-error ( alien size -- * ) \ realloc-error construct-boa throw ; stream-read-quot ; [ [ ] ] [ - "USE: temporary hello" parse-interactive + "USE: listener.tests hello" parse-interactive ] unit-test [ @@ -45,6 +45,6 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary : hello\n\"world\" ;" parse-interactive + "IN: listener.tests : hello\n\"world\" ;" parse-interactive drop ] unit-test diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 2d777d8087..fe1471716d 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays hashtables io kernel math memory namespaces -parser sequences strings io.styles io.streams.lines +USING: arrays hashtables io kernel math math.parser memory +namespaces parser sequences strings io.styles io.streams.lines io.streams.duplex vectors words generic system combinators tuples continuations debugger definitions compiler.units ; IN: listener @@ -62,11 +62,7 @@ M: duplex-stream stream-read-quot [ quit-flag off ] [ listen until-quit ] if ; inline -: print-banner ( -- ) - "Factor " write version write - " on " write os write "/" write cpu print ; - : listener ( -- ) - print-banner [ until-quit ] with-interactive-vocabs ; + [ until-quit ] with-interactive-vocabs ; MAIN: listener diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor index a10c0566f8..6dfc51f440 100755 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -1,5 +1,5 @@ USING: math math.bitfields tools.test kernel words ; -IN: temporary +IN: math.bitfields.tests [ 0 ] [ { } bitfield ] unit-test [ 256 ] [ 1 { 8 } bitfield ] unit-test diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 54a90ef233..095392ed81 100755 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.constants tools.test sequences ; -IN: temporary +IN: math.floats.tests [ t ] [ 0.0 float? ] unit-test [ t ] [ 3.1415 number? ] unit-test diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index aa716c3197..056e19e1de 100755 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -14,6 +14,7 @@ $nl { $subsection fixnum? } { $subsection bignum? } { $subsection >fixnum } +{ $subsection >integer } { $subsection >bignum } { $see-also "prettyprint-numbers" "modular-arithmetic" "bitwise-arithmetic" "integer-functions" "syntax-integers" } ; diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 194edb8f7e..eebc45511a 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -1,6 +1,6 @@ USING: kernel math namespaces prettyprint math.private continuations tools.test sequences ; -IN: temporary +IN: math.integers.tests [ "-8" ] [ -8 unparse ] unit-test diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 59a4dff8de..011af6342e 100755 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -6,6 +6,7 @@ IN: math.integers.private M: integer numerator ; M: integer denominator drop 1 ; +M: integer >integer ; M: fixnum >fixnum ; M: fixnum >bignum fixnum>bignum ; diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 2c6ac2ecb0..8e2f47f72b 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -1,6 +1,6 @@ USING: math.intervals kernel sequences words math arrays prettyprint tools.test random vocabs ; -IN: temporary +IN: math.intervals.tests [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index c650f7384c..fcd3b929ea 100644 --- a/core/math/math-tests.factor +++ b/core/math/math-tests.factor @@ -1,5 +1,5 @@ USING: kernel math namespaces tools.test ; -IN: temporary +IN: math.tests [ ] [ 5 [ ] times ] unit-test [ ] [ 0 [ ] times ] unit-test diff --git a/core/math/math.factor b/core/math/math.factor index 8b48e49f97..cd908ea10f 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -5,6 +5,7 @@ IN: math GENERIC: >fixnum ( x -- y ) foldable GENERIC: >bignum ( x -- y ) foldable +GENERIC: >integer ( x -- y ) foldable GENERIC: >float ( x -- y ) foldable MATH: number= ( x y -- ? ) foldable @@ -16,6 +17,11 @@ MATH: <= ( x y -- ? ) foldable MATH: > ( x y -- ? ) foldable MATH: >= ( x y -- ? ) foldable +: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline +: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline +: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline +: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline + MATH: + ( x y -- z ) foldable MATH: - ( x y -- z ) foldable MATH: * ( x y -- z ) foldable diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 226e47090a..baa6634a9f 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.parser sequences tools.test ; -IN: temporary +IN: math.parser.tests [ f ] [ f string>number ] diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor old mode 100644 new mode 100755 index 7d99e6311e..e29844dc89 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -47,8 +47,8 @@ HELP: gc-time ( -- n ) { $values { "n" "a timestamp in milliseconds" } } { $description "Outputs the total time spent in garbage collection during this Factor session." } ; -HELP: data-room ( -- cards semi generations ) -{ $values { "cards" "number of bytes reserved for card marking" } { "semi" "number of bytes reserved for tenured semi-space" } { "generations" "array of free/total bytes pairs" } } +HELP: data-room ( -- cards generations ) +{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } } { $description "Queries the runtime for memory usage information." } ; HELP: code-room ( -- code-free code-total ) diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index d0dfd2c0be..8808b30c59 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,6 +1,6 @@ USING: generic kernel kernel.private math memory prettyprint sequences tools.test words namespaces layouts classes ; -IN: temporary +IN: memory.tests TUPLE: testing x y z ; diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor index 994bb8ef84..863c4baa42 100644 --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -1,5 +1,5 @@ USING: mirrors tools.test assocs kernel arrays ; -IN: temporary +IN: mirrors.tests TUPLE: foo bar baz ; diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor old mode 100644 new mode 100755 index 7d3d5a53d0..af540ef86c --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel sequences generic words arrays classes slots slots.private tuples math vectors -quotations ; +quotations sorting prettyprint ; IN: mirrors GENERIC: object-slots ( obj -- seq ) @@ -69,8 +69,13 @@ M: enum clear-assoc enum-seq delete-all ; INSTANCE: enum assoc +: sort-assoc ( assoc -- alist ) + >alist + [ dup first unparse-short swap ] { } map>assoc + sort-keys values ; + GENERIC: make-mirror ( obj -- assoc ) -M: hashtable make-mirror ; +M: hashtable make-mirror sort-assoc ; M: integer make-mirror drop f ; M: array make-mirror ; M: vector make-mirror ; diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor old mode 100644 new mode 100755 index f087090f2c..2d4b9a03b2 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -179,8 +179,5 @@ HELP: % { $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ; HELP: init-namespaces -{ $description "Resets the name stack to its initial state, holding a single copy of the global namespace. This word is called during startup and is rarely useful, except in certain situations such as the example below." } -{ $examples - "You can use this word to spawn a new thread which does not inherit the parent thread's dynamic variable bindings:" - { $code "[ init-namestack do-some-work ] in-thread" } -} ; +{ $description "Resets the name stack to its initial state, holding a single copy of the global namespace." } +$low-level-note ; diff --git a/core/namespaces/namespaces-tests.factor b/core/namespaces/namespaces-tests.factor index 07e9d80c9e..8dc065c04a 100644 --- a/core/namespaces/namespaces-tests.factor +++ b/core/namespaces/namespaces-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: namespaces.tests USING: kernel namespaces tools.test words ; H{ } clone "test-namespace" set diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index b5b52e0e0e..d7638fa66d 100755 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: optimizer.control.tests USING: tools.test optimizer.control combinators kernel sequences inference.dataflow math inference classes strings optimizer ; diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index 815c564109..d5e8e2d75d 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: optimizer.def-use.tests USING: inference inference.dataflow optimizer optimizer.def-use namespaces assocs kernel sequences math tools.test words ; diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 6f535ec8e6..b7c82e402a 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -379,7 +379,7 @@ most-negative-fixnum most-positive-fixnum [a,b] >r dup dup node-in-d first node-interval swap dup node-in-d second node-literal r> execute ; inline -: foldable-comparison? ( #call word -- ) +: foldable-comparison? ( #call word -- ? ) >r dup known-comparison? [ r> perform-comparison incomparable eq? not ] [ diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 66d3956dba..5116d66715 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -1,9 +1,9 @@ -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 continuations growable optimizer.inlining namespaces hints ; -IN: temporary +IN: optimizer.tests [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index b89f56334b..89783d1b3c 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -1,8 +1,8 @@ USING: arrays math parser tools.test kernel generic words io.streams.string namespaces classes effects source-files assocs sequences strings io.files definitions continuations -sorting tuples compiler.units ; -IN: temporary +sorting tuples compiler.units debugger ; +IN: parser.tests [ [ 1 [ 2 [ 3 ] 4 ] 5 ] @@ -23,8 +23,8 @@ IN: temporary [ "hello world" ] [ - "IN: temporary : hello \"hello world\" ;" - eval "USE: temporary hello" eval + "IN: parser.tests : hello \"hello world\" ;" + eval "USE: parser.tests hello" eval ] unit-test [ ] @@ -51,7 +51,7 @@ IN: temporary : effect-parsing-test ( a b -- c ) + ; [ t ] [ - "effect-parsing-test" "temporary" lookup + "effect-parsing-test" "parser.tests" lookup \ effect-parsing-test eq? ] unit-test @@ -64,24 +64,24 @@ IN: temporary [ \ baz "declared-effect" word-prop effect-terminated? ] unit-test - [ ] [ "IN: temporary USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test + [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test [ t ] [ - "effect-parsing-test" "temporary" lookup + "effect-parsing-test" "parser.tests" lookup \ effect-parsing-test eq? ] unit-test [ T{ effect f { "a" "b" } { "d" } f } ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test - [ ] [ "IN: temporary : effect-parsing-test ;" eval ] unit-test + [ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test [ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test ! Funny bug - [ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test + [ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test - [ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail + [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail ! These should throw errors [ "HEX: zzz" eval ] must-fail @@ -102,71 +102,71 @@ IN: temporary ] unit-test DEFER: foo - "IN: temporary USING: math prettyprint ; : foo 2 2 + . ; parsing" eval + "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ; parsing" eval - [ ] [ "USE: temporary foo" eval ] unit-test + [ ] [ "USE: parser.tests foo" eval ] unit-test - "IN: temporary USING: math prettyprint ; : foo 2 2 + . ;" eval + "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval [ t ] [ - "USE: temporary \\ foo" eval - "foo" "temporary" lookup eq? + "USE: parser.tests \\ foo" eval + "foo" "parser.tests" lookup eq? ] unit-test ! Test smudging [ 1 ] [ - "IN: temporary : smudge-me ;" "foo" + "IN: parser.tests : smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test - [ t ] [ "smudge-me" "temporary" lookup >boolean ] unit-test + [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test [ ] [ - "IN: temporary : smudge-me-more ;" "foo" + "IN: parser.tests : smudge-me-more ;" "foo" parse-stream drop ] unit-test - [ t ] [ "smudge-me-more" "temporary" lookup >boolean ] unit-test - [ f ] [ "smudge-me" "temporary" lookup >boolean ] unit-test + [ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test + [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test [ 3 ] [ - "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" "foo" + "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test [ 1 ] [ - "IN: temporary USING: arrays ; M: array smudge-me ;" "bar" + "IN: parser.tests USING: arrays ; M: array smudge-me ;" "bar" parse-stream drop "bar" source-file source-file-definitions first assoc-size ] unit-test [ 2 ] [ - "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" "foo" + "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test [ t ] [ - array "smudge-me" "temporary" lookup order memq? + array "smudge-me" "parser.tests" lookup order memq? ] unit-test [ t ] [ - integer "smudge-me" "temporary" lookup order memq? + integer "smudge-me" "parser.tests" lookup order memq? ] unit-test [ f ] [ - string "smudge-me" "temporary" lookup order memq? + string "smudge-me" "parser.tests" lookup order memq? ] unit-test [ ] [ - "IN: temporary USE: math 2 2 +" "a" + "IN: parser.tests USE: math 2 2 +" "a" parse-stream drop ] unit-test @@ -175,7 +175,7 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary USE: math 2 2 -" "a" + "IN: parser.tests USE: math 2 2 -" "a" parse-stream drop ] unit-test @@ -186,7 +186,7 @@ IN: temporary [ ] [ "a" source-files get delete-at 2 [ - "IN: temporary DEFER: x : y x ; : x y ;" + "IN: parser.tests DEFER: x : y x ; : x y ;" "a" parse-stream drop ] times ] unit-test @@ -194,19 +194,19 @@ IN: temporary "a" source-files get delete-at [ - "IN: temporary : x ; : y 3 throw ; this is an error" + "IN: parser.tests : x ; : y 3 throw ; this is an error" "a" parse-stream ] [ parse-error? ] must-fail-with [ t ] [ - "y" "temporary" lookup >boolean + "y" "parser.tests" lookup >boolean ] unit-test [ f ] [ - "IN: temporary : x ;" + "IN: parser.tests : x ;" "a" parse-stream drop - "y" "temporary" lookup + "y" "parser.tests" lookup ] unit-test ! Test new forward definition logic @@ -269,81 +269,81 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary : ; : bogus ;" + "IN: parser.tests : ; : bogus ;" "bogus-error" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: bogus-error ; C: bogus-error : bogus ;" + "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ;" "bogus-error" parse-stream drop ] unit-test ! Problems with class predicates -vs- ordinary words [ ] [ - "IN: temporary TUPLE: killer ;" + "IN: parser.tests TUPLE: killer ;" "removing-the-predicate" parse-stream drop ] unit-test [ ] [ - "IN: temporary GENERIC: killer? ( a -- b )" + "IN: parser.tests GENERIC: killer? ( a -- b )" "removing-the-predicate" parse-stream drop ] unit-test [ t ] [ - "killer?" "temporary" lookup >boolean + "killer?" "parser.tests" lookup >boolean ] unit-test [ - "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" + "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?" "removing-the-predicate" parse-stream ] [ [ redefine-error? ] is? ] must-fail-with [ - "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" + "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;" "redefining-a-class-1" parse-stream ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ - "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test" + "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test" "redefining-a-class-2" parse-stream drop ] unit-test [ - "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" + "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" "redefining-a-class-3" parse-stream drop ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ - "IN: temporary TUPLE: class-fwd-test ;" + "IN: parser.tests TUPLE: class-fwd-test ;" "redefining-a-class-3" parse-stream drop ] unit-test [ - "IN: temporary \\ class-fwd-test" + "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop ] [ [ no-word? ] is? ] must-fail-with [ ] [ - "IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" + "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" "redefining-a-class-3" parse-stream drop ] unit-test [ - "IN: temporary \\ class-fwd-test" + "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop ] [ [ no-word? ] is? ] must-fail-with [ - "IN: temporary : foo ; TUPLE: foo ;" + "IN: parser.tests : foo ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ - "IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval + "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval ] unit-test [ - "IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval + "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval ] must-fail ] with-file-vocabs @@ -351,13 +351,18 @@ IN: temporary << file get parsed >> file set : ~a ; - : ~b ~a ; + + DEFER: ~b + + "IN: parser.tests : ~b ~a ;" + "smudgy" parse-stream drop + : ~c ; : ~d ; - { H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set + { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set - { H{ { ~d ~d } } H{ } } new-definitions set + { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set [ V{ ~b } { ~a } { ~a ~c } ] [ smudged-usage @@ -365,10 +370,63 @@ IN: temporary ] unit-test ] with-scope +[ + << file get parsed >> file set + + GENERIC: ~e + + : ~f ~e ; + + : ~g ; + + { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set + + { H{ { ~g ~g } } H{ } } new-definitions set + + [ V{ } { } { ~e ~f } ] + [ smudged-usage natural-sort ] + unit-test +] with-scope + [ ] [ - "IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval + "IN: parser.tests USE: kernel PREDICATE: object foo ( x -- y ) ;" eval ] unit-test [ t ] [ - "foo?" "temporary" lookup word eq? + "foo?" "parser.tests" lookup word eq? ] unit-test + +[ ] [ + "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "redefining-a-class-5" parse-stream drop +] unit-test + +[ ] [ + "IN: parser.tests M: f foo ;" + "redefining-a-class-6" parse-stream drop +] unit-test + +[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test + +[ ] [ + "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "redefining-a-class-5" parse-stream drop +] unit-test + +[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test + +[ ] [ + "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "redefining-a-class-7" parse-stream drop +] unit-test + +[ ] [ + "IN: parser.tests TUPLE: foo ;" + "redefining-a-class-7" parse-stream drop +] unit-test + +[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test + +[ "resource:core/parser/test/assert-depth.factor" run-file ] +[ relative-overflow-stack { 1 2 3 } sequence= ] +must-fail-with diff --git a/core/parser/parser.factor b/core/parser/parser.factor index fc29445f88..2f2d4a8c18 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -352,6 +352,8 @@ TUPLE: bad-number ; : parse-definition ( -- quot ) \ ; parse-until >quotation ; +: (:) CREATE dup reset-generic parse-definition ; + GENERIC: expected>string ( obj -- str ) M: f expected>string drop "end of input" ; @@ -409,6 +411,7 @@ SYMBOL: interactive-vocabs "tools.memory" "tools.profiler" "tools.test" + "tools.threads" "tools.time" "vocabs" "vocabs.loader" @@ -438,11 +441,12 @@ SYMBOL: interactive-vocabs "Warning: the following definitions were removed from sources," print "but are still referenced from other definitions:" print nl - dup stack. + dup sorted-definitions. nl "The following definitions need to be updated:" print nl - over stack. + over sorted-definitions. + nl ] when 2drop ; : filter-moved ( assoc -- newassoc ) @@ -462,9 +466,16 @@ SYMBOL: interactive-vocabs dup values concat prune swap keys ] keep ; +: fix-class-words ( -- ) + #! 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 dup reset-generic define-symbol ] assoc-each ; + : forget-smudged ( -- ) smudged-usage forget-all - over empty? [ 2dup smudged-usage-warning ] unless 2drop ; + over empty? [ 2dup smudged-usage-warning ] unless 2drop + fix-class-words ; : finish-parsing ( lines quot -- ) file get @@ -498,7 +509,7 @@ SYMBOL: interactive-vocabs ] recover ; : run-file ( file -- ) - [ [ parse-file call ] keep ] assert-depth drop ; + [ dup parse-file call ] assert-depth drop ; : ?run-file ( path -- ) dup resource-exists? [ run-file ] [ drop ] if ; diff --git a/core/parser/test/assert-depth.factor b/core/parser/test/assert-depth.factor new file mode 100755 index 0000000000..3008dc05b6 --- /dev/null +++ b/core/parser/test/assert-depth.factor @@ -0,0 +1 @@ +1 2 3 diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 11a685d581..20130d7f7e 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -2,8 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex kernel math namespaces parser prettyprint prettyprint.config prettyprint.sections sequences tools.test vectors words effects splitting generic.standard prettyprint.private -continuations generic compiler.units ; -IN: temporary +continuations generic compiler.units tools.walker ; +IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test [ "1.0" ] [ 1.0 unparse ] unit-test @@ -67,18 +67,18 @@ unit-test [ "[ \\ [ ]" ] [ [ \ [ ] unparse ] unit-test [ t ] [ - 100 \ dup [ pprint-short ] with-string-writer + 100 \ dup unparse-short "{" head? ] unit-test : foo ( a -- b ) dup * ; inline -[ "USING: kernel math ;\nIN: temporary\n: foo ( a -- b ) dup * ; inline\n" ] +[ "USING: kernel math ;\nIN: prettyprint.tests\n: foo ( a -- b ) dup * ; inline\n" ] [ [ \ foo see ] with-string-writer ] unit-test : bar ( x -- y ) 2 + ; -[ "USING: math ;\nIN: temporary\n: bar ( x -- y ) 2 + ;\n" ] +[ "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" ] [ [ \ bar see ] with-string-writer ] unit-test : blah @@ -115,28 +115,28 @@ unit-test [ [ parse-fresh drop ] with-compilation-unit [ - "temporary" lookup see + "prettyprint.tests" lookup see ] with-string-writer "\n" split 1 head* ] keep = ] with-scope ; : method-test { - "IN: temporary" + "IN: prettyprint.tests" "GENERIC: method-layout" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: complex method-layout" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" " ;" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: fixnum method-layout ;" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: integer method-layout ;" "" - "USING: kernel temporary ;" + "USING: kernel prettyprint.tests ;" "M: object method-layout ;" } ; @@ -147,7 +147,7 @@ unit-test : retain-stack-test { "USING: io kernel sequences words ;" - "IN: temporary" + "IN: prettyprint.tests" ": retain-stack-layout ( x -- )" " dup stream-readln stream-readln" " >r [ define ] map r>" @@ -161,7 +161,7 @@ unit-test : soft-break-test { "USING: kernel math sequences strings ;" - "IN: temporary" + "IN: prettyprint.tests" ": soft-break-layout ( x y -- ? )" " over string? [" " over hashcode over hashcode number=" @@ -176,7 +176,7 @@ unit-test : another-retain-layout-test { "USING: kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": another-retain-layout ( seq1 seq2 quot -- newseq )" " -rot 2dup dupd min-length [ each drop roll ] map" " >r 3drop r> ; inline" @@ -189,7 +189,7 @@ unit-test : another-soft-break-test { "USING: namespaces parser sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": another-soft-break-layout ( node -- quot )" " parse-error-file" " [ \"hello world foo\" add ] [ ] make ;" @@ -203,7 +203,7 @@ unit-test : string-layout { "USING: io kernel parser ;" - "IN: temporary" + "IN: prettyprint.tests" ": string-layout-test ( error -- )" " \"Expected \" write dup unexpected-want expected>string write" " \" but got \" write unexpected-got expected>string print ;" @@ -224,7 +224,7 @@ unit-test : final-soft-break-test { "USING: kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": final-soft-break-layout ( class dim -- view )" " >r \"alloc\" send 0 0 r>" " first2 " @@ -240,7 +240,7 @@ unit-test : narrow-test { "USING: arrays combinators continuations kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": narrow-layout ( obj -- )" " {" " { [ dup continuation? ] [ append ] }" @@ -255,7 +255,7 @@ unit-test : another-narrow-test { - "IN: temporary" + "IN: prettyprint.tests" ": another-narrow-layout ( -- obj )" " H{" " { 1 2 }" @@ -274,13 +274,13 @@ unit-test : class-see-test { - "IN: temporary" + "IN: prettyprint.tests" "TUPLE: class-see-layout ;" "" - "IN: temporary" + "IN: prettyprint.tests" "GENERIC: class-see-layout ( x -- y )" "" - "USING: temporary ;" + "USING: prettyprint.tests ;" "M: class-see-layout class-see-layout ;" } ; @@ -292,34 +292,26 @@ unit-test ! Regression [ t ] [ - "IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n" + "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n" dup eval - "generic-decl-test" "temporary" lookup + "generic-decl-test" "prettyprint.tests" lookup [ see ] with-string-writer = ] unit-test [ [ + ] ] [ - [ \ + (step-into) ] (remove-breakpoints) + [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test -[ [ (step-into) ] ] [ - [ (step-into) ] (remove-breakpoints) -] unit-test - -[ [ 3 ] ] [ - [ 3 (step-into) ] (remove-breakpoints) +[ [ (step-into-execute) ] ] [ + [ (step-into-execute) ] (remove-breakpoints) ] unit-test [ [ 2 2 + . ] ] [ - [ 2 2 \ + (step-into) . ] (remove-breakpoints) + [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints) ] unit-test [ [ 2 2 + . ] ] [ - [ 2 break 2 \ + (step-into) . ] (remove-breakpoints) -] unit-test - -[ [ 2 . ] ] [ - [ 2 \ break (step-into) . ] (remove-breakpoints) + [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints) ] unit-test [ ] [ 1 \ + curry unparse drop ] unit-test diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 2d4e6ced14..2efc9b4e67 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -75,6 +75,9 @@ combinators quotations ; { string-limit t } } clone [ pprint ] bind ; +: unparse-short ( obj -- str ) + [ pprint-short ] with-string-writer ; + : short. ( obj -- ) pprint-short nl ; : .b ( n -- ) >bin print ; @@ -94,27 +97,18 @@ SYMBOL: -> { { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } } "word-style" set-word-prop -! This code is ugly and could probably be simplified -: remove-step-into - building get dup empty? [ - drop \ (step-into) , - ] [ - pop dup wrapper? [ - wrapped dup \ break eq? - [ drop ] [ , ] if - ] [ - , - ] if - ] if ; +: remove-step-into ( word -- ) + building get dup empty? [ drop ] [ nip pop wrapped ] if , ; : (remove-breakpoints) ( quot -- newquot ) [ [ { - { break [ ] } - { (step-into) [ remove-step-into ] } - [ , ] - } case + { [ dup word? not ] [ , ] } + { [ dup "break?" word-prop ] [ drop ] } + { [ dup "step-into?" word-prop ] [ remove-step-into ] } + { [ t ] [ , ] } + } cond ] each ] [ ] make ; @@ -174,12 +168,18 @@ M: hook-generic synopsis* dup definer. dup seeing-word dup pprint-word - dup "combination" word-prop hook-combination-var pprint-word + dup "combination" word-prop hook-combination-var pprint* stack-effect. ; M: method-spec synopsis* dup definer. [ pprint-word ] each ; +M: method-body synopsis* + dup definer. + "method" word-prop dup + method-specializer pprint* + method-generic pprint* ; + M: mixin-instance synopsis* dup definer. dup mixin-instance-class pprint-word @@ -194,6 +194,15 @@ M: pathname synopsis* pprint* ; [ synopsis* ] with-in ] with-string-writer ; +: synopsis-alist ( definitions -- alist ) + [ dup synopsis swap ] { } map>assoc ; + +: definitions. ( alist -- ) + [ write-object nl ] assoc-each ; + +: sorted-definitions. ( definitions -- ) + synopsis-alist sort-keys definitions. ; + GENERIC: declarations. ( obj -- ) M: object declarations. drop ; @@ -259,7 +268,9 @@ M: builtin-class see-class* natural-sort [ nl see ] each ; : see-implementors ( class -- seq ) - dup implementors [ 2array ] with map ; + dup implementors + [ method method-word ] with map + natural-sort ; : see-class ( class -- ) dup class? [ @@ -269,8 +280,9 @@ M: builtin-class see-class* ] when drop ; : see-methods ( generic -- seq ) - [ "methods" word-prop keys natural-sort ] keep - [ 2array ] curry map ; + "methods" word-prop + [ nip method-word ] { } assoc>map + natural-sort ; M: word see dup see-class diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor index 90ba150a41..a4c9a619b5 100755 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -1,5 +1,5 @@ USING: math kernel quotations tools.test sequences ; -IN: temporary +IN: quotations.tests [ [ 3 ] ] [ 3 [ ] curry ] unit-test [ [ \ + ] ] [ \ + [ ] curry ] unit-test diff --git a/core/sbufs/sbufs-tests.factor b/core/sbufs/sbufs-tests.factor index b8d5b3e3fc..b30812b06f 100644 --- a/core/sbufs/sbufs-tests.factor +++ b/core/sbufs/sbufs-tests.factor @@ -1,6 +1,6 @@ USING: kernel math namespaces sequences sbufs strings tools.test classes ; -IN: temporary +IN: sbufs.tests [ 5 ] [ "Hello" >sbuf length ] unit-test diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index fbb879b01e..6e39bced07 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -429,7 +429,7 @@ HELP: collect HELP: each { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } -{ $description "Applies the quotation to each element of the sequence in turn." } ; +{ $description "Applies the quotation to each element of the sequence in order." } ; HELP: reduce { $values { "seq" sequence } { "identity" object } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "result" "the final result" } } @@ -447,7 +447,7 @@ HELP: accumulate HELP: map { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } } -{ $description "Applies the quotation to each element yielding a new element. The new elements are collected into a sequence of the same class as the input sequence." } ; +{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ; HELP: change-nth { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } } diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 40b2fef85e..c545a9baee 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -1,7 +1,7 @@ USING: arrays kernel math namespaces sequences kernel.private sequences.private strings sbufs tools.test vectors bit-arrays generic ; -IN: temporary +IN: sequences.tests [ V{ 1 2 3 4 } ] [ 1 5 dup >vector ] unit-test [ 3 ] [ 1 4 dup length ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index ee38d30750..7208e05af0 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -310,13 +310,11 @@ M: immutable-sequence clone-like like ; r dup length swap r> ; inline - : (each) ( seq quot -- n quot' ) - iterate-seq [ >r nth-unsafe r> call ] 2curry ; inline + >r dup length swap [ nth-unsafe ] curry r> compose ; inline : (collect) ( quot into -- quot' ) - [ >r over slip r> set-nth-unsafe ] 2curry ; inline + [ >r keep r> set-nth-unsafe ] 2curry ; inline : collect ( n quot into -- ) (collect) each-integer ; inline @@ -415,7 +413,7 @@ PRIVATE> >r dup length 1- swap r> (monotonic) all? ; inline : interleave ( seq between quot -- ) - [ (interleave) ] 2curry iterate-seq 2each ; inline + [ (interleave) ] 2curry >r dup length swap r> 2each ; inline : unfold ( pred quot tail -- seq ) V{ } clone [ @@ -695,9 +693,9 @@ PRIVATE> : sequence-hashcode-step ( oldhash newpart -- newhash ) swap [ - dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum + dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast fixnum+fast fixnum+fast - ] keep bitxor ; inline + ] keep fixnum-bitxor ; inline : sequence-hashcode ( n seq -- x ) 0 -rot [ diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor old mode 100644 new mode 100755 index 8325832050..732aeb045d --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -1,6 +1,6 @@ USING: sorting sequences kernel math random tools.test vectors ; -IN: temporary +IN: sorting.tests [ [ ] ] [ [ ] natural-sort ] unit-test @@ -11,7 +11,7 @@ unit-test [ t ] [ 100 [ drop - 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ <=> 0 <= ] monotonic? + 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic? ] all? ] unit-test diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 25b8252ea1..ab2ce21010 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -52,7 +52,7 @@ PRIVATE> : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ; -: sort-pair ( a b -- c d ) 2dup <=> 0 > [ swap ] when ; +: sort-pair ( a b -- c d ) 2dup after? [ swap ] when ; : midpoint ( seq -- elt ) [ midpoint@ ] keep nth-unsafe ; inline diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index c7539ad3eb..98c39ae390 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -68,7 +68,10 @@ uses definitions ; : reset-checksums ( -- ) source-files get [ swap ?resource-path dup exists? - [ file-lines swap record-checksum ] [ 2drop ] if + [ + over record-modified + file-lines swap record-checksum + ] [ 2drop ] if ] assoc-each ; M: pathname where pathname-string 1 2array ; @@ -97,16 +100,8 @@ SYMBOL: file [ ] [ file get rollback-source-file ] cleanup ] with-scope ; inline -: smart-usage ( word -- definitions ) - \ f or usage [ - dup method-body? [ - "method" word-prop - { method-specializer method-generic } get-slots - 2array - ] when - ] map ; - : outside-usages ( seq -- usages ) dup [ - over smart-usage [ pathname? not ] subset seq-diff + over usage + [ dup pathname? not swap where and ] subset seq-diff ] curry { } map>assoc ; diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index 2b6107e08b..d60403362c 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,5 +1,5 @@ USING: splitting tools.test ; -IN: temporary +IN: splitting.tests [ { 1 2 3 } 0 group ] must-fail diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 90e74275ff..c971287ef6 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -1,6 +1,6 @@ USING: continuations kernel math namespaces strings sbufs tools.test sequences vectors arrays ; -IN: temporary +IN: strings.tests [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test @@ -28,8 +28,8 @@ IN: temporary [ "end" ] [ "Beginning and end" 14 tail ] unit-test -[ t ] [ "abc" "abd" <=> 0 < ] unit-test -[ t ] [ "z" "abd" <=> 0 > ] unit-test +[ t ] [ "abc" "abd" before? ] unit-test +[ t ] [ "z" "abd" after? ] unit-test [ 0 10 "hello" subseq ] must-fail diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 95a00f3801..eeb3f85962 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -163,7 +163,7 @@ ARTICLE: "syntax-byte-vectors" "Byte vector syntax" ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } -"Pathnames are documented in " { $link "file-streams" } "." ; +"Pathnames are documented in " { $link "pathnames" } "." ; ARTICLE: "syntax-literals" "Literals" "Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words." diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 601c05d8d9..79a5553228 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -107,7 +107,7 @@ IN: bootstrap.syntax ] define-syntax ":" [ - CREATE dup reset-generic parse-definition define + (:) define ] define-syntax "GENERIC:" [ diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index bdd04307df..c5c7791a35 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -1,5 +1,5 @@ USING: generic help.markup help.syntax kernel math memory -namespaces sequences kernel.private io.files strings ; +namespaces sequences kernel.private strings ; IN: system ARTICLE: "os" "System interface" @@ -29,7 +29,7 @@ ARTICLE: "os" "System interface" { $subsection millis } "Exiting the Factor VM:" { $subsection exit } -{ $see-also "file-streams" "network-streams" "io.launcher" "io.mmap" } ; +{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ; ABOUT: "os" diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index c542e68981..296f542418 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -1,5 +1,5 @@ USING: math tools.test system prettyprint ; -IN: temporary +IN: system.tests [ t ] [ cell integer? ] unit-test [ t ] [ bootstrap-cell integer? ] unit-test diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index ece90d9a11..d157907cc2 100755 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,69 +1,165 @@ USING: help.markup help.syntax kernel kernel.private io -threads.private continuations dlists ; +threads.private continuations dlists init quotations strings +assocs heaps boxes namespaces ; IN: threads -ARTICLE: "threads" "Threads" -"A limited form of multiprocessing is supported in the form of cooperative threads, which are implemented on top of continuations. A thread will yield while waiting for I/O operations to complete, or when a yield has been explicitly requested." -$nl -"Words for working with threads are in the " { $vocab-link "threads" } " vocabulary." -{ $subsection in-thread } -{ $subsection yield } -{ $subsection sleep } -"Threads stop either when the quotation given to " { $link in-thread } " returns, or when the following word is called:" +ARTICLE: "threads-start/stop" "Starting and stopping threads" +"Spawning new threads:" +{ $subsection spawn } +{ $subsection spawn-server } +"Creating and spawning a thread can be factored out into two separate steps:" +{ $subsection } +{ $subsection (spawn) } +"Threads stop either when the quotation given to " { $link spawn } " returns, or when the following word is called:" { $subsection stop } -"Continuations can be added to the run queue directly:" -{ $subsection schedule-thread } -{ $subsection schedule-thread-with } +"If the image is saved and started again, all runnable threads are stopped. Vocabularies wishing to have a background thread always running should use " { $link add-init-hook } "." ; + +ARTICLE: "threads-yield" "Yielding and suspending threads" +"Yielding to other threads:" +{ $subsection yield } +"Sleeping for a period of time:" +{ $subsection sleep } +"Interrupting sleep:" +{ $subsection interrupt } +"Threads can be suspended and woken up at some point in the future when a condition is satisfied:" +{ $subsection suspend } +{ $subsection resume } +{ $subsection resume-with } ; + +ARTICLE: "thread-state" "Thread-local state" +"Threads form a class of objects:" +{ $subsection thread } +"The current thread:" +{ $subsection self } +"Thread-local variables:" +{ $subsection tnamespace } +{ $subsection tget } +{ $subsection tset } +{ $subsection tchange } +"Global hashtable of all threads, keyed by " { $link thread-id } ":" +{ $subsection threads } +"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ; + +ARTICLE: "thread-impl" "Thread implementation" "Thread implementation:" { $subsection run-queue } { $subsection sleep-queue } ; +ARTICLE: "threads" "Lightweight co-operative threads" +"Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." +$nl +"Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads." +$nl +"Words for working with threads are in the " { $vocab-link "threads" } " vocabulary." +{ $subsection "threads-start/stop" } +{ $subsection "threads-yield" } +{ $subsection "thread-state" } +{ $subsection "thread-impl" } ; + ABOUT: "threads" +HELP: thread +{ $class-description "A thread. The slots are as follows:" + { $list + { { $link thread-id } " - a unique identifier assigned to each thread." } + { { $link thread-name } " - the name passed to " { $link spawn } "." } + { { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." } + { { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." } + } +} ; + +HELP: self +{ $values { "thread" thread } } +{ $description "Pushes the currently-running thread." } ; + +HELP: +{ $values { "quot" quotation } { "name" string } { "error-handler" quotation } } +{ $description "Low-level thread constructor. The thread runs the quotation when spawned; the name is simply used to identify the thread for debugging purposes. The error handler is called if the thread's quotation throws an unhandled error; it should either print the error or notify another thread." } +{ $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link } " then passed to " { $link (spawn) } "." } ; + HELP: run-queue { $values { "queue" dlist } } -{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } +{ $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time." +$nl +"By convention, threads are queued with " { $link push-front } " and dequeued with " { $link pop-back } "." } ; -HELP: schedule-thread -{ $values { "continuation" "a continuation reified by " { $link callcc0 } } } -{ $description "Adds a runnable thread to the end of the run queue." } ; +HELP: resume +{ $values { "thread" thread } } +{ $description "Adds a thread to the end of the run queue. The thread must have previously been suspended by a call to " { $link suspend } "." } ; -HELP: schedule-thread-with -{ $values { "obj" "an object" } { "continuation" "a continuation reified by " { $link callcc1 } } } -{ $description "Adds a runnable thread to the end of the run queue. When the thread runs the object is passed to the continuation using " { $link continue-with } "." } ; +HELP: resume-with +{ $values { "obj" object } { "thread" thread } } +{ $description "Adds a thread to the end of the run queue together with an object to pass to the thread. The thread must have previously been suspended by a call to " { $link suspend } "; the object is returned from the " { $link suspend } " call." } ; HELP: sleep-queue -{ $var-description "Sleeping thread queue. This is not actually a queue, but an array of pairs of the shape " { $snippet "{ time continuation }" } "." } ; +{ $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ; HELP: sleep-time -{ $values { "ms" "a non-negative integer" } } -{ $description "Outputs the time until the next sleeping thread is scheduled to wake up, or a default sleep time if there are no sleeping threads." } ; +{ $values { "ms" "a non-negative integer or " { $link f } } } +{ $description "Outputs the time until the next sleeping thread is scheduled to wake up, which could be zero if there are threads in the run queue, or threads which need to wake up right now. If there are no runnable or sleeping threads, outputs " { $link f } "." } ; HELP: stop -{ $description "Stops the current thread." } ; +{ $description "Stops the current thread. The thread may be started again from another thread using " { $link (spawn) } "." } ; 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. It will not get woken up before this time period elapses, but since the multitasker is co-operative, the precise wakeup time is dependent on when other threads yield." } ; - -HELP: in-thread -{ $values { "quot" "a quotation" } } -{ $description "Spawns a new thread. The new thread begins running immediately." +{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." $nl -"The new thread inherits the current data stack and name stack. The call stack initially contains the new quotation only, so when the quotation returns the thread stops. The catch stack contains a default handler which logs errors to the " { $link stdio } " stream." } +"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ; + +HELP: interrupt +{ $values { "thread" thread } } +{ $description "Interrupts a sleeping thread." } ; + +HELP: suspend +{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } } +{ $description "Suspends the current thread and passes it to the quotation. After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "." } ; + +HELP: spawn +{ $values { "quot" quotation } { "name" string } } +{ $description "Spawns a new thread. The thread begins executing the given quotation; the name is for debugging purposes. The new thread begins running immediately and the current thread is added to the end of the run queue." +$nl +"The new thread begins with an empty data stack, an empty retain stack, and an empty catch stack. The name stack is inherited from the parent thread but may be cleared with " { $link init-namespaces } "." } +{ $notes + "The recommended way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "." +} { $examples - { $code "1 2 [ + . ] in-thread" } + { $code "1 2 [ + . ] 2curry \"Addition thread\" spawn" } } ; -HELP: idle-thread -{ $description "Runs the idle thread, which services I/O requests and relinquishes control to the operating system until the next Factor thread has to wake up again." -$nl -"If the run queue is empty, the idle thread will sleep until the next sleeping thread is scheduled to wake up, otherwise it yields immediately after checking for any completed I/O requests." } -{ $notes "This word should never be called directly. The idle thread is always running." } ; +HELP: spawn-server +{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } } +{ $description "Convenience wrapper around " { $link spawn } " which repeatedly calls the quotation in a new thread until it outputs " { $link f } "." } +{ $examples + "A thread that runs forever:" + { $code "[ do-foo-bar t ] \"Foo bar server\" spawn-server" } +} ; HELP: init-threads { $description "Called during startup to initialize the threading system. This word should never be called directly." } ; + +HELP: tnamespace +{ $values { "assoc" assoc } } +{ $description "Outputs the current thread's set of thread-local variables." } ; + +HELP: tget +{ $values { "key" object } { "value" object } } +{ $description "Outputs the value of a thread-local variable." } ; + +HELP: tset +{ $values { "value" object } { "key" object } } +{ $description "Sets the value of a thread-local variable." } ; + +HELP: tchange +{ $values { "key" object } { "quot" "a quotation with stack effect " { $snippet "( value -- newvalue )" } } } +{ $description "Applies the quotation to the current value of a thread-local variable, storing the result back to the same variable." } ; diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index 379b10ce88..c2e627e7bf 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -1,12 +1,16 @@ USING: namespaces io tools.test threads kernel ; -IN: temporary +IN: threads.tests 3 "x" set -[ yield 2 "x" set ] in-thread +namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop [ 2 ] [ yield "x" get ] unit-test -[ ] [ [ flush ] in-thread flush ] unit-test -[ ] [ [ "Errors, errors" throw ] in-thread ] unit-test +[ ] [ [ flush ] "flush test" spawn drop flush ] unit-test +[ ] [ [ "Errors, errors" throw ] "error test" spawn drop ] unit-test yield [ ] [ 0.3 sleep ] unit-test [ "hey" sleep ] must-fail + +[ 3 ] [ + [ 3 swap resume-with ] "Test suspend" suspend +] unit-test diff --git a/core/threads/threads.factor b/core/threads/threads.factor index c4e159742a..b4fd6eee60 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -1,71 +1,211 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. IN: threads -USING: arrays init hashtables heaps io.backend kernel -kernel.private math namespaces sequences vectors io system -continuations debugger dlists ; +USING: arrays hashtables heaps kernel kernel.private math +namespaces sequences vectors continuations continuations.private +dlists assocs system combinators init boxes ; + +SYMBOL: initial-thread + +TUPLE: thread +name quot exit-handler +id +continuation state +mailbox variables sleep-entry ; + +: self ( -- thread ) 40 getenv ; inline + +! Thread-local storage +: tnamespace ( -- assoc ) + self dup thread-variables + [ ] [ H{ } clone dup rot set-thread-variables ] ?if ; + +: tget ( key -- value ) + self thread-variables at ; + +: tset ( value key -- ) + tnamespace set-at ; + +: tchange ( key quot -- ) + tnamespace change-at ; inline + +: threads 41 getenv ; + +threads global [ H{ } assoc-like ] change-at + +: thread ( id -- thread ) threads at ; + +: thread-registered? ( thread -- ? ) + thread-id threads key? ; + +: check-unregistered + dup thread-registered? + [ "Thread already stopped" throw ] when ; + +: check-registered + dup thread-registered? + [ "Thread is not running" throw ] unless ; -: schedule-thread ( continuation -- ) - run-queue push-front ; +: ( quot name -- thread ) + \ thread counter [ ] { + set-thread-quot + set-thread-name + set-thread-id + set-thread-continuation + set-thread-exit-handler + } \ thread construct ; -: schedule-thread-with ( obj continuation -- ) - 2array schedule-thread ; +: run-queue 42 getenv ; + +: 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 ; + +r check-registered dup r> sleep-queue heap-push* + swap set-thread-sleep-entry ; + +: expire-sleep? ( heap -- ? ) + dup heap-empty? + [ drop f ] [ heap-peek nip millis <= ] if ; + +: expire-sleep ( thread -- ) + f over set-thread-sleep-entry resume ; + +: expire-sleep-loop ( -- ) + sleep-queue + [ dup expire-sleep? ] + [ dup heap-pop drop expire-sleep ] + [ ] while + drop ; + +: next ( -- * ) + expire-sleep-loop + 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> : stop ( -- ) - walker-hook [ - continue - ] [ - run-queue pop-back dup array? - [ first2 continue-with ] [ continue ] if - ] if* ; + self dup thread-exit-handler call + unregister-thread next ; -: yield ( -- ) [ schedule-thread stop ] callcc0 ; - -: sleep ( ms -- ) - >fixnum millis + [ schedule-sleep stop ] curry callcc0 ; - -: in-thread ( quot -- ) +: suspend ( quot state -- obj ) [ - >r schedule-thread r> [ + self thread-continuation >box + self set-thread-state + self swap call next + ] callcc1 2nip ; inline + +: yield ( -- ) [ resume ] f suspend drop ; + +GENERIC: sleep-until ( time/f -- ) + +M: integer sleep-until + [ schedule-sleep ] curry "sleep" suspend drop ; + +M: f sleep-until + drop [ drop ] "interrupt" suspend drop ; + +GENERIC: sleep ( ms -- ) + +M: real sleep + millis + >integer sleep-until ; + +: interrupt ( thread -- ) + dup thread-state [ + dup thread-sleep-entry [ sleep-queue heap-delete ] when* + f over set-thread-sleep-entry + dup resume + ] when drop ; + +: (spawn) ( thread -- ) + [ + resume-now [ + dup set-self + dup register-thread V{ } set-catchstack { } set-retainstack - [ [ print-error ] recover stop ] call-clear + >r { } set-datastack r> + thread-quot [ call stop ] call-clear ] 1 (throw) - ] curry callcc0 ; + ] "spawn" suspend 2drop ; + +: spawn ( quot name -- thread ) + [ (spawn) ] keep ; + +: spawn-server ( quot name -- thread ) + >r [ [ ] [ ] while ] curry r> spawn ; + +: in-thread ( quot -- ) + >r datastack namestack r> + [ >r set-namestack set-datastack r> call ] 3curry + "Thread" spawn drop ; + +GENERIC: error-in-thread ( error thread -- ) \ run-queue set-global - sleep-queue set-global - [ idle-thread ] in-thread ; + H{ } clone 41 setenv + 42 setenv + 43 setenv + initial-thread global + [ drop f "Initial" ] cache + over set-thread-continuation + f over set-thread-state + dup register-thread + set-self ; + +[ self error-in-thread stop ] +thread-error-hook set-global + +PRIVATE> [ init-threads ] "threads" add-init-hook -PRIVATE> diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index c9656a3b9e..63bb233654 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -3,7 +3,7 @@ math.constants parser sequences tools.test words assocs namespaces quotations sequences.private classes continuations generic.standard effects tuples tuples.private arrays vectors strings compiler.units ; -IN: temporary +IN: tuples.tests [ t ] [ \ tuple-class \ class class< ] unit-test [ f ] [ \ class \ tuple-class class< ] unit-test @@ -45,19 +45,19 @@ C: point 100 200 "p" set ! Use eval to sequence parsing explicitly -"IN: temporary TUPLE: point x y z ;" eval +"IN: tuples.tests TUPLE: point x y z ;" eval [ 100 ] [ "p" get point-x ] unit-test [ 200 ] [ "p" get point-y ] unit-test -[ f ] [ "p" get "point-z" "temporary" lookup execute ] unit-test +[ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test -300 "p" get "set-point-z" "temporary" lookup execute +300 "p" get "set-point-z" "tuples.tests" lookup execute -"IN: temporary TUPLE: point z y ;" eval +"IN: tuples.tests TUPLE: point z y ;" eval [ "p" get point-x ] must-fail [ 200 ] [ "p" get point-y ] unit-test -[ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test +[ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test TUPLE: predicate-test ; @@ -113,7 +113,7 @@ GENERIC: TUPLE: yo-momma ; -"IN: temporary C: yo-momma" eval +"IN: tuples.tests C: yo-momma" eval [ f ] [ \ generic? ] unit-test @@ -202,12 +202,12 @@ M: vector silly "z" ; SYMBOL: not-a-tuple-class [ - "IN: temporary C: not-a-tuple-class" + "IN: tuples.tests C: not-a-tuple-class" eval ] must-fail [ t ] [ - "not-a-tuple-class" "temporary" lookup symbol? + "not-a-tuple-class" "tuples.tests" lookup symbol? ] unit-test ! Missing check @@ -226,7 +226,7 @@ C: erg's-reshape-problem { set-erg's-reshape-problem-a } \ erg's-reshape-problem construct ; -"IN: temporary TUPLE: erg's-reshape-problem a b c d e f ;" eval +"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test @@ -235,5 +235,42 @@ C: erg's-reshape-problem [ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test [ - "IN: temporary SYMBOL: not-a-class C: not-a-class" eval + "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval ] [ [ check-tuple? ] is? ] must-fail-with + +! Hardcore unit tests +USE: threads + +\ thread "slot-names" word-prop "slot-names" set + +[ ] [ + [ + \ thread { "xxx" } "slot-names" get append + define-tuple-class + ] with-compilation-unit + + [ 1337 sleep ] "Test" spawn drop + + [ + \ thread "slot-names" get + define-tuple-class + ] with-compilation-unit +] unit-test + +USE: vocabs + +\ vocab "slot-names" word-prop "slot-names" set + +[ ] [ + [ + \ vocab { "xxx" } "slot-names" get append + define-tuple-class + ] with-compilation-unit + + all-words drop + + [ + \ vocab "slot-names" get + define-tuple-class + ] with-compilation-unit +] unit-test diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index ea74645525..e48a803659 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -3,7 +3,7 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces sequences sequences.private strings vectors words quotations memory combinators generic -classes classes.private slots slots.private ; +classes classes.private slots slots.private compiler.units ; IN: tuples M: tuple delegate 3 slot ; @@ -35,9 +35,12 @@ M: tuple class class-of-tuple ; append (>tuple) ; : reshape-tuples ( class newslots -- ) - >r dup [ swap class eq? ] curry instances dup - rot "slot-names" word-prop r> permutation - [ reshape-tuple ] curry map become ; + >r dup "slot-names" word-prop r> permutation + [ + >r [ swap class eq? ] curry instances dup r> + [ reshape-tuple ] curry map + become + ] 2curry after-compilation ; : old-slots ( class newslots -- seq ) swap "slots" word-prop 1 tail-slice @@ -55,6 +58,7 @@ M: tuple class class-of-tuple ; over "slot-names" word-prop over = [ 2dup forget-slots 2dup reshape-tuples + over changed-word over redefined ] unless ] when 2drop ; diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index b56cee1b34..d990f5f31c 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -1,7 +1,7 @@ USING: arrays kernel kernel.private math namespaces sequences sequences.private strings tools.test vectors continuations random growable classes ; -IN: temporary +IN: vectors.tests [ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 3a8fc37583..f99bf94aa4 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -1,5 +1,5 @@ ! Unit tests for vocabs.loader vocabulary -IN: temporary +IN: vocabs.loader.tests USING: vocabs.loader tools.test continuations vocabs math kernel arrays sequences namespaces io.streams.string parser source-files words assocs tuples definitions @@ -31,7 +31,7 @@ IN: vocabs.loader.test.2 MAIN: hello -IN: temporary +IN: vocabs.loader.tests [ { 3 3 3 } ] [ "vocabs.loader.test.2" run diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 2d53ed82e2..acc6c783a5 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -4,7 +4,7 @@ USING: namespaces sequences io.files kernel assocs words vocabs definitions parser continuations inspector debugger io io.styles io.streams.lines hashtables sorting prettyprint source-files arrays combinators strings system math.parser compiler.errors -splitting ; +splitting init ; IN: vocabs.loader SYMBOL: vocab-roots @@ -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 -- ) @@ -173,15 +175,25 @@ SYMBOL: blacklist : refresh ( prefix -- ) to-refresh do-refresh ; -: refresh-all ( -- ) "" refresh ; +SYMBOL: sources-changed? + +[ t sources-changed? set-global ] "vocabs.loader" add-init-hook + +: refresh-all ( -- ) + "" refresh f sources-changed? set-global ; 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 +201,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/vocabs/vocabs-tests.factor b/core/vocabs/vocabs-tests.factor index 9b05660d9d..21c3668148 100644 --- a/core/vocabs/vocabs-tests.factor +++ b/core/vocabs/vocabs-tests.factor @@ -1,5 +1,5 @@ ! Unit tests for vocabs vocabulary USING: vocabs tools.test ; -IN: temporary +IN: vocabs.tests [ f ] [ "kernel" vocab-main ] unit-test diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 91b5295427..f1cc678d17 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -76,9 +76,9 @@ $nl ARTICLE: "declarations" "Declarations" "Declarations give special behavior to a word. Declarations are parsing words that set a word property in the most recently defined word." $nl -"The first declaration specifies the time when a word runs. It affects both interpreted and compiled definitions." +"The first declaration specifies the time when a word runs. It affects both the non-optimizing and optimizing compilers:" { $subsection POSTPONE: parsing } -"The remaining declarations only affect compiled definitions. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently." +"The remaining declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently." { $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." } { $subsection POSTPONE: inline } { $subsection POSTPONE: foldable } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index f29d21cd9f..97ce86d38a 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -1,13 +1,13 @@ USING: arrays generic assocs kernel math namespaces sequences tools.test words definitions parser quotations -vocabs continuations tuples compiler.units ; -IN: temporary +vocabs continuations tuples compiler.units io.streams.string ; +IN: words.tests [ 4 ] [ [ - "poo" "temporary" create [ 2 2 + ] define + "poo" "words.tests" create [ 2 2 + ] define ] with-compilation-unit - "poo" "temporary" lookup execute + "poo" "words.tests" lookup execute ] unit-test [ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-test @@ -50,7 +50,7 @@ SYMBOL: a-symbol ! See if redefining a generic as a colon def clears some ! word props. GENERIC: testing -"IN: temporary : testing ;" eval +"IN: words.tests : testing ;" eval [ f ] [ \ testing generic? ] unit-test @@ -112,13 +112,13 @@ M: array freakish ; DEFER: x [ x ] [ undefined? ] must-fail-with -[ ] [ "no-loc" "temporary" create drop ] unit-test -[ f ] [ "no-loc" "temporary" lookup where ] unit-test +[ ] [ "no-loc" "words.tests" create drop ] unit-test +[ f ] [ "no-loc" "words.tests" lookup where ] unit-test -[ ] [ "IN: temporary : no-loc-2 ;" eval ] unit-test -[ f ] [ "no-loc-2" "temporary" lookup where ] unit-test +[ ] [ "IN: words.tests : no-loc-2 ;" eval ] unit-test +[ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test -[ ] [ "IN: temporary : test-last ( -- ) ;" eval ] unit-test +[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test [ "test-last" ] [ word word-name ] unit-test ! regression @@ -141,38 +141,40 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ "IN: temporary : undef-test ; << undef-test >>" eval ] +[ "IN: words.tests : undef-test ; << undef-test >>" eval ] [ [ undefined? ] is? ] must-fail-with [ ] [ - "IN: temporary GENERIC: symbol-generic" eval + "IN: words.tests GENERIC: symbol-generic" eval ] unit-test [ ] [ - "IN: temporary SYMBOL: symbol-generic" eval + "IN: words.tests SYMBOL: symbol-generic" eval ] unit-test -[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test -[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test +[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test +[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test [ ] [ - "IN: temporary GENERIC: symbol-generic" eval + "IN: words.tests GENERIC: symbol-generic" + "symbol-generic-test" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: symbol-generic ;" eval + "IN: words.tests TUPLE: symbol-generic ;" + "symbol-generic-test" parse-stream drop ] unit-test -[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test -[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test +[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test +[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test ! Regressions -[ ] [ "IN: temporary : decl-forget-test ; foldable" eval ] unit-test -[ t ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test -[ f ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ; foldable" eval ] unit-test +[ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test +[ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ; flushable" eval ] unit-test -[ t ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test -[ f ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ; flushable" eval ] unit-test +[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test +[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index efb3d06a9b..e8b3fd9781 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -111,9 +111,17 @@ compiled-crossref global [ H{ } assoc-like ] change-at dup compiled-unxref compiled-crossref get delete-at ; +SYMBOL: +inlined+ +SYMBOL: +called+ + : compiled-usage ( word -- assoc ) compiled-crossref get at ; +: compiled-usages ( words -- seq ) + [ [ dup ] H{ } map>assoc dup ] keep [ + compiled-usage [ nip +inlined+ eq? ] assoc-subset update + ] with each keys ; + M: word redefined* ( word -- ) { "inferred-effect" "no-effect" } reset-props ; diff --git a/cp_dir b/cp_dir deleted file mode 100755 index 76c8a8f03b..0000000000 --- a/cp_dir +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh - -echo $1 -mkdir -p "`dirname \"$2\"`" -cp "$1" "$2" diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor new file mode 100755 index 0000000000..fcb2de8b6b --- /dev/null +++ b/extra/alarms/alarms-docs.factor @@ -0,0 +1,27 @@ +IN: alarms +USING: help.markup help.syntax calendar quotations ; + +HELP: alarm +{ $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ; + +HELP: add-alarm +{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } } +{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; + +HELP: later +{ $values { "quot" quotation } { "time" duration } { "alarm" alarm } } +{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ; + +HELP: cancel-alarm +{ $values { "alarm" alarm } } +{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ; + +ARTICLE: "alarms" "Alarms" +"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread." +{ $subsection alarm } +{ $subsection add-alarm } +{ $subsection later } +{ $subsection cancel-alarm } +"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ; + +ABOUT: "alarms" diff --git a/extra/alarms/alarms-tests.factor b/extra/alarms/alarms-tests.factor new file mode 100755 index 0000000000..1af851c9c6 --- /dev/null +++ b/extra/alarms/alarms-tests.factor @@ -0,0 +1,17 @@ +IN: alarms.tests +USING: alarms kernel calendar sequences tools.test threads +concurrency.count-downs ; + +[ ] [ + 1 + { f } clone 2dup + [ first cancel-alarm count-down ] 2curry 1 seconds later + swap set-first + await +] unit-test + +[ ] [ + [ + [ resume ] curry instant later drop + ] "test" suspend drop +] unit-test diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor old mode 100644 new mode 100755 index 4540b7b2aa..1ccfdcbd30 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -1,87 +1,89 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar combinators concurrency generic -init kernel math namespaces sequences threads ; +USING: arrays calendar combinators generic init kernel math +namespaces sequences heaps boxes threads debugger quotations +assocs ; IN: alarms -TUPLE: alarm time quot ; - -C: alarm +TUPLE: alarm quot time interval entry ; 0 > ] with subset ; - -: unexpired-alarms ( -- seq ) - now alarms get-global - [ alarm-time <=> 0 <= ] with subset ; - -: call-alarm ( alarm -- ) - alarm-quot spawn drop ; - -: do-alarms ( -- ) - expired-alarms [ call-alarm ] each - unexpired-alarms alarms set-global ; - -: alarm-receive-loop ( -- ) - receive dup alarm? [ handle-alarm ] [ drop ] if - alarm-receive-loop ; - -: start-alarm-receiver ( -- ) - [ - alarm-receive-loop - ] spawn alarm-receiver set-global ; - -: alarm-loop ( -- ) - alarms get-global empty? [ - do-alarms - ] unless 100 sleep alarm-loop ; - -: start-alarm-looper ( -- ) - [ - alarm-loop - ] spawn alarm-looper set-global ; - -: send-alarm ( str alarm -- ) - over set-delegate - alarm-receiver get-global send ; - -: start-alarm-daemon ( -- ) - alarms get-global [ V{ } clone alarms set-global ] unless - start-alarm-looper - start-alarm-receiver ; - -[ start-alarm-daemon ] "alarms" add-init-hook -PRIVATE> +: ( quot time frequency -- alarm ) + check-alarm alarm construct-boa ; : register-alarm ( alarm -- ) - "register" send-alarm ; + dup dup alarm-time alarms get-global heap-push* + swap alarm-entry >box + notify-alarm-thread ; -: unregister-alarm ( alarm -- ) - "unregister" send-alarm ; +: alarm-expired? ( alarm now -- ? ) + >r alarm-time r> before=? ; -: change-alarm ( alarm-old alarm-new -- ) - "register" send-alarm - "unregister" send-alarm ; +: reschedule-alarm ( alarm -- ) + dup alarm-time over alarm-interval time+ + over set-alarm-time + register-alarm ; -! Example: -! 5 seconds from-now [ "hi" print flush ] register-alarm +: call-alarm ( alarm -- ) + dup alarm-entry box> drop + dup alarm-quot try + dup alarm-interval [ reschedule-alarm ] [ drop ] if ; + +: (trigger-alarms) ( alarms now -- ) + over heap-empty? [ + 2drop + ] [ + over heap-peek drop over alarm-expired? [ + over heap-pop drop call-alarm (trigger-alarms) + ] [ + 2drop + ] if + ] if ; + +: trigger-alarms ( alarms -- ) + now (trigger-alarms) ; + +: next-alarm ( alarms -- timestamp/f ) + dup heap-empty? + [ drop f ] [ heap-peek drop alarm-time ] if ; + +: alarm-thread-loop ( -- ) + alarms get-global + dup next-alarm sleep-until + dup trigger-alarms + alarm-thread-loop ; + +: cancel-alarms ( alarms -- ) + [ + heap-pop-all [ nip alarm-entry box> drop ] assoc-each + ] when* ; + +: init-alarms ( -- ) + alarms global [ cancel-alarms ] change-at + [ alarm-thread-loop ] "Alarms" spawn + alarm-thread set-global ; + +[ init-alarms ] "alarms" add-init-hook + +PRIVATE> + +: add-alarm ( quot time frequency -- alarm ) + [ register-alarm ] keep ; + +: later ( quot dt -- alarm ) + from-now f add-alarm ; + +: cancel-alarm ( alarm -- ) + alarm-entry [ alarms get-global heap-delete ] if-box? ; diff --git a/extra/ascii/ascii-tests.factor b/extra/ascii/ascii-tests.factor index ec76d89d7c..b2b13b1d78 100644 --- a/extra/ascii/ascii-tests.factor +++ b/extra/ascii/ascii-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ascii.tests USING: ascii tools.test sequences kernel math ; [ t ] [ CHAR: a letter? ] unit-test diff --git a/extra/benchmark/crc32/crc32.factor b/extra/benchmark/crc32/crc32.factor new file mode 100644 index 0000000000..7dad272296 --- /dev/null +++ b/extra/benchmark/crc32/crc32.factor @@ -0,0 +1,10 @@ +USING: io.crc32 io.files kernel math ; +IN: benchmark.crc32 + +: crc32-primes-list ( -- ) + 10 [ + "extra/math/primes/list/list.factor" resource-path + file-contents crc32 drop + ] times ; + +MAIN: crc32-primes-list diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 75321def2d..1740bcb28e 100644 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -51,7 +51,7 @@ HINTS: random fixnum ; dup keys >byte-array swap values >float-array unclip [ + ] accumulate swap add ; -:: select-random | seed chars floats | +:: select-random ( seed chars floats -- elt ) floats seed random -rot [ >= ] curry find drop chars nth-unsafe ; inline @@ -62,7 +62,7 @@ HINTS: random fixnum ; : write-description ( desc id -- ) ">" write write bl print ; inline -:: split-lines | n quot | +:: split-lines ( n quot -- ) n line-length /mod [ [ line-length quot call ] times ] dip dup zero? [ drop ] quot if ; inline @@ -71,7 +71,7 @@ HINTS: random fixnum ; write-description [ make-random-fasta ] 2curry split-lines ; inline -:: make-repeat-fasta | k len alu | +:: make-repeat-fasta ( k len alu -- ) [let | kn [ alu length ] | len [ k + kn mod alu nth-unsafe ] B{ } map-as print k len + diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor new file mode 100755 index 0000000000..cc42028df6 --- /dev/null +++ b/extra/benchmark/fib6/fib6.factor @@ -0,0 +1,14 @@ +IN: benchmark.fib6 +USING: math kernel alien ; + +: fib + "int" { "int" } "cdecl" [ + dup 1 <= [ drop 1 ] [ + 1- dup fib swap 1- fib + + ] if + ] alien-callback + "int" { "int" } "cdecl" alien-indirect ; + +: fib-main 25 fib drop ; + +MAIN: fib-main diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 230fb2f889..0da4785785 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -65,7 +65,7 @@ SYMBOL: cols ] with-scope ; : mandel-main ( -- ) - "mandel.ppm" resource-path + "mandel.ppm" temp-file [ mandel write ] with-file-writer ; MAIN: mandel-main diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor new file mode 100644 index 0000000000..3043725acd --- /dev/null +++ b/extra/benchmark/md5/md5.factor @@ -0,0 +1,7 @@ +USING: crypto.md5 io.files kernel ; +IN: benchmark.md5 + +: md5-primes-list ( -- ) + "extra/math/primes/list/list.factor" resource-path file>md5 drop ; + +MAIN: md5-primes-list diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor new file mode 100644 index 0000000000..95c797cddd --- /dev/null +++ b/extra/benchmark/random/random.factor @@ -0,0 +1,14 @@ +USING: io.files random math.parser io math ; +IN: benchmark.random + +: random-numbers-path "random-numbers.txt" temp-file ; + +: write-random-numbers ( n -- ) + random-numbers-path [ + [ 200 random 100 - number>string print ] times + ] with-file-writer ; + +: random-main ( -- ) + 1000000 write-random-numbers ; + +MAIN: random-main diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 8f2badc95f..ddfd0ed6dd 100644 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -170,7 +170,7 @@ DEFER: create ( level c r -- scene ) ] "" make ; : raytracer-main - "raytracer.pnm" resource-path + "raytracer.pnm" temp-file [ run write ] with-file-writer ; MAIN: raytracer-main diff --git a/extra/benchmark/reverse-complement/reverse-complement-test-out.txt b/extra/benchmark/reverse-complement/reverse-complement-test-out.txt old mode 100644 new mode 100755 diff --git a/extra/benchmark/reverse-complement/reverse-complement-tests.factor b/extra/benchmark/reverse-complement/reverse-complement-tests.factor new file mode 100755 index 0000000000..c8d4714802 --- /dev/null +++ b/extra/benchmark/reverse-complement/reverse-complement-tests.factor @@ -0,0 +1,13 @@ +IN: benchmark.reverse-complement.tests +USING: tools.test benchmark.reverse-complement crypto.md5 +io.files kernel ; + +[ "c071aa7e007a9770b2fb4304f55a17e5" ] [ + "extra/benchmark/reverse-complement/reverse-complement-test-in.txt" + "extra/benchmark/reverse-complement/reverse-complement-test-out.txt" + [ resource-path ] 2apply + reverse-complement + + "extra/benchmark/reverse-complement/reverse-complement-test-out.txt" + resource-path file>md5str +] unit-test diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 0771b756bf..cf4143d533 100755 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -41,12 +41,10 @@ HINTS: do-line vector string ; ] with-disposal ; : reverse-complement-in - "extra/benchmark/reverse-complement/reverse-complement-in.txt" - resource-path ; + "reverse-complement-in.txt" temp-file ; : reverse-complement-out - "extra/benchmark/reverse-complement/reverse-complement-out.txt" - resource-path ; + "reverse-complement-out.txt" temp-file ; : reverse-complement-main ( -- ) reverse-complement-in diff --git a/extra/benchmark/ring/ring.factor b/extra/benchmark/ring/ring.factor old mode 100644 new mode 100755 index b0d02c4239..ae918b7ebc --- a/extra/benchmark/ring/ring.factor +++ b/extra/benchmark/ring/ring.factor @@ -1,4 +1,5 @@ -USING: concurrency kernel tools.time math sequences ; +USING: threads concurrency.messaging kernel +tools.time math sequences ; IN: benchmark.ring SYMBOL: done @@ -7,7 +8,9 @@ SYMBOL: done receive 2dup swap send done eq? [ tunnel ] unless ; : create-ring ( processes -- target ) - self swap [ [ tunnel ] spawn nip ] times ; + self swap [ + dup [ tunnel ] curry "Tunnel" spawn nip + ] times ; : send-messages ( messages target -- ) dupd [ send ] curry each [ receive drop ] times ; @@ -22,4 +25,3 @@ SYMBOL: done 1000 1000 ring-bench ; MAIN: main-ring-bench - diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index a621331968..c739bb787c 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,32 +1,54 @@ -USING: io.sockets io.server io kernel math threads debugger -concurrency tools.time prettyprint ; +USING: io.sockets io kernel math threads +debugger tools.time prettyprint concurrency.count-downs +namespaces arrays continuations ; IN: benchmark.sockets +SYMBOL: counter + +: number-of-requests 1 ; + +: server-addr "127.0.0.1" 7777 ; + +: server-loop ( server -- ) + dup accept [ + [ + read1 CHAR: x = [ + "server" get dispose + ] [ + number-of-requests + [ read1 write1 flush ] times + counter get count-down + ] if + ] with-stream + ] curry "Client handler" spawn drop server-loop ; + : simple-server ( -- ) - 7777 local-server "benchmark.sockets" [ - read1 CHAR: x = [ - stop-server - ] [ - 20 [ read1 write1 flush ] times - ] if - ] with-server ; + [ + server-addr dup "server" set [ + server-loop + ] with-disposal + ] ignore-errors ; : simple-client ( -- ) - "localhost" 7777 [ + server-addr [ CHAR: b write1 flush - 20 [ CHAR: a dup write1 flush read1 assert= ] times + number-of-requests + [ CHAR: a dup write1 flush read1 assert= ] times + counter get count-down ] with-stream ; : stop-server ( -- ) - "localhost" 7777 [ + server-addr [ CHAR: x write1 ] with-stream ; : clients ( n -- ) dup pprint " clients: " write [ - [ simple-server ] in-thread + dup 2 * counter set + [ simple-server ] "Simple server" spawn drop yield yield - [ drop simple-client ] parallel-each + [ [ simple-client ] "Simple client" spawn drop ] times + counter get await stop-server yield yield ] time ; @@ -34,10 +56,10 @@ IN: benchmark.sockets : socket-benchmarks 10 clients 20 clients - 40 clients - 80 clients - 160 clients - 320 clients - 640 clients ; + 40 clients ; + ! 80 clients + ! 160 clients + ! 320 clients + ! 640 clients ; MAIN: socket-benchmarks diff --git a/extra/benchmark/sort/sort.factor b/extra/benchmark/sort/sort.factor index 0a31bf0ca4..a54480692a 100644 --- a/extra/benchmark/sort/sort.factor +++ b/extra/benchmark/sort/sort.factor @@ -1,7 +1,8 @@ -USING: kernel sequences sorting random ; +USING: kernel sequences sorting benchmark.random math.parser +io.files ; IN: benchmark.sort : sort-benchmark - 100000 [ drop 100000 random ] map natural-sort drop ; + random-numbers-path file-lines [ string>number ] map natural-sort drop ; MAIN: sort-benchmark diff --git a/extra/benchmark/sum-file/sum-file.factor b/extra/benchmark/sum-file/sum-file.factor index e17765d542..1d52beebfc 100644 --- a/extra/benchmark/sum-file/sum-file.factor +++ b/extra/benchmark/sum-file/sum-file.factor @@ -1,4 +1,5 @@ -USING: io io.files math math.parser kernel prettyprint ; +USING: io io.files math math.parser kernel prettyprint +benchmark.random ; IN: benchmark.sum-file : sum-file-loop ( n -- n' ) @@ -8,6 +9,6 @@ IN: benchmark.sum-file [ 0 sum-file-loop ] with-file-reader . ; : sum-file-main ( -- ) - home "sum-file-in.txt" path+ sum-file ; + random-numbers-path sum-file ; MAIN: sum-file-main diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 552e26ebf5..084f30a103 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -4,21 +4,32 @@ IN: bootstrap.image.upload USING: http.client crypto.md5 splitting assocs kernel io.files bootstrap.image sequences io namespaces io.launcher math ; -: destination "slava@factorcode.org:www/images/latest/" ; +SYMBOL: upload-images-destination + +: destination ( -- dest ) + upload-images-destination get + "slava@/var/www/factorcode.org/newsite/images/latest/" + or ; + +: checksums "checksums.txt" temp-file ; : boot-image-names images [ boot-image-name ] map ; : compute-checksums ( -- ) - "checksums.txt" [ + checksums [ boot-image-names [ dup write bl file>md5str print ] each ] with-file-writer ; : upload-images ( -- ) [ - "scp" , boot-image-names % "checksums.txt" , destination , + "scp" , + boot-image-names % + "temp/checksums.txt" , destination , ] { } make try-process ; : new-images ( -- ) - make-images compute-checksums upload-images ; + "" resource-path + [ make-images compute-checksums upload-images ] + with-directory ; MAIN: new-images diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index 40d77e03be..718f73308c 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -5,10 +5,11 @@ USING: vocabs.loader sequences ; "tools.annotations" "tools.crossref" "tools.deploy" + "tools.disassembler" "tools.memory" "tools.profiler" "tools.test" "tools.time" - "tools.disassembler" + "tools.threads" "editors" } [ require ] each diff --git a/extra/bootstrap/ui/tools/tools.factor b/extra/bootstrap/ui/tools/tools.factor old mode 100644 new mode 100755 index af715966b3..c4a555b3e2 --- a/extra/bootstrap/ui/tools/tools.factor +++ b/extra/bootstrap/ui/tools/tools.factor @@ -7,4 +7,6 @@ USING: kernel vocabs vocabs.loader sequences system ; "ui.cocoa" vocab [ "ui.cocoa.tools" require ] when + + "ui.tools.walker" require ] when diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor new file mode 100644 index 0000000000..48891593d2 --- /dev/null +++ b/extra/builder/benchmark/benchmark.factor @@ -0,0 +1,41 @@ + +USING: kernel continuations arrays assocs sequences sorting math + io io.styles prettyprint builder.util ; + +IN: builder.benchmark + +: passing-benchmarks ( table -- table ) + [ second first2 number? swap number? and ] subset ; + +: simplify-table ( table -- table ) [ first2 second 2array ] map ; + +: benchmark-difference ( old-table benchmark-result -- result-diff ) + first2 >r + tuck swap at + r> + swap - + 2array ; + +: compare-tables ( old new -- table ) + [ passing-benchmarks simplify-table ] 2apply + [ benchmark-difference ] with map ; + +: benchmark-deltas ( -- table ) + "../../benchmarks" "../benchmarks" [ eval-file ] 2apply + compare-tables + sort-values ; + +: benchmark-deltas. ( deltas -- ) + standard-table-style + [ + [ [ "Benchmark" write ] with-cell [ "Delta (ms)" write ] with-cell ] + with-row + [ [ swap [ write ] with-cell pprint-cell ] with-row ] + assoc-each + ] + tabular-output ; + +: show-benchmark-deltas ( -- ) + [ benchmark-deltas benchmark-deltas. ] + [ drop "Error generating benchmark deltas" . ] + recover ; \ No newline at end of file diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 0c9f4ab099..92cd5f5241 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,21 +1,16 @@ USING: kernel namespaces sequences splitting system combinators continuations parser io io.files io.launcher io.sockets prettyprint threads - bootstrap.image benchmark vars bake smtp builder.util accessors ; + bootstrap.image benchmark vars bake smtp builder.util accessors + calendar + builder.common + builder.benchmark + builder.release ; IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: builds-dir - -: builds ( -- path ) - builds-dir get - home "/builds" append - or ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : prepare-build-machine ( -- ) builds make-directory builds cd @@ -31,8 +26,6 @@ SYMBOL: builds-dir ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -VAR: stamp - : enter-build-dir ( -- ) datestamp >stamp builds cd @@ -46,31 +39,30 @@ VAR: stamp : record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ; -: make-clean ( -- desc ) { "make" "clean" } ; +: do-make-clean ( -- desc ) { "make" "clean" } try-process ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ; - : make-vm ( -- desc ) - { "make" target } to-strings >>arguments - "../compile-log" >>stdout - +stdout+ >>stderr + { "make" } >>arguments + "../compile-log" >>stdout + +stdout+ >>stderr >desc ; +: do-make-vm ( -- ) + make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: factor-binary ( -- name ) - os - { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } - { "winnt" [ "./factor-nt.exe" ] } - [ drop "./factor" ] } - case ; +: copy-image ( -- ) + builds "factor" path+ my-boot-image-name path+ ".." copy-file-into + builds "factor" path+ my-boot-image-name path+ "." copy-file-into ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : bootstrap-cmd ( -- cmd ) - { factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" } - to-strings ; + { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; : bootstrap ( -- desc ) @@ -78,11 +70,27 @@ VAR: stamp +closed+ >>stdin "../boot-log" >>stdout +stdout+ >>stderr - 20 minutes>ms >>timeout + 20 minutes >>timeout >desc ; -: builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ; - +: do-bootstrap ( -- ) + bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ; + +: builder-test-cmd ( -- cmd ) + { "./factor" "-run=builder.test" } to-strings ; + +: builder-test ( -- desc ) + + builder-test-cmd >>arguments + +closed+ >>stdin + "../test-log" >>stdout + +stdout+ >>stderr + 45 minutes >>timeout + >desc ; + +: do-builder-test ( -- ) + builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: build-status @@ -95,42 +103,48 @@ SYMBOL: build-status enter-build-dir - "report" [ + "report" + [ + "Build machine: " write host-name print + "CPU: " write cpu print + "OS: " write os print + "Build directory: " write cwd print - "Build machine: " write host-name print - "CPU: " write cpu print - "OS: " write os print - "Build directory: " write cwd print nl + git-clone [ "git clone failed" print ] run-or-bail - git-clone [ "git clone failed" print ] run-or-bail + "factor" + [ + record-git-id + do-make-clean + do-make-vm + copy-image + do-bootstrap + do-builder-test + ] + with-directory - "factor" cd + "test-log" delete-file - record-git-id + "git id: " write "git-id" eval-file print nl - make-clean run-process drop + "Boot time: " write "boot-time" eval-file milli-seconds>time print + "Load time: " write "load-time" eval-file milli-seconds>time print + "Test time: " write "test-time" eval-file milli-seconds>time print nl - make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail + "Did not pass load-everything: " print "load-everything-vocabs" cat + "Did not pass test-all: " print "test-all-vocabs" cat - [ retrieve-image ] [ "Image download error" print throw ] recover + "Benchmarks: " print "benchmarks" eval-file benchmarks. - bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail + nl - [ builder-test try-process ] - [ "Builder test error" print throw ] - recover + show-benchmark-deltas - "Boot time: " write "../boot-time" eval-file milli-seconds>time print - "Load time: " write "../load-time" eval-file milli-seconds>time print - "Test time: " write "../test-time" eval-file milli-seconds>time print nl + "benchmarks" ".." copy-file-into - "Did not pass load-everything: " print "../load-everything-vocabs" cat - "Did not pass test-all: " print "../test-all-vocabs" cat - - "Benchmarks: " print - "../benchmarks" [ stdio get contents eval ] with-file-reader benchmarks. - - ] with-file-writer + maybe-release + ] + with-file-writer build-status on ; @@ -149,15 +163,25 @@ SYMBOL: builder-recipients builder-from get >>from builder-recipients get >>to subject >>subject - "../report" file>string >>body + "./report" file>string >>body send ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: compress-image ( -- ) + { "bzip2" my-boot-image-name } to-strings run-process drop ; + : build ( -- ) - [ (build) ] [ drop ] recover - [ send-builder-email ] [ drop "not sending mail" . ] recover ; + [ (build) ] failsafe + builds cd stamp> cd + [ send-builder-email ] [ drop "not sending mail" . ] recover + { "rm" "-rf" "factor" } run-process drop + [ compress-image ] failsafe ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +USE: bootstrap.image.download + : git-pull ( -- desc ) { "git" @@ -173,17 +197,22 @@ SYMBOL: builder-recipients git-id = not ; +: new-image-available? ( -- ? ) + my-boot-image-name need-new-image? + [ download-my-image t ] + [ f ] + if ; + : build-loop ( -- ) builds-check [ builds "/factor" append cd - updates-available? + updates-available? new-image-available? or [ build ] when ] - [ drop ] - recover - 5 minutes>ms sleep + failsafe + 5 minutes sleep build-loop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor new file mode 100644 index 0000000000..6ebe1d625a --- /dev/null +++ b/extra/builder/common/common.factor @@ -0,0 +1,18 @@ + +USING: kernel namespaces io.files sequences vars ; + +IN: builder.common + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builds-dir + +: builds ( -- path ) + builds-dir get + home "/builds" append + or ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: stamp + diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor new file mode 100644 index 0000000000..849d1a54a3 --- /dev/null +++ b/extra/builder/release/release.factor @@ -0,0 +1,116 @@ + +USING: kernel system namespaces sequences splitting combinators + io.files io.launcher + bake combinators.cleave builder.common builder.util ; + +IN: builder.release + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: releases ( -- path ) + builds "releases" path+ + dup exists? not + [ dup make-directory ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: common-files ( -- seq ) + { + "boot.x86.32.image" + "boot.x86.64.image" + "boot.macosx-ppc.boot" + "vm" + "temp" + "logs" + ".git" + ".gitignore" + "Makefile" + "cp_dir" + "unmaintained" + "misc/target" + "misc/wordsize" + "misc/wordsize.c" + "misc/macos-release.sh" + "misc/source-release.sh" + "misc/windows-release.sh" + "misc/version.sh" + } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cpu- ( -- cpu ) cpu "." split "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: extension ( -- extension ) + os + { + { "linux" [ ".tar.gz" ] } + { "winnt" [ ".zip" ] } + { "macosx" [ ".dmg" ] } + } + case ; + +: archive-name ( -- string ) base-name extension append ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ; + +: macosx-archive-cmd ( -- cmd ) + { "hdiutil" "create" + "-srcfolder" "factor" + "-fs" "HFS+" + "-volname" "factor" + archive-name } ; + +: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: archive-cmd ( -- cmd ) + { + { [ windows? ] [ windows-archive-cmd ] } + { [ macosx? ] [ macosx-archive-cmd ] } + { [ unix? ] [ unix-archive-cmd ] } + } + cond ; + +: make-archive ( -- ) archive-cmd to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: remove-common-files ( -- ) + { "rm" "-rf" common-files } to-strings try-process ; + +: remove-factor-app ( -- ) + macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ; + +: release ( -- ) + "factor" + [ + remove-factor-app + remove-common-files + ] + with-directory + make-archive + archive-name releases move-file-into ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: release? ( -- ? ) + { + "./load-everything-vocabs" + "./test-all-vocabs" + } + [ eval-file empty? ] + all? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: maybe-release ( -- ) release? [ release ] when ; \ No newline at end of file diff --git a/extra/builder/server/server.factor b/extra/builder/server/server.factor deleted file mode 100644 index f3ec349557..0000000000 --- a/extra/builder/server/server.factor +++ /dev/null @@ -1,68 +0,0 @@ - -USING: kernel continuations namespaces threads match bake concurrency builder ; - -IN: builder.server - -! : build-server ( -- ) -! receive -! { -! { -! "start" -! [ [ build ] in-thread ] -! } - -! { -! { ?from ?tag "status" } -! [ `{ ?tag ,[ build-status get ] } ?from send ] -! } -! } -! match-cond -! build-server ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! : build-server ( -- ) -! receive -! { -! { -! "start" -! [ -! [ [ build ] [ drop ] recover "idle" build-status set-global ] in-thread -! ] -! } - -! { -! { ?from ?tag "status" } -! [ `{ ?tag ,[ build-status get ] } ?from send ] -! } -! } -! match-cond -! build-server ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! : build-server ( -- ) -! receive -! { -! { -! "start" -! [ -! build-status get "idle" = -! build-status get f = -! or -! [ -! [ [ build ] [ drop ] recover "idle" build-status set-global ] -! in-thread -! ] -! when -! ] -! } - -! { -! { ?from ?tag "status" } -! [ `{ ?tag ,[ build-status get ] } ?from send ] -! } -! } -! match-cond -! build-server ; - diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index f9eb17c565..9682fc1346 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -3,8 +3,8 @@ USING: kernel words namespaces classes parser continuations io io.files io.launcher io.sockets math math.parser combinators sequences splitting quotations arrays strings tools.time - parser-combinators new-slots accessors assocs.lib - combinators.cleave bake calendar ; + sequences.deep new-slots accessors assocs.lib + combinators.cleave bake calendar calendar.format ; IN: builder.util @@ -83,4 +83,29 @@ TUPLE: process* arguments stdin stdout stderr timeout ; USING: bootstrap.image bootstrap.image.download io.streams.null ; -: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ; \ No newline at end of file +: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: longer? ( seq seq -- ? ) [ length ] 2apply > ; + +: maybe-tail* ( seq n -- seq ) + 2dup longer? + [ tail* ] + [ drop ] + if ; + +: cat-n ( file n -- ) + [ file-lines ] [ ] bi* + maybe-tail* + [ print ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: prettyprint + +: to-file ( object file -- ) [ . ] with-file-writer ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: failsafe ( quot -- ) [ drop ] recover ; diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 7cf6132925..963379896d 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl -opengl.gl opengl.glu shuffle http.client vectors timers +opengl.gl opengl.glu shuffle http.client vectors namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting combinators tools.time system combinators.lib combinators.cleave float-arrays continuations opengl.demo-support multiline diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor old mode 100644 new mode 100755 index 7c77ed98af..49a0f9254a --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -17,7 +17,7 @@ IN: bunny.model } cond (parse-model) ] when* ; -: parse-model ( stream -- vs is ) +: parse-model ( -- vs is ) 100000 100000 (parse-model) ; : n ( vs triple -- n ) @@ -39,12 +39,12 @@ IN: bunny.model [ normals ] 2keep 3array ] time ; -: model-path "bun_zipper.ply" ; +: model-path "bun_zipper.ply" temp-file ; : model-url "http://factorcode.org/bun_zipper.ply" ; : maybe-download ( -- path ) - model-path resource-path dup exists? [ + model-path dup exists? [ "Downloading bunny from " write model-url dup print flush over download-to diff --git a/extra/calendar/authors.txt b/extra/calendar/authors.txt index 1901f27a24..7c1b2f2279 100644 --- a/extra/calendar/authors.txt +++ b/extra/calendar/authors.txt @@ -1 +1 @@ -Slava Pestov +Doug Coleman diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index a3ae5f115a..f700d244f5 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,15 @@ USING: arrays calendar kernel math sequences tools.test -continuations system io.streams.string ; +continuations system ; -[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ f ] [ 2004 12 32 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 2 30 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2003 2 29 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 -2 9 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 0 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 24 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 60 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 59 60 0 valid-timestamp? ] unit-test +[ t ] [ now valid-timestamp? ] unit-test [ f ] [ 1900 leap-year? ] unit-test [ t ] [ 1904 leap-year? ] unit-test @@ -16,148 +17,144 @@ continuations system io.streams.string ; [ f ] [ 2001 leap-year? ] unit-test [ f ] [ 2006 leap-year? ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt - 2006 10 10 0 0 1 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 100 seconds +dt - 2006 10 10 0 1 40 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 seconds +dt - 2006 10 9 23 58 20 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 86400 seconds +dt - 2006 10 11 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 1 seconds time+ + 2006 10 10 0 0 1 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 100 seconds time+ + 2006 10 10 0 1 40 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -100 seconds time+ + 2006 10 9 23 58 20 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 86400 seconds time+ + 2006 10 11 0 0 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt - 2006 10 10 0 10 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10.5 minutes +dt - 2006 10 10 0 10 30 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 3/4 minutes +dt - 2006 10 10 0 0 45 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -3/4 minutes +dt - 2006 10 9 23 59 15 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 10 minutes time+ + 2006 10 10 0 10 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 10.5 minutes time+ + 2006 10 10 0 10 30 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 3/4 minutes time+ + 2006 10 10 0 0 45 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -3/4 minutes time+ + 2006 10 9 23 59 15 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt - 2006 10 15 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -10 minutes +dt - 2006 10 9 23 50 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 minutes +dt - 2006 10 9 22 20 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 7200 minutes time+ + 2006 10 15 0 0 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -10 minutes time+ + 2006 10 9 23 50 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -100 minutes time+ + 2006 10 9 22 20 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt - 2006 1 1 1 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 hours +dt - 2006 1 2 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 hours +dt - 2005 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 hours +dt - 2006 1 1 12 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 72 hours +dt - 2006 1 4 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 hours time+ + 2006 1 1 1 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 24 hours time+ + 2006 1 2 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -24 hours time+ + 2005 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 12 hours time+ + 2006 1 1 12 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 72 hours time+ + 2006 1 4 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt - 2006 1 2 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 days +dt - 2005 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 365 days +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -365 days +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 365 days +dt - 2004 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 366 days +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 days time+ + 2006 1 2 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 days time+ + 2005 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 365 days time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -365 days time+ + 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 365 days time+ + 2004 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 366 days time+ + 2005 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt - 2006 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 months +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 months +dt - 2008 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 13 months +dt - 2007 2 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 months +dt - 2006 2 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 months +dt - 2006 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 months +dt - 2005 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -2 months +dt - 2005 11 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -13 months +dt - 2004 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 months +dt - 2004 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 make-timestamp 12 months +dt - 2005 3 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 make-timestamp -12 months +dt - 2003 3 1 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 11 months time+ + 2006 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 12 months time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 24 months time+ + 2008 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 13 months time+ + 2007 2 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 months time+ + 2006 2 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 0 months time+ + 2006 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 months time+ + 2005 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -2 months time+ + 2005 11 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -13 months time+ + 2004 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -24 months time+ + 2004 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 2 29 0 0 0 0 12 months time+ + 2005 3 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 2 29 0 0 0 0 -12 months time+ + 2003 3 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt - 2006 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 years +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 years +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -100 years +dt - 1906 1 1 0 0 0 0 make-timestamp = ] unit-test -! [ t ] [ 2004 2 29 0 0 0 0 make-timestamp -1 years +dt - ! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 0 years time+ + 2006 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 years time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 years time+ + 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -100 years time+ + 1906 1 1 0 0 0 0 = ] unit-test +! [ t ] [ 2004 2 29 0 0 0 0 -1 years time+ +! 2003 2 28 0 0 0 0 = ] unit-test -[ 5 ] [ 2006 7 14 0 0 0 0 make-timestamp day-of-week ] unit-test +[ 5 ] [ 2006 7 14 0 0 0 0 day-of-week ] unit-test -[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 make-timestamp ] 3keep 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 ] 3keep 0 0 0 0 = ] unit-test -[ 1 ] [ 2006 1 1 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 60 ] [ 2004 2 29 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 61 ] [ 2004 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 366 ] [ 2004 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 365 ] [ 2003 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 60 ] [ 2003 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test +[ 1 ] [ 2006 1 1 0 0 0 0 day-of-year ] unit-test +[ 60 ] [ 2004 2 29 0 0 0 0 day-of-year ] unit-test +[ 61 ] [ 2004 3 1 0 0 0 0 day-of-year ] unit-test +[ 366 ] [ 2004 12 31 0 0 0 0 day-of-year ] unit-test +[ 365 ] [ 2003 12 31 0 0 0 0 day-of-year ] unit-test +[ 60 ] [ 2003 3 1 0 0 0 0 day-of-year ] unit-test -[ t ] [ 2004 12 31 0 0 0 0 make-timestamp dup = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 10 seconds 5 years +dts +dt - 2009 1 1 0 0 10 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp -10 seconds -5 years +dts +dt - 1998 12 31 23 59 50 0 make-timestamp = ] unit-test +[ t ] [ 2004 12 31 0 0 0 0 dup = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 10 seconds 5 years time+ time+ + 2009 1 1 0 0 10 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 -10 seconds -5 years time+ time+ + 1998 12 31 23 59 50 0 = ] unit-test -[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone - 2004 1 1 11 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 5 0 0 -11 make-timestamp 0 convert-timezone - 2004 1 1 16 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 23 0 0 9.5 make-timestamp 0 convert-timezone - 2004 1 1 13 30 0 0 make-timestamp = ] unit-test +[ t ] [ 2004 1 1 23 0 0 12 0 convert-timezone + 2004 1 1 11 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 5 0 0 -11 0 convert-timezone + 2004 1 1 16 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 23 0 0 9+1/2 0 convert-timezone + 2004 1 1 13 30 0 0 = ] unit-test -[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp - 2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test +[ 0 ] [ 2004 1 1 13 30 0 0 + 2004 1 1 12 30 0 -1 <=> ] unit-test -[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp - 2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test +[ 1 ] [ 2004 1 1 13 30 0 0 + 2004 1 1 12 30 0 0 <=> ] unit-test -[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp - 2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test +[ -1 ] [ 2004 1 1 12 30 0 0 + 2004 1 1 13 30 0 0 <=> ] unit-test -[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp - 2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test +[ 1 ] [ 2005 1 1 12 30 0 0 + 2004 1 1 13 30 0 0 <=> ] unit-test -[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test -[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test -[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test -[ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test +[ t ] [ now timestamp>millis millis - 1000 < ] unit-test +[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test +[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test +[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test -[ 0 ] [ - "Z" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +: checktime+ now dup clone [ rot time+ drop ] keep = ; -[ 1 ] [ - "+01" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 seconds checktime+ ] unit-test -[ -1 ] [ - "-01" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 minutes checktime+ ] unit-test -[ -1-1/2 ] [ - "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 hours checktime+ ] unit-test -[ 1+1/2 ] [ - "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 days checktime+ ] unit-test + +[ t ] [ 5 weeks checktime+ ] unit-test + +[ t ] [ 5 months checktime+ ] unit-test + +[ t ] [ 5 years checktime+ ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 5b89d6e8c5..2b80a8dce6 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -1,20 +1,21 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays hashtables io io.streams.string kernel math -math.vectors math.functions math.parser namespaces sequences -strings tuples system debugger combinators vocabs.loader -calendar.backend structs alien.c-types math.vectors -math.ranges shuffle ; +USING: arrays kernel math math.functions namespaces sequences +strings tuples system vocabs.loader calendar.backend threads +new-slots accessors combinators ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; C: timestamp -TUPLE: dt year month day hour minute second ; +: ( year month day -- timestamp ) + 0 0 0 gmt-offset ; -C:
dt +TUPLE: duration year month day hour minute second ; + +C: duration : month-names { @@ -36,9 +37,14 @@ C:
dt : day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ; : day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ; -: average-month ( -- x ) - #! length of average month in days - 30.41666666666667 ; +: average-month 30+5/12 ; inline +: months-per-year 12 ; inline +: days-per-year 3652425/10000 ; inline +: hours-per-year 876582/100 ; inline +: minutes-per-year 5259492/10 ; inline +: seconds-per-year 31556952 ; inline + + + : julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 @@ -74,38 +82,31 @@ SYMBOL: m e get 153 m get * 2 + 5 /i - 1+ ] with-scope ; -: set-date ( year month day timestamp -- ) - [ set-timestamp-day ] keep - [ set-timestamp-month ] keep - set-timestamp-year ; - -: set-time ( hour minute second timestamp -- ) - [ set-timestamp-second ] keep - [ set-timestamp-minute ] keep - set-timestamp-hour ; - : >date< ( timestamp -- year month day ) - [ timestamp-year ] keep - [ timestamp-month ] keep - timestamp-day ; + { year>> month>> day>> } get-slots ; : >time< ( timestamp -- hour minute second ) - [ timestamp-hour ] keep - [ timestamp-minute ] keep - timestamp-second ; + { hour>> minute>> second>> } get-slots ; -: zero-dt ( --
) 0 0 0 0 0 0
; -: years ( n -- dt ) zero-dt [ set-dt-year ] keep ; -: months ( n -- dt ) zero-dt [ set-dt-month ] keep ; -: days ( n -- dt ) zero-dt [ set-dt-day ] keep ; +: instant ( -- dt ) 0 0 0 0 0 0 ; +: years ( n -- dt ) instant swap >>year ; +: months ( n -- dt ) instant swap >>month ; +: days ( n -- dt ) instant swap >>day ; : weeks ( n -- dt ) 7 * days ; -: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ; -: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ; -: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ; -: milliseconds ( n -- dt ) 1000 /f seconds ; +: hours ( n -- dt ) instant swap >>hour ; +: minutes ( n -- dt ) instant swap >>minute ; +: seconds ( n -- dt ) instant swap >>second ; +: milliseconds ( n -- dt ) 1000 / seconds ; -: julian-day-number>timestamp ( n -- timestamp ) - julian-day-number>date 0 0 0 0 ; +GENERIC: leap-year? ( obj -- ? ) + +M: integer leap-year? ( year -- ? ) + dup 100 mod zero? 400 4 ? mod zero? ; + +M: timestamp leap-year? ( timestamp -- ? ) + year>> leap-year? ; + +integer ] 2keep rem ; + [ / floor >integer ] 2keep rem ; : float>whole-part ( float -- int float ) [ floor >integer ] keep over - ; -GENERIC: leap-year? ( obj -- ? ) -M: integer leap-year? ( year -- ? ) - dup 100 mod zero? 400 4 ? mod zero? ; - -M: timestamp leap-year? ( timestamp -- ? ) - timestamp-year leap-year? ; - : adjust-leap-year ( timestamp -- timestamp ) - dup >date< 29 = swap 2 = and swap leap-year? not and [ - dup >r timestamp-year 3 1 r> [ set-date ] keep - ] when ; + dup day>> 29 = over month>> 2 = pick leap-year? not and and + [ 3 >>month 1 >>day ] when ; + +: unless-zero >r dup zero? [ drop ] r> if ; inline M: integer +year ( timestamp n -- timestamp ) - over timestamp-year + swap [ set-timestamp-year ] keep - adjust-leap-year ; + [ [ + ] curry change-year adjust-leap-year ] unless-zero ; + M: real +year ( timestamp n -- timestamp ) - float>whole-part rot swap 365.2425 * +day swap +year ; + [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ; + +: months/years ( n -- months years ) + 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline M: integer +month ( timestamp n -- timestamp ) - over timestamp-month + 12 /rem - dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month - +year ; + [ over month>> + months/years >r >>month r> +year ] unless-zero ; + M: real +month ( timestamp n -- timestamp ) - float>whole-part rot swap average-month * +day swap +month ; + [ float>whole-part swapd average-month * +day swap +month ] unless-zero ; M: integer +day ( timestamp n -- timestamp ) - swap [ - >date< julian-day-number + julian-day-number>timestamp - ] keep swap >r >time< r> [ set-time ] keep ; + [ + over >date< julian-day-number + julian-day-number>date + >r >r >>year r> >>month r> >>day + ] unless-zero ; + M: real +day ( timestamp n -- timestamp ) - float>whole-part rot swap 24 * +hour swap +day ; + [ float>whole-part swapd 24 * +hour swap +day ] unless-zero ; + +: hours/days ( n -- hours days ) + 24 /rem swap ; M: integer +hour ( timestamp n -- timestamp ) - over timestamp-hour + 24 /rem pick set-timestamp-hour - +day ; + [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ; + M: real +hour ( timestamp n -- timestamp ) - float>whole-part rot swap 60 * +minute swap +hour ; + float>whole-part swapd 60 * +minute swap +hour ; + +: minutes/hours ( n -- minutes hours ) + 60 /rem swap ; M: integer +minute ( timestamp n -- timestamp ) - over timestamp-minute + 60 /rem pick - set-timestamp-minute +hour ; + [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ; + M: real +minute ( timestamp n -- timestamp ) - float>whole-part rot swap 60 * +second swap +minute ; + [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ; + +: seconds/minutes ( n -- seconds minutes ) + 60 /rem swap >integer ; M: number +second ( timestamp n -- timestamp ) - over timestamp-second + 60 /rem >r >integer r> - pick set-timestamp-second +minute ; + [ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ; -: +dt ( timestamp dt -- timestamp ) - dupd - [ dt-second +second ] keep - [ dt-minute +minute ] keep - [ dt-hour +hour ] keep - [ dt-day +day ] keep - [ dt-month +month ] keep - dt-year +year - swap timestamp-gmt-offset over set-timestamp-gmt-offset ; +: (time+) + [ second>> +second ] keep + [ minute>> +minute ] keep + [ hour>> +hour ] keep + [ day>> +day ] keep + [ month>> +month ] keep + [ year>> +year ] keep ; inline -: make-timestamp ( year month day hour minute second gmt-offset -- timestamp ) - [ 0 seconds +dt ] keep - [ = [ "invalid timestamp" throw ] unless ] keep ; +: +slots [ 2apply + ] curry 2keep ; inline -: make-date ( year month day -- timestamp ) - 0 0 0 gmt-offset make-timestamp ; +PRIVATE> -: array>dt ( vec -- dt ) { dt f } swap append >tuple ; -: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ; +GENERIC# time+ 1 ( time dt -- time ) + +M: timestamp time+ + >r clone r> (time+) drop ; + +M: duration time+ + dup timestamp? [ + swap time+ + ] [ + [ year>> ] +slots + [ month>> ] +slots + [ day>> ] +slots + [ hour>> ] +slots + [ minute>> ] +slots + [ second>> ] +slots + 2drop + ] if ; : dt>years ( dt -- x ) #! Uses average month/year length since dt loses calendar #! data - tuple-slots - { 1 12 365.2425 8765.82 525949.2 31556952.0 } - v/ sum ; + 0 swap + [ year>> + ] keep + [ month>> months-per-year / + ] keep + [ day>> days-per-year / + ] keep + [ hour>> hours-per-year / + ] keep + [ minute>> minutes-per-year / + ] keep + second>> seconds-per-year / + ; -: dt>months ( dt -- x ) dt>years 12 * ; -: dt>days ( dt -- x ) dt>years 365.2425 * ; -: dt>hours ( dt -- x ) dt>years 8765.82 * ; -: dt>minutes ( dt -- x ) dt>years 525949.2 * ; -: dt>seconds ( dt -- x ) dt>years 31556952 * ; -: dt>milliseconds ( dt -- x ) dt>years 31556952000 * ; +M: duration <=> [ dt>years ] compare ; + +: dt>months ( dt -- x ) dt>years months-per-year * ; +: dt>days ( dt -- x ) dt>years days-per-year * ; +: dt>hours ( dt -- x ) dt>years hours-per-year * ; +: dt>minutes ( dt -- x ) dt>years minutes-per-year * ; +: dt>seconds ( dt -- x ) dt>years seconds-per-year * ; +: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ; : convert-timezone ( timestamp n -- timestamp ) - [ over timestamp-gmt-offset - hours +dt ] keep - over set-timestamp-gmt-offset ; + over gmt-offset>> over = [ drop ] [ + [ over gmt-offset>> - hours time+ ] keep >>gmt-offset + ] if ; : >local-time ( timestamp -- timestamp ) gmt-offset convert-timezone ; @@ -216,39 +240,54 @@ M: number +second ( timestamp n -- timestamp ) M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; -: timestamp- ( timestamp timestamp -- seconds ) - #! Exact calendar-time difference +: (time-) ( timestamp timestamp -- n ) [ >gmt ] 2apply [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; +GENERIC: time- ( time1 time2 -- time ) + +M: timestamp time- + #! Exact calendar-time difference + (time-) seconds ; + +: before ( dt -- -dt ) + [ year>> neg ] keep + [ month>> neg ] keep + [ day>> neg ] keep + [ hour>> neg ] keep + [ minute>> neg ] keep + second>> neg + ; + +M: duration time- + before time+ ; + +: 0 0 0 0 0 0 0 ; + +: valid-timestamp? ( timestamp -- ? ) + clone 0 >>gmt-offset + dup time- time+ = ; + : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; + 1970 1 1 0 0 0 0 ; foldable -: unix-time>timestamp ( n -- timestamp ) - >r unix-1970 r> seconds +dt ; - -: timestamp>unix-time ( timestamp -- n ) - unix-1970 timestamp- >integer ; - -: timestamp>timeval ( timestamp -- timeval ) - timestamp>unix-time 1000 * make-timeval ; - -: timeval>timestamp ( timeval -- timestamp ) - [ timeval-sec ] keep - timeval-usec 1000000 / + unix-time>timestamp ; +: millis>timestamp ( n -- timestamp ) + >r unix-1970 r> milliseconds time+ ; +: timestamp>millis ( timestamp -- n ) + unix-1970 (time-) 1000 * >integer ; : gmt ( -- timestamp ) #! GMT time, right now - unix-1970 millis 1000 /f seconds +dt ; + unix-1970 millis milliseconds time+ ; : now ( -- timestamp ) gmt >local-time ; -: before ( dt -- -dt ) tuple-slots vneg array>dt ; -: from-now ( dt -- timestamp ) now swap +dt ; -: ago ( dt -- timestamp ) before from-now ; -: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; +: from-now ( dt -- timestamp ) now swap time+ ; +: ago ( dt -- timestamp ) now swap time- ; + +: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline : zeller-congruence ( year month day -- n ) #! Zeller Congruence @@ -262,7 +301,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) GENERIC: days-in-year ( obj -- n ) M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; -M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ; +M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; GENERIC: days-in-month ( obj -- n ) @@ -274,7 +313,7 @@ M: array days-in-month ( obj -- n ) ] if ; M: timestamp days-in-month ( timestamp -- n ) - { timestamp-year timestamp-month } get-slots 2array days-in-month ; + >date< drop 2array days-in-month ; GENERIC: day-of-week ( obj -- n ) @@ -291,156 +330,20 @@ M: array day-of-year ( array -- n ) 3dup day-counts rot head-slice sum + swap leap-year? [ -roll - pick 3 1 make-date >r make-date r> - <=> 0 >= [ 1+ ] when + pick 3 1 >r r> + after=? [ 1+ ] when ] [ - 3nip + >r 3drop r> ] if ; M: timestamp day-of-year ( timestamp -- n ) - { timestamp-year timestamp-month timestamp-day } get-slots - 3array day-of-year ; - -GENERIC: day. ( obj -- ) - -M: integer day. ( n -- ) - number>string dup length 2 < [ bl ] when write ; - -M: timestamp day. ( timestamp -- ) - timestamp-day day. ; - -GENERIC: month. ( obj -- ) - -M: array month. ( pair -- ) - first2 - [ month-names nth write bl number>string print ] 2keep - [ 1 zeller-congruence ] 2keep - 2array days-in-month day-abbreviations2 " " join print - over " " concat write - [ - [ 1+ day. ] keep - 1+ + 7 mod zero? [ nl ] [ bl ] if - ] with each nl ; - -M: timestamp month. ( timestamp -- ) - { timestamp-year timestamp-month } get-slots 2array month. ; - -GENERIC: year. ( obj -- ) - -M: integer year. ( n -- ) - 12 [ 1+ 2array month. nl ] with each ; - -M: timestamp year. ( timestamp -- ) - timestamp-year year. ; - -: pad-00 number>string 2 CHAR: 0 pad-left ; - -: write-00 pad-00 write ; - -: (timestamp>string) ( timestamp -- ) - dup day-of-week day-abbreviations3 nth write ", " write - dup timestamp-day number>string write bl - dup timestamp-month month-abbreviations nth write bl - dup timestamp-year number>string write bl - dup timestamp-hour write-00 ":" write - dup timestamp-minute write-00 ":" write - timestamp-second >fixnum write-00 ; - -: timestamp>string ( timestamp -- str ) - [ (timestamp>string) ] with-string-writer ; - -: (write-gmt-offset) ( ratio -- ) - 1 /mod swap write-00 60 * write-00 ; - -: write-gmt-offset ( gmt-offset -- ) - { - { [ dup zero? ] [ drop "GMT" write ] } - { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } - { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } - } cond ; - -: timestamp>rfc822-string ( timestamp -- str ) - #! RFC822 timestamp format - #! Example: Tue, 15 Nov 1994 08:12:31 +0200 - [ - dup (timestamp>string) - " " write - timestamp-gmt-offset write-gmt-offset - ] with-string-writer ; - -: timestamp>http-string ( timestamp -- str ) - #! http timestamp format - #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt timestamp>rfc822-string ; - -: write-rfc3339-gmt-offset ( n -- ) - dup zero? [ drop "Z" write ] [ - dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if - 60 * 60 /mod swap write-00 CHAR: : write1 write-00 - ] if ; - -: (timestamp>rfc3339) ( timestamp -- ) - dup timestamp-year number>string write CHAR: - write1 - dup timestamp-month write-00 CHAR: - write1 - dup timestamp-day write-00 CHAR: T write1 - dup timestamp-hour write-00 CHAR: : write1 - dup timestamp-minute write-00 CHAR: : write1 - dup timestamp-second >fixnum write-00 - timestamp-gmt-offset write-rfc3339-gmt-offset ; - -: timestamp>rfc3339 ( timestamp -- str ) - [ (timestamp>rfc3339) ] with-string-writer ; - -: expect ( str -- ) - read1 swap member? [ "Parse error" throw ] unless ; - -: read-00 2 read string>number ; - -: read-0000 4 read string>number ; - -: read-rfc3339-gmt-offset ( -- n ) - read1 dup CHAR: Z = [ drop 0 ] [ - { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case - read-00 - read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case - 60 / + * - ] if ; - -: (rfc3339>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day - "Tt" expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second - read-rfc3339-gmt-offset ! timezone - ; - -: rfc3339>timestamp ( str -- timestamp ) - [ (rfc3339>timestamp) ] with-string-reader ; - -: file-time-string ( timestamp -- string ) - [ - [ timestamp-month month-abbreviations nth write ] keep bl - [ timestamp-day number>string 2 32 pad-left write ] keep bl - dup now [ timestamp-year ] 2apply = [ - [ timestamp-hour write-00 ] keep ":" write - timestamp-minute write-00 - ] [ - timestamp-year number>string 5 32 pad-left write - ] if - ] with-string-writer ; + >date< 3array day-of-year ; : day-offset ( timestamp m -- timestamp n ) over day-of-week - ; inline : day-this-week ( timestamp n -- timestamp ) - day-offset days +dt ; + day-offset days time+ ; : sunday ( timestamp -- timestamp ) 0 day-this-week ; : monday ( timestamp -- timestamp ) 1 day-this-week ; @@ -451,21 +354,26 @@ M: timestamp year. ( timestamp -- ) : saturday ( timestamp -- timestamp ) 6 day-this-week ; : beginning-of-day ( timestamp -- new-timestamp ) - clone dup >r 0 0 0 r> - { set-timestamp-hour set-timestamp-minute set-timestamp-second } - set-slots ; inline + clone + 0 >>hour + 0 >>minute + 0 >>second ; inline : beginning-of-month ( timestamp -- new-timestamp ) - beginning-of-day 1 over set-timestamp-day ; + beginning-of-day 1 >>day ; : beginning-of-week ( timestamp -- new-timestamp ) beginning-of-day sunday ; : beginning-of-year ( timestamp -- new-timestamp ) - beginning-of-month 1 over set-timestamp-month ; + beginning-of-month 1 >>month ; -: seconds-since-midnight ( timestamp -- x ) - dup beginning-of-day timestamp- ; +: time-since-midnight ( timestamp -- duration ) + dup beginning-of-day time- ; + +M: timestamp sleep-until timestamp>millis sleep-until ; + +M: duration sleep from-now sleep-until ; { { [ unix? ] [ "calendar.unix" ] } diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor new file mode 100755 index 0000000000..eb32ce5b43 --- /dev/null +++ b/extra/calendar/format/format-tests.factor @@ -0,0 +1,22 @@ +IN: calendar.format.tests +USING: calendar.format tools.test io.streams.string ; + +[ 0 ] [ + "Z" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ 1 ] [ + "+01" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ -1 ] [ + "-01" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ -1-1/2 ] [ + "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ 1+1/2 ] [ + "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor new file mode 100755 index 0000000000..75ceea8ea2 --- /dev/null +++ b/extra/calendar/format/format.factor @@ -0,0 +1,138 @@ +IN: calendar.format +USING: math math.parser kernel sequences io calendar +accessors arrays io.streams.string combinators accessors ; + +GENERIC: day. ( obj -- ) + +M: integer day. ( n -- ) + number>string dup length 2 < [ bl ] when write ; + +M: timestamp day. ( timestamp -- ) + day>> day. ; + +GENERIC: month. ( obj -- ) + +M: array month. ( pair -- ) + first2 + [ month-names nth write bl number>string print ] 2keep + [ 1 zeller-congruence ] 2keep + 2array days-in-month day-abbreviations2 " " join print + over " " concat write + [ + [ 1+ day. ] keep + 1+ + 7 mod zero? [ nl ] [ bl ] if + ] with each nl ; + +M: timestamp month. ( timestamp -- ) + { year>> month>> } get-slots 2array month. ; + +GENERIC: year. ( obj -- ) + +M: integer year. ( n -- ) + 12 [ 1+ 2array month. nl ] with each ; + +M: timestamp year. ( timestamp -- ) + year>> year. ; + +: pad-00 number>string 2 CHAR: 0 pad-left ; + +: write-00 pad-00 write ; + +: (timestamp>string) ( timestamp -- ) + dup day-of-week day-abbreviations3 nth write ", " write + dup day>> number>string write bl + dup month>> month-abbreviations nth write bl + dup year>> number>string write bl + dup hour>> write-00 ":" write + dup minute>> write-00 ":" write + second>> >integer write-00 ; + +: timestamp>string ( timestamp -- str ) + [ (timestamp>string) ] with-string-writer ; + +: (write-gmt-offset) ( ratio -- ) + 1 /mod swap write-00 60 * write-00 ; + +: write-gmt-offset ( gmt-offset -- ) + { + { [ dup zero? ] [ drop "GMT" write ] } + { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } + { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } + } cond ; + +: timestamp>rfc822-string ( timestamp -- str ) + #! RFC822 timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 +0200 + [ + dup (timestamp>string) + " " write + gmt-offset>> write-gmt-offset + ] with-string-writer ; + +: timestamp>http-string ( timestamp -- str ) + #! http timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 GMT + >gmt timestamp>rfc822-string ; + +: write-rfc3339-gmt-offset ( n -- ) + dup zero? [ drop "Z" write ] [ + dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if + 60 * 60 /mod swap write-00 CHAR: : write1 write-00 + ] if ; + +: (timestamp>rfc3339) ( timestamp -- ) + dup year>> number>string write CHAR: - write1 + dup month>> write-00 CHAR: - write1 + dup day>> write-00 CHAR: T write1 + dup hour>> write-00 CHAR: : write1 + dup minute>> write-00 CHAR: : write1 + dup second>> >fixnum write-00 + gmt-offset>> write-rfc3339-gmt-offset ; + +: timestamp>rfc3339 ( timestamp -- str ) + [ (timestamp>rfc3339) ] with-string-writer ; + +: expect ( str -- ) + read1 swap member? [ "Parse error" throw ] unless ; + +: read-00 2 read string>number ; + +: read-0000 4 read string>number ; + +: read-rfc3339-gmt-offset ( -- n ) + read1 dup CHAR: Z = [ drop 0 ] [ + { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case + read-00 + read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case + 60 / + * + ] if ; + +: (rfc3339>timestamp) ( -- timestamp ) + read-0000 ! year + "-" expect + read-00 ! month + "-" expect + read-00 ! day + "Tt" expect + read-00 ! hour + ":" expect + read-00 ! minute + ":" expect + read-00 ! second + read-rfc3339-gmt-offset ! timezone + ; + +: rfc3339>timestamp ( str -- timestamp ) + [ (rfc3339>timestamp) ] with-string-reader ; + +: file-time-string ( timestamp -- string ) + [ + [ month>> month-abbreviations nth write ] keep bl + [ day>> number>string 2 32 pad-left write ] keep bl + dup now [ year>> ] 2apply = [ + [ hour>> write-00 ] keep ":" write + minute>> write-00 + ] [ + year>> number>string 5 32 pad-left write + ] if + ] with-string-writer ; diff --git a/extra/calendar/format/summary.txt b/extra/calendar/format/summary.txt new file mode 100644 index 0000000000..b5360f7868 --- /dev/null +++ b/extra/calendar/format/summary.txt @@ -0,0 +1 @@ +Formatting dates and times diff --git a/extra/calendar/model/model.factor b/extra/calendar/model/model.factor index 855b0cd815..aa295e0f75 100755 --- a/extra/calendar/model/model.factor +++ b/extra/calendar/model/model.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: calendar namespaces models threads init ; +USING: calendar namespaces models threads kernel init ; IN: calendar.model SYMBOL: time @@ -9,7 +9,8 @@ SYMBOL: time now time get set-model 1000 sleep (time-thread) ; -: time-thread ( -- ) [ (time-thread) ] in-thread ; +: time-thread ( -- ) + [ (time-thread) ] "Time model update" spawn drop ; f time set-global [ time-thread ] "calendar.model" add-init-hook diff --git a/extra/calendar/model/summary.txt b/extra/calendar/model/summary.txt new file mode 100644 index 0000000000..4cc85fd2b9 --- /dev/null +++ b/extra/calendar/model/summary.txt @@ -0,0 +1 @@ +Timestamp model updated every second diff --git a/extra/calendar/summary.txt b/extra/calendar/summary.txt index 4cc85fd2b9..63d1c3fec3 100644 --- a/extra/calendar/summary.txt +++ b/extra/calendar/summary.txt @@ -1 +1 @@ -Timestamp model updated every second +Operations on timestamps and durations diff --git a/extra/calendar/unix/unix-tests.factor b/extra/calendar/unix/unix-tests.factor deleted file mode 100644 index a35a60c6f3..0000000000 --- a/extra/calendar/unix/unix-tests.factor +++ /dev/null @@ -1,13 +0,0 @@ -USING: alien alien.c-types calendar calendar.unix -kernel math tools.test ; - -[ t ] [ 239293000 [ - unix-time>timestamp timestamp>timeval - timeval>timestamp timestamp>timeval *ulong -] keep = ] unit-test - - -[ t ] [ 23929000.3 [ - unix-time>timestamp timestamp>timeval - timeval>timestamp timestamp>timeval *ulong -] keep >bignum = ] unit-test diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor index 4e1833af06..30e22c487b 100644 --- a/extra/calendar/unix/unix.factor +++ b/extra/calendar/unix/unix.factor @@ -1,5 +1,7 @@ + USING: alien alien.c-types arrays calendar.backend -kernel structs math unix namespaces ; + kernel structs math unix.time namespaces ; + IN: calendar.unix TUPLE: unix-calendar ; diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor old mode 100644 new mode 100755 index 1f2436cf5d..df72572c67 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -3,7 +3,7 @@ ! USING: kernel tools.test math channels channels.private sequences threads sorting ; -IN: temporary +IN: channels.tests { V{ 10 } } [ V{ } clone diff --git a/extra/channels/channels.factor b/extra/channels/channels.factor old mode 100644 new mode 100755 index 07b5d2f5d5..8fe36ab454 --- a/extra/channels/channels.factor +++ b/extra/channels/channels.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Channels - based on ideas from newsqueak -USING: kernel sequences sequences.lib threads continuations random math ; +USING: kernel sequences sequences.lib threads continuations +random math ; IN: channels TUPLE: channel receivers senders ; @@ -16,16 +17,17 @@ GENERIC: from ( channel -- value ) @@ -36,5 +38,5 @@ M: channel to ( value channel -- ) M: channel from ( channel -- value ) [ notify channel-senders - dup empty? [ stop ] [ (from) ] if - ] curry callcc1 ; + dup empty? [ drop ] [ (from) ] if + ] curry "channel receive" suspend ; diff --git a/extra/channels/examples/examples.factor b/extra/channels/examples/examples.factor index 87b755614a..1e51fb06d8 100755 --- a/extra/channels/examples/examples.factor +++ b/extra/channels/examples/examples.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Examples of using channels -USING: kernel concurrency channels math namespaces locals -sequences ; +USING: kernel threads channels math namespaces +locals sequences ; IN: channels.examples : (counter) ( channel n -- ) @@ -13,7 +13,7 @@ IN: channels.examples 2 (counter) ; : counter-test ( -- n1 n2 n3 ) - [ counter ] spawn drop + dup [ counter ] curry "Counter" spawn drop [ from ] keep [ from ] keep from ; : filter ( send prime recv -- ) @@ -24,21 +24,21 @@ IN: channels.examples from swap dupd mod zero? not [ swap to ] [ 2drop ] if ] 3keep filter ; -:: (sieve) | prime c | ( prime c -- ) +:: (sieve) ( prime c -- ) [let | p [ c from ] newc [ ] | p prime to - [ newc p c filter ] spawn drop + [ newc p c filter ] "Filter" spawn drop prime newc (sieve) ] ; : sieve ( prime -- ) #! Send prime numbers to 'prime' channel - [ counter ] spawn drop + dup [ counter ] curry "Counter" spawn drop (sieve) ; : sieve-test ( -- seq ) - [ sieve ] spawn drop + dup [ sieve ] curry "Sieve" spawn drop V{ } clone swap [ from swap push ] 2keep [ from swap push ] 2keep diff --git a/extra/channels/remote/remote-tests.factor b/extra/channels/remote/remote-tests.factor index 58a70fbf62..03967c954e 100644 --- a/extra/channels/remote/remote-tests.factor +++ b/extra/channels/remote/remote-tests.factor @@ -3,7 +3,7 @@ ! USING: kernel tools.test math assocs channels channels.remote channels.remote.private ; -IN: temporary +IN: channels.remote.tests { t } [ remote-channels assoc? diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor old mode 100644 new mode 100755 index 4f483b8775..2d8d003b8d --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -3,7 +3,8 @@ ! ! Remote Channels USING: kernel init namespaces assocs arrays random -sequences channels match concurrency concurrency.distributed ; +sequences channels match concurrency.messaging +concurrency.distributed threads ; IN: channels.remote : start-channel-node ( -- ) - "remote-channels" get-process [ - [ channel-process ] spawn "remote-channels" swap register-process + "remote-channels" get-process [ + "remote-channels" + [ channel-process t ] "Remote channels" spawn-server + register-process ] unless ; TUPLE: remote-channel node id ; @@ -49,12 +52,12 @@ TUPLE: remote-channel node id ; C: remote-channel M: remote-channel to ( value remote-channel -- ) - dup >r [ \ to , remote-channel-id , , ] { } make r> + [ [ \ to , remote-channel-id , , ] { } make ] keep remote-channel-node "remote-channels" send-synchronous no-channel = [ no-channel throw ] when ; M: remote-channel from ( remote-channel -- value ) - dup >r [ \ from , remote-channel-id , ] { } make r> + [ [ \ from , remote-channel-id , ] { } make ] keep remote-channel-node "remote-channels" send-synchronous dup no-channel = [ no-channel throw ] when* ; diff --git a/extra/channels/sniffer/bsd/bsd.factor b/extra/channels/sniffer/bsd/bsd.factor old mode 100644 new mode 100755 index 0ba267bb03..f986f11484 --- a/extra/channels/sniffer/bsd/bsd.factor +++ b/extra/channels/sniffer/bsd/bsd.factor @@ -2,12 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Wrap a sniffer in a channel -USING: kernel channels channels.sniffer.backend concurrency io -io.sniffer.backend io.sniffer.bsd io.unix.backend ; +USING: kernel channels channels.sniffer.backend +threads io io.sniffer.backend io.sniffer.bsd +io.unix.backend ; IN: channels.sniffer.bsd M: unix-io sniff-channel ( -- channel ) "/dev/bpf0" "en1" [ - (sniff-channel) - ] spawn drop nip ; + [ + (sniff-channel) + ] 3curry spawn drop + ] keep ; diff --git a/extra/channels/sniffer/sniffer.factor b/extra/channels/sniffer/sniffer.factor index 1502201225..cbf31c71e3 100755 --- a/extra/channels/sniffer/sniffer.factor +++ b/extra/channels/sniffer/sniffer.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Wrap a sniffer in a channel -USING: kernel channels concurrency io io.backend -io.sniffer io.sniffer.backend system vocabs.loader ; +USING: kernel channels io io.backend io.sniffer +io.sniffer.backend system vocabs.loader ; : (sniff-channel) ( stream channel -- ) 4096 pick stream-read-partial over to (sniff-channel) ; diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor old mode 100644 new mode 100755 index 709d318e63..0cf020a087 --- a/extra/cocoa/application/application.factor +++ b/extra/cocoa/application/application.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien io kernel namespaces core-foundation cocoa.messages -cocoa cocoa.classes cocoa.runtime sequences threads debugger -init inspector kernel.private ; +cocoa cocoa.classes cocoa.runtime sequences threads +debugger init inspector kernel.private ; IN: cocoa.application : ( str -- alien ) -> autorelease ; diff --git a/extra/cocoa/cocoa-tests.factor b/extra/cocoa/cocoa-tests.factor index 1f94c051b7..20b7e2a02d 100644 --- a/extra/cocoa/cocoa-tests.factor +++ b/extra/cocoa/cocoa-tests.factor @@ -1,6 +1,7 @@ -IN: temporary +IN: cocoa.tests 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/cocoa/plists/plists.factor b/extra/cocoa/plists/plists.factor index 32b35e9153..646a759c59 100644 --- a/extra/cocoa/plists/plists.factor +++ b/extra/cocoa/plists/plists.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: strings arrays hashtables assocs sequences xml.writer xml.utilities kernel namespaces ; +IN: cocoa.plists GENERIC: >plist ( obj -- tag ) diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index e1e3585813..44555f7b1e 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -1,5 +1,5 @@ -USING: kernel ; +USING: kernel sequences macros ; IN: combinators.cleave @@ -19,6 +19,22 @@ IN: combinators.cleave : 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! General cleave + +MACRO: cleave ( seq -- ) + dup + [ drop [ dup ] ] map concat + swap + dup + [ drop [ >r ] ] map concat + swap + [ [ r> ] append ] map concat + 3append + [ drop ] + append ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! The spread family ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -30,3 +46,14 @@ IN: combinators.cleave : tetra* ( obj obj obj obj quot quot quot quot -- val val val val ) >r roll >r tri* r> r> call ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! General spread + +MACRO: spread ( seq -- ) + dup + [ drop [ >r ] ] map concat + swap + [ [ r> ] swap append ] map concat + append ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 32fca44eaf..0a08948346 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,6 +1,6 @@ USING: combinators.lib kernel math random sequences tools.test continuations arrays vectors ; -IN: temporary +IN: combinators.lib.tests [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 9ccada1ec1..f65b94dc11 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -3,7 +3,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel combinators namespaces quotations hashtables sequences assocs arrays inference effects math math.ranges -arrays.lib shuffle macros bake combinators.cleave ; +arrays.lib shuffle macros bake combinators.cleave +continuations ; IN: combinators.lib @@ -167,3 +168,6 @@ MACRO: construct-slots ( assoc tuple-class -- tuple ) : and? ( obj quot1 quot2 -- ? ) >r keep r> rot [ call ] [ 2drop f ] if ; inline + +: retry ( quot n -- ) + [ drop ] rot compose attempt-all ; inline diff --git a/extra/concurrency/combinators/combinators-docs.factor b/extra/concurrency/combinators/combinators-docs.factor new file mode 100755 index 0000000000..0db235d9e6 --- /dev/null +++ b/extra/concurrency/combinators/combinators-docs.factor @@ -0,0 +1,25 @@ +USING: help.markup help.syntax sequences ; +IN: concurrency.combinators + +HELP: parallel-map +{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } } +{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." } +{ $errors "Throws an error if one of the iterations throws an error." } ; + +HELP: parallel-each +{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } +{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." } +{ $errors "Throws an error if one of the iterations throws an error." } ; + +HELP: parallel-subset +{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } } +{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." } +{ $errors "Throws an error if one of the iterations throws an error." } ; + +ARTICLE: "concurrency.combinators" "Concurrent combinators" +"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link subset } ":" +{ $subsection parallel-each } +{ $subsection parallel-map } +{ $subsection parallel-subset } ; + +ABOUT: "concurrency.combinators" diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor new file mode 100755 index 0000000000..0f18fcf431 --- /dev/null +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -0,0 +1,24 @@ +IN: concurrency.combinators.tests +USING: concurrency.combinators tools.test random kernel math +concurrency.mailboxes threads sequences ; + +[ [ drop ] parallel-each ] must-infer +[ [ ] parallel-map ] must-infer +[ [ ] parallel-subset ] must-infer + +[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test + +[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test + +[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ] +[ delegate "Even" = ] must-fail-with + +[ V{ 0 3 6 9 } ] +[ 10 [ 3 mod zero? ] parallel-subset ] unit-test + +[ 10 ] +[ + V{ } clone + 10 over [ push ] curry parallel-each + length +] unit-test diff --git a/extra/concurrency/combinators/combinators.factor b/extra/concurrency/combinators/combinators.factor new file mode 100755 index 0000000000..76c3cfa77d --- /dev/null +++ b/extra/concurrency/combinators/combinators.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.futures concurrency.count-downs sequences +kernel ; +IN: concurrency.combinators + +: parallel-map ( seq quot -- newseq ) + [ curry future ] curry map dup [ ?future ] change-each ; + inline + +: parallel-each ( seq quot -- ) + over length + [ [ >r curry r> spawn-stage ] 2curry each ] keep await ; + inline + +: parallel-subset ( seq quot -- newseq ) + over >r pusher >r each r> r> like ; inline diff --git a/extra/concurrency/combinators/summary.txt b/extra/concurrency/combinators/summary.txt new file mode 100755 index 0000000000..ae64ac5c9c --- /dev/null +++ b/extra/concurrency/combinators/summary.txt @@ -0,0 +1 @@ +Parallel sequence operations diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor deleted file mode 100644 index 16a2e65a90..0000000000 --- a/extra/concurrency/concurrency-docs.factor +++ /dev/null @@ -1,171 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup concurrency.private match ; -IN: concurrency - -HELP: make-mailbox -{ $values { "mailbox" "a mailbox object" } -} -{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to process the get operation." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: mailbox-empty? -{ $values { "mailbox" "a mailbox object" } - { "bool" "a boolean value" } -} -{ $description "Return true if the mailbox is empty." } -{ $see-also make-mailbox mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: mailbox-put -{ $values { "obj" "an object" } - { "mailbox" "a mailbox object" } -} -{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } -{ $see-also make-mailbox mailbox-empty? mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: (mailbox-block-unless-pred) -{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" "a mailbox object" } - { "timeout" "a timeout in milliseconds" } -} -{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack. The predicate must have stack effect " { $snippet "( X -- bool )" } "." } -{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: (mailbox-block-if-empty) -{ $values { "mailbox" "a mailbox object" } - { "mailbox2" "same object as 'mailbox'" } - { "timeout" "a timeout in milliseconds" } -} -{ $description "Block the thread if the mailbox is empty." } -{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: mailbox-get -{ $values { "mailbox" "a mailbox object" } - { "obj" "an object" } -} -{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } -{ $see-also make-mailbox mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; - -HELP: mailbox-get-all -{ $values { "mailbox" "a mailbox object" } - { "array" "an array" } -} -{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } -{ $see-also make-mailbox mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; - -HELP: while-mailbox-empty -{ $values { "mailbox" "a mailbox object" } - { "quot" "a quotation with stack effect " { $snippet "( -- )" } } -} -{ $description "Repeatedly call the quotation while there are no items in the mailbox. Quotation should have stack effect " { $snippet "( -- )" } "." } -{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all mailbox-get? } ; - -HELP: mailbox-get? -{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" "a mailbox object" } - { "obj" "an object" } -} -{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does. 'pred' must have stack effect " { $snippet "( X -- bool }" } "." } -{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ; - -HELP: -{ $values { "links" "an array of processes" } - { "pid" "the process id" } - { "mailbox" "a mailbox object" } -} -{ $description "Constructs a process object. A process is a lightweight thread with a mailbox that can be used to communicate with other processes. Each process has a unique process id." } -{ $see-also spawn send receive } ; - -HELP: self -{ $values { "process" "a process object" } -} -{ $description "Returns the currently running process object." } -{ $see-also send receive receive-if } ; - -HELP: send -{ $values { "message" "an object" } - { "process" "a process object" } -} -{ $description "Send the message to the process by placing it in the processes mailbox. This is an asynchronous operation and will return immediately. The receving process will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-process the message must be a serializable Factor type." } -{ $see-also receive receive-if } ; - -HELP: receive -{ $values { "message" "an object" } -} -{ $description "Return a message from the current processes mailbox. If the box is empty, suspend the process until another process places an item in the mailbox (usually via the " { $link send } " word." } -{ $see-also send receive-if } ; - -HELP: receive-if -{ $values { "pred" "a predicate with stack effect " { $snippet "( X -- bool )" } } - { "message" "an object" } -} -{ $description "Return the first message from the current processes mailbox that satisfies the predicate. To satisfy the predicate, 'pred' is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. The predicate must have stack effect " { $snippet "( X -- bool )" } ". If nothing in the mailbox satisfies the predicate then the process will block until something does." } -{ $see-also send receive } ; - -HELP: spawn -{ $values { "quot" "a predicate with stack effect " { $snippet "( -- )" } } - { "process" "a process object" } -} -{ $description "Start a process which runs the given quotation." } -{ $see-also send receive receive-if self spawn-link } ; - -HELP: spawn-link -{ $values { "quot" "a predicate with stack effect " { $snippet "( -- )" } } - { "process" "a process object" } -} -{ $description "Start a process which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the process that spawned it. This can be used to set up 'supervisor' processes that restart child processes that crash due to uncaught errors.\n" } -{ $see-also spawn } ; - -ARTICLE: { "concurrency" "loading" } "Loading" -"The Factor module system can be used to load the Concurrency library:" -{ $code "USING: concurrency ;" } ; - -ARTICLE: { "concurrency" "processes" } "Processes" -"A process is basically a thread with a message queue. Other processes can place items on this queue by sending the process a message. A process can check its queue for messages, blocking if none are pending, and process them as they are queued.\n\nFactor processes are very lightweight. Each process can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple processes.\n\nThe messages that are sent from process to process are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a process and the predicate dispatch mechanism can be used to perform actions depending on what the type of the tuple is.\n\nProcesses are usually created using " { $link spawn } ". This word takes a quotation on the stack and starts a process that will execute that quotation asynchronously. When the quotation completes the process will die. 'spawn' leaves on the stack the process object that was started. This object can be used to send messages to the process using " { $link send } ".\n\n'send' will return immediately after placing the message in the target processes message queue.\n\nA process can get a message from its queue using " { $link receive } ". This will get the most recent message and leave it on the stack. If there are no messages in the queue the process will 'block' until a message is available. When a process is blocked it takes no CPU time at all." -{ $code "[ receive print ] spawn\n\"Hello Process!\" swap send" } -"This example spawns a process that first blocks, waiting to receive a message. When a message is received, the 'receive' call returns leaving it on the stack. It then prints the message and exits. 'spawn' left the process on the stack so it's available to send the 'Hello Process!' message to it. Immediately after the 'send' you should see 'Hello Process!' printed on the console.\n\nIt is also possible to selectively retrieve messages from the message queue. " { $link receive-if } " takes a predicate quotation on the stack and returns the first message in the queue that satisfies the predicate. If no items satisfy the predicate then the process is blocked until a message is received that does." -{ $code ": odd? ( n -- ? ) 2 mod 1 = ;\n1 self send 2 self send 3 self send\n\nreceive .\n => 1\n\n[ odd? ] receive-if .\n => 3\n\nreceive .\n => 2" } ; - -ARTICLE: { "concurrency" "self" } "Self" -"A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current process' 'self' and spawns a process which sends a message to it. We then receive the message from the original process:" -{ $code "self [ \"Hello!\" swap send ] spawn 2drop receive .\n => \"Hello!\"" } ; - -ARTICLE: { "concurrency" "servers" } "Servers" -"A common idiom is to create 'server' processes that act on messages that are sent to it. These follow a basic pattern of blocking until a message is received, processing that message then looping back to blocking for a message.\n\nThe following example shows a very simple server that expects an array as its message. The first item of the array should be the senders process object. If the second item is 'ping' then the server sends 'pong' back to the caller. If the second item is anything else then the server exits:" -{ $code ": pong-server ( -- )\n receive {\n { { ?from \"ping\" } [ \"pong\" ?from send pong-server ] }\n { { ?from _ } [ \"server shutdown\" ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn" } -"Handling the deconstructing of messages and dispatching based on the message can be a bit of a chore. Especially in servers that take a number of different messages. The approach taken above is to use the 'match' library which allows easy deconstructing of messages using " { $link match-cond } "." ; - -ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" -{ $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":" -{ $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" } -"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" -{ $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" } -"Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ; - -ARTICLE: { "concurrency" "exceptions" } "Exceptions" -"A process can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the process will terminate. For example:" -{ $code "[ 1 0 / \"This will not print\" print ] spawn" } -"Processes can be linked so that a parent process can receive the exception that caused the child process to terminate. In this way 'supervisor' processes can be created that are notified when child processes terminate and possibly restart them.\n\nThe easiest way to form this link is using " { $link spawn-link } ". This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent process can catch it:" -{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] [ \"Exception caught.\" print ] recover" } -"Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; - -ARTICLE: { "concurrency" "futures" } "Futures" -"A future is a placeholder for the result of a computation that is being calculated in a process. When the process has completed the computation the future can be queried to find out the result. If the computation has not completed when the future is queried them the process will block until the result is completed. A future is created using " { $link future } ".\n\nThe quotation will be run in a spawned process, and a future object is immediately returned. This future object can be resolved using " { $link ?future } ".\n\nFutures are useful for starting calculations that take a long time to run but aren't needed until later in the process. When the process needs the value it can use '?future' to get the result or block until the result is available. For example:" -{ $code "[ 30 fib ] future\n...do stuff...\n?future" } ; - -ARTICLE: { "concurrency" "promises" } "Promises" -"A promise is similar to a future but it is not produced by calculating something in the background. It represents a promise to provide a value sometime later. A process can request the value of a promise and will block if the promise is not fulfilled. Later, another process can fulfill the promise, providing a value. All threads waiting on the promise will then resume with that value on the stack. Use " { $link } " to create a promise, " { $link fulfill } " to set it to a value, and " { $link ?promise } " to retrieve the value, or block until the promise is fulfilled:" -{ $code "\n[ ?promise \"Promise fulfilled: \" write print ] spawn drop\n[ ?promise \"Promise fulfilled: \" write print ] spawn drop\n[ ?promise \"Promise fulfilled: \" write print ] spawn drop\n\"hello\" swap fulfill\n => Promise fulfilled: hello\n Promise fulfilled: hello\n Promise fulfilled: hello" } ; - -ARTICLE: { "concurrency" "concurrency" } "Concurrency" -"The concurrency library is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system.\nA concurrency oriented program is one in which multiple processes run simultaneously in a single Factor image or across multiple running Factor instances. The processes can communicate with each other by asynchronous message sends. Although processes can share data via Factor's mutable data structures it is not recommended as the use of shared state concurrency is often a cause of problems." -{ $subsection { "concurrency" "loading" } } -{ $subsection { "concurrency" "processes" } } -{ $subsection { "concurrency" "self" } } -{ $subsection { "concurrency" "servers" } } -{ $subsection { "concurrency" "synchronous-sends" } } -{ $subsection { "concurrency" "exceptions" } } -{ $subsection { "concurrency" "futures" } } -{ $subsection { "concurrency" "promises" } } ; - -ABOUT: { "concurrency" "concurrency" } diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor deleted file mode 100755 index 8908506d51..0000000000 --- a/extra/concurrency/concurrency-tests.factor +++ /dev/null @@ -1,141 +0,0 @@ -! Copyright (C) 2005 Chris Double. All Rights Reserved. -! See http://factorcode.org/license.txt for BSD license. -! -USING: kernel concurrency threads vectors arrays sequences -namespaces tools.test continuations dlists strings math words -match quotations concurrency.private ; -IN: temporary - -[ ] [ self process-mailbox mailbox-data dlist-delete-all ] unit-test - -[ V{ 1 2 3 } ] [ - 0 - make-mailbox - 2dup [ mailbox-get swap push ] 2curry in-thread - 2dup [ mailbox-get swap push ] 2curry in-thread - 2dup [ mailbox-get swap push ] 2curry in-thread - 1 over mailbox-put - 2 over mailbox-put - 3 swap mailbox-put -] unit-test - -[ V{ 1 2 3 } ] [ - 0 - make-mailbox - 2dup [ [ integer? ] swap mailbox-get? swap push ] 2curry in-thread - 2dup [ [ integer? ] swap mailbox-get? swap push ] 2curry in-thread - 2dup [ [ integer? ] swap mailbox-get? swap push ] 2curry in-thread - 1 over mailbox-put - 2 over mailbox-put - 3 swap mailbox-put -] unit-test - -[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ - 0 - make-mailbox - 2dup [ [ integer? ] swap mailbox-get? swap push ] 2curry in-thread - 2dup [ [ integer? ] swap mailbox-get? swap push ] 2curry in-thread - 2dup [ [ string? ] swap mailbox-get? swap push ] 2curry in-thread - 2dup [ [ string? ] swap mailbox-get? swap push ] 2curry in-thread - 1 over mailbox-put - "junk" over mailbox-put - [ 456 ] over mailbox-put - 3 over mailbox-put - "junk2" over mailbox-put - mailbox-get -] unit-test - -[ "test" ] [ - [ self ] "test" with-process -] unit-test - - -[ "received" ] [ - [ - receive { - { { ?from ?tag _ } [ ?tag "received" 2array ?from send ] } - } match-cond - ] spawn - "sent" swap send-synchronous -] unit-test - -[ 1 3 2 ] [ - 1 self send - 2 self send - 3 self send - receive - [ 2 mod 0 = not ] receive-if - receive -] unit-test - - -[ - [ - "crash" throw - ] spawn-link drop - receive -] [ "crash" = ] must-fail-with - -[ 50 ] [ - [ 50 ] future ?future -] unit-test - -[ V{ 50 50 50 } ] [ - 0 - - 2dup [ ?promise swap push ] 2curry spawn drop - 2dup [ ?promise swap push ] 2curry spawn drop - 2dup [ ?promise swap push ] 2curry spawn drop - 50 swap fulfill -] unit-test - -MATCH-VARS: ?value ; -SYMBOL: increment -SYMBOL: decrement -SYMBOL: value - -: counter ( value -- ) - receive { - { { increment ?value } [ ?value + counter ] } - { { decrement ?value } [ ?value - counter ] } - { { value ?from } [ dup ?from send counter ] } - } match-cond ; - -[ -5 ] [ - [ 0 counter ] spawn - { increment 10 } over send - { decrement 15 } over send - [ value , self , ] { } make swap send - receive -] unit-test - -! The following unit test blocks forever if the -! exception does not propogate. Uncomment when -! this is fixed (via a timeout). -[ - [ "this should propogate" throw ] future ?future -] must-fail - -[ ] [ - [ "this should not propogate" throw ] future drop -] unit-test - -[ f ] [ - [ 1 drop ] spawn 100 sleep process-pid get-process -] unit-test - -[ f ] [ - [ "testing unregistering on error" throw ] spawn - 100 sleep process-pid get-process -] unit-test - -! Race condition with futures -[ 3 3 ] [ - [ 3 ] future - dup ?future swap ?future -] unit-test - -! Another race -[ 3 ] [ - [ 3 yield ] future ?future -] unit-test \ No newline at end of file diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor deleted file mode 100755 index b0abac8f5b..0000000000 --- a/extra/concurrency/concurrency.factor +++ /dev/null @@ -1,384 +0,0 @@ -! Copyright (C) 2005 Chris Double. All Rights Reserved. -! See http://factorcode.org/license.txt for BSD license. -! -! Concurrency library for Factor based on Erlang/Termite style -! concurrency. -USING: vectors dlists threads sequences continuations - namespaces random math quotations words kernel match - arrays io assocs init shuffle system ; -IN: concurrency - -TUPLE: mailbox threads data ; - -TUPLE: thread timeout continuation continued? ; - -: ( timeout continuation -- obj ) - >r dup [ millis + ] when r> - { - set-thread-timeout - set-thread-continuation - } thread construct ; - -: make-mailbox ( -- mailbox ) - V{ } clone mailbox construct-boa ; - -: mailbox-empty? ( mailbox -- bool ) - mailbox-data dlist-empty? ; - -: mailbox-put ( obj mailbox -- ) - [ mailbox-data push-back ] keep - [ mailbox-threads ] keep - V{ } clone swap set-mailbox-threads - [ thread-continuation schedule-thread ] each yield ; - - swap mailbox-threads push stop ] callcc0 - (mailbox-block-unless-pred) - ] if ; inline - -: (mailbox-block-if-empty) ( mailbox timeout -- mailbox2 ) - over mailbox-empty? [ - [ swap mailbox-threads push stop ] callcc0 - (mailbox-block-if-empty) - ] [ - drop - ] if ; -PRIVATE> -: mailbox-get* ( mailbox timeout -- obj ) - (mailbox-block-if-empty) - mailbox-data pop-front ; - -: mailbox-get ( mailbox -- obj ) - f mailbox-get* ; - -: mailbox-get-all* ( mailbox timeout -- array ) - (mailbox-block-if-empty) - [ dup mailbox-empty? ] - [ dup mailbox-data pop-front ] - [ ] unfold nip ; - -: mailbox-get-all ( mailbox -- array ) - f mailbox-get-all* ; - -: while-mailbox-empty ( mailbox quot -- ) - over mailbox-empty? [ - dup >r swap slip r> while-mailbox-empty - ] [ - 2drop - ] if ; inline - -: mailbox-get?* ( pred mailbox timeout -- obj ) - 2over >r >r (mailbox-block-unless-pred) r> r> - mailbox-data delete-node-if ; inline - -: mailbox-get? ( pred mailbox -- obj ) - f mailbox-get?* ; - -TUPLE: process links pid mailbox ; - -C: process - -GENERIC: send ( message process -- ) - - ; - -: make-linked-process ( process -- process ) - #! Return a process set to run on the local node. That process is - #! linked to the process on the stack. It will receive a message if - #! that process terminates. - 1quotation random-256 make-mailbox ; -PRIVATE> - -: self ( -- process ) - \ self get ; - - - -DEFER: register-process -DEFER: unregister-process - - - -: spawn ( quot -- process ) - [ ((spawn)) ] curry (spawn) ; inline - -TUPLE: linked-exception error ; - -C: linked-exception - -: while-no-messages ( quot -- ) - #! Run the quotation in a loop while no messages are in - #! the processes mailbox. The quot should have stack effect - #! ( -- ). - >r self process-mailbox r> while-mailbox-empty ; inline - -M: process send ( message process -- ) - process-mailbox mailbox-put ; - -: receive ( -- message ) - self process-mailbox mailbox-get dup linked-exception? [ - linked-exception-error rethrow - ] when ; - -: receive-if ( pred -- message ) - self process-mailbox mailbox-get? dup linked-exception? [ - linked-exception-error rethrow - ] when ; inline - -: rethrow-linked ( error -- ) - #! Rethrow the error to the linked process - self process-links [ - over swap send - ] each drop ; - - - -: spawn-link ( quot -- process ) - [ [ rethrow-linked ] recover ] curry - [ ((spawn)) ] curry (spawn-link) ; inline - - - -: recv ( forms -- ) - #! Get a message from the processes mailbox. Compare it against the - #! forms to run a quotation if it matches the given message. 'forms' - #! is a list of quotations in the following format: - #! [ pred match-quot ] - #! 'pred' is a word that has stack effect ( msg -- bool ). It is - #! executed with the message on the stack. It should return a - #! boolean if it is a message this form should process. - #! 'match-quot' is a quotation with stack effect ( msg -- ). It - #! will be called with the message on the top of the stack if - #! the 'pred' word returned true. - #! Each form in the list will be matched against the message, - #! even if a prior match succeeded. This means multiple quotations - #! may be run against the message. - receive swap [ dupd (recv) ] each drop ; - -MATCH-VARS: ?from ?tag ; - -r self random-256 r> 3array ; -PRIVATE> - -: send-synchronous ( message process -- reply ) - #! Sends a message to the process synchronously. The - #! message will be wrapped to include the process of the sender - #! and a unique tag. After being sent the sending process will - #! block for a reply tagged with the same unique tag. - >r tag-message dup r> send second _ 2array [ match ] curry - receive-if second ; - - - -: spawn-server ( quot -- process ) - #! Spawn a server that receives messages, calling the - #! quotation on the message. If the quotation returns false - #! the spawned process exits. If it returns true, the process - #! starts from the beginning again. The quotation should have - #! stack effect ( message -- bool ). - [ - (spawn-server) - "Exiting process: " write self process-pid print - ] curry spawn ; inline - -: spawn-linked-server ( quot -- process ) - #! Similar to 'spawn-server' but the parent process will be linked - #! to the child. - [ - (spawn-server) - "Exiting process: " write self process-pid print - ] curry spawn-link ; inline - -: server-cc ( -- cc|process ) - #! Captures the current continuation and returns the value. - #! If that CC is called with a process on the stack it will - #! set 'self' for the current process to it. Otherwise it will - #! return the value. This allows capturing a continuation in a server, - #! and jumping back into it from a spawn and keeping the 'self' - #! variable correct. It's a workaround until I can find out how to - #! stop 'self' from being clobbered back to its old value. - [ ] callcc1 dup process? [ \ self set-global f ] when ; - -: call-server-cc ( server-cc -- ) - #! Calls the server continuation passing the current 'self' - #! so the server continuation gets its new self updated. - self swap call ; - -TUPLE: future value processes ; - -: notify-future ( value future -- ) - tuck set-future-value - dup future-processes [ schedule-thread ] each - f swap set-future-processes ; - -: future ( quot -- future ) - #! Spawn a process to call the quotation and immediately return. - f V{ } clone \ future construct-boa [ - [ - >r [ t 2array ] compose [ f 2array ] recover r> - notify-future - ] 2curry spawn drop - ] keep ; - -: ?future ( future -- result ) - #! Block the process until the future has completed and then - #! place the result on the stack. Return the result - #! immediately if the future has completed. - dup future-value [ - first2 [ rethrow ] unless - ] [ - dup [ future-processes push stop ] curry callcc0 ?future - ] ?if ; - -: parallel-map ( seq quot -- newseq ) - #! Spawn a process to apply quot to each element of seq, - #! joining the results into a sequence at the end. - [ curry future ] curry map [ ?future ] map ; - -: parallel-each ( seq quot -- ) - #! Spawn a process to apply quot to each element of seq, - #! and waits for all processes to complete. - [ f ] compose parallel-map drop ; - -TUPLE: promise fulfilled? value processes ; - -: ( -- ) - f f V{ } clone promise construct-boa ; - -: fulfill ( value promise -- ) - #! Set the future of the promise to the given value. Threads - #! blocking on the promise will then be released. - dup promise-fulfilled? [ - 2drop - ] [ - [ set-promise-value ] keep - [ t swap set-promise-fulfilled? ] keep - [ promise-processes ] keep - V{ } clone swap set-promise-processes - [ thread-continuation schedule-thread ] each yield - ] if ; - - swap promise-processes push stop ] callcc0 - drop - ] if ; -PRIVATE> - -: ?promise* ( promise timeout -- result ) - (maybe-block-promise) promise-value ; - -: ?promise ( promise -- result ) - f ?promise* ; - -! ****************************** -! Experimental code below -! ****************************** - - -: lazy ( quot -- lazy ) - #! Spawn a process that immediately blocks and return it. - #! When '?lazy' is called on the returned process, call the quotation - #! and return the result. The quotation must have stack effect ( -- X ). - [ - receive { - { { ?from ?tag _ } - [ call ?tag over 2array ?from send (lazy) ] } - } match-cond - ] spawn nip ; - -: ?lazy ( lazy -- result ) - #! Given a process spawned using 'lazy', evaluate it and return the result. - f swap send-synchronous ; - - - -: register-process ( name process -- ) - swap remote-processes set-at ; - -: unregister-process ( name -- ) - remote-processes delete-at ; - -: get-process ( name -- process ) - remote-processes at ; - -[ - H{ } clone \ remote-processes set-global - init-main-process - self [ process-pid ] keep register-process -] "process-registry" add-init-hook diff --git a/extra/concurrency/conditions/conditions.factor b/extra/concurrency/conditions/conditions.factor new file mode 100755 index 0000000000..b10aded671 --- /dev/null +++ b/extra/concurrency/conditions/conditions.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: dlists dlists.private threads kernel arrays sequences +alarms ; +IN: concurrency.conditions + +: notify-1 ( dlist -- ) + dup dlist-empty? [ drop ] [ pop-back resume-now ] if ; + +: notify-all ( dlist -- ) + [ resume-now ] dlist-slurp ; + +: queue-timeout ( queue timeout -- alarm ) + #! Add an alarm which removes the current thread from the + #! queue, and resumes it, passing it a value of t. + >r self over push-front* [ + tuck delete-node + dlist-node-obj t swap resume-with + ] 2curry r> later ; + +: wait ( queue timeout status -- ) + over [ + >r queue-timeout [ drop ] r> suspend + [ "Timeout" throw ] [ cancel-alarm ] if + ] [ + >r drop [ push-front ] curry r> suspend drop + ] if ; diff --git a/extra/concurrency/conditions/summary.txt b/extra/concurrency/conditions/summary.txt new file mode 100755 index 0000000000..7441ca5d5f --- /dev/null +++ b/extra/concurrency/conditions/summary.txt @@ -0,0 +1 @@ +Low-level wait/notify support diff --git a/extra/concurrency/count-downs/count-downs-docs.factor b/extra/concurrency/count-downs/count-downs-docs.factor new file mode 100755 index 0000000000..5da10f7b57 --- /dev/null +++ b/extra/concurrency/count-downs/count-downs-docs.factor @@ -0,0 +1,24 @@ +USING: help.markup help.syntax sequences ; +IN: concurrency.count-downs + +HELP: +{ $values { "n" "a non-negative integer" } { "count-down" count-down } } +{ $description "Creates a new count-down latch." } +{ $errors "Throws an error if the count is lower than zero." } ; + +HELP: count-down +{ $values { "count-down" count-down } } +{ $description "Decrements a count-down latch. If it reaches zero, all threads blocking on " { $link await } " are notified." } +{ $errors "Throws an error if an attempt is made to decrement the count lower than zero." } ; + +HELP: await +{ $values { "count-down" count-down } } +{ $description "Waits until the count-down value reaches zero." } ; + +ARTICLE: "concurrency.count-downs" "Count-down latches" +"The " { $vocab-link "concurrency.count-downs" } " vocabulary implements the " { $emphasis "count-down latch" } " data type, whichis a wrapper for a non-negative integer value which tends towards zero. A thread can either decrement the value, or wait for it to become zero." +{ $subsection } +{ $subsection count-down } +{ $subsection await } ; + +ABOUT: "concurrency.count-downs" diff --git a/extra/concurrency/count-downs/count-downs-tests.factor b/extra/concurrency/count-downs/count-downs-tests.factor new file mode 100755 index 0000000000..649802cd95 --- /dev/null +++ b/extra/concurrency/count-downs/count-downs-tests.factor @@ -0,0 +1,16 @@ +USING: concurrency.count-downs threads kernel tools.test ; +IN: concurrency.count-downs.tests` + +[ ] [ 0 await ] unit-test + +[ 1 dup count-down count-down ] must-fail + +[ ] [ + 1 + 3 + 2dup [ await count-down ] 2curry "Master" spawn drop + dup [ count-down ] curry "Slave" spawn drop + dup [ count-down ] curry "Slave" spawn drop + dup [ count-down ] curry "Slave" spawn drop + drop await +] unit-test diff --git a/extra/concurrency/count-downs/count-downs.factor b/extra/concurrency/count-downs/count-downs.factor new file mode 100755 index 0000000000..b1fa137bc4 --- /dev/null +++ b/extra/concurrency/count-downs/count-downs.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: dlists kernel math concurrency.promises +concurrency.mailboxes ; +IN: concurrency.count-downs + +! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html + +TUPLE: count-down n promise ; + +: count-down-check ( count-down -- ) + dup count-down-n zero? [ + t swap count-down-promise fulfill + ] [ drop ] if ; + +: ( n -- count-down ) + dup 0 < [ "Invalid count for count down" throw ] when + \ count-down construct-boa + dup count-down-check ; + +: count-down ( count-down -- ) + dup count-down-n dup zero? [ + "Count down already done" throw + ] [ + 1- over set-count-down-n + count-down-check + ] if ; + +: await-timeout ( count-down timeout -- ) + >r count-down-promise r> ?promise-timeout drop ; + +: await ( count-down -- ) + f await-timeout ; + +: spawn-stage ( quot count-down -- ) + [ [ count-down ] curry compose ] keep + "Count down stage" + swap count-down-promise + promise-mailbox spawn-linked-to drop ; diff --git a/extra/concurrency/count-downs/summary.txt b/extra/concurrency/count-downs/summary.txt new file mode 100755 index 0000000000..1992a149af --- /dev/null +++ b/extra/concurrency/count-downs/summary.txt @@ -0,0 +1 @@ +Count-down latches diff --git a/extra/concurrency/distributed/distributed-docs.factor b/extra/concurrency/distributed/distributed-docs.factor old mode 100644 new mode 100755 index 23af641600..4fae6ddbcc --- a/extra/concurrency/distributed/distributed-docs.factor +++ b/extra/concurrency/distributed/distributed-docs.factor @@ -1,25 +1,20 @@ -USING: help.markup help.syntax concurrency ; +USING: help.markup help.syntax concurrency.messaging threads ; IN: concurrency.distributed -HELP: -{ $values { "node" "a node object" } - { "pid" "a process id" } - { "remote-process" "the constructed remote-process object" } +HELP: local-node +{ $values { "addrspec" "an address specifier" } } -{ $description "Constructs a proxy to a process running on another node. It can be used to send messages to the process it is acting as a proxy for." } -{ $see-also spawn send } ; +{ $description "Return the node the current thread is running on." } ; +HELP: start-node +{ $values { "port" "a port number between 0 and 65535" } } +{ $description "Starts a node server for receiving messages from remote Factor instances." } ; -HELP: -{ $values { "hostname" "the hostname of the node as a string" } - { "port" "the integer port number of the node" } - { "node" "the constructed node object" } -} -{ $description "Processes run on nodes. Each node has a hostname and a port." } -{ $see-also localnode } ; +ARTICLE: "concurrency.distributed" "Distributed message passing" +"The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing." +{ $subsection start-node } +"Instances of " { $link thread } " can be sent to remote processes, at which point they are converted to objects holding the thread ID and the current node's host name:" +{ $subsection remote-process } +"The " { $vocab-link "serialize" } " vocabulary is used to convert Factor objects to byte arrays for transfer over a socket." ; -HELP: localnode -{ $values { "node" "a node object" } -} -{ $description "Return the node the process is currently running on." } -{ $see-also } ; +ABOUT: "concurrency.distributed" diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index 83052b803a..2c54a872f7 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -1,43 +1,36 @@ ! Copyright (C) 2005 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: serialize sequences concurrency io io.server qualified -threads arrays namespaces kernel ; +USING: serialize sequences concurrency.messaging +threads io io.server qualified arrays +namespaces kernel ; QUALIFIED: io.sockets IN: concurrency.distributed -TUPLE: node hostname port ; - -C: node +SYMBOL: local-node ( -- addrspec ) : handle-node-client ( -- ) deserialize first2 get-process send ; -: node-server ( port -- ) - internet-server - "concurrency.distributed" - [ handle-node-client ] with-server ; +: (start-node) ( addrspecs addrspec -- ) + [ + local-node set-global + "concurrency.distributed" + [ handle-node-client ] with-server + ] 2curry f spawn drop ; -: send-to-node ( msg pid host port -- ) - io.sockets: io.sockets: [ - 2array serialize - ] with-stream ; +: start-node ( port -- ) + dup internet-server io.sockets:host-name + rot io.sockets: (start-node) ; -: localnode ( -- node ) - \ localnode get ; - -: start-node ( hostname port -- ) - [ node-server ] in-thread - \ localnode set-global ; - -TUPLE: remote-process node pid ; +TUPLE: remote-process id node ; C: remote-process -M: remote-process send ( message process -- ) - #! Send the message via the inter-node protocol - { remote-process-pid remote-process-node } get-slots - { node-hostname node-port } get-slots - send-to-node ; +M: remote-process send ( message thread -- ) + { remote-process-id remote-process-node } get-slots + io.sockets: [ 2array serialize ] with-stream ; -M: process (serialize) ( obj -- ) - localnode swap process-pid (serialize) ; +M: thread (serialize) ( obj -- ) + thread-id local-node get-global + + (serialize) ; diff --git a/extra/network-clipboard/authors.txt b/extra/concurrency/exchangers/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/network-clipboard/authors.txt rename to extra/concurrency/exchangers/authors.txt diff --git a/extra/concurrency/exchangers/exchangers-docs.factor b/extra/concurrency/exchangers/exchangers-docs.factor new file mode 100755 index 0000000000..6df3729e41 --- /dev/null +++ b/extra/concurrency/exchangers/exchangers-docs.factor @@ -0,0 +1,22 @@ +USING: help.markup help.syntax sequences kernel ; +IN: concurrency.exchangers + +HELP: exchanger +{ $class-description "The class of object exchange points." } ; + +HELP: +{ $values { "exchanger" exchanger } } +{ $description "Creates a new object exchange point." } ; + +HELP: exchange +{ $values { "obj" object } { "exchanger" exchanger } { "newobj" object } } +{ $description "Waits for another thread to call " { $link exchange } " on the same exchanger. The thread's call to " { $link exchange } " returns with " { $snippet "obj" } " on the stack, and the object passed to " { $link exchange } " by the other thread is left on the current's thread stack as " { $snippet "newobj" } "." } ; + +ARTICLE: "concurrency.exchangers" "Object exchange points" +"The " { $vocab-link "concurrency.exchangers" } " vocabulary implements " { $emphasis "object exchange points" } ", which are rendezvous points where two threads can exchange objects." +{ $subsection exchanger } +{ $subsection } +{ $subsection exchange } +"One use-case is two threads, where one thread reads data into a buffer and another thread processes the data. The reader thread can begin by reading the data, then passing the buffer through an exchanger, then recursing. The processing thread can begin by creating an empty buffer, and exchanging it through the exchanger. It then processes the result and recurses." ; + +ABOUT: "concurrency.exchangers" diff --git a/extra/concurrency/exchangers/exchangers-tests.factor b/extra/concurrency/exchangers/exchangers-tests.factor new file mode 100755 index 0000000000..569b1a72c2 --- /dev/null +++ b/extra/concurrency/exchangers/exchangers-tests.factor @@ -0,0 +1,30 @@ +IN: concurrency.exchangers.tests +USING: sequences tools.test concurrency.exchangers +concurrency.count-downs concurrency.promises locals kernel +threads ; + +:: exchanger-test ( -- ) + [let | + ex [ ] + c [ 2 ] + v1! [ f ] + v2! [ f ] + pr [ ] | + + [ + c await + v1 ", " v2 3append pr fulfill + ] "Awaiter" spawn drop + + [ + "Goodbye world" ex exchange v1! c count-down + ] "Exchanger 1" spawn drop + + [ + "Hello world" ex exchange v2! c count-down + ] "Exchanger 2" spawn drop + + pr ?promise + ] ; + +[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test diff --git a/extra/concurrency/exchangers/exchangers.factor b/extra/concurrency/exchangers/exchangers.factor new file mode 100755 index 0000000000..0a631d1c7b --- /dev/null +++ b/extra/concurrency/exchangers/exchangers.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel threads boxes ; +IN: concurrency.exchangers + +! Motivated by +! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/Exchanger.html + +TUPLE: exchanger thread object ; + +: ( -- exchanger ) + exchanger construct-boa ; + +: exchange ( obj exchanger -- newobj ) + dup exchanger-thread box-full? [ + dup exchanger-object box> + >r exchanger-thread box> resume-with r> + ] [ + [ exchanger-object >box ] keep + [ exchanger-thread >box ] curry "exchange" suspend + ] if ; diff --git a/extra/concurrency/exchangers/summary.txt b/extra/concurrency/exchangers/summary.txt new file mode 100755 index 0000000000..c403f5a6e2 --- /dev/null +++ b/extra/concurrency/exchangers/summary.txt @@ -0,0 +1 @@ +Object exchange points diff --git a/extra/concurrency/flags/flags-docs.factor b/extra/concurrency/flags/flags-docs.factor new file mode 100644 index 0000000000..1b2c1b754e --- /dev/null +++ b/extra/concurrency/flags/flags-docs.factor @@ -0,0 +1,38 @@ +! 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: wait-for-flag +{ $values { "flag" flag } } +{ $description "Waits for a flag to be raised. If the flag has already been raised, returns immediately." } ; + +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 it has not been raised yet will wait for another thread to raise the flag." +$nl +"Essentially, a flag can be thought of as a counting semaphore where the count never goes above one." +{ $subsection flag } +{ $subsection flag? } +"Waiting for a flag to be raised:" +{ $subsection raise-flag } +{ $subsection wait-for-flag } +{ $subsection lower-flag } ; + +ABOUT: "concurrency.flags" diff --git a/extra/concurrency/flags/flags-tests.factor b/extra/concurrency/flags/flags-tests.factor new file mode 100755 index 0000000000..f23ea95167 --- /dev/null +++ b/extra/concurrency/flags/flags-tests.factor @@ -0,0 +1,46 @@ +IN: concurrency.flags.tests +USING: tools.test concurrency.flags kernel threads locals ; + +:: flag-test-1 ( -- ) + [let | f [ ] | + [ f raise-flag ] "Flag test" spawn drop + f lower-flag + f flag-value? + ] ; + +[ f ] [ flag-test-1 ] unit-test + +:: flag-test-2 ( -- ) + [let | f [ ] | + [ 1000 sleep f raise-flag ] "Flag test" spawn drop + f lower-flag + f flag-value? + ] ; + +[ f ] [ flag-test-2 ] unit-test + +:: flag-test-3 ( -- ) + [let | f [ ] | + f raise-flag + f flag-value? + ] ; + +[ t ] [ flag-test-3 ] unit-test + +:: flag-test-4 ( -- ) + [let | f [ ] | + [ f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f flag-value? + ] ; + +[ t ] [ flag-test-4 ] unit-test + +:: flag-test-5 ( -- ) + [let | f [ ] | + [ 1000 sleep f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f flag-value? + ] ; + +[ t ] [ flag-test-5 ] unit-test diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor new file mode 100755 index 0000000000..d598bf0b59 --- /dev/null +++ b/extra/concurrency/flags/flags.factor @@ -0,0 +1,22 @@ +! 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? [ + t over set-flag-value? + dup flag-thread [ resume ] if-box? + ] unless drop ; + +: wait-for-flag ( flag -- ) + dup flag-value? [ drop ] [ + [ flag-thread >box ] curry "flag" suspend drop + ] if ; + +: lower-flag ( flag -- ) + dup wait-for-flag f swap set-flag-value? ; diff --git a/extra/concurrency/authors.txt b/extra/concurrency/futures/authors.txt similarity index 50% rename from extra/concurrency/authors.txt rename to extra/concurrency/futures/authors.txt index 44b06f94bc..a8fb961d36 100644 --- a/extra/concurrency/authors.txt +++ b/extra/concurrency/futures/authors.txt @@ -1 +1,2 @@ Chris Double +Slava Pestov diff --git a/extra/concurrency/futures/futures-docs.factor b/extra/concurrency/futures/futures-docs.factor new file mode 100755 index 0000000000..99b4bb6e81 --- /dev/null +++ b/extra/concurrency/futures/futures-docs.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.promises concurrency.messaging kernel arrays +continuations help.markup help.syntax quotations ; +IN: concurrency.futures + +HELP: future +{ $values { "quot" "a quotation with stack effect " { $snippet "( -- value )" } } { "future" future } } +{ $description "Creates a deferred computation." +$nl +"The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ; + +HELP: ?future-timeout +{ $values { "future" future } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } } +{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to " { $snippet "timeout" } " milliseconds." } +{ $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ; + +HELP: ?future +{ $values { "future" future } { "value" object } } +{ $description "Waits for a deferred computation to complete, blocking indefinitely." } +{ $errors "Throws an error if future quotation threw an error." } ; + +ARTICLE: "concurrency.futures" "Futures" +"The " { $vocab-link "concurrency.futures" } " vocabulary implements " { $emphasis "futures" } ", which are deferred computations performed in a background thread. A thread may create a future, then proceed to perform other tasks, then later wait for the future to complete." +{ $subsection future } +{ $subsection ?future } +{ $subsection ?future-timeout } ; + +ABOUT: "concurrency.futures" diff --git a/extra/concurrency/futures/futures-tests.factor b/extra/concurrency/futures/futures-tests.factor new file mode 100755 index 0000000000..208a72f820 --- /dev/null +++ b/extra/concurrency/futures/futures-tests.factor @@ -0,0 +1,25 @@ +IN: concurrency.futures.tests +USING: concurrency.futures kernel tools.test threads ; + +[ 50 ] [ + [ 50 ] future ?future +] unit-test + +[ + [ "this should propogate" throw ] future ?future +] must-fail + +[ ] [ + [ "this should not propogate" throw ] future drop +] unit-test + +! Race condition with futures +[ 3 3 ] [ + [ 3 ] future + dup ?future swap ?future +] unit-test + +! Another race +[ 3 ] [ + [ 3 yield ] future ?future +] unit-test diff --git a/extra/concurrency/futures/futures.factor b/extra/concurrency/futures/futures.factor new file mode 100755 index 0000000000..85f1ba44a0 --- /dev/null +++ b/extra/concurrency/futures/futures.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.promises concurrency.mailboxes kernel arrays +continuations ; +IN: concurrency.futures + +: future ( quot -- future ) + [ + [ [ >r call r> fulfill ] 2curry "Future" ] keep + promise-mailbox spawn-linked-to drop + ] keep ; inline + +: ?future-timeout ( future timeout -- value ) + ?promise-timeout ?linked ; + +: ?future ( future -- value ) + ?promise ?linked ; diff --git a/extra/concurrency/futures/summary.txt b/extra/concurrency/futures/summary.txt new file mode 100644 index 0000000000..12de3c6f7e --- /dev/null +++ b/extra/concurrency/futures/summary.txt @@ -0,0 +1 @@ +Deferred computations diff --git a/extra/timers/authors.txt b/extra/concurrency/locks/authors.txt similarity index 100% rename from extra/timers/authors.txt rename to extra/concurrency/locks/authors.txt diff --git a/extra/concurrency/locks/locks-docs.factor b/extra/concurrency/locks/locks-docs.factor new file mode 100755 index 0000000000..3a89af5ba0 --- /dev/null +++ b/extra/concurrency/locks/locks-docs.factor @@ -0,0 +1,60 @@ +USING: help.markup help.syntax sequences kernel quotations ; +IN: concurrency.locks + +HELP: lock +{ $class-description "The class of mutual exclusion locks." } ; + +HELP: +{ $values { "lock" lock } } +{ $description "Creates a non-reentrant lock." } ; + +HELP: +{ $values { "lock" lock } } +{ $description "Creates a reentrant lock." } ; + +HELP: with-lock +{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } +{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; + +ARTICLE: "concurrency.locks.mutex" "Mutual-exclusion locks" +"A mutual-exclusion lock ensures that only one thread executes with the lock held at a time. They are used to protect critical sections so that certain operations appear to be atomic to other threads." +$nl +"There are two varieties of locks: non-reentrant and reentrant. The latter may be acquired recursively by the same thread. Attempting to do so with the former will deadlock." +{ $subsection lock } +{ $subsection } +{ $subsection } +{ $subsection with-lock } ; + +HELP: rw-lock +{ $class-description "The class of reader/writer locks." } ; + +HELP: with-read-lock +{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } +{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; + +HELP: with-write-lock +{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } +{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; + +ARTICLE: "concurrency.locks.rw" "Read-write locks" +"A read-write lock encapsulates a common pattern in the implementation of concurrent data structures, where one wishes to ensure that a thread is able to see a consistent view of the structure for a period of time, during which no other thread modifies the structure." +$nl +"While this can be achieved with a simple " { $link "concurrency.locks.mutex" } ", performance will suffer, since in fact multiple threads can view the structure at the same time; serialization must only be enforced for writes." +$nl +"Read/write locks allow any number of threads to hold the read lock simulateneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks." +$nl +"Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held." +{ $subsection rw-lock } +{ $subsection } +{ $subsection with-read-lock } +{ $subsection with-write-lock } ; + +ARTICLE: "concurrency.locks" "Locks" +"A " { $emphasis "lock" } " is an object protecting a critical region of code, enforcing a particular mutual-exclusion policy. The " { $vocab-link "concurrency.locks" } " vocabulary implements two types of locks:" +{ $subsection "concurrency.locks.mutex" } +{ $subsection "concurrency.locks.rw" } ; + +ABOUT: "concurrency.locks" diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor new file mode 100755 index 0000000000..659bd2714e --- /dev/null +++ b/extra/concurrency/locks/locks-tests.factor @@ -0,0 +1,213 @@ +IN: concurrency.locks.tests +USING: tools.test concurrency.locks concurrency.count-downs +concurrency.messaging concurrency.mailboxes locals kernel +threads sequences calendar ; + +:: lock-test-0 ( -- ) + [let | v [ V{ } clone ] + c [ 2 ] | + + [ + yield + 1 v push + yield + 2 v push + c count-down + ] "Lock test 1" spawn drop + + [ + yield + 3 v push + yield + 4 v push + c count-down + ] "Lock test 2" spawn drop + + c await + v + ] ; + +:: lock-test-1 ( -- ) + [let | v [ V{ } clone ] + l [ ] + c [ 2 ] | + + [ + l [ + yield + 1 v push + yield + 2 v push + ] with-lock + c count-down + ] "Lock test 1" spawn drop + + [ + l [ + yield + 3 v push + yield + 4 v push + ] with-lock + c count-down + ] "Lock test 2" spawn drop + + c await + v + ] ; + +[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test +[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test + +[ 3 ] [ + dup [ + [ + 3 + ] with-lock + ] with-lock +] unit-test + +[ ] [ drop ] unit-test + +[ ] [ [ ] with-read-lock ] unit-test + +[ ] [ dup [ [ ] with-read-lock ] with-read-lock ] unit-test + +[ ] [ [ ] with-write-lock ] unit-test + +[ ] [ dup [ [ ] with-write-lock ] with-write-lock ] unit-test + +[ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test + +:: rw-lock-test-1 ( -- ) + [let | l [ ] + c [ 1 ] + c' [ 1 ] + c'' [ 4 ] + v [ V{ } clone ] | + + [ + l [ + 1 v push + c count-down + yield + 3 v push + ] with-read-lock + c'' count-down + ] "R/W lock test 1" spawn drop + + [ + c await + l [ + 4 v push + 1000 sleep + 5 v push + ] with-write-lock + c'' count-down + ] "R/W lock test 2" spawn drop + + [ + c await + l [ + 2 v push + c' count-down + ] with-read-lock + c'' count-down + ] "R/W lock test 4" spawn drop + + [ + c' await + l [ + 6 v push + ] with-write-lock + c'' count-down + ] "R/W lock test 5" spawn drop + + c'' await + v + ] ; + +[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test + +:: rw-lock-test-2 ( -- ) + [let | l [ ] + c [ 1 ] + c' [ 2 ] + v [ V{ } clone ] | + + [ + l [ + 1 v push + c count-down + 1000 sleep + 2 v push + ] with-write-lock + c' count-down + ] "R/W lock test 1" spawn drop + + [ + c await + l [ + 3 v push + ] with-read-lock + c' count-down + ] "R/W lock test 2" spawn drop + + c' await + v + ] ; + +[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test + +! Test lock timeouts +:: lock-timeout-test ( -- ) + [let | l [ ] | + [ + l [ 1 seconds sleep ] with-lock + ] "Lock holder" spawn drop + + [ + l 1/10 seconds [ ] with-lock-timeout + ] "Lock timeout-er" spawn-linked drop + + receive + ] ; + +[ lock-timeout-test ] [ + linked-error-thread thread-name "Lock timeout-er" = +] must-fail-with + +:: read/write-test ( -- ) + [let | l [ ] | + [ + l [ 1 seconds sleep ] with-lock + ] "Lock holder" spawn drop + + [ + l 1/10 seconds [ ] with-lock-timeout + ] "Lock timeout-er" spawn-linked drop + + receive + ] ; + +[ + dup [ + 1 seconds [ ] with-write-lock-timeout + ] with-read-lock +] must-fail + +[ + dup [ + dup [ + 1 seconds [ ] with-write-lock-timeout + ] with-read-lock + ] with-write-lock +] must-fail + +[ ] [ + dup [ + dup [ + 1 seconds [ ] with-read-lock-timeout + ] with-read-lock + ] with-write-lock +] unit-test diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor new file mode 100755 index 0000000000..43f22c00da --- /dev/null +++ b/extra/concurrency/locks/locks.factor @@ -0,0 +1,116 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: dlists kernel threads continuations math +concurrency.conditions ; +IN: concurrency.locks + +! Simple critical sections +TUPLE: lock threads owner reentrant? ; + +: ( -- lock ) + f f lock construct-boa ; + +: ( -- lock ) + f t lock construct-boa ; + +r lock-threads r> "lock" wait ] when drop + self swap set-lock-owner ; + +: release-lock ( lock -- ) + f over set-lock-owner + lock-threads notify-1 ; + +: do-lock ( lock timeout quot acquire release -- ) + >r >r pick rot r> call ! use up timeout acquire + swap r> curry [ ] cleanup ; inline + +: (with-lock) ( lock timeout quot -- ) + [ acquire-lock ] [ release-lock ] do-lock ; inline + +PRIVATE> + +: with-lock-timeout ( lock timeout quot -- ) + pick lock-reentrant? [ + pick lock-owner self eq? [ + 2nip call + ] [ + (with-lock) + ] if + ] [ + (with-lock) + ] if ; inline + +: with-lock ( lock quot -- ) + f swap with-lock-timeout ; inline + +! Many-reader/single-writer locks +TUPLE: rw-lock readers writers reader# writer ; + +: ( -- lock ) + 0 f rw-lock construct-boa ; + +r rw-lock-readers r> "read lock" wait ] when drop + add-reader ; + +: notify-writer ( lock -- ) + rw-lock-writers notify-1 ; + +: remove-reader ( lock -- ) + dup rw-lock-reader# 1- swap set-rw-lock-reader# ; + +: release-read-lock ( lock -- ) + dup remove-reader + dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ; + +: acquire-write-lock ( lock timeout -- ) + over rw-lock-writer pick rw-lock-reader# 0 > or + [ 2dup >r rw-lock-writers r> "write lock" wait ] when drop + self swap set-rw-lock-writer ; + +: release-write-lock ( lock -- ) + f over set-rw-lock-writer + dup rw-lock-readers dlist-empty? + [ notify-writer ] [ rw-lock-readers notify-all ] if ; + +: reentrant-read-lock-ok? ( lock -- ? ) + #! If we already have a write lock, then we can grab a read + #! lock too. + rw-lock-writer self eq? ; + +: reentrant-write-lock-ok? ( lock -- ? ) + #! The only case where we have a writer and > 1 reader is + #! write -> read re-entrancy, and in this case we prohibit + #! a further write -> read -> write re-entrancy. + dup rw-lock-writer self eq? + swap rw-lock-reader# zero? and ; + +PRIVATE> + +: with-read-lock-timeout ( lock timeout quot -- ) + pick reentrant-read-lock-ok? [ + [ drop add-reader ] [ remove-reader ] do-lock + ] [ + [ acquire-read-lock ] [ release-read-lock ] do-lock + ] if ; inline + +: with-read-lock ( lock quot -- ) + f swap with-read-lock-timeout ; inline + +: with-write-lock-timeout ( lock timeout quot -- ) + pick reentrant-write-lock-ok? [ 2nip call ] [ + [ acquire-write-lock ] [ release-write-lock ] do-lock + ] if ; inline + +: with-write-lock ( lock quot -- ) + f swap with-write-lock-timeout ; inline diff --git a/extra/concurrency/locks/summary.txt b/extra/concurrency/locks/summary.txt new file mode 100644 index 0000000000..2ac51cd59b --- /dev/null +++ b/extra/concurrency/locks/summary.txt @@ -0,0 +1 @@ +Traditional locks and many reader/single writer locks diff --git a/extra/concurrency/mailboxes/mailboxes-docs.factor b/extra/concurrency/mailboxes/mailboxes-docs.factor new file mode 100755 index 0000000000..4937ef1fb9 --- /dev/null +++ b/extra/concurrency/mailboxes/mailboxes-docs.factor @@ -0,0 +1,75 @@ +USING: help.markup help.syntax kernel arrays ; +IN: concurrency.mailboxes + +HELP: +{ $values { "mailbox" mailbox } } +{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ; + +HELP: mailbox-empty? +{ $values { "mailbox" mailbox } + { "bool" "a boolean" } +} +{ $description "Return true if the mailbox is empty." } ; + +HELP: mailbox-put +{ $values { "obj" object } + { "mailbox" mailbox } +} +{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ; + +HELP: block-unless-pred +{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } + { "mailbox" mailbox } + { "timeout" "a timeout in milliseconds, or " { $link f } } +} +{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ; + +HELP: block-if-empty +{ $values { "mailbox" mailbox } + { "timeout" "a timeout in milliseconds, or " { $link f } } +} +{ $description "Block the thread if the mailbox is empty." } ; + +HELP: mailbox-get +{ $values { "mailbox" mailbox } + { "obj" object } +} +{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ; + +HELP: mailbox-get-all +{ $values { "mailbox" mailbox } + { "array" array } +} +{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ; + +HELP: while-mailbox-empty +{ $values { "mailbox" mailbox } + { "quot" "a quotation with stack effect " { $snippet "( -- )" } } +} +{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ; + +HELP: mailbox-get? +{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } + { "mailbox" mailbox } + { "obj" object } +} +{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ; + + +ARTICLE: "concurrency.mailboxes" "Mailboxes" +"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error." +{ $subsection mailbox } +{ $subsection } +"Removing the first element:" +{ $subsection mailbox-get } +{ $subsection mailbox-get-timeout } +"Removing the first element matching a predicate:" +{ $subsection mailbox-get? } +{ $subsection mailbox-get-timeout? } +"Emptying out a mailbox:" +{ $subsection mailbox-get-all } +"Adding an element:" +{ $subsection mailbox-put } +"Testing if a mailbox is empty:" +{ $subsection mailbox-empty? } +{ $subsection while-mailbox-empty } ; diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor new file mode 100755 index 0000000000..24d83b2961 --- /dev/null +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -0,0 +1,40 @@ +IN: concurrency.mailboxes.tests +USING: concurrency.mailboxes vectors sequences threads +tools.test math kernel strings ; + +[ V{ 1 2 3 } ] [ + 0 + + [ mailbox-get swap push ] in-thread + [ mailbox-get swap push ] in-thread + [ mailbox-get swap push ] in-thread + 1 over mailbox-put + 2 over mailbox-put + 3 swap mailbox-put +] unit-test + +[ V{ 1 2 3 } ] [ + 0 + + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] swap mailbox-get? swap push ] in-thread + 1 over mailbox-put + 2 over mailbox-put + 3 swap mailbox-put +] unit-test + +[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ + 0 + + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ string? ] swap mailbox-get? swap push ] in-thread + [ [ string? ] swap mailbox-get? swap push ] in-thread + 1 over mailbox-put + "junk" over mailbox-put + [ 456 ] over mailbox-put + 3 over mailbox-put + "junk2" over mailbox-put + mailbox-get +] unit-test diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor new file mode 100755 index 0000000000..28b2fb7221 --- /dev/null +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -0,0 +1,87 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: concurrency.mailboxes +USING: dlists threads sequences continuations +namespaces random math quotations words kernel arrays assocs +init system concurrency.conditions ; + +TUPLE: mailbox threads data ; + +: ( -- mailbox ) + mailbox construct-boa ; + +: mailbox-empty? ( mailbox -- bool ) + mailbox-data dlist-empty? ; + +: mailbox-put ( obj mailbox -- ) + [ mailbox-data push-front ] keep + mailbox-threads notify-all yield ; + +: block-unless-pred ( pred mailbox timeout -- ) + 2over mailbox-data dlist-contains? [ + 3drop + ] [ + 2dup >r mailbox-threads r> "mailbox" wait + block-unless-pred + ] if ; inline + +: block-if-empty ( mailbox timeout -- mailbox ) + over mailbox-empty? [ + 2dup >r mailbox-threads r> "mailbox" wait + block-if-empty + ] [ + drop + ] if ; + +: mailbox-peek ( mailbox -- obj ) + mailbox-data peek-back ; + +: mailbox-get-timeout ( mailbox timeout -- obj ) + block-if-empty mailbox-data pop-back ; + +: mailbox-get ( mailbox -- obj ) + f mailbox-get-timeout ; + +: mailbox-get-all-timeout ( mailbox timeout -- array ) + block-if-empty + [ dup mailbox-empty? ] + [ dup mailbox-data pop-back ] + [ ] unfold nip ; + +: mailbox-get-all ( mailbox -- array ) + f mailbox-get-all-timeout ; + +: while-mailbox-empty ( mailbox quot -- ) + over mailbox-empty? [ + dup >r swap slip r> while-mailbox-empty + ] [ + 2drop + ] if ; inline + +: mailbox-get-timeout? ( pred mailbox timeout -- obj ) + [ block-unless-pred ] 3keep drop + mailbox-data delete-node-if ; inline + +: mailbox-get? ( pred mailbox -- obj ) + f mailbox-get-timeout? ; inline + +TUPLE: linked-error thread ; + +: ( error thread -- linked ) + { set-delegate set-linked-error-thread } + linked-error construct ; + +: ?linked dup linked-error? [ rethrow ] when ; + +TUPLE: linked-thread supervisor ; + +M: linked-thread error-in-thread + [ ] keep + linked-thread-supervisor mailbox-put ; + +: ( quot name mailbox -- thread' ) + >r linked-thread construct-delegate r> + over set-linked-thread-supervisor ; + +: spawn-linked-to ( quot name mailbox -- thread ) + [ (spawn) ] keep ; diff --git a/extra/concurrency/messaging/authors.txt b/extra/concurrency/messaging/authors.txt new file mode 100644 index 0000000000..a8fb961d36 --- /dev/null +++ b/extra/concurrency/messaging/authors.txt @@ -0,0 +1,2 @@ +Chris Double +Slava Pestov diff --git a/extra/concurrency/messaging/messaging-docs.factor b/extra/concurrency/messaging/messaging-docs.factor new file mode 100755 index 0000000000..bee80fd357 --- /dev/null +++ b/extra/concurrency/messaging/messaging-docs.factor @@ -0,0 +1,84 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup concurrency.messaging.private +threads kernel arrays quotations ; +IN: concurrency.messaging + +HELP: send +{ $values { "message" object } + { "thread" "a thread object" } +} +{ $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } +{ $see-also receive receive-if } ; + +HELP: receive +{ $values { "message" object } +} +{ $description "Return a message from the current threades mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } +{ $see-also send receive-if } ; + +HELP: receive-if +{ $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } } + { "message" object } +} +{ $description "Return the first message from the current threades mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } +{ $see-also send receive } ; + +HELP: spawn-linked +{ $values { "quot" quotation } + { "thread" "a thread object" } +} +{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } +{ $see-also spawn } ; + +ARTICLE: { "concurrency" "messaging" } "Mailboxes" +"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued." +$nl +"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is." +$nl +"The " { $link spawn } " word pushes the newly-created thread on the calling thread's stack; this thread object can then be sent messages:" +{ $subsection send } +"A thread can get a message from its queue:" +{ $subsection receive } +{ $subsection receive-timeout } +{ $subsection receive-if } +{ $subsection receive-if-timeout } ; + +ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" +"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:" +{ $subsection send-synchronous } +"To reply to a synchronous message:" +{ $subsection reply-synchronous } +"An example:" +{ $example + "USING: concurrency.messaging kernel threads ;" + ": pong-server ( -- )" + " receive >r \"pong\" r> reply-synchronous ;" + "[ pong-server t ] spawn-server" + "\"ping\" swap send-synchronous ." + "\"pong\"" +} ; + +ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" +"A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:" +{ $code "[ 1 0 / \"This will not print\" print ] spawn" } +"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them." +{ $subsection spawn-linked } +"This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:" +{ $code "[" +" [ 1 0 / \"This will not print\" print ] spawn-linked drop" +" receive" +"] [ \"Exception caught.\" print ] recover" } +"Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; + +ARTICLE: "concurrency.messaging" "Message-passing concurrency" +"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system." +$nl +"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends." +$nl +"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." +{ $subsection { "concurrency" "messaging" } } +{ $subsection { "concurrency" "synchronous-sends" } } +{ $subsection { "concurrency" "exceptions" } } ; + +ABOUT: "concurrency.messaging" diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor new file mode 100755 index 0000000000..6de381b166 --- /dev/null +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2005 Chris Double. All Rights Reserved. +! See http://factorcode.org/license.txt for BSD license. +! +USING: kernel threads vectors arrays sequences +namespaces tools.test continuations dlists strings math words +match quotations concurrency.messaging concurrency.mailboxes ; +IN: concurrency.messaging.tests + +[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test + +[ "received" ] [ + [ + receive "received" swap reply-synchronous + ] "Synchronous test" spawn + "sent" swap send-synchronous +] unit-test + +[ 1 3 2 ] [ + 1 self send + 2 self send + 3 self send + receive + [ 2 mod 0 = not ] receive-if + receive +] unit-test + +[ + [ + "crash" throw + ] "Linked test" spawn-linked drop + receive +] [ delegate "crash" = ] must-fail-with + +MATCH-VARS: ?from ?to ?value ; +SYMBOL: increment +SYMBOL: decrement +SYMBOL: value +SYMBOL: exit + +: counter ( value -- value ? ) + receive { + { { increment ?value } [ ?value + t ] } + { { decrement ?value } [ ?value - t ] } + { { value ?from } [ dup ?from send t ] } + { exit [ f ] } + } match-cond ; + +[ -5 ] [ + [ 0 [ counter ] [ ] [ ] while ] "Counter" spawn "counter" set + { increment 10 } "counter" get send + { decrement 15 } "counter" get send + [ value , self , ] { } make "counter" get send + receive + exit "counter" get send +] unit-test \ No newline at end of file diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor new file mode 100755 index 0000000000..6915653eb4 --- /dev/null +++ b/extra/concurrency/messaging/messaging.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +! +! Concurrency library for Factor, based on Erlang/Termite style +! concurrency. +USING: kernel threads concurrency.mailboxes continuations +namespaces assocs random ; +IN: concurrency.messaging + +GENERIC: send ( message process -- ) + +: mailbox-of ( thread -- mailbox ) + dup thread-mailbox [ ] [ + dup rot set-thread-mailbox + ] ?if ; + +M: thread send ( message thread -- ) + check-registered mailbox-of mailbox-put ; + +: my-mailbox self mailbox-of ; + +: receive ( -- message ) + my-mailbox mailbox-get ?linked ; + +: receive-timeout ( timeout -- message ) + my-mailbox swap mailbox-get-timeout ?linked ; + +: receive-if ( pred -- message ) + my-mailbox mailbox-get? ?linked ; inline + +: receive-if-timeout ( pred timeout -- message ) + my-mailbox swap mailbox-get-timeout? ?linked ; inline + +: rethrow-linked ( error process supervisor -- ) + >r r> send ; + +: spawn-linked ( quot name -- thread ) + my-mailbox spawn-linked-to ; + +TUPLE: synchronous data sender tag ; + +: ( data -- sync ) + self random-256 synchronous construct-boa ; + +TUPLE: reply data tag ; + +: ( data synchronous -- reply ) + synchronous-tag \ reply construct-boa ; + +: synchronous-reply? ( response synchronous -- ? ) + over reply? + [ >r reply-tag r> synchronous-tag = ] + [ 2drop f ] if ; + +: send-synchronous ( message thread -- reply ) + dup self eq? [ + "Cannot synchronous send to myself" throw + ] [ + >r dup r> send + [ synchronous-reply? ] curry receive-if + reply-data + ] if ; + +: reply-synchronous ( message synchronous -- ) + [ ] keep synchronous-sender send ; + +: handle-synchronous ( quot -- ) + receive [ + synchronous-data swap call + ] keep reply-synchronous ; inline + + + +: register-process ( name process -- ) + swap registered-processes set-at ; + +: unregister-process ( name -- ) + registered-processes delete-at ; + +: get-process ( name -- process ) + dup registered-processes at [ ] [ thread ] ?if ; + +\ registered-processes global [ H{ } assoc-like ] change-at diff --git a/extra/concurrency/messaging/summary.txt b/extra/concurrency/messaging/summary.txt new file mode 100644 index 0000000000..a41b7edb49 --- /dev/null +++ b/extra/concurrency/messaging/summary.txt @@ -0,0 +1 @@ +Erlang/Termite-style message-passing concurrency diff --git a/extra/concurrency/promises/authors.txt b/extra/concurrency/promises/authors.txt new file mode 100644 index 0000000000..a8fb961d36 --- /dev/null +++ b/extra/concurrency/promises/authors.txt @@ -0,0 +1,2 @@ +Chris Double +Slava Pestov diff --git a/extra/concurrency/promises/promises-docs.factor b/extra/concurrency/promises/promises-docs.factor new file mode 100755 index 0000000000..a4d79d8a47 --- /dev/null +++ b/extra/concurrency/promises/promises-docs.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.messaging kernel arrays +continuations help.markup help.syntax quotations ; +IN: concurrency.promises + +HELP: promise +{ $class-description "The class of write-once promises." } ; + +HELP: promise-fulfilled? +{ $values { "promise" promise } { "?" "a boolean" } } +{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ; + +HELP: ?promise-timeout +{ $values { "promise" promise } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } } +{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." } +{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ; + +HELP: ?promise +{ $values { "promise" promise } { "value" object } } +{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled." } ; + +HELP: fulfill +{ $values { "value" object } { "promise" promise } } +{ $description "Fulfills a promise by writing a value to it. Any threads waiting for the value are notified." } +{ $errors "Throws an error if the promise has already been fulfilled." } ; + +ARTICLE: "concurrency.promises" "Promises" +"The " { $vocab-link "concurrency.promises" } " vocabulary implements " { $emphasis "promises" } ", which are thread-safe write-once variables. Once a promise is created, threads may block waiting for it to be " { $emphasis "fulfilled" } "; at some point in the future, another thread may provide a value at which point all waiting threads are notified." +{ $subsection promise } +{ $subsection } +{ $subsection fulfill } +{ $subsection ?promise } +{ $subsection ?promise-timeout } ; + +ABOUT: "concurrency.promises" diff --git a/extra/concurrency/promises/promises-tests.factor b/extra/concurrency/promises/promises-tests.factor new file mode 100755 index 0000000000..36fe4ef907 --- /dev/null +++ b/extra/concurrency/promises/promises-tests.factor @@ -0,0 +1,12 @@ +IN: concurrency.promises.tests +USING: vectors concurrency.promises kernel threads sequences +tools.test ; + +[ V{ 50 50 50 } ] [ + 0 + + [ ?promise swap push ] in-thread + [ ?promise swap push ] in-thread + [ ?promise swap push ] in-thread + 50 swap fulfill +] unit-test diff --git a/extra/concurrency/promises/promises.factor b/extra/concurrency/promises/promises.factor new file mode 100755 index 0000000000..b7ccff7fa7 --- /dev/null +++ b/extra/concurrency/promises/promises.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.mailboxes kernel continuations ; +IN: concurrency.promises + +TUPLE: promise mailbox ; + +: ( -- promise ) + promise construct-boa ; + +: promise-fulfilled? ( promise -- ? ) + promise-mailbox mailbox-empty? not ; + +: fulfill ( value promise -- ) + dup promise-fulfilled? [ + "Promise already fulfilled" throw + ] [ + promise-mailbox mailbox-put + ] if ; + +: ?promise-timeout ( promise timeout -- result ) + >r promise-mailbox r> block-if-empty mailbox-peek ; + +: ?promise ( promise -- result ) + f ?promise-timeout ; diff --git a/extra/concurrency/promises/summary.txt b/extra/concurrency/promises/summary.txt new file mode 100644 index 0000000000..96c70cb31a --- /dev/null +++ b/extra/concurrency/promises/summary.txt @@ -0,0 +1 @@ +Thread-safe write-once variables diff --git a/extra/tools/interpreter/authors.txt b/extra/concurrency/semaphores/authors.txt similarity index 100% rename from extra/tools/interpreter/authors.txt rename to extra/concurrency/semaphores/authors.txt diff --git a/extra/concurrency/semaphores/semaphores-docs.factor b/extra/concurrency/semaphores/semaphores-docs.factor new file mode 100755 index 0000000000..76a87f2077 --- /dev/null +++ b/extra/concurrency/semaphores/semaphores-docs.factor @@ -0,0 +1,56 @@ +IN: concurrency.semaphores +USING: help.markup help.syntax kernel quotations calendar ; + +HELP: semaphore +{ $class-description "The class of counting semaphores." } ; + +HELP: +{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } } +{ $description "Creates a counting semaphore with the specified initial count." } ; + +HELP: acquire-timeout +{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "value" object } } +{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." } +{ $errors "Throws an error if the timeout expires before the semaphore is released." } ; + +HELP: acquire +{ $values { "semaphore" semaphore } { "value" object } } +{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, waits for it to be released." } ; + +HELP: release +{ $values { "semaphore" semaphore } } +{ $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ; + +HELP: with-semaphore-timeout +{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } +{ $description "Calls the quotation with the semaphore held." } ; + +HELP: with-semaphore +{ $values { "semaphore" semaphore } { "quot" quotation } } +{ $description "Calls the quotation with the semaphore held." } ; + +ARTICLE: "concurrency.semaphores" "Counting semaphores" +"Counting semaphores are used to ensure that no more than a fixed number of threads are executing in a critical section at a time; as such, they generalize " { $link "concurrency.locks.mutex" } ", since locks can be thought of as semaphores with an initial count of 1." +$nl +"A use-case would be a batch processing server which runs a large number of jobs which perform calculations but then need to fire off expensive external processes or perform heavy network I/O. While for most of the time, the threads can all run in parallel, it might be desired that the expensive operation is not run by more than 10 threads at once, to avoid thrashing swap space or saturating the network. This can be accomplished with a counting semaphore:" +{ $code + "SYMBOL: expensive-section" + "10 expensive-section set-global" + "requests [" + " ..." + " expensive-section [ do-expensive-stuff ] with-semaphore" + " ..." + "] parallel-map" +} +"Creating semaphores:" +{ $subsection semaphore } +{ $subsection } +"Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:" +{ $subsection acquire } +{ $subsection acquire-timeout } +{ $subsection release } +"Combinators which pair acquisition and release:" +{ $subsection with-semaphore } +{ $subsection with-semaphore-timeout } ; + +ABOUT: "concurrency.semaphores" diff --git a/extra/concurrency/semaphores/semaphores.factor b/extra/concurrency/semaphores/semaphores.factor new file mode 100755 index 0000000000..031614ea95 --- /dev/null +++ b/extra/concurrency/semaphores/semaphores.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: dlists kernel threads math concurrency.conditions +continuations ; +IN: concurrency.semaphores + +TUPLE: semaphore count threads ; + +: ( n -- semaphore ) + dup 0 < [ "Cannot have semaphore with negative count" throw ] when + semaphore construct-boa ; + +: wait-to-acquire ( semaphore timeout -- ) + >r semaphore-threads r> "semaphore" wait ; + +: acquire-timeout ( semaphore timeout -- ) + over semaphore-count zero? + [ dupd wait-to-acquire ] [ drop ] if + dup semaphore-count 1- swap set-semaphore-count ; + +: acquire ( semaphore -- ) + f acquire-timeout ; + +: release ( semaphore -- ) + dup semaphore-count 1+ over set-semaphore-count + semaphore-threads notify-1 ; + +: with-semaphore-timeout ( semaphore timeout quot -- ) + pick rot acquire-timeout swap + [ release ] curry [ ] cleanup ; inline + +: with-semaphore ( semaphore quot -- ) + over acquire swap [ release ] curry [ ] cleanup ; inline diff --git a/extra/concurrency/semaphores/summary.txt b/extra/concurrency/semaphores/summary.txt new file mode 100644 index 0000000000..15883d541f --- /dev/null +++ b/extra/concurrency/semaphores/summary.txt @@ -0,0 +1 @@ +Counting semaphores diff --git a/extra/concurrency/summary.txt b/extra/concurrency/summary.txt deleted file mode 100644 index 7f48dd43b4..0000000000 --- a/extra/concurrency/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Erlang-style concurrency diff --git a/extra/coroutines/coroutines-tests.factor b/extra/coroutines/coroutines-tests.factor index 52b1123265..6710452b22 100644 --- a/extra/coroutines/coroutines-tests.factor +++ b/extra/coroutines/coroutines-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither. ! See http://factorcode.org/license.txt for BSD license. -IN: temporary +IN: coroutines.tests USING: coroutines kernel sequences prettyprint tools.test math ; : test1 ( -- co ) diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index 64efb96f90..35c99258db 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -1,5 +1,5 @@ USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ; -IN: temporary +IN: crypto.hmac.tests [ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" string>md5-hmac >string ] unit-test [ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index fe215e32db..631a7a1020 100644 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -32,7 +32,7 @@ SYMBOL: old-d old-c c update-old-new old-d d update-old-new ; -:: (ABCD) | x s i k func a b c d | +:: (ABCD) ( x s i k func a b c d -- ) #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) a [ b get c get d get func call w+ diff --git a/extra/crypto/random.factor b/extra/crypto/random.factor old mode 100644 new mode 100755 index 74dd2dba13..f2d3b0555a --- a/extra/crypto/random.factor +++ b/extra/crypto/random.factor @@ -1,5 +1,5 @@ USING: kernel math math-contrib sequences namespaces errors -hashtables words arrays parser compiler syntax io threads ; +hashtables words arrays parser compiler syntax io ; IN: crypto : make-bits ( quot numbits -- n | quot: -- 0/1 ) 0 -rot [ drop dup call rot 1 shift bitor swap ] each drop ; diff --git a/extra/crypto/timing/timing-tests.factor b/extra/crypto/timing/timing-tests.factor index 1337ccca8a..9afb913724 100644 --- a/extra/crypto/timing/timing-tests.factor +++ b/extra/crypto/timing/timing-tests.factor @@ -1,4 +1,4 @@ USING: crypto.timing kernel tools.test system math ; -IN: temporary +IN: crypto.timing.tests [ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test diff --git a/extra/crypto/xor/xor-tests.factor b/extra/crypto/xor/xor-tests.factor index 2a6fd525e0..ef781b9f25 100644 --- a/extra/crypto/xor/xor-tests.factor +++ b/extra/crypto/xor/xor-tests.factor @@ -1,5 +1,5 @@ USING: continuations crypto.xor kernel strings tools.test ; -IN: temporary +IN: crypto.xor.tests ! No key [ "" dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with diff --git a/extra/db/db.factor b/extra/db/db.factor index d88bbaee03..e834144d0c 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -1,40 +1,48 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations kernel math -namespaces sequences sequences.lib tuples words strings ; +namespaces sequences sequences.lib tuples words strings +tools.walker new-slots accessors ; IN: db -TUPLE: db handle insert-statements update-statements delete-statements ; +TUPLE: db + handle + insert-statements + update-statements + delete-statements ; + : ( handle -- obj ) H{ } clone H{ } clone H{ } clone db construct-boa ; +GENERIC: make-db* ( seq class -- db ) GENERIC: db-open ( db -- ) HOOK: db-close db ( handle -- ) +: make-db ( seq class -- db ) construct-empty make-db* ; : dispose-statements ( seq -- ) [ dispose drop ] assoc-each ; : dispose-db ( db -- ) dup db [ - dup db-insert-statements dispose-statements - dup db-update-statements dispose-statements - dup db-delete-statements dispose-statements - db-handle db-close + dup insert-statements>> dispose-statements + dup update-statements>> dispose-statements + dup delete-statements>> dispose-statements + handle>> db-close ] with-variable ; -TUPLE: statement sql params handle bound? slot-names ; +TUPLE: statement handle sql in-params out-params bind-params bound? ; TUPLE: simple-statement ; TUPLE: prepared-statement ; - -HOOK: db ( str -- statement ) -HOOK: db ( str -- statement ) -GENERIC: prepare-statement ( statement -- ) -GENERIC: bind-statement* ( obj statement -- ) -GENERIC: reset-statement ( statement -- ) -GENERIC: insert-statement ( statement -- id ) - TUPLE: result-set sql params handle n max ; +: ( sql in out -- statement ) + { (>>sql) (>>in-params) (>>out-params) } statement construct ; + +HOOK: db ( str in out -- statement ) +HOOK: db ( str in out -- statement ) +GENERIC: prepare-statement ( statement -- ) +GENERIC: bind-statement* ( statement -- ) +GENERIC: bind-tuple ( tuple statement -- ) GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) GENERIC: #columns ( result-set -- n ) @@ -42,25 +50,26 @@ GENERIC# row-column 1 ( result-set n -- obj ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) -: execute-statement ( statement -- ) query-results dispose ; +: execute-statement ( statement -- ) + dup sequence? [ + [ execute-statement ] each + ] [ + query-results dispose + ] if ; : bind-statement ( obj statement -- ) - dup statement-bound? [ dup reset-statement ] when - [ bind-statement* ] 2keep - [ set-statement-params ] keep - t swap set-statement-bound? ; + swap >>bind-params + [ bind-statement* ] keep + t >>bound? drop ; : init-result-set ( result-set -- ) - dup #rows over set-result-set-max - 0 swap set-result-set-n ; + dup #rows >>max + 0 >>n drop ; : ( query handle tuple -- result-set ) - >r >r { statement-sql statement-params } get-slots r> - { - set-result-set-sql - set-result-set-params - set-result-set-handle - } result-set construct r> construct-delegate ; + >r >r { sql>> in-params>> } get-slots r> + { (>>sql) (>>params) (>>handle) } result-set + construct r> construct-delegate ; : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; @@ -75,22 +84,19 @@ GENERIC: more-rows? ( result-set -- ? ) : query-map ( statement quot -- seq ) accumulator >r query-each r> { } like ; inline -: with-db ( db quot -- ) - [ - over db-open - [ db swap with-variable ] curry with-disposal - ] with-scope ; +: with-db ( db seq quot -- ) + >r make-db dup db-open db r> + [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ; -: do-query ( query -- result-set ) +: default-query ( query -- result-set ) query-results [ [ sql-row ] query-map ] with-disposal ; : do-bound-query ( obj query -- rows ) - [ bind-statement ] keep do-query ; + [ bind-statement ] keep default-query ; : do-bound-command ( obj query -- ) [ bind-statement ] keep execute-statement ; - SYMBOL: in-transaction HOOK: begin-transaction db ( -- ) HOOK: commit-transaction db ( -- ) @@ -105,11 +111,11 @@ HOOK: rollback-transaction db ( -- ) ] with-variable ; : sql-query ( sql -- rows ) - [ do-query ] with-disposal ; + f f [ default-query ] with-disposal ; : sql-command ( sql -- ) dup string? [ - [ execute-statement ] with-disposal + f f [ execute-statement ] with-disposal ] [ ! [ [ sql-command ] each diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor old mode 100644 new mode 100755 index c48eff964a..25b3a6d2cf --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -2,21 +2,25 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types -db.types ; +db.types tools.walker ascii splitting ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) dup zero? [ drop f ] [ - PQresultErrorMessage [ CHAR: \n = ] right-trim + PQresultErrorMessage [ blank? ] trim ] if ; : postgres-result-error ( res -- ) postgresql-result-error-message [ throw ] when* ; +: (postgresql-error-message) ( handle -- str ) + PQerrorMessage + "\n" split [ [ blank? ] trim ] map "\n" join ; + : postgresql-error-message ( -- str ) - db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ; + db get db-handle (postgresql-error-message) ; : postgresql-error ( res -- res ) dup [ postgresql-error-message throw ] unless ; @@ -27,7 +31,7 @@ IN: db.postgresql.lib : connect-postgres ( host port pgopts pgtty db user pass -- conn ) PQsetdbLogin - dup PQstatus zero? [ postgresql-error-message throw ] unless ; + dup PQstatus zero? [ (postgresql-error-message) throw ] unless ; : do-postgresql-statement ( statement -- res ) db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [ @@ -37,9 +41,9 @@ IN: db.postgresql.lib : do-postgresql-bound-statement ( statement -- res ) >r db get db-handle r> [ statement-sql ] keep - [ statement-params length f ] keep - statement-params - [ first number>string* malloc-char-string ] map >c-void*-array + [ statement-bind-params length f ] keep + statement-bind-params + [ number>string* malloc-char-string ] map >c-void*-array f f 0 PQexecParams dup postgresql-result-ok? [ dup postgresql-result-error-message swap PQclear throw diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor old mode 100644 new mode 100755 index 36b6fc829b..250f98f73e --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -1,14 +1,13 @@ ! You will need to run 'createdb factor-test' to create the database. ! Set username and password in the 'connect' word. -USING: kernel db.postgresql alien continuations io prettyprint -sequences namespaces tools.test db db.types ; -IN: temporary +USING: kernel db.postgresql alien continuations io classes +prettyprint sequences namespaces tools.test db +db.tuples db.types unicode.case ; +IN: db.postgresql.tests -IN: scratchpad : test-db ( -- postgresql-db ) - "localhost" "postgres" "" "factor-test" ; -IN: temporary + { "localhost" "postgres" "" "factor-test" } postgresql-db ; [ ] [ test-db [ ] with-db ] unit-test @@ -39,7 +38,7 @@ IN: temporary ] [ test-db [ "select * from person where name = $1 and country = $2" - [ + f f [ { { "Jane" TEXT } { "New Zealand" TEXT } } over do-bound-query @@ -108,3 +107,248 @@ IN: temporary "select * from person" sql-query length ] with-db ] unit-test + + +: with-dummy-db ( quot -- ) + >r T{ postgresql-db } db r> with-variable ; + +! TEST TUPLE DB + +TUPLE: puppy id name age ; +: ( name age -- puppy ) + { set-puppy-name set-puppy-age } puppy construct ; + +puppy "PUPPY" { + { "id" "ID" +native-id+ +not-null+ } + { "name" "NAME" { VARCHAR 256 } } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: kitty id name age ; +: ( name age -- kitty ) + { set-kitty-name set-kitty-age } kitty construct ; + +kitty "KITTY" { + { "id" "ID" INTEGER +assigned-id+ } + { "name" "NAME" TEXT } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: basket id puppies kitties ; +basket "BASKET" +{ + { "id" "ID" +native-id+ +not-null+ } + { "location" "LOCATION" TEXT } + { "puppies" { +has-many+ puppy } } + { "kitties" { +has-many+ kitty } } +} define-persistent + +! Create table +[ + "create table puppy(id serial primary key not null, name varchar 256, age integer);" +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table create-table-sql >lower + ] with-variable +] unit-test + +[ + "create table kitty(id integer primary key, name text, age integer);" +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table create-table-sql >lower + ] with-variable +] unit-test + +[ + "create table basket(id serial primary key not null, location text);" +] [ + T{ postgresql-db } db [ + basket dup db-columns swap db-table create-table-sql >lower + ] with-variable +] unit-test + +! Create function +[ + "create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;" +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table create-function-sql >lower + ] with-variable +] unit-test + +! Drop table + +[ + "drop table puppy;" +] [ + T{ postgresql-db } db [ + puppy db-table drop-table-sql >lower + ] with-variable +] unit-test + +[ + "drop table kitty;" +] [ + T{ postgresql-db } db [ + kitty db-table drop-table-sql >lower + ] with-variable +] unit-test + +[ + "drop table basket;" +] [ + T{ postgresql-db } db [ + basket db-table drop-table-sql >lower + ] with-variable +] unit-test + + +! Drop function +[ + "drop function add_puppy(varchar, integer);" +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table drop-function-sql >lower + ] with-variable +] unit-test + +! Insert +[ +] [ + T{ postgresql-db } db [ + puppy + ] with-variable +] unit-test + +[ + "insert into kitty(id, name, age) values($1, $2, $3);" + { + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + T{ sql-spec f "name" "NAME" TEXT { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } + { } +] [ + T{ postgresql-db } db [ + kitty + ] with-variable +] unit-test + +! Update +[ + "update puppy set name = $1, age = $2 where id = $3" + { + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table >r >r >lower r> r> + ] with-variable +] unit-test + +[ + "update kitty set name = $1, age = $2 where id = $3" + { + T{ sql-spec f "name" "NAME" TEXT { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table >r >r >lower r> r> + ] with-variable +] unit-test + +! Delete +[ + "delete from puppy where id = $1" + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table >r >r >lower r> r> + ] with-variable +] unit-test + +[ + "delete from KITTY where ID = $1" + { + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table + ] with-variable +] unit-test + +! Select +[ + "select from PUPPY ID, NAME, AGE where NAME = $1;" + { T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } } + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } +] [ + T{ postgresql-db } db [ + T{ puppy f f "Mr. Clunkers" } + + ] with-variable +] unit-test diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 03746bcaa0..9383a9290c 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -4,25 +4,28 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges -combinators ; +combinators sequences.lib classes locals words tools.walker ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; TUPLE: postgresql-statement ; TUPLE: postgresql-result-set ; -: ( statement -- postgresql-statement ) +: ( statement in out -- postgresql-statement ) + postgresql-statement construct-delegate ; -: ( host user pass db -- obj ) - { - set-postgresql-db-host - set-postgresql-db-user - set-postgresql-db-pass - set-postgresql-db-db - } postgresql-db construct ; +M: postgresql-db make-db* ( seq tuple -- db ) + >r first4 r> [ + { + set-postgresql-db-host + set-postgresql-db-user + set-postgresql-db-pass + set-postgresql-db-db + } set-slots + ] keep ; M: postgresql-db db-open ( db -- ) - dup { + dup { postgresql-db-host postgresql-db-port postgresql-db-pgopts @@ -35,15 +38,15 @@ M: postgresql-db db-open ( db -- ) M: postgresql-db dispose ( db -- ) db-handle PQfinish ; -: with-postgresql ( host ust pass db quot -- ) - >r r> with-disposal ; - -M: postgresql-statement bind-statement* ( seq statement -- ) - set-statement-params ; - -M: postgresql-statement reset-statement ( statement -- ) +M: postgresql-statement bind-statement* ( statement -- ) drop ; +M: postgresql-statement bind-tuple ( tuple statement -- ) + [ + statement-in-params + [ sql-spec-slot-name swap get-slot-named ] with map + ] keep set-statement-bind-params ; + M: postgresql-result-set #rows ( result-set -- n ) result-set-handle PQntuples ; @@ -56,19 +59,8 @@ M: postgresql-result-set row-column ( result-set n -- obj ) M: postgresql-result-set row-column-typed ( result-set n type -- obj ) >r row-column r> sql-type>factor-type ; -M: postgresql-result-set sql-type>factor-type ( obj type -- newobj ) - { - { INTEGER [ string>number ] } - { BIG_INTEGER [ string>number ] } - { DOUBLE [ string>number ] } - [ drop ] - } case ; - -M: postgresql-statement insert-statement ( statement -- id ) - query-results [ 0 row-column ] with-disposal string>number ; - M: postgresql-statement query-results ( query -- result-set ) - dup statement-params [ + dup statement-bind-params [ over [ bind-statement ] keep do-postgresql-bound-statement ] [ @@ -96,17 +88,15 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) [ >r db get db-handle "" r> - dup statement-sql swap statement-params + dup statement-sql swap statement-in-params length f PQprepare postgresql-error ] keep set-statement-handle ; -M: postgresql-db ( sql -- statement ) - { set-statement-sql } statement construct +M: postgresql-db ( sql in out -- statement ) ; -M: postgresql-db ( sql -- statement ) - { set-statement-sql } statement construct - ; +M: postgresql-db ( sql in out -- statement ) + dup prepare-statement ; M: postgresql-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -117,139 +107,176 @@ M: postgresql-db commit-transaction ( -- ) M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -: postgresql-type-hash* ( -- assoc ) - H{ - { SERIAL "serial" } - } ; +SYMBOL: postgresql-counter +: bind-name% ( -- ) + CHAR: $ 0, + postgresql-counter [ inc ] keep get 0# ; -: postgresql-type-hash ( -- assoc ) +M: postgresql-db bind% ( spec -- ) + 1, bind-name% ; + +: postgresql-make ( class quot -- ) + >r sql-props r> + [ postgresql-counter off ] swap compose + { "" { } { } } nmake ; + +: create-table-sql ( class -- statement ) + [ + "create table " 0% 0% + "(" 0% + [ ", " 0% ] [ + dup sql-spec-column-name 0% + " " 0% + dup sql-spec-type t lookup-type 0% + modifiers 0% + ] interleave ");" 0% + ] postgresql-make ; + +: create-function-sql ( class -- statement ) + [ + >r remove-id r> + "create function add_" 0% dup 0% + "(" 0% + over [ "," 0% ] + [ + sql-spec-type f lookup-type 0% + ] interleave + ")" 0% + " returns bigint as '" 0% + + "insert into " 0% + dup 0% + "(" 0% + over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ") values(" 0% + swap [ ", " 0% ] [ drop bind-name% ] interleave + "); " 0% + "select currval(''" 0% 0% "_id_seq'');' language sql;" 0% + ] postgresql-make ; + +M: postgresql-db create-sql-statement ( class -- seq ) + [ + [ create-table-sql , ] keep + dup db-columns find-primary-key native-id? + [ create-function-sql , ] [ drop ] if + ] { } make ; + +: drop-function-sql ( class -- statement ) + [ + "drop function add_" 0% 0% + "(" 0% + remove-id + [ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave + ");" 0% + ] postgresql-make ; + +: drop-table-sql ( table -- statement ) + [ + "drop table " 0% 0% ";" 0% drop + ] 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 , ] [ drop ] if + ] { } make ; + +M: postgresql-db ( class -- statement ) + [ + "select add_" 0% 0% + "(" 0% + dup find-primary-key 2, + remove-id + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] postgresql-make ; + +M: postgresql-db ( class -- statement ) + [ + "insert into " 0% 0% + "(" 0% + dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ")" 0% + + " values(" 0% + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] postgresql-make ; + +M: postgresql-db insert-tuple* ( tuple statement -- ) + query-modify-tuple ; + +M: postgresql-db ( class -- statement ) + [ + "update " 0% 0% + " set " 0% + dup remove-id + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + " where " 0% + find-primary-key + dup sql-spec-column-name 0% " = " 0% bind% + ] postgresql-make ; + +M: postgresql-db ( class -- statement ) + [ + "delete from " 0% 0% + " where " 0% + find-primary-key + dup sql-spec-column-name 0% " = " 0% bind% + ] postgresql-make ; + +M: postgresql-db ( tuple class -- statement ) + [ + ! tuple columns table + "select " 0% + over [ ", " 0% ] + [ dup sql-spec-column-name 0% 2, ] interleave + + " from " 0% 0% + [ sql-spec-slot-name swap get-slot-named ] with subset + " where " 0% + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ";" 0% + ] postgresql-make ; + +M: postgresql-db type-table ( -- hash ) H{ - { INTEGER "integer" } - { SERIAL "integer" } + { +native-id+ "integer" } { TEXT "text" } { VARCHAR "varchar" } + { INTEGER "integer" } { DOUBLE "real" } + { TIMESTAMP "timestamp" } } ; -: enquote ( str -- newstr ) "(" swap ")" 3append ; - -: postgresql-type ( str n/str -- newstr ) - " " swap number>string* enquote 3append ; - -: >sql-type* ( obj -- str ) - dup pair? [ - first2 >r >sql-type* r> postgresql-type - ] [ - dup postgresql-type-hash* at* [ - nip - ] [ - drop >sql-type - ] if - ] if ; - -M: postgresql-db >sql-type ( hash obj -- str ) - dup pair? [ - first2 >r >sql-type r> postgresql-type - ] [ - postgresql-type-hash at* [ - no-sql-type - ] unless - ] if ; - -: insert-function ( columns table -- sql ) - [ - >r remove-id r> - "create function add_" % dup % - "(" % - over [ "," % ] - [ third dup array? [ first ] when >sql-type % ] interleave - ")" % - " returns bigint as '" % - - 2dup "insert into " % - % - "(" % - dup [ ", " % ] [ second % ] interleave - ") " % - " values (" % - length [1,b] [ ", " % ] [ "$" % # ] interleave - "); " % - - "select currval(''" % % "_id_seq'');' language sql;" % - drop - ] "" make ; - -: drop-function ( columns table -- sql ) - [ - >r remove-id r> - "drop function add_" % % - "(" % - [ "," % ] [ third >sql-type % ] interleave - ")" % - ] "" make ; - -M: postgresql-db create-sql ( columns table -- seq ) - [ - [ - 2dup - "create table " % % - " (" % [ ", " % ] [ - dup second % " " % - dup third >sql-type* % " " % - sql-modifiers " " join % - ] interleave "); " % - ] "" make , - - over native-id? [ insert-function , ] [ 2drop ] if - ] { } make ; - -M: postgresql-db drop-sql ( columns table -- seq ) - [ - [ - dup "drop table " % % ";" % - ] "" make , - over native-id? [ drop-function , ] [ 2drop ] if - ] { } make ; - -M: postgresql-db insert-sql* ( columns table -- slot-names sql ) - [ - "select add_" % % - "(" % - length [1,b] [ ", " % ] [ "$" % # ] interleave - ")" % - ] "" make ; - -M: postgresql-db update-sql* ( columns table -- slot-names sql ) - [ - "update " % - % - " set " % - dup remove-id - dup length [1,b] swap 2array flip - [ ", " % ] [ first2 second % " = $" % # ] interleave - " where " % - [ primary-key? ] find nip second dup % " = $" % length 2 + # - ] "" make ; - -M: postgresql-db delete-sql* ( columns table -- slot-names sql ) - [ - "delete from " % - % - " where " % - first second % " = $1" % - ] "" make ; - -M: postgresql-db select-sql ( columns table -- slot-names sql ) - drop ; - -M: postgresql-db tuple>params ( columns tuple -- obj ) - [ >r dup third swap first r> get-slot-named swap ] - curry { } map>assoc ; - -: postgresql-db-modifiers ( -- hashtable ) +M: postgresql-db create-type-table ( -- hash ) H{ - { +native-id+ "not null primary key" } + { +native-id+ "serial primary key" } + } ; + +: postgresql-compound ( str n -- newstr ) + over { + { "default" [ first number>string join-space ] } + { "varchar" [ first number>string paren append ] } + { "references" [ + first2 >r [ unparse join-space ] keep db-columns r> + swap [ sql-spec-slot-name = ] with find nip + sql-spec-column-name paren append + ] } + [ "no compound found" 3array throw ] + } case ; + +M: postgresql-db compound-modifier ( str seq -- newstr ) + postgresql-compound ; + +M: postgresql-db modifier-table ( -- hashtable ) + H{ + { +native-id+ "primary key" } { +assigned-id+ "primary key" } + { +foreign-id+ "references" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } @@ -257,13 +284,5 @@ M: postgresql-db tuple>params ( columns tuple -- obj ) { +not-null+ "not null" } } ; -M: postgresql-db sql-modifiers* ( modifiers -- str ) - postgresql-db-modifiers swap [ - dup array? [ - first2 - >r swap at r> number>string* - " " swap 3append - ] [ - swap at - ] if - ] with map [ ] subset ; +M: postgresql-db compound-type ( str n -- newstr ) + postgresql-compound ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 85aa671d4d..648d8493dc 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -78,7 +78,8 @@ IN: db.sqlite.lib { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { SERIAL [ sqlite-bind-int-by-name ] } + { TIMESTAMP [ sqlite-bind-double-by-name ] } + { +native-id+ [ sqlite-bind-int-by-name ] } ! { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -102,6 +103,8 @@ IN: db.sqlite.lib { BIG_INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } + { TIMESTAMP [ sqlite3_column_double ] } + [ no-sql-type ] } case ; ! TODO diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor old mode 100644 new mode 100755 index d3388b4648..974fdb8782 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,7 +1,7 @@ USING: io io.files io.launcher kernel namespaces prettyprint tools.test db.sqlite db sequences -continuations db.types ; -IN: temporary +continuations db.types db.tuples unicode.case ; +IN: db.sqlite.tests : test.db "extra/db/sqlite/test.db" resource-path ; @@ -89,3 +89,158 @@ IN: temporary "select * from person" sql-query length ] with-sqlite ] unit-test + +! TEST TUPLE DB + +TUPLE: puppy id name age ; +: ( name age -- puppy ) + { set-puppy-name set-puppy-age } puppy construct ; + +puppy "PUPPY" { + { "id" "ID" +native-id+ +not-null+ } + { "name" "NAME" { VARCHAR 256 } } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: kitty id name age ; +: ( name age -- kitty ) + { set-kitty-name set-kitty-age } kitty construct ; + +kitty "KITTY" { + { "id" "ID" INTEGER +assigned-id+ } + { "name" "NAME" TEXT } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: basket id puppies kitties ; +basket "BASKET" +{ + { "id" "ID" +native-id+ +not-null+ } + { "location" "LOCATION" TEXT } + { "puppies" { +has-many+ puppy } } + { "kitties" { +has-many+ kitty } } +} define-persistent + +! Create table +[ + "create table puppy(id integer primary key not null, name varchar, age integer);" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +[ + "create table kitty(id integer primary key, name text, age integer);" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +[ + "create table basket(id integer primary key not null, location text);" +] [ + T{ sqlite-db } db [ + basket dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +! Drop table +[ + "drop table puppy;" +] [ + T{ sqlite-db } db [ + puppy db-table drop-sql >lower + ] with-variable +] unit-test + +[ + "drop table kitty;" +] [ + T{ sqlite-db } db [ + kitty db-table drop-sql >lower + ] with-variable +] unit-test + +[ + "drop table basket;" +] [ + T{ sqlite-db } db [ + basket db-table drop-sql >lower + ] with-variable +] unit-test + +! Insert +[ + "insert into puppy(name, age) values(:name, :age);" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table insert-sql* >lower + ] with-variable +] unit-test + +[ + "insert into kitty(id, name, age) values(:id, :name, :age);" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table insert-sql* >lower + ] with-variable +] unit-test + +! Update +[ + "update puppy set name = :name, age = :age where id = :id" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table update-sql* >lower + ] with-variable +] unit-test + +[ + "update kitty set name = :name, age = :age where id = :id" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table update-sql* >lower + ] with-variable +] unit-test + +! Delete +[ + "delete from puppy where id = :id" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table delete-sql* >lower + ] with-variable +] unit-test + +[ + "delete from kitty where id = :id" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table delete-sql* >lower + ] with-variable +] unit-test + +! Select +[ + "select from puppy id, name, age where name = :name;" + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } +] [ + T{ sqlite-db } db [ + T{ puppy f f "Mr. Clunkers" } + select-sql >r >lower r> + ] with-variable +] unit-test diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 4eabfc2ecd..cfdcfc7750 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -4,11 +4,14 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types ; +words combinators.lib db.types combinators tools.walker +combinators.cleave io ; IN: db.sqlite TUPLE: sqlite-db path ; -C: sqlite-db + +M: sqlite-db make-db* ( path db -- db ) + [ set-sqlite-db-path ] keep ; M: sqlite-db db-open ( db -- ) dup sqlite-db-path sqlite-open @@ -19,11 +22,7 @@ M: sqlite-db db-close ( handle -- ) M: sqlite-db dispose ( db -- ) dispose-db ; -: with-sqlite ( path quot -- ) - >r r> with-db ; inline - TUPLE: sqlite-statement ; -C: sqlite-statement TUPLE: sqlite-result-set has-more? ; @@ -31,9 +30,14 @@ M: sqlite-db ( str -- obj ) ; M: sqlite-db ( str -- obj ) - db get db-handle over sqlite-prepare - { set-statement-sql set-statement-handle } statement construct - [ set-delegate ] keep ; + { + set-statement-sql + set-statement-in-params + set-statement-out-params + } statement construct + db get db-handle over statement-sql sqlite-prepare + over set-statement-handle + sqlite-statement construct-delegate ; M: sqlite-statement dispose ( statement -- ) statement-handle sqlite-finalize ; @@ -44,18 +48,31 @@ M: sqlite-result-set dispose ( result-set -- ) : sqlite-bind ( triples handle -- ) swap [ first3 sqlite-bind-type ] with each ; -M: sqlite-statement bind-statement* ( triples statement -- ) - statement-handle sqlite-bind ; - -M: sqlite-statement reset-statement ( statement -- ) +: reset-statement ( statement -- ) statement-handle sqlite-reset ; +M: sqlite-statement bind-statement* ( statement -- ) + dup statement-bound? [ dup reset-statement ] when + [ statement-bind-params ] [ statement-handle ] bi + sqlite-bind ; + +M: sqlite-statement bind-tuple ( tuple statement -- ) + [ + statement-in-params + [ + [ sql-spec-column-name ":" swap append ] + [ sql-spec-slot-name rot get-slot-named ] + [ sql-spec-type ] tri 3array + ] with map + ] keep + bind-statement ; + : last-insert-id ( -- id ) db get db-handle sqlite3_last_insert_rowid dup zero? [ "last-id failed" throw ] when ; -M: sqlite-statement insert-statement ( statement -- id ) - execute-statement last-insert-id ; +M: sqlite-db insert-tuple* ( tuple statement -- ) + execute-statement last-insert-id swap set-primary-key ; M: sqlite-result-set #columns ( result-set -- n ) result-set-handle sqlite-#columns ; @@ -86,78 +103,87 @@ M: sqlite-db commit-transaction ( -- ) M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -M: sqlite-db create-sql ( columns table -- sql ) - [ - "create table " % % - " (" % [ ", " % ] [ - dup second % " " % - dup third >sql-type % " " % - sql-modifiers " " join % - ] interleave ")" % - ] "" make ; +: sqlite-make ( class quot -- ) + >r sql-props r> + { "" { } { } } nmake ; -M: sqlite-db drop-sql ( columns table -- sql ) +M: sqlite-db create-sql-statement ( class -- statement ) [ - "drop table " % % - drop - ] "" make ; + "create table " 0% 0% + "(" 0% [ ", " 0% ] [ + dup sql-spec-column-name 0% + " " 0% + dup sql-spec-type t lookup-type 0% + modifiers 0% + ] interleave ");" 0% + ] sqlite-make ; -M: sqlite-db insert-sql* ( columns table -- sql ) +M: sqlite-db drop-sql-statement ( class -- statement ) [ - "insert into " % - % - "(" % - dup [ ", " % ] [ second % ] interleave - ") " % - " values (" % - [ ", " % ] [ ":" % second % ] interleave - ")" % - ] "" make ; + "drop table " 0% 0% ";" 0% drop + ] sqlite-make ; -: where-primary-key% ( columns -- ) - " where " % - [ primary-key? ] find nip second dup % " = :" % % ; - -M: sqlite-db update-sql* ( columns table -- sql ) +M: sqlite-db ( tuple -- statement ) [ - "update " % - % - " set " % + "insert into " 0% 0% + "(" 0% + maybe-remove-id + dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ") values(" 0% + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] sqlite-make ; + +M: sqlite-db ( tuple -- statement ) + ; + +: where-primary-key% ( specs -- ) + " where " 0% + find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ; + +M: sqlite-db ( class -- statement ) + [ + "update " 0% + 0% + " set " 0% dup remove-id - [ ", " % ] [ second dup % " = :" % % ] interleave + [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave where-primary-key% - ] "" make ; + ] sqlite-make ; -M: sqlite-db delete-sql* ( columns table -- sql ) +M: sqlite-db ( specs table -- sql ) [ - "delete from " % - % - " where " % - first second dup % " = :" % % - ] "" make ; + "delete from " 0% 0% + " where " 0% + find-primary-key + dup sql-spec-column-name 0% " = " 0% bind% + ] sqlite-make ; -: select-interval ( interval name -- ) - ; +! : select-interval ( interval name -- ) ; +! : select-sequence ( seq name -- ) ; -: select-sequence ( seq name -- ) - ; +M: sqlite-db bind% ( spec -- ) + dup 1, sql-spec-column-name ":" swap append 0% ; -M: sqlite-db select-sql ( columns table -- sql ) +M: sqlite-db ( tuple class -- statement ) [ - "select ROWID, " % - over [ ", " % ] [ second % ] interleave - " from " % % - " where " % - ] "" make ; + "select " 0% + over [ ", " 0% ] + [ dup sql-spec-column-name 0% 2, ] interleave -M: sqlite-db tuple>params ( columns tuple -- obj ) - [ - >r [ second ":" swap append ] keep r> - dupd >r first r> get-slot-named swap - third 3array - ] curry map ; + " from " 0% 0% + [ sql-spec-slot-name swap get-slot-named ] with subset + dup empty? [ + drop + ] [ + " where " 0% + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ";" 0% + ] if + ] sqlite-make ; -: sqlite-db-modifiers ( -- hashtable ) +M: sqlite-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } @@ -168,33 +194,24 @@ M: sqlite-db tuple>params ( columns tuple -- obj ) { +not-null+ "not null" } } ; -M: sqlite-db sql-modifiers* ( modifiers -- str ) - sqlite-db-modifiers swap [ - dup array? [ - first2 - >r swap at r> number>string* - " " swap 3append - ] [ - swap at - ] if - ] with map [ ] subset ; +M: sqlite-db compound-modifier ( str obj -- newstr ) + compound-type ; -: sqlite-type-hash ( -- assoc ) +M: sqlite-db compound-type ( str seq -- newstr ) + over { + { "default" [ first number>string join-space ] } + [ 2drop ] ! "no sqlite compound data type" 3array throw ] + } case ; + +M: sqlite-db type-table ( -- assoc ) H{ + { +native-id+ "integer primary key" } { INTEGER "integer" } - { SERIAL "integer" } { TEXT "text" } { VARCHAR "text" } + { TIMESTAMP "timestamp" } { DOUBLE "real" } } ; -M: sqlite-db >sql-type ( obj -- str ) - dup pair? [ - first >sql-type - ] [ - sqlite-type-hash at* [ T{ no-sql-type } throw ] unless - ] if ; - -! HOOK: get-column-value ( n result-set type -- ) -! M: sqlite get-column-value { { "TEXT" get-text-column } { -! "INTEGER" get-integer-column } ... } case ; +M: sqlite-db create-type-table + type-table ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index ea57193750..517f8bcc36 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,70 +1,131 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel tools.test db db.sqlite db.tuples -db.types continuations namespaces db.postgresql math ; -! tools.time ; -IN: temporary +USING: io.files kernel tools.test db db.tuples +db.types continuations namespaces db.postgresql math +prettyprint tools.walker db.sqlite ; +IN: db.tuples.tests -TUPLE: person the-id the-name the-number real ; +TUPLE: person the-id the-name the-number the-real ; : ( name age real -- person ) { set-person-the-name set-person-the-number - set-person-real + set-person-the-real } person construct ; -: ( id name number real -- obj ) +: ( 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 + [ person create-table ] must-fail - [ ] [ 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 - [ ] [ the-person get delete-tuple ] unit-test - ; ! 1 [ ] [ person drop-table ] 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 + [ + { + T{ person f 1 "billy" 200 3.14 } + T{ person f 2 "johnny" 10 3.14 } + } + ] [ T{ person f } select-tuples ] unit-test -: test-sqlite ( -- ) - "tuples-test.db" resource-path [ - test-tuples - ] with-db ; + + [ ] [ the-person1 get delete-tuple ] unit-test + [ f ] [ T{ person f 1 } select-tuple ] unit-test + [ ] [ person drop-table ] unit-test ; + +: make-native-person-table ( -- ) + [ person drop-table ] [ drop ] recover + person create-table + T{ person f f "billy" 200 3.14 } insert-tuple + T{ person f f "johnny" 10 3.14 } insert-tuple + ; + +: native-person-schema ( -- ) + person "PERSON" + { + { "the-id" "ID" +native-id+ } + { "the-name" "NAME" { VARCHAR 256 } +not-null+ } + { "the-number" "AGE" INTEGER { +default+ 0 } } + { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + } define-persistent + "billy" 10 3.14 the-person1 set + "johnny" 10 3.14 the-person2 set ; + +: assigned-person-schema ( -- ) + 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" 10 3.14 the-person1 set + 2 "johnny" 10 3.14 the-person2 set ; + + +TUPLE: paste n summary author channel mode contents timestamp annotations ; +TUPLE: annotation n paste-id summary author mode contents ; + +: native-paste-schema ( -- ) + paste "PASTE" + { + { "n" "ID" +native-id+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "channel" "CHANNEL" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + { "date" "DATE" TIMESTAMP } + { "annotations" { +has-many+ annotation } } + } define-persistent + + annotation "ANNOTATION" + { + { "n" "ID" +native-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; + +! { "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 + + +: test-sqlite ( quot -- ) + >r "tuples-test.db" resource-path sqlite-db r> with-db ; : test-postgresql ( -- ) - "localhost" "postgres" "" "factor-test" [ - test-tuples - ] with-db ; + >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; -person "PERSON" -{ - { "the-id" "ID" SERIAL +native-id+ } - { "the-name" "NAME" { VARCHAR 256 } +not-null+ } - { "the-number" "AGE" INTEGER { +default+ 0 } } - { "real" "REAL" DOUBLE { +default+ 0.3 } } -} define-persistent +[ native-person-schema test-tuples ] test-sqlite +[ assigned-person-schema test-tuples ] test-sqlite -"billy" 10 3.14 the-person 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 } } - ! { "real" "REAL" DOUBLE { +default+ 0.3 } } -! } define-persistent - -! 1 "billy" 20 6.28 the-person set - -! test-sqlite -! test-postgresql +! [ make-native-person-table ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 20cdd8a386..e7fe7e49c2 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -1,115 +1,111 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes db kernel namespaces -tuples words sequences slots slots.private math -math.parser io prettyprint db.types continuations ; +tuples words sequences slots math +math.parser io prettyprint db.types continuations +mirrors sequences.lib tools.walker combinators.lib ; IN: db.tuples -: db-columns ( class -- obj ) "db-columns" word-prop ; +: define-persistent ( class table columns -- ) + >r dupd "db-table" set-word-prop dup r> + [ relation? ] partition swapd + dupd [ spec>tuple ] with map + "db-columns" set-word-prop + "db-relations" set-word-prop ; + : db-table ( class -- obj ) "db-table" word-prop ; +: db-columns ( class -- obj ) "db-columns" word-prop ; +: db-relations ( class -- obj ) "db-relations" word-prop ; -TUPLE: no-slot-named ; -: no-slot-named ( -- * ) T{ no-slot-named } throw ; +: set-primary-key ( key tuple -- ) + [ + class db-columns find-primary-key sql-spec-slot-name + ] keep set-slot-named ; -: slot-spec-named ( str class -- slot-spec ) - "slots" word-prop [ slot-spec-name = ] with find nip - [ no-slot-named ] unless* ; +! returns a sequence of prepared-statements +HOOK: create-sql-statement db ( class -- obj ) +HOOK: drop-sql-statement db ( class -- obj ) -: offset-of-slot ( str obj -- n ) - class slot-spec-named slot-spec-offset ; +HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) -: get-slot-named ( str obj -- value ) - tuck offset-of-slot [ no-slot-named ] unless* slot ; +HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) -: set-slot-named ( value str obj -- ) - tuck offset-of-slot [ no-slot-named ] unless* set-slot ; +HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) -: primary-key-spec ( class -- spec ) - db-columns [ primary-key? ] find nip ; - -: primary-key ( tuple -- obj ) - dup class primary-key-spec get-slot-named ; - -: set-primary-key ( obj tuple -- ) - [ class primary-key-spec first ] keep - set-slot-named ; - -: cache-statement ( columns class assoc quot -- statement ) - [ db-table dupd ] swap - [ ] 3compose cache nip ; inline - -HOOK: create-sql db ( columns table -- seq ) -HOOK: drop-sql db ( columns table -- seq ) - -HOOK: insert-sql* db ( columns table -- slot-names sql ) -HOOK: update-sql* db ( columns table -- slot-names sql ) -HOOK: delete-sql* db ( columns table -- slot-names sql ) -HOOK: select-sql db ( tuple -- statement ) +HOOK: db ( tuple -- tuple ) HOOK: row-column-typed db ( result-set n type -- sql ) -HOOK: sql-type>factor-type db ( obj type -- obj ) -HOOK: tuple>params db ( columns tuple -- obj ) +HOOK: insert-tuple* db ( tuple statement -- ) +: resulting-tuple ( row out-params -- tuple ) + dup first sql-spec-class construct-empty [ + [ + >r [ sql-spec-type sql-type>factor-type ] keep + sql-spec-slot-name r> set-slot-named + ] curry 2each + ] keep ; -HOOK: make-slot-names* db ( quot -- seq ) -HOOK: column-slot-name% db ( spec -- ) -HOOK: column-bind-name% db ( spec -- ) +: query-tuples ( statement -- seq ) + [ statement-out-params ] keep query-results [ + [ sql-row swap resulting-tuple ] with query-map + ] with-disposal ; + +: query-modify-tuple ( tuple statement -- ) + [ query-results [ sql-row ] with-disposal ] keep + statement-out-params rot [ + >r [ sql-spec-type sql-type>factor-type ] keep + sql-spec-slot-name r> set-slot-named + ] curry 2each ; -: make-slots-names ( quot -- seq str ) - [ make-slot-names* ] "" make ; inline -: slot-name% ( seq -- ) first % ; -: column-name% ( seq -- ) second % ; -: column-type% ( seq -- ) third % ; +: sql-props ( class -- columns table ) + dup db-columns swap db-table ; -: insert-sql ( columns class -- statement ) - db get db-insert-statements [ insert-sql* ] cache-statement ; - -: update-sql ( columns class -- statement ) - db get db-update-statements [ update-sql* ] cache-statement ; - -: delete-sql ( columns class -- statement ) - db get db-delete-statements [ delete-sql* ] cache-statement ; - - -: tuple-statement ( columns tuple quot -- statement ) - >r [ tuple>params ] 2keep class r> call - 2dup . . - [ bind-statement ] keep ; - -: make-tuple-statement ( tuple columns-quot statement-quot -- statement ) - >r [ class db-columns ] swap compose keep - r> tuple-statement ; - -: do-tuple-statement ( tuple columns-quot statement-quot -- ) - make-tuple-statement execute-statement ; +: with-disposals ( seq quot -- ) + over sequence? [ + [ with-disposal ] curry each + ] [ + with-disposal + ] if ; : create-table ( class -- ) - dup db-columns swap db-table create-sql sql-command ; - + create-sql-statement [ execute-statement ] with-disposals ; + : drop-table ( class -- ) - dup db-columns swap db-table drop-sql sql-command ; + drop-sql-statement [ execute-statement ] with-disposals ; + +: insert-native ( tuple -- ) + dup class + db get db-insert-statements [ ] cache + [ bind-tuple ] 2keep insert-tuple* ; + +: insert-assigned ( tuple -- ) + dup class + db get db-insert-statements [ ] cache + [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - [ - [ maybe-remove-id ] [ insert-sql ] - make-tuple-statement insert-statement - ] keep set-primary-key ; + dup class db-columns find-primary-key assigned-id? [ + insert-assigned + ] [ + insert-native + ] if ; : update-tuple ( tuple -- ) - [ ] [ update-sql ] do-tuple-statement ; + dup class + db get db-update-statements [ ] cache + [ bind-tuple ] keep execute-statement ; : delete-tuple ( tuple -- ) - [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ; + dup class + db get db-delete-statements [ ] cache + [ bind-tuple ] keep execute-statement ; -: select-tuple ( tuple -- ) - [ select-sql ] keep do-query ; +: select-tuples ( tuple -- tuple ) + dup dup class [ + [ bind-tuple ] keep query-tuples + ] with-disposal ; -: persist ( tuple -- ) - dup primary-key [ update-tuple ] [ insert-tuple ] if ; - -: define-persistent ( class table columns -- ) - >r dupd "db-table" set-word-prop r> - "db-columns" set-word-prop ; - -: define-relation ( spec -- ) - drop ; +: select-tuple ( tuple -- tuple/f ) select-tuples ?first ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 7cacbcf861..c84b23c50f 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -1,21 +1,50 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser -sequences continuations ; +sequences continuations sequences.deep sequences.lib +words namespaces tools.walker slots slots.private classes +mirrors tuples combinators ; IN: db.types +HOOK: modifier-table db ( -- hash ) +HOOK: compound-modifier db ( str seq -- hash ) +HOOK: type-table db ( -- hash ) +HOOK: create-type-table db ( -- hash ) +HOOK: compound-type db ( str n -- hash ) + +TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; ! ID is the Primary key +! +native-id+ can be a columns type or a modifier SYMBOL: +native-id+ +! +assigned-id+ can only be a modifier SYMBOL: +assigned-id+ -: primary-key? ( spec -- ? ) - [ { +native-id+ +assigned-id+ } member? ] contains? ; +: (primary-key?) ( obj -- ? ) + { +native-id+ +assigned-id+ } member? ; -: contains-id? ( columns id -- ? ) - swap [ member? ] with contains? ; - -: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ; -: native-id? ( columns -- ? ) +native-id+ contains-id? ; +: primary-key? ( spec -- ? ) + sql-spec-primary-key (primary-key?) ; + +: normalize-spec ( spec -- ) + dup sql-spec-type dup (primary-key?) [ + swap set-sql-spec-primary-key + ] [ + drop dup sql-spec-modifiers [ + (primary-key?) + ] deep-find + [ swap set-sql-spec-primary-key ] [ drop ] if* + ] if ; + +: find-primary-key ( specs -- obj ) + [ sql-spec-primary-key ] find nip ; + +: native-id? ( spec -- ? ) + sql-spec-primary-key +native-id+ = ; + +: assigned-id? ( spec -- ? ) + sql-spec-primary-key +assigned-id+ = ; + +SYMBOL: +foreign-id+ ! Same concept, SQLite has autoincrement, PostgreSQL has serial SYMBOL: +autoincrement+ @@ -28,40 +57,168 @@ SYMBOL: +not-null+ SYMBOL: +has-many+ -SYMBOL: SERIAL -SYMBOL: INTEGER -SYMBOL: DOUBLE -SYMBOL: BOOLEAN +: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; +SYMBOL: INTEGER +SYMBOL: BIG_INTEGER +SYMBOL: DOUBLE +SYMBOL: REAL +SYMBOL: BOOLEAN SYMBOL: TEXT SYMBOL: VARCHAR - SYMBOL: TIMESTAMP SYMBOL: DATE -SYMBOL: BIG_INTEGER +: spec>tuple ( class spec -- tuple ) + [ ?first3 ] keep 3 ?tail* + { + set-sql-spec-class + set-sql-spec-slot-name + set-sql-spec-column-name + set-sql-spec-type + set-sql-spec-modifiers + } sql-spec construct + dup normalize-spec ; + +: sql-type-hash ( -- assoc ) + H{ + { INTEGER "integer" } + { TEXT "text" } + { VARCHAR "varchar" } + { DOUBLE "real" } + { TIMESTAMP "timestamp" } + } ; TUPLE: no-sql-type ; : no-sql-type ( -- * ) T{ no-sql-type } throw ; -HOOK: sql-modifiers* db ( modifiers -- str ) -HOOK: >sql-type db ( obj -- str ) - -! HOOK: >factor-type db ( obj -- obj ) +TUPLE: no-sql-modifier ; +: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ; : number>string* ( n/str -- str ) dup number? [ number>string ] when ; -: maybe-remove-id ( columns -- obj ) - [ +native-id+ swap member? not ] subset ; +: maybe-remove-id ( specs -- obj ) + [ native-id? not ] subset ; -: remove-id ( columns -- obj ) - [ primary-key? not ] subset ; +: remove-relations ( specs -- newcolumns ) + [ relation? not ] subset ; -: sql-modifiers ( spec -- seq ) - 3 tail sql-modifiers* ; +: remove-id ( specs -- obj ) + [ sql-spec-primary-key not ] subset ; ! SQLite Types: http://www.sqlite.org/datatype3.html ! NULL INTEGER REAL TEXT BLOB ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html + +: lookup-modifier ( obj -- str ) + dup array? [ + unclip lookup-modifier swap compound-modifier + ] [ + modifier-table at* + [ "unknown modifier" throw ] unless + ] if ; + +: lookup-type* ( obj -- str ) + dup array? [ + first lookup-type* + ] [ + type-table at* + [ no-sql-type ] unless + ] if ; + +: lookup-create-type ( obj -- str ) + dup array? [ + unclip lookup-create-type swap compound-type + ] [ + dup create-type-table at* + [ nip ] [ drop lookup-type* ] if + ] if ; + +: lookup-type ( obj create? -- str ) + [ lookup-create-type ] [ lookup-type* ] if ; + +: single-quote ( str -- newstr ) + "'" swap "'" 3append ; + +: double-quote ( str -- newstr ) + "\"" swap "\"" 3append ; + +: paren ( str -- newstr ) + "(" swap ")" 3append ; + +: join-space ( str1 str2 -- newstr ) + " " swap 3append ; + +: modifiers ( spec -- str ) + sql-spec-modifiers + [ lookup-modifier ] map " " join + dup empty? [ " " swap append ] unless ; + +SYMBOL: building-seq +: get-building-seq ( n -- seq ) + building-seq get nth ; + +: n, get-building-seq push ; +: n% get-building-seq push-all ; +: n# >r number>string r> n% ; + +: 0, 0 n, ; +: 0% 0 n% ; +: 0# 0 n# ; +: 1, 1 n, ; +: 1% 1 n% ; +: 1# 1 n# ; +: 2, 2 n, ; +: 2% 2 n% ; +: 2# 2 n# ; + +: nmake ( quot exemplars -- seqs ) + dup length dup zero? [ 1+ ] when + [ + [ + [ drop 1024 swap new-resizable ] 2map + [ building-seq set call ] keep + ] 2keep >r [ like ] 2map r> firstn + ] with-scope ; + +HOOK: bind% db ( spec -- ) + +TUPLE: no-slot-named ; +: no-slot-named ( -- * ) T{ no-slot-named } throw ; + +: slot-spec-named ( str class -- slot-spec ) + "slots" word-prop [ slot-spec-name = ] with find nip + [ no-slot-named ] unless* ; + +: offset-of-slot ( str obj -- n ) + class slot-spec-named slot-spec-offset ; + +: get-slot-named ( str obj -- value ) + tuck offset-of-slot [ no-slot-named ] unless* slot ; + +: set-slot-named ( value str obj -- ) + tuck offset-of-slot [ no-slot-named ] unless* set-slot ; + +: tuple>filled-slots ( tuple -- alist ) + dup mirror-slots [ slot-spec-name ] map + swap tuple-slots 2array flip [ nip ] assoc-subset ; + +: tuple>params ( specs tuple -- obj ) + [ + >r dup sql-spec-type swap sql-spec-slot-name r> + get-slot-named swap + ] curry { } map>assoc ; + +: sql-type>factor-type ( obj type -- obj ) + dup array? [ first ] when + { + { +native-id+ [ string>number ] } + { INTEGER [ string>number ] } + { DOUBLE [ string>number ] } + { REAL [ string>number ] } + { TEXT [ ] } + { VARCHAR [ ] } + [ "no conversion from sql type to factor type" throw ] + } case ; diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index dd9a77aa21..d66357daa5 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -1,5 +1,5 @@ USING: delegate kernel arrays tools.test ; -IN: temporary +IN: delegate.tests TUPLE: hello this that ; C: hello diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index db4f023dad..09b4ccc357 100755 --- a/extra/destructors/destructors-tests.factor +++ b/extra/destructors/destructors-tests.factor @@ -1,5 +1,5 @@ USING: destructors kernel tools.test continuations ; -IN: temporary +IN: destructors.tests TUPLE: dummy-obj destroyed? ; diff --git a/extra/documents/documents-tests.factor b/extra/documents/documents-tests.factor index dfa24c6cea..e09afebfc2 100644 --- a/extra/documents/documents-tests.factor +++ b/extra/documents/documents-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: documents.tests USING: documents namespaces tools.test ; ! Tests diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor old mode 100644 new mode 100755 index 7d95c8ce8a..3b65466225 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -35,6 +35,9 @@ SYMBOL: edit-hook : edit ( defspec -- ) where [ first2 edit-location ] when* ; +: edit-vocab ( name -- ) + vocab-source-path 1 edit-location ; + : :edit ( -- ) error get delegates [ parse-error? ] find-last nip [ dup parse-error-file source-file-path ?resource-path @@ -43,7 +46,7 @@ SYMBOL: edit-hook : fix ( word -- ) "Fixing " write dup pprint " and all usages..." print nl - dup smart-usage swap add* [ + dup usage swap add* [ "Editing " write dup . "RETURN moves on to the next usage, C+d stops." print flush diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor index 5a8168a181..eb31b2aa47 100755 --- a/extra/editors/editpadpro/editpadpro.factor +++ b/extra/editors/editpadpro/editpadpro.factor @@ -6,7 +6,7 @@ IN: editors.editpadpro : editpadpro-path \ editpadpro-path get-global [ program-files "JGsoft" path+ - [ >lower "editpadpro.exe" tail? ] find-file-breadth + t [ >lower "editpadpro.exe" tail? ] find-file ] unless* ; : editpadpro ( file line -- ) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor old mode 100644 new mode 100755 index e68bf04732..030c968e81 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -5,5 +5,5 @@ IN: editors.gvim.windows M: windows-io gvim-path \ gvim-path get-global [ program-files "vim" path+ - [ "gvim.exe" tail? ] find-file-breadth + t [ "gvim.exe" tail? ] find-file ] unless* ; diff --git a/extra/factory/factory-menus b/extra/factory/factory-menus index fa72fa6c9a..35ee75e31b 100644 --- a/extra/factory/factory-menus +++ b/extra/factory/factory-menus @@ -25,14 +25,14 @@ apps-menu> not [ new-wm-menu >apps-menu ] when { { "Emacs" [ "emacs &" system drop ] } { "KMail" [ "kmail &" system drop ] } { "Akregator" [ "akregator &" system drop ] } - { "Amarok" [ "amarok &" system drop ] } - { "K3b" [ "k3b &" system drop ] } - { "xchat" [ "xchat &" system drop ] } + { "Amarok" [ "amarok &" system drop ] } + { "K3b" [ "k3b &" system drop ] } + { "xchat" [ "xchat &" system drop ] } { "Nautilus" [ "nautilus --no-desktop &" system drop ] } - { "synaptic" [ "gksudo synaptic &" system drop ] } + { "synaptic" [ "gksudo synaptic &" system drop ] } { "Volume control" [ "gnome-volume-control &" system drop ] } { "Azureus" [ "~/azureus/azureus &" system drop ] } - { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] } + { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] } { "Stop Xephyr" [ "pkill Xephyr &" system drop ] } { "Stop Firefox" [ "pkill firefox &" system drop ] } } apps-menu> set-menu-items @@ -95,8 +95,8 @@ factory-menu> not [ new-wm-menu >factory-menu ] when { { "Maximize" [ maximize ] } { "Maximize Vertical" [ maximize-vertical ] } { "Restore" [ restore ] } - { "Hide" [ minimize ] } - { "Tile Master" [ tile-master ] } + { "Hide" [ minimize ] } + { "Tile Master" [ tile-master ] } } factory-menu> set-menu-items @@ -106,17 +106,17 @@ factory-menu> set-menu-items ! VAR: root-menu { { "xterm" [ "urxvt -bd grey +sb &" system drop ] } - { "Firefox" [ "firefox &" system drop ] } - { "xclock" [ "xclock &" system drop ] } - { "Apps >" [ apps-menu> <- popup ] } + { "Firefox" [ "firefox &" system drop ] } + { "xclock" [ "xclock &" system drop ] } + { "Apps >" [ apps-menu> <- popup ] } { "Factor >" [ factor-menu> <- popup ] } { "Unmapped frames >" [ unmapped-frames-menu> <- popup ] } - { "Emacs >" [ emacs-menu> <- popup ] } - { "Mail >" [ mail-menu> <- popup ] } - { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &" - system drop ] } - { "Edit menus" [ edit-factory-menus ] } + { "Emacs >" [ emacs-menu> <- popup ] } + { "Mail >" [ mail-menu> <- popup ] } + { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &" + system drop ] } + { "Edit menus" [ edit-factory-menus ] } { "Reload menus" [ load-factory-menus ] } - { "Factory >" [ factory-menu> <- popup ] } + { "Factory >" [ factory-menu> <- popup ] } } root-menu> set-menu-items diff --git a/extra/farkup/authors.factor b/extra/farkup/authors.factor new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/extra/farkup/authors.factor @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/assoc-heaps/authors.txt b/extra/farkup/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/assoc-heaps/authors.txt rename to extra/farkup/authors.txt diff --git a/extra/farkup/farkup-docs.factor b/extra/farkup/farkup-docs.factor new file mode 100644 index 0000000000..5d59a093af --- /dev/null +++ b/extra/farkup/farkup-docs.factor @@ -0,0 +1,6 @@ +USING: help.markup help.syntax ; +IN: farkup + +HELP: parse-farkup +{ $values { "string" "a string" } { "string'" "a string" } } +{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ; diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor new file mode 100755 index 0000000000..2e0d9832b0 --- /dev/null +++ b/extra/farkup/farkup-tests.factor @@ -0,0 +1,44 @@ +USING: farkup kernel tools.test ; +IN: farkup.tests + +[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test +[ "
  • foo
\n" ] [ "-foo\n" convert-farkup ] unit-test +[ "
  • foo
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test +[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test + +[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test +[ "

*foo\nbar\n

" ] [ "*foo\nbar\n" convert-farkup ] unit-test +[ "

Wow!

" ] [ "*Wow!*" convert-farkup ] unit-test +[ "

Wow.

" ] [ "_Wow._" convert-farkup ] unit-test + +[ "

*

" ] [ "*" convert-farkup ] unit-test +[ "

*

" ] [ "\\*" convert-farkup ] unit-test +[ "

**

" ] [ "\\**" convert-farkup ] unit-test + +[ "" ] [ "\n\n" convert-farkup ] unit-test +[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test + +[ "\n

bar\n

" ] [ "\nbar\n" convert-farkup ] unit-test + +[ "

foo

\n

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test + +[ "" ] [ "" convert-farkup ] unit-test + +[ "

|a

" ] +[ "|a" convert-farkup ] unit-test + +[ "

|a|

" ] +[ "|a|" convert-farkup ] unit-test + +[ "
ab
" ] +[ "a|b" convert-farkup ] unit-test + +[ "
ab
\n
cd
" ] +[ "a|b\nc|d" convert-farkup ] unit-test + +[ "
ab
\n
cd
\n" ] +[ "a|b\nc|d\n" convert-farkup ] unit-test + +[ "

foo\n

aheading

\n

adfasd

" ] +[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor new file mode 100755 index 0000000000..dac4359d90 --- /dev/null +++ b/extra/farkup/farkup.factor @@ -0,0 +1,129 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays io kernel memoize namespaces peg sequences strings +html.elements xml.entities xmode.code2html splitting +io.streams.string html peg.parsers html.elements sequences.deep +unicode.categories ; +IN: farkup + +: delimiters ( -- string ) + "*_^~%[-=|\\\n" ; inline + +MEMO: text ( -- parser ) + [ delimiters member? not ] satisfy repeat1 + [ >string escape-string ] action ; + +MEMO: delimiter ( -- parser ) + [ dup delimiters member? swap "\n=" member? not and ] satisfy + [ 1string ] action ; + +: surround-with-foo ( string tag -- seq ) + dup swap swapd 3array ; + +: delimited ( str html -- parser ) + [ + over token hide , + text [ surround-with-foo ] swapd curry action , + token hide , + ] seq* ; + +MEMO: escaped-char ( -- parser ) + [ "\\" token hide , any-char , ] seq* [ >string ] action ; + +MEMO: strong ( -- parser ) "*" "strong" delimited ; +MEMO: emphasis ( -- parser ) "_" "em" delimited ; +MEMO: superscript ( -- parser ) "^" "sup" delimited ; +MEMO: subscript ( -- parser ) "~" "sub" delimited ; +MEMO: inline-code ( -- parser ) "%" "code" delimited ; +MEMO: nl ( -- parser ) "\n" token ; +MEMO: 2nl ( -- parser ) "\n\n" token hide ; +MEMO: h1 ( -- parser ) "=" "h1" delimited ; +MEMO: h2 ( -- parser ) "==" "h2" delimited ; +MEMO: h3 ( -- parser ) "===" "h3" delimited ; +MEMO: h4 ( -- parser ) "====" "h4" delimited ; + +: render-code ( string mode -- string' ) + >r string-lines r> + [ [ htmlize-lines ] with-html-stream ] with-string-writer ; + +: make-link ( href text -- seq ) + >r escape-quoted-string r> escape-string + [ "r , r> "\">" , [ , ] when* "" , ] { } make ; + +MEMO: simple-link ( -- parser ) + [ + "[[" token hide , + [ "|]" member? not ] satisfy repeat1 , + "]]" token hide , + ] seq* [ first f make-link ] action ; + +MEMO: labelled-link ( -- parser ) + [ + "[[" token hide , + [ CHAR: | = not ] satisfy repeat1 , + "|" token hide , + [ CHAR: ] = not ] satisfy repeat1 , + "]]" token hide , + ] seq* [ first2 make-link ] action ; + +MEMO: link ( -- parser ) [ simple-link , labelled-link , ] choice* ; + +DEFER: line +MEMO: list-item ( -- parser ) + [ + "-" token hide , line , + ] seq* [ "li" surround-with-foo ] action ; + +MEMO: list ( -- parser ) + list-item "\n" token hide list-of + [ "ul" surround-with-foo ] action ; + +MEMO: table-column ( -- parser ) + text [ "td" surround-with-foo ] action ; + +MEMO: table-row ( -- parser ) + [ + table-column "|" token hide list-of-many , + ] seq* [ "tr" surround-with-foo ] action ; + +MEMO: table ( -- parser ) + table-row repeat1 [ "table" surround-with-foo ] action ; + +MEMO: code ( -- parser ) + [ + "[" token hide , + [ "{" member? not ] satisfy repeat1 optional [ >string ] action , + "{" token hide , + [ + [ any-char , "}]" token ensure-not , ] seq* + repeat1 [ concat >string ] action , + [ any-char , "}]" token hide , ] seq* optional [ >string ] action , + ] seq* [ concat ] action , + ] seq* [ first2 swap render-code ] action ; + +MEMO: line ( -- parser ) + [ + text , strong , emphasis , link , + superscript , subscript , inline-code , + escaped-char , delimiter , + ] choice* repeat1 ; + +MEMO: paragraph ( -- parser ) + line + "\n" token over 2seq repeat0 + "\n" token "\n" token ensure-not 2seq optional 3seq + [ + dup [ dup string? not swap [ blank? ] all? or ] deep-all? + [ "

" swap "

" 3array ] unless + ] action ; + +PEG: parse-farkup ( -- parser ) + [ + list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , + ] choice* repeat0 "\n" token optional 2seq ; + +: write-farkup ( parse-result -- ) + [ dup string? [ write ] [ drop ] if ] deep-each ; + +: convert-farkup ( string -- string' ) + parse-farkup [ write-farkup ] with-string-writer ; diff --git a/extra/farkup/summary.txt b/extra/farkup/summary.txt new file mode 100644 index 0000000000..c6e75d28a9 --- /dev/null +++ b/extra/farkup/summary.txt @@ -0,0 +1 @@ +Simple markup language for generating HTML diff --git a/extra/farkup/tags.txt b/extra/farkup/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/farkup/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/fjsc/fjsc-tests.factor b/extra/fjsc/fjsc-tests.factor index ccb004581a..ce968128be 100755 --- a/extra/fjsc/fjsc-tests.factor +++ b/extra/fjsc/fjsc-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test peg fjsc ; -IN: temporary +IN: fjsc.tests { T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ "55 2abc1 100" 'expression' parse parse-result-ast diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index 5b5900f0bc..3811949c1d 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg strings promises sequences math math.parser namespaces words quotations arrays hashtables io - io.streams.string assocs memoize ascii ; + io.streams.string assocs memoize ascii peg.parsers ; IN: fjsc TUPLE: ast-number value ; diff --git a/extra/fry/authors.txt b/extra/fry/authors.txt new file mode 100644 index 0000000000..e1907c6d91 --- /dev/null +++ b/extra/fry/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Eduardo Cavazos diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor new file mode 100755 index 0000000000..4d2c9fe1c8 --- /dev/null +++ b/extra/fry/fry-tests.factor @@ -0,0 +1,46 @@ +IN: fry.tests +USING: fry tools.test math prettyprint kernel io arrays +sequences ; + +[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test + +[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test + +[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test + +[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test + +[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test + +[ [ "a" write "b" print ] ] +[ "a" "b" '[ , write , print ] ] unit-test + +[ [ 1 2 + 3 4 - ] ] +[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test + +[ 1/2 ] [ + 1 '[ , _ / ] 2 swap call +] unit-test + +[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [ + 1 '[ , _ _ 3array ] + { "a" "b" "c" } { "A" "B" "C" } rot 2map +] unit-test + +[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [ + '[ 1 _ 2array ] + { "a" "b" "c" } swap map +] unit-test + +[ 1 2 ] [ + 1 2 '[ _ , ] call +] unit-test + +[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [ + 1 2 '[ , _ , 3array ] + { "a" "b" "c" } swap map +] unit-test + +: funny-dip '[ @ _ ] call ; inline + +[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor new file mode 100755 index 0000000000..f8d49af163 --- /dev/null +++ b/extra/fry/fry.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences combinators parser splitting +quotations arrays namespaces ; +IN: fry + +: , "Only valid inside a fry" throw ; +: @ "Only valid inside a fry" throw ; +: _ "Only valid inside a fry" throw ; + +DEFER: (fry) + +: ((fry)) ( accum quot adder -- result ) + >r [ ] swap (fry) r> + append swap dup empty? [ drop ] [ + [ swap compose ] curry append + ] if ; inline + +: (fry) ( accum quot -- result ) + dup empty? [ + drop 1quotation + ] [ + unclip { + { , [ [ curry ] ((fry)) ] } + { @ [ [ compose ] ((fry)) ] } + [ swap >r add r> (fry) ] + } case + ] if ; + +: trivial-fry ( quot -- quot' ) [ ] swap (fry) ; + +: fry ( quot -- quot' ) + { _ } last-split1 [ + [ + trivial-fry % + [ >r ] % + fry % + [ [ dip ] curry r> compose ] % + ] [ ] make + ] [ + trivial-fry + ] if* ; + +: '[ \ ] parse-until fry over push-all ; parsing diff --git a/extra/fry/summary.txt b/extra/fry/summary.txt new file mode 100644 index 0000000000..340948a43c --- /dev/null +++ b/extra/fry/summary.txt @@ -0,0 +1 @@ +Syntax for pictured partial application and composition diff --git a/extra/concurrency/tags.txt b/extra/fry/tags.txt similarity index 100% rename from extra/concurrency/tags.txt rename to extra/fry/tags.txt diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor old mode 100644 new mode 100755 index 4afbd653bd..d8124d1f2b --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -1,5 +1,5 @@ USING: kernel sequences namespaces math tools.test furnace furnace.validator ; -IN: temporary +IN: furnace.tests TUPLE: test-tuple m n ; @@ -39,7 +39,7 @@ TUPLE: test-tuple m n ; ] unit-test [ - "/responder/temporary/foo?foo=3" + "/responder/furnace.tests/foo?foo=3" ] [ [ [ "3" foo ] quot-link diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 9b7a8a8aa5..590b3c82a7 100755 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -57,17 +57,9 @@ SYMBOL: validation-errors ] if* ] with map ; -: expire-sessions ( -- ) - sessions get-global - [ nip session-last-seen 20 minutes ago <=> 0 > ] - [ 2drop ] heap-pop-while ; - : lookup-session ( hash -- session ) - "furnace-session-id" over at sessions get-global at [ - nip - ] [ - new-session rot "furnace-session-id" swap set-at - ] if* ; + "furnace-session-id" over at get-session + [ ] [ new-session "furnace-session-id" roll set-at ] ?if ; : quot>query ( seq action -- hash ) >r >array r> "action-params" word-prop @@ -212,4 +204,3 @@ SYMBOL: model ] [ drop ] if ; - diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor old mode 100644 new mode 100755 index 523598efe7..cf03fee6b1 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -1,37 +1,47 @@ -USING: assoc-heaps assocs calendar crypto.sha2 heaps -init kernel math.parser namespaces random ; +USING: assocs calendar init kernel math.parser +namespaces random boxes alarms combinators.lib ; IN: furnace.sessions SYMBOL: sessions +: timeout ( -- dt ) 20 minutes ; + [ - H{ } clone - sessions set-global + H{ } clone sessions set-global ] "furnace.sessions" add-init-hook : new-session-id ( -- str ) - 4 big-random number>string string>sha-256-string - dup sessions get-global at [ drop new-session-id ] when ; + [ 4 big-random >hex ] + [ sessions get-global key? not ] generate ; -TUPLE: session created last-seen user-agent namespace ; +TUPLE: session id namespace alarm user-agent ; -M: session <=> ( session1 session2 -- n ) - [ session-last-seen ] 2apply <=> ; +: cancel-timeout ( session -- ) + session-alarm ?box [ cancel-alarm ] [ drop ] if ; -: ( -- obj ) - now dup H{ } clone - [ set-session-created set-session-last-seen set-session-namespace ] - \ session construct ; +: delete-session ( session -- ) + sessions get-global delete-at* + [ cancel-timeout ] [ drop ] if ; -: new-session ( -- obj id ) - new-session-id [ sessions get-global set-at ] 2keep ; +: touch-session ( session -- ) + dup cancel-timeout + dup [ session-id delete-session ] curry timeout later + swap session-alarm >box ; -: get-session ( id -- obj/f ) - sessions get-global at* [ "no session found 1" throw ] unless ; +: ( id -- session ) + H{ } clone f session construct-boa ; -! Delete from the assoc only, the heap will timeout -: destroy-session ( id -- ) - sessions get-global assoc-heap-assoc delete-at ; +: new-session ( -- session id ) + new-session-id [ + dup [ + [ sessions get-global set-at ] keep + touch-session + ] keep + ] keep ; + +: get-session ( id -- session/f ) + sessions get-global at* + [ dup touch-session ] when ; : session> ( str -- obj ) session get session-namespace at ; diff --git a/extra/furnace/validator/validator-tests.factor b/extra/furnace/validator/validator-tests.factor index 06d8ac815d..e84e57be6a 100644 --- a/extra/furnace/validator/validator-tests.factor +++ b/extra/furnace/validator/validator-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: furnace.validator.tests USING: kernel sequences tools.test furnace.validator furnace ; [ diff --git a/extra/globs/globs-tests.factor b/extra/globs/globs-tests.factor index 8021128810..446f1ee0a9 100644 --- a/extra/globs/globs-tests.factor +++ b/extra/globs/globs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: globs.tests USING: tools.test globs ; [ f ] [ "abd" "fdf" glob-matches? ] unit-test diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 6dee7d4be3..45d19cb891 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,13 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-c-types? f } - { deploy-ui? f } - { deploy-reflection 1 } + { deploy-io 2 } { deploy-math? f } + { deploy-threads? f } + { deploy-compiler? f } { deploy-word-props? f } { deploy-word-defs? f } { deploy-name "Hello world (console)" } + { deploy-reflection 2 } + { deploy-c-types? f } + { deploy-ui? f } { "stop-after-last-window?" t } - { deploy-compiler? f } - { deploy-io 2 } } diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 5be69663f8..ebdbdeb37e 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -197,7 +197,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook" { $code "\"data.bin\" [ 1024 read ] with-file-reader" } -"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory:" +"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" { $code "\"mydata.dat\" dup file-length [" " 4 [ reverse-here ] change-each" diff --git a/extra/help/crossref/crossref-tests.factor b/extra/help/crossref/crossref-tests.factor index eb30965f6a..1d569d8a8f 100755 --- a/extra/help/crossref/crossref-tests.factor +++ b/extra/help/crossref/crossref-tests.factor @@ -1,10 +1,10 @@ -IN: temporary +IN: help.crossref.tests USING: help.crossref help.topics help.markup tools.test words definitions assocs sequences kernel namespaces parser arrays io.streams.string continuations debugger compiler.units ; [ ] [ - "IN: temporary USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval ] unit-test [ $subsection ] [ @@ -13,17 +13,17 @@ io.streams.string continuations debugger compiler.units ; [ t ] [ "foo" article-children - "foo" "temporary" lookup 1array sequence= + "foo" "help.crossref.tests" lookup 1array sequence= ] unit-test -[ "foo" ] [ "foo" "temporary" lookup article-parent ] unit-test +[ "foo" ] [ "foo" "help.crossref.tests" lookup article-parent ] unit-test [ ] [ - [ "foo" "temporary" lookup forget ] with-compilation-unit + [ "foo" "help.crossref.tests" lookup forget ] with-compilation-unit ] unit-test [ ] [ - "IN: temporary USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval ] unit-test [ ] [ diff --git a/extra/help/definitions/definitions-tests.factor b/extra/help/definitions/definitions-tests.factor index 836f82a306..7134c6b0b0 100755 --- a/extra/help/definitions/definitions-tests.factor +++ b/extra/help/definitions/definitions-tests.factor @@ -1,13 +1,13 @@ USING: math definitions help.topics help tools.test prettyprint parser io.streams.string kernel source-files assocs namespaces words io sequences ; -IN: temporary +IN: help.definitions.tests [ ] [ \ + >link see ] unit-test [ [ 4 ] [ - "IN: temporary USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" + "IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size @@ -16,11 +16,11 @@ IN: temporary [ t ] [ "hello" articles get key? ] unit-test [ t ] [ "hello2" articles get key? ] unit-test [ t ] [ - "hello" "temporary" lookup "help" word-prop >boolean + "hello" "help.definitions.tests" lookup "help" word-prop >boolean ] unit-test [ 2 ] [ - "IN: temporary USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" "foo" + "IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size @@ -29,12 +29,12 @@ IN: temporary [ t ] [ "hello" articles get key? ] unit-test [ f ] [ "hello2" articles get key? ] unit-test [ f ] [ - "hello" "temporary" lookup "help" word-prop + "hello" "help.definitions.tests" lookup "help" word-prop ] unit-test - [ ] [ "IN: temporary USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test + [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test - [ ] [ "xxx" "temporary" lookup help ] unit-test + [ ] [ "xxx" "help.definitions.tests" lookup help ] unit-test - [ ] [ "xxx" "temporary" lookup >link synopsis print ] unit-test + [ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test ] with-file-vocabs diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 90e780c1ad..178b7a5d35 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -66,8 +66,7 @@ ARTICLE: "evaluator" "Evaluation semantics" { "All other types of objects are pushed on the data stack." } } "If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage." -$nl -"There are various ways of implementing these evaluation semantics. See " { $link "compiler" } " and " { $link "meta-interpreter" } "." ; +{ $see-also "compiler" } ; ARTICLE: "dataflow" "Data and control flow" { $subsection "evaluator" } @@ -78,8 +77,38 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "conditionals" } { $subsection "basic-combinators" } { $subsection "combinators" } -{ $subsection "continuations" } -{ $subsection "threads" } ; +{ $subsection "continuations" } ; + +USING: concurrency.combinators +concurrency.messaging +concurrency.promises +concurrency.futures +concurrency.locks +concurrency.semaphores +concurrency.count-downs +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." +$nl +"Factor's concurrency support was insipired by Erlang, Termite, Scheme48 and Java's " { $snippet "java.util.concurrent" } " library." +$nl +"The basic building blocks:" +{ $subsection "threads" } +"High-level abstractions:" +{ $subsection "concurrency.combinators" } +{ $subsection "concurrency.promises" } +{ $subsection "concurrency.futures" } +{ $subsection "concurrency.mailboxes" } +{ $subsection "concurrency.messaging" } +"Shared-state abstractions:" +{ $subsection "concurrency.locks" } +{ $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" "An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed." @@ -134,6 +163,7 @@ ARTICLE: "collections" "Collections" { $subsection "hashtables" } { $subsection "alists" } { $heading "Other collections" } +{ $subsection "boxes" } { $subsection "dlists" } { $subsection "heaps" } { $subsection "graphs" } @@ -141,23 +171,24 @@ ARTICLE: "collections" "Collections" USING: io.sockets io.launcher io.mmap io.monitors ; -ARTICLE: "io" "Input and output" +ARTICLE: "io" "Input and output" +{ $heading "Streams" } { $subsection "streams" } -"External streams:" -{ $subsection "file-streams" } -{ $subsection "network-streams" } "Wrapper streams:" { $subsection "io.streams.duplex" } { $subsection "io.streams.lines" } { $subsection "io.streams.plain" } { $subsection "io.streams.string" } -"Stream utilities:" +"Utilities:" { $subsection "stream-binary" } { $subsection "styles" } -"Advanced features:" -{ $subsection "io.launcher" } +{ $heading "Files" } +{ $subsection "io.files" } { $subsection "io.mmap" } { $subsection "io.monitors" } +{ $heading "Other features" } +{ $subsection "network-streams" } +{ $subsection "io.launcher" } { $subsection "io.timeouts" } ; ARTICLE: "tools" "Developer tools" @@ -168,7 +199,7 @@ ARTICLE: "tools" "Developer tools" "Debugging tools:" { $subsection "tools.annotations" } { $subsection "tools.test" } -{ $subsection "meta-interpreter" } +{ $subsection "tools.threads" } "Performance tools:" { $subsection "tools.memory" } { $subsection "profiling" } @@ -216,6 +247,7 @@ ARTICLE: "handbook" "Factor documentation" { $subsection "numbers" } { $subsection "collections" } { $subsection "io" } +{ $subsection "concurrency" } { $subsection "os" } { $subsection "alien" } { $heading "Environment reference" } diff --git a/extra/help/help.factor b/extra/help/help.factor index 77b9f699aa..9332e6aff8 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -122,18 +122,31 @@ M: word set-article-parent swap "help-parent" set-word-prop ; : (:help-multi) "This error has multiple delegates:" print - ($index) nl ; + ($index) nl + "Use \\ ... help to get help about a specific delegate." print ; : (:help-none) drop "No help for this error. " print ; +: (:help-debugger) + nl + "Debugger commands:" print + nl + ":s - data stack at error time" print + ":r - retain stack at error time" print + ":c - call stack at error time" print + ":edit - jump to source location (parse errors only)" print + + ":get ( var -- value ) accesses variables at time of the error" print + ":vars - list all variables at error time"; + : :help ( -- ) error get delegates [ error-help ] map [ ] subset { { [ dup empty? ] [ (:help-none) ] } { [ dup length 1 = ] [ first help ] } { [ t ] [ (:help-multi) ] } - } cond ; + } cond (:help-debugger) ; : remove-article ( name -- ) dup articles get key? [ diff --git a/extra/help/lint/lint-docs.factor b/extra/help/lint/lint-docs.factor index 2813391d07..6aa3310bf9 100644 --- a/extra/help/lint/lint-docs.factor +++ b/extra/help/lint/lint-docs.factor @@ -1,26 +1,26 @@ USING: help.markup help.syntax ; IN: help.lint -HELP: check-help -{ $description "Checks all word and article help." } ; +HELP: help-lint-all +{ $description "Checks all word help and articles in all loaded vocabularies." } ; -HELP: check-vocab-help +HELP: help-lint { $values { "vocab" "a vocabulary specifier" } } -{ $description "Checks all word help in the given vocabulary." } ; +{ $description "Checks all word help and articles in the given vocabulary and all child vocabularies." } ; ARTICLE: "help.lint" "Help lint tool" "The " { $vocab-link "help.lint" } " vocabulary implements a tool to check documentation in an automated fashion. You should use this tool to check any documentation that you write." $nl "To run help lint, use one of the following two words:" -{ $subsection check-help } -{ $subsection check-vocab-help } +{ $subsection help-lint } +{ $subsection help-lint-all } "Help lint performs the following checks:" { $list "ensures examples run and produce stated output" { "ensures " { $link $see-also } " elements don't contain duplicate entries" } { "ensures " { $link $vocab-link } " elements point to modules which actually exist" } { "ensures that " { $link $values } " match the stack effect declaration" } - { "ensures that word help articles actually render (this catches broken links, improper nesting, etc)" } + { "ensures that help topics actually render (this catches broken links, improper nesting, etc)" } } ; ABOUT: "help.lint" diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index 3c11a93509..4b97499a4c 100644 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -5,7 +5,7 @@ words strings classes tools.browser namespaces io io.streams.string prettyprint definitions arrays vectors combinators splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate -macros combinators.lib ; +macros combinators.lib sequences.lib ; IN: help.lint : check-example ( element -- ) @@ -84,7 +84,7 @@ M: help-error error. delegate error. ; : check-something ( obj quot -- ) - over . flush [ , ] recover ; inline + flush [ , ] recover ; inline : check-word ( word -- ) dup word-help [ @@ -106,22 +106,45 @@ M: help-error error. [ dup check-rendering ] assert-depth drop ] check-something ; -: check-articles ( -- ) - articles get keys [ check-article ] each ; +: group-articles ( -- assoc ) + articles get keys + vocabs [ dup vocab-docs-path swap ] H{ } map>assoc + H{ } clone [ + [ + >r >r dup >link where ?first r> at r> [ ?push ] change-at + ] 2curry each + ] keep ; -: with-help-lint ( quot -- ) +: check-vocab ( vocab -- seq ) + "Checking " write dup write "..." print + [ + dup words [ check-word ] each + "vocab-articles" get at [ check-article ] each + ] { } make ; + +: run-help-lint ( prefix -- alist ) [ all-vocabs-seq [ vocab-name ] map "all-vocabs" set - call - ] { } make [ nl error. ] each ; inline + articles get keys "group-articles" set + child-vocabs + [ dup check-vocab ] { } map>assoc + [ nip empty? not ] assoc-subset + ] with-scope ; -: check-help ( -- ) - [ all-words check-words check-articles ] with-help-lint ; +: typos. ( assoc -- ) + dup empty? [ + drop + "==== ALL CHECKS PASSED" print + ] [ + [ + swap vocab-heading. + [ error. nl ] each + ] assoc-each + ] if ; -: check-vocab-help ( vocab -- ) - [ - child-vocabs [ words check-words ] each - ] with-help-lint ; +: help-lint ( prefix -- ) run-help-lint typos. ; + +: help-lint-all ( -- ) "" help-lint ; : unlinked-words ( words -- seq ) all-word-help [ article-parent not ] subset ; @@ -132,4 +155,4 @@ M: help-error error. [ article-parent ] subset [ "predicating" word-prop not ] subset ; -MAIN: check-help +MAIN: help-lint diff --git a/extra/help/markup/markup-tests.factor b/extra/help/markup/markup-tests.factor index 71a9b54760..0b4b69bf59 100644 --- a/extra/help/markup/markup-tests.factor +++ b/extra/help/markup/markup-tests.factor @@ -1,6 +1,6 @@ USING: definitions help help.markup kernel sequences tools.test words parser namespaces assocs generic io.streams.string ; -IN: temporary +IN: help.markup.tests TUPLE: blahblah quux ; diff --git a/extra/help/syntax/syntax-tests.factor b/extra/help/syntax/syntax-tests.factor index 136313c2ef..bcf92b77c7 100755 --- a/extra/help/syntax/syntax-tests.factor +++ b/extra/help/syntax/syntax-tests.factor @@ -1,21 +1,21 @@ -IN: temporary +IN: help.syntax.tests USING: tools.test parser vocabs help.syntax namespaces ; [ [ "foobar" ] [ - "IN: temporary USE: help.syntax ABOUT: \"foobar\"" eval - "temporary" vocab vocab-help + "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval + "help.syntax.tests" vocab vocab-help ] unit-test [ { "foobar" } ] [ - "IN: temporary USE: help.syntax ABOUT: { \"foobar\" }" eval - "temporary" vocab vocab-help + "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval + "help.syntax.tests" vocab vocab-help ] unit-test SYMBOL: xyz [ xyz ] [ - "IN: temporary USE: help.syntax ABOUT: xyz" eval - "temporary" vocab vocab-help + "IN: help.syntax.tests USE: help.syntax ABOUT: xyz" eval + "help.syntax.tests" vocab vocab-help ] unit-test ] with-file-vocabs diff --git a/extra/help/topics/topics-tests.factor b/extra/help/topics/topics-tests.factor index c4c22b551f..1099f747bc 100644 --- a/extra/help/topics/topics-tests.factor +++ b/extra/help/topics/topics-tests.factor @@ -1,7 +1,7 @@ USING: definitions help help.topics help.crossref help.markup help.syntax kernel sequences tools.test words parser namespaces assocs source-files ; -IN: temporary +IN: help.topics.tests ! Test help cross-referencing diff --git a/extra/hexdump/hexdump-tests.factor b/extra/hexdump/hexdump-tests.factor index 3ddfe721a6..7fb26e10c5 100644 --- a/extra/hexdump/hexdump-tests.factor +++ b/extra/hexdump/hexdump-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: hexdump.tests USING: hexdump kernel sequences tools.test ; [ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test diff --git a/extra/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor index aab00e0ca3..aa6a017540 100644 --- a/extra/html/elements/elements-tests.factor +++ b/extra/html/elements/elements-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: html.elements.tests USING: tools.test html html.elements io.streams.string ; : make-html-string 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/html/html-tests.factor b/extra/html/html-tests.factor index 4e3344855f..2994e2d792 100644 --- a/extra/html/html-tests.factor +++ b/extra/html/html-tests.factor @@ -1,6 +1,6 @@ USING: html http io io.streams.string io.styles kernel namespaces tools.test xml.writer sbufs sequences html.private ; -IN: temporary +IN: html.tests : make-html-string [ with-html-stream ] with-string-writer ; diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor index c490b737d9..0e98c1b998 100644 --- a/extra/html/parser/parser-tests.factor +++ b/extra/html/parser/parser-tests.factor @@ -1,5 +1,5 @@ USING: html.parser kernel tools.test ; -IN: temporary +IN: html.parser.tests [ V{ T{ tag f "html" H{ } f f f } } diff --git a/extra/html/parser/utils/utils-tests.factor b/extra/html/parser/utils/utils-tests.factor index fcac31a6aa..4b25db16fd 100644 --- a/extra/html/parser/utils/utils-tests.factor +++ b/extra/html/parser/utils/utils-tests.factor @@ -3,7 +3,7 @@ hashtables.private io kernel math namespaces prettyprint quotations sequences splitting state-parser strings tools.test ; USING: html.parser.utils ; -IN: temporary +IN: html.parser.utils.tests [ "'Rome'" ] [ "Rome" single-quote ] unit-test [ "\"Roma\"" ] [ "Roma" double-quote ] unit-test 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/client/client.factor b/extra/http/client/client.factor index 679d603708..99ba045019 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting continuations assocs.lib ; +splitting continuations assocs.lib calendar ; IN: http.client : parse-host ( url -- host port ) @@ -47,7 +47,7 @@ DEFER: http-get-stream dispose "location" swap peek-at nip http-get-stream ] when ; -: default-timeout 60 1000 * over set-timeout ; +: default-timeout 1 minutes over set-timeout ; : http-get-stream ( url -- code headers stream ) #! Opens a stream for reading from an HTTP URL. diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 5146502644..0a4941aaa0 100644 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,5 +1,5 @@ USING: http tools.test ; -IN: temporary +IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index e4e0e257c4..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" swap at string>number dup [ + "content-length" swap peek-at string>number dup [ dup max-post-request get > [ "Content-Length > max-post-request" throw ] when @@ -136,7 +136,7 @@ LOG: log-headers DEBUG : host ( -- string ) #! The host the current responder was called from. - "Host" header-param ":" split1 drop ; + "host" header-param ":" split1 drop ; : add-responder ( responder -- ) #! Add a responder object to the list. diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 18edd94f12..627d7d889d 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,7 +1,7 @@ USING: webapps.file http.server.responders http http.server namespaces io tools.test strings io.server logging ; -IN: temporary +IN: http.server.tests [ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 957a82d09f..a2f5c3474b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting threads http http.server.responders sequences prettyprint -io.server logging ; +io.server logging calendar ; IN: http.server @@ -50,7 +50,7 @@ IN: http.server : httpd ( port -- ) internet-server "http.server" [ - 60000 stdio get set-timeout + 1 minutes stdio get set-timeout readln [ parse-request ] when* ] with-server ; diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/templating-tests.factor index d889cd848a..ceb2ed95be 100644 --- a/extra/http/server/templating/templating-tests.factor +++ b/extra/http/server/templating/templating-tests.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.string http.server.templating kernel tools.test sequences ; -IN: temporary +IN: http.server.templating.tests : test-template ( path -- ? ) "extra/http/server/templating/test/" swap append diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index f364b86524..4c451f7f6e 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -80,13 +80,12 @@ DEFER: <% delimiter "quiet" on parser-notes off templating-vocab use+ - dup source-file file set ! so that reload works properly - [ - ?resource-path file-contents - [ eval-template ] [ html-error. drop ] recover - ] keep + ! so that reload works properly + dup source-file file set + ?resource-path file-contents + [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs - ] assert-depth drop ; + ] curry assert-depth ; : run-relative-template-file ( filename -- ) file get source-file-path parent-directory diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index c9203d9ef8..2260bf5882 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.buffers.tests USING: alien alien.c-types io.buffers kernel kernel.private libc sequences tools.test namespaces ; diff --git a/extra/io/files/unique/backend/backend.factor b/extra/io/files/unique/backend/backend.factor new file mode 100644 index 0000000000..b26557688b --- /dev/null +++ b/extra/io/files/unique/backend/backend.factor @@ -0,0 +1,5 @@ +USING: io.backend ; +IN: io.files.unique.backend + +HOOK: (make-unique-file) io-backend ( path -- stream ) +HOOK: temporary-path io-backend ( -- path ) diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor new file mode 100644 index 0000000000..61f960d9f7 --- /dev/null +++ b/extra/io/files/unique/unique-docs.factor @@ -0,0 +1,50 @@ +USING: help.markup help.syntax io io.nonblocking kernel math +io.files.unique.private math.parser io.files ; +IN: io.files.unique + +ARTICLE: "unique" "Making and using unique files" +"Files:" +{ $subsection make-unique-file } +{ $subsection with-unique-file } +{ $subsection with-temporary-file } +"Directories:" +{ $subsection make-unique-directory } +{ $subsection with-unique-directory } +{ $subsection with-temporary-directory } ; + +ABOUT: "unique" + +HELP: make-unique-file ( prefix suffix -- path stream ) +{ $values { "prefix" "a string" } { "suffix" "a string" } +{ "path" "a pathname string" } { "stream" "an output stream" } } +{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname and a " { $link } " stream." } +{ $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." } +{ $see-also with-unique-file } ; + +HELP: make-unique-directory ( -- path ) +{ $values { "path" "a pathname string" } } +{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." } +{ $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." } +{ $see-also with-unique-directory } ; + +HELP: with-unique-file ( quot -- path ) +{ $values { "quot" "a quotation" } { "path" "a pathname string" } } +{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. Returns the full pathname after the stream has been closed." } +{ $notes "The unique file will remain after calling this word." } +{ $see-also with-temporary-file } ; + +HELP: with-unique-directory ( quot -- path ) +{ $values { "quot" "a quotation" } { "path" "a pathname string" } } +{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. Returns the full pathname after the quotation has been called." } +{ $notes "The directory will remain after calling this word." } +{ $see-also with-temporary-directory } ; + +HELP: with-temporary-file ( quot -- ) +{ $values { "quot" "a quotation" } } +{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. The file is deleted after the quotation returns." } +{ $see-also with-unique-file } ; + +HELP: with-temporary-directory ( quot -- ) +{ $values { "quot" "a quotation" } } +{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. The directory is deleted after the quotation returns." } +{ $see-also with-unique-directory } ; diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor new file mode 100644 index 0000000000..1e77cd6814 --- /dev/null +++ b/extra/io/files/unique/unique.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.bitfields combinators.lib math.parser +random sequences sequences.lib continuations namespaces +io.files io.backend io.nonblocking io arrays +io.files.unique.backend system combinators vocabs.loader ; +IN: io.files.unique + + + +: make-unique-file ( prefix suffix -- path stream ) + temporary-path -rot + [ + unique-length random-name swap 3append path+ + dup (make-unique-file) + ] 3curry unique-retries retry ; + +: with-unique-file ( quot -- path ) + >r f f make-unique-file r> rot [ with-stream ] dip ; inline + +: with-temporary-file ( quot -- ) + with-unique-file delete-file ; inline + +: make-unique-directory ( -- path ) + [ + temporary-path unique-length random-name path+ + dup make-directory + ] unique-retries retry ; + +: with-unique-directory ( quot -- path ) + >r make-unique-directory r> + [ with-directory ] curry keep ; inline + +: with-temporary-directory ( quot -- ) + with-unique-directory delete-tree ; inline + +{ + { [ unix? ] [ "io.unix.files.unique" ] } + { [ windows? ] [ "io.windows.files.unique" ] } +} cond require diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 3a557e9fd5..96639dee87 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax quotations kernel io math ; +USING: help.markup help.syntax quotations kernel io math +calendar ; IN: io.launcher HELP: +command+ @@ -77,7 +78,7 @@ $nl "This is used in situations where you want a spawn child process with some overridden environment variables." } ; HELP: +timeout+ -{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ; +{ $description "Launch descriptor key. If set to a " { $link duration } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ; HELP: default-descriptor { $description "Association storing default values for launch descriptor keys." } ; diff --git a/extra/io/launcher/launcher-tests.factor b/extra/io/launcher/launcher-tests.factor index 6705caa33c..bacb8eb5a9 100755 --- a/extra/io/launcher/launcher-tests.factor +++ b/extra/io/launcher/launcher-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.launcher.tests USING: tools.test io.launcher ; \ must-infer diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index dce893dcaf..b9cdab06f9 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.backend io.timeouts system kernel namespaces -strings hashtables sequences assocs combinators vocabs.loader -init threads continuations math ; +USING: io io.backend io.nonblocking io.streams.duplex +io.timeouts system kernel namespaces strings hashtables +sequences assocs combinators vocabs.loader init threads +continuations math ; IN: io.launcher ! Non-blocking process exit notification facility @@ -10,14 +11,14 @@ SYMBOL: processes [ H{ } clone processes set-global ] "io.launcher" add-init-hook -TUPLE: process handle status killed? lapse ; +TUPLE: process handle status killed? timeout ; HOOK: register-process io-backend ( process -- ) M: object register-process drop ; : ( handle -- process ) - f f process construct-boa + f f f process construct-boa V{ } clone over processes get set-at dup register-process ; @@ -83,7 +84,10 @@ HOOK: run-process* io-backend ( desc -- handle ) : wait-for-process ( process -- status ) [ dup process-handle - [ dup [ processes get at push stop ] curry callcc0 ] when + [ + dup [ processes get at push ] curry + "process" suspend drop + ] when dup process-killed? [ "Process was killed" throw ] [ process-status ] if ] with-timeout ; @@ -112,7 +116,9 @@ HOOK: kill-process* io-backend ( handle -- ) t over set-process-killed? process-handle [ kill-process* ] when* ; -M: process get-lapse process-lapse ; +M: process timeout process-timeout ; + +M: process set-timeout set-process-timeout ; M: process timed-out kill-process ; @@ -134,5 +140,14 @@ TUPLE: process-stream process ; : notify-exit ( status process -- ) [ set-process-status ] keep - [ processes get delete-at* drop [ schedule-thread ] each ] keep + [ processes get delete-at* drop [ resume ] each ] keep f swap set-process-handle ; + +GENERIC: underlying-handle ( stream -- handle ) + +M: port underlying-handle port-handle ; + +M: duplex-stream underlying-handle + dup duplex-stream-in underlying-handle + swap duplex-stream-out underlying-handle tuck = + [ "Invalid duplex stream" throw ] when ; diff --git a/extra/io/launcher/summary.txt b/extra/io/launcher/summary.txt index 1044a84d4b..c287261b4f 100644 --- a/extra/io/launcher/summary.txt +++ b/extra/io/launcher/summary.txt @@ -1 +1 @@ -Support for launching OS processes +Launching operating system processes diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index 25caae036d..832b88b248 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,5 +1,5 @@ USING: io io.mmap io.files kernel tools.test continuations sequences ; -IN: temporary +IN: io.mmap.tests [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-file-writer ] unit-test diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index eff27614ae..1678c2de41 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations namespaces sequences -assocs hashtables sorting arrays threads ; +assocs hashtables sorting arrays threads boxes io.timeouts ; IN: io.monitors ( handle -- simple-monitor ) - f (monitor) { + f (monitor) { set-simple-monitor-handle set-delegate + set-simple-monitor-callback } simple-monitor construct ; : construct-simple-monitor ( handle class -- simple-monitor ) >r r> construct-delegate ; inline : notify-callback ( simple-monitor -- ) - dup simple-monitor-callback - f rot set-simple-monitor-callback - [ schedule-thread ] when* ; + simple-monitor-callback [ resume ] if-box? ; + +M: simple-monitor timed-out + notify-callback ; M: simple-monitor fill-queue ( monitor -- ) - dup simple-monitor-callback [ - "Cannot wait for changes on the same file from multiple threads" throw - ] when - [ swap set-simple-monitor-callback stop ] callcc0 + [ + [ swap simple-monitor-callback >box ] + "monitor" suspend drop + ] with-timeout check-monitor ; M: simple-monitor dispose ( monitor -- ) diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 72507f26b6..6798f37887 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -13,11 +13,12 @@ SYMBOL: default-buffer-size TUPLE: port handle error -lapse +timeout type eof? ; -! Ports support the lapse protocol -M: port get-lapse port-lapse ; +M: port timeout port-timeout ; + +M: port set-timeout set-port-timeout ; SYMBOL: closed @@ -28,12 +29,10 @@ GENERIC: init-handle ( handle -- ) GENERIC: close-handle ( handle -- ) : ( handle buffer type -- port ) - pick init-handle - { + pick init-handle { set-port-handle set-delegate set-port-type - set-port-lapse } port construct ; : ( handle type -- port ) diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor old mode 100644 new mode 100755 index a393cef7fa..4acfb9acad --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -1,49 +1,50 @@ -USING: arrays assocs combinators.lib dlists io.files -kernel namespaces sequences shuffle vectors ; +USING: io.files kernel sequences new-slots accessors +dlists arrays sequences.lib ; IN: io.paths -! HOOK: library-roots io-backend ( -- seq ) -! HOOK: binary-roots io-backend ( -- seq ) +TUPLE: directory-iterator path bfs queue ; -r path+ r> ] with* assoc-map ; +: qualified-directory ( path -- seq ) + dup directory [ first2 >r path+ r> 2array ] with map ; -: get-paths ( dir -- paths ) - dup directory append-path ; +: push-directory ( path iter -- ) + >r qualified-directory r> [ + dup queue>> swap bfs>> + [ push-front ] [ push-back ] if + ] curry each ; -: (walk-dir) ( path -- ) - first2 [ - get-paths dup keys % [ (walk-dir) ] each +: ( path bfs? -- iterator ) + directory-iterator construct-boa + dup path>> over push-directory ; + +: next-file ( iter -- file/f ) + dup queue>> dlist-empty? [ drop f ] [ + dup queue>> pop-back first2 + [ over push-directory next-file ] [ nip ] if + ] if ; + +: iterate-directory ( iter quot -- obj ) + 2dup >r >r >r next-file dup [ + r> call dup [ + r> r> 2drop + ] [ + drop r> r> iterate-directory + ] if ] [ - drop - ] if ; -PRIVATE> + drop r> r> r> 3drop f + ] if ; inline -: walk-dir ( path -- seq ) - dup directory? 2array [ (walk-dir) ] { } make ; +: find-file ( path bfs? quot -- path/f ) + >r r> + [ keep and ] curry iterate-directory ; inline -GENERIC# find-file* 1 ( obj quot -- path/f ) +: each-file ( path bfs? quot -- ) + >r r> + [ f ] compose iterate-directory drop ; inline -M: dlist find-file* ( dlist quot -- path/f ) - over dlist-empty? [ 2drop f ] [ - 2dup >r pop-front get-paths dup r> assoc-find - [ drop 3nip ] - [ 2drop [ nip ] assoc-subset keys pick push-all-back find-file* ] if - ] if ; +: find-all-files ( path bfs? quot -- paths ) + >r r> + pusher >r iterate-directory drop r> ; inline -M: vector find-file* ( vector quot -- path/f ) - over empty? [ 2drop f ] [ - 2dup >r pop get-paths dup r> assoc-find - [ drop 3nip ] - [ 2drop [ nip ] assoc-subset keys pick push-all find-file* ] if - ] if ; - -: prepare-find-file ( quot -- quot ) - [ drop ] swap compose ; - -: find-file-depth ( path quot -- path/f ) - prepare-find-file >r 1vector r> find-file* ; - -: find-file-breadth ( path quot -- path/f ) - prepare-find-file >r 1dlist r> find-file* ; +: recursive-directory ( path bfs? -- paths ) + [ ] accumulator >r each-file r> ; diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor old mode 100644 new mode 100755 index 4e4342266a..cbcaae9569 --- a/extra/io/server/server-docs.factor +++ b/extra/io/server/server-docs.factor @@ -1,10 +1,6 @@ USING: help help.syntax help.markup io ; IN: io.server -HELP: with-client -{ $values { "quot" "a quotation" } { "client" "a client socket stream" } } -{ $description "Logs a client connection and spawns a new thread that calls the quotation, with the " { $link stdio } " stream set to the client stream. If the quotation throws an error, the client connection is closed, and the error is printed to the " { $link stdio } " stream at the time the thread was spawned." } ; - HELP: with-server { $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } } { $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being the " { $link stdio } " stream. Client connections are logged to the " { $link stdio } " stream at the time the server was started." } ; diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index 776bc4b429..8e56169bb3 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,4 @@ -IN: temporary -USING: tools.test io.server ; +IN: io.server.tests +USING: tools.test io.server io.server.private ; -{ 1 0 } [ [ ] spawn-server ] must-infer-as +{ 1 0 } [ [ ] server-loop ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 5cb5aa5592..a76ebcc450 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -2,11 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.sockets io.files logging continuations kernel math math.parser namespaces parser sequences strings -prettyprint debugger quotations calendar qualified ; -QUALIFIED: concurrency - +prettyprint debugger quotations calendar +threads concurrency.combinators assocs ; IN: io.server +SYMBOL: servers + +r accept r> [ with-client ] 2curry - concurrency:spawn drop + >r accept r> [ with-client ] 2curry "Client" spawn drop ] 2keep accept-loop ; inline -: server-loop ( server quot -- ) +: server-loop ( addrspec quot -- ) + >r dup servers get push r> [ accept-loop ] curry with-disposal ; inline -SYMBOL: servers +\ server-loop NOTICE add-error-logging -: spawn-server ( addrspec quot -- ) - >r dup servers get push r> server-loop ; inline - -\ spawn-server NOTICE add-error-logging +PRIVATE> : local-server ( port -- seq ) "localhost" swap t resolve-host ; @@ -40,17 +40,18 @@ SYMBOL: servers f swap t resolve-host ; : with-server ( seq service quot -- ) - [ - V{ } clone servers set - [ spawn-server ] curry concurrency:parallel-each - ] curry with-logging ; inline + V{ } clone [ + servers [ + [ server-loop ] curry with-logging + ] with-variable + ] 3curry parallel-each ; inline : stop-server ( -- ) servers get [ dispose ] each ; -: received-datagram ( addrspec -- ) drop ; + + : with-datagrams ( seq service quot -- ) [ - [ swap spawn-datagrams ] curry concurrency:parallel-each + [ swap spawn-datagrams ] curry parallel-each ] curry with-logging ; inline diff --git a/extra/io/server/summary.txt b/extra/io/server/summary.txt new file mode 100644 index 0000000000..e791b704eb --- /dev/null +++ b/extra/io/server/summary.txt @@ -0,0 +1 @@ +TCP/IP and UDP/IP servers diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor index 66336425a1..1c72a4780c 100644 --- a/extra/io/sniffer/bsd/bsd.factor +++ b/extra/io/sniffer/bsd/bsd.factor @@ -24,7 +24,7 @@ C: sniffer-spec : IOC_INOUT IOC_IN IOC_OUT bitor ; inline : IOC_DIRMASK HEX: e0000000 ; inline -:: ioc | inout group num len | +:: ioc ( inout group num len -- n ) group first 8 shift num bitor len IOCPARM_MASK bitand 16 shift bitor inout bitor ; diff --git a/extra/io/sockets/impl/impl-tests.factor b/extra/io/sockets/impl/impl-tests.factor index 51305db45c..6b930a994e 100644 --- a/extra/io/sockets/impl/impl-tests.factor +++ b/extra/io/sockets/impl/impl-tests.factor @@ -1,5 +1,5 @@ USING: io.sockets.impl io.sockets kernel tools.test ; -IN: temporary +IN: io.sockets.impl.tests [ B{ 1 2 3 4 } ] [ "1.2.3.4" T{ inet4 } inet-pton ] unit-test 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/timeouts/summary.txt b/extra/io/timeouts/summary.txt new file mode 100644 index 0000000000..7a648d30bb --- /dev/null +++ b/extra/io/timeouts/summary.txt @@ -0,0 +1 @@ +Low-level support for setting timeouts on I/O operations diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor index a704e3473a..df7e1389cc 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/extra/io/timeouts/timeouts-docs.factor @@ -1,14 +1,13 @@ IN: io.timeouts -USING: help.markup help.syntax math kernel ; +USING: help.markup help.syntax math kernel calendar ; -HELP: get-lapse -{ $values { "obj" object } { "lapse" lapse } } -{ $contract "Outputs an object's timeout lapse descriptor." } ; +HELP: timeout +{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } } +{ $contract "Outputs an object's timeout." } ; HELP: set-timeout -{ $values { "ms" integer } { "obj" object } } -{ $contract "Sets an object's timeout, in milliseconds." } -{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ; +{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } } +{ $contract "Sets an object's timeout." } ; HELP: timed-out { $values { "obj" object } } @@ -20,13 +19,12 @@ HELP: with-timeout ARTICLE: "io.timeouts" "I/O timeout protocol" "Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed." +{ $subsection timeout } { $subsection set-timeout } "The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations." -{ $subsection get-lapse } { $subsection timed-out } "A combinator to be used in operations which can time out:" { $subsection with-timeout } -{ $see-also "stream-protocol" "io.launcher" } -; +{ $see-also "stream-protocol" "io.launcher" } ; ABOUT: "io.timeouts" diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index 001f59368e..ef660a6f0d 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -1,76 +1,27 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math system dlists namespaces assocs init threads -io.streams.duplex ; +USING: kernel calendar alarms io.streams.duplex ; IN: io.timeouts -TUPLE: lapse entry timeout cutoff ; - -: f 0 0 \ lapse construct-boa ; - ! Won't need this with new slot accessors -GENERIC: get-lapse ( obj -- lapse ) +GENERIC: timeout ( obj -- dt/f ) +GENERIC: set-timeout ( dt/f obj -- ) -GENERIC: set-timeout ( ms obj -- ) - -M: object set-timeout get-lapse set-timeout ; - -M: lapse set-timeout set-lapse-timeout ; - -: timeout ( obj -- ms ) get-lapse lapse-timeout ; -: entry ( obj -- dlist-node ) get-lapse lapse-entry ; -: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ; -: cutoff ( obj -- ms ) get-lapse lapse-cutoff ; -: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ; - -! Won't need this with inheritance -TUPLE: duplex-stream-lapse stream ; - -M: duplex-stream-lapse set-timeout - duplex-stream-lapse-stream 2dup +M: duplex-stream set-timeout + 2dup duplex-stream-in set-timeout duplex-stream-out set-timeout ; -M: duplex-stream get-lapse duplex-stream-lapse construct-boa ; - -SYMBOL: timeout-queue - -: timeout? ( lapse -- ? ) - cutoff dup zero? not swap millis < and ; - -timeout-queue global [ [ ] unless* ] change-at - -: unqueue-timeout ( obj -- ) - entry [ - timeout-queue get-global swap delete-node - ] when* ; - -: queue-timeout ( obj -- ) - dup timeout-queue get-global push-front* - swap set-entry ; - GENERIC: timed-out ( obj -- ) M: object timed-out drop ; -: expire-timeouts ( -- ) - timeout-queue get-global dup dlist-empty? [ drop ] [ - dup peek-back timeout? - [ pop-back timed-out expire-timeouts ] [ drop ] if - ] if ; - -: begin-timeout ( obj -- ) - dup timeout dup zero? [ - 2drop - ] [ - millis + over set-cutoff - dup unqueue-timeout queue-timeout - ] if ; +: queue-timeout ( obj timeout -- alarm ) + >r [ timed-out ] curry r> later ; : with-timeout ( obj quot -- ) - over begin-timeout keep unqueue-timeout ; inline - -: expiry-thread ( -- ) - expire-timeouts 5000 sleep expiry-thread ; - -[ [ expiry-thread ] in-thread ] "io.timeouts" add-init-hook + over dup timeout dup [ + queue-timeout slip cancel-alarm + ] [ + 2drop call + ] if ; inline diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 7d9f76c686..fe2f63e99a 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien generic assocs kernel kernel.private math -io.nonblocking sequences strings structs sbufs threads unix -vectors io.buffers io.backend io.streams.duplex math.parser -continuations system libc qualified namespaces io.timeouts ; +io.nonblocking sequences strings structs sbufs +threads unix vectors io.buffers io.backend +io.streams.duplex math.parser continuations system libc +qualified namespaces io.timeouts ; QUALIFIED: io IN: io.unix.backend @@ -58,10 +59,10 @@ M: mx register-io-task ( task mx -- ) 2dup check-io-task fd/container set-at ; : add-io-task ( task -- ) - mx get-global register-io-task stop ; + mx get-global register-io-task ; : with-port-continuation ( port quot -- port ) - [ callcc0 ] curry with-timeout ; inline + [ "I/O" suspend drop ] curry with-timeout ; inline M: mx unregister-io-task ( task mx -- ) fd/container delete-at drop ; @@ -99,7 +100,7 @@ M: integer close-handle ( fd -- ) : pop-callbacks ( mx task -- ) dup rot unregister-io-task - io-task-callbacks [ schedule-thread ] each ; + io-task-callbacks [ resume ] each ; : handle-io-task ( mx task -- ) dup do-io-task [ pop-callbacks ] [ 2drop ] if ; @@ -168,7 +169,7 @@ M: write-task do-io-task : add-write-io-task ( port continuation -- ) over port-handle mx get-global mx-writes at* - [ io-task-callbacks push stop ] + [ io-task-callbacks push drop ] [ drop add-io-task ] if ; : (wait-to-write) ( port -- ) @@ -177,7 +178,7 @@ M: write-task do-io-task M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; -M: unix-io io-multiplex ( ms -- ) +M: unix-io io-multiplex ( ms/f -- ) mx get-global wait-for-events ; M: unix-io init-stdio ( -- ) diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 0ab9f4ed2a..89b0757da5 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.unix.bsd USING: io.backend io.unix.backend io.unix.kqueue io.unix.select -io.launcher io.unix.launcher namespaces kernel assocs threads -continuations ; +io.launcher io.unix.launcher namespaces kernel assocs +threads continuations ; ! On Mac OS X, we use select() for the top-level ! multiplexer, and we hang a kqueue off of it for process exit diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor index 103c2789c6..f5366d32ae 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -1,5 +1,5 @@ USING: tools.test io.files ; -IN: temporary +IN: io.unix.files.tests [ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test [ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 3bf0e3f897..db3cf674c7 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io -unix kernel math continuations math.bitfields byte-arrays -alien ; + unix unix.stat unix.time kernel math continuations math.bitfields + byte-arrays alien combinators combinators.cleave calendar ; + IN: io.unix.files M: unix-io cwd @@ -37,7 +38,15 @@ M: unix-io ( path -- stream ) M: unix-io ( path -- stream ) open-append ; -M: unix-io rename-file ( from to -- ) +: touch-mode + { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable + +M: unix-io touch-file ( path -- ) + touch-mode file-mode open + dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when + close ; + +M: unix-io move-file ( from to -- ) rename io-error ; M: unix-io delete-file ( path -- ) @@ -48,3 +57,35 @@ M: unix-io make-directory ( path -- ) M: unix-io delete-directory ( path -- ) rmdir io-error ; + +: (copy-file) ( from to -- ) + dup parent-directory make-directories + [ + swap [ + swap stream-copy + ] with-disposal + ] with-disposal ; + +M: unix-io copy-file ( from to -- ) + >r dup file-permissions over r> (copy-file) chmod io-error ; + +: stat>type ( stat -- type ) + stat-st_mode { + { [ dup S_ISREG ] [ +regular-file+ ] } + { [ dup S_ISDIR ] [ +directory+ ] } + { [ dup S_ISCHR ] [ +character-device+ ] } + { [ dup S_ISBLK ] [ +block-device+ ] } + { [ dup S_ISFIFO ] [ +fifo+ ] } + { [ dup S_ISLNK ] [ +symbolic-link+ ] } + { [ dup S_ISSOCK ] [ +socket+ ] } + { [ t ] [ +unknown+ ] } + } cond nip ; + +M: unix-io file-info ( path -- info ) + stat* { + [ stat>type ] + [ stat-st_size ] + [ stat-st_mode ] + [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] + } cleave + \ file-info construct-boa ; diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor new file mode 100644 index 0000000000..185d9cd405 --- /dev/null +++ b/extra/io/unix/files/unique/unique.factor @@ -0,0 +1,12 @@ +USING: kernel io.nonblocking io.unix.backend math.bitfields +unix io.files.unique.backend ; +IN: io.unix.files.unique + +: open-unique-flags ( -- flags ) + { O_RDWR O_CREAT O_EXCL } flags ; + +M: unix-io (make-unique-file) ( path -- duplex-stream ) + open-unique-flags file-mode open dup io-error + ; + +M: unix-io temporary-path ( -- path ) "/tmp" ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 19005df404..60e3754ec6 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel io.nonblocking io.unix.backend -sequences assocs unix unix.kqueue unix.process math namespaces -combinators threads vectors io.launcher io.unix.launcher ; +sequences assocs unix unix.time unix.kqueue unix.process math namespaces +combinators threads vectors io.launcher +io.unix.launcher ; IN: io.unix.kqueue TUPLE: kqueue-mx events ; @@ -65,7 +66,8 @@ M: kqueue-mx unregister-io-task ( task mx -- ) [ over kqueue-mx-events kevent-nth handle-kevent ] with each ; M: kqueue-mx wait-for-events ( ms mx -- ) - swap make-timespec dupd wait-kevent handle-kevents ; + swap dup [ make-timespec ] when + dupd wait-kevent handle-kevents ; : make-proc-kevent ( pid -- kevent ) "kevent" diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor deleted file mode 100755 index eb3038e1b5..0000000000 --- a/extra/io/unix/launcher/launcher-tests.factor +++ /dev/null @@ -1,33 +0,0 @@ -IN: temporary -USING: io.unix.launcher tools.test ; - -[ "" tokenize-command ] must-fail -[ " " tokenize-command ] must-fail -[ { "a" } ] [ "a" tokenize-command ] unit-test -[ { "abc" } ] [ "abc" tokenize-command ] unit-test -[ { "abc" } ] [ "abc " tokenize-command ] unit-test -[ { "abc" } ] [ " abc" tokenize-command ] unit-test -[ { "abc" "def" } ] [ "abc def" tokenize-command ] unit-test -[ { "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test -[ { "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test -[ { "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test -[ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test -[ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test -[ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] must-fail -[ "'abc def" tokenize-command ] must-fail -[ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test - -[ - { - "Hello world.app/Contents/MacOS/hello-ui" - "-i=boot.macosx-ppc.image" - "-include= math compiler ui" - "-deploy-vocab=hello-ui" - "-output-image=Hello world.app/Contents/Resources/hello-ui.image" - "-no-stack-traces" - "-no-user-init" - } -] [ - "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command -] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 5adf0d7453..a589af0457 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -1,42 +1,15 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.backend io.launcher io.unix.backend io.unix.files -io.nonblocking sequences kernel namespaces math system - alien.c-types debugger continuations arrays assocs -combinators unix.process parser-combinators memoize -promises strings threads unix ; +USING: io io.backend io.launcher io.nonblocking io.unix.backend +io.unix.files io.nonblocking sequences kernel namespaces math +system alien.c-types debugger continuations arrays assocs +combinators unix.process strings threads unix +io.unix.launcher.parser ; IN: io.unix.launcher ! Search unix first USE: unix -! Our command line parser. Supported syntax: -! foo bar baz -- simple tokens -! foo\ bar -- escaping the space -! 'foo bar' -- quotation -! "foo bar" -- quotation -LAZY: 'escaped-char' "\\" token any-char-parser &> ; - -LAZY: 'quoted-char' ( delimiter -- parser' ) - 'escaped-char' - swap [ member? not ] curry satisfy - <|> ; inline - -LAZY: 'quoted' ( delimiter -- parser ) - dup 'quoted-char' swap dup surrounded-by ; - -LAZY: 'unquoted' ( -- parser ) " '\"" 'quoted-char' ; - -LAZY: 'argument' ( -- parser ) - "\"" 'quoted' "'" 'quoted' 'unquoted' <|> <|> - [ >string ] <@ ; - -MEMO: 'arguments' ( -- parser ) - 'argument' " " token nonempty-list-of ; - -: tokenize-command ( command -- arguments ) - 'arguments' just parse-1 ; - : get-arguments ( -- seq ) +command+ get [ tokenize-command ] [ +arguments+ get ] if* ; @@ -120,8 +93,6 @@ M: unix-io process-stream* ] if ] if ; -: wait-loop ( -- ) - wait-for-processes [ 250 sleep ] when wait-loop ; - : start-wait-thread ( -- ) - [ wait-loop ] in-thread ; + [ wait-for-processes [ 250 sleep ] when t ] + "Process reaper" spawn-server drop ; diff --git a/extra/io/unix/launcher/parser/parser-tests.factor b/extra/io/unix/launcher/parser/parser-tests.factor new file mode 100755 index 0000000000..63aadcabbe --- /dev/null +++ b/extra/io/unix/launcher/parser/parser-tests.factor @@ -0,0 +1,33 @@ +IN: io.unix.launcher.parser.tests +USING: io.unix.launcher.parser tools.test ; + +[ "" tokenize-command ] must-fail +[ " " tokenize-command ] must-fail +[ V{ "a" } ] [ "a" tokenize-command ] unit-test +[ V{ "abc" } ] [ "abc" tokenize-command ] unit-test +[ V{ "abc" } ] [ "abc " tokenize-command ] unit-test +[ V{ "abc" } ] [ " abc" tokenize-command ] unit-test +[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test +[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test +[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test +[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test +[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test +[ "'abc def' \"hey" tokenize-command ] must-fail +[ "'abc def" tokenize-command ] must-fail +[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test + +[ + V{ + "Hello world.app/Contents/MacOS/hello-ui" + "-i=boot.macosx-ppc.image" + "-include= math compiler ui" + "-deploy-vocab=hello-ui" + "-output-image=Hello world.app/Contents/Resources/hello-ui.image" + "-no-stack-traces" + "-no-user-init" + } +] [ + "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command +] unit-test diff --git a/extra/io/unix/launcher/parser/parser.factor b/extra/io/unix/launcher/parser/parser.factor new file mode 100755 index 0000000000..f3bb82343a --- /dev/null +++ b/extra/io/unix/launcher/parser/parser.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: peg peg.parsers kernel sequences strings words +memoize ; +IN: io.unix.launcher.parser + +! Our command line parser. Supported syntax: +! foo bar baz -- simple tokens +! foo\ bar -- escaping the space +! 'foo bar' -- quotation +! "foo bar" -- quotation +MEMO: 'escaped-char' ( -- parser ) + "\\" token [ drop t ] satisfy 2seq [ second ] action ; + +MEMO: 'quoted-char' ( delimiter -- parser' ) + 'escaped-char' + swap [ member? not ] curry satisfy + 2choice ; inline + +MEMO: 'quoted' ( delimiter -- parser ) + dup 'quoted-char' repeat0 swap dup surrounded-by ; + +MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; + +MEMO: 'argument' ( -- parser ) + "\"" 'quoted' + "'" 'quoted' + 'unquoted' 3choice + [ >string ] action ; + +PEG: tokenize-command ( command -- ast/f ) + 'argument' " " token repeat1 list-of + " " token repeat0 swap over pack + just ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 70f8038baf..7580e7bf6b 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -3,8 +3,8 @@ USING: kernel io.backend io.monitors io.monitors.private io.files io.buffers io.nonblocking io.timeouts io.unix.backend io.unix.select io.unix.launcher unix.linux.inotify assocs -namespaces threads continuations init math alien.c-types alien -vocabs.loader ; +namespaces threads continuations init math +alien.c-types alien vocabs.loader ; IN: io.unix.linux TUPLE: linux-io ; @@ -22,10 +22,12 @@ TUPLE: inotify watches ; : wd>monitor ( wd -- monitor ) watches at ; -: ( -- port ) +: ( -- port/f ) H{ } clone - inotify_init dup io-error inotify - { set-inotify-watches set-delegate } inotify construct ; + inotify_init dup 0 < [ 2drop f ] [ + inotify + { set-inotify-watches set-delegate } inotify construct + ] if ; : inotify-fd inotify get-global port-handle ; @@ -45,7 +47,13 @@ TUPLE: inotify watches ; dup simple-monitor-handle watches delete-at simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ; +: check-inotify + inotify get [ + "inotify is not supported by this Linux release" throw + ] unless ; + M: linux-io ( path recursive? -- monitor ) + check-inotify drop IN_CHANGE_EVENTS add-watch ; M: linux-monitor dispose ( monitor -- ) @@ -103,8 +111,7 @@ TUPLE: inotify-task ; f inotify-task ; : init-inotify ( mx -- ) - - dup inotify set-global + dup inotify set-global swap register-io-task ; M: inotify-task do-io-task ( task -- ) diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 9827d4d54f..77a20beb42 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -49,7 +49,7 @@ TUPLE: select-mx read-fdset write-fdset ; f ; M: select-mx wait-for-events ( ms mx -- ) - swap >r dup init-fdsets r> make-timeval + swap >r dup init-fdsets r> dup [ make-timeval ] when select multiplexer-error dup read-fdset/tasks pick handle-fdset dup write-fdset/tasks rot handle-fdset ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 59a9a8ac2e..930240419a 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -4,11 +4,11 @@ ! We need to fiddle with the exact search order here, since ! unix::accept shadows streams::accept. IN: io.unix.sockets -USING: alien alien.c-types generic io -kernel math namespaces io.nonblocking parser threads unix -sequences byte-arrays io.sockets io.binary io.unix.backend -io.streams.duplex io.sockets.impl math.parser continuations -libc combinators ; +USING: alien alien.c-types generic io kernel math namespaces +io.nonblocking parser threads unix sequences +byte-arrays io.sockets io.binary io.unix.backend +io.streams.duplex io.sockets.impl math.parser continuations libc +combinators ; : pending-init-error ( port -- ) #! We close it here to avoid a resource leak; callers of diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index e1c3108952..680cb0b3e5 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,15 +1,15 @@ -USING: io.files io.sockets io kernel threads namespaces -tools.test continuations strings byte-arrays sequences -prettyprint system ; -IN: temporary +USING: io.files io.sockets io kernel threads +namespaces tools.test continuations strings byte-arrays +sequences prettyprint system ; +IN: io.unix.tests ! 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 -] in-thread + 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" resource-path ; -: client-addr "unix-domain-datagram-test-2" resource-path ; +! 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 -] in-thread +] "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" resource-path 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/io/unix/unix.factor b/extra/io/unix/unix.factor index e740561cf9..64e2cc3c3d 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,6 +1,6 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend combinators namespaces -system vocabs.loader sequences ; +io.unix.launcher io.unix.mmap io.backend +combinators namespaces system vocabs.loader sequences ; "io.unix." os append require diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index e90a9f16e2..d92b4db77c 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -7,7 +7,9 @@ IN: io.windows.ce.backend : port-errored ( port -- ) win32-error-string swap set-port-error ; -M: windows-ce-io io-multiplex ( ms -- ) (sleep) ; +M: windows-ce-io io-multiplex ( ms -- ) + 60 60 * 1000 * or (sleep) ; + M: windows-ce-io add-completion ( handle -- ) drop ; GENERIC: wince-read ( port port-handle -- ) diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor new file mode 100644 index 0000000000..0823c3f0f3 --- /dev/null +++ b/extra/io/windows/files/unique/unique.factor @@ -0,0 +1,9 @@ +USING: kernel system io.files.unique.backend +windows.kernel32 io.windows io.nonblocking ; +IN: io.windows.files.unique + +M: windows-io (make-unique-file) ( path -- stream ) + GENERIC_WRITE CREATE_NEW 0 open-file 0 ; + +M: windows-io temporary-path ( -- path ) + "TEMP" os-env ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index cc3278dadc..708dc1dc38 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -4,7 +4,8 @@ USING: alien alien.c-types arrays continuations destructors io io.windows io.windows.nt.pipes libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs -splitting system threads init strings combinators io.backend ; +splitting system threads init strings combinators +io.backend ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -145,11 +146,16 @@ M: windows-io kill-process* ( handle -- ) : wait-loop ( -- ) processes get dup assoc-empty? - [ drop t ] [ wait-for-processes ] if - [ 250 sleep ] when - wait-loop ; + [ drop f sleep-until ] + [ wait-for-processes [ 100 sleep ] when ] if ; + +SYMBOL: wait-thread : start-wait-thread ( -- ) - [ wait-loop ] in-thread ; + [ wait-loop t ] "Process wait" spawn-server + wait-thread set-global ; + +M: windows-io register-process + drop wait-thread get-global interrupt ; [ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 597bc99be2..10e55ed5f2 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,14 +1,15 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences -threads tuples.lib windows windows.errors windows.kernel32 -strings splitting io.files qualified ascii combinators.lib ; +threads tuples.lib windows windows.errors +windows.kernel32 strings splitting io.files qualified ascii +combinators.lib ; QUALIFIED: windows.winsock IN: io.windows.nt.backend SYMBOL: io-hash -TUPLE: io-callback port continuation ; +TUPLE: io-callback port thread ; C: io-callback @@ -52,11 +53,12 @@ M: windows-nt-io add-completion ( handle -- ) [ swap dup alien? [ "bad overlapped in save-callback" throw ] unless - io-hash get-global set-at stop - ] callcc0 2drop ; + io-hash get-global set-at + ] "I/O" suspend 3drop ; : wait-for-overlapped ( ms -- overlapped ? ) - >r master-completion-port get-global r> ! port ms + >r master-completion-port get-global + r> INFINITE or ! timeout 0 ! bytes f ! key f ! overlapped @@ -77,11 +79,11 @@ M: windows-nt-io add-completion ( handle -- ) ] [ (win32-error-string) swap lookup-callback [ io-callback-port set-port-error ] keep - ] if io-callback-continuation schedule-thread f + ] if io-callback-thread resume f ] if ] [ lookup-callback - io-callback-continuation schedule-thread f + io-callback-thread resume f ] if ; : drain-overlapped ( timeout -- ) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index f2be11855b..dda94da892 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,8 +1,8 @@ USING: continuations destructors io.buffers io.files io.backend io.timeouts io.nonblocking io.windows io.windows.nt.backend -kernel libc math threads windows windows.kernel32 alien.c-types -alien.arrays sequences combinators combinators.lib sequences.lib -ascii splitting alien strings assocs ; +kernel libc math threads windows windows.kernel32 +alien.c-types alien.arrays sequences combinators combinators.lib +sequences.lib ascii splitting alien strings assocs ; IN: io.windows.nt.files M: windows-nt-io cwd @@ -59,7 +59,8 @@ M: windows-nt-io root-directory? ( path -- ? ) } cond ; M: windows-nt-io normalize-pathname ( string -- string ) - dup string? [ "pathname must be a string" throw ] unless + dup string? [ "Pathname must be a string" throw ] unless + dup empty? [ "Empty pathname" throw ] when { { CHAR: / CHAR: \\ } } substitute cwd swap windows-path+ [ "/\\." member? ] right-trim diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index eff3c250dc..d14dff8c22 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32 windows.types libc assocs alien namespaces continuations io.monitors io.monitors.private io.nonblocking io.buffers io.files io.timeouts io sequences hashtables sorting arrays -combinators ; +combinators math.bitfields ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) @@ -13,7 +13,7 @@ IN: io.windows.nt.monitors share-mode f OPEN_EXISTING - FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED bitor + { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags f CreateFile dup invalid-handle? diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index e4ebe3dd37..c4ac99fe4a 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,6 +1,6 @@ USING: io.files kernel tools.test io.backend io.windows.nt.files splitting ; -IN: temporary +IN: io.windows.nt.tests [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test [ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index da7e83baca..be57a398a2 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -12,3 +12,5 @@ USE: io.windows.mmap USE: io.backend T{ windows-nt-io } set-io-backend + +"vocabs.monitor" require diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index ee3f744bb0..38b7d4829c 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend io.buffers io.files io.nonblocking io.sockets io.binary -io.sockets.impl windows.errors strings io.streams.duplex kernel -math namespaces sequences windows windows.kernel32 +io.sockets.impl windows.errors strings io.streams.duplex +kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting continuations math.bitfields ; IN: io.windows @@ -28,7 +28,7 @@ HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) M: windows-io normalize-directory ( string -- string ) - "\\" ?tail drop "\\*" append ; + normalize-pathname "\\" ?tail drop "\\*" append ; : share-mode ( -- fixnum ) { @@ -121,7 +121,7 @@ M: windows-io ( path -- stream ) M: windows-io ( path -- stream ) open-append ; -M: windows-io rename-file ( from to -- ) +M: windows-io move-file ( from to -- ) [ normalize-pathname ] 2apply MoveFile win32-error=0/f ; M: windows-io delete-file ( path -- ) diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 649a6bada7..8031678896 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ; -IN: temporary +IN: jamshred.tunnel.tests [ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 } T{ segment T{ oint f { 1 1 1 } } 1 } diff --git a/extra/koszul/koszul-tests.factor b/extra/koszul/koszul-tests.factor index d72314fc4d..13dc341350 100644 --- a/extra/koszul/koszul-tests.factor +++ b/extra/koszul/koszul-tests.factor @@ -1,5 +1,5 @@ USING: koszul tools.test kernel sequences assocs namespaces ; -IN: temporary +IN: koszul.tests [ { V{ { } } V{ { 1 } } V{ { 2 3 } { 7 8 } } V{ { 4 5 6 } } } diff --git a/extra/lazy-lists/examples/examples-tests.factor b/extra/lazy-lists/examples/examples-tests.factor index 14798de18a..d4e3ed79b8 100644 --- a/extra/lazy-lists/examples/examples-tests.factor +++ b/extra/lazy-lists/examples/examples-tests.factor @@ -1,5 +1,5 @@ USING: lazy-lists.examples lazy-lists tools.test ; -IN: temporary +IN: lazy-lists.examples.tests [ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test [ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test diff --git a/extra/lazy-lists/lazy-lists-tests.factor b/extra/lazy-lists/lazy-lists-tests.factor index 9b7f0effd2..0424a5d069 100644 --- a/extra/lazy-lists/lazy-lists-tests.factor +++ b/extra/lazy-lists/lazy-lists-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: lazy-lists tools.test kernel math io sequences ; -IN: temporary +IN: lazy-lists.tests [ { 1 2 3 4 } ] [ { 1 2 3 4 } >list list>array diff --git a/extra/lcd/lcd.factor b/extra/lcd/lcd.factor index 605ac4cd59..952bc17f17 100755 --- a/extra/lcd/lcd.factor +++ b/extra/lcd/lcd.factor @@ -1,4 +1,7 @@ -USING: sequences kernel math io ; +USING: sequences kernel math io calendar calendar.format +calendar.model arrays models namespaces ui.gadgets +ui.gadgets.labels +ui.gadgets.theme ui ; IN: lcd : lcd-digit ( row digit -- str ) @@ -6,14 +9,26 @@ IN: lcd " _ _ _ _ _ _ _ _ " " | | | _| _| |_| |_ |_ | |_| |_| * " " |_| | |_ _| | _| |_| | |_| | * " + " " } nth >r 4 * dup 4 + r> subseq ; : lcd-row ( num row -- string ) [ swap lcd-digit ] curry { } map-as concat ; : lcd ( digit-str -- string ) - 3 [ lcd-row ] with map "\n" join ; + 4 [ lcd-row ] with map "\n" join ; -: lcd-demo ( -- ) "31337" lcd print ; +: hh:mm:ss ( timestamp -- string ) + { + timestamp-hour timestamp-minute timestamp-second + } get-slots >fixnum 3array [ pad-00 ] map ":" join ; -MAIN: lcd-demo +: ( timestamp -- gadget ) + [ hh:mm:ss lcd ] + "99:99:99" lcd over set-label-string + monospace-font over set-label-font ; + +: time-window ( -- ) + [ time get "Time" open-window ] with-ui ; + +MAIN: time-window diff --git a/extra/lcd/summary.txt b/extra/lcd/summary.txt old mode 100644 new mode 100755 index 1b6436a614..e477045071 --- a/extra/lcd/summary.txt +++ b/extra/lcd/summary.txt @@ -1 +1 @@ -7-segment numeric display demo +7-segment LCD clock demo diff --git a/extra/levenshtein/levenshtein-tests.factor b/extra/levenshtein/levenshtein-tests.factor index 40e055686a..722ccb86ca 100644 --- a/extra/levenshtein/levenshtein-tests.factor +++ b/extra/levenshtein/levenshtein-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: temporary +IN: levenshtein.tests USING: tools.test levenshtein ; [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test diff --git a/extra/lint/lint-tests.factor b/extra/lint/lint-tests.factor index 707d34b274..9a39980c9f 100644 --- a/extra/lint/lint-tests.factor +++ b/extra/lint/lint-tests.factor @@ -1,5 +1,5 @@ USING: io lint kernel math tools.test ; -IN: temporary +IN: lint.tests ! Don't write code like this : lint1 diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor index 97f9aa5c65..b8d836ecc1 100644 --- a/extra/locals/locals-docs.factor +++ b/extra/locals/locals-docs.factor @@ -16,7 +16,7 @@ HELP: [| { $examples { $example "USE: locals" - ":: adder | n | [| m | m n + ] ;" + ":: adder ( n -- quot ) [| m | m n + ] ;" "3 5 adder call ." "8" } @@ -29,7 +29,7 @@ HELP: [let { $examples { $example "USING: locals math.functions ;" - ":: frobnicate | n seq |" + ":: frobnicate ( n seq -- newseq )" " [let | n' [ n 6 * ] |" " seq [ n' gcd nip ] map ] ;" "6 { 36 14 } frobnicate ." @@ -44,7 +44,7 @@ HELP: [wlet { $examples { $example "USE: locals" - ":: quuxify | n seq |" + ":: quuxify ( n seq -- newseq )" " [wlet | add-n [| m | m n + ] |" " seq [ add-n ] map ] ;" "2 { 1 2 3 } quuxify ." @@ -57,13 +57,15 @@ HELP: with-locals { $description "Performs closure conversion of a lexically-scoped form. All nested sub-forms are converted. This word must be applied to a " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " used in an ordinary definition, however forms in " { $link POSTPONE: :: } " and " { $link POSTPONE: MACRO:: } " definitions are automatically closure-converted and there is no need to use this word." } ; HELP: :: -{ $syntax ":: word | bindings... | body... ;" } +{ $syntax ":: word ( bindings... -- outputs... ) body... ;" } { $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } +{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } { $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ; HELP: MACRO:: -{ $syntax "MACRO:: word | bindings... | body... ;" } -{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } ; +{ $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" } +{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } +{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ; { POSTPONE: MACRO: POSTPONE: MACRO:: } related-words @@ -72,7 +74,7 @@ ARTICLE: "locals-mutable" "Mutable locals" $nl "Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:" { $code - ":: counter | |" + ":: counter ( -- )" " [let | value! [ 0 ] |" " [ value 1+ dup value! ]" " [ value 1- dup value! ] ] ;" @@ -86,7 +88,7 @@ ARTICLE: "locals-limitations" "Limitations of locals" $nl "Another limitation is that closure conversion does not descend into arrays, hashtables or other types of literals. For example, the following does not work:" { $code - ":: bad-cond-usage | a |" + ":: bad-cond-usage ( a -- ... )" " { [ a 0 < ] [ ... ] }" " { [ a 0 > ] [ ... ] }" " { [ a 0 = ] [ ... ] } ;" diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index 85984ffaee..e48f9f4061 100644 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -1,52 +1,52 @@ USING: locals math sequences tools.test hashtables words kernel -namespaces arrays ; -IN: temporary +namespaces arrays strings prettyprint ; +IN: locals.tests -:: foo | a b | a a ; +:: foo ( a b -- a a ) a a ; [ 1 1 ] [ 1 2 foo ] unit-test -:: add-test | a b | a b + ; +:: add-test ( a b -- c ) a b + ; [ 3 ] [ 1 2 add-test ] unit-test -:: sub-test | a b | a b - ; +:: sub-test ( a b -- c ) a b - ; [ -1 ] [ 1 2 sub-test ] unit-test -:: map-test | a b | a [ b + ] map ; +:: map-test ( a b -- seq ) a [ b + ] map ; [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test -:: map-test-2 | seq inc | seq [| elt | elt inc + ] map ; +:: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ; [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test -:: let-test | c | +:: let-test ( c -- d ) [let | a [ 1 ] b [ 2 ] | a b + c + ] ; [ 7 ] [ 4 let-test ] unit-test -:: let-test-2 | | - [let | a [ ] | [let | b [ a ] | a ] ] ; +:: let-test-2 ( a -- a ) + a [let | a [ ] | [let | b [ a ] | a ] ] ; [ 3 ] [ 3 let-test-2 ] unit-test -:: let-test-3 | | - [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ; +:: let-test-3 ( a -- a ) + a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ; -:: let-test-4 | | - [let | a [ 1 ] b [ ] | a b 2array ] ; +:: let-test-4 ( a -- b ) + a [let | a [ 1 ] b [ ] | a b 2array ] ; [ { 1 2 } ] [ 2 let-test-4 ] unit-test -:: let-test-5 | | - [let | a [ ] b [ ] | a b 2array ] ; +:: let-test-5 ( a -- b ) + a [let | a [ ] b [ ] | a b 2array ] ; [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test -:: let-test-6 | | - [let | a [ ] b [ 1 ] | a b 2array ] ; +:: let-test-6 ( a -- b ) + a [let | a [ ] b [ 1 ] | a b 2array ] ; [ { 2 1 } ] [ 2 let-test-6 ] unit-test @@ -57,26 +57,26 @@ IN: temporary with-locals ] unit-test -:: wlet-test-2 | a b | +:: wlet-test-2 ( a b -- seq ) [wlet | add-b [ b + ] | a [ add-b ] map ] ; [ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test -:: wlet-test-3 | a | +:: wlet-test-3 ( a -- b ) [wlet | add-a [ a + ] | [ add-a ] ] [let | a [ 3 ] | a swap call ] ; [ 5 ] [ 2 wlet-test-3 ] unit-test -:: wlet-test-4 | a | +:: wlet-test-4 ( a -- b ) [wlet | sub-a [| b | b a - ] | 3 sub-a ] ; [ -7 ] [ 10 wlet-test-4 ] unit-test -:: write-test-1 | n! | +:: write-test-1 ( n! -- q ) [| i | n i + dup n! ] ; 0 write-test-1 "q" set @@ -89,7 +89,7 @@ IN: temporary [ 5 ] [ 2 "q" get call ] unit-test -:: write-test-2 | | +:: write-test-2 ( -- q ) [let | n! [ 0 ] | [| i | n i + dup n! ] ] ; @@ -108,17 +108,55 @@ write-test-2 "q" set 20 10 [| a! | [| b! | a b ] ] with-locals call call ] unit-test -:: write-test-3 | a! | [| b | b a! ] ; +:: write-test-3 ( a! -- q ) [| b | b a! ] ; [ ] [ 1 2 write-test-3 call ] unit-test -:: write-test-4 | x! | [ [let | y! [ 0 ] | f x! ] ] ; +:: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ; [ ] [ 5 write-test-4 drop ] unit-test SYMBOL: a -:: use-test | a b c | +:: use-test ( a b c -- a b c ) USE: kernel ; [ t ] [ a symbol? ] unit-test + +:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ; + +[ 13 ] [ 10 let-let-test ] unit-test + +GENERIC: lambda-generic ( a b -- c ) + +GENERIC# lambda-generic-1 1 ( a b -- c ) + +M:: integer lambda-generic-1 ( a b -- c ) a b * ; + +M:: string lambda-generic-1 ( a b -- c ) + a b CHAR: x lambda-generic ; + +M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ; + +GENERIC# lambda-generic-2 1 ( a b -- c ) + +M:: integer lambda-generic-2 ( a b -- c ) + a CHAR: x b lambda-generic ; + +M:: string lambda-generic-2 ( a b -- c ) a b append ; + +M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; + +[ 10 ] [ 5 2 lambda-generic ] unit-test + +[ "abab" ] [ "aba" "b" lambda-generic ] unit-test + +[ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test + +[ "xaba" ] [ 1 "aba" lambda-generic ] unit-test + +[ ] [ \ lambda-generic-1 see ] unit-test + +[ ] [ \ lambda-generic-2 see ] unit-test + +[ ] [ \ lambda-generic see ] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 52ccb1bed3..2e6fd6485d 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math inference.transforms parser words quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables combinators.lib -prettyprint.sections sequences.private ; +prettyprint.sections sequences.private effects generic +compiler.units ; IN: locals ! Inspired by @@ -208,9 +209,6 @@ M: object local-rewrite* , ; : push-locals ( assoc -- ) use get push ; -: parse-locals ( -- words assoc ) - "|" parse-tokens make-locals ; - : pop-locals ( assoc -- ) use get delete ; @@ -218,7 +216,7 @@ M: object local-rewrite* , ; over push-locals parse-until >quotation swap pop-locals ; : parse-lambda ( -- lambda ) - parse-locals \ ] (parse-lambda) ; + "|" parse-tokens make-locals \ ] (parse-lambda) ; : (parse-bindings) ( -- ) scan dup "|" = [ @@ -246,11 +244,18 @@ M: wlet local-rewrite* dup wlet-bindings values over wlet-vars rot wlet-body [ call ] curry compose local-rewrite* \ call , ; -: (::) ( prop -- word quot n ) - >r CREATE dup reset-generic - scan "|" assert= parse-locals \ ; (parse-lambda) - 2dup r> set-word-prop - [ lambda-rewrite first ] keep lambda-vars length ; +: parse-locals + parse-effect + word [ over "declared-effect" set-word-prop ] when* + effect-in make-locals ; + +: ((::)) ( word -- word quot ) + scan "(" assert= parse-locals \ ; (parse-lambda) + 2dup "lambda" set-word-prop + lambda-rewrite first ; + +: (::) ( -- word quot ) + CREATE dup reset-generic ((::)) ; PRIVATE> @@ -268,9 +273,22 @@ PRIVATE> MACRO: with-locals ( form -- quot ) lambda-rewrite ; -: :: "lambda" (::) drop define ; parsing +: :: (::) define ; parsing -: MACRO:: "lambda-macro" (::) (MACRO:) ; parsing +! This will be cleaned up when method tuples and method words +! are unified +: create-method ( class generic -- method ) + 2dup method dup + [ 2nip method-word ] + [ drop 2dup [ ] -rot define-method create-method ] if ; + +: CREATE-METHOD ( -- class generic body ) + scan-word bootstrap-word scan-word 2dup + create-method f set-word dup save-location ; + +: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing + +: MACRO:: (::) define-macro ; parsing boolean ; + "lambda" word-prop >boolean ; M: lambda-macro definer drop \ MACRO:: \ ; ; M: lambda-macro definition - "lambda-macro" word-prop lambda-body ; + "lambda" word-prop lambda-body ; -M: lambda-macro synopsis* - "lambda-macro" lambda-word-synopsis ; +M: lambda-macro synopsis* lambda-word-synopsis ; + +PREDICATE: method-body lambda-method + "lambda" word-prop >boolean ; + +M: lambda-method definer drop \ M:: \ ; ; + +M: lambda-method definition + "lambda" word-prop lambda-body ; + +: method-stack-effect + dup "lambda" word-prop lambda-vars + swap "method" word-prop method-generic stack-effect dup [ effect-out ] when + ; + +M: lambda-method synopsis* + dup definer. + dup "method" word-prop dup + method-specializer pprint* + method-generic pprint* + method-stack-effect effect>string comment. ; PRIVATE> diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 1503e00163..5846515dca 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: logging.server sequences namespaces concurrency +USING: logging.server sequences namespaces concurrency.messaging words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string splitting continuations effects arrays.lib parser strings diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index b4c7e12772..015861501e 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -3,7 +3,7 @@ USING: parser-combinators memoize kernel sequences logging arrays words strings vectors io io.files namespaces combinators combinators.lib logging.server -calendar ; +calendar calendar.format ; IN: logging.parser : string-of satisfy [ >string ] <@ ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 05029df1d0..99f637f4a0 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel io calendar sequences io.files io.sockets continuations prettyprint assocs math.parser -words debugger math combinators concurrency arrays init -math.ranges strings ; +words debugger math combinators concurrency.messaging +threads arrays init math.ranges strings calendar.format ; IN: logging.server : log-root ( -- string ) @@ -68,11 +68,11 @@ SYMBOL: log-files : delete-oldest keep-logs log# ?delete-file ; -: ?rename-file ( old new -- ) - over exists? [ rename-file ] [ 2drop ] if ; +: ?move-file ( old new -- ) + over exists? [ move-file ] [ 2drop ] if ; : advance-log ( path n -- ) - [ 1- log# ] 2keep log# ?rename-file ; + [ 1- log# ] 2keep log# ?move-file ; : rotate-log ( service -- ) dup close-log @@ -85,17 +85,16 @@ SYMBOL: log-files log-root directory [ drop rotate-log ] assoc-each ; : log-server-loop ( -- ) - [ - receive unclip { - { "log-message" [ (log-message) ] } - { "rotate-logs" [ drop (rotate-logs) ] } - { "close-logs" [ drop (close-logs) ] } - } case - ] [ error. (close-logs) ] recover - log-server-loop ; + receive unclip { + { "log-message" [ (log-message) ] } + { "rotate-logs" [ drop (rotate-logs) ] } + { "close-logs" [ drop (close-logs) ] } + } case log-server-loop ; : log-server ( -- ) - [ log-server-loop ] spawn "log-server" set-global ; + [ [ log-server-loop ] [ error. (close-logs) ] recover t ] + "Log server" spawn-server + "log-server" set-global ; [ H{ } clone log-files set-global diff --git a/extra/macros/macros-tests.factor b/extra/macros/macros-tests.factor index d41003797c..59a53afb70 100644 --- a/extra/macros/macros-tests.factor +++ b/extra/macros/macros-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: macros.tests USING: tools.test macros math kernel arrays vectors ; diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor index 7694d9fa84..87b3acd47c 100755 --- a/extra/macros/macros.factor +++ b/extra/macros/macros.factor @@ -1,26 +1,21 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. - -USING: parser kernel sequences words effects inference.transforms -combinators assocs definitions quotations namespaces memoize ; - +USING: parser kernel sequences words effects +inference.transforms combinators assocs definitions quotations +namespaces memoize ; IN: macros -: (:) ( -- word definition effect-in ) - CREATE dup reset-generic parse-definition - over "declared-effect" word-prop effect-in length ; - : real-macro-effect ( word -- effect' ) "declared-effect" word-prop effect-in 1 ; -: (MACRO:) ( word definition effect-in -- ) - >r 2dup "macro" set-word-prop - 2dup over real-macro-effect memoize-quot - [ call ] append define +: define-macro ( word definition -- ) + over "declared-effect" word-prop effect-in length >r + 2dup "macro" set-word-prop + 2dup over real-macro-effect memoize-quot [ call ] append define r> define-transform ; : MACRO: - (:) (MACRO:) ; parsing + (:) define-macro ; parsing PREDICATE: word macro "macro" word-prop >boolean ; diff --git a/extra/match/match-tests.factor b/extra/match/match-tests.factor index d9162ae286..044b80fe9d 100755 --- a/extra/match/match-tests.factor +++ b/extra/match/match-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test match namespaces arrays ; -IN: temporary +IN: match.tests MATCH-VARS: ?a ?b ; diff --git a/extra/math/analysis/analysis-tests.factor b/extra/math/analysis/analysis-tests.factor index 0ed66a569c..5b537c2621 100644 --- a/extra/math/analysis/analysis-tests.factor +++ b/extra/math/analysis/analysis-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.functions tools.test math.analysis math.constants ; -IN: temporary +IN: math.analysis.tests : eps .00000001 ; diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/extra/math/combinatorics/combinatorics-tests.factor index 440630e38f..e6a2824433 100644 --- a/extra/math/combinatorics/combinatorics-tests.factor +++ b/extra/math/combinatorics/combinatorics-tests.factor @@ -1,5 +1,5 @@ USING: math.combinatorics math.combinatorics.private tools.test ; -IN: temporary +IN: math.combinatorics.tests [ { } ] [ 0 factoradic ] unit-test [ { 1 0 } ] [ 1 factoradic ] unit-test diff --git a/extra/math/complex/complex-tests.factor b/extra/math/complex/complex-tests.factor index e8535d0637..9174ac9988 100755 --- a/extra/math/complex/complex-tests.factor +++ b/extra/math/complex/complex-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.constants math.functions tools.test prettyprint ; -IN: temporary +IN: math.complex.tests [ 1 C{ 0 1 } rect> ] must-fail [ C{ 0 1 } 1 rect> ] must-fail diff --git a/extra/math/erato/erato-tests.factor b/extra/math/erato/erato-tests.factor index 6e961b979c..9244fa62e2 100644 --- a/extra/math/erato/erato-tests.factor +++ b/extra/math/erato/erato-tests.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: lazy-lists math.erato tools.test ; -IN: temporary +IN: math.erato.tests [ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 6f4dc42593..6773678dab 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.constants math.functions math.private math.libm tools.test ; -IN: temporary +IN: math.functions.tests [ t ] [ 4 4 .00000001 ~ ] unit-test [ t ] [ 4.0000001 4.0000001 .000001 ~ ] unit-test diff --git a/extra/math/matrices/elimination/elimination-tests.factor b/extra/math/matrices/elimination/elimination-tests.factor index d6fb2957e1..7c833391d8 100644 --- a/extra/math/matrices/elimination/elimination-tests.factor +++ b/extra/math/matrices/elimination/elimination-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.matrices.elimination.tests USING: kernel math.matrices math.matrices.elimination tools.test sequences ; diff --git a/extra/math/matrices/matrices-tests.factor b/extra/math/matrices/matrices-tests.factor index 9670ab80b8..ee2516e9a6 100644 --- a/extra/math/matrices/matrices-tests.factor +++ b/extra/math/matrices/matrices-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.matrices.tests USING: math.matrices math.vectors tools.test math ; [ diff --git a/extra/math/miller-rabin/miller-rabin-tests.factor b/extra/math/miller-rabin/miller-rabin-tests.factor index f8bc9d4970..9ca85ea72c 100644 --- a/extra/math/miller-rabin/miller-rabin-tests.factor +++ b/extra/math/miller-rabin/miller-rabin-tests.factor @@ -1,5 +1,5 @@ USING: math.miller-rabin tools.test ; -IN: temporary +IN: math.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test [ t ] [ 2 miller-rabin ] unit-test diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index 8b0d98283c..3985906b32 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -30,7 +30,7 @@ TUPLE: positive-even-expected n ; #! factor an integer into s * 2^r 0 swap (factor-2s) ; -:: (miller-rabin) | n prime?! | +:: (miller-rabin) ( n prime?! -- ? ) n 1- factor-2s s set r set trials get [ n 1- [1,b] random a set diff --git a/extra/math/numerical-integration/numerical-integration-tests.factor b/extra/math/numerical-integration/numerical-integration-tests.factor index 33b6e78571..c5b92c73de 100644 --- a/extra/math/numerical-integration/numerical-integration-tests.factor +++ b/extra/math/numerical-integration/numerical-integration-tests.factor @@ -1,6 +1,6 @@ USING: kernel math.numerical-integration tools.test math math.constants math.functions ; -IN: temporary +IN: math.numerical-integration.tests [ 50 ] [ 0 10 [ ] integrate-simpson ] unit-test [ 1000/3 ] [ 0 10 [ sq ] integrate-simpson ] unit-test diff --git a/extra/math/polynomials/polynomials-tests.factor b/extra/math/polynomials/polynomials-tests.factor index 4d0cdf8c8b..73215f9167 100644 --- a/extra/math/polynomials/polynomials-tests.factor +++ b/extra/math/polynomials/polynomials-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.polynomials.tests USING: kernel math math.polynomials tools.test ; ! Tests diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index 68ab5b3221..685124e4e9 100644 --- a/extra/math/primes/primes.factor +++ b/extra/math/primes/primes.factor @@ -47,3 +47,5 @@ PRIVATE> primes-upto >r 1- next-prime r> [ [ <=> ] binsearch ] keep [ length ] keep ; foldable + +: coprime? ( a b -- ? ) gcd nip 1 = ; foldable diff --git a/extra/math/quaternions/quaternions-tests.factor b/extra/math/quaternions/quaternions-tests.factor index 4f59798df0..b30a1bc271 100644 --- a/extra/math/quaternions/quaternions-tests.factor +++ b/extra/math/quaternions/quaternions-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.quaternions.tests USING: tools.test math.quaternions kernel math.vectors math.constants ; diff --git a/extra/math/ranges/ranges-tests.factor b/extra/math/ranges/ranges-tests.factor index 09416814bd..825c68d1b9 100644 --- a/extra/math/ranges/ranges-tests.factor +++ b/extra/math/ranges/ranges-tests.factor @@ -1,5 +1,5 @@ USING: math.ranges sequences tools.test arrays ; -IN: temporary +IN: math.ranges.tests [ { } ] [ 1 1 (a,b) >array ] unit-test [ { } ] [ 1 1 (a,b] >array ] unit-test diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor old mode 100644 new mode 100755 index 83a95c312d..ade3b63a5c --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -1,10 +1,6 @@ USING: kernel layouts math namespaces sequences sequences.private ; IN: math.ranges -: >integer ( n -- i ) - dup most-negative-fixnum most-positive-fixnum between? - [ >fixnum ] [ >bignum ] if ; - TUPLE: range from length step ; : ( from to step -- range ) diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index 4dba49b908..75572d8415 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.parser math.ratios math.functions tools.test ; -IN: temporary +IN: math.ratios.tests [ 1 2 ] [ 1/2 >fraction ] unit-test diff --git a/extra/math/statistics/statistics-tests.factor b/extra/math/statistics/statistics-tests.factor index 4d3b21bbbe..0884e1aed2 100644 --- a/extra/math/statistics/statistics-tests.factor +++ b/extra/math/statistics/statistics-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.functions math.statistics tools.test ; -IN: temporary +IN: math.statistics.tests [ 1 ] [ { 1 } mean ] unit-test [ 3/2 ] [ { 1 2 } mean ] unit-test diff --git a/extra/math/text/english/english-tests.factor b/extra/math/text/english/english-tests.factor index 00fccde1d3..8f8932c97d 100644 --- a/extra/math/text/english/english-tests.factor +++ b/extra/math/text/english/english-tests.factor @@ -1,5 +1,5 @@ USING: math.functions math.text.english tools.test ; -IN: temporary +IN: math.text.english.tests [ "Zero" ] [ 0 number>text ] unit-test [ "Twenty-One" ] [ 21 number>text ] unit-test diff --git a/extra/math/vectors/vectors-tests.factor b/extra/math/vectors/vectors-tests.factor index 924dc16c44..5c71e2374f 100644 --- a/extra/math/vectors/vectors-tests.factor +++ b/extra/math/vectors/vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.vectors.tests USING: math.vectors tools.test ; [ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test diff --git a/extra/models/models-docs.factor b/extra/models/models-docs.factor index 92ea6ced95..d514a539aa 100755 --- a/extra/models/models-docs.factor +++ b/extra/models/models-docs.factor @@ -1,4 +1,5 @@ -USING: help.syntax help.markup kernel math classes tuples ; +USING: help.syntax help.markup kernel math classes tuples +calendar ; IN: models HELP: model @@ -142,18 +143,18 @@ HELP: delay { $examples "The following code displays a sliders and a label which is updated half a second after the slider stops changing:" { $code - "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;" + "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;" ": " " 0 0 0 100 500 over set-slider-max ;" " dup gadget." - "gadget-model 500 [ number>string ] " + "gadget-model 1/2 seconds [ number>string ] " " gadget." } } ; HELP: -{ $values { "model" model } { "timeout" "a positive integer" } { "delay" delay } } -{ $description "Creates a new instance of " { $link delay } ". A timer of " { $snippet "timeout" } " milliseconds must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } +{ $values { "model" model } { "timeout" duration } { "delay" delay } } +{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } { $examples "See the example in the documentation for " { $link delay } "." } ; HELP: range-value diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor index ea615d2f9a..bd02c2f708 100755 --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: models.tests USING: arrays generic kernel math models namespaces sequences assocs tools.test ; diff --git a/extra/models/models.factor b/extra/models/models.factor index a6f1f6909a..fd84dd248f 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic kernel math sequences timers arrays assocs ; +USING: generic kernel math sequences arrays assocs alarms +calendar ; IN: models TUPLE: model value connections dependencies ref locked? ; @@ -174,7 +175,7 @@ TUPLE: history back forward ; dup history-forward delete-all dup history-back (add-history) ; -TUPLE: delay model timeout ; +TUPLE: delay model timeout alarm ; : update-delay-model ( delay -- ) dup delay-model model-value swap set-model ; @@ -185,12 +186,18 @@ TUPLE: delay model timeout ; [ set-delay-model ] 2keep [ add-dependency ] keep ; -M: delay model-changed nip 0 over delay-timeout add-timer ; +: cancel-delay ( delay -- ) + delay-alarm [ cancel-alarm ] when* ; + +: start-delay ( delay -- ) + dup [ f over set-delay-alarm update-delay-model ] curry + over delay-timeout later + swap set-delay-alarm ; + +M: delay model-changed nip dup cancel-delay start-delay ; M: delay model-activated update-delay-model ; -M: delay tick dup remove-timer update-delay-model ; - GENERIC: range-value ( model -- value ) GENERIC: range-page-value ( model -- value ) GENERIC: range-min-value ( model -- value ) diff --git a/extra/money/money-tests.factor b/extra/money/money-tests.factor index 19d6b6c2aa..b2ccdf93b7 100644 --- a/extra/money/money-tests.factor +++ b/extra/money/money-tests.factor @@ -1,5 +1,5 @@ USING: money parser tools.test ; -IN: temporary +IN: money.tests [ -1/10 ] [ DECIMAL: -.1 ] unit-test [ -1/10 ] [ DECIMAL: -0.1 ] unit-test diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index 1c68cbe540..8910e64092 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: multi-methods.tests USING: multi-methods tools.test kernel math arrays sequences prettyprint strings classes hashtables assocs namespaces debugger continuations ; diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor index 4edd4239fa..3273036b8b 100755 --- a/extra/new-slots/new-slots.factor +++ b/extra/new-slots/new-slots.factor @@ -34,7 +34,7 @@ IN: new-slots [ \ over , swap writer-word , ] [ ] make define-inline ] [ 2drop ] if ; -: changer-effect T{ effect f { "object" "quot" } } ; inline +: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline : changer-word ( name -- word ) "change-" swap append changer-effect create-accessor ; @@ -44,9 +44,9 @@ IN: new-slots [ [ over >r >r ] % over reader-word , - [ r> call r> ] % - swap writer-word , - ] [ ] make define + [ r> call r> swap ] % + swap setter-word , + ] [ ] make define-inline ] [ 2drop ] if ; : define-new-slot ( class slot name -- ) diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor old mode 100644 new mode 100755 index 518030ee4d..e24cee748e --- a/extra/ogg/player/player.factor +++ b/extra/ogg/player/player.factor @@ -14,7 +14,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays sequences libc shuffle alien.c-types system openal math 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 ; + continuations io.files hints combinators.lib sequences.lib debugger ; IN: ogg.player @@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ; dup player-gadget [ dup { player-td player-yuv } get-slots theora_decode_YUVout drop dup player-rgb over player-yuv yuv>rgb - dup player-gadget find-world dup draw-world + dup player-gadget relayout-1 yield ] when ; : num-audio-buffers-processed ( player -- player n ) @@ -177,7 +177,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 ; @@ -602,8 +602,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/opengl/capabilities/capabilities.factor b/extra/opengl/capabilities/capabilities.factor old mode 100644 new mode 100755 index d9eb6fd679..d27df4965d --- a/extra/opengl/capabilities/capabilities.factor +++ b/extra/opengl/capabilities/capabilities.factor @@ -26,8 +26,8 @@ IN: opengl.capabilities : version-seq ( version-string -- version-seq ) "." split [ string>number ] map ; -: version<=> ( version1 version2 -- n ) - swap version-seq swap version-seq <=> ; +: version-before? ( version1 version2 -- ? ) + swap version-seq swap version-seq before=? ; : (gl-version) ( -- version vendor ) GL_VERSION glGetString " " split1 ; @@ -36,7 +36,7 @@ IN: opengl.capabilities : gl-vendor-version ( -- version ) (gl-version) nip ; : has-gl-version? ( version -- ? ) - gl-version version<=> 0 <= ; + gl-version version-before? ; : (make-gl-version-error) ( required-version -- ) "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ; : require-gl-version ( version -- ) @@ -51,7 +51,7 @@ IN: opengl.capabilities : glsl-vendor-version ( -- version ) (glsl-version) nip ; : has-glsl-version? ( version -- ? ) - glsl-version version<=> 0 <= ; + glsl-version version-before? ; : require-glsl-version ( version -- ) [ has-glsl-version? ] [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ] diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index e05e3a1af5..01725ee9a9 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -17,7 +17,7 @@ SYMBOL: +gl-function-pointers+ : reset-gl-function-pointers ( -- ) 100 +gl-function-pointers+ set-global ; -[ reset-gl-function-pointers ] "opengl.gl init hook" add-init-hook +[ reset-gl-function-pointers ] "opengl.gl" add-init-hook reset-gl-function-pointers reset-gl-function-number-counter diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor old mode 100644 new mode 100755 index b9b1f6f314..a2958d5bea --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types arrays assocs byte-arrays inference inference.transforms io io.binary io.streams.string kernel math math.parser namespaces parser prettyprint -quotations sequences strings threads vectors +quotations sequences strings vectors words macros math.functions ; IN: pack diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor old mode 100644 new mode 100755 index a1f82391a0..2dd3fd911c --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel lazy-lists tools.test strings math sequences parser-combinators arrays math.parser unicode.categories ; -IN: scratchpad +IN: parser-combinators.tests ! Testing <&> { { T{ parse-result f { "a" "b" } T{ slice f 2 4 "abcd" } } } } [ diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index cdf89e1f37..bf06708e09 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: lazy-lists promises kernel sequences strings math arrays splitting quotations combinators namespaces -unicode.case unicode.categories ; +unicode.case unicode.categories sequences.deep ; IN: parser-combinators ! Parser combinator protocol @@ -329,11 +329,6 @@ LAZY: <(+)> ( parser -- parser ) LAZY: surrounded-by ( parser start end -- parser' ) [ token ] 2apply swapd pack ; -: flatten* ( obj -- ) - dup array? [ [ flatten* ] each ] [ , ] if ; - -: flatten [ flatten* ] { } make ; - : exactly-n ( parser n -- parser' ) swap [ flatten ] <@ ; diff --git a/extra/partial-apply/partial-apply.factor b/extra/partial-apply/partial-apply.factor deleted file mode 100644 index 0340e53025..0000000000 --- a/extra/partial-apply/partial-apply.factor +++ /dev/null @@ -1,26 +0,0 @@ - -USING: kernel sequences quotations math parser - shuffle combinators.cleave combinators.lib sequences.lib ; - -IN: partial-apply - -! Basic conceptual implementation. Todo: get it to compile. - -: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ; - -SYMBOL: _ - -SYMBOL: ~ - -: blank-positions ( quot -- seq ) - [ length 2 - ] [ _ indices ] bi [ - ] map-with ; - -: partial-apply ( pattern -- quot ) - [ blank-positions length nrev ] - [ peek 1quotation ] - [ blank-positions ] - tri - [ apply-n ] each ; - -: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing - diff --git a/extra/partial-continuations/partial-continuations-tests.factor b/extra/partial-continuations/partial-continuations-tests.factor index 56dc6bcd87..7e876b0934 100644 --- a/extra/partial-continuations/partial-continuations-tests.factor +++ b/extra/partial-continuations/partial-continuations-tests.factor @@ -1,6 +1,6 @@ USING: namespaces math partial-continuations tools.test kernel sequences ; -IN: temporary +IN: partial-continuations.tests SYMBOL: sum diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index a308b9af52..452da8df05 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test peg peg.ebnf ; -IN: temporary +IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ "abc" 'non-terminal' parse parse-result-ast diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index d134f3316f..5d7d7297ef 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - unicode.categories ; + peg.parsers unicode.categories ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -182,4 +182,4 @@ DEFER: 'choice' f ] if* ; -: " parse-tokens " " join ebnf>quot call ; parsing \ No newline at end of file +: " parse-tokens " " join ebnf>quot call ; parsing diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor new file mode 100755 index 0000000000..437edc1007 --- /dev/null +++ b/extra/peg/parsers/parsers-docs.factor @@ -0,0 +1,149 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax peg peg.parsers.private +unicode.categories ; +IN: peg.parsers + +HELP: (list-of) +{ $values + { "items" "a sequence" } + { "separator" "a parser" } + { "repeat1?" "a boolean" } + { "parser" "a parser" } +} { $description + "Returns a parser that returns a list of items separated by the separator parser. Does not hide the separators." +} { $see-also list-of list-of-many } ; + +HELP: list-of +{ $values + { "items" "a sequence" } + { "separator" "a parser" } +} { $description + "Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of one or more items." +} { $notes "Use " { $link list-of-many } " to ensure a list contains two or more items." } +{ $examples + { $example "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" } + { $example "\"a,a,a,a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also list-of-many } ; + +HELP: list-of-many +{ $values + { "items" "a sequence" } + { "separator" "a parser" } +} { $description + "Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of two or more items." +} { $notes "Use " { $link list-of } " to return a list of only one item." +} { $examples + { $example "\"a\" \"a\" token \",\" token list-of-many parse ." "f" } + { $example "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also list-of } ; + +HELP: epsilon +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches the empty sequence." +} ; + +HELP: any-char +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches the any single character." +} ; + +HELP: exactly-n +{ $values + { "parser" "a parser" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches an exact repetition of the input parser." +} { $examples + { $example "\"aaa\" \"a\" token 4 exactly-n parse ." "f" } + { $example "\"aaaa\" \"a\" token 4 exactly-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also at-least-n at-most-n from-m-to-n } ; + +HELP: at-least-n +{ $values + { "parser" "a parser" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches n or more repetitions of the input parser." +} { $examples + { $example "\"aaa\" \"a\" token 4 at-least-n parse ." "f" } + { $example "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "\"aaaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also exactly-n at-most-n from-m-to-n } ; + +HELP: at-most-n +{ $values + { "parser" "a parser" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches n or fewer repetitions of the input parser." +} { $examples + { $example "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "\"aaaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also exactly-n at-least-n from-m-to-n } ; + +HELP: from-m-to-n +{ $values + { "parser" "a parser" } + { "m" "an integer" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches between and including m to n repetitions of the input parser." +} { $examples + { $example "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" } + { $example "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also exactly-n at-most-n at-least-n } ; + +HELP: pack +{ $values + { "begin" "a parser" } + { "body" "a parser" } + { "end" "a parser" } + { "parser'" "a parser" } +} { $description + "Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden." +} { $examples + { $example "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "123" } +} { $see-also surrounded-by } ; + +HELP: surrounded-by +{ $values + { "parser" "a parser" } + { "begin" "a string" } + { "end" "a string" } + { "parser'" "a parser" } +} { $description + "Calls token on begin and end to make them into string parsers. Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden." +} { $examples + { $example "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "123" } +} { $see-also pack } ; + +HELP: 'digit' +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches a single digit as defined by the " { $link digit? } " word." +} { $see-also 'integer' } ; + +HELP: 'integer' +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches an integer composed of digits, as defined by the " { $link 'digit' } " word." +} { $see-also 'digit' 'string' } ; + +HELP: 'string' +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches an string composed of a \", anything that is not \", and another \"." +} { $see-also 'integer' } ; diff --git a/extra/peg/parsers/parsers-tests.factor b/extra/peg/parsers/parsers-tests.factor new file mode 100644 index 0000000000..08bde98419 --- /dev/null +++ b/extra/peg/parsers/parsers-tests.factor @@ -0,0 +1,50 @@ +USING: kernel peg peg.parsers tools.test ; +IN: peg.parsers.tests + +[ V{ "a" } ] +[ "a" "a" token "," token list-of parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "a,a,a,a" "a" token "," token list-of parse parse-result-ast ] unit-test + +[ f ] +[ "a" "a" token "," token list-of-many parse ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "a,a,a,a" "a" token "," token list-of-many parse parse-result-ast ] unit-test + +[ f ] +[ "aaa" "a" token 4 exactly-n parse ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 4 exactly-n parse parse-result-ast ] unit-test + +[ f ] +[ "aaa" "a" token 4 at-least-n parse ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" "a" } ] +[ "aaaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" } ] +[ "aaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test + +[ 97 ] +[ "a" any-char parse parse-result-ast ] unit-test + +[ V{ } ] +[ "" epsilon parse parse-result-ast ] unit-test diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor new file mode 100755 index 0000000000..5e82756853 --- /dev/null +++ b/extra/peg/parsers/parsers.factor @@ -0,0 +1,83 @@ +! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences strings namespaces math assocs shuffle + vectors arrays combinators.lib memoize math.parser match + unicode.categories sequences.deep peg peg.private ; +IN: peg.parsers + +TUPLE: just-parser p1 ; + +: just-pattern + [ + dup [ + dup parse-result-remaining empty? [ drop f ] unless + ] when + ] ; + + +M: just-parser compile ( parser -- quot ) + just-parser-p1 compile just-pattern append ; + +MEMO: just ( parser -- parser ) + just-parser construct-boa init-parser ; + +r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq + [ unclip 1vector swap first append ] action ; +PRIVATE> + +MEMO: list-of ( items separator -- parser ) + hide f (list-of) ; + +MEMO: list-of-many ( items separator -- parser ) + hide t (list-of) ; + +MEMO: epsilon ( -- parser ) V{ } token ; + +MEMO: any-char ( -- parser ) [ drop t ] satisfy ; + + + +MEMO: exactly-n ( parser n -- parser' ) + swap seq ; + +MEMO: at-most-n ( parser n -- parser' ) + dup zero? [ + 2drop epsilon + ] [ + 2dup exactly-n + -rot 1- at-most-n 2choice + ] if ; + +MEMO: at-least-n ( parser n -- parser' ) + dupd exactly-n swap repeat0 2seq + [ flatten-vectors ] action ; + +MEMO: from-m-to-n ( parser m n -- parser' ) + >r [ exactly-n ] 2keep r> swap - at-most-n 2seq + [ flatten-vectors ] action ; + +MEMO: pack ( begin body end -- parser ) + >r >r hide r> r> hide 3seq [ first ] action ; + +MEMO: surrounded-by ( parser begin end -- parser' ) + [ token ] 2apply swapd pack ; + +MEMO: 'digit' ( -- parser ) + [ digit? ] satisfy [ digit> ] action ; + +MEMO: 'integer' ( -- parser ) + 'digit' repeat1 [ 10 digits>integer ] action ; + +MEMO: 'string' ( -- parser ) + [ + [ CHAR: " = ] satisfy hide , + [ CHAR: " = not ] satisfy repeat0 , + [ CHAR: " = ] satisfy hide , + ] { } make seq [ first >string ] action ; diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 6a8d7429f3..7a1ce99883 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test strings namespaces arrays sequences peg peg.private ; -IN: temporary +IN: peg.tests { 0 1 2 } [ 0 next-id set-global get-next-id get-next-id get-next-id diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 59a8b63c14..01decc2c81 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib memoize math.parser match - unicode.categories ; + unicode.categories sequences.lib compiler.units parser + words ; IN: peg TUPLE: parse-result remaining ast ; @@ -306,9 +307,33 @@ MEMO: range ( min max -- parser ) : seq ( seq -- parser ) seq-parser construct-boa init-parser ; +: 2seq ( parser1 parser2 -- parser ) + 2array seq ; + +: 3seq ( parser1 parser2 parser3 -- parser ) + 3array seq ; + +: 4seq ( parser1 parser2 parser3 parser4 -- parser ) + 4array seq ; + +: seq* ( quot -- paser ) + { } make seq ; inline + : choice ( seq -- parser ) choice-parser construct-boa init-parser ; +: 2choice ( parser1 parser2 -- parser ) + 2array choice ; + +: 3choice ( parser1 parser2 parser3 -- parser ) + 3array choice ; + +: 4choice ( parser1 parser2 parser3 parser4 -- parser ) + 4array choice ; + +: choice* ( quot -- paser ) + { } make choice ; inline + MEMO: repeat0 ( parser -- parser ) repeat0-parser construct-boa init-parser ; @@ -336,18 +361,11 @@ MEMO: hide ( parser -- parser ) MEMO: delay ( parser -- parser ) delay-parser construct-boa init-parser ; -MEMO: list-of ( items separator -- parser ) - hide over 2array seq repeat0 [ concat ] action 2array seq [ unclip 1vector swap first append ] action ; - -MEMO: 'digit' ( -- parser ) - [ digit? ] satisfy [ digit> ] action ; - -MEMO: 'integer' ( -- parser ) - 'digit' repeat1 [ 10 digits>integer ] action ; - -MEMO: 'string' ( -- parser ) - [ - [ CHAR: " = ] satisfy hide , - [ CHAR: " = not ] satisfy repeat0 , - [ CHAR: " = ] satisfy hide , - ] { } make seq [ first >string ] action ; +: PEG: + (:) [ + [ + call compile + [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ] + append define + ] with-compilation-unit + ] 2curry over push-all ; parsing diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index cec7b24cd0..fa8ac89f57 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test peg peg.pl0 ; -IN: temporary +IN: peg.pl0.tests { "abc" } [ "abc" ident parse parse-result-ast diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index b6b030f56c..6844eb44dc 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays strings math.parser sequences peg peg.ebnf memoize ; +USING: kernel arrays strings math.parser sequences +peg peg.ebnf peg.parsers memoize ; IN: peg.pl0 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0 diff --git a/extra/peg/search/search-tests.factor b/extra/peg/search/search-tests.factor index b33161dfff..c65001be09 100755 --- a/extra/peg/search/search-tests.factor +++ b/extra/peg/search/search-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel math math.parser arrays tools.test peg peg.search ; -IN: temporary +IN: peg.search.tests { V{ 123 456 } } [ "abc 123 def 456" 'integer' search diff --git a/extra/porter-stemmer/porter-stemmer-tests.factor b/extra/porter-stemmer/porter-stemmer-tests.factor index d3e031fdc6..7294ac0e8f 100644 --- a/extra/porter-stemmer/porter-stemmer-tests.factor +++ b/extra/porter-stemmer/porter-stemmer-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: porter-stemmer.tests USING: arrays io kernel porter-stemmer sequences tools.test io.files ; diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor index fd3ca02135..a2c3ebcd1f 100644 --- a/extra/project-euler/019/019.factor +++ b/extra/project-euler/019/019.factor @@ -45,25 +45,20 @@ IN: project-euler.019 ; : end-date ( -- timestamp ) - 2000 12 31 0 0 0 0 make-timestamp ; + 2000 12 31 ; -: (first-days) ( end-date start-date -- ) - 2dup timestamp- 0 >= [ - dup day-of-week , 1 +month (first-days) - ] [ - 2drop - ] if ; - -: first-days ( start-date end-date -- seq ) - [ swap (first-days) ] { } make ; +: first-days ( end-date start-date -- days ) + [ 2dup after=? ] + [ dup 1 months time+ swap day-of-week ] + [ ] unfold 2nip ; PRIVATE> : euler019a ( -- answer ) - start-date end-date first-days [ zero? ] count ; + end-date start-date first-days [ zero? ] count ; ! [ euler019a ] 100 ave-time ! 131 ms run / 3 ms GC ave time - 100 trials 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/random/random-tests.factor b/extra/random/random-tests.factor index 7d506b85f3..d431e57d01 100644 --- a/extra/random/random-tests.factor +++ b/extra/random/random-tests.factor @@ -1,5 +1,5 @@ USING: kernel math random namespaces sequences tools.test ; -IN: temporary +IN: random.tests : check-random ( max -- ? ) dup >r random 0 r> between? ; diff --git a/extra/regexp/summary.txt b/extra/regexp/summary.txt new file mode 100644 index 0000000000..aa1e1c27a9 --- /dev/null +++ b/extra/regexp/summary.txt @@ -0,0 +1 @@ +Regular expressions diff --git a/extra/sequences/deep/deep.factor b/extra/sequences/deep/deep.factor index c55647bbcb..27b875bd8f 100644 --- a/extra/sequences/deep/deep.factor +++ b/extra/sequences/deep/deep.factor @@ -34,6 +34,9 @@ IN: sequences.deep : deep-contains? ( obj quot -- ? ) deep-find* nip ; inline +: deep-all? ( obj quot -- ? ) + [ not ] compose deep-contains? not ; inline + : deep-change-each ( obj quot -- ) over branch? [ [ [ call ] keep over >r deep-change-each r> diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 2f50ad1786..b19c2f39c9 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel sequences sequences.lib math math.functions math.ranges tools.test strings ; -IN: temporary +IN: sequences.lib.tests [ 50 ] [ 100 [1,b] [ even? ] count ] unit-test [ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test @@ -20,8 +20,6 @@ IN: temporary [ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test [ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test -[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test - [ -4 ] [ 1 -4 [ abs ] higher ] unit-test [ 1 ] [ 1 -4 [ abs ] lower ] unit-test @@ -80,4 +78,4 @@ IN: temporary { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test -[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test +[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 1beec90b75..c02932a020 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -18,8 +18,9 @@ IN: sequences.lib : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline -MACRO: nfirst ( n -- ) - [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ; +MACRO: firstn ( n -- ) + [ [ swap nth ] curry + [ keep ] curry ] map concat [ drop ] compose ; : prepare-index ( seq quot -- seq n quot ) >r dup length r> ; inline @@ -182,6 +183,14 @@ PRIVATE> : ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline : ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline +USE: continuations +: ?subseq ( from to seq -- subseq ) + >r >r 0 max r> r> + [ length tuck min >r min r> ] keep subseq ; + +: ?head* ( seq n -- seq/f ) (head) ?subseq ; +: ?tail* ( seq n -- seq/f ) (tail) ?subseq ; + : accumulator ( quot -- quot vec ) V{ } clone [ [ push ] curry compose ] keep ; diff --git a/extra/sequences/next/next.factor b/extra/sequences/next/next.factor old mode 100644 new mode 100755 index 5483cdff4b..5919fb0701 --- a/extra/sequences/next/next.factor +++ b/extra/sequences/next/next.factor @@ -3,6 +3,8 @@ IN: sequences.next r dup length swap r> ; inline + : (map-next) ( i seq quot -- ) ! this uses O(n) more bounds checks than is really necessary >r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index 6c80c8de7d..766103e4b0 100755 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -4,7 +4,7 @@ USING: tools.test kernel serialize io io.streams.string math alien arrays byte-arrays sequences math prettyprint parser classes math.constants ; -IN: temporary +IN: serialize.tests TUPLE: serialize-test a b ; diff --git a/extra/size-of/size-of.factor b/extra/size-of/size-of.factor new file mode 100644 index 0000000000..df43a9adb2 --- /dev/null +++ b/extra/size-of/size-of.factor @@ -0,0 +1,46 @@ + +USING: kernel namespaces sequences + io io.files io.launcher bake builder.util + accessors vars ; + +IN: size-of + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: headers + +: include-headers ( -- seq ) + headers> [ { "#include <" , ">" } bake to-string ] map ; + +: size-of-c-program ( type -- lines ) + { + "#include " + include-headers + { "main() { printf( \"%i\\n\" , sizeof( " , " ) ) ; }" } + } + bake to-strings ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: c-file ( -- path ) "size-of.c" temp-file ; + +: exe ( -- path ) "size-of" temp-file ; + +: answer ( -- path ) "size-of-answer" temp-file ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: size-of ( type -- n ) + c-file + [ size-of-c-program [ print ] each ] + with-file-writer + + { "gcc" c-file "-o" exe } to-strings + [ "Error compiling generated C program" print ] run-or-bail + + + { exe } to-strings >>arguments + answer >>stdout + >desc run-process drop + + answer eval-file ; \ No newline at end of file diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index 3ca1c72296..c28ec7745a 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -28,7 +28,7 @@ ! Connection closed by foreign host. USING: combinators kernel prettyprint io io.timeouts io.server -sequences namespaces io.sockets continuations ; +sequences namespaces io.sockets continuations calendar ; IN: smtp.server SYMBOL: data-mode @@ -56,7 +56,7 @@ SYMBOL: data-mode data-mode off "220 OK\r\n" write flush t ] } - { [ data-mode get ] [ global [ print ] bind t ] } + { [ data-mode get ] [ dup global [ print ] bind t ] } { [ t ] [ "500 ERROR\r\n" write flush t ] } @@ -66,7 +66,7 @@ SYMBOL: data-mode "Starting SMTP server on port " write dup . flush "127.0.0.1" swap [ accept [ - 60000 stdio get set-timeout + 1 minutes stdio get set-timeout "220 hello\r\n" write flush process global [ flush ] bind diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 784f446b7e..c1afeced3d 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,6 +1,6 @@ USING: smtp tools.test io.streams.string threads smtp.server kernel sequences namespaces logging ; -IN: temporary +IN: smtp.tests { 0 0 } [ [ ] with-smtp-connection ] must-infer-as diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 47bc16e029..f3f90f68b9 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -3,14 +3,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces io io.timeouts kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings -math.parser random system calendar ; +math.parser random system calendar calendar.format ; IN: smtp SYMBOL: smtp-domain SYMBOL: smtp-host "localhost" smtp-host set-global SYMBOL: smtp-port 25 smtp-port set-global -SYMBOL: read-timeout 60000 read-timeout set-global +SYMBOL: read-timeout 1 minutes read-timeout set-global SYMBOL: esmtp t esmtp set-global : log-smtp-connection ( host port -- ) 2drop ; @@ -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/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index 57c6b23d19..d66ffdc66e 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -3,8 +3,9 @@ ! USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel shuffle arrays io.files combinators ui.gestures -ui.gadgets ui.render opengl.gl system threads concurrency match -ui byte-arrays combinators.lib ; +ui.gadgets ui.render opengl.gl system match +ui byte-arrays combinators.lib qualified ; +QUALIFIED: threads IN: space-invaders TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ; @@ -337,7 +338,7 @@ M: space-invaders update-video ( value addr cpu -- ) : sync-frame ( millis -- millis ) #! Sleep until the time for the next frame arrives. 1000 60 / >fixnum + millis - dup 0 > - [ sleep ] [ drop yield ] if millis ; + [ threads:sleep ] [ drop threads:yield ] if millis ; : invaders-process ( millis gadget -- ) #! Run a space invaders gadget inside a @@ -353,9 +354,10 @@ M: space-invaders update-video ( value addr cpu -- ) ] if ; M: invaders-gadget graft* ( gadget -- ) - dup invaders-gadget-cpu init-sounds - [ f swap set-invaders-gadget-quit? ] keep - [ millis swap invaders-process ] spawn 2drop ; + dup invaders-gadget-cpu init-sounds + f over set-invaders-gadget-quit? + [ millis swap invaders-process ] curry + "Space invaders" threads:spawn drop ; M: invaders-gadget ungraft* ( gadget -- ) t swap set-invaders-gadget-quit? ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index d92b4bd48b..9d492e6467 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,7 +1,7 @@ USING: combinators io io.files io.streams.duplex io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences strings system -hexdump tools.interpreter ; +hexdump ; IN: tar : zero-checksum 256 ; diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor index 4091156558..6aeb5aa098 100644 --- a/extra/taxes/taxes-tests.factor +++ b/extra/taxes/taxes-tests.factor @@ -1,5 +1,5 @@ USING: kernel money taxes tools.test ; -IN: temporary +IN: taxes.tests [ 426 23 diff --git a/extra/timers/summary.txt b/extra/timers/summary.txt deleted file mode 100644 index 2b0c0b053f..0000000000 --- a/extra/timers/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Simple low-resolution timers diff --git a/extra/timers/timers-docs.factor b/extra/timers/timers-docs.factor deleted file mode 100644 index 05a52516ff..0000000000 --- a/extra/timers/timers-docs.factor +++ /dev/null @@ -1,36 +0,0 @@ -USING: help.syntax help.markup classes kernel ; -IN: timers - -HELP: init-timers -{ $description "Initializes the timer code." } -{ $notes "This word is automatically called when the UI is initialized, and it should only be called manually if timers are being used outside of the UI." } ; - -HELP: tick -{ $values { "object" object } } -{ $description "Called to notify an object registered with a timer that the timer has fired." } ; - -HELP: add-timer -{ $values { "object" object } { "delay" "a positive integer" } { "initial" "a positive integer" } } -{ $description "Registers a timer. Every " { $snippet "delay" } " milliseconds, " { $link tick } " will be called on the object. The initial delay from the time " { $link add-timer } " is called to when " { $link tick } " is first called is " { $snippet "initial" } " milliseconds." } ; - -HELP: remove-timer -{ $values { "object" object } } -{ $description "Unregisters a timer." } ; - -HELP: do-timers -{ $description "Fires all registered timers which are due to fire." } -{ $notes "This word is automatically called from the UI event loop, and it should only be called manually if timers are being used outside of the UI." } ; - -{ init-timers add-timer remove-timer tick do-timers } related-words - -ARTICLE: "timers" "Timers" -"Timers can be added and removed:" -{ $subsection add-timer } -{ $subsection remove-timer } -"Classes must implement a generic word so that their instances can handle timer ticks:" -{ $subsection tick } -"Timers can be used outside of the UI, however they must be initialized with an explicit call, and fired manually:" -{ $subsection init-timers } -{ $subsection do-timers } ; - -ABOUT: "timers" diff --git a/extra/timers/timers.factor b/extra/timers/timers.factor deleted file mode 100644 index e3a510287b..0000000000 --- a/extra/timers/timers.factor +++ /dev/null @@ -1,30 +0,0 @@ -! Copyright (C) 2005, 2006 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math namespaces sequences system ; -IN: timers - -TUPLE: timer object delay next ; - -: ( object delay initial -- timer ) - millis + timer construct-boa ; - -GENERIC: tick ( object -- ) - -: timers \ timers get-global ; - -: init-timers ( -- ) H{ } clone \ timers set-global ; - -: add-timer ( object delay initial -- ) - pick >r r> timers set-at ; - -: remove-timer ( object -- ) timers delete-at ; - -: advance-timer ( ms timer -- ) - [ timer-delay + ] keep set-timer-next ; - -: do-timer ( ms timer -- ) - dup timer-next pick <= - [ [ advance-timer ] keep timer-object tick ] [ 2drop ] if ; - -: do-timers ( -- ) - millis timers values [ do-timer ] with each ; diff --git a/extra/tools/annotations/annotations-tests.factor b/extra/tools/annotations/annotations-tests.factor index 90d9d26f51..ec8f48a161 100755 --- a/extra/tools/annotations/annotations-tests.factor +++ b/extra/tools/annotations/annotations-tests.factor @@ -1,5 +1,5 @@ USING: tools.test tools.annotations math parser ; -IN: temporary +IN: tools.annotations.tests : foo ; \ foo watch @@ -17,7 +17,7 @@ M: integer some-generic 1+ ; [ 4 ] [ 3 some-generic ] unit-test -[ ] [ "IN: temporary USE: math M: integer some-generic 1- ;" eval ] unit-test +[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test [ 2 ] [ 3 some-generic ] unit-test diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index eed23e8bc1..07038ceadf 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words parser io inspector quotations sequences prettyprint continuations effects definitions compiler.units -namespaces assocs ; +namespaces assocs tools.walker ; IN: tools.annotations : reset ( word -- ) @@ -61,7 +61,7 @@ IN: tools.annotations dupd [ (watch-vars) ] 2curry annotate ; : breakpoint ( word -- ) - [ \ break add* ] annotate ; + [ add-breakpoint ] annotate ; : breakpoint-if ( word quot -- ) [ [ [ break ] when ] rot 3append ] curry annotate ; diff --git a/extra/tools/browser/browser-tests.factor b/extra/tools/browser/browser-tests.factor index fc7960e475..38d9ae65e2 100755 --- a/extra/tools/browser/browser-tests.factor +++ b/extra/tools/browser/browser-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.browser.tests USING: tools.browser tools.test help.markup ; [ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 7c28983519..e9aaa190dc 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -107,6 +107,7 @@ MEMO: all-vocabs-seq ( -- seq ) { [ "ui.windows" ?head ] [ t ] } { [ "ui.cocoa" ?head ] [ t ] } { [ "cocoa" ?head ] [ t ] } + { [ "core-foundation" ?head ] [ t ] } { [ "vocabs.loader.test" ?head ] [ t ] } { [ "editors." ?head ] [ t ] } { [ ".windows" ?tail ] [ t ] } diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor old mode 100644 new mode 100755 index 657b5fc030..a277a68ed7 --- a/extra/tools/crossref/crossref-tests.factor +++ b/extra/tools/crossref/crossref-tests.factor @@ -1,12 +1,12 @@ USING: math kernel sequences io.files tools.crossref tools.test -parser namespaces source-files ; -IN: temporary +parser namespaces source-files generic definitions ; +IN: tools.crossref.tests GENERIC: foo M: integer foo + ; -"resource:extra/tools/test/foo.factor" run-file +"resource:extra/tools/crossref/test/foo.factor" run-file -[ t ] [ { integer foo } \ + smart-usage member? ] unit-test -[ t ] [ \ foo smart-usage [ pathname? ] contains? ] unit-test +[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test +[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor index f6561e9f26..f4515a9ebe 100755 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -6,14 +6,8 @@ generic tools.completion quotations parser inspector sorting hashtables vocabs parser source-files ; IN: tools.crossref -: synopsis-alist ( definitions -- alist ) - [ dup synopsis swap ] { } map>assoc ; - -: definitions. ( alist -- ) - [ write-object nl ] assoc-each ; - : usage. ( word -- ) - smart-usage synopsis-alist sort-keys definitions. ; + usage sorted-definitions. ; : words-matching ( str -- seq ) all-words [ dup word-name ] { } map>assoc completions ; diff --git a/extra/tools/test/foo.factor b/extra/tools/crossref/test/foo.factor old mode 100644 new mode 100755 similarity index 50% rename from extra/tools/test/foo.factor rename to extra/tools/crossref/test/foo.factor index 944a25cf5e..f7bc321912 --- a/extra/tools/test/foo.factor +++ b/extra/tools/crossref/test/foo.factor @@ -1,4 +1,4 @@ -USE: temporary +USE: tools.crossref.tests USE: kernel 1 2 foo drop diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor index c1b9755cd6..846bb5c274 100755 --- a/extra/tools/deploy/config/config-docs.factor +++ b/extra/tools/deploy/config/config-docs.factor @@ -66,6 +66,11 @@ HELP: deploy-math? $nl "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ; +HELP: deploy-threads? +{ $description "Deploy flag. If set, the deployed image will contain support for threads." +$nl +"On by default. Often the programmer will use threads without realizing it. A small amount of space can be saved by stripping this feature out, but some code may require changes to work properly." } ; + HELP: deploy-compiler? { $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible." $nl diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index 1f34e68f29..64f863b730 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -10,6 +10,7 @@ SYMBOL: deploy-name SYMBOL: deploy-ui? SYMBOL: deploy-compiler? SYMBOL: deploy-math? +SYMBOL: deploy-threads? SYMBOL: deploy-io @@ -55,6 +56,7 @@ SYMBOL: deploy-image { deploy-io 2 } { deploy-reflection 1 } { deploy-compiler? t } + { deploy-threads? t } { deploy-math? t } { deploy-word-props? f } { deploy-word-defs? f } diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor new file mode 100755 index 0000000000..d473d8f640 --- /dev/null +++ b/extra/tools/deploy/deploy-tests.factor @@ -0,0 +1,22 @@ +IN: tools.deploy.tests +USING: tools.test system io.files kernel tools.deploy.config +tools.deploy.backend math ; + +: shake-and-bake + "." resource-path [ + vm + "hello.image" temp-file + rot dup deploy-config make-deploy-image + ] with-directory ; + +[ ] [ "hello-world" shake-and-bake ] unit-test + +[ t ] [ + "hello.image" temp-file file-length 500000 <= +] unit-test + +[ ] [ "hello-ui" shake-and-bake ] unit-test + +[ t ] [ + "hello.image" temp-file file-length 2000000 <= +] unit-test diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index eb1a4af4a7..61d7b9eaed 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -1,36 +1,22 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files io.launcher kernel namespaces sequences -system tools.deploy.backend tools.deploy.config assocs -hashtables prettyprint io.unix.backend cocoa -cocoa.application cocoa.classes cocoa.plists qualified ; -QUALIFIED: unix +USING: io io.files kernel namespaces sequences system +tools.deploy.backend tools.deploy.config assocs hashtables +prettyprint cocoa cocoa.application cocoa.classes cocoa.plists ; IN: tools.deploy.macosx -: touch ( path -- ) - { "touch" } swap add try-process ; - -: rm ( path -- ) - { "rm" "-rf" } swap add try-process ; - : bundle-dir ( -- dir ) vm parent-directory parent-directory ; : copy-bundle-dir ( name dir -- ) - bundle-dir over path+ -rot - >r "Contents" path+ r> path+ copy-directory ; - -: chmod ( path perms -- ) - unix:chmod io-error ; + bundle-dir swap path+ swap "Contents" path+ copy-tree ; : copy-vm ( executable bundle-name -- vm ) - "Contents/MacOS/" path+ swap path+ vm swap - [ copy-file ] keep - [ OCT: 755 chmod ] keep ; + "Contents/MacOS/" path+ swap path+ vm over copy-file ; : copy-fonts ( name -- ) "fonts/" resource-path - swap "Contents/Resources/fonts/" path+ copy-directory ; + swap "Contents/Resources/" path+ copy-tree ; : print-app-plist ( executable bundle-name -- ) [ @@ -75,7 +61,7 @@ M: macosx-deploy-implementation deploy* ( vocab -- ) ".app deploy tool" assert.app "." resource-path cd dup deploy-config [ - bundle-name rm + bundle-name delete-tree [ bundle-name create-app-dir ] keep [ bundle-name deploy.app-image ] keep namespace make-deploy-image diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 16507232ae..0ddc2d5707 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -11,8 +11,16 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show "command-line" init-hooks get delete-at - "mallocs" init-hooks get delete-at - strip-io? [ "io.backend" init-hooks get delete-at ] when ; + "libc" init-hooks get delete-at + deploy-threads? get [ + "threads" init-hooks get delete-at + ] unless + native-io? [ + "io.thread" init-hooks get delete-at + ] unless + strip-io? [ + "io.backend" init-hooks get delete-at + ] when ; : strip-debugger ( -- ) strip-debugger? [ @@ -85,6 +93,7 @@ IN: tools.deploy.shaker { } set-retainstack V{ } set-namestack V{ } set-catchstack + "Saving final image" show [ save-image-and-exit ] call-clear ; diff --git a/extra/tools/deploy/shaker/strip-debugger.factor b/extra/tools/deploy/shaker/strip-debugger.factor index 38f5268c80..5caab02e69 100755 --- a/extra/tools/deploy/shaker/strip-debugger.factor +++ b/extra/tools/deploy/shaker/strip-debugger.factor @@ -1,6 +1,8 @@ -USING: kernel ; +USING: kernel threads threads.private ; IN: debugger : print-error die ; : error. die ; + +M: thread error-in-thread ( error thread -- ) die 2drop ; diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 00dbc2e4df..6a2ce448af 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.files kernel namespaces sequences system tools.deploy.backend tools.deploy.config assocs hashtables @@ -6,20 +6,16 @@ prettyprint windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-vm ( executable bundle-name -- vm ) - swap path+ ".exe" append vm swap [ copy-file ] keep ; + swap path+ ".exe" append + vm over copy-file ; : copy-fonts ( bundle-name -- ) - "fonts/" resource-path - swap "fonts/" path+ copy-directory ; + "fonts/" resource-path swap copy-tree-into ; : copy-dlls ( bundle-name -- ) - { - "freetype6.dll" - "zlib1.dll" - "factor-nt.dll" - } [ - dup resource-path -rot path+ copy-file - ] with each ; + { "freetype6.dll" "zlib1.dll" "factor.dll" } + [ resource-path ] map + swap copy-files-into ; : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dlls @@ -34,10 +30,11 @@ TUPLE: windows-deploy-implementation ; T{ windows-deploy-implementation } deploy-implementation set-global M: windows-deploy-implementation deploy* - "." resource-path cd - dup deploy-config [ - [ deploy-name get create-exe-dir ] keep - [ deploy-name get image-name ] keep - [ namespace make-deploy-image ] keep - open-in-explorer - ] bind ; + "." resource-path [ + dup deploy-config [ + [ deploy-name get create-exe-dir ] keep + [ deploy-name get image-name ] keep + [ namespace make-deploy-image ] keep + open-in-explorer + ] bind + ] with-directory ; diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 745e3b1842..8a0cd495cf 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -5,9 +5,9 @@ io.launcher system assocs arrays sequences namespaces qualified system math generator.fixup ; IN: tools.disassembler -: in-file "gdb-in.txt" resource-path ; +: in-file "gdb-in.txt" temp-file ; -: out-file "gdb-out.txt" resource-path ; +: out-file "gdb-out.txt" temp-file ; GENERIC: make-disassemble-cmd ( obj -- ) @@ -27,7 +27,7 @@ M: pair make-disassemble-cmd +closed+ +stdin+ set out-file +stdout+ set [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set - ] { } make-assoc run-process drop + ] { } make-assoc try-process out-file file-lines ; : tabs>spaces ( str -- str' ) diff --git a/extra/tools/interpreter/debug/debug.factor b/extra/tools/interpreter/debug/debug.factor deleted file mode 100644 index 438734773f..0000000000 --- a/extra/tools/interpreter/debug/debug.factor +++ /dev/null @@ -1,31 +0,0 @@ -! Copyright (C) 2004, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.interpreter kernel arrays continuations threads -sequences namespaces ; -IN: tools.interpreter.debug - -: run-interpreter ( interpreter -- ) - dup interpreter-continuation [ - dup step-into run-interpreter - ] [ - drop - ] if ; - -: quot>cont ( quot -- cont ) - [ - swap [ - continue-with - ] curry callcc0 call stop - ] curry callcc1 ; - -: init-interpreter ( quot interpreter -- ) - >r - [ datastack "datastack" set ] compose quot>cont - f swap 2array - r> restore ; - -: test-interpreter ( quot -- ) - - [ init-interpreter ] keep - run-interpreter - "datastack" get ; diff --git a/extra/tools/interpreter/interpreter-docs.factor b/extra/tools/interpreter/interpreter-docs.factor deleted file mode 100644 index cb4b207fd9..0000000000 --- a/extra/tools/interpreter/interpreter-docs.factor +++ /dev/null @@ -1,54 +0,0 @@ -USING: help.markup help.syntax kernel generic -math hashtables quotations classes continuations ; -IN: tools.interpreter - -ARTICLE: "meta-interpreter" "Meta-circular interpreter" -"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "." -$nl -"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section." -$nl -"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary." -$nl -"Breakpoints can be inserted in user code:" -{ $subsection break } -"Breakpoints invoke a hook:" -{ $subsection break-hook } -"Single stepping with the meta-circular interpreter:" -{ $subsection step } -{ $subsection step-into } -{ $subsection step-out } -{ $subsection step-all } ; - -ABOUT: "meta-interpreter" - -HELP: interpreter -{ $class-description "An interpreter instance." } ; - -HELP: step -{ $values { "interpreter" interpreter } } -{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:" - { $list - { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" } - { "If the object is a word, then the word is executed in the single stepper's continuation atomically" } - { "Otherwise, the object is pushed on the single stepper's data stack" } - } -} ; - -HELP: step-into -{ $values { "interpreter" interpreter } } -{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:" - { $list - { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" } - { "If the object is a compound word, then the single stepper enters the word definition" } - { "If the object is a primitive word or a word with special single stepper behavior, it is executed in the single stepper's continuation atomically" } - { "Otherwise, the object is pushed on the single stepper's data stack" } - } -} ; - -HELP: step-out -{ $values { "interpreter" interpreter } } -{ $description "Evaluates the remainder of the current quotation in the single stepper." } ; - -HELP: step-all -{ $values { "interpreter" interpreter } } -{ $description "Executes the remainder of the single stepper's continuation. This effectively ends single stepping unless the continuation invokes " { $link break } " at a later point in time." } ; diff --git a/extra/tools/interpreter/interpreter-tests.factor b/extra/tools/interpreter/interpreter-tests.factor deleted file mode 100755 index 644f83c2ca..0000000000 --- a/extra/tools/interpreter/interpreter-tests.factor +++ /dev/null @@ -1,113 +0,0 @@ -USING: tools.interpreter io io.streams.string kernel math -math.private namespaces prettyprint sequences tools.test -continuations math.parser threads arrays -tools.interpreter.private tools.interpreter.debug ; -IN: temporary - -[ "Ooops" throw ] break-hook set - -[ { } ] [ - [ ] test-interpreter -] unit-test - -[ { 1 } ] [ - [ 1 ] test-interpreter -] unit-test - -[ { 1 2 3 } ] [ - [ 1 2 3 ] test-interpreter -] unit-test - -[ { "Yo" 2 } ] [ - [ 2 >r "Yo" r> ] test-interpreter -] unit-test - -[ { 2 } ] [ - [ t [ 2 ] [ "hi" ] if ] test-interpreter -] unit-test - -[ { "hi" } ] [ - [ f [ 2 ] [ "hi" ] if ] test-interpreter -] unit-test - -[ { 4 } ] [ - [ 2 2 fixnum+ ] test-interpreter -] unit-test - -: foo 2 2 fixnum+ ; - -[ { 8 } ] [ - [ foo 4 fixnum+ ] test-interpreter -] unit-test - -[ { C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [ - [ C{ 1 1.5 } { } 2dup ] test-interpreter -] unit-test - -[ { t } ] [ - [ 5 5 number= ] test-interpreter -] unit-test - -[ { f } ] [ - [ 5 6 number= ] test-interpreter -] unit-test - -[ { f } ] [ - [ "XYZ" "XYZ" mismatch ] test-interpreter -] unit-test - -[ { t } ] [ - [ "XYZ" "XYZ" sequence= ] test-interpreter -] unit-test - -[ { t } ] [ - [ "XYZ" "XYZ" = ] test-interpreter -] unit-test - -[ { f } ] [ - [ "XYZ" "XuZ" = ] test-interpreter -] unit-test - -[ { 4 } ] [ - [ 2 2 + ] test-interpreter -] unit-test - -[ { } 2 ] [ - 2 "x" set [ [ 3 "x" set ] with-scope ] test-interpreter "x" get -] unit-test - -[ { 3 } ] [ - [ 3 "x" set "x" get ] test-interpreter -] unit-test - -[ { "hi\n" } ] [ - [ [ "hi" print ] with-string-writer ] test-interpreter -] unit-test - -[ { "4\n" } ] [ - [ [ 2 2 + number>string print ] with-string-writer ] test-interpreter -] unit-test - -[ { 1 2 3 } ] [ - [ { 1 2 3 } set-datastack ] test-interpreter -] unit-test - -[ { 6 } ] -[ [ 3 [ nip continue ] callcc0 2 * ] test-interpreter ] unit-test - -[ { 6 } ] -[ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test - -[ { } ] -[ [ [ ] [ ] recover ] test-interpreter ] unit-test - -[ { 6 } ] -[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test - -[ { "{ 1 2 3 }\n" } ] [ - [ [ { 1 2 3 } . ] with-string-writer ] test-interpreter -] unit-test - -[ { } ] [ - [ "a" "b" set "c" "d" set [ ] test-interpreter ] with-scope -] unit-test diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor deleted file mode 100755 index 02c0af89ac..0000000000 --- a/extra/tools/interpreter/interpreter.factor +++ /dev/null @@ -1,116 +0,0 @@ -! Copyright (C) 2004, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs classes combinators sequences.private -continuations continuations.private generic hashtables io kernel -kernel.private math namespaces namespaces.private prettyprint -quotations sequences splitting strings threads vectors words ; -IN: tools.interpreter - -: walk ( quot -- ) \ break add* call ; - -TUPLE: interpreter continuation ; - -: interpreter construct-empty ; - -GENERIC# restore 1 ( obj interpreter -- ) - -M: f restore - set-interpreter-continuation ; - -M: continuation restore - >r clone r> set-interpreter-continuation ; - -: with-interpreter-datastack ( quot interpreter -- ) - interpreter-continuation [ - continuation-data - swap with-datastack - ] keep set-continuation-data ; inline - -M: pair restore - >r first2 r> [ restore ] keep - >r [ nip f ] curry r> with-interpreter-datastack ; - -n ndrop >c c> - continue continue-with - (continue-with) stop -} [ - dup [ execute break ] curry - "step-into" set-word-prop -] each - -\ break [ break ] "step-into" set-word-prop - -! Stepping -: change-innermost-frame ( quot interpreter -- ) - interpreter-continuation [ - continuation-call clone - [ - dup innermost-frame-scan 1+ - swap innermost-frame-quot - rot call - ] keep - [ set-innermost-frame-quot ] keep - ] keep set-continuation-call ; inline - -: (step) ( interpreter quot -- ) - swap - [ change-innermost-frame ] keep - [ interpreter-continuation with-walker-hook ] keep - restore ; - -PRIVATE> - -: step ( interpreter -- ) - [ - 2dup nth \ break = [ - nip - ] [ - swap 1+ cut [ break ] swap 3append - ] if - ] (step) ; - -: step-out ( interpreter -- ) - [ nip \ break add ] (step) ; - -: step-into ( interpreter -- ) - [ - swap cut [ - swap % unclip literalize , \ (step-into) , % - ] [ ] make - ] (step) ; - -: step-all ( interpreter -- ) - interpreter-continuation [ (continue) ] curry in-thread ; diff --git a/extra/tools/interpreter/summary.txt b/extra/tools/interpreter/summary.txt deleted file mode 100644 index 242b9cbbd1..0000000000 --- a/extra/tools/interpreter/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Meta-circular interpreter and single-stepper support diff --git a/extra/tools/memory/memory-tests.factor b/extra/tools/memory/memory-tests.factor index 36bcc73b74..9efbf63f7f 100644 --- a/extra/tools/memory/memory-tests.factor +++ b/extra/tools/memory/memory-tests.factor @@ -1,4 +1,4 @@ USING: tools.test tools.memory ; -IN: temporary +IN: tools.memory.tests [ ] [ heap-stats. ] unit-test diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor index c346d9763c..e33201e22c 100755 --- a/extra/tools/profiler/profiler-tests.factor +++ b/extra/tools/profiler/profiler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.profiler.tests USING: tools.profiler tools.test kernel memory math threads alien tools.profiler.private sequences ; diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index a8c7239922..743822e7f9 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -43,7 +43,7 @@ $nl } "The latter is used for vocabularies with more extensive test suites." $nl -"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run." +"If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested." { $subsection "tools.test.write" } { $subsection "tools.test.run" } { $subsection "tools.test.failure" } ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 69093f18a6..259b91c3af 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -48,18 +48,10 @@ SYMBOL: this-test : must-fail ( quot -- ) [ drop t ] must-fail-with ; -: ignore-errors ( quot -- ) - [ drop ] recover ; inline - : (run-test) ( vocab -- ) dup vocab-source-loaded? [ - vocab-tests - [ - "temporary" forget-vocab - dup [ forget-source ] each - ] with-compilation-unit - dup [ run-file ] each - ] when drop ; + vocab-tests [ run-file ] each + ] [ drop ] if ; : run-test ( vocab -- failures ) V{ } clone [ diff --git a/extra/tools/test/tools.factor b/extra/tools/test/tools.factor index 7699d61062..bf74c1ae98 100644 --- a/extra/tools/test/tools.factor +++ b/extra/tools/test/tools.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.test.tests USING: completion words sequences test ; [ ] [ "swp" apropos ] unit-test diff --git a/extra/tools/threads/threads-docs.factor b/extra/tools/threads/threads-docs.factor new file mode 100644 index 0000000000..d4c5be9c17 --- /dev/null +++ b/extra/tools/threads/threads-docs.factor @@ -0,0 +1,17 @@ +IN: tools.threads +USING: help.markup help.syntax threads ; + +HELP: threads. +{ $description "Prints a list of running threads and their state. The ``Waiting on'' column displays one of the following:" + { $list + "``running'' if the thread is the current thread" + "``yield'' if the thread is waiting to run" + { "the string given to " { $link suspend } " if the thread is suspended" } + } +} ; + +ARTICLE: "tools.threads" "Listing threads" +"Printing a list of running threads:" +{ $subsection threads. } ; + +ABOUT: "tools.threads" diff --git a/extra/tools/threads/threads.factor b/extra/tools/threads/threads.factor new file mode 100755 index 0000000000..552247e2c4 --- /dev/null +++ b/extra/tools/threads/threads.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: tools.threads +USING: threads kernel prettyprint prettyprint.config +io io.styles sequences assocs namespaces sorting boxes +heaps.private system math math.parser ; + +: thread. ( thread -- ) + dup thread-id pprint-cell + dup thread-name over [ write-object ] with-cell + dup thread-state [ + [ dup self eq? "running" "yield" ? ] unless* + write + ] with-cell + [ + thread-sleep-entry [ + entry-key millis [-] number>string write + " ms" write + ] when* + ] with-cell ; + +: threads. ( -- ) + standard-table-style [ + [ + { "ID" "Name" "Waiting on" "Remaining sleep" } + [ [ write ] with-cell ] each + ] with-row + + threads >alist sort-keys values [ + [ thread. ] with-row + ] each + ] tabular-output ; diff --git a/extra/tools/interpreter/debug/authors.txt b/extra/tools/walker/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/tools/interpreter/debug/authors.txt rename to extra/tools/walker/authors.txt diff --git a/extra/tools/walker/debug/authors.txt b/extra/tools/walker/debug/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/walker/debug/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tools/walker/debug/debug.factor b/extra/tools/walker/debug/debug.factor new file mode 100755 index 0000000000..c8c0ff28a6 --- /dev/null +++ b/extra/tools/walker/debug/debug.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.promises models tools.walker kernel +sequences concurrency.messaging locals continuations +threads namespaces namespaces.private ; +IN: tools.walker.debug + +:: test-walker ( quot -- data ) + [let | p [ ] + s [ f ] + c [ f ] | + [ + H{ } clone >n + [ s c start-walker-thread p fulfill ] new-walker-hook set + [ drop ] show-walker-hook set + + break + + quot call + ] "Walker test" spawn drop + + step-into-all + p ?promise + send-synchronous drop + + detach + p ?promise + send-synchronous drop + + c model-value continuation-data + ] ; diff --git a/extra/tools/walker/summary.txt b/extra/tools/walker/summary.txt new file mode 100644 index 0000000000..d595bf34cf --- /dev/null +++ b/extra/tools/walker/summary.txt @@ -0,0 +1 @@ +Single-stepper for walking through code diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor new file mode 100755 index 0000000000..2d4a6c3396 --- /dev/null +++ b/extra/tools/walker/walker-tests.factor @@ -0,0 +1,102 @@ +USING: tools.walker io io.streams.string kernel math +math.private namespaces prettyprint sequences tools.test +continuations math.parser threads arrays tools.walker.debug ; +IN: tools.walker.tests + +[ { } ] [ + [ ] test-walker +] unit-test + +[ { 1 } ] [ + [ 1 ] test-walker +] unit-test + +[ { 1 2 3 } ] [ + [ 1 2 3 ] test-walker +] unit-test + +[ { "Yo" 2 } ] [ + [ 2 >r "Yo" r> ] test-walker +] unit-test + +[ { 2 } ] [ + [ t [ 2 ] [ "hi" ] if ] test-walker +] unit-test + +[ { "hi" } ] [ + [ f [ 2 ] [ "hi" ] if ] test-walker +] unit-test + +[ { 4 } ] [ + [ 2 2 fixnum+ ] test-walker +] unit-test + +: foo 2 2 fixnum+ ; + +[ { 8 } ] [ + [ foo 4 fixnum+ ] test-walker +] unit-test + +[ { C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [ + [ C{ 1 1.5 } { } 2dup ] test-walker +] unit-test + +[ { t } ] [ + [ 5 5 number= ] test-walker +] unit-test + +[ { f } ] [ + [ 5 6 number= ] test-walker +] unit-test + +[ { f } ] [ + [ "XYZ" "XYZ" mismatch ] test-walker +] unit-test + +[ { t } ] [ + [ "XYZ" "XYZ" sequence= ] test-walker +] unit-test + +[ { t } ] [ + [ "XYZ" "XYZ" = ] test-walker +] unit-test + +[ { f } ] [ + [ "XYZ" "XuZ" = ] test-walker +] unit-test + +[ { 4 } ] [ + [ 2 2 + ] test-walker +] unit-test + +[ { 3 } ] [ + [ [ 3 "x" set "x" get ] with-scope ] test-walker +] unit-test + +[ { "hi\n" } ] [ + [ [ "hi" print ] with-string-writer ] test-walker +] unit-test + +[ { "4\n" } ] [ + [ [ 2 2 + number>string print ] with-string-writer ] test-walker +] unit-test + +[ { 1 2 3 } ] [ + [ { 1 2 3 } set-datastack ] test-walker +] unit-test + +[ { 6 } ] +[ [ 3 [ nip continue ] callcc0 2 * ] test-walker ] unit-test + +[ { 6 } ] +[ [ [ 3 swap continue-with ] callcc1 2 * ] test-walker ] unit-test + +[ { } ] +[ [ [ ] [ ] recover ] test-walker ] unit-test + +[ { 6 } ] +[ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test + +[ { } ] [ + [ "a" "b" set "c" "d" set [ ] test-walker ] with-scope +] unit-test diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor new file mode 100755 index 0000000000..1b37673c38 --- /dev/null +++ b/extra/tools/walker/walker.factor @@ -0,0 +1,257 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: threads kernel namespaces continuations combinators +sequences math namespaces.private continuations.private +concurrency.messaging quotations kernel.private words +sequences.private assocs models ; +IN: tools.walker + +SYMBOL: new-walker-hook ! ( -- ) +SYMBOL: show-walker-hook ! ( thread -- ) + +! Thread local +SYMBOL: walker-thread +SYMBOL: walking-thread + +: get-walker-thread ( -- thread ) + walker-thread tget [ + dup show-walker-hook get call + ] [ + new-walker-hook get call + walker-thread tget + ] if* ; + +: break ( -- ) + continuation callstack over set-continuation-call + + get-walker-thread send-synchronous { + { [ dup continuation? ] [ (continue) ] } + { [ dup quotation? ] [ call ] } + { [ dup not ] [ "Single stepping abandoned" throw ] } + } cond ; + +\ break t "break?" set-word-prop + +: add-breakpoint ( quot -- quot' ) + dup [ break ] head? [ \ break add* ] unless ; + +: walk ( quot -- ) add-breakpoint call ; + +: (step-into-if) ? walk ; + +: (step-into-dispatch) nth walk ; + +: (step-into-execute) ( word -- ) + dup "step-into" word-prop [ + call + ] [ + dup primitive? [ + execute break + ] [ + word-def walk + ] if + ] ?if ; + +\ (step-into-execute) t "step-into?" set-word-prop + +: (step-into-continuation) + continuation callstack over set-continuation-call break ; + +! Messages sent to walker thread +SYMBOL: step +SYMBOL: step-out +SYMBOL: step-into +SYMBOL: step-all +SYMBOL: step-into-all +SYMBOL: step-back +SYMBOL: detach +SYMBOL: abandon +SYMBOL: call-in + +! Thread locals +SYMBOL: walker-status +SYMBOL: walker-continuation +SYMBOL: walker-history + +SYMBOL: +running+ +SYMBOL: +suspended+ +SYMBOL: +stopped+ +SYMBOL: +detached+ + +: change-frame ( continuation quot -- continuation' ) + #! Applies quot to innermost call frame of the + #! continuation. + >r clone r> + over continuation-call clone + [ + dup innermost-frame-scan 1+ + swap innermost-frame-quot + rot call + ] keep + [ set-innermost-frame-quot ] keep + over set-continuation-call ; inline + +: step-msg ( continuation -- continuation' ) + [ + 2dup nth \ break = [ + nip + ] [ + swap 1+ cut [ break ] swap 3append + ] if + ] change-frame ; + +: step-out-msg ( continuation -- continuation' ) + [ nip \ break add ] change-frame ; + +{ + { call [ walk ] } + { (throw) [ drop walk ] } + { execute [ (step-into-execute) ] } + { if [ (step-into-if) ] } + { dispatch [ (step-into-dispatch) ] } + { continuation [ (step-into-continuation) ] } +} [ "step-into" set-word-prop ] assoc-each + +{ + >n ndrop >c c> + continue continue-with + stop yield suspend sleep (spawn) + suspend +} [ + dup [ execute break ] curry + "step-into" set-word-prop +] each + +\ break [ break ] "step-into" set-word-prop + +: step-into-msg ( continuation -- continuation' ) + [ + swap cut [ + swap % unclip { + { [ dup \ break eq? ] [ , ] } + { [ dup quotation? ] [ add-breakpoint , \ break , ] } + { [ dup word? ] [ literalize , \ (step-into-execute) , ] } + { [ t ] [ , \ break , ] } + } cond % + ] [ ] make + ] change-frame ; + +: status ( -- symbol ) + walker-status tget model-value ; + +: set-status ( symbol -- ) + walker-status tget set-model ; + +: unassociate-thread ( -- ) + walker-thread walking-thread tget thread-variables delete-at + [ ] walking-thread tget set-thread-exit-handler ; + +: detach-msg ( -- ) + +detached+ set-status + unassociate-thread ; + +: keep-running ( -- ) + +running+ set-status ; + +: walker-stopped ( -- ) + +stopped+ set-status + [ status +stopped+ eq? ] [ + [ + { + { detach [ detach-msg ] } + [ drop ] + } case f + ] handle-synchronous + ] [ ] while ; + +: step-into-all-loop ( -- ) + +running+ set-status + [ status +running+ eq? ] [ + [ + { + { detach [ detach-msg f ] } + { step [ f ] } + { step-out [ f ] } + { step-into [ f ] } + { step-all [ f ] } + { step-into-all [ f ] } + { step-back [ f ] } + { f [ +stopped+ set-status f ] } + [ + dup walker-continuation tget set-model + step-into-msg + ] + } case + ] handle-synchronous + ] [ ] while ; + +: step-back-msg ( continuation -- continuation' ) + walker-history tget dup pop* + empty? [ drop walker-history tget pop ] unless ; + +: walker-suspended ( continuation -- continuation' ) + +suspended+ set-status + [ status +suspended+ eq? ] [ + dup walker-history tget push + dup walker-continuation tget set-model + [ + { + ! These are sent by the walker tool. We reply + ! and keep cycling. + { detach [ detach-msg ] } + ! These change the state of the thread being + ! interpreted, so we modify the continuation and + ! output f. + { step [ step-msg keep-running ] } + { step-out [ step-out-msg keep-running ] } + { step-into [ step-into-msg keep-running ] } + { step-all [ keep-running ] } + { step-into-all [ step-into-all-loop ] } + { abandon [ drop f keep-running ] } + ! Pass quotation to debugged thread + { call-in [ nip keep-running ] } + ! Pass previous continuation to debugged thread + { step-back [ step-back-msg ] } + } case f + ] handle-synchronous + ] [ ] while ; + +: walker-loop ( -- ) + +running+ set-status + [ status +detached+ eq? not ] [ + [ + { + { detach [ detach-msg f ] } + ! ignore these commands while the thread is + ! running + { step [ f ] } + { step-out [ f ] } + { step-into [ f ] } + { step-all [ f ] } + { step-into-all [ step-into-all-loop f ] } + { step-back [ f ] } + { abandon [ f ] } + { f [ walker-stopped f ] } + ! thread hit a breakpoint and sent us the + ! continuation, so we modify it and send it + ! back. + [ walker-suspended ] + } case + ] handle-synchronous + ] [ ] while ; + +: associate-thread ( walker -- ) + walker-thread tset + [ f walker-thread tget send-synchronous drop ] + self set-thread-exit-handler ; + +: start-walker-thread ( status continuation -- thread' ) + self [ + walking-thread tset + walker-continuation tset + walker-status tset + V{ } clone walker-history tset + walker-loop + ] 3curry + "Walker on " self thread-name append spawn + [ associate-thread ] keep ; diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index 0964ea7e56..570125cb45 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test trees trees.avl math random sequences assocs ; -IN: temporary +IN: trees.avl.tests [ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor old mode 100644 new mode 100755 index a806dafdec..81628684bc --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -53,14 +53,14 @@ TUPLE: avl-node balance ; DEFER: avl-set : avl-insert ( value key node -- node taller? ) - 2dup node-key key< left right ? [ + 2dup node-key before? left right ? [ [ node-link avl-set ] keep swap >r tuck set-node-link r> [ dup current-side get change-balance balance-insert ] [ f ] if ] with-side ; : (avl-set) ( value key node -- node taller? ) - 2dup node-key key= [ + 2dup node-key = [ -rot pick set-node-key over set-node-value f ] [ avl-insert ] if ; diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor index 5075163802..29ea2eee2d 100644 --- a/extra/trees/splay/splay-tests.factor +++ b/extra/trees/splay/splay-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test trees.splay math namespaces assocs sequences random ; -IN: temporary +IN: trees.splay.tests : randomize-numeric-splay-tree ( splay-tree -- ) 100 [ drop 100 random swap at drop ] with each ; diff --git a/extra/trees/trees-tests.factor b/extra/trees/trees-tests.factor index 2795b0d5da..fd26b37c70 100644 --- a/extra/trees/trees-tests.factor +++ b/extra/trees/trees-tests.factor @@ -1,5 +1,5 @@ USING: trees assocs tools.test kernel sequences ; -IN: temporary +IN: trees.tests : test-tree ( -- tree ) TREE{ diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor old mode 100644 new mode 100755 index 6d53d9e541..e59bbab1ed --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -61,10 +61,6 @@ SYMBOL: current-side #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2 <=> sgn ; -: key< ( k1 k2 -- ? ) <=> 0 < ; -: key> ( k1 k2 -- ? ) <=> 0 > ; -: key= ( k1 k2 -- ? ) <=> zero? ; - : random-side ( -- side ) left right 2array random ; : choose-branch ( key node -- key node-left/right ) @@ -72,7 +68,7 @@ SYMBOL: current-side : node-at* ( key node -- value ? ) [ - 2dup node-key key= [ + 2dup node-key = [ nip node-value t ] [ choose-branch node-at* @@ -97,8 +93,8 @@ M: tree set-at ( value key tree -- ) : valid-node? ( node -- ? ) [ - dup dup node-left [ node-key swap node-key key< ] when* >r - dup dup node-right [ node-key swap node-key key> ] when* r> and swap + dup dup node-left [ node-key swap node-key before? ] when* >r + dup dup node-right [ node-key swap node-key after? ] when* r> and swap dup node-left valid-node? swap node-right valid-node? and and ] [ t ] if* ; diff --git a/extra/tuple-syntax/tuple-syntax-tests.factor b/extra/tuple-syntax/tuple-syntax-tests.factor index 0a9711c446..2eb9d8bb12 100755 --- a/extra/tuple-syntax/tuple-syntax-tests.factor +++ b/extra/tuple-syntax/tuple-syntax-tests.factor @@ -1,5 +1,5 @@ USING: tools.test tuple-syntax ; -IN: temporary +IN: tuple-syntax.tests TUPLE: foo bar baz ; diff --git a/extra/tuples/lib/lib-tests.factor b/extra/tuples/lib/lib-tests.factor index 88c09d81c4..5d90f25bd7 100644 --- a/extra/tuples/lib/lib-tests.factor +++ b/extra/tuples/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test tuples.lib ; -IN: temporary +IN: tuples.lib.tests TUPLE: foo a b* c d* e f* ; diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index 2334c7602b..d95cbd69ed 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -15,7 +15,7 @@ HOOK: (open-window) ui-backend ( world -- ) HOOK: (close-window) ui-backend ( handle -- ) -HOOK: raise-window ui-backend ( world -- ) +HOOK: raise-window* ui-backend ( world -- ) HOOK: select-gl-context ui-backend ( handle -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 06de1d81fb..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 ; @@ -85,7 +85,7 @@ M: cocoa-ui-backend close-window ( gadget -- ) world-handle second f -> performClose: ] when* ; -M: cocoa-ui-backend raise-window ( world -- ) +M: cocoa-ui-backend raise-window* ( world -- ) world-handle [ second dup f -> orderFront: -> makeKeyWindow NSApp 1 -> activateIgnoringOtherApps: diff --git a/extra/ui/cocoa/tools/tools.factor b/extra/ui/cocoa/tools/tools.factor old mode 100644 new mode 100755 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/commands/commands-tests.factor b/extra/ui/commands/commands-tests.factor index de9534ab74..8001ff9761 100644 --- a/extra/ui/commands/commands-tests.factor +++ b/extra/ui/commands/commands-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.commands.tests USING: ui.commands ui.gestures tools.test help.markup io io.streams.string ; diff --git a/extra/ui/gadgets/books/books-tests.factor b/extra/ui/gadgets/books/books-tests.factor index 9e1b0aa985..dab9ef5acf 100755 --- a/extra/ui/gadgets/books/books-tests.factor +++ b/extra/ui/gadgets/books/books-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.books.tests USING: tools.test ui.gadgets.books ; \ must-infer diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index 224ef9e1ce..6c5d757dd4 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.buttons.tests USING: ui.commands ui.gadgets.buttons ui.gadgets.labels ui.gadgets tools.test namespaces sequences kernel models ; diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index a196173852..defd5aa38a 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 507dc932a4..def6b99b05 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -256,7 +256,7 @@ M: editor gadget-text* editor-string % ; } at T{ one-line-elt } or ; : drag-direction? ( loc editor -- ? ) - editor-mark* <=> 0 < ; + editor-mark* before? ; : drag-selection-caret ( loc editor element -- loc ) >r [ drag-direction? ] 2keep diff --git a/extra/ui/gadgets/frames/frames-tests.factor b/extra/ui/gadgets/frames/frames-tests.factor index 80cf70b960..e38e97c76c 100644 --- a/extra/ui/gadgets/frames/frames-tests.factor +++ b/extra/ui/gadgets/frames/frames-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.frames.tests USING: ui.gadgets.frames ui.gadgets tools.test ; [ ] [ layout ] unit-test diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index 54bae31f79..0a44e5e267 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.tests USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel dlists math math.parser ui sequences hashtables assocs io arrays diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 0ac43af756..ed3631bca5 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -1,10 +1,14 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables kernel models math namespaces sequences -timers quotations math.vectors combinators sorting vectors -dlists models ; +quotations math.vectors combinators sorting vectors dlists +models 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/gadgets/grids/grids-tests.factor b/extra/ui/gadgets/grids/grids-tests.factor index 6f08009da3..0792d55135 100644 --- a/extra/ui/gadgets/grids/grids-tests.factor +++ b/extra/ui/gadgets/grids/grids-tests.factor @@ -1,6 +1,6 @@ USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays namespaces ; -IN: temporary +IN: ui.gadgets.grids.tests [ { 0 0 } ] [ { } pref-dim ] unit-test diff --git a/extra/ui/gadgets/labelled/labelled-docs.factor b/extra/ui/gadgets/labelled/labelled-docs.factor index 285e470564..f09bcaa825 100755 --- a/extra/ui/gadgets/labelled/labelled-docs.factor +++ b/extra/ui/gadgets/labelled/labelled-docs.factor @@ -18,7 +18,7 @@ HELP: { $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ; HELP: -{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "title" string } { "gadget" "a new " { $link gadget } } } +{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } } { $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ; { } related-words diff --git a/extra/ui/gadgets/labelled/labelled-tests.factor b/extra/ui/gadgets/labelled/labelled-tests.factor index 87b2a45678..377f3ab787 100644 --- a/extra/ui/gadgets/labelled/labelled-tests.factor +++ b/extra/ui/gadgets/labelled/labelled-tests.factor @@ -1,7 +1,7 @@ USING: ui.gadgets ui.gadgets.labels ui.gadgets.labelled ui.gadgets.packs ui.gadgets.frames ui.gadgets.grids namespaces kernel tools.test ui.gadgets.buttons sequences ; -IN: temporary +IN: ui.gadgets.labelled.tests TUPLE: testing ; diff --git a/extra/ui/gadgets/labelled/labelled.factor b/extra/ui/gadgets/labelled/labelled.factor old mode 100644 new mode 100755 index 672d3d96d8..0231aef4d0 --- a/extra/ui/gadgets/labelled/labelled.factor +++ b/extra/ui/gadgets/labelled/labelled.factor @@ -21,8 +21,8 @@ M: labelled-gadget focusable-child* labelled-gadget-content ; : ( gadget title -- gadget ) >r r> ; -: ( model quot title -- gadget ) - >r t over set-pane-scrolls? r> +: ( model quot scrolls? title -- gadget ) + >r >r r> over set-pane-scrolls? r> ; : ( quot -- button/f ) diff --git a/extra/ui/gadgets/lists/lists-tests.factor b/extra/ui/gadgets/lists/lists-tests.factor index 44a89a7e60..bf2ad72d0e 100644 --- a/extra/ui/gadgets/lists/lists-tests.factor +++ b/extra/ui/gadgets/lists/lists-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.lists.tests USING: ui.gadgets.lists models prettyprint math tools.test kernel ; diff --git a/extra/ui/gadgets/packs/packs-tests.factor b/extra/ui/gadgets/packs/packs-tests.factor index ce6df74769..28a656e2ad 100644 --- a/extra/ui/gadgets/packs/packs-tests.factor +++ b/extra/ui/gadgets/packs/packs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.packs.tests USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render kernel namespaces tools.test math.parser sequences ; diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/extra/ui/gadgets/panes/panes-tests.factor index 848f7919d3..e3f6e36050 100755 --- a/extra/ui/gadgets/panes/panes-tests.factor +++ b/extra/ui/gadgets/panes/panes-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.panes.tests USING: alien ui.gadgets.panes ui.gadgets namespaces kernel sequences io io.streams.string tools.test prettyprint definitions help help.syntax help.markup splitting diff --git a/extra/ui/gadgets/presentations/presentations-tests.factor b/extra/ui/gadgets/presentations/presentations-tests.factor index c4f693c939..46f274d53a 100644 --- a/extra/ui/gadgets/presentations/presentations-tests.factor +++ b/extra/ui/gadgets/presentations/presentations-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.presentations.tests USING: math ui.gadgets.presentations ui.gadgets tools.test prettyprint ui.gadgets.buttons io io.streams.string kernel tuples ; diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index dd667fdfec..5ccd6c7cd8 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.scrollers.tests USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test kernel models ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames diff --git a/extra/ui/gadgets/slots/slots-tests.factor b/extra/ui/gadgets/slots/slots-tests.factor index 5388794624..b955a2604d 100644 --- a/extra/ui/gadgets/slots/slots-tests.factor +++ b/extra/ui/gadgets/slots/slots-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.slots.tests USING: assocs ui.gadgets.slots tools.test refs ; [ t ] [ { 1 2 3 } 2 slot-editor? ] unit-test diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/extra/ui/gadgets/status-bar/status-bar.factor old mode 100644 new mode 100755 index c5508e1891..b528d6739c --- a/extra/ui/gadgets/status-bar/status-bar.factor +++ b/extra/ui/gadgets/status-bar/status-bar.factor @@ -1,11 +1,12 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: models sequences ui.gadgets.labels ui.gadgets.theme -ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel ; +ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel +calendar ; IN: ui.gadgets.status-bar : ( model -- gadget ) - 100 [ "" like ] + 1/10 seconds [ "" like ] dup reverse-video-theme t over set-gadget-root? ; diff --git a/extra/ui/gadgets/tracks/tracks-tests.factor b/extra/ui/gadgets/tracks/tracks-tests.factor index 77c69bc8a8..e2db914089 100644 --- a/extra/ui/gadgets/tracks/tracks-tests.factor +++ b/extra/ui/gadgets/tracks/tracks-tests.factor @@ -1,5 +1,5 @@ USING: kernel ui.gadgets ui.gadgets.tracks tools.test ; -IN: temporary +IN: ui.gadgets.tracks.tests [ { 100 100 } ] [ [ diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/extra/ui/gadgets/worlds/worlds-docs.factor index a47717329d..c5c5c642f7 100755 --- a/extra/ui/gadgets/worlds/worlds-docs.factor +++ b/extra/ui/gadgets/worlds/worlds-docs.factor @@ -13,11 +13,6 @@ HELP: set-title { $description "Sets the title bar of the native window containing the world." } { $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ; -HELP: raise-window -{ $values { "world" world } } -{ $description "Makes the native window containing the given world the front-most window." } -{ $notes "To raise the window containing a specific gadget, use " { $link find-world } " to find the world containing the gadget first." } ; - HELP: select-gl-context { $values { "handle" "a backend-specific handle" } } { $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ; diff --git a/extra/ui/gadgets/worlds/worlds-tests.factor b/extra/ui/gadgets/worlds/worlds-tests.factor index 949ad49460..2e186d875d 100644 --- a/extra/ui/gadgets/worlds/worlds-tests.factor +++ b/extra/ui/gadgets/worlds/worlds-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.worlds.tests USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel ; diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 2a3e344a9e..0edf82dbd1 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser -math.vectors tuples classes ui.gadgets timers combinators.lib ; +math.vectors tuples classes ui.gadgets combinators.lib boxes +calendar alarms ; IN: ui.gestures : set-gestures ( class hash -- ) "gestures" set-word-prop ; @@ -107,20 +108,21 @@ SYMBOL: double-click-timeout : drag-gesture ( -- ) hand-buttons get-global first button-gesture ; -TUPLE: drag-timer ; +SYMBOL: drag-timer -M: drag-timer tick drop drag-gesture ; - -drag-timer construct-empty drag-timer set-global + drag-timer set-global : start-drag-timer ( -- ) hand-buttons get-global empty? [ - drag-timer get-global 100 300 add-timer + [ drag-gesture ] + 300 milliseconds from-now + 100 milliseconds + add-alarm drag-timer get-global >box ] when ; : stop-drag-timer ( -- ) hand-buttons get-global empty? [ - drag-timer get-global remove-timer + drag-timer get-global box> cancel-alarm ] when ; : fire-motion ( -- ) diff --git a/extra/ui/operations/operations-tests.factor b/extra/ui/operations/operations-tests.factor index b7b2224cfa..1e3d08f164 100755 --- a/extra/ui/operations/operations-tests.factor +++ b/extra/ui/operations/operations-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.operations.tests USING: ui.operations ui.commands prettyprint kernel namespaces tools.test ui.gadgets ui.gadgets.editors parser io io.streams.string math help help.markup ; diff --git a/extra/ui/tools/browser/browser-tests.factor b/extra/ui/tools/browser/browser-tests.factor index 7262c72756..f56f5bcc4e 100755 --- a/extra/ui/tools/browser/browser-tests.factor +++ b/extra/ui/tools/browser/browser-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.tools.browser.tests USING: tools.test tools.test.ui ui.tools.browser ; \ must-infer diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index df87d57873..9aa763d7ec 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -34,9 +34,10 @@ TUPLE: deploy-gadget vocab settings ; "Advanced:"