diff --git a/Makefile b/Makefile index 60091d44ea..6f12633871 100755 --- a/Makefile +++ b/Makefile @@ -145,7 +145,8 @@ wince-arm: macosx.app: factor mkdir -p $(BUNDLE)/Contents/MacOS - cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor + mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor + ln -s Factor.app/Contents/MacOS/factor ./factor cp $(ENGINE) $(BUNDLE)/Contents/Frameworks install_name_tool \ diff --git a/core/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 48e8d7e307..baab72036d 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -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/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/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 7c7a03f575..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 @@ -40,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-tests.factor b/core/boxes/boxes-tests.factor index 66ee5247ec..76a6cfd8b1 100755 --- a/core/boxes/boxes-tests.factor +++ b/core/boxes/boxes-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: boxes.tests USING: boxes namespaces tools.test ; [ ] [ "b" set ] unit-test diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index 8197e57969..a989e091bb 100755 --- a/core/boxes/boxes.factor +++ b/core/boxes/boxes.factor @@ -19,3 +19,6 @@ TUPLE: box value 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..640439312d 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 @@ -56,13 +56,13 @@ UNION: c a b ; [ t ] [ \ c \ tuple class< ] unit-test [ f ] [ \ tuple \ c class< ] unit-test -DEFER: bah -FORGET: bah +! DEFER: bah +! FORGET: bah 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 a1e2525c14..9a26dbc67e 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -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" } ; @@ -148,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." } @@ -188,6 +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." } ; 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 a0aa59332e..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 @@ -120,6 +123,9 @@ SYMBOL: thread-error-hook : 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,17 +172,3 @@ M: condition compute-restarts condition-continuation [ ] curry { } assoc>map append ; - - 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 95470dcbcd..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 -- ) @@ -57,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 ] @@ -77,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 ; @@ -260,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/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-docs.factor b/core/generic/generic-docs.factor index 631aa7e62d..b2fba47d3a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -116,16 +116,18 @@ HELP: method-spec { $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." } { $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ; +HELP: method-body +{ $class-description "The class of method bodies, which are words with special word properties set." } ; + HELP: method -{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } } -{ $description "Looks up a method definition." } -{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ; +{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } } +{ $description "Looks up a method definition." } ; { method define-method POSTPONE: M: } related-words HELP: { $values { "def" "a quotation" } { "method" "a new method definition" } } -{ $description "Creates a new "{ $link method } " instance." } ; +{ $description "Creates a new method." } ; HELP: methods { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } 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 35cc471033..f73579661d 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -25,16 +25,12 @@ GENERIC: make-default-method ( generic combination -- method ) PREDICATE: word generic "combination" word-prop >boolean ; -M: generic definer drop f f ; - M: generic definition drop f ; : make-generic ( word -- ) dup { "unannotated-def" } reset-props dup dup "combination" word-prop perform-combination define ; -TUPLE: method word def specializer generic loc ; - : method ( class generic -- method/f ) "methods" word-prop at ; @@ -47,7 +43,7 @@ PREDICATE: pair method-spec : methods ( word -- assoc ) "methods" word-prop [ keys sort-classes ] keep - [ dupd at method-word ] curry { } map>assoc ; + [ dupd at ] curry { } map>assoc ; TUPLE: check-method class generic ; @@ -63,29 +59,33 @@ TUPLE: check-method class generic ; : method-word-name ( class word -- string ) word-name "/" rot word-name 3append ; -: make-method-def ( quot word combination -- quot ) +: make-method-def ( quot class generic -- quot ) "combination" word-prop method-prologue swap append ; -PREDICATE: word method-body "method" word-prop >boolean ; +PREDICATE: word method-body "method-def" word-prop >boolean ; M: method-body stack-effect - "method" word-prop method-generic stack-effect ; + "method-generic" word-prop stack-effect ; -: ( quot class generic -- word ) - [ make-method-def ] 2keep - method-word-name f - dup rot define - dup xref ; +: method-word-props ( quot class generic -- assoc ) + [ + "method-generic" set + "method-class" set + "method-def" set + ] H{ } make-assoc ; -: ( quot class generic -- method ) +: ( quot class generic -- word ) check-method - [ ] 3keep f \ method construct-boa - dup method-word over "method" set-word-prop ; + [ make-method-def ] 3keep + [ method-word-props ] 2keep + method-word-name f + tuck set-word-props + dup rot define ; : redefine-method ( quot class generic -- ) - [ method set-method-def ] 3keep + [ method swap "method-def" set-word-prop ] 3keep [ make-method-def ] 2keep - method method-word swap define ; + method swap define ; : define-method ( quot class generic -- ) >r bootstrap-word r> @@ -102,21 +102,22 @@ M: method-body stack-effect ! Definition protocol M: method-spec where - dup first2 method [ method-word ] [ second ] ?if where ; + dup first2 method [ ] [ second ] ?if where ; M: method-spec set-where - first2 method method-word set-where ; + first2 method set-where ; M: method-spec definer drop \ M: \ ; ; M: method-spec definition - first2 method dup [ method-def ] when ; + first2 method dup + [ "method-def" word-prop ] when ; : forget-method ( class generic -- ) check-method [ delete-at* ] with-methods - [ method-word forget-word ] [ drop ] if ; + [ forget-word ] [ drop ] if ; M: method-spec forget* first2 forget-method ; @@ -125,11 +126,11 @@ M: method-body definer drop \ M: \ ; ; M: method-body definition - "method" word-prop method-def ; + "method-def" word-prop ; M: method-body forget* - "method" word-prop - { method-specializer method-generic } get-slots + dup "method-class" word-prop + swap "method-generic" word-prop forget-method ; : implementors* ( classes -- words ) @@ -168,8 +169,7 @@ M: word subwords drop f ; M: generic subwords dup "methods" word-prop values - swap "default-method" word-prop add - [ method-word ] map ; + swap "default-method" word-prop add ; M: generic forget-word dup subwords [ forget-word ] each (forget-word) ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 0b2b9fcca3..27b0ddb7a2 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ; : applicable-method ( generic class -- quot ) over method - [ method-word word-def ] + [ word-def ] [ default-math-method ] ?if ; : object-method ( generic -- quot ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 230ec446c7..313f487c99 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -69,7 +69,7 @@ TUPLE: no-method object generic ; ] if ; : default-method ( word -- pair ) - "default-method" word-prop method-word + "default-method" word-prop object bootstrap-word swap 2array ; : method-alist>quot ( alist base-class -- quot ) 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/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index f199ba8837..61e09d894e 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -3,7 +3,7 @@ USING: arrays kernel math namespaces tools.test heaps heaps.private math.parser random assocs sequences sorting ; -IN: temporary +IN: heaps.tests [ heap-pop ] must-fail [ heap-pop ] must-fail diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index cadf326692..2a2e6995eb 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -10,8 +10,7 @@ IN: inference.backend recursive-state get at ; : inline? ( word -- ? ) - dup "method" word-prop - [ method-generic inline? ] [ "inline" word-prop ] ?if ; + dup "method-generic" word-prop swap or "inline" word-prop ; : local-recursive-state ( -- assoc ) recursive-state get dup keys diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 10eae1eb99..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 diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 1fe4b7ae1e..3c12e388c4 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -6,7 +6,7 @@ continuations generic.standard sorting assocs definitions prettyprint io inspector tuples classes.union classes.predicate debugger threads.private io.streams.string io.timeouts io.thread sequences.private ; -IN: temporary +IN: inference.tests { 0 2 } [ 2 "Hello" ] must-infer-as { 1 2 } [ dup ] must-infer-as 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 index 770655d990..6ee11c76fc 100755 --- 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/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/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 a111070151..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 ] "Test" spawn drop ] 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 ] "Test" spawn drop ] 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 7dbe8c229e..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 ) @@ -155,10 +217,10 @@ M: pathname <=> [ pathname-string ] compare ; : with-file-appender ( path quot -- ) >r r> with-stream ; inline -: temp-directory ( -- path ) - "temp" resource-path - dup exists? not - [ dup make-directory ] - when ; - -: temp-file ( name -- path ) temp-directory swap path+ ; \ No newline at end of file +! 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 16b78c2192..3da9f27646 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,5 +1,5 @@ USING: tools.test io.files io io.streams.c ; -IN: temporary +IN: io.streams.c.tests [ "hello world" ] [ "test.txt" temp-file [ 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/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 456c3cc4ca..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." } ; 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/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 288cb53322..fe1471716d 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -1,7 +1,7 @@ ! 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-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/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 1d034aad49..cd908ea10f 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -17,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/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/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index f3709780f9..04d7ab4ee5 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -1,208 +1,208 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic assocs inference inference.class -inference.dataflow inference.backend inference.state io kernel -math namespaces sequences vectors words quotations hashtables -combinators classes generic.math continuations optimizer.def-use -optimizer.backend generic.standard optimizer.specializers -optimizer.def-use optimizer.pattern-match generic.standard -optimizer.control kernel.private ; -IN: optimizer.inlining - -: remember-inlining ( node history -- ) - [ swap set-node-history ] curry each-node ; - -: inlining-quot ( node quot -- node ) - over node-in-d dataflow-with - dup rot infer-classes/node ; - -: splice-quot ( #call quot history -- node ) - #! Must add history *before* splicing in, otherwise - #! the rest of the IR will also remember the history - pick node-history append - >r dupd inlining-quot dup r> remember-inlining - tuck splice-node ; - -! A heuristic to avoid excessive inlining -DEFER: (flat-length) - -: word-flat-length ( word -- n ) - { - ! heuristic: { ... } declare comes up in method bodies - ! and we don't care about it - { [ dup \ declare eq? ] [ drop -2 ] } - ! recursive - { [ dup get ] [ drop 1 ] } - ! not inline - { [ dup inline? not ] [ drop 1 ] } - ! inline - { [ t ] [ dup dup set word-def (flat-length) ] } - } cond ; - -: (flat-length) ( seq -- n ) - [ - { - { [ dup quotation? ] [ (flat-length) 1+ ] } - { [ dup array? ] [ (flat-length) ] } - { [ dup word? ] [ word-flat-length ] } - { [ t ] [ drop 1 ] } - } cond - ] map sum ; - -: flat-length ( seq -- n ) - [ word-def (flat-length) ] with-scope ; - -! Single dispatch method inlining optimization -: specific-method ( class word -- class ) order min-class ; - -: node-class# ( node n -- class ) - over node-in-d ?nth node-class ; - -: dispatching-class ( node word -- class ) - [ dispatch# node-class# ] keep specific-method ; - -: inline-standard-method ( node word -- node ) - 2dup dispatching-class dup [ - over +inlined+ depends-on - swap method method-word 1quotation f splice-quot - ] [ - 3drop t - ] if ; - -! Partial dispatch of math-generic words -: math-both-known? ( word left right -- ? ) - math-class-max swap specific-method ; - -: inline-math-method ( #call word -- node ) - over node-input-classes first2 3dup math-both-known? - [ math-method f splice-quot ] [ 2drop 2drop t ] if ; - -: inline-method ( #call -- node ) - dup node-param { - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ t ] [ 2drop t ] } - } cond ; - -! Resolve type checks at compile time where possible -: comparable? ( actual testing -- ? ) - #! If actual is a subset of testing or if the two classes - #! are disjoint, return t. - 2dup class< >r classes-intersect? not r> or ; - -: optimize-predicate? ( #call -- ? ) - dup node-param "predicating" word-prop dup [ - >r node-class-first r> comparable? - ] [ - 2drop f - ] if ; - -: literal-quot ( node literals -- quot ) - #! Outputs a quotation which drops the node's inputs, and - #! pushes some literals. - >r node-in-d length \ drop - r> [ literalize ] map append >quotation ; - -: inline-literals ( node literals -- node ) - #! Make #shuffle -> #push -> #return -> successor - dupd literal-quot f splice-quot ; - -: evaluate-predicate ( #call -- ? ) - dup node-param "predicating" word-prop >r - node-class-first r> class< ; - -: optimize-predicate ( #call -- node ) - #! If the predicate is followed by a branch we fold it - #! immediately - dup evaluate-predicate swap - dup node-successor #if? [ - dup drop-inputs >r - node-successor swap 0 1 ? fold-branch - r> [ set-node-successor ] keep - ] [ - swap 1array inline-literals - ] if ; - -: optimizer-hooks ( node -- conditions ) - node-param "optimizer-hooks" word-prop ; - -: optimizer-hook ( node -- pair/f ) - dup optimizer-hooks [ first call ] find 2nip ; - -: optimize-hook ( node -- ) - dup optimizer-hook second call ; - -: define-optimizers ( word optimizers -- ) - "optimizer-hooks" set-word-prop ; - -: flush-eval? ( #call -- ? ) - dup node-param "flushable" word-prop [ - node-out-d [ unused? ] all? - ] [ - drop f - ] if ; - -: flush-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup node-out-d length f inline-literals ; - -: partial-eval? ( #call -- ? ) - dup node-param "foldable" word-prop [ - dup node-in-d [ node-literal? ] with all? - ] [ - drop f - ] if ; - -: literal-in-d ( #call -- inputs ) - dup node-in-d [ node-literal ] with map ; - -: partial-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup literal-in-d over node-param 1quotation - [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; - -: define-identities ( words identities -- ) - [ "identities" set-word-prop ] curry each ; - -: find-identity ( node -- quot ) - [ node-param "identities" word-prop ] keep - [ swap first in-d-match? ] curry find - nip dup [ second ] when ; - -: apply-identities ( node -- node/f ) - dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; - -: optimistic-inline? ( #call -- ? ) - dup node-param "specializer" word-prop dup [ - >r node-input-classes r> specialized-length tail* - [ types length 1 = ] all? - ] [ - 2drop f - ] if ; - -: splice-word-def ( #call word -- node ) - dup +inlined+ depends-on - dup word-def swap 1array splice-quot ; - -: optimistic-inline ( #call -- node ) - dup node-param over node-history memq? [ - drop t - ] [ - dup node-param splice-word-def - ] if ; - -: method-body-inline? ( #call -- ? ) - node-param dup method-body? - [ flat-length 10 <= ] [ drop f ] if ; - -M: #call optimize-node* - { - { [ dup flush-eval? ] [ flush-eval ] } - { [ dup partial-eval? ] [ partial-eval ] } - { [ dup find-identity ] [ apply-identities ] } - { [ dup optimizer-hook ] [ optimize-hook ] } - { [ dup optimize-predicate? ] [ optimize-predicate ] } - { [ dup optimistic-inline? ] [ optimistic-inline ] } - { [ dup method-body-inline? ] [ optimistic-inline ] } - { [ t ] [ inline-method ] } - } cond dup not ; +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays generic assocs inference inference.class +inference.dataflow inference.backend inference.state io kernel +math namespaces sequences vectors words quotations hashtables +combinators classes generic.math continuations optimizer.def-use +optimizer.backend generic.standard optimizer.specializers +optimizer.def-use optimizer.pattern-match generic.standard +optimizer.control kernel.private ; +IN: optimizer.inlining + +: remember-inlining ( node history -- ) + [ swap set-node-history ] curry each-node ; + +: inlining-quot ( node quot -- node ) + over node-in-d dataflow-with + dup rot infer-classes/node ; + +: splice-quot ( #call quot history -- node ) + #! Must add history *before* splicing in, otherwise + #! the rest of the IR will also remember the history + pick node-history append + >r dupd inlining-quot dup r> remember-inlining + tuck splice-node ; + +! A heuristic to avoid excessive inlining +DEFER: (flat-length) + +: word-flat-length ( word -- n ) + { + ! heuristic: { ... } declare comes up in method bodies + ! and we don't care about it + { [ dup \ declare eq? ] [ drop -2 ] } + ! recursive + { [ dup get ] [ drop 1 ] } + ! not inline + { [ dup inline? not ] [ drop 1 ] } + ! inline + { [ t ] [ dup dup set word-def (flat-length) ] } + } cond ; + +: (flat-length) ( seq -- n ) + [ + { + { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup array? ] [ (flat-length) ] } + { [ dup word? ] [ word-flat-length ] } + { [ t ] [ drop 1 ] } + } cond + ] map sum ; + +: flat-length ( seq -- n ) + [ word-def (flat-length) ] with-scope ; + +! Single dispatch method inlining optimization +: specific-method ( class word -- class ) order min-class ; + +: node-class# ( node n -- class ) + over node-in-d ?nth node-class ; + +: dispatching-class ( node word -- class ) + [ dispatch# node-class# ] keep specific-method ; + +: inline-standard-method ( node word -- node ) + 2dup dispatching-class dup [ + over +inlined+ depends-on + swap method 1quotation f splice-quot + ] [ + 3drop t + ] if ; + +! Partial dispatch of math-generic words +: math-both-known? ( word left right -- ? ) + math-class-max swap specific-method ; + +: inline-math-method ( #call word -- node ) + over node-input-classes first2 3dup math-both-known? + [ math-method f splice-quot ] [ 2drop 2drop t ] if ; + +: inline-method ( #call -- node ) + dup node-param { + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ t ] [ 2drop t ] } + } cond ; + +! Resolve type checks at compile time where possible +: comparable? ( actual testing -- ? ) + #! If actual is a subset of testing or if the two classes + #! are disjoint, return t. + 2dup class< >r classes-intersect? not r> or ; + +: optimize-predicate? ( #call -- ? ) + dup node-param "predicating" word-prop dup [ + >r node-class-first r> comparable? + ] [ + 2drop f + ] if ; + +: literal-quot ( node literals -- quot ) + #! Outputs a quotation which drops the node's inputs, and + #! pushes some literals. + >r node-in-d length \ drop + r> [ literalize ] map append >quotation ; + +: inline-literals ( node literals -- node ) + #! Make #shuffle -> #push -> #return -> successor + dupd literal-quot f splice-quot ; + +: evaluate-predicate ( #call -- ? ) + dup node-param "predicating" word-prop >r + node-class-first r> class< ; + +: optimize-predicate ( #call -- node ) + #! If the predicate is followed by a branch we fold it + #! immediately + dup evaluate-predicate swap + dup node-successor #if? [ + dup drop-inputs >r + node-successor swap 0 1 ? fold-branch + r> [ set-node-successor ] keep + ] [ + swap 1array inline-literals + ] if ; + +: optimizer-hooks ( node -- conditions ) + node-param "optimizer-hooks" word-prop ; + +: optimizer-hook ( node -- pair/f ) + dup optimizer-hooks [ first call ] find 2nip ; + +: optimize-hook ( node -- ) + dup optimizer-hook second call ; + +: define-optimizers ( word optimizers -- ) + "optimizer-hooks" set-word-prop ; + +: flush-eval? ( #call -- ? ) + dup node-param "flushable" word-prop [ + node-out-d [ unused? ] all? + ] [ + drop f + ] if ; + +: flush-eval ( #call -- node ) + dup node-param +inlined+ depends-on + dup node-out-d length f inline-literals ; + +: partial-eval? ( #call -- ? ) + dup node-param "foldable" word-prop [ + dup node-in-d [ node-literal? ] with all? + ] [ + drop f + ] if ; + +: literal-in-d ( #call -- inputs ) + dup node-in-d [ node-literal ] with map ; + +: partial-eval ( #call -- node ) + dup node-param +inlined+ depends-on + dup literal-in-d over node-param 1quotation + [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; + +: define-identities ( words identities -- ) + [ "identities" set-word-prop ] curry each ; + +: find-identity ( node -- quot ) + [ node-param "identities" word-prop ] keep + [ swap first in-d-match? ] curry find + nip dup [ second ] when ; + +: apply-identities ( node -- node/f ) + dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; + +: optimistic-inline? ( #call -- ? ) + dup node-param "specializer" word-prop dup [ + >r node-input-classes r> specialized-length tail* + [ types length 1 = ] all? + ] [ + 2drop f + ] if ; + +: splice-word-def ( #call word -- node ) + dup +inlined+ depends-on + dup word-def swap 1array splice-quot ; + +: optimistic-inline ( #call -- node ) + dup node-param over node-history memq? [ + drop t + ] [ + dup node-param splice-word-def + ] if ; + +: method-body-inline? ( #call -- ? ) + node-param dup method-body? + [ flat-length 10 <= ] [ drop f ] if ; + +M: #call optimize-node* + { + { [ dup flush-eval? ] [ flush-eval ] } + { [ dup partial-eval? ] [ partial-eval ] } + { [ dup find-identity ] [ apply-identities ] } + { [ dup optimizer-hook ] [ optimize-hook ] } + { [ dup optimize-predicate? ] [ optimize-predicate ] } + { [ dup optimistic-inline? ] [ optimistic-inline ] } + { [ dup method-body-inline? ] [ optimistic-inline ] } + { [ t ] [ inline-method ] } + } cond dup not ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 66d3956dba..3abccecc7f 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -1,378 +1,378 @@ -USING: arrays compiler 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 - -[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* -] unit-test - -[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* -] unit-test - -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - -GENERIC: xyz ( obj -- obj ) -M: array xyz xyz ; - -[ t ] [ \ xyz compiled? ] unit-test - -! Test predicate inlining -: pred-test-1 - dup fixnum? [ - dup integer? [ "integer" ] [ "nope" ] if - ] [ - "not a fixnum" - ] if ; - -[ 1 "integer" ] [ 1 pred-test-1 ] unit-test - -TUPLE: pred-test ; - -: pred-test-2 - dup tuple? [ - dup pred-test? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test - -: pred-test-3 - dup pred-test? [ - dup tuple? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test - -: inline-test - "nom" = ; - -[ t ] [ "nom" inline-test ] unit-test -[ f ] [ "shayin" inline-test ] unit-test -[ f ] [ 3 inline-test ] unit-test - -: fixnum-declarations >fixnum 24 shift 1234 bitxor ; - -[ ] [ 1000000 fixnum-declarations . ] unit-test - -! regression - -: literal-not-branch 0 not [ ] [ ] if ; - -[ ] [ literal-not-branch ] unit-test - -! regression - -: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline -: bad-kill-2 bad-kill-1 drop ; - -[ 3 ] [ t bad-kill-2 ] unit-test - -! regression -: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline -: the-test ( -- x y ) 2 dup (the-test) ; - -[ 2 0 ] [ the-test ] unit-test - -! regression -: (double-recursion) ( start end -- ) - < [ - 6 1 (double-recursion) - 3 2 (double-recursion) - ] when ; inline - -: double-recursion 0 2 (double-recursion) ; - -[ ] [ double-recursion ] unit-test - -! regression -: double-label-1 ( a b c -- d ) - [ f double-label-1 ] [ swap nth-unsafe ] if ; inline - -: double-label-2 ( a -- b ) - dup array? [ ] [ ] if 0 t double-label-1 ; - -[ 0 ] [ 10 double-label-2 ] unit-test - -! regression -GENERIC: void-generic ( obj -- * ) -: breakage "hi" void-generic ; -[ t ] [ \ breakage compiled? ] unit-test -[ breakage ] must-fail - -! regression -: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline -: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline -: test-2 ( -- ) 5 test-1 ; - -[ f ] [ f test-2 ] unit-test - -: branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline - -: branch-fold-regression-1 ( -- m ) - 10 branch-fold-regression-0 ; - -[ 10 ] [ branch-fold-regression-1 ] unit-test - -! another regression -: constant-branch-fold-0 "hey" ; foldable -: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline -[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test - -! another regression -: foo f ; -: bar foo 4 4 = and ; -[ f ] [ bar ] unit-test - -! ensure identities are working in some form -[ t ] [ - [ { number } declare 0 + ] dataflow optimize - [ #push? ] node-exists? not -] unit-test - -! compiling with a non-literal class failed -: -regression ; - -[ t ] [ \ -regression compiled? ] unit-test - -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ reversed ] [ reversed \ foozul specific-method ] unit-test - -! regression -: constant-fold-2 f ; foldable -: constant-fold-3 4 ; foldable - -[ f t ] [ - [ constant-fold-2 constant-fold-3 4 = ] compile-call -] unit-test - -: constant-fold-4 f ; foldable -: constant-fold-5 f ; foldable - -[ f ] [ - [ constant-fold-4 constant-fold-5 or ] compile-call -] unit-test - -[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test -[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test -[ 0 ] [ 5 [ dup - ] compile-call ] unit-test - -[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test -[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test - -[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test -[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test - -[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test -[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test - -[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test - -[ f ] [ 5 [ dup < ] compile-call ] unit-test -[ t ] [ 5 [ dup <= ] compile-call ] unit-test -[ f ] [ 5 [ dup > ] compile-call ] unit-test -[ t ] [ 5 [ dup >= ] compile-call ] unit-test - -[ t ] [ 5 [ dup eq? ] compile-call ] unit-test -[ t ] [ 5 [ dup = ] compile-call ] unit-test -[ t ] [ 5 [ dup number= ] compile-call ] unit-test -[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test - -GENERIC: detect-number ( obj -- obj ) -M: number detect-number ; - -[ 10 f [ 0 + detect-number ] compile-call ] must-fail - -! Regression -[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test - -! Regression -USE: sorting -USE: sorting.private - -: old-binsearch ( elt quot seq -- elt quot i ) - dup length 1 <= [ - slice-from - ] [ - [ midpoint swap call ] 3keep roll dup zero? - [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if - ] if ; inline - -[ 10 ] [ - 10 20 >vector - [ [ - ] swap old-binsearch ] compile-call 2nip -] unit-test - -! Regression -TUPLE: silly-tuple a b ; - -[ 1 2 { silly-tuple-a silly-tuple-b } ] [ - T{ silly-tuple f 1 2 } - [ - { silly-tuple-a silly-tuple-b } [ get-slots ] keep - ] compile-call -] unit-test - -! Regression -: empty-compound ; - -: node-successor-f-bug ( x -- * ) - [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; - -[ t ] [ \ node-successor-f-bug compiled? ] unit-test - -[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test - -[ ] [ [ ] dataflow optimize drop ] unit-test - -! Make sure we have sane heuristics -: should-inline? method method-word flat-length 10 <= ; - -[ t ] [ \ fixnum \ shift should-inline? ] unit-test -[ f ] [ \ array \ equal? should-inline? ] unit-test -[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test -[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test - -! Regression -: lift-throw-tail-regression - dup integer? [ "an integer" ] [ - dup string? [ "a string" ] [ - "error" throw - ] if - ] if ; - -[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test -[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test -[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test - -: lift-loop-tail-test-1 ( a quot -- ) - over even? [ - [ >r 3 - r> call ] keep lift-loop-tail-test-1 - ] [ - over 0 < [ - 2drop - ] [ - [ >r 2 - r> call ] keep lift-loop-tail-test-1 - ] if - ] if ; inline - -: lift-loop-tail-test-2 - 10 [ ] lift-loop-tail-test-1 1 2 3 ; - -[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test - -! Make sure we don't lose -GENERIC: generic-inline-test ( x -- y ) -M: integer generic-inline-test ; - -: generic-inline-test-1 - 1 - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test ; - -[ { t f } ] [ - \ generic-inline-test-1 word-def dataflow - [ optimize-1 , optimize-1 , drop ] { } make -] unit-test - -! Forgot a recursive inline check -: recursive-inline-hang ( a -- a ) - dup array? [ recursive-inline-hang ] when ; - -HINTS: recursive-inline-hang array ; - -: recursive-inline-hang-1 - { } recursive-inline-hang ; - -[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test - -DEFER: recursive-inline-hang-3 - -: recursive-inline-hang-2 ( a -- a ) - dup array? [ recursive-inline-hang-3 ] when ; - -HINTS: recursive-inline-hang-2 array ; - -: recursive-inline-hang-3 ( a -- a ) - dup array? [ recursive-inline-hang-2 ] when ; - -HINTS: recursive-inline-hang-3 array ; - - +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: optimizer.tests + +[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* +] unit-test + +[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* +] unit-test + +! Test method inlining +[ f ] [ fixnum { } min-class ] unit-test + +[ string ] [ + \ string + [ integer string array reversed sbuf + slice vector quotation ] + sort-classes min-class +] unit-test + +[ fixnum ] [ + \ fixnum + [ fixnum integer object ] + sort-classes min-class +] unit-test + +[ integer ] [ + \ fixnum + [ integer float object ] + sort-classes min-class +] unit-test + +[ object ] [ + \ word + [ integer float object ] + sort-classes min-class +] unit-test + +[ reversed ] [ + \ reversed + [ integer reversed slice ] + sort-classes min-class +] unit-test + +GENERIC: xyz ( obj -- obj ) +M: array xyz xyz ; + +[ t ] [ \ xyz compiled? ] unit-test + +! Test predicate inlining +: pred-test-1 + dup fixnum? [ + dup integer? [ "integer" ] [ "nope" ] if + ] [ + "not a fixnum" + ] if ; + +[ 1 "integer" ] [ 1 pred-test-1 ] unit-test + +TUPLE: pred-test ; + +: pred-test-2 + dup tuple? [ + dup pred-test? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test + +: pred-test-3 + dup pred-test? [ + dup tuple? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test + +: inline-test + "nom" = ; + +[ t ] [ "nom" inline-test ] unit-test +[ f ] [ "shayin" inline-test ] unit-test +[ f ] [ 3 inline-test ] unit-test + +: fixnum-declarations >fixnum 24 shift 1234 bitxor ; + +[ ] [ 1000000 fixnum-declarations . ] unit-test + +! regression + +: literal-not-branch 0 not [ ] [ ] if ; + +[ ] [ literal-not-branch ] unit-test + +! regression + +: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline +: bad-kill-2 bad-kill-1 drop ; + +[ 3 ] [ t bad-kill-2 ] unit-test + +! regression +: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline +: the-test ( -- x y ) 2 dup (the-test) ; + +[ 2 0 ] [ the-test ] unit-test + +! regression +: (double-recursion) ( start end -- ) + < [ + 6 1 (double-recursion) + 3 2 (double-recursion) + ] when ; inline + +: double-recursion 0 2 (double-recursion) ; + +[ ] [ double-recursion ] unit-test + +! regression +: double-label-1 ( a b c -- d ) + [ f double-label-1 ] [ swap nth-unsafe ] if ; inline + +: double-label-2 ( a -- b ) + dup array? [ ] [ ] if 0 t double-label-1 ; + +[ 0 ] [ 10 double-label-2 ] unit-test + +! regression +GENERIC: void-generic ( obj -- * ) +: breakage "hi" void-generic ; +[ t ] [ \ breakage compiled? ] unit-test +[ breakage ] must-fail + +! regression +: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline +: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline +: test-2 ( -- ) 5 test-1 ; + +[ f ] [ f test-2 ] unit-test + +: branch-fold-regression-0 ( m -- n ) + t [ ] [ 1+ branch-fold-regression-0 ] if ; inline + +: branch-fold-regression-1 ( -- m ) + 10 branch-fold-regression-0 ; + +[ 10 ] [ branch-fold-regression-1 ] unit-test + +! another regression +: constant-branch-fold-0 "hey" ; foldable +: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline +[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! another regression +: foo f ; +: bar foo 4 4 = and ; +[ f ] [ bar ] unit-test + +! ensure identities are working in some form +[ t ] [ + [ { number } declare 0 + ] dataflow optimize + [ #push? ] node-exists? not +] unit-test + +! compiling with a non-literal class failed +: -regression ; + +[ t ] [ \ -regression compiled? ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ reversed ] [ reversed \ foozul specific-method ] unit-test + +! regression +: constant-fold-2 f ; foldable +: constant-fold-3 4 ; foldable + +[ f t ] [ + [ constant-fold-2 constant-fold-3 4 = ] compile-call +] unit-test + +: constant-fold-4 f ; foldable +: constant-fold-5 f ; foldable + +[ f ] [ + [ constant-fold-4 constant-fold-5 or ] compile-call +] unit-test + +[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test +[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test +[ 0 ] [ 5 [ dup - ] compile-call ] unit-test + +[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test +[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test + +[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test +[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test + +[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test +[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test + +[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test + +[ f ] [ 5 [ dup < ] compile-call ] unit-test +[ t ] [ 5 [ dup <= ] compile-call ] unit-test +[ f ] [ 5 [ dup > ] compile-call ] unit-test +[ t ] [ 5 [ dup >= ] compile-call ] unit-test + +[ t ] [ 5 [ dup eq? ] compile-call ] unit-test +[ t ] [ 5 [ dup = ] compile-call ] unit-test +[ t ] [ 5 [ dup number= ] compile-call ] unit-test +[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test + +GENERIC: detect-number ( obj -- obj ) +M: number detect-number ; + +[ 10 f [ 0 + detect-number ] compile-call ] must-fail + +! Regression +[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test + +! Regression +USE: sorting +USE: sorting.private + +: old-binsearch ( elt quot seq -- elt quot i ) + dup length 1 <= [ + slice-from + ] [ + [ midpoint swap call ] 3keep roll dup zero? + [ drop dup slice-from swap midpoint@ + ] + [ partition old-binsearch ] if + ] if ; inline + +[ 10 ] [ + 10 20 >vector + [ [ - ] swap old-binsearch ] compile-call 2nip +] unit-test + +! Regression +TUPLE: silly-tuple a b ; + +[ 1 2 { silly-tuple-a silly-tuple-b } ] [ + T{ silly-tuple f 1 2 } + [ + { silly-tuple-a silly-tuple-b } [ get-slots ] keep + ] compile-call +] unit-test + +! Regression +: empty-compound ; + +: node-successor-f-bug ( x -- * ) + [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; + +[ t ] [ \ node-successor-f-bug compiled? ] unit-test + +[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +[ ] [ [ ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test + +! Regression +: lift-throw-tail-regression + dup integer? [ "an integer" ] [ + dup string? [ "a string" ] [ + "error" throw + ] if + ] if ; + +[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test +[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test +[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test + +: lift-loop-tail-test-1 ( a quot -- ) + over even? [ + [ >r 3 - r> call ] keep lift-loop-tail-test-1 + ] [ + over 0 < [ + 2drop + ] [ + [ >r 2 - r> call ] keep lift-loop-tail-test-1 + ] if + ] if ; inline + +: lift-loop-tail-test-2 + 10 [ ] lift-loop-tail-test-1 1 2 3 ; + +[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test + +! Make sure we don't lose +GENERIC: generic-inline-test ( x -- y ) +M: integer generic-inline-test ; + +: generic-inline-test-1 + 1 + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test ; + +[ { t f } ] [ + \ generic-inline-test-1 word-def dataflow + [ optimize-1 , optimize-1 , drop ] { } make +] unit-test + +! Forgot a recursive inline check +: recursive-inline-hang ( a -- a ) + dup array? [ recursive-inline-hang ] when ; + +HINTS: recursive-inline-hang array ; + +: recursive-inline-hang-1 + { } recursive-inline-hang ; + +[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test + +DEFER: recursive-inline-hang-3 + +: recursive-inline-hang-2 ( a -- a ) + dup array? [ recursive-inline-hang-3 ] when ; + +HINTS: recursive-inline-hang-2 array ; + +: recursive-inline-hang-3 ( a -- a ) + dup array? [ recursive-inline-hang-2 ] when ; + +HINTS: recursive-inline-hang-3 array ; + + diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index a0e7e4b909..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 @@ -354,7 +354,7 @@ IN: temporary DEFER: ~b - "IN: temporary : ~b ~a ;" + "IN: parser.tests : ~b ~a ;" "smudgy" parse-stream drop : ~c ; @@ -389,9 +389,44 @@ IN: temporary ] 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 e2efdd8163..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" ; @@ -464,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 @@ -500,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 32629724bd..20130d7f7e 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint prettyprint.config prettyprint.sections sequences tools.test vectors words effects splitting generic.standard prettyprint.private continuations generic compiler.units tools.walker ; -IN: temporary +IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test [ "1.0" ] [ 1.0 unparse ] unit-test @@ -73,12 +73,12 @@ 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,9 +292,9 @@ 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 diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 2efc9b4e67..6cb03e4199 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -175,10 +175,10 @@ 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* ; + dup dup + definer. + "method-class" word-prop pprint* + "method-generic" word-prop pprint* ; M: mixin-instance synopsis* dup definer. @@ -269,7 +269,7 @@ M: builtin-class see-class* : see-implementors ( class -- seq ) dup implementors - [ method method-word ] with map + [ method ] with map natural-sort ; : see-class ( class -- ) @@ -280,9 +280,7 @@ M: builtin-class see-class* ] when drop ; : see-methods ( generic -- seq ) - "methods" word-prop - [ nip method-word ] { } assoc>map - natural-sort ; + "methods" word-prop values 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/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 dd5313383e..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 ; 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 a8e4eef587..d157907cc2 100755 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private io threads.private continuations dlists init quotations strings -assocs heaps boxes ; +assocs heaps boxes namespaces ; IN: threads ARTICLE: "threads-start/stop" "Starting and stopping threads" @@ -19,8 +19,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads" { $subsection yield } "Sleeping for a period of time:" { $subsection sleep } -"Interruptible sleep:" -{ $subsection nap } +"Interrupting sleep:" { $subsection interrupt } "Threads can be suspended and woken up at some point in the future when a condition is satisfied:" { $subsection suspend } @@ -106,14 +105,17 @@ HELP: stop HELP: yield { $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ; +HELP: sleep-until +{ $values { "time/f" "a non-negative integer or " { $link f } } } +{ $description "Suspends the current thread until the given time, or indefinitely if a value of " { $link f } " is passed in." +$nl +"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ; + HELP: sleep { $values { "ms" "a non-negative integer" } } -{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." } -{ $errors "Throws an error if another thread interrupted the sleep with " { $link interrupt } "." } ; - -HELP: nap -{ $values { "ms/f" "a non-negative integer or " { $link f } } { "?" "a boolean indicating whether the thread was interrupted" } } -{ $description "Suspends the current thread until another thread interrupts it with " { $link interrupt } ". If the input parameter is not " { $link f } ", then the thread will also wake up if the timeout expires before an interrupt is received." } ; +{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." +$nl +"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ; HELP: interrupt { $values { "thread" thread } } @@ -127,7 +129,10 @@ 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 catch stack, and a name stack containing the global namespace only. This means that the only 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 } "." } +"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 [ + . ] 2curry \"Addition thread\" spawn" } } ; diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index 00306da062..c2e627e7bf 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -1,5 +1,5 @@ USING: namespaces io tools.test threads kernel ; -IN: temporary +IN: threads.tests 3 "x" set namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 2ba5179c1c..b4fd6eee60 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -4,13 +4,12 @@ IN: threads USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private -dlists assocs system combinators debugger prettyprint io init -boxes ; +dlists assocs system combinators init boxes ; SYMBOL: initial-thread TUPLE: thread -name quot error-handler exit-handler +name quot exit-handler id continuation state mailbox variables sleep-entry ; @@ -60,11 +59,10 @@ threads global [ H{ } assoc-like ] change-at PRIVATE> -: ( quot name error-handler -- thread ) +: ( quot name -- thread ) \ thread counter [ ] { set-thread-quot set-thread-name - set-thread-error-handler set-thread-id set-thread-continuation set-thread-exit-handler @@ -75,14 +73,24 @@ PRIVATE> : sleep-queue 43 getenv ; : resume ( thread -- ) + f over set-thread-state check-registered run-queue push-front ; : resume-now ( thread -- ) + f over set-thread-state check-registered run-queue push-back ; : resume-with ( obj thread -- ) + f over set-thread-state check-registered 2array run-queue push-front ; +: sleep-time ( -- ms/f ) + { + { [ run-queue dlist-empty? not ] [ 0 ] } + { [ sleep-queue heap-empty? ] [ f ] } + { [ t ] [ sleep-queue heap-peek nip millis [-] ] } + } cond ; + [ ] while drop ; -: next ( -- ) +: next ( -- * ) expire-sleep-loop - run-queue pop-back - dup array? [ first2 ] [ f swap ] if dup set-self - f over set-thread-state - thread-continuation box> - continue-with ; + run-queue dup dlist-empty? [ + ! We should never be in a state where the only threads + ! are sleeping; the I/O wait thread is always runnable. + ! However, if it dies, we handle this case + ! semi-gracefully. + ! + ! And if sleep-time outputs f, there are no sleeping + ! threads either... so WTF. + drop sleep-time [ die 0 ] unless* (sleep) next + ] [ + pop-back + dup array? [ first2 ] [ f swap ] if dup set-self + f over set-thread-state + thread-continuation box> + continue-with + ] if ; PRIVATE> -: sleep-time ( -- ms/f ) - { - { [ run-queue dlist-empty? not ] [ 0 ] } - { [ sleep-queue heap-empty? ] [ f ] } - { [ t ] [ sleep-queue heap-peek nip millis [-] ] } - } cond ; - : stop ( -- ) self dup thread-exit-handler call unregister-thread next ; @@ -131,41 +143,33 @@ PRIVATE> self swap call next ] callcc1 2nip ; inline -: yield ( -- ) [ resume ] "yield" suspend drop ; +: yield ( -- ) [ resume ] f suspend drop ; -GENERIC: nap-until ( time -- ? ) +GENERIC: sleep-until ( time/f -- ) -M: integer nap-until [ schedule-sleep ] curry "sleep" suspend ; +M: integer sleep-until + [ schedule-sleep ] curry "sleep" suspend drop ; -M: f nap-until drop [ drop ] "interrupt" suspend ; +M: f sleep-until + drop [ drop ] "interrupt" suspend drop ; -GENERIC: nap ( time -- ? ) +GENERIC: sleep ( ms -- ) -M: real nap millis + >integer nap-until ; - -M: f nap nap-until ; - -: sleep-until ( time -- ) - nap-until [ "Sleep interrupted" throw ] when ; - -: sleep ( time -- ) - nap [ "Sleep interrupted" throw ] when ; +M: real sleep + millis + >integer sleep-until ; : interrupt ( thread -- ) - dup self eq? [ - drop - ] [ + dup thread-state [ dup thread-sleep-entry [ sleep-queue heap-delete ] when* f over set-thread-sleep-entry - t swap resume-with - ] if ; + dup resume + ] when drop ; : (spawn) ( thread -- ) [ resume-now [ dup set-self dup register-thread - init-namespaces V{ } set-catchstack { } set-retainstack >r { } set-datastack r> @@ -173,20 +177,8 @@ M: f nap nap-until ; ] 1 (throw) ] "spawn" suspend 2drop ; -: default-thread-error-handler ( error thread -- ) - global [ - "Error in thread " write - dup thread-id pprint - " (" write - dup thread-name pprint ")" print - "spawned to call " write - thread-quot short. - nl - print-error flush - ] bind ; - : spawn ( quot name -- thread ) - [ default-thread-error-handler ] [ (spawn) ] keep ; + [ (spawn) ] keep ; : spawn-server ( quot name -- thread ) >r [ [ ] [ ] while ] curry r> spawn ; @@ -196,6 +188,8 @@ M: f nap nap-until ; [ >r set-namestack set-datastack r> call ] 3curry "Thread" spawn drop ; +GENERIC: error-in-thread ( error thread -- ) + 42 setenv 43 setenv initial-thread global - [ drop f "Initial" [ die ] ] cache + [ drop f "Initial" ] cache over set-thread-continuation + f over set-thread-state dup register-thread set-self ; -[ self dup thread-error-handler call stop ] +[ self error-in-thread stop ] thread-error-hook set-global 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/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 720a1ef645..1a3fecc3fb 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ; M: f set-vocab-docs-loaded? 2drop ; +M: f vocab-help ; + : create-vocab ( name -- vocab ) dictionary get [ ] cache ; 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..06f3c7a782 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 FORGET: undef-test : 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..ce69c1ff2e 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,7 +68,7 @@ SYMBOL: bootstrapping? : crossref? ( word -- ? ) { { [ dup "forgotten" word-prop ] [ f ] } - { [ dup "method" word-prop ] [ t ] } + { [ dup "method-def" word-prop ] [ t ] } { [ dup word-vocabulary ] [ t ] } { [ t ] [ f ] } } cond nip ; @@ -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/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor index b609878c77..fcb2de8b6b 100755 --- a/extra/alarms/alarms-docs.factor +++ b/extra/alarms/alarms-docs.factor @@ -5,11 +5,11 @@ HELP: alarm { $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ; HELP: add-alarm -{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link dt } " or " { $link f } } { "alarm" 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" dt } { "alarm" alarm } } +{ $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 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 index 92a7c488ef..1ccfdcbd30 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -16,7 +16,7 @@ SYMBOL: alarm-thread alarm-thread get-global interrupt ; : check-alarm - dup dt? over not or [ "Not a dt" throw ] unless + dup duration? over not or [ "Not a duration" throw ] unless over timestamp? [ "Not a timestamp" throw ] unless pick callable? [ "Not a quotation" throw ] unless ; inline @@ -29,16 +29,16 @@ SYMBOL: alarm-thread notify-alarm-thread ; : alarm-expired? ( alarm now -- ? ) - >r alarm-time r> <=> 0 <= ; + >r alarm-time r> before=? ; : reschedule-alarm ( alarm -- ) - dup alarm-time over alarm-interval +dt + dup alarm-time over alarm-interval time+ over set-alarm-time register-alarm ; : call-alarm ( alarm -- ) - dup alarm-quot try dup alarm-entry box> drop + dup alarm-quot try dup alarm-interval [ reschedule-alarm ] [ drop ] if ; : (trigger-alarms) ( alarms now -- ) @@ -46,8 +46,7 @@ SYMBOL: alarm-thread 2drop ] [ over heap-peek drop over alarm-expired? [ - over heap-pop drop call-alarm - (trigger-alarms) + over heap-pop drop call-alarm (trigger-alarms) ] [ 2drop ] if @@ -62,7 +61,7 @@ SYMBOL: alarm-thread : alarm-thread-loop ( -- ) alarms get-global - dup next-alarm nap-until drop + dup next-alarm sleep-until dup trigger-alarms alarm-thread-loop ; @@ -87,5 +86,4 @@ PRIVATE> from-now f add-alarm ; : cancel-alarm ( alarm -- ) - alarm-entry ?box - [ alarms get-global heap-delete ] [ drop ] if ; + 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/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 182f04a367..88095759e6 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -16,13 +16,16 @@ IN: assocs.lib : at-default ( key assoc -- value/key ) dupd at [ nip ] when* ; +: replace-at ( assoc value key -- assoc ) + >r >r dup r> 1vector r> rot set-at ; + : insert-at ( value key assoc -- ) [ ?push ] change-at ; -: peek-at* ( key assoc -- obj ? ) - at* dup [ >r peek r> ] when ; +: peek-at* ( assoc key -- obj ? ) + swap at* dup [ >r peek r> ] when ; -: peek-at ( key assoc -- obj ) +: peek-at ( assoc key -- obj ) peek-at* drop ; : >multi-assoc ( assoc -- new-assoc ) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index bd13455357..231c6edf50 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -21,7 +21,7 @@ IN: benchmark ] with-row [ [ - swap [ ($vocab-link) ] with-cell + swap [ dup ($vocab-link) ] with-cell first2 pprint-cell pprint-cell ] with-row ] assoc-each 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/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/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/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 6b1908afb1..4927776575 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,43 +1,58 @@ -USING: io.sockets io.server io kernel math threads -debugger tools.time prettyprint concurrency.combinators ; -IN: benchmark.sockets - -: simple-server ( -- ) - 7777 local-server "benchmark.sockets" [ - read1 CHAR: x = [ - stop-server - ] [ - 20 [ read1 write1 flush ] times - ] if - ] with-server ; - -: simple-client ( -- ) - "localhost" 7777 [ - CHAR: b write1 flush - 20 [ CHAR: a dup write1 flush read1 assert= ] times - ] with-stream ; - -: stop-server ( -- ) - "localhost" 7777 [ - CHAR: x write1 - ] with-stream ; - -: clients ( n -- ) - dup pprint " clients: " write [ - [ simple-server ] in-thread - yield yield - [ drop simple-client ] parallel-each - stop-server - yield yield - ] time ; - -: socket-benchmarks - 10 clients - 20 clients - 40 clients ; - ! 80 clients - ! 160 clients - ! 320 clients - ! 640 clients ; - -MAIN: socket-benchmarks +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 ( -- ) + [ + server-addr dup "server" set [ + server-loop + ] with-disposal + ] ignore-errors ; + +: simple-client ( -- ) + server-addr [ + CHAR: b write1 flush + number-of-requests + [ CHAR: a dup write1 flush read1 assert= ] times + counter get count-down + ] with-stream ; + +: stop-server ( -- ) + server-addr [ + CHAR: x write1 + ] with-stream ; + +: clients ( n -- ) + dup pprint " clients: " write [ + dup 2 * counter set + [ simple-server ] "Simple server" spawn drop + yield yield + [ [ simple-client ] "Simple client" spawn drop ] times + counter get await + stop-server + yield yield + ] time ; + +: socket-benchmarks ; + +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..3c0b464dbf 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@factorcode.org:/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/builder/builder.factor b/extra/builder/builder.factor index d9961f9452..92cd5f5241 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -39,41 +39,30 @@ IN: builder : 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 ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : copy-image ( -- ) - "../../factor/" my-boot-image-name append - "../" my-boot-image-name append - copy-file - - "../../factor/" my-boot-image-name append - my-boot-image-name - copy-file ; + builds "factor" path+ my-boot-image-name path+ ".." copy-file-into + builds "factor" path+ my-boot-image-name path+ "." copy-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: factor-binary ( -- name ) - os - { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } - { "winnt" [ "./factor-nt.exe" ] } - [ drop "./factor" ] } - case ; - : bootstrap-cmd ( -- cmd ) - { factor-binary { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; + { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; : bootstrap ( -- desc ) @@ -84,8 +73,11 @@ IN: builder 20 minutes >>timeout >desc ; +: do-bootstrap ( -- ) + bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ; + : builder-test-cmd ( -- cmd ) - { factor-binary "-run=builder.test" } to-strings ; + { "./factor" "-run=builder.test" } to-strings ; : builder-test ( -- desc ) @@ -96,6 +88,9 @@ IN: builder 45 minutes >>timeout >desc ; +: do-builder-test ( -- ) + builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: build-status @@ -108,48 +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 - copy-image + "Benchmarks: " print "benchmarks" eval-file benchmarks. - bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail + nl - builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail + show-benchmark-deltas - "../test-log" delete-file + "benchmarks" ".." copy-file-into - "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 - - "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. - - nl - - show-benchmark-deltas - - "../benchmarks" "../../benchmarks" copy-file - - ] with-file-writer + maybe-release + ] + with-file-writer build-status on ; @@ -168,7 +163,7 @@ SYMBOL: builder-recipients builder-from get >>from builder-recipients get >>to subject >>subject - "../report" file>string >>body + "./report" file>string >>body send ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,10 +172,11 @@ SYMBOL: builder-recipients { "bzip2" my-boot-image-name } to-strings run-process drop ; : build ( -- ) - [ (build) ] [ drop ] recover + [ (build) ] failsafe + builds cd stamp> cd [ send-builder-email ] [ drop "not sending mail" . ] recover - ".." cd { "rm" "-rf" "factor" } run-process drop - [ compress-image ] [ drop ] recover ; + { "rm" "-rf" "factor" } run-process drop + [ compress-image ] failsafe ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -215,8 +211,7 @@ USE: bootstrap.image.download [ build ] when ] - [ drop ] - recover + failsafe 5 minutes sleep build-loop ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index db903c9501..849d1a54a3 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -1,12 +1,17 @@ -USING: kernel namespaces sequences combinators io.files io.launcher - combinators.cleave builder.common builder.util ; +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" append ; +: releases ( -- path ) + builds "releases" path+ + dup exists? not + [ dup make-directory ] + when ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -34,8 +39,6 @@ IN: builder.release ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USING: system sequences splitting ; - : cpu- ( -- cpu ) cpu "." split "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -57,61 +60,57 @@ USING: system sequences splitting ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: move-file ( source destination -- ) swap { "mv" , , } run-process drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: linux-release ( -- ) - - { "rm" "-rf" "Factor.app" } run-process drop - - { "rm" "-rf" common-files } to-strings run-process drop - - ".." cd - - { "tar" "-cvzf" archive-name "factor" } to-strings run-process drop - - archive-name releases move-file ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: windows-release ( -- ) - - { "rm" "-rf" "Factor.app" } run-process drop - - { "rm" "-rf" common-files } to-strings run-process drop - - ".." cd - - { "zip" "-r" archive-name "factor" } to-strings run-process drop - - archive-name releases move-file ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: macosx-release ( -- ) - - { "rm" "-rf" common-files } to-strings run-process drop - - ".." cd +: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ; +: macosx-archive-cmd ( -- cmd ) { "hdiutil" "create" "-srcfolder" "factor" "-fs" "HFS+" "-volname" "factor" - archive-name } - to-strings run-process drop + archive-name } ; - archive-name releases move-file ; +: 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 ( -- ) - os - { - { "linux" [ linux-release ] } - { "winnt" [ windows-release ] } - { "macosx" [ macosx-release ] } - } - case ; - \ No newline at end of file + "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/util/util.factor b/extra/builder/util/util.factor index 3d699d4ba8..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 @@ -104,4 +104,8 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ; USE: prettyprint -: to-file ( object file -- ) [ . ] with-file-writer ; \ No newline at end of file +: to-file ( object file -- ) [ . ] with-file-writer ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: failsafe ( quot -- ) [ drop ] recover ; diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 2d731dd830..49a0f9254a 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -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 d1d7246a58..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 -shuffle threads ; +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,45 +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 : millis>timestamp ( n -- timestamp ) - >r unix-1970 r> 1000 /f seconds +dt ; + >r unix-1970 r> milliseconds time+ ; : timestamp>millis ( timestamp -- n ) - unix-1970 timestamp- 1000 * >integer ; - -: 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 ; - + 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 @@ -268,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 ) @@ -280,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 ) @@ -297,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 ; @@ -457,25 +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 nap-until timestamp>millis nap-until ; +M: timestamp sleep-until timestamp>millis sleep-until ; -M: dt nap from-now nap-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/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 index 1f2436cf5d..df72572c67 100755 --- 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/examples/examples.factor b/extra/channels/examples/examples.factor index 993b1db1a4..1e51fb06d8 100755 --- a/extra/channels/examples/examples.factor +++ b/extra/channels/examples/examples.factor @@ -24,7 +24,7 @@ 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 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/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/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-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index 831dad6b56..0f18fcf431 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.combinators.tests USING: concurrency.combinators tools.test random kernel math concurrency.mailboxes threads sequences ; @@ -11,7 +11,7 @@ concurrency.mailboxes threads sequences ; [ { 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 ] -[ linked-error "Even" = ] must-fail-with +[ delegate "Even" = ] must-fail-with [ V{ 0 3 6 9 } ] [ 10 [ 3 mod zero? ] parallel-subset ] unit-test diff --git a/extra/concurrency/conditions/conditions.factor b/extra/concurrency/conditions/conditions.factor index 359ceaa9ae..b10aded671 100755 --- a/extra/concurrency/conditions/conditions.factor +++ b/extra/concurrency/conditions/conditions.factor @@ -8,7 +8,7 @@ IN: concurrency.conditions dup dlist-empty? [ drop ] [ pop-back resume-now ] if ; : notify-all ( dlist -- ) - [ resume-now ] dlist-slurp yield ; + [ resume-now ] dlist-slurp ; : queue-timeout ( queue timeout -- alarm ) #! Add an alarm which removes the current thread from the diff --git a/extra/concurrency/count-downs/count-downs-tests.factor b/extra/concurrency/count-downs/count-downs-tests.factor index f6bd64234f..649802cd95 100755 --- a/extra/concurrency/count-downs/count-downs-tests.factor +++ b/extra/concurrency/count-downs/count-downs-tests.factor @@ -1,5 +1,5 @@ USING: concurrency.count-downs threads kernel tools.test ; -IN: temporary` +IN: concurrency.count-downs.tests` [ ] [ 0 await ] unit-test diff --git a/extra/concurrency/exchangers/exchangers-tests.factor b/extra/concurrency/exchangers/exchangers-tests.factor index 3e7f67b9f0..569b1a72c2 100755 --- a/extra/concurrency/exchangers/exchangers-tests.factor +++ b/extra/concurrency/exchangers/exchangers-tests.factor @@ -1,9 +1,9 @@ -IN: temporary +IN: concurrency.exchangers.tests USING: sequences tools.test concurrency.exchangers concurrency.count-downs concurrency.promises locals kernel threads ; -:: exchanger-test | | +:: exchanger-test ( -- ) [let | ex [ ] c [ 2 ] 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/futures/futures-tests.factor b/extra/concurrency/futures/futures-tests.factor index 39299f9cf7..208a72f820 100755 --- a/extra/concurrency/futures/futures-tests.factor +++ b/extra/concurrency/futures/futures-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.futures.tests USING: concurrency.futures kernel tools.test threads ; [ 50 ] [ diff --git a/extra/concurrency/locks/locks-docs.factor b/extra/concurrency/locks/locks-docs.factor index 86db5914c9..3a89af5ba0 100755 --- a/extra/concurrency/locks/locks-docs.factor +++ b/extra/concurrency/locks/locks-docs.factor @@ -46,7 +46,7 @@ $nl $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 read lock may acquire a write lock recursively, and a thread holding a write lock may acquire a write lock or a read lock recursively, 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." +"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 } diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor index 8ebf6856a9..659bd2714e 100755 --- a/extra/concurrency/locks/locks-tests.factor +++ b/extra/concurrency/locks/locks-tests.factor @@ -1,9 +1,9 @@ -IN: temporary +IN: concurrency.locks.tests USING: tools.test concurrency.locks concurrency.count-downs concurrency.messaging concurrency.mailboxes locals kernel threads sequences calendar ; -:: lock-test-0 | | +:: lock-test-0 ( -- ) [let | v [ V{ } clone ] c [ 2 ] | @@ -27,7 +27,7 @@ threads sequences calendar ; v ] ; -:: lock-test-1 | | +:: lock-test-1 ( -- ) [let | v [ V{ } clone ] l [ ] c [ 2 ] | @@ -79,7 +79,7 @@ threads sequences calendar ; [ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test -:: rw-lock-test-1 | | +:: rw-lock-test-1 ( -- ) [let | l [ ] c [ 1 ] c' [ 1 ] @@ -129,7 +129,7 @@ threads sequences calendar ; [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test -:: rw-lock-test-2 | | +:: rw-lock-test-2 ( -- ) [let | l [ ] c [ 1 ] c' [ 2 ] @@ -160,7 +160,7 @@ threads sequences calendar ; [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test ! Test lock timeouts -:: lock-timeout-test | | +:: lock-timeout-test ( -- ) [let | l [ ] | [ l [ 1 seconds sleep ] with-lock @@ -174,5 +174,40 @@ threads sequences calendar ; ] ; [ lock-timeout-test ] [ - linked-thread thread-name "Lock timeout-er" = + 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 index ea442612b1..43f22c00da 100755 --- a/extra/concurrency/locks/locks.factor +++ b/extra/concurrency/locks/locks.factor @@ -55,17 +55,23 @@ TUPLE: rw-lock readers writers reader# writer ; r rw-lock-readers r> "read lock" wait ] when drop - dup rw-lock-reader# 1+ swap set-rw-lock-reader# ; + 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 rw-lock-reader# 1- dup pick set-rw-lock-reader# - zero? [ notify-writer ] [ drop ] if ; + 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 @@ -77,23 +83,34 @@ TUPLE: rw-lock readers writers reader# writer ; dup rw-lock-readers dlist-empty? [ notify-writer ] [ rw-lock-readers notify-all ] if ; -: do-reentrant-rw-lock ( lock timeout quot quot' -- ) - >r pick rw-lock-writer self eq? [ 2nip call ] r> if ; inline +: 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 - ] do-reentrant-rw-lock ; inline + ] 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 - ] do-reentrant-rw-lock ; inline + ] if ; inline : with-write-lock ( lock quot -- ) f swap with-write-lock-timeout ; inline diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 4541d06a5a..24d83b2961 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.mailboxes.tests USING: concurrency.mailboxes vectors sequences threads tools.test math kernel strings ; diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index e5f12d5507..28b2fb7221 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -15,7 +15,7 @@ TUPLE: mailbox threads data ; : mailbox-put ( obj mailbox -- ) [ mailbox-data push-front ] keep - mailbox-threads notify-all ; + mailbox-threads notify-all yield ; : block-unless-pred ( pred mailbox timeout -- ) 2over mailbox-data dlist-contains? [ @@ -65,12 +65,23 @@ TUPLE: mailbox threads data ; : mailbox-get? ( pred mailbox -- obj ) f mailbox-get-timeout? ; inline -TUPLE: linked error thread ; +TUPLE: linked-error thread ; -C: linked +: ( error thread -- linked ) + { set-delegate set-linked-error-thread } + linked-error construct ; -: ?linked dup linked? [ rethrow ] when ; +: ?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 ) - [ >r r> mailbox-put ] curry - [ (spawn) ] keep ; + [ (spawn) ] keep ; diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 5f241b77e3..6de381b166 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -4,7 +4,7 @@ USING: kernel threads vectors arrays sequences namespaces tools.test continuations dlists strings math words match quotations concurrency.messaging concurrency.mailboxes ; -IN: temporary +IN: concurrency.messaging.tests [ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test @@ -29,7 +29,7 @@ IN: temporary "crash" throw ] "Linked test" spawn-linked drop receive -] [ linked-error "crash" = ] must-fail-with +] [ delegate "crash" = ] must-fail-with MATCH-VARS: ?from ?to ?value ; SYMBOL: increment diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index 97cd45190f..6915653eb4 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -32,7 +32,7 @@ M: thread send ( message thread -- ) my-mailbox swap mailbox-get-timeout? ?linked ; inline : rethrow-linked ( error process supervisor -- ) - >r r> send ; + >r r> send ; : spawn-linked ( quot name -- thread ) my-mailbox spawn-linked-to ; diff --git a/extra/concurrency/promises/promises-tests.factor b/extra/concurrency/promises/promises-tests.factor index fa749438d2..36fe4ef907 100755 --- a/extra/concurrency/promises/promises-tests.factor +++ b/extra/concurrency/promises/promises-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.promises.tests USING: vectors concurrency.promises kernel threads sequences tools.test ; diff --git a/extra/concurrency/semaphores/semaphores-docs.factor b/extra/concurrency/semaphores/semaphores-docs.factor index 7f8b9b017a..76a87f2077 100755 --- a/extra/concurrency/semaphores/semaphores-docs.factor +++ b/extra/concurrency/semaphores/semaphores-docs.factor @@ -9,7 +9,7 @@ HELP: { $description "Creates a counting semaphore with the specified initial count." } ; HELP: acquire-timeout -{ $values { "semaphore" semaphore } { "timeout" "a " { $link dt } " or " { $link f } } { "value" object } } +{ $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." } ; @@ -22,7 +22,7 @@ HELP: release { $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 dt } " or " { $link f } } { "quot" quotation } } +{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } { $description "Calls the quotation with the semaphore held." } ; HELP: with-semaphore 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/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..a6c2975c89 --- 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 @@ -34,24 +33,6 @@ IN: temporary ] with-db ] unit-test -[ - { { "John" "America" } } -] [ - test-db [ - "select * from person where name = $1 and country = $2" - [ - { { "Jane" TEXT } { "New Zealand" TEXT } } - over do-bound-query - - { { "Jane" "New Zealand" } } = - [ "test fails" throw ] unless - - { { "John" TEXT } { "America" TEXT } } - swap do-bound-query - ] with-disposal - ] with-db -] unit-test - [ { { "John" "America" } @@ -108,3 +89,7 @@ IN: temporary "select * from person" sql-query length ] with-db ] unit-test + + +: with-dummy-db ( quot -- ) + >r T{ postgresql-db } db r> with-variable ; 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/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 8c957108e1..63bce0a8c3 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -112,7 +112,7 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; +FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; 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..08139610a0 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,51 +1,36 @@ 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 ; +: db-path "extra/db/sqlite/test.db" resource-path ; +: test.db db-path sqlite-db ; -[ ] [ [ test.db delete-file ] ignore-errors ] unit-test +[ ] [ [ db-path delete-file ] ignore-errors ] unit-test [ ] [ test.db [ "create table person (name varchar(30), country varchar(30))" sql-command "insert into person values('John', 'America')" sql-command "insert into person values('Jane', 'New Zealand')" sql-command - ] with-sqlite + ] with-db ] unit-test [ { { "John" "America" } { "Jane" "New Zealand" } } ] [ test.db [ "select * from person" sql-query - ] with-sqlite -] unit-test - -[ { { "John" "America" } } ] [ - test.db [ - "select * from person where name = :name and country = :country" - [ - { { ":name" "Jane" TEXT } { ":country" "New Zealand" TEXT } } - over do-bound-query - - { { "Jane" "New Zealand" } } = - [ "test fails" throw ] unless - - { { ":name" "John" TEXT } { ":country" "America" TEXT } } - swap do-bound-query - ] with-disposal - ] with-sqlite + ] with-db ] unit-test [ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ] -[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test [ ] [ test.db [ "insert into person(name, country) values('Jimmy', 'Canada')" sql-command - ] with-sqlite + ] with-db ] unit-test [ @@ -54,7 +39,7 @@ IN: temporary { "2" "Jane" "New Zealand" } { "3" "Jimmy" "Canada" } } -] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +] [ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test [ test.db [ @@ -63,13 +48,13 @@ IN: temporary "insert into person(name, country) values('Jose', 'Mexico')" sql-command "oops" throw ] with-transaction - ] with-sqlite + ] with-db ] must-fail [ 3 ] [ test.db [ "select * from person" sql-query length - ] with-sqlite + ] with-db ] unit-test [ @@ -81,11 +66,11 @@ IN: temporary "insert into person(name, country) values('Jose', 'Mexico')" sql-command ] with-transaction - ] with-sqlite + ] with-db ] unit-test [ 5 ] [ test.db [ "select * from person" sql-query length - ] with-sqlite + ] with-db ] unit-test diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 4eabfc2ecd..62f5717c84 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 + ] if + ";" 0% + ] 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/sqlite/test.db b/extra/db/sqlite/test.db new file mode 100644 index 0000000000..e483c47cea Binary files /dev/null and b/extra/db/sqlite/test.db differ 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..d61fe8135e 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 -- tuples ) + 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/delegate/delegate.factor b/extra/delegate/delegate.factor index 667805dcc3..654d096b26 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -39,7 +39,8 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ method-def spin define-method ] [ 3drop ] if + [ "method-def" word-prop spin define-method ] + [ 3drop ] if ] 2curry each ; : MIMIC: 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 index f0c5289dd9..3b65466225 100755 --- 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 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/http/server/responders/authors.txt b/extra/farkup/authors.factor old mode 100755 new mode 100644 similarity index 50% rename from extra/http/server/responders/authors.txt rename to extra/farkup/authors.factor index 1901f27a24..5674120196 --- a/extra/http/server/responders/authors.txt +++ b/extra/farkup/authors.factor @@ -1 +1,2 @@ +Doug Coleman Slava Pestov diff --git a/extra/farkup/authors.txt b/extra/farkup/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/farkup/authors.txt @@ -0,0 +1 @@ +Doug Coleman 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/fry-tests.factor b/extra/fry/fry-tests.factor index fd21a4a4cd..4d2c9fe1c8 100755 --- a/extra/fry/fry-tests.factor +++ b/extra/fry/fry-tests.factor @@ -1,42 +1,46 @@ -IN: temporary -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 "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 +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 index 0b0b91f0d0..f8d49af163 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -1,39 +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 ; -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 [ - >r fry [ [ dip ] curry ] r> trivial-fry [ compose ] compose 3compose - ] [ - trivial-fry - ] if* ; - -: '[ \ ] parse-until fry over push-all ; parsing +! 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/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 11ff697049..3bbd2d03da 100755 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -35,6 +35,17 @@ SYMBOL: current-action SYMBOL: validators-errored SYMBOL: validation-errors +: build-url ( str query-params -- newstr ) + [ + over % + dup assoc-empty? [ + 2drop + ] [ + CHAR: ? rot member? "&" "?" ? % + assoc>query % + ] if + ] "" make ; + : action-link ( query action -- url ) [ "/responder/" % @@ -204,4 +215,3 @@ SYMBOL: model ] [ drop ] if ; - diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 579e5a607e..cf03fee6b1 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -1,5 +1,5 @@ USING: assocs calendar init kernel math.parser -namespaces random boxes alarms ; +namespaces random boxes alarms combinators.lib ; IN: furnace.sessions SYMBOL: sessions @@ -11,9 +11,8 @@ SYMBOL: sessions ] "furnace.sessions" add-init-hook : new-session-id ( -- str ) - 4 big-random >hex - dup sessions get-global key? - [ drop new-session-id ] when ; + [ 4 big-random >hex ] + [ sessions get-global key? not ] generate ; TUPLE: session id namespace alarm user-agent ; diff --git a/extra/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 f12e0180b1..178b7a5d35 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -86,7 +86,8 @@ concurrency.futures concurrency.locks concurrency.semaphores concurrency.count-downs -concurrency.exchangers ; +concurrency.exchangers +concurrency.flags ; ARTICLE: "concurrency" "Concurrency" "Factor supports a variety of concurrency abstractions, however they are mostly used to multiplex input/output operations since the thread scheduling is co-operative and only one CPU is used at a time." @@ -106,6 +107,7 @@ $nl { $subsection "concurrency.semaphores" } { $subsection "concurrency.count-downs" } { $subsection "concurrency.exchangers" } +{ $subsection "concurrency.flags" } "Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ; ARTICLE: "objects" "Objects" @@ -169,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" @@ -196,6 +199,7 @@ ARTICLE: "tools" "Developer tools" "Debugging tools:" { $subsection "tools.annotations" } { $subsection "tools.test" } +{ $subsection "tools.threads" } "Performance tools:" { $subsection "tools.memory" } { $subsection "profiling" } 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/markup/markup.factor b/extra/help/markup/markup.factor old mode 100644 new mode 100755 index 5f1b027823..32e29db7db --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -144,24 +144,36 @@ M: f print-element drop ; : $link ( element -- ) first ($link) ; -: ($subsection) ( object -- ) - [ article-title ] keep >link write-object ; +: ($long-link) ( object -- ) + dup article-title swap >link write-link ; -: $subsection ( element -- ) +: ($subsection) ( element quot -- ) [ subsection-style get [ bullet get write bl - first ($subsection) + call ] with-style - ] ($block) ; + ] ($block) ; inline -: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ; +: $subsection ( element -- ) + [ first ($long-link) ] ($subsection) ; -: $vocab-link ( element -- ) first ($vocab-link) ; +: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ; + +: $vocab-subsection ( element -- ) + [ + first2 dup vocab-help dup [ + 2nip ($long-link) + ] [ + drop ($vocab-link) + ] if + ] ($subsection) ; + +: $vocab-link ( element -- ) first dup ($vocab-link) ; : $vocabulary ( element -- ) first word-vocabulary [ - "Vocabulary" $heading nl ($vocab-link) + "Vocabulary" $heading nl dup ($vocab-link) ] when* ; : textual-list ( seq quot -- ) 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/authors.txt b/extra/http/basic-authentication/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/extra/http/basic-authentication/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/http/basic-authentication/basic-authentication-docs.factor b/extra/http/basic-authentication/basic-authentication-docs.factor deleted file mode 100644 index 68d6e6bf1d..0000000000 --- a/extra/http/basic-authentication/basic-authentication-docs.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax crypto.sha2 ; -IN: http.basic-authentication - -HELP: realms -{ $description - "A hashtable mapping a basic authentication realm (a string) " - "to either a quotation or a hashtable. The quotation has " - "stack effect ( username sha-256-string -- bool ). It " - "is expected to perform the user authentication when called." $nl - "If the realm maps to a hashtable then the hashtable should be a " - "mapping of usernames to sha-256 hashed passwords." $nl - "If the 'realms' variable does not exist in the current scope then " - "authentication will always fail." } -{ $see-also add-realm with-basic-authentication } ; - -HELP: add-realm -{ $values - { "data" "a quotation or a hashtable" } { "name" "a string" } } -{ $description - "Adds the authentication data to the " { $link realms } ". 'data' can be " - "a quotation with stack effect ( username sha-256-string -- bool ) or " - "a hashtable mapping username strings to sha-256-string passwords." } -{ $examples - { $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" } - { $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" } -} -{ $see-also with-basic-authentication realms } ; - -HELP: with-basic-authentication -{ $values - { "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } } -{ $description - "Checks if the HTTP request has the correct authorisation headers " - "for basic authentication within the named realm. If the headers " - "are not present then a '401' HTTP response results from the " - "request, otherwise the quotation is called." } -{ $examples -{ $code "\"my-realm\" [\n serving-html \"Success!\" write\n] with-basic-authentication" } } -{ $see-also add-realm realms } - ; - -ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication" -"The Basic Authentication system provides a simple browser based " -"authentication method to web applications. When the browser requests " -"a resource protected with basic authentication the server responds with " -"a '401' response code which means the user is unauthorized." -$nl -"When the browser receives this it prompts the user for a username and " -"password. This is sent back to the server in a special HTTP header. The " -"server then checks this against its authentication information and either " -"accepts or rejects the users request." -$nl -"Authentication is split up into " { $link realms } ". Each realm can have " -"a different database of username and password information. A responder can " -"require basic authentication by using the " { $link with-basic-authentication } " word." -$nl -"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "." -$nl -"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word." -$nl -"Note that Basic Authentication itself is insecure in that it " -"sends the username and password as clear text (although it is " -"base64 encoded this is not much help). To prevent eavesdropping " -"it is best to use Basic Authentication with SSL." ; - -IN: http.basic-authentication -ABOUT: { "http-authentication" "basic-authentication" } diff --git a/extra/http/basic-authentication/basic-authentication-tests.factor b/extra/http/basic-authentication/basic-authentication-tests.factor deleted file mode 100644 index 318123b0b4..0000000000 --- a/extra/http/basic-authentication/basic-authentication-tests.factor +++ /dev/null @@ -1,66 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel crypto.sha2 http.basic-authentication tools.test - namespaces base64 sequences ; - -{ t } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ t } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - f realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test diff --git a/extra/http/basic-authentication/basic-authentication.factor b/extra/http/basic-authentication/basic-authentication.factor deleted file mode 100644 index e15ba9db16..0000000000 --- a/extra/http/basic-authentication/basic-authentication.factor +++ /dev/null @@ -1,65 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel base64 http.server crypto.sha2 namespaces assocs - quotations hashtables combinators splitting sequences - http.server.responders io html.elements ; -IN: http.basic-authentication - -! 'realms' is a hashtable mapping a realm (a string) to -! either a quotation or a hashtable. The quotation -! has stack effect ( username sha-256-string -- bool ). -! It should perform the user authentication. 'sha-256-string' -! is the plain text password provided by the user passed through -! 'string>sha-256-string'. If 'realms' maps to a hashtable then -! it is a mapping of usernames to sha-256 hashed passwords. -! -! 'realms' can be set on a per vhost basis in the vhosts -! table. -! -! If there are no realms then authentication fails. -SYMBOL: realms - -: add-realm ( data name -- ) - #! Add the named realm to the realms table. - #! 'data' should be a hashtable or a quotation. - realms get [ H{ } clone dup realms set ] unless* - set-at ; - -: user-authorized? ( username password realm -- bool ) - realms get dup [ - at { - { [ dup quotation? ] [ call ] } - { [ dup hashtable? ] [ swapd at = ] } - { [ t ] [ 3drop f ] } - } cond - ] [ - 3drop drop f - ] if ; - -: authorization-ok? ( realm header -- bool ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. - dup [ - " " split dup first "Basic" = [ - second base64> ":" split first2 string>sha-256-string rot - user-authorized? - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; - -: authentication-error ( realm -- ) - "401 Unauthorized" response - "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header - - "Username or Password is invalid" write - ; - -: with-basic-authentication ( realm quot -- ) - #! 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? - [ nip call ] [ drop authentication-error ] if ; diff --git a/extra/http/basic-authentication/summary.txt b/extra/http/basic-authentication/summary.txt deleted file mode 100644 index 60cef7e630..0000000000 --- a/extra/http/basic-authentication/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP Basic Authentication implementation diff --git a/extra/http/basic-authentication/tags.txt b/extra/http/basic-authentication/tags.txt deleted file mode 100644 index c0772185a0..0000000000 --- a/extra/http/basic-authentication/tags.txt +++ /dev/null @@ -1 +0,0 @@ -web diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index d2fb719acd..4fca1697a5 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -1,14 +1,28 @@ -USING: http.client tools.test ; +USING: http.client http.client.private http tools.test +tuple-syntax namespaces ; [ "localhost" 80 ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test -[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test -[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test -[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test -[ 404 ] [ "404 File not found" parse-response ] unit-test -[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test -[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test +[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test +[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test [ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test + +[ + TUPLE{ request + method: "GET" + host: "www.apple.com" + path: "/index.html" + port: 80 + version: "1.1" + cookies: V{ } + } +] [ + [ + "http://www.apple.com/index.html" + + request-with-url + ] with-scope +] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 99ba045019..1c408e44e3 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,64 +2,72 @@ ! 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 calendar ; +splitting continuations calendar vectors hashtables +accessors ; IN: http.client -: parse-host ( url -- host port ) - #! Extract the host name and port number from an HTTP URL. - ":" split1 [ string>number ] [ 80 ] if* ; - -SYMBOL: domain - -: parse-url ( url -- host resource ) - dup "https://" head? [ - "ssl not yet supported: " swap append throw - ] when "http://" ?head drop +: parse-url ( url -- resource host port ) + "http://" ?head [ "Only http:// supported" throw ] unless "/" split1 [ "/" swap append ] [ "/" ] if* - >r dup empty? [ drop domain get ] [ dup domain set ] if r> ; + swap parse-host ; -: parse-response ( line -- code ) - "HTTP/" ?head [ " " split1 nip ] when - " " split1 drop string>number [ - "Premature end of stream" throw - ] unless* ; +r >>path r> dup [ query>assoc ] when >>query ; -: crlf "\r\n" write ; +! This is all pretty complex because it needs to handle +! HTTP redirects, which might be absolute or relative +: request-with-url ( url request -- request ) + clone dup "request" set + swap parse-url >r >r store-path r> >>host r> >>port ; -: http-request ( host resource method -- ) - write bl write " HTTP/1.0" write crlf - "Host: " write write crlf ; +DEFER: (http-request) -: get-request ( host resource -- ) - "GET" http-request crlf ; +: absolute-redirect ( url -- request ) + "request" get request-with-url ; -DEFER: http-get-stream +: relative-redirect ( path -- request ) + "request" get swap store-path ; -: do-redirect ( code headers stream -- code headers stream ) - #! Should this support Location: headers that are - #! relative URLs? - pick 100 /i 3 = [ - dispose "location" swap peek-at nip http-get-stream - ] when ; +: do-redirect ( response -- response stream ) + dup response-code 300 399 between? [ + header>> "location" swap at + dup "http://" head? [ + absolute-redirect + ] [ + relative-redirect + ] if "GET" >>method (http-request) + ] [ + stdio get + ] if ; -: default-timeout 1 minutes over set-timeout ; +: (http-request) ( request -- response stream ) + dup host>> over port>> stdio set + dup "r" set-global write-request flush read-response + do-redirect ; -: http-get-stream ( url -- code headers stream ) - #! Opens a stream for reading from an HTTP URL. - parse-url over parse-host [ - [ [ get-request read-response ] with-stream* ] keep - default-timeout - ] [ ] [ dispose ] cleanup do-redirect ; +PRIVATE> + +: http-request ( url request -- response stream ) + [ + request-with-url + [ + (http-request) + 1 minutes over set-timeout + ] [ ] [ stdio get dispose ] cleanup + ] with-scope ; + +: ( -- request ) + "GET" >>method ; + +: http-get-stream ( url -- response stream ) + http-request ; : success? ( code -- ? ) 200 = ; -: check-response ( code headers stream -- stream ) - nip swap success? +: check-response ( response stream -- stream ) + swap code>> success? [ dispose "HTTP download failed" throw ] unless ; : http-get ( url -- string ) @@ -70,23 +78,18 @@ DEFER: http-get-stream : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get-stream check-response - r> stream-copy ; + swap http-get-stream check-response + [ swap stream-copy ] with-disposal ; : download ( url -- ) dup download-name download-to ; -: post-request ( content-type content host resource -- ) - #! Note: It is up to the caller to url encode the content if - #! it is required according to the content-type. - "POST" http-request [ - "Content-Length: " write length number>string write crlf - "Content-Type: " write url-encode write crlf - crlf - ] keep write ; +: ( content-type content -- request ) + + "POST" >>method + swap >>post-data + swap >>post-data-type ; -: http-post ( content-type content url -- code headers string ) - #! Make a POST request. The content is URL encoded for you. - parse-url over parse-host [ - post-request flush read-response stdio get contents - ] with-stream ; +: http-post ( content-type content url -- response string ) + #! The content is URL encoded for you. + -rot url-encode http-request contents ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor old mode 100644 new mode 100755 index 5146502644..b706f34d13 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,5 +1,6 @@ -USING: http tools.test ; -IN: temporary +USING: http tools.test multiline tuple-syntax +io.streams.string kernel arrays splitting sequences ; +IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test @@ -16,3 +17,113 @@ IN: temporary [ "%20%21%20" ] [ " ! " url-encode ] unit-test [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test + +[ "/" ] [ "http://foo.com" url>path ] unit-test +[ "/" ] [ "http://foo.com/" url>path ] unit-test +[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test +[ "/bar" ] [ "/bar" url>path ] unit-test + +STRING: read-request-test-1 +GET http://foo/bar HTTP/1.1 +Some-Header: 1 +Some-Header: 2 +Content-Length: 4 + +blah +; + +[ + TUPLE{ request + port: 80 + method: "GET" + path: "/bar" + query: H{ } + version: "1.1" + header: H{ { "some-header" "1; 2" } { "content-length" "4" } } + post-data: "blah" + cookies: V{ } + } +] [ + read-request-test-1 [ + read-request + ] with-string-reader +] unit-test + +STRING: read-request-test-1' +GET /bar HTTP/1.1 +content-length: 4 +some-header: 1; 2 + +blah +; + +read-request-test-1' 1array [ + read-request-test-1 + [ read-request ] with-string-reader + [ write-request ] with-string-writer + ! normalize crlf + string-lines "\n" join +] unit-test + +STRING: read-request-test-2 +HEAD http://foo/bar HTTP/1.1 +Host: www.sex.com +; + +[ + TUPLE{ request + port: 80 + method: "HEAD" + path: "/bar" + query: H{ } + version: "1.1" + header: H{ { "host" "www.sex.com" } } + host: "www.sex.com" + cookies: V{ } + } +] [ + read-request-test-2 [ + read-request + ] with-string-reader +] unit-test + +STRING: read-response-test-1 +HTTP/1.1 404 not found +Content-Type: text/html + +blah +; + +[ + TUPLE{ response + version: "1.1" + code: 404 + message: "not found" + header: H{ { "content-type" "text/html" } } + cookies: V{ } + } +] [ + read-response-test-1 + [ read-response ] with-string-reader +] unit-test + + +STRING: read-response-test-1' +HTTP/1.1 404 not found +content-type: text/html + + +; + +read-response-test-1' 1array [ + read-response-test-1 + [ read-response ] with-string-reader + [ write-response ] with-string-writer + ! normalize crlf + string-lines "\n" join +] unit-test + +[ t ] [ + "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT" + dup parse-cookies unparse-cookies = +] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 5c4dae94c7..35fe3ce544 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,19 +1,13 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io kernel math namespaces math.parser assocs -sequences strings splitting ascii io.encodings.utf8 assocs.lib -namespaces unicode.case ; +USING: hashtables io io.streams.string kernel math namespaces +math.parser assocs sequences strings splitting ascii +io.encodings.utf8 namespaces unicode.case combinators +vectors sorting new-slots accessors calendar calendar.format +quotations arrays ; IN: http -: header-line ( line -- ) - ": " split1 dup [ swap >lower insert ] [ 2drop ] if ; - -: (read-header) ( -- ) - readln dup - empty? [ drop ] [ header-line (read-header) ] if ; - -: read-header ( -- hash ) - [ (read-header) ] H{ } make-assoc ; +: http-port 80 ; inline : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without @@ -23,7 +17,7 @@ IN: http over digit? or swap "/_-." member? or ; foldable -: push-utf8 ( string -- ) +: push-utf8 ( ch -- ) 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; : url-encode ( str -- str ) @@ -58,17 +52,375 @@ IN: http : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make decode-utf8 ; -: hash>query ( hash -- str ) +: crlf "\r\n" write ; + +: add-header ( value key assoc -- ) + [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ; + +: header-line ( line -- ) + dup first blank? [ + [ blank? ] left-trim + "last-header" get + "header" get + add-header + ] [ + ": " split1 dup [ + swap >lower dup "last-header" set + "header" get add-header + ] [ + 2drop + ] if + ] if ; + +: read-header-line ( -- ) + readln dup + empty? [ drop ] [ header-line read-header-line ] if ; + +: read-header ( -- assoc ) + H{ } clone [ + "header" [ read-header-line ] with-variable + ] keep ; + +: header-value>string ( value -- string ) + { + { [ dup number? ] [ number>string ] } + { [ dup timestamp? ] [ timestamp>http-string ] } + { [ dup string? ] [ ] } + { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } + } cond ; + +: check-header-string ( str -- str ) + #! http://en.wikipedia.org/wiki/HTTP_Header_Injection + dup [ "\r\n" member? ] contains? + [ "Header injection attack" throw ] when ; + +: write-header ( assoc -- ) + >alist sort-keys [ + swap url-encode write ": " write + header-value>string check-header-string write crlf + ] assoc-each crlf ; + +: query>assoc ( query -- assoc ) + dup [ + "&" split [ + "=" split1 [ dup [ url-decode ] when ] 2apply + ] H{ } map>assoc + ] when ; + +: assoc>query ( hash -- str ) [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map "&" join ; -: build-url ( str query-params -- newstr ) +TUPLE: cookie name value path domain expires http-only ; + +: ( value name -- cookie ) + cookie construct-empty + swap >>name swap >>value ; + +: parse-cookies ( string -- seq ) [ - over % - dup assoc-empty? [ - 2drop - ] [ - CHAR: ? rot member? "&" "?" ? % - hash>query % - ] if - ] "" make ; + f swap + + ";" split [ + [ blank? ] trim "=" split1 swap >lower { + { "expires" [ >>expires ] } + { "domain" [ >>domain ] } + { "path" [ >>path ] } + { "httponly" [ drop t >>http-only ] } + { "" [ drop ] } + [ dup , nip ] + } case + ] each + + drop + ] { } make ; + +: (unparse-cookie) ( key value -- ) + { + { [ dup f eq? ] [ 2drop ] } + { [ dup t eq? ] [ drop , ] } + { [ t ] [ "=" swap 3append , ] } + } cond ; + +: unparse-cookie ( cookie -- strings ) + [ + dup name>> >lower over value>> (unparse-cookie) + "path" over path>> (unparse-cookie) + "domain" over domain>> (unparse-cookie) + "expires" over expires>> (unparse-cookie) + "httponly" over http-only>> (unparse-cookie) + drop + ] { } make ; + +: unparse-cookies ( cookies -- string ) + [ unparse-cookie ] map concat "; " join ; + +TUPLE: request +host +port +method +path +query +version +header +post-data +post-data-type +cookies ; + +: + request construct-empty + "1.1" >>version + http-port >>port + H{ } clone >>query + V{ } clone >>cookies ; + +: query-param ( request key -- value ) + swap query>> at ; + +: set-query-param ( request value key -- request ) + pick query>> set-at ; + +: chop-hostname ( str -- str' ) + CHAR: / over index over length or tail + dup empty? [ drop "/" ] when ; + +: url>path ( url -- path ) + #! Technically, only proxies are meant to support hostnames + #! in HTTP requests, but IE sends these sometimes so we + #! just chop the hostname part. + url-decode "http://" ?head [ chop-hostname ] when ; + +: read-method ( request -- request ) + " " read-until [ "Bad request: method" throw ] unless + >>method ; + +: read-query ( request -- request ) + " " read-until + [ "Bad request: query params" throw ] unless + query>assoc >>query ; + +: read-url ( request -- request ) + " ?" read-until { + { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] } + { CHAR: ? [ url>path >>path read-query ] } + [ "Bad request: URL" throw ] + } case ; + +: parse-version ( string -- version ) + "HTTP/" ?head [ "Bad version" throw ] unless + dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; + +: read-request-version ( request -- request ) + readln [ CHAR: \s = ] left-trim + parse-version + >>version ; + +: read-request-header ( request -- request ) + read-header >>header ; + +: header ( request/response key -- value ) + swap header>> at ; + +SYMBOL: max-post-request + +1024 256 * max-post-request set-global + +: content-length ( header -- n ) + "content-length" swap at string>number dup [ + dup max-post-request get > [ + "content-length > max-post-request" throw + ] when + ] when ; + +: read-post-data ( request -- request ) + dup header>> content-length [ read >>post-data ] when* ; + +: parse-host ( string -- host port ) + "." ?tail drop ":" split1 + [ string>number ] [ http-port ] if* ; + +: extract-host ( request -- request ) + dup "host" header parse-host >r >>host r> >>port ; + +: extract-post-data-type ( request -- request ) + dup "content-type" header >>post-data-type ; + +: extract-cookies ( request -- request ) + dup "cookie" header [ parse-cookies >>cookies ] when* ; + +: read-request ( -- request ) + + read-method + read-url + read-request-version + read-request-header + read-post-data + extract-host + extract-post-data-type + extract-cookies ; + +: write-method ( request -- request ) + dup method>> write bl ; + +: write-url ( request -- request ) + dup path>> url-encode write + dup query>> dup assoc-empty? [ drop ] [ + "?" write + assoc>query write + ] if ; + +: write-request-url ( request -- request ) + write-url bl ; + +: write-version ( request -- request ) + "HTTP/" write dup request-version write crlf ; + +: write-request-header ( request -- request ) + dup header>> >hashtable + over host>> [ "host" pick set-at ] when* + over post-data>> [ length "content-length" pick set-at ] when* + over post-data-type>> [ "content-type" pick set-at ] when* + over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* + write-header ; + +: write-post-data ( request -- request ) + dup post-data>> [ write ] when* ; + +: write-request ( request -- ) + write-method + write-request-url + write-version + write-request-header + write-post-data + flush + drop ; + +: request-url ( request -- url ) + [ + dup host>> [ + "http://" write + dup host>> url-encode write + ":" write + dup port>> number>string write + ] when + dup path>> "/" head? [ "/" write ] unless + write-url + drop + ] with-string-writer ; + +: set-header ( request/response value key -- request/response ) + pick header>> set-at ; + +GENERIC: write-response ( response -- ) + +GENERIC: write-full-response ( request response -- ) + +TUPLE: response +version +code +message +header +cookies +body ; + +: + response construct-empty + "1.1" >>version + H{ } clone >>header + "close" "connection" set-header + now timestamp>http-string "date" set-header + V{ } clone >>cookies ; + +: read-response-version + " \t" read-until + [ "Bad response: version" throw ] unless + parse-version + >>version ; + +: read-response-code + " \t" read-until [ "Bad response: code" throw ] unless + string>number [ "Bad response: code" throw ] unless* + >>code ; + +: read-response-message + readln >>message ; + +: read-response-header + read-header >>header + dup "set-cookie" header [ parse-cookies >>cookies ] when* ; + +: read-response ( -- response ) + + read-response-version + read-response-code + read-response-message + read-response-header ; + +: write-response-version ( response -- response ) + "HTTP/" write + dup version>> write bl ; + +: write-response-code ( response -- response ) + dup code>> number>string write bl ; + +: write-response-message ( response -- response ) + dup message>> write crlf ; + +: write-response-header ( response -- response ) + dup header>> clone + over cookies>> f like + [ unparse-cookies "set-cookie" pick set-at ] when* + write-header ; + +: write-response-body ( response -- response ) + dup body>> { + { [ dup not ] [ drop ] } + { [ dup string? ] [ write ] } + { [ dup callable? ] [ call ] } + { [ t ] [ stdio get stream-copy ] } + } cond ; + +M: response write-response ( respose -- ) + write-response-version + write-response-code + write-response-message + write-response-header + flush + drop ; + +M: response write-full-response ( request response -- ) + dup write-response + swap method>> "HEAD" = [ write-response-body ] unless ; + +: set-content-type ( request/response content-type -- request/response ) + "content-type" set-header ; + +: get-cookie ( request/response name -- cookie/f ) + >r cookies>> r> [ swap name>> = ] curry find nip ; + +: delete-cookie ( request/response name -- ) + over cookies>> >r get-cookie r> delete ; + +: put-cookie ( request/response cookie -- request/response ) + [ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep + over cookies>> push ; + +TUPLE: raw-response +version +code +message +body ; + +: ( -- response ) + raw-response construct-empty + "1.1" >>version ; + +M: raw-response write-response ( respose -- ) + write-response-version + write-response-code + write-response-message + write-response-body + drop ; + +M: raw-response write-full-response ( response -- ) + write-response nip ; diff --git a/extra/http/mime/mime.factor b/extra/http/mime/mime.factor old mode 100644 new mode 100755 index 3365127d87..f9097ecce3 --- a/extra/http/mime/mime.factor +++ b/extra/http/mime/mime.factor @@ -30,5 +30,6 @@ H{ { "pdf" "application/pdf" } { "factor" "text/plain" } + { "cgi" "application/x-cgi-script" } { "fhtml" "application/x-factor-server-page" } } "mime-types" set-global diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor new file mode 100644 index 0000000000..2d74e92e86 --- /dev/null +++ b/extra/http/server/actions/actions-tests.factor @@ -0,0 +1,37 @@ +IN: http.server.actions.tests +USING: http.server.actions tools.test math math.parser +multiline namespaces http io.streams.string http.server +sequences ; + +[ + ] +{ { "a" [ string>number ] } { "b" [ string>number ] } } +"GET" "action-1" set + +STRING: action-request-test-1 +GET http://foo/bar?a=12&b=13 HTTP/1.1 + +blah +; + +[ 25 ] [ + action-request-test-1 [ read-request ] with-string-reader + "/blah" + "action-1" get call-responder +] unit-test + +[ "X" concat append ] +{ { +path+ [ ] } { "xxx" [ string>number ] } } +"POST" "action-2" set + +STRING: action-request-test-2 +POST http://foo/bar/baz HTTP/1.1 +content-length: 5 + +xxx=4 +; + +[ "/blahXXXX" ] [ + action-request-test-2 [ read-request ] with-string-reader + "/blah" + "action-2" get call-responder +] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor new file mode 100755 index 0000000000..feb16a4488 --- /dev/null +++ b/extra/http/server/actions/actions.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots sequences kernel assocs combinators +http.server http hashtables namespaces ; +IN: http.server.actions + +SYMBOL: +path+ + +TUPLE: action quot params method ; + +C: action + +: extract-params ( request path -- assoc ) + >r dup method>> { + { "GET" [ query>> ] } + { "POST" [ post-data>> query>assoc ] } + } case r> +path+ associate union ; + +: push-params ( assoc action -- ... ) + params>> [ first2 >r swap at r> call ] with each ; + +M: action call-responder ( request path action -- response ) + pick request set + pick method>> over method>> = [ + >r extract-params r> + [ push-params ] keep + quot>> call + ] [ + 3drop <400> + ] if ; diff --git a/extra/http/server/authentication/basic/basic.factor b/extra/http/server/authentication/basic/basic.factor new file mode 100755 index 0000000000..b6dbed4b62 --- /dev/null +++ b/extra/http/server/authentication/basic/basic.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.authentication.basic +USING: accessors new-slots quotations assocs kernel splitting +base64 crypto.sha2 html.elements io combinators http.server +http sequences ; + +! 'users' is a quotation or an assoc. The quotation +! has stack effect ( sha-256-string username -- ? ). +! It should perform the user authentication. 'sha-256-string' +! is the plain text password provided by the user passed through +! 'string>sha-256-string'. If 'users' is an assoc then +! it is a mapping of usernames to sha-256 hashed passwords. +TUPLE: realm responder name users ; + +C: realm + +: user-authorized? ( password username realm -- ? ) + users>> { + { [ dup callable? ] [ call ] } + { [ dup assoc? ] [ at = ] } + } cond ; + +: authorization-ok? ( realm header -- bool ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split1 swap "Basic" = [ + base64> ":" split1 string>sha-256-string + spin user-authorized? + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: <401> ( realm -- response ) + 401 "Unauthorized" + "Basic realm=\"" rot name>> "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>body ; + +M: realm call-responder ( request path realm -- response ) + pick "authorization" header dupd authorization-ok? + [ responder>> call-responder ] [ 2nip <401> ] if ; diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor new file mode 100755 index 0000000000..fd2e8f8ad7 --- /dev/null +++ b/extra/http/server/callbacks/callbacks.factor @@ -0,0 +1,135 @@ +! Copyright (C) 2004 Chris Double. +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: html http http.server io kernel math namespaces +continuations calendar sequences assocs new-slots hashtables +accessors arrays alarms quotations combinators ; +IN: http.server.callbacks + +SYMBOL: responder + +TUPLE: callback-responder responder callbacks ; + +: ( responder -- responder' ) + #! A continuation responder is a special type of session + #! manager. However it works entirely differently from + #! the URL and cookie session managers. + H{ } clone callback-responder construct-boa ; + +TUPLE: callback cont quot expires alarm responder ; + +: timeout 20 minutes ; + +: timeout-callback ( callback -- ) + dup alarm>> cancel-alarm + dup responder>> callbacks>> delete-at ; + +: touch-callback ( callback -- ) + dup expires>> [ + dup alarm>> [ cancel-alarm ] when* + dup [ timeout-callback ] curry timeout later >>alarm + ] when drop ; + +: ( cont quot expires? -- callback ) + [ f responder get callback construct-boa ] keep + [ dup touch-callback ] when ; + +: invoke-callback ( request exit-cont callback -- response ) + [ quot>> 3array ] keep cont>> continue-with ; + +: register-callback ( cont quot expires? -- id ) + + responder get callbacks>> generate-key + [ responder get callbacks>> set-at ] keep ; + +SYMBOL: exit-continuation + +: exit-with exit-continuation get continue-with ; + +: forward-to-url ( url -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + request get swap exit-with ; + +: cont-id "factorcontid" ; + +: id>url ( id -- url ) + request get + swap cont-id associate >>query + request-url ; + +: forward-to-id ( id -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + id>url forward-to-url ; + +: restore-request ( pair -- ) + first3 >r exit-continuation set request set r> call ; + +: resume-page ( request page responder callback -- * ) + dup touch-callback + >r 2drop exit-continuation get + r> invoke-callback ; + +SYMBOL: post-refresh-get? + +: redirect-to-here ( -- ) + #! Force a redirect to the client browser so that the browser + #! goes to the current point in the code. This forces an URL + #! change on the browser so that refreshing that URL will + #! immediately run from this code point. This prevents the + #! "this request will issue a POST" warning from the browser + #! and prevents re-running the previous POST logic. This is + #! known as the 'post-refresh-get' pattern. + post-refresh-get? get [ + [ + [ ] t register-callback forward-to-id + ] callcc1 restore-request + ] [ + post-refresh-get? on + ] if ; + +SYMBOL: current-show + +: store-current-show ( -- ) + #! Store the current continuation in the variable 'current-show' + #! so it can be returned to later by 'quot-id'. Note that it + #! recalls itself when the continuation is called to ensure that + #! it resets its value back to the most recent show call. + [ current-show set f ] callcc1 + [ restore-request store-current-show ] when* ; + +: show-final ( quot -- * ) + >r redirect-to-here store-current-show + r> call exit-with ; inline + +M: callback-responder call-responder + [ + [ + exit-continuation set + dup responder set + pick request set + pick cont-id query-param over callbacks>> at [ + resume-page + ] [ + responder>> call-responder + "Continuation responder pages must use show-final" throw + ] if* + ] with-scope + ] callcc1 >r 3drop r> ; + +: show-page ( quot -- ) + >r redirect-to-here store-current-show r> + [ + [ ] register-callback + with-scope + exit-with + ] callcc1 restore-request ; inline + +: quot-id ( quot -- id ) + current-show get swap t register-callback ; + +: quot-url ( quot -- url ) + quot-id id>url ; diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor new file mode 100755 index 0000000000..9950a9a4a4 --- /dev/null +++ b/extra/http/server/cgi/cgi.factor @@ -0,0 +1,65 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel assocs io.files combinators +arrays io.launcher io http.server.static http.server +http accessors sequences strings math.parser ; +IN: http.server.cgi + +: post? request get method>> "POST" = ; + +: cgi-variables ( script-path -- assoc ) + #! This needs some work. + [ + "CGI/1.0" "GATEWAY_INTERFACE" set + "HTTP/" request get version>> append "SERVER_PROTOCOL" set + "Factor" "SERVER_SOFTWARE" set + + dup "PATH_TRANSLATED" set + "SCRIPT_FILENAME" set + + request get path>> "SCRIPT_NAME" set + + request get host>> "SERVER_NAME" set + request get port>> number>string "SERVER_PORT" set + "" "PATH_INFO" set + "" "REMOTE_HOST" set + "" "REMOTE_ADDR" set + "" "AUTH_TYPE" set + "" "REMOTE_USER" set + "" "REMOTE_IDENT" set + + request get method>> "REQUEST_METHOD" set + request get query>> assoc>query "QUERY_STRING" set + request get "cookie" header "HTTP_COOKIE" set + + request get "user-agent" header "HTTP_USER_AGENT" set + request get "accept" header "HTTP_ACCEPT" set + + post? [ + request get post-data-type>> "CONTENT_TYPE" set + request get post-data>> length number>string "CONTENT_LENGTH" set + ] when + ] H{ } make-assoc ; + +: cgi-descriptor ( name -- desc ) + [ + dup 1array +arguments+ set + cgi-variables +environment+ set + ] H{ } make-assoc ; + +: serve-cgi ( name -- response ) + + 200 >>code + "CGI output follows" >>message + swap [ + stdio get swap cgi-descriptor [ + post? [ + request get post-data>> write flush + ] when + stdio get swap (stream-copy) + ] with-stream + ] curry >>body ; + +: enable-cgi ( responder -- responder ) + [ serve-cgi ] "application/x-cgi-script" + pick special>> set-at ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor new file mode 100755 index 0000000000..4baee5f02b --- /dev/null +++ b/extra/http/server/db/db.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db http.server kernel new-slots accessors +continuations namespaces ; +IN: http.server.db + +TUPLE: db-persistence responder db params ; + +C: db-persistence + +M: db-persistence call-responder + dup db>> over params>> make-db dup db-open [ + db set responder>> call-responder + ] with-disposal ; diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor deleted file mode 100755 index e4e0e257c4..0000000000 --- a/extra/http/server/responders/responders.factor +++ /dev/null @@ -1,225 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs hashtables html html.elements splitting -http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib logging ; - -IN: http.server.responders - -! Variables -SYMBOL: vhosts -SYMBOL: responders - -: >header ( value key -- multi-hash ) - H{ } clone [ insert-at ] keep ; - -: print-header ( alist -- ) - [ swap write ": " write print ] multi-assoc-each nl ; - -: response ( msg -- ) "HTTP/1.0 " write print ; - -: error-body ( error -- ) -

write

; - -: error-head ( error -- ) - response - H{ { "Content-Type" V{ "text/html" } } } print-header nl ; - -: httpd-error ( error -- ) - #! This must be run from handle-request - dup error-head - "head" "method" get = [ drop ] [ error-body ] if ; - -\ httpd-error ERROR add-error-logging - -: bad-request ( -- ) - [ - ! Make httpd-error print a body - "get" "method" set - "400 Bad request" httpd-error - ] with-scope ; - -: serving-content ( mime -- ) - "200 Document follows" response - "Content-Type" >header print-header ; - -: serving-html "text/html" serving-content ; - -: serve-html ( quot -- ) - serving-html with-html-stream ; - -: serving-text "text/plain" serving-content ; - -: redirect ( to response -- ) - response "Location" >header print-header ; - -: permanent-redirect ( to -- ) - "301 Moved Permanently" redirect ; - -: temporary-redirect ( to -- ) - "307 Temporary Redirect" redirect ; - -: directory-no/ ( -- ) - [ - "request" get % CHAR: / , - "raw-query" get [ CHAR: ? , % ] when* - ] "" make permanent-redirect ; - -: query>hash ( query -- hash ) - dup [ - "&" split [ - "=" split1 [ dup [ url-decode ] when ] 2apply 2array - ] map - ] when >hashtable ; - -SYMBOL: max-post-request - -1024 256 * max-post-request set-global - -: content-length ( header -- n ) - "Content-Length" swap at string>number dup [ - dup max-post-request get > [ - "Content-Length > max-post-request" throw - ] when - ] when ; - -: read-post-request ( header -- str hash ) - content-length [ read dup query>hash ] [ f f ] if* ; - -LOG: log-headers DEBUG - -: interesting-headers ( assoc -- string ) - [ - [ - drop { - "user-agent" - "referer" - "x-forwarded-for" - "host" - } member? - ] assoc-subset [ - ": " swap 3append % "\n" % - ] multi-assoc-each - ] "" make ; - -: prepare-url ( url -- url ) - #! This is executed in the with-request namespace. - "?" split1 - dup "raw-query" set query>hash "query" set - dup "request" set ; - -: prepare-header ( -- ) - read-header - dup "header" set - dup interesting-headers log-headers - read-post-request "response" set "raw-response" set ; - -! Responders are called in a new namespace with these -! variables: - -! - method -- one of get, post, or head. -! - request -- the entire URL requested, including responder -! name -! - responder-url -- the component of the URL for the responder -! - raw-query -- raw query string -! - query -- a hashtable of query parameters, eg -! foo.bar?a=b&c=d becomes -! H{ { "a" "b" } { "c" "d" } } -! - header -- a hashtable of headers from the user's client -! - response -- a hashtable of the POST request response -! - raw-response -- raw POST request response - -: query-param ( key -- value ) "query" get at ; - -: header-param ( key -- value ) - "header" get peek-at ; - -: host ( -- string ) - #! The host the current responder was called from. - "Host" header-param ":" split1 drop ; - -: add-responder ( responder -- ) - #! Add a responder object to the list. - "responder" over at responders get set-at ; - -: make-responder ( quot -- ) - #! quot has stack effect ( url -- ) - [ - [ - drop "GET method not implemented" httpd-error - ] "get" set - [ - drop "POST method not implemented" httpd-error - ] "post" set - [ - drop "HEAD method not implemented" httpd-error - ] "head" set - [ - drop bad-request - ] "bad" set - - call - ] H{ } make-assoc add-responder ; - -: add-simple-responder ( name quot -- ) - [ - [ drop ] swap append dup "get" set "post" set - "responder" set - ] make-responder ; - -: vhost ( name -- vhost ) - vhosts get at [ "default" vhost ] unless* ; - -: responder ( name -- responder ) - responders get at [ "404" responder ] unless* ; - -: set-default-responder ( name -- ) - responder "default" responders get set-at ; - -: call-responder ( method argument responder -- ) - over "argument" set [ swap get with-scope ] bind ; - -: serve-default-responder ( method url -- ) - "/" "responder-url" set - "default" responder call-responder ; - -: trim-/ ( url -- url ) - #! Trim a leading /, if there is one. - "/" ?head drop ; - -: serve-explicit-responder ( method url -- ) - "/" split1 - "/responder/" pick "/" 3append "responder-url" set - dup [ - swap responder call-responder - ] [ - ! Just a responder name by itself - drop "request" get "/" append permanent-redirect 2drop - ] if ; - -: serve-responder ( method path host -- ) - #! Responder paths come in two forms: - #! /foo/bar... - default responder used - #! /responder/foo/bar - responder foo, argument bar - vhost [ - trim-/ "responder/" ?head [ - serve-explicit-responder - ] [ - serve-default-responder - ] if - ] bind ; - -\ serve-responder DEBUG add-input-logging - -: no-such-responder ( -- ) - "404 No such responder" httpd-error ; - -! create a responders hash if it doesn't already exist -global [ - responders [ H{ } assoc-like ] change - - ! 404 error message pages are served by this guy - "404" [ no-such-responder ] add-simple-responder - - H{ } clone "default" associate vhosts set -] bind diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 18edd94f12..0635e1f895 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,39 +1,61 @@ -USING: webapps.file http.server.responders http -http.server namespaces io tools.test strings io.server -logging ; -IN: temporary +USING: http.server tools.test kernel namespaces accessors +new-slots io http math sequences assocs ; +IN: http.server.tests -[ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test +TUPLE: mock-responder path ; -[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test +C: mock-responder -[ "index.html" ] -[ "http://www.jedit.org/index.html" url>path ] unit-test +M: mock-responder call-responder + 2nip + path>> on + "text/plain" ; -[ "foo/bar" ] -[ "http://www.jedit.org/foo/bar" url>path ] unit-test +: check-dispatch ( tag path -- ? ) + over off + swap default-host get call-responder + write-response get ; -[ "" ] -[ "http://www.jedit.org/" url>path ] unit-test +[ + + "foo" "foo" add-responder + "bar" "bar" add-responder + + "123" "123" add-responder + "default" >>default + "baz" add-responder + default-host set -[ "" ] -[ "http://www.jedit.org" url>path ] unit-test + [ "foo" ] [ + "foo" default-host get find-responder path>> nip + ] unit-test -[ "foobar" ] -[ "foobar" secure-path ] unit-test + [ "bar" ] [ + "bar" default-host get find-responder path>> nip + ] unit-test -[ f ] -[ "foobar/../baz" secure-path ] unit-test + [ t ] [ "foo" "foo" check-dispatch ] unit-test + [ f ] [ "foo" "bar" check-dispatch ] unit-test + [ t ] [ "bar" "bar" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test + [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test + [ t ] [ "123" "baz/123" check-dispatch ] unit-test + [ t ] [ "123" "baz///123" check-dispatch ] unit-test -[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test -[ ] [ f [ "POO" parse-request ] with-logging ] unit-test + [ t ] [ + + "baz" >>path + "baz" default-host get call-responder + dup code>> 300 399 between? >r + header>> "location" swap at "baz/" tail? r> and + ] unit-test +] with-scope -[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] unit-test +[ + + "default" >>default + default-host set -[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ] -[ "Foo=Bar&Baz=Quux" query>hash ] unit-test - -[ H{ { "Baz" " " } } ] -[ "Baz=%20" query>hash ] unit-test - -[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test + [ "/default" ] [ "/default" default-host get find-responder drop ] unit-test +] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index a2f5c3474b..f397b280d0 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,65 +1,170 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! 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 calendar ; - +threads http sequences prettyprint io.server logging calendar +new-slots html.elements accessors math.parser combinators.lib +vocabs.loader debugger html continuations random combinators ; IN: http.server -: (url>path) ( uri -- path ) - url-decode "http://" ?head [ - "/" split1 dup "" ? nip - ] when ; +GENERIC: call-responder ( request path responder -- response ) -: url>path ( uri -- path ) - "?" split1 dup [ - >r (url>path) "?" r> 3append - ] [ - drop (url>path) - ] if ; +TUPLE: trivial-responder response ; -: secure-path ( path -- path ) - ".." over subseq? [ drop f ] when ; +C: trivial-responder -: request-method ( cmd -- method ) - H{ - { "GET" "get" } - { "POST" "post" } - { "HEAD" "head" } - } at "bad" or ; +M: trivial-responder call-responder nip response>> call ; -: (handle-request) ( arg cmd -- method path host ) - request-method dup "method" set swap - prepare-url prepare-header host ; +: trivial-response-body ( code message -- ) + + +

swap number>string write bl write

+ + ; -: handle-request ( arg cmd -- ) - [ (handle-request) serve-responder ] with-scope ; +: ( code message -- response ) + + 2over [ trivial-response-body ] 2curry >>body + "text/html" set-content-type + swap >>message + swap >>code ; -: parse-request ( request -- ) - " " split1 dup [ - " HTTP" split1 drop url>path secure-path dup [ - swap handle-request +: <400> ( -- response ) + 400 "Bad request" ; + +: <404> ( -- response ) + 404 "Not Found" ; + +SYMBOL: 404-responder + +[ drop <404> ] 404-responder set-global + +: modify-for-redirect ( request to -- url ) + { + { [ dup "http://" head? ] [ nip ] } + { [ dup "/" head? ] [ >>path request-url ] } + { [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] } + } cond ; + +: ( request to code message -- response ) + + -rot modify-for-redirect + "location" set-header ; + +\ DEBUG add-input-logging + +: ( request to -- response ) + 301 "Moved Permanently" ; + +: ( request to -- response ) + 307 "Temporary Redirect" ; + +: ( content-type -- response ) + + 200 >>code + swap set-content-type ; + +TUPLE: dispatcher default responders ; + +: ( -- dispatcher ) + 404-responder H{ } clone dispatcher construct-boa ; + +: set-main ( dispatcher name -- dispatcher ) + [ ] curry + >>default ; + +: split-path ( path -- rest first ) + [ CHAR: / = ] left-trim "/" split1 swap ; + +: find-responder ( path dispatcher -- path responder ) + over split-path pick responders>> at* + [ >r >r 2drop r> r> ] [ 2drop default>> ] if ; + +: redirect-with-/ ( request -- response ) + dup path>> "/" append ; + +M: dispatcher call-responder + over [ + 3dup find-responder call-responder [ + >r 3drop r> ] [ - 2drop bad-request - ] if + default>> [ + call-responder + ] [ + 3drop f + ] if* + ] if* ] [ - 2drop bad-request + 2drop redirect-with-/ ] if ; -\ parse-request NOTICE add-input-logging +: add-responder ( dispatcher responder path -- dispatcher ) + pick responders>> set-at ; + +: add-main-responder ( dispatcher responder path -- dispatcher ) + [ add-responder ] keep set-main ; + +: ( class -- dispatcher ) + swap construct-delegate ; inline + +SYMBOL: virtual-hosts +SYMBOL: default-host + +virtual-hosts global [ drop H{ } clone ] cache drop +default-host global [ drop 404-responder get-global ] cache drop + +: find-virtual-host ( host -- responder ) + virtual-hosts get at [ default-host get ] unless* ; + +SYMBOL: development-mode + +: <500> ( error -- response ) + 500 "Internal server error" + swap [ + "Internal server error" [ + development-mode get [ + [ print-error nl :c ] with-html-stream + ] [ + 500 "Internal server error" + trivial-response-body + ] if + ] simple-page + ] curry >>body ; + +: do-response ( request response -- ) + dup write-response + swap method>> "HEAD" = + [ drop ] [ write-response-body ] if ; + +: do-request ( request -- request ) + [ + dup dup path>> over host>> + find-virtual-host call-responder + [ <404> ] unless* + ] [ dup \ do-request log-error <500> ] recover ; + +: default-timeout 1 minutes stdio get set-timeout ; + +LOG: httpd-hit NOTICE + +: log-request ( request -- ) + { method>> host>> path>> } map-exec-with httpd-hit ; + +: handle-client ( -- ) + default-timeout + development-mode get-global + [ global [ refresh-all ] bind ] when + read-request + dup log-request + do-request do-response ; : httpd ( port -- ) - internet-server "http.server" [ - 1 minutes stdio get set-timeout - readln [ parse-request ] when* - ] with-server ; + internet-server "http.server" + [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; MAIN: httpd-main -! Load default webapps -USE: webapps.file -USE: webapps.callback -USE: webapps.continuation -USE: webapps.cgi +: generate-key ( assoc -- str ) + 4 big-random >hex dup pick key? + [ drop generate-key ] [ nip ] if ; diff --git a/extra/http/server/sessions/authors.txt b/extra/http/server/sessions/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/http/server/sessions/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor new file mode 100755 index 0000000000..4c21ba3c8d --- /dev/null +++ b/extra/http/server/sessions/sessions-tests.factor @@ -0,0 +1,34 @@ +IN: http.server.sessions.tests +USING: tools.test http.server.sessions math namespaces +kernel accessors ; + +: with-session \ session swap with-variable ; inline + +"1234" f [ + [ ] [ 3 "x" sset ] unit-test + + [ 9 ] [ "x" sget sq ] unit-test + + [ ] [ "x" [ 1- ] schange ] unit-test + + [ 4 ] [ "x" sget sq ] unit-test +] with-session + +[ t ] [ f url-sessions? ] unit-test +[ t ] [ f cookie-sessions? ] unit-test + +[ ] [ + f + [ 0 "x" sset ] >>init + "manager" set +] unit-test + +[ { 5 0 } ] [ + [ + "manager" get new-session + dup "manager" get get-session [ 5 "a" sset ] with-session + dup "manager" get get-session [ "a" sget , ] with-session + dup "manager" get get-session [ "x" sget , ] with-session + "manager" get get-session delete-session + ] { } make +] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor new file mode 100755 index 0000000000..2977e5938d --- /dev/null +++ b/extra/http/server/sessions/sessions.factor @@ -0,0 +1,112 @@ +! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs calendar kernel math.parser namespaces random +boxes alarms new-slots accessors http http.server +quotations hashtables sequences ; +IN: http.server.sessions + +! ! ! ! ! ! +! WARNING: this session manager is vulnerable to XSRF attacks +! ! ! ! ! ! + +GENERIC: init-session ( responder -- ) + +TUPLE: session-manager responder sessions ; + +: ( responder class -- responder' ) + >r H{ } clone session-manager construct-boa r> + construct-delegate ; inline + +TUPLE: session id manager namespace alarm ; + +: ( id manager -- session ) + H{ } clone \ session construct-boa ; + +: timeout ( -- dt ) 20 minutes ; + +: cancel-timeout ( session -- ) + alarm>> [ cancel-alarm ] if-box? ; + +: delete-session ( session -- ) + dup cancel-timeout + dup manager>> sessions>> delete-at ; + +: touch-session ( session -- ) + dup cancel-timeout + dup [ delete-session ] curry timeout later + swap session-alarm >box ; + +: session ( -- assoc ) \ session get namespace>> ; + +: sget ( key -- value ) session at ; + +: sset ( value key -- ) session set-at ; + +: schange ( key quot -- ) session swap change-at ; inline + +: new-session ( responder -- id ) + [ sessions>> generate-key dup ] keep + [ dup touch-session ] keep + [ swap \ session [ responder>> init-session ] with-variable ] 2keep + >r over r> sessions>> set-at ; + +: get-session ( id responder -- session ) + sessions>> tuck at* [ + nip dup touch-session + ] [ + 2drop f + ] if ; + +: call-responder/session ( request path responder session -- response ) + \ session set responder>> call-responder ; + +: sessions ( -- manager/f ) + \ session get dup [ manager>> ] when ; + +GENERIC: session-link* ( url query sessions -- string ) + +M: object session-link* 2drop url-encode ; + +: session-link ( url query -- string ) sessions session-link* ; + +TUPLE: url-sessions ; + +: ( responder -- responder' ) + url-sessions ; + +: sess-id "factorsessid" ; + +M: url-sessions call-responder ( request path responder -- response ) + pick sess-id query-param over get-session [ + call-responder/session + ] [ + new-session nip sess-id set-query-param + dup request-url + ] if* ; + +M: url-sessions session-link* + drop + \ session get id>> sess-id associate union assoc>query + >r url-encode r> + dup assoc-empty? [ drop ] [ "?" swap 3append ] if ; + +TUPLE: cookie-sessions ; + +: ( responder -- responder' ) + cookie-sessions ; + +: get-session-cookie ( request responder -- cookie ) + >r sess-id get-cookie dup + [ value>> r> get-session ] [ r> 2drop f ] if ; + +: ( id -- cookie ) + sess-id ; + +M: cookie-sessions call-responder ( request path responder -- response ) + 3dup nip get-session-cookie [ + call-responder/session + ] [ + dup new-session + [ over get-session call-responder/session ] keep + put-cookie + ] if* ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor new file mode 100755 index 0000000000..8d47d38eb1 --- /dev/null +++ b/extra/http/server/static/static.factor @@ -0,0 +1,101 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar html io io.files kernel math math.parser http +http.server namespaces parser sequences strings assocs +hashtables debugger http.mime sorting html.elements logging +calendar.format new-slots accessors ; +IN: http.server.static + +SYMBOL: responder + +! special maps mime types to quots with effect ( path -- ) +TUPLE: file-responder root hook special ; + +: unix-time>timestamp ( n -- timestamp ) + >r unix-1970 r> seconds time+ ; + +: file-http-date ( filename -- string ) + file-modified unix-time>timestamp timestamp>http-string ; + +: last-modified-matches? ( filename -- ? ) + file-http-date dup [ + request get "if-modified-since" header = + ] when ; + +: <304> ( -- response ) + 304 "Not modified" ; + +: ( root hook -- responder ) + H{ } clone file-responder construct-boa ; + +: ( root -- responder ) + [ + + over file-length "content-length" set-header + over file-http-date "last-modified" set-header + swap [ stdio get stream-copy ] curry >>body + ] ; + +: serve-static ( filename mime-type -- response ) + over last-modified-matches? + [ 2drop <304> ] [ responder get hook>> call ] if ; + +: serving-path ( filename -- filename ) + "" or responder get root>> swap path+ ; + +: serve-file ( filename -- response ) + dup mime-type + dup responder get special>> at + [ call ] [ serve-static ] ?if ; + +\ serve-file NOTICE add-input-logging + +: file. ( name dirp -- ) + [ "/" append ] when + dup write ; + +: directory. ( path -- ) + dup file-name [ +

dup file-name write

+
    + directory sort-keys + [
  • file.
    • ] assoc-each +
+ ] simple-html-document ; + +: list-directory ( directory -- response ) + "text/html" + swap [ directory. ] curry >>body ; + +: find-index ( filename -- path ) + { "index.html" "index.fhtml" } + [ dupd path+ exists? ] find nip + dup [ path+ ] [ nip ] if ; + +: serve-directory ( filename -- response ) + dup "/" tail? [ + dup find-index + [ serve-file ] [ list-directory ] ?if + ] [ + drop request get redirect-with-/ + ] if ; + +: serve-object ( filename -- response ) + serving-path dup exists? [ + dup directory? [ serve-directory ] [ serve-file ] if + ] [ + drop <404> + ] if ; + +M: file-responder call-responder ( request path responder -- response ) + over [ + ".." pick subseq? [ + 3drop <400> + ] [ + responder set + swap request set + serve-object + ] if + ] [ + 2drop redirect-with-/ + ] if ; 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..b298faca74 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -4,7 +4,8 @@ USING: continuations sequences kernel parser namespaces io io.files io.streams.lines io.streams.string html html.elements source-files debugger combinators math quotations generic -strings splitting ; +strings splitting accessors http.server.static http.server +assocs ; IN: http.server.templating @@ -80,13 +81,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 @@ -94,3 +94,13 @@ DEFER: <% delimiter : template-convert ( infile outfile -- ) [ run-template-file ] with-file-writer ; + +! file responder integration +: serve-fhtml ( filename -- response ) + "text/html" + swap [ run-template-file ] curry >>body ; + +: enable-fhtml ( responder -- responder ) + [ serve-fhtml ] + "application/x-factor-server-page" + pick special>> set-at ; 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 48b2a01b7d..31d7e7a60d 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -35,33 +35,43 @@ HELP: +environment-mode+ HELP: +stdin+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard input is inherited" } + { { $link f } " - standard input is either inherited from the current process, or is a " { $link } " pipe" } + { { $link +inherit+ } " - standard input is inherited from the current process" } { { $link +closed+ } " - standard input is closed" } { "a path name - standard input is read from the given file, which must exist" } + { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" } } } ; HELP: +stdout+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard output is inherited" } + { { $link f } " - standard output is either inherited from the current process, or is a " { $link } " pipe" } + { { $link +inherit+ } " - standard output is inherited from the current process" } { { $link +closed+ } " - standard output is closed" } { "a path name - standard output is written to the given file, which is overwritten if it already exists" } + { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" } } } ; HELP: +stderr+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard error is inherited" } + { { $link f } " - standard error is inherited from the current process" } + { { $link +inherit+ } " - same as above" } + { { $link +stdout+ } " - standard error is merged with standard output" } { { $link +closed+ } " - standard error is closed" } { "a path name - standard error is written to the given file, which is overwritten if it already exists" } + { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" } } } ; HELP: +closed+ { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; +HELP: +inherit+ +{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; + HELP: +prepend-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." $nl @@ -78,7 +88,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 to a " { $link dt } ", 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 021ea487fc..c5ea4feeaf 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 @@ -35,13 +36,16 @@ SYMBOL: +environment-mode+ SYMBOL: +stdin+ SYMBOL: +stdout+ SYMBOL: +stderr+ -SYMBOL: +closed+ + SYMBOL: +timeout+ SYMBOL: +prepend-environment+ SYMBOL: +replace-environment+ SYMBOL: +append-environment+ +SYMBOL: +closed+ +SYMBOL: +inherit+ + : default-descriptor H{ { +command+ f } @@ -141,3 +145,12 @@ TUPLE: process-stream process ; [ set-process-status ] 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 8c2c9cb9d8..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 boxes ; +assocs hashtables sorting arrays threads boxes io.timeouts ; IN: io.monitors ( handle -- simple-monitor ) f (monitor) { @@ -45,11 +49,16 @@ TUPLE: simple-monitor handle callback ; >r r> construct-delegate ; inline : notify-callback ( simple-monitor -- ) - simple-monitor-callback ?box [ resume ] [ drop ] if ; + simple-monitor-callback [ resume ] if-box? ; + +M: simple-monitor timed-out + notify-callback ; M: simple-monitor fill-queue ( monitor -- ) - [ swap simple-monitor-callback >box ] - "monitor" suspend drop + [ + [ swap simple-monitor-callback >box ] + "monitor" suspend drop + ] with-timeout check-monitor ; M: simple-monitor dispose ( monitor -- ) 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-tests.factor b/extra/io/server/server-tests.factor index 24b4c231d1..8e56169bb3 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.server.tests USING: tools.test io.server io.server.private ; { 1 0 } [ [ ] server-loop ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 6cc11ea6b6..a76ebcc450 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -10,10 +10,6 @@ SYMBOL: servers r [ dup get ] H{ } map>assoc [ swap bind ] 2curry r> - spawn drop ; - LOG: accepted-connection NOTICE : with-client ( client quot -- ) @@ -26,8 +22,7 @@ LOG: accepted-connection NOTICE : accept-loop ( server quot -- ) [ - >r accept r> [ with-client ] 2curry - { log-service servers } "Client" spawn-vars + >r accept r> [ with-client ] 2curry "Client" spawn drop ] 2keep accept-loop ; inline : server-loop ( addrspec quot -- ) 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 347c57a0d6..df7e1389cc 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/extra/io/timeouts/timeouts-docs.factor @@ -2,11 +2,11 @@ IN: io.timeouts USING: help.markup help.syntax math kernel calendar ; HELP: timeout -{ $values { "obj" object } { "dt/f" "a " { $link dt } " or " { $link f } } } +{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } } { $contract "Outputs an object's timeout." } ; HELP: set-timeout -{ $values { "dt/f" "a " { $link dt } " or " { $link f } } { "obj" object } } +{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } } { $contract "Sets an object's timeout." } ; HELP: timed-out 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 7b67a9d468..60e3754ec6 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -1,7 +1,7 @@ ! 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 +sequences assocs unix unix.time unix.kqueue unix.process math namespaces combinators threads vectors io.launcher io.unix.launcher ; IN: io.unix.kqueue diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor old mode 100755 new mode 100644 index eb3038e1b5..fd2fb53cc5 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,33 +1,80 @@ -IN: temporary -USING: io.unix.launcher tools.test ; +IN: io.unix.launcher.tests +USING: io.files tools.test io.launcher arrays io namespaces +continuations math ; -[ "" 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 +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + "touch" + "launcher-test-1" temp-file + 2array + try-process +] unit-test + +[ t ] [ "launcher-test-1" temp-file exists? ] unit-test + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + [ + "echo Hello" +command+ set + "launcher-test-1" temp-file +stdout+ set + ] { } make-assoc try-process +] unit-test + +[ "Hello\n" ] [ + "cat" + "launcher-test-1" temp-file + 2array + contents +] unit-test + +[ "" ] [ + [ + "cat" + "launcher-test-1" temp-file + 2array +arguments+ set + +inherit+ +stdout+ set + ] { } make-assoc contents +] unit-test + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + [ + "cat" +command+ set + +closed+ +stdin+ set + "launcher-test-1" temp-file +stdout+ set + ] { } make-assoc try-process +] unit-test + +[ "" ] [ + "cat" + "launcher-test-1" temp-file + 2array + contents +] unit-test + +[ ] [ + 2 [ + "launcher-test-1" temp-file [ + [ + +stdout+ set + "echo Hello" +command+ set + ] { } make-assoc try-process + ] with-disposal + ] times +] unit-test + +[ "Hello\nHello\n" ] [ + "cat" + "launcher-test-1" temp-file + 2array + contents ] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 0393b13c7f..58e41a06c0 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -1,56 +1,45 @@ ! 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* ; : assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; -: (redirect) ( path mode fd -- ) - >r file-mode open dup io-error dup - r> dup2 io-error close ; +: redirect-fd ( oldfd fd -- ) + 2dup = [ 2drop ] [ dupd dup2 io-error close ] if ; + +: reset-fd ( fd -- ) F_SETFL 0 fcntl io-error ; + +: redirect-inherit ( obj mode fd -- ) + 2nip reset-fd ; + +: redirect-file ( obj mode fd -- ) + >r file-mode open dup io-error r> redirect-fd ; + +: redirect-closed ( obj mode fd -- ) + >r >r drop "/dev/null" r> r> redirect-file ; + +: redirect-stream ( obj mode fd -- ) + >r drop underlying-handle dup reset-fd r> redirect-fd ; : redirect ( obj mode fd -- ) { - { [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] } - { [ pick string? ] [ (redirect) ] } + { [ pick not ] [ redirect-inherit ] } + { [ pick string? ] [ redirect-file ] } + { [ pick +closed+ eq? ] [ redirect-closed ] } + { [ pick +inherit+ eq? ] [ redirect-closed ] } + { [ t ] [ redirect-stream ] } } cond ; : ?closed dup +closed+ eq? [ drop "/dev/null" ] when ; 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 c38d8c1283..7580e7bf6b 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -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/unix-tests.factor b/extra/io/unix/unix-tests.factor index 6eb0b78955..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 +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 + socket-server delete-file ] "Test" spawn drop yield [ { "Hello world" "FOO" } ] [ [ - "unix-domain-socket-test" resource-path + socket-server [ readln , "XYZ" print flush @@ -33,17 +33,16 @@ yield ] { } make ] unit-test -! Unix domain datagram sockets -[ - "unix-domain-datagram-test" resource-path delete-file -] ignore-errors +: datagram-server "unix-domain-datagram-test" temp-file ; +: datagram-client "unix-domain-datagram-test-2" temp-file ; -: server-addr "unix-domain-datagram-test" temp-file ; -: client-addr "unix-domain-datagram-test-2" temp-file ; +! Unix domain datagram sockets +[ datagram-server delete-file ] ignore-errors +[ datagram-client delete-file ] ignore-errors [ [ - server-addr "d" set + datagram-server "d" set "Receive 1" print @@ -67,58 +66,53 @@ yield "Done" print - "unix-domain-datagram-test" resource-path delete-file + datagram-server delete-file ] with-scope ] "Test" spawn drop yield -[ - "unix-domain-datagram-test-2" resource-path delete-file -] ignore-errors +[ datagram-client delete-file ] ignore-errors -client-addr +datagram-client "d" set [ ] [ "hello" >byte-array - server-addr + datagram-server "d" get send ] unit-test [ "olleh" t ] [ "d" get receive - server-addr = + datagram-server = >r >string r> ] unit-test [ ] [ "hello" >byte-array - server-addr + datagram-server "d" get send ] unit-test [ "hello world" t ] [ "d" get receive - server-addr = + datagram-server = >r >string r> ] unit-test [ ] [ "d" get dispose ] unit-test ! Test error behavior +: another-datagram "unix-domain-datagram-test-3" temp-file ; -[ - "unix-domain-datagram-test-3" resource-path delete-file -] ignore-errors +[ another-datagram delete-file ] ignore-errors -"unix-domain-datagram-test-2" temp-file delete-file +datagram-client delete-file -[ ] [ client-addr "d" set ] unit-test +[ ] [ datagram-client "d" set ] unit-test -[ - B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send -] must-fail +[ B{ 1 2 3 } another-datagram "d" get send ] must-fail [ ] [ "d" get dispose ] unit-test @@ -126,7 +120,7 @@ client-addr [ "d" get receive ] must-fail -[ B{ 1 2 } server-addr "d" get send ] must-fail +[ B{ 1 2 } datagram-server "d" get send ] must-fail ! Invalid parameter tests @@ -140,7 +134,7 @@ client-addr [ image [ - B{ 1 2 } server-addr + B{ 1 2 } datagram-server stdio get send ] with-file-reader ] must-fail diff --git a/extra/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/files/files.factor b/extra/io/windows/files/files.factor new file mode 100644 index 0000000000..fdd574d00e --- /dev/null +++ b/extra/io/windows/files/files.factor @@ -0,0 +1,108 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types io.files io.windows kernel +math windows windows.kernel32 combinators.cleave +windows.time calendar combinators math.functions +sequences combinators.lib namespaces words ; +IN: io.windows.files + +SYMBOL: +read-only+ +SYMBOL: +hidden+ +SYMBOL: +system+ +SYMBOL: +directory+ +SYMBOL: +archive+ +SYMBOL: +device+ +SYMBOL: +normal+ +SYMBOL: +temporary+ +SYMBOL: +sparse-file+ +SYMBOL: +reparse-point+ +SYMBOL: +compressed+ +SYMBOL: +offline+ +SYMBOL: +not-content-indexed+ +SYMBOL: +encrypted+ + +: expand-constants ( word/obj -- obj'/obj ) + dup word? [ execute ] when ; + +: get-flags ( n seq -- seq' ) + [ + [ + first2 expand-constants + [ swapd mask? [ , ] [ drop ] if ] 2curry + ] map call-with + ] { } make ; + +: win32-file-attributes ( n -- seq ) + { + { +read-only+ FILE_ATTRIBUTE_READONLY } + { +hidden+ FILE_ATTRIBUTE_HIDDEN } + { +system+ FILE_ATTRIBUTE_SYSTEM } + { +directory+ FILE_ATTRIBUTE_DIRECTORY } + { +archive+ FILE_ATTRIBUTE_ARCHIVE } + { +device+ FILE_ATTRIBUTE_DEVICE } + { +normal+ FILE_ATTRIBUTE_NORMAL } + { +temporary+ FILE_ATTRIBUTE_TEMPORARY } + { +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE } + { +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT } + { +compressed+ FILE_ATTRIBUTE_COMPRESSED } + { +offline+ FILE_ATTRIBUTE_OFFLINE } + { +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED } + { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED } + } get-flags ; + +: WIN32_FIND_DATA>file-info + { + [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ] + [ + [ WIN32_FIND_DATA-nFileSizeLow ] + [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit + ] + [ WIN32_FIND_DATA-dwFileAttributes ] + [ + WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp + ] + } cleave + \ file-info construct-boa ; + +: find-first-file-stat ( path -- WIN32_FIND_DATA ) + "WIN32_FIND_DATA" [ + FindFirstFile + [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep + FindClose win32-error=0/f + ] keep ; + +: BY_HANDLE_FILE_INFORMATION>file-info + { + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes ] + [ + [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] + [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit + ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ] + [ + BY_HANDLE_FILE_INFORMATION-ftLastWriteTime + FILETIME>timestamp + ] + } cleave + \ file-info construct-boa ; + +: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION ) + [ + "BY_HANDLE_FILE_INFORMATION" + [ GetFileInformationByHandle win32-error=0/f ] keep + ] keep CloseHandle win32-error=0/f ; + +: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION ) + dup + GENERIC_READ FILE_SHARE_READ f + OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f + CreateFileW dup INVALID_HANDLE_VALUE = [ + drop find-first-file-stat WIN32_FIND_DATA>file-info + ] [ + nip + get-file-information BY_HANDLE_FILE_INFORMATION>file-info + ] if ; + +M: windows-nt-io file-info ( path -- info ) + get-file-information-stat ; + 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 58e3c0ba69..708dc1dc38 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -146,8 +146,8 @@ M: windows-io kill-process* ( handle -- ) : wait-loop ( -- ) processes get dup assoc-empty? - [ drop f nap drop ] - [ wait-for-processes [ 100 nap drop ] when ] if ; + [ drop f sleep-until ] + [ wait-for-processes [ 100 sleep ] when ] if ; SYMBOL: wait-thread diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 3541243016..dda94da892 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -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/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index cd9bb9baef..a4a3122b4d 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -1,18 +1,38 @@ -! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations destructors io io.windows libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system strings io.windows.launcher io.windows.nt.pipes io.backend -combinators ; +combinators shuffle ; IN: io.windows.nt.launcher +: duplicate-handle ( handle -- handle' ) + GetCurrentProcess ! source process + swap ! handle + GetCurrentProcess ! target process + f [ ! target handle + DUPLICATE_SAME_ACCESS ! desired access + TRUE ! inherit handle + DUPLICATE_CLOSE_SOURCE ! options + DuplicateHandle win32-error=0/f + ] keep *void* ; + ! The below code is based on the example given in ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx -: (redirect) ( path access-mode create-mode -- handle ) - >r >r +: redirect-default ( default obj access-mode create-mode -- handle ) + 3drop ; + +: redirect-inherit ( default obj access-mode create-mode -- handle ) + 4drop f ; + +: redirect-closed ( default obj access-mode create-mode -- handle ) + drop 2nip null-pipe ; + +: redirect-file ( default path access-mode create-mode -- handle ) + >r >r >r drop r> normalize-pathname r> ! access-mode share-mode @@ -22,47 +42,59 @@ IN: io.windows.nt.launcher f ! template file CreateFile dup invalid-handle? dup close-later ; -: redirect ( obj access-mode create-mode -- handle ) - { - { [ pick not ] [ 3drop f ] } - { [ pick +closed+ eq? ] [ drop nip null-pipe ] } - { [ pick string? ] [ (redirect) ] } - } cond ; - -: ?closed or dup t eq? [ drop f ] when ; - -: inherited-stdout ( args -- handle ) - CreateProcess-args-stdout-pipe - [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ; - -: redirect-stdout ( args -- handle ) - +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stdout ?closed ; - -: inherited-stderr ( args -- handle ) - drop STD_ERROR_HANDLE GetStdHandle ; - -: redirect-stderr ( args -- handle ) - +stderr+ get - dup +stdout+ eq? [ - drop - CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput - ] [ - GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stderr ?closed - ] if ; - -: inherited-stdin ( args -- handle ) - CreateProcess-args-stdin-pipe - [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ; - -: redirect-stdin ( args -- handle ) - +stdin+ get GENERIC_READ OPEN_EXISTING redirect - swap inherited-stdin ?closed ; - : set-inherit ( handle ? -- ) >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; +: redirect-stream ( default stream access-mode create-mode -- handle ) + 2drop nip + underlying-handle win32-file-handle + duplicate-handle dup t set-inherit ; + +: redirect ( default obj access-mode create-mode -- handle ) + { + { [ pick not ] [ redirect-default ] } + { [ pick +inherit+ eq? ] [ redirect-inherit ] } + { [ pick +closed+ eq? ] [ redirect-closed ] } + { [ pick string? ] [ redirect-file ] } + { [ t ] [ redirect-stream ] } + } cond ; + +: default-stdout ( args -- handle ) + CreateProcess-args-stdout-pipe dup [ pipe-out ] when ; + +: redirect-stdout ( args -- handle ) + default-stdout + +stdout+ get + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_OUTPUT_HANDLE GetStdHandle or ; + +: redirect-stderr ( args -- handle ) + +stderr+ get +stdout+ eq? [ + CreateProcess-args-lpStartupInfo + STARTUPINFO-hStdOutput + ] [ + drop + f + +stderr+ get + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_ERROR_HANDLE GetStdHandle or + ] if ; + +: default-stdin ( args -- handle ) + CreateProcess-args-stdin-pipe dup [ pipe-in ] when ; + +: redirect-stdin ( args -- handle ) + default-stdin + +stdin+ get + GENERIC_READ + OPEN_EXISTING + redirect + STD_INPUT_HANDLE GetStdHandle or ; + : add-pipe-dtors ( pipe -- ) dup pipe-in close-later 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/windows.factor b/extra/io/windows/windows.factor index ee3f744bb0..291bef6018 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 ) { @@ -55,7 +55,7 @@ M: win32-file close-handle ( handle -- ) : open-file ( path access-mode create-mode flags -- handle ) [ >r >r >r normalize-pathname r> - share-mode f r> r> CreateFile-flags f CreateFile + share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile dup invalid-handle? dup close-later dup add-completion ] with-destructors ; @@ -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 2ea8a64bd9..3cc230126c 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,5 +1,5 @@ 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 aa724c4aca..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,21 +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 | [let | n [ n 3 + ] | n ] ; +:: 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..5f58f1464a 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 ] + [ 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 ( method -- effect ) + dup "lambda" word-prop lambda-vars + swap "method-generic" word-prop stack-effect + dup [ effect-out ] when + ; + +M: lambda-method synopsis* + dup dup dup definer. + "method-specializer" word-prop pprint* + "method-generic" word-prop pprint* + method-stack-effect effect>string comment. ; PRIVATE> diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor old mode 100644 new mode 100755 index 64ac3b4ff6..93485e4c7c --- a/extra/logging/insomniac/insomniac-docs.factor +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -27,7 +27,7 @@ HELP: schedule-insomniac { $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } { $description "Starts a thread which e-mails log reports and rotates logs daily." } ; -ARTICLE: "logging.insomniac" "Automating log analysis and rotation" +ARTICLE: "logging.insomniac" "Automated log analysis" "The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary." $nl "Required configuration parameters:" diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor old mode 100644 new mode 100755 index 939388026d..715b1551b9 --- a/extra/logging/logging-docs.factor +++ b/extra/logging/logging-docs.factor @@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework" { $subsection "logging.levels" } { $subsection "logging.messages" } { $subsection "logging.rotation" } -{ $subsection "logging.parser" } -{ $subsection "logging.analysis" } -{ $subsection "logging.insomniac" } +{ $vocab-subsection "Log file parser" "logging.parser" } +{ $vocab-subsection "Log analysis" "logging.analysis" } +{ $vocab-subsection "Automated log analysis" "logging.insomniac" } { $subsection "logging.server" } ; ABOUT: "logging" 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 e31391e5d5..99f637f4a0 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -3,7 +3,7 @@ USING: namespaces kernel io calendar sequences io.files io.sockets continuations prettyprint assocs math.parser words debugger math combinators concurrency.messaging -threads arrays init math.ranges strings ; +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 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/functions/functions.factor b/extra/math/functions/functions.factor index 59ade44365..85e07fe73f 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -34,6 +34,10 @@ M: real sqrt : set-bit ( x n -- y ) 2^ bitor ; foldable : bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable : bit-set? ( x n -- ? ) bit-clear? not ; foldable +: unmask ( x n -- ? ) bitnot bitand ; foldable +: unmask? ( x n -- ? ) unmask 0 > ; foldable +: mask ( x n -- ? ) bitand ; foldable +: mask? ( x n -- ? ) mask 0 > ; foldable GENERIC: (^) ( x y -- z ) foldable 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/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 ce86905b9f..d514a539aa 100755 --- a/extra/models/models-docs.factor +++ b/extra/models/models-docs.factor @@ -153,7 +153,7 @@ HELP: delay } ; HELP: -{ $values { "model" model } { "timeout" dt } { "delay" delay } } +{ $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 } "." } ; 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/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 index dae96dc0ea..e24cee748e 100755 --- 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 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/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index 6f921497b2..2dd3fd911c 100755 --- 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: temporary +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-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/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/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 c74a6e72fb..f3f90f68b9 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -3,7 +3,7 @@ ! 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 @@ -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/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/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/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/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor index b616766597..0717763ed0 100755 --- 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 generic definitions ; -IN: temporary +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 method method-word \ + usage member? ] unit-test +[ t ] [ integer \ foo method \ + usage member? ] unit-test [ t ] [ \ foo usage [ pathname? ] contains? ] unit-test 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-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor index 2eddce6475..b37e42f323 100755 --- a/extra/tools/deploy/shaker/strip-cocoa.factor +++ b/extra/tools/deploy/shaker/strip-cocoa.factor @@ -1,5 +1,6 @@ USING: cocoa cocoa.messages cocoa.application cocoa.nibs -assocs namespaces kernel words compiler sequences ui.cocoa ; +assocs namespaces kernel words compiler.units sequences +ui.cocoa ; "stop-after-last-window?" get global [ 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/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/profiler/profiler.factor b/extra/tools/profiler/profiler.factor index 784c9e8da6..467fcc14f4 100755 --- a/extra/tools/profiler/profiler.factor +++ b/extra/tools/profiler/profiler.factor @@ -29,9 +29,8 @@ M: string (profile.) dup write-object ; M: method-body (profile.) - "method" word-prop - dup method-specializer over method-generic 2array synopsis - swap method-generic write-object ; + dup synopsis swap "method-generic" word-prop + write-object ; : counter. ( obj n -- ) [ 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 index 3313a56964..552247e2c4 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -8,7 +8,10 @@ heaps.private system math math.parser ; : thread. ( thread -- ) dup thread-id pprint-cell dup thread-name over [ write-object ] with-cell - dup thread-state "running" or [ write ] with-cell + dup thread-state [ + [ dup self eq? "running" "yield" ? ] unless* + write + ] with-cell [ thread-sleep-entry [ entry-key millis [-] number>string write diff --git a/extra/tools/walker/debug/debug.factor b/extra/tools/walker/debug/debug.factor index cfac9d8367..c8c0ff28a6 100755 --- a/extra/tools/walker/debug/debug.factor +++ b/extra/tools/walker/debug/debug.factor @@ -5,7 +5,7 @@ sequences concurrency.messaging locals continuations threads namespaces namespaces.private ; IN: tools.walker.debug -:: test-walker | quot | +:: test-walker ( quot -- data ) [let | p [ ] s [ f ] c [ f ] | diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor index 1302ebe3d8..2d4a6c3396 100755 --- a/extra/tools/walker/walker-tests.factor +++ b/extra/tools/walker/walker-tests.factor @@ -1,7 +1,7 @@ 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: temporary +IN: tools.walker.tests [ { } ] [ [ ] test-walker 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/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 53ed62252d..572e798bd0 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window? : event-loop ( -- ) event-loop? [ [ - [ NSApp do-events ui-step 10 sleep ] ui-try + [ NSApp do-events ui-wait ] ui-try ] with-autorelease-pool event-loop ] when ; diff --git a/extra/ui/cocoa/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 cf6d1a9ed9..defd5aa38a 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -88,7 +88,6 @@ TUPLE: repeat-button ; repeat-button H{ { T{ drag } [ button-clicked ] } - { T{ button-down } [ button-clicked ] } } set-gestures : ( label quot -- button ) 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 37c5684cc9..ed3631bca5 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -2,9 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables kernel models math namespaces sequences quotations math.vectors combinators sorting vectors dlists -models ; +models threads concurrency.flags ; IN: ui.gadgets +SYMBOL: ui-notify-flag + +: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; + TUPLE: rect loc dim ; C: rect @@ -184,7 +188,7 @@ M: array gadget-text* #! When unit testing gadgets without the UI running, the #! invalid queue is not initialized and we simply ignore #! invalidation requests. - layout-queue [ push-front ] [ drop ] if* ; + layout-queue [ push-front notify-ui-thread ] [ drop ] if* ; DEFER: relayout @@ -256,11 +260,11 @@ M: gadget layout* drop ; : queue-graft ( gadget -- ) { f t } over set-gadget-graft-state - graft-queue push-front ; + graft-queue push-front notify-ui-thread ; : queue-ungraft ( gadget -- ) { t f } over set-gadget-graft-state - graft-queue push-front ; + graft-queue push-front notify-ui-thread ; : graft-later ( gadget -- ) dup gadget-graft-state { diff --git a/extra/ui/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-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/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/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-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/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:"