diff --git a/.gitignore b/.gitignore index 897825c826..19ace1f500 100644 --- a/.gitignore +++ b/.gitignore @@ -15,5 +15,7 @@ factor .gdb_history *.*.marks .*.swp -reverse-complement-in.txt -reverse-complement-out.txt +temp +logs +work +misc/wordsize \ No newline at end of file diff --git a/Makefile b/Makefile index 9776027a59..6f12633871 100755 --- a/Makefile +++ b/Makefile @@ -45,7 +45,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ EXE_OBJS = $(PLAF_EXE_OBJS) -default: +default: misc/wordsize + make `./misc/target` + +help: @echo "Run 'make' with one of the following parameters:" @echo "" @echo "freebsd-x86-32" @@ -142,7 +145,8 @@ wince-arm: macosx.app: factor mkdir -p $(BUNDLE)/Contents/MacOS - cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor + mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor + ln -s Factor.app/Contents/MacOS/factor ./factor cp $(ENGINE) $(BUNDLE)/Contents/Frameworks install_name_tool \ @@ -158,6 +162,9 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) +misc/wordsize: misc/wordsize.c + gcc misc/wordsize.c -o misc/wordsize + clean: rm -f vm/*.o rm -f factor*.dll libfactor*.* diff --git a/README.txt b/README.txt old mode 100644 new mode 100755 index f92bfe25c7..12dade5ba1 --- a/README.txt +++ b/README.txt @@ -52,7 +52,9 @@ The Factor runtime is written in GNU C99, and is built with GNU make and gcc. Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc -3.3 or earlier. +3.3 or earlier. If you are using gcc 4.3, you might get an unusable +Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the +command-line arguments for make. Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of targets and build options. Then run 'make' with the appropriate target diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 19ee52b039..475cf72d28 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -87,7 +87,7 @@ $nl HELP: alien-invoke-error { $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "The symbol or library could not be found." } { "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." } @@ -103,7 +103,7 @@ HELP: alien-invoke HELP: alien-indirect-error { $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "One of the three inputs to " { $link alien-indirect } " is not a literal value." } } @@ -120,7 +120,7 @@ HELP: alien-indirect HELP: alien-callback-error { $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "One of the four inputs to " { $link alien-callback } " is not a literal value." } } @@ -199,9 +199,7 @@ ARTICLE: "alien-invoke" "Calling C from Factor" { $subsection alien-invoke } "Sometimes it is necessary to invoke a C function pointer, rather than a named C function:" { $subsection alien-indirect } -"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." -$nl -"Don't forget to compile your binding word after defining it; C library calls cannot be made from an interpreted definition. Words defined in source files are automatically compiled when the source file is loaded, but words defined in the listener are not; when interactively testing C libraries, use " { $link compile } " or " { $link recompile } " to compile binding words." ; +"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ; ARTICLE: "alien-callback-gc" "Callbacks and code GC" "A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body." diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 74c94c8edf..5f7b9fff21 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,7 +1,7 @@ -IN: temporary +IN: alien.tests USING: alien alien.accessors byte-arrays arrays kernel kernel.private namespaces tools.test sequences libc math system -prettyprint ; +prettyprint layouts ; [ t ] [ -1 alien-address 0 > ] unit-test diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index f4aa297a3a..fe6873ac3a 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -84,33 +84,15 @@ HELP: alien>u16-string ( c-ptr -- string ) { $values { "c-ptr" c-ptr } { "string" string } } { $description "Reads a null-terminated UCS-2 string from the specified address." } ; -HELP: memory>byte-array ( base len -- string ) -{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } +HELP: memory>byte-array +{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ; -HELP: memory>char-string ( base len -- string ) -{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } } -{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new string." } ; - -HELP: memory>u16-string ( base len -- string ) -{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } } -{ $description "Reads " { $snippet "len" } " UCS2 characters starting from " { $snippet "base" } " and stores them in a new string." } ; - -HELP: byte-array>memory ( string base -- ) +HELP: byte-array>memory { $values { "byte-array" byte-array } { "base" c-ptr } } { $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." } { $warning "This word is unsafe. Improper use can corrupt memory." } ; -HELP: string>char-memory ( string base -- ) -{ $values { "string" string } { "base" c-ptr } } -{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." } -{ $warning "This word is unsafe. Improper use can corrupt memory." } ; - -HELP: string>u16-memory ( string base -- ) -{ $values { "string" string } { "base" c-ptr } } -{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." } -{ $warning "This word is unsafe. Improper use can corrupt memory." } ; - HELP: malloc-array { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } } { $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." } @@ -293,11 +275,7 @@ ARTICLE: "c-strings" "C strings" $nl "Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:" { $subsection alien>char-string } -{ $subsection alien>u16-string } -{ $subsection memory>char-string } -{ $subsection memory>u16-string } -{ $subsection string>char-memory } -{ $subsection string>u16-memory } ; +{ $subsection alien>u16-string } ; ARTICLE: "c-data" "Passing data between Factor and C" "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code." 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/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 7d01fb2b00..c3f5c64b29 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: bit-arrays byte-arrays float-arrays arrays generator.registers assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations -system compiler.units ; +layouts system compiler.units io.files io.encodings.binary ; IN: alien.c-types DEFER: @@ -155,20 +155,9 @@ M: float-array byte-length length "double" heap-size * ; : memory>byte-array ( alien len -- byte-array ) dup [ -rot memcpy ] keep ; -: memory>char-string ( alien len -- string ) - memory>byte-array >string ; - -DEFER: c-ushort-array> - -: memory>u16-string ( alien len -- string ) - [ memory>byte-array ] keep 2/ c-ushort-array> >string ; - : byte-array>memory ( byte-array base -- ) swap dup length memcpy ; -: string>char-memory ( string base -- ) - >r B{ } like r> byte-array>memory ; - DEFER: >c-ushort-array : string>u16-memory ( string base -- ) @@ -273,6 +262,9 @@ M: long-long-type box-return ( type -- ) r> add* ] when ; +: malloc-file-contents ( path -- alien ) + binary file-contents malloc-byte-array ; + [ [ alien-cell ] [ set-alien-cell ] 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..fb7d50e882 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -6,7 +6,7 @@ inference.state inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.structs alien.syntax cpu.architecture alien inspector quotations assocs kernel.private threads continuations.private libc combinators -compiler.errors continuations ; +compiler.errors continuations layouts ; IN: alien.compiler ! Common protocol for alien-invoke/alien-callback/alien-indirect @@ -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-docs.factor b/core/assocs/assocs-docs.factor index 716ac64c9b..b6326e1c10 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -162,6 +162,7 @@ HELP: assoc-each { $description "Applies a quotation to each entry in the assoc." } { $examples { $example + "USING: assocs kernel math prettyprint ;" "H{ { \"bananas\" 5 } { \"apples\" 42 } { \"pears\" 17 } }" "0 swap [ nip + ] assoc-each ." "64" diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 8fabee06ef..a0a60e875a 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: assocs.tests USING: kernel math namespaces tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations ; diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index 5f89b90608..5774b86e45 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -1,6 +1,6 @@ USING: sequences arrays bit-arrays kernel tools.test math random ; -IN: temporary +IN: bit-arrays.tests [ 100 ] [ 100 length ] unit-test diff --git a/core/bit-vectors/bit-vectors-tests.factor b/core/bit-vectors/bit-vectors-tests.factor index 5838c1eb8d..dff9a8db37 100755 --- a/core/bit-vectors/bit-vectors-tests.factor +++ b/core/bit-vectors/bit-vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: bit-vectors.tests USING: tools.test bit-vectors vectors sequences kernel math ; [ 0 ] [ 123 length ] unit-test diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 608b5cb581..5ccde88e28 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -16,6 +16,14 @@ IN: bootstrap.compiler "cpu." cpu append require +: enable-compiler ( -- ) + [ optimized-recompile-hook ] recompile-hook set-global ; + +: disable-compiler ( -- ) + [ default-recompile-hook ] recompile-hook set-global ; + +enable-compiler + nl "Compiling some words to speed up bootstrap..." write flush @@ -74,12 +82,4 @@ nl malloc free memcpy } compile -: enable-compiler ( -- ) - [ compiled-usages recompile ] recompile-hook set-global ; - -: disable-compiler ( -- ) - [ default-recompile-hook ] recompile-hook set-global ; - -enable-compiler - " done" print flush diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor index 8c618a8f30..ae5c66a45c 100755 --- a/core/bootstrap/image/image-tests.factor +++ b/core/bootstrap/image/image-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: bootstrap.image.tests USING: bootstrap.image bootstrap.image.private tools.test ; \ ' must-infer diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 35dae109cf..f5f4d70d14 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -7,7 +7,7 @@ strings sbufs vectors words quotations assocs system layouts splitting growable classes tuples words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger float-arrays quotations.private -sequences.private combinators ; +sequences.private combinators io.encodings.binary ; IN: bootstrap.image : my-arch ( -- arch ) @@ -191,7 +191,9 @@ M: bignum ' M: fixnum ' #! When generating a 32-bit image on a 64-bit system, #! some fixnums should be bignums. - dup most-negative-fixnum most-positive-fixnum between? + dup + bootstrap-most-negative-fixnum + bootstrap-most-positive-fixnum between? [ tag-fixnum ] [ >bignum ' ] if ; ! Floats @@ -416,7 +418,7 @@ M: curry ' "Writing image to " write architecture get boot-image-name resource-path dup write "..." print flush - [ (write-image) ] with-file-writer ; + binary [ (write-image) ] with-stream ; PRIVATE> diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 97712972f3..aeb5ec1d82 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 @@ -75,6 +78,7 @@ call "strings" "strings.private" "system" + "system.private" "threads.private" "tools.profiler.private" "tuples" @@ -271,7 +275,7 @@ define-builtin } { { "object" "kernel" } - "?" + "compiled?" { "compiled?" "words" } f } @@ -620,6 +624,7 @@ builtins get num-tags get tail f union-class define-class { "fopen" "io.streams.c" } { "fgetc" "io.streams.c" } { "fread" "io.streams.c" } + { "fputc" "io.streams.c" } { "fwrite" "io.streams.c" } { "fflush" "io.streams.c" } { "fclose" "io.streams.c" } @@ -642,7 +647,8 @@ builtins get num-tags get tail f union-class define-class { "innermost-frame-scan" "kernel.private" } { "set-innermost-frame-quot" "kernel.private" } { "call-clear" "kernel" } - { "(os-envs)" "system" } + { "(os-envs)" "system.private" } + { "(set-os-envs)" "system.private" } { "resize-byte-array" "byte-arrays" } { "resize-bit-array" "bit-arrays" } { "resize-float-array" "float-arrays" } 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-docs.factor b/core/boxes/boxes-docs.factor index b3b91d06d9..3b8caaca1b 100755 --- a/core/boxes/boxes-docs.factor +++ b/core/boxes/boxes-docs.factor @@ -19,7 +19,7 @@ HELP: box> { $errors "Throws an error if the box is empty." } ; HELP: ?box -{ $values { "box" box } { "value" "the value of the box or " { $link f } } { "?" "a boolean" } } +{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" "a boolean" } } { $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ; ARTICLE: "boxes" "Boxes" 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/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index 0acf06c0c1..6a08f657a2 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -6,7 +6,7 @@ IN: byte-vectors vector ( byte-array capacity -- byte-vector ) +: byte-array>vector ( byte-array length -- byte-vector ) byte-vector construct-boa ; inline PRIVATE> diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 56dda6f904..df97a3eff5 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -1,4 +1,4 @@ -USING: generic help.markup help.syntax kernel kernel.private +USING: help.markup help.syntax kernel kernel.private namespaces sequences words arrays layouts help effects math layouts classes.private classes.union classes.mixin classes.predicate ; @@ -7,11 +7,6 @@ IN: classes ARTICLE: "builtin-classes" "Built-in classes" "Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior." $nl -"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:" -{ $subsection type } -"Built-in type numbers can be converted to classes, and vice versa:" -{ $subsection type>class } -{ $subsection type-number } "The set of built-in classes is a class:" { $subsection builtin-class } { $subsection builtin-class? } @@ -79,7 +74,7 @@ HELP: class { $values { "object" object } { "class" class } } { $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." } { $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." } -{ $examples { $example "USE: classes" "1.0 class ." "float" } { $example "USE: classes" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ; +{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ; HELP: classes { $values { "seq" "a sequence of class words" } } @@ -89,14 +84,14 @@ HELP: builtin-class { $class-description "The class of built-in classes." } { $examples "The class of arrays is a built-in class:" - { $example "USE: classes" "array builtin-class? ." "t" } - "However, a literal array is not a built-in class; it is not even a class:" - { $example "USE: classes" "{ 1 2 3 } builtin-class? ." "f" } + { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" } + "However, an instance of the array class is not a built-in class; it is not even a class:" + { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" } } ; HELP: tuple-class { $class-description "The class of tuple class words." } -{ $examples { $example "USE: classes\nTUPLE: name title first last ;\nname tuple-class? ." "t" } } ; +{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; HELP: typemap { $var-description "Hashtable mapping unions to class words, used to implement " { $link class-and } " and " { $link class-or } "." } ; @@ -167,7 +162,7 @@ HELP: types HELP: class-empty? { $values { "class" "a class" } { "?" "a boolean" } } { $description "Tests if a class is a union class with no members." } -{ $examples { $example "USE: classes" "null class-empty? ." "t" } } ; +{ $examples { $example "USING: classes kernel prettyprint ;" "null class-empty? ." "t" } } ; HELP: (class<) { $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } } @@ -182,8 +177,6 @@ HELP: sort-classes { $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } } { $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ; -{ sort-classes methods order } related-words - HELP: lookup-union { $values { "classes" "a hashtable mapping class words to themselves" } { "class" class } } { $description "Given a set of classes represented as a hashtable with equal keys and values, looks up a previously-defined union class having those members. If no union is defined, outputs " { $link object } "." } ; 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-docs.factor b/core/combinators/combinators-docs.factor index 5b87297b0c..f5d4470bde 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -82,7 +82,7 @@ HELP: with-datastack { $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } { $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } { $examples - { $example "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } + { $example "USING: combinators math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } } ; HELP: recursive-hashcode 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/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor index 678face309..6cce72eed0 100755 --- a/core/compiler/errors/errors-docs.factor +++ b/core/compiler/errors/errors-docs.factor @@ -24,8 +24,8 @@ HELP: compiler-error. { $description "Prints a compiler error to the " { $link stdio } " stream." } ; HELP: compiler-errors. -{ $values { "errors" "an assoc mapping words to errors" } } -{ $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ; +{ $values { "type" symbol } } +{ $description "Prints compiler errors to the " { $link stdio } " stream. The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ; HELP: :errors { $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ; 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..74dac17be8 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 { "words" "a sequence of words" } } +{ $description "Compiles a set of words." } ; + +HELP: compile-call +{ $values { "quot" "a quotation" } } +{ $description "Compiles and runs a quotation." } ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 225e1c17c6..9849ddca7d 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations assocs namespaces sequences words -vocabs definitions hashtables ; +vocabs definitions hashtables init ; IN: compiler.units SYMBOL: old-definitions @@ -37,10 +37,11 @@ SYMBOL: recompile-hook SYMBOL: definition-observers -definition-observers global [ V{ } like ] change-at - GENERIC: definitions-changed ( assoc obj -- ) +[ V{ } clone definition-observers set-global ] +"compiler.units" add-init-hook + : add-definition-observer ( obj -- ) definition-observers get push ; @@ -63,24 +64,45 @@ GENERIC: definitions-changed ( assoc obj -- ) dup changed-words get update dup dup changed-vocabs update ; +: compile ( words -- ) + recompile-hook get call + dup [ drop crossref? ] assoc-contains? + modify-code-heap ; + +SYMBOL: post-compile-tasks + +: after-compilation ( quot -- ) + post-compile-tasks get push ; + +: call-recompile-hook ( -- ) + changed-words get keys + compiled-usages recompile-hook get call ; + +: call-post-compile-tasks ( -- ) + post-compile-tasks get [ call ] each ; + : finish-compilation-unit ( -- ) - changed-words get keys recompile-hook get call + call-recompile-hook + call-post-compile-tasks + dup [ drop crossref? ] assoc-contains? modify-code-heap changed-definitions notify-definition-observers ; : with-compilation-unit ( quot -- ) [ H{ } clone changed-words set H{ } clone forgotten-definitions set + V{ } clone post-compile-tasks set new-definitions set old-definitions set [ finish-compilation-unit ] [ ] cleanup ] with-scope ; inline -: default-recompile-hook - [ f ] { } map>assoc - dup [ drop crossref? ] assoc-contains? - modify-code-heap ; +: compile-call ( quot -- ) + [ define-temp ] with-compilation-unit execute ; + +: default-recompile-hook ( words -- alist ) + [ f ] { } map>assoc ; recompile-hook global [ [ default-recompile-hook ] or ] diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 7cf15394ef..81063031f9 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private continuations.private parser vectors arrays namespaces -threads assocs words quotations ; +assocs words quotations ; IN: continuations ARTICLE: "errors-restartable" "Restartable errors" @@ -23,9 +23,10 @@ $nl "Two words raise an error in the innermost error handler for the current dynamic extent:" { $subsection throw } { $subsection rethrow } -"Two words for establishing an error handler:" +"Words for establishing an error handler:" { $subsection cleanup } { $subsection recover } +{ $subsection ignore-errors } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "errors-post-mortem" } ; @@ -44,11 +45,7 @@ ARTICLE: "continuations.private" "Continuation implementation details" { $subsection namestack } { $subsection set-namestack } { $subsection catchstack } -{ $subsection set-catchstack } -"The continuations implementation has hooks for single-steppers:" -{ $subsection walker-hook } -{ $subsection set-walker-hook } -{ $subsection (continue-with) } ; +{ $subsection set-catchstack } ; ARTICLE: "continuations" "Continuations" "At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation." @@ -110,10 +107,6 @@ HELP: callcc1 { $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } } { $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ; -HELP: (continue-with) -{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } } -{ $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ; - HELP: continue { $values { "continuation" continuation } } { $description "Resumes a continuation reified by " { $link callcc0 } "." } ; @@ -156,6 +149,10 @@ HELP: recover { $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } } { $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; +HELP: ignore-errors +{ $values { "quot" quotation } } +{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ; + HELP: rethrow { $values { "error" object } } { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } @@ -196,9 +193,3 @@ HELP: save-error { $values { "error" "an error" } } { $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." } $low-level-note ; - -HELP: init-error-handler -{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ; - -HELP: break -{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index b7d580afe5..d5ede60086 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -1,7 +1,7 @@ USING: kernel math namespaces io tools.test sequences vectors continuations debugger parser memory arrays words kernel.private ; -IN: temporary +IN: continuations.tests : (callcc1-test) swap 1- tuck swap ?push diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 19802da7df..13b31cfde6 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -6,6 +6,7 @@ IN: continuations SYMBOL: error SYMBOL: error-continuation +SYMBOL: error-thread SYMBOL: restarts : catchstack ( -- catchstack ) catchstack* clone ; inline @@ -91,14 +94,8 @@ C: continuation PRIVATE> -: set-walker-hook ( quot -- ) 3 setenv ; inline - -: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline - : continue-with ( obj continuation -- ) - [ - walker-hook [ >r 2array r> ] when* (continue-with) - ] 2 (throw) ; + [ (continue-with) ] 2 (throw) ; : continue ( continuation -- ) f swap continue-with ; @@ -116,15 +113,19 @@ PRIVATE> SYMBOL: thread-error-hook : rethrow ( error -- * ) + dup save-error catchstack* empty? [ thread-error-hook get-global [ 1 (throw) ] [ die ] if* ] when - dup save-error c> continue-with ; + c> continue-with ; : recover ( try recovery -- ) >r [ swap >c call c> drop ] curry r> ifcc ; inline +: ignore-errors ( quot -- ) + [ drop ] recover ; inline + : cleanup ( try cleanup-always cleanup-error -- ) over >r compose [ dip rethrow ] curry recover r> call ; inline @@ -171,34 +172,3 @@ M: condition compute-restarts condition-continuation [ ] curry { } assoc>map append ; - - - -! Debugging support -: with-walker-hook ( continuation -- ) - [ swap set-walker-hook (continue) ] curry callcc1 ; - -SYMBOL: break-hook - -: break ( -- ) - continuation callstack - over set-continuation-call - walker-hook [ (continue-with) ] [ break-hook get call ] if* ; - -GENERIC: (step-into) ( obj -- ) - -M: wrapper (step-into) wrapped break ; -M: object (step-into) break ; -M: callable (step-into) \ break add* break ; diff --git a/core/cpu/arm/assembler/assembler-tests.factor b/core/cpu/arm/assembler/assembler-tests.factor index 219015fae9..a30ab9f797 100644 --- a/core/cpu/arm/assembler/assembler-tests.factor +++ b/core/cpu/arm/assembler/assembler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: cpu.arm.assembler.tests USING: assembler-arm math test namespaces sequences kernel quotations ; diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index ecae55e69a..19b913541c 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 +generator.registers generator.fixup generator system layouts 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/64/64.factor b/core/cpu/x86/64/64.factor index 2996a3feeb..25e32225d4 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup system -alien alien.accessors alien.compiler alien.structs slots +layouts alien alien.accessors alien.compiler alien.structs slots splitting assocs ; IN: cpu.x86.64 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/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 2d7ffb762d..65caec412e 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator.fixup io.binary kernel combinators kernel.private math namespaces parser sequences -words system ; +words system layouts ; IN: cpu.x86.assembler ! A postfix assembler for x86 and AMD64. diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index b754856ee4..5e8b6df34a 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -1,6 +1,6 @@ USING: alien arrays generic generic.math help.markup help.syntax kernel math memory strings sbufs vectors io io.files classes -help generic.standard continuations system ; +help generic.standard continuations system debugger.private ; IN: debugger ARTICLE: "errors-assert" "Assertions" @@ -80,9 +80,6 @@ HELP: print-error HELP: restarts. { $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ; -HELP: debug-help -{ $description "Print a synopsis of useful debugger words." } ; - HELP: error-hook { $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." } { $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ; @@ -169,3 +166,6 @@ HELP: depth HELP: assert-depth { $values { "quot" "a quotation" } } { $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ; + +HELP: init-debugger +{ $description "Called on startup to set a pair of hooks which allow the " { $link throw } " word to function." } ; diff --git a/core/debugger/debugger-tests.factor b/core/debugger/debugger-tests.factor index 31c3e8a762..afa4aa1c28 100755 --- a/core/debugger/debugger-tests.factor +++ b/core/debugger/debugger-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: debugger.tests USING: debugger kernel continuations tools.test ; [ ] [ [ drop ] [ error. ] recover ] unit-test diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 776e2976d9..40bcbe78b1 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -5,7 +5,8 @@ math namespaces prettyprint sequences assocs sequences.private strings io.styles vectors words system splitting math.parser tuples continuations continuations.private combinators generic.math io.streams.duplex classes compiler.units -generic.standard vocabs ; +generic.standard vocabs threads threads.private init +kernel.private libc ; IN: debugger GENERIC: error. ( error -- ) @@ -31,6 +32,9 @@ M: string error. print ; : :get ( variable -- value ) error-continuation get continuation-name assoc-stack ; +: :vars ( -- ) + error-continuation get continuation-name namestack. ; + : :res ( n -- ) 1- restarts get-global nth f restarts set-global restart ; @@ -54,19 +58,6 @@ M: string error. print ; dup length [ restart. ] 2each ] if ; -: debug-help ( -- ) - nl - "Debugger commands:" print - nl - ":help - documentation for this error" print - ":s - data stack at exception time" print - ":r - retain stack at exception time" print - ":c - call stack at exception time" print - ":edit - jump to source location (parse errors only)" print - - ":get ( var -- value ) accesses variables at time of the error" print - flush ; - : print-error ( error -- ) [ error. flush ] curry [ global [ "Error in print-error!" print drop ] bind ] @@ -74,7 +65,12 @@ M: string error. print ; SYMBOL: error-hook -[ print-error restarts. debug-help ] error-hook set-global +[ + print-error + restarts. + nl + "Type :help for debugging help." print flush +] error-hook set-global : try ( quot -- ) [ error-hook get call ] recover ; @@ -257,3 +253,49 @@ M: no-compilation-unit error. M: no-vocab summary drop "Vocabulary does not exist" ; + +M: check-ptr summary + drop "Memory allocation failed" ; + +M: double-free summary + drop "Free failed since memory is not allocated" ; + +M: realloc-error summary + drop "Memory reallocation failed" ; + +: error-in-thread. ( -- ) + error-thread get-global + "Error in thread " write + [ + dup thread-id # + " (" % dup thread-name % + ", " % dup thread-quot unparse-short % ")" % + ] "" make swap write-object ":" print nl ; + +! Hooks +M: thread error-in-thread ( error thread -- ) + initial-thread get-global eq? [ + die drop + ] [ + global [ + error-in-thread. print-error flush + ] bind + ] if ; + + + +[ init-debugger ] "debugger" add-init-hook diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index f0b0888052..4e8fb255dd 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: definitions.tests USING: tools.test generic kernel definitions sequences compiler.units ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index ad261df7d4..01f9643cdd 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -43,7 +43,7 @@ M: object uses drop f ; : xref ( defspec -- ) dup uses crossref get add-vertex ; -: usage ( defspec -- seq ) crossref get at keys ; +: usage ( defspec -- seq ) \ f or crossref get at keys ; GENERIC: redefined* ( defspec -- ) diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index 203c975bb2..cd651bff2f 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -1,7 +1,7 @@ USING: dlists dlists.private kernel tools.test random assocs hashtables sequences namespaces sorting debugger io prettyprint math ; -IN: temporary +IN: dlists.tests [ t ] [ dlist-empty? ] unit-test diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index f473eb58c8..9e37ba4c85 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -58,7 +58,7 @@ HELP: effect>string { $values { "effect" effect } { "string" string } } { $description "Turns a stack effect object into a string mnemonic." } { $examples - { $example "USE: effects" "1 2 effect>string print" "( object -- object object )" } + { $example "USING: effects io ;" "1 2 effect>string print" "( object -- object object )" } } ; HELP: stack-effect 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/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 3ee93ba4a5..7581377a6a 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs hashtables kernel kernel.private math namespaces sequences words -quotations strings alien system combinators math.bitfields -words.private cpu.architecture ; +quotations strings alien layouts system combinators +math.bitfields words.private cpu.architecture ; IN: generator.fixup : no-stack-frame -1 ; inline diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index 4473df7277..432a2a0008 100755 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -57,7 +57,7 @@ HELP: generate { $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ; HELP: word-dataflow -{ $values { "word" word } { "effect" effect } { "dependencies" sequence } { "dataflow" "a dataflow graph" } } +{ $values { "word" word } { "effect" effect } { "dataflow" "a dataflow graph" } } { $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ; HELP: define-intrinsics diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 631aa7e62d..9b799d9143 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -1,6 +1,6 @@ -USING: help.markup help.syntax generic.math generic.standard -words classes definitions kernel alien combinators sequences -math quotations ; +USING: help.markup help.syntax words classes definitions kernel +alien sequences math quotations generic.standard generic.math +combinators ; IN: generic ARTICLE: "method-order" "Method precedence" @@ -33,8 +33,6 @@ $nl "New generic words can be defined:" { $subsection define-generic } { $subsection define-simple-generic } -"Methods are tuples:" -{ $subsection } "Methods can be added to existing generic words:" { $subsection define-method } "Method definitions can be looked up:" @@ -42,8 +40,10 @@ $nl { $subsection methods } "A generic word contains methods; the list of methods specializing on a class can also be obtained:" { $subsection implementors } -"Low-level words which rebuilds the generic word after methods are added or removed, or the method combination is changed:" +"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:" { $subsection make-generic } +"Low-level method constructor:" +{ $subsection } "A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":" { $subsection method-spec } ; @@ -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." } ; +{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } } +{ $description "Creates a new method." } ; HELP: methods { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } @@ -146,7 +148,7 @@ HELP: with-methods $low-level-note ; HELP: define-method -{ $values { "method" quotation } { "class" class } { "generic" generic } } +{ $values { "quot" quotation } { "class" class } { "generic" generic } } { $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ; HELP: implementors @@ -156,3 +158,5 @@ HELP: implementors HELP: forget-methods { $values { "class" class } } { $description "Remove all method definitions which specialize on the class." } ; + +{ sort-classes methods order } related-words diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index e3fdbc7b46..2dc699f87b 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -3,7 +3,7 @@ generic.math assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes continuations layouts classes.union sorting compiler.units ; -IN: temporary +IN: generic.tests GENERIC: foobar ( x -- y ) M: object foobar drop "Hello world" ; @@ -87,11 +87,11 @@ M: number union-containment drop 2 ; [ 2 ] [ 1.0 union-containment ] unit-test ! Testing recovery from bad method definitions -"IN: temporary GENERIC: unhappy ( x -- x )" eval +"IN: generic.tests GENERIC: unhappy ( x -- x )" eval [ - "IN: temporary M: dictionary unhappy ;" eval + "IN: generic.tests M: dictionary unhappy ;" eval ] must-fail -[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test +[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test GENERIC# complex-combination 1 ( a b -- c ) M: string complex-combination drop ; @@ -192,12 +192,12 @@ SYMBOL: redefinition-test-generic TUPLE: redefinition-test-tuple ; -"IN: temporary M: redefinition-test-tuple redefinition-test-generic ;" eval +"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval [ t ] [ [ redefinition-test-generic , - "IN: temporary TUPLE: redefinition-test-tuple ;" eval + "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval redefinition-test-generic , ] { } make all-equal? ] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 4bdd1ae40d..3c83b87d49 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 ) 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,36 @@ M: method-body stack-effect ! Definition protocol M: method-spec where - dup first2 method [ method-loc ] [ second where ] ?if ; + dup first2 method [ ] [ second ] ?if where ; -M: method-spec set-where first2 method set-method-loc ; +M: method-spec set-where + first2 method set-where ; -M: method-spec definer drop \ M: \ ; ; +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 ] [ drop ] if ; + [ forget-word ] [ drop ] if ; -M: method-spec forget* first2 forget-method ; +M: method-spec forget* + first2 forget-method ; + +M: method-body definer + drop \ M: \ ; ; + +M: method-body definition + "method-def" word-prop ; + +M: method-body forget* + dup "method-class" word-prop + swap "method-generic" word-prop + forget-method ; : implementors* ( classes -- words ) all-words [ @@ -154,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-docs.factor b/core/generic/math/math-docs.factor index b1148bb34e..cbbf070398 100644 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -1,26 +1,27 @@ USING: kernel generic help.markup help.syntax math classes -generic.math ; +sequences quotations ; +IN: generic.math HELP: math-upgrade -{ $values { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } } +{ $values { "class1" class } { "class2" class } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } } { $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." } -{ $examples { $example "USE: generic.math" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ; +{ $examples { $example "USING: generic.math math kernel prettyprint ;" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ; HELP: no-math-method -{ $values { "left" "an object" } { "right" "an object" } { "generic" "a generic word" } } +{ $values { "left" "an object" } { "right" "an object" } { "generic" generic } } { $description "Throws a " { $link no-math-method } " error." } { $error-description "Thrown by generic words using the " { $link math-combination } " method combination if there is no suitable method defined for the two inputs." } ; HELP: math-method -{ $values { "word" "a generic word" } { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation" } } +{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } } { $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." } -{ $examples { $example "USE: generic.math" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ; +{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ; HELP: math-class { $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ; HELP: math-combination -{ $values { "word" "a generic word" } { "quot" "a quotation" } } +{ $values { "word" generic } { "quot" quotation } } { $description "Generates a double-dispatching word definition. Only methods defined on numerical classes and " { $link object } " take effect in the math combination. Methods defined on numerical classes are guaranteed to have their two inputs upgraded to the highest priority type of the two." $nl "The math method combination is used for binary operators such as " { $link + } " and " { $link * } "." @@ -40,5 +41,5 @@ HELP: math-generic { $class-description "The class of generic words using " { $link math-combination } "." } ; HELP: last/first -{ $values { "seq" "a sequence" } { "pair" "a two-element array" } } +{ $values { "seq" sequence } { "pair" "a two-element array" } } { $description "Creates an array holding the first and last element of the sequence." } ; 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-docs.factor b/core/generic/standard/standard-docs.factor index 820a027d10..a6a65bb62f 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -1,5 +1,5 @@ -USING: generic help.markup help.syntax sequences -generic.standard ; +USING: generic help.markup help.syntax sequences ; +IN: generic.standard HELP: no-method { $values { "object" "an object" } { "generic" "a generic word" } } 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-docs.factor b/core/growable/growable-docs.factor index 02f6292001..9de3c8ab24 100755 --- a/core/growable/growable-docs.factor +++ b/core/growable/growable-docs.factor @@ -18,19 +18,19 @@ $nl ABOUT: "growable" HELP: set-fill -{ $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } } +{ $values { "n" "a new fill pointer" } { "seq" growable } } { $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." } { $side-effects "seq" } -{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; +{ $warning "This word is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; HELP: underlying -{ $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } } +{ $values { "seq" growable } { "underlying" "the underlying sequence" } } { $contract "Outputs the underlying storage of a resizable sequence." } ; HELP: set-underlying -{ $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } } +{ $values { "underlying" sequence } { "seq" growable } } { $contract "Modifies the underlying storage of a resizable sequence." } -{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; +{ $warning "This word is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; HELP: capacity { $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } } @@ -41,7 +41,7 @@ HELP: new-size { $description "Computes the new size of a resizable sequence." } ; HELP: ensure -{ $values { "n" "a positive integer" } { "seq" "a resizable sequence" } } +{ $values { "n" "a positive integer" } { "seq" growable } } { $description "If " { $snippet "n" } " is less than the length of the sequence, does nothing. Otherwise, if " { $snippet "n" } " also exceeds the capacity of the underlying storage, the underlying storage is grown, and the fill pointer is reset. Finally, if " { $snippet "n" } " is greater than or equal to the length but less than the capacity of the underlying storage, the fill pointer is moved and nothing else is done." $nl "This word is used in the implementation of the " { $link set-nth } " generic for sequences supporting the resizable sequence protocol (see " { $link "growable" } ")." 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-docs.factor b/core/hashtables/hashtables-docs.factor index 563a59d20f..d62afdffb5 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -128,14 +128,14 @@ HELP: prune { $values { "seq" "a sequence" } { "newseq" "a sequence" } } { $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." } { $examples - { $example "USE: hashtables" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" } + { $example "USING: hashtables prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" } } ; HELP: all-unique? { $values { "seq" sequence } { "?" "a boolean" } } { $description "Tests whether a sequence contains any repeated elements." } { $example - "USE: combinators.lib" + "USING: hashtables prettyprint ;" "{ 0 1 1 2 3 5 } all-unique? ." "f" } ; diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 31486372f2..a62b306378 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: hashtables.tests USING: kernel math namespaces tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations ; diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 8c935db859..7d8c6f0b5f 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private slots.private math assocs -math.private sequences sequences.private vectors ; + math.private sequences sequences.private vectors ; IN: hashtables over set-hash-array init-hash ; : (new-key@) ( key keys i -- keys n empty? ) - #! cond form expanded by hand for better interpreter speed 3dup swap array-nth dup ((empty)) eq? [ 2drop rot drop t ] [ diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor old mode 100644 new mode 100755 index 3605ec519a..f9224eafeb --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -11,69 +11,73 @@ $nl { $subsection min-heap? } { $subsection } "Max-heaps sort their elements so that the maximum element is first:" -{ $subsection min-heap } -{ $subsection min-heap? } -{ $subsection } +{ $subsection max-heap } +{ $subsection max-heap? } +{ $subsection } "Both obey a protocol." $nl "Queries:" { $subsection heap-empty? } -{ $subsection heap-length } +{ $subsection heap-size } { $subsection heap-peek } "Insertion:" { $subsection heap-push } +{ $subsection heap-push* } { $subsection heap-push-all } "Removal:" { $subsection heap-pop* } -{ $subsection heap-pop } ; +{ $subsection heap-pop } +{ $subsection heap-delete } ; ABOUT: "heaps" HELP: { $values { "min-heap" min-heap } } -{ $description "Create a new " { $link min-heap } "." } -{ $see-also } ; +{ $description "Create a new " { $link min-heap } "." } ; HELP: { $values { "max-heap" max-heap } } -{ $description "Create a new " { $link max-heap } "." } -{ $see-also } ; +{ $description "Create a new " { $link max-heap } "." } ; HELP: heap-push -{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } } -{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } -{ $side-effects "heap" } -{ $see-also heap-push-all heap-pop } ; +{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } } +{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } +{ $side-effects "heap" } ; + +HELP: heap-push* +{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } } +{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." } +{ $side-effects "heap" } ; HELP: heap-push-all -{ $values { "assoc" assoc } { "heap" heap } } +{ $values { "assoc" assoc } { "heap" "a heap" } } { $description "Push every key/value pair of an assoc onto a heap." } -{ $side-effects "heap" } -{ $see-also heap-push heap-pop } ; +{ $side-effects "heap" } ; HELP: heap-peek -{ $values { "heap" heap } { "key" object } { "value" object } } -{ $description "Outputs the first element in the heap, leaving it in the heap." } -{ $see-also heap-pop heap-pop* } ; +{ $values { "heap" "a heap" } { "key" object } { "value" object } } +{ $description "Output the first element in the heap, leaving it in the heap." } ; HELP: heap-pop* -{ $values { "heap" heap } } -{ $description "Removes the first element from the heap." } -{ $side-effects "heap" } -{ $see-also heap-pop heap-push heap-peek } ; +{ $values { "heap" "a heap" } } +{ $description "Remove the first element from the heap." } +{ $side-effects "heap" } ; HELP: heap-pop -{ $values { "heap" heap } { "key" object } { "value" object } } -{ $description "Outputs the first element in the heap and removes it from the heap." } -{ $side-effects "heap" } -{ $see-also heap-pop* heap-push heap-peek } ; +{ $values { "heap" "a heap" } { "key" object } { "value" object } } +{ $description "Output and remove the first element in the heap." } +{ $side-effects "heap" } ; HELP: heap-empty? -{ $values { "heap" heap } { "?" "a boolean" } } -{ $description "Tests if a " { $link heap } " has no nodes." } -{ $see-also heap-length heap-peek } ; +{ $values { "heap" "a heap" } { "?" "a boolean" } } +{ $description "Tests if a heap has no nodes." } ; -HELP: heap-length -{ $values { "heap" heap } { "n" integer } } -{ $description "Returns the number of key/value pairs in the heap." } -{ $see-also heap-empty? } ; +HELP: heap-size +{ $values { "heap" "a heap" } { "n" integer } } +{ $description "Returns the number of key/value pairs in the heap." } ; + +HELP: heap-delete +{ $values { "entry" entry } { "heap" "a heap" } } +{ $description "Remove the specified entry from the heap." } +{ $errors "Throws an error if the entry is from another heap or if it has already been deleted." } +{ $side-effects "heap" } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor old mode 100644 new mode 100755 index 92b06b866c..61e09d894e --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -1,9 +1,9 @@ -! Copyright 2007 Ryan Murphy +! Copyright 2007, 2008 Ryan Murphy, Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces tools.test -heaps heaps.private ; -IN: temporary +heaps heaps.private math.parser random assocs sequences sorting ; +IN: heaps.tests [ heap-pop ] must-fail [ heap-pop ] must-fail @@ -15,16 +15,8 @@ IN: temporary ! Binary Min Heap { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test -{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test -{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test - -[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ] -[ { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test - -[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [ - { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all - 3 [ dup heap-pop* ] times -] unit-test +{ t } [ t 5 f t 3 f T{ min-heap } heap-compare ] unit-test +{ f } [ t 5 f t 3 f T{ max-heap } heap-compare ] unit-test [ t 2 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test @@ -32,18 +24,51 @@ IN: temporary [ t 400 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test -[ 0 ] [ heap-length ] unit-test -[ 1 ] [ t 1 pick heap-push heap-length ] unit-test +[ 0 ] [ heap-size ] unit-test +[ 1 ] [ t 1 pick heap-push heap-size ] unit-test -[ { { 1 2 } { 3 4 } { 5 6 } } ] [ - T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } - [ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make -] unit-test -[ { { 1 2 } } ] [ - T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } - [ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make -] unit-test -[ { } ] [ - T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } - [ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make -] unit-test +: heap-sort ( alist -- keys ) + [ heap-push-all ] keep heap-pop-all ; + +: random-alist ( n -- alist ) + [ + [ + (random) dup number>string swap set + ] times + ] H{ } make-assoc ; + +: test-heap-sort ( n -- ? ) + random-alist dup >alist sort-keys swap heap-sort = ; + +14 [ + [ t ] swap [ 2^ test-heap-sort ] curry unit-test +] each + +: test-entry-indices ( n -- ? ) + random-alist + [ heap-push-all ] keep + heap-data dup length swap [ entry-index ] map sequence= ; + +14 [ + [ t ] swap [ 2^ test-entry-indices ] curry unit-test +] each + +: delete-random ( seq -- elt ) + dup length random dup pick nth >r swap delete-nth r> ; + +: sort-entries ( entries -- entries' ) + [ [ entry-key ] compare ] sort ; + +: delete-test ( n -- ? ) + [ + random-alist + [ heap-push-all ] keep + dup heap-data clone swap + ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times + heap-data + [ [ entry-key ] map ] 2apply + [ natural-sort ] 2apply ; + +11 [ + [ t ] swap [ 2^ delete-test sequence= ] curry unit-test +] each diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor old mode 100644 new mode 100755 index cd00dc0db3..caab0d8f8e --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -1,26 +1,31 @@ -! Copyright (C) 2007 Ryan Murphy, Doug Coleman. +! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman, +! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences arrays assocs ; +USING: kernel math sequences arrays assocs sequences.private +growable ; IN: heaps MIXIN: priority-queue -GENERIC: heap-push ( value key heap -- ) +GENERIC: heap-push* ( value key heap -- entry ) GENERIC: heap-peek ( heap -- value key ) GENERIC: heap-pop* ( heap -- ) GENERIC: heap-pop ( heap -- value key ) -GENERIC: heap-delete ( key heap -- ) -GENERIC: heap-delete* ( key heap -- old ? ) +GENERIC: heap-delete ( entry heap -- ) GENERIC: heap-empty? ( heap -- ? ) -GENERIC: heap-length ( heap -- n ) -GENERIC# heap-pop-while 2 ( heap pred quot -- ) +GENERIC: heap-size ( heap -- n ) ( class -- heap ) - >r V{ } clone heap construct-boa r> - construct-delegate ; inline + >r V{ } clone r> construct-delegate ; inline + +TUPLE: entry value key heap index ; + +: ( value key heap -- entry ) f entry construct-boa ; + PRIVATE> TUPLE: min-heap ; @@ -34,23 +39,67 @@ TUPLE: max-heap ; INSTANCE: min-heap priority-queue INSTANCE: max-heap priority-queue +M: priority-queue heap-empty? ( heap -- ? ) + heap-data empty? ; + +M: priority-queue heap-size ( heap -- n ) + heap-data length ; + r left r> nth ; inline -: right-value ( n heap -- obj ) >r right r> nth ; inline -: up-value ( n vec -- obj ) >r up r> nth ; inline -: swap-up ( n vec -- ) >r dup up r> exchange ; inline -: last-index ( vec -- n ) length 1- ; inline + +: left ( n -- m ) 1 shift 1 + ; inline + +: right ( n -- m ) 1 shift 2 + ; inline + +: up ( n -- m ) 1- 2/ ; inline + +: data-nth ( n heap -- entry ) + heap-data nth-unsafe ; inline + +: up-value ( n heap -- entry ) + >r up r> data-nth ; inline + +: left-value ( n heap -- entry ) + >r left r> data-nth ; inline + +: right-value ( n heap -- entry ) + >r right r> data-nth ; inline + +: data-set-nth ( entry n heap -- ) + >r [ swap set-entry-index ] 2keep r> + heap-data set-nth-unsafe ; + +: data-push ( entry heap -- n ) + dup heap-size [ + swap 2dup heap-data ensure 2drop data-set-nth + ] keep ; inline + +: data-pop ( heap -- entry ) + heap-data pop ; inline + +: data-pop* ( heap -- ) + heap-data pop* ; inline + +: data-peek ( heap -- entry ) + heap-data peek ; inline + +: data-first ( heap -- entry ) + heap-data first ; inline + +: data-exchange ( m n heap -- ) + [ tuck data-nth >r data-nth r> ] 3keep + tuck >r >r data-set-nth r> r> data-set-nth ; inline GENERIC: heap-compare ( pair1 pair2 heap -- ? ) -: (heap-compare) drop [ first ] compare 0 ; inline + +: (heap-compare) drop [ entry-key ] compare 0 ; inline + M: min-heap heap-compare (heap-compare) > ; + M: max-heap heap-compare (heap-compare) < ; : heap-bounds-check? ( m heap -- ? ) - heap-data length >= ; inline + heap-size >= ; inline : left-bounds-check? ( m heap -- ? ) >r left r> heap-bounds-check? ; inline @@ -58,41 +107,44 @@ M: max-heap heap-compare (heap-compare) < ; : right-bounds-check? ( m heap -- ? ) >r right r> heap-bounds-check? ; inline -: up-heap-continue? ( vec heap -- ? ) - >r [ last-index ] keep [ up-value ] keep peek r> +: continue? ( m up[m] heap -- ? ) + [ data-nth swap ] keep [ data-nth ] keep heap-compare ; inline -: up-heap ( vec heap -- ) - 2dup up-heap-continue? [ - >r dup last-index [ over swap-up ] keep - up 1+ head-slice r> up-heap +DEFER: up-heap + +: (up-heap) ( n heap -- ) + >r dup up r> + 3dup continue? [ + [ data-exchange ] 2keep up-heap ] [ - 2drop + 3drop ] if ; +: up-heap ( n heap -- ) + over 0 > [ (up-heap) ] [ 2drop ] if ; + : (child) ( m heap -- n ) - dupd - [ heap-data left-value ] 2keep - [ heap-data right-value ] keep heap-compare + 2dup right-value + >r 2dup left-value r> + rot heap-compare [ right ] [ left ] if ; : child ( m heap -- n ) - 2dup right-bounds-check? [ drop left ] [ (child) ] if ; + 2dup right-bounds-check? + [ drop left ] [ (child) ] if ; : swap-down ( m heap -- ) - [ child ] 2keep heap-data exchange ; + [ child ] 2keep data-exchange ; DEFER: down-heap -: down-heap-continue? ( heap m heap -- m heap ? ) - [ heap-data nth ] 2keep child pick - dupd [ heap-data nth swapd ] keep heap-compare ; - : (down-heap) ( m heap -- ) - 2dup down-heap-continue? [ - -rot [ swap-down ] keep down-heap - ] [ + [ child ] 2keep swapd + 3dup continue? [ 3drop + ] [ + [ data-exchange ] 2keep down-heap ] if ; : down-heap ( m heap -- ) @@ -100,40 +152,43 @@ DEFER: down-heap PRIVATE> -M: priority-queue heap-push ( value key heap -- ) - >r swap 2array r> - [ heap-data push ] keep - [ heap-data ] keep - up-heap ; +M: priority-queue heap-push* ( value key heap -- entry ) + [ dup ] keep [ data-push ] keep up-heap ; + +: heap-push ( value key heap -- ) heap-push* drop ; : heap-push-all ( assoc heap -- ) [ swapd heap-push ] curry assoc-each ; +: >entry< ( entry -- key value ) + { entry-value entry-key } get-slots ; + M: priority-queue heap-peek ( heap -- value key ) - heap-data first first2 swap ; + data-first >entry< ; + +: entry>index ( entry heap -- n ) + over entry-heap eq? [ + "Invalid entry passed to heap-delete" throw + ] unless + entry-index ; + +M: priority-queue heap-delete ( entry heap -- ) + [ entry>index ] keep + 2dup heap-size 1- = [ + nip data-pop* + ] [ + [ nip data-pop ] 2keep + [ data-set-nth ] 2keep + down-heap + ] if ; M: priority-queue heap-pop* ( heap -- ) - dup heap-data length 1 > [ - [ heap-data pop ] keep - [ heap-data set-first ] keep - 0 swap down-heap - ] [ - heap-data pop* - ] if ; + dup data-first swap heap-delete ; -M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ; +M: priority-queue heap-pop ( heap -- value key ) + dup data-first [ swap heap-delete ] keep >entry< ; -M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ; - -M: priority-queue heap-length ( heap -- n ) heap-data length ; - -: (heap-pop-while) ( heap pred quot -- ) - pick heap-empty? [ - 3drop - ] [ - [ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep - roll [ (heap-pop-while) ] [ 3drop ] if - ] if ; - -M: priority-queue heap-pop-while ( heap pred quot -- ) - [ heap-pop ] swap [ t ] 3compose (heap-pop-while) ; +: heap-pop-all ( heap -- alist ) + [ dup heap-empty? not ] + [ dup heap-pop swap 2array ] + [ ] unfold nip ; diff --git a/core/inference/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 691010e9ca..17197db667 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -1,10 +1,10 @@ -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 alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units -system ; +system layouts ; ! Make sure these compile even though this is invalid code [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test @@ -288,3 +288,10 @@ cell-bits 32 = [ [ HEX: ff bitand 0 HEX: ff between? ] \ >= inlined? ] unit-test + +[ t ] [ + [ HEX: ff swap HEX: ff bitand >= ] + \ >= inlined? +] unit-test + + diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index b841080c94..3c12e388c4 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -5,8 +5,8 @@ sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector tuples classes.union classes.predicate debugger threads.private io.streams.string io.timeouts -sequences.private ; -IN: temporary +io.thread sequences.private ; +IN: inference.tests { 0 2 } [ 2 "Hello" ] must-infer-as { 1 2 } [ dup ] must-infer-as @@ -440,7 +440,7 @@ DEFER: bar \ error. must-infer ! Test odds and ends -\ idle-thread must-infer +\ io-thread must-infer ! Incorrect stack declarations on inline recursive words should ! be caught diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 8e8251ff62..235c2924bb 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -10,7 +10,8 @@ namespaces.private parser prettyprint quotations quotations.private sbufs sbufs.private sequences sequences.private slots.private strings strings.private system threads.private tuples tuples.private vectors vectors.private -words words.private assocs inspector compiler.units ; +words words.private assocs inspector compiler.units +system.private ; IN: inference.known-words ! Shuffle words @@ -538,6 +539,8 @@ set-primitive-effect \ fwrite { string alien } { } set-primitive-effect +\ fputc { object alien } { } set-primitive-effect + \ fread { integer string } { object } set-primitive-effect \ fflush { alien } { } set-primitive-effect @@ -595,6 +598,8 @@ set-primitive-effect \ (os-envs) { } { array } set-primitive-effect +\ (set-os-envs) { array } { } set-primitive-effect + \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop \ dll-valid? { object } { object } set-primitive-effect 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/inspector/inspector.factor b/core/inspector/inspector.factor old mode 100644 new mode 100755 index 868cffb81c..449d34f05b --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables io kernel assocs math namespaces prettyprint sequences strings io.styles vectors words @@ -93,6 +93,15 @@ SYMBOL: +editable+ : describe ( obj -- ) H{ } describe* ; +: namestack. ( seq -- ) + [ + [ global eq? not ] subset + [ keys ] map concat prune + ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ; + +: .vars ( -- ) + namestack namestack. ; + SYMBOL: inspector-hook [ H{ { +number-rows+ t } } describe* ] inspector-hook set-global diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor index e295cc34dc..04f34068eb 100644 --- a/core/io/backend/backend-tests.factor +++ b/core/io/backend/backend-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.backend.tests USING: tools.test io.backend kernel ; [ ] [ "a" normalize-pathname drop ] unit-test diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index c38b7355b1..1595ecd576 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,13 +1,17 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: init kernel system namespaces ; +USING: init kernel system namespaces io io.encodings io.encodings.utf8 ; IN: io.backend SYMBOL: io-backend HOOK: init-io io-backend ( -- ) -HOOK: init-stdio io-backend ( -- ) +HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ) + +: init-stdio ( -- ) + (init-stdio) utf8 stderr set-global + utf8 stdio set-global ; HOOK: io-multiplex io-backend ( ms -- ) @@ -19,7 +23,7 @@ HOOK: normalize-pathname io-backend ( str -- newstr ) M: object normalize-pathname ; -: set-io-backend ( backend -- ) +: set-io-backend ( io-backend -- ) io-backend set-global init-io init-stdio ; [ init-io embedded? [ init-stdio ] unless ] diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor index 69e733b55a..a6fea14fc7 100755 --- a/core/io/binary/binary-tests.factor +++ b/core/io/binary/binary-tests.factor @@ -1,8 +1,10 @@ -USING: io.binary tools.test ; -IN: temporary +USING: io.binary tools.test classes math ; +IN: io.binary.tests -[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test -[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test +[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test +[ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test [ 1234 ] [ 1234 4 >be be> ] unit-test [ 1234 ] [ 1234 4 >le le> ] unit-test + +[ fixnum ] [ B{ 0 0 0 0 0 0 0 0 0 0 } be> class ] unit-test diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor old mode 100644 new mode 100755 index c4d3abefce..f2ede93fd5 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -3,14 +3,14 @@ USING: kernel math sequences ; IN: io.binary -: le> ( seq -- x ) B{ } like byte-array>bignum ; +: le> ( seq -- x ) B{ } like byte-array>bignum >integer ; : be> ( seq -- x ) le> ; : mask-byte ( x -- y ) HEX: ff bitand ; inline : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline -: >le ( x n -- str ) [ nth-byte ] with "" map-as ; +: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ; : >be ( x n -- str ) >le dup reverse-here ; : d>w/w ( d -- w1 w2 ) diff --git a/core/io/crc32/crc32-docs.factor b/core/io/crc32/crc32-docs.factor index 3855c77cd8..7f85ee2b4e 100644 --- a/core/io/crc32/crc32-docs.factor +++ b/core/io/crc32/crc32-docs.factor @@ -6,7 +6,7 @@ HELP: crc32 { $description "Computes the CRC32 checksum of a sequence of bytes." } ; HELP: lines-crc32 -{ $values { "lines" "a sequence of strings" } { "n" integer } } +{ $values { "seq" "a sequence of strings" } { "n" integer } } { $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ; ARTICLE: "io.crc32" "CRC32 checksum calculation" 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/binary/binary-docs.factor b/core/io/encodings/binary/binary-docs.factor index f8be5054df..823eea67be 100644 --- a/core/io/encodings/binary/binary-docs.factor +++ b/core/io/encodings/binary/binary-docs.factor @@ -2,4 +2,4 @@ USING: help.syntax help.markup ; IN: io.encodings.binary HELP: binary -{ $class-description "This is the encoding descriptor for binary I/O." } ; +{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } ; diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor index c4c6237715..b8bcc0f87a 100644 --- a/core/io/encodings/binary/binary.factor +++ b/core/io/encodings/binary/binary.factor @@ -1,3 +1,3 @@ -USING: kernel io.encodings ; - -TUPLE: binary ; +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +IN: io.encodings.binary SYMBOL: binary diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor new file mode 100644 index 0000000000..e5e71b05f0 --- /dev/null +++ b/core/io/encodings/encodings-docs.factor @@ -0,0 +1,68 @@ +USING: help.markup help.syntax ; +IN: io.encodings + +ABOUT: "encodings" + +ARTICLE: "io.encodings" "I/O encodings" +"Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream." +{ $subsection "encodings-constructors" } +{ $subsection "encodings-descriptors" } +{ $subsection "encodings-protocol" } ; + +ARTICLE: "encodings-constructors" "Constructing an encoded stream" +{ $subsection } +{ $subsection } +{ $subsection } ; + +HELP: ( stream encoding -- newstream ) +{ $values { "stream" "an output stream" } + { "encoding" "an encoding descriptor" } + { "newstream" "an encoded output stream" } } +{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ; + +HELP: ( stream encoding -- newstream ) +{ $values { "stream" "an input stream" } + { "encoding" "an encoding descriptor" } + { "newstream" "an encoded output stream" } } +{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ; + +HELP: ( stream-in stream-out encoding -- duplex ) +{ $values { "stream-in" "an input stream" } + { "stream-out" "an output stream" } + { "encoding" "an encoding descriptor" } + { "duplex" "an encoded duplex stream" } } +{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." } ; + +{ } related-words + +ARTICLE: "encodings-descriptors" "Encoding descriptors" +"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" +$nl { $vocab-link "io.encodings.utf8" } +$nl { $vocab-link "io.encodings.ascii" } +$nl { $vocab-link "io.encodings.binary" } +$nl { $vocab-link "io.encodings.utf16" } ; + +ARTICLE: "encodings-protocol" "Encoding protocol" +"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again." +{ $subsection decode-step } +{ $subsection init-decoder } +{ $subsection stream-write-encoded } ; + +HELP: decode-step ( buf char encoding -- ) +{ $values { "buf" "A string buffer which characters can be pushed to" } + { "char" "An octet which is read from a stream" } + { "encoding" "An encoding descriptor tuple" } } +{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ; + +HELP: stream-write-encoded ( string stream encoding -- ) +{ $values { "string" "a string" } + { "stream" "an output stream" } + { "encoding" "an encoding descriptor" } } +{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ; + +HELP: init-decoder ( stream encoding -- encoding ) +{ $values { "stream" "an input stream" } + { "encoding" "an encoding descriptor" } } +{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ; + +{ init-decoder decode-step stream-write-encoded } related-words diff --git a/core/io/streams/lines/lines-tests.factor b/core/io/encodings/encodings-tests.factor similarity index 86% rename from core/io/streams/lines/lines-tests.factor rename to core/io/encodings/encodings-tests.factor index 64dc7bff3b..73d2efa7d4 100755 --- a/core/io/streams/lines/lines-tests.factor +++ b/core/io/encodings/encodings-tests.factor @@ -1,9 +1,9 @@ -USING: io.streams.lines io.files io.streams.string io -tools.test kernel ; -IN: temporary +USING: io.files io.streams.string io +tools.test kernel io.encodings.ascii ; +IN: io.streams.encodings.tests : ( resource -- stream ) - resource-path ; + resource-path ascii ; [ { } ] [ "/core/io/test/empty-file.txt" lines ] diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 2d94e3ea80..2f68334bde 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -1,13 +1,24 @@ -! Copyright (C) 2006, 2007 Daniel Ehrenberg. +! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain -namespaces unicode growable strings io classes io.streams.c -continuations ; +USING: math kernel sequences sbufs vectors namespaces +growable strings io classes continuations combinators +io.styles io.streams.plain io.encodings.binary splitting +io.streams.duplex byte-arrays ; IN: io.encodings -TUPLE: encode-error ; +! The encoding descriptor protocol -: encode-error ( -- * ) \ encode-error construct-empty throw ; +GENERIC: decode-step ( buf char encoding -- ) +M: object decode-step drop swap push ; + +GENERIC: init-decoder ( stream encoding -- encoding ) +M: tuple-class init-decoder construct-empty init-decoder ; +M: object init-decoder nip ; + +GENERIC: stream-write-encoded ( string stream encoding -- byte-array ) +M: object stream-write-encoded drop stream-write ; + +! Decoding TUPLE: decode-error ; @@ -15,24 +26,12 @@ TUPLE: decode-error ; SYMBOL: begin -: decoded ( buf ch -- buf ch state ) +: push-decoded ( buf ch -- buf ch state ) over push 0 begin ; : push-replacement ( buf -- buf ch state ) - CHAR: replacement-character decoded ; - -: finish-decoding ( buf ch state -- str ) - begin eq? [ decode-error ] unless drop "" like ; - -: start-decoding ( seq length -- buf ch state seq ) - 0 begin roll ; - -GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) - -: decode ( seq quot -- string ) - >r dup length start-decoding r> - [ -rot ] swap compose each - finish-decoding ; inline + ! This is the replacement character + HEX: fffd push-decoded ; : space ( resizable -- room-left ) dup underlying swap [ length ] 2apply - ; @@ -42,54 +41,113 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) : end-read-loop ( buf ch state stream quot -- string/f ) 2drop 2drop >string f like ; -: decode-read-loop ( buf ch state stream encoding -- string/f ) - >r >r pick r> r> rot full? [ end-read-loop ] [ +: decode-read-loop ( buf stream encoding -- string/f ) + pick full? [ 2drop >string ] [ over stream-read1 [ - -rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop - ] [ end-read-loop ] if* + -rot tuck >r >r >r dupd r> decode-step r> r> + decode-read-loop + ] [ 2drop >string f like ] if* ] if ; : decode-read ( length stream encoding -- string ) - >r swap start-decoding r> - decode-read-loop ; + rot -rot decode-read-loop ; -: ( stream decoding-class -- decoded-stream ) - construct-delegate ; +TUPLE: decoder code cr ; +: ( stream encoding -- newstream ) + dup binary eq? [ drop ] [ + dupd init-decoder { set-delegate set-decoder-code } + decoder construct + ] if ; -: ( stream encoding-class -- encoded-stream ) - construct-delegate ; +: cr+ t swap set-decoder-cr ; inline -GENERIC: encode-string ( string encoding -- byte-array ) -M: tuple-class encode-string construct-empty encode-string ; +: cr- f swap set-decoder-cr ; inline -MIXIN: encoding-stream +: line-ends/eof ( stream str -- str ) f like swap cr- ; inline -M: encoding-stream stream-read1 1 swap stream-read ; +: line-ends\r ( stream str -- str ) swap cr+ ; inline -M: encoding-stream stream-read - [ delegate ] keep decode-read ; +: line-ends\n ( stream str -- str ) + over decoder-cr over empty? and + [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline -M: encoding-stream stream-read-partial stream-read ; +: handle-readln ( stream str ch -- str ) + { + { f [ line-ends/eof ] } + { CHAR: \r [ line-ends\r ] } + { CHAR: \n [ line-ends\n ] } + } case ; -M: encoding-stream stream-read-until +: fix-read ( stream string -- string ) + over decoder-cr [ + over cr- + "\n" ?head [ + swap stream-read1 [ add ] when* + ] [ nip ] if + ] [ nip ] if ; + +M: decoder stream-read + tuck { delegate decoder-code } get-slots decode-read fix-read ; + +M: decoder stream-read-partial stream-read ; + +: decoder-read-until ( stream delim -- ch ) ! Copied from { c-reader stream-read-until }!!! - [ swap read-until-loop ] "" make + over stream-read1 dup [ + dup pick memq? [ 2nip ] [ , decoder-read-until ] if + ] [ + 2nip + ] if ; + +M: decoder stream-read-until + ! Copied from { c-reader stream-read-until }!!! + [ swap decoder-read-until ] "" make swap over empty? over not and [ 2drop f f ] when ; -M: encoding-stream stream-write1 +: fix-read1 ( stream char -- char ) + over decoder-cr [ + over cr- + dup CHAR: \n = [ + drop stream-read1 + ] [ nip ] if + ] [ nip ] if ; + +M: decoder stream-read1 + 1 swap stream-read f like [ first ] [ f ] if* ; + +M: decoder stream-readln ( stream -- str ) + "\r\n" over stream-read-until handle-readln ; + +! Encoding + +TUPLE: encode-error ; + +: encode-error ( -- * ) \ encode-error construct-empty throw ; + +TUPLE: encoder code ; +: ( stream encoding -- newstream ) + dup binary eq? [ drop ] [ + construct-empty { set-delegate set-encoder-code } + encoder construct + ] if ; + +M: encoder stream-write1 >r 1string r> stream-write ; -M: encoding-stream stream-write - [ encode-string ] keep delegate stream-write ; +M: encoder stream-write + { delegate encoder-code } get-slots stream-write-encoded ; -M: encoding-stream dispose delegate dispose ; +M: encoder dispose delegate dispose ; -GENERIC: underlying-stream ( encoded-stream -- delegate ) -M: encoding-stream underlying-stream delegate ; +INSTANCE: encoder plain-writer -GENERIC: set-underlying-stream ( new-underlying stream -- ) -M: encoding-stream set-underlying-stream set-delegate ; +! Rebinding duplex streams which have not read anything yet -: set-encoding ( encoding stream -- ) ! This doesn't work now - [ underlying-stream swap construct-delegate ] keep - set-underlying-stream ; +: reencode ( stream encoding -- newstream ) + over encoder? [ >r delegate r> ] when ; + +: redecode ( stream encoding -- newstream ) + over decoder? [ >r delegate r> ] when ; + +: ( stream-in stream-out encoding -- duplex ) + tuck reencode >r redecode r> ; diff --git a/core/io/encodings/latin1/latin1.factor b/core/io/encodings/latin1/latin1.factor deleted file mode 100755 index e6d6281eb6..0000000000 --- a/core/io/encodings/latin1/latin1.factor +++ /dev/null @@ -1,10 +0,0 @@ -USING: io io.encodings strings kernel ; -IN: io.encodings.latin1 - -TUPLE: latin1 ; - -M: latin1 stream-read delegate stream-read >string ; - -M: latin1 stream-read-until delegate stream-read-until >string ; - -M: latin1 stream-read-partial delegate stream-read-partial >string ; diff --git a/core/io/encodings/latin1/authors.txt b/core/io/encodings/string/authors.txt similarity index 100% rename from core/io/encodings/latin1/authors.txt rename to core/io/encodings/string/authors.txt diff --git a/core/io/encodings/string/string-docs.factor b/core/io/encodings/string/string-docs.factor new file mode 100644 index 0000000000..0a35eee272 --- /dev/null +++ b/core/io/encodings/string/string-docs.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax byte-arrays strings ; +IN: io.encodings.string + +ARTICLE: "io.encodings.string" "Encoding and decoding strings" +"Strings can be encoded or decoded to and from byte arrays through an encoding with the following words:" +{ $subsection encode } +{ $subsection decode } ; + +HELP: decode +{ $values { "byte-array" byte-array } { "encoding" "an encoding descriptor" } + { "string" string } } +{ $description "Decodes the byte array using the given encoding, outputting a string" } ; + +HELP: encode +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } } +{ $description "Encodes the given string into a byte array with the given encoding." } ; diff --git a/core/io/encodings/string/string-tests.factor b/core/io/encodings/string/string-tests.factor new file mode 100644 index 0000000000..ddae9c8734 --- /dev/null +++ b/core/io/encodings/string/string-tests.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: strings io.encodings.utf8 io.encodings.utf16 +io.encodings.string tools.test ; +IN: io.encodings.string.tests + +[ "hello" ] [ "hello" utf8 decode ] unit-test +[ "he" ] [ "\0h\0e" utf16be decode ] unit-test + +[ "hello" ] [ "hello" utf8 encode >string ] unit-test +[ "\0h\0e" ] [ "he" utf16be encode >string ] unit-test diff --git a/core/io/encodings/string/string.factor b/core/io/encodings/string/string.factor new file mode 100644 index 0000000000..5e57a943a9 --- /dev/null +++ b/core/io/encodings/string/string.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.streams.byte-array ; +IN: io.encodings.string + +: decode ( byte-array encoding -- string ) + contents ; + +: encode ( string encoding -- byte-array ) + [ write ] with-byte-writer ; diff --git a/core/io/encodings/string/summary.txt b/core/io/encodings/string/summary.txt new file mode 100644 index 0000000000..59b8927dea --- /dev/null +++ b/core/io/encodings/string/summary.txt @@ -0,0 +1 @@ +Encoding and decoding strings diff --git a/core/io/encodings/latin1/tags.txt b/core/io/encodings/string/tags.factor similarity index 100% rename from core/io/encodings/latin1/tags.txt rename to core/io/encodings/string/tags.factor diff --git a/core/io/encodings/utf16/tags.txt b/core/io/encodings/tags.txt similarity index 100% rename from core/io/encodings/utf16/tags.txt rename to core/io/encodings/tags.txt diff --git a/core/io/encodings/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor deleted file mode 100644 index c49c030ef3..0000000000 --- a/core/io/encodings/utf16/utf16-docs.factor +++ /dev/null @@ -1,45 +0,0 @@ -USING: help.markup help.syntax io.encodings strings ; -IN: io.encodings.utf16 - -ARTICLE: "io.utf16" "Working with UTF16-encoded data" -"The UTF16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences." -{ $subsection encode-utf16le } -{ $subsection encode-utf16be } -{ $subsection decode-utf16le } -{ $subsection decode-utf16be } -"Support for UTF16 data with a byte order mark:" -{ $subsection encode-utf16 } -{ $subsection decode-utf16 } ; - -ABOUT: "io.utf16" - -HELP: decode-utf16 -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in UTF16 format. The bytes must begin with a UTF16 byte order mark, which determines if the input is in little or big endian. To decode data without a byte order mark, use " { $link decode-utf16le } " or " { $link decode-utf16be } "." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; - -HELP: decode-utf16be -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in big endian UTF16 format. The bytes must not begin with a UTF16 byte order mark. To decode data with a byte order mark, use " { $link decode-utf16 } "." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; - -HELP: decode-utf16le -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in little endian UTF16 format. The bytes must not begin with a UTF16 byte order mark. To decode data with a byte order mark, use " { $link decode-utf16 } "." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; - -{ decode-utf16 decode-utf16le decode-utf16be } related-words - -HELP: encode-utf16be -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in big endian UTF16 format." } ; - -HELP: encode-utf16le -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in little endian UTF16 format." } ; - -HELP: encode-utf16 -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in UTF16 format with a byte order mark." } ; - -{ encode-utf16 encode-utf16be encode-utf16le } related-words diff --git a/core/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor deleted file mode 100755 index 041c486915..0000000000 --- a/core/io/encodings/utf16/utf16-tests.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: kernel tools.test io.encodings.utf16 arrays sbufs sequences io.encodings -io unicode ; - -: decode-w/stream ( array encoding -- newarray ) - >r >sbuf dup reverse-here r> contents >array ; - -: encode-w/stream ( array encoding -- newarray ) - >r SBUF" " clone tuck r> stream-write >array ; - -[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test -[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode-w/stream ] unit-test - -[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode-w/stream ] unit-test - -[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode-w/stream ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode-w/stream ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test - -[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode-w/stream ] unit-test - -[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode-w/stream ] unit-test -[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode-w/stream ] unit-test - -[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode-w/stream ] unit-test diff --git a/core/io/encodings/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor index 6e1923824f..dbbc193a02 100755 --- a/core/io/encodings/utf8/utf8-docs.factor +++ b/core/io/encodings/utf8/utf8-docs.factor @@ -1,18 +1,11 @@ -USING: help.markup help.syntax io.encodings strings ; +USING: help.markup help.syntax io.encodings strings io.files ; IN: io.encodings.utf8 ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data" -"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." -{ $subsection encode-utf8 } -{ $subsection decode-utf8 } ; +"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences. The encoding descriptor for UTF-8:" +{ $subsection utf8 } ; + +HELP: utf8 +{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. This conforms to the " { $link "encodings-protocol" } "." } ; ABOUT: "io.encodings.utf8" - -HELP: decode-utf8 -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in UTF8 format." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; - -HELP: encode-utf8 -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in UTF8 format." } ; diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor old mode 100644 new mode 100755 index 44d0870385..af169854c9 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -1,21 +1,21 @@ -USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings -sequences strings arrays unicode ; +USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ; +IN: io.encodings.utf8.tests : decode-utf8-w/stream ( array -- newarray ) - >sbuf dup reverse-here utf8 contents ; + utf8 decode >array ; : encode-utf8-w/stream ( array -- newarray ) - SBUF" " clone tuck utf8 stream-write >array ; + utf8 encode >array ; -[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test -[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test +[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream ] unit-test [ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test [ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream ] unit-test [ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 6a3a8b8ec7..5887a8375e 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -1,11 +1,13 @@ -! Copyright (C) 2006, 2007 Daniel Ehrenberg. +! Copyright (C) 2006, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors growable io continuations -namespaces io.encodings combinators strings io.streams.c ; +namespaces io.encodings combinators strings ; IN: io.encodings.utf8 ! Decoding UTF-8 +TUPLE: utf8 ch state ; + SYMBOL: double SYMBOL: triple SYMBOL: triple2 @@ -23,7 +25,7 @@ SYMBOL: quad3 : begin-utf8 ( buf byte -- buf ch state ) { - { [ dup -7 shift zero? ] [ decoded ] } + { [ dup -7 shift zero? ] [ push-decoded ] } { [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] } { [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] } { [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] } @@ -31,7 +33,7 @@ SYMBOL: quad3 } cond ; : end-multibyte ( buf byte ch -- buf ch state ) - f append-nums [ decoded ] unless* ; + f append-nums [ push-decoded ] unless* ; : decode-utf8-step ( buf byte ch state -- buf ch state ) { @@ -44,42 +46,42 @@ SYMBOL: quad3 { quad3 [ end-multibyte ] } } case ; -: decode-utf8 ( seq -- str ) - [ decode-utf8-step ] decode ; +: unpack-state ( encoding -- ch state ) + { utf8-ch utf8-state } get-slots ; + +: pack-state ( ch state encoding -- ) + { set-utf8-ch set-utf8-state } set-slots ; + +M: utf8 decode-step ( buf char encoding -- ) + [ unpack-state decode-utf8-step ] keep pack-state drop ; + +M: utf8 init-decoder nip begin over set-utf8-state ; ! Encoding UTF-8 : encoded ( char -- ) - BIN: 111111 bitand BIN: 10000000 bitor , ; + BIN: 111111 bitand BIN: 10000000 bitor write1 ; : char>utf8 ( char -- ) { - { [ dup -7 shift zero? ] [ , ] } + { [ dup -7 shift zero? ] [ write1 ] } { [ dup -11 shift zero? ] [ - dup -6 shift BIN: 11000000 bitor , + dup -6 shift BIN: 11000000 bitor write1 encoded ] } { [ dup -16 shift zero? ] [ - dup -12 shift BIN: 11100000 bitor , + dup -12 shift BIN: 11100000 bitor write1 dup -6 shift encoded encoded ] } { [ t ] [ - dup -18 shift BIN: 11110000 bitor , + dup -18 shift BIN: 11110000 bitor write1 dup -12 shift encoded dup -6 shift encoded encoded ] } } cond ; -: encode-utf8 ( str -- seq ) - [ [ char>utf8 ] each ] B{ } make ; - -! Interface for streams - -TUPLE: utf8 ; -INSTANCE: utf8 encoding-stream - -M: utf8 encode-string drop encode-utf8 ; -M: utf8 decode-step drop decode-utf8-step ; -! In the future, this should detect and ignore a BOM at the beginning +M: utf8 stream-write-encoded + ! For efficiency, this should be modified to avoid variable reads + drop [ [ char>utf8 ] each ] with-stream* ; diff --git a/core/io/files/authors.txt b/core/io/files/authors.txt index 1901f27a24..a44f8d7f8d 100644 --- a/core/io/files/authors.txt +++ b/core/io/files/authors.txt @@ -1 +1,2 @@ Slava Pestov +Daniel Ehrenberg diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 185fa1436b..1ff972b505 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -1,70 +1,179 @@ 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 } +{ $subsection file-contents } +{ $subsection file-lines } ; + +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 file-info } +{ $subsection link-info } { $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" } { $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 "USING: io 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 + { $example "USING: io.files prettyprint ;" "\"/usr/bin/gcc\" file-name ." "\"gcc\"" } + { $example "USING: io.files prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } +} ; + +! need a $class-description file-info + +HELP: file-info + { $values { "path" "a pathname string" } + { "info" "a file-info tuple" } } + { $description "Queries the file system for meta data. " + "If path refers to a symbolic link, it is followed." + "If the file does not exist, an exception is thrown." } ; +! need a see also to link-info + +HELP: link-info + { $values { "path" "a pathname string" } + { "info" "a file-info tuple" } } + { $description "Queries the file system for meta data. " + "If path refers to a symbolic link, information about " + "the symbolic link itself is returned." + "If the file does not exist, an exception is thrown." } ; +! need a see also to file-info HELP: -{ $values { "path" "a pathname string" } { "stream" "an input stream" } } -{ $description "Outputs an input stream for reading from the specified pathname." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } } + { "stream" "an input stream" } } +{ $description "Outputs an input stream for reading from the specified pathname using the given encoding." } { $errors "Throws an error if the file is unreadable." } ; HELP: -{ $values { "path" "a pathname string" } { "stream" "an output stream" } } -{ $description "Outputs an output stream for writing to the specified pathname. The file's length is truncated to zero." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } +{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The file's length is truncated to zero." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: -{ $values { "path" "a pathname string" } { "stream" "an output stream" } } -{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } +{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The stream begins writing at the end of the file." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: with-file-reader -{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } { $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." } { $errors "Throws an error if the file is unreadable." } ; HELP: with-file-writer -{ $values { "path" "a pathname string" } { "quot" "a quotation" } } -{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } +{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-stream } "." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: with-file-appender -{ $values { "path" "a pathname string" } { "quot" "a quotation" } } -{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } +{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + +HELP: file-lines +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" "an array of strings" } } +{ $description "Opens the file at the given path using the given encoding, and returns a list of the lines in that file." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + +HELP: file-contents +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } } +{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: cwd @@ -77,7 +186,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 +222,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 +235,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 +274,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..e2eeef6528 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,68 +1,125 @@ -IN: temporary -USING: tools.test io.files io threads kernel continuations ; +IN: io.files.tests +USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ ] [ - "test-foo.txt" resource-path [ - "Hello world." print - ] with-file-writer + { "Hello world." } + "test-foo.txt" temp-file ascii set-file-lines ] unit-test [ ] [ - "test-foo.txt" resource-path [ + "test-foo.txt" temp-file ascii [ "Hello appender." print - ] with-stream + ] with-file-appender ] unit-test [ ] [ - "test-bar.txt" resource-path [ + "test-bar.txt" temp-file ascii [ "Hello appender." print - ] with-stream + ] with-file-appender ] unit-test [ "Hello world.\nHello appender.\n" ] [ - "test-foo.txt" resource-path file-contents + "test-foo.txt" temp-file ascii file-contents ] unit-test [ "Hello appender.\n" ] [ - "test-bar.txt" resource-path file-contents + "test-bar.txt" temp-file ascii 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 ascii 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 ascii [ [ 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 ascii [ [ 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 + +[ ] [ + { "Hi" } + "delete-tree-test/a/b/c/d" temp-file ascii set-file-lines +] unit-test + +[ ] [ + "delete-tree-test" temp-file delete-tree +] unit-test + +[ ] [ + "copy-tree-test/a/b/c" temp-file make-directories +] unit-test + +[ ] [ + "Foobar" + "copy-tree-test/a/b/c/d" temp-file + ascii set-file-contents +] unit-test + +[ ] [ + "copy-tree-test" temp-file + "copy-destination" temp-file copy-tree +] unit-test + +[ "Foobar" ] [ + "copy-destination/a/b/c/d" temp-file ascii 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 ascii 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 ascii file-contents +] unit-test + +[ ] [ "d" temp-file delete-file ] unit-test + +[ ] [ "copy-destination" temp-file delete-tree ] unit-test + +[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test + +[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1824a47867..cbb6e77ff9 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,34 +1,31 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg. ! 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 ; +system combinators splitting sbufs continuations io.encodings +io.encodings.binary ; +IN: io.files -HOOK: cd io-backend ( path -- ) +HOOK: (file-reader) io-backend ( path -- stream ) -HOOK: cwd io-backend ( -- path ) +HOOK: (file-writer) io-backend ( path -- stream ) -HOOK: io-backend ( path -- stream ) +HOOK: (file-appender) io-backend ( path -- stream ) -HOOK: io-backend ( path -- stream ) +: ( path encoding -- stream ) + swap (file-reader) swap ; -HOOK: io-backend ( path -- stream ) +: ( path encoding -- stream ) + swap (file-writer) swap ; -HOOK: delete-file io-backend ( path -- ) +: ( path encoding -- stream ) + swap (file-appender) swap ; HOOK: rename-file io-backend ( from to -- ) -HOOK: make-directory io-backend ( path -- ) - -HOOK: delete-directory io-backend ( path -- ) - +! 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 +36,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 +68,44 @@ 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 ) +HOOK: link-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,46 +119,133 @@ 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 [ + binary [ + swap binary [ swap stream-copy ] with-disposal ] with-disposal ; -: 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-file-into ( from to -- ) + to-directory copy-file ; -: home ( -- dir ) - { - { [ winnt? ] [ "USERPROFILE" os-env ] } - { [ wince? ] [ "" resource-path ] } - { [ unix? ] [ "HOME" os-env ] } - } cond ; +: copy-files-into ( files to -- ) + [ copy-file-into ] curry each ; +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? ; + +! Pathname presentations TUPLE: pathname string ; C: pathname M: pathname <=> [ pathname-string ] compare ; -: file-lines ( path -- seq ) lines ; +: file-lines ( path encoding -- seq ) + lines ; -: file-contents ( path -- str ) - dup swap file-length - [ stream-copy ] keep >string ; - -: with-file-reader ( path quot -- ) +: with-file-reader ( path encoding quot -- ) >r r> with-stream ; inline -: with-file-writer ( path quot -- ) +: file-contents ( path encoding -- str ) + dupd [ file-length read ] with-file-reader ; + +: with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline -: with-file-appender ( path quot -- ) +: set-file-lines ( seq path encoding -- ) + [ [ print ] each ] with-file-writer ; + +: set-file-contents ( str path encoding -- ) + [ write ] with-file-writer ; + +: with-file-appender ( path encoding 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+ ; + +! 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..fd40950e62 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,52 +95,62 @@ $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" } -{ $see-also "io.streams.string" "io.streams.lines" "io.streams.plain" "io.streams.duplex" } ; +{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ; 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 old mode 100644 new mode 100755 index 23686abab5..22c942d2d9 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,14 +1,15 @@ USING: arrays io io.files kernel math parser strings system -tools.test words namespaces ; -IN: temporary +tools.test words namespaces io.encodings.latin1 +io.encodings.binary ; +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 ) - resource-path ; + resource-path latin1 ; [ "This is a line.\rThis is another line.\r" @@ -31,10 +32,10 @@ IN: temporary ! [ ] [ "123" write 9000 CHAR: x write flush ] unit-test -[ "" ] [ +[ "/core/io/test/binary.txt" [ 0.2 read ] with-stream -] unit-test +] must-fail [ { @@ -53,7 +54,7 @@ IN: temporary ] unit-test [ ] [ - image [ + image binary [ 10 [ 65536 read drop ] times ] with-file-reader ] unit-test diff --git a/core/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor new file mode 100644 index 0000000000..741725af41 --- /dev/null +++ b/core/io/streams/byte-array/byte-array-docs.factor @@ -0,0 +1,34 @@ +USING: help.syntax help.markup io byte-arrays quotations ; +IN: io.streams.byte-array + +ABOUT: "io.streams.byte-array" + +ARTICLE: "io.streams.byte-array" "Byte-array streams" +"Byte array streams:" +{ $subsection } +{ $subsection } +"Utility combinators:" +{ $subsection with-byte-reader } +{ $subsection with-byte-writer } ; + +HELP: +{ $values { "byte-array" byte-array } + { "encoding" "an encoding descriptor" } + { "stream" "a new byte reader" } } +{ $description "Creates an input stream reading from a byte array using an encoding." } ; + +HELP: +{ $values { "encoding" "an encoding descriptor" } + { "stream" "a new byte writer" } } +{ $description "Creates an output stream writing data to a byte array using an encoding." } ; + +HELP: with-byte-reader +{ $values { "encoding" "an encoding descriptor" } + { "quot" quotation } { "byte-array" byte-array } } +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream for reading from a byte array using an encoding." } ; + +HELP: with-byte-writer +{ $values { "encoding" "an encoding descriptor" } + { "quot" quotation } + { "byte-array" byte-array } } +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an output stream writing data to a byte array using an encoding." } ; diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor index eb224650f3..d5ca8eac68 100644 --- a/core/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -3,14 +3,14 @@ sequences io namespaces ; IN: io.streams.byte-array : ( encoding -- stream ) - 512 swap ; + 512 swap ; : with-byte-writer ( encoding quot -- byte-array ) >r r> [ stdio get ] compose with-stream* >byte-array ; inline : ( byte-array encoding -- stream ) - >r >byte-vector dup reverse-here r> ; + >r >byte-vector dup reverse-here r> ; : with-byte-reader ( byte-array encoding quot -- ) >r r> with-stream ; inline diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor index de8a756f92..5d9c7b1a53 100644 --- a/core/io/streams/c/c-docs.factor +++ b/core/io/streams/c/c-docs.factor @@ -6,7 +6,6 @@ ARTICLE: "io.streams.c" "ANSI C streams" "C streams are found in the " { $vocab-link "io.streams.c" } " vocabulary; they are " { $link "stream-protocol" } " implementations which read and write C " { $snippet "FILE*" } " handles." { $subsection } { $subsection } -{ $subsection } "Underlying primitives used to implement the above:" { $subsection fopen } { $subsection fwrite } @@ -31,10 +30,6 @@ HELP: ( out -- stream ) { $description "Creates a stream which writes data by calling C standard library functions." } { $notes "Usually C streams are only used during bootstrap, and non-blocking OS-specific I/O routines are used during normal operation." } ; -HELP: -{ $values { "in" "a C FILE* handle" } { "out" "a C FILE* handle" } { "stream" "a new stream" } } -{ $description "Creates a stream which reads and writes data by calling C standard library functions, wrapping the input portion in a " { $link line-reader } " and the output portion in a " { $link plain-writer } "." } ; - HELP: fopen ( path mode -- alien ) { $values { "path" "a pathname string" } { "mode" "an access mode specifier" } { "alien" "a C FILE* handle" } } { $description "Opens a file named by " { $snippet "path" } ". The " { $snippet "mode" } " parameter should be something like " { $snippet "\"r\"" } " or " { $snippet "\"rw\"" } "; consult the " { $snippet "fopen(3)" } " manual page for details." } diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 5ace929ceb..4a3d94a172 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,10 +1,10 @@ -USING: tools.test io.files io io.streams.c ; -IN: temporary +USING: tools.test io.files io io.streams.c +io.encodings.ascii strings ; +IN: io.streams.c.tests [ "hello world" ] [ - "test.txt" resource-path [ - "hello world" write - ] with-file-writer + "hello world" "test.txt" temp-file ascii set-file-contents - "test.txt" resource-path "rb" fopen contents + "test.txt" temp-file "rb" fopen contents + >string ] unit-test diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 288ab212d1..372acbe0c1 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private namespaces io -strings sequences math generic threads.private classes -io.backend io.streams.lines io.streams.plain io.streams.duplex -io.files continuations ; +USING: kernel kernel.private namespaces io io.encodings +sequences math generic threads.private classes io.backend +io.streams.duplex io.files continuations byte-arrays ; IN: io.streams.c TUPLE: c-writer handle ; @@ -11,7 +10,7 @@ TUPLE: c-writer handle ; C: c-writer M: c-writer stream-write1 - >r 1string r> stream-write ; + c-writer-handle fputc ; M: c-writer stream-write c-writer-handle fwrite ; @@ -27,7 +26,7 @@ TUPLE: c-reader handle ; C: c-reader M: c-reader stream-read - >r >fixnum r> c-reader-handle fread ; + c-reader-handle fread ; M: c-reader stream-read-partial stream-read ; @@ -43,41 +42,39 @@ M: c-reader stream-read1 ] if ; M: c-reader stream-read-until - [ swap read-until-loop ] "" make swap + [ swap read-until-loop ] B{ } make swap over empty? over not and [ 2drop f f ] when ; M: c-reader dispose c-reader-handle fclose ; -: ( in out -- stream ) - >r r> - - ; - M: object init-io ; : stdin-handle 11 getenv ; : stdout-handle 12 getenv ; : stderr-handle 38 getenv ; -M: object init-stdio - stdin-handle stdout-handle stdio set-global - stderr-handle stderr set-global ; +M: object (init-stdio) + stdin-handle + stdout-handle + stderr-handle ; -M: object io-multiplex (sleep) ; +M: object io-multiplex 60 60 * 1000 * or (sleep) ; -M: object - "rb" fopen ; +M: object (file-reader) + "rb" fopen ; -M: object - "wb" fopen ; +M: object (file-writer) + "wb" fopen ; -M: object - "ab" fopen ; +M: object (file-appender) + "ab" fopen ; : show ( msg -- ) #! A word which directly calls primitives. It is used to #! print stuff from contexts where the I/O system would #! otherwise not work (tools.deploy.shaker, the I/O #! multiplexer thread). - "\r\n" append stdout-handle fwrite stdout-handle fflush ; + "\r\n" append >byte-array + stdout-handle fwrite + stdout-handle fflush ; 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-docs.factor b/core/io/streams/lines/lines-docs.factor deleted file mode 100644 index 789a060ed5..0000000000 --- a/core/io/streams/lines/lines-docs.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: help.markup help.syntax io strings ; -IN: io.streams.lines - -ARTICLE: "io.streams.lines" "Line reader streams" -"Line reader streams wrap an underlying stream and provide a default implementation of " { $link stream-readln } "." -{ $subsection line-reader } -{ $subsection } ; - -ABOUT: "io.streams.lines" - -HELP: line-reader -{ $class-description "An input stream which delegates to an underlying stream while providing an implementation of the " { $link stream-readln } " word in terms of the underlying stream's " { $link stream-read-until } ". Line readers are created by calling " { $link } "." } ; - -HELP: -{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } } -{ $description "Creates a new " { $link line-reader } "." } -{ $notes "Stream constructors should call this word to wrap streams that do not natively support reading lines. Unix (" { $snippet "\\n" } "), Windows (" { $snippet "\\r\\n" } ") and MacOS (" { $snippet "\\r" } ") line endings are supported." } ; diff --git a/core/io/streams/lines/lines.factor b/core/io/streams/lines/lines.factor deleted file mode 100755 index 391c602cc3..0000000000 --- a/core/io/streams/lines/lines.factor +++ /dev/null @@ -1,57 +0,0 @@ -! Copyright (C) 2004, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: io.streams.lines -USING: arrays generic io kernel math namespaces sequences -vectors combinators splitting ; - -TUPLE: line-reader cr ; - -: ( stream -- new-stream ) - line-reader construct-delegate ; - -: cr+ t swap set-line-reader-cr ; inline - -: cr- f swap set-line-reader-cr ; inline - -: line-ends/eof ( stream str -- str ) f like swap cr- ; inline - -: line-ends\r ( stream str -- str ) swap cr+ ; inline - -: line-ends\n ( stream str -- str ) - over line-reader-cr over empty? and - [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline - -: handle-readln ( stream str ch -- str ) - { - { f [ line-ends/eof ] } - { CHAR: \r [ line-ends\r ] } - { CHAR: \n [ line-ends\n ] } - } case ; - -M: line-reader stream-readln ( stream -- str ) - "\r\n" over delegate stream-read-until handle-readln ; - -: fix-read ( stream string -- string ) - over line-reader-cr [ - over cr- - "\n" ?head [ - swap stream-read1 [ add ] when* - ] [ nip ] if - ] [ nip ] if ; - -M: line-reader stream-read - tuck delegate stream-read fix-read ; - -M: line-reader stream-read-partial - tuck delegate stream-read-partial fix-read ; - -: fix-read1 ( stream char -- char ) - over line-reader-cr [ - over cr- - dup CHAR: \n = [ - drop stream-read1 - ] [ nip ] if - ] [ nip ] if ; - -M: line-reader stream-read1 ( stream -- char ) - dup delegate stream-read1 fix-read1 ; diff --git a/core/io/streams/lines/summary.txt b/core/io/streams/lines/summary.txt deleted file mode 100644 index 8c0c096f0b..0000000000 --- a/core/io/streams/lines/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Read lines of text from a character-oriented stream 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/plain/plain-docs.factor b/core/io/streams/plain/plain-docs.factor index 4d7c5cc25e..a84e5be4f7 100644 --- a/core/io/streams/plain/plain-docs.factor +++ b/core/io/streams/plain/plain-docs.factor @@ -8,17 +8,10 @@ ARTICLE: "io.streams.plain" "Plain writer streams" { $link make-span-stream } ", " { $link make-block-stream } " and " { $link make-cell-stream } "." -{ $subsection plain-writer } -{ $subsection } ; +{ $subsection plain-writer } ; ABOUT: "io.streams.plain" HELP: plain-writer -{ $class-description "An output stream which delegates to an underlying stream while providing an implementation of the extended stream output protocol in a trivial way. Plain writers are created by calling " { $link } "." } -{ $see-also "stream-protocol" } ; - -HELP: -{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } } -{ $description "Creates a new " { $link plain-writer } "." } -{ $notes "Stream constructors should call this word to wrap streams that do not natively support the extended stream output protocol." } +{ $class-description "An output stream mixin providing an implementation of the extended stream output protocol in a trivial way." } { $see-also "stream-protocol" } ; diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor index 70421eb1c2..4898a58fb1 100644 --- a/core/io/streams/plain/plain.factor +++ b/core/io/streams/plain/plain.factor @@ -1,13 +1,9 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel io io.streams.nested ; IN: io.streams.plain -USING: generic assocs kernel math namespaces sequences -io.styles io io.streams.nested ; -TUPLE: plain-writer ; - -: ( stream -- new-stream ) - plain-writer construct-delegate ; +MIXIN: plain-writer M: plain-writer stream-nl CHAR: \n swap stream-write1 ; diff --git a/core/io/streams/string/string-docs.factor b/core/io/streams/string/string-docs.factor index e948d2162a..91ac244608 100644 --- a/core/io/streams/string/string-docs.factor +++ b/core/io/streams/string/string-docs.factor @@ -26,4 +26,4 @@ HELP: HELP: with-string-reader { $values { "str" string } { "quot" quotation } } -{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end. The accumulated string is output when the quotation returns." } ; +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end." } ; 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/streams/string/string.factor b/core/io/streams/string/string.factor index a45c616b9a..7833e0aa47 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.string USING: io kernel math namespaces sequences sbufs strings -generic splitting io.streams.plain io.streams.lines growable -continuations ; +generic splitting growable continuations io.streams.plain +io.encodings ; M: growable dispose drop ; @@ -12,38 +12,19 @@ M: growable stream-write push-all ; M: growable stream-flush drop ; : ( -- stream ) - 512 ; + 512 ; : with-string-writer ( quot -- str ) swap [ stdio get ] compose with-stream* >string ; inline -: format-column ( seq ? -- seq ) - [ - [ 0 [ length max ] reduce ] keep - swap [ CHAR: \s pad-right ] curry map - ] unless ; - -: map-last ( seq quot -- seq ) - swap dup length - [ zero? rot [ call ] keep swap ] 2map nip ; inline - -: format-table ( table -- seq ) - flip [ format-column ] map-last - flip [ " " join ] map ; - -M: plain-writer stream-write-table - [ drop format-table [ print ] each ] with-stream* ; - -M: plain-writer make-cell-stream 2drop ; - M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ; : harden-as ( seq growble-exemplar -- newseq ) underlying like ; : growable-read-until ( growable n -- str ) - dupd tail-slice swap harden-as dup reverse-here ; + >fixnum dupd tail-slice swap harden-as dup reverse-here ; : find-last-sep swap [ memq? ] curry find-last drop ; @@ -69,7 +50,31 @@ M: growable stream-read-partial stream-read ; : ( str -- stream ) - >sbuf dup reverse-here ; + >sbuf dup reverse-here f ; : with-string-reader ( str quot -- ) >r r> with-stream ; inline + +INSTANCE: growable plain-writer + +: format-column ( seq ? -- seq ) + [ + [ 0 [ length max ] reduce ] keep + swap [ CHAR: \s pad-right ] curry map + ] unless ; + +: map-last ( seq quot -- seq ) + swap dup length + [ zero? rot [ call ] keep swap ] 2map nip ; inline + +: format-table ( table -- seq ) + flip [ format-column ] map-last + flip [ " " join ] map ; + +M: plain-writer stream-write-table + [ drop format-table [ print ] each ] with-stream* ; + +M: plain-writer make-cell-stream 2drop ; + +M: growable stream-readln ( stream -- str ) + "\r\n" over stream-read-until handle-readln ; diff --git a/core/io/test/no-trailing-eol.factor b/core/io/test/no-trailing-eol.factor index aa4d8b82d1..959f145bf5 100644 --- a/core/io/test/no-trailing-eol.factor +++ b/core/io/test/no-trailing-eol.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.tests USE: math : foo 2 2 + ; FORGET: foo \ No newline at end of file diff --git a/core/io/thread/thread.factor b/core/io/thread/thread.factor index 53ab5193c6..fe86ba9e3d 100755 --- a/core/io/thread/thread.factor +++ b/core/io/thread/thread.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.thread -USING: threads io.backend namespaces init ; +USING: threads io.backend namespaces init math ; : io-thread ( -- ) sleep-time io-multiplex yield ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 456c3cc4ca..8e107975bb 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -127,22 +127,28 @@ ARTICLE: "conditionals" "Conditionals and logic" { $see-also "booleans" "bitwise-arithmetic" both? either? } ; ARTICLE: "equality" "Equality and comparison testing" -"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object, or you can test if two objects are equal in some sense, usually by being instances of the same class, and having equal slot values. Both notions of equality are equality relations in the mathematical sense." +"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense." +$nl +"Identity comparison:" { $subsection eq? } +"Value comparison:" { $subsection = } +"Generic words for custom value comparison methods:" +{ $subsection equal? } "Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":" { $subsection <=> } { $subsection compare } +"Utilities for comparing objects:" +{ $subsection after? } +{ $subsection before? } +{ $subsection after=? } +{ $subsection before=? } "An object can be cloned; the clone has distinct identity but equal value:" { $subsection clone } ; ! 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." } ; @@ -229,21 +235,18 @@ HELP: equal? { $contract "Tests if two objects are equal." $nl - "Method definitions should ensure that this is an equality relation:" + "User code should call " { $link = } " instead; that word first tests the case where the objects are " { $link eq? } ", and so by extension, methods defined on " { $link equal? } " assume they are never called on " { $link eq? } " objects." + $nl + "Method definitions should ensure that this is an equality relation, modulo the assumption that the two objects are not " { $link eq? } ". That is, for any three non-" { $link eq? } " objects " { $snippet "a" } ", " { $snippet "b" } " and " { $snippet "c" } ", we must have:" { $list - { $snippet "a = a" } { { $snippet "a = b" } " implies " { $snippet "b = a" } } { { $snippet "a = b" } " and " { $snippet "b = c" } " implies " { $snippet "a = c" } } } - "While user code can define methods for this generic word, it should not call it directly, since it does not handle the case where the two references point to the same object." } { $examples - "The most common reason for defining a method for this generic word to ensure that instances of a specific tuple class are only ever equal to themselves, overriding the default implementation which checks slot values for equality." + "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:" { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" } - "Note that with the above definition, calling " { $link equal? } " directly will give unexpected results:" - { $unchecked-example "T{ foo } dup equal? ." "f" } - { $unchecked-example "T{ foo } dup clone equal? ." "f" } - "As documented above, " { $link = } " should be called instead:" + "By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:" { $unchecked-example "T{ foo } dup = ." "t" } { $unchecked-example "T{ foo } dup clone = ." "f" } } ; @@ -268,7 +271,7 @@ HELP: compare { $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "n" integer } } { $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." } { $examples - { $example "\"hello\" \"hi\" [ length ] compare ." "3" } + { $example "USING: kernel prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "3" } } ; HELP: clone @@ -300,9 +303,9 @@ HELP: and { $notes "This word implements boolean and, so applying it to integers will not yield useful results (all integers have a true value). Bitwise and is the " { $link bitand } " word." } { $examples "Usually only the boolean value of the result is used, however you can also explicitly rely on the behavior that if both inputs are true, the second is output:" - { $example "t f and ." "f" } - { $example "t 7 and ." "7" } - { $example "\"hi\" 12.0 and ." "12.0" } + { $example "USING: kernel prettyprint ;" "t f and ." "f" } + { $example "USING: kernel prettyprint ;" "t 7 and ." "7" } + { $example "USING: kernel prettyprint ;" "\"hi\" 12.0 and ." "12.0" } } ; HELP: or @@ -311,8 +314,8 @@ HELP: or { $notes "This word implements boolean inclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise inclusive or is the " { $link bitor } " word." } { $examples "Usually only the boolean value of the result is used, however you can also explicitly rely on the behavior that the result will be the first true input:" - { $example "t f or ." "t" } - { $example "\"hi\" 12.0 or ." "\"hi\"" } + { $example "USING: kernel prettyprint ;" "t f or ." "t" } + { $example "USING: kernel prettyprint ;" "\"hi\" 12.0 or ." "\"hi\"" } } ; HELP: xor @@ -324,23 +327,21 @@ HELP: both? { $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } } { $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." } { $examples - { $example "3 5 [ odd? ] both? ." "t" } - { $example "12 7 [ even? ] both? ." "f" } + { $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" } + { $example "USING: kernel math prettyprint ;" "12 7 [ even? ] both? ." "f" } } ; HELP: either? { $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } } { $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." } { $examples - { $example "3 6 [ odd? ] either? ." "t" } - { $example "5 7 [ even? ] either? ." "f" } + { $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" } + { $example "USING: kernel math prettyprint ;" "5 7 [ even? ] either? ." "f" } } ; -HELP: call ( callable -- ) -{ $values { "quot" callable } } -{ $description "Calls a quotation." -$nl -"Under the covers, pushes the current call frame on the call stack, and set the call frame to the given quotation." } +HELP: call +{ $values { "callable" callable } } +{ $description "Calls a quotation." } { $examples "The following two lines are equivalent:" { $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" } @@ -493,9 +494,9 @@ HELP: curry ( obj quot -- curry ) $nl "This operation is efficient and does not copy the quotation." } { $examples - { $example "5 [ . ] curry ." "[ 5 . ]" } - { $example "\\ = [ see ] curry ." "[ \\ = see ]" } - { $example "{ 1 2 3 } 2 [ - ] curry map ." "{ -1 0 1 }" } + { $example "USING: kernel prettyprint ;" "5 [ . ] curry ." "[ 5 . ]" } + { $example "USING: kernel prettyprint ;" "\\ = [ see ] curry ." "[ \\ = see ]" } + { $example "USING: kernel math prettyprint sequences ;" "{ 1 2 3 } 2 [ - ] curry map ." "{ -1 0 1 }" } } ; HELP: 2curry @@ -503,7 +504,7 @@ HELP: 2curry { $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } " and " { $snippet "obj2" } " and then calls " { $snippet "quot" } "." } { $notes "This operation is efficient and does not copy the quotation." } { $examples - { $example "5 4 [ + ] 2curry ." "[ 5 4 + ]" } + { $example "USING: kernel math prettyprint ;" "5 4 [ + ] 2curry ." "[ 5 4 + ]" } } ; HELP: 3curry @@ -520,7 +521,7 @@ HELP: with } { $notes "This operation is efficient and does not copy the quotation." } { $examples - { $example "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" } + { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" } } ; HELP: compose diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 2972cb2d5d..3c40984d7a 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs ; -IN: temporary +IN: kernel.tests [ 0 ] [ f size ] unit-test [ t ] [ [ \ = \ = ] all-equal? ] unit-test diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d1f3af4779..61574e406f 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -3,8 +3,6 @@ USING: kernel.private ; IN: kernel -: version ( -- str ) "0.92" ; foldable - ! Stack stuff : spin ( x y z -- z y x ) swap rot ; inline diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor index 0ce4c9bb73..d4188dd3b6 100755 --- a/core/layouts/layouts-docs.factor +++ b/core/layouts/layouts-docs.factor @@ -1,5 +1,7 @@ -USING: layouts generic help.markup help.syntax kernel math -memory namespaces sequences kernel.private classes ; +USING: generic help.markup help.syntax kernel math +memory namespaces sequences kernel.private classes +sequences.private ; +IN: layouts HELP: tag-bits { $var-description "Number of least significant bits reserved for a type tag in a tagged pointer." } @@ -35,3 +37,88 @@ HELP: most-positive-fixnum HELP: most-negative-fixnum { $values { "n" "smallest negative integer representable by a fixnum" } } ; + +HELP: bootstrap-first-bignum +{ $values { "n" "smallest positive integer not representable by a fixnum" } } +{ $description "Outputs the value for the target architecture when bootstrapping." } ; + +HELP: bootstrap-most-positive-fixnum +{ $values { "n" "largest positive integer representable by a fixnum" } } +{ $description "Outputs the value for the target architecture when bootstrapping." } ; + +HELP: bootstrap-most-negative-fixnum +{ $values { "n" "smallest negative integer representable by a fixnum" } } +{ $description "Outputs the value for the target architecture when bootstrapping." } ; + +HELP: cell +{ $values { "n" "a positive integer" } } +{ $description "Outputs the pointer size in bytes of the current CPU architecture." } ; + +HELP: cells +{ $values { "m" integer } { "n" integer } } +{ $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ; + +HELP: cell-bits +{ $values { "n" integer } } +{ $description "Outputs the number of bits in one CPU operand-sized cell." } ; + +HELP: bootstrap-cell +{ $values { "n" "a positive integer" } } +{ $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; + +HELP: bootstrap-cells +{ $values { "m" integer } { "n" integer } } +{ $description "Computes the number of bytes used by " { $snippet "m" } " cells in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; + +HELP: bootstrap-cell-bits +{ $values { "n" integer } } +{ $description "Outputs the number of bits in one cell in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; + +ARTICLE: "layouts-types" "Type numbers" +"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:" +{ $subsection type } +"Built-in type numbers can be converted to classes, and vice versa:" +{ $subsection type>class } +{ $subsection type-number } +{ $subsection num-types } +{ $see-also "builtin-classes" } ; + +ARTICLE: "layouts-tags" "Tagged pointers" +"Every pointer stored on the stack or in the heap has a " { $emphasis "tag" } ", which is a small integer identifying the type of the pointer. If the tag is not equal to one of the two special tags, the remaining bits contain the memory address of a heap-allocated object. The two special tags are the " { $link fixnum } " tag and the " { $link f } " tag." +$nl +"Getting the tag of an object:" +{ $link tag } +"Words for working with tagged pointers:" +{ $subsection tag-bits } +{ $subsection num-tags } +{ $subsection tag-mask } +{ $subsection tag-number } +"The Factor VM does not actually expose any words for working with tagged pointers directly. The above words operate on integers; they are used in the bootstrap image generator and the optimizing compiler." ; + +ARTICLE: "layouts-limits" "Sizes and limits" +"Processor cell size:" +{ $subsection cell } +{ $subsection cells } +{ $subsection cell-bits } +"Range of integers representable by " { $link fixnum } "s:" +{ $subsection most-negative-fixnum } +{ $subsection most-positive-fixnum } +"Maximum array size:" +{ $subsection max-array-capacity } ; + +ARTICLE: "layouts-bootstrap" "Bootstrap support" +"Bootstrap support:" +{ $subsection bootstrap-cell } +{ $subsection bootstrap-cells } +{ $subsection bootstrap-cell-bits } +{ $subsection bootstrap-most-negative-fixnum } +{ $subsection bootstrap-most-positive-fixnum } ; + +ARTICLE: "layouts" "VM memory layouts" +"The words documented in this section do not ever need to be called by user code. They are documented for the benefit of those wishing to explore the internals of Factor's implementation." +{ $subsection "layouts-types" } +{ $subsection "layouts-tags" } +{ $subsection "layouts-limits" } +{ $subsection "layouts-bootstrap" } ; + +ABOUT: "layouts" diff --git a/core/layouts/layouts-tests.factor b/core/layouts/layouts-tests.factor new file mode 100755 index 0000000000..cf50356f76 --- /dev/null +++ b/core/layouts/layouts-tests.factor @@ -0,0 +1,5 @@ +IN: system.tests +USING: layouts math tools.test ; + +[ t ] [ cell integer? ] unit-test +[ t ] [ bootstrap-cell integer? ] unit-test diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 2f8b158bbf..879862c926 100755 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces math words kernel assocs system classes ; +USING: namespaces math words kernel assocs classes +kernel.private ; IN: layouts SYMBOL: tag-mask @@ -24,11 +25,43 @@ SYMBOL: type-numbers : tag-fixnum ( n -- tagged ) tag-bits get shift ; +: cell ( -- n ) 7 getenv ; foldable + +: cells ( m -- n ) cell * ; inline + +: cell-bits ( -- n ) 8 cells ; inline + +: bootstrap-cell \ cell get cell or ; inline + +: bootstrap-cells bootstrap-cell * ; inline + +: bootstrap-cell-bits 8 bootstrap-cells ; inline + +: (first-bignum) ( m -- n ) + tag-bits get - 1 - 2^ ; + : first-bignum ( -- n ) - bootstrap-cell-bits tag-bits get - 1 - 2^ ; + cell-bits (first-bignum) ; : most-positive-fixnum ( -- n ) first-bignum 1- ; : most-negative-fixnum ( -- n ) first-bignum neg ; + +: bootstrap-first-bignum ( -- n ) + bootstrap-cell-bits (first-bignum) ; + +: bootstrap-most-positive-fixnum ( -- n ) + bootstrap-first-bignum 1- ; + +: bootstrap-most-negative-fixnum ( -- n ) + bootstrap-first-bignum neg ; + +M: bignum >integer + dup most-negative-fixnum most-positive-fixnum between? + [ >fixnum ] when ; + +M: real >integer + dup most-negative-fixnum most-positive-fixnum between? + [ >fixnum ] [ >bignum ] if ; diff --git a/core/libc/libc.factor b/core/libc/libc.factor old mode 100644 new mode 100755 index 2006850839..e82b244d6d --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -2,7 +2,7 @@ ! Copyright (C) 2007 Slava Pestov ! Copyright (C) 2007 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs continuations init inspector kernel namespaces ; +USING: alien assocs continuations init kernel namespaces ; IN: libc TUPLE: check-ptr ; -M: check-ptr summary drop "Memory allocation failed" ; - : check-ptr ( c-ptr -- c-ptr ) [ \ check-ptr construct-boa throw ] unless* ; TUPLE: double-free ; -M: double-free summary drop "Free failed since memory is not allocated" ; - : double-free ( -- * ) \ double-free construct-empty throw ; TUPLE: realloc-error ptr size ; -M: realloc-error summary drop "Memory reallocation failed" ; - : realloc-error ( alien size -- * ) \ realloc-error construct-boa throw ; stream-read-quot ; -[ [ ] ] [ - "USE: temporary hello" parse-interactive -] unit-test +[ + [ [ ] ] [ + "USE: listener.tests hello" parse-interactive + ] unit-test +] with-file-vocabs [ "debugger" use+ @@ -35,8 +37,10 @@ IN: temporary ] unit-test [ - "USE: vocabs.loader.test.c" parse-interactive -] must-fail + [ + "USE: vocabs.loader.test.c" parse-interactive + ] must-fail +] with-file-vocabs [ ] [ [ @@ -44,7 +48,9 @@ IN: temporary ] with-compilation-unit ] unit-test -[ ] [ - "IN: temporary : hello\n\"world\" ;" parse-interactive +[ + [ ] [ + "IN: listener.tests : hello\n\"world\" ;" parse-interactive drop -] unit-test + ] unit-test +] with-file-vocabs diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 288cb53322..16ee2705fe 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.duplex vectors words generic system combinators tuples continuations debugger definitions compiler.units ; IN: listener @@ -32,13 +32,13 @@ GENERIC: stream-read-quot ( stream -- quot/f ) 3drop f ] if ; -M: line-reader stream-read-quot +M: object stream-read-quot V{ } clone read-quot-loop ; M: duplex-stream stream-read-quot duplex-stream-in stream-read-quot ; -: read-quot ( -- quot ) stdio get stream-read-quot ; +: read-quot ( -- quot/f ) stdio get stream-read-quot ; : bye ( -- ) quit-flag on ; @@ -62,11 +62,7 @@ M: duplex-stream stream-read-quot [ quit-flag off ] [ listen until-quit ] if ; inline -: print-banner ( -- ) - "Factor " write version write - " on " write os write "/" write cpu print ; - : listener ( -- ) - print-banner [ until-quit ] with-interactive-vocabs ; + [ until-quit ] with-interactive-vocabs ; MAIN: listener diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor index a10c0566f8..6dfc51f440 100755 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -1,5 +1,5 @@ USING: math math.bitfields tools.test kernel words ; -IN: temporary +IN: math.bitfields.tests [ 0 ] [ { } bitfield ] unit-test [ 256 ] [ 1 { 8 } bitfield ] unit-test diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 54a90ef233..095392ed81 100755 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.constants tools.test sequences ; -IN: temporary +IN: math.floats.tests [ t ] [ 0.0 float? ] unit-test [ t ] [ 3.1415 number? ] unit-test diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index aa716c3197..056e19e1de 100755 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -14,6 +14,7 @@ $nl { $subsection fixnum? } { $subsection bignum? } { $subsection >fixnum } +{ $subsection >integer } { $subsection >bignum } { $see-also "prettyprint-numbers" "modular-arithmetic" "bitwise-arithmetic" "integer-functions" "syntax-integers" } ; diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 194edb8f7e..eebc45511a 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -1,6 +1,6 @@ USING: kernel math namespaces prettyprint math.private continuations tools.test sequences ; -IN: temporary +IN: math.integers.tests [ "-8" ] [ -8 unparse ] unit-test diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 59a4dff8de..70a6d2e087 100755 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -9,6 +9,7 @@ M: integer denominator drop 1 ; M: fixnum >fixnum ; M: fixnum >bignum fixnum>bignum ; +M: fixnum >integer ; M: fixnum number= eq? ; diff --git a/core/math/intervals/intervals-docs.factor b/core/math/intervals/intervals-docs.factor index 09afded43c..7eb20090ab 100644 --- a/core/math/intervals/intervals-docs.factor +++ b/core/math/intervals/intervals-docs.factor @@ -213,41 +213,41 @@ HELP: incomparable { $description "Output value from " { $link interval<= } ", " { $link interval< } ", " { $link interval>= } " and " { $link interval> } " in the case where the result of the comparison is ambiguous." } ; HELP: interval<= -{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } } -{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:" +{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } } +{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:" { $list - { { $link t } " if every point in " { $snippet "int" } " is less than or equal to " { $snippet "n" } } - { { $link f } " if every point in " { $snippet "int" } " is greater than " { $snippet "n" } } + { { $link t } " if every point in " { $snippet "i1" } " is less than or equal to every point in " { $snippet "i2" } } + { { $link f } " if every point in " { $snippet "i1" } " is greater than every point in " { $snippet "i2" } } { { $link incomparable } " if neither of the above conditions hold" } } } ; HELP: interval< -{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } } -{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:" +{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } } +{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:" { $list - { { $link t } " if every point in " { $snippet "int" } " is less than " { $snippet "n" } } - { { $link f } " if every point in " { $snippet "int" } " is greater than or equal to " { $snippet "n" } } + { { $link t } " if every point in " { $snippet "i1" } " is less than every point in " { $snippet "i2" } } + { { $link f } " if every point in " { $snippet "i1" } " is greater than or equal to every point in " { $snippet "i2" } } { { $link incomparable } " if neither of the above conditions hold" } } } ; HELP: interval>= -{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } } -{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:" +{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } } +{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:" { $list - { { $link t } " if every point in " { $snippet "int" } " is greater than or equal to " { $snippet "n" } } - { { $link f } " if every point in " { $snippet "int" } " is less than " { $snippet "n" } } + { { $link t } " if every point in " { $snippet "i1" } " is greater than or equal to every point in " { $snippet "i2" } } + { { $link f } " if every point in " { $snippet "i1" } " is less than every point in " { $snippet "i2" } } { { $link incomparable } " if neither of the above conditions hold" } } } ; HELP: interval> -{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } } -{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:" +{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } } +{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:" { $list - { { $link t } " if every point in " { $snippet "int" } " is greater than " { $snippet "n" } } - { { $link f } " if every point in " { $snippet "int" } " is less than or equal to " { $snippet "n" } } + { { $link t } " if every point in " { $snippet "i1" } " is greater than every point in " { $snippet "i2" } } + { { $link f } " if every point in " { $snippet "i1" } " is less than or equal to every point in " { $snippet "i2" } } { { $link incomparable } " if neither of the above conditions hold" } } } ; diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 2c6ac2ecb0..5a3fe777b6 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 +prettyprint tools.test random vocabs combinators ; +IN: math.intervals.tests [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test @@ -94,33 +94,88 @@ IN: temporary ] unit-test ] when -[ t ] [ 0 5 [a,b] 5 interval<= ] unit-test +[ t ] [ 1 [a,a] interval-singleton? ] unit-test -[ incomparable ] [ 0 5 [a,b] 5 interval< ] unit-test +[ f ] [ 1 1 [a,b) interval-singleton? ] unit-test -[ t ] [ 0 5 [a,b) 5 interval< ] unit-test +[ f ] [ 1 3 [a,b) interval-singleton? ] unit-test -[ f ] [ 0 5 [a,b] -1 interval< ] unit-test +[ f ] [ 1 1 (a,b) interval-singleton? ] unit-test -[ incomparable ] [ 0 5 [a,b] 1 interval< ] unit-test +[ 2 ] [ 1 3 [a,b) interval-length ] unit-test -[ t ] [ -1 1 (a,b) -1 interval> ] unit-test +[ 0 ] [ f interval-length ] unit-test -[ t ] [ -1 1 (a,b) -1 interval>= ] unit-test +[ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test -[ f ] [ -1 1 (a,b) -1 interval< ] unit-test +[ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test -[ f ] [ -1 1 (a,b) -1 interval<= ] unit-test +[ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test -[ t ] [ -1 1 (a,b] 1 interval<= ] unit-test +[ f ] [ 0 5 [a,b] -1 [a,a] interval< ] unit-test + +[ incomparable ] [ 0 5 [a,b] 1 [a,a] interval< ] unit-test + +[ t ] [ -1 1 (a,b) -1 [a,a] interval> ] unit-test + +[ t ] [ -1 1 (a,b) -1 [a,a] interval>= ] unit-test + +[ f ] [ -1 1 (a,b) -1 [a,a] interval< ] unit-test + +[ f ] [ -1 1 (a,b) -1 [a,a] interval<= ] unit-test + +[ t ] [ -1 1 (a,b] 1 [a,a] interval<= ] unit-test + +[ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test + +[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test + +[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test + +[ t ] [ -1 1 (a,b] 1 2 (a,b] interval<= ] unit-test + +[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test + +[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test + +[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test + +[ incomparable ] [ 10 [a,a] 0 10 [a,b] interval> ] unit-test + +[ t ] [ 0 [a,a] 0 10 [a,b] interval<= ] unit-test + +[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval>= ] unit-test + +[ t ] [ 0 10 [a,b] 0 [a,a] interval>= ] unit-test + +[ t ] [ + 418 + 418 423 [a,b) + 79 893 (a,b] + interval-max + interval-contains? +] unit-test + +[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test ! Interval random tester : random-element ( interval -- n ) - dup interval-to first swap interval-from first tuck - - random + ; + dup interval-to first over interval-from first tuck - random + + 2dup swap interval-contains? [ + nip + ] [ + drop random-element + ] if ; : random-interval ( -- interval ) - 1000 random dup 1 1000 random + + [a,b] ; + 1000 random dup 2 1000 random + + + 1 random zero? [ [ neg ] 2apply swap ] when + 4 random { + { 0 [ [a,b] ] } + { 1 [ [a,b) ] } + { 2 [ (a,b) ] } + { 3 [ (a,b] ] } + } case ; : random-op { @@ -138,12 +193,32 @@ IN: temporary random ; : interval-test - random-interval random-interval random-op + random-interval random-interval random-op ! 3dup . . . 0 pick interval-contains? over first { / /i } member? and [ 3drop t ] [ - [ >r [ random-element ] 2apply r> first execute ] 3keep + [ >r [ random-element ] 2apply ! 2dup . . + r> first execute ] 3keep second execute interval-contains? ] if ; -[ t ] [ 1000 [ drop interval-test ] all? ] unit-test +[ t ] [ 40000 [ drop interval-test ] all? ] unit-test + +: random-comparison + { + { < interval< } + { <= interval<= } + { > interval> } + { >= interval>= } + } random ; + +: comparison-test + random-interval random-interval random-comparison + [ >r [ random-element ] 2apply r> first execute ] 3keep + second execute dup incomparable eq? [ + 2drop t + ] [ + = + ] if ; + +[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor old mode 100644 new mode 100755 index b7eb5be8c9..d1c458065f --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -88,20 +88,6 @@ C: interval [ interval>points [ first integer? ] both? ] both? r> [ 2drop f ] if ; inline -: interval-shift ( i1 i2 -- i3 ) - [ [ shift ] interval-op ] interval-integer-op ; - -: interval-shift-safe ( i1 i2 -- i3 ) - dup interval-to first 100 > [ - 2drop f - ] [ - interval-shift - ] if ; - -: interval-max ( i1 i2 -- i3 ) [ max ] interval-op ; - -: interval-min ( i1 i2 -- i3 ) [ min ] interval-op ; - : interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ; : interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ; @@ -143,8 +129,41 @@ C: interval : interval-contains? ( x int -- ? ) >r [a,a] r> interval-subset? ; +: interval-singleton? ( int -- ? ) + interval>points + 2dup [ second ] 2apply and + [ [ first ] 2apply = ] + [ 2drop f ] if ; + +: interval-length ( int -- n ) + dup + [ interval>points [ first ] 2apply swap - ] + [ drop 0 ] if ; + : interval-closure ( i1 -- i2 ) - interval>points [ first ] 2apply [a,b] ; + dup [ interval>points [ first ] 2apply [a,b] ] when ; + +: interval-shift ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ [ shift ] interval-op ] interval-integer-op interval-closure ; + +: interval-shift-safe ( i1 i2 -- i3 ) + dup interval-to first 100 > [ + 2drop f + ] [ + interval-shift + ] if ; + +: interval-max ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ max ] interval-op interval-closure ; + +: interval-min ( i1 i2 -- i3 ) + #! Inaccurate; could be tighter + [ min ] interval-op interval-closure ; + +: interval-interior ( i1 -- i2 ) + interval>points [ first ] 2apply (a,b) ; : interval-division-op ( i1 i2 quot -- i3 ) >r 0 over interval-closure interval-contains? @@ -156,7 +175,7 @@ C: interval : interval/i ( i1 i2 -- i3 ) [ [ [ /i ] interval-op ] interval-integer-op - ] interval-division-op ; + ] interval-division-op interval-closure ; : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; @@ -164,24 +183,46 @@ C: interval SYMBOL: incomparable -: interval-compare ( int n quot -- ? ) - >r dupd r> call interval-intersect dup [ - = t incomparable ? - ] [ - 2drop f - ] if ; inline +: left-endpoint-< ( i1 i2 -- ? ) + [ swap interval-subset? ] 2keep + [ nip interval-singleton? ] 2keep + [ interval-from ] 2apply = + and and ; -: interval< ( int n -- ? ) - [ [-inf,a) ] interval-compare ; inline +: right-endpoint-< ( i1 i2 -- ? ) + [ interval-subset? ] 2keep + [ drop interval-singleton? ] 2keep + [ interval-to ] 2apply = + and and ; -: interval<= ( int n -- ? ) - [ [-inf,a] ] interval-compare ; inline +: (interval<) over interval-from over interval-from endpoint< ; -: interval> ( int n -- ? ) - [ (a,inf] ] interval-compare ; inline +: interval< ( i1 i2 -- ? ) + { + { [ 2dup interval-intersect not ] [ (interval<) ] } + { [ 2dup left-endpoint-< ] [ f ] } + { [ 2dup right-endpoint-< ] [ f ] } + { [ t ] [ incomparable ] } + } cond 2nip ; -: interval>= ( int n -- ? ) - [ [a,inf] ] interval-compare ; inline +: left-endpoint-<= ( i1 i2 -- ? ) + >r interval-from r> interval-to = ; + +: right-endpoint-<= ( i1 i2 -- ? ) + >r interval-to r> interval-from = ; + +: interval<= ( i1 i2 -- ? ) + { + { [ 2dup interval-intersect not ] [ (interval<) ] } + { [ 2dup right-endpoint-<= ] [ t ] } + { [ t ] [ incomparable ] } + } cond 2nip ; + +: interval> ( i1 i2 -- ? ) + swap interval< ; + +: interval>= ( i1 i2 -- ? ) + swap interval<= ; : assume< ( i1 i2 -- i3 ) interval-to first [-inf,a) interval-intersect ; diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 1ec3592c79..6ec1c5790f 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -184,8 +184,8 @@ HELP: bitand { $values { "x" integer } { "y" integer } { "z" integer } } { $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in both inputs." } { $examples - { $example "BIN: 101 BIN: 10 bitand .b" "0" } - { $example "BIN: 110 BIN: 10 bitand .b" "10" } + { $example "USING: math prettyprint ;" "BIN: 101 BIN: 10 bitand .b" "0" } + { $example "USING: math prettyprint ;" "BIN: 110 BIN: 10 bitand .b" "10" } } { $notes "This word implements bitwise and, so applying it to booleans will throw an error. Boolean and is the " { $link and } " word." } ; @@ -193,8 +193,8 @@ HELP: bitor { $values { "x" integer } { "y" integer } { "z" integer } } { $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in at least one of the inputs." } { $examples - { $example "BIN: 101 BIN: 10 bitor .b" "111" } - { $example "BIN: 110 BIN: 10 bitor .b" "110" } + { $example "USING: math prettyprint ;" "BIN: 101 BIN: 10 bitor .b" "111" } + { $example "USING: math prettyprint ;" "BIN: 110 BIN: 10 bitor .b" "110" } } { $notes "This word implements bitwise inclusive or, so applying it to booleans will throw an error. Boolean inclusive or is the " { $link and } " word." } ; @@ -202,15 +202,15 @@ HELP: bitxor { $values { "x" integer } { "y" integer } { "z" integer } } { $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in exactly one of the inputs." } { $examples - { $example "BIN: 101 BIN: 10 bitxor .b" "111" } - { $example "BIN: 110 BIN: 10 bitxor .b" "100" } + { $example "USING: math prettyprint ;" "BIN: 101 BIN: 10 bitxor .b" "111" } + { $example "USING: math prettyprint ;" "BIN: 110 BIN: 10 bitxor .b" "100" } } { $notes "This word implements bitwise exclusive or, so applying it to booleans will throw an error. Boolean exclusive or is the " { $link xor } " word." } ; HELP: shift { $values { "x" integer } { "n" integer } { "y" integer } } { $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." } -{ $examples { $example "BIN: 101 5 shift .b" "10100000" } { $example "BIN: 11111 -2 shift .b" "111" } } ; +{ $examples { $example "USING: math prettyprint ;" "BIN: 101 5 shift .b" "10100000" } { $example "USING: math prettyprint ;" "BIN: 11111 -2 shift .b" "111" } } ; HELP: bitnot { $values { "x" integer } { "y" integer } } @@ -222,7 +222,7 @@ $nl HELP: bit? { $values { "x" integer } { "n" integer } { "?" "a boolean" } } { $description "Tests if the " { $snippet "n" } "th bit of " { $snippet "x" } " is set." } -{ $examples { $example "BIN: 101 2 bit? ." "t" } } ; +{ $examples { $example "USING: math prettyprint ;" "BIN: 101 2 bit? ." "t" } } ; HELP: log2 { $values { "x" "a positive integer" } { "n" integer } } @@ -295,9 +295,9 @@ HELP: 2/ { $values { "x" integer } { "y" integer } } { $description "Shifts " { $snippet "x" } " to the right by one bit." } { $examples - { $example "14 2/ ." "7" } - { $example "17 2/ ." "8" } - { $example "-17 2/ ." "-9" } + { $example "USING: math prettyprint ;" "14 2/ ." "7" } + { $example "USING: math prettyprint ;" "17 2/ ." "8" } + { $example "USING: math prettyprint ;" "-17 2/ ." "-9" } } { $notes "This word is not equivalent to " { $snippet "2 /" } " or " { $snippet "2 /i" } "; the name is historic and originates from the Forth programming language." } ; diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index c650f7384c..fcd3b929ea 100644 --- a/core/math/math-tests.factor +++ b/core/math/math-tests.factor @@ -1,5 +1,5 @@ USING: kernel math namespaces tools.test ; -IN: temporary +IN: math.tests [ ] [ 5 [ ] times ] unit-test [ ] [ 0 [ ] times ] unit-test diff --git a/core/math/math.factor b/core/math/math.factor index 8b48e49f97..cd908ea10f 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -5,6 +5,7 @@ IN: math GENERIC: >fixnum ( x -- y ) foldable GENERIC: >bignum ( x -- y ) foldable +GENERIC: >integer ( x -- y ) foldable GENERIC: >float ( x -- y ) foldable MATH: number= ( x y -- ? ) foldable @@ -16,6 +17,11 @@ MATH: <= ( x y -- ? ) foldable MATH: > ( x y -- ? ) foldable MATH: >= ( x y -- ? ) foldable +: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline +: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline +: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline +: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline + MATH: + ( x y -- z ) foldable MATH: - ( x y -- z ) foldable MATH: * ( x y -- z ) foldable diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 226e47090a..baa6634a9f 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.parser sequences tools.test ; -IN: temporary +IN: math.parser.tests [ f ] [ f string>number ] diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor old mode 100644 new mode 100755 index 7d99e6311e..e29844dc89 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -47,8 +47,8 @@ HELP: gc-time ( -- n ) { $values { "n" "a timestamp in milliseconds" } } { $description "Outputs the total time spent in garbage collection during this Factor session." } ; -HELP: data-room ( -- cards semi generations ) -{ $values { "cards" "number of bytes reserved for card marking" } { "semi" "number of bytes reserved for tenured semi-space" } { "generations" "array of free/total bytes pairs" } } +HELP: data-room ( -- cards generations ) +{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } } { $description "Queries the runtime for memory usage information." } ; HELP: code-room ( -- code-free code-total ) diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index d0dfd2c0be..8808b30c59 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,6 +1,6 @@ USING: generic kernel kernel.private math memory prettyprint sequences tools.test words namespaces layouts classes ; -IN: temporary +IN: memory.tests TUPLE: testing x y z ; diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor old mode 100644 new mode 100755 index ae40c85c0d..140f92567b --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -20,7 +20,7 @@ HELP: object-slots HELP: mirror { $class-description "An associative structure which wraps an object and presents itself as a mapping from slot names to the object's slot values. Mirrors are used to build reflective developer tools." $nl -"Mirrors are mutable, however new keys cannot be inserted and keys cannot be deleted, only values of existing keys can be changed." +"Mirrors are mutable, however new keys cannot be inserted, only values of existing keys can be changed. Deleting a key has the effect of setting its value to " { $link f } "." $nl "Mirrors are created by calling " { $link } " or " { $link make-mirror } "." } ; @@ -29,11 +29,11 @@ HELP: { $description "Creates a " { $link mirror } " reflecting an object." } { $examples { $example - "USING: assocs mirrors ;" + "USING: assocs mirrors prettyprint ;" "TUPLE: circle center radius ;" "C: circle" "{ 100 50 } 15 >alist ." - "{ { circle-center { 100 50 } } { circle-radius 15 } }" + "{ { \"center\" { 100 50 } } { \"radius\" 15 } }" } } ; @@ -47,5 +47,5 @@ $nl "Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ; HELP: make-mirror -{ $values { "obj" object } { "assoc" "an assoc" } } +{ $values { "obj" object } { "assoc" assoc } } { $description "Creates an assoc which reflects the internal structure of the object." } ; diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor old mode 100644 new mode 100755 index 994bb8ef84..8f2964b19d --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -1,16 +1,16 @@ USING: mirrors tools.test assocs kernel arrays ; -IN: temporary +IN: mirrors.tests TUPLE: foo bar baz ; C: foo -[ { foo-bar foo-baz } ] [ 1 2 keys ] unit-test +[ { "bar" "baz" } ] [ 1 2 keys ] unit-test -[ 1 t ] [ \ foo-bar 1 2 at* ] unit-test +[ 1 t ] [ "bar" 1 2 at* ] unit-test [ f f ] [ "hi" 1 2 at* ] unit-test [ 3 ] [ - 3 \ foo-baz 1 2 [ set-at ] keep foo-baz + 3 "baz" 1 2 [ set-at ] keep foo-baz ] unit-test diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor old mode 100644 new mode 100755 index 7d3d5a53d0..8f12bbb2f4 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel sequences generic words arrays classes slots slots.private tuples math vectors -quotations ; +quotations sorting prettyprint ; IN: mirrors GENERIC: object-slots ( obj -- seq ) @@ -21,12 +21,14 @@ TUPLE: mirror object slots ; : >mirror< ( mirror -- obj slots ) dup mirror-object swap mirror-slots ; +: mirror@ ( slot-name mirror -- obj slot-spec ) + >mirror< swapd slot-named ; + M: mirror at* - >mirror< swapd slot-of-reader - dup [ slot-spec-offset slot t ] [ 2drop f f ] if ; + mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ; M: mirror set-at ( val key mirror -- ) - >mirror< swapd slot-of-reader dup [ + mirror@ dup [ dup slot-spec-writer [ slot-spec-offset set-slot ] [ @@ -42,7 +44,7 @@ M: mirror delete-at ( key mirror -- ) M: mirror >alist ( mirror -- alist ) >mirror< [ [ slot-spec-offset slot ] with map ] keep - [ slot-spec-reader ] map swap 2array flip ; + [ slot-spec-name ] map swap 2array flip ; M: mirror assoc-size mirror-slots length ; @@ -69,8 +71,13 @@ M: enum clear-assoc enum-seq delete-all ; INSTANCE: enum assoc +: sort-assoc ( assoc -- alist ) + >alist + [ dup first unparse-short swap ] { } map>assoc + sort-keys values ; + GENERIC: make-mirror ( obj -- assoc ) -M: hashtable make-mirror ; +M: hashtable make-mirror sort-assoc ; M: integer make-mirror drop f ; M: array make-mirror ; M: vector make-mirror ; diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor index 2d4b9a03b2..971477cd4d 100755 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -87,7 +87,7 @@ HELP: +@ { $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." } { $side-effects "variable" } { $examples - { $example "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" } + { $example "USING: namespaces prettyprint ;" "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" } } ; HELP: inc @@ -168,7 +168,7 @@ HELP: building HELP: make { $values { "quot" quotation } { "exemplar" "a sequence" } { "seq" "a new sequence" } } { $description "Calls the quotation in a new " { $emphasis "dynamic scope" } ". The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." } -{ $examples { $example "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ; +{ $examples { $example "USING: namespaces prettyprint ;" "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ; HELP: , { $values { "elt" object } } 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/math/math.factor b/core/optimizer/math/math.factor index 6f535ec8e6..7afc177d10 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -371,15 +371,17 @@ most-negative-fixnum most-positive-fixnum [a,b] ] assoc-each ! Remove redundant comparisons -: known-comparison? ( #call -- ? ) +: intervals-first2 ( #call -- first second ) dup dup node-in-d first node-interval - swap dup node-in-d second node-literal real? and ; + swap dup node-in-d second node-interval ; + +: known-comparison? ( #call -- ? ) + intervals-first2 and ; : perform-comparison ( #call word -- result ) - >r dup dup node-in-d first node-interval - swap dup node-in-d second node-literal r> execute ; inline + >r intervals-first2 r> execute ; inline -: foldable-comparison? ( #call word -- ) +: foldable-comparison? ( #call word -- ? ) >r dup known-comparison? [ r> perform-comparison incomparable eq? not ] [ diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 66d3956dba..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-docs.factor b/core/parser/parser-docs.factor index ce6a119e32..48f929b836 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -221,8 +221,8 @@ HELP: { $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ; HELP: skip -{ $values { "i" "a starting index" } { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "n" integer } } -{ $description "Variant of " { $link find* } " that outputs the length of the sequence instead of " { $link f } " if no elements satisfy the predicate." } ; +{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } +{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; HELP: change-column { $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } } @@ -264,7 +264,7 @@ HELP: bad-number HELP: escape { $values { "escape" "a single-character escape" } { "ch" "a character" } } { $description "Converts from a single-character escape code and the corresponding character." } -{ $examples { $example "CHAR: n escape CHAR: \\n = ." "t" } } ; +{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ; HELP: parse-string { $values { "str" "a new " { $link string } } } @@ -340,8 +340,8 @@ HELP: no-word { $notes "Apart from a missing " { $link POSTPONE: USE: } ", this error can also indicate an ordering issue. In Factor, words must be defined before they can be called. Mutual recursion can be implemented via " { $link POSTPONE: DEFER: } "." } ; HELP: search -{ $values { "str" string } { "word" word } } -{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, throws a " { $link no-word } " error. If the search path does not contain a word with this name but other vocabularies do, the error will have restarts offering to add vocabularies to the search path." } +{ $values { "str" string } { "word/f" "a word or " { $link f } } } +{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, outputs " { $link f } "." } $parsing-note ; HELP: scan-word @@ -459,7 +459,7 @@ HELP: forget-smudged { $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ; HELP: finish-parsing -{ $values { "quot" "the quotation just parsed" } } +{ $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } } { $description "Records information to the current " { $link file } " and prints warnings about any removed definitions which are still in use." } { $notes "This is one of the factors of " { $link parse-stream } "." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index b89f56334b..89783d1b3c 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -1,8 +1,8 @@ USING: arrays math parser tools.test kernel generic words io.streams.string namespaces classes effects source-files assocs sequences strings io.files definitions continuations -sorting tuples compiler.units ; -IN: temporary +sorting tuples compiler.units debugger ; +IN: parser.tests [ [ 1 [ 2 [ 3 ] 4 ] 5 ] @@ -23,8 +23,8 @@ IN: temporary [ "hello world" ] [ - "IN: temporary : hello \"hello world\" ;" - eval "USE: temporary hello" eval + "IN: parser.tests : hello \"hello world\" ;" + eval "USE: parser.tests hello" eval ] unit-test [ ] @@ -51,7 +51,7 @@ IN: temporary : effect-parsing-test ( a b -- c ) + ; [ t ] [ - "effect-parsing-test" "temporary" lookup + "effect-parsing-test" "parser.tests" lookup \ effect-parsing-test eq? ] unit-test @@ -64,24 +64,24 @@ IN: temporary [ \ baz "declared-effect" word-prop effect-terminated? ] unit-test - [ ] [ "IN: temporary USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test + [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test [ t ] [ - "effect-parsing-test" "temporary" lookup + "effect-parsing-test" "parser.tests" lookup \ effect-parsing-test eq? ] unit-test [ T{ effect f { "a" "b" } { "d" } f } ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test - [ ] [ "IN: temporary : effect-parsing-test ;" eval ] unit-test + [ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test [ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test ! Funny bug - [ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test + [ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test - [ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail + [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail ! These should throw errors [ "HEX: zzz" eval ] must-fail @@ -102,71 +102,71 @@ IN: temporary ] unit-test DEFER: foo - "IN: temporary USING: math prettyprint ; : foo 2 2 + . ; parsing" eval + "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ; parsing" eval - [ ] [ "USE: temporary foo" eval ] unit-test + [ ] [ "USE: parser.tests foo" eval ] unit-test - "IN: temporary USING: math prettyprint ; : foo 2 2 + . ;" eval + "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval [ t ] [ - "USE: temporary \\ foo" eval - "foo" "temporary" lookup eq? + "USE: parser.tests \\ foo" eval + "foo" "parser.tests" lookup eq? ] unit-test ! Test smudging [ 1 ] [ - "IN: temporary : smudge-me ;" "foo" + "IN: parser.tests : smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test - [ t ] [ "smudge-me" "temporary" lookup >boolean ] unit-test + [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test [ ] [ - "IN: temporary : smudge-me-more ;" "foo" + "IN: parser.tests : smudge-me-more ;" "foo" parse-stream drop ] unit-test - [ t ] [ "smudge-me-more" "temporary" lookup >boolean ] unit-test - [ f ] [ "smudge-me" "temporary" lookup >boolean ] unit-test + [ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test + [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test [ 3 ] [ - "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" "foo" + "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test [ 1 ] [ - "IN: temporary USING: arrays ; M: array smudge-me ;" "bar" + "IN: parser.tests USING: arrays ; M: array smudge-me ;" "bar" parse-stream drop "bar" source-file source-file-definitions first assoc-size ] unit-test [ 2 ] [ - "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" "foo" + "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test [ t ] [ - array "smudge-me" "temporary" lookup order memq? + array "smudge-me" "parser.tests" lookup order memq? ] unit-test [ t ] [ - integer "smudge-me" "temporary" lookup order memq? + integer "smudge-me" "parser.tests" lookup order memq? ] unit-test [ f ] [ - string "smudge-me" "temporary" lookup order memq? + string "smudge-me" "parser.tests" lookup order memq? ] unit-test [ ] [ - "IN: temporary USE: math 2 2 +" "a" + "IN: parser.tests USE: math 2 2 +" "a" parse-stream drop ] unit-test @@ -175,7 +175,7 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary USE: math 2 2 -" "a" + "IN: parser.tests USE: math 2 2 -" "a" parse-stream drop ] unit-test @@ -186,7 +186,7 @@ IN: temporary [ ] [ "a" source-files get delete-at 2 [ - "IN: temporary DEFER: x : y x ; : x y ;" + "IN: parser.tests DEFER: x : y x ; : x y ;" "a" parse-stream drop ] times ] unit-test @@ -194,19 +194,19 @@ IN: temporary "a" source-files get delete-at [ - "IN: temporary : x ; : y 3 throw ; this is an error" + "IN: parser.tests : x ; : y 3 throw ; this is an error" "a" parse-stream ] [ parse-error? ] must-fail-with [ t ] [ - "y" "temporary" lookup >boolean + "y" "parser.tests" lookup >boolean ] unit-test [ f ] [ - "IN: temporary : x ;" + "IN: parser.tests : x ;" "a" parse-stream drop - "y" "temporary" lookup + "y" "parser.tests" lookup ] unit-test ! Test new forward definition logic @@ -269,81 +269,81 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary : ; : bogus ;" + "IN: parser.tests : ; : bogus ;" "bogus-error" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: bogus-error ; C: bogus-error : bogus ;" + "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ;" "bogus-error" parse-stream drop ] unit-test ! Problems with class predicates -vs- ordinary words [ ] [ - "IN: temporary TUPLE: killer ;" + "IN: parser.tests TUPLE: killer ;" "removing-the-predicate" parse-stream drop ] unit-test [ ] [ - "IN: temporary GENERIC: killer? ( a -- b )" + "IN: parser.tests GENERIC: killer? ( a -- b )" "removing-the-predicate" parse-stream drop ] unit-test [ t ] [ - "killer?" "temporary" lookup >boolean + "killer?" "parser.tests" lookup >boolean ] unit-test [ - "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" + "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?" "removing-the-predicate" parse-stream ] [ [ redefine-error? ] is? ] must-fail-with [ - "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" + "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;" "redefining-a-class-1" parse-stream ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ - "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test" + "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test" "redefining-a-class-2" parse-stream drop ] unit-test [ - "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" + "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" "redefining-a-class-3" parse-stream drop ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ - "IN: temporary TUPLE: class-fwd-test ;" + "IN: parser.tests TUPLE: class-fwd-test ;" "redefining-a-class-3" parse-stream drop ] unit-test [ - "IN: temporary \\ class-fwd-test" + "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop ] [ [ no-word? ] is? ] must-fail-with [ ] [ - "IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" + "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" "redefining-a-class-3" parse-stream drop ] unit-test [ - "IN: temporary \\ class-fwd-test" + "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop ] [ [ no-word? ] is? ] must-fail-with [ - "IN: temporary : foo ; TUPLE: foo ;" + "IN: parser.tests : foo ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ - "IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval + "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval ] unit-test [ - "IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval + "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval ] must-fail ] with-file-vocabs @@ -351,13 +351,18 @@ IN: temporary << file get parsed >> file set : ~a ; - : ~b ~a ; + + DEFER: ~b + + "IN: parser.tests : ~b ~a ;" + "smudgy" parse-stream drop + : ~c ; : ~d ; - { H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set + { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set - { H{ { ~d ~d } } H{ } } new-definitions set + { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set [ V{ ~b } { ~a } { ~a ~c } ] [ smudged-usage @@ -365,10 +370,63 @@ IN: temporary ] unit-test ] with-scope +[ + << file get parsed >> file set + + GENERIC: ~e + + : ~f ~e ; + + : ~g ; + + { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set + + { H{ { ~g ~g } } H{ } } new-definitions set + + [ V{ } { } { ~e ~f } ] + [ smudged-usage natural-sort ] + unit-test +] with-scope + [ ] [ - "IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval + "IN: parser.tests USE: kernel PREDICATE: object foo ( x -- y ) ;" eval ] unit-test [ t ] [ - "foo?" "temporary" lookup word eq? + "foo?" "parser.tests" lookup word eq? ] unit-test + +[ ] [ + "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "redefining-a-class-5" parse-stream drop +] unit-test + +[ ] [ + "IN: parser.tests M: f foo ;" + "redefining-a-class-6" parse-stream drop +] unit-test + +[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test + +[ ] [ + "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "redefining-a-class-5" parse-stream drop +] unit-test + +[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test + +[ ] [ + "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "redefining-a-class-7" parse-stream drop +] unit-test + +[ ] [ + "IN: parser.tests TUPLE: foo ;" + "redefining-a-class-7" parse-stream drop +] unit-test + +[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test + +[ "resource:core/parser/test/assert-depth.factor" run-file ] +[ relative-overflow-stack { 1 2 3 } sequence= ] +must-fail-with diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 9bc02c763d..81c9b68668 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger -io.files io.streams.string io.streams.lines vocabs +io.files io.streams.string vocabs io.encodings.utf8 source-files classes hashtables compiler.errors compiler.units ; IN: parser @@ -240,11 +240,14 @@ PREDICATE: unexpected unexpected-eof : CREATE ( -- word ) scan create-in ; -: CREATE-CLASS ( -- word ) - scan in get create +: create-class-in ( word -- word ) + in get create dup save-class-location dup predicate-word dup set-word save-location ; +: CREATE-CLASS ( -- word ) + scan create-class-in ; + : word-restarts ( possibilities -- restarts ) natural-sort [ [ "Use the word " swap summary append ] keep @@ -352,6 +355,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" ; @@ -439,11 +444,12 @@ SYMBOL: interactive-vocabs "Warning: the following definitions were removed from sources," print "but are still referenced from other definitions:" print nl - dup stack. + dup sorted-definitions. nl "The following definitions need to be updated:" print nl - over stack. + over sorted-definitions. + nl ] when 2drop ; : filter-moved ( assoc -- newassoc ) @@ -463,9 +469,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 @@ -490,7 +503,7 @@ SYMBOL: interactive-vocabs [ [ [ parsing-file ] keep - [ ?resource-path ] keep + [ ?resource-path utf8 ] keep parse-stream ] with-compiler-errors ] [ @@ -499,7 +512,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-docs.factor b/core/prettyprint/prettyprint-docs.factor index 69400d2527..7ea0f5c412 100755 --- a/core/prettyprint/prettyprint-docs.factor +++ b/core/prettyprint/prettyprint-docs.factor @@ -242,8 +242,8 @@ HELP: definer { $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } } { $contract "Outputs the parsing words which delimit the definition." } { $examples - { $example ": foo ; \\ foo definer . ." ";\nPOSTPONE: :" } - { $example "SYMBOL: foo \\ foo definer . ." "f\nPOSTPONE: SYMBOL:" } + { $example "USING: definitions prettyprint ;" ": foo ; \\ foo definer . ." ";\nPOSTPONE: :" } + { $example "USING: definitions prettyprint ;" "SYMBOL: foo \\ foo definer . ." "f\nPOSTPONE: SYMBOL:" } } { $notes "This word is used in the implementation of " { $link see } "." } ; @@ -251,6 +251,6 @@ HELP: definition { $values { "defspec" "a definition specifier" } { "seq" "a sequence" } } { $contract "Outputs the body of a definition." } { $examples - { $example "USE: math" "\\ sq definition ." "[ dup * ]" } + { $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" } } { $notes "This word is used in the implementation of " { $link see } "." } ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 11a685d581..20130d7f7e 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -2,8 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex kernel math namespaces parser prettyprint prettyprint.config prettyprint.sections sequences tools.test vectors words effects splitting generic.standard prettyprint.private -continuations generic compiler.units ; -IN: temporary +continuations generic compiler.units tools.walker ; +IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test [ "1.0" ] [ 1.0 unparse ] unit-test @@ -67,18 +67,18 @@ unit-test [ "[ \\ [ ]" ] [ [ \ [ ] unparse ] unit-test [ t ] [ - 100 \ dup [ pprint-short ] with-string-writer + 100 \ dup unparse-short "{" head? ] unit-test : foo ( a -- b ) dup * ; inline -[ "USING: kernel math ;\nIN: temporary\n: foo ( a -- b ) dup * ; inline\n" ] +[ "USING: kernel math ;\nIN: prettyprint.tests\n: foo ( a -- b ) dup * ; inline\n" ] [ [ \ foo see ] with-string-writer ] unit-test : bar ( x -- y ) 2 + ; -[ "USING: math ;\nIN: temporary\n: bar ( x -- y ) 2 + ;\n" ] +[ "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" ] [ [ \ bar see ] with-string-writer ] unit-test : blah @@ -115,28 +115,28 @@ unit-test [ [ parse-fresh drop ] with-compilation-unit [ - "temporary" lookup see + "prettyprint.tests" lookup see ] with-string-writer "\n" split 1 head* ] keep = ] with-scope ; : method-test { - "IN: temporary" + "IN: prettyprint.tests" "GENERIC: method-layout" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: complex method-layout" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" " ;" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: fixnum method-layout ;" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: integer method-layout ;" "" - "USING: kernel temporary ;" + "USING: kernel prettyprint.tests ;" "M: object method-layout ;" } ; @@ -147,7 +147,7 @@ unit-test : retain-stack-test { "USING: io kernel sequences words ;" - "IN: temporary" + "IN: prettyprint.tests" ": retain-stack-layout ( x -- )" " dup stream-readln stream-readln" " >r [ define ] map r>" @@ -161,7 +161,7 @@ unit-test : soft-break-test { "USING: kernel math sequences strings ;" - "IN: temporary" + "IN: prettyprint.tests" ": soft-break-layout ( x y -- ? )" " over string? [" " over hashcode over hashcode number=" @@ -176,7 +176,7 @@ unit-test : another-retain-layout-test { "USING: kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": another-retain-layout ( seq1 seq2 quot -- newseq )" " -rot 2dup dupd min-length [ each drop roll ] map" " >r 3drop r> ; inline" @@ -189,7 +189,7 @@ unit-test : another-soft-break-test { "USING: namespaces parser sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": another-soft-break-layout ( node -- quot )" " parse-error-file" " [ \"hello world foo\" add ] [ ] make ;" @@ -203,7 +203,7 @@ unit-test : string-layout { "USING: io kernel parser ;" - "IN: temporary" + "IN: prettyprint.tests" ": string-layout-test ( error -- )" " \"Expected \" write dup unexpected-want expected>string write" " \" but got \" write unexpected-got expected>string print ;" @@ -224,7 +224,7 @@ unit-test : final-soft-break-test { "USING: kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": final-soft-break-layout ( class dim -- view )" " >r \"alloc\" send 0 0 r>" " first2 " @@ -240,7 +240,7 @@ unit-test : narrow-test { "USING: arrays combinators continuations kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": narrow-layout ( obj -- )" " {" " { [ dup continuation? ] [ append ] }" @@ -255,7 +255,7 @@ unit-test : another-narrow-test { - "IN: temporary" + "IN: prettyprint.tests" ": another-narrow-layout ( -- obj )" " H{" " { 1 2 }" @@ -274,13 +274,13 @@ unit-test : class-see-test { - "IN: temporary" + "IN: prettyprint.tests" "TUPLE: class-see-layout ;" "" - "IN: temporary" + "IN: prettyprint.tests" "GENERIC: class-see-layout ( x -- y )" "" - "USING: temporary ;" + "USING: prettyprint.tests ;" "M: class-see-layout class-see-layout ;" } ; @@ -292,34 +292,26 @@ unit-test ! Regression [ t ] [ - "IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n" + "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n" dup eval - "generic-decl-test" "temporary" lookup + "generic-decl-test" "prettyprint.tests" lookup [ see ] with-string-writer = ] unit-test [ [ + ] ] [ - [ \ + (step-into) ] (remove-breakpoints) + [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test -[ [ (step-into) ] ] [ - [ (step-into) ] (remove-breakpoints) -] unit-test - -[ [ 3 ] ] [ - [ 3 (step-into) ] (remove-breakpoints) +[ [ (step-into-execute) ] ] [ + [ (step-into-execute) ] (remove-breakpoints) ] unit-test [ [ 2 2 + . ] ] [ - [ 2 2 \ + (step-into) . ] (remove-breakpoints) + [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints) ] unit-test [ [ 2 2 + . ] ] [ - [ 2 break 2 \ + (step-into) . ] (remove-breakpoints) -] unit-test - -[ [ 2 . ] ] [ - [ 2 \ break (step-into) . ] (remove-breakpoints) + [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints) ] unit-test [ ] [ 1 \ + curry unparse drop ] unit-test diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index d578738c56..6cb03e4199 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -75,6 +75,9 @@ combinators quotations ; { string-limit t } } clone [ pprint ] bind ; +: unparse-short ( obj -- str ) + [ pprint-short ] with-string-writer ; + : short. ( obj -- ) pprint-short nl ; : .b ( n -- ) >bin print ; @@ -94,27 +97,18 @@ SYMBOL: -> { { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } } "word-style" set-word-prop -! This code is ugly and could probably be simplified -: remove-step-into - building get dup empty? [ - drop \ (step-into) , - ] [ - pop dup wrapper? [ - wrapped dup \ break eq? - [ drop ] [ , ] if - ] [ - , - ] if - ] if ; +: remove-step-into ( word -- ) + building get dup empty? [ drop ] [ nip pop wrapped ] if , ; : (remove-breakpoints) ( quot -- newquot ) [ [ { - { break [ ] } - { (step-into) [ remove-step-into ] } - [ , ] - } case + { [ dup word? not ] [ , ] } + { [ dup "break?" word-prop ] [ drop ] } + { [ dup "step-into?" word-prop ] [ remove-step-into ] } + { [ t ] [ , ] } + } cond ] each ] [ ] make ; @@ -180,6 +174,12 @@ M: hook-generic synopsis* M: method-spec synopsis* dup definer. [ pprint-word ] each ; +M: method-body synopsis* + dup dup + definer. + "method-class" word-prop pprint* + "method-generic" word-prop pprint* ; + M: mixin-instance synopsis* dup definer. dup mixin-instance-class pprint-word @@ -194,6 +194,15 @@ M: pathname synopsis* pprint* ; [ synopsis* ] with-in ] with-string-writer ; +: synopsis-alist ( definitions -- alist ) + [ dup synopsis swap ] { } map>assoc ; + +: definitions. ( alist -- ) + [ write-object nl ] assoc-each ; + +: sorted-definitions. ( definitions -- ) + synopsis-alist sort-keys definitions. ; + GENERIC: declarations. ( obj -- ) M: object declarations. drop ; @@ -259,7 +268,9 @@ M: builtin-class see-class* natural-sort [ nl see ] each ; : see-implementors ( class -- seq ) - dup implementors [ 2array ] with map ; + dup implementors + [ method ] with map + natural-sort ; : see-class ( class -- ) dup class? [ @@ -269,8 +280,7 @@ M: builtin-class see-class* ] when drop ; : see-methods ( generic -- seq ) - [ "methods" word-prop keys natural-sort ] keep - [ 2array ] curry map ; + "methods" word-prop values natural-sort ; M: word see dup see-class diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index c30db0a4b8..74c296d94c 100755 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -51,8 +51,8 @@ HELP: literalize { $values { "obj" object } { "wrapped" object } } { $description "Outputs an object which evaluates to " { $snippet "obj" } " when placed in a quotation. If " { $snippet "obj" } " is not self-evaluating (for example, it is a word), then it will be wrapped." } { $examples - { $example "USE: quotations" "5 literalize ." "5" } - { $example "USE: quotations" "[ + ] [ literalize ] map ." "[ \\ + ]" } + { $example "USING: prettyprint quotations ;" "5 literalize ." "5" } + { $example "USING: math prettyprint quotations sequences ;" "[ + ] [ literalize ] map ." "[ \\ + ]" } } ; { literalize curry POSTPONE: \ POSTPONE: W{ } related-words 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..9e8dcd6559 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -288,8 +288,8 @@ HELP: new-resizable { $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } } { $contract "Outputs a resizable mutable sequence with an initial capacity of " { $snippet "n" } " elements and zero length, which can hold the elements of " { $snippet "seq" } "." } { $examples - { $example "300 V{ } new-resizable ." "V{ }" } - { $example "300 SBUF\" \" new-resizable ." "SBUF\" \"" } + { $example "USING: prettyprint sequences ;" "300 V{ } new-resizable ." "V{ }" } + { $example "USING: prettyprint sequences ;" "300 SBUF\" \" new-resizable ." "SBUF\" \"" } } ; HELP: like @@ -429,25 +429,27 @@ 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" } } { $description "Combines successive elements of the sequence using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." } { $examples - { $example "{ 1 5 3 } 0 [ + ] reduce ." "9" } + { $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" } } ; HELP: accumulate { $values { "identity" object } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } } -{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence. Given the empty sequence, outputs a one-element sequence consisting of " { $snippet "identity" } "." } +{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." +$nl +"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } { $examples - { $example "{ 2 2 2 2 2 } 0 [ + ] accumulate . ." "{ 0 2 4 6 8 }\n10" } + { $example "USING: math prettyprint sequences ;" "{ 2 2 2 2 2 } 0 [ + ] accumulate . ." "{ 0 2 4 6 8 }\n10" } } ; 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 )" } } } @@ -546,9 +548,9 @@ HELP: monotonic? { $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." } { $examples "Testing if a sequence is non-decreasing:" - { $example "{ 1 1 2 } [ <= ] monotonic? ." "t" } + { $example "USING: math prettyprint sequences ;" "{ 1 1 2 } [ <= ] monotonic? ." "t" } "Testing if a sequence is decreasing:" - { $example "{ 9 8 6 7 } [ < ] monotonic? ." "f" } + { $example "USING: math prettyprint sequences ;" "{ 9 8 6 7 } [ < ] monotonic? ." "f" } } ; { monotonic? all-eq? all-equal? } related-words @@ -556,7 +558,7 @@ HELP: monotonic? HELP: interleave { $values { "seq" sequence } { "between" "a quotation" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } { $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." } -{ $example "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ; +{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ; HELP: cache-nth { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( i -- elt )" } } { "elt" object } } @@ -590,7 +592,7 @@ HELP: memq? { $description "Tests if the sequence contains the object." } { $examples "This word uses identity comparison, so the following will most likely print " { $link f } ":" - { $example "\"hello\" { \"hello\" } memq? ." "f" } + { $example "USING: prettyprint sequences ;" "\"hello\" { \"hello\" } memq? ." "f" } } ; HELP: remove @@ -629,6 +631,7 @@ HELP: push-new { $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." } { $examples { $example + "USING: namespaces prettyprint sequences ;" "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set" "\"nachos\" \"v\" get push-new" "\"salsa\" \"v\" get push-new" @@ -645,7 +648,7 @@ HELP: add { $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." } { $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." } { $examples - { $example "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" } + { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" } } ; HELP: add* @@ -653,7 +656,7 @@ HELP: add* { $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." } { $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." } { $examples - { $example "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" } +{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" } } ; HELP: seq-diff @@ -710,7 +713,7 @@ HELP: mismatch HELP: flip { $values { "matrix" "a sequence of equal-length sequences" } { "newmatrix" "a sequence of equal-length sequences" } } { $description "Transposes the matrix; that is, rows become columns and columns become rows." } -{ $examples { $example "{ { 1 2 3 } { 4 5 6 } } flip ." "{ { 1 4 } { 2 5 } { 3 6 } }" } } ; +{ $examples { $example "USING: prettyprint sequences ;" "{ { 1 2 3 } { 4 5 6 } } flip ." "{ { 1 4 } { 2 5 } { 3 6 } }" } } ; HELP: exchange { $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } } @@ -728,12 +731,12 @@ HELP: padding HELP: pad-left { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } } { $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the left with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." } -{ $examples { $example "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ; +{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ; HELP: pad-right { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } } { $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the right with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." } -{ $examples { $example "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ; +{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ; HELP: sequence= { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } } @@ -798,6 +801,7 @@ HELP: ( seq n -- column ) { $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } { $examples { $example + "USING: arrays prettyprint sequences ;" "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 >array ." "{ 1 4 7 }" } @@ -813,8 +817,8 @@ HELP: ( len elt -- repetition ) { $values { "len" "a non-negative integer" } { "elt" object } { "repetition" repetition } } { $description "Creates a new " { $link repetition } "." } { $examples - { $example "10 \"X\" >array ." "{ \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" }" } - { $example "10 \"X\" >array concat ." "\"XXXXXXXXXX\"" } + { $example "USING: arrays prettyprint sequences ;" "10 \"X\" >array ." "{ \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" }" } + { $example "USING: prettyprint sequences ;" "10 \"X\" concat ." "\"XXXXXXXXXX\"" } } ; HELP: copy { $values { "src" sequence } { "i" "an index in " { $snippet "dest" } } { "dst" "a mutable sequence" } } @@ -936,7 +940,7 @@ HELP: unclip { $values { "seq" sequence } { "rest" sequence } { "first" object } } { $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first." } { $examples - { $example "{ 1 2 3 } unclip add ." "{ 2 3 1 }" } + { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip add ." "{ 2 3 1 }" } } ; HELP: unclip-slice @@ -966,7 +970,7 @@ HELP: unfold { $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." } { $examples "The following example divides a number by two until we reach zero, and accumulates intermediate results:" - { $example "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" } + { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" } "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:" - { $unchecked-example "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" } + { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" } } ; diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 40b2fef85e..c545a9baee 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -1,7 +1,7 @@ USING: arrays kernel math namespaces sequences kernel.private sequences.private strings sbufs tools.test vectors bit-arrays generic ; -IN: temporary +IN: sequences.tests [ V{ 1 2 3 4 } ] [ 1 5 dup >vector ] unit-test [ 3 ] [ 1 4 dup length ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index ee38d30750..9fc5264440 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -310,13 +310,11 @@ M: immutable-sequence clone-like like ; r dup length swap r> ; inline - : (each) ( seq quot -- n quot' ) - iterate-seq [ >r nth-unsafe r> call ] 2curry ; inline + >r dup length swap [ nth-unsafe ] curry r> compose ; inline : (collect) ( quot into -- quot' ) - [ >r over slip r> set-nth-unsafe ] 2curry ; inline + [ >r keep r> set-nth-unsafe ] 2curry ; inline : collect ( n quot into -- ) (collect) each-integer ; inline @@ -415,7 +413,7 @@ PRIVATE> >r dup length 1- swap r> (monotonic) all? ; inline : interleave ( seq between quot -- ) - [ (interleave) ] 2curry iterate-seq 2each ; inline + [ (interleave) ] 2curry >r dup length swap r> 2each ; inline : unfold ( pred quot tail -- seq ) V{ } clone [ @@ -443,6 +441,9 @@ PRIVATE> : memq? ( obj seq -- ? ) [ eq? ] with contains? ; +: seq-intersect ( seq1 seq2 -- seq1/\seq2 ) + swap [ member? ] curry subset ; + : remove ( obj seq -- newseq ) [ = not ] with subset ; @@ -695,9 +696,9 @@ PRIVATE> : sequence-hashcode-step ( oldhash newpart -- newhash ) swap [ - dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum + dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast fixnum+fast fixnum+fast - ] keep bitxor ; inline + ] keep fixnum-bitxor ; inline : sequence-hashcode ( n seq -- x ) 0 -rot [ diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index d8c8f5fbba..d57c4053e6 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -68,7 +68,7 @@ HELP: reader-quot HELP: slot-reader { $class-description "The class of slot reader words." } { $examples - { $example "USING: classes slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" } + { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" } } ; HELP: define-reader @@ -83,7 +83,7 @@ HELP: writer-effect HELP: slot-writer { $class-description "The class of slot writer words." } { $examples - { $example "USING: classes slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" } + { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" } } ; HELP: define-writer diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 40f0dd3da1..92d22247bd 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -110,3 +110,6 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ; : slot-of-writer ( writer specs -- spec/f ) [ slot-spec-writer eq? ] with find nip ; + +: slot-named ( string specs -- spec/f ) + [ slot-spec-name = ] with find nip ; 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-docs.factor b/core/source-files/source-files-docs.factor index 36a7ae67bb..2371c27e52 100755 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -51,7 +51,7 @@ HELP: record-modified $low-level-note ; HELP: record-checksum -{ $values { "source-file" source-file } { "contents" string } } +{ $values { "source-file" source-file } { "lines" "a sequence of strings" } } { $description "Records the CRC32 checksm of the source file's contents." } $low-level-note ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index c7539ad3eb..98438b48d8 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -4,8 +4,8 @@ USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger -io.files io.crc32 io.streams.string io.streams.lines vocabs -hashtables graphs compiler.units ; +io.files io.crc32 io.streams.string vocabs +hashtables graphs compiler.units io.encodings.utf8 ; IN: source-files SYMBOL: source-files @@ -17,7 +17,7 @@ uses definitions ; : (source-modified?) ( path modified checksum -- ? ) pick file-modified rot [ 0 or ] 2apply > - [ swap file-lines lines-crc32 = not ] [ 2drop f ] if ; + [ swap utf8 file-lines lines-crc32 = not ] [ 2drop f ] if ; : source-modified? ( path -- ? ) dup source-files get at [ @@ -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 + utf8 file-lines swap record-checksum + ] [ 2drop ] if ] assoc-each ; M: pathname where pathname-string 1 2array ; @@ -82,7 +85,7 @@ M: pathname where pathname-string 1 2array ; M: pathname forget* pathname-string forget-source ; -: rollback-source-file ( source-file -- ) +: rollback-source-file ( file -- ) dup source-file-definitions new-definitions get [ union ] 2map swap set-source-file-definitions ; @@ -97,16 +100,8 @@ SYMBOL: file [ ] [ file get rollback-source-file ] cleanup ] with-scope ; inline -: smart-usage ( word -- definitions ) - \ f or usage [ - dup method-body? [ - "method" word-prop - { method-specializer method-generic } get-slots - 2array - ] when - ] map ; - : outside-usages ( seq -- usages ) dup [ - over smart-usage [ pathname? not ] subset seq-diff + over usage + [ dup pathname? not swap where and ] subset seq-diff ] curry { } map>assoc ; diff --git a/core/splitting/splitting-docs.factor b/core/splitting/splitting-docs.factor index 2535f98524..5000dbf5fd 100644 --- a/core/splitting/splitting-docs.factor +++ b/core/splitting/splitting-docs.factor @@ -33,7 +33,7 @@ HELP: last-split1 HELP: split { $values { "seq" "a sequence" } { "separators" "a sequence" } { "pieces" "a new array" } } { $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." } -{ $examples { $example "USE: splitting" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ; +{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ; HELP: groups { $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively." @@ -51,7 +51,7 @@ HELP: { $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example - "USE: splitting" + "USING: arrays kernel prettyprint sequences splitting ;" "9 >array 3 dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" } } ; @@ -61,7 +61,7 @@ HELP: { $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example - "USE: splitting" + "USING: arrays kernel prettyprint sequences splitting ;" "9 >array 3 " "dup [ reverse-here ] each concat >array ." "{ 2 1 0 5 4 3 8 7 6 }" @@ -90,5 +90,5 @@ HELP: string-lines { $values { "str" string } { "seq" "a sequence of strings" } } { $description "Splits a string along line breaks." } { $examples - { $example "USE: splitting" "\"Hello\\r\\nworld\\n\" string-lines ." "{ \"Hello\" \"world\" \"\" }" } + { $example "USING: prettyprint splitting ;" "\"Hello\\r\\nworld\\n\" string-lines ." "{ \"Hello\" \"world\" \"\" }" } } ; 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/splitting/splitting.factor b/core/splitting/splitting.factor old mode 100644 new mode 100755 index c6230ebe16..6416e27eaf --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -69,12 +69,12 @@ INSTANCE: groups sequence : split ( seq separators -- pieces ) [ split, ] { } make ; : string-lines ( str -- seq ) - dup [ "\r\n" member? ] contains? [ + dup "\r\n" seq-intersect empty? [ + 1array + ] [ "\n" split [ 1 head-slice* [ "\r" ?tail drop "\r" split ] map ] keep peek "\r" split add concat - ] [ - 1array ] if ; 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..dc06a239de 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." @@ -204,7 +204,7 @@ HELP: delimiter HELP: parsing { $syntax ": foo ... ; parsing" } { $description "Declares the most recently defined word as a parsing word." } -{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example ": hello \"Hello parser!\" print ; parsing\n: world hello ;" "Hello parser!" } } ; +{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example "USE: io" "<< : hello \"Hello parser!\" print ; parsing >>\n: world hello ;" "Hello parser!" } } ; HELP: inline { $syntax ": foo ... ; inline" } @@ -367,7 +367,7 @@ HELP: SYMBOL: { $syntax "SYMBOL: word" } { $values { "word" "a new word to define" } } { $description "Defines a new symbol word in the current vocabulary. Symbols push themselves on the stack when executed, and are used to identify variables (see " { $link "namespaces" } ") as well as for storing crufties in word properties (see " { $link "word-props" } ")." } -{ $examples { $example "SYMBOL: foo\nfoo ." "foo" } } ; +{ $examples { $example "USE: prettyprint" "SYMBOL: foo\nfoo ." "foo" } } ; { define-symbol POSTPONE: SYMBOL: } related-words @@ -424,19 +424,19 @@ HELP: " { $syntax "\"string...\"" } { $values { "string" "literal and escaped characters" } } { $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", and appends the resulting string to the parse tree. String literals cannot span multiple lines. Strings containing the " { $link POSTPONE: " } " character and various other special characters can be read by inserting escape sequences." } -{ $examples { $example "\"Hello\\nworld\" print" "Hello\nworld" } } ; +{ $examples { $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" } } ; HELP: SBUF" { $syntax "SBUF\" string... \"" } { $values { "string" "literal and escaped characters" } } { $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", converts the string to a string buffer, and appends it to the parse tree." } -{ $examples { $example "SBUF\" Hello world\" >string print" "Hello world" } } ; +{ $examples { $example "USING: io strings ;" "SBUF\" Hello world\" >string print" "Hello world" } } ; HELP: P" { $syntax "P\" pathname\"" } { $values { "pathname" "a pathname string" } } { $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", creates a new " { $link pathname } ", and appends it to the parse tree." } -{ $examples { $example "USE: io.files" "P\" foo.txt\" pathname-string print" "foo.txt" } } ; +{ $examples { $example "USING: io io.files ;" "P\" foo.txt\" pathname-string print" "foo.txt" } } ; HELP: ( { $syntax "( inputs -- outputs )" } @@ -460,19 +460,19 @@ HELP: HEX: { $syntax "HEX: integer" } { $values { "integer" "hexadecimal digits (0-9, a-f, A-F)" } } { $description "Adds an integer read from a hexadecimal literal to the parse tree." } -{ $examples { $example "HEX: ff ." "255" } } ; +{ $examples { $example "USE: prettyprint" "HEX: ff ." "255" } } ; HELP: OCT: { $syntax "OCT: integer" } { $values { "integer" "octal digits (0-7)" } } { $description "Adds an integer read from an octal literal to the parse tree." } -{ $examples { $example "OCT: 31337 ." "13023" } } ; +{ $examples { $example "USE: prettyprint" "OCT: 31337 ." "13023" } } ; HELP: BIN: { $syntax "BIN: integer" } { $values { "integer" "binary digits (0 and 1)" } } { $description "Adds an integer read from an binary literal to the parse tree." } -{ $examples { $example "BIN: 100 ." "4" } } ; +{ $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ; HELP: GENERIC: { $syntax "GENERIC: word" } @@ -500,6 +500,7 @@ HELP: HOOK: { $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." } { $examples { $example + "USING: io namespaces ;" "SYMBOL: transport" "TUPLE: land-transport ;" "TUPLE: air-transport ;" 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..7e7a5ff215 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" @@ -15,10 +15,6 @@ ARTICLE: "os" "System interface" { $subsection wince? } "Processor detection:" { $subsection cpu } -"Processor cell size:" -{ $subsection cell } -{ $subsection cells } -{ $subsection cell-bits } "Reading environment variables:" { $subsection os-env } { $subsection os-envs } @@ -29,7 +25,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" @@ -114,7 +110,15 @@ HELP: os-envs } { $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ; -{ os-env os-envs } related-words +HELP: set-os-envs +{ $values { "assoc" "an association mapping strings to strings" } } +{ $description "Replaces the current set of environment variables." } +{ $notes + "Names and values of environment variables are operating system-specific." +} +{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ; + +{ os-env os-envs set-os-envs } related-words HELP: win32? { $values { "?" "a boolean" } } @@ -135,27 +139,3 @@ HELP: vm HELP: unix? { $values { "?" "a boolean" } } { $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ; - -HELP: cell -{ $values { "n" "a positive integer" } } -{ $description "Outputs the pointer size in bytes of the current CPU architecture." } ; - -HELP: cells -{ $values { "m" integer } { "n" integer } } -{ $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ; - -HELP: cell-bits -{ $values { "n" integer } } -{ $description "Outputs the number of bits in one CPU operand-sized cell." } ; - -HELP: bootstrap-cell -{ $values { "n" "a positive integer" } } -{ $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; - -HELP: bootstrap-cells -{ $values { "m" integer } { "n" integer } } -{ $description "Computes the number of bytes used by " { $snippet "m" } " cells in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; - -HELP: bootstrap-cell-bits -{ $values { "n" integer } } -{ $description "Outputs the number of bits in one cell in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index c542e68981..4b074ed7aa 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -1,6 +1,14 @@ -USING: math tools.test system prettyprint ; -IN: temporary +USING: math tools.test system prettyprint namespaces kernel ; +IN: system.tests -[ t ] [ cell integer? ] unit-test -[ t ] [ bootstrap-cell integer? ] unit-test -[ ] [ os-envs . ] unit-test +wince? [ + [ ] [ os-envs . ] unit-test +] unless + +unix? [ + [ ] [ os-envs "envs" set ] unit-test + [ ] [ { { "A" "B" } } set-os-envs ] unit-test + [ "B" ] [ "A" os-env ] unit-test + [ ] [ "envs" get set-os-envs ] unit-test + [ t ] [ os-envs "envs" get = ] unit-test +] when diff --git a/core/system/system.factor b/core/system/system.factor index 4500720058..87bbcfdc3f 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -2,13 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: system USING: kernel kernel.private sequences math namespaces -splitting assocs ; - -: cell ( -- n ) 7 getenv ; foldable - -: cells ( m -- n ) cell * ; inline - -: cell-bits ( -- n ) 8 cells ; inline +splitting assocs system.private layouts ; : cpu ( -- cpu ) 8 getenv ; foldable @@ -51,11 +45,8 @@ splitting assocs ; : solaris? ( -- ? ) os "solaris" = ; -: bootstrap-cell \ cell get cell or ; inline - -: bootstrap-cells bootstrap-cell * ; inline - -: bootstrap-cell-bits 8 bootstrap-cells ; inline - : os-envs ( -- assoc ) (os-envs) [ "=" split1 ] H{ } map>assoc ; + +: set-os-envs ( assoc -- ) + [ "=" swap 3append ] { } assoc>map (set-os-envs) ; diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index da6844ed85..a2c50346df 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" @@ -17,7 +17,10 @@ ARTICLE: "threads-start/stop" "Starting and stopping threads" ARTICLE: "threads-yield" "Yielding and suspending threads" "Yielding to other threads:" { $subsection yield } +"Sleeping for a period of time:" { $subsection sleep } +"Interrupting sleep:" +{ $subsection interrupt } "Threads can be suspended and woken up at some point in the future when a condition is satisfied:" { $subsection suspend } { $subsection resume } @@ -62,7 +65,6 @@ HELP: thread { { $link thread-name } " - the name passed to " { $link spawn } "." } { { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." } { { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." } - { { $link thread-registered? } " - a boolean indicating whether the thread is eligible to run or not. Spawning a thread with " { $link (spawn) } " sets this flag and " { $link stop } " clears it." } } } ; @@ -71,8 +73,10 @@ HELP: self { $description "Pushes the currently-running thread." } ; HELP: -{ $values { "quot" quotation } { "name" string } { "error-handler" quotation } } -{ $description "Low-level thread constructor. The thread runs the quotation when spawned; the name is simply used to identify the thread for debugging purposes. The error handler is called if the thread's quotation throws an unhandled error; it should either print the error or notify another thread." } +{ $values { "quot" quotation } { "name" string } { "thread" thread } } +{ $description "Low-level thread constructor. The thread runs the quotation when spawned." +$nl +"The name is used to identify the thread for debugging purposes; see " { $link "tools.threads" } "." } { $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link } " then passed to " { $link (spawn) } "." } ; HELP: run-queue @@ -94,7 +98,7 @@ HELP: sleep-queue { $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ; HELP: sleep-time -{ $values { "ms" "a non-negative integer or " { $link f } } } +{ $values { "ms/f" "a non-negative integer or " { $link f } } } { $description "Outputs the time until the next sleeping thread is scheduled to wake up, which could be zero if there are threads in the run queue, or threads which need to wake up right now. If there are no runnable or sleeping threads, outputs " { $link f } "." } ; HELP: stop @@ -103,25 +107,44 @@ 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. It will not get woken up before this time period elapses, but since the multitasker is co-operative, the precise wakeup time is dependent on when other threads yield." } ; +{ $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 } } +{ $description "Interrupts a sleeping thread." } ; HELP: suspend -{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } } -{ $description "Suspends the current thread and passes it to the quotation. After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "." } ; +{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "state" string } { "obj" object } } +{ $description "Suspends the current thread and passes it to the quotation." +$nl +"After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "." +$nl +"The status string is for debugging purposes; see " { $link "tools.threads" } "." } ; HELP: spawn -{ $values { "quot" quotation } { "name" string } } +{ $values { "quot" quotation } { "name" string } { "thread" thread } } { $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" } } ; HELP: spawn-server -{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } } +{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } { "thread" thread } } { $description "Convenience wrapper around " { $link spawn } " which repeatedly calls the quotation in a new thread until it outputs " { $link f } "." } { $examples "A thread that runs forever:" 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 05128982bb..b4fd6eee60 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -4,16 +4,15 @@ 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 -id registered? +name quot exit-handler +id continuation state -mailbox variables ; +mailbox variables sleep-entry ; : self ( -- thread ) 40 getenv ; inline @@ -37,37 +36,36 @@ threads global [ H{ } assoc-like ] change-at : thread ( id -- thread ) threads at ; - -: ( quot name error-handler -- thread ) - \ thread counter { +: ( 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 } \ thread construct ; : run-queue 42 getenv ; @@ -75,48 +73,68 @@ 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 ; -r check-registered r> sleep-queue heap-push ; - -: wake-up? ( heap -- ? ) - dup heap-empty? - [ drop f ] [ heap-peek nip millis <= ] if ; - -: wake-up ( -- ) - sleep-queue - [ dup wake-up? ] [ dup heap-pop drop resume ] [ ] while - drop ; - -: next ( -- ) - walker-hook [ - continue - ] [ - wake-up - run-queue 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 ) +: sleep-time ( -- ms/f ) { { [ run-queue dlist-empty? not ] [ 0 ] } { [ sleep-queue heap-empty? ] [ f ] } { [ t ] [ sleep-queue heap-peek nip millis [-] ] } } cond ; +r check-registered dup r> sleep-queue heap-push* + swap set-thread-sleep-entry ; + +: expire-sleep? ( heap -- ? ) + dup heap-empty? + [ drop f ] [ heap-peek nip millis <= ] if ; + +: expire-sleep ( thread -- ) + f over set-thread-sleep-entry resume ; + +: expire-sleep-loop ( -- ) + sleep-queue + [ dup expire-sleep? ] + [ dup heap-pop drop expire-sleep ] + [ ] while + drop ; + +: next ( -- * ) + expire-sleep-loop + run-queue dup dlist-empty? [ + ! We should never be in a state where the only threads + ! are sleeping; the I/O wait thread is always runnable. + ! However, if it dies, we handle this case + ! semi-gracefully. + ! + ! And if sleep-time outputs f, there are no sleeping + ! threads either... so WTF. + drop sleep-time [ die 0 ] unless* (sleep) next + ] [ + pop-back + dup array? [ first2 ] [ f swap ] if dup set-self + f over set-thread-state + thread-continuation box> + continue-with + ] if ; + +PRIVATE> + : stop ( -- ) - self unregister-thread next ; + self dup thread-exit-handler call + unregister-thread next ; : suspend ( quot state -- obj ) [ @@ -125,19 +143,33 @@ PRIVATE> self swap call next ] callcc1 2nip ; inline -: yield ( -- ) [ resume ] "yield" suspend drop ; +: yield ( -- ) [ resume ] f suspend drop ; -: sleep ( ms -- ) - >fixnum millis + - [ schedule-sleep ] curry - "sleep" suspend drop ; +GENERIC: sleep-until ( time/f -- ) + +M: integer sleep-until + [ schedule-sleep ] curry "sleep" suspend drop ; + +M: f sleep-until + drop [ drop ] "interrupt" suspend drop ; + +GENERIC: sleep ( ms -- ) + +M: real sleep + millis + >integer sleep-until ; + +: interrupt ( thread -- ) + dup thread-state [ + dup thread-sleep-entry [ sleep-queue heap-delete ] when* + f over set-thread-sleep-entry + dup resume + ] when drop ; : (spawn) ( thread -- ) [ - resume [ + resume-now [ dup set-self dup register-thread - init-namespaces V{ } set-catchstack { } set-retainstack >r { } set-datastack r> @@ -146,19 +178,7 @@ PRIVATE> ] "spawn" suspend 2drop ; : spawn ( quot name -- 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) ] keep ; + [ (spawn) ] keep ; : spawn-server ( quot name -- thread ) >r [ [ ] [ ] while ] curry r> spawn ; @@ -168,6 +188,8 @@ PRIVATE> [ >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-registered? + 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-docs.factor b/core/tuples/tuples-docs.factor index a4fe3265fc..c03b9784ee 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -180,6 +180,7 @@ HELP: construct-empty { $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." } { $examples { $example + "USING: kernel prettyprint ;" "TUPLE: employee number name department ;" "employee construct-empty ." "T{ employee f f f f }" 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/vectors/vectors.factor b/core/vectors/vectors.factor index ed97bcc0c4..1820c62ff4 100755 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -5,7 +5,7 @@ IN: vectors vector ( byte-array capacity -- byte-vector ) +: array>vector ( array length -- vector ) vector construct-boa ; inline PRIVATE> diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index a306efbd68..9f7b2b5b9f 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -65,12 +65,12 @@ HELP: load-help? { $var-description "If set to a true value, documentation will be automatically loaded when vocabularies are loaded. This variable is usually on, except when Factor has been bootstrapped without the help system." } ; HELP: load-source -{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } } -{ $description "Loads a vocabulary's source code from the specified vocabulary root." } ; +{ $values { "vocab" "a vocabulary specifier" } } +{ $description "Loads a vocabulary's source code." } ; HELP: load-docs -{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } } -{ $description "If " { $link load-help? } " is on, loads a vocabulary's documentation from the specified vocabulary root." } ; +{ $values { "vocab" "a vocabulary specifier" } } +{ $description "If " { $link load-help? } " is on, loads a vocabulary's documentation." } ; HELP: reload { $values { "name" "a vocabulary name" } } 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..885bccddd1 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. 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 +hashtables sorting prettyprint source-files arrays combinators strings system math.parser compiler.errors -splitting ; +splitting init ; IN: vocabs.loader SYMBOL: vocab-roots @@ -75,7 +75,7 @@ SYMBOL: load-help? : source-wasn't-loaded f swap set-vocab-source-loaded? ; -: load-source ( vocab-link -- ) +: load-source ( vocab -- ) [ source-wasn't-loaded ] keep [ vocab-source-path bootstrap-file ] keep source-was-loaded ; @@ -84,7 +84,7 @@ SYMBOL: load-help? : docs-weren't-loaded f swap set-vocab-docs-loaded? ; -: load-docs ( vocab-link -- ) +: load-docs ( vocab -- ) load-help? get [ [ docs-weren't-loaded ] keep [ vocab-docs-path ?run-file ] keep @@ -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..eb1bd0908a 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -1,5 +1,5 @@ -USING: definitions help.markup help.syntax kernel -kernel.private parser words.private vocabs classes quotations +USING: definitions help.markup help.syntax kernel parser +kernel.private words.private vocabs classes quotations strings effects compiler.units ; IN: words @@ -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 } @@ -197,7 +197,7 @@ HELP: execute ( word -- ) { $values { "word" word } } { $description "Executes a word." } { $examples - { $example ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } + { $example "USING: kernel io words ;" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } } ; HELP: word-props ( word -- props ) @@ -322,7 +322,7 @@ HELP: create HELP: constructor-word { $values { "name" string } { "vocab" string } { "word" word } } { $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." } -{ $examples { $example "\"salmon\" \"scratchpad\" constructor-word ." "" } } ; +{ $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "" } } ; HELP: forget-word { $values { "word" word } } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index f29d21cd9f..4d9933147b 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,44 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ "IN: temporary : undef-test ; << undef-test >>" eval ] +"undef-test" "words.tests" lookup [ + [ forget ] with-compilation-unit +] when* + +[ "IN: words.tests : undef-test ; << undef-test >>" eval ] [ [ undefined? ] is? ] must-fail-with [ ] [ - "IN: temporary GENERIC: symbol-generic" eval + "IN: words.tests GENERIC: symbol-generic" eval ] unit-test [ ] [ - "IN: temporary SYMBOL: symbol-generic" eval + "IN: words.tests SYMBOL: symbol-generic" eval ] unit-test -[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test -[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test +[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test +[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test [ ] [ - "IN: temporary GENERIC: symbol-generic" eval + "IN: words.tests GENERIC: symbol-generic" + "symbol-generic-test" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: symbol-generic ;" eval + "IN: words.tests TUPLE: symbol-generic ;" + "symbol-generic-test" parse-stream drop ] unit-test -[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test -[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test +[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test +[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test ! Regressions -[ ] [ "IN: temporary : decl-forget-test ; foldable" eval ] unit-test -[ t ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test -[ f ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ; foldable" eval ] unit-test +[ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test +[ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ; flushable" eval ] unit-test -[ t ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test -[ f ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ; flushable" eval ] unit-test +[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test +[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index efb3d06a9b..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/cp_dir b/cp_dir deleted file mode 100755 index 76c8a8f03b..0000000000 --- a/cp_dir +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh - -echo $1 -mkdir -p "`dirname \"$2\"`" -cp "$1" "$2" diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor new file mode 100755 index 0000000000..80a0c14079 --- /dev/null +++ b/extra/alarms/alarms-docs.factor @@ -0,0 +1,27 @@ +IN: alarms +USING: help.markup help.syntax calendar quotations ; + +HELP: alarm +{ $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ; + +HELP: add-alarm +{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } } +{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; + +HELP: later +{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } } +{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ; + +HELP: cancel-alarm +{ $values { "alarm" alarm } } +{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ; + +ARTICLE: "alarms" "Alarms" +"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread." +{ $subsection alarm } +{ $subsection add-alarm } +{ $subsection later } +{ $subsection cancel-alarm } +"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ; + +ABOUT: "alarms" diff --git a/extra/alarms/alarms-tests.factor b/extra/alarms/alarms-tests.factor new file mode 100755 index 0000000000..d1161e4cee --- /dev/null +++ b/extra/alarms/alarms-tests.factor @@ -0,0 +1,19 @@ +IN: alarms.tests +USING: alarms alarms.private 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 + +\ alarm-thread-loop must-infer diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 40eda02fac..adf79c84c9 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -1,87 +1,91 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar combinators concurrency.messaging -threads generic init kernel math namespaces sequences ; +USING: arrays calendar combinators generic init kernel math +namespaces sequences heaps boxes threads debugger quotations +assocs ; IN: alarms -TUPLE: alarm time quot ; - -C: alarm +TUPLE: alarm quot time interval entry ; 0 > ] with subset ; - -: unexpired-alarms ( -- seq ) - now alarms get-global - [ alarm-time <=> 0 <= ] with subset ; - -: call-alarm ( alarm -- ) - alarm-quot "Alarm invocation" spawn drop ; - -: do-alarms ( -- ) - expired-alarms [ call-alarm ] each - unexpired-alarms alarms set-global ; - -: alarm-receive-loop ( -- ) - receive dup alarm? [ handle-alarm ] [ drop ] if - alarm-receive-loop ; - -: start-alarm-receiver ( -- ) - [ - alarm-receive-loop - ] "Alarm receiver" spawn alarm-receiver set-global ; - -: alarm-loop ( -- ) - alarms get-global empty? [ - do-alarms - ] unless 100 sleep alarm-loop ; - -: start-alarm-looper ( -- ) - [ - alarm-loop - ] "Alarm looper" spawn alarm-looper set-global ; - -: send-alarm ( str alarm -- ) - over set-delegate - alarm-receiver get-global send ; - -: start-alarm-daemon ( -- ) - alarms get-global [ V{ } clone alarms set-global ] unless - start-alarm-looper - start-alarm-receiver ; - -[ start-alarm-daemon ] "alarms" add-init-hook -PRIVATE> +: ( quot time frequency -- alarm ) + check-alarm alarm construct-boa ; : register-alarm ( alarm -- ) - "register" send-alarm ; + dup dup alarm-time alarms get-global heap-push* + swap alarm-entry >box + notify-alarm-thread ; -: unregister-alarm ( alarm -- ) - "unregister" send-alarm ; +: alarm-expired? ( alarm now -- ? ) + >r alarm-time r> before=? ; -: change-alarm ( alarm-old alarm-new -- ) - "register" send-alarm - "unregister" send-alarm ; +: reschedule-alarm ( alarm -- ) + dup alarm-time over alarm-interval time+ + over set-alarm-time + register-alarm ; -! Example: -! 5 seconds from-now [ "hi" print flush ] register-alarm +: call-alarm ( alarm -- ) + dup alarm-entry box> drop + dup alarm-quot "Alarm execution" spawn drop + dup alarm-interval [ reschedule-alarm ] [ drop ] if ; + +: (trigger-alarms) ( alarms now -- ) + over heap-empty? [ + 2drop + ] [ + over heap-peek drop over alarm-expired? [ + over heap-pop drop call-alarm (trigger-alarms) + ] [ + 2drop + ] if + ] if ; + +: trigger-alarms ( alarms -- ) + now (trigger-alarms) ; + +: next-alarm ( alarms -- timestamp/f ) + dup heap-empty? + [ drop f ] [ heap-peek drop alarm-time ] if ; + +: alarm-thread-loop ( -- ) + alarms get-global + dup next-alarm sleep-until + trigger-alarms ; + +: cancel-alarms ( alarms -- ) + [ + heap-pop-all [ nip alarm-entry box> drop ] assoc-each + ] when* ; + +: init-alarms ( -- ) + alarms global [ cancel-alarms ] change-at + [ alarm-thread-loop t ] "Alarms" spawn-server + alarm-thread set-global ; + +[ init-alarms ] "alarms" add-init-hook + +PRIVATE> + +: add-alarm ( quot time frequency -- alarm ) + [ register-alarm ] keep ; + +: later ( quot dt -- alarm ) + from-now f add-alarm ; + +: every ( quot dt -- alarm ) + [ from-now ] keep add-alarm ; + +: cancel-alarm ( alarm -- ) + alarm-entry [ alarms get-global heap-delete ] if-box? ; diff --git a/extra/ascii/ascii-tests.factor b/extra/ascii/ascii-tests.factor index ec76d89d7c..b2b13b1d78 100644 --- a/extra/ascii/ascii-tests.factor +++ b/extra/ascii/ascii-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ascii.tests USING: ascii tools.test sequences kernel math ; [ t ] [ CHAR: a letter? ] unit-test diff --git a/extra/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 100755 index 0000000000..ec424e89c9 --- /dev/null +++ b/extra/benchmark/crc32/crc32.factor @@ -0,0 +1,10 @@ +USING: io.crc32 io.encodings.ascii io.files kernel math ; +IN: benchmark.crc32 + +: crc32-primes-list ( -- ) + 10 [ + "extra/math/primes/list/list.factor" resource-path + ascii 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..3c9c78d358 100644 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -1,6 +1,6 @@ ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2 USING: math kernel io io.files locals multiline assocs sequences -sequences.private benchmark.reverse-complement hints +sequences.private benchmark.reverse-complement hints io.encodings.ascii byte-arrays float-arrays ; IN: benchmark.fasta @@ -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 + @@ -94,7 +94,7 @@ HINTS: random fixnum ; n [ ] seed [ initial-seed ] | - out [ + out ascii [ n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta initial-seed 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/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index b95e182bd1..e06b81f6de 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files splitting strings +USING: kernel io io.files splitting strings io.encodings.ascii hashtables sequences assocs math namespaces prettyprint math.parser combinators arrays sorting unicode.case ; @@ -57,7 +57,7 @@ IN: benchmark.knucleotide : knucleotide ( -- ) "extra/benchmark/knucleotide/knucleotide-input.txt" resource-path - [ read-input ] with-file-reader + ascii [ read-input ] with-file-reader process-input ; MAIN: knucleotide diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 230fb2f889..b890fdc8e8 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,6 +1,7 @@ IN: benchmark.mandel -USING: arrays io kernel math namespaces sequences strings sbufs -math.functions math.parser io.files colors.hsv ; +USING: arrays io kernel math namespaces sequences +byte-arrays byte-vectors math.functions math.parser io.files +colors.hsv io.encodings.binary ; : max-color 360 ; inline : zoom-fact 0.8 ; inline @@ -53,19 +54,18 @@ SYMBOL: cols : ppm-header ( w h -- ) "P6\n" % swap # " " % # "\n255\n" % ; -: sbuf-size width height * 3 * 100 + ; +: buf-size width height * 3 * 100 + ; -: mandel ( -- string ) +: mandel ( -- data ) [ - sbuf-size building set + buf-size building set width height ppm-header nb-iter max-color min cols set render - building get >string + building get >byte-array ] with-scope ; : mandel-main ( -- ) - "mandel.ppm" resource-path - [ mandel write ] with-file-writer ; + mandel "mandel.ppm" temp-file binary set-file-contents ; MAIN: mandel-main diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor new file mode 100644 index 0000000000..3043725acd --- /dev/null +++ b/extra/benchmark/md5/md5.factor @@ -0,0 +1,7 @@ +USING: crypto.md5 io.files kernel ; +IN: benchmark.md5 + +: md5-primes-list ( -- ) + "extra/math/primes/list/list.factor" resource-path file>md5 drop ; + +MAIN: md5-primes-list diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor new file mode 100755 index 0000000000..775595709a --- /dev/null +++ b/extra/benchmark/random/random.factor @@ -0,0 +1,14 @@ +USING: io.files io.encodings.ascii random math.parser io math ; +IN: benchmark.random + +: random-numbers-path "random-numbers.txt" temp-file ; + +: write-random-numbers ( n -- ) + random-numbers-path ascii [ + [ 200 random 100 - number>string print ] times + ] with-file-writer ; + +: random-main ( -- ) + 1000000 write-random-numbers ; + +MAIN: random-main diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor old mode 100644 new mode 100755 index 8f2badc95f..dbd1f5131b --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -3,7 +3,7 @@ USING: float-arrays compiler generic io io.files kernel math math.functions math.vectors math.parser namespaces sequences -sequences.private words ; +sequences.private words io.encodings.binary ; IN: benchmark.raytracer ! parameters @@ -167,10 +167,9 @@ DEFER: create ( level c r -- scene ) levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [ size size pgm-header [ [ oversampling sq / pgm-pixel ] each ] each - ] "" make ; + ] B{ } make ; : raytracer-main - "raytracer.pnm" resource-path - [ run write ] with-file-writer ; + run "raytracer.pnm" temp-file binary set-file-contents ; MAIN: raytracer-main diff --git a/extra/benchmark/reverse-complement/reverse-complement-test-out.txt b/extra/benchmark/reverse-complement/reverse-complement-test-out.txt old mode 100644 new mode 100755 diff --git a/extra/benchmark/reverse-complement/reverse-complement-tests.factor b/extra/benchmark/reverse-complement/reverse-complement-tests.factor new file mode 100755 index 0000000000..c8d4714802 --- /dev/null +++ b/extra/benchmark/reverse-complement/reverse-complement-tests.factor @@ -0,0 +1,13 @@ +IN: benchmark.reverse-complement.tests +USING: tools.test benchmark.reverse-complement crypto.md5 +io.files kernel ; + +[ "c071aa7e007a9770b2fb4304f55a17e5" ] [ + "extra/benchmark/reverse-complement/reverse-complement-test-in.txt" + "extra/benchmark/reverse-complement/reverse-complement-test-out.txt" + [ resource-path ] 2apply + reverse-complement + + "extra/benchmark/reverse-complement/reverse-complement-test-out.txt" + resource-path file>md5str +] unit-test diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 0771b756bf..9c782e65e6 100755 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.duplex kernel sequences sequences.private strings vectors words memoize splitting -hints unicode.case continuations ; +hints unicode.case continuations io.encodings.latin1 ; IN: benchmark.reverse-complement MEMO: trans-map ( -- str ) @@ -32,8 +32,8 @@ HINTS: do-line vector string ; readln [ do-line (reverse-complement) ] [ show-seq ] if* ; : reverse-complement ( infile outfile -- ) - [ - swap [ + latin1 [ + swap latin1 [ swap [ 500000 (reverse-complement) ] with-stream @@ -41,12 +41,10 @@ HINTS: do-line vector string ; ] with-disposal ; : reverse-complement-in - "extra/benchmark/reverse-complement/reverse-complement-in.txt" - resource-path ; + "reverse-complement-in.txt" temp-file ; : reverse-complement-out - "extra/benchmark/reverse-complement/reverse-complement-out.txt" - resource-path ; + "reverse-complement-out.txt" temp-file ; : reverse-complement-main ( -- ) reverse-complement-in diff --git a/extra/benchmark/ring/ring.factor b/extra/benchmark/ring/ring.factor index f1b7d6c9cc..ae918b7ebc 100755 --- a/extra/benchmark/ring/ring.factor +++ b/extra/benchmark/ring/ring.factor @@ -8,7 +8,9 @@ SYMBOL: done receive 2dup swap send done eq? [ tunnel ] unless ; : create-ring ( processes -- target ) - self swap [ [ tunnel ] "Tunnel" spawn nip ] times ; + self swap [ + dup [ tunnel ] curry "Tunnel" spawn nip + ] times ; : send-messages ( messages target -- ) dupd [ send ] curry each [ receive drop ] times ; diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 36529facaa..25212c7264 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 io.encodings.ascii +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 ascii dup "server" set [ + server-loop + ] with-disposal + ] ignore-errors ; + +: simple-client ( -- ) + server-addr ascii [ + 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 ascii [ + 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 old mode 100644 new mode 100755 index 0a31bf0ca4..cd6189fe22 --- a/extra/benchmark/sort/sort.factor +++ b/extra/benchmark/sort/sort.factor @@ -1,7 +1,10 @@ -USING: kernel sequences sorting random ; +USING: kernel sequences sorting benchmark.random math.parser +io.files io.encodings.ascii ; IN: benchmark.sort : sort-benchmark - 100000 [ drop 100000 random ] map natural-sort drop ; + random-numbers-path + ascii 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..bb7aebba62 100644 --- a/extra/benchmark/sum-file/sum-file.factor +++ b/extra/benchmark/sum-file/sum-file.factor @@ -1,13 +1,14 @@ -USING: io io.files math math.parser kernel prettyprint ; +USING: io io.files math math.parser kernel prettyprint +benchmark.random io.encodings.ascii ; IN: benchmark.sum-file : sum-file-loop ( n -- n' ) readln [ string>number + sum-file-loop ] when* ; : sum-file ( file -- ) - [ 0 sum-file-loop ] with-file-reader . ; + ascii [ 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/bitfields/bitfields-tests.factor b/extra/bitfields/bitfields-tests.factor old mode 100644 new mode 100755 index 8a3bb1f043..bbd4aa3db0 --- a/extra/bitfields/bitfields-tests.factor +++ b/extra/bitfields/bitfields-tests.factor @@ -1,4 +1,5 @@ USING: tools.test bitfields kernel ; +IN: bitfields.tests SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ; diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 552e26ebf5..ab26a4ff13 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -2,23 +2,34 @@ ! See http://factorcode.org/license.txt for BSD license. IN: bootstrap.image.upload USING: http.client crypto.md5 splitting assocs kernel io.files -bootstrap.image sequences io namespaces io.launcher math ; +bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ; -: 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 ascii [ boot-image-names [ dup write bl file>md5str print ] each ] with-file-writer ; : upload-images ( -- ) [ - "scp" , boot-image-names % "checksums.txt" , destination , + "scp" , + boot-image-names % + "temp/checksums.txt" , destination , ] { } make try-process ; : new-images ( -- ) - make-images compute-checksums upload-images ; + "" resource-path + [ make-images compute-checksums upload-images ] + with-directory ; MAIN: new-images diff --git a/extra/bootstrap/ui/tools/tools.factor b/extra/bootstrap/ui/tools/tools.factor old mode 100644 new mode 100755 index af715966b3..c4a555b3e2 --- a/extra/bootstrap/ui/tools/tools.factor +++ b/extra/bootstrap/ui/tools/tools.factor @@ -7,4 +7,6 @@ USING: kernel vocabs vocabs.loader sequences system ; "ui.cocoa" vocab [ "ui.cocoa.tools" require ] when + + "ui.tools.walker" require ] when diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100644 new mode 100755 index d8305041ab..da96e51dd4 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -2,21 +2,16 @@ USING: kernel namespaces sequences splitting system combinators continuations parser io io.files io.launcher io.sockets prettyprint threads bootstrap.image benchmark vars bake smtp builder.util accessors - builder.benchmark ; + io.encodings.utf8 + calendar + builder.common + builder.benchmark + builder.release ; IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: builds-dir - -: builds ( -- path ) - builds-dir get - home "/builds" append - or ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : prepare-build-machine ( -- ) builds make-directory builds cd @@ -32,8 +27,6 @@ SYMBOL: builds-dir ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -VAR: stamp - : enter-build-dir ( -- ) datestamp >stamp builds cd @@ -43,66 +36,59 @@ VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : git-id ( -- id ) - { "git" "show" } [ readln ] with-stream " " split second ; + { "git" "show" } utf8 + [ readln ] with-stream " " split second ; -: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ; +: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ; -: make-clean ( -- desc ) { "make" "clean" } ; +: do-make-clean ( -- ) { "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 - >desc ; + + { "make" } >>command + "../compile-log" >>stdout + +stdout+ >>stderr ; + +: 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 ) - - bootstrap-cmd >>arguments + + bootstrap-cmd >>command +closed+ >>stdin "../boot-log" >>stdout +stdout+ >>stderr - 20 minutes>ms >>timeout - >desc ; + 20 minutes >>timeout ; + +: 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 ) - - builder-test-cmd >>arguments + + builder-test-cmd >>command +closed+ >>stdin "../test-log" >>stdout +stdout+ >>stderr - 45 minutes>ms >>timeout - >desc ; + 45 minutes >>timeout ; + +: do-builder-test ( -- ) + builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -116,48 +102,49 @@ SYMBOL: build-status enter-build-dir - "report" [ + "report" utf8 + [ + "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 + "help-lint results:" print "help-lint" 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 ; @@ -176,8 +163,8 @@ SYMBOL: builder-recipients builder-from get >>from builder-recipients get >>to subject >>subject - "../report" file>string >>body - send ; + "./report" file>string >>body + send-email ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -185,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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -223,9 +211,8 @@ USE: bootstrap.image.download [ build ] when ] - [ drop ] - recover - 5 minutes>ms sleep + failsafe + 5 minutes sleep build-loop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor new file mode 100644 index 0000000000..6ebe1d625a --- /dev/null +++ b/extra/builder/common/common.factor @@ -0,0 +1,18 @@ + +USING: kernel namespaces io.files sequences vars ; + +IN: builder.common + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builds-dir + +: builds ( -- path ) + builds-dir get + home "/builds" append + or ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: stamp + diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor new file mode 100644 index 0000000000..f0cf0ee113 --- /dev/null +++ b/extra/builder/release/release.factor @@ -0,0 +1,116 @@ + +USING: kernel system namespaces sequences splitting combinators + io.files io.launcher + bake combinators.cleave builder.common builder.util ; + +IN: builder.release + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: releases ( -- path ) + builds "releases" path+ + dup exists? not + [ dup make-directory ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: common-files ( -- seq ) + { + "boot.x86.32.image" + "boot.x86.64.image" + "boot.macosx-ppc.image" + "vm" + "temp" + "logs" + ".git" + ".gitignore" + "Makefile" + "cp_dir" + "unmaintained" + "misc/target" + "misc/wordsize" + "misc/wordsize.c" + "misc/macos-release.sh" + "misc/source-release.sh" + "misc/windows-release.sh" + "misc/version.sh" + } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cpu- ( -- cpu ) cpu "." split "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: extension ( -- extension ) + os + { + { "linux" [ ".tar.gz" ] } + { "winnt" [ ".zip" ] } + { "macosx" [ ".dmg" ] } + } + case ; + +: archive-name ( -- string ) base-name extension append ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ; + +: macosx-archive-cmd ( -- cmd ) + { "hdiutil" "create" + "-srcfolder" "factor" + "-fs" "HFS+" + "-volname" "factor" + archive-name } ; + +: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: archive-cmd ( -- cmd ) + { + { [ windows? ] [ windows-archive-cmd ] } + { [ macosx? ] [ macosx-archive-cmd ] } + { [ unix? ] [ unix-archive-cmd ] } + } + cond ; + +: make-archive ( -- ) archive-cmd to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: remove-common-files ( -- ) + { "rm" "-rf" common-files } to-strings try-process ; + +: remove-factor-app ( -- ) + macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ; + +: release ( -- ) + "factor" + [ + remove-factor-app + remove-common-files + ] + with-directory + make-archive + archive-name releases move-file-into ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: release? ( -- ? ) + { + "./load-everything-vocabs" + "./test-all-vocabs" + } + [ eval-file empty? ] + all? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: maybe-release ( -- ) release? [ release ] when ; \ No newline at end of file diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index c664941132..dd3c640a84 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -6,22 +6,40 @@ USING: kernel namespaces sequences assocs builder continuations prettyprint tools.browser tools.test + io.encodings.utf8 + combinators.cleave + help.lint bootstrap.stage2 benchmark builder.util ; IN: builder.test : do-load ( -- ) - try-everything keys "../load-everything-vocabs" [ . ] with-file-writer ; + try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ; + +! : do-tests ( -- ) +! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; : do-tests ( -- ) - run-all-tests keys "../test-all-vocabs" [ . ] with-file-writer ; + run-all-tests + "../test-all-vocabs" utf8 + [ + [ keys . ] + [ test-failures. ] + bi + ] + with-file-writer ; -: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-writer ; +: do-help-lint ( -- ) + "" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ; + +: do-benchmarks ( -- ) + run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ; : do-all ( -- ) - bootstrap-time get "../boot-time" [ . ] with-file-writer - [ do-load ] runtime "../load-time" [ . ] with-file-writer - [ do-tests ] runtime "../test-time" [ . ] with-file-writer + bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer + [ do-load ] runtime "../load-time" utf8 [ . ] with-file-writer + [ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer + do-help-lint do-benchmarks ; MAIN: do-all \ No newline at end of file diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 0e68cdbc0e..82514ca43d 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -3,8 +3,9 @@ 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 + io.encodings.utf8 + combinators.cleave bake calendar calendar.format ; IN: builder.util @@ -14,7 +15,7 @@ IN: builder.util : minutes>ms ( min -- ms ) 60 * 1000 * ; -: file>string ( file -- string ) [ stdio get contents ] with-file-reader ; +: file>string ( file -- string ) utf8 [ stdio get contents ] with-file-reader ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -39,18 +40,18 @@ DEFER: to-strings ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: process* arguments stdin stdout stderr timeout ; +! TUPLE: process* arguments stdin stdout stderr timeout ; -: process* construct-empty ; +! : process* construct-empty ; -: >desc ( process* -- desc ) - H{ } clone - over arguments>> [ +arguments+ swap put-at ] when* - over stdin>> [ +stdin+ swap put-at ] when* - over stdout>> [ +stdout+ swap put-at ] when* - over stderr>> [ +stderr+ swap put-at ] when* - over timeout>> [ +timeout+ swap put-at ] when* - nip ; +! : >desc ( process* -- desc ) +! H{ } clone +! over arguments>> [ +arguments+ swap put-at ] when* +! over stdin>> [ +stdin+ swap put-at ] when* +! over stdout>> [ +stdout+ swap put-at ] when* +! over stderr>> [ +stderr+ swap put-at ] when* +! over timeout>> [ +timeout+ swap put-at ] when* +! nip ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -69,9 +70,9 @@ TUPLE: process* arguments stdin stdout stderr timeout ; : milli-seconds>time ( n -- string ) 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ; -: eval-file ( file -- obj ) file-contents eval ; +: eval-file ( file -- obj ) utf8 file-contents eval ; -: cat ( file -- ) file-contents print ; +: cat ( file -- ) utf8 file-contents print ; : run-or-bail ( desc quot -- ) [ [ try-process ] curry ] @@ -96,6 +97,16 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ; if ; : cat-n ( file n -- ) - [ file-lines ] [ ] bi* + [ utf8 file-lines ] [ ] bi* maybe-tail* - [ print ] each ; \ No newline at end of file + [ print ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: prettyprint + +: to-file ( object file -- ) utf8 [ . ] with-file-writer ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: failsafe ( quot -- ) [ drop ] recover ; diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 7cf6132925..963379896d 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl -opengl.gl opengl.glu shuffle http.client vectors timers +opengl.gl opengl.glu shuffle http.client vectors namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting combinators tools.time system combinators.lib combinators.cleave float-arrays continuations opengl.demo-support multiline diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 2d731dd830..1d90209ed4 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices - math.parser io io.files kernel opengl opengl.gl opengl.glu + math.parser io io.files kernel opengl opengl.gl opengl.glu io.encodings.ascii opengl.capabilities shuffle http.client vectors splitting tools.time system combinators combinators.cleave float-arrays continuations namespaces sequences.lib ; @@ -35,16 +35,16 @@ IN: bunny.model : read-model ( stream -- model ) "Reading model" print flush [ - [ parse-model ] with-file-reader + ascii [ parse-model ] with-file-reader [ 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/cairo/cairo.factor b/extra/cairo/cairo.factor index 4ec9de8c5b..0d3e0c27e6 100644 --- a/extra/cairo/cairo.factor +++ b/extra/cairo/cairo.factor @@ -14,11 +14,14 @@ IN: cairo << "cairo" { { [ win32? ] [ "cairo.dll" ] } - { [ macosx? ] [ "libcairo.dylib" ] } + ! { [ macosx? ] [ "libcairo.dylib" ] } + { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] } { [ unix? ] [ "libcairo.so.2" ] } } cond "cdecl" add-library >> -! cairo_status_t +LIBRARY: cairo + +TYPEDEF: int cairo_status_t C-ENUM: CAIRO_STATUS_SUCCESS CAIRO_STATUS_NO_MEMORY @@ -45,12 +48,12 @@ C-ENUM: CAIRO_STATUS_CLIP_NOT_REPRESENTABLE ; -! cairo_content_t +TYPEDEF: int cairo_content_t : CAIRO_CONTENT_COLOR HEX: 1000 ; : CAIRO_CONTENT_ALPHA HEX: 2000 ; : CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ; -! cairo_operator_t +TYPEDEF: int cairo_operator_t C-ENUM: CAIRO_OPERATOR_CLEAR CAIRO_OPERATOR_SOURCE @@ -68,34 +71,34 @@ C-ENUM: CAIRO_OPERATOR_SATURATE ; -! cairo_line_cap_t +TYPEDEF: int cairo_line_cap_t C-ENUM: CAIRO_LINE_CAP_BUTT CAIRO_LINE_CAP_ROUND CAIRO_LINE_CAP_SQUARE ; -! cair_line_join_t +TYPEDEF: int cair_line_join_t C-ENUM: CAIRO_LINE_JOIN_MITER CAIRO_LINE_JOIN_ROUND CAIRO_LINE_JOIN_BEVEL ; -! cairo_fill_rule_t +TYPEDEF: int cairo_fill_rule_t C-ENUM: CAIRO_FILL_RULE_WINDING CAIRO_FILL_RULE_EVEN_ODD ; -! cairo_font_slant_t +TYPEDEF: int cairo_font_slant_t C-ENUM: CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_SLANT_ITALIC CAIRO_FONT_SLANT_OBLIQUE ; -! cairo_font_weight_t +TYPEDEF: int cairo_font_weight_t C-ENUM: CAIRO_FONT_WEIGHT_NORMAL CAIRO_FONT_WEIGHT_BOLD @@ -159,7 +162,7 @@ C-STRUCT: cairo_matrix_t { "double" "x0" } { "double" "y0" } ; -! cairo_format_t +TYPEDEF: int cairo_format_t C-ENUM: CAIRO_FORMAT_ARGB32 CAIRO_FORMAT_RGB24 @@ -167,7 +170,7 @@ C-ENUM: CAIRO_FORMAT_A1 ; -! cairo_antialias_t +TYPEDEF: int cairo_antialias_t C-ENUM: CAIRO_ANTIALIAS_DEFAULT CAIRO_ANTIALIAS_NONE @@ -175,7 +178,7 @@ C-ENUM: CAIRO_ANTIALIAS_SUBPIXEL ; -! cairo_subpixel_order_t +TYPEDEF: int cairo_subpixel_order_t C-ENUM: CAIRO_SUBPIXEL_ORDER_DEFAULT CAIRO_SUBPIXEL_ORDER_RGB @@ -184,7 +187,7 @@ C-ENUM: CAIRO_SUBPIXEL_ORDER_VBGR ; -! cairo_hint_style_t +TYPEDEF: int cairo_hint_style_t C-ENUM: CAIRO_HINT_STYLE_DEFAULT CAIRO_HINT_STYLE_NONE @@ -193,7 +196,7 @@ C-ENUM: CAIRO_HINT_STYLE_FULL ; -! cairo_hint_metrics_t +TYPEDEF: int cairo_hint_metrics_t C-ENUM: CAIRO_HINT_METRICS_DEFAULT CAIRO_HINT_METRICS_OFF @@ -420,7 +423,11 @@ C-ENUM: : cairo_get_font_matrix ( cairo_t cairo_matrix_t -- ) "void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; - +FUNCTION: uchar* cairo_image_surface_get_data ( cairo_surface_t* surface ) ; +FUNCTION: cairo_format_t cairo_image_surface_get_format ( cairo_surface_t* surface ) ; +FUNCTION: int cairo_image_surface_get_width ( cairo_surface_t* surface ) ; +FUNCTION: int cairo_image_surface_get_height ( cairo_surface_t* surface ) ; +FUNCTION: int cairo_image_surface_get_stride ( cairo_surface_t* surface ) ; ! Cairo pdf @@ -437,3 +444,16 @@ C-ENUM: : cairo_pdf_surface_set_size ( surface width height -- ) "void" "cairo" "cairo_pdf_surface_set_size" [ "void*" "double" "double" ] alien-invoke ; + +! Cairo png + +TYPEDEF: void* cairo_write_func_t +TYPEDEF: void* cairo_read_func_t + +FUNCTION: cairo_surface_t* cairo_image_surface_create_from_png ( char* filename ) ; + +FUNCTION: cairo_surface_t* cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ; + +FUNCTION: cairo_status_t cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ; + +FUNCTION: cairo_status_t cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ; 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..1041c79691 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,16 @@ USING: arrays calendar kernel math sequences tools.test -continuations system io.streams.string ; +continuations system ; +IN: calendar.tests -[ 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 +18,144 @@ continuations system io.streams.string ; [ f ] [ 2001 leap-year? ] unit-test [ f ] [ 2006 leap-year? ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt - 2006 10 10 0 0 1 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 100 seconds +dt - 2006 10 10 0 1 40 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 seconds +dt - 2006 10 9 23 58 20 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 86400 seconds +dt - 2006 10 11 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 1 seconds time+ + 2006 10 10 0 0 1 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 100 seconds time+ + 2006 10 10 0 1 40 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -100 seconds time+ + 2006 10 9 23 58 20 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 86400 seconds time+ + 2006 10 11 0 0 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt - 2006 10 10 0 10 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10.5 minutes +dt - 2006 10 10 0 10 30 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 3/4 minutes +dt - 2006 10 10 0 0 45 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -3/4 minutes +dt - 2006 10 9 23 59 15 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 10 minutes time+ + 2006 10 10 0 10 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 10.5 minutes time+ + 2006 10 10 0 10 30 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 3/4 minutes time+ + 2006 10 10 0 0 45 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -3/4 minutes time+ + 2006 10 9 23 59 15 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt - 2006 10 15 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -10 minutes +dt - 2006 10 9 23 50 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 minutes +dt - 2006 10 9 22 20 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 7200 minutes time+ + 2006 10 15 0 0 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -10 minutes time+ + 2006 10 9 23 50 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -100 minutes time+ + 2006 10 9 22 20 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt - 2006 1 1 1 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 hours +dt - 2006 1 2 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 hours +dt - 2005 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 hours +dt - 2006 1 1 12 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 72 hours +dt - 2006 1 4 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 hours time+ + 2006 1 1 1 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 24 hours time+ + 2006 1 2 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -24 hours time+ + 2005 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 12 hours time+ + 2006 1 1 12 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 72 hours time+ + 2006 1 4 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt - 2006 1 2 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 days +dt - 2005 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 365 days +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -365 days +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 365 days +dt - 2004 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 366 days +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 days time+ + 2006 1 2 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 days time+ + 2005 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 365 days time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -365 days time+ + 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 365 days time+ + 2004 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 366 days time+ + 2005 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt - 2006 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 months +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 months +dt - 2008 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 13 months +dt - 2007 2 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 months +dt - 2006 2 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 months +dt - 2006 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 months +dt - 2005 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -2 months +dt - 2005 11 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -13 months +dt - 2004 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 months +dt - 2004 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 make-timestamp 12 months +dt - 2005 3 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 make-timestamp -12 months +dt - 2003 3 1 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 11 months time+ + 2006 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 12 months time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 24 months time+ + 2008 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 13 months time+ + 2007 2 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 months time+ + 2006 2 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 0 months time+ + 2006 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 months time+ + 2005 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -2 months time+ + 2005 11 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -13 months time+ + 2004 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -24 months time+ + 2004 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 2 29 0 0 0 0 12 months time+ + 2005 3 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 2 29 0 0 0 0 -12 months time+ + 2003 3 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt - 2006 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 years +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 years +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -100 years +dt - 1906 1 1 0 0 0 0 make-timestamp = ] unit-test -! [ t ] [ 2004 2 29 0 0 0 0 make-timestamp -1 years +dt - ! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 0 years time+ + 2006 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 years time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 years time+ + 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -100 years time+ + 1906 1 1 0 0 0 0 = ] unit-test +! [ t ] [ 2004 2 29 0 0 0 0 -1 years time+ +! 2003 2 28 0 0 0 0 = ] unit-test -[ 5 ] [ 2006 7 14 0 0 0 0 make-timestamp day-of-week ] unit-test +[ 5 ] [ 2006 7 14 0 0 0 0 day-of-week ] unit-test -[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 make-timestamp ] 3keep 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 ] 3keep 0 0 0 0 = ] unit-test -[ 1 ] [ 2006 1 1 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 60 ] [ 2004 2 29 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 61 ] [ 2004 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 366 ] [ 2004 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 365 ] [ 2003 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 60 ] [ 2003 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test +[ 1 ] [ 2006 1 1 0 0 0 0 day-of-year ] unit-test +[ 60 ] [ 2004 2 29 0 0 0 0 day-of-year ] unit-test +[ 61 ] [ 2004 3 1 0 0 0 0 day-of-year ] unit-test +[ 366 ] [ 2004 12 31 0 0 0 0 day-of-year ] unit-test +[ 365 ] [ 2003 12 31 0 0 0 0 day-of-year ] unit-test +[ 60 ] [ 2003 3 1 0 0 0 0 day-of-year ] unit-test -[ t ] [ 2004 12 31 0 0 0 0 make-timestamp dup = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 10 seconds 5 years +dts +dt - 2009 1 1 0 0 10 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp -10 seconds -5 years +dts +dt - 1998 12 31 23 59 50 0 make-timestamp = ] unit-test +[ t ] [ 2004 12 31 0 0 0 0 dup = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 10 seconds 5 years time+ time+ + 2009 1 1 0 0 10 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 -10 seconds -5 years time+ time+ + 1998 12 31 23 59 50 0 = ] unit-test -[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone - 2004 1 1 11 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 5 0 0 -11 make-timestamp 0 convert-timezone - 2004 1 1 16 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 23 0 0 9.5 make-timestamp 0 convert-timezone - 2004 1 1 13 30 0 0 make-timestamp = ] unit-test +[ t ] [ 2004 1 1 23 0 0 12 0 convert-timezone + 2004 1 1 11 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 5 0 0 -11 0 convert-timezone + 2004 1 1 16 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 23 0 0 9+1/2 0 convert-timezone + 2004 1 1 13 30 0 0 = ] unit-test -[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp - 2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test +[ 0 ] [ 2004 1 1 13 30 0 0 + 2004 1 1 12 30 0 -1 <=> ] unit-test -[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp - 2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test +[ 1 ] [ 2004 1 1 13 30 0 0 + 2004 1 1 12 30 0 0 <=> ] unit-test -[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp - 2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test +[ -1 ] [ 2004 1 1 12 30 0 0 + 2004 1 1 13 30 0 0 <=> ] unit-test -[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp - 2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test +[ 1 ] [ 2005 1 1 12 30 0 0 + 2004 1 1 13 30 0 0 <=> ] unit-test -[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test -[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test -[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test -[ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test +[ t ] [ now timestamp>millis millis - 1000 < ] unit-test +[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test +[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test +[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test -[ 0 ] [ - "Z" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +: checktime+ now dup clone [ rot time+ drop ] keep = ; -[ 1 ] [ - "+01" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 seconds checktime+ ] unit-test -[ -1 ] [ - "-01" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 minutes checktime+ ] unit-test -[ -1-1/2 ] [ - "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 hours checktime+ ] unit-test -[ 1+1/2 ] [ - "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 days checktime+ ] unit-test + +[ t ] [ 5 weeks checktime+ ] unit-test + +[ t ] [ 5 months checktime+ ] unit-test + +[ t ] [ 5 years checktime+ ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 5b89d6e8c5..2b80a8dce6 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -1,20 +1,21 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays hashtables io io.streams.string kernel math -math.vectors math.functions math.parser namespaces sequences -strings tuples system debugger combinators vocabs.loader -calendar.backend structs alien.c-types math.vectors -math.ranges shuffle ; +USING: arrays kernel math math.functions namespaces sequences +strings tuples system vocabs.loader calendar.backend threads +new-slots accessors combinators ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; C: timestamp -TUPLE: dt year month day hour minute second ; +: ( year month day -- timestamp ) + 0 0 0 gmt-offset ; -C:
dt +TUPLE: duration year month day hour minute second ; + +C: duration : month-names { @@ -36,9 +37,14 @@ C:
dt : day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ; : day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ; -: average-month ( -- x ) - #! length of average month in days - 30.41666666666667 ; +: average-month 30+5/12 ; inline +: months-per-year 12 ; inline +: days-per-year 3652425/10000 ; inline +: hours-per-year 876582/100 ; inline +: minutes-per-year 5259492/10 ; inline +: seconds-per-year 31556952 ; inline + + + : julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 @@ -74,38 +82,31 @@ SYMBOL: m e get 153 m get * 2 + 5 /i - 1+ ] with-scope ; -: set-date ( year month day timestamp -- ) - [ set-timestamp-day ] keep - [ set-timestamp-month ] keep - set-timestamp-year ; - -: set-time ( hour minute second timestamp -- ) - [ set-timestamp-second ] keep - [ set-timestamp-minute ] keep - set-timestamp-hour ; - : >date< ( timestamp -- year month day ) - [ timestamp-year ] keep - [ timestamp-month ] keep - timestamp-day ; + { year>> month>> day>> } get-slots ; : >time< ( timestamp -- hour minute second ) - [ timestamp-hour ] keep - [ timestamp-minute ] keep - timestamp-second ; + { hour>> minute>> second>> } get-slots ; -: zero-dt ( --
) 0 0 0 0 0 0
; -: years ( n -- dt ) zero-dt [ set-dt-year ] keep ; -: months ( n -- dt ) zero-dt [ set-dt-month ] keep ; -: days ( n -- dt ) zero-dt [ set-dt-day ] keep ; +: instant ( -- dt ) 0 0 0 0 0 0 ; +: years ( n -- dt ) instant swap >>year ; +: months ( n -- dt ) instant swap >>month ; +: days ( n -- dt ) instant swap >>day ; : weeks ( n -- dt ) 7 * days ; -: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ; -: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ; -: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ; -: milliseconds ( n -- dt ) 1000 /f seconds ; +: hours ( n -- dt ) instant swap >>hour ; +: minutes ( n -- dt ) instant swap >>minute ; +: seconds ( n -- dt ) instant swap >>second ; +: milliseconds ( n -- dt ) 1000 / seconds ; -: julian-day-number>timestamp ( n -- timestamp ) - julian-day-number>date 0 0 0 0 ; +GENERIC: leap-year? ( obj -- ? ) + +M: integer leap-year? ( year -- ? ) + dup 100 mod zero? 400 4 ? mod zero? ; + +M: timestamp leap-year? ( timestamp -- ? ) + year>> leap-year? ; + +integer ] 2keep rem ; + [ / floor >integer ] 2keep rem ; : float>whole-part ( float -- int float ) [ floor >integer ] keep over - ; -GENERIC: leap-year? ( obj -- ? ) -M: integer leap-year? ( year -- ? ) - dup 100 mod zero? 400 4 ? mod zero? ; - -M: timestamp leap-year? ( timestamp -- ? ) - timestamp-year leap-year? ; - : adjust-leap-year ( timestamp -- timestamp ) - dup >date< 29 = swap 2 = and swap leap-year? not and [ - dup >r timestamp-year 3 1 r> [ set-date ] keep - ] when ; + dup day>> 29 = over month>> 2 = pick leap-year? not and and + [ 3 >>month 1 >>day ] when ; + +: unless-zero >r dup zero? [ drop ] r> if ; inline M: integer +year ( timestamp n -- timestamp ) - over timestamp-year + swap [ set-timestamp-year ] keep - adjust-leap-year ; + [ [ + ] curry change-year adjust-leap-year ] unless-zero ; + M: real +year ( timestamp n -- timestamp ) - float>whole-part rot swap 365.2425 * +day swap +year ; + [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ; + +: months/years ( n -- months years ) + 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline M: integer +month ( timestamp n -- timestamp ) - over timestamp-month + 12 /rem - dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month - +year ; + [ over month>> + months/years >r >>month r> +year ] unless-zero ; + M: real +month ( timestamp n -- timestamp ) - float>whole-part rot swap average-month * +day swap +month ; + [ float>whole-part swapd average-month * +day swap +month ] unless-zero ; M: integer +day ( timestamp n -- timestamp ) - swap [ - >date< julian-day-number + julian-day-number>timestamp - ] keep swap >r >time< r> [ set-time ] keep ; + [ + over >date< julian-day-number + julian-day-number>date + >r >r >>year r> >>month r> >>day + ] unless-zero ; + M: real +day ( timestamp n -- timestamp ) - float>whole-part rot swap 24 * +hour swap +day ; + [ float>whole-part swapd 24 * +hour swap +day ] unless-zero ; + +: hours/days ( n -- hours days ) + 24 /rem swap ; M: integer +hour ( timestamp n -- timestamp ) - over timestamp-hour + 24 /rem pick set-timestamp-hour - +day ; + [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ; + M: real +hour ( timestamp n -- timestamp ) - float>whole-part rot swap 60 * +minute swap +hour ; + float>whole-part swapd 60 * +minute swap +hour ; + +: minutes/hours ( n -- minutes hours ) + 60 /rem swap ; M: integer +minute ( timestamp n -- timestamp ) - over timestamp-minute + 60 /rem pick - set-timestamp-minute +hour ; + [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ; + M: real +minute ( timestamp n -- timestamp ) - float>whole-part rot swap 60 * +second swap +minute ; + [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ; + +: seconds/minutes ( n -- seconds minutes ) + 60 /rem swap >integer ; M: number +second ( timestamp n -- timestamp ) - over timestamp-second + 60 /rem >r >integer r> - pick set-timestamp-second +minute ; + [ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ; -: +dt ( timestamp dt -- timestamp ) - dupd - [ dt-second +second ] keep - [ dt-minute +minute ] keep - [ dt-hour +hour ] keep - [ dt-day +day ] keep - [ dt-month +month ] keep - dt-year +year - swap timestamp-gmt-offset over set-timestamp-gmt-offset ; +: (time+) + [ second>> +second ] keep + [ minute>> +minute ] keep + [ hour>> +hour ] keep + [ day>> +day ] keep + [ month>> +month ] keep + [ year>> +year ] keep ; inline -: make-timestamp ( year month day hour minute second gmt-offset -- timestamp ) - [ 0 seconds +dt ] keep - [ = [ "invalid timestamp" throw ] unless ] keep ; +: +slots [ 2apply + ] curry 2keep ; inline -: make-date ( year month day -- timestamp ) - 0 0 0 gmt-offset make-timestamp ; +PRIVATE> -: array>dt ( vec -- dt ) { dt f } swap append >tuple ; -: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ; +GENERIC# time+ 1 ( time dt -- time ) + +M: timestamp time+ + >r clone r> (time+) drop ; + +M: duration time+ + dup timestamp? [ + swap time+ + ] [ + [ year>> ] +slots + [ month>> ] +slots + [ day>> ] +slots + [ hour>> ] +slots + [ minute>> ] +slots + [ second>> ] +slots + 2drop + ] if ; : dt>years ( dt -- x ) #! Uses average month/year length since dt loses calendar #! data - tuple-slots - { 1 12 365.2425 8765.82 525949.2 31556952.0 } - v/ sum ; + 0 swap + [ year>> + ] keep + [ month>> months-per-year / + ] keep + [ day>> days-per-year / + ] keep + [ hour>> hours-per-year / + ] keep + [ minute>> minutes-per-year / + ] keep + second>> seconds-per-year / + ; -: dt>months ( dt -- x ) dt>years 12 * ; -: dt>days ( dt -- x ) dt>years 365.2425 * ; -: dt>hours ( dt -- x ) dt>years 8765.82 * ; -: dt>minutes ( dt -- x ) dt>years 525949.2 * ; -: dt>seconds ( dt -- x ) dt>years 31556952 * ; -: dt>milliseconds ( dt -- x ) dt>years 31556952000 * ; +M: duration <=> [ dt>years ] compare ; + +: dt>months ( dt -- x ) dt>years months-per-year * ; +: dt>days ( dt -- x ) dt>years days-per-year * ; +: dt>hours ( dt -- x ) dt>years hours-per-year * ; +: dt>minutes ( dt -- x ) dt>years minutes-per-year * ; +: dt>seconds ( dt -- x ) dt>years seconds-per-year * ; +: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ; : convert-timezone ( timestamp n -- timestamp ) - [ over timestamp-gmt-offset - hours +dt ] keep - over set-timestamp-gmt-offset ; + over gmt-offset>> over = [ drop ] [ + [ over gmt-offset>> - hours time+ ] keep >>gmt-offset + ] if ; : >local-time ( timestamp -- timestamp ) gmt-offset convert-timezone ; @@ -216,39 +240,54 @@ M: number +second ( timestamp n -- timestamp ) M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; -: timestamp- ( timestamp timestamp -- seconds ) - #! Exact calendar-time difference +: (time-) ( timestamp timestamp -- n ) [ >gmt ] 2apply [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; +GENERIC: time- ( time1 time2 -- time ) + +M: timestamp time- + #! Exact calendar-time difference + (time-) seconds ; + +: before ( dt -- -dt ) + [ year>> neg ] keep + [ month>> neg ] keep + [ day>> neg ] keep + [ hour>> neg ] keep + [ minute>> neg ] keep + second>> neg + ; + +M: duration time- + before time+ ; + +: 0 0 0 0 0 0 0 ; + +: valid-timestamp? ( timestamp -- ? ) + clone 0 >>gmt-offset + dup time- time+ = ; + : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; + 1970 1 1 0 0 0 0 ; foldable -: unix-time>timestamp ( n -- timestamp ) - >r unix-1970 r> seconds +dt ; - -: timestamp>unix-time ( timestamp -- n ) - unix-1970 timestamp- >integer ; - -: timestamp>timeval ( timestamp -- timeval ) - timestamp>unix-time 1000 * make-timeval ; - -: timeval>timestamp ( timeval -- timestamp ) - [ timeval-sec ] keep - timeval-usec 1000000 / + unix-time>timestamp ; +: millis>timestamp ( n -- timestamp ) + >r unix-1970 r> milliseconds time+ ; +: timestamp>millis ( timestamp -- n ) + unix-1970 (time-) 1000 * >integer ; : gmt ( -- timestamp ) #! GMT time, right now - unix-1970 millis 1000 /f seconds +dt ; + unix-1970 millis milliseconds time+ ; : now ( -- timestamp ) gmt >local-time ; -: before ( dt -- -dt ) tuple-slots vneg array>dt ; -: from-now ( dt -- timestamp ) now swap +dt ; -: ago ( dt -- timestamp ) before from-now ; -: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; +: from-now ( dt -- timestamp ) now swap time+ ; +: ago ( dt -- timestamp ) now swap time- ; + +: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline : zeller-congruence ( year month day -- n ) #! Zeller Congruence @@ -262,7 +301,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) GENERIC: days-in-year ( obj -- n ) M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; -M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ; +M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; GENERIC: days-in-month ( obj -- n ) @@ -274,7 +313,7 @@ M: array days-in-month ( obj -- n ) ] if ; M: timestamp days-in-month ( timestamp -- n ) - { timestamp-year timestamp-month } get-slots 2array days-in-month ; + >date< drop 2array days-in-month ; GENERIC: day-of-week ( obj -- n ) @@ -291,156 +330,20 @@ M: array day-of-year ( array -- n ) 3dup day-counts rot head-slice sum + swap leap-year? [ -roll - pick 3 1 make-date >r make-date r> - <=> 0 >= [ 1+ ] when + pick 3 1 >r r> + after=? [ 1+ ] when ] [ - 3nip + >r 3drop r> ] if ; M: timestamp day-of-year ( timestamp -- n ) - { timestamp-year timestamp-month timestamp-day } get-slots - 3array day-of-year ; - -GENERIC: day. ( obj -- ) - -M: integer day. ( n -- ) - number>string dup length 2 < [ bl ] when write ; - -M: timestamp day. ( timestamp -- ) - timestamp-day day. ; - -GENERIC: month. ( obj -- ) - -M: array month. ( pair -- ) - first2 - [ month-names nth write bl number>string print ] 2keep - [ 1 zeller-congruence ] 2keep - 2array days-in-month day-abbreviations2 " " join print - over " " concat write - [ - [ 1+ day. ] keep - 1+ + 7 mod zero? [ nl ] [ bl ] if - ] with each nl ; - -M: timestamp month. ( timestamp -- ) - { timestamp-year timestamp-month } get-slots 2array month. ; - -GENERIC: year. ( obj -- ) - -M: integer year. ( n -- ) - 12 [ 1+ 2array month. nl ] with each ; - -M: timestamp year. ( timestamp -- ) - timestamp-year year. ; - -: pad-00 number>string 2 CHAR: 0 pad-left ; - -: write-00 pad-00 write ; - -: (timestamp>string) ( timestamp -- ) - dup day-of-week day-abbreviations3 nth write ", " write - dup timestamp-day number>string write bl - dup timestamp-month month-abbreviations nth write bl - dup timestamp-year number>string write bl - dup timestamp-hour write-00 ":" write - dup timestamp-minute write-00 ":" write - timestamp-second >fixnum write-00 ; - -: timestamp>string ( timestamp -- str ) - [ (timestamp>string) ] with-string-writer ; - -: (write-gmt-offset) ( ratio -- ) - 1 /mod swap write-00 60 * write-00 ; - -: write-gmt-offset ( gmt-offset -- ) - { - { [ dup zero? ] [ drop "GMT" write ] } - { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } - { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } - } cond ; - -: timestamp>rfc822-string ( timestamp -- str ) - #! RFC822 timestamp format - #! Example: Tue, 15 Nov 1994 08:12:31 +0200 - [ - dup (timestamp>string) - " " write - timestamp-gmt-offset write-gmt-offset - ] with-string-writer ; - -: timestamp>http-string ( timestamp -- str ) - #! http timestamp format - #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt timestamp>rfc822-string ; - -: write-rfc3339-gmt-offset ( n -- ) - dup zero? [ drop "Z" write ] [ - dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if - 60 * 60 /mod swap write-00 CHAR: : write1 write-00 - ] if ; - -: (timestamp>rfc3339) ( timestamp -- ) - dup timestamp-year number>string write CHAR: - write1 - dup timestamp-month write-00 CHAR: - write1 - dup timestamp-day write-00 CHAR: T write1 - dup timestamp-hour write-00 CHAR: : write1 - dup timestamp-minute write-00 CHAR: : write1 - dup timestamp-second >fixnum write-00 - timestamp-gmt-offset write-rfc3339-gmt-offset ; - -: timestamp>rfc3339 ( timestamp -- str ) - [ (timestamp>rfc3339) ] with-string-writer ; - -: expect ( str -- ) - read1 swap member? [ "Parse error" throw ] unless ; - -: read-00 2 read string>number ; - -: read-0000 4 read string>number ; - -: read-rfc3339-gmt-offset ( -- n ) - read1 dup CHAR: Z = [ drop 0 ] [ - { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case - read-00 - read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case - 60 / + * - ] if ; - -: (rfc3339>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day - "Tt" expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second - read-rfc3339-gmt-offset ! timezone - ; - -: rfc3339>timestamp ( str -- timestamp ) - [ (rfc3339>timestamp) ] with-string-reader ; - -: file-time-string ( timestamp -- string ) - [ - [ timestamp-month month-abbreviations nth write ] keep bl - [ timestamp-day number>string 2 32 pad-left write ] keep bl - dup now [ timestamp-year ] 2apply = [ - [ timestamp-hour write-00 ] keep ":" write - timestamp-minute write-00 - ] [ - timestamp-year number>string 5 32 pad-left write - ] if - ] with-string-writer ; + >date< 3array day-of-year ; : day-offset ( timestamp m -- timestamp n ) over day-of-week - ; inline : day-this-week ( timestamp n -- timestamp ) - day-offset days +dt ; + day-offset days time+ ; : sunday ( timestamp -- timestamp ) 0 day-this-week ; : monday ( timestamp -- timestamp ) 1 day-this-week ; @@ -451,21 +354,26 @@ M: timestamp year. ( timestamp -- ) : saturday ( timestamp -- timestamp ) 6 day-this-week ; : beginning-of-day ( timestamp -- new-timestamp ) - clone dup >r 0 0 0 r> - { set-timestamp-hour set-timestamp-minute set-timestamp-second } - set-slots ; inline + clone + 0 >>hour + 0 >>minute + 0 >>second ; inline : beginning-of-month ( timestamp -- new-timestamp ) - beginning-of-day 1 over set-timestamp-day ; + beginning-of-day 1 >>day ; : beginning-of-week ( timestamp -- new-timestamp ) beginning-of-day sunday ; : beginning-of-year ( timestamp -- new-timestamp ) - beginning-of-month 1 over set-timestamp-month ; + beginning-of-month 1 >>month ; -: seconds-since-midnight ( timestamp -- x ) - dup beginning-of-day timestamp- ; +: time-since-midnight ( timestamp -- duration ) + dup beginning-of-day time- ; + +M: timestamp sleep-until timestamp>millis sleep-until ; + +M: duration sleep from-now sleep-until ; { { [ unix? ] [ "calendar.unix" ] } diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor new file mode 100755 index 0000000000..eb32ce5b43 --- /dev/null +++ b/extra/calendar/format/format-tests.factor @@ -0,0 +1,22 @@ +IN: calendar.format.tests +USING: calendar.format tools.test io.streams.string ; + +[ 0 ] [ + "Z" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ 1 ] [ + "+01" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ -1 ] [ + "-01" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ -1-1/2 ] [ + "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ 1+1/2 ] [ + "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor new file mode 100755 index 0000000000..89e09e0d0c --- /dev/null +++ b/extra/calendar/format/format.factor @@ -0,0 +1,186 @@ +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 ; + +: pad-0000 number>string 4 CHAR: 0 pad-left ; + +: write-00 pad-00 write ; + +: write-0000 pad-0000 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 ; + +: read-ymd ( -- y m d ) + read-0000 "-" expect read-00 "-" expect read-00 ; + +: read-hms ( -- h m s ) + read-00 ":" expect read-00 ":" expect read-00 ; + +: (rfc3339>timestamp) ( -- timestamp ) + read-ymd + "Tt" expect + read-hms + read-rfc3339-gmt-offset ! timezone + ; + +: rfc3339>timestamp ( str -- timestamp ) + [ (rfc3339>timestamp) ] with-string-reader ; + +: (ymdhms>timestamp) ( -- timestamp ) + read-ymd " " expect read-hms 0 ; + +: ymdhms>timestamp ( str -- timestamp ) + [ (ymdhms>timestamp) ] with-string-reader ; + +: (hms>timestamp) ( -- timestamp ) + f f f read-hms f ; + +: hms>timestamp ( str -- timestamp ) + [ (hms>timestamp) ] with-string-reader ; + +: (ymd>timestamp) ( -- timestamp ) + read-ymd f f f f ; + +: ymd>timestamp ( str -- timestamp ) + [ (ymd>timestamp) ] with-string-reader ; + +: (timestamp>ymd) ( timestamp -- ) + dup timestamp-year write-0000 + "-" write + dup timestamp-month write-00 + "-" write + timestamp-day write-00 ; + +: timestamp>ymd ( timestamp -- str ) + [ (timestamp>ymd) ] with-string-writer ; + +: (timestamp>hms) + dup timestamp-hour write-00 + ":" write + dup timestamp-minute write-00 + ":" write + timestamp-second >integer write-00 ; + +: timestamp>hms ( timestamp -- str ) + [ (timestamp>hms) ] with-string-writer ; + +: timestamp>ymdhms ( timestamp -- str ) + >gmt + [ + dup (timestamp>ymd) + " " write + (timestamp>hms) + ] with-string-writer ; + +: 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/channels.factor b/extra/channels/channels.factor index 01f810b8e3..8fe36ab454 100755 --- a/extra/channels/channels.factor +++ b/extra/channels/channels.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Channels - based on ideas from newsqueak -USING: kernel sequences sequences.lib threads continuations random math ; +USING: kernel sequences sequences.lib threads continuations +random math ; IN: channels TUPLE: channel receivers senders ; @@ -16,7 +17,8 @@ GENERIC: from ( channel -- value ) @@ -36,5 +38,5 @@ M: channel to ( value channel -- ) M: channel from ( channel -- value ) [ notify channel-senders - dup empty? [ stop ] [ (from) ] if - ] curry callcc1 ; + dup empty? [ drop ] [ (from) ] if + ] curry "channel receive" suspend ; diff --git a/extra/channels/examples/examples.factor b/extra/channels/examples/examples.factor index 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/channels/remote/remote.factor b/extra/channels/remote/remote.factor index 437a668a73..2d8d003b8d 100755 --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -29,14 +29,14 @@ MATCH-VARS: ?from ?tag ?id ?value ; SYMBOL: no-channel : channel-process ( -- ) - receive [ + [ { { { to ?id ?value } [ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] } { { from ?id } [ ?id get-channel [ from ] [ no-channel ] if* ] } } match-cond - ] keep reply-synchronous ; + ] handle-synchronous ; PRIVATE> 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..5965c74af8 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 ) @@ -18,5 +19,5 @@ M: hashtable >plist >plist 1array "plist" build-tag* dup { { "version" "1.0" } } update ; -: print-plist ( obj -- ) - build-plist build-xml print-xml ; +: plist>string ( obj -- string ) + build-plist build-xml xml>string ; diff --git a/extra/combinators/cleave/cleave-docs.factor b/extra/combinators/cleave/cleave-docs.factor new file mode 100644 index 0000000000..0c491b88b1 --- /dev/null +++ b/extra/combinators/cleave/cleave-docs.factor @@ -0,0 +1,82 @@ + +USING: kernel quotations help.syntax help.markup ; + +IN: combinators.cleave + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ARTICLE: "cleave-combinators" "Cleave Combinators" + +{ $subsection bi } +{ $subsection tri } + +{ $notes + "From the Merriam-Webster Dictionary: " + $nl + { $strong "cleave" } + { $list + { $emphasis "To divide by or as if by a cutting blow" } + { $emphasis "To separate into distinct parts and especially into " + "groups having divergent views" } } + $nl + "The Joy programming language has a " { $emphasis "cleave" } " combinator." } + +; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +HELP: bi + + { $values { "x" object } + { "p" quotation } + { "q" quotation } + + { "p(x)" "p applied to x" } + { "q(x)" "q applied to x" } } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +HELP: tri + + { $values { "x" object } + { "p" quotation } + { "q" quotation } + { "r" quotation } + + { "p(x)" "p applied to x" } + { "q(x)" "q applied to x" } + { "r(x)" "r applied to x" } } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ARTICLE: "spread-combinators" "Spread Combinators" + +{ $subsection bi* } +{ $subsection tri* } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +HELP: bi* + + { $values { "x" object } + { "y" object } + { "p" quotation } + { "q" quotation } + + { "p(x)" "p applied to x" } + { "q(y)" "q applied to y" } } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +HELP: tri* + + { $values { "x" object } + { "y" object } + { "z" object } + { "p" quotation } + { "q" quotation } + { "r" quotation } + + { "p(x)" "p applied to x" } + { "q(y)" "q applied to y" } + { "r(z)" "r applied to z" } } ; diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index e1e3585813..5359512610 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -1,5 +1,5 @@ -USING: kernel ; +USING: kernel sequences macros ; IN: combinators.cleave @@ -7,10 +7,8 @@ IN: combinators.cleave ! The cleaver family ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: bi ( obj quot quot -- val val ) >r keep r> call ; inline - -: tri ( obj quot quot quot -- val val val ) - >r pick >r bi r> r> call ; inline +: bi ( x p q -- p(x) q(x) ) >r keep r> call ; inline +: tri ( x p q r -- p(x) q(x) r(x) ) >r pick >r bi r> r> call ; inline : tetra ( obj quot quot quot quot -- val val val val ) >r >r pick >r bi r> r> r> bi ; inline @@ -19,14 +17,41 @@ IN: combinators.cleave : 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! General cleave + +MACRO: cleave ( seq -- ) + dup + [ drop [ dup ] ] map concat + swap + dup + [ drop [ >r ] ] map concat + swap + [ [ r> ] append ] map concat + 3append + [ drop ] + append ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! The spread family ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: bi* ( obj obj quot quot -- val val ) >r swap slip r> call ; inline +: bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline -: tri* ( obj obj obj quot quot quot -- val val val ) +: tri* ( x y z p q r -- p(x) q(y) r(z) ) >r rot >r bi* r> r> call ; inline : tetra* ( obj obj obj obj quot quot quot quot -- val val val val ) >r roll >r tri* r> r> call ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! General spread + +MACRO: spread ( seq -- ) + dup + [ drop [ >r ] ] map concat + swap + [ [ r> ] swap append ] map concat + append ; diff --git a/extra/combinators/lib/lib-docs.factor b/extra/combinators/lib/lib-docs.factor index d850243bd0..c88ce8d9f9 100755 --- a/extra/combinators/lib/lib-docs.factor +++ b/extra/combinators/lib/lib-docs.factor @@ -7,7 +7,7 @@ HELP: generate { $description "Loop until the generator quotation generates an object that satisfies predicate quotation." } { $unchecked-example "! Generate a random 20-bit prime number congruent to 3 (mod 4)" - "USE: math.miller-rabin" + "USING: combinators.lib math math.miller-rabin prettyprint ;" "[ 20 random-prime ] [ 4 mod 3 = ] generate ." "526367" } ; @@ -20,8 +20,8 @@ HELP: ndip "stack. The quotation can consume and produce any number of items." } { $examples - { $example "USE: combinators.lib" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } - { $example "USE: combinators.lib" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } + { $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } + { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } } { $see-also dip dipd } ; @@ -32,7 +32,7 @@ HELP: nslip "removed from the stack, the quotation called, and the items restored." } { $examples - { $example "USE: combinators.lib" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: combinators.lib prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } } { $see-also slip nkeep } ; @@ -43,7 +43,7 @@ HELP: nkeep "saved, the quotation called, and the items restored." } { $examples - { $example "USE: combinators.lib" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } } { $see-also keep nslip } ; 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 f73a99c1a2..99386272f3 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 @@ -174,3 +175,6 @@ MACRO: multikeep ( word out-indexes -- ... ) % r> [ drop \ r> , ] each ] [ ] make ; + +: 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 ed59034835..0f18fcf431 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -1,6 +1,6 @@ -IN: temporary +IN: concurrency.combinators.tests USING: concurrency.combinators tools.test random kernel math -concurrency.messaging threads sequences ; +concurrency.mailboxes threads sequences ; [ [ drop ] parallel-each ] must-infer [ [ ] parallel-map ] must-infer @@ -11,7 +11,7 @@ concurrency.messaging 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 4662f1b369..b10aded671 100755 --- a/extra/concurrency/conditions/conditions.factor +++ b/extra/concurrency/conditions/conditions.factor @@ -1,13 +1,27 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: dlists threads kernel arrays sequences ; +USING: dlists dlists.private threads kernel arrays sequences +alarms ; IN: concurrency.conditions : notify-1 ( dlist -- ) - dup dlist-empty? [ drop ] [ pop-back second resume ] if ; + dup dlist-empty? [ drop ] [ pop-back resume-now ] if ; : notify-all ( dlist -- ) - [ second resume ] dlist-slurp yield ; + [ resume-now ] dlist-slurp ; + +: queue-timeout ( queue timeout -- alarm ) + #! Add an alarm which removes the current thread from the + #! queue, and resumes it, passing it a value of t. + >r self over push-front* [ + tuck delete-node + dlist-node-obj t swap resume-with + ] 2curry r> later ; : wait ( queue timeout status -- ) - >r [ 2array swap push-front ] r> suspend 3drop ; inline + over [ + >r queue-timeout [ drop ] r> suspend + [ "Timeout" throw ] [ cancel-alarm ] if + ] [ + >r drop [ push-front ] curry r> suspend drop + ] if ; diff --git a/extra/concurrency/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/count-downs/count-downs.factor b/extra/concurrency/count-downs/count-downs.factor index 61dd366c77..b1fa137bc4 100755 --- a/extra/concurrency/count-downs/count-downs.factor +++ b/extra/concurrency/count-downs/count-downs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: dlists kernel math concurrency.promises -concurrency.messaging ; +concurrency.mailboxes ; IN: concurrency.count-downs ! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html diff --git a/extra/concurrency/distributed/distributed-docs.factor b/extra/concurrency/distributed/distributed-docs.factor index 4fae6ddbcc..b3f3b633cd 100755 --- a/extra/concurrency/distributed/distributed-docs.factor +++ b/extra/concurrency/distributed/distributed-docs.factor @@ -2,9 +2,7 @@ USING: help.markup help.syntax concurrency.messaging threads ; IN: concurrency.distributed HELP: local-node -{ $values { "addrspec" "an address specifier" } -} -{ $description "Return the node the current thread is running on." } ; +{ $var-description "A variable containing the node the current thread is running on." } ; HELP: start-node { $values { "port" "a port number between 0 and 65535" } } diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor new file mode 100755 index 0000000000..0941eb4251 --- /dev/null +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -0,0 +1,31 @@ +IN: concurrency.distributed.tests +USING: tools.test concurrency.distributed kernel io.files +arrays io.sockets system combinators threads math sequences +concurrency.messaging ; + +: test-node + { + { [ unix? ] [ "distributed-concurrency-test" temp-file ] } + { [ windows? ] [ "127.0.0.1" 1238 ] } + } cond ; + +[ ] [ test-node dup 1array swap (start-node) ] unit-test + +[ ] [ yield ] unit-test + +[ ] [ + [ + receive first2 >r 3 + r> send + "thread-a" unregister-process + ] "Thread A" spawn + "thread-a" swap register-process +] unit-test + +[ 8 ] [ + 5 self 2array + "thread-a" test-node send + + receive +] unit-test + +[ ] [ test-node stop-node ] unit-test diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index 2c54a872f7..c0787a96a2 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -2,35 +2,46 @@ ! See http://factorcode.org/license.txt for BSD license. USING: serialize sequences concurrency.messaging threads io io.server qualified arrays -namespaces kernel ; +namespaces kernel io.encodings.binary combinators.cleave +new-slots accessors ; QUALIFIED: io.sockets IN: concurrency.distributed -SYMBOL: local-node ( -- addrspec ) +SYMBOL: local-node : handle-node-client ( -- ) - deserialize first2 get-process send ; + deserialize + [ first2 get-process send ] + [ stop-server ] if* ; : (start-node) ( addrspecs addrspec -- ) + local-node set-global [ - local-node set-global "concurrency.distributed" + binary [ handle-node-client ] with-server - ] 2curry f spawn drop ; + ] curry "Distributed concurrency server" spawn drop ; : start-node ( port -- ) - dup internet-server io.sockets:host-name - rot io.sockets: (start-node) ; + [ internet-server ] + [ io.sockets:host-name swap io.sockets: ] bi + (start-node) ; TUPLE: remote-process id node ; C: remote-process +: send-remote-message ( message node -- ) + binary io.sockets: + [ serialize ] with-stream ; + M: remote-process send ( message thread -- ) - { remote-process-id remote-process-node } get-slots - io.sockets: [ 2array serialize ] with-stream ; + [ id>> 2array ] [ node>> ] bi + send-remote-message ; M: thread (serialize) ( obj -- ) - thread-id local-node get-global - + thread-id local-node get-global (serialize) ; + +: stop-node ( node -- ) + f swap send-remote-message ; 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/exchangers/exchangers.factor b/extra/concurrency/exchangers/exchangers.factor index e7c9be76d2..0a631d1c7b 100755 --- a/extra/concurrency/exchangers/exchangers.factor +++ b/extra/concurrency/exchangers/exchangers.factor @@ -17,5 +17,5 @@ TUPLE: exchanger thread object ; >r exchanger-thread box> resume-with r> ] [ [ exchanger-object >box ] keep - [ exchanger-thread >box ] curry "Exchange wait" suspend + [ exchanger-thread >box ] curry "exchange" suspend ] if ; 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/futures/futures.factor b/extra/concurrency/futures/futures.factor index 0a05d2d78e..85f1ba44a0 100755 --- a/extra/concurrency/futures/futures.factor +++ b/extra/concurrency/futures/futures.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.promises concurrency.messaging kernel arrays +USING: concurrency.promises concurrency.mailboxes kernel arrays continuations ; IN: concurrency.futures @@ -11,7 +11,7 @@ IN: concurrency.futures ] keep ; inline : ?future-timeout ( future timeout -- value ) - ?promise-timeout ; + ?promise-timeout ?linked ; : ?future ( future -- value ) - ?promise ; + ?promise ?linked ; diff --git a/extra/concurrency/locks/locks-docs.factor b/extra/concurrency/locks/locks-docs.factor index 86db5914c9..a3cf2fc782 100755 --- a/extra/concurrency/locks/locks-docs.factor +++ b/extra/concurrency/locks/locks-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax sequences kernel quotations ; +USING: help.markup help.syntax sequences kernel quotations +calendar ; IN: concurrency.locks HELP: lock @@ -12,11 +13,15 @@ HELP: { $values { "lock" lock } } { $description "Creates a reentrant lock." } ; -HELP: with-lock -{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +HELP: with-lock-timeout +{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } { $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } { $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; +HELP: with-lock +{ $values { "lock" lock } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } ; + ARTICLE: "concurrency.locks.mutex" "Mutual-exclusion locks" "A mutual-exclusion lock ensures that only one thread executes with the lock held at a time. They are used to protect critical sections so that certain operations appear to be atomic to other threads." $nl @@ -24,21 +29,30 @@ $nl { $subsection lock } { $subsection } { $subsection } -{ $subsection with-lock } ; +{ $subsection with-lock } +{ $subsection with-lock-timeout } ; HELP: rw-lock { $class-description "The class of reader/writer locks." } ; -HELP: with-read-lock -{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +HELP: with-read-lock-timeout +{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } { $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } { $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; -HELP: with-write-lock -{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +HELP: with-read-lock +{ $values { "lock" lock } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } ; + +HELP: with-write-lock-timeout +{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } { $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } { $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; +HELP: with-write-lock +{ $values { "lock" lock } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } ; + ARTICLE: "concurrency.locks.rw" "Read-write locks" "A read-write lock encapsulates a common pattern in the implementation of concurrent data structures, where one wishes to ensure that a thread is able to see a consistent view of the structure for a period of time, during which no other thread modifies the structure." $nl @@ -46,11 +60,14 @@ $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 } -{ $subsection with-write-lock } ; +{ $subsection with-write-lock } +"Versions of the above that take a timeout duration:" +{ $subsection with-read-lock-timeout } +{ $subsection with-write-lock-timeout } ; ARTICLE: "concurrency.locks" "Locks" "A " { $emphasis "lock" } " is an object protecting a critical region of code, enforcing a particular mutual-exclusion policy. The " { $vocab-link "concurrency.locks" } " vocabulary implements two types of locks:" diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor index 4c1d280cd6..659bd2714e 100755 --- a/extra/concurrency/locks/locks-tests.factor +++ b/extra/concurrency/locks/locks-tests.factor @@ -1,8 +1,9 @@ -IN: temporary +IN: concurrency.locks.tests USING: tools.test concurrency.locks concurrency.count-downs -locals kernel threads sequences ; +concurrency.messaging concurrency.mailboxes locals kernel +threads sequences calendar ; -:: lock-test-0 | | +:: lock-test-0 ( -- ) [let | v [ V{ } clone ] c [ 2 ] | @@ -26,13 +27,13 @@ locals kernel threads sequences ; v ] ; -:: lock-test-1 | | +:: lock-test-1 ( -- ) [let | v [ V{ } clone ] l [ ] c [ 2 ] | [ - l f [ + l [ yield 1 v push yield @@ -42,7 +43,7 @@ locals kernel threads sequences ; ] "Lock test 1" spawn drop [ - l f [ + l [ yield 3 v push yield @@ -59,8 +60,8 @@ locals kernel threads sequences ; [ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test [ 3 ] [ - dup f [ - f [ + dup [ + [ 3 ] with-lock ] with-lock @@ -68,17 +69,17 @@ locals kernel threads sequences ; [ ] [ drop ] unit-test -[ ] [ f [ ] with-read-lock ] unit-test +[ ] [ [ ] with-read-lock ] unit-test -[ ] [ dup f [ f [ ] with-read-lock ] with-read-lock ] unit-test +[ ] [ dup [ [ ] with-read-lock ] with-read-lock ] unit-test -[ ] [ f [ ] with-write-lock ] unit-test +[ ] [ [ ] with-write-lock ] unit-test -[ ] [ dup f [ f [ ] with-write-lock ] with-write-lock ] unit-test +[ ] [ dup [ [ ] with-write-lock ] with-write-lock ] unit-test -[ ] [ dup f [ f [ ] with-read-lock ] with-write-lock ] unit-test +[ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test -:: rw-lock-test-1 | | +:: rw-lock-test-1 ( -- ) [let | l [ ] c [ 1 ] c' [ 1 ] @@ -86,7 +87,7 @@ locals kernel threads sequences ; v [ V{ } clone ] | [ - l f [ + l [ 1 v push c count-down yield @@ -97,7 +98,7 @@ locals kernel threads sequences ; [ c await - l f [ + l [ 4 v push 1000 sleep 5 v push @@ -107,7 +108,7 @@ locals kernel threads sequences ; [ c await - l f [ + l [ 2 v push c' count-down ] with-read-lock @@ -116,7 +117,7 @@ locals kernel threads sequences ; [ c' await - l f [ + l [ 6 v push ] with-write-lock c'' count-down @@ -128,14 +129,14 @@ locals kernel threads sequences ; [ 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 ] v [ V{ } clone ] | [ - l f [ + l [ 1 v push c count-down 1000 sleep @@ -146,7 +147,7 @@ locals kernel threads sequences ; [ c await - l f [ + l [ 3 v push ] with-read-lock c' count-down @@ -157,3 +158,56 @@ locals kernel threads sequences ; ] ; [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test + +! Test lock timeouts +:: lock-timeout-test ( -- ) + [let | l [ ] | + [ + l [ 1 seconds sleep ] with-lock + ] "Lock holder" spawn drop + + [ + l 1/10 seconds [ ] with-lock-timeout + ] "Lock timeout-er" spawn-linked drop + + receive + ] ; + +[ lock-timeout-test ] [ + linked-error-thread thread-name "Lock timeout-er" = +] must-fail-with + +:: read/write-test ( -- ) + [let | l [ ] | + [ + l [ 1 seconds sleep ] with-lock + ] "Lock holder" spawn drop + + [ + l 1/10 seconds [ ] with-lock-timeout + ] "Lock timeout-er" spawn-linked drop + + receive + ] ; + +[ + dup [ + 1 seconds [ ] with-write-lock-timeout + ] with-read-lock +] must-fail + +[ + dup [ + dup [ + 1 seconds [ ] with-write-lock-timeout + ] with-read-lock + ] with-write-lock +] must-fail + +[ ] [ + dup [ + dup [ + 1 seconds [ ] with-read-lock-timeout + ] with-read-lock + ] with-write-lock +] unit-test diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor index f4138a0a76..43f22c00da 100755 --- a/extra/concurrency/locks/locks.factor +++ b/extra/concurrency/locks/locks.factor @@ -25,15 +25,15 @@ TUPLE: lock threads owner reentrant? ; lock-threads notify-1 ; : do-lock ( lock timeout quot acquire release -- ) - >r swap compose pick >r 2curry r> r> curry [ ] cleanup ; - inline + >r >r pick rot r> call ! use up timeout acquire + swap r> curry [ ] cleanup ; inline : (with-lock) ( lock timeout quot -- ) [ acquire-lock ] [ release-lock ] do-lock ; inline PRIVATE> -: with-lock ( lock timeout quot -- ) +: with-lock-timeout ( lock timeout quot -- ) pick lock-reentrant? [ pick lock-owner self eq? [ 2nip call @@ -44,6 +44,9 @@ PRIVATE> (with-lock) ] if ; inline +: with-lock ( lock quot -- ) + f swap with-lock-timeout ; inline + ! Many-reader/single-writer locks TUPLE: rw-lock readers writers reader# writer ; @@ -52,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 @@ -74,17 +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 ( lock timeout quot -- ) - [ +: 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-write-lock ( lock timeout quot -- ) - [ +: 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-docs.factor b/extra/concurrency/mailboxes/mailboxes-docs.factor new file mode 100755 index 0000000000..4937ef1fb9 --- /dev/null +++ b/extra/concurrency/mailboxes/mailboxes-docs.factor @@ -0,0 +1,75 @@ +USING: help.markup help.syntax kernel arrays ; +IN: concurrency.mailboxes + +HELP: +{ $values { "mailbox" mailbox } } +{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ; + +HELP: mailbox-empty? +{ $values { "mailbox" mailbox } + { "bool" "a boolean" } +} +{ $description "Return true if the mailbox is empty." } ; + +HELP: mailbox-put +{ $values { "obj" object } + { "mailbox" mailbox } +} +{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ; + +HELP: block-unless-pred +{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } + { "mailbox" mailbox } + { "timeout" "a timeout in milliseconds, or " { $link f } } +} +{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ; + +HELP: block-if-empty +{ $values { "mailbox" mailbox } + { "timeout" "a timeout in milliseconds, or " { $link f } } +} +{ $description "Block the thread if the mailbox is empty." } ; + +HELP: mailbox-get +{ $values { "mailbox" mailbox } + { "obj" object } +} +{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ; + +HELP: mailbox-get-all +{ $values { "mailbox" mailbox } + { "array" array } +} +{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ; + +HELP: while-mailbox-empty +{ $values { "mailbox" mailbox } + { "quot" "a quotation with stack effect " { $snippet "( -- )" } } +} +{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ; + +HELP: mailbox-get? +{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } + { "mailbox" mailbox } + { "obj" object } +} +{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ; + + +ARTICLE: "concurrency.mailboxes" "Mailboxes" +"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error." +{ $subsection mailbox } +{ $subsection } +"Removing the first element:" +{ $subsection mailbox-get } +{ $subsection mailbox-get-timeout } +"Removing the first element matching a predicate:" +{ $subsection mailbox-get? } +{ $subsection mailbox-get-timeout? } +"Emptying out a mailbox:" +{ $subsection mailbox-get-all } +"Adding an element:" +{ $subsection mailbox-put } +"Testing if a mailbox is empty:" +{ $subsection mailbox-empty? } +{ $subsection while-mailbox-empty } ; diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor new file mode 100755 index 0000000000..24d83b2961 --- /dev/null +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -0,0 +1,40 @@ +IN: concurrency.mailboxes.tests +USING: concurrency.mailboxes vectors sequences threads +tools.test math kernel strings ; + +[ V{ 1 2 3 } ] [ + 0 + + [ mailbox-get swap push ] in-thread + [ mailbox-get swap push ] in-thread + [ mailbox-get swap push ] in-thread + 1 over mailbox-put + 2 over mailbox-put + 3 swap mailbox-put +] unit-test + +[ V{ 1 2 3 } ] [ + 0 + + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] swap mailbox-get? swap push ] in-thread + 1 over mailbox-put + 2 over mailbox-put + 3 swap mailbox-put +] unit-test + +[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ + 0 + + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ string? ] swap mailbox-get? swap push ] in-thread + [ [ string? ] swap mailbox-get? swap push ] in-thread + 1 over mailbox-put + "junk" over mailbox-put + [ 456 ] over mailbox-put + 3 over mailbox-put + "junk2" over mailbox-put + mailbox-get +] unit-test diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor new file mode 100755 index 0000000000..28b2fb7221 --- /dev/null +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -0,0 +1,87 @@ +! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: concurrency.mailboxes +USING: dlists threads sequences continuations +namespaces random math quotations words kernel arrays assocs +init system concurrency.conditions ; + +TUPLE: mailbox threads data ; + +: ( -- mailbox ) + mailbox construct-boa ; + +: mailbox-empty? ( mailbox -- bool ) + mailbox-data dlist-empty? ; + +: mailbox-put ( obj mailbox -- ) + [ mailbox-data push-front ] keep + mailbox-threads notify-all yield ; + +: block-unless-pred ( pred mailbox timeout -- ) + 2over mailbox-data dlist-contains? [ + 3drop + ] [ + 2dup >r mailbox-threads r> "mailbox" wait + block-unless-pred + ] if ; inline + +: block-if-empty ( mailbox timeout -- mailbox ) + over mailbox-empty? [ + 2dup >r mailbox-threads r> "mailbox" wait + block-if-empty + ] [ + drop + ] if ; + +: mailbox-peek ( mailbox -- obj ) + mailbox-data peek-back ; + +: mailbox-get-timeout ( mailbox timeout -- obj ) + block-if-empty mailbox-data pop-back ; + +: mailbox-get ( mailbox -- obj ) + f mailbox-get-timeout ; + +: mailbox-get-all-timeout ( mailbox timeout -- array ) + block-if-empty + [ dup mailbox-empty? ] + [ dup mailbox-data pop-back ] + [ ] unfold nip ; + +: mailbox-get-all ( mailbox -- array ) + f mailbox-get-all-timeout ; + +: while-mailbox-empty ( mailbox quot -- ) + over mailbox-empty? [ + dup >r swap slip r> while-mailbox-empty + ] [ + 2drop + ] if ; inline + +: mailbox-get-timeout? ( pred mailbox timeout -- obj ) + [ block-unless-pred ] 3keep drop + mailbox-data delete-node-if ; inline + +: mailbox-get? ( pred mailbox -- obj ) + f mailbox-get-timeout? ; inline + +TUPLE: linked-error thread ; + +: ( error thread -- linked ) + { set-delegate set-linked-error-thread } + linked-error construct ; + +: ?linked dup linked-error? [ rethrow ] when ; + +TUPLE: linked-thread supervisor ; + +M: linked-thread error-in-thread + [ ] keep + linked-thread-supervisor mailbox-put ; + +: ( quot name mailbox -- thread' ) + >r linked-thread construct-delegate r> + over set-linked-thread-supervisor ; + +: spawn-linked-to ( quot name mailbox -- thread ) + [ (spawn) ] keep ; diff --git a/extra/concurrency/messaging/messaging-docs.factor b/extra/concurrency/messaging/messaging-docs.factor index 45bf2006e0..e7aa5d1a7e 100755 --- a/extra/concurrency/messaging/messaging-docs.factor +++ b/extra/concurrency/messaging/messaging-docs.factor @@ -1,76 +1,12 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: help.syntax help.markup concurrency.messaging.private -threads kernel arrays quotations ; +threads kernel arrays quotations threads strings ; IN: concurrency.messaging -HELP: -{ $values { "mailbox" mailbox } -} -{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: mailbox-empty? -{ $values { "mailbox" mailbox } - { "bool" "a boolean" } -} -{ $description "Return true if the mailbox is empty." } -{ $see-also mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: mailbox-put -{ $values { "obj" object } - { "mailbox" mailbox } -} -{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } -{ $see-also mailbox-empty? mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: block-unless-pred -{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" mailbox } - { "timeout" "a timeout in milliseconds, or " { $link f } } -} -{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: block-if-empty -{ $values { "mailbox" mailbox } - { "timeout" "a timeout in milliseconds, or " { $link f } } -} -{ $description "Block the thread if the mailbox is empty." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ; - -HELP: mailbox-get -{ $values { "mailbox" mailbox } - { "obj" object } -} -{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } -{ $see-also mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; - -HELP: mailbox-get-all -{ $values { "mailbox" mailbox } - { "array" array } -} -{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } -{ $see-also mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; - -HELP: while-mailbox-empty -{ $values { "mailbox" mailbox } - { "quot" "a quotation with stack effect " { $snippet "( -- )" } } -} -{ $description "Repeatedly call the quotation while there are no items in the mailbox." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all mailbox-get? } ; - -HELP: mailbox-get? -{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" mailbox } - { "obj" object } -} -{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } -{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ; - HELP: send { $values { "message" object } - { "thread" "a thread object" } + { "thread" thread } } { $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } { $see-also receive receive-if } ; @@ -90,13 +26,14 @@ HELP: receive-if HELP: spawn-linked { $values { "quot" quotation } - { "thread" "a thread object" } + { "name" string } + { "thread" thread } } { $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } { $see-also spawn } ; -ARTICLE: { "concurrency" "mailboxes" } "Mailboxes" -"Each thread has an associated message queue. Other threads can place items on this queue by sending the thread a message. A thread can check its queue for messages, blocking if none are pending, and thread them as they are queued." +ARTICLE: { "concurrency" "messaging" } "Mailboxes" +"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued." $nl "The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is." $nl @@ -104,14 +41,9 @@ $nl { $subsection send } "A thread can get a message from its queue:" { $subsection receive } -{ $subsection receive } +{ $subsection receive-timeout } { $subsection receive-if } -"Mailboxes can be created and used directly:" -{ $subsection mailbox } -{ $subsection } -{ $subsection mailbox-get } -{ $subsection mailbox-put } -{ $subsection mailbox-empty? } ; +{ $subsection receive-if-timeout } ; ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" "The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:" @@ -133,8 +65,6 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" { $code "[ 1 0 / \"This will not print\" print ] spawn" } "Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them." { $subsection spawn-linked } -"A more flexible version of the above deposits the error in an arbitary mailbox:" -{ $subsection spawn-linked-to } "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:" { $code "[" " [ 1 0 / \"This will not print\" print ] spawn-linked drop" @@ -148,7 +78,7 @@ $nl "A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends." $nl "Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." -{ $subsection { "concurrency" "mailboxes" } } +{ $subsection { "concurrency" "messaging" } } { $subsection { "concurrency" "synchronous-sends" } } { $subsection { "concurrency" "exceptions" } } ; diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 267fc7a8cd..6de381b166 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -3,48 +3,10 @@ ! USING: kernel threads vectors arrays sequences namespaces tools.test continuations dlists strings math words -match quotations concurrency.messaging ; -IN: temporary - -[ ] [ mailbox mailbox-data dlist-delete-all ] unit-test - -[ V{ 1 2 3 } ] [ - 0 - - [ mailbox-get swap push ] in-thread - [ mailbox-get swap push ] in-thread - [ mailbox-get swap push ] in-thread - 1 over mailbox-put - 2 over mailbox-put - 3 swap mailbox-put -] unit-test - -[ V{ 1 2 3 } ] [ - 0 - - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ integer? ] swap mailbox-get? swap push ] in-thread - 1 over mailbox-put - 2 over mailbox-put - 3 swap mailbox-put -] unit-test - -[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ - 0 - - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ string? ] swap mailbox-get? swap push ] in-thread - [ [ string? ] swap mailbox-get? swap push ] in-thread - 1 over mailbox-put - "junk" over mailbox-put - [ 456 ] over mailbox-put - 3 over mailbox-put - "junk2" over mailbox-put - mailbox-get -] unit-test +match quotations concurrency.messaging concurrency.mailboxes ; +IN: concurrency.messaging.tests +[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test [ "received" ] [ [ @@ -67,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 22a7282364..cfa2aea30d 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -1,82 +1,13 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. ! -! Concurrency library for Factor based on Erlang/Termite style +! Concurrency library for Factor, based on Erlang/Termite style ! concurrency. +USING: kernel threads concurrency.mailboxes continuations +namespaces assocs random ; IN: concurrency.messaging -USING: dlists threads sequences continuations -namespaces random math quotations words kernel arrays assocs -init system concurrency.conditions ; -TUPLE: mailbox threads data ; - -: ( -- mailbox ) - \ mailbox construct-boa ; - -: mailbox-empty? ( mailbox -- bool ) - mailbox-data dlist-empty? ; - -: mailbox-put ( obj mailbox -- ) - [ mailbox-data push-front ] keep - mailbox-threads notify-all ; - -r mailbox-threads r> "mailbox" wait - block-unless-pred - ] if ; inline - -: block-if-empty ( mailbox timeout -- mailbox ) - over mailbox-empty? [ - 2dup >r mailbox-threads r> "mailbox" wait - block-if-empty - ] [ - drop - ] if ; - -PRIVATE> - -: mailbox-peek ( mailbox -- obj ) - mailbox-data peek-back ; - -: mailbox-get-timeout ( mailbox timeout -- obj ) - block-if-empty mailbox-data pop-back ; - -: mailbox-get ( mailbox -- obj ) - f mailbox-get-timeout ; - -: mailbox-get-all-timeout ( mailbox timeout -- array ) - block-if-empty - [ dup mailbox-empty? ] - [ dup mailbox-data pop-back ] - [ ] unfold nip ; - -: mailbox-get-all ( mailbox -- array ) - f mailbox-get-all-timeout ; - -: while-mailbox-empty ( mailbox quot -- ) - over mailbox-empty? [ - dup >r swap slip r> while-mailbox-empty - ] [ - 2drop - ] if ; inline - -: mailbox-timeout-get? ( pred mailbox timeout -- obj ) - [ block-unless-pred ] 3keep drop - mailbox-data delete-node-if ; inline - -: mailbox-get? ( pred mailbox -- obj ) - f mailbox-timeout-get? ; inline - -TUPLE: linked error thread ; - -C: linked - -GENERIC: send ( message process -- ) +GENERIC: send ( message thread -- ) : mailbox-of ( thread -- mailbox ) dup thread-mailbox [ ] [ @@ -84,27 +15,27 @@ GENERIC: send ( message process -- ) ] ?if ; M: thread send ( message thread -- ) - mailbox-of mailbox-put ; + check-registered mailbox-of mailbox-put ; -: ?linked dup linked? [ rethrow ] when ; - -: mailbox self mailbox-of ; +: my-mailbox self mailbox-of ; : receive ( -- message ) - mailbox mailbox-get ?linked ; + my-mailbox mailbox-get ?linked ; + +: receive-timeout ( timeout -- message ) + my-mailbox swap mailbox-get-timeout ?linked ; : receive-if ( pred -- message ) - mailbox mailbox-get? ?linked ; inline + my-mailbox mailbox-get? ?linked ; inline + +: receive-if-timeout ( pred timeout -- message ) + my-mailbox swap mailbox-get-timeout? ?linked ; inline : rethrow-linked ( error process supervisor -- ) - >r r> send ; - -: spawn-linked-to ( quot name mailbox -- thread ) - [ >r r> mailbox-put ] curry - [ (spawn) ] keep ; + >r r> send ; : spawn-linked ( quot name -- thread ) - mailbox spawn-linked-to ; + my-mailbox spawn-linked-to ; TUPLE: synchronous data sender tag ; @@ -116,32 +47,42 @@ TUPLE: reply data tag ; : ( data synchronous -- reply ) synchronous-tag \ reply construct-boa ; +: synchronous-reply? ( response synchronous -- ? ) + over reply? + [ >r reply-tag r> synchronous-tag = ] + [ 2drop f ] if ; + : send-synchronous ( message thread -- reply ) - >r dup r> send [ - over reply? [ - >r reply-tag r> synchronous-tag = - ] [ - 2drop f - ] if - ] curry receive-if reply-data ; + dup self eq? [ + "Cannot synchronous send to myself" throw + ] [ + >r dup r> send + [ synchronous-reply? ] curry receive-if + reply-data + ] if ; : reply-synchronous ( message synchronous -- ) [ ] keep synchronous-sender send ; +: handle-synchronous ( quot -- ) + receive [ + synchronous-data swap call + ] keep reply-synchronous ; inline + : register-process ( name process -- ) - swap remote-processes set-at ; + swap registered-processes set-at ; : unregister-process ( name -- ) - remote-processes delete-at ; + registered-processes delete-at ; : get-process ( name -- process ) - dup remote-processes at [ ] [ thread ] ?if ; + dup registered-processes at [ ] [ thread ] ?if ; -\ remote-processes global [ H{ } assoc-like ] change-at +\ registered-processes global [ H{ } assoc-like ] change-at diff --git a/extra/concurrency/promises/promises-docs.factor b/extra/concurrency/promises/promises-docs.factor index a4d79d8a47..6a4a2bf8d6 100755 --- a/extra/concurrency/promises/promises-docs.factor +++ b/extra/concurrency/promises/promises-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.messaging kernel arrays -continuations help.markup help.syntax quotations ; +continuations help.markup help.syntax quotations calendar ; IN: concurrency.promises HELP: promise @@ -12,12 +12,12 @@ HELP: promise-fulfilled? { $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ; HELP: ?promise-timeout -{ $values { "promise" promise } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } } +{ $values { "promise" promise } { "timeout" "a " { $link duration } " or " { $link f } } { "result" object } } { $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." } { $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ; HELP: ?promise -{ $values { "promise" promise } { "value" object } } +{ $values { "promise" promise } { "result" object } } { $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled." } ; HELP: fulfill 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/promises/promises.factor b/extra/concurrency/promises/promises.factor index 6610a8c7ed..b7ccff7fa7 100755 --- a/extra/concurrency/promises/promises.factor +++ b/extra/concurrency/promises/promises.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.messaging concurrency.messaging.private -kernel ; +USING: concurrency.mailboxes kernel continuations ; IN: concurrency.promises TUPLE: promise mailbox ; @@ -20,8 +19,7 @@ TUPLE: promise mailbox ; ] if ; : ?promise-timeout ( promise timeout -- result ) - >r promise-mailbox r> block-if-empty - mailbox-peek ?linked ; + >r promise-mailbox r> block-if-empty mailbox-peek ; : ?promise ( promise -- result ) f ?promise-timeout ; diff --git a/extra/concurrency/semaphores/semaphores-docs.factor b/extra/concurrency/semaphores/semaphores-docs.factor index 05ef6cc39e..33f4de8783 100755 --- a/extra/concurrency/semaphores/semaphores-docs.factor +++ b/extra/concurrency/semaphores/semaphores-docs.factor @@ -1,5 +1,5 @@ IN: concurrency.semaphores -USING: help.markup help.syntax kernel quotations ; +USING: help.markup help.syntax kernel quotations calendar ; HELP: semaphore { $class-description "The class of counting semaphores." } ; @@ -8,14 +8,23 @@ HELP: { $values { "n" "a non-negative integer" } { "semaphore" semaphore } } { $description "Creates a counting semaphore with the specified initial count." } ; +HELP: acquire-timeout +{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } } +{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." } +{ $errors "Throws an error if the timeout expires before the semaphore is released." } ; + HELP: acquire -{ $values { "semaphore" semaphore } { "timeout" "a timeout in milliseconds 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 up to that number of milliseconds for the semaphore to be released." } ; +{ $values { "semaphore" semaphore } } +{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, waits for it to be released." } ; HELP: release { $values { "semaphore" semaphore } } { $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ; +HELP: with-semaphore-timeout +{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } +{ $description "Calls the quotation with the semaphore held." } ; + HELP: with-semaphore { $values { "semaphore" semaphore } { "quot" quotation } } { $description "Calls the quotation with the semaphore held." } ; @@ -38,8 +47,10 @@ $nl { $subsection } "Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:" { $subsection acquire } +{ $subsection acquire-timeout } { $subsection release } -"A combinator which pairs acquisition and release:" -{ $subsection with-semaphore } ; +"Combinators which pair acquisition and release:" +{ $subsection with-semaphore } +{ $subsection with-semaphore-timeout } ; ABOUT: "concurrency.semaphores" diff --git a/extra/concurrency/semaphores/semaphores.factor b/extra/concurrency/semaphores/semaphores.factor index 413e491fdb..031614ea95 100755 --- a/extra/concurrency/semaphores/semaphores.factor +++ b/extra/concurrency/semaphores/semaphores.factor @@ -13,17 +13,21 @@ TUPLE: semaphore count threads ; : wait-to-acquire ( semaphore timeout -- ) >r semaphore-threads r> "semaphore" wait ; -: acquire ( semaphore timeout -- ) - dup semaphore-count zero? [ - wait-to-acquire - ] [ - drop - dup semaphore-count 1- swap set-semaphore-count - ] if ; +: acquire-timeout ( semaphore timeout -- ) + over semaphore-count zero? + [ dupd wait-to-acquire ] [ drop ] if + dup semaphore-count 1- swap set-semaphore-count ; + +: acquire ( semaphore -- ) + f acquire-timeout ; : release ( semaphore -- ) dup semaphore-count 1+ over set-semaphore-count semaphore-threads notify-1 ; +: with-semaphore-timeout ( semaphore timeout quot -- ) + pick rot acquire-timeout swap + [ release ] curry [ ] cleanup ; inline + : with-semaphore ( semaphore quot -- ) - over acquire [ release ] curry [ ] cleanup ; inline + over acquire swap [ release ] curry [ ] cleanup ; inline 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/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index 187297d0a0..24eceee744 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -3,7 +3,7 @@ ! USING: kernel math sequences words arrays io io.files namespaces math.parser assocs quotations parser parser-combinators -tools.time ; +tools.time io.encodings.binary ; IN: cpu.8080.emulator TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; @@ -439,7 +439,7 @@ M: cpu reset ( cpu -- ) : load-rom ( filename cpu -- ) #! Load the contents of the file into ROM. #! (address 0x0000-0x1FFF). - cpu-ram swap [ + cpu-ram swap binary [ 0 swap (load-rom) ] with-file-reader ; @@ -455,7 +455,7 @@ SYMBOL: rom-root #! file path shoul dbe relative to the '/roms' resource path. rom-dir [ cpu-ram [ - swap first2 rom-dir swap path+ [ + swap first2 rom-dir swap path+ binary [ swap (load-rom) ] with-file-reader ] curry each diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor index 032e174eb1..b53ecaac3c 100644 --- a/extra/crypto/common/common-docs.factor +++ b/extra/crypto/common/common-docs.factor @@ -3,19 +3,19 @@ math.private ; IN: crypto.common HELP: >32-bit -{ $values { "x" "an integer" } { "y" "an integer" } } +{ $values { "x" integer } { "y" integer } } { $description "Used to implement 32-bit integer overflow." } ; HELP: >64-bit -{ $values { "x" "an integer" } { "y" "an integer" } } +{ $values { "x" integer } { "y" integer } } { $description "Used to implement 64-bit integer overflow." } ; HELP: bitroll -{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" "an integer" } } +{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } { $description "Roll n by s bits to the left, wrapping around after w bits." } { $examples - { $example "USE: crypto.common" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } - { $example "USE: crypto.common" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } + { $example "USING: crypto.common prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } + { $example "USING: crypto.common prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } } ; @@ -23,7 +23,7 @@ HELP: hex-string { $values { "seq" "a sequence" } { "str" "a string" } } { $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." } { $examples - { $example "USE: crypto.common" "B{ 1 2 3 4 } hex-string print" "01020304" } + { $example "USING: crypto.common io ;" "B{ 1 2 3 4 } hex-string print" "01020304" } } { $notes "Numbers are zero-padded on the left." } ; diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index 64efb96f90..fa0cbef4c7 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -1,11 +1,12 @@ -USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ; -IN: temporary +USING: kernel io strings byte-arrays sequences namespaces math +parser crypto.hmac tools.test ; +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 -[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd string>md5-hmac >string ] unit-test +[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" byte-array>md5-hmac >string ] unit-test +[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test +[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>md5-hmac >string ] unit-test -[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" string>sha1-hmac >string ] unit-test -[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test -[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd string>sha1-hmac >string ] unit-test +[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test +[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test +[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>sha1-hmac >string ] unit-test diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor old mode 100644 new mode 100755 index 7c358a8c09..3dad01fe3a --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -1,6 +1,6 @@ USING: arrays combinators crypto.common crypto.md5 crypto.sha1 -crypto.md5.private io io.binary io.files io.streams.string -kernel math math.vectors memoize sequences ; +crypto.md5.private io io.binary io.files io.streams.byte-array +kernel math math.vectors memoize sequences io.encodings.binary ; IN: crypto.hmac : sha1-hmac ( Ko Ki -- hmac ) @@ -32,18 +32,17 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; [ init-hmac sha1-hmac ] with-stream ; : file>sha1-hmac ( K path -- hmac ) - stream>sha1-hmac ; + binary stream>sha1-hmac ; -: string>sha1-hmac ( K string -- hmac ) - stream>sha1-hmac ; +: byte-array>sha1-hmac ( K string -- hmac ) + binary stream>sha1-hmac ; : stream>md5-hmac ( K stream -- hmac ) [ init-hmac md5-hmac ] with-stream ; : file>md5-hmac ( K path -- hmac ) - stream>md5-hmac ; - -: string>md5-hmac ( K string -- hmac ) - stream>md5-hmac ; + binary stream>md5-hmac ; +: byte-array>md5-hmac ( K string -- hmac ) + binary stream>md5-hmac ; diff --git a/extra/crypto/md5/md5-docs.factor b/extra/crypto/md5/md5-docs.factor old mode 100644 new mode 100755 index fd8bf3f74d..667e0449ae --- a/extra/crypto/md5/md5-docs.factor +++ b/extra/crypto/md5/md5-docs.factor @@ -1,15 +1,15 @@ USING: help.markup help.syntax kernel math sequences quotations -crypto.common ; +crypto.common byte-arrays ; IN: crypto.md5 HELP: stream>md5 { $values { "stream" "a stream" } { "byte-array" "md5 hash" } } { $description "Take the MD5 hash until end of stream." } -{ $notes "Used to implement " { $link string>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ; +{ $notes "Used to implement " { $link byte-array>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ; -HELP: string>md5 -{ $values { "string" "a string" } { "byte-array" "byte-array md5 hash" } } -{ $description "Outputs the MD5 hash of a string." } +HELP: byte-array>md5 +{ $values { "byte-array" byte-array } { "checksum" "an md5 hash" } } +{ $description "Outputs the MD5 hash of a byte array." } { $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ; HELP: file>md5 diff --git a/extra/crypto/md5/md5-tests.factor b/extra/crypto/md5/md5-tests.factor old mode 100644 new mode 100755 index 9a361eb594..73bd240455 --- a/extra/crypto/md5/md5-tests.factor +++ b/extra/crypto/md5/md5-tests.factor @@ -1,10 +1,10 @@ -USING: kernel math namespaces crypto.md5 tools.test ; +USING: kernel math namespaces crypto.md5 tools.test byte-arrays ; -[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5str ] unit-test -[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test -[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test -[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test -[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test -[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test -[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test +[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array byte-array>md5str ] unit-test +[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array byte-array>md5str ] unit-test +[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array byte-array>md5str ] unit-test +[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array byte-array>md5str ] unit-test +[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array byte-array>md5str ] unit-test +[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array byte-array>md5str ] unit-test +[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array byte-array>md5str ] unit-test diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor old mode 100644 new mode 100755 index fe215e32db..7ecbd767b9 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -1,20 +1,14 @@ ! See http://www.faqs.org/rfcs/rfc1321.html -USING: kernel io io.binary io.files io.streams.string math +USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting strings -sequences crypto.common byte-arrays locals sequences.private ; +sequences crypto.common byte-arrays locals sequences.private +io.encodings.binary symbols ; IN: crypto.md5 bignum ; foldable @@ -32,7 +26,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+ @@ -184,7 +178,14 @@ PRIVATE> : stream>md5 ( stream -- byte-array ) [ initialize-md5 (stream>md5) get-md5 ] with-stream ; -: string>md5 ( string -- byte-array ) stream>md5 ; -: string>md5str ( string -- md5-string ) string>md5 hex-string ; -: file>md5 ( path -- byte-array ) stream>md5 ; -: file>md5str ( path -- md5-string ) file>md5 hex-string ; +: byte-array>md5 ( byte-array -- checksum ) + binary stream>md5 ; + +: byte-array>md5str ( byte-array -- md5-string ) + byte-array>md5 hex-string ; + +: file>md5 ( path -- byte-array ) + binary stream>md5 ; + +: file>md5str ( path -- md5-string ) + file>md5 hex-string ; diff --git a/extra/crypto/rc4/rc4.factor b/extra/crypto/rc4/rc4.factor deleted file mode 100644 index b730c4b7fe..0000000000 --- a/extra/crypto/rc4/rc4.factor +++ /dev/null @@ -1,39 +0,0 @@ -USING: kernel math sequences namespaces ; -IN: crypto.rc4 - -! http://en.wikipedia.org/wiki/RC4_%28cipher%29 - - - -: rc4 ( key -- ) - [ - [ key set ] keep - length l set - ksa - 0 i set - 0 j set - ] with-scope ; - diff --git a/extra/crypto/sha1/sha1-tests.factor b/extra/crypto/sha1/sha1-tests.factor index 795ee4971d..14307355c2 100755 --- a/extra/crypto/sha1/sha1-tests.factor +++ b/extra/crypto/sha1/sha1-tests.factor @@ -1,14 +1,14 @@ USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ; -[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test -[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test +[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" byte-array>sha1str ] unit-test +[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" byte-array>sha1str ] unit-test ! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time... [ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" -10 swap concat string>sha1str ] unit-test +10 swap concat byte-array>sha1str ] unit-test [ ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099" ] [ "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7" - string>sha1-interleave + byte-array>sha1-interleave ] unit-test diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor old mode 100644 new mode 100755 index f6dfbcd031..af3671e7d9 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,23 +1,12 @@ -USING: arrays combinators crypto.common kernel io io.binary -io.files io.streams.string math.vectors strings sequences -namespaces math parser sequences vectors -hashtables ; +USING: arrays combinators crypto.common kernel io +io.encodings.binary io.files io.streams.byte-array math.vectors +strings sequences namespaces math parser sequences vectors +io.binary hashtables symbols ; IN: crypto.sha1 ! Implemented according to RFC 3174. -SYMBOL: h0 -SYMBOL: h1 -SYMBOL: h2 -SYMBOL: h3 -SYMBOL: h4 -SYMBOL: A -SYMBOL: B -SYMBOL: C -SYMBOL: D -SYMBOL: E -SYMBOL: w -SYMBOL: K +SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; : get-wth ( n -- wth ) w get nth ; inline : shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline @@ -118,15 +107,22 @@ SYMBOL: K [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ; : stream>sha1 ( stream -- sha1 ) - [ [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ] with-scope ; + [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ; -: string>sha1 ( string -- sha1 ) stream>sha1 ; -: string>sha1str ( string -- str ) string>sha1 hex-string ; -: string>sha1-bignum ( string -- n ) string>sha1 be> ; -: file>sha1 ( file -- sha1 ) stream>sha1 ; +: byte-array>sha1 ( string -- sha1 ) + binary stream>sha1 ; -: string>sha1-interleave ( string -- seq ) +: byte-array>sha1str ( string -- str ) + byte-array>sha1 hex-string ; + +: byte-array>sha1-bignum ( string -- n ) + byte-array>sha1 be> ; + +: file>sha1 ( file -- sha1 ) + binary stream>sha1 ; + +: byte-array>sha1-interleave ( string -- seq ) [ zero? ] left-trim dup length odd? [ 1 tail ] when - seq>2seq [ string>sha1 ] 2apply + seq>2seq [ byte-array>sha1 ] 2apply swap 2seq>seq ; diff --git a/extra/crypto/sha2/sha2-tests.factor b/extra/crypto/sha2/sha2-tests.factor old mode 100644 new mode 100755 index 25da4e1446..8fe655f205 --- a/extra/crypto/sha2/sha2-tests.factor +++ b/extra/crypto/sha2/sha2-tests.factor @@ -1,7 +1,7 @@ USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ; -[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" string>sha-256-string ] unit-test -[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" string>sha-256-string ] unit-test -[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" string>sha-256-string ] unit-test -[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" string>sha-256-string ] unit-test -[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>sha-256-string ] unit-test -[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>sha-256-string ] unit-test +[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" byte-array>sha-256-string ] unit-test +[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" byte-array>sha-256-string ] unit-test +[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" byte-array>sha-256-string ] unit-test +[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" byte-array>sha-256-string ] unit-test +[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" byte-array>sha-256-string ] unit-test +[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" byte-array>sha-256-string ] unit-test diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor old mode 100644 new mode 100755 index 8e7710f40f..daba6d29ff --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -1,19 +1,10 @@ USING: crypto.common kernel splitting math sequences namespaces -io.binary ; +io.binary symbols ; IN: crypto.sha2 word +SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ; : a 0 ; : b 1 ; @@ -117,26 +108,25 @@ SYMBOL: >word T1 T2 update-vars ] with each vars get H get [ w+ ] 2map H set ; -: seq>string ( n seq -- string ) - [ swap [ >be % ] curry each ] "" make ; +: seq>byte-array ( n seq -- string ) + [ swap [ >be % ] curry each ] B{ } make ; -: string>sha2 ( string -- string ) +: byte-array>sha2 ( byte-array -- string ) t preprocess-plaintext block-size get group [ process-chunk ] each - 4 H get seq>string ; + 4 H get seq>byte-array ; PRIVATE> -: string>sha-256 ( string -- string ) +: byte-array>sha-256 ( string -- string ) [ K-256 K set initial-H-256 H set 4 word-size set 64 block-size set \ >32-bit >word set - string>sha2 + byte-array>sha2 ] with-scope ; -: string>sha-256-string ( string -- hexstring ) - string>sha-256 hex-string ; - +: byte-array>sha-256-string ( string -- hexstring ) + byte-array>sha-256 hex-string ; 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..309847209f 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -1,70 +1,82 @@ ! 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-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 ; +TUPLE: result-set sql in-params out-params handle n max ; +: ( sql in out -- statement ) + { (>>sql) (>>in-params) (>>out-params) } statement construct ; -HOOK: db ( str -- statement ) -HOOK: db ( str -- statement ) +HOOK: db ( str in out -- statement ) +HOOK: db ( str in out -- 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 ; +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 ) -GENERIC# row-column 1 ( result-set n -- obj ) +GENERIC# row-column 1 ( result-set column -- obj ) +GENERIC# row-column-typed 1 ( result-set column -- sql ) 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>> out-params>> } get-slots r> + { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set + construct r> construct-delegate ; : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; +: sql-row-typed ( result-set -- seq ) + dup #columns [ row-column-typed ] with map ; + : query-each ( statement quot -- ) over more-rows? [ [ call ] 2keep over advance-row query-each @@ -75,22 +87,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 +114,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/mysql/mysql.factor b/extra/db/mysql/mysql.factor old mode 100644 new mode 100755 index 91562e89ff..dc7225514e --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -9,37 +9,37 @@ TUPLE: mysql-statement ; TUPLE: mysql-result-set ; M: mysql-db db-open ( mysql-db -- ) - ; + drop ; M: mysql-db dispose ( mysql-db -- ) mysql-db-handle mysql_close ; -M: mysql-db ( str -- statement ) - ; +M: mysql-db ( str in out -- statement ) + 3drop f ; -M: mysql-db ( str -- statement ) - ; +M: mysql-db ( str in out -- statement ) + 3drop f ; M: mysql-statement prepare-statement ( statement -- ) - ; + drop ; M: mysql-statement bind-statement* ( statement -- ) - ; + drop ; M: mysql-statement query-results ( query -- result-set ) - ; + drop f ; M: mysql-result-set #rows ( result-set -- n ) - ; + drop 0 ; M: mysql-result-set #columns ( result-set -- n ) - ; + drop 0 ; M: mysql-result-set row-column ( result-set n -- obj ) - ; + 2drop f ; -M: mysql-result-set advance-row ( result-set -- ? ) - ; +M: mysql-result-set advance-row ( result-set -- ) + drop ; M: mysql-db begin-transaction ( -- ) ; diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index d14ec13ff8..be491b8c85 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -6,7 +6,7 @@ IN: db.postgresql.ffi << "postgresql" { { [ win32? ] [ "libpq.dll" ] } - { [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] } + { [ macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } { [ unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> @@ -270,7 +270,8 @@ FUNCTION: char* PQcmdStatus ( PGresult* res ) ; FUNCTION: char* PQoidStatus ( PGresult* res ) ; FUNCTION: Oid PQoidValue ( PGresult* res ) ; FUNCTION: char* PQcmdTuples ( PGresult* res ) ; -FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ; +! FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ; +FUNCTION: void* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ; FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ; FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ; @@ -297,8 +298,8 @@ FUNCTION: size_t PQescapeStringConn ( PGconn* conn, FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn, char* from, size_t length, size_t* to_length ) ; -FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, - size_t* retbuflen ) ; +FUNCTION: void* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ; +! FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ; ! These forms are deprecated! FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ; FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen, @@ -346,3 +347,23 @@ FUNCTION: int PQdsplen ( uchar* s, int encoding ) ; ! Get encoding id from environment variable PGCLIENTENCODING FUNCTION: int PQenv2encoding ( ) ; + +! From git, include/catalog/pg_type.h +: BOOL-OID 16 ; inline +: BYTEA-OID 17 ; inline +: CHAR-OID 18 ; inline +: NAME-OID 19 ; inline +: INT8-OID 20 ; inline +: INT2-OID 21 ; inline +: INT4-OID 23 ; inline +: TEXT-OID 23 ; inline +: OID-OID 26 ; inline +: FLOAT4-OID 700 ; inline +: FLOAT8-OID 701 ; inline +: VARCHAR-OID 1043 ; inline +: DATE-OID 1082 ; inline +: TIME-OID 1083 ; inline +: TIMESTAMP-OID 1114 ; inline +: TIMESTAMPTZ-OID 1184 ; inline +: INTERVAL-OID 1186 ; inline +: NUMERIC-OID 1700 ; inline diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor old mode 100644 new mode 100755 index c48eff964a..b48c87f0ca --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -2,21 +2,28 @@ ! 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 math.parser +combinators combinators.cleave libc shuffle calendar.format +byte-arrays destructors prettyprint new-slots accessors +strings serialize io.encodings.binary io.streams.byte-array ; 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,20 +34,137 @@ 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? [ dup postgresql-result-error-message swap PQclear throw ] unless ; +: type>oid ( symbol -- n ) + dup array? [ first ] when + { + { BLOB [ BYTEA-OID ] } + { FACTOR-BLOB [ BYTEA-OID ] } + [ drop 0 ] + } case ; + +: type>param-format ( symbol -- n ) + dup array? [ first ] when + { + { BLOB [ 1 ] } + { FACTOR-BLOB [ 1 ] } + [ drop 0 ] + } case ; + +: param-types ( statement -- seq ) + statement-in-params + [ sql-spec-type type>oid ] map + >c-uint-array ; + +: malloc-byte-array/length + [ malloc-byte-array dup free-always ] [ length ] bi ; + + +: param-values ( statement -- seq seq2 ) + [ statement-bind-params ] + [ statement-in-params ] bi + [ + sql-spec-type { + { FACTOR-BLOB [ + dup [ + binary [ serialize ] with-byte-writer + malloc-byte-array/length ] [ 0 ] if ] } + { BLOB [ + dup [ malloc-byte-array/length ] [ 0 ] if ] } + [ + drop number>string* dup [ + malloc-char-string dup free-always + ] when 0 + ] + } case 2array + ] 2map flip dup empty? [ + drop f f + ] [ + first2 [ >c-void*-array ] [ >c-uint-array ] bi* + ] if ; + +: param-formats ( statement -- seq ) + statement-in-params + [ sql-spec-type type>param-format ] map + >c-uint-array ; + : 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 - f f 0 PQexecParams - dup postgresql-result-ok? [ - dup postgresql-result-error-message swap PQclear throw - ] unless ; + [ + >r db get db-handle r> + { + [ statement-sql ] + [ statement-bind-params length ] + [ param-types ] + [ param-values ] + [ param-formats ] + } cleave + 0 PQexecParams dup postgresql-result-ok? [ + dup postgresql-result-error-message swap PQclear throw + ] unless + ] with-destructors ; + +: pq-get-is-null ( handle row column -- ? ) + PQgetisnull 1 = ; + +: pq-get-string ( handle row column -- obj ) + 3dup PQgetvalue alien>char-string + dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ; + +: pq-get-number ( handle row column -- obj ) + pq-get-string dup [ string>number ] when ; + +TUPLE: postgresql-malloc-destructor alien ; +C: postgresql-malloc-destructor + +M: postgresql-malloc-destructor dispose ( obj -- ) + alien>> PQfreemem ; + +: postgresql-free-always ( alien -- ) + add-always-destructor ; + +: pq-get-blob ( handle row column -- obj/f ) + [ PQgetvalue ] 3keep 3dup PQgetlength + dup 0 > [ + 3nip + [ + memory>byte-array >string + 0 + [ + PQunescapeBytea dup zero? [ + postgresql-result-error-message throw + ] [ + dup postgresql-free-always + ] if + ] keep + *uint memory>byte-array + ] with-destructors + ] [ + drop pq-get-is-null nip [ f ] [ B{ } clone ] if + ] if ; + +: postgresql-column-typed ( handle row column type -- obj ) + dup array? [ first ] when + { + { +native-id+ [ pq-get-number ] } + { INTEGER [ pq-get-number ] } + { BIG-INTEGER [ pq-get-number ] } + { DOUBLE [ pq-get-number ] } + { TEXT [ pq-get-string ] } + { VARCHAR [ pq-get-string ] } + { DATE [ pq-get-string dup [ ymd>timestamp ] when ] } + { TIME [ pq-get-string dup [ hms>timestamp ] when ] } + { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] } + { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] } + { BLOB [ pq-get-blob ] } + { FACTOR-BLOB [ + pq-get-blob + dup [ binary [ deserialize ] with-byte-reader ] when ] } + [ no-sql-type ] + } case ; + ! PQgetlength PQgetisnull diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor old mode 100644 new mode 100755 index 36b6fc829b..65b75a63dc --- 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" "foob" "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..26b6cbe75c 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -4,25 +4,29 @@ 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 +combinators.cleave namespaces.lib ; 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,40 +39,30 @@ 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 ; M: postgresql-result-set #columns ( result-set -- n ) result-set-handle PQnfields ; -M: postgresql-result-set row-column ( result-set n -- obj ) - >r dup result-set-handle swap result-set-n r> PQgetvalue ; +M: postgresql-result-set row-column ( result-set column -- obj ) + >r dup result-set-handle swap result-set-n r> pq-get-string ; -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-result-set row-column-typed ( result-set column -- obj ) + dup pick result-set-out-params nth sql-spec-type + >r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ; 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 +90,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 +109,184 @@ 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 + dup empty? [ + drop + ] [ + " where " 0% + [ " and " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ] if ";" 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" } + { DATE "date" } + { TIME "time" } + { DATETIME "timestamp" } + { TIMESTAMP "timestamp" } + { BLOB "bytea" } + { FACTOR-BLOB "bytea" } } ; -: 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 +294,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/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor new file mode 100644 index 0000000000..c490ace770 --- /dev/null +++ b/extra/db/sql/sql-tests.factor @@ -0,0 +1,42 @@ +USING: kernel namespaces db.sql sequences math ; +IN: db.sql.tests + +TUPLE: person name age ; +: insert-1 + { insert + { table "person" } + { columns "name" "age" } + { values "erg" 26 } + } ; + +: update-1 + { update "person" + { set { "name" "erg" } + { "age" 6 } } + { where { "age" 6 } } + } ; + +: select-1 + { select + { columns + "branchno" + { count "staffno" as "mycount" } + { sum "salary" as "mysum" } } + { from "staff" "lol" } + { where + { "salary" > all + { select + { columns "salary" } + { from "staff" } + { where { "branchno" "b003" } } + } + } + { "branchno" > 3 } } + { group-by "branchno" "lol2" } + { having { count "staffno" > 1 } } + { order-by "branchno" } + { offset 40 } + { limit 20 } + } ; + + diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor new file mode 100755 index 0000000000..1de4bdfb5a --- /dev/null +++ b/extra/db/sql/sql.factor @@ -0,0 +1,69 @@ +USING: kernel parser quotations tuples words +namespaces.lib namespaces sequences arrays combinators +prettyprint strings math.parser sequences.lib math symbols ; +USE: tools.walker +IN: db.sql + +SYMBOLS: insert update delete select distinct columns from as +where group-by having order-by limit offset is-null desc all +any count avg table values ; + +: input-spec, 1, ; +: output-spec, 2, ; +: input, 3, ; +: output, 4, ; + +DEFER: sql% + +: (sql-interleave) ( seq sep -- ) + [ sql% ] curry [ sql% ] interleave ; + +: sql-interleave ( seq str sep -- ) + swap sql% (sql-interleave) ; + +: sql-function, ( seq function -- ) + sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; + +: sql-array% ( array -- ) + unclip + { + { columns [ "," (sql-interleave) ] } + { from [ "from" "," sql-interleave ] } + { where [ "where" "and" sql-interleave ] } + { group-by [ "group by" "," sql-interleave ] } + { having [ "having" "," sql-interleave ] } + { order-by [ "order by" "," sql-interleave ] } + { offset [ "offset" sql% sql% ] } + { limit [ "limit" sql% sql% ] } + { select [ "(select" sql% sql% ")" sql% ] } + { table [ sql% ] } + { set [ "set" "," sql-interleave ] } + { values [ "values(" sql% "," (sql-interleave) ")" sql% ] } + { count [ "count" sql-function, ] } + { sum [ "sum" sql-function, ] } + { avg [ "avg" sql-function, ] } + { min [ "min" sql-function, ] } + { max [ "max" sql-function, ] } + [ sql% [ sql% ] each ] + } case ; + +TUPLE: no-sql-match ; +: sql% ( obj -- ) + { + { [ dup string? ] [ " " 0% 0% ] } + { [ dup array? ] [ sql-array% ] } + { [ dup number? ] [ number>string sql% ] } + { [ dup symbol? ] [ unparse sql% ] } + { [ dup word? ] [ unparse sql% ] } + { [ t ] [ T{ no-sql-match } throw ] } + } cond ; + +: parse-sql ( obj -- sql in-spec out-spec in out ) + [ + unclip { + { insert [ "insert into" sql% ] } + { update [ "update" sql% ] } + { delete [ "delete" sql% ] } + { select [ "select" sql% ] } + } case [ sql% ] each + ] { "" { } { } { } { } } nmake ; 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..dbada854fb 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -2,7 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators -continuations db.types ; +continuations db.types calendar.format serialize +io.streams.byte-array byte-arrays io.encodings.binary +tools.walker ; IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -55,6 +57,10 @@ IN: db.sqlite.lib : sqlite-bind-null ( handle i -- ) sqlite3_bind_null sqlite-check-result ; +: sqlite-bind-blob ( handle i byte-array -- ) + dup length SQLITE_TRANSIENT + sqlite3_bind_blob sqlite-check-result ; + : sqlite-bind-text-by-name ( handle name text -- ) parameter-index sqlite-bind-text ; @@ -67,19 +73,32 @@ IN: db.sqlite.lib : sqlite-bind-double-by-name ( handle name double -- ) parameter-index sqlite-bind-double ; +: sqlite-bind-blob-by-name ( handle name blob -- ) + parameter-index sqlite-bind-blob ; + : sqlite-bind-null-by-name ( handle name obj -- ) parameter-index drop sqlite-bind-null ; : sqlite-bind-type ( handle key value type -- ) + over [ drop NULL ] unless dup array? [ first ] when { { INTEGER [ sqlite-bind-int-by-name ] } - { BIG_INTEGER [ sqlite-bind-int64-by-name ] } + { BIG-INTEGER [ sqlite-bind-int64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { SERIAL [ sqlite-bind-int-by-name ] } - ! { NULL [ sqlite-bind-null-by-name ] } + { DATE [ sqlite-bind-text-by-name ] } + { TIME [ sqlite-bind-text-by-name ] } + { DATETIME [ sqlite-bind-text-by-name ] } + { TIMESTAMP [ sqlite-bind-text-by-name ] } + { BLOB [ sqlite-bind-blob-by-name ] } + { FACTOR-BLOB [ + binary [ serialize ] with-byte-writer + sqlite-bind-blob-by-name + ] } + { +native-id+ [ sqlite-bind-int-by-name ] } + { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -92,19 +111,39 @@ IN: db.sqlite.lib : sqlite-#columns ( query -- int ) sqlite3_column_count ; -! TODO : sqlite-column ( handle index -- string ) sqlite3_column_text ; +: sqlite-column-blob ( handle index -- byte-array/f ) + [ sqlite3_column_bytes ] 2keep + pick zero? [ + 3drop f + ] [ + sqlite3_column_blob swap memory>byte-array + ] if ; + : sqlite-column-typed ( handle index type -- obj ) + dup array? [ first ] when { + { +native-id+ [ sqlite3_column_int64 ] } { INTEGER [ sqlite3_column_int ] } - { BIG_INTEGER [ sqlite3_column_int64 ] } - { TEXT [ sqlite3_column_text ] } + { BIG-INTEGER [ sqlite3_column_int64 ] } { DOUBLE [ sqlite3_column_double ] } + { TEXT [ sqlite3_column_text ] } + { VARCHAR [ sqlite3_column_text ] } + { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] } + { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] } + { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } + { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } + { BLOB [ sqlite-column-blob ] } + { FACTOR-BLOB [ + sqlite-column-blob + dup [ binary [ deserialize ] with-byte-reader ] when + ] } + ! { NULL [ 2drop f ] } + [ no-sql-type ] } case ; -! TODO : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor old mode 100644 new mode 100755 index d3388b4648..b30cb4ba80 --- 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 "test.db" temp-file ; +: 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..b72d788605 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 +combinators.cleave io namespaces.lib ; 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 @@ -20,20 +23,24 @@ M: sqlite-db db-close ( handle -- ) M: sqlite-db dispose ( db -- ) dispose-db ; : with-sqlite ( path quot -- ) - >r r> with-db ; inline + sqlite-db swap with-db ; inline TUPLE: sqlite-statement ; -C: sqlite-statement TUPLE: sqlite-result-set has-more? ; -M: sqlite-db ( str -- obj ) +M: sqlite-db ( str in out -- obj ) ; -M: sqlite-db ( str -- obj ) - db get db-handle over sqlite-prepare - { set-statement-sql set-statement-handle } statement construct - [ set-delegate ] keep ; +M: sqlite-db ( str in out -- obj ) + { + 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 +51,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 ; @@ -63,8 +83,9 @@ M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set row-column ( result-set n -- obj ) >r result-set-handle r> sqlite-column ; -M: sqlite-result-set row-column-typed ( result-set n type -- obj ) - >r result-set-handle r> sqlite-column-typed ; +M: sqlite-result-set row-column-typed ( result-set n -- obj ) + dup pick result-set-out-params nth sql-spec-type + >r >r result-set-handle r> r> sqlite-column-typed ; M: sqlite-result-set advance-row ( result-set -- ) [ result-set-handle sqlite-next ] keep @@ -86,78 +107,84 @@ 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% ; + +: where-clause ( specs -- ) + " where " 0% + [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ; + +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-clause ] 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 +195,29 @@ 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" } + { DATE "date" } + { TIME "time" } + { DATETIME "datetime" } + { TIMESTAMP "timestamp" } { DOUBLE "real" } + { BLOB "blob" } + { FACTOR-BLOB "blob" } } ; -M: sqlite-db >sql-type ( obj -- str ) - dup pair? [ - first >sql-type - ] [ - sqlite-type-hash at* [ T{ no-sql-type } throw ] unless - ] if ; - -! HOOK: get-column-value ( n result-set type -- ) -! M: sqlite get-column-value { { "TEXT" get-text-column } { -! "INTEGER" get-integer-column } ... } case ; +M: sqlite-db create-type-table + type-table ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index ea57193750..584282e1c8 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,70 +1,239 @@ ! 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 math +prettyprint tools.walker db.sqlite calendar +math.intervals db.postgresql ; +IN: db.tuples.tests -TUPLE: person the-id the-name the-number real ; -: ( name age real -- person ) +TUPLE: person the-id the-name the-number the-real +ts date time blob factor-blob ; + +: ( name age real ts date time blob -- person ) { set-person-the-name set-person-the-number - set-person-real + set-person-the-real + set-person-ts + set-person-date + set-person-time + set-person-blob + set-person-factor-blob } person construct ; -: ( id name number real -- obj ) +: ( id name age real ts date time blob factor-blob -- person ) [ set-person-the-id ] keep ; -SYMBOL: the-person +SYMBOL: person1 +SYMBOL: person2 +SYMBOL: person3 +SYMBOL: person4 : test-tuples ( -- ) [ person drop-table ] [ drop ] recover [ ] [ person create-table ] unit-test + [ person create-table ] must-fail - [ ] [ the-person get insert-tuple ] unit-test + [ ] [ person1 get insert-tuple ] unit-test - [ 1 ] [ the-person get person-the-id ] unit-test + [ 1 ] [ person1 get person-the-id ] unit-test - 200 the-person get set-person-the-number + 200 person1 get set-person-the-number - [ ] [ the-person get update-tuple ] unit-test + [ ] [ 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 + [ ] [ 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 ; + [ + { + T{ person f 2 "johnny" 10 3.14 } + } + ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test + + + [ ] [ person1 get delete-tuple ] unit-test + [ f ] [ T{ person f 1 } select-tuple ] unit-test + + [ ] [ person3 get insert-tuple ] unit-test + + [ + T{ + person + f + 3 + "teddy" + 10 + 3.14 + T{ timestamp f 2008 3 5 16 24 11 0 } + T{ timestamp f 2008 11 22 f f f f } + T{ timestamp f f f f 12 34 56 f } + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } + } + ] [ T{ person f 3 } select-tuple ] unit-test + + [ ] [ person4 get insert-tuple ] unit-test + [ + T{ + person + f + 4 + "eddie" + 10 + 3.14 + T{ timestamp f 2008 3 5 16 24 11 0 } + T{ timestamp f 2008 11 22 f f f f } + T{ timestamp f f f f 12 34 56 f } + f + H{ { 1 2 } { 3 4 } { 5 "lol" } } + } + ] [ T{ person f 4 } 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 } } + { "ts" "TS" TIMESTAMP } + { "date" "D" DATE } + { "time" "T" TIME } + { "blob" "B" BLOB } + { "factor-blob" "FB" FACTOR-BLOB } + } define-persistent + "billy" 10 3.14 f f f f f person1 set + "johnny" 10 3.14 f f f f f person2 set + "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set + "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 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 } } + { "ts" "TS" TIMESTAMP } + { "date" "D" DATE } + { "time" "T" TIME } + { "blob" "B" BLOB } + { "factor-blob" "FB" FACTOR-BLOB } + } define-persistent + 1 "billy" 10 3.14 f f f f f person1 set + 2 "johnny" 10 3.14 f f f f f person2 set + 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set + 4 "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 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" temp-file sqlite-db r> with-db ; : test-postgresql ( -- ) - "localhost" "postgres" "" "factor-test" [ - test-tuples - ] with-db ; +>r { "localhost" "postgres" "foob" "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 +[ native-person-schema test-tuples ] test-postgresql +[ assigned-person-schema test-tuples ] test-postgresql -! test-sqlite - test-postgresql +TUPLE: serialize-me id data ; -! 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 +: test-serialize ( -- ) + serialize-me "SERIALIZED" + { + { "id" "ID" +native-id+ } + { "data" "DATA" FACTOR-BLOB } + } define-persistent + [ serialize-me drop-table ] [ drop ] recover + [ ] [ serialize-me create-table ] unit-test -! 1 "billy" 20 6.28 the-person set + [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test + [ + { T{ serialize-me f 1 H{ { 1 2 } } } } + ] [ T{ serialize-me f 1 } select-tuples ] unit-test ; -! test-sqlite -! test-postgresql +[ test-serialize ] test-sqlite +[ test-serialize ] test-postgresql + +TUPLE: exam id name score ; + +: test-ranges ( -- ) + exam "EXAM" + { + { "id" "ID" +native-id+ } + { "name" "NAME" TEXT } + { "score" "SCORE" INTEGER } + } define-persistent + [ exam drop-table ] [ drop ] recover + [ ] [ exam create-table ] unit-test + + [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test + + [ + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test + ; + +! [ test-ranges ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 20cdd8a386..32055ccedc 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -1,115 +1,108 @@ ! 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 ; +HOOK: db ( tuple -- tuple ) -: set-primary-key ( obj tuple -- ) - [ class primary-key-spec first ] keep - set-slot-named ; +HOOK: insert-tuple* db ( tuple statement -- ) -: cache-statement ( columns class assoc quot -- statement ) - [ db-table dupd ] swap - [ ] 3compose cache nip ; inline +: resulting-tuple ( row out-params -- tuple ) + dup first sql-spec-class construct-empty [ + [ + >r sql-spec-slot-name r> set-slot-named + ] curry 2each + ] keep ; -HOOK: create-sql db ( columns table -- seq ) -HOOK: drop-sql db ( columns table -- seq ) +: query-tuples ( statement -- seq ) + [ statement-out-params ] keep query-results [ + [ sql-row-typed swap resulting-tuple ] with query-map + ] with-disposal ; + +: query-modify-tuple ( tuple statement -- ) + [ query-results [ sql-row-typed ] with-disposal ] keep + statement-out-params rot [ + >r sql-spec-slot-name r> set-slot-named + ] curry 2each ; -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 ) +: sql-props ( class -- columns table ) + dup db-columns swap db-table ; -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: make-slot-names* db ( quot -- seq ) -HOOK: column-slot-name% db ( spec -- ) -HOOK: column-bind-name% db ( spec -- ) - -: make-slots-names ( quot -- seq str ) - [ make-slot-names* ] "" make ; inline -: slot-name% ( seq -- ) first % ; -: column-name% ( seq -- ) second % ; -: column-type% ( seq -- ) third % ; - -: 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..7014aaa943 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -1,67 +1,155 @@ ! 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 calendar.format symbols ; IN: db.types -! ID is the Primary key -SYMBOL: +native-id+ -SYMBOL: +assigned-id+ +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 ; + +SYMBOLS: +native-id+ +assigned-id+ +autoincrement+ ++serial+ +unique+ +default+ +null+ +not-null+ ++foreign-id+ +has-many+ ; + +: (primary-key?) ( obj -- ? ) + { +native-id+ +assigned-id+ } member? ; : primary-key? ( spec -- ? ) - [ { +native-id+ +assigned-id+ } member? ] contains? ; + sql-spec-primary-key (primary-key?) ; -: contains-id? ( columns id -- ? ) - swap [ member? ] with contains? ; - -: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ; -: native-id? ( columns -- ? ) +native-id+ contains-id? ; +: 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 ; -! Same concept, SQLite has autoincrement, PostgreSQL has serial -SYMBOL: +autoincrement+ -SYMBOL: +serial+ -SYMBOL: +unique+ +: find-primary-key ( specs -- obj ) + [ sql-spec-primary-key ] find nip ; -SYMBOL: +default+ -SYMBOL: +null+ -SYMBOL: +not-null+ +: native-id? ( spec -- ? ) + sql-spec-primary-key +native-id+ = ; -SYMBOL: +has-many+ +: assigned-id? ( spec -- ? ) + sql-spec-primary-key +assigned-id+ = ; -SYMBOL: SERIAL -SYMBOL: INTEGER -SYMBOL: DOUBLE -SYMBOL: BOOLEAN +: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; -SYMBOL: TEXT -SYMBOL: VARCHAR +SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR +DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; -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 ; 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 ; + +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 ; 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-docs.factor b/extra/destructors/destructors-docs.factor index 4c51e7ddfb..f96931c412 100755 --- a/extra/destructors/destructors-docs.factor +++ b/extra/destructors/destructors-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax libc kernel ; +USING: help.markup help.syntax libc kernel continuations ; IN: destructors HELP: free-always @@ -23,7 +23,7 @@ HELP: close-later HELP: with-destructors { $values { "quot" "a quotation" } } -{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link destruct } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } +{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } { $notes "Destructors are not allowed to throw exceptions. No exceptions." } { $examples { $code "[ 10 malloc free-always ] with-destructors" } diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index db4f023dad..147e183688 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? ; @@ -9,7 +9,7 @@ TUPLE: dummy-destructor obj ; C: dummy-destructor -M: dummy-destructor destruct ( obj -- ) +M: dummy-destructor dispose ( obj -- ) dummy-destructor-obj t swap set-dummy-obj-destroyed? ; : destroy-always diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index 0f8ec3af84..b2561c7439 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -4,18 +4,16 @@ USING: continuations io.backend libc kernel namespaces sequences system vectors ; IN: destructors -GENERIC: destruct ( obj -- ) - SYMBOL: error-destructors SYMBOL: always-destructors TUPLE: destructor object destroyed? ; -M: destructor destruct +M: destructor dispose dup destructor-destroyed? [ drop ] [ - dup destructor-object destruct + dup destructor-object dispose t swap set-destructor-destroyed? ] if ; @@ -29,10 +27,10 @@ M: destructor destruct always-destructors get push ; : do-always-destructors ( -- ) - always-destructors get [ destruct ] each ; + always-destructors get [ dispose ] each ; : do-error-destructors ( -- ) - error-destructors get [ destruct ] each ; + error-destructors get [ dispose ] each ; : with-destructors ( quot -- ) [ @@ -47,7 +45,7 @@ TUPLE: memory-destructor alien ; C: memory-destructor -M: memory-destructor destruct ( obj -- ) +M: memory-destructor dispose ( obj -- ) memory-destructor-alien free ; : free-always ( alien -- ) @@ -63,7 +61,7 @@ C: handle-destructor HOOK: destruct-handle io-backend ( obj -- ) -M: handle-destructor destruct ( obj -- ) +M: handle-destructor dispose ( obj -- ) handle-destructor-alien destruct-handle ; : close-always ( handle -- ) @@ -79,7 +77,7 @@ C: socket-destructor HOOK: destruct-socket io-backend ( obj -- ) -M: socket-destructor destruct ( obj -- ) +M: socket-destructor dispose ( obj -- ) socket-destructor-alien destruct-socket ; : close-socket-always ( handle -- ) diff --git a/unmaintained/gap-buffer/authors.txt b/extra/digraphs/authors.txt similarity index 100% rename from unmaintained/gap-buffer/authors.txt rename to extra/digraphs/authors.txt diff --git a/extra/digraphs/digraphs-tests.factor b/extra/digraphs/digraphs-tests.factor new file mode 100644 index 0000000000..b113c18ca7 --- /dev/null +++ b/extra/digraphs/digraphs-tests.factor @@ -0,0 +1,9 @@ +USING: digraphs kernel sequences tools.test ; +IN: digraphs.tests + +: test-digraph ( -- digraph ) + + { { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } [ first2 pick add-vertex ] each + { { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } [ first2 pick add-edge ] each ; + +[ 5 ] [ test-digraph topological-sort length ] unit-test diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor new file mode 100644 index 0000000000..5c6fa9b2a1 --- /dev/null +++ b/extra/digraphs/digraphs.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel new-slots sequences vectors ; +IN: digraphs + +TUPLE: digraph ; +TUPLE: vertex value edges ; + +: ( -- digraph ) + digraph construct-empty H{ } clone over set-delegate ; + +: ( value -- vertex ) + V{ } clone vertex construct-boa ; + +: add-vertex ( key value digraph -- ) + >r swap r> set-at ; + +: children ( key digraph -- seq ) + at edges>> ; + +: @edges ( from to digraph -- to edges ) swapd at edges>> ; +: add-edge ( from to digraph -- ) @edges push ; +: delete-edge ( from to digraph -- ) @edges delete ; + +: delete-to-edges ( to digraph -- ) + [ nip dupd edges>> delete ] assoc-each drop ; + +: delete-vertex ( key digraph -- ) + 2dup delete-at delete-to-edges ; + +: unvisited? ( unvisited key -- ? ) swap key? ; +: visited ( unvisited key -- ) swap delete-at ; + +DEFER: (topological-sort) +: visit-children ( seq unvisited key -- seq unvisited ) + over children [ (topological-sort) ] each ; + +: (topological-sort) ( seq unvisited key -- seq unvisited ) + 2dup unvisited? [ + [ visit-children ] keep 2dup visited pick push + ] [ + drop + ] if ; + +: topological-sort ( digraph -- seq ) + dup clone V{ } clone spin + [ drop (topological-sort) ] assoc-each drop reverse ; + +: topological-sorted-values ( digraph -- seq ) + dup topological-sort swap [ at value>> ] curry map ; diff --git a/extra/digraphs/summary.txt b/extra/digraphs/summary.txt new file mode 100644 index 0000000000..78e5a53313 --- /dev/null +++ b/extra/digraphs/summary.txt @@ -0,0 +1 @@ +Simple directed graph implementation for topological sorting 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/documents/documents.factor b/extra/documents/documents.factor index 34ecce5f8e..993e69ec14 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel math models namespaces sequences strings -splitting io.streams.lines combinators unicode.categories ; +splitting combinators unicode.categories ; IN: documents : +col ( loc n -- newloc ) >r first2 r> + 2array ; diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor old mode 100644 new mode 100755 index 7d95c8ce8a..3b65466225 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -35,6 +35,9 @@ SYMBOL: edit-hook : edit ( defspec -- ) where [ first2 edit-location ] when* ; +: edit-vocab ( name -- ) + vocab-source-path 1 edit-location ; + : :edit ( -- ) error get delegates [ parse-error? ] find-last nip [ dup parse-error-file source-file-path ?resource-path @@ -43,7 +46,7 @@ SYMBOL: edit-hook : fix ( word -- ) "Fixing " write dup pprint " and all usages..." print nl - dup smart-usage swap add* [ + dup usage swap add* [ "Editing " write dup . "RETURN moves on to the next usage, C+d stops." print flush diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor index 5a8168a181..eb31b2aa47 100755 --- a/extra/editors/editpadpro/editpadpro.factor +++ b/extra/editors/editpadpro/editpadpro.factor @@ -6,7 +6,7 @@ IN: editors.editpadpro : editpadpro-path \ editpadpro-path get-global [ program-files "JGsoft" path+ - [ >lower "editpadpro.exe" tail? ] find-file-breadth + t [ >lower "editpadpro.exe" tail? ] find-file ] unless* ; : editpadpro ( file line -- ) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor old mode 100644 new mode 100755 index e68bf04732..030c968e81 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -5,5 +5,5 @@ IN: editors.gvim.windows M: windows-io gvim-path \ gvim-path get-global [ program-files "vim" path+ - [ "gvim.exe" tail? ] find-file-breadth + t [ "gvim.exe" tail? ] find-file ] unless* ; diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor index fd5b6c1b06..3ce2c40192 100644 --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -1,30 +1,31 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions io kernel math namespaces parser prettyprint sequences strings words -editors io.files io.sockets io.streams.string io.binary -math.parser ; +editors io.files io.sockets io.streams.byte-array io.binary +math.parser io.encodings.ascii io.encodings.binary +io.encodings.utf8 ; IN: editors.jedit : jedit-server-info ( -- port auth ) - home "/.jedit/server" path+ [ + home "/.jedit/server" path+ ascii [ readln drop readln string>number readln string>number ] with-file-reader ; : make-jedit-request ( files -- code ) - [ + utf8 [ "EditServer.handleClient(false,false,false," write cwd pprint "," write "new String[] {" write [ pprint "," write ] each "null});\n" write - ] with-string-writer ; + ] with-byte-writer ; : send-jedit-request ( request -- ) - jedit-server-info swap "localhost" swap [ + jedit-server-info "localhost" rot binary [ 4 >be write dup length 2 >be write write diff --git a/extra/factory/factory-menus b/extra/factory/factory-menus index fa72fa6c9a..35ee75e31b 100644 --- a/extra/factory/factory-menus +++ b/extra/factory/factory-menus @@ -25,14 +25,14 @@ apps-menu> not [ new-wm-menu >apps-menu ] when { { "Emacs" [ "emacs &" system drop ] } { "KMail" [ "kmail &" system drop ] } { "Akregator" [ "akregator &" system drop ] } - { "Amarok" [ "amarok &" system drop ] } - { "K3b" [ "k3b &" system drop ] } - { "xchat" [ "xchat &" system drop ] } + { "Amarok" [ "amarok &" system drop ] } + { "K3b" [ "k3b &" system drop ] } + { "xchat" [ "xchat &" system drop ] } { "Nautilus" [ "nautilus --no-desktop &" system drop ] } - { "synaptic" [ "gksudo synaptic &" system drop ] } + { "synaptic" [ "gksudo synaptic &" system drop ] } { "Volume control" [ "gnome-volume-control &" system drop ] } { "Azureus" [ "~/azureus/azureus &" system drop ] } - { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] } + { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] } { "Stop Xephyr" [ "pkill Xephyr &" system drop ] } { "Stop Firefox" [ "pkill firefox &" system drop ] } } apps-menu> set-menu-items @@ -95,8 +95,8 @@ factory-menu> not [ new-wm-menu >factory-menu ] when { { "Maximize" [ maximize ] } { "Maximize Vertical" [ maximize-vertical ] } { "Restore" [ restore ] } - { "Hide" [ minimize ] } - { "Tile Master" [ tile-master ] } + { "Hide" [ minimize ] } + { "Tile Master" [ tile-master ] } } factory-menu> set-menu-items @@ -106,17 +106,17 @@ factory-menu> set-menu-items ! VAR: root-menu { { "xterm" [ "urxvt -bd grey +sb &" system drop ] } - { "Firefox" [ "firefox &" system drop ] } - { "xclock" [ "xclock &" system drop ] } - { "Apps >" [ apps-menu> <- popup ] } + { "Firefox" [ "firefox &" system drop ] } + { "xclock" [ "xclock &" system drop ] } + { "Apps >" [ apps-menu> <- popup ] } { "Factor >" [ factor-menu> <- popup ] } { "Unmapped frames >" [ unmapped-frames-menu> <- popup ] } - { "Emacs >" [ emacs-menu> <- popup ] } - { "Mail >" [ mail-menu> <- popup ] } - { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &" - system drop ] } - { "Edit menus" [ edit-factory-menus ] } + { "Emacs >" [ emacs-menu> <- popup ] } + { "Mail >" [ mail-menu> <- popup ] } + { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &" + system drop ] } + { "Edit menus" [ edit-factory-menus ] } { "Reload menus" [ load-factory-menus ] } - { "Factory >" [ factory-menu> <- popup ] } + { "Factory >" [ factory-menu> <- popup ] } } root-menu> set-menu-items diff --git a/extra/webapps/callback/authors.txt b/extra/farkup/authors.factor old mode 100755 new mode 100644 similarity index 50% rename from extra/webapps/callback/authors.txt rename to extra/farkup/authors.factor index a8fb961d36..5674120196 --- a/extra/webapps/callback/authors.txt +++ b/extra/farkup/authors.factor @@ -1,2 +1,2 @@ -Chris Double +Doug Coleman Slava Pestov diff --git a/extra/assoc-heaps/authors.txt b/extra/farkup/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/assoc-heaps/authors.txt rename to extra/farkup/authors.txt diff --git a/extra/farkup/farkup-docs.factor b/extra/farkup/farkup-docs.factor new file mode 100644 index 0000000000..b2b662db82 --- /dev/null +++ b/extra/farkup/farkup-docs.factor @@ -0,0 +1,6 @@ +USING: help.markup help.syntax ; +IN: farkup + +HELP: convert-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..bdb08bd29a --- /dev/null +++ b/extra/farkup/farkup-tests.factor @@ -0,0 +1,58 @@ +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 + +[ "

foo

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

lol

foo

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

=foo\n

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

=foo

" ] [ "=foo" convert-farkup ] unit-test +[ "

==foo

" ] [ "==foo" convert-farkup ] unit-test +[ "

=

foo

" ] [ "==foo=" convert-farkup ] unit-test +[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test +[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test +[ "

=

foo

" ] [ "===foo==" convert-farkup ] unit-test + + +[ "

foo

=

" ] [ "=foo==" convert-farkup ] unit-test + diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor new file mode 100755 index 0000000000..ac91a77685 --- /dev/null +++ b/extra/farkup/farkup.factor @@ -0,0 +1,138 @@ +! 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 ; + +MEMO: eq ( -- parser ) + [ + h1 ensure-not , + h2 ensure-not , + h3 ensure-not , + h4 ensure-not , + "=" token , + ] seq* ; + +: 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 , eq , + ] choice* repeat1 ; + +MEMO: paragraph ( -- parser ) + line + "\n" token over 2seq repeat0 + "\n" token "\n" token ensure-not 2seq optional 3seq + [ + dup [ dup string? not swap [ blank? ] all? or ] deep-all? + [ "

" swap "

" 3array ] unless + ] action ; + +PEG: parse-farkup ( -- parser ) + [ + list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , + ] choice* repeat0 "\n" token optional 2seq ; + +: write-farkup ( parse-result -- ) + [ dup string? [ write ] [ drop ] if ] deep-each ; + +: convert-farkup ( string -- string' ) + parse-farkup [ write-farkup ] with-string-writer ; diff --git a/extra/farkup/summary.txt b/extra/farkup/summary.txt new file mode 100644 index 0000000000..c6e75d28a9 --- /dev/null +++ b/extra/farkup/summary.txt @@ -0,0 +1 @@ +Simple markup language for generating HTML diff --git a/extra/farkup/tags.txt b/extra/farkup/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/farkup/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/fjsc/fjsc-tests.factor b/extra/fjsc/fjsc-tests.factor index ccb004581a..ce968128be 100755 --- a/extra/fjsc/fjsc-tests.factor +++ b/extra/fjsc/fjsc-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test peg fjsc ; -IN: temporary +IN: fjsc.tests { T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ "55 2abc1 100" 'expression' parse parse-result-ast diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index 5b5900f0bc..3811949c1d 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg strings promises sequences math math.parser namespaces words quotations arrays hashtables io - io.streams.string assocs memoize ascii ; + io.streams.string assocs memoize ascii peg.parsers ; IN: fjsc TUPLE: ast-number value ; diff --git a/extra/fry/authors.txt b/extra/fry/authors.txt new file mode 100644 index 0000000000..e1907c6d91 --- /dev/null +++ b/extra/fry/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Eduardo Cavazos diff --git a/extra/fry/fry-docs.factor b/extra/fry/fry-docs.factor new file mode 100755 index 0000000000..31b544d488 --- /dev/null +++ b/extra/fry/fry-docs.factor @@ -0,0 +1,108 @@ +USING: help.markup help.syntax quotations kernel ; +IN: fry + +HELP: , +{ $description "Fry specifier. Inserts a literal value into the fried quotation." } ; + +HELP: @ +{ $description "Fry specifier. Splices a quotation into the fried quotation." } ; + +HELP: _ +{ $description "Fry specifier. Shifts all fry specifiers to the left down by one stack position." } ; + +HELP: fry +{ $values { "quot" quotation } { "quot'" quotation } } +{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." } +{ $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:" + { $code "[ X ] fry call" "'[ X ]" } +} ; + +HELP: '[ +{ $syntax "code... ]" } +{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ; + +ARTICLE: "fry.examples" "Examples of fried quotations" +"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples." +$nl +"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":" +{ $code "{ 10 20 30 } '[ . ] each" } +"Occurrences of " { $link , } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:" +{ $code + "{ 10 20 30 } 5 '[ , + ] map" + "{ 10 20 30 } 5 [ + ] curry map" + "{ 10 20 30 } [ 5 + ] map" +} +"Occurrences of " { $link , } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:" +{ $code + "{ 10 20 30 } 5 '[ 3 , / ] map" + "{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map" + "{ 10 20 30 } [ 3 5 / ] map" +} +"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:" +{ $code + "{ 10 20 30 } [ sq ] '[ @ . ] map" + "{ 10 20 30 } [ sq ] [ . ] compose map" + "{ 10 20 30 } [ sq . ] map" +} +"The " { $link , } " and " { $link @ } " specifiers may be freely mixed:" +{ $code + "{ 8 13 14 27 } [ even? ] 5 [ @ dup , ? ] map" + "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map" + "{ 8 13 14 27 } [ even? dup 5 ? ] map" +} +"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":" +{ $code + "{ 10 20 30 } 1 '[ , _ / ] map" + "{ 10 20 30 } 1 [ swap / ] curry map" + "{ 10 20 30 } [ 1 swap / ] map" +} +"For any quotation body " { $snippet "X" } ", the following two are equivalent:" +{ $code + "[ >r X r> ]" + "[ X _ ]" +} +"Here are some built-in combinators rewritten in terms of fried quotations:" +{ $table + { { $link literalize } { $snippet ": literalize '[ , ] ;" } } + { { $link slip } { $snippet ": slip '[ @ , ] call ;" } } + { { $link dip } { $snippet ": dip '[ @ _ ] call ;" } } + { { $link curry } { $snippet ": curry '[ , @ ] ;" } } + { { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } } + { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } + { { $link 2apply } { $snippet ": 2apply tuck '[ , @ , @ ] call ;" } } +} ; + +ARTICLE: "fry.philosophy" "Fried quotation philosophy" +"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "." +$nl +"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:" +{ $code + "'[ 3 , + 4 , / ]" + "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]" +} +"The " { $link _ } " fry specifier has no direct analogue in " { $vocab-link "locals" } ", however closure conversion together with the " { $link dip } " combinator achieve the same effect:" +{ $code + "'[ , 2 + , * _ / ]" + "[let | a [ ] b [ ] | [ [ a 2 + b * ] dip / ] ]" +} ; + +ARTICLE: "fry.limitations" "Fried quotation limitations" +"As with " { $link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". Unlike " { $link "locals" } ", using " { $link dip } " is not a suitable workaround since unlike closure conversion, fry conversion is not recursive, and so the quotation passed to " { $link dip } " cannot contain fry specifiers." ; + +ARTICLE: "fry" "Fried quotations" +"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation." +$nl +"Fried quotations are denoted with a special parsing word:" +{ $subsection POSTPONE: '[ } +"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":" +{ $subsection , } +{ $subsection @ } +{ $subsection _ } +"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left." +{ $subsection "fry.examples" } +{ $subsection "fry.philosophy" } +{ $subsection "fry.limitations" } +"Quotations can also be fried without using a parsing word:" +{ $subsection fry } ; + +ABOUT: "fry" diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor new file mode 100755 index 0000000000..4d2c9fe1c8 --- /dev/null +++ b/extra/fry/fry-tests.factor @@ -0,0 +1,46 @@ +IN: fry.tests +USING: fry tools.test math prettyprint kernel io arrays +sequences ; + +[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test + +[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test + +[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test + +[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test + +[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test + +[ [ "a" write "b" print ] ] +[ "a" "b" '[ , write , print ] ] unit-test + +[ [ 1 2 + 3 4 - ] ] +[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test + +[ 1/2 ] [ + 1 '[ , _ / ] 2 swap call +] unit-test + +[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [ + 1 '[ , _ _ 3array ] + { "a" "b" "c" } { "A" "B" "C" } rot 2map +] unit-test + +[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [ + '[ 1 _ 2array ] + { "a" "b" "c" } swap map +] unit-test + +[ 1 2 ] [ + 1 2 '[ _ , ] call +] unit-test + +[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [ + 1 2 '[ , _ , 3array ] + { "a" "b" "c" } swap map +] unit-test + +: funny-dip '[ @ _ ] call ; inline + +[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor new file mode 100755 index 0000000000..490ce992ab --- /dev/null +++ b/extra/fry/fry.factor @@ -0,0 +1,49 @@ +! 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 qualified ; +QUALIFIED: 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)) ] } + + ! to avoid confusion, remove if fry goes core + { namespaces:, [ [ curry ] ((fry)) ] } + + [ swap >r add r> (fry) ] + } case + ] if ; + +: trivial-fry ( quot -- quot' ) [ ] swap (fry) ; + +: fry ( quot -- quot' ) + { _ } last-split1 [ + [ + trivial-fry % + [ >r ] % + fry % + [ [ dip ] curry r> compose ] % + ] [ ] make + ] [ + trivial-fry + ] if* ; + +: '[ \ ] parse-until fry over push-all ; parsing diff --git a/extra/fry/summary.txt b/extra/fry/summary.txt new file mode 100644 index 0000000000..340948a43c --- /dev/null +++ b/extra/fry/summary.txt @@ -0,0 +1 @@ +Syntax for pictured partial application and composition diff --git a/extra/fry/tags.txt b/extra/fry/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/extra/fry/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor deleted file mode 100644 index 4afbd653bd..0000000000 --- a/extra/furnace/furnace-tests.factor +++ /dev/null @@ -1,47 +0,0 @@ -USING: kernel sequences namespaces math tools.test furnace furnace.validator ; -IN: temporary - -TUPLE: test-tuple m n ; - -[ H{ { "m" 3 } { "n" 2 } } ] -[ - [ T{ test-tuple f 3 2 } explode-tuple ] H{ } make-assoc -] unit-test - -[ - { 3 } -] [ - H{ { "n" "3" } } { { "n" v-number } } - [ action-param drop ] with map -] unit-test - -: foo ; - -\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action - -[ t ] [ [ 1 2 foo ] action-call? ] unit-test -[ f ] [ [ 2 + ] action-call? ] unit-test - -[ - { "2" "hello" } -] [ - [ - H{ - { "bar" "hello" } - } \ foo query>seq - ] with-scope -] unit-test - -[ - H{ { "foo" "1" } { "bar" "2" } } -] [ - { "1" "2" } \ foo quot>query -] unit-test - -[ - "/responder/temporary/foo?foo=3" -] [ - [ - [ "3" foo ] quot-link - ] with-scope -] unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor deleted file mode 100755 index 9b7a8a8aa5..0000000000 --- a/extra/furnace/furnace.factor +++ /dev/null @@ -1,215 +0,0 @@ -! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs calendar debugger furnace.sessions -furnace.validator hashtables heaps html.elements http -http.server.responders http.server.templating io.files kernel -math namespaces quotations sequences splitting words strings -vectors webapps.callback continuations tuples classes vocabs -html io ; -IN: furnace - -: code>quotation ( word/quot -- quot ) - dup word? [ 1quotation ] when ; - -SYMBOL: default-action -SYMBOL: template-path - -: render-template ( template -- ) - template-path get swap path+ - ".furnace" append resource-path - run-template-file ; - -: define-action ( word hash -- ) - over t "action" set-word-prop - "action-params" set-word-prop ; - -: define-form ( word1 word2 hash -- ) - dupd define-action - swap code>quotation "form-failed" set-word-prop ; - -: default-values ( word hash -- ) - "default-values" set-word-prop ; - -SYMBOL: request-params -SYMBOL: current-action -SYMBOL: validators-errored -SYMBOL: validation-errors - -: action-link ( query action -- url ) - [ - "/responder/" % - dup word-vocabulary "webapps." ?head drop % - "/" % - word-name % - ] "" make swap build-url ; - -: action-param ( hash paramsepc -- obj error/f ) - unclip rot at swap >quotation apply-validators ; - -: query>seq ( hash word -- seq ) - "action-params" word-prop [ - dup first -rot - action-param [ - t validators-errored >session - rot validation-errors session> set-at - ] [ - nip - ] if* - ] with map ; - -: expire-sessions ( -- ) - sessions get-global - [ nip session-last-seen 20 minutes ago <=> 0 > ] - [ 2drop ] heap-pop-while ; - -: lookup-session ( hash -- session ) - "furnace-session-id" over at sessions get-global at [ - nip - ] [ - new-session rot "furnace-session-id" swap set-at - ] if* ; - -: quot>query ( seq action -- hash ) - >r >array r> "action-params" word-prop - [ first swap 2array ] 2map >hashtable ; - -PREDICATE: word action "action" word-prop ; - -: action-call? ( quot -- ? ) - >vector dup pop action? >r [ word? not ] all? r> and ; - -: unclip* dup 1 head* swap peek ; - -: quot-link ( quot -- url ) - dup action-call? [ - unclip* [ quot>query ] keep action-link - ] [ - t register-html-callback - ] if ; - -: replace-variables ( quot -- quot ) - [ dup string? [ request-params session> at ] when ] map ; - -: furnace-session-id ( -- hash ) - "furnace-session-id" request-params session> at - "furnace-session-id" associate ; - -: redirect-to-action ( -- ) - current-action session> - "form-failed" word-prop replace-variables - quot-link furnace-session-id build-url permanent-redirect ; - -: if-form-page ( if then -- ) - current-action session> "form-failed" word-prop -rot if ; - -: do-action - current-action session> [ query>seq ] keep add >quotation call ; - -: process-form ( -- ) - H{ } clone validation-errors >session - request-params session> current-action session> query>seq - validators-errored session> [ - drop redirect-to-action - ] [ - current-action session> add >quotation call - ] if ; - -: page-submitted ( -- ) - [ process-form ] [ request-params session> do-action ] if-form-page ; - -: action-first-time ( -- ) - request-params session> current-action session> - [ "default-values" word-prop swap union request-params >session ] keep - request-params session> do-action ; - -: page-not-submitted ( -- ) - [ redirect-to-action ] [ action-first-time ] if-form-page ; - -: setup-call-action ( hash word -- ) - over lookup-session session set - current-action >session - request-params session> swap union - request-params >session - f validators-errored >session ; - -: call-action ( hash word -- ) - setup-call-action - "furnace-form-submitted" request-params session> at - [ page-submitted ] [ page-not-submitted ] if ; - -: responder-vocab ( str -- newstr ) - "webapps." swap append ; - -: lookup-action ( str webapp -- word ) - responder-vocab lookup dup [ - dup "action" word-prop [ drop f ] unless - ] when ; - -: truncate-url ( str -- newstr ) - CHAR: / over index [ head ] when* ; - -: parse-action ( str -- word/f ) - dup empty? [ drop default-action get ] when - truncate-url "responder" get lookup-action ; - -: service-request ( hash str -- ) - parse-action [ - [ call-action ] [ 
 print-error
] recover - ] [ - "404 no such action: " "argument" get append httpd-error - ] if* ; - -: service-get - "query" get swap service-request ; - -: service-post - "response" get swap service-request ; - -: web-app ( name defaul path -- ) - [ - template-path set - default-action set - "responder" set - [ service-get ] "get" set - [ service-post ] "post" set - ] make-responder ; - -: explode-tuple ( tuple -- ) - dup tuple-slots swap class "slot-names" word-prop - [ set ] 2each ; - -SYMBOL: model - -: with-slots ( model quot -- ) - [ - >r [ dup model set explode-tuple ] when* r> call - ] with-scope ; - -: render-component ( model template -- ) - swap [ render-template ] with-slots ; - -: browse-webapp-source ( vocab -- ) - - "Browse source" write - ; - -: send-resource ( name -- ) - template-path get swap path+ resource-path - stdio get stream-copy ; - -: render-link ( quot name -- ) - write ; - -: session-var ( str -- newstr ) - request-params session> at ; - -: render ( str -- ) - request-params session> at [ write ] when* ; - -: render-error ( str error-str -- ) - swap validation-errors session> at validation-error? [ - write - ] [ - drop - ] if ; - diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor deleted file mode 100644 index 523598efe7..0000000000 --- a/extra/furnace/sessions/sessions.factor +++ /dev/null @@ -1,40 +0,0 @@ -USING: assoc-heaps assocs calendar crypto.sha2 heaps -init kernel math.parser namespaces random ; -IN: furnace.sessions - -SYMBOL: sessions - -[ - H{ } clone - sessions set-global -] "furnace.sessions" add-init-hook - -: new-session-id ( -- str ) - 4 big-random number>string string>sha-256-string - dup sessions get-global at [ drop new-session-id ] when ; - -TUPLE: session created last-seen user-agent namespace ; - -M: session <=> ( session1 session2 -- n ) - [ session-last-seen ] 2apply <=> ; - -: ( -- obj ) - now dup H{ } clone - [ set-session-created set-session-last-seen set-session-namespace ] - \ session construct ; - -: new-session ( -- obj id ) - new-session-id [ sessions get-global set-at ] 2keep ; - -: get-session ( id -- obj/f ) - sessions get-global at* [ "no session found 1" throw ] unless ; - -! Delete from the assoc only, the heap will timeout -: destroy-session ( id -- ) - sessions get-global assoc-heap-assoc delete-at ; - -: session> ( str -- obj ) - session get session-namespace at ; - -: >session ( value key -- ) - session get session-namespace set-at ; diff --git a/extra/furnace/summary.txt b/extra/furnace/summary.txt deleted file mode 100755 index 5696506f79..0000000000 --- a/extra/furnace/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Action-based web framework diff --git a/extra/furnace/tags.txt b/extra/furnace/tags.txt deleted file mode 100644 index 0aef4feca8..0000000000 --- a/extra/furnace/tags.txt +++ /dev/null @@ -1 +0,0 @@ -enterprise diff --git a/extra/furnace/validator/validator-tests.factor b/extra/furnace/validator/validator-tests.factor deleted file mode 100644 index 06d8ac815d..0000000000 --- a/extra/furnace/validator/validator-tests.factor +++ /dev/null @@ -1,30 +0,0 @@ -IN: temporary -USING: kernel sequences tools.test furnace.validator furnace ; - -[ - 123 f -] [ - H{ { "foo" "123" } } { "foo" v-number } action-param -] unit-test - -: validation-fails - [ action-param nip not ] append [ f ] swap unit-test ; - -[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails - -[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails - -[ "ABCD" f ] -[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ] -unit-test - -[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ] -validation-fails - -[ "AB" f ] -[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ] -unit-test - -[ "AB" f ] -[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ] -unit-test diff --git a/extra/furnace/validator/validator.factor b/extra/furnace/validator/validator.factor deleted file mode 100644 index 698c77fa9a..0000000000 --- a/extra/furnace/validator/validator.factor +++ /dev/null @@ -1,43 +0,0 @@ -! Copyright (C) 2006 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences math namespaces math.parser ; -IN: furnace.validator - -TUPLE: validation-error reason ; - -: apply-validators ( string quot -- obj error/f ) - [ - call f - ] [ - dup validation-error? [ >r 2drop f r> ] [ rethrow ] if - ] recover ; - -: validation-error ( msg -- * ) - \ validation-error construct-boa throw ; - -: v-default ( obj value -- obj ) - over empty? [ nip ] [ drop ] if ; - -: v-required ( str -- str ) - dup empty? [ "required" validation-error ] when ; - -: v-min-length ( str n -- str ) - over length over < [ - [ "must be at least " % # " characters" % ] "" make - validation-error - ] [ - drop - ] if ; - -: v-max-length ( str n -- str ) - over length over > [ - [ "must be no more than " % # " characters" % ] "" make - validation-error - ] [ - drop - ] if ; - -: v-number ( str -- n ) - string>number [ - "must be a number" validation-error - ] unless* ; diff --git a/unmaintained/gap-buffer/cursortree/authors.txt b/extra/gap-buffer/authors.txt similarity index 100% rename from unmaintained/gap-buffer/cursortree/authors.txt rename to extra/gap-buffer/authors.txt diff --git a/extra/gap-buffer/cursortree/authors.txt b/extra/gap-buffer/cursortree/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/gap-buffer/cursortree/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/unmaintained/gap-buffer/cursortree/cursortree-tests.factor b/extra/gap-buffer/cursortree/cursortree-tests.factor similarity index 82% rename from unmaintained/gap-buffer/cursortree/cursortree-tests.factor rename to extra/gap-buffer/cursortree/cursortree-tests.factor index 36b5efd7fa..2b3ff69c97 100644 --- a/unmaintained/gap-buffer/cursortree/cursortree-tests.factor +++ b/extra/gap-buffer/cursortree/cursortree-tests.factor @@ -1,4 +1,6 @@ -USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ; +USING: assocs kernel gap-buffer.cursortree tools.test sequences trees +arrays strings ; +IN: gap-buffer.cursortree.tests [ t ] [ "this is a test string" 0 at-beginning? ] unit-test [ t ] [ "this is a test string" dup length at-end? ] unit-test @@ -6,7 +8,8 @@ USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ; [ CHAR: i ] [ "this is a test string" 3 element< ] unit-test [ CHAR: s ] [ "this is a test string" 3 element> ] unit-test [ t ] [ "this is a test string" 3 CHAR: a over set-element< CHAR: t over set-element> cursor-tree "that is a test string" sequence= ] unit-test -[ t ] [ "this is a test string" 3 8 over set-cursor-pos dup 1array swap cursor-tree cursortree-cursors tree-values sequence= ] unit-test +[ 0 ] [ "this is a test string" dup dup 3 remove-cursor cursors length ] unit-test +[ t ] [ "this is a test string" 3 8 over set-cursor-pos dup 1array swap cursor-tree cursors sequence= ] unit-test [ "this is no longer a test string" ] [ "this is a test string" 8 "no longer " over insert cursor-tree >string ] unit-test [ "refactor" ] [ "factor" 0 CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test [ "refactor" ] [ "factor" 0 CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test diff --git a/unmaintained/gap-buffer/cursortree/cursortree.factor b/extra/gap-buffer/cursortree/cursortree.factor similarity index 83% rename from unmaintained/gap-buffer/cursortree/cursortree.factor rename to extra/gap-buffer/cursortree/cursortree.factor index de567702a8..fb2abf1c3d 100644 --- a/unmaintained/gap-buffer/cursortree/cursortree.factor +++ b/extra/gap-buffer/cursortree/cursortree.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2007 Alex Chapman All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel gap-buffer generic trees trees.avl-tree math sequences quotations ; +USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math +sequences quotations ; IN: gap-buffer.cursortree TUPLE: cursortree cursors ; : ( seq -- cursortree ) - cursortree construct-empty tuck set-delegate + cursortree construct-empty tuck set-delegate over set-cursortree-cursors ; GENERIC: cursortree-gb ( cursortree -- gb ) @@ -18,12 +19,12 @@ TUPLE: cursor i tree ; TUPLE: left-cursor ; TUPLE: right-cursor ; -: cursor-index ( cursor -- i ) cursor-i ; inline +: cursor-index ( cursor -- i ) cursor-i ; -: add-cursor ( cursortree cursor -- ) dup cursor-index rot tree-insert ; +: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ; : remove-cursor ( cursortree cursor -- ) - dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ; + tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ; : set-cursor-index ( index cursor -- ) dup cursor-tree over remove-cursor tuck set-cursor-i @@ -48,14 +49,17 @@ M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] ke : ( cursortree pos -- right-cursor ) right-cursor construct-empty make-cursor ; +: cursors ( cursortree -- seq ) + cursortree-cursors values concat ; + : cursor-positions ( cursortree -- seq ) - cursortree-cursors tree-values [ cursor-pos ] map ; + cursors [ cursor-pos ] map ; M: cursortree move-gap ( n cursortree -- ) #! Get the position of each cursor before the move, then re-set the #! position afterwards. This will update any changed cursor indices. dup cursor-positions >r tuck cursortree-gb move-gap - cursortree-cursors tree-values r> swap [ set-cursor-pos ] 2each ; + cursors r> swap [ set-cursor-pos ] 2each ; : element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ; : element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ; @@ -80,7 +84,7 @@ M: right-cursor fix-cursor ( cursortree cursor -- ) >r gb-gap-end r> set-cursor-index ; : fix-cursors ( old-gap-end cursortree -- ) - tuck cursortree-cursors tree-get-all [ fix-cursor ] curry* each ; + tuck cursortree-cursors at [ fix-cursor ] with each ; M: cursortree delete* ( pos cursortree -- ) tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ; diff --git a/unmaintained/gap-buffer/cursortree/summary.txt b/extra/gap-buffer/cursortree/summary.txt similarity index 100% rename from unmaintained/gap-buffer/cursortree/summary.txt rename to extra/gap-buffer/cursortree/summary.txt diff --git a/unmaintained/gap-buffer/gap-buffer-tests.factor b/extra/gap-buffer/gap-buffer-tests.factor similarity index 100% rename from unmaintained/gap-buffer/gap-buffer-tests.factor rename to extra/gap-buffer/gap-buffer-tests.factor diff --git a/unmaintained/gap-buffer/gap-buffer.factor b/extra/gap-buffer/gap-buffer.factor similarity index 89% rename from unmaintained/gap-buffer/gap-buffer.factor rename to extra/gap-buffer/gap-buffer.factor index 75d5be4f7a..3d78204d3f 100644 --- a/unmaintained/gap-buffer/gap-buffer.factor +++ b/extra/gap-buffer/gap-buffer.factor @@ -4,7 +4,7 @@ ! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain ! for a good introduction see: ! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf -USING: kernel arrays sequences sequences.private circular math generic ; +USING: kernel arrays sequences sequences.private circular math math.functions generic ; IN: gap-buffer ! gap-start -- the first element of the gap @@ -44,15 +44,36 @@ M: gb like ( seq gb -- seq ) drop ; M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ; +: valid-position? ( pos gb -- ? ) + #! one element past the end of the buffer is a valid position when we're inserting + length -1 swap between? ; + +: valid-index? ( i gb -- ? ) + buffer-length -1 swap between? ; + +TUPLE: position-out-of-bounds position gap-buffer ; +C: position-out-of-bounds + : position>index ( pos gb -- i ) - 2dup gb-gap-start >= [ - gap-length + - ] [ drop ] if ; + 2dup valid-position? [ + 2dup gb-gap-start >= [ + gap-length + + ] [ drop ] if + ] [ + throw + ] if ; + +TUPLE: index-out-of-bounds index gap-buffer ; +C: index-out-of-bounds : index>position ( i gb -- pos ) - 2dup gb-gap-end >= [ - gap-length - - ] [ drop ] if ; + 2dup valid-index? [ + 2dup gb-gap-end >= [ + gap-length - + ] [ drop ] if + ] [ + throw + ] if ; M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ; @@ -159,6 +180,7 @@ INSTANCE: gb virtual-sequence : fix-gap ( n gb -- ) 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ; +! moving the gap to position 5 means that the element in position 5 will be immediately after the gap GENERIC: move-gap ( n gb -- ) M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ; diff --git a/unmaintained/gap-buffer/summary.txt b/extra/gap-buffer/summary.txt similarity index 100% rename from unmaintained/gap-buffer/summary.txt rename to extra/gap-buffer/summary.txt diff --git a/unmaintained/gap-buffer/tags.txt b/extra/gap-buffer/tags.txt similarity index 100% rename from unmaintained/gap-buffer/tags.txt rename to extra/gap-buffer/tags.txt 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/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index 8e61766de1..ec4d6b79e1 100644 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -4,7 +4,7 @@ USING: alien arrays byte-arrays combinators graphics.viewer io io.binary io.files kernel libc math math.functions namespaces opengl opengl.gl prettyprint -sequences strings ui ui.gadgets.panes ; +sequences strings ui ui.gadgets.panes io.encodings.binary ; IN: graphics.bitmap ! Currently can only handle 24bit bitmaps. @@ -59,7 +59,7 @@ TUPLE: bitmap magic size reserved offset header-length width dup color-index-length read swap set-bitmap-color-index ; : load-bitmap ( path -- bitmap ) - [ + binary [ T{ bitmap } clone dup parse-file-header dup parse-bitmap-header @@ -69,7 +69,7 @@ TUPLE: bitmap magic size reserved offset header-length width raw-bitmap>string >byte-array over set-bitmap-array ; : save-bitmap ( bitmap path -- ) - [ + binary [ "BM" write dup bitmap-array length 14 + 40 + 4 >le write 0 4 >le write diff --git a/extra/hash2/hash2-tests.factor b/extra/hash2/hash2-tests.factor old mode 100644 new mode 100755 index b7a4f42ac5..f3c17bb04b --- a/extra/hash2/hash2-tests.factor +++ b/extra/hash2/hash2-tests.factor @@ -1,4 +1,5 @@ USING: tools.test hash2 kernel ; +IN: hash2.tests : sample-hash 5 diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index a1ad007c62..43d8ca21ef 100755 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,13 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 2 } { deploy-io 1 } - { deploy-word-props? f } - { deploy-word-defs? f } - { "stop-after-last-window?" t } - { deploy-ui? t } { deploy-compiler? t } + { deploy-word-defs? f } + { deploy-word-props? f } + { deploy-math? t } { deploy-name "Hello world" } { deploy-c-types? f } + { deploy-ui? t } + { deploy-threads? t } + { deploy-reflection 1 } + { "stop-after-last-window?" t } } 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..72b300b585 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -191,13 +191,13 @@ ARTICLE: "cookbook-io" "Input and output cookbook" } "Print the lines of a file in sorted order:" { $code - "\"lines.txt\" file-lines natural-sort [ print ] each" + "utf8 \"lines.txt\" file-lines natural-sort [ print ] each" } "Read 1024 bytes from a file:" { $code - "\"data.bin\" [ 1024 read ] with-file-reader" + "\"data.bin\" binary [ 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-docs.factor b/extra/help/crossref/crossref-docs.factor index 5c1f687d05..4331a45490 100644 --- a/extra/help/crossref/crossref-docs.factor +++ b/extra/help/crossref/crossref-docs.factor @@ -1,4 +1,5 @@ -USING: help.crossref help.topics help.syntax help.markup ; +USING: help.topics help.syntax help.markup ; +IN: help.crossref HELP: article-children { $values { "topic" "an article name or a word" } { "seq" "a new sequence" } } @@ -12,7 +13,7 @@ HELP: help-path { $values { "topic" "an article name or a word" } { "seq" "a new sequence" } } { $description "Outputs a sequence of all help articles which contain " { $snippet "topic" } " as a subsection, traversing all the way up to the root." } { $examples - { $example "USE: help.crossref" "\"sequences\" help-path ." "{ \"collections\" \"handbook\" }" } + { $example "USING: help.crossref prettyprint ;" "\"sequences\" help-path ." "{ \"collections\" \"handbook\" }" } } ; HELP: xref-article 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-tests.factor b/extra/help/handbook/handbook-tests.factor new file mode 100644 index 0000000000..ae6c7d55f4 --- /dev/null +++ b/extra/help/handbook/handbook-tests.factor @@ -0,0 +1,8 @@ +IN: help.handbook.tests +USING: help tools.test ; + +[ ] [ "article-index" help ] unit-test +[ ] [ "primitive-index" help ] unit-test +[ ] [ "error-index" help ] unit-test +[ ] [ "type-index" help ] unit-test +[ ] [ "class-index" help ] unit-test diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 1e3d2cf312..d77cc9268d 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -2,7 +2,7 @@ USING: help help.markup help.syntax help.definitions help.topics namespaces words sequences classes assocs vocabs kernel arrays prettyprint.backend kernel.private io generic math system strings sbufs vectors byte-arrays bit-arrays float-arrays -quotations ; +quotations io.streams.byte-array io.encodings.string ; IN: help.handbook ARTICLE: "conventions" "Conventions" @@ -66,8 +66,7 @@ ARTICLE: "evaluator" "Evaluation semantics" { "All other types of objects are pushed on the data stack." } } "If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage." -$nl -"There are various ways of implementing these evaluation semantics. See " { $link "compiler" } " and " { $link "meta-interpreter" } "." ; +{ $see-also "compiler" } ; ARTICLE: "dataflow" "Data and control flow" { $subsection "evaluator" } @@ -87,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." @@ -100,12 +100,14 @@ $nl { $subsection "concurrency.combinators" } { $subsection "concurrency.promises" } { $subsection "concurrency.futures" } +{ $subsection "concurrency.mailboxes" } { $subsection "concurrency.messaging" } "Shared-state abstractions:" { $subsection "concurrency.locks" } { $subsection "concurrency.semaphores" } { $subsection "concurrency.count-downs" } { $subsection "concurrency.exchangers" } +{ $subsection "concurrency.flags" } "Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ; ARTICLE: "objects" "Objects" @@ -114,6 +116,7 @@ ARTICLE: "objects" "Objects" { $subsection "classes" } { $subsection "tuples" } { $subsection "generic" } +{ $subsection "slots" } { $subsection "mirrors" } ; USE: random @@ -169,23 +172,27 @@ 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:" +{ $subsection "io.streams.byte-array" } +"Utilities:" { $subsection "stream-binary" } { $subsection "styles" } -"Advanced features:" -{ $subsection "io.launcher" } +{ $heading "Files" } +{ $subsection "io.files" } { $subsection "io.mmap" } { $subsection "io.monitors" } +{ $heading "Encodings" } +{ $subsection "io.encodings" } +{ $subsection "io.encodings.string" } +{ $heading "Other features" } +{ $subsection "network-streams" } +{ $subsection "io.launcher" } { $subsection "io.timeouts" } ; ARTICLE: "tools" "Developer tools" @@ -196,7 +203,7 @@ ARTICLE: "tools" "Developer tools" "Debugging tools:" { $subsection "tools.annotations" } { $subsection "tools.test" } -{ $subsection "meta-interpreter" } +{ $subsection "tools.threads" } "Performance tools:" { $subsection "tools.memory" } { $subsection "profiling" } @@ -229,7 +236,7 @@ ARTICLE: "program-org" "Program organization" USING: help.cookbook help.tutorial ; ARTICLE: "handbook" "Factor documentation" -"Welcome to Factor. Factor is dynamically-typed, stack-based, and very expressive. It is one of the most powerful and flexible programming languages ever invented. Have fun with Factor!" +"Welcome to Factor." { $heading "Starting points" } { $subsection "cookbook" } { $subsection "first-program" } @@ -255,6 +262,7 @@ ARTICLE: "handbook" "Factor documentation" { $subsection "help" } { $subsection "inference" } { $subsection "compiler" } +{ $subsection "layouts" } { $heading "User interface" } { $about "ui" } { $about "ui.tools" } diff --git a/extra/help/help-docs.factor b/extra/help/help-docs.factor index fc795572fb..1d2af5fb39 100755 --- a/extra/help/help-docs.factor +++ b/extra/help/help-docs.factor @@ -230,17 +230,17 @@ HELP: $examples { $values { "element" "a markup element" } } { $description "Prints a heading followed by some examples. Word documentation should include examples, at least if the usage of the word is not entirely obvious." } { $examples - { $markup-example { $examples { $example "2 2 + ." "4" } } } + { $markup-example { $examples { $example "USING: math prettyprint ;" "2 2 + ." "4" } } } } ; HELP: $example { $values { "element" "a markup element of the form " { $snippet "{ inputs... output }" } } } { $description "Prints a clickable example with sample output. The markup element must be an array of strings. All but the last string are joined by newlines and taken as the input text, and the last string is the output. The example becomes clickable if the output stream supports it, and clicking it opens a listener window with the input text inserted at the input prompt." } { $examples - "The output text should be a string of what the input prints when executed, not the final stack contents or anything like that. So the following is an incorrect example:" + "The input text must contain a correct " { $link POSTPONE: USING: } " declaration, and output text should be a string of what the input prints when executed, not the final stack contents or anything like that. So the following is an incorrect example:" { $markup-example { $unchecked-example "2 2 +" "4" } } "However the following is right:" - { $markup-example { $example "2 2 + ." "4" } } + { $markup-example { $example "USING: math prettyprint ;" "2 2 + ." "4" } } "Examples can incorporate a call to " { $link .s } " to show multiple output values; the convention is that you may assume the stack is empty before the example evaluates." } ; @@ -270,7 +270,7 @@ HELP: textual-list { $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } { $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." } { $examples - { $example "USE: help.markup" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" } + { $example "USING: help.markup io ;" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" } } ; HELP: $links @@ -344,7 +344,7 @@ HELP: $side-effects HELP: $notes { $values { "element" "a markup element" } } -{ $description "Prints the errors subheading found on the help page of some words. This section should usage tips and pitfalls." } ; +{ $description "Prints the notes subheading found on the help page of some words. This section should document usage tips and pitfalls." } ; HELP: $see { $values { "element" "a markup element of the form " { $snippet "{ word }" } } } diff --git a/extra/help/help.factor b/extra/help/help.factor index 77b9f699aa..85f5a35a5c 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -109,9 +109,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ] ?if ; : ($index) ( articles -- ) - subsection-style get [ - sort-articles [ nl ] [ ($subsection) ] interleave - ] with-style ; + sort-articles [ \ $subsection swap 2array ] map print-element ; : $index ( element -- ) first call dup empty? @@ -122,18 +120,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..0c0fcf92d2 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 -{ $values { "vocab" "a vocabulary specifier" } } -{ $description "Checks all word help in the given vocabulary." } ; +HELP: help-lint +{ $values { "prefix" "a vocabulary specifier" } } +{ $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..22a1945b24 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 math ; IN: help.lint : check-example ( element -- ) @@ -27,8 +27,13 @@ IN: help.lint ] unless ; : effect-values ( word -- seq ) - stack-effect dup effect-in swap effect-out - append [ string? ] subset prune natural-sort ; + stack-effect dup effect-in swap effect-out append [ + { + { [ dup word? ] [ word-name ] } + { [ dup integer? ] [ drop "object" ] } + { [ dup string? ] [ ] } + } cond + ] map prune natural-sort ; : contains-funky-elements? ( element -- ? ) { @@ -84,7 +89,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 +111,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 +160,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..d81e9cd81e --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic io kernel assocs hashtables namespaces parser prettyprint sequences strings io.styles @@ -42,9 +42,9 @@ M: f print-element drop ; [ print-element ] with-style ; : with-default-style ( quot -- ) - default-style get [ + default-span-style get [ last-element off - default-style get swap with-nesting + default-block-style get swap with-nesting ] with-style ; inline : print-content ( element -- ) @@ -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/stylesheet/stylesheet.factor b/extra/help/stylesheet/stylesheet.factor old mode 100644 new mode 100755 index 3c5271d381..945d9a4ce1 --- a/extra/help/stylesheet/stylesheet.factor +++ b/extra/help/stylesheet/stylesheet.factor @@ -3,13 +3,17 @@ USING: io.styles namespaces ; IN: help.stylesheet -SYMBOL: default-style +SYMBOL: default-span-style H{ { font "sans-serif" } { font-size 12 } { font-style plain } +} default-span-style set-global + +SYMBOL: default-block-style +H{ { wrap-margin 500 } -} default-style set-global +} default-block-style set-global SYMBOL: link-style H{ 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..286037d4dc 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 @@ -161,5 +161,6 @@ SYMBOL: html "id" "onclick" "style" "valign" "accesskey" "src" "language" "colspan" "onchange" "rel" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" + "media" ] [ define-attribute-word ] each ] with-compilation-unit 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/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index fca15d9b07..1a60390f64 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,8 +1,44 @@ USING: assocs html.parser kernel math sequences strings ascii -arrays shuffle unicode.case namespaces splitting -http.server.responders ; +arrays shuffle unicode.case namespaces splitting http +sequences.lib ; IN: html.parser.analyzer +: (find-relative) + [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; + +: find-relative ( seq quot n -- i elt ) + >r over [ find drop ] dip r> swap pick + (find-relative) ; + +: (find-all) ( n seq quot -- ) + 2dup >r >r find* [ + dupd 2array , 1+ r> r> (find-all) + ] [ + r> r> 3drop + ] if* ; + +: find-all ( seq quot -- alist ) + [ 0 -rot (find-all) ] { } make ; + +: (find-nth) ( offset seq quot n count -- obj ) + >r >r [ find* ] 2keep 4 npick [ + r> r> 1+ 2dup <= [ + 4drop + ] [ + >r >r >r >r drop 1+ r> r> r> r> + (find-nth) + ] if + ] [ + 2drop r> r> 2drop + ] if ; + +: find-nth ( seq quot n -- i elt ) + 0 -roll 0 (find-nth) ; + +: find-nth-relative ( seq quot n offest -- i elt ) + >r [ find-nth ] 3keep 2drop nip r> swap pick + (find-relative) ; + : remove-blank-text ( vector -- vector' ) [ dup tag-name text = [ @@ -52,29 +88,33 @@ IN: html.parser.analyzer >r >lower r> [ tag-attributes at over = ] with find rot drop ; -: find-between ( i/f tag/f vector -- vector ) +: find-between* ( i/f tag/f vector -- vector ) pick integer? [ - rot 1+ tail-slice + rot tail-slice >r tag-name r> - [ find-matching-close drop ] keep swap head + [ find-matching-close drop 1+ ] keep swap head ] [ 3drop V{ } clone ] if ; + +: find-between ( i/f tag/f vector -- vector ) + find-between* dup length 3 >= [ + [ 1 tail-slice 1 head-slice* ] keep like + ] when ; + +: find-between-first ( string vector -- vector' ) + [ find-first-name ] keep find-between ; + +: tag-link ( tag -- link/f ) + tag-attributes [ "href" swap at ] [ f ] if* ; : find-links ( vector -- vector ) [ tag-name "a" = ] subset - [ tag-attributes "href" swap at ] map - [ ] subset ; + [ tag-link ] subset ; -: (find-all) ( n seq quot -- ) - 2dup >r >r find* [ - dupd 2array , 1+ r> r> (find-all) - ] [ - r> r> 3drop - ] if* ; -: find-all ( seq quot -- alist ) - [ 0 -rot (find-all) ] { } make ; +: find-by-text ( seq quot -- tag ) + [ dup tag-name text = ] swap compose find drop ; : find-opening-tags-by-name ( name seq -- seq ) [ [ tag-name = ] keep tag-closing? not and ] with find-all ; @@ -82,8 +122,8 @@ IN: html.parser.analyzer : href-contains? ( str tag -- ? ) tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; -: query>hash* ( str -- hash ) - "?" split1 nip query>hash ; +: query>assoc* ( str -- hash ) + "?" split1 nip query>assoc ; ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map @@ -91,5 +131,5 @@ IN: html.parser.analyzer ! "a" over find-opening-tags-by-name ! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset ! first first 8 + over nth -! tag-attributes "href" swap at query>hash* +! tag-attributes "href" swap at query>assoc* ! "lat" over at "lon" rot at diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor index c490b737d9..0e98c1b998 100644 --- a/extra/html/parser/parser-tests.factor +++ b/extra/html/parser/parser-tests.factor @@ -1,5 +1,5 @@ USING: html.parser kernel tools.test ; -IN: temporary +IN: html.parser.tests [ V{ T{ tag f "html" H{ } f f f } } diff --git a/extra/html/parser/utils/utils-tests.factor b/extra/html/parser/utils/utils-tests.factor index fcac31a6aa..4b25db16fd 100644 --- a/extra/html/parser/utils/utils-tests.factor +++ b/extra/html/parser/utils/utils-tests.factor @@ -3,7 +3,7 @@ hashtables.private io kernel math namespaces prettyprint quotations sequences splitting state-parser strings tools.test ; USING: html.parser.utils ; -IN: temporary +IN: html.parser.utils.tests [ "'Rome'" ] [ "Rome" single-quote ] unit-test [ "\"Roma\"" ] [ "Roma" double-quote ] unit-test diff --git a/extra/http/basic-authentication/basic-authentication-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..661f63ab59 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -1,14 +1,27 @@ -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" + + ] with-scope +] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 679d603708..ee0d5f7f3b 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -1,92 +1,99 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting continuations assocs.lib ; +splitting calendar continuations accessors vectors +io.encodings.latin1 io.encodings.binary fry ; IN: http.client -: parse-host ( url -- host port ) - #! Extract the host name and port number from an HTTP URL. - ":" split1 [ string>number ] [ 80 ] if* ; +DEFER: http-request -SYMBOL: domain +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* ; +: store-path ( request path -- request ) + "?" split1 >r >>path r> dup [ query>assoc ] when >>query ; -: read-response ( -- code header ) - #! After sending a GET or POST we read a response line and - #! header. - flush readln parse-response read-header ; +: request-with-url ( url request -- request ) + swap parse-url >r >r store-path r> >>host r> >>port ; -: crlf "\r\n" write ; +! This is all pretty complex because it needs to handle +! HTTP redirects, which might be absolute or relative +: absolute-redirect ( url -- request ) + request get request-with-url ; -: http-request ( host resource method -- ) - write bl write " HTTP/1.0" write crlf - "Host: " write write crlf ; +: relative-redirect ( path -- request ) + request get swap store-path ; -: get-request ( host resource -- ) - "GET" http-request crlf ; +: do-redirect ( response -- response stream ) + dup response-code 300 399 between? [ + stdio get dispose + header>> "location" swap at + dup "http://" head? [ + absolute-redirect + ] [ + relative-redirect + ] if "GET" >>method http-request + ] [ + stdio get + ] if ; -DEFER: http-get-stream +: request-addr ( request -- addr ) + dup host>> swap port>> ; -: 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 ; +: close-on-error ( stream quot -- ) + '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline -: default-timeout 60 1000 * over set-timeout ; +PRIVATE> -: 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 ; +: http-request ( request -- response stream ) + dup request [ + dup request-addr latin1 + 1 minutes over set-timeout + [ + write-request flush + read-response + do-redirect + ] close-on-error + ] with-variable ; + +: ( url -- request ) + request-with-url "GET" >>method ; + +: http-get-stream ( url -- response stream ) + http-request ; : success? ( code -- ? ) 200 = ; -: check-response ( code headers stream -- stream ) - nip swap success? - [ dispose "HTTP download failed" throw ] unless ; +: check-response ( response -- ) + code>> success? + [ "HTTP download failed" throw ] unless ; : http-get ( url -- string ) - http-get-stream check-response contents ; + http-get-stream contents swap check-response ; : download-name ( url -- name ) file-name "?" split1 drop "/" ?tail drop ; : 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 swap check-response + [ swap latin1 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 url -- request ) + + request-with-url + "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. + >r url-encode r> 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..66182b10ae --- 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,140 @@ 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 + +! Live-fire exercise +USING: http.server http.server.static http.server.actions +http.client io.server io.files io accessors namespaces threads +io.encodings.ascii ; + +[ ] [ + [ + + + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display + "quit" add-responder + "extra/http/test" resource-path >>default + main-responder set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ t ] [ + "extra/http/test/foo.html" resource-path ascii file-contents + "http://localhost:1237/foo.html" http-get = +] unit-test + +[ "Goodbye" ] [ + "http://localhost:1237/quit" http-get +] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 5c4dae94c7..c72a631d16 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: fry hashtables io io.streams.string kernel math +namespaces math.parser assocs sequences strings splitting ascii +io.encodings.utf8 io.encodings.string 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,8 +17,8 @@ IN: http over digit? or swap "/_-." member? or ; foldable -: push-utf8 ( string -- ) - 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; +: push-utf8 ( ch -- ) + 1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; : url-encode ( str -- str ) [ [ @@ -56,19 +50,377 @@ IN: http ] if ; : url-decode ( str -- str ) - [ 0 swap url-decode-iter ] "" make decode-utf8 ; + [ 0 swap url-decode-iter ] "" make utf8 decode ; -: 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" seq-intersect empty? + [ "Header injection attack" throw ] unless ; + +: 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> '[ , _ name>> = ] find nip ; + +: delete-cookie ( request/response name -- ) + over cookies>> >r get-cookie r> delete ; + +: put-cookie ( request/response cookie -- request/response ) + [ name>> dupd 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 100755 index 0000000000..98a92e083a --- /dev/null +++ b/extra/http/server/actions/actions-tests.factor @@ -0,0 +1,41 @@ +IN: http.server.actions.tests +USING: http.server.actions tools.test math math.parser +multiline namespaces http io.streams.string http.server +sequences accessors ; + + + [ "a" get "b" get + ] >>display + { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params +"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 + request set + "/blah" + "action-1" get call-responder +] unit-test + + + [ +path+ get "xxx" get "X" concat append ] >>submit + { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params +"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 + request set + "/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..bab55eef0c --- /dev/null +++ b/extra/http/server/actions/actions.factor @@ -0,0 +1,61 @@ +! 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.server.validators http hashtables namespaces +combinators.cleave fry continuations ; +IN: http.server.actions + +SYMBOL: +path+ + +SYMBOL: params + +TUPLE: action init display submit get-params post-params ; + +: + action construct-empty + [ ] >>init + [ <400> ] >>display + [ <400> ] >>submit ; + +: extract-params ( path -- assoc ) + +path+ associate + request get dup method>> { + { "GET" [ query>> ] } + { "HEAD" [ query>> ] } + { "POST" [ post-data>> query>assoc ] } + } case union ; + +: with-validator ( string quot -- result error? ) + '[ , @ f ] [ + dup validation-error? [ t ] [ rethrow ] if + ] recover ; inline + +: validate-param ( name validator assoc -- error? ) + swap pick + >r >r at r> with-validator swap r> set ; + +: action-params ( validators -- error? ) + [ params get validate-param ] { } assoc>map [ ] contains? ; + +: handle-get ( -- response ) + action get get-params>> action-params [ <400> ] [ + action get [ init>> call ] [ display>> call ] bi + ] if ; + +: handle-post ( -- response ) + action get post-params>> action-params + [ <400> ] [ action get submit>> call ] if ; + +: validation-failed ( -- * ) + action get display>> call exit-with ; + +M: action call-responder ( path action -- response ) + [ extract-params params set ] + [ + action set + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case + ] bi* ; diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor new file mode 100755 index 0000000000..1b1534b85e --- /dev/null +++ b/extra/http/server/auth/auth.factor @@ -0,0 +1,9 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: http.server.sessions accessors +http.server.auth.providers ; +IN: http.server.auth + +SYMBOL: logged-in-user + +: uid ( -- string ) logged-in-user sget username>> ; diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor new file mode 100755 index 0000000000..2ea74febba --- /dev/null +++ b/extra/http/server/auth/basic/basic.factor @@ -0,0 +1,41 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots quotations assocs kernel splitting +base64 html.elements io combinators http.server +http.server.auth.providers http.server.auth.providers.null +http sequences ; +IN: http.server.auth.basic + +TUPLE: basic-auth responder realm provider ; + +C: basic-auth + +: authorization-ok? ( provider header -- ? ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split1 swap "Basic" = [ + base64> ":" split1 spin check-login + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: <401> ( realm -- response ) + 401 "Unauthorized" + "Basic realm=\"" rot "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>body ; + +: logged-in? ( request responder -- ? ) + provider>> swap "authorization" header authorization-ok? ; + +M: basic-auth call-responder ( request path responder -- response ) + pick over logged-in? + [ responder>> call-responder ] [ 2nip realm>> <401> ] if ; diff --git a/extra/http/server/auth/login/login-tests.factor b/extra/http/server/auth/login/login-tests.factor new file mode 100755 index 0000000000..b69630a930 --- /dev/null +++ b/extra/http/server/auth/login/login-tests.factor @@ -0,0 +1,6 @@ +IN: http.server.auth.login.tests +USING: tools.test http.server.auth.login ; + +\ must-infer +\ allow-registration must-infer +\ allow-password-recovery must-infer diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor new file mode 100755 index 0000000000..7d92c727c6 --- /dev/null +++ b/extra/http/server/auth/login/login.factor @@ -0,0 +1,300 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots quotations assocs kernel splitting +base64 html.elements io combinators http.server +http.server.auth.providers http.server.auth.providers.null +http.server.actions http.server.components http.server.sessions +http.server.templating.fhtml http.server.validators +http.server.auth http sequences io.files namespaces hashtables +fry io.sockets combinators.cleave arrays threads locals +qualified ; +IN: http.server.auth.login +QUALIFIED: smtp + +TUPLE: login users ; + +SYMBOL: post-login-url +SYMBOL: login-failed? + +! ! ! Login + +: + "login"
+ "resource:extra/http/server/auth/login/login.fhtml" >>edit-template + "username" + t >>required + add-field + "password" + t >>required + add-field ; + +: successful-login ( user -- response ) + logged-in-user sset + post-login-url sget f ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + "password" value "username" value + login get users>> check-login [ + successful-login + ] [ + login-failed? on + validation-failed + ] if* + ] >>submit + ] ; + +! ! ! New user registration + +: ( -- form ) + "register" + "resource:extra/http/server/auth/login/register.fhtml" >>edit-template + "username" + t >>required + add-field + "realname" add-field + "password" + t >>required + add-field + "verify-password" + t >>required + add-field + "email" add-field + "captcha" add-field ; + +SYMBOL: password-mismatch? +SYMBOL: user-exists? + +: same-password-twice ( -- ) + "password" value "verify-password" value = [ + password-mismatch? on + validation-failed + ] unless ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + same-password-twice + + values get [ + "username" get >>username + "realname" get >>realname + "password" get >>password + "email" get >>email + ] bind + + login get users>> new-user [ + user-exists? on + validation-failed + ] unless* + + successful-login + ] >>submit + ] ; + +! ! ! Password recovery + +SYMBOL: lost-password-from + +: current-host ( -- string ) + request get host>> host-name or ; + +: new-password-url ( user -- url ) + "new-password" + swap [ + [ username>> "username" set ] + [ ticket>> "ticket" set ] + bi + ] H{ } make-assoc + derive-url ; + +: password-email ( user -- email ) + smtp: + [ "[ " % current-host % " ] password recovery" % ] "" make >>subject + lost-password-from get >>from + over email>> 1array >>to + [ + "This e-mail was sent by the application server on " % current-host % "\n" % + "because somebody, maybe you, clicked on a ``recover password'' link in the\n" % + "login form, and requested a new password for the user named ``" % + over username>> % "''.\n" % + "\n" % + "If you believe that this request was legitimate, you may click the below link in\n" % + "your browser to set a new password for your account:\n" % + "\n" % + swap new-password-url % + "\n\n" % + "Love,\n" % + "\n" % + " FactorBot\n" % + ] "" make >>body ; + +: send-password-email ( user -- ) + '[ , password-email smtp:send-email ] + "E-mail send thread" spawn drop ; + +: ( -- form ) + "register" + "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template + "username" + t >>required + add-field + "email" + t >>required + add-field + "captcha" add-field ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + "email" value "username" value + login get users>> issue-ticket [ + send-password-email + ] when* + + "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template + ] >>submit + ] ; + +: + "new-password" + "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template + "username" + t >>required + add-field + "password" + t >>required + add-field + "verify-password" + t >>required + add-field + "ticket" + t >>required + add-field ; + +:: ( -- action ) + [let | form [ ] | + + [ + { "username" [ v-required ] } + { "ticket" [ v-required ] } + ] >>get-params + + [ + [ + "username" [ get ] keep set + "ticket" [ get ] keep set + ] H{ } make-assoc values set + ] >>init + + [ + "text/html" + [ edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + same-password-twice + + "ticket" value + "username" value + login get users>> claim-ticket [ + "password" value >>password + login get users>> update-user + + "resource:extra/http/server/auth/login/recover-4.fhtml" + serve-template + ] [ + <400> + ] if* + ] >>submit + ] ; + +! ! ! Logout +: ( -- action ) + + [ + f logged-in-user sset + "login" f + ] >>submit ; + +! ! ! Authentication logic + +TUPLE: protected responder ; + +C: protected + +M: protected call-responder ( path responder -- response ) + logged-in-user sget [ responder>> call-responder ] [ + 2drop + request get method>> { "GET" "HEAD" } member? [ + request get request-url post-login-url sset + "login" f + ] [ <400> ] if + ] if ; + +M: login call-responder ( path responder -- response ) + dup login set + delegate call-responder ; + +: ( responder -- auth ) + login + swap >>default + "login" add-responder + "logout" add-responder + no >>users ; + +! ! ! Configuration + +: allow-registration ( login -- login ) + "register" add-responder ; + +: allow-password-recovery ( login -- login ) + "recover-password" add-responder + "new-password" add-responder ; + +: allow-registration? ( -- ? ) + login get responders>> "register" swap key? ; + +: allow-password-recovery? ( -- ? ) + login get responders>> "recover-password" swap key? ; diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml new file mode 100755 index 0000000000..8e879420a9 --- /dev/null +++ b/extra/http/server/auth/login/login.fhtml @@ -0,0 +1,41 @@ +<% USING: http.server.auth.login http.server.components kernel +namespaces ; %> + + +

Login required

+ + + + + + + + + + + + + + +
User name:<% "username" component render-edit %>
Password:<% "password" component render-edit %>
+ +

+<% +login-failed? get +[ "Invalid username or password" render-error ] when +%> +

+ + + +

+<% allow-registration? [ %> + Register +<% ] when %> +<% allow-password-recovery? [ %> + Recover Password +<% ] when %> +

+ + + diff --git a/extra/http/server/auth/login/recover-1.fhtml b/extra/http/server/auth/login/recover-1.fhtml new file mode 100755 index 0000000000..3e8448f64b --- /dev/null +++ b/extra/http/server/auth/login/recover-1.fhtml @@ -0,0 +1,38 @@ +<% USING: http.server.components ; %> + + +

Recover lost password: step 1 of 4

+ +

Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.

+ +
+ + + + + + + + + + + + + + + + + + + + + + +
User name:<% "username" component render-edit %>
E-mail:<% "email" component render-edit %>
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.
+ + + +
+ + + diff --git a/extra/http/server/auth/login/recover-2.fhtml b/extra/http/server/auth/login/recover-2.fhtml new file mode 100755 index 0000000000..9b13734273 --- /dev/null +++ b/extra/http/server/auth/login/recover-2.fhtml @@ -0,0 +1,9 @@ +<% USING: http.server.components ; %> + + +

Recover lost password: step 2 of 4

+ +

If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.

+ + + diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml new file mode 100755 index 0000000000..b220cc4f75 --- /dev/null +++ b/extra/http/server/auth/login/recover-3.fhtml @@ -0,0 +1,43 @@ +<% USING: http.server.components http.server.auth.login +namespaces kernel combinators ; %> + + +

Recover lost password: step 3 of 4

+ +

Choose a new password for your account.

+ +
+ + +<% "username" component render-edit %> +<% "ticket" component render-edit %> + + + + + + + + + + + + + + + + +
Password:<% "password" component render-edit %>
Verify password:<% "verify-password" component render-edit %>
Enter your password twice to ensure it is correct.
+ +

+ +<% password-mismatch? get [ +"passwords do not match" render-error +] when %> + +

+ +
+ + + diff --git a/extra/http/server/auth/login/recover-4.fhtml b/extra/http/server/auth/login/recover-4.fhtml new file mode 100755 index 0000000000..dec7a5404f --- /dev/null +++ b/extra/http/server/auth/login/recover-4.fhtml @@ -0,0 +1,10 @@ +<% USING: http.server.components http.server.auth.login +namespaces kernel combinators ; %> + + +

Recover lost password: step 4 of 4

+ +

Your password has been reset. You may now log in.

+ + + diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml new file mode 100755 index 0000000000..c7e274e626 --- /dev/null +++ b/extra/http/server/auth/login/register.fhtml @@ -0,0 +1,75 @@ +<% USING: http.server.components http.server.auth.login +namespaces kernel combinators ; %> + + +

New user registration

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:<% "username" component render-edit %>
Real name:<% "realname" component render-edit %>
Specifying a real name is optional.
Password:<% "password" component render-edit %>
Verify:<% "verify-password" component render-edit %>
Enter your password twice to ensure it is correct.
E-mail:<% "email" component render-edit %>
Specifying an e-mail address is optional. It enables the "recover password" feature.
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
+ +

+ +<% { + { [ password-mismatch? get ] [ "passwords do not match" render-error ] } + { [ user-exists? get ] [ "username taken" render-error ] } + { [ t ] [ ] } +} cond %> + +

+ +
+ + + diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor new file mode 100755 index 0000000000..12c799816d --- /dev/null +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -0,0 +1,33 @@ +IN: http.server.auth.providers.assoc.tests +USING: http.server.auth.providers +http.server.auth.providers.assoc tools.test +namespaces accessors kernel ; + + "provider" set + +[ t ] [ + + "slava" >>username + "foobar" >>password + "slava@factorcode.org" >>email + "provider" get new-user + username>> "slava" = +] unit-test + +[ f ] [ + + "slava" >>username + "provider" get new-user +] unit-test + +[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test + +[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test + +[ f ] [ "xx" "blah" "provider" get set-password ] unit-test + +[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test + +[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test + +[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor new file mode 100755 index 0000000000..8433e54fda --- /dev/null +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.auth.providers.assoc +USING: new-slots accessors assocs kernel +http.server.auth.providers ; + +TUPLE: in-memory assoc ; + +: ( -- provider ) + H{ } clone in-memory construct-boa ; + +M: in-memory get-user ( username provider -- user/f ) + assoc>> at ; + +M: in-memory update-user ( user provider -- ) 2drop ; + +M: in-memory new-user ( user provider -- user/f ) + >r dup username>> r> assoc>> + 2dup key? [ 3drop f ] [ pick >r set-at r> ] if ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor new file mode 100755 index 0000000000..247359aea4 --- /dev/null +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -0,0 +1,40 @@ +IN: http.server.auth.providers.db.tests +USING: http.server.auth.providers +http.server.auth.providers.db tools.test +namespaces db db.sqlite db.tuples continuations +io.files accessors kernel ; + +from-db "provider" set + +"auth-test.db" temp-file sqlite-db [ + + [ user drop-table ] ignore-errors + [ user create-table ] ignore-errors + + [ t ] [ + + "slava" >>username + "foobar" >>password + "slava@factorcode.org" >>email + "provider" get new-user + username>> "slava" = + ] unit-test + + [ f ] [ + + "slava" >>username + "provider" get new-user + ] unit-test + + [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test + + [ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test + + [ f ] [ "xx" "blah" "provider" get set-password ] unit-test + + [ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test + + [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test + + [ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test +] with-db diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor new file mode 100755 index 0000000000..e9e79ff82f --- /dev/null +++ b/extra/http/server/auth/providers/db/db.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db db.tuples db.types new-slots accessors +http.server.auth.providers kernel continuations ; +IN: http.server.auth.providers.db + +user "USERS" +{ + { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ } + { "realname" "REALNAME" { VARCHAR 256 } } + { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } + { "email" "EMAIL" { VARCHAR 256 } } + { "ticket" "TICKET" { VARCHAR 256 } } + { "profile" "PROFILE" FACTOR-BLOB } +} define-persistent + +: init-users-table ( -- ) + [ user drop-table ] ignore-errors + user create-table ; + +TUPLE: from-db ; + +: from-db T{ from-db } ; + +: find-user ( username -- user ) + + swap >>username + select-tuple ; + +M: from-db get-user + drop + find-user ; + +M: from-db new-user + drop + [ + dup username>> find-user [ + drop f + ] [ + dup insert-tuple + ] if + ] with-transaction ; + +M: from-db update-user + drop update-tuple ; diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor new file mode 100755 index 0000000000..7b8bfc627c --- /dev/null +++ b/extra/http/server/auth/providers/null/null.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: http.server.auth.providers kernel ; +IN: http.server.auth.providers.null + +! Named "no" because we can say no >>users + +TUPLE: no ; + +: no T{ no } ; + +M: no get-user 2drop f ; + +M: no new-user 2drop f ; + +M: no update-user 2drop ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor new file mode 100755 index 0000000000..0aa27f870d --- /dev/null +++ b/extra/http/server/auth/providers/providers.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel new-slots accessors random math.parser locals +sequences math ; +IN: http.server.auth.providers + +TUPLE: user username realname password email ticket profile ; + +: user construct-empty H{ } clone >>profile ; + +GENERIC: get-user ( username provider -- user/f ) + +GENERIC: update-user ( user provider -- ) + +GENERIC: new-user ( user provider -- user/f ) + +: check-login ( password username provider -- user/f ) + get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; + +:: set-password ( password username provider -- ? ) + [let | user [ username provider get-user ] | + user [ + user + password >>password + provider update-user t + ] [ f ] if + ] ; + +! Password recovery support + +:: issue-ticket ( email username provider -- user/f ) + [let | user [ username provider get-user ] | + user [ + user email>> length 0 > [ + user email>> email = [ + user + random-256 >hex >>ticket + dup provider update-user + ] [ f ] if + ] [ f ] if + ] [ f ] if + ] ; + +:: claim-ticket ( ticket username provider -- user/f ) + [let | user [ username provider get-user ] | + user [ + user ticket>> ticket = [ + user f >>ticket dup provider update-user + ] [ f ] if + ] [ f ] if + ] ; + +! For configuration + +: add-user ( provider user -- provider ) + over new-user [ "User exists" throw ] when ; diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor new file mode 100755 index 0000000000..4cad097cf5 --- /dev/null +++ b/extra/http/server/callbacks/callbacks-tests.factor @@ -0,0 +1,64 @@ +IN: http.server.callbacks +USING: http.server.actions http.server.callbacks accessors +http.server http tools.test namespaces io fry sequences +splitting kernel hashtables continuations ; + +[ 123 ] [ + [ + "GET" >>method request set + [ + exit-continuation set + "xxx" + [ [ "hello" print 123 ] show-final ] >>display + + call-responder + ] callcc1 + ] with-scope +] unit-test + +[ + [ + [ + "hello" print + "text/html" swap '[ , write ] >>body + ] show-page + "byebye" print + [ 123 ] show-final + ] >>display + "r" set + + [ 123 ] [ + [ + exit-continuation set + "GET" >>method request set + "" "r" get call-responder + ] callcc1 + + body>> first + + + "GET" >>method + swap cont-id associate >>query + "/" >>path + request set + + [ + exit-continuation set + "/" + "r" get call-responder + ] callcc1 + + ! get-post-get + + "GET" >>method + swap "location" header "=" last-split1 nip cont-id associate >>query + "/" >>path + request set + + [ + exit-continuation set + "/" + "r" get call-responder + ] callcc1 + ] unit-test +] with-scope diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor new file mode 100755 index 0000000000..ac03e0efc8 --- /dev/null +++ b/extra/http/server/callbacks/callbacks.factor @@ -0,0 +1,117 @@ +! 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 +combinators.cleave fry ; +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 -- ) + [ alarm>> cancel-alarm ] + [ dup responder>> callbacks>> delete-at ] + bi ; + +: touch-callback ( callback -- ) + dup expires>> [ + dup alarm>> [ cancel-alarm ] when* + dup '[ , timeout-callback ] timeout later >>alarm + ] when drop ; + +: ( cont quot expires? -- callback ) + f callback-responder get callback construct-boa + dup touch-callback ; + +: invoke-callback ( callback -- response ) + [ touch-callback ] + [ quot>> request get exit-continuation get 3array ] + [ cont>> continue-with ] + tri ; + +: register-callback ( cont quot expires? -- id ) + callback-responder get callbacks>> set-at-unique ; + +: forward-to-url ( url query -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + exit-with ; + +: cont-id "factorcontid" ; + +: 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. + f swap cont-id associate forward-to-url ; + +: restore-request ( pair -- ) + first3 exit-continuation set request set call ; + +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 + +: resuming-callback ( responder request -- id ) + cont-id query-param swap callbacks>> at ; + +M: callback-responder call-responder ( path responder -- response ) + [ callback-responder set ] + [ request get resuming-callback ] bi + + [ invoke-callback ] + [ callback-responder get responder>> call-responder ] ?if ; + +: show-page ( quot -- ) + >r redirect-to-here store-current-show r> + [ + [ ] t register-callback swap call exit-with + ] callcc1 restore-request ; inline + +: quot-id ( quot -- id ) + current-show get swap t register-callback ; + +: quot-url ( quot -- url ) + quot-id f swap cont-id associate derive-url ; diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor new file mode 100755 index 0000000000..509943faa8 --- /dev/null +++ b/extra/http/server/cgi/cgi.factor @@ -0,0 +1,62 @@ +! 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 fry ; +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 ; + +: ( name -- desc ) + + over 1array >>command + swap cgi-variables >>environment ; + +: serve-cgi ( name -- response ) + + 200 >>code + "CGI output follows" >>message + swap '[ + , stdio get swap [ + post? [ request get post-data>> write flush ] when + stdio get swap (stream-copy) + ] with-stream + ] >>body ; + +: enable-cgi ( responder -- responder ) + [ serve-cgi ] "application/x-cgi-script" + pick special>> set-at ; diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor new file mode 100755 index 0000000000..2a507e6416 --- /dev/null +++ b/extra/http/server/components/components-tests.factor @@ -0,0 +1,88 @@ +IN: http.server.components.tests +USING: http.server.components http.server.validators +namespaces tools.test kernel accessors new-slots +tuple-syntax mirrors http.server.actions ; + +validation-failed? off + +[ 3 ] [ "3" "n" validate ] unit-test + +[ 123 ] [ + "" + "n" + 123 >>default + validate +] unit-test + +[ f ] [ validation-failed? get ] unit-test + +[ t ] [ "3x" "n" validate validation-error? ] unit-test + +[ t ] [ validation-failed? get ] unit-test + +[ "" ] [ "" "email" validate ] unit-test + +[ "slava@jedit.org" ] [ "slava@jedit.org" "email" validate ] unit-test + +[ "slava@jedit.org" ] [ + "slava@jedit.org" + "email" + t >>required + validate +] unit-test + +[ t ] [ + "a" + "email" + t >>required + validate validation-error? +] unit-test + +[ t ] [ "a" "email" validate validation-error? ] unit-test + +TUPLE: test-tuple text number more-text ; + +: test-tuple construct-empty ; + +: ( -- form ) + "test"
+ "resource:extra/http/server/components/test/form.fhtml" >>view-template + "resource:extra/http/server/components/test/form.fhtml" >>edit-template + "text" + t >>required + add-field + "number" + 123 >>default + t >>required + 0 >>min-value + 10 >>max-value + add-field + "more-text" + "hi" >>default + add-field ; + +[ ] [ values set view-form ] unit-test + +[ ] [ values set edit-form ] unit-test + +[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [ + from-tuple + set-defaults + values-tuple +] unit-test + +[ + H{ + { "text" "fdafsa" } + { "number" "xxx" } + { "more-text" "" } + } params set + + H{ } clone values set + + [ t ] [ (validate-form) ] unit-test + + [ "fdafsa" ] [ "text" value ] unit-test + + [ t ] [ "number" value validation-error? ] unit-test +] with-scope diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor new file mode 100755 index 0000000000..bb0fc4b3dd --- /dev/null +++ b/extra/http/server/components/components.factor @@ -0,0 +1,240 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: new-slots html.elements http.server.validators accessors +namespaces kernel io math.parser assocs classes words tuples +arrays sequences io.files http.server.templating.fhtml +http.server.actions splitting mirrors hashtables +combinators.cleave fry continuations math ; +IN: http.server.components + +SYMBOL: validation-failed? + +SYMBOL: components + +TUPLE: component id required default ; + +: component ( name -- component ) + dup components get at + [ ] [ "No such component: " swap append throw ] ?if ; + +GENERIC: validate* ( value component -- result ) +GENERIC: render-view* ( value component -- ) +GENERIC: render-edit* ( value component -- ) +GENERIC: render-error* ( reason value component -- ) + +SYMBOL: values + +: value values get at ; + +: set-value values get set-at ; + +: validate ( value component -- result ) + '[ + , , + over empty? [ + [ default>> [ v-default ] when* ] + [ required>> [ v-required ] when ] + bi + ] [ validate* ] if + ] [ + dup validation-error? + [ validation-failed? on ] [ rethrow ] if + ] recover ; + +: render-view ( component -- ) + [ id>> value ] [ render-view* ] bi ; + +: render-error ( error -- ) + write ; + +: render-edit ( component -- ) + dup id>> value dup validation-error? [ + [ reason>> ] [ value>> ] bi rot render-error* + ] [ + swap [ default>> or ] keep render-edit* + ] if ; + +: ( id class -- component ) + \ component construct-empty + swap construct-delegate + swap >>id ; inline + +! Forms +TUPLE: form view-template edit-template components ; + +: ( id -- form ) + form + V{ } clone >>components ; + +: add-field ( form component -- form ) + dup id>> pick components>> set-at ; + +: with-form ( form quot -- ) + >r components>> components r> with-variable ; inline + +: set-defaults ( form -- ) + [ + components get [ + swap values get [ + swap default>> or + ] change-at + ] assoc-each + ] with-form ; + +: view-form ( form -- ) + dup view-template>> '[ , run-template ] with-form ; + +: edit-form ( form -- ) + dup edit-template>> '[ , run-template ] with-form ; + +: validate-param ( id component -- ) + [ [ params get at ] [ validate ] bi* ] + [ drop set-value ] 2bi ; + +: (validate-form) ( form -- error? ) + [ + validation-failed? off + components get [ validate-param ] assoc-each + validation-failed? get + ] with-form ; + +: validate-form ( form -- ) + (validate-form) [ validation-failed ] when ; + +: blank-values H{ } clone values set ; + +: from-tuple values set ; + +: values-tuple values get mirror-object ; + +! ! ! +! Canned components: for simple applications and prototyping +! ! ! + +: render-input ( value component type -- ) + > [ =id ] [ =name ] bi + =value + input/> ; + +! Hidden fields +TUPLE: hidden ; + +: ( component -- component ) + hidden construct-delegate ; + +M: hidden render-view* + 2drop ; + +M: hidden render-edit* + >r dup number? [ number>string ] when r> + "hidden" render-input ; + +! String input fields +TUPLE: string min-length max-length ; + +: ( id -- component ) string ; + +M: string validate* + [ v-one-line ] [ + [ min-length>> [ v-min-length ] when* ] + [ max-length>> [ v-max-length ] when* ] + bi + ] bi* ; + +M: string render-view* + drop write ; + +M: string render-edit* + "text" render-input ; + +M: string render-error* + "text" render-input render-error ; + +! Username fields +TUPLE: username ; + +: ( id -- component ) + username construct-delegate + 2 >>min-length + 20 >>max-length ; + +M: username validate* + delegate validate* v-one-word ; + +! E-mail fields +TUPLE: email ; + +: ( id -- component ) + email construct-delegate + 5 >>min-length + 60 >>max-length ; + +M: email validate* + delegate validate* dup empty? [ v-email ] unless ; + +! Password fields +TUPLE: password ; + +: ( id -- component ) + password construct-delegate + 6 >>min-length + 60 >>max-length ; + +M: password validate* + delegate validate* v-one-word ; + +M: password render-edit* + >r drop f r> "password" render-input ; + +M: password render-error* + render-edit* render-error ; + +! Number fields +TUPLE: number min-value max-value ; + +: ( id -- component ) number ; + +M: number validate* + [ v-number ] [ + [ min-value>> [ v-min-value ] when* ] + [ max-value>> [ v-max-value ] when* ] + bi + ] bi* ; + +M: number render-view* + drop number>string write ; + +M: number render-edit* + >r number>string r> "text" render-input ; + +M: number render-error* + "text" render-input render-error ; + +! Text areas +TUPLE: text ; + +: ( id -- component ) text construct-delegate ; + +: render-textarea + ; + +M: text render-edit* + render-textarea ; + +M: text render-error* + render-textarea render-error ; + +! Simple captchas +TUPLE: captcha ; + +: ( id -- component ) + captcha construct-delegate ; + +M: captcha validate* + drop v-captcha ; diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor new file mode 100755 index 0000000000..09c8471905 --- /dev/null +++ b/extra/http/server/components/farkup/farkup.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: splitting http.server.components kernel io sequences +farkup ; +IN: http.server.components.farkup + +TUPLE: farkup ; + +: ( id -- component ) + farkup construct-delegate ; + +M: farkup render-view* + drop string-lines "\n" join convert-farkup write ; diff --git a/extra/http/server/components/test/form.fhtml b/extra/http/server/components/test/form.fhtml new file mode 100755 index 0000000000..d3f5a12faa --- /dev/null +++ b/extra/http/server/components/test/form.fhtml @@ -0,0 +1 @@ + diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor new file mode 100755 index 0000000000..4893977f76 --- /dev/null +++ b/extra/http/server/crud/crud.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.crud +USING: kernel namespaces db.tuples math.parser http.server +http.server.actions http.server.components +http.server.validators accessors fry locals hashtables ; + +:: ( form ctor -- action ) + + { { "id" [ v-number ] } } >>get-params + + [ "id" get ctor call select-tuple from-tuple ] >>init + + [ + "text/html" + [ form view-form ] >>body + ] >>display ; + +: ( id next -- response ) + swap number>string "id" associate ; + +:: ( form ctor next -- action ) + + [ f ctor call from-tuple form set-defaults ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + f ctor call from-tuple + + form validate-form + + values-tuple insert-tuple + + "id" value next + ] >>submit ; + +:: ( form ctor next -- action ) + + { { "id" [ v-number ] } } >>get-params + [ "id" get ctor call select-tuple from-tuple ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + f ctor call from-tuple + + form validate-form + + values-tuple update-tuple + + "id" value next + ] >>submit ; + +:: ( ctor next -- action ) + + { { "id" [ v-number ] } } >>post-params + + [ + "id" get ctor call delete-tuple + + next f + ] >>submit ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor new file mode 100755 index 0000000000..4a2315b4fd --- /dev/null +++ b/extra/http/server/db/db.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db http.server kernel new-slots accessors +continuations namespaces destructors combinators.cleave ; +IN: http.server.db + +TUPLE: db-persistence responder db params ; + +C: db-persistence + +: connect-db ( db-persistence -- ) + [ db>> ] [ params>> ] bi make-db + [ db set ] [ db-open ] [ add-always-destructor ] tri ; + +M: db-persistence call-responder + [ connect-db ] [ responder>> call-responder ] bi ; 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..e992a1b6fa 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,39 +1,79 @@ -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 +[ + + "www.apple.com" >>host + "/xxx/bar" >>path + { { "a" "b" } } >>query + request set -[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test + [ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test + [ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test + [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test + [ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test + [ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test + [ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test + [ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test + [ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test +] with-scope -[ "index.html" ] -[ "http://www.jedit.org/index.html" url>path ] unit-test +TUPLE: mock-responder path ; -[ "foo/bar" ] -[ "http://www.jedit.org/foo/bar" url>path ] unit-test +C: mock-responder -[ "" ] -[ "http://www.jedit.org/" url>path ] unit-test +M: mock-responder call-responder + nip + path>> on + "text/plain" ; -[ "" ] -[ "http://www.jedit.org" url>path ] unit-test +: check-dispatch ( tag path -- ? ) + over off + main-responder get call-responder + write-response get ; -[ "foobar" ] -[ "foobar" secure-path ] unit-test +[ + + "foo" "foo" add-responder + "bar" "bar" add-responder + + "123" "123" add-responder + "default" >>default + "baz" add-responder + main-responder set -[ f ] -[ "foobar/../baz" secure-path ] unit-test + [ "foo" ] [ + "foo" main-responder get find-responder path>> nip + ] unit-test -[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test -[ ] [ f [ "POO" parse-request ] with-logging ] unit-test + [ "bar" ] [ + "bar" main-responder get find-responder path>> nip + ] unit-test -[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] 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 -[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ] -[ "Foo=Bar&Baz=Quux" query>hash ] unit-test + [ t ] [ + + "baz" >>path + request set + "baz" main-responder get call-responder + dup code>> 300 399 between? >r + header>> "location" swap at "baz/" tail? r> and + ] unit-test +] with-scope -[ H{ { "Baz" " " } } ] -[ "Baz=%20" query>hash ] unit-test +[ + + "default" >>default + main-responder set -[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test + [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test +] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 957a82d09f..37f21278df 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,65 +1,212 @@ ! 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 ; - +threads http sequences prettyprint io.server logging calendar +new-slots html.elements accessors math.parser combinators.lib +vocabs.loader debugger html continuations random combinators +destructors io.encodings.latin1 fry combinators.cleave ; IN: http.server -: (url>path) ( uri -- path ) - url-decode "http://" ?head [ - "/" split1 dup "" ? nip - ] when ; +GENERIC: call-responder ( path responder -- response ) -: url>path ( uri -- path ) - "?" split1 dup [ - >r (url>path) "?" r> 3append +: ( content-type -- response ) + + 200 >>code + swap set-content-type ; + +TUPLE: trivial-responder response ; + +C: trivial-responder + +M: trivial-responder call-responder nip response>> call ; + +: trivial-response-body ( code message -- ) + + +

[ number>string write bl ] [ write ] bi*

+ + ; + +: ( code message -- response ) + 2dup '[ , , trivial-response-body ] + "text/html" + swap >>body + swap >>message + swap >>code ; + +: <400> ( -- response ) + 400 "Bad request" ; + +: <404> ( -- response ) + 404 "Not Found" ; + +SYMBOL: 404-responder + +[ <404> ] 404-responder set-global + +: url-redirect ( to query -- url ) + #! Different host. + dup assoc-empty? [ + drop ] [ - drop (url>path) + assoc>query "?" swap 3append ] if ; -: secure-path ( path -- path ) - ".." over subseq? [ drop f ] when ; +: absolute-redirect ( to query -- url ) + #! Same host. + request get clone + swap [ >>query ] when* + swap >>path + request-url ; -: request-method ( cmd -- method ) - H{ - { "GET" "get" } - { "POST" "post" } - { "HEAD" "head" } - } at "bad" or ; +: replace-last-component ( path with -- path' ) + >r "/" last-split1 drop "/" r> 3append ; -: (handle-request) ( arg cmd -- method path host ) - request-method dup "method" set swap - prepare-url prepare-header host ; +: relative-redirect ( to query -- url ) + request get clone + swap [ >>query ] when* + swap [ '[ , replace-last-component ] change-path ] when* + request-url ; -: handle-request ( arg cmd -- ) - [ (handle-request) serve-responder ] with-scope ; +: derive-url ( to query -- url ) + { + { [ over "http://" head? ] [ url-redirect ] } + { [ over "/" head? ] [ absolute-redirect ] } + { [ t ] [ relative-redirect ] } + } cond ; -: parse-request ( request -- ) - " " split1 dup [ - " HTTP" split1 drop url>path secure-path dup [ - swap handle-request +: ( to query code message -- response ) + -rot derive-url "location" set-header ; + +\ DEBUG add-input-logging + +: ( to query -- response ) + 301 "Moved Permanently" ; + +: ( to query -- response ) + 307 "Temporary Redirect" ; + +TUPLE: dispatcher default responders ; + +: ( -- dispatcher ) + 404-responder get H{ } clone dispatcher construct-boa ; + +: set-main ( dispatcher name -- dispatcher ) + '[ , f ] + >>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-/ ( -- response ) + request get path>> "/" append f ; + +M: dispatcher call-responder ( path dispatcher -- response ) + over [ + 2dup find-responder call-responder [ + 2nip ] [ - 2drop bad-request - ] if + default>> [ + call-responder + ] [ + drop 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: main-responder + +main-responder global +[ drop 404-responder get-global ] cache +drop + +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 + ] >>body ; + +: do-response ( response -- ) + dup write-response + request get method>> "HEAD" = + [ drop ] [ write-response-body ] if ; + +LOG: httpd-hit NOTICE + +: log-request ( request -- ) + { method>> host>> path>> } map-exec-with httpd-hit ; + +SYMBOL: exit-continuation + +: exit-with exit-continuation get continue-with ; + +: do-request ( request -- response ) + '[ + exit-continuation set , + [ + [ log-request ] + [ request set ] + [ path>> main-responder get call-responder ] tri + [ <404> ] unless* + ] [ + [ \ do-request log-error ] + [ <500> ] + bi + ] recover + ] callcc1 + exit-continuation off ; + +: default-timeout 1 minutes stdio get set-timeout ; + +: ?refresh-all ( -- ) + development-mode get-global + [ global [ refresh-all ] bind ] when ; + +: handle-client ( -- ) + [ + default-timeout + ?refresh-all + read-request + do-request + do-response + ] with-destructors ; : httpd ( port -- ) - internet-server "http.server" [ - 60000 stdio get set-timeout - readln [ parse-request ] when* - ] with-server ; + internet-server "http.server" + latin1 [ 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 +! Utility +: generate-key ( assoc -- str ) + >r random-256 >hex r> + 2dup key? [ nip generate-key ] [ drop ] if ; + +: set-at-unique ( value assoc -- key ) + dup generate-key [ swap set-at ] keep ; diff --git a/extra/crypto/rc4/authors.txt b/extra/http/server/sessions/authors.txt similarity index 100% rename from extra/crypto/rc4/authors.txt rename to extra/http/server/sessions/authors.txt diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor new file mode 100755 index 0000000000..5c2d3a57cd --- /dev/null +++ b/extra/http/server/sessions/sessions-tests.factor @@ -0,0 +1,39 @@ +IN: http.server.sessions.tests +USING: tools.test http.server.sessions math namespaces +kernel accessors ; + +: with-session \ session swap with-variable ; inline + +TUPLE: foo ; + +C: foo + +M: foo init-session* drop 0 "x" sset ; + +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 + +[ ] [ + + "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..1d90a32faf --- /dev/null +++ b/extra/http/server/sessions/sessions.factor @@ -0,0 +1,127 @@ +! 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 fry combinators.cleave ; +IN: http.server.sessions + +! ! ! ! ! ! +! WARNING: this session manager is vulnerable to XSRF attacks +! ! ! ! ! ! + +GENERIC: init-session* ( responder -- ) + +M: dispatcher init-session* drop ; + +TUPLE: session-manager responder sessions ; + +: ( responder class -- responder' ) + >r H{ } clone session-manager construct-boa r> + construct-delegate ; inline + +TUPLE: session manager id namespace alarm ; + +: ( manager -- session ) + f H{ } clone \ session construct-boa ; + +: timeout ( -- dt ) 20 minutes ; + +: cancel-timeout ( session -- ) + alarm>> [ cancel-alarm ] if-box? ; + +: delete-session ( session -- ) + [ cancel-timeout ] + [ dup manager>> sessions>> delete-at ] + bi ; + +: touch-session ( session -- session ) + [ cancel-timeout ] + [ [ '[ , delete-session ] timeout later ] keep alarm>> >box ] + [ ] + tri ; + +: session ( -- assoc ) \ session get namespace>> ; + +: sget ( key -- value ) session at ; + +: sset ( value key -- ) session set-at ; + +: schange ( key quot -- ) session swap change-at ; inline + +: init-session ( session -- session ) + dup dup \ session [ + manager>> responder>> init-session* + ] with-variable ; + +: new-session ( responder -- id ) + [ init-session touch-session ] + [ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ] + bi id>> ; + +: get-session ( id responder -- session/f ) + sessions>> at* [ touch-session ] when ; + +: call-responder/session ( 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: null-sessions ; + +: + null-sessions ; + +M: null-sessions call-responder ( path responder -- response ) + dup call-responder/session ; + +TUPLE: url-sessions ; + +: ( responder -- responder' ) + url-sessions ; + +: sess-id "factorsessid" ; + +: current-session ( responder request -- session ) + sess-id query-param swap get-session ; + +M: url-sessions call-responder ( path responder -- response ) + dup request get current-session [ + call-responder/session + ] [ + nip + f swap new-session sess-id associate + ] if* ; + +M: url-sessions session-link* + drop + url-encode + \ session get id>> sess-id associate union assoc>query + dup assoc-empty? [ drop ] [ "?" swap 3append ] if ; + +TUPLE: cookie-sessions ; + +: ( responder -- responder' ) + cookie-sessions ; + +: get-session-cookie ( responder -- cookie ) + request get sess-id get-cookie + [ value>> swap get-session ] [ drop f ] if* ; + +: ( id -- cookie ) + sess-id ; + +M: cookie-sessions call-responder ( path responder -- response ) + dup 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..6c365ad87b --- /dev/null +++ b/extra/http/server/static/static.factor @@ -0,0 +1,104 @@ +! 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 io.encodings.binary +combinators.cleave fry ; +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 ) + [ + + swap + [ file-length "content-length" set-header ] + [ file-http-date "last-modified" set-header ] + [ '[ , binary stdio get stream-copy ] >>body ] + tri + ] ; + +: serve-static ( filename mime-type -- response ) + over last-modified-matches? + [ 2drop <304> ] [ file-responder get hook>> call ] if ; + +: serving-path ( filename -- filename ) + "" or file-responder get root>> swap path+ ; + +: serve-file ( filename -- response ) + dup mime-type + dup file-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 [ + [

file-name write

] + [ +
    + directory sort-keys + [
  • file.
    • ] assoc-each +
+ ] bi + ] simple-html-document ; + +: list-directory ( directory -- response ) + "text/html" + swap '[ , directory. ] >>body ; + +: find-index ( filename -- path ) + { "index.html" "index.fhtml" } [ path+ ] with map + [ exists? ] find nip ; + +: 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 ( path responder -- response ) + file-responder set + dup [ + ".." over subseq? [ + drop <400> + ] [ + serve-object + ] if + ] [ + drop redirect-with-/ + ] if ; diff --git a/extra/http/server/templating/authors.txt b/extra/http/server/templating/fhtml/authors.txt similarity index 100% rename from extra/http/server/templating/authors.txt rename to extra/http/server/templating/fhtml/authors.txt diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor new file mode 100755 index 0000000000..9774e4c1f2 --- /dev/null +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -0,0 +1,20 @@ +USING: io io.files io.streams.string io.encodings.utf8 +http.server.templating.fhtml kernel tools.test sequences +parser ; +IN: http.server.templating.fhtml.tests + +: test-template ( path -- ? ) + "resource:extra/http/server/templating/fhtml/test/" + swap append + [ + ".fhtml" append [ run-template ] with-string-writer + ] keep + ".html" append ?resource-path utf8 file-contents = ; + +[ t ] [ "example" test-template ] unit-test +[ t ] [ "bug" test-template ] unit-test +[ t ] [ "stack" test-template ] unit-test + +[ + [ ] [ "<%\n%>" parse-template drop ] unit-test +] with-file-vocabs diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/fhtml/fhtml.factor similarity index 68% rename from extra/http/server/templating/templating.factor rename to extra/http/server/templating/fhtml/fhtml.factor index f364b86524..8567524217 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -2,13 +2,14 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. 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 ; +io.files io.streams.string html html.elements source-files +debugger combinators math quotations generic strings splitting +accessors http.server.static http.server assocs +io.encodings.utf8 fry ; -IN: http.server.templating +IN: http.server.templating.fhtml -: templating-vocab ( -- vocab-name ) "http.server.templating" ; +: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; ! See apps/http-server/test/ or libs/furnace/ for template usage ! examples @@ -74,23 +75,29 @@ DEFER: <% delimiter : html-error. ( error -- ) 
 error.
; -: run-template-file ( filename -- ) - [ - [ +: run-template ( filename -- ) + '[ + , [ "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 utf8 file-contents + [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs - ] assert-depth drop ; - -: run-relative-template-file ( filename -- ) - file get source-file-path parent-directory - swap path+ run-template-file ; + ] assert-depth ; : template-convert ( infile outfile -- ) - [ run-template-file ] with-file-writer ; + utf8 [ run-template ] with-file-writer ; + +! responder integration +: serve-template ( name -- response ) + "text/html" + swap '[ , run-template ] >>body ; + +! file responder integration +: enable-fhtml ( responder -- responder ) + [ serve-template ] + "application/x-factor-server-page" + pick special>> set-at ; diff --git a/extra/http/server/templating/test/bug.fhtml b/extra/http/server/templating/fhtml/test/bug.fhtml similarity index 100% rename from extra/http/server/templating/test/bug.fhtml rename to extra/http/server/templating/fhtml/test/bug.fhtml diff --git a/extra/http/server/templating/test/bug.html b/extra/http/server/templating/fhtml/test/bug.html similarity index 100% rename from extra/http/server/templating/test/bug.html rename to extra/http/server/templating/fhtml/test/bug.html diff --git a/extra/http/server/templating/test/example.fhtml b/extra/http/server/templating/fhtml/test/example.fhtml similarity index 100% rename from extra/http/server/templating/test/example.fhtml rename to extra/http/server/templating/fhtml/test/example.fhtml diff --git a/extra/http/server/templating/test/example.html b/extra/http/server/templating/fhtml/test/example.html similarity index 100% rename from extra/http/server/templating/test/example.html rename to extra/http/server/templating/fhtml/test/example.html diff --git a/extra/http/server/templating/test/stack.fhtml b/extra/http/server/templating/fhtml/test/stack.fhtml similarity index 100% rename from extra/http/server/templating/test/stack.fhtml rename to extra/http/server/templating/fhtml/test/stack.fhtml diff --git a/extra/http/server/templating/test/stack.html b/extra/http/server/templating/fhtml/test/stack.html similarity index 100% rename from extra/http/server/templating/test/stack.html rename to extra/http/server/templating/fhtml/test/stack.html diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/templating-tests.factor deleted file mode 100644 index d889cd848a..0000000000 --- a/extra/http/server/templating/templating-tests.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: io io.files io.streams.string http.server.templating kernel tools.test - sequences ; -IN: temporary - -: test-template ( path -- ? ) - "extra/http/server/templating/test/" swap append - [ - ".fhtml" append resource-path - [ run-template-file ] with-string-writer - ] keep - ".html" append resource-path file-contents = ; - -[ t ] [ "example" test-template ] unit-test -[ t ] [ "bug" test-template ] unit-test -[ t ] [ "stack" test-template ] unit-test - -[ ] [ "<%\n%>" parse-template drop ] unit-test diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor new file mode 100755 index 0000000000..3ef2b6c863 --- /dev/null +++ b/extra/http/server/validators/validators-tests.factor @@ -0,0 +1,22 @@ +IN: http.server.validators.tests +USING: kernel sequences tools.test http.server.validators +accessors ; + +[ "foo" v-number ] [ validation-error? ] must-fail-with + +[ "slava@factorcode.org" ] [ + "slava@factorcode.org" v-email +] unit-test + +[ "slava+foo@factorcode.org" ] [ + "slava+foo@factorcode.org" v-email +] unit-test + +[ "slava@factorcode.o" v-email ] +[ reason>> "invalid e-mail" = ] must-fail-with + +[ "sla@@factorcode.o" v-email ] +[ reason>> "invalid e-mail" = ] must-fail-with + +[ "slava@factorcodeorg" v-email ] +[ reason>> "invalid e-mail" = ] must-fail-with diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor new file mode 100755 index 0000000000..7eb5163d33 --- /dev/null +++ b/extra/http/server/validators/validators.factor @@ -0,0 +1,75 @@ +! Copyright (C) 2006, 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel continuations sequences math namespaces +math.parser assocs new-slots regexp fry unicode.categories +combinators.cleave sequences ; +IN: http.server.validators + +TUPLE: validation-error value reason ; + +: validation-error ( value reason -- * ) + \ validation-error construct-boa throw ; + +: v-default ( str def -- str ) + over empty? spin ? ; + +: v-required ( str -- str ) + dup empty? [ "required" validation-error ] when ; + +: v-min-length ( str n -- str ) + over length over < [ + [ "must be at least " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-length ( str n -- str ) + over length over > [ + [ "must be no more than " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-number ( str -- n ) + dup string>number [ ] [ + "must be a number" validation-error + ] ?if ; + +: v-min-value ( x n -- x ) + 2dup < [ + [ "must be at least " % # ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-value ( x n -- x ) + 2dup > [ + [ "must be no more than " % # ] "" make + validation-error + ] [ + drop + ] if ; + +: v-regexp ( str what regexp -- str ) + >r over r> matches? + [ drop ] [ "invalid " swap append validation-error ] if ; + +: v-email ( str -- str ) + #! From http://www.regular-expressions.info/email.html + "e-mail" + R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i + v-regexp ; + +: v-captcha ( str -- str ) + dup empty? [ "must remain blank" validation-error ] unless ; + +: v-one-line ( str -- str ) + dup "\r\n" seq-intersect empty? + [ "must be a single line" validation-error ] unless ; + +: v-one-word ( str -- str ) + dup [ alpha? ] all? + [ "must be a single word" validation-error ] unless ; diff --git a/extra/http/test/foo.html b/extra/http/test/foo.html new file mode 100644 index 0000000000..2638986853 --- /dev/null +++ b/extra/http/test/foo.html @@ -0,0 +1 @@ +HelloHTTPd test diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index ae0e058490..1740e8a523 100755 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences kernel.private namespaces arrays io io.files splitting io.binary math.functions vectors quotations -combinators ; +combinators io.encodings.binary ; IN: icfp.2006 SYMBOL: regs @@ -134,7 +134,7 @@ SYMBOL: open-arrays [ run-op exec-loop ] unless ; : load-platters ( path -- ) - file-contents 4 group [ be> ] map + binary file-contents 4 group [ be> ] map 0 arrays get set-nth ; : init ( path -- ) diff --git a/extra/io/buffers/buffers-docs.factor b/extra/io/buffers/buffers-docs.factor old mode 100644 new mode 100755 index def3e475f7..5ce9b71427 --- a/extra/io/buffers/buffers-docs.factor +++ b/extra/io/buffers/buffers-docs.factor @@ -1,8 +1,8 @@ -USING: help.markup help.syntax strings alien ; +USING: help.markup help.syntax byte-arrays alien ; IN: io.buffers ARTICLE: "buffers" "Locked I/O buffers" -"I/O buffers are first-in-first-out queues of characters. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends." +"I/O buffers are first-in-first-out queues of bytes. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends." $nl "Buffer words are found in the " { $vocab-link "buffers" } " vocabulary." { $subsection buffer } @@ -23,14 +23,14 @@ $nl { $subsection buffer-until } "Writing to the buffer:" { $subsection extend-buffer } -{ $subsection ch>buffer } +{ $subsection byte>buffer } { $subsection >buffer } { $subsection n>buffer } ; ABOUT: "buffers" HELP: buffer -{ $class-description "The class of I/O buffers, which resemble FIFO queues, but are optimize for holding bytes, are have underlying storage allocated at a fixed address. Buffers must be de-allocated manually." +{ $class-description "The class of I/O buffers, which resemble FIFO queues, but are optimized for holding bytes, are have underlying storage allocated at a fixed address. Buffers must be de-allocated manually." $nl "Buffers have two internal pointers:" { $list @@ -48,7 +48,7 @@ HELP: buffer-free { $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ; HELP: (buffer>>) -{ $values { "buffer" buffer } { "string" "a string" } } +{ $values { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects the entire contents of the buffer into a string." } ; HELP: buffer-reset @@ -68,15 +68,15 @@ HELP: buffer-end { $description "Outputs the memory address of the current fill-pointer." } ; HELP: (buffer>) -{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" string } } +{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } { $description "Outputs a string of the first " { $snippet "n" } " characters at the buffer's current position. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ; HELP: buffer> -{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" "a string" } } +{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects a string of " { $snippet "n" } " characters starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ; HELP: buffer>> -{ $values { "buffer" buffer } { "string" "a string" } } +{ $values { "buffer" buffer } { "byte-array" byte-array } } { $description "Collects the contents of the buffer into a string, and resets the position and fill pointer to 0." } ; HELP: buffer-length @@ -102,11 +102,11 @@ HELP: check-overflow { $errors "Throws an error if the buffer contains unread data, and the new data does not fit." } ; HELP: >buffer -{ $values { "string" "a string" } { "buffer" buffer } } +{ $values { "byte-array" byte-array } { "buffer" buffer } } { $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ; -HELP: ch>buffer -{ $values { "ch" "a character" } { "buffer" buffer } } +HELP: byte>buffer +{ $values { "byte" "a byte" } { "buffer" buffer } } { $description "Appends a single byte to a buffer." } ; HELP: n>buffer @@ -115,13 +115,13 @@ HELP: n>buffer { $errors "Throws an error if the buffer does not contain " { $snippet "n" } " bytes of data." } ; HELP: buffer-peek -{ $values { "buffer" buffer } { "ch" "a character" } } +{ $values { "buffer" buffer } { "byte" "a byte" } } { $description "Outputs the byte at the buffer position." } ; HELP: buffer-pop -{ $values { "buffer" buffer } { "ch" "a character" } } +{ $values { "buffer" buffer } { "byte" "a byte" } } { $description "Outputs the byte at the buffer position and advances the position." } ; HELP: buffer-until -{ $values { "separators" string } { "buffer" buffer } { "string" string } { "separator" "a character or " { $link f } } } -{ $description "Searches the buffer for a character appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ; +{ $values { "separators" "a sequence of bytes" } { "buffer" buffer } { "byte-array" byte-array } { "separator" "a byte or " { $link f } } } +{ $description "Searches the buffer for a byte appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ; diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index c9203d9ef8..1f3e262fed 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -1,15 +1,15 @@ -IN: temporary +IN: io.buffers.tests USING: alien alien.c-types io.buffers kernel kernel.private libc -sequences tools.test namespaces ; +sequences tools.test namespaces byte-arrays strings ; : buffer-set ( string buffer -- ) - 2dup buffer-ptr string>char-memory + over >byte-array over buffer-ptr byte-array>memory >r length r> buffer-reset ; : string>buffer ( string -- buffer ) dup length tuck buffer-set ; -[ "" 65536 ] [ +[ B{ } 65536 ] [ 65536 dup (buffer>>) over buffer-capacity @@ -18,15 +18,15 @@ sequences tools.test namespaces ; [ "hello world" "" ] [ "hello world" string>buffer - dup (buffer>>) + dup (buffer>>) >string 0 pick buffer-reset - over (buffer>>) + over (buffer>>) >string rot buffer-free ] unit-test [ "hello" ] [ "hello world" string>buffer - 5 over buffer> swap buffer-free + 5 over buffer> >string swap buffer-free ] unit-test [ 11 ] [ @@ -36,8 +36,8 @@ sequences tools.test namespaces ; [ "hello world" ] [ "hello" 1024 [ buffer-set ] keep - " world" over >buffer - dup (buffer>>) swap buffer-free + " world" >byte-array over >buffer + dup (buffer>>) >string swap buffer-free ] unit-test [ CHAR: e ] [ @@ -47,33 +47,33 @@ sequences tools.test namespaces ; [ "hello" CHAR: \r ] [ "hello\rworld" string>buffer - "\r" over buffer-until + "\r" over buffer-until >r >string r> rot buffer-free ] unit-test [ "hello" CHAR: \r ] [ "hello\rworld" string>buffer - "\n\r" over buffer-until + "\n\r" over buffer-until >r >string r> rot buffer-free ] unit-test [ "hello\rworld" f ] [ "hello\rworld" string>buffer - "X" over buffer-until + "X" over buffer-until >r >string r> rot buffer-free ] unit-test [ "hello" CHAR: \r "world" CHAR: \n ] [ "hello\rworld\n" string>buffer - [ "\r\n" swap buffer-until ] keep - [ "\r\n" swap buffer-until ] keep + [ "\r\n" swap buffer-until >r >string r> ] keep + [ "\r\n" swap buffer-until >r >string r> ] keep buffer-free ] unit-test "hello world" string>buffer "b" set -[ "hello world" ] [ 1000 "b" get buffer> ] unit-test +[ "hello world" ] [ 1000 "b" get buffer> >string ] unit-test "b" get buffer-free 100 "b" set -[ 1000 "b" get n>buffer ] must-fail +[ 1000 "b" get n>buffer >string ] must-fail "b" get buffer-free diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index ef12543d52..7d51d04d7b 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.buffers USING: alien alien.accessors alien.c-types alien.syntax kernel -kernel.private libc math sequences strings hints ; +kernel.private libc math sequences byte-arrays strings hints ; TUPLE: buffer size ptr fill pos ; @@ -31,24 +31,24 @@ TUPLE: buffer size ptr fill pos ; : buffer-end ( buffer -- alien ) dup buffer-fill swap buffer-ptr ; -: buffer-peek ( buffer -- ch ) +: buffer-peek ( buffer -- byte ) buffer@ 0 alien-unsigned-1 ; -: buffer-pop ( buffer -- ch ) +: buffer-pop ( buffer -- byte ) dup buffer-peek 1 rot buffer-consume ; -: (buffer>) ( n buffer -- string ) +: (buffer>) ( n buffer -- byte-array ) [ dup buffer-fill swap buffer-pos - min ] keep - buffer@ swap memory>char-string ; + buffer@ swap memory>byte-array ; -: buffer> ( n buffer -- string ) +: buffer> ( n buffer -- byte-array ) [ (buffer>) ] 2keep buffer-consume ; -: (buffer>>) ( buffer -- string ) +: (buffer>>) ( buffer -- byte-array ) dup buffer-pos over buffer-ptr - over buffer-fill rot buffer-pos - memory>char-string ; + over buffer-fill rot buffer-pos - memory>byte-array ; -: buffer>> ( buffer -- string ) +: buffer>> ( buffer -- byte-array ) dup (buffer>>) 0 rot buffer-reset ; : search-buffer-until ( start end alien separators -- n ) @@ -56,7 +56,7 @@ TUPLE: buffer size ptr fill pos ; HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; -: finish-buffer-until ( buffer n -- string separator ) +: finish-buffer-until ( buffer n -- byte-array separator ) [ over buffer-pos - over buffer> @@ -65,7 +65,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; buffer>> f ] if* ; -: buffer-until ( separators buffer -- string separator ) +: buffer-until ( separators buffer -- byte-array separator ) tuck { buffer-pos buffer-fill buffer-ptr } get-slots roll search-buffer-until finish-buffer-until ; @@ -85,12 +85,12 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; : check-overflow ( n buffer -- ) 2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ; -: >buffer ( string buffer -- ) +: >buffer ( byte-array buffer -- ) over length over check-overflow - [ buffer-end string>char-memory ] 2keep + [ buffer-end byte-array>memory ] 2keep [ buffer-fill swap length + ] keep set-buffer-fill ; -: ch>buffer ( ch buffer -- ) +: byte>buffer ( byte buffer -- ) 1 over check-overflow [ buffer-end 0 set-alien-unsigned-1 ] keep [ buffer-fill 1+ ] keep set-buffer-fill ; diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor new file mode 100644 index 0000000000..1c50e4c2a4 --- /dev/null +++ b/extra/io/encodings/ascii/ascii.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ; +IN: io.encodings.ascii + +: encode-check<= ( string stream max -- ) + [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ; + +TUPLE: ascii ; + +M: ascii stream-write-encoded ( string stream encoding -- ) + drop 128 encode-check<= ; + +M: ascii decode-step + drop dup 128 >= [ decode-error ] [ swap push ] if ; diff --git a/core/io/encodings/utf16/authors.txt b/extra/io/encodings/ascii/authors.txt similarity index 100% rename from core/io/encodings/utf16/authors.txt rename to extra/io/encodings/ascii/authors.txt diff --git a/extra/io/encodings/ascii/summary.txt b/extra/io/encodings/ascii/summary.txt new file mode 100644 index 0000000000..8c54de7680 --- /dev/null +++ b/extra/io/encodings/ascii/summary.txt @@ -0,0 +1 @@ +ASCII encoding for streams diff --git a/extra/io/encodings/ascii/tags.txt b/extra/io/encodings/ascii/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/io/encodings/ascii/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/io/encodings/latin1/authors.txt b/extra/io/encodings/latin1/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/io/encodings/latin1/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/core/io/encodings/latin1/latin1-docs.factor b/extra/io/encodings/latin1/latin1-docs.factor similarity index 100% rename from core/io/encodings/latin1/latin1-docs.factor rename to extra/io/encodings/latin1/latin1-docs.factor diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor new file mode 100755 index 0000000000..3cb361b2fd --- /dev/null +++ b/extra/io/encodings/latin1/latin1.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.encodings strings kernel io.encodings.ascii sequences math ; +IN: io.encodings.latin1 + +TUPLE: latin1 ; + +M: latin1 stream-write-encoded + drop 256 encode-check<= ; + +M: latin1 decode-step + drop swap push ; diff --git a/core/io/encodings/latin1/summary.txt b/extra/io/encodings/latin1/summary.txt similarity index 100% rename from core/io/encodings/latin1/summary.txt rename to extra/io/encodings/latin1/summary.txt diff --git a/extra/io/encodings/latin1/tags.txt b/extra/io/encodings/latin1/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/io/encodings/latin1/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/io/encodings/utf16/.utf16.factor.swo b/extra/io/encodings/utf16/.utf16.factor.swo similarity index 100% rename from core/io/encodings/utf16/.utf16.factor.swo rename to extra/io/encodings/utf16/.utf16.factor.swo diff --git a/extra/io/encodings/utf16/authors.txt b/extra/io/encodings/utf16/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/io/encodings/utf16/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/core/io/encodings/utf16/summary.txt b/extra/io/encodings/utf16/summary.txt similarity index 100% rename from core/io/encodings/utf16/summary.txt rename to extra/io/encodings/utf16/summary.txt diff --git a/extra/io/encodings/utf16/tags.txt b/extra/io/encodings/utf16/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/io/encodings/utf16/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor new file mode 100644 index 0000000000..018a15a534 --- /dev/null +++ b/extra/io/encodings/utf16/utf16-docs.factor @@ -0,0 +1,22 @@ +USING: help.markup help.syntax io.encodings strings ; +IN: io.encodings.utf16 + +ARTICLE: "utf16" "Working with UTF-16-encoded data" +"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:" +{ $subsection utf16le } +{ $subsection utf16be } +{ $subsection utf16 } +"All of these conform to the " { $link "encodings-protocol" } "." ; + +ABOUT: "utf16" + +HELP: utf16le +{ $class-description "The encoding protocol for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ; + +HELP: utf16be +{ $class-description "The encoding protocol for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ; + +HELP: utf16 +{ $class-description "The encoding protocol for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." } ; + +{ utf16 utf16le utf16be } related-words diff --git a/extra/io/encodings/utf16/utf16-tests.factor b/extra/io/encodings/utf16/utf16-tests.factor new file mode 100755 index 0000000000..89b61a3e37 --- /dev/null +++ b/extra/io/encodings/utf16/utf16-tests.factor @@ -0,0 +1,22 @@ +USING: kernel tools.test io.encodings.utf16 arrays sbufs +sequences io.encodings io unicode io.encodings.string ; + +[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test +[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test + +[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test + +[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test +[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test +[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test + +[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test + +[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test +[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test + +[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test diff --git a/core/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor similarity index 55% rename from core/io/encodings/utf16/utf16.factor rename to extra/io/encodings/utf16/utf16.factor index 35b6282e21..a501fad0bd 100755 --- a/core/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -1,9 +1,13 @@ -! Copyright (C) 2006, 2007 Daniel Ehrenberg. +! Copyright (C) 2006, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary io.encodings combinators splitting io byte-arrays ; IN: io.encodings.utf16 +! UTF-16BE decoding + +TUPLE: utf16be ch state ; + SYMBOL: double SYMBOL: quad1 SYMBOL: quad2 @@ -16,7 +20,7 @@ SYMBOL: ignore 8 shift bitor ; : end-multibyte ( buf byte ch -- buf ch state ) - append-nums decoded ; + append-nums push-decoded ; : begin-utf16be ( buf byte -- buf ch state ) dup -3 shift BIN: 11011 number= [ @@ -36,12 +40,24 @@ SYMBOL: ignore { double [ end-multibyte ] } { quad1 [ append-nums quad2 ] } { quad2 [ handle-quad2be ] } - { quad3 [ append-nums HEX: 10000 + decoded ] } + { quad3 [ append-nums HEX: 10000 + push-decoded ] } { ignore [ 2drop push-replacement ] } } case ; -: decode-utf16be ( seq -- str ) - [ decode-utf16be-step ] decode ; +: unpack-state-be ( encoding -- ch state ) + { utf16be-ch utf16be-state } get-slots ; + +: pack-state-be ( ch state encoding -- ) + { set-utf16be-ch set-utf16be-state } set-slots ; + +M: utf16be decode-step + [ unpack-state-be decode-utf16be-step ] keep pack-state-be drop ; + +M: utf16be init-decoder nip begin over set-utf16be-state ; + +! UTF-16LE decoding + +TUPLE: utf16le ch state ; : handle-double ( buf byte ch -- buf ch state ) swap dup -3 shift BIN: 11011 = [ @@ -52,7 +68,7 @@ SYMBOL: ignore : handle-quad3le ( buf byte ch -- buf ch state ) swap dup -2 shift BIN: 110111 = [ - BIN: 11 bitand append-nums HEX: 10000 + decoded + BIN: 11 bitand append-nums HEX: 10000 + push-decoded ] [ 2drop push-replacement ] if ; : decode-utf16le-step ( buf byte ch state -- buf ch state ) @@ -64,8 +80,18 @@ SYMBOL: ignore { quad3 [ handle-quad3le ] } } case ; -: decode-utf16le ( seq -- str ) - [ decode-utf16le-step ] decode ; +: unpack-state-le ( encoding -- ch state ) + { utf16le-ch utf16le-state } get-slots ; + +: pack-state-le ( ch state encoding -- ) + { set-utf16le-ch set-utf16le-state } set-slots ; + +M: utf16le decode-step + [ unpack-state-le decode-utf16le-step ] keep pack-state-le drop ; + +M: utf16le init-decoder nip begin over set-utf16le-state ; + +! UTF-16LE/BE encoding : encode-first -10 shift @@ -80,73 +106,50 @@ SYMBOL: ignore : char>utf16be ( char -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first swap , , - encode-second swap , , - ] [ h>b/b , , ] if ; + dup encode-first swap write1 write1 + encode-second swap write1 write1 + ] [ h>b/b write1 write1 ] if ; -: encode-utf16be ( str -- seq ) - [ [ char>utf16be ] each ] B{ } make ; +: stream-write-utf16be ( string stream -- ) + [ [ char>utf16be ] each ] with-stream* ; + +M: utf16be stream-write-encoded ( string stream encoding -- ) + drop stream-write-utf16be ; : char>utf16le ( char -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first , , - encode-second , , - ] [ h>b/b swap , , ] if ; + dup encode-first write1 write1 + encode-second write1 write1 + ] [ h>b/b swap write1 write1 ] if ; -: encode-utf16le ( str -- seq ) - [ [ char>utf16le ] each ] B{ } make ; +: stream-write-utf16le ( string stream -- ) + [ [ char>utf16le ] each ] with-stream* ; + +M: utf16le stream-write-encoded ( string stream encoding -- ) + drop stream-write-utf16le ; + +! UTF-16 : bom-le B{ HEX: ff HEX: fe } ; inline : bom-be B{ HEX: fe HEX: ff } ; inline -: encode-utf16 ( str -- seq ) - encode-utf16le bom-le swap append ; - : start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ; : start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ; -: decode-utf16 ( seq -- str ) - { - { [ start-utf16le? ] [ decode-utf16le ] } - { [ start-utf16be? ] [ decode-utf16be ] } - { [ t ] [ decode-error ] } - } cond ; +TUPLE: utf16 started? ; -TUPLE: utf16le ; -INSTANCE: utf16le encoding-stream - -M: utf16le encode-string drop encode-utf16le ; -M: utf16le decode-step drop decode-utf16le-step ; - -TUPLE: utf16be ; -INSTANCE: utf16be encoding-stream - -M: utf16be encode-string drop encode-utf16be ; -M: utf16be decode-step drop decode-utf16be-step ; - -TUPLE: utf16 encoding ; -INSTANCE: utf16 encoding-stream -M: utf16 underlying-stream delegate dup delegate [ ] [ ] ?if ; ! necessary? -M: utf16 set-underlying-stream delegate set-delegate ; ! necessary? - -M: utf16 encode-string - >r encode-utf16le r> - dup utf16-encoding [ drop ] - [ t swap set-utf16-encoding bom-le swap append ] if ; +M: utf16 stream-write-encoded + dup utf16-started? [ drop ] + [ t swap set-utf16-started? bom-le over stream-write ] if + stream-write-utf16le ; : bom>le/be ( bom -- le/be ) dup bom-le sequence= [ drop utf16le ] [ bom-be sequence= [ utf16be ] [ decode-error ] if ] if ; -: read-bom ( utf16 -- encoding ) - 2 over delegate stream-read bom>le/be construct-empty - [ swap set-utf16-encoding ] keep ; - -M: utf16 decode-step - ! inefficient: checks if bom is done many times - ! This should transform itself into utf16be or utf16le after reading BOM - dup utf16-encoding [ ] [ read-bom ] ?if decode-step ; +M: utf16 init-decoder ( stream encoding -- newencoding ) + 2 rot stream-read bom>le/be construct-empty init-decoder ; 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/authors.txt b/extra/io/launcher/authors.txt index 7c1b2f2279..5674120196 100644 --- a/extra/io/launcher/authors.txt +++ b/extra/io/launcher/authors.txt @@ -1 +1,2 @@ Doug Coleman +Slava Pestov diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 3a557e9fd5..7fdd22c8a5 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -1,118 +1,94 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax quotations kernel io math ; +USING: help.markup help.syntax quotations kernel io math +calendar ; IN: io.launcher -HELP: +command+ -{ $description "Launch descriptor key. A command line string, to be processed by the system's shell." } ; +ARTICLE: "io.launcher.command" "Specifying a command" +"The " { $snippet "command" } " slot of a " { $link process } " can contain either a string or a sequence of strings. In the first case, the string is processed in an operating system-specific manner. In the second case, the first element is a program name and the remaining elements are passed to the program as command-line arguments." ; -HELP: +arguments+ -{ $description "Launch descriptor key. A sequence of command line argument strings. The first element is the program to launch and the remaining arguments are passed to the program without further processing." } ; +ARTICLE: "io.launcher.detached" "Running processes in the background" +"By default, " { $link run-process } " waits for the process to complete. To run a process without waiting for it to finish, set the " { $snippet "detached" } " slot of a " { $link process } ", or use the following word:" +{ $subsection run-detached } ; -HELP: +detached+ -{ $description "Launch descriptor key. A boolean indicating whether " { $link run-process } " will return immediately, rather than wait for the program to complete." +ARTICLE: "io.launcher.environment" "Setting environment variables" +"The " { $snippet "environment" } " slot of a " { $link process } " contains an association mapping environment variable names to values. The interpretation of environment variables is operating system-specific." $nl -"Default value is " { $link f } "." } -{ $notes "Cannot be used with " { $link } "." } -{ $see-also run-detached } ; +"The " { $snippet "environment-mode" } " slot controls how the environment of the current Factor instance is composed with the value of the " { $snippet "environment" } " slot:" +{ $subsection +prepend-environment+ } +{ $subsection +replace-environment+ } +{ $subsection +append-environment+ } +"The default value is " { $link +append-environment+ } "." ; -HELP: +environment+ -{ $description "Launch descriptor key. An association mapping strings to strings, specifying environment variables to set for the spawned process. The association is combined with the current environment using the operation specified by the " { $link +environment-mode+ } " launch descriptor key." +ARTICLE: "io.launcher.redirection" "Input/output redirection" +"On all operating systems except for Windows CE, the default input/output/error streams can be redirected." $nl -"Default value is an empty association." } ; - -HELP: +environment-mode+ -{ $description "Launch descriptor key. Must equal of the following:" - { $list - { $link +prepend-environment+ } - { $link +replace-environment+ } - { $link +append-environment+ } - } -"Default value is " { $link +append-environment+ } "." -} ; - -HELP: +stdin+ -{ $description "Launch descriptor key. Must equal one of the following:" - { $list - { { $link f } " - standard input is inherited" } - { { $link +closed+ } " - standard input is closed" } - { "a path name - standard input is read from the given file, which must exist" } - } -} ; - -HELP: +stdout+ -{ $description "Launch descriptor key. Must equal one of the following:" - { $list - { { $link f } " - standard output is inherited" } - { { $link +closed+ } " - standard output is closed" } - { "a path name - standard output is written to the given file, which is overwritten if it already exists" } - } -} ; - -HELP: +stderr+ -{ $description "Launch descriptor key. Must equal one of the following:" - { $list - { { $link f } " - standard error is inherited" } - { { $link +closed+ } " - standard error is closed" } - { "a path name - standard error is written to the given file, which is overwritten if it already exists" } - } +"To specify redirection, set the " { $snippet "stdin" } ", " { $snippet "stdout" } " and " { $snippet "stderr" } " slots of a " { $link process } " to one of the following values:" +{ $list + { { $link f } " - default value; the stream is either inherited from the current process, or is a " { $link } " pipe" } + { { $link +inherit+ } " - the stream is inherited from the current process, overriding a " { $link } " pipe" } + { { $link +closed+ } " - the stream is closed; reads will return end of file and writes will fails" } + { { $link +stdout+ } " - a special value for the " { $snippet "stderr" } " slot only, indicating that the standard output and standard error streams should be merged" } + { "a path name - the stream is sent to the given file, which must exist for input and is created automatically on output" } + { "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" } } ; HELP: +closed+ -{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; +{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ; + +HELP: +inherit+ +{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ; + +HELP: +stdout+ +{ $description "Possible value for the " { $snippet "stderr" } " slot of a " { $link process } "." } ; 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." +{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "." +$nl +"If this value is set, the child process environment consists of the value of the " { $snippet "environment" } " slot together with the current environment, with entries from the current environment taking precedence." $nl "This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ; HELP: +replace-environment+ -{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key." +{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "." +$nl +"The child process environment consists of the value of the " { $snippet "environment" } " slot." $nl "This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ; HELP: +append-environment+ -{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence." +{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "." +$nl +"The child process environment consists of the current environment together with the value of the " { $snippet "environment" } " key, with entries from the " { $snippet "environment" } " key taking precedence." $nl "This is used in situations where you want a spawn child process with some overridden environment variables." } ; -HELP: +timeout+ -{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ; - -HELP: default-descriptor -{ $description "Association storing default values for launch descriptor keys." } ; - -HELP: with-descriptor -{ $values { "desc" "a launch descriptor" } { "quot" quotation } } -{ $description "Calls the quotation in a dynamic scope where keys from " { $snippet "desc" } " can be read as variables, and any keys not supplied assume their default value as set in " { $link default-descriptor } "." } ; +ARTICLE: "io.launcher.timeouts" "Process run-time timeouts" +"The " { $snippet "timeout" } " slot of a " { $link process } " can be set to a " { $link duration } " specifying a maximum running time for the process. If " { $link wait-for-process } " is called and the process does not exit before the duration expires, it will be killed." ; HELP: get-environment -{ $values { "env" "an association" } } -{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ; +{ $values { "process" process } { "env" "an association" } } +{ $description "Combines the current environment with the value of the " { $snippet "environment" } " slot of the " { $link process } " using the " { $snippet "environment-mode" } " slot." } ; HELP: current-process-handle { $values { "handle" "a process handle" } } { $description "Returns the handle of the current process." } ; HELP: run-process* -{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } } -{ $contract "Launches a process using the launch descriptor." } +{ $values { "process" process } { "handle" "a process handle" } } +{ $contract "Launches a process." } { $notes "User code should call " { $link run-process } " instead." } ; -HELP: >descriptor -{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } } -{ $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ; - HELP: run-process { $values { "desc" "a launch descriptor" } { "process" process } } -{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." } +{ $description "Launches a process. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." } { $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; HELP: run-detached { $values { "desc" "a launch descriptor" } { "process" process } } -{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." } +{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." } { $notes - "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set." + "This word is functionally identical to passing a " { $link process } " to " { $link run-process } " having the " { $snippet "detached" } " slot set." $nl "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; @@ -136,11 +112,11 @@ HELP: kill-process* { $notes "User code should call " { $link kill-process } " intead." } ; HELP: process -{ $class-description "A class representing an active or finished process." -$nl -"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances." -$nl -"Processes can be passed to " { $link wait-for-process } "." } ; +{ $class-description "A class representing a process. Instances are created by calling " { $link } "." } ; + +HELP: +{ $values { "process" process } } +{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ; HELP: process-stream { $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ; @@ -148,9 +124,9 @@ HELP: process-stream HELP: { $values { "desc" "a launch descriptor" } + { "encoding" "an encoding descriptor" } { "stream" "a bidirectional stream" } } -{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." } -{ $notes "Closing the stream will block until the process exits." } ; +{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ; HELP: with-process-stream { $values @@ -164,41 +140,82 @@ HELP: wait-for-process { $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ; ARTICLE: "io.launcher.descriptors" "Launch descriptors" -"Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:" -{ $list - { "strings are wrapped in an assoc with a single " { $link +command+ } " key" } - { "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" } - { "associations can be passed in, which allows finer control over launch parameters" } -} -"The associations can contain the following keys:" -{ $subsection +command+ } -{ $subsection +arguments+ } -{ $subsection +detached+ } -{ $subsection +environment+ } -{ $subsection +environment-mode+ } -{ $subsection +timeout+ } -{ $subsection +stdin+ } -{ $subsection +stdout+ } -{ $subsection +stderr+ } ; +"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "." +$nl +"Strings and string arrays are wrapped in a new empty " { $link process } " with the " { $snippet "command" } " slot set. This covers basic use-cases where no launch parameters need to be set." +$nl +"A " { $link process } " instance can be created directly and passed to launching words for more control. It must be a fresh instance which has never been spawned before. To spawn a process several times from the same descriptor, " { $link clone } " the descriptor first." ; -ARTICLE: "io.launcher" "Launching OS processes" -"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching." -{ $subsection "io.launcher.descriptors" } -"The following words are used to launch processes:" +ARTICLE: "io.launcher.lifecycle" "The process lifecycle" +"A freshly instantiated " { $link process } " represents a set of launch parameters." +{ $subsection process } +{ $subsection } +"Words for launching processes take a fresh process which has never been started before as input, and output a copy as output." +{ $subsection process-started? } +"The " { $link process } " instance output by launching words contains all original slot values in addition to the " { $snippet "handle" } " slot, which indicates the process is currently running." +{ $subsection process-running? } +"It is possible to wait for a process to exit:" +{ $subsection wait-for-process } +"A running process can also be killed:" +{ $subsection kill-process } ; + +ARTICLE: "io.launcher.launch" "Launching processes" +"Launching processes:" { $subsection run-process } -{ $subsection run-detached } { $subsection try-process } -"Stopping processes:" -{ $subsection kill-process } -"Finding the current process handle:" -{ $subsection current-process-handle } "Redirecting standard input and output to a pipe:" { $subsection } -{ $subsection with-process-stream } -"A class representing an active or finished process:" -{ $subsection process } -"Waiting for a process to end, or getting the exit code of a finished process:" -{ $subsection wait-for-process } -"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ; +{ $subsection with-process-stream } ; + +ARTICLE: "io.launcher.examples" "Launcher examples" +"Starting a command and waiting for it to finish:" +{ $code + "\"ls /etc\" run-process" +} +"Starting a program in the background:" +{ $code + "{ \"emacs\" \"foo.txt\" } run-detached" +} +"Running a command, throwing an exception if it exits unsuccessfully:" +{ $code + "\"make clean all\" try-process" +} +"Running a command, throwing an exception if it exits unsuccessfully or if it takes too long to run:" +{ $code + "" + " \"make test\" >>command" + " 5 minutes >>timeout" + "try-process" +} +"Running a command, throwing an exception if it exits unsuccessfully, and redirecting output and error messages to a log file:" +{ $code + "" + " \"make clean all\" >>command" + " \"log.txt\" >>stdout" + " +stdout+ >>stderr" + "try-process" +} +"Running a command, appending error messages to a log file, and reading the output for further processing:" +{ $code + "\"log.txt\" [" + " " + " swap >>stderr" + " \"report\" >>command" + " ascii lines sort reverse [ print ] each" + "] with-disposal" +} ; + +ARTICLE: "io.launcher" "Operating system processes" +"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching." +{ $subsection "io.launcher.examples" } +{ $subsection "io.launcher.descriptors" } +{ $subsection "io.launcher.launch" } +"Advanced topics:" +{ $subsection "io.launcher.lifecycle" } +{ $subsection "io.launcher.command" } +{ $subsection "io.launcher.detached" } +{ $subsection "io.launcher.environment" } +{ $subsection "io.launcher.redirection" } +{ $subsection "io.launcher.timeouts" } ; ABOUT: "io.launcher" 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 eda4332473..e133416101 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -2,65 +2,72 @@ ! 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 ; +init threads continuations math io.encodings io.streams.duplex +io.nonblocking new-slots accessors ; IN: io.launcher + +TUPLE: process + +command +detached + +environment +environment-mode + +stdin +stdout +stderr + +timeout + +handle status +killed ; + +SYMBOL: +closed+ +SYMBOL: +inherit+ +SYMBOL: +stdout+ + +SYMBOL: +prepend-environment+ +SYMBOL: +replace-environment+ +SYMBOL: +append-environment+ + +: ( -- process ) + process construct-empty + H{ } clone >>environment + +append-environment+ >>environment-mode ; + +: process-started? ( process -- ? ) + dup handle>> swap status>> or ; + +: process-running? ( process -- ? ) + process-handle >boolean ; + ! Non-blocking process exit notification facility SYMBOL: processes [ H{ } clone processes set-global ] "io.launcher" add-init-hook -TUPLE: process handle status killed? lapse ; - HOOK: register-process io-backend ( process -- ) M: object register-process drop ; -: ( handle -- process ) - f f process construct-boa +: process-started ( process handle -- ) + >>handle V{ } clone over processes get set-at - dup register-process ; + register-process ; M: process equal? 2drop f ; M: process hashcode* process-handle hashcode* ; -: process-running? ( process -- ? ) process-status not ; +: pass-environment? ( process -- ? ) + dup environment>> assoc-empty? not + swap environment-mode>> +replace-environment+ eq? or ; -SYMBOL: +command+ -SYMBOL: +arguments+ -SYMBOL: +detached+ -SYMBOL: +environment+ -SYMBOL: +environment-mode+ -SYMBOL: +stdin+ -SYMBOL: +stdout+ -SYMBOL: +stderr+ -SYMBOL: +closed+ -SYMBOL: +timeout+ - -SYMBOL: +prepend-environment+ -SYMBOL: +replace-environment+ -SYMBOL: +append-environment+ - -: default-descriptor - H{ - { +command+ f } - { +arguments+ f } - { +detached+ f } - { +environment+ H{ } } - { +environment-mode+ +append-environment+ } - } ; - -: with-descriptor ( desc quot -- ) - default-descriptor [ >r clone r> bind ] bind ; inline - -: pass-environment? ( -- ? ) - +environment+ get assoc-empty? not - +environment-mode+ get +replace-environment+ eq? or ; - -: get-environment ( -- env ) - +environment+ get - +environment-mode+ get { +: get-environment ( process -- env ) + dup environment>> + swap environment-mode>> { { +prepend-environment+ [ os-envs union ] } { +append-environment+ [ os-envs swap union ] } { +replace-environment+ [ ] } @@ -69,36 +76,39 @@ SYMBOL: +append-environment+ : string-array? ( obj -- ? ) dup sequence? [ [ string? ] all? ] [ drop f ] if ; -: >descriptor ( desc -- desc ) - { - { [ dup string? ] [ +command+ associate ] } - { [ dup string-array? ] [ +arguments+ associate ] } - { [ dup assoc? ] [ >hashtable ] } - } cond ; +GENERIC: >process ( obj -- process ) + +M: process >process + dup process-started? [ + "Process has already been started once" throw + ] when + clone ; + +M: object >process swap >>command ; HOOK: current-process-handle io-backend ( -- handle ) -HOOK: run-process* io-backend ( desc -- handle ) +HOOK: run-process* io-backend ( process -- handle ) : wait-for-process ( process -- status ) [ - dup process-handle + dup handle>> [ dup [ processes get at push ] curry "process" suspend drop ] when - dup process-killed? - [ "Process was killed" throw ] [ process-status ] if + dup killed>> + [ "Process was killed" throw ] [ status>> ] if ] with-timeout ; -: run-process ( desc -- process ) - >descriptor - dup run-process* - +timeout+ pick at [ over set-timeout ] when* - +detached+ rot at [ dup wait-for-process drop ] unless ; - : run-detached ( desc -- process ) - >descriptor H{ { +detached+ t } } union run-process ; + >process + dup dup run-process* process-started + dup timeout>> [ over set-timeout ] when* ; + +: run-process ( desc -- process ) + run-detached + dup detached>> [ dup wait-for-process drop ] unless ; TUPLE: process-failed code ; @@ -112,30 +122,41 @@ TUPLE: process-failed code ; HOOK: kill-process* io-backend ( handle -- ) : kill-process ( process -- ) - t over set-process-killed? - process-handle [ kill-process* ] when* ; + t >>killed + handle>> [ kill-process* ] when* ; -M: process get-lapse process-lapse ; +M: process timeout timeout>> ; + +M: process set-timeout set-process-timeout ; M: process timed-out kill-process ; -HOOK: process-stream* io-backend ( desc -- stream process ) +HOOK: (process-stream) io-backend ( process -- handle in out ) TUPLE: process-stream process ; -: ( desc -- stream ) - >descriptor - [ process-stream* ] keep - +timeout+ swap at [ over set-timeout ] when* - { set-delegate set-process-stream-process } - process-stream construct ; +: ( desc encoding -- stream ) + >r >process dup dup (process-stream) + >r >r process-started process-stream construct-boa + r> r> r> + over set-delegate ; : with-process-stream ( desc quot -- status ) swap [ swap with-stream ] keep - process-stream-process wait-for-process ; inline + process>> wait-for-process ; inline -: notify-exit ( status process -- ) - [ set-process-status ] keep +: notify-exit ( process status -- ) + >>status [ processes get delete-at* drop [ resume ] each ] keep - f swap set-process-handle ; + f >>handle + drop ; + +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..f1c65178d9 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,9 +1,10 @@ -USING: io io.mmap io.files kernel tools.test continuations sequences ; -IN: temporary +USING: io io.mmap io.files kernel tools.test continuations +sequences io.encodings.ascii ; +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 +[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test -[ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test +[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index 9d985ff3fb..76a354b0bd 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -2,13 +2,13 @@ IN: io.monitors USING: help.markup help.syntax continuations ; HELP: -{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } } +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } } { $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." $nl "Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ; HELP: next-change -{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } } +{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } } { $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; HELP: with-monitor 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/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor index d8d2cf5479..ae69553b53 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -1,5 +1,5 @@ USING: io io.buffers io.backend help.markup help.syntax kernel -strings sbufs words continuations ; +byte-arrays sbufs words continuations byte-vectors ; IN: io.nonblocking ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" @@ -58,17 +58,17 @@ HELP: $low-level-note ; HELP: -{ $values { "handle" "a native handle identifying an I/O resource" } { "port" "a new " { $link port } } } +{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } } { $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." } $low-level-note ; HELP: -{ $values { "handle" "a native handle identifying an I/O resource" } { "stream" "a new " { $link input-port } } } +{ $values { "handle" "a native handle identifying an I/O resource" } { "input-port" "a new " { $link input-port } } } { $description "Creates a new " { $link input-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; HELP: -{ $values { "handle" "a native handle identifying an I/O resource" } { "stream" "a new " { $link output-port } } } +{ $values { "handle" "a native handle identifying an I/O resource" } { "output-port" "a new " { $link output-port } } } { $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; @@ -93,12 +93,12 @@ HELP: unless-eof { $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ; HELP: read-until-step -{ $values { "separators" string } { "port" input-port } { "string/f" "a string or " { $link f } } { "separator/f" "a character or " { $link f } } } +{ $values { "separators" "a sequence of bytes" } { "port" input-port } { "byte-array/f" "a byte array or " { $link f } } { "separator/f" "a byte or " { $link f } } } { $description "If the port has reached end of file, outputs " { $link f } { $link f } ", otherwise scans the buffer for a separator and outputs a string up to but not including the separator." } ; HELP: read-until-loop -{ $values { "seps" string } { "port" input-port } { "sbuf" sbuf } { "separator/f" "a character or " { $link f } } } -{ $description "Accumulates data in the string buffer, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ; +{ $values { "seps" "a sequence of bytes" } { "port" input-port } { "accum" byte-vector } { "separator/f" "a byte or " { $link f } } } +{ $description "Accumulates data in the byte vector, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ; HELP: can-write? { $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } } diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 72507f26b6..8f5babeff7 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking USING: math kernel io sequences io.buffers io.timeouts generic -sbufs system io.streams.lines io.streams.plain io.streams.duplex +byte-vectors system io.streams.duplex io.encodings io.backend continuations debugger classes byte-arrays namespaces -splitting dlists assocs ; +splitting dlists assocs io.encodings.binary ; SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global @@ -13,11 +13,12 @@ SYMBOL: default-buffer-size TUPLE: port handle error -lapse +timeout type eof? ; -! Ports support the lapse protocol -M: port get-lapse port-lapse ; +M: port timeout port-timeout ; + +M: port set-timeout set-port-timeout ; SYMBOL: closed @@ -28,27 +29,23 @@ GENERIC: init-handle ( handle -- ) GENERIC: close-handle ( handle -- ) : ( handle buffer type -- port ) - pick init-handle - { + pick init-handle { set-port-handle set-delegate set-port-type - set-port-lapse } port construct ; : ( handle type -- port ) default-buffer-size get swap ; -: ( handle -- stream ) - input-port ; +: ( handle -- input-port ) + input-port ; -: ( handle -- stream ) - output-port ; +: ( handle -- output-port ) + output-port ; -: handle>duplex-stream ( in-handle out-handle -- stream ) - - [ >r r> ] [ ] [ dispose ] - cleanup ; +: ( read-handle write-handle -- input-port output-port ) + swap [ swap ] [ ] [ dispose drop ] cleanup ; : pending-error ( port -- ) dup port-error f rot set-port-error [ throw ] when* ; @@ -74,11 +71,11 @@ GENERIC: (wait-to-read) ( port -- ) M: input-port stream-read1 dup wait-to-read1 [ buffer-pop ] unless-eof ; -: read-step ( count port -- string/f ) +: read-step ( count port -- byte-array/f ) [ wait-to-read ] 2keep [ dupd buffer> ] unless-eof nip ; -: read-loop ( count port sbuf -- ) +: read-loop ( count port accum -- ) pick over length - dup 0 > [ pick read-step dup [ over push-all read-loop @@ -93,10 +90,10 @@ M: input-port stream-read >r 0 max >fixnum r> 2dup read-step dup [ pick over length > [ - pick + pick [ push-all ] keep [ read-loop ] keep - "" like + B{ } like ] [ 2nip ] if @@ -104,7 +101,7 @@ M: input-port stream-read 2nip ] if ; -: read-until-step ( separators port -- string/f separator/f ) +: read-until-step ( separators port -- byte-array/f separator/f ) dup wait-to-read1 dup port-eof? [ f swap set-port-eof? drop f f @@ -112,7 +109,7 @@ M: input-port stream-read buffer-until ] if ; -: read-until-loop ( seps port sbuf -- separator/f ) +: read-until-loop ( seps port accum -- separator/f ) 2over read-until-step over [ >r over push-all r> dup [ >r 3drop r> @@ -123,18 +120,20 @@ M: input-port stream-read >r 2drop 2drop r> ] if ; -M: input-port stream-read-until ( seps port -- str/f sep/f ) +M: input-port stream-read-until ( seps port -- byte-array/f sep/f ) 2dup read-until-step dup [ >r 2nip r> ] [ over [ - drop >sbuf [ read-until-loop ] keep "" like swap + drop BV{ } like + [ read-until-loop ] keep + B{ } like swap ] [ >r 2nip r> ] if ] if ; -M: input-port stream-read-partial ( max stream -- string/f ) +M: input-port stream-read-partial ( max stream -- byte-array/f ) >r 0 max >fixnum r> read-step ; : can-write? ( len writer -- ? ) @@ -144,7 +143,7 @@ M: input-port stream-read-partial ( max stream -- string/f ) tuck can-write? [ drop ] [ stream-flush ] if ; M: output-port stream-write1 - 1 over wait-to-write ch>buffer ; + 1 over wait-to-write byte>buffer ; M: output-port stream-write over length over buffer-size > [ @@ -172,11 +171,11 @@ M: port dispose [ dup port-type >r closed over set-port-type r> close-port ] if ; -TUPLE: server-port addr client ; +TUPLE: server-port addr client client-addr encoding ; -: ( handle addr -- server ) - >r f server-port r> - { set-delegate set-server-port-addr } +: ( handle addr encoding -- server ) + rot f server-port + { set-server-port-addr set-server-port-encoding set-delegate } server-port construct ; : check-server-port ( port -- ) diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor old mode 100644 new mode 100755 index a393cef7fa..4acfb9acad --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -1,49 +1,50 @@ -USING: arrays assocs combinators.lib dlists io.files -kernel namespaces sequences shuffle vectors ; +USING: io.files kernel sequences new-slots accessors +dlists arrays sequences.lib ; IN: io.paths -! HOOK: library-roots io-backend ( -- seq ) -! HOOK: binary-roots io-backend ( -- seq ) +TUPLE: directory-iterator path bfs queue ; -r path+ r> ] with* assoc-map ; +: qualified-directory ( path -- seq ) + dup directory [ first2 >r path+ r> 2array ] with map ; -: get-paths ( dir -- paths ) - dup directory append-path ; +: push-directory ( path iter -- ) + >r qualified-directory r> [ + dup queue>> swap bfs>> + [ push-front ] [ push-back ] if + ] curry each ; -: (walk-dir) ( path -- ) - first2 [ - get-paths dup keys % [ (walk-dir) ] each +: ( path bfs? -- iterator ) + directory-iterator construct-boa + dup path>> over push-directory ; + +: next-file ( iter -- file/f ) + dup queue>> dlist-empty? [ drop f ] [ + dup queue>> pop-back first2 + [ over push-directory next-file ] [ nip ] if + ] if ; + +: iterate-directory ( iter quot -- obj ) + 2dup >r >r >r next-file dup [ + r> call dup [ + r> r> 2drop + ] [ + drop r> r> iterate-directory + ] if ] [ - drop - ] if ; -PRIVATE> + drop r> r> r> 3drop f + ] if ; inline -: walk-dir ( path -- seq ) - dup directory? 2array [ (walk-dir) ] { } make ; +: find-file ( path bfs? quot -- path/f ) + >r r> + [ keep and ] curry iterate-directory ; inline -GENERIC# find-file* 1 ( obj quot -- path/f ) +: each-file ( path bfs? quot -- ) + >r r> + [ f ] compose iterate-directory drop ; inline -M: dlist find-file* ( dlist quot -- path/f ) - over dlist-empty? [ 2drop f ] [ - 2dup >r pop-front get-paths dup r> assoc-find - [ drop 3nip ] - [ 2drop [ nip ] assoc-subset keys pick push-all-back find-file* ] if - ] if ; +: find-all-files ( path bfs? quot -- paths ) + >r r> + pusher >r iterate-directory drop r> ; inline -M: vector find-file* ( vector quot -- path/f ) - over empty? [ 2drop f ] [ - 2dup >r pop get-paths dup r> assoc-find - [ drop 3nip ] - [ 2drop [ nip ] assoc-subset keys pick push-all find-file* ] if - ] if ; - -: prepare-find-file ( quot -- quot ) - [ drop ] swap compose ; - -: find-file-depth ( path quot -- path/f ) - prepare-find-file >r 1vector r> find-file* ; - -: find-file-breadth ( path quot -- path/f ) - prepare-find-file >r 1dlist r> find-file* ; +: recursive-directory ( path bfs? -- paths ) + [ ] accumulator >r each-file r> ; diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor old mode 100644 new mode 100755 index 4e4342266a..7eda48f747 --- a/extra/io/server/server-docs.factor +++ b/extra/io/server/server-docs.factor @@ -1,12 +1,8 @@ USING: help help.syntax help.markup io ; IN: io.server -HELP: with-client -{ $values { "quot" "a quotation" } { "client" "a client socket stream" } } -{ $description "Logs a client connection and spawns a new thread that calls the quotation, with the " { $link stdio } " stream set to the client stream. If the quotation throws an error, the client connection is closed, and the error is printed to the " { $link stdio } " stream at the time the thread was spawned." } ; - HELP: with-server -{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } } +{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } } { $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being the " { $link stdio } " stream. Client connections are logged to the " { $link stdio } " stream at the time the server was started." } ; HELP: with-datagrams diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index 776bc4b429..e1297a9839 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,4 @@ -IN: temporary -USING: tools.test io.server ; +IN: io.server.tests +USING: tools.test io.server io.server.private ; -{ 1 0 } [ [ ] spawn-server ] must-infer-as +{ 2 0 } [ [ ] server-loop ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 6cc11ea6b6..0b7e626908 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,11 +22,10 @@ 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 -- ) +: server-loop ( addrspec encoding quot -- ) >r dup servers get push r> [ accept-loop ] curry with-disposal ; inline @@ -44,12 +39,12 @@ PRIVATE> : internet-server ( port -- seq ) f swap t resolve-host ; -: with-server ( seq service quot -- ) - V{ } clone [ - servers [ - [ server-loop ] curry with-logging - ] with-variable - ] 3curry parallel-each ; inline +: with-server ( seq service encoding quot -- ) + V{ } clone servers [ + [ + [ server-loop ] 2curry with-logging + ] 3curry parallel-each + ] with-variable ; inline : stop-server ( -- ) servers get [ dispose ] each ; 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/sockets/authors.txt b/extra/io/sockets/authors.txt index 1901f27a24..a44f8d7f8d 100644 --- a/extra/io/sockets/authors.txt +++ b/extra/io/sockets/authors.txt @@ -1 +1,2 @@ Slava Pestov +Daniel Ehrenberg 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/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 9136c3ca22..fa38ec90ee 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -92,20 +92,20 @@ HELP: inet6 } ; HELP: -{ $values { "addrspec" "an address specifier" } { "stream" "a bidirectional stream" } } -{ $description "Opens a network connection and outputs a bidirectional stream." } +{ $values { "addrspec" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } } +{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding." } { $errors "Throws an error if the connection cannot be established." } { $examples - { $code "\"www.apple.com\" \"http\" " } + { $code "\"www.apple.com\" \"http\" utf8 " } } ; HELP: -{ $values { "addrspec" "an address specifier" } { "server" "a handle" } } +{ $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } } { $description "Begins listening for network connections to a local address. Server objects responds to two words:" { $list { { $link dispose } " - stops listening on the port and frees all associated resources" } - { { $link accept } " - blocks until there is a connection" } + { { $link accept } " - blocks until there is a connection, and returns a stream of the encoding passed to the constructor" } } } { $notes @@ -119,7 +119,7 @@ HELP: HELP: accept { $values { "server" "a handle" } { "client" "a bidirectional stream" } } -{ $description "Waits for a connection to a server socket created by " { $link } ", and outputs a bidirectional stream when the connection has been established." +{ $description "Waits for a connection to a server socket created by " { $link } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." $nl "The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." } { $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ; @@ -139,6 +139,7 @@ HELP: "To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:" { $code "\"localhost\" 1234 t resolve-host" } "Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly." + "Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding" } { $errors "Throws an error if the port is already in use, or if the OS forbids access." } ; diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 1afffcc7b2..1dc7f4883d 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -IN: io.sockets USING: generic kernel io.backend namespaces continuations -sequences arrays ; +sequences arrays io.encodings io.nonblocking ; +IN: io.sockets TUPLE: local path ; @@ -26,17 +26,26 @@ TUPLE: client-stream addr ; { set-client-stream-addr set-delegate } client-stream construct ; -HOOK: (client) io-backend ( addrspec -- stream ) +HOOK: (client) io-backend ( addrspec -- client-in client-out ) -GENERIC: ( addrspec -- stream ) +GENERIC: client* ( addrspec -- client-in client-out ) +M: array client* [ (client) 2array ] attempt-all first2 ; +M: object client* (client) ; -M: array [ (client) ] attempt-all ; +: ( addrspec encoding -- stream ) + >r client* r> ; -M: object (client) ; +HOOK: (server) io-backend ( addrspec -- handle ) -HOOK: io-backend ( addrspec -- server ) +: ( addrspec encoding -- server ) + >r [ (server) ] keep r> ; -HOOK: accept io-backend ( server -- client ) +HOOK: (accept) io-backend ( server -- addrspec handle ) + +: accept ( server -- client ) + [ (accept) dup ] keep + server-port-encoding + ; HOOK: io-backend ( addrspec -- datagram ) @@ -48,7 +57,7 @@ HOOK: resolve-host io-backend ( host serv passive? -- seq ) HOOK: host-name io-backend ( -- string ) -M: inet +M: inet client* dup inet-host swap inet-port f resolve-host dup empty? [ "Host name lookup failed" throw ] when - ; + client* ; diff --git a/extra/io/timeouts/summary.txt b/extra/io/timeouts/summary.txt new file mode 100644 index 0000000000..7a648d30bb --- /dev/null +++ b/extra/io/timeouts/summary.txt @@ -0,0 +1 @@ +Low-level support for setting timeouts on I/O operations diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor index a704e3473a..df7e1389cc 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/extra/io/timeouts/timeouts-docs.factor @@ -1,14 +1,13 @@ IN: io.timeouts -USING: help.markup help.syntax math kernel ; +USING: help.markup help.syntax math kernel calendar ; -HELP: get-lapse -{ $values { "obj" object } { "lapse" lapse } } -{ $contract "Outputs an object's timeout lapse descriptor." } ; +HELP: timeout +{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } } +{ $contract "Outputs an object's timeout." } ; HELP: set-timeout -{ $values { "ms" integer } { "obj" object } } -{ $contract "Sets an object's timeout, in milliseconds." } -{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ; +{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } } +{ $contract "Sets an object's timeout." } ; HELP: timed-out { $values { "obj" object } } @@ -20,13 +19,12 @@ HELP: with-timeout ARTICLE: "io.timeouts" "I/O timeout protocol" "Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed." +{ $subsection timeout } { $subsection set-timeout } "The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations." -{ $subsection get-lapse } { $subsection timed-out } "A combinator to be used in operations which can time out:" { $subsection with-timeout } -{ $see-also "stream-protocol" "io.launcher" } -; +{ $see-also "stream-protocol" "io.launcher" } ; ABOUT: "io.timeouts" diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index 0bae855399..ef660a6f0d 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -1,79 +1,27 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math system dlists namespaces assocs init -threads io.streams.duplex ; +USING: kernel calendar alarms io.streams.duplex ; IN: io.timeouts -TUPLE: lapse entry timeout cutoff ; - -: f 0 0 \ lapse construct-boa ; - ! Won't need this with new slot accessors -GENERIC: get-lapse ( obj -- lapse ) +GENERIC: timeout ( obj -- dt/f ) +GENERIC: set-timeout ( dt/f obj -- ) -GENERIC: set-timeout ( ms obj -- ) - -M: object set-timeout get-lapse set-timeout ; - -M: lapse set-timeout set-lapse-timeout ; - -: timeout ( obj -- ms ) get-lapse lapse-timeout ; -: entry ( obj -- dlist-node ) get-lapse lapse-entry ; -: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ; -: cutoff ( obj -- ms ) get-lapse lapse-cutoff ; -: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ; - -! Won't need this with inheritance -TUPLE: duplex-stream-lapse stream ; - -M: duplex-stream-lapse set-timeout - duplex-stream-lapse-stream 2dup +M: duplex-stream set-timeout + 2dup duplex-stream-in set-timeout duplex-stream-out set-timeout ; -M: duplex-stream get-lapse duplex-stream-lapse construct-boa ; - -SYMBOL: timeout-queue - -: timeout? ( lapse -- ? ) - cutoff dup zero? not swap millis < and ; - -timeout-queue global [ [ ] unless* ] change-at - -: unqueue-timeout ( obj -- ) - entry [ - timeout-queue get-global swap delete-node - ] when* ; - -: queue-timeout ( obj -- ) - dup timeout-queue get-global push-front* - swap set-entry ; - GENERIC: timed-out ( obj -- ) M: object timed-out drop ; -: expire-timeouts ( -- ) - timeout-queue get-global dup dlist-empty? [ drop ] [ - dup peek-back timeout? - [ pop-back timed-out expire-timeouts ] [ drop ] if - ] if ; - -: begin-timeout ( obj -- ) - dup timeout dup zero? [ - 2drop - ] [ - millis + over set-cutoff - dup unqueue-timeout queue-timeout - ] if ; +: queue-timeout ( obj timeout -- alarm ) + >r [ timed-out ] curry r> later ; : with-timeout ( obj quot -- ) - over begin-timeout keep unqueue-timeout ; inline - -: expiry-thread ( -- ) - expire-timeouts 5000 sleep expiry-thread ; - -: start-expiry-thread ( -- ) - [ expiry-thread ] "I/O expiry" spawn drop ; - -[ start-expiry-thread ] "io.timeouts" add-init-hook + over dup timeout dup [ + queue-timeout slip cancel-alarm + ] [ + 2drop call + ] if ; inline diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index f22483d6e3..93691c63e2 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien generic assocs kernel kernel.private math io.nonblocking sequences strings structs sbufs -threads unix vectors io.buffers io.backend +threads unix vectors io.buffers io.backend io.encodings io.streams.duplex math.parser continuations system libc -qualified namespaces io.timeouts ; +qualified namespaces io.timeouts io.encodings.utf8 ; QUALIFIED: io IN: io.unix.backend @@ -169,7 +169,7 @@ M: write-task do-io-task : add-write-io-task ( port continuation -- ) over port-handle mx get-global mx-writes at* - [ io-task-callbacks push ] + [ io-task-callbacks push drop ] [ drop add-io-task ] if ; : (wait-to-write) ( port -- ) @@ -178,12 +178,13 @@ M: write-task do-io-task M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; -M: unix-io io-multiplex ( ms -- ) +M: unix-io io-multiplex ( ms/f -- ) mx get-global wait-for-events ; -M: unix-io init-stdio ( -- ) - 0 1 handle>duplex-stream io:stdio set-global - 2 io:stderr set-global ; +M: unix-io (init-stdio) ( -- ) + 0 + 1 + 2 ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port mx ; 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..73090ea724 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,8 +1,10 @@ ! 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 +io.encodings.binary ; + IN: io.unix.files M: unix-io cwd @@ -17,7 +19,7 @@ M: unix-io cd : open-read ( path -- fd ) O_RDONLY file-mode open dup io-error ; -M: unix-io ( path -- stream ) +M: unix-io (file-reader) ( path -- stream ) open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline @@ -25,7 +27,7 @@ M: unix-io ( path -- stream ) : open-write ( path -- fd ) write-flags file-mode open dup io-error ; -M: unix-io ( path -- stream ) +M: unix-io (file-writer) ( path -- stream ) open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline @@ -34,10 +36,18 @@ M: unix-io ( path -- stream ) append-flags file-mode open dup io-error [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ; -M: unix-io ( path -- stream ) +M: unix-io (file-appender) ( 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 +58,44 @@ M: unix-io make-directory ( path -- ) M: unix-io delete-directory ( path -- ) rmdir io-error ; + +: (copy-file) ( from to -- ) + dup parent-directory make-directories + binary [ + swap binary [ + swap stream-copy + ] with-disposal + ] with-disposal ; + +M: unix-io copy-file ( from to -- ) + [ (copy-file) ] 2keep swap file-permissions 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 ; + +M: unix-io link-info ( path -- info ) + lstat* { + [ 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 04bb70d57d..97b186edf3 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 @@ -31,7 +31,8 @@ M: output-task io-task-filter drop EVFILT_WRITE ; swap io-task-filter over set-kevent-filter ; : register-kevent ( kevent mx -- ) - mx-fd swap 1 f 0 f kevent io-error ; + mx-fd swap 1 f 0 f kevent + 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ; M: kqueue-mx register-io-task ( task mx -- ) over EV_ADD make-kevent over register-kevent @@ -53,7 +54,7 @@ M: kqueue-mx unregister-io-task ( task mx -- ) : kevent-proc-task ( pid -- ) dup wait-for-pid swap find-process - dup [ notify-exit ] [ 2drop ] if ; + dup [ swap notify-exit ] [ 2drop ] if ; : handle-kevent ( mx kevent -- ) dup kevent-ident swap kevent-filter { @@ -66,7 +67,8 @@ M: kqueue-mx unregister-io-task ( task mx -- ) [ over kqueue-mx-events kevent-nth handle-kevent ] with each ; M: kqueue-mx wait-for-events ( ms mx -- ) - swap make-timespec dupd wait-kevent handle-kevents ; + swap dup [ make-timespec ] when + dupd wait-kevent handle-kevents ; : make-proc-kevent ( pid -- kevent ) "kevent" diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor old mode 100755 new mode 100644 index eb3038e1b5..aa54d3ec94 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,33 +1,97 @@ -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 io.encodings.ascii io.encodings.latin1 +accessors kernel sequences ; -[ "" 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 + "launcher-test-1" temp-file >>stdout + try-process +] unit-test + +[ "Hello\n" ] [ + "cat" + "launcher-test-1" temp-file + 2array + ascii contents +] unit-test + +[ "" ] [ + + "cat" + "launcher-test-1" temp-file + 2array >>command + +inherit+ >>stdout + ascii contents +] unit-test + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + + "cat" >>command + +closed+ >>stdin + "launcher-test-1" temp-file >>stdout + try-process +] unit-test + +[ "" ] [ + "cat" + "launcher-test-1" temp-file + 2array + ascii contents +] unit-test + +[ ] [ + 2 [ + "launcher-test-1" temp-file ascii [ + + swap >>stdout + "echo Hello" >>command + try-process + ] with-disposal + ] times +] unit-test + +[ "Hello\nHello\n" ] [ + "cat" + "launcher-test-1" temp-file + 2array + ascii contents +] unit-test + +[ t ] [ + + "env" >>command + { { "A" "B" } } >>environment + latin1 lines + "A=B" swap member? +] unit-test + +[ { "A=B" } ] [ + + "env" >>command + { { "A" "B" } } >>environment + +replace-environment+ >>environment-mode + latin1 lines ] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 0393b13c7f..7b4831a2c5 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -1,82 +1,70 @@ ! 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 io.encodings.latin1 accessors new-slots ; 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* ; +: get-arguments ( process -- seq ) + command>> dup string? [ tokenize-command ] when ; : 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 ; -: setup-redirection ( -- ) - +stdin+ get ?closed read-flags 0 redirect - +stdout+ get ?closed write-flags 1 redirect - +stderr+ get dup +stdout+ eq? +: setup-redirection ( process -- process ) + dup stdin>> ?closed read-flags 0 redirect + dup stdout>> ?closed write-flags 1 redirect + dup stderr>> dup +stdout+ eq? [ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ; -: spawn-process ( -- ) +: spawn-process ( process -- * ) [ setup-redirection - get-arguments - pass-environment? - [ get-environment assoc>env exec-args-with-env ] - [ exec-args-with-path ] if - io-error - ] [ error. :c flush ] recover 1 exit ; + dup pass-environment? [ + dup get-environment set-os-envs + ] when + + get-arguments exec-args-with-path + (io-error) + ] [ 255 exit ] recover ; M: unix-io current-process-handle ( -- handle ) getpid ; -M: unix-io run-process* ( desc -- pid ) - [ - [ spawn-process ] [ ] with-fork - ] with-descriptor ; +M: unix-io run-process* ( process -- pid ) + [ spawn-process ] curry [ ] with-fork ; M: unix-io kill-process* ( pid -- ) SIGTERM kill io-error ; @@ -89,21 +77,15 @@ M: unix-io kill-process* ( pid -- ) 2dup first close second close >r first 0 dup2 drop r> second 1 dup2 drop ; -: spawn-process-stream ( -- in out pid ) - open-pipe open-pipe [ - setup-stdio-pipe - spawn-process - ] [ - -rot 2dup second close first close - ] with-fork first swap second rot ; - -M: unix-io process-stream* - [ - spawn-process-stream >r handle>duplex-stream r> - ] with-descriptor ; +M: unix-io (process-stream) + >r open-pipe open-pipe r> + [ >r setup-stdio-pipe r> spawn-process ] curry + [ -rot 2dup second close first close ] + with-fork + first swap second ; : find-process ( handle -- process ) - processes get swap [ nip swap process-handle = ] curry + processes get swap [ nip swap handle>> = ] curry assoc-find 2drop ; ! Inefficient process wait polling, used on Linux and Solaris. @@ -114,7 +96,7 @@ M: unix-io process-stream* 2drop t ] [ find-process dup [ - >r *int WEXITSTATUS r> notify-exit f + swap *int WEXITSTATUS notify-exit f ] [ 2drop f ] if 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/select/select.factor b/extra/io/unix/select/select.factor index 9827d4d54f..77a20beb42 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -49,7 +49,7 @@ TUPLE: select-mx read-fdset write-fdset ; f ; M: select-mx wait-for-events ( ms mx -- ) - swap >r dup init-fdsets r> make-timeval + swap >r dup init-fdsets r> dup [ make-timeval ] when select multiplexer-error dup read-fdset/tasks pick handle-fdset dup write-fdset/tasks rot handle-fdset ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 930240419a..bd7dfd9ce1 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. +! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. ! We need to fiddle with the exact search order here, since ! unix::accept shadows streams::accept. -IN: io.unix.sockets USING: alien alien.c-types generic io kernel math namespaces io.nonblocking parser threads unix sequences byte-arrays io.sockets io.binary io.unix.backend io.streams.duplex io.sockets.impl math.parser continuations libc combinators ; +IN: io.unix.sockets : pending-init-error ( port -- ) #! We close it here to avoid a resource leak; callers of @@ -42,16 +42,15 @@ M: connect-task do-io-task : wait-to-connect ( port -- ) [ add-io-task ] with-port-continuation drop ; -M: unix-io (client) ( addrspec -- stream ) +M: unix-io (client) ( addrspec -- client-in client-out ) dup make-sockaddr/size >r >r protocol-family SOCK_STREAM socket-fd dup r> r> connect zero? err_no EINPROGRESS = or [ dup init-client-socket - dup handle>duplex-stream - dup duplex-stream-out + dup dup wait-to-connect - pending-init-error + dup pending-init-error ] [ dup close (io-error) ] if ; @@ -72,10 +71,10 @@ TUPLE: accept-task ; dup [ swap heap-size accept ] keep ; inline : do-accept ( port fd sockaddr -- ) - rot [ - server-port-addr parse-sockaddr - swap dup handle>duplex-stream - ] keep set-server-port-client ; + rot + [ server-port-addr parse-sockaddr ] keep + [ set-server-port-client-addr ] keep + set-server-port-client ; M: accept-task do-io-task io-task-port dup accept-sockaddr @@ -92,18 +91,17 @@ USE: io.sockets dup rot make-sockaddr/size bind zero? [ dup close (io-error) ] unless ; -M: unix-io ( addrspec -- stream ) - [ - SOCK_STREAM server-fd - dup 10 listen zero? [ dup close (io-error) ] unless - ] keep ; +M: unix-io (server) ( addrspec -- handle ) + SOCK_STREAM server-fd + dup 10 listen zero? [ dup close (io-error) ] unless ; -M: unix-io accept ( server -- client ) +M: unix-io (accept) ( server -- addrspec handle ) #! Wait for a client connection. dup check-server-port dup wait-to-accept dup pending-error - server-port-client ; + dup server-port-client-addr + swap server-port-client ; ! Datagram sockets - UDP and Unix domain M: unix-io diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 515077f22b..c8ed4fc41c 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,30 +1,30 @@ USING: io.files io.sockets io kernel threads namespaces tools.test continuations strings byte-arrays -sequences prettyprint system ; -IN: temporary +sequences prettyprint system io.encodings.binary io.encodings.ascii ; +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 - [ - stdio get accept [ +[ + [ socket-server delete-file ] ignore-errors + + socket-server + ascii [ + accept [ "Hello world" print flush readln "XYZ" = "FOO" "BAR" ? print flush ] with-stream - ] with-stream + ] with-disposal - "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 ascii [ readln , "XYZ" print flush @@ -33,17 +33,16 @@ yield ] { } make ] unit-test -! Unix domain datagram sockets -[ - "unix-domain-datagram-test" resource-path delete-file -] ignore-errors +: datagram-server "unix-domain-datagram-test" temp-file ; +: datagram-client "unix-domain-datagram-test-2" temp-file ; -: server-addr "unix-domain-datagram-test" resource-path ; -: client-addr "unix-domain-datagram-test-2" resource-path ; +! Unix domain datagram sockets +[ datagram-server delete-file ] ignore-errors +[ datagram-client delete-file ] ignore-errors [ [ - server-addr "d" set + datagram-server "d" set "Receive 1" print @@ -67,58 +66,53 @@ yield "Done" print - "unix-domain-datagram-test" resource-path delete-file + datagram-server delete-file ] with-scope ] "Test" spawn drop yield -[ - "unix-domain-datagram-test-2" resource-path delete-file -] ignore-errors +[ datagram-client delete-file ] ignore-errors -client-addr +datagram-client "d" set [ ] [ "hello" >byte-array - server-addr + datagram-server "d" get send ] unit-test [ "olleh" t ] [ "d" get receive - server-addr = + datagram-server = >r >string r> ] unit-test [ ] [ "hello" >byte-array - server-addr + datagram-server "d" get send ] unit-test [ "hello world" t ] [ "d" get receive - server-addr = + datagram-server = >r >string r> ] unit-test [ ] [ "d" get dispose ] unit-test ! Test error behavior +: another-datagram "unix-domain-datagram-test-3" temp-file ; -[ - "unix-domain-datagram-test-3" resource-path delete-file -] ignore-errors +[ another-datagram delete-file ] ignore-errors -"unix-domain-datagram-test-2" resource-path delete-file +datagram-client delete-file -[ ] [ client-addr "d" set ] unit-test +[ ] [ datagram-client "d" set ] unit-test -[ - B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send -] must-fail +[ B{ 1 2 3 } another-datagram "d" get send ] must-fail [ ] [ "d" get dispose ] unit-test @@ -126,21 +120,21 @@ 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 [ - image [ stdio get accept ] with-file-reader + image binary [ stdio get accept ] with-file-reader ] must-fail [ - image [ stdio get receive ] with-file-reader + image binary [ stdio get receive ] with-file-reader ] must-fail [ - image [ - B{ 1 2 } server-addr + image binary [ + B{ 1 2 } datagram-server stdio get send ] with-file-reader ] must-fail diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index e740561cf9..64e2cc3c3d 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,6 +1,6 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend combinators namespaces -system vocabs.loader sequences ; +io.unix.launcher io.unix.mmap io.backend +combinators namespaces system vocabs.loader sequences ; "io.unix." os append require diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index e90a9f16e2..f51521dfcc 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -1,13 +1,15 @@ USING: io.nonblocking io.windows threads.private kernel io.backend windows.winsock windows.kernel32 windows io.streams.duplex io namespaces alien.syntax system combinators -io.buffers ; +io.buffers io.encodings io.encodings.utf8 combinators.lib ; IN: io.windows.ce.backend : port-errored ( port -- ) win32-error-string swap set-port-error ; -M: windows-ce-io io-multiplex ( ms -- ) (sleep) ; +M: windows-ce-io io-multiplex ( ms -- ) + 60 60 * 1000 * or (sleep) ; + M: windows-ce-io add-completion ( handle -- ) drop ; GENERIC: wince-read ( port port-handle -- ) @@ -31,15 +33,18 @@ LIBRARY: libc FUNCTION: void* _getstdfilex int fd ; FUNCTION: void* _fileno void* file ; -M: windows-ce-io init-stdio ( -- ) +M: windows-ce-io (init-stdio) ( -- ) #! We support Windows NT too, to make this I/O backend #! easier to debug. 512 default-buffer-size [ winnt? [ STD_INPUT_HANDLE GetStdHandle STD_OUTPUT_HANDLE GetStdHandle + STD_ERROR_HANDLE GetStdHandle ] [ 0 _getstdfilex _fileno 1 _getstdfilex _fileno - ] if - ] with-variable stdio set-global ; + 2 _getstdfilex _fileno + ] if [ f ] 3apply + rot -rot [ ] 2apply + ] with-variable ; diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index a5e0cb6b4a..878f5899f6 100755 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -3,4 +3,5 @@ io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher namespaces io.windows.mmap ; IN: io.windows.ce +USE: io.windows.files T{ windows-ce-io } set-io-backend diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index e9ca6220af..9bc583a3d8 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -31,17 +31,15 @@ M: win32-socket wince-write ( port port-handle -- ) windows.winsock:WSAConnect windows.winsock:winsock-error!=0/f ; -M: windows-ce-io (client) ( addrspec -- duplex-stream ) - do-connect dup handle>duplex-stream ; +M: windows-ce-io (client) ( addrspec -- reader writer ) + do-connect dup ; -M: windows-ce-io ( addrspec -- duplex-stream ) - [ - windows.winsock:SOCK_STREAM server-fd - dup listen-on-socket - - ] keep ; +M: windows-ce-io (server) ( addrspec -- handle ) + windows.winsock:SOCK_STREAM server-fd + dup listen-on-socket + ; -M: windows-ce-io accept ( server -- client ) +M: windows-ce-io (accept) ( server -- client ) [ dup check-server-port [ @@ -54,7 +52,7 @@ M: windows-ce-io accept ( server -- client ) [ windows.winsock:winsock-error ] when ] keep ] keep server-port-addr parse-sockaddr swap - dup handle>duplex-stream + ] with-timeout ; M: windows-ce-io ( addrspec -- datagram ) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor new file mode 100644 index 0000000000..3d51e65116 --- /dev/null +++ b/extra/io/windows/files/files.factor @@ -0,0 +1,100 @@ +! 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 symbols ; +IN: io.windows.files + +SYMBOLS: +read-only+ +hidden+ +system+ ++directory+ +archive+ +device+ +normal+ +temporary+ ++sparse-file+ +reparse-point+ +compressed+ +offline+ ++not-content-indexed+ +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-file-type ( n -- symbol ) + FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; + +: WIN32_FIND_DATA>file-info + { + [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ] + [ + [ WIN32_FIND_DATA-nFileSizeLow ] + [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit + ] + [ WIN32_FIND_DATA-dwFileAttributes ] + ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ] + [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ] + ! [ WIN32_FIND_DATA-ftLastAccessTime 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-type ] + [ + [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] + [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit + ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ] + ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ] + [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ] + ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime 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 6f79388016..b09d867e10 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system threads init strings combinators -io.backend ; +io.backend new-slots accessors ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -22,30 +22,25 @@ TUPLE: CreateProcess-args stdout-pipe stdin-pipe ; : default-CreateProcess-args ( -- obj ) - 0 + CreateProcess-args construct-empty + 0 >>dwCreateFlags "STARTUPINFO" - "STARTUPINFO" heap-size over set-STARTUPINFO-cb - "PROCESS_INFORMATION" - TRUE - { - set-CreateProcess-args-dwCreateFlags - set-CreateProcess-args-lpStartupInfo - set-CreateProcess-args-lpProcessInformation - set-CreateProcess-args-bInheritHandles - } \ CreateProcess-args construct ; + "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo + "PROCESS_INFORMATION" >>lpProcessInformation + TRUE >>bInheritHandles ; : call-CreateProcess ( CreateProcess-args -- ) { - CreateProcess-args-lpApplicationName - CreateProcess-args-lpCommandLine - CreateProcess-args-lpProcessAttributes - CreateProcess-args-lpThreadAttributes - CreateProcess-args-bInheritHandles - CreateProcess-args-dwCreateFlags - CreateProcess-args-lpEnvironment - CreateProcess-args-lpCurrentDirectory - CreateProcess-args-lpStartupInfo - CreateProcess-args-lpProcessInformation + lpApplicationName>> + lpCommandLine>> + lpProcessAttributes>> + lpThreadAttributes>> + bInheritHandles>> + dwCreateFlags>> + lpEnvironment>> + lpCurrentDirectory>> + lpStartupInfo>> + lpProcessInformation>> } get-slots CreateProcess win32-error=0/f ; : escape-argument ( str -- newstr ) @@ -54,66 +49,64 @@ TUPLE: CreateProcess-args : join-arguments ( args -- cmd-line ) [ escape-argument ] map " " join ; -: app-name/cmd-line ( -- app-name cmd-line ) - +command+ get [ +: app-name/cmd-line ( process -- app-name cmd-line ) + command>> dup string? [ " " split1 ] [ - +arguments+ get unclip swap join-arguments - ] if* ; + unclip swap join-arguments + ] if ; -: cmd-line ( -- cmd-line ) - +command+ get [ +arguments+ get join-arguments ] unless* ; +: cmd-line ( process -- cmd-line ) + command>> dup string? [ join-arguments ] unless ; -: fill-lpApplicationName - app-name/cmd-line - pick set-CreateProcess-args-lpCommandLine - over set-CreateProcess-args-lpApplicationName ; +: fill-lpApplicationName ( process args -- process args ) + over app-name/cmd-line + >r >>lpApplicationName + r> >>lpCommandLine ; -: fill-lpCommandLine - cmd-line over set-CreateProcess-args-lpCommandLine ; +: fill-lpCommandLine ( process args -- process args ) + over cmd-line >>lpCommandLine ; -: fill-dwCreateFlags +: fill-dwCreateFlags ( process args -- process args ) 0 - pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when - +detached+ get winnt? and [ DETACHED_PROCESS bitor ] when - over set-CreateProcess-args-dwCreateFlags ; + pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when + pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when + >>dwCreateFlags ; -: fill-lpEnvironment - pass-environment? [ +: fill-lpEnvironment ( process args -- process args ) + over pass-environment? [ [ - get-environment - [ "=" swap 3append string>u16-alien % ] assoc-each + over get-environment + [ swap % "=" % % "\0" % ] assoc-each "\0" % - ] { } make >c-ushort-array - over set-CreateProcess-args-lpEnvironment + ] "" make >c-ushort-array + >>lpEnvironment ] when ; -: fill-startup-info - dup CreateProcess-args-lpStartupInfo - STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ; +: fill-startup-info ( process args -- process args ) + STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ; -HOOK: fill-redirection io-backend ( args -- args ) +HOOK: fill-redirection io-backend ( process args -- ) -M: windows-ce-io fill-redirection ; +M: windows-ce-io fill-redirection 2drop ; -: make-CreateProcess-args ( -- args ) +: make-CreateProcess-args ( process -- args ) default-CreateProcess-args wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if fill-dwCreateFlags fill-lpEnvironment - fill-startup-info ; + fill-startup-info + nip ; M: windows-io current-process-handle ( -- handle ) GetCurrentProcessId ; -M: windows-io run-process* ( desc -- handle ) +M: windows-io run-process* ( process -- handle ) [ - [ - make-CreateProcess-args - fill-redirection - dup call-CreateProcess - CreateProcess-args-lpProcessInformation - ] with-descriptor + dup make-CreateProcess-args + tuck fill-redirection + dup call-CreateProcess + lpProcessInformation>> ] with-destructors ; M: windows-io kill-process* ( handle -- ) @@ -134,7 +127,7 @@ M: windows-io kill-process* ( handle -- ) : process-exited ( process -- ) dup process-handle exit-code over process-handle dispose-process - swap notify-exit ; + notify-exit ; : wait-for-processes ( processes -- ? ) keys dup @@ -146,10 +139,16 @@ M: windows-io kill-process* ( handle -- ) : wait-loop ( -- ) processes get dup assoc-empty? - [ drop t ] [ wait-for-processes ] if - [ 250 sleep ] when ; + [ drop f sleep-until ] + [ wait-for-processes [ 100 sleep ] when ] if ; + +SYMBOL: wait-thread : start-wait-thread ( -- ) - [ wait-loop t ] "Process wait" spawn-server drop ; + [ wait-loop t ] "Process wait" spawn-server + wait-thread set-global ; + +M: windows-io register-process + drop wait-thread get-global interrupt ; [ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 50b199b3bd..10e55ed5f2 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -57,7 +57,8 @@ M: windows-nt-io add-completion ( handle -- ) ] "I/O" suspend 3drop ; : wait-for-overlapped ( ms -- overlapped ? ) - >r master-completion-port get-global r> ! port ms + >r master-completion-port get-global + r> INFINITE or ! timeout 0 ! bytes f ! key f ! overlapped 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-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor new file mode 100755 index 0000000000..fac6471b8c --- /dev/null +++ b/extra/io/windows/nt/launcher/launcher-tests.factor @@ -0,0 +1,131 @@ +IN: io.windows.launcher.nt.tests +USING: io.launcher tools.test calendar accessors +namespaces kernel system arrays io io.files io.encodings.ascii +sequences parser assocs hashtables ; + +[ ] [ + + "notepad" >>command + 1/2 seconds >>timeout + "notepad" set +] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ f ] [ "notepad" get process-started? ] unit-test + +[ ] [ "notepad" [ run-detached ] change ] unit-test + +[ "notepad" get wait-for-process ] must-fail + +[ t ] [ "notepad" get killed>> ] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ ] [ + + vm "-quiet" "-run=hello-world" 3array >>command + "out.txt" temp-file >>stdout + try-process +] unit-test + +[ "Hello world" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + + vm "-run=listener" 2array >>command + +closed+ >>stdin + try-process +] unit-test + +[ ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + "err.txt" temp-file >>stderr + try-process + ] with-directory +] unit-test + +[ "output" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "error" ] [ + "err.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + +stdout+ >>stderr + try-process + ] with-directory +] unit-test + +[ "outputerror" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "output" ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "stderr.factor" 3array >>command + "err2.txt" temp-file >>stderr + ascii lines first + ] with-directory +] unit-test + +[ "error" ] [ + "err2.txt" temp-file ascii file-lines first +] unit-test + +[ t ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ t ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + +replace-environment+ >>environment-mode + os-envs >>environment + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ "B" ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + { { "A" "B" } } >>environment + ascii contents + ] with-directory eval + + "A" swap at +] unit-test + +[ f ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + { { "HOME" "XXX" } } >>environment + +prepend-environment+ >>environment-mode + ascii contents + ] with-directory eval + + "HOME" swap at "XXX" = +] unit-test diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index cd9bb9baef..c342b2ee9a 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -1,110 +1,138 @@ -! 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 accessors locals ; 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 - normalize-pathname - r> ! access-mode +: 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 ) + path normalize-pathname + access-mode share-mode security-attributes-inherit - r> ! create-mode + create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes 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 ) + stdout-pipe>> dup [ pipe-out ] when ; + +: redirect-stdout ( process args -- handle ) + default-stdout + swap stdout>> + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_OUTPUT_HANDLE GetStdHandle or ; + +: redirect-stderr ( process args -- handle ) + over stderr>> +stdout+ eq? [ + lpStartupInfo>> + STARTUPINFO-hStdOutput + nip + ] [ + drop + f + swap stderr>> + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_ERROR_HANDLE GetStdHandle or + ] if ; + +: default-stdin ( args -- handle ) + stdin-pipe>> dup [ pipe-in ] when ; + +: redirect-stdin ( process args -- handle ) + default-stdin + swap stdin>> + GENERIC_READ + OPEN_EXISTING + redirect + STD_INPUT_HANDLE GetStdHandle or ; + : add-pipe-dtors ( pipe -- ) dup - pipe-in close-later - pipe-out close-later ; + in>> close-later + out>> close-later ; -: fill-stdout-pipe +: fill-stdout-pipe ( args -- args ) dup add-pipe-dtors dup pipe-in f set-inherit - over set-CreateProcess-args-stdout-pipe ; + >>stdout-pipe ; -: fill-stdin-pipe +: fill-stdin-pipe ( args -- args ) dup add-pipe-dtors dup pipe-out f set-inherit - over set-CreateProcess-args-stdin-pipe ; + >>stdin-pipe ; -M: windows-nt-io fill-redirection - dup CreateProcess-args-lpStartupInfo - over redirect-stdout over set-STARTUPINFO-hStdOutput - over redirect-stderr over set-STARTUPINFO-hStdError - over redirect-stdin over set-STARTUPINFO-hStdInput - drop ; +M: windows-nt-io fill-redirection ( process args -- ) + [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput + [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError + [ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput + 2drop ; -M: windows-nt-io process-stream* +M: windows-nt-io (process-stream) [ - [ - make-CreateProcess-args + dup make-CreateProcess-args - fill-stdout-pipe - fill-stdin-pipe + fill-stdout-pipe + fill-stdin-pipe - fill-redirection + tuck fill-redirection - dup call-CreateProcess + dup call-CreateProcess - dup CreateProcess-args-stdin-pipe pipe-in CloseHandle drop - dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop + dup stdin-pipe>> pipe-in CloseHandle drop + dup stdout-pipe>> pipe-out CloseHandle drop - dup CreateProcess-args-stdout-pipe pipe-in - over CreateProcess-args-stdin-pipe pipe-out - - swap CreateProcess-args-lpProcessInformation - ] with-destructors - ] with-descriptor ; + dup lpProcessInformation>> + over stdout-pipe>> in>> f + rot stdin-pipe>> out>> f + ] with-destructors ; diff --git a/extra/io/windows/nt/launcher/test/env.factor b/extra/io/windows/nt/launcher/test/env.factor new file mode 100755 index 0000000000..a0015f7ea2 --- /dev/null +++ b/extra/io/windows/nt/launcher/test/env.factor @@ -0,0 +1,3 @@ +USE: system +USE: prettyprint +os-envs . diff --git a/extra/io/windows/nt/launcher/test/stderr.factor b/extra/io/windows/nt/launcher/test/stderr.factor new file mode 100755 index 0000000000..0b97387cf7 --- /dev/null +++ b/extra/io/windows/nt/launcher/test/stderr.factor @@ -0,0 +1,5 @@ +USE: io +USE: namespaces + +"output" write flush +"error" stderr get stream-write stderr get stream-flush diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index eff3c250dc..83e062c3a9 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 strings ; 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? @@ -66,6 +66,9 @@ M: windows-nt-io ( path recursive? -- monitor ) { [ t ] [ +modify-file+ ] } } cond nip ; +: memory>u16-string ( alien len -- string ) + [ memory>byte-array ] keep 2/ c-ushort-array> >string ; + : parse-file-notify ( buffer -- changed path ) { FILE_NOTIFY_INFORMATION-FileName diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index e4ebe3dd37..c4ac99fe4a 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,6 +1,6 @@ USING: io.files kernel tools.test io.backend io.windows.nt.files splitting ; -IN: temporary +IN: io.windows.nt.tests [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test [ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index be57a398a2..9bc587e00e 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -9,6 +9,7 @@ USE: io.windows.nt.launcher USE: io.windows.nt.monitors USE: io.windows.nt.sockets USE: io.windows.mmap +USE: io.windows.files USE: io.backend T{ windows-nt-io } set-io-backend diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index 9591063609..eb6dae2a0a 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types arrays destructors io io.windows libc windows.types math windows.kernel32 windows namespaces kernel sequences windows.errors assocs math.parser system random -combinators ; +combinators new-slots accessors ; IN: io.windows.nt.pipes ! This code is based on @@ -42,8 +42,8 @@ TUPLE: pipe in out ; : close-pipe ( pipe -- ) dup - pipe-in CloseHandle drop - pipe-out CloseHandle drop ; + in>> CloseHandle drop + out>> CloseHandle drop ; : ( name -- pipe ) PIPE_ACCESS_INBOUND GENERIC_WRITE ; @@ -70,13 +70,13 @@ TUPLE: pipe in out ; ! /dev/null simulation : null-input ( -- pipe ) - dup pipe-out CloseHandle drop - pipe-in ; + dup out>> CloseHandle drop + in>> ; : null-output ( -- pipe ) - dup pipe-in CloseHandle drop - pipe-out ; + dup in>> CloseHandle drop + out>> ; : null-pipe ( mode -- pipe ) { diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index eef7476dd5..a63a533ba1 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -45,13 +45,12 @@ TUPLE: ConnectEx-args port "stdcall" alien-indirect drop winsock-error-string [ throw ] when* ; -: connect-continuation ( ConnectEx -- ) - dup ConnectEx-args-lpOverlapped* - swap ConnectEx-args-port duplex-stream-in - [ save-callback ] 2keep +: connect-continuation ( ConnectEx port -- ) + >r ConnectEx-args-lpOverlapped* r> + 2dup save-callback get-overlapped-result drop ; -M: windows-nt-io (client) ( addrspec -- duplex-stream ) +M: windows-nt-io (client) ( addrspec -- client-in client-out ) [ \ ConnectEx-args construct-empty over make-sockaddr/size pick init-connect @@ -61,13 +60,8 @@ M: windows-nt-io (client) ( addrspec -- duplex-stream ) dup ConnectEx-args-s* INADDR_ANY roll bind-socket dup (ConnectEx) - dup ConnectEx-args-s* dup handle>duplex-stream - over set-ConnectEx-args-port - - dup connect-continuation - ConnectEx-args-port - [ duplex-stream-in pending-error ] keep - [ duplex-stream-out pending-error ] keep + dup ConnectEx-args-s* dup + >r [ connect-continuation ] keep [ pending-error ] keep r> ] with-destructors ; TUPLE: AcceptEx-args port @@ -91,7 +85,7 @@ TUPLE: AcceptEx-args port f over set-AcceptEx-args-lpdwBytesReceived* (make-overlapped) swap set-AcceptEx-args-lpOverlapped* ; -: (accept) ( AcceptEx -- ) +: ((accept)) ( AcceptEx -- ) \ AcceptEx-args >tuple*< AcceptEx drop winsock-error-string [ throw ] when* ; @@ -117,38 +111,31 @@ TUPLE: AcceptEx-args port ] keep *void* ] keep AcceptEx-args-port server-port-addr parse-sockaddr ; -: accept-continuation ( AcceptEx -- client ) +: accept-continuation ( AcceptEx -- addrspec client ) [ make-accept-continuation ] keep [ check-accept-error ] keep [ extract-remote-host ] keep ! addrspec AcceptEx - [ - AcceptEx-args-sAcceptSocket* add-completion - ] keep - AcceptEx-args-sAcceptSocket* dup handle>duplex-stream - ; + [ AcceptEx-args-sAcceptSocket* add-completion ] keep + AcceptEx-args-sAcceptSocket* ; -M: windows-nt-io accept ( server -- client ) +M: windows-nt-io (accept) ( server -- addrspec handle ) [ [ dup check-server-port \ AcceptEx-args construct-empty [ init-accept ] keep - [ (accept) ] keep + [ ((accept)) ] keep [ accept-continuation ] keep AcceptEx-args-port pending-error - dup duplex-stream-in pending-error - dup duplex-stream-out pending-error ] with-timeout ] with-destructors ; -M: windows-nt-io ( addrspec -- server ) +M: windows-nt-io (server) ( addrspec -- handle ) [ - [ - SOCK_STREAM server-fd dup listen-on-socket - dup add-completion - - ] keep + SOCK_STREAM server-fd dup listen-on-socket + dup add-completion + ] with-destructors ; M: windows-nt-io ( addrspec -- datagram ) diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index ee3f744bb0..094a6ec0d6 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 @@ -20,15 +20,12 @@ TUPLE: win32-file handle ptr ; C: win32-file -: ( in out -- stream ) - >r f r> f handle>duplex-stream ; - HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) 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 +52,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 ; @@ -112,16 +109,16 @@ C: FileArgs [ FileArgs-lpNumberOfBytesRet ] keep FileArgs-lpOverlapped ; -M: windows-io ( path -- stream ) +M: windows-io (file-reader) ( path -- stream ) open-read ; -M: windows-io ( path -- stream ) +M: windows-io (file-writer) ( path -- stream ) open-write ; -M: windows-io ( path -- stream ) +M: windows-io (file-appender) ( 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/irc/irc.factor b/extra/irc/irc.factor index 44c682e671..8a39846fc4 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays calendar io io.sockets kernel match namespaces -sequences splitting strings continuations threads ascii ; +sequences splitting strings continuations threads ascii +io.encodings.utf8 ; IN: irc ! "setup" objects @@ -97,7 +98,7 @@ SYMBOL: irc-client " hostname servername :irc.factor" irc-print ; : connect* ( server port -- ) - irc-client get set-irc-client-stream ; + utf8 irc-client get set-irc-client-stream ; : connect ( server -- ) 6667 connect* ; diff --git a/extra/jamshred/authors.txt b/extra/jamshred/authors.txt old mode 100755 new mode 100644 diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index fe517d68fd..f82ee91d22 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: kernel opengl arrays sequences jamshred.tunnel jamshred.player math.vectors ; IN: jamshred.game diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index da38e43392..85c5a8dbaf 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.vectors opengl opengl.gl opengl.glu sequences ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 36dd0619f0..8beecc955c 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,9 +1,11 @@ -USING: arrays jamshred.game jamshred.gl kernel math math.constants -namespaces sequences timers ui ui.gadgets ui.gestures ui.render +! Copyright (C) 2007, 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: alarms arrays calendar jamshred.game jamshred.gl kernel math +math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render math.vectors ; IN: jamshred -TUPLE: jamshred-gadget jamshred last-hand-loc ; +TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; : ( jamshred -- gadget ) jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ; @@ -17,13 +19,17 @@ M: jamshred-gadget pref-dim* M: jamshred-gadget draw-gadget* ( gadget -- ) dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ; -M: jamshred-gadget tick ( gadget -- ) +: tick ( gadget -- ) dup jamshred-gadget-jamshred jamshred-update relayout-1 ; M: jamshred-gadget graft* ( gadget -- ) - 10 1 add-timer ; + [ + [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm + ] keep set-jamshred-gadget-alarm ; -M: jamshred-gadget ungraft* ( gadget -- ) remove-timer ; +M: jamshred-gadget ungraft* ( gadget -- ) + [ jamshred-gadget-alarm cancel-alarm f ] keep + set-jamshred-gadget-alarm ; : jamshred-restart ( jamshred-gadget -- ) swap set-jamshred-gadget-jamshred ; diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 254be2057a..bcf4597307 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; IN: jamshred.oint diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 4daecf29a2..6cc433903e 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: colors jamshred.oint jamshred.tunnel kernel math math.constants sequences ; IN: jamshred.player diff --git a/extra/jamshred/summary.txt b/extra/jamshred/summary.txt new file mode 100644 index 0000000000..e26fc1cf8b --- /dev/null +++ b/extra/jamshred/summary.txt @@ -0,0 +1 @@ +A simple 3d tunnel racing game diff --git a/extra/jamshred/tags.txt b/extra/jamshred/tags.txt new file mode 100644 index 0000000000..8ae5957a4b --- /dev/null +++ b/extra/jamshred/tags.txt @@ -0,0 +1,2 @@ +applications +games diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 2ea8a64bd9..8031678896 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,5 +1,7 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ; -IN: temporary +IN: jamshred.tunnel.tests [ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 } T{ segment T{ oint f { 1 1 1 } } 1 } diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 4d60a65a4a..61fef7959c 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: arrays float-arrays kernel jamshred.oint math math.functions math.ranges math.vectors math.constants random sequences vectors ; IN: jamshred.tunnel diff --git a/extra/koszul/koszul-tests.factor b/extra/koszul/koszul-tests.factor old mode 100644 new mode 100755 index d72314fc4d..01fba49995 --- a/extra/koszul/koszul-tests.factor +++ b/extra/koszul/koszul-tests.factor @@ -1,5 +1,6 @@ -USING: koszul tools.test kernel sequences assocs namespaces ; -IN: temporary +USING: koszul tools.test kernel sequences assocs namespaces +symbols ; +IN: koszul.tests [ { V{ { } } V{ { 1 } } V{ { 2 3 } { 7 8 } } V{ { 4 5 6 } } } diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 9545e1cc9d..69de838eec 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -3,14 +3,10 @@ USING: arrays assocs hashtables assocs io kernel math math.vectors math.matrices math.matrices.elimination namespaces parser prettyprint sequences words combinators math.parser -splitting sorting shuffle ; +splitting sorting shuffle symbols ; IN: koszul ! Utilities -: SYMBOLS: - ";" parse-tokens [ create-in define-symbol ] each ; - parsing - : -1^ odd? -1 1 ? ; : >alt ( obj -- vec ) 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-docs.factor b/extra/lazy-lists/lazy-lists-docs.factor index 11afc9b6b5..ebacea03d8 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lazy-lists/lazy-lists-docs.factor @@ -26,7 +26,7 @@ HELP: nil? { $values { "cons" "a cons object" } { "?" "a boolean" } } { $description "Return true if the cons object is the nil cons." } ; -HELP: list? +HELP: list? ( object -- ? ) { $values { "object" "an object" } { "?" "a boolean" } } { $description "Returns true if the object conforms to the list protocol." } ; @@ -175,7 +175,7 @@ HELP: lmerge { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } } { $description "Return the result of merging the two lists in a lazy manner." } { $examples - { $example "USE: lazy-lists" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } + { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } } ; HELP: lcontents diff --git a/extra/lazy-lists/lazy-lists-tests.factor b/extra/lazy-lists/lazy-lists-tests.factor index 9b7f0effd2..302299b452 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 @@ -23,3 +23,7 @@ IN: temporary [ { 5 6 7 8 } ] [ { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array ] unit-test + +[ { 4 5 6 } ] [ + 3 { 1 2 3 } >list [ + ] lmap-with list>array +] unit-test diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index e3e7b14917..07cd34b4df 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -144,25 +144,8 @@ M: lazy-map cdr ( lazy-map -- cdr ) M: lazy-map nil? ( lazy-map -- bool ) lazy-map-cons nil? ; -TUPLE: lazy-map-with value cons quot ; - -C: lazy-map-with - : lmap-with ( value list quot -- result ) - over nil? [ 3drop nil ] [ ] if ; - -M: lazy-map-with car ( lazy-map-with -- car ) - [ lazy-map-with-value ] keep - [ lazy-map-with-cons car ] keep - lazy-map-with-quot call ; - -M: lazy-map-with cdr ( lazy-map-with -- cdr ) - [ lazy-map-with-value ] keep - [ lazy-map-with-cons cdr ] keep - lazy-map-with-quot lmap-with ; - -M: lazy-map-with nil? ( lazy-map-with -- bool ) - lazy-map-with-cons nil? ; + with lmap ; TUPLE: lazy-take n cons ; @@ -453,7 +436,6 @@ INSTANCE: lazy-io list INSTANCE: lazy-concat list INSTANCE: lazy-cons list INSTANCE: lazy-map list -INSTANCE: lazy-map-with list INSTANCE: lazy-take list INSTANCE: lazy-append list INSTANCE: lazy-from-by list 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/ldap/ldap-tests.factor b/extra/ldap/ldap-tests.factor old mode 100644 new mode 100755 index e4338615ce..14029706e5 --- a/extra/ldap/ldap-tests.factor +++ b/extra/ldap/ldap-tests.factor @@ -1,54 +1,58 @@ -USING: alien alien.c-types io kernel ldap ldap.libldap namespaces prettyprint -tools.test ; +USING: alien alien.c-types io kernel ldap ldap.libldap +namespaces prettyprint tools.test ; +IN: ldap.tests "void*" "ldap://localhost:389" initialize get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 set-option -[ B{ 0 0 0 3 } ] [ +[ 3 ] [ get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" [ get-option ] keep + *int ] unit-test -get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ +[ + get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ - ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0 - ! "void*" [ search-s ] keep *int . + ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0 + ! "void*" [ search-s ] keep *int . - [ 2 ] [ - get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0 - search - ] unit-test + [ 2 ] [ + get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0 + search + ] unit-test - ! get-ldp LDAP_RES_ANY 0 f "void*" result . + ! get-ldp LDAP_RES_ANY 0 f "void*" result . - get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" result + get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" result - ! get-message *int . + ! get-message *int . - "Message ID: " write + "Message ID: " write - get-message msgid . + get-message msgid . - get-ldp get-message get-dn . + get-ldp get-message get-dn . - "Entries count: " write + "Entries count: " write - get-ldp get-message count-entries . + get-ldp get-message count-entries . - SYMBOL: entry - SYMBOL: attr + SYMBOL: entry + SYMBOL: attr - "Attribute: " write + "Attribute: " write - get-ldp get-message first-entry entry set get-ldp entry get - "void*" first-attribute dup . attr set + get-ldp get-message first-entry entry set get-ldp entry get + "void*" first-attribute dup . attr set - "Value: " write + "Value: " write - get-ldp entry get attr get get-values *char* . + get-ldp entry get attr get get-values *char* . - get-ldp get-message first-message msgtype result-type + get-ldp get-message first-message msgtype result-type - get-ldp get-message next-message msgtype result-type + get-ldp get-message next-message msgtype result-type -] with-bind + ] with-bind +] drop diff --git a/extra/ldap/libldap/libldap.factor b/extra/ldap/libldap/libldap.factor index 492aed1a54..ae613bd461 100755 --- a/extra/ldap/libldap/libldap.factor +++ b/extra/ldap/libldap/libldap.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ; IN: ldap.libldap -"libldap" { +<< "libldap" { { [ win32? ] [ "libldap.dll" "stdcall" ] } { [ macosx? ] [ "libldap.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] } -} cond add-library +} cond add-library >> : LDAP_VERSION1 1 ; inline : LDAP_VERSION2 2 ; inline 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..62f2eac513 100644 --- a/extra/locals/locals-docs.factor +++ b/extra/locals/locals-docs.factor @@ -15,8 +15,8 @@ HELP: [| { $description "A lambda abstraction. When called, reads stack values into the bindings from left to right; the body may then refer to these bindings." } { $examples { $example - "USE: locals" - ":: adder | n | [| m | m n + ] ;" + "USING: kernel locals math prettyprint ;" + ":: adder ( n -- quot ) [| m | m n + ] ;" "3 5 adder call ." "8" } @@ -28,8 +28,8 @@ HELP: [let { $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." } { $examples { $example - "USING: locals math.functions ;" - ":: frobnicate | n seq |" + "USING: kernel locals math math.functions prettyprint sequences ;" + ":: frobnicate ( n seq -- newseq )" " [let | n' [ n 6 * ] |" " seq [ n' gcd nip ] map ] ;" "6 { 36 14 } frobnicate ." @@ -43,8 +43,8 @@ HELP: [wlet { $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [wlet } " is equivalent to the Lisp " { $snippet "flet" } ", not " { $snippet "labels" } "." } { $examples { $example - "USE: locals" - ":: quuxify | n seq |" + "USING: locals math prettyprint sequences ;" + ":: 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 old mode 100644 new mode 100755 index 85984ffaee..b4f1b0a61e --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -1,52 +1,52 @@ USING: locals math sequences tools.test hashtables words kernel -namespaces arrays ; -IN: temporary +namespaces arrays strings prettyprint ; +IN: locals.tests -:: foo | a b | a a ; +:: foo ( a b -- a a ) a a ; [ 1 1 ] [ 1 2 foo ] unit-test -:: add-test | a b | a b + ; +:: add-test ( a b -- c ) a b + ; [ 3 ] [ 1 2 add-test ] unit-test -:: sub-test | a b | a b - ; +:: sub-test ( a b -- c ) a b - ; [ -1 ] [ 1 2 sub-test ] unit-test -:: map-test | a b | a [ b + ] map ; +:: map-test ( a b -- seq ) a [ b + ] map ; [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test -:: map-test-2 | seq inc | seq [| elt | elt inc + ] map ; +:: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ; [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test -:: let-test | c | +:: let-test ( c -- d ) [let | a [ 1 ] b [ 2 ] | a b + c + ] ; [ 7 ] [ 4 let-test ] unit-test -:: let-test-2 | | - [let | a [ ] | [let | b [ a ] | a ] ] ; +:: let-test-2 ( a -- a ) + a [let | a [ ] | [let | b [ a ] | a ] ] ; [ 3 ] [ 3 let-test-2 ] unit-test -:: let-test-3 | | - [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ; +:: let-test-3 ( a -- a ) + a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ; -:: let-test-4 | | - [let | a [ 1 ] b [ ] | a b 2array ] ; +:: let-test-4 ( a -- b ) + a [let | a [ 1 ] b [ ] | a b 2array ] ; [ { 1 2 } ] [ 2 let-test-4 ] unit-test -:: let-test-5 | | - [let | a [ ] b [ ] | a b 2array ] ; +:: let-test-5 ( a -- b ) + a [let | a [ ] b [ ] | a b 2array ] ; [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test -:: let-test-6 | | - [let | a [ ] b [ 1 ] | a b 2array ] ; +:: let-test-6 ( a -- b ) + a [let | a [ ] b [ 1 ] | a b 2array ] ; [ { 2 1 } ] [ 2 let-test-6 ] unit-test @@ -57,26 +57,26 @@ IN: temporary with-locals ] unit-test -:: wlet-test-2 | a b | +:: wlet-test-2 ( a b -- seq ) [wlet | add-b [ b + ] | a [ add-b ] map ] ; [ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test -:: wlet-test-3 | a | +:: wlet-test-3 ( a -- b ) [wlet | add-a [ a + ] | [ add-a ] ] [let | a [ 3 ] | a swap call ] ; [ 5 ] [ 2 wlet-test-3 ] unit-test -:: wlet-test-4 | a | +:: wlet-test-4 ( a -- b ) [wlet | sub-a [| b | b a - ] | 3 sub-a ] ; [ -7 ] [ 10 wlet-test-4 ] unit-test -:: write-test-1 | n! | +:: write-test-1 ( n! -- q ) [| i | n i + dup n! ] ; 0 write-test-1 "q" set @@ -89,7 +89,7 @@ IN: temporary [ 5 ] [ 2 "q" get call ] unit-test -:: write-test-2 | | +:: write-test-2 ( -- q ) [let | n! [ 0 ] | [| i | n i + dup n! ] ] ; @@ -108,17 +108,73 @@ 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 +! Not really a write test; just enforcing consistency +:: write-test-5 ( x -- y ) + [wlet | fun! [ x + ] | 5 fun! ] ; + +[ 9 ] [ 4 write-test-5 ] unit-test + SYMBOL: a -:: use-test | a b c | +:: use-test ( a b c -- a b c ) USE: kernel ; [ t ] [ a symbol? ] unit-test + +:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ; + +[ 13 ] [ 10 let-let-test ] unit-test + +GENERIC: lambda-generic ( a b -- c ) + +GENERIC# lambda-generic-1 1 ( a b -- c ) + +M:: integer lambda-generic-1 ( a b -- c ) a b * ; + +M:: string lambda-generic-1 ( a b -- c ) + a b CHAR: x lambda-generic ; + +M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ; + +GENERIC# lambda-generic-2 1 ( a b -- c ) + +M:: integer lambda-generic-2 ( a b -- c ) + a CHAR: x b lambda-generic ; + +M:: string lambda-generic-2 ( a b -- c ) a b append ; + +M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; + +[ 10 ] [ 5 2 lambda-generic ] unit-test + +[ "abab" ] [ "aba" "b" lambda-generic ] unit-test + +[ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test + +[ "xaba" ] [ 1 "aba" lambda-generic ] unit-test + +[ ] [ \ lambda-generic-1 see ] unit-test + +[ ] [ \ lambda-generic-2 see ] unit-test + +[ ] [ \ lambda-generic see ] unit-test + +[ "[let | a! [ ] | ]" ] [ + [let | a! [ ] | ] unparse +] unit-test + +[ "[wlet | a! [ ] | ]" ] [ + [wlet | a! [ ] | ] unparse +] unit-test + +[ "[| a! | ]" ] [ + [| a! | ] unparse +] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 52ccb1bed3..956504be2c 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 r pprint-word r> pprint* block> ] 2each + values [ r pprint-var r> pprint* block> ] 2each block> \ | pprint-word @@ -311,7 +329,7 @@ M: let pprint* \ ] pprint-word ; M: wlet pprint* - \ [let pprint-word + \ [wlet pprint-word { wlet-body wlet-vars wlet-bindings } get-slots pprint-let \ ] pprint-word ; @@ -323,26 +341,42 @@ M: lambda-word definer drop \ :: \ ; ; M: lambda-word definition "lambda" word-prop lambda-body ; -: lambda-word-synopsis ( word prop -- ) - over definer. - over seeing-word - over pprint-word - \ | pprint-word - word-prop lambda-vars pprint-vars - \ | pprint-word ; +: lambda-word-synopsis ( word -- ) + dup definer. + dup seeing-word + dup pprint-word + stack-effect. ; -M: lambda-word synopsis* - "lambda" lambda-word-synopsis ; +M: lambda-word synopsis* lambda-word-synopsis ; PREDICATE: macro lambda-macro - "lambda-macro" word-prop >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/log-viewer/log-viewer.factor b/extra/log-viewer/log-viewer.factor index 0f139d184e..7bc63d3e34 100755 --- a/extra/log-viewer/log-viewer.factor +++ b/extra/log-viewer/log-viewer.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files io.monitors ; +USING: kernel io io.files io.monitors io.encodings.utf8 ; IN: log-viewer : read-lines ( stream -- ) @@ -9,6 +9,6 @@ IN: log-viewer dup next-change 2drop over read-lines tail-file-loop ; : tail-file ( file -- ) - dup dup read-lines + dup utf8 dup read-lines swap parent-directory f tail-file-loop ; diff --git a/extra/logging/analysis/analysis-docs.factor b/extra/logging/analysis/analysis-docs.factor index 2919f2bcd4..10b6924b52 100644 --- a/extra/logging/analysis/analysis-docs.factor +++ b/extra/logging/analysis/analysis-docs.factor @@ -16,7 +16,7 @@ HELP: analysis. { $description "Prints a logging report output by " { $link analyze-entries } ". Formatted output words are used, so the report looks nice in the UI or if sent to an HTML stream." } ; HELP: analyze-log -{ $values { "service" "a log service name" } { "n" integer } { "word-names" "a sequence of strings" } } +{ $values { "lines" "a parsed log file" } { "word-names" "a sequence of strings" } } { $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; ARTICLE: "logging.analysis" "Log analysis" diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor index b530c09b22..e2c77377ac 100755 --- a/extra/logging/analysis/analysis.factor +++ b/extra/logging/analysis/analysis.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences namespaces words assocs logging sorting -prettyprint io io.styles strings logging.parser ; +prettyprint io io.styles strings logging.parser calendar.format ; IN: logging.analysis SYMBOL: word-names @@ -42,16 +42,14 @@ SYMBOL: message-histogram ] tabular-output ; : log-entry. - [ - dup first [ write ] with-cell - dup second [ pprint ] with-cell - dup third [ write ] with-cell - fourth "\n" join [ write ] with-cell - ] with-row ; + "====== " write + dup first (timestamp>string) bl + dup second pprint bl + dup third write nl + fourth "\n" join print ; : errors. ( errors -- ) - standard-table-style - [ [ log-entry. ] each ] tabular-output ; + [ log-entry. ] each ; : analysis. ( errors word-histogram message-histogram -- ) "==== INTERESTING MESSAGES:" print nl diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor old mode 100644 new mode 100755 index 64ac3b4ff6..c86a675698 --- a/extra/logging/insomniac/insomniac-docs.factor +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -2,12 +2,6 @@ USING: help.markup help.syntax assocs strings logging logging.analysis smtp ; IN: logging.insomniac -HELP: insomniac-smtp-host -{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ; - -HELP: insomniac-smtp-port -{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ; - HELP: insomniac-sender { $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; @@ -15,27 +9,24 @@ HELP: insomniac-recipients { $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; HELP: ?analyze-log -{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string" string } } +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string/f" string } } { $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." } { $see-also analyze-log } ; HELP: email-log-report { $values { "service" "a log service name" } { "word-names" "a sequence of strings" } } -{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; +{ $description "E-mails a log report for the given log service. The " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; HELP: schedule-insomniac -{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } } { $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:" { $subsection insomniac-sender } { $subsection insomniac-recipients } -"Optional configuration parameters:" -{ $subsection insomniac-smtp-host } -{ $subsection insomniac-smtp-port } "E-mailing a one-off report:" { $subsection email-log-report } "E-mailing reports and rotating logs on a daily basis:" diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index bb143879bf..c7d1faf42e 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -1,41 +1,35 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: logging.analysis logging.server logging smtp io.sockets -kernel io.files io.streams.string namespaces raptor.cron assocs ; +USING: logging.analysis logging.server logging smtp kernel +io.files io.streams.string namespaces alarms assocs +io.encodings.utf8 accessors calendar qualified ; +QUALIFIED: io.sockets IN: logging.insomniac -SYMBOL: insomniac-smtp-host -SYMBOL: insomniac-smtp-port SYMBOL: insomniac-sender SYMBOL: insomniac-recipients : ?analyze-log ( service word-names -- string/f ) >r log-path 1 log# dup exists? [ - file-lines r> [ analyze-log ] with-string-writer + utf8 file-lines r> [ analyze-log ] with-string-writer ] [ r> 2drop f ] if ; -: with-insomniac-smtp ( quot -- ) - [ - insomniac-smtp-host get [ smtp-host set ] when* - insomniac-smtp-port get [ smtp-port set ] when* - call - ] with-scope ; inline - : email-subject ( service -- string ) - [ "[INSOMNIAC] " % % " on " % host-name % ] "" make ; + [ + "[INSOMNIAC] " % % " on " % io.sockets:host-name % + ] "" make ; : (email-log-report) ( service word-names -- ) - [ - over >r - ?analyze-log dup [ - r> email-subject - insomniac-recipients get - insomniac-sender get - send-simple-message - ] [ r> 2drop ] if - ] with-insomniac-smtp ; + dupd ?analyze-log dup [ + + swap >>body + insomniac-recipients get >>to + insomniac-sender get >>from + swap email-subject >>subject + send-email + ] [ 2drop ] if ; \ (email-log-report) NOTICE add-error-logging @@ -43,6 +37,5 @@ SYMBOL: insomniac-recipients "logging.insomniac" [ (email-log-report) ] with-logging ; : schedule-insomniac ( service word-names -- ) - { 25 } { 6 } f f f -rot [ - [ email-log-report ] assoc-each rotate-logs - ] 2curry schedule ; + [ [ email-log-report ] assoc-each rotate-logs ] 2curry + 1 days every drop ; diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor old mode 100644 new mode 100755 index 939388026d..df0b132ac8 --- a/extra/logging/logging-docs.factor +++ b/extra/logging/logging-docs.factor @@ -39,19 +39,19 @@ HELP: log-message { $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; HELP: add-logging -{ $values { "word" word } } +{ $values { "level" "a log level" } { "word" word } } { $description "Causes the word to log a message every time it is called." } ; HELP: add-input-logging -{ $values { "word" word } } +{ $values { "level" "a log level" } { "word" word } } { $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ; HELP: add-output-logging -{ $values { "word" word } } +{ $values { "level" "a log level" } { "word" word } } { $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ; HELP: add-error-logging -{ $values { "word" word } } +{ $values { "level" "a log level" } { "word" word } } { $description "Causes the word to log its input values and any errors it throws." $nl "If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller." @@ -63,7 +63,7 @@ HELP: log-error { $description "Logs an error." } ; HELP: log-critical -{ $values { "critical" "an critical" } { "word" word } } +{ $values { "error" "an error" } { "word" word } } { $description "Logs a critical error." } ; HELP: LOG: @@ -100,7 +100,7 @@ ARTICLE: "logging.rotation" "Log rotation" "The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ; ARTICLE: "logging.server" "Log implementation" -"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead ot uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion." +"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead it uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion." $nl "The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:" { $subsection (log-message) } @@ -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-docs.factor b/extra/logging/parser/parser-docs.factor index ee995749be..dc80f9e87f 100644 --- a/extra/logging/parser/parser-docs.factor +++ b/extra/logging/parser/parser-docs.factor @@ -6,7 +6,7 @@ HELP: parse-log { $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where" { $list { { $snippet "timestamp" } " is a " { $link timestamp } } - { { $snippet "level" } " is a log level; see " { $link "logger.levels" } } + { { $snippet "level" } " is a log level; see " { $link "logging.levels" } } { { $snippet "word-name" } " is a string" } { { $snippet "message" } " is a string" } } 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..d181ab8a16 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -3,7 +3,8 @@ 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 +io.encodings.ascii ; IN: logging.server : log-root ( -- string ) @@ -20,7 +21,7 @@ SYMBOL: log-files : open-log-stream ( service -- stream ) log-path dup make-directories - 1 log# ; + 1 log# ascii ; : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; @@ -68,11 +69,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-docs.factor b/extra/match/match-docs.factor index 96d2ea98de..4ac59bb0cc 100644 --- a/extra/match/match-docs.factor +++ b/extra/match/match-docs.factor @@ -41,7 +41,7 @@ HELP: match-replace { $description "Matches the " { $snippet "object" } " against " { $snippet "pattern1" } ". The pattern match variables in " { $snippet "pattern1" } " are assigned the values from the matching " { $snippet "object" } ". These are then replaced into the " { $snippet "pattern2" } " pattern match variables." } { $examples { $example - "USE: match" + "USING: match prettyprint ;" "MATCH-VARS: ?a ?b ;" "{ 1 2 } { ?a ?b } { ?b ?a } match-replace ." "{ 2 1 }" 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-docs.factor b/extra/math/combinatorics/combinatorics-docs.factor index c763cc32cf..355898a8bd 100644 --- a/extra/math/combinatorics/combinatorics-docs.factor +++ b/extra/math/combinatorics/combinatorics-docs.factor @@ -4,46 +4,46 @@ IN: math.combinatorics HELP: factorial { $values { "n" "a non-negative integer" } { "n!" integer } } { $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." } -{ $examples { $example "4 factorial ." "24" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ; HELP: nPk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } } { $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." } -{ $examples { $example "10 4 nPk ." "5040" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ; HELP: nCk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } } { $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." } -{ $examples { $example "10 4 nCk ." "210" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ; HELP: permutation { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } { $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } { $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } -{ $examples { $example "1 3 permutation ." "{ 0 2 1 }" } { $example "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\"}" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ; HELP: all-permutations { $values { "seq" sequence } { "seq" sequence } } { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } -{ $examples { $example "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; HELP: inverse-permutation { $values { "seq" sequence } { "permutation" sequence } } { $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." } { $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." } -{ $examples { $example "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; IN: math.combinatorics.private HELP: factoradic -{ $values { "n" integer } { "seq" sequence } } +{ $values { "n" integer } { "factoradic" sequence } } { $description "Converts a positive integer " { $snippet "n" } " to factoradic form. The factoradic of an integer is its representation based on a mixed radix numerical system that corresponds to the values of " { $snippet "n" } " factorial." } -{ $examples { $example "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ; +{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ; HELP: >permutation { $values { "factoradic" sequence } { "permutation" sequence } } { $description "Converts an integer represented in factoradic form into its corresponding unique permutation (0-based)." } { $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } } -{ $examples { $example "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ; +{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ; 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/constants/constants-docs.factor b/extra/math/constants/constants-docs.factor index 42cdf0e8f1..4fdd975202 100755 --- a/extra/math/constants/constants-docs.factor +++ b/extra/math/constants/constants-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel layouts ; +USING: help.markup help.syntax kernel ; IN: math.constants ARTICLE: "math-constants" "Constants" @@ -7,9 +7,6 @@ ARTICLE: "math-constants" "Constants" { $subsection euler } { $subsection phi } { $subsection pi } -"Various limits:" -{ $subsection most-positive-fixnum } -{ $subsection most-negative-fixnum } { $subsection epsilon } ; ABOUT: "math-constants" diff --git a/extra/math/erato/erato-docs.factor b/extra/math/erato/erato-docs.factor index 6e84c84057..29bd3020f3 100644 --- a/extra/math/erato/erato-docs.factor +++ b/extra/math/erato/erato-docs.factor @@ -3,4 +3,4 @@ IN: math.erato HELP: lerato { $values { "n" "a positive number" } { "lazy-list" "a lazy prime numbers generator" } } -{ $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive). Lazy lists are described in " { $link "lazy-lists" } "." } ; +{ $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive)." } ; 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-docs.factor b/extra/math/functions/functions-docs.factor index d3a81566b9..f0819fb03e 100755 --- a/extra/math/functions/functions-docs.factor +++ b/extra/math/functions/functions-docs.factor @@ -273,16 +273,16 @@ HELP: mod-inv { $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." } { $errors "Throws an error if " { $snippet "n" } " is not invertible modulo " { $snippet "n" } "." } { $examples - { $example "USE: math.functions" "173 1119 mod-inv ." "815" } - { $example "USE: math.functions" "173 815 * 1119 mod ." "1" } + { $example "USING: math.functions prettyprint ;" "173 1119 mod-inv ." "815" } + { $example "USING: math prettyprint ;" "173 815 * 1119 mod ." "1" } } ; HELP: each-bit { $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( ? -- )" } } } { $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." } { $examples - { $example "USE: math.functions" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" } - { $example "USE: math.functions" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" } + { $example "USING: math.functions namespaces prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" } + { $example "USING: math.functions namespaces prettyprint ;" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" } } ; HELP: ~ 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/factors/factors-docs.factor b/extra/math/primes/factors/factors-docs.factor index f5b14b5a5a..f9fe4d5dcb 100644 --- a/extra/math/primes/factors/factors-docs.factor +++ b/extra/math/primes/factors/factors-docs.factor @@ -6,17 +6,17 @@ IN: math.primes.factors HELP: factors { $values { "n" "a positive integer" } { "seq" sequence } } { $description { "Return an ordered list of a number's prime factors, possibly repeated." } } -{ $examples { $example "300 factors ." "{ 2 2 3 5 5 }" } } ; +{ $examples { $example "USING: math.primes.factors prettyprint ;" "300 factors ." "{ 2 2 3 5 5 }" } } ; HELP: group-factors { $values { "n" "a positive integer" } { "seq" sequence } } { $description { "Return a sequence of pairs representing each prime factor in the number and its corresponding power (multiplicity)." } } -{ $examples { $example "300 group-factors ." "{ { 2 2 } { 3 1 } { 5 2 } }" } } ; +{ $examples { $example "USING: math.primes.factors prettyprint ;" "300 group-factors ." "{ { 2 2 } { 3 1 } { 5 2 } }" } } ; HELP: unique-factors { $values { "n" "a positive integer" } { "seq" sequence } } { $description { "Return an ordered list of a number's unique prime factors." } } -{ $examples { $example "300 unique-factors ." "{ 2 3 5 }" } } ; +{ $examples { $example "USING: math.primes.factors prettyprint ;" "300 unique-factors ." "{ 2 3 5 }" } } ; HELP: totient { $values { "n" "a positive integer" } { "t" integer } } diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index 68ab5b3221..685124e4e9 100644 --- a/extra/math/primes/primes.factor +++ b/extra/math/primes/primes.factor @@ -47,3 +47,5 @@ PRIVATE> primes-upto >r 1- next-prime r> [ [ <=> ] binsearch ] keep [ length ] keep ; foldable + +: coprime? ( a b -- ? ) gcd nip 1 = ; foldable diff --git a/extra/math/quaternions/quaternions-tests.factor b/extra/math/quaternions/quaternions-tests.factor index 4f59798df0..b30a1bc271 100644 --- a/extra/math/quaternions/quaternions-tests.factor +++ b/extra/math/quaternions/quaternions-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.quaternions.tests USING: tools.test math.quaternions kernel math.vectors math.constants ; diff --git a/extra/math/ranges/ranges-tests.factor b/extra/math/ranges/ranges-tests.factor index 09416814bd..825c68d1b9 100644 --- a/extra/math/ranges/ranges-tests.factor +++ b/extra/math/ranges/ranges-tests.factor @@ -1,5 +1,5 @@ USING: math.ranges sequences tools.test arrays ; -IN: temporary +IN: math.ranges.tests [ { } ] [ 1 1 (a,b) >array ] unit-test [ { } ] [ 1 1 (a,b] >array ] unit-test diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor old mode 100644 new mode 100755 index 83a95c312d..ade3b63a5c --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -1,10 +1,6 @@ USING: kernel layouts math namespaces sequences sequences.private ; IN: math.ranges -: >integer ( n -- i ) - dup most-negative-fixnum most-positive-fixnum between? - [ >fixnum ] [ >bignum ] if ; - TUPLE: range from length step ; : ( from to step -- range ) diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index 4dba49b908..75572d8415 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.parser math.ratios math.functions tools.test ; -IN: temporary +IN: math.ratios.tests [ 1 2 ] [ 1/2 >fraction ] unit-test diff --git a/extra/math/statistics/statistics-docs.factor b/extra/math/statistics/statistics-docs.factor index 4787a85aed..695834b554 100644 --- a/extra/math/statistics/statistics-docs.factor +++ b/extra/math/statistics/statistics-docs.factor @@ -4,56 +4,56 @@ IN: math.statistics HELP: geometric-mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } -{ $examples { $example "USE: math.statistics" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } +{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ; HELP: harmonic-mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } -{ $examples { $example "USE: math.statistics" "{ 1 2 3 } harmonic-mean ." "6/11" } } +{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." } -{ $examples { $example "USE: math.statistics" "{ 1 2 3 } mean ." "2" } } +{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: median { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." } { $examples - { $example "USE: math.statistics" "{ 1 2 3 } median ." "2" } - { $example "USE: math.statistics" "{ 1 2 3 4 } median ." "5/2" } } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } median ." "2+1/2" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: range { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." } { $examples - { $example "USE: math.statistics" "{ 1 2 3 } range ." "2" } - { $example "USE: math.statistics" "{ 1 2 3 4 } range ." "3" } } ; + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } range ." "3" } } ; HELP: std { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." } { $examples - { $example "USE: math.statistics" "{ 1 2 3 } std ." "1.0" } - { $example "USE: math.statistics" "{ 1 2 3 4 } std ." "1.290994448735806" } } ; + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ; HELP: ste { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." } { $examples - { $example "USE: math.statistics" "{ -2 2 } ste ." "2.0" } - { $example "USE: math.statistics" "{ -2 2 2 } ste ." "1.333333333333333" } } ; + { $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" } + { $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ; HELP: var { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." } { $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." } { $examples - { $example "USE: math.statistics" "{ 1 } var ." "0" } - { $example "USE: math.statistics" "{ 1 2 3 } var ." "1" } - { $example "USE: math.statistics" "{ 1 2 3 4 } var ." "5/3" } } ; + { $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } var ." "1" } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } var ." "1+2/3" } } ; 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-docs.factor b/extra/math/text/english/english-docs.factor index d544f49ad8..a7fdc421aa 100644 --- a/extra/math/text/english/english-docs.factor +++ b/extra/math/text/english/english-docs.factor @@ -4,4 +4,4 @@ IN: math.text.english HELP: number>text { $values { "n" integer } { "str" string } } { $description "Converts an integer to a text string representation in English, including appropriate punctuation and conjunctions." } -{ $examples { $example "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ; +{ $examples { $example "USING: math.text.english prettyprint ;" "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ; 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-docs.factor b/extra/math/vectors/vectors-docs.factor index fe33dd65e3..140eddb2f6 100755 --- a/extra/math/vectors/vectors-docs.factor +++ b/extra/math/vectors/vectors-docs.factor @@ -69,12 +69,12 @@ HELP: v/ HELP: vmax { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } { $description "Creates a sequence where each element is the maximum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." } -{ $examples { $example "USE: math.vectors" "{ 1 2 5 } { -7 6 3 } vmax ." "{ 1 6 5 }" } } ; +{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmax ." "{ 1 6 5 }" } } ; HELP: vmin { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } { $description "Creates a sequence where each element is the minimum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." } -{ $examples { $example "USE: math.vectors" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ; +{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ; HELP: v. { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "x" "a real number" } } @@ -99,7 +99,7 @@ HELP: normalize HELP: set-axis { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "axis" "a sequence of 0/1" } { "w" "a sequence of numbers" } } { $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." } -{ $examples { $example "USE: math.vectors" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ; +{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ; { 2map v+ v- v* v/ } related-words diff --git a/extra/math/vectors/vectors-tests.factor b/extra/math/vectors/vectors-tests.factor index 924dc16c44..5c71e2374f 100644 --- a/extra/math/vectors/vectors-tests.factor +++ b/extra/math/vectors/vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.vectors.tests USING: math.vectors tools.test ; [ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test diff --git a/extra/models/models-docs.factor b/extra/models/models-docs.factor index 92ea6ced95..d514a539aa 100755 --- a/extra/models/models-docs.factor +++ b/extra/models/models-docs.factor @@ -1,4 +1,5 @@ -USING: help.syntax help.markup kernel math classes tuples ; +USING: help.syntax help.markup kernel math classes tuples +calendar ; IN: models HELP: model @@ -142,18 +143,18 @@ HELP: delay { $examples "The following code displays a sliders and a label which is updated half a second after the slider stops changing:" { $code - "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;" + "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;" ": " " 0 0 0 100 500 over set-slider-max ;" " dup gadget." - "gadget-model 500 [ number>string ] " + "gadget-model 1/2 seconds [ number>string ] " " gadget." } } ; HELP: -{ $values { "model" model } { "timeout" "a positive integer" } { "delay" delay } } -{ $description "Creates a new instance of " { $link delay } ". A timer of " { $snippet "timeout" } " milliseconds must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } +{ $values { "model" model } { "timeout" duration } { "delay" delay } } +{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } { $examples "See the example in the documentation for " { $link delay } "." } ; HELP: range-value diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor index ea615d2f9a..bd02c2f708 100755 --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: models.tests USING: arrays generic kernel math models namespaces sequences assocs tools.test ; diff --git a/extra/models/models.factor b/extra/models/models.factor index a6f1f6909a..fd84dd248f 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic kernel math sequences timers arrays assocs ; +USING: generic kernel math sequences arrays assocs alarms +calendar ; IN: models TUPLE: model value connections dependencies ref locked? ; @@ -174,7 +175,7 @@ TUPLE: history back forward ; dup history-forward delete-all dup history-back (add-history) ; -TUPLE: delay model timeout ; +TUPLE: delay model timeout alarm ; : update-delay-model ( delay -- ) dup delay-model model-value swap set-model ; @@ -185,12 +186,18 @@ TUPLE: delay model timeout ; [ set-delay-model ] 2keep [ add-dependency ] keep ; -M: delay model-changed nip 0 over delay-timeout add-timer ; +: cancel-delay ( delay -- ) + delay-alarm [ cancel-alarm ] when* ; + +: start-delay ( delay -- ) + dup [ f over set-delay-alarm update-delay-model ] curry + over delay-timeout later + swap set-delay-alarm ; + +M: delay model-changed nip dup cancel-delay start-delay ; M: delay model-activated update-delay-model ; -M: delay tick dup remove-timer update-delay-model ; - GENERIC: range-value ( model -- value ) GENERIC: range-page-value ( model -- value ) GENERIC: range-min-value ( model -- value ) diff --git a/extra/money/money-tests.factor b/extra/money/money-tests.factor index 19d6b6c2aa..b2ccdf93b7 100644 --- a/extra/money/money-tests.factor +++ b/extra/money/money-tests.factor @@ -1,5 +1,5 @@ USING: money parser tools.test ; -IN: temporary +IN: money.tests [ -1/10 ] [ DECIMAL: -.1 ] unit-test [ -1/10 ] [ DECIMAL: -0.1 ] unit-test diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor new file mode 100644 index 0000000000..c11ba23db7 --- /dev/null +++ b/extra/morse/morse-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: morse + +HELP: ch>morse +{ $values + { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } } +{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ; + +HELP: morse>ch +{ $values + { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } } +{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ; + +HELP: >morse +{ $values + { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } } +{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." } +{ $see-also morse> ch>morse } ; + +HELP: morse> +{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } } +{ $description "Translates morse code into ASCII text" } +{ $see-also >morse morse>ch } ; diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor new file mode 100644 index 0000000000..97efe1afb4 --- /dev/null +++ b/extra/morse/morse-tests.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: arrays morse strings tools.test ; + +[ "" ] [ CHAR: \\ ch>morse ] unit-test +[ "..." ] [ CHAR: s ch>morse ] unit-test +[ CHAR: s ] [ "..." morse>ch ] unit-test +[ f ] [ "..--..--.." morse>ch ] unit-test +[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test +[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test +[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor new file mode 100644 index 0000000000..f493951ed5 --- /dev/null +++ b/extra/morse/morse.factor @@ -0,0 +1,125 @@ +! Copyright (C) 2007 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: assocs hashtables kernel lazy-lists namespaces openal +parser-combinators promises sequences strings unicode.case ; +IN: morse + +morse-assoc ( -- assoc ) + morse-codes >hashtable ; + +: morse>ch-assoc ( -- assoc ) + morse-codes [ reverse ] map >hashtable ; + +PRIVATE> + +: ch>morse ( ch -- str ) + ch>lower ch>morse-assoc at* swap "" ? ; + +: morse>ch ( str -- ch ) + morse>ch-assoc at* swap f ? ; + +: >morse ( str -- str ) + [ + [ CHAR: \s , ] [ ch>morse % ] interleave + ] "" make ; + + <+> ; + +LAZY: 'morse-word' ( -- parser ) + 'morse-char' 'char-gap' list-of ; + +LAZY: 'morse-words' ( -- parser ) + 'morse-word' 'word-gap' list-of ; + +PRIVATE> + +: morse> ( str -- str ) + 'morse-words' parse car parse-result-parsed [ + [ + >string morse>ch + ] map >string + ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ; + diff --git a/extra/msxml-to-csv/msxml-to-csv.factor b/extra/msxml-to-csv/msxml-to-csv.factor index 8a9ba9cf98..839fcaaf54 100644 --- a/extra/msxml-to-csv/msxml-to-csv.factor +++ b/extra/msxml-to-csv/msxml-to-csv.factor @@ -1,8 +1,7 @@ -USING: io io.files sequences xml xml.utilities ; +USING: io io.files sequences xml xml.utilities +io.encodings.ascii kernel ; IN: msxml-to-csv -: print-csv ( table -- ) [ "," join print ] each ; - : (msxml>csv) ( xml -- table ) "Worksheet" tag-named "Table" tag-named @@ -12,7 +11,6 @@ IN: msxml-to-csv ] map ] map ; -: msxml>csv ( infile outfile -- ) - [ - file>xml (msxml>csv) print-csv - ] with-file-writer ; +: msxml>csv ( outfile infile -- ) + file>xml (msxml>csv) [ "," join ] map + swap ascii set-file-lines ; 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/multiline/multiline-tests.factor b/extra/multiline/multiline-tests.factor old mode 100644 new mode 100755 index a9b9ee2322..c323e9b96a --- a/extra/multiline/multiline-tests.factor +++ b/extra/multiline/multiline-tests.factor @@ -1,4 +1,5 @@ USING: multiline tools.test ; +IN: multiline.tests STRING: test-it foo diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor index d32c11dd06..5baa205d15 100755 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -38,3 +38,5 @@ IN: multiline : <" "\">" parse-multiline-string parsed ; parsing + +: /* "*/" parse-multiline-string drop ; parsing diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 528e770558..76ba0ac63e 100644 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -2,7 +2,7 @@ ! USING: kernel quotations namespaces sequences assocs.lib ; USING: kernel namespaces namespaces.private quotations sequences - assocs.lib ; + assocs.lib math.parser math sequences.lib ; IN: namespaces.lib @@ -17,3 +17,36 @@ IN: namespaces.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : set* ( val var -- ) namestack* set-assoc-stack ; + +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# ; +: 3, 3 n, ; +: 3% 3 n% ; +: 3# 3 n# ; +: 4, 4 n, ; +: 4% 4 n% ; +: 4# 4 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 ; diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor index 4edd4239fa..3273036b8b 100755 --- a/extra/new-slots/new-slots.factor +++ b/extra/new-slots/new-slots.factor @@ -34,7 +34,7 @@ IN: new-slots [ \ over , swap writer-word , ] [ ] make define-inline ] [ 2drop ] if ; -: changer-effect T{ effect f { "object" "quot" } } ; inline +: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline : changer-word ( name -- word ) "change-" swap append changer-effect create-accessor ; @@ -44,9 +44,9 @@ IN: new-slots [ [ over >r >r ] % over reader-word , - [ r> call r> ] % - swap writer-word , - ] [ ] make define + [ r> call r> swap ] % + swap setter-word , + ] [ ] make define-inline ] [ 2drop ] if ; : define-new-slot ( class slot name -- ) diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor old mode 100644 new mode 100755 index 518030ee4d..2a685eccd1 --- a/extra/ogg/player/player.factor +++ b/extra/ogg/player/player.factor @@ -14,7 +14,8 @@ 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 + io.encodings.binary debugger ; IN: ogg.player @@ -149,7 +150,7 @@ HINTS: yuv>rgb byte-array byte-array ; dup player-gadget [ dup { player-td player-yuv } get-slots theora_decode_YUVout drop dup player-rgb over player-yuv yuv>rgb - dup player-gadget find-world dup draw-world + dup player-gadget relayout-1 yield ] when ; : num-audio-buffers-processed ( player -- player n ) @@ -177,7 +178,7 @@ HINTS: yuv>rgb byte-array byte-array ; : append-audio ( player -- player bool ) num-audio-buffers-processed { { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] } - { [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] } + { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] } { [ t ] [ fill-processed-audio-buffer t ] } } cond ; @@ -602,8 +603,7 @@ M: theora-gadget draw-gadget* ( gadget -- ) parse-remaining-headers initialize-decoder dup player-gadget [ initialize-gui ] when* - [ decode ] [ drop ] recover -! decode + [ decode ] try wait-for-sound cleanup drop ; @@ -612,7 +612,7 @@ M: theora-gadget draw-gadget* ( gadget -- ) play-ogg ; : play-vorbis-file ( filename -- ) - play-vorbis-stream ; + binary play-vorbis-stream ; : play-theora-stream ( stream -- ) @@ -620,5 +620,5 @@ M: theora-gadget draw-gadget* ( gadget -- ) play-ogg ; : play-theora-file ( filename -- ) - play-theora-stream ; + binary play-theora-stream ; diff --git a/extra/opengl/capabilities/capabilities-docs.factor b/extra/opengl/capabilities/capabilities-docs.factor index e73b7a3f0b..f5424e19da 100644 --- a/extra/opengl/capabilities/capabilities-docs.factor +++ b/extra/opengl/capabilities/capabilities-docs.factor @@ -43,7 +43,7 @@ HELP: has-gl-extensions? { $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ; HELP: has-gl-version-or-extensions? -{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } } { $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; HELP: require-gl-extensions 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/opengl/shaders/shaders-docs.factor b/extra/opengl/shaders/shaders-docs.factor index e065367323..93251627f4 100644 --- a/extra/opengl/shaders/shaders-docs.factor +++ b/extra/opengl/shaders/shaders-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io kernel math quotations -opengl.gl multiline assocs ; +opengl.gl multiline assocs strings ; IN: opengl.shaders HELP: gl-shader @@ -28,19 +28,19 @@ HELP: fragment-shader } ; HELP: -{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } } +{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } { "shader" "a new " { $link gl-shader } } } { $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ; HELP: -{ $values { "source" "The GLSL source code to compile" } } +{ $values { "source" "The GLSL source code to compile" } { "vertex-shader" "a new " { $link vertex-shader } } } { $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER " } "." } ; HELP: -{ $values { "source" "The GLSL source code to compile" } } +{ $values { "source" "The GLSL source code to compile" } { "fragment-shader" "a new " { $link fragment-shader } } } { $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER " } "." } ; HELP: gl-shader-ok? -{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $values { "shader" "A " { $link gl-shader } " object" } { "?" "a boolean" } } { $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ; HELP: check-gl-shader @@ -52,7 +52,7 @@ HELP: delete-gl-shader { $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ; HELP: gl-shader-info-log -{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } } { $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ; HELP: gl-program @@ -69,17 +69,17 @@ HELP: gl-program } ; HELP: -{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } } +{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } { "program" "a new " { $link gl-program } } } { $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ; HELP: -{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } } +{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } { "program" "a new " { $link gl-program } } } { $description "Wrapper for " { $link } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ; { } related-words HELP: gl-program-ok? -{ $values { "program" "A " { $link gl-program } " object" } } +{ $values { "program" "A " { $link gl-program } " object" } { "?" "a boolean" } } { $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ; HELP: check-gl-program @@ -87,7 +87,7 @@ HELP: check-gl-program { $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ; HELP: gl-program-info-log -{ $values { "program" "A " { $link gl-program } " object" } } +{ $values { "program" "A " { $link gl-program } " object" } { "log" string } } { $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ; HELP: delete-gl-program diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor index 6033933146..c8186e55c3 100755 --- a/extra/opengl/shaders/shaders.factor +++ b/extra/opengl/shaders/shaders.factor @@ -50,7 +50,7 @@ IN: opengl.shaders alien>char-string ] with-malloc ; -: check-gl-shader ( shader -- shader* ) +: check-gl-shader ( shader -- shader ) dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ; : delete-gl-shader ( shader -- ) glDeleteShader ; inline @@ -85,7 +85,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ; alien>char-string ] with-malloc ; -: check-gl-program ( program -- program* ) +: check-gl-program ( program -- program ) dup gl-program-ok? [ dup gl-program-info-log throw ] unless ; : gl-program-shaders-length ( program -- shaders-length ) diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 29016f6d57..8d1b3b5247 100644 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libssl -"libssl" { +<< "libssl" { { [ win32? ] [ "ssleay32.dll" "stdcall" ] } { [ macosx? ] [ "libssl.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] } -} cond add-library +} cond add-library >> : X509_FILETYPE_PEM 1 ; inline : X509_FILETYPE_ASN1 2 ; inline diff --git a/extra/oracle/oracle-tests.factor b/extra/oracle/oracle-tests.factor old mode 100644 new mode 100755 index 5756578d92..2f957ac4a9 --- a/extra/oracle/oracle-tests.factor +++ b/extra/oracle/oracle-tests.factor @@ -1,57 +1,60 @@ -USING: oracle oracle.liboci prettyprint tools.test ; +USING: oracle oracle.liboci prettyprint tools.test +kernel ; -"testuser" "testpassword" "//localhost/test1" log-on . +[ + "testuser" "testpassword" "//localhost/test1" log-on . -allocate-statement-handle + allocate-statement-handle -"CREATE TABLE TESTTABLE ( COL1 VARCHAR(40), COL2 NUMBER)" prepare-statement + "CREATE TABLE TESTTABLE ( COL1 VARCHAR(40), COL2 NUMBER)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hello', 50)" prepare-statement + "INSERT INTO TESTTABLE (COL1, COL2) VALUES('hello', 50)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hi', 60)" prepare-statement + "INSERT INTO TESTTABLE (COL1, COL2) VALUES('hi', 60)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"INSERT INTO TESTTABLE (COL1, COL2) VALUES('bye', 70)" prepare-statement + "INSERT INTO TESTTABLE (COL1, COL2) VALUES('bye', 70)" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"COMMIT" prepare-statement + "COMMIT" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"SELECT * FROM TESTTABLE" prepare-statement + "SELECT * FROM TESTTABLE" prepare-statement -1 SQLT_STR define-by-position run-query + 1 SQLT_STR define-by-position run-query -[ V{ "hello" "hi" "bye" "50" "60" "70" } ] [ -2 SQLT_STR define-by-position run-query gather-results -] unit-test + [ V{ "hello" "hi" "bye" "50" "60" "70" } ] [ + 2 SQLT_STR define-by-position run-query gather-results + ] unit-test -clear-result + clear-result -"UPDATE TESTTABLE SET COL2 = 10 WHERE COL1='hi'" prepare-statement + "UPDATE TESTTABLE SET COL2 = 10 WHERE COL1='hi'" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"COMMIT" prepare-statement + "COMMIT" prepare-statement -[ t ] [ execute-statement ] unit-test + [ t ] [ execute-statement ] unit-test -"SELECT * FROM TESTTABLE WHERE COL1 = 'hi'" prepare-statement + "SELECT * FROM TESTTABLE WHERE COL1 = 'hi'" prepare-statement -[ V{ "10" } ] [ -2 SQLT_STR define-by-position run-query gather-results -] unit-test + [ V{ "10" } ] [ + 2 SQLT_STR define-by-position run-query gather-results + ] unit-test -clear-result + clear-result -"DROP TABLE TESTTABLE" prepare-statement + "DROP TABLE TESTTABLE" prepare-statement -execute-statement + execute-statement -free-statement-handle log-off clean-up terminate + free-statement-handle log-off clean-up terminate +] drop diff --git a/extra/parser-combinators/parser-combinators-docs.factor b/extra/parser-combinators/parser-combinators-docs.factor index 774069d5a5..41171ce822 100755 --- a/extra/parser-combinators/parser-combinators-docs.factor +++ b/extra/parser-combinators/parser-combinators-docs.factor @@ -12,7 +12,7 @@ HELP: list-of "'items' is a parser that can parse the individual elements. 'separator' " "is a parser for the symbol that separatest them. The result tree of " "the resulting parser is an array of the parsed elements." } -{ $example "USE: parser-combinators" "\"1,2,3,4\" 'integer' \",\" token list-of parse-1 ." "{ 1 2 3 4 }" } +{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' \",\" token list-of parse-1 ." "{ 1 2 3 4 }" } { $see-also list-of } ; HELP: any-char-parser @@ -23,4 +23,4 @@ HELP: any-char-parser "from the input string. The value consumed is the " "result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"foo\" any-char-parser parse-1 ." "102" } } ; +{ $example "USING: lazy-lists parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ; diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor old mode 100644 new mode 100755 index a1f82391a0..2dd3fd911c --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel lazy-lists tools.test strings math sequences parser-combinators arrays math.parser unicode.categories ; -IN: scratchpad +IN: parser-combinators.tests ! Testing <&> { { T{ parse-result f { "a" "b" } T{ slice f 2 4 "abcd" } } } } [ diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index cdf89e1f37..bf06708e09 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: lazy-lists promises kernel sequences strings math arrays splitting quotations combinators namespaces -unicode.case unicode.categories ; +unicode.case unicode.categories sequences.deep ; IN: parser-combinators ! Parser combinator protocol @@ -329,11 +329,6 @@ LAZY: <(+)> ( parser -- parser ) LAZY: surrounded-by ( parser start end -- parser' ) [ token ] 2apply swapd pack ; -: flatten* ( obj -- ) - dup array? [ [ flatten* ] each ] [ , ] if ; - -: flatten [ flatten* ] { } make ; - : exactly-n ( parser n -- parser' ) swap [ flatten ] <@ ; diff --git a/extra/parser-combinators/simple/simple-docs.factor b/extra/parser-combinators/simple/simple-docs.factor index bba37ca4ca..78b731f5b0 100755 --- a/extra/parser-combinators/simple/simple-docs.factor +++ b/extra/parser-combinators/simple/simple-docs.factor @@ -11,7 +11,7 @@ HELP: 'digit' "the input string. The numeric value of the digit " " consumed is the result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse-1 ." "1" } } ; +{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ; HELP: 'integer' { $values @@ -21,7 +21,7 @@ HELP: 'integer' "the input string. The numeric value of the integer " " consumed is the result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse-1 ." "123" } } ; +{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ; HELP: 'string' { $values { "parser" "a parser object" } } @@ -30,7 +30,8 @@ HELP: 'string' "quotations from the input string. The string value " " consumed is the result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ; +{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ; + HELP: 'bold' { $values { "parser" "a parser object" } } @@ -39,8 +40,9 @@ HELP: 'bold' "the '*' character from the input string. This is " "commonly used in markup languages to indicate bold " "faced text." } -{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" } -{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } ; +{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" } +{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } ; + HELP: 'italic' { $values { "parser" "a parser object" } } @@ -50,8 +52,8 @@ HELP: 'italic' "commonly used in markup languages to indicate italic " "faced text." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" } -{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } } ; +{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" } +{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } } ; HELP: comma-list { $values { "element" "a parser object" } { "parser" "a parser object" } } @@ -60,6 +62,6 @@ HELP: comma-list "'element' should be a parser that can parse the elements. The " "result of the parser is a sequence of the parsed elements." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ; +{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ; { $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words diff --git a/extra/partial-apply/partial-apply.factor b/extra/partial-apply/partial-apply.factor deleted file mode 100644 index 0340e53025..0000000000 --- a/extra/partial-apply/partial-apply.factor +++ /dev/null @@ -1,26 +0,0 @@ - -USING: kernel sequences quotations math parser - shuffle combinators.cleave combinators.lib sequences.lib ; - -IN: partial-apply - -! Basic conceptual implementation. Todo: get it to compile. - -: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ; - -SYMBOL: _ - -SYMBOL: ~ - -: blank-positions ( quot -- seq ) - [ length 2 - ] [ _ indices ] bi [ - ] map-with ; - -: partial-apply ( pattern -- quot ) - [ blank-positions length nrev ] - [ peek 1quotation ] - [ blank-positions ] - tri - [ apply-n ] each ; - -: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing - diff --git a/extra/partial-continuations/partial-continuations-tests.factor b/extra/partial-continuations/partial-continuations-tests.factor index 56dc6bcd87..7e876b0934 100644 --- a/extra/partial-continuations/partial-continuations-tests.factor +++ b/extra/partial-continuations/partial-continuations-tests.factor @@ -1,6 +1,6 @@ USING: namespaces math partial-continuations tools.test kernel sequences ; -IN: temporary +IN: partial-continuations.tests SYMBOL: sum diff --git a/extra/pdf/libhpdf/libhpdf.factor b/extra/pdf/libhpdf/libhpdf.factor index 85ccc70c25..a40b7cddee 100644 --- a/extra/pdf/libhpdf/libhpdf.factor +++ b/extra/pdf/libhpdf/libhpdf.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators system ; IN: pdf.libhpdf -"libhpdf" { +<< "libhpdf" { { [ win32? ] [ "libhpdf.dll" "stdcall" ] } { [ macosx? ] [ "libhpdf.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] } -} cond add-library +} cond add-library >> ! compression mode : HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed diff --git a/extra/pdf/pdf-tests.factor b/extra/pdf/pdf-tests.factor old mode 100644 new mode 100755 index dc42874d2a..290773a89d --- a/extra/pdf/pdf-tests.factor +++ b/extra/pdf/pdf-tests.factor @@ -1,4 +1,5 @@ USING: io.files kernel math namespaces pdf pdf.libhpdf prettyprint sequences ; +IN: pdf.tests SYMBOL: font @@ -92,6 +93,6 @@ SYMBOL: twidth ] with-text - "extra/pdf/test/font_test.pdf" resource-path save-to-file + "font_test.pdf" temp-file save-to-file ] with-pdf diff --git a/extra/pdf/test/font_test.pdf b/extra/pdf/test/font_test.pdf deleted file mode 100644 index 4360cf349f..0000000000 --- a/extra/pdf/test/font_test.pdf +++ /dev/null @@ -1,300 +0,0 @@ -%PDF-1.3 -%·¾­ª -1 0 obj -<< -/Type /Catalog -/Pages 2 0 R ->> -endobj -2 0 obj -<< -/Type /Pages -/Kids [ 4 0 R ] -/Count 1 ->> -endobj -3 0 obj -<< -/Producer (Haru\040Free\040PDF\040Library\0402.0.8) ->> -endobj -4 0 obj -<< -/Type /Page -/MediaBox [ 0 0 595 841 ] -/Contents 5 0 R -/Resources << -/ProcSet [ /PDF /Text /ImageB /ImageC /ImageI ] -/Font << -/F1 7 0 R -/F2 8 0 R -/F3 9 0 R -/F4 10 0 R -/F5 11 0 R -/F6 12 0 R -/F7 13 0 R -/F8 14 0 R -/F9 15 0 R -/F10 16 0 R -/F11 17 0 R -/F12 18 0 R -/F13 19 0 R -/F14 20 0 R ->> ->> -/Parent 2 0 R ->> -endobj -5 0 obj -<< -/Length 6 0 R ->> -stream -1 w -50 50 495 731 re -S -/F1 24 Tf -BT -238.148 791 Td -(Font\040Demo) Tj -ET -BT -/F1 16 Tf -60 761 Td -(\074Standard\040Type1\040font\040samples\076) Tj -ET -BT -60 736 Td -/F2 9 Tf -(Courier) Tj -0 -18 Td -/F2 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F3 9 Tf -(Courier-Bold) Tj -0 -18 Td -/F3 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F4 9 Tf -(Courier-Oblique) Tj -0 -18 Td -/F4 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F5 9 Tf -(Courier-BoldOblique) Tj -0 -18 Td -/F5 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F1 9 Tf -(Helvetica) Tj -0 -18 Td -/F1 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F6 9 Tf -(Helvetica-Bold) Tj -0 -18 Td -/F6 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F7 9 Tf -(Helvetica-Oblique) Tj -0 -18 Td -/F7 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F8 9 Tf -(Helvetica-BoldOblique) Tj -0 -18 Td -/F8 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F9 9 Tf -(Times-Roman) Tj -0 -18 Td -/F9 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F10 9 Tf -(Times-Bold) Tj -0 -18 Td -/F10 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F11 9 Tf -(Times-Italic) Tj -0 -18 Td -/F11 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F12 9 Tf -(Times-BoldItalic) Tj -0 -18 Td -/F12 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F13 9 Tf -(Symbol) Tj -0 -18 Td -/F13 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F14 9 Tf -(ZapfDingbats) Tj -0 -18 Td -/F14 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -ET - -endstream -endobj -6 0 obj -1517 -endobj -7 0 obj -<< -/Type /Font -/BaseFont /Helvetica -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -8 0 obj -<< -/Type /Font -/BaseFont /Courier -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -9 0 obj -<< -/Type /Font -/BaseFont /Courier-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -10 0 obj -<< -/Type /Font -/BaseFont /Courier-Oblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -11 0 obj -<< -/Type /Font -/BaseFont /Courier-BoldOblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -12 0 obj -<< -/Type /Font -/BaseFont /Helvetica-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -13 0 obj -<< -/Type /Font -/BaseFont /Helvetica-Oblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -14 0 obj -<< -/Type /Font -/BaseFont /Helvetica-BoldOblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -15 0 obj -<< -/Type /Font -/BaseFont /Times-Roman -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -16 0 obj -<< -/Type /Font -/BaseFont /Times-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -17 0 obj -<< -/Type /Font -/BaseFont /Times-Italic -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -18 0 obj -<< -/Type /Font -/BaseFont /Times-BoldItalic -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -19 0 obj -<< -/Type /Font -/BaseFont /Symbol -/Subtype /Type1 ->> -endobj -20 0 obj -<< -/Type /Font -/BaseFont /ZapfDingbats -/Subtype /Type1 ->> -endobj -xref -0 21 -0000000000 65535 f -0000000015 00000 n -0000000064 00000 n -0000000123 00000 n -0000000196 00000 n -0000000518 00000 n -0000002089 00000 n -0000002109 00000 n -0000002207 00000 n -0000002303 00000 n -0000002404 00000 n -0000002509 00000 n -0000002618 00000 n -0000002722 00000 n -0000002829 00000 n -0000002940 00000 n -0000003041 00000 n -0000003141 00000 n -0000003243 00000 n -0000003349 00000 n -0000003417 00000 n -trailer -<< -/Root 1 0 R -/Info 3 0 R -/Size 21 ->> -startxref -3491 -%%EOF 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..1991cba0eb --- /dev/null +++ b/extra/peg/parsers/parsers-docs.factor @@ -0,0 +1,161 @@ +! Copyright (C) 2008 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax peg peg.parsers.private +unicode.categories ; +IN: peg.parsers + +HELP: 1token +{ $values + { "ch" "a character" } + { "parser" "a parser" } +} { $description + "Calls 1string on a character and returns a parser that matches that character." +} { $examples + { $example "USING: peg peg.parsers prettyprint ;" "\"a\" CHAR: a 1token parse parse-result-ast ." "\"a\"" } +} { $see-also 'string' } ; + +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" } + { "parser" "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 "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"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" } + { "parser" "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 "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of-many parse ." "f" } + { $example "USING: peg peg.parsers prettyprint ;" "\"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 "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 exactly-n parse ." "f" } + { $example "USING: peg peg.parsers prettyprint ;" "\"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 "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 at-least-n parse ." "f" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"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 "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"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 "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"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 "USING: peg peg.parsers prettyprint ;" "\"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 "USING: peg peg.parsers prettyprint ;" "\"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..87306e1469 --- /dev/null +++ b/extra/peg/parsers/parsers.factor @@ -0,0 +1,85 @@ +! 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 ; + +MEMO: 1token ( ch -- parser ) 1string token ; + +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-docs.factor b/extra/peg/peg-docs.factor index 6dff95c829..9ad375ea04 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -135,9 +135,10 @@ HELP: hide HELP: delay { $values + { "quot" "a quotation" } { "parser" "a parser" } } { $description "Delays the construction of a parser until it is actually required to parse. This " "allows for calling a parser that results in a recursive call to itself. The quotation " - "should return the constructed parser." } ; \ No newline at end of file + "should return the constructed parser." } ; 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..16cf40f884 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 ; @@ -333,21 +358,14 @@ MEMO: sp ( parser -- parser ) MEMO: hide ( parser -- parser ) [ drop ignore ] action ; -MEMO: delay ( parser -- parser ) +MEMO: delay ( quot -- 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-docs.factor b/extra/peg/search/search-docs.factor index fc1e618b9b..565601ea11 100755 --- a/extra/peg/search/search-docs.factor +++ b/extra/peg/search/search-docs.factor @@ -10,7 +10,7 @@ HELP: tree-write "Write the object to the standard output stream, unless " "it is an array, in which case recurse through the array " "writing each object to the stream." } -{ $example "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; +{ $example "USE: peg.search" "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; HELP: search { $values @@ -24,8 +24,8 @@ HELP: search "parser." } -{ $example "\"one 123 two 456\" 'integer' search" "V{ 123 456 }" } -{ $example "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array choice search" "V{ 123 \"hello\" 456 }" } +{ $example "USING: peg.parsers peg.search prettyprint ;" "\"one 123 two 456\" 'integer' search ." "V{ 123 456 }" } +{ $example "USING: peg peg.parsers peg.search prettyprint ;" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2choice search ." "V{ 123 \"hello\" 456 }" } { $see-also replace } ; HELP: replace @@ -39,6 +39,6 @@ HELP: replace "successfully parse with the given parser replaced with " "the result of that parser." } -{ $example "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace" "\"one 246 two 912\"" } +{ $example "USING: math math.parser peg peg.parsers peg.search prettyprint ;" "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace ." "\"one 246 two 912\"" } { $see-also search } ; diff --git a/extra/peg/search/search-tests.factor b/extra/peg/search/search-tests.factor index b33161dfff..b22a5ef0d0 100755 --- a/extra/peg/search/search-tests.factor +++ b/extra/peg/search/search-tests.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel math math.parser arrays tools.test peg peg.search ; -IN: temporary +USING: kernel math math.parser arrays tools.test peg peg.parsers +peg.search ; +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..da0658f94d 100644 --- a/extra/porter-stemmer/porter-stemmer-tests.factor +++ b/extra/porter-stemmer/porter-stemmer-tests.factor @@ -1,6 +1,6 @@ -IN: temporary +IN: porter-stemmer.tests USING: arrays io kernel porter-stemmer sequences tools.test -io.files ; +io.files io.encodings.utf8 ; [ 0 ] [ "xa" consonant-seq ] unit-test [ 0 ] [ "xxaa" consonant-seq ] unit-test @@ -56,7 +56,7 @@ io.files ; [ "hell" ] [ "hell" step5 "" like ] unit-test [ "mate" ] [ "mate" step5 "" like ] unit-test -: resource-lines resource-path file-lines ; +: resource-lines resource-path utf8 file-lines ; [ { } ] [ "extra/porter-stemmer/test/voc.txt" resource-lines 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/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 5bd1797272..c0a48ec055 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: ascii io.files kernel math project-euler.common sequences sorting splitting ; +USING: ascii io.encodings.ascii io.files kernel math project-euler.common + sequences sequences.lib sorting splitting ; IN: project-euler.022 ! http://projecteuler.net/index.php?section=problems&id=22 @@ -28,10 +29,10 @@ IN: project-euler.022 : source-022 ( -- seq ) "extra/project-euler/022/names.txt" resource-path - file-contents [ quotable? ] subset "," split ; + ascii file-contents [ quotable? ] subset "," split ; : name-scores ( seq -- seq ) - dup length [ 1+ swap alpha-value * ] 2map ; + [ 1+ swap alpha-value * ] map-index ; PRIVATE> diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor index c66be27df7..a87722debc 100644 --- a/extra/project-euler/042/042.factor +++ b/extra/project-euler/042/042.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: ascii io.files kernel math math.functions namespaces - project-euler.common sequences sequences.lib splitting ; + project-euler.common sequences sequences.lib splitting io.encodings.ascii ; IN: project-euler.042 ! http://projecteuler.net/index.php?section=problems&id=42 @@ -31,7 +31,7 @@ IN: project-euler.042 : source-042 ( -- seq ) "extra/project-euler/042/words.txt" resource-path - file-contents [ quotable? ] subset "," split ; + ascii file-contents [ quotable? ] subset "," split ; : (triangle-upto) ( limit n -- ) 2dup nth-triangle > [ diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor new file mode 100644 index 0000000000..98e819a7db --- /dev/null +++ b/extra/project-euler/047/047.factor @@ -0,0 +1,96 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib kernel math math.primes math.primes.factors + math.ranges namespaces sequences ; +IN: project-euler.047 + +! http://projecteuler.net/index.php?section=problems&id=47 + +! DESCRIPTION +! ----------- + +! The first two consecutive numbers to have two distinct prime factors are: + +! 14 = 2 * 7 +! 15 = 3 * 5 + +! The first three consecutive numbers to have three distinct prime factors are: + +! 644 = 2² * 7 * 23 +! 645 = 3 * 5 * 43 +! 646 = 2 * 17 * 19. + +! Find the first four consecutive integers to have four distinct primes +! factors. What is the first of these numbers? + + +! SOLUTION +! -------- + +! Brute force, not sure why it's incredibly slow compared to other languages + + + +: euler047 ( -- answer ) + 4 646 consecutive ; + +! [ euler047 ] time +! 542708 ms run / 60548 ms GC time + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Use a sieve to generate prime factor counts up to an arbitrary limit, then +! look for a repetition of the specified number of factors. + + >array sieve set ; + +: is-prime? ( index -- ? ) + sieve get nth zero? ; + +: multiples ( n -- seq ) + sieve get length 1- over ; + +: increment-counts ( n -- ) + multiples [ sieve get [ 1+ ] change-nth ] each ; + +: prime-tau-upto ( limit -- seq ) + dup initialize-sieve 2 swap [a,b) [ + dup is-prime? [ increment-counts ] [ drop ] if + ] each sieve get ; + +: consecutive-under ( m limit -- n/f ) + prime-tau-upto [ dup ] dip start ; + +PRIVATE> + +: euler047a ( -- answer ) + 4 200000 consecutive-under ; + +! [ euler047a ] 100 ave-time +! 503 ms run / 5 ms GC ave time - 100 trials + +! TODO: I don't like that you have to specify the upper bound, maybe try making +! this lazy so it could also short-circuit when it finds the answer? + +MAIN: euler047a diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor new file mode 100644 index 0000000000..1c20d1ab34 --- /dev/null +++ b/extra/project-euler/059/059.factor @@ -0,0 +1,92 @@ +! Copyright (c) 2008 Aaron Schaefer, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math + math.parser namespaces sequences sequences.lib sequences.private sorting + splitting strings ; +IN: project-euler.059 + +! http://projecteuler.net/index.php?section=problems&id=59 + +! DESCRIPTION +! ----------- + +! Each character on a computer is assigned a unique code and the preferred +! standard is ASCII (American Standard Code for Information Interchange). For +! example, uppercase A = 65, asterisk (*) = 42, and lowercase k = 107. + +! A modern encryption method is to take a text file, convert the bytes to +! ASCII, then XOR each byte with a given value, taken from a secret key. The +! advantage with the XOR function is that using the same encryption key on the +! cipher text, restores the plain text; for example, 65 XOR 42 = 107, then 107 +! XOR 42 = 65. + +! For unbreakable encryption, the key is the same length as the plain text +! message, and the key is made up of random bytes. The user would keep the +! encrypted message and the encryption key in different locations, and without +! both "halves", it is impossible to decrypt the message. + +! Unfortunately, this method is impractical for most users, so the modified +! method is to use a password as a key. If the password is shorter than the +! message, which is likely, the key is repeated cyclically throughout the +! message. The balance for this method is using a sufficiently long password +! key for security, but short enough to be memorable. + +! Your task has been made easy, as the encryption key consists of three lower +! case characters. Using cipher1.txt (right click and 'Save Link/Target +! As...'), a file containing the encrypted ASCII codes, and the knowledge that +! the plain text must contain common English words, decrypt the message and +! find the sum of the ASCII values in the original text. + + +! SOLUTION +! -------- + +! Assume that the space character will be the most common, so XOR the input +! text with a space character then group the text into three "columns" since +! that's how long our key is. Then do frequency analysis on each column to +! find out what the most likely candidate is for the key. + +! NOTE: This technique would probably not work well in all cases, but luckily +! it did for this particular problem. + +number ] map ; + +TUPLE: rollover seq n ; + +C: rollover + +M: rollover length rollover-n ; + +M: rollover nth-unsafe rollover-seq [ length mod ] keep nth-unsafe ; + +INSTANCE: rollover immutable-sequence + +: decrypt ( seq key -- seq ) + over length swap [ bitxor ] 2map ; + +: frequency-analysis ( seq -- seq ) + dup prune [ + [ 2dup [ = ] curry count 2array , ] each + ] { } make nip ; inline + +: most-frequent ( seq -- elt ) + frequency-analysis sort-values keys peek ; + +: crack-key ( seq key-length -- key ) + [ " " decrypt ] dip group 1 head-slice* + flip [ most-frequent ] map ; + +PRIVATE> + +: euler059 ( -- answer ) + source-059 dup 3 crack-key decrypt sum ; + +! [ euler059 ] 100 ave-time +! 13 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler059 diff --git a/extra/project-euler/059/cipher1.txt b/extra/project-euler/059/cipher1.txt new file mode 100644 index 0000000000..08cee2dba4 --- /dev/null +++ b/extra/project-euler/059/cipher1.txt @@ -0,0 +1 @@ +79,59,12,2,79,35,8,28,20,2,3,68,8,9,68,45,0,12,9,67,68,4,7,5,23,27,1,21,79,85,78,79,85,71,38,10,71,27,12,2,79,6,2,8,13,9,1,13,9,8,68,19,7,1,71,56,11,21,11,68,6,3,22,2,14,0,30,79,1,31,6,23,19,10,0,73,79,44,2,79,19,6,28,68,16,6,16,15,79,35,8,11,72,71,14,10,3,79,12,2,79,19,6,28,68,32,0,0,73,79,86,71,39,1,71,24,5,20,79,13,9,79,16,15,10,68,5,10,3,14,1,10,14,1,3,71,24,13,19,7,68,32,0,0,73,79,87,71,39,1,71,12,22,2,14,16,2,11,68,2,25,1,21,22,16,15,6,10,0,79,16,15,10,22,2,79,13,20,65,68,41,0,16,15,6,10,0,79,1,31,6,23,19,28,68,19,7,5,19,79,12,2,79,0,14,11,10,64,27,68,10,14,15,2,65,68,83,79,40,14,9,1,71,6,16,20,10,8,1,79,19,6,28,68,14,1,68,15,6,9,75,79,5,9,11,68,19,7,13,20,79,8,14,9,1,71,8,13,17,10,23,71,3,13,0,7,16,71,27,11,71,10,18,2,29,29,8,1,1,73,79,81,71,59,12,2,79,8,14,8,12,19,79,23,15,6,10,2,28,68,19,7,22,8,26,3,15,79,16,15,10,68,3,14,22,12,1,1,20,28,72,71,14,10,3,79,16,15,10,68,3,14,22,12,1,1,20,28,68,4,14,10,71,1,1,17,10,22,71,10,28,19,6,10,0,26,13,20,7,68,14,27,74,71,89,68,32,0,0,71,28,1,9,27,68,45,0,12,9,79,16,15,10,68,37,14,20,19,6,23,19,79,83,71,27,11,71,27,1,11,3,68,2,25,1,21,22,11,9,10,68,6,13,11,18,27,68,19,7,1,71,3,13,0,7,16,71,28,11,71,27,12,6,27,68,2,25,1,21,22,11,9,10,68,10,6,3,15,27,68,5,10,8,14,10,18,2,79,6,2,12,5,18,28,1,71,0,2,71,7,13,20,79,16,2,28,16,14,2,11,9,22,74,71,87,68,45,0,12,9,79,12,14,2,23,2,3,2,71,24,5,20,79,10,8,27,68,19,7,1,71,3,13,0,7,16,92,79,12,2,79,19,6,28,68,8,1,8,30,79,5,71,24,13,19,1,1,20,28,68,19,0,68,19,7,1,71,3,13,0,7,16,73,79,93,71,59,12,2,79,11,9,10,68,16,7,11,71,6,23,71,27,12,2,79,16,21,26,1,71,3,13,0,7,16,75,79,19,15,0,68,0,6,18,2,28,68,11,6,3,15,27,68,19,0,68,2,25,1,21,22,11,9,10,72,71,24,5,20,79,3,8,6,10,0,79,16,8,79,7,8,2,1,71,6,10,19,0,68,19,7,1,71,24,11,21,3,0,73,79,85,87,79,38,18,27,68,6,3,16,15,0,17,0,7,68,19,7,1,71,24,11,21,3,0,71,24,5,20,79,9,6,11,1,71,27,12,21,0,17,0,7,68,15,6,9,75,79,16,15,10,68,16,0,22,11,11,68,3,6,0,9,72,16,71,29,1,4,0,3,9,6,30,2,79,12,14,2,68,16,7,1,9,79,12,2,79,7,6,2,1,73,79,85,86,79,33,17,10,10,71,6,10,71,7,13,20,79,11,16,1,68,11,14,10,3,79,5,9,11,68,6,2,11,9,8,68,15,6,23,71,0,19,9,79,20,2,0,20,11,10,72,71,7,1,71,24,5,20,79,10,8,27,68,6,12,7,2,31,16,2,11,74,71,94,86,71,45,17,19,79,16,8,79,5,11,3,68,16,7,11,71,13,1,11,6,1,17,10,0,71,7,13,10,79,5,9,11,68,6,12,7,2,31,16,2,11,68,15,6,9,75,79,12,2,79,3,6,25,1,71,27,12,2,79,22,14,8,12,19,79,16,8,79,6,2,12,11,10,10,68,4,7,13,11,11,22,2,1,68,8,9,68,32,0,0,73,79,85,84,79,48,15,10,29,71,14,22,2,79,22,2,13,11,21,1,69,71,59,12,14,28,68,14,28,68,9,0,16,71,14,68,23,7,29,20,6,7,6,3,68,5,6,22,19,7,68,21,10,23,18,3,16,14,1,3,71,9,22,8,2,68,15,26,9,6,1,68,23,14,23,20,6,11,9,79,11,21,79,20,11,14,10,75,79,16,15,6,23,71,29,1,5,6,22,19,7,68,4,0,9,2,28,68,1,29,11,10,79,35,8,11,74,86,91,68,52,0,68,19,7,1,71,56,11,21,11,68,5,10,7,6,2,1,71,7,17,10,14,10,71,14,10,3,79,8,14,25,1,3,79,12,2,29,1,71,0,10,71,10,5,21,27,12,71,14,9,8,1,3,71,26,23,73,79,44,2,79,19,6,28,68,1,26,8,11,79,11,1,79,17,9,9,5,14,3,13,9,8,68,11,0,18,2,79,5,9,11,68,1,14,13,19,7,2,18,3,10,2,28,23,73,79,37,9,11,68,16,10,68,15,14,18,2,79,23,2,10,10,71,7,13,20,79,3,11,0,22,30,67,68,19,7,1,71,8,8,8,29,29,71,0,2,71,27,12,2,79,11,9,3,29,71,60,11,9,79,11,1,79,16,15,10,68,33,14,16,15,10,22,73 diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index f206f59472..436ccde776 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files math.parser namespaces project-euler.common sequences splitting ; +USING: io.files math.parser namespaces project-euler.common +io.encodings.ascii sequences splitting ; IN: project-euler.067 ! http://projecteuler.net/index.php?section=problems&id=67 @@ -38,7 +39,7 @@ IN: project-euler.067 : source-067 ( -- seq ) "extra/project-euler/067/triangle.txt" resource-path - file-lines [ " " split [ string>number ] map ] map ; + ascii file-lines [ " " split [ string>number ] map ] map ; PRIVATE> diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index f068db77ec..30c46de0a0 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs hashtables io.files kernel math math.parser namespaces sequences ; +USING: assocs hashtables io.files kernel math math.parser namespaces +io.encodings.ascii sequences ; IN: project-euler.079 ! http://projecteuler.net/index.php?section=problems&id=79 @@ -26,7 +27,7 @@ IN: project-euler.079 edges ( seq -- seq ) [ diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index a322f69e90..25ddd9a60b 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -13,10 +13,11 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.043 project-euler.044 - project-euler.045 project-euler.046 project-euler.048 project-euler.052 - project-euler.053 project-euler.056 project-euler.067 project-euler.075 - project-euler.079 project-euler.092 project-euler.097 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.045 project-euler.046 project-euler.047 project-euler.048 + project-euler.052 project-euler.053 project-euler.056 project-euler.059 + project-euler.067 project-euler.075 project-euler.079 project-euler.092 + project-euler.097 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler r random 0 r> between? ; diff --git a/extra/raptor/raptor.factor b/extra/raptor/raptor.factor index 1ada2a30c6..1bf9b2d4c7 100755 --- a/extra/raptor/raptor.factor +++ b/extra/raptor/raptor.factor @@ -42,11 +42,11 @@ SYMBOL: networking-hook ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! USING: io io.files io.streams.lines io.streams.plain io.streams.duplex - listener ; + listener io.encodings.utf8 ; : tty-listener ( tty -- ) - dup [ - swap [ + dup utf8 [ + swap utf8 [ [ listener ] with-stream diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor index f6e7c05910..5a6b0bdfac 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/regexp/regexp-tests.factor @@ -222,3 +222,7 @@ IN: regexp-tests [ f ] [ "foo bar" "foo\\B bar" f matches? ] unit-test [ t ] [ "fooxbar" "foo\\Bxbar" f matches? ] unit-test [ f ] [ "foo" "foo\\Bbar" f matches? ] unit-test + +[ t ] [ "s@f" "[a-z.-]@[a-z]" f matches? ] unit-test +[ f ] [ "a" "[a-z.-]@[a-z]" f matches? ] unit-test +[ t ] [ ".o" "\\.[a-z]" f matches? ] unit-test diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index fe1d87d9e9..8a642a8692 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -167,7 +167,8 @@ C: group-result "(" ")" surrounded-by ; : 'range' ( -- parser ) - any-char-parser "-" token <& any-char-parser <&> + [ CHAR: ] = not ] satisfy "-" token <& + [ CHAR: ] = not ] satisfy <&> [ first2 char-between?-quot ] <@ ; : 'character-class-term' ( -- parser ) 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/regexp2/regexp2-tests.factor b/extra/regexp2/regexp2-tests.factor new file mode 100644 index 0000000000..1fb3f61f29 --- /dev/null +++ b/extra/regexp2/regexp2-tests.factor @@ -0,0 +1,5 @@ +USING: kernel peg regexp2 sequences tools.test ; +IN: regexp2.tests + +[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ] + [ "056" 'octal' parse ] unit-test diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor new file mode 100644 index 0000000000..e62eb76cb1 --- /dev/null +++ b/extra/regexp2/regexp2.factor @@ -0,0 +1,262 @@ +USING: assocs combinators.lib kernel math math.parser +namespaces peg unicode.case sequences unicode.categories +memoize peg.parsers ; +USE: io +USE: tools.walker +IN: regexp2 + +upper [ swap ch>upper = ] ] [ [ = ] ] if + curry ; + +: char-between?-quot ( ch1 ch2 -- quot ) + ignore-case? get + [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ] + [ [ between? ] ] + if 2curry ; + +: or-predicates ( quots -- quot ) + [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ; + +: literal-action [ nip ] curry action ; + +: delay-action [ curry ] curry action ; + +PRIVATE> + +: ascii? ( n -- ? ) + 0 HEX: 7f between? ; + +: octal-digit? ( n -- ? ) + CHAR: 0 CHAR: 7 between? ; + +: hex-digit? ( n -- ? ) + { + [ dup digit? ] + [ dup CHAR: a CHAR: f between? ] + [ dup CHAR: A CHAR: F between? ] + } || nip ; + +: control-char? ( n -- ? ) + { [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ; + +: punct? ( n -- ? ) + "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ; + +: c-identifier-char? ( ch -- ? ) + { [ dup alpha? ] [ dup CHAR: _ = ] } || nip ; + +: java-blank? ( n -- ? ) + { + CHAR: \s + CHAR: \t CHAR: \n CHAR: \r + HEX: c HEX: 7 HEX: 1b + } member? ; + +: java-printable? ( n -- ? ) + { [ dup alpha? ] [ dup punct? ] } || nip ; + +MEMO: 'ordinary-char' ( -- parser ) + [ "\\^*+?|(){}[$" member? not ] satisfy + [ char=-quot ] action ; + +MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ; + +MEMO: 'octal' ( -- parser ) + "0" token hide 'octal-digit' 1 3 from-m-to-n 2seq + [ first oct> ] action ; + +MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ; + +MEMO: 'hex' ( -- parser ) + "x" token hide 'hex-digit' 2 exactly-n 2seq + "u" token hide 'hex-digit' 6 exactly-n 2seq 2choice + [ first hex> ] action ; + +: satisfy-tokens ( assoc -- parser ) + [ >r token r> literal-action ] { } assoc>map choice ; + +MEMO: 'simple-escape-char' ( -- parser ) + { + { "\\" CHAR: \\ } + { "t" CHAR: \t } + { "n" CHAR: \n } + { "r" CHAR: \r } + { "f" HEX: c } + { "a" HEX: 7 } + { "e" HEX: 1b } + } [ char=-quot ] assoc-map satisfy-tokens ; + +MEMO: 'predefined-char-class' ( -- parser ) + { + { "d" [ digit? ] } + { "D" [ digit? not ] } + { "s" [ java-blank? ] } + { "S" [ java-blank? not ] } + { "w" [ c-identifier-char? ] } + { "W" [ c-identifier-char? not ] } + } satisfy-tokens ; + +MEMO: 'posix-character-class' ( -- parser ) + { + { "Lower" [ letter? ] } + { "Upper" [ LETTER? ] } + { "ASCII" [ ascii? ] } + { "Alpha" [ Letter? ] } + { "Digit" [ digit? ] } + { "Alnum" [ alpha? ] } + { "Punct" [ punct? ] } + { "Graph" [ java-printable? ] } + { "Print" [ java-printable? ] } + { "Blank" [ " \t" member? ] } + { "Cntrl" [ control-char? ] } + { "XDigit" [ hex-digit? ] } + { "Space" [ java-blank? ] } + } satisfy-tokens "p{" "}" surrounded-by ; + +MEMO: 'simple-escape' ( -- parser ) + [ + 'octal' , + 'hex' , + "c" token hide [ LETTER? ] satisfy 2seq , + any-char , + ] choice* [ char=-quot ] action ; + +MEMO: 'escape' ( -- parser ) + "\\" token hide [ + 'simple-escape-char' , + 'predefined-char-class' , + 'posix-character-class' , + 'simple-escape' , + ] choice* 2seq ; + +MEMO: 'any-char' ( -- parser ) + "." token [ drop t ] literal-action ; + +MEMO: 'char' ( -- parser ) + 'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ; + +DEFER: 'regexp' + +TUPLE: group-result str ; + +C: group-result + +MEMO: 'non-capturing-group' ( -- parser ) + "?:" token hide 'regexp' ; + +MEMO: 'positive-lookahead-group' ( -- parser ) + "?=" token hide 'regexp' [ ensure ] action ; + +MEMO: 'negative-lookahead-group' ( -- parser ) + "?!" token hide 'regexp' [ ensure-not ] action ; + +MEMO: 'simple-group' ( -- parser ) + 'regexp' [ [ ] action ] action ; + +MEMO: 'group' ( -- parser ) + [ + 'non-capturing-group' , + 'positive-lookahead-group' , + 'negative-lookahead-group' , + 'simple-group' , + ] choice* "(" ")" surrounded-by ; + +MEMO: 'range' ( -- parser ) + any-char "-" token hide any-char 3seq + [ first2 char-between?-quot ] action ; + +MEMO: 'character-class-term' ( -- parser ) + 'range' + 'escape' + [ "\\]" member? not ] satisfy [ char=-quot ] action + 3choice ; + +MEMO: 'positive-character-class' ( -- parser ) + ! todo + "]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq + 'character-class-term' repeat1 2choice [ or-predicates ] action ; + +MEMO: 'negative-character-class' ( -- parser ) + "^" token hide 'positive-character-class' 2seq + [ [ not ] append ] action ; + +MEMO: 'character-class' ( -- parser ) + 'negative-character-class' 'positive-character-class' 2choice + "[" "]" surrounded-by [ satisfy ] action ; + +MEMO: 'escaped-seq' ( -- parser ) + any-char repeat1 + [ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ; + +MEMO: 'break' ( quot -- parser ) + satisfy ensure + epsilon just 2choice ; + +MEMO: 'break-escape' ( -- parser ) + "$" token [ "\r\n" member? ] 'break' literal-action + "\\b" token [ blank? ] 'break' literal-action + "\\B" token [ blank? not ] 'break' literal-action + "\\z" token epsilon just literal-action 4choice ; + +MEMO: 'simple' ( -- parser ) + [ + 'escaped-seq' , + 'break-escape' , + 'group' , + 'character-class' , + 'char' , + ] choice* ; + +MEMO: 'exactly-n' ( -- parser ) + 'integer' [ exactly-n ] delay-action ; + +MEMO: 'at-least-n' ( -- parser ) + 'integer' "," token hide 2seq [ at-least-n ] delay-action ; + +MEMO: 'at-most-n' ( -- parser ) + "," token hide 'integer' 2seq [ at-most-n ] delay-action ; + +MEMO: 'from-m-to-n' ( -- parser ) + 'integer' "," token hide 'integer' 3seq + [ first2 from-m-to-n ] delay-action ; + +MEMO: 'greedy-interval' ( -- parser ) + 'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ; + +MEMO: 'interval' ( -- parser ) + 'greedy-interval' + 'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action + 'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action + 3choice "{" "}" surrounded-by ; + +MEMO: 'repetition' ( -- parser ) + [ + ! Possessive + ! "*+" token [ ] literal-action , + ! "++" token [ ] literal-action , + ! "?+" token [ ] literal-action , + ! Reluctant + ! "*?" token [ <(*)> ] literal-action , + ! "+?" token [ <(+)> ] literal-action , + ! "??" token [ <(?)> ] literal-action , + ! Greedy + "*" token [ repeat0 ] literal-action , + "+" token [ repeat1 ] literal-action , + "?" token [ optional ] literal-action , + ] choice* ; + +MEMO: 'dummy' ( -- parser ) + epsilon [ ] literal-action ; + +! todo -- check the action +! MEMO: 'term' ( -- parser ) + ! 'simple' + ! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action + ! [ ] action ; + diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor old mode 100644 new mode 100755 index 68a40704b3..77364d73e7 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -1,9 +1,10 @@ -USING: rss io kernel io.files tools.test ; +USING: rss io kernel io.files tools.test io.encodings.utf8 ; +IN: rss.tests : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. - read-feed ; + utf8 read-feed ; [ T{ feed diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor new file mode 100644 index 0000000000..777c481ebb --- /dev/null +++ b/extra/semantic-db/context/context.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces semantic-db ; +IN: semantic-db.context + +: create-context* ( context-name -- context-id ) create-node* ; +: create-context ( context-name -- ) create-context* drop ; + +: context ( -- context-id ) + \ context get ; + +: set-context ( context-id -- ) + \ context set ; + +: with-context ( context-id quot -- ) + >r \ context r> with-variable ; diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor new file mode 100644 index 0000000000..7d5f976909 --- /dev/null +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors db.tuples kernel new-slots semantic-db +semantic-db.relations sorting sequences sequences.deep ; +IN: semantic-db.hierarchy + +TUPLE: tree id children ; +C: tree + +: has-parent-relation ( -- relation-id ) + "has parent" relation-id ; + +: parent-child* ( parent child -- arc-id ) + has-parent-relation spin create-arc* ; + +: parent-child ( parent child -- ) + parent-child* drop ; + +: un-parent-child ( parent child -- ) + has-parent-relation spin select-tuples [ id>> delete-arc ] each ; + +: child-arcs ( node-id -- child-arcs ) + has-parent-relation f rot select-tuples ; + +: children ( node-id -- children ) + child-arcs [ subject>> ] map ; + +: parent-arcs ( node-id -- parent-arcs ) + has-parent-relation swap f select-tuples ; + +: parents ( node-id -- parents ) + parent-arcs [ object>> ] map ; + +: get-node-hierarchy ( node-id -- tree ) + dup children [ get-node-hierarchy ] map ; + +: uniq ( sorted-seq -- seq ) + f swap [ tuck = not ] subset nip ; + +: (get-root-nodes) ( node-id -- root-nodes/node-id ) + dup parents dup empty? [ + drop + ] [ + nip [ (get-root-nodes) ] map + ] if ; + +: get-root-nodes ( node-id -- root-nodes ) + (get-root-nodes) flatten natural-sort uniq ; diff --git a/extra/semantic-db/relations/relations.factor b/extra/semantic-db/relations/relations.factor new file mode 100644 index 0000000000..17c335c4ae --- /dev/null +++ b/extra/semantic-db/relations/relations.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: db.types kernel namespaces semantic-db semantic-db.context +sequences.lib ; +IN: semantic-db.relations + +! relations: +! - have a context in context 'semantic-db' + +: create-relation* ( context-id relation-name -- relation-id ) + create-node* tuck has-context-relation spin create-arc ; + +: create-relation ( context-id relation-name -- ) + create-relation* drop ; + +: get-relation ( context-id relation-name -- relation-id/f ) + [ + ":name" TEXT param , + ":context" INTEGER param , + has-context-relation ":has_context" INTEGER param , + ] { } make + "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.relation = :has_context and a.object = :context" + single-int-results ?first ; + +: relation-id ( relation-name -- relation-id ) + context swap [ get-relation ] [ create-relation* ] ensure2 ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor new file mode 100644 index 0000000000..6c2c4d3e9e --- /dev/null +++ b/extra/semantic-db/semantic-db-tests.factor @@ -0,0 +1,71 @@ +USING: accessors arrays continuations db db.sqlite db.tuples io.files +kernel math namespaces semantic-db semantic-db.context +semantic-db.hierarchy semantic-db.relations sequences tools.test +tools.walker ; +IN: semantic-db.tests + +: db-path "semantic-db-test.db" temp-file ; +: test-db db-path sqlite-db ; +: delete-db [ db-path delete-file ] ignore-errors ; + +delete-db + +test-db [ + create-node-table create-arc-table + [ 1 ] [ "first node" create-node* ] unit-test + [ 2 ] [ "second node" create-node* ] unit-test + [ 3 ] [ "third node" create-node* ] unit-test + [ 4 ] [ f create-node* ] unit-test + [ 5 ] [ 1 2 3 create-arc* ] unit-test +] with-db + +delete-db + +test-db [ + init-semantic-db + "test content" create-context* [ + [ 4 ] [ context ] unit-test + [ 5 ] [ context "is test content" create-relation* ] unit-test + [ 5 ] [ context "is test content" get-relation ] unit-test + [ 5 ] [ "is test content" relation-id ] unit-test + [ 7 ] [ "has parent" relation-id ] unit-test + [ 7 ] [ "has parent" relation-id ] unit-test + [ "has parent" ] [ "has parent" relation-id node-content ] unit-test + [ "test content" ] [ context node-content ] unit-test + ] with-context + ! type-type 1array [ "type" ensure-type ] unit-test + ! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test + ! [ 1 ] [ type-type select-node-of-type ] unit-test + ! [ t ] [ "content" ensure-type integer? ] unit-test + ! [ t ] [ "content" ensure-type "content" ensure-type = ] unit-test + ! [ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test + ! [ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test + ! [ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test + ! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test + ! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test + ! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test +] with-db + +delete-db + +! test hierarchy +test-db [ + init-semantic-db + "family tree" create-context* [ + "adam" create-node* "adam" set + "eve" create-node* "eve" set + "bob" create-node* "bob" set + "fran" create-node* "fran" set + "charlie" create-node* "charlie" set + "gertrude" create-node* "gertrude" set + [ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test + { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each + [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test + [ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map ] unit-test + [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test + ] with-context +] with-db + +delete-db diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor new file mode 100644 index 0000000000..e8075c016d --- /dev/null +++ b/extra/semantic-db/semantic-db.factor @@ -0,0 +1,89 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ; +IN: semantic-db + +TUPLE: node id content ; +: ( content -- node ) + node construct-empty swap >>content ; + +: ( id -- node ) + node construct-empty swap >>id ; + +node "node" +{ + { "id" "id" +native-id+ +autoincrement+ } + { "content" "content" TEXT } +} define-persistent + +: create-node-table ( -- ) + node create-table ; + +: delete-node ( node-id -- ) + delete-tuple ; + +: create-node* ( str -- node-id ) + dup insert-tuple id>> ; + +: create-node ( str -- ) + create-node* drop ; + +: node-content ( id -- str ) + f swap >>id select-tuple content>> ; + +TUPLE: arc id relation subject object ; + +: ( relation subject object -- arc ) + arc construct-empty swap >>object swap >>subject swap >>relation ; + +: ( id -- arc ) + arc construct-empty swap >>id ; + +: insert-arc ( arc -- ) + f dup insert-tuple id>> >>id insert-tuple ; + +: delete-arc ( arc-id -- ) + dup delete-node delete-tuple ; + +: create-arc* ( relation subject object -- arc-id ) + dup insert-arc id>> ; + +: create-arc ( relation subject object -- ) + create-arc* drop ; + +arc "arc" +{ + { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table? + { "relation" "relation" INTEGER +not-null+ } + { "subject" "subject" INTEGER +not-null+ } + { "object" "object" INTEGER +not-null+ } +} define-persistent + +: create-arc-table ( -- ) + arc create-table ; + +: create-bootstrap-nodes ( -- ) + "semantic-db" create-node + "has context" create-node ; + +: semantic-db-context 1 ; +: has-context-relation 2 ; + +: create-bootstrap-arcs ( -- ) + has-context-relation has-context-relation semantic-db-context create-arc ; + +: init-semantic-db ( -- ) + create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; + +: param ( value key type -- param ) + swapd 3array ; + +: single-int-results ( bindings sql -- array ) + f f [ do-bound-query ] with-disposal + [ first string>number ] map ; + +: ensure2 ( x y quot1 quot2 -- z ) + #! quot1 ( x y -- z/f ) finds an existing z + #! quot2 ( x y -- z ) creates a new z if quot1 returns f + >r >r 2dup r> call [ 2nip ] r> if* ; + diff --git a/extra/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor old mode 100644 new mode 100755 index 9c02d52089..541570f3f9 --- a/extra/sequences/deep/deep-tests.factor +++ b/extra/sequences/deep/deep-tests.factor @@ -1,5 +1,6 @@ USING: sequences.deep kernel tools.test strings math arrays namespaces sequences ; +IN: sequences.deep.tests [ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test 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-docs.factor b/extra/sequences/lib/lib-docs.factor index eb56e35cd5..6f4a173874 100755 --- a/extra/sequences/lib/lib-docs.factor +++ b/extra/sequences/lib/lib-docs.factor @@ -8,7 +8,7 @@ HELP: map-withn "passed to the quotation given to map-withn for each element in the sequence." } { $examples - { $example "USE: combinators.lib" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" } + { $example "USING: math sequences.lib prettyprint ;" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" } } { $see-also each-withn } ; @@ -24,7 +24,7 @@ HELP: sigma { $description "Like map sum, but without creating an intermediate sequence." } { $example "! Find the sum of the squares [0,99]" - "USING: math.ranges combinators.lib ;" + "USING: math math.ranges sequences.lib prettyprint ;" "100 [1,b] [ sq ] sigma ." "338350" } ; @@ -33,7 +33,7 @@ HELP: count { $values { "seq" sequence } { "quot" quotation } { "n" integer } } { $description "Efficiently returns the number of elements that the predicate quotation matches." } { $example - "USING: math.ranges combinators.lib ;" + "USING: math math.ranges sequences.lib prettyprint ;" "100 [1,b] [ even? ] count ." "50" } ; 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..050de0ae1c 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 @@ -139,13 +140,13 @@ PRIVATE> : strings ( alphabet length -- seqs ) >r dup length r> number-strings map-alphabet ; -: nths ( nths seq -- subseq ) - ! nths is a sequence of ones and zeroes +: switches ( seq1 seq -- subseq ) + ! seq1 is a sequence of ones and zeroes >r [ length ] keep [ nth 1 = ] curry subset r> [ nth ] curry { } map-as ; : power-set ( seq -- subsets ) - 2 over length exact-number-strings swap [ nths ] curry map ; + 2 over length exact-number-strings swap [ switches ] curry map ; : push-either ( elt quot accum1 accum2 -- ) >r >r keep swap r> r> ? push ; 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 ; @@ -205,3 +214,9 @@ PRIVATE> : attempt-each ( seq quot -- result ) (each) iterate-prep (attempt-each-integer) ; inline + +: ?nth* ( n seq -- elt/f ? ) + 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable + +: nths ( indices seq -- seq' ) + [ swap nth ] with map ; diff --git a/extra/sequences/next/next.factor b/extra/sequences/next/next.factor old mode 100644 new mode 100755 index 5483cdff4b..5919fb0701 --- a/extra/sequences/next/next.factor +++ b/extra/sequences/next/next.factor @@ -3,6 +3,8 @@ IN: sequences.next r dup length swap r> ; inline + : (map-next) ( i seq quot -- ) ! this uses O(n) more bounds checks than is really necessary >r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline diff --git a/extra/serialize/serialize-docs.factor b/extra/serialize/serialize-docs.factor old mode 100644 new mode 100755 index e12751d6ab..fc060d6b33 --- a/extra/serialize/serialize-docs.factor +++ b/extra/serialize/serialize-docs.factor @@ -3,47 +3,20 @@ USING: help.syntax help.markup ; IN: serialize -HELP: (serialize) -{ $values { "obj" "object to serialize" } -} -{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." } -{ $examples - { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" } -} -{ $see-also deserialize (deserialize) serialize with-serialized } ; - -HELP: (deserialize) -{ $values { "obj" "deserialized object" } -} -{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." } -{ $examples - { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" } -} -{ $see-also (serialize) deserialize serialize with-serialized } ; - -HELP: with-serialized -{ $values { "quot" "a quotation" } -} -{ $description "Creates a scope for serialization and deserialization operations. The quotation is called within this scope. The scope is used for maintaining the structure and object references of serialized objects." } -{ $examples - { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" } -} -{ $see-also (serialize) (deserialize) serialize deserialize } ; - HELP: serialize { $values { "obj" "object to serialize" } } { $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained." } { $examples - { $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" } + { $example "USING: serialize io.encodings.binary io.streams.byte-array prettyprint ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } -{ $see-also deserialize (deserialize) (serialize) with-serialized } ; +{ $see-also deserialize } ; HELP: deserialize { $values { "obj" "deserialized object" } } { $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained." } { $examples - { $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" } + { $example "USING: serialize io.encodings.binary io.streams.byte-array prettyprint ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } -{ $see-also (serialize) deserialize (deserialize) with-serialized } ; +{ $see-also serialize } ; diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index 6c80c8de7d..1831495924 100755 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -1,10 +1,28 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: tools.test kernel serialize io io.streams.string math +USING: tools.test kernel serialize io io.streams.byte-array math alien arrays byte-arrays sequences math prettyprint parser -classes math.constants ; -IN: temporary +classes math.constants io.encodings.binary random +combinators.lib ; +IN: serialize.tests + +: test-serialize-cell + 2^ random dup + binary [ serialize-cell ] with-byte-writer + binary [ deserialize-cell ] with-byte-reader = ; + +[ t ] [ + 100 [ + drop + { + [ 40 [ test-serialize-cell ] all? ] + [ 4 [ 40 * test-serialize-cell ] all? ] + [ 4 [ 400 * test-serialize-cell ] all? ] + [ 4 [ 4000 * test-serialize-cell ] all? ] + } && + ] all? +] unit-test TUPLE: serialize-test a b ; @@ -25,6 +43,7 @@ C: serialize-test { 1 2 "three" } V{ 1 2 "three" } SBUF" hello world" + "hello \u123456 unicode" \ dup [ \ dup dup ] T{ serialize-test f "a" 2 } @@ -38,8 +57,9 @@ C: serialize-test : check-serialize-1 ( obj -- ? ) dup class . - dup [ serialize ] with-string-writer - [ deserialize ] with-string-reader = ; + dup + binary [ serialize ] with-byte-writer + binary [ deserialize ] with-byte-reader = ; : check-serialize-2 ( obj -- ? ) dup number? over wrapper? or [ @@ -47,8 +67,8 @@ C: serialize-test ] [ dup class . dup 2array - [ serialize ] with-string-writer - [ deserialize ] with-string-reader + binary [ serialize ] with-byte-writer + binary [ deserialize ] with-byte-reader first2 eq? ] if ; @@ -57,13 +77,5 @@ C: serialize-test [ t ] [ objects [ check-serialize-2 ] all? ] unit-test [ t ] [ pi check-serialize-1 ] unit-test - -[ t ] [ - { 1 2 3 } [ - [ - dup (serialize) (serialize) - ] with-serialized - ] with-string-writer [ - deserialize-sequence all-eq? - ] with-string-reader -] unit-test +[ serialize ] must-infer +[ deserialize ] must-infer diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 03e1645870..f573499695 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -10,151 +10,177 @@ IN: serialize USING: namespaces sequences kernel math io math.functions io.binary strings classes words sbufs tuples arrays vectors byte-arrays bit-arrays quotations hashtables -assocs help.syntax help.markup float-arrays splitting ; +assocs help.syntax help.markup float-arrays splitting +io.encodings.string io.encodings.utf8 combinators new-slots +accessors ; -! Variable holding a sequence of objects already serialized +! Variable holding a assoc of objects already serialized SYMBOL: serialized -: add-object ( obj -- id ) +TUPLE: id obj ; + +C: id + +M: id hashcode* obj>> hashcode* ; + +M: id equal? over id? [ [ obj>> ] 2apply eq? ] [ 2drop f ] if ; + +: add-object ( obj -- ) #! Add an object to the sequence of already serialized - #! objects. Return the id of that object. - serialized get [ push ] keep length 1 - ; + #! objects. + serialized get [ assoc-size swap ] keep set-at ; : object-id ( obj -- id ) #! Return the id of an already serialized object - serialized get [ eq? ] with find [ drop f ] unless ; - -USE: prettyprint + serialized get at ; ! Serialize object GENERIC: (serialize) ( obj -- ) -: serialize-cell 8 >be write ; +! Numbers are serialized as follows: +! 0 => B{ 0 } +! 1<=x<=126 => B{ x | 0x80 } +! x>127 => B{ length(x) x[0] x[1] ... } +! x>2^1024 => B{ 0xff length(x) x[0] x[1] ... } +! The last case is needed because a very large number would +! otherwise be confused with a small number. +: serialize-cell ( n -- ) + dup zero? [ drop 0 write1 ] [ + dup HEX: 7e <= [ + HEX: 80 bitor write1 + ] [ + dup log2 8 /i 1+ + dup HEX: 7f >= [ + HEX: ff write1 + dup serialize-cell + ] [ + dup write1 + ] if + >be write + ] if + ] if ; -: deserialize-cell 8 read be> ; +: deserialize-cell ( -- n ) + read1 { + { [ dup HEX: ff = ] [ drop deserialize-cell read be> ] } + { [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] } + { [ t ] [ read be> ] } + } cond ; : serialize-shared ( obj quot -- ) >r dup object-id - [ "o" write serialize-cell drop ] r> if* ; inline + [ CHAR: o write1 serialize-cell drop ] r> if* ; inline M: f (serialize) ( obj -- ) - drop "n" write ; - -: bytes-needed ( number -- int ) - log2 8 + 8 /i ; inline + drop CHAR: n write1 ; M: integer (serialize) ( obj -- ) - dup 0 = [ - drop "z" write + dup zero? [ + drop CHAR: z write1 ] [ - dup 0 < [ neg "m" ] [ "p" ] if write - dup bytes-needed dup serialize-cell - >be write + dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1 + serialize-cell ] if ; M: float (serialize) ( obj -- ) - "F" write + CHAR: F write1 double>bits serialize-cell ; M: complex (serialize) ( obj -- ) - "c" write + CHAR: c write1 dup real-part (serialize) imaginary-part (serialize) ; M: ratio (serialize) ( obj -- ) - "r" write + CHAR: r write1 dup numerator (serialize) denominator (serialize) ; -M: string (serialize) ( obj -- ) - [ - "s" write - dup add-object serialize-cell - dup length serialize-cell - write - ] serialize-shared ; +: serialize-string ( obj code -- ) + write1 + dup utf8 encode dup length serialize-cell write + add-object ; -M: sbuf (serialize) ( obj -- ) - [ - "S" write - dup add-object serialize-cell - dup length serialize-cell - >string write - ] serialize-shared ; +M: string (serialize) ( obj -- ) + [ CHAR: s serialize-string ] serialize-shared ; + +: serialize-elements ( seq -- ) + [ (serialize) ] each CHAR: . write1 ; M: tuple (serialize) ( obj -- ) [ - "T" write - dup add-object serialize-cell - tuple>array - dup length serialize-cell - [ (serialize) ] each + CHAR: T write1 + dup tuple>array serialize-elements + add-object ] serialize-shared ; : serialize-seq ( seq code -- ) [ - write - dup add-object serialize-cell - dup length serialize-cell - [ (serialize) ] each + write1 + dup serialize-elements + add-object ] curry serialize-shared ; M: array (serialize) ( obj -- ) - "a" serialize-seq ; - -M: vector (serialize) ( obj -- ) - "v" serialize-seq ; + CHAR: a serialize-seq ; M: byte-array (serialize) ( obj -- ) - "A" serialize-seq ; + [ + CHAR: A write1 + dup dup length serialize-cell write + add-object + ] serialize-shared ; M: bit-array (serialize) ( obj -- ) - "b" serialize-seq ; + [ + CHAR: b write1 + dup length serialize-cell + dup [ 1 0 ? ] B{ } map-as write + add-object + ] serialize-shared ; M: quotation (serialize) ( obj -- ) - "q" serialize-seq ; - -M: curry (serialize) ( obj -- ) - [ - "C" write - dup add-object serialize-cell - dup curry-obj (serialize) curry-quot (serialize) - ] serialize-shared ; + CHAR: q serialize-seq ; M: float-array (serialize) ( obj -- ) [ - "f" write - dup add-object serialize-cell + CHAR: f write1 dup length serialize-cell - [ double>bits 8 >be write ] each + dup [ double>bits 8 >be write ] each + add-object ] serialize-shared ; M: hashtable (serialize) ( obj -- ) [ - "h" write - dup add-object serialize-cell - >alist (serialize) + CHAR: h write1 + dup >alist (serialize) + add-object ] serialize-shared ; M: word (serialize) ( obj -- ) - "w" write - dup word-name (serialize) - word-vocabulary (serialize) ; + [ + CHAR: w write1 + dup word-name (serialize) + dup word-vocabulary (serialize) + add-object + ] serialize-shared ; M: wrapper (serialize) ( obj -- ) - "W" write + CHAR: W write1 wrapped (serialize) ; DEFER: (deserialize) ( -- obj ) -: intern-object ( id obj -- obj ) - dup rot serialized get set-nth ; +SYMBOL: deserialized + +: intern-object ( obj -- ) + deserialized get push ; : deserialize-false ( -- f ) f ; : deserialize-positive-integer ( -- number ) - deserialize-cell read be> ; + deserialize-cell ; : deserialize-negative-integer ( -- number ) deserialize-positive-integer neg ; @@ -171,85 +197,83 @@ DEFER: (deserialize) ( -- obj ) : deserialize-complex ( -- complex ) (deserialize) (deserialize) rect> ; -: deserialize-string ( -- string ) - deserialize-cell deserialize-cell read intern-object ; +: (deserialize-string) ( -- string ) + deserialize-cell read utf8 decode ; -: deserialize-sbuf ( -- sbuf ) - deserialize-cell deserialize-cell read >sbuf intern-object ; +: deserialize-string ( -- string ) + (deserialize-string) dup intern-object ; : deserialize-word ( -- word ) (deserialize) dup (deserialize) lookup - [ ] [ "Unknown word" throw ] ?if ; + [ dup intern-object ] [ "Unknown word" throw ] ?if ; : deserialize-wrapper ( -- wrapper ) (deserialize) ; +SYMBOL: +stop+ + +: (deserialize-seq) ( -- seq ) + [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ; + : deserialize-seq ( seq -- array ) - deserialize-cell deserialize-cell - [ drop (deserialize) ] roll map-as - intern-object ; + >r (deserialize-seq) r> like dup intern-object ; : deserialize-array ( -- array ) { } deserialize-seq ; -: deserialize-vector ( -- array ) - V{ } deserialize-seq ; - : deserialize-quotation ( -- array ) [ ] deserialize-seq ; +: (deserialize-byte-array) ( -- byte-array ) + deserialize-cell read B{ } like ; + : deserialize-byte-array ( -- byte-array ) - B{ } deserialize-seq ; + (deserialize-byte-array) dup intern-object ; : deserialize-bit-array ( -- bit-array ) - ?{ } deserialize-seq ; + (deserialize-byte-array) [ 0 > ] ?{ } map-as + dup intern-object ; : deserialize-float-array ( -- float-array ) - deserialize-cell deserialize-cell + deserialize-cell 8 * read 8 [ be> bits>double ] F{ } map-as - intern-object ; + dup intern-object ; : deserialize-hashtable ( -- hashtable ) - deserialize-cell (deserialize) >hashtable intern-object ; + (deserialize) >hashtable dup intern-object ; : deserialize-tuple ( -- array ) - deserialize-cell - deserialize-cell [ drop (deserialize) ] map >tuple - intern-object ; - -: deserialize-curry ( -- curry ) - deserialize-cell - (deserialize) (deserialize) curry - intern-object ; + (deserialize-seq) >tuple dup intern-object ; : deserialize-unknown ( -- object ) - deserialize-cell serialized get nth ; + deserialize-cell deserialized get nth ; + +: deserialize-stop ( -- object ) + +stop+ get ; : deserialize* ( -- object ? ) read1 [ - H{ - { CHAR: A deserialize-byte-array } - { CHAR: C deserialize-curry } - { CHAR: F deserialize-float } - { CHAR: S deserialize-sbuf } - { CHAR: T deserialize-tuple } - { CHAR: W deserialize-wrapper } - { CHAR: a deserialize-array } - { CHAR: b deserialize-bit-array } - { CHAR: c deserialize-complex } - { CHAR: f deserialize-float-array } - { CHAR: h deserialize-hashtable } - { CHAR: m deserialize-negative-integer } - { CHAR: n deserialize-false } - { CHAR: o deserialize-unknown } - { CHAR: p deserialize-positive-integer } - { CHAR: q deserialize-quotation } - { CHAR: r deserialize-ratio } - { CHAR: s deserialize-string } - { CHAR: v deserialize-vector } - { CHAR: w deserialize-word } - { CHAR: z deserialize-zero } - } at dup [ "Unknown typecode" throw ] unless execute t + { + { CHAR: A [ deserialize-byte-array ] } + { CHAR: F [ deserialize-float ] } + { CHAR: T [ deserialize-tuple ] } + { CHAR: W [ deserialize-wrapper ] } + { CHAR: a [ deserialize-array ] } + { CHAR: b [ deserialize-bit-array ] } + { CHAR: c [ deserialize-complex ] } + { CHAR: f [ deserialize-float-array ] } + { CHAR: h [ deserialize-hashtable ] } + { CHAR: m [ deserialize-negative-integer ] } + { CHAR: n [ deserialize-false ] } + { CHAR: o [ deserialize-unknown ] } + { CHAR: p [ deserialize-positive-integer ] } + { CHAR: q [ deserialize-quotation ] } + { CHAR: r [ deserialize-ratio ] } + { CHAR: s [ deserialize-string ] } + { CHAR: w [ deserialize-word ] } + { CHAR: z [ deserialize-zero ] } + { CHAR: . [ deserialize-stop ] } + } case t ] [ f f ] if* ; @@ -257,14 +281,15 @@ DEFER: (deserialize) ( -- obj ) : (deserialize) ( -- obj ) deserialize* [ "End of stream" throw ] unless ; -: with-serialized ( quot -- ) - V{ } clone serialized rot with-variable ; inline - -: deserialize-sequence ( -- seq ) - [ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ; - : deserialize ( -- obj ) - [ (deserialize) ] with-serialized ; + [ + V{ } clone deserialized set + gensym +stop+ set + (deserialize) + ] with-scope ; : serialize ( obj -- ) - [ (serialize) ] with-serialized ; \ No newline at end of file + [ + H{ } clone serialized set + (serialize) + ] with-scope ; \ No newline at end of file diff --git a/extra/shuffle/shuffle-docs.factor b/extra/shuffle/shuffle-docs.factor index 8f6ccc410a..4caace3b00 100755 --- a/extra/shuffle/shuffle-docs.factor +++ b/extra/shuffle/shuffle-docs.factor @@ -11,7 +11,7 @@ HELP: npick "placed on the top of the stack." } { $examples - { $example "USE: shuffle" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } } { $see-also dup over pick } ; @@ -23,7 +23,7 @@ HELP: ndup "placed on the top of the stack." } { $examples - { $example "USE: shuffle" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } } { $see-also dup 2dup 3dup } ; @@ -34,7 +34,7 @@ HELP: nnip "for any number of items." } { $examples - { $example "USE: shuffle" "1 2 3 4 3 nnip .s" "4" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 nnip .s" "4" } } { $see-also nip 2nip } ; @@ -45,7 +45,7 @@ HELP: ndrop "for any number of items." } { $examples - { $example "USE: shuffle" "1 2 3 4 3 ndrop .s" "1" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 ndrop .s" "1" } } { $see-also drop 2drop 3drop } ; @@ -55,7 +55,7 @@ HELP: nrot "number of items on the stack. " } { $examples - { $example "USE: shuffle" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } } { $see-also rot -nrot } ; @@ -65,7 +65,7 @@ HELP: -nrot "number of items on the stack. " } { $examples - { $example "USE: shuffle" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } } { $see-also rot nrot } ; diff --git a/extra/furnace/sessions/authors.txt b/extra/singleton/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/furnace/sessions/authors.txt rename to extra/singleton/authors.txt diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor new file mode 100644 index 0000000000..92ddcc494a --- /dev/null +++ b/extra/singleton/singleton-docs.factor @@ -0,0 +1,26 @@ +USING: help.markup help.syntax kernel words ; +IN: singleton + +HELP: SINGLETON: +{ $syntax "SINGLETON: class" +} { $values + { "class" "a new singleton to define" } +} { $description + "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton." +} { $examples + { $example "USING: singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } +} { $see-also + POSTPONE: PREDICATE: +} ; + +HELP: SINGLETONS: +{ $syntax "SINGLETONS: classes... ;" +} { $values + { "classes" "new singletons to define" } +} { $description + "Defines a new singleton for each class in the list." +} { $examples + { $example "USE: singleton" "SINGLETONS: foo bar baz ;" "" } +} { $see-also + POSTPONE: SINGLETON: +} ; diff --git a/extra/singleton/singleton-tests.factor b/extra/singleton/singleton-tests.factor new file mode 100644 index 0000000000..1698181ed3 --- /dev/null +++ b/extra/singleton/singleton-tests.factor @@ -0,0 +1,9 @@ +USING: kernel singleton tools.test ; +IN: singleton.tests + +[ ] [ SINGLETON: bzzt ] unit-test +[ t ] [ bzzt bzzt? ] unit-test +[ t ] [ bzzt bzzt eq? ] unit-test +GENERIC: zammo ( obj -- ) +[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test +[ "yes!" ] [ bzzt zammo ] unit-test diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor new file mode 100755 index 0000000000..0b77443a50 --- /dev/null +++ b/extra/singleton/singleton.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: classes.predicate kernel namespaces parser quotations +sequences words ; +IN: singleton + +: define-singleton ( token -- ) + \ word swap create-class-in + dup [ eq? ] curry define-predicate-class ; + +: SINGLETON: + scan define-singleton ; parsing + +: SINGLETONS: + ";" parse-tokens [ define-singleton ] each ; parsing diff --git a/extra/size-of/size-of.factor b/extra/size-of/size-of.factor new file mode 100644 index 0000000000..5b6f26acea --- /dev/null +++ b/extra/size-of/size-of.factor @@ -0,0 +1,39 @@ + +USING: kernel namespaces sequences + io io.files io.launcher io.encodings.ascii + bake builder.util + accessors vars + math.parser ; + +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\" , sizeof( " , " ) ) ; }" } + } + bake to-strings ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: c-file ( -- path ) "size-of.c" temp-file ; + +: exe ( -- path ) "size-of" temp-file ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: size-of ( type -- n ) + size-of-c-program c-file ascii set-file-lines + + { "gcc" c-file "-o" exe } to-strings + [ "Error compiling generated C program" print ] run-or-bail + + exe ascii contents string>number ; \ No newline at end of file diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index a0065d6fe3..b58253381c 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -6,10 +6,14 @@ IN: slides : stylesheet H{ - { default-style + { default-span-style H{ { font "sans-serif" } { font-size 36 } + } + } + { default-block-style + H{ { wrap-margin 1000 } } } diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index b89b351f9e..14957ceca2 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -1,9 +1,12 @@ ! Copyright (C) 2007 Elie CHAFTARI ! See http://factorcode.org/license.txt for BSD license. +USING: combinators kernel prettyprint io io.timeouts io.server +sequences namespaces io.sockets continuations calendar io.encodings.ascii ; +IN: smtp.server ! Mock SMTP server for testing purposes. -! Usage: 4321 smtp-server +! Usage: 4321 mock-smtp-server ! $ telnet 127.0.0.1 4321 ! Trying 127.0.0.1... ! Connected to localhost. @@ -27,10 +30,6 @@ ! bye ! Connection closed by foreign host. -USING: combinators kernel prettyprint io io.timeouts io.server -sequences namespaces io.sockets continuations ; -IN: smtp.server - SYMBOL: data-mode : process ( -- ) @@ -62,11 +61,11 @@ SYMBOL: data-mode ] } } cond nip [ process ] when ; -: smtp-server ( port -- ) +: mock-smtp-server ( port -- ) "Starting SMTP server on port " write dup . flush - "127.0.0.1" swap [ + "127.0.0.1" swap ascii [ accept [ - 60000 stdio get set-timeout + 1 minutes stdio get set-timeout "220 hello\r\n" write flush process global [ flush ] bind diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 784f446b7e..a705a9609e 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,6 +1,7 @@ -USING: smtp tools.test io.streams.string threads -smtp.server kernel sequences namespaces logging ; -IN: temporary +USING: smtp tools.test io.streams.string io.sockets threads +smtp.server kernel sequences namespaces logging accessors +assocs sorting ; +IN: smtp.tests { 0 0 } [ [ ] with-smtp-connection ] must-infer-as @@ -12,7 +13,7 @@ IN: temporary [ { "hello" "." "world" } validate-message ] must-fail [ "hello\r\nworld\r\n.\r\n" ] [ - { "hello" "world" } [ send-body ] with-string-writer + "hello\nworld" [ send-body ] with-string-writer ] unit-test [ "500 syntax error" check-response ] must-fail @@ -38,62 +39,43 @@ IN: temporary ] must-fail [ - V{ - { "To" "Slava , Ed " } + { { "From" "Doug " } { "Subject" "Factor rules" } + { "To" "Slava , Ed " } } { "slava@factorcode.org" "dharmatech@factorcode.org" } "erg@factorcode.org" ] [ - "Factor rules" - { - "Slava " - "Ed " - } - "Doug " - simple-headers >r >r 2 head* r> r> -] unit-test - -[ - { - "To: Slava , Ed " - "From: Doug " - "Subject: Factor rules" - f - f - "" - "Hi guys" - "Bye guys" - } - { "slava@factorcode.org" "dharmatech@factorcode.org" } - "erg@factorcode.org" -] [ - "Hi guys\nBye guys" - "Factor rules" - { - "Slava " - "Ed " - } - "Doug " - prepare-simple-message - >r >r f 3 pick set-nth f 4 pick set-nth r> r> -] unit-test - -[ ] [ [ 4321 smtp-server ] in-thread ] unit-test - -[ ] [ - [ - 4321 smtp-port set - - "Hi guys\nBye guys" - "Factor rules" + + "Factor rules" >>subject { "Slava " "Ed " - } - "Doug " + } >>to + "Doug " >>from + prepare + dup headers>> >alist sort-keys [ + drop { "Date" "Message-Id" } member? not + ] assoc-subset + over to>> + rot from>> +] unit-test - send-simple-message +[ ] [ [ 4321 mock-smtp-server ] in-thread ] unit-test + +[ ] [ + [ + "localhost" 4321 smtp-server set + + + "Hi guys\nBye guys" >>body + "Factor rules" >>subject + { + "Slava " + "Ed " + } >>to + "Doug " >>from + send-email ] with-scope -] unit-test \ No newline at end of file +] unit-test diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 47bc16e029..a941b14a47 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -3,24 +3,21 @@ ! 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 io.encodings.ascii +calendar.format new-slots accessors ; IN: smtp SYMBOL: smtp-domain -SYMBOL: smtp-host "localhost" smtp-host set-global -SYMBOL: smtp-port 25 smtp-port set-global -SYMBOL: read-timeout 60000 read-timeout set-global +SYMBOL: smtp-server "localhost" 25 smtp-server set-global +SYMBOL: read-timeout 1 minutes read-timeout set-global SYMBOL: esmtp t esmtp set-global -: log-smtp-connection ( host port -- ) 2drop ; - -\ log-smtp-connection NOTICE add-input-logging +LOG: log-smtp-connection NOTICE ( addrspec -- ) : with-smtp-connection ( quot -- ) - smtp-host get smtp-port get - 2dup log-smtp-connection - [ + smtp-server get + dup log-smtp-connection + ascii [ smtp-domain [ host-name or ] change read-timeout get stdio get set-timeout call @@ -33,8 +30,8 @@ SYMBOL: esmtp t esmtp set-global : validate-address ( string -- string' ) #! Make sure we send funky stuff to the server by accident. - dup [ "\r\n>" member? ] contains? - [ "Bad e-mail address: " swap append throw ] when ; + dup "\r\n>" seq-intersect empty? + [ "Bad e-mail address: " swap append throw ] unless ; : mail-from ( fromaddr -- ) "MAIL FROM:<" write validate-address write ">" write crlf ; @@ -49,6 +46,7 @@ SYMBOL: esmtp t esmtp set-global "." over member? [ "Message cannot contain . on a line by itself" throw ] when ; : send-body ( body -- ) + string-lines validate-message [ write crlf ] each "." write crlf ; @@ -89,32 +87,40 @@ LOG: smtp-response DEBUG : get-ok ( -- ) flush receive-response check-response ; -: send-raw-message ( body to from -- ) +: validate-header ( string -- string' ) + dup "\r\n" seq-intersect empty? + [ "Invalid header string: " swap append throw ] unless ; + +: write-header ( key value -- ) + swap + validate-header write + ": " write + validate-header write + crlf ; + +: write-headers ( assoc -- ) + [ write-header ] assoc-each ; + +TUPLE: email from to subject headers body ; + +M: email clone + (clone) [ clone ] change-headers ; + +: (send) ( email -- ) [ helo get-ok - mail-from get-ok - [ rcpt-to get-ok ] each + dup from>> mail-from get-ok + dup to>> [ rcpt-to get-ok ] each data get-ok - send-body get-ok + dup headers>> write-headers + crlf + body>> send-body get-ok quit get-ok ] with-smtp-connection ; -: validate-header ( string -- string' ) - dup [ "\r\n" member? ] contains? - [ "Invalid header string: " swap append throw ] when ; - -: prepare-header ( key value -- ) - swap - validate-header % - ": " % - validate-header % ; - -: prepare-headers ( assoc -- ) - [ [ prepare-header ] "" make , ] assoc-each ; - : 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 ) [ @@ -127,30 +133,25 @@ LOG: smtp-response DEBUG ">" % ] "" make ; -: simple-headers ( subject to from -- headers to from ) - [ - >r dup ", " join "To" set [ extract-email ] map r> - dup "From" set extract-email - rot "Subject" set - now timestamp>rfc822-string "Date" set - message-id "Message-Id" set - ] { } make-assoc -rot ; +: set-header ( email value key -- email ) + pick headers>> set-at ; -: prepare-message ( body headers -- body' ) - [ - prepare-headers - "" , - dup string? [ string-lines ] when % - ] { } make ; +: prepare ( email -- email ) + clone + dup from>> "From" set-header + [ extract-email ] change-from + dup to>> ", " join "To" set-header + [ [ extract-email ] map ] change-to + dup subject>> "Subject" set-header + now timestamp>rfc822-string "Date" set-header + message-id "Message-Id" set-header ; -: prepare-simple-message ( body subject to from -- body' to from ) - simple-headers >r >r prepare-message r> r> ; +: ( -- email ) + email construct-empty + H{ } clone >>headers ; -: send-message ( body headers to from -- ) - >r >r prepare-message r> r> send-raw-message ; - -: send-simple-message ( body subject to from -- ) - prepare-simple-message send-raw-message ; +: send-email ( email -- ) + prepare (send) ; ! Dirk's old AUTH CRAM-MD5 code. I don't know anything about ! CRAM MD5, and the old code didn't work properly either, so here @@ -171,13 +172,3 @@ LOG: smtp-response DEBUG ! (cram-md5-auth) "\r\n" append get-ok ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USE: new-slots - -TUPLE: email from to subject body ; - -: ( -- email ) email construct-empty ; - -: send ( email -- ) - { email-body email-subject email-to email-from } get-slots - send-simple-message ; \ No newline at end of file diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index d992df4d8f..d66ffdc66e 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -3,8 +3,9 @@ ! USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel shuffle arrays io.files combinators ui.gestures -ui.gadgets ui.render opengl.gl system threads match -ui byte-arrays combinators.lib ; +ui.gadgets ui.render opengl.gl system match +ui byte-arrays combinators.lib qualified ; +QUALIFIED: threads IN: space-invaders TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ; @@ -337,7 +338,7 @@ M: space-invaders update-video ( value addr cpu -- ) : sync-frame ( millis -- millis ) #! Sleep until the time for the next frame arrives. 1000 60 / >fixnum + millis - dup 0 > - [ sleep ] [ drop yield ] if millis ; + [ threads:sleep ] [ drop threads:yield ] if millis ; : invaders-process ( millis gadget -- ) #! Run a space invaders gadget inside a @@ -356,7 +357,7 @@ M: invaders-gadget graft* ( gadget -- ) dup invaders-gadget-cpu init-sounds f over set-invaders-gadget-quit? [ millis swap invaders-process ] curry - "Space invaders" spawn drop ; + "Space invaders" threads:spawn drop ; M: invaders-gadget ungraft* ( gadget -- ) t swap set-invaders-gadget-quit? ; diff --git a/extra/strings/lib/lib-tests.factor b/extra/strings/lib/lib-tests.factor new file mode 100644 index 0000000000..2779e190c9 --- /dev/null +++ b/extra/strings/lib/lib-tests.factor @@ -0,0 +1,8 @@ +USING: kernel sequences strings.lib tools.test ; +IN: temporary + +[ "abcdefghijklmnopqrstuvwxyz" ] [ lower-alpha-chars "" like ] unit-test +[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test +[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test +[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test +[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor new file mode 100644 index 0000000000..7f13cd58a9 --- /dev/null +++ b/extra/strings/lib/lib.factor @@ -0,0 +1,39 @@ +USING: math arrays sequences kernel random splitting strings unicode.case ; +IN: strings.lib + +: char>digit ( c -- i ) 48 - ; + +: string>digits ( s -- seq ) [ char>digit ] { } map-as ; + +: >Upper ( str -- str ) + dup empty? [ + unclip ch>upper 1string swap append + ] unless ; + +: >Upper-dashes ( str -- str ) + "-" split [ >Upper ] map "-" join ; + +: lower-alpha-chars ( -- seq ) + 26 [ CHAR: a + ] map ; + +: upper-alpha-chars ( -- seq ) + 26 [ CHAR: A + ] map ; + +: numeric-chars ( -- seq ) + 10 [ CHAR: 0 + ] map ; + +: alpha-chars ( -- seq ) + lower-alpha-chars upper-alpha-chars append ; + +: alphanumeric-chars ( -- seq ) + alpha-chars numeric-chars append ; + +: random-alpha-char ( -- ch ) + alpha-chars random ; + +: random-alphanumeric-char ( -- ch ) + alphanumeric-chars random ; + +: random-alphanumeric-string ( length -- str ) + [ drop random-alphanumeric-char ] map "" like ; + diff --git a/extra/furnace/authors.txt b/extra/symbols/authors.txt similarity index 100% rename from extra/furnace/authors.txt rename to extra/symbols/authors.txt diff --git a/extra/symbols/symbols-docs.factor b/extra/symbols/symbols-docs.factor new file mode 100644 index 0000000000..f542948970 --- /dev/null +++ b/extra/symbols/symbols-docs.factor @@ -0,0 +1,9 @@ +USING: help.markup help.syntax ; +IN: symbols + +HELP: SYMBOLS: +{ $syntax "SYMBOLS: words... ;" } +{ $values { "words" "a sequence of new words to define" } } +{ $description "Creates a new word for every token until the ';'." } +{ $examples { $example "USING: prettyprint symbols ;" "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } } +{ $see-also POSTPONE: SYMBOL: } ; diff --git a/extra/symbols/symbols-tests.factor b/extra/symbols/symbols-tests.factor new file mode 100644 index 0000000000..84a61509c8 --- /dev/null +++ b/extra/symbols/symbols-tests.factor @@ -0,0 +1,7 @@ +USING: kernel symbols tools.test ; +IN: symbols.tests + +[ ] [ SYMBOLS: a b c ; ] unit-test +[ a ] [ a ] unit-test +[ b ] [ b ] unit-test +[ c ] [ c ] unit-test diff --git a/extra/symbols/symbols.factor b/extra/symbols/symbols.factor new file mode 100644 index 0000000000..8e074f4163 --- /dev/null +++ b/extra/symbols/symbols.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser sequences words ; +IN: symbols + +: SYMBOLS: + ";" parse-tokens [ create-in define-symbol ] each ; + parsing diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index d92b4bd48b..06e9644370 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,7 +1,7 @@ USING: combinators io io.files io.streams.duplex io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences strings system -hexdump tools.interpreter ; +hexdump io.encodings.binary ; IN: tar : zero-checksum 256 ; @@ -94,7 +94,7 @@ TUPLE: unimplemented-typeflag header ; ! Normal file : typeflag-0 - tar-header-name tar-path+ + tar-header-name tar-path+ binary [ read-data-blocks ] keep dispose ; ! Hard link @@ -236,7 +236,7 @@ TUPLE: unimplemented-typeflag header ; ] when* ; : parse-tar ( path -- obj ) - [ + binary [ "tar-test" resource-path base-dir set global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind 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/tetris/tetris.factor b/extra/tetris/tetris.factor index 78f3f8f0f7..02f8f240d2 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ui.gadgets ui.gadgets.labels ui.gadgets.worlds -ui.gadgets.status-bar ui.gestures ui.render ui tetris.game -tetris.gl sequences arrays math math.parser namespaces timers ; +USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels +ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui +tetris.game tetris.gl sequences system math math.parser namespaces ; IN: tetris -TUPLE: tetris-gadget tetris ; +TUPLE: tetris-gadget tetris alarm ; : ( tetris -- gadget ) tetris-gadget construct-gadget @@ -41,14 +41,15 @@ tetris-gadget H{ { T{ key-down f f "n" } [ new-tetris ] } } set-gestures -M: tetris-gadget tick ( object -- ) +: tick ( gadget -- ) dup tetris-gadget-tetris maybe-update relayout-1 ; M: tetris-gadget graft* ( gadget -- ) - 100 1 add-timer ; + dup [ tick ] curry 100 milliseconds from-now 100 milliseconds add-alarm + swap set-tetris-gadget-alarm ; M: tetris-gadget ungraft* ( gadget -- ) - remove-timer ; + [ tetris-gadget-alarm cancel-alarm f ] keep set-tetris-gadget-alarm ; : tetris-window ( -- ) [ diff --git a/extra/timers/summary.txt b/extra/timers/summary.txt deleted file mode 100644 index 2b0c0b053f..0000000000 --- a/extra/timers/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Simple low-resolution timers diff --git a/extra/timers/timers-docs.factor b/extra/timers/timers-docs.factor deleted file mode 100644 index 05a52516ff..0000000000 --- a/extra/timers/timers-docs.factor +++ /dev/null @@ -1,36 +0,0 @@ -USING: help.syntax help.markup classes kernel ; -IN: timers - -HELP: init-timers -{ $description "Initializes the timer code." } -{ $notes "This word is automatically called when the UI is initialized, and it should only be called manually if timers are being used outside of the UI." } ; - -HELP: tick -{ $values { "object" object } } -{ $description "Called to notify an object registered with a timer that the timer has fired." } ; - -HELP: add-timer -{ $values { "object" object } { "delay" "a positive integer" } { "initial" "a positive integer" } } -{ $description "Registers a timer. Every " { $snippet "delay" } " milliseconds, " { $link tick } " will be called on the object. The initial delay from the time " { $link add-timer } " is called to when " { $link tick } " is first called is " { $snippet "initial" } " milliseconds." } ; - -HELP: remove-timer -{ $values { "object" object } } -{ $description "Unregisters a timer." } ; - -HELP: do-timers -{ $description "Fires all registered timers which are due to fire." } -{ $notes "This word is automatically called from the UI event loop, and it should only be called manually if timers are being used outside of the UI." } ; - -{ init-timers add-timer remove-timer tick do-timers } related-words - -ARTICLE: "timers" "Timers" -"Timers can be added and removed:" -{ $subsection add-timer } -{ $subsection remove-timer } -"Classes must implement a generic word so that their instances can handle timer ticks:" -{ $subsection tick } -"Timers can be used outside of the UI, however they must be initialized with an explicit call, and fired manually:" -{ $subsection init-timers } -{ $subsection do-timers } ; - -ABOUT: "timers" diff --git a/extra/timers/timers.factor b/extra/timers/timers.factor deleted file mode 100644 index e3a510287b..0000000000 --- a/extra/timers/timers.factor +++ /dev/null @@ -1,30 +0,0 @@ -! Copyright (C) 2005, 2006 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math namespaces sequences system ; -IN: timers - -TUPLE: timer object delay next ; - -: ( object delay initial -- timer ) - millis + timer construct-boa ; - -GENERIC: tick ( object -- ) - -: timers \ timers get-global ; - -: init-timers ( -- ) H{ } clone \ timers set-global ; - -: add-timer ( object delay initial -- ) - pick >r r> timers set-at ; - -: remove-timer ( object -- ) timers delete-at ; - -: advance-timer ( ms timer -- ) - [ timer-delay + ] keep set-timer-next ; - -: do-timer ( ms timer -- ) - dup timer-next pick <= - [ [ advance-timer ] keep timer-object tick ] [ 2drop ] if ; - -: do-timers ( -- ) - millis timers values [ do-timer ] with each ; diff --git a/extra/tools/annotations/annotations-tests.factor b/extra/tools/annotations/annotations-tests.factor index 90d9d26f51..ec8f48a161 100755 --- a/extra/tools/annotations/annotations-tests.factor +++ b/extra/tools/annotations/annotations-tests.factor @@ -1,5 +1,5 @@ USING: tools.test tools.annotations math parser ; -IN: temporary +IN: tools.annotations.tests : foo ; \ foo watch @@ -17,7 +17,7 @@ M: integer some-generic 1+ ; [ 4 ] [ 3 some-generic ] unit-test -[ ] [ "IN: temporary USE: math M: integer some-generic 1- ;" eval ] unit-test +[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test [ 2 ] [ 3 some-generic ] unit-test diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index eed23e8bc1..07038ceadf 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words parser io inspector quotations sequences prettyprint continuations effects definitions compiler.units -namespaces assocs ; +namespaces assocs tools.walker ; IN: tools.annotations : reset ( word -- ) @@ -61,7 +61,7 @@ IN: tools.annotations dupd [ (watch-vars) ] 2curry annotate ; : breakpoint ( word -- ) - [ \ break add* ] annotate ; + [ add-breakpoint ] annotate ; : breakpoint-if ( word quot -- ) [ [ [ break ] when ] rot 3append ] curry annotate ; diff --git a/extra/tools/browser/browser-tests.factor b/extra/tools/browser/browser-tests.factor index fc7960e475..38d9ae65e2 100755 --- a/extra/tools/browser/browser-tests.factor +++ b/extra/tools/browser/browser-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.browser.tests USING: tools.browser tools.test help.markup ; [ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index e9aaa190dc..c189a6f9de 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -2,23 +2,22 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces splitting sequences io.files kernel assocs words vocabs vocabs.loader definitions parser continuations -inspector debugger io io.styles io.streams.lines hashtables +inspector debugger io io.styles hashtables sorting prettyprint source-files arrays combinators strings system math.parser help.markup help.topics help.syntax -help.stylesheet memoize ; +help.stylesheet memoize io.encodings.utf8 ; IN: tools.browser MEMO: (vocab-file-contents) ( path -- lines ) ?resource-path dup exists? - [ file-lines ] [ drop f ] if ; + [ utf8 file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) vocab-path+ dup [ (vocab-file-contents) ] when ; : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-path+ [ - ?resource-path - [ [ print ] each ] with-file-writer + ?resource-path utf8 set-file-lines ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" diff --git a/extra/tools/completion/completion-docs.factor b/extra/tools/completion/completion-docs.factor index 7683ef1ca1..4d7154fb2d 100644 --- a/extra/tools/completion/completion-docs.factor +++ b/extra/tools/completion/completion-docs.factor @@ -24,7 +24,7 @@ HELP: runs { $values { "seq" "a sequence of integers" } { "newseq" "a sequence of sequences of integers" } } { $description "Groups subsequences of consecutive integers." } { $examples - { $example "USE: tools.completion" "{ 1 2 3 5 6 9 10 } runs ." "V{ V{ 1 2 3 } V{ 5 6 } V{ 9 10 } }" } + { $example "USING: prettyprint tools.completion ;" "{ 1 2 3 5 6 9 10 } runs ." "V{ V{ 1 2 3 } V{ 5 6 } V{ 9 10 } }" } } ; HELP: score diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor old mode 100644 new mode 100755 index 657b5fc030..0717763ed0 --- a/extra/tools/crossref/crossref-tests.factor +++ b/extra/tools/crossref/crossref-tests.factor @@ -1,12 +1,12 @@ USING: math kernel sequences io.files tools.crossref tools.test -parser namespaces source-files ; -IN: temporary +parser namespaces source-files generic definitions ; +IN: tools.crossref.tests GENERIC: foo M: integer foo + ; -"resource:extra/tools/test/foo.factor" run-file +"resource:extra/tools/crossref/test/foo.factor" run-file -[ t ] [ { integer foo } \ + smart-usage member? ] unit-test -[ t ] [ \ foo smart-usage [ pathname? ] contains? ] unit-test +[ t ] [ integer \ foo method \ + usage member? ] unit-test +[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor index f6561e9f26..f4515a9ebe 100755 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -6,14 +6,8 @@ generic tools.completion quotations parser inspector sorting hashtables vocabs parser source-files ; IN: tools.crossref -: synopsis-alist ( definitions -- alist ) - [ dup synopsis swap ] { } map>assoc ; - -: definitions. ( alist -- ) - [ write-object nl ] assoc-each ; - : usage. ( word -- ) - smart-usage synopsis-alist sort-keys definitions. ; + usage sorted-definitions. ; : words-matching ( str -- seq ) all-words [ dup word-name ] { } map>assoc completions ; diff --git a/extra/tools/test/foo.factor b/extra/tools/crossref/test/foo.factor old mode 100644 new mode 100755 similarity index 50% rename from extra/tools/test/foo.factor rename to extra/tools/crossref/test/foo.factor index 944a25cf5e..f7bc321912 --- a/extra/tools/test/foo.factor +++ b/extra/tools/crossref/test/foo.factor @@ -1,4 +1,4 @@ -USE: temporary +USE: tools.crossref.tests USE: kernel 1 2 foo drop diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 2439ef8636..301ffa3378 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -6,7 +6,7 @@ continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.streams.duplex io.files io.backend quotations io.launcher words.private tools.deploy.config -bootstrap.image ; +bootstrap.image io.encodings.utf8 accessors ; IN: tools.deploy.backend : (copy-lines) ( stream -- ) @@ -17,13 +17,13 @@ IN: tools.deploy.backend [ (copy-lines) ] with-disposal ; : run-with-output ( arguments -- ) - [ - +arguments+ set - +stdout+ +stderr+ set - ] H{ } make-assoc - dup duplex-stream-out dispose + + swap >>command + +stdout+ >>stderr + +closed+ >>stdin + utf8 dup copy-lines - process-stream-process wait-for-process zero? [ + process>> wait-for-process zero? [ "Deployment failed" throw ] unless ; @@ -61,7 +61,7 @@ IN: tools.deploy.backend ] { } make ; : run-factor ( vm flags -- ) - dup . swap add* run-with-output ; inline + swap add* dup . run-with-output ; inline : make-staging-image ( vm config -- ) staging-command-line run-factor ; 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..6db19cf868 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -1,38 +1,26 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files io.launcher kernel namespaces sequences +USING: io io.files kernel namespaces sequences system tools.deploy.backend tools.deploy.config assocs -hashtables prettyprint io.unix.backend cocoa +hashtables prettyprint io.unix.backend cocoa io.encodings.utf8 cocoa.application cocoa.classes cocoa.plists qualified ; -QUALIFIED: unix 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 -- ) +: copy-bundle-dir ( bundle-name dir -- ) bundle-dir over path+ -rot - >r "Contents" path+ r> path+ copy-directory ; - -: chmod ( path perms -- ) - unix:chmod io-error ; + "Contents" swap path+ 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-into ; -: print-app-plist ( executable bundle-name -- ) +: app-plist ( executable bundle-name -- string ) [ namespace { { "CFBundleInfoDictionaryVersion" "6.0" } @@ -43,11 +31,12 @@ IN: tools.deploy.macosx dup "CFBundleExecutable" set "org.factor." swap append "CFBundleIdentifier" set - ] H{ } make-assoc print-plist ; + ] H{ } make-assoc plist>string ; : create-app-plist ( vocab bundle-name -- ) - dup "Contents/Info.plist" path+ - [ print-app-plist ] with-stream ; + [ app-plist ] keep + "Contents/Info.plist" path+ + utf8 set-file-contents ; : create-app-dir ( vocab bundle-name -- vm ) dup "Frameworks" copy-bundle-dir @@ -75,7 +64,7 @@ M: macosx-deploy-implementation deploy* ( vocab -- ) ".app deploy tool" assert.app "." resource-path cd dup deploy-config [ - bundle-name rm + bundle-name dup exists? [ delete-tree ] [ drop ] if [ 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..2fa882ff68 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -2,12 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax io.launcher system assocs arrays sequences namespaces qualified -system math generator.fixup ; +system math generator.fixup io.encodings.ascii accessors ; 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 -- ) @@ -15,7 +15,7 @@ M: word make-disassemble-cmd word-xt code-format - 2array make-disassemble-cmd ; M: pair make-disassemble-cmd - in-file [ + in-file ascii [ "attach " write current-process-handle number>string print "disassemble " write @@ -23,16 +23,16 @@ M: pair make-disassemble-cmd ] with-file-writer ; : run-gdb ( -- lines ) - [ - +closed+ +stdin+ set - out-file +stdout+ set - [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set - ] { } make-assoc run-process drop - out-file file-lines ; + + +closed+ >>stdin + out-file >>stdout + [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command + try-process + out-file ascii file-lines ; : tabs>spaces ( str -- str' ) { { CHAR: \t CHAR: \s } } substitute ; -: disassemble ( word -- ) +: disassemble ( obj -- ) make-disassemble-cmd run-gdb [ tabs>spaces ] map [ print ] each ; diff --git a/extra/tools/interpreter/debug/debug.factor b/extra/tools/interpreter/debug/debug.factor deleted file mode 100644 index 438734773f..0000000000 --- a/extra/tools/interpreter/debug/debug.factor +++ /dev/null @@ -1,31 +0,0 @@ -! Copyright (C) 2004, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.interpreter kernel arrays continuations threads -sequences namespaces ; -IN: tools.interpreter.debug - -: run-interpreter ( interpreter -- ) - dup interpreter-continuation [ - dup step-into run-interpreter - ] [ - drop - ] if ; - -: quot>cont ( quot -- cont ) - [ - swap [ - continue-with - ] curry callcc0 call stop - ] curry callcc1 ; - -: init-interpreter ( quot interpreter -- ) - >r - [ datastack "datastack" set ] compose quot>cont - f swap 2array - r> restore ; - -: test-interpreter ( quot -- ) - - [ init-interpreter ] keep - run-interpreter - "datastack" get ; diff --git a/extra/tools/interpreter/interpreter-docs.factor b/extra/tools/interpreter/interpreter-docs.factor deleted file mode 100644 index cb4b207fd9..0000000000 --- a/extra/tools/interpreter/interpreter-docs.factor +++ /dev/null @@ -1,54 +0,0 @@ -USING: help.markup help.syntax kernel generic -math hashtables quotations classes continuations ; -IN: tools.interpreter - -ARTICLE: "meta-interpreter" "Meta-circular interpreter" -"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "." -$nl -"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section." -$nl -"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary." -$nl -"Breakpoints can be inserted in user code:" -{ $subsection break } -"Breakpoints invoke a hook:" -{ $subsection break-hook } -"Single stepping with the meta-circular interpreter:" -{ $subsection step } -{ $subsection step-into } -{ $subsection step-out } -{ $subsection step-all } ; - -ABOUT: "meta-interpreter" - -HELP: interpreter -{ $class-description "An interpreter instance." } ; - -HELP: step -{ $values { "interpreter" interpreter } } -{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:" - { $list - { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" } - { "If the object is a word, then the word is executed in the single stepper's continuation atomically" } - { "Otherwise, the object is pushed on the single stepper's data stack" } - } -} ; - -HELP: step-into -{ $values { "interpreter" interpreter } } -{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:" - { $list - { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" } - { "If the object is a compound word, then the single stepper enters the word definition" } - { "If the object is a primitive word or a word with special single stepper behavior, it is executed in the single stepper's continuation atomically" } - { "Otherwise, the object is pushed on the single stepper's data stack" } - } -} ; - -HELP: step-out -{ $values { "interpreter" interpreter } } -{ $description "Evaluates the remainder of the current quotation in the single stepper." } ; - -HELP: step-all -{ $values { "interpreter" interpreter } } -{ $description "Executes the remainder of the single stepper's continuation. This effectively ends single stepping unless the continuation invokes " { $link break } " at a later point in time." } ; diff --git a/extra/tools/interpreter/interpreter-tests.factor b/extra/tools/interpreter/interpreter-tests.factor deleted file mode 100755 index 644f83c2ca..0000000000 --- a/extra/tools/interpreter/interpreter-tests.factor +++ /dev/null @@ -1,113 +0,0 @@ -USING: tools.interpreter io io.streams.string kernel math -math.private namespaces prettyprint sequences tools.test -continuations math.parser threads arrays -tools.interpreter.private tools.interpreter.debug ; -IN: temporary - -[ "Ooops" throw ] break-hook set - -[ { } ] [ - [ ] test-interpreter -] unit-test - -[ { 1 } ] [ - [ 1 ] test-interpreter -] unit-test - -[ { 1 2 3 } ] [ - [ 1 2 3 ] test-interpreter -] unit-test - -[ { "Yo" 2 } ] [ - [ 2 >r "Yo" r> ] test-interpreter -] unit-test - -[ { 2 } ] [ - [ t [ 2 ] [ "hi" ] if ] test-interpreter -] unit-test - -[ { "hi" } ] [ - [ f [ 2 ] [ "hi" ] if ] test-interpreter -] unit-test - -[ { 4 } ] [ - [ 2 2 fixnum+ ] test-interpreter -] unit-test - -: foo 2 2 fixnum+ ; - -[ { 8 } ] [ - [ foo 4 fixnum+ ] test-interpreter -] unit-test - -[ { C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [ - [ C{ 1 1.5 } { } 2dup ] test-interpreter -] unit-test - -[ { t } ] [ - [ 5 5 number= ] test-interpreter -] unit-test - -[ { f } ] [ - [ 5 6 number= ] test-interpreter -] unit-test - -[ { f } ] [ - [ "XYZ" "XYZ" mismatch ] test-interpreter -] unit-test - -[ { t } ] [ - [ "XYZ" "XYZ" sequence= ] test-interpreter -] unit-test - -[ { t } ] [ - [ "XYZ" "XYZ" = ] test-interpreter -] unit-test - -[ { f } ] [ - [ "XYZ" "XuZ" = ] test-interpreter -] unit-test - -[ { 4 } ] [ - [ 2 2 + ] test-interpreter -] unit-test - -[ { } 2 ] [ - 2 "x" set [ [ 3 "x" set ] with-scope ] test-interpreter "x" get -] unit-test - -[ { 3 } ] [ - [ 3 "x" set "x" get ] test-interpreter -] unit-test - -[ { "hi\n" } ] [ - [ [ "hi" print ] with-string-writer ] test-interpreter -] unit-test - -[ { "4\n" } ] [ - [ [ 2 2 + number>string print ] with-string-writer ] test-interpreter -] unit-test - -[ { 1 2 3 } ] [ - [ { 1 2 3 } set-datastack ] test-interpreter -] unit-test - -[ { 6 } ] -[ [ 3 [ nip continue ] callcc0 2 * ] test-interpreter ] unit-test - -[ { 6 } ] -[ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test - -[ { } ] -[ [ [ ] [ ] recover ] test-interpreter ] unit-test - -[ { 6 } ] -[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test - -[ { "{ 1 2 3 }\n" } ] [ - [ [ { 1 2 3 } . ] with-string-writer ] test-interpreter -] unit-test - -[ { } ] [ - [ "a" "b" set "c" "d" set [ ] test-interpreter ] with-scope -] unit-test diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor deleted file mode 100755 index 3be832aec8..0000000000 --- a/extra/tools/interpreter/interpreter.factor +++ /dev/null @@ -1,117 +0,0 @@ -! Copyright (C) 2004, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs classes combinators sequences.private -continuations continuations.private generic hashtables io kernel -kernel.private math namespaces namespaces.private prettyprint -quotations sequences splitting strings threads -vectors words ; -IN: tools.interpreter - -: walk ( quot -- ) \ break add* call ; - -TUPLE: interpreter continuation ; - -: interpreter construct-empty ; - -GENERIC# restore 1 ( obj interpreter -- ) - -M: f restore - set-interpreter-continuation ; - -M: continuation restore - >r clone r> set-interpreter-continuation ; - -: with-interpreter-datastack ( quot interpreter -- ) - interpreter-continuation [ - continuation-data - swap with-datastack - ] keep set-continuation-data ; inline - -M: pair restore - >r first2 r> [ restore ] keep - >r [ nip f ] curry r> with-interpreter-datastack ; - -n ndrop >c c> - continue continue-with - (continue-with) stop -} [ - dup [ execute break ] curry - "step-into" set-word-prop -] each - -\ break [ break ] "step-into" set-word-prop - -! Stepping -: change-innermost-frame ( quot interpreter -- ) - interpreter-continuation [ - continuation-call clone - [ - dup innermost-frame-scan 1+ - swap innermost-frame-quot - rot call - ] keep - [ set-innermost-frame-quot ] keep - ] keep set-continuation-call ; inline - -: (step) ( interpreter quot -- ) - swap - [ change-innermost-frame ] keep - [ interpreter-continuation with-walker-hook ] keep - restore ; - -PRIVATE> - -: step ( interpreter -- ) - [ - 2dup nth \ break = [ - nip - ] [ - swap 1+ cut [ break ] swap 3append - ] if - ] (step) ; - -: step-out ( interpreter -- ) - [ nip \ break add ] (step) ; - -: step-into ( interpreter -- ) - [ - swap cut [ - swap % unclip literalize , \ (step-into) , % - ] [ ] make - ] (step) ; - -: step-all ( interpreter -- ) - interpreter-continuation [ (continue) ] curry in-thread ; diff --git a/extra/tools/interpreter/summary.txt b/extra/tools/interpreter/summary.txt deleted file mode 100644 index 242b9cbbd1..0000000000 --- a/extra/tools/interpreter/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Meta-circular interpreter and single-stepper support diff --git a/extra/tools/memory/memory-tests.factor b/extra/tools/memory/memory-tests.factor index 36bcc73b74..9efbf63f7f 100644 --- a/extra/tools/memory/memory-tests.factor +++ b/extra/tools/memory/memory-tests.factor @@ -1,4 +1,4 @@ USING: tools.test tools.memory ; -IN: temporary +IN: tools.memory.tests [ ] [ heap-stats. ] unit-test diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor index c346d9763c..e33201e22c 100755 --- a/extra/tools/profiler/profiler-tests.factor +++ b/extra/tools/profiler/profiler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.profiler.tests USING: tools.profiler tools.test kernel memory math threads alien tools.profiler.private sequences ; diff --git a/extra/tools/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..a605543bda 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" } ; @@ -89,6 +89,6 @@ HELP: run-all-tests { $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } { $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; -HELP: failure. -{ $values { "failures" "an association list of unit test failures" } } +HELP: test-failures. +{ $values { "assoc" "an association list of unit test failures" } } { $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to the " { $link stdio } " stream." } ; 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 70a94cb910..552247e2c4 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -2,18 +2,27 @@ ! See http://factorcode.org/license.txt for BSD license. IN: tools.threads USING: threads kernel prettyprint prettyprint.config -io io.styles sequences assocs namespaces sorting boxes ; +io io.styles sequences assocs namespaces sorting boxes +heaps.private system math math.parser ; : thread. ( thread -- ) dup thread-id pprint-cell - dup thread-name pprint-cell - thread-state [ "Waiting for " swap append ] [ "Running" ] if* - [ write ] with-cell ; + dup thread-name over [ write-object ] with-cell + dup thread-state [ + [ dup self eq? "running" "yield" ? ] unless* + write + ] with-cell + [ + thread-sleep-entry [ + entry-key millis [-] number>string write + " ms" write + ] when* + ] with-cell ; : threads. ( -- ) standard-table-style [ [ - { "ID" "Name" "State" } + { "ID" "Name" "Waiting on" "Remaining sleep" } [ [ write ] with-cell ] each ] with-row diff --git a/core/io/streams/lines/authors.txt b/extra/tools/walker/authors.txt similarity index 100% rename from core/io/streams/lines/authors.txt rename to extra/tools/walker/authors.txt diff --git a/extra/http/server/responders/authors.txt b/extra/tools/walker/debug/authors.txt similarity index 100% rename from extra/http/server/responders/authors.txt rename to extra/tools/walker/debug/authors.txt diff --git a/extra/tools/walker/debug/debug.factor b/extra/tools/walker/debug/debug.factor new file mode 100755 index 0000000000..c8c0ff28a6 --- /dev/null +++ b/extra/tools/walker/debug/debug.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.promises models tools.walker kernel +sequences concurrency.messaging locals continuations +threads namespaces namespaces.private ; +IN: tools.walker.debug + +:: test-walker ( quot -- data ) + [let | p [ ] + s [ f ] + c [ f ] | + [ + H{ } clone >n + [ s c start-walker-thread p fulfill ] new-walker-hook set + [ drop ] show-walker-hook set + + break + + quot call + ] "Walker test" spawn drop + + step-into-all + p ?promise + send-synchronous drop + + detach + p ?promise + send-synchronous drop + + c model-value continuation-data + ] ; diff --git a/extra/tools/walker/summary.txt b/extra/tools/walker/summary.txt new file mode 100644 index 0000000000..d595bf34cf --- /dev/null +++ b/extra/tools/walker/summary.txt @@ -0,0 +1 @@ +Single-stepper for walking through code diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor new file mode 100755 index 0000000000..2d4a6c3396 --- /dev/null +++ b/extra/tools/walker/walker-tests.factor @@ -0,0 +1,102 @@ +USING: tools.walker io io.streams.string kernel math +math.private namespaces prettyprint sequences tools.test +continuations math.parser threads arrays tools.walker.debug ; +IN: tools.walker.tests + +[ { } ] [ + [ ] test-walker +] unit-test + +[ { 1 } ] [ + [ 1 ] test-walker +] unit-test + +[ { 1 2 3 } ] [ + [ 1 2 3 ] test-walker +] unit-test + +[ { "Yo" 2 } ] [ + [ 2 >r "Yo" r> ] test-walker +] unit-test + +[ { 2 } ] [ + [ t [ 2 ] [ "hi" ] if ] test-walker +] unit-test + +[ { "hi" } ] [ + [ f [ 2 ] [ "hi" ] if ] test-walker +] unit-test + +[ { 4 } ] [ + [ 2 2 fixnum+ ] test-walker +] unit-test + +: foo 2 2 fixnum+ ; + +[ { 8 } ] [ + [ foo 4 fixnum+ ] test-walker +] unit-test + +[ { C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [ + [ C{ 1 1.5 } { } 2dup ] test-walker +] unit-test + +[ { t } ] [ + [ 5 5 number= ] test-walker +] unit-test + +[ { f } ] [ + [ 5 6 number= ] test-walker +] unit-test + +[ { f } ] [ + [ "XYZ" "XYZ" mismatch ] test-walker +] unit-test + +[ { t } ] [ + [ "XYZ" "XYZ" sequence= ] test-walker +] unit-test + +[ { t } ] [ + [ "XYZ" "XYZ" = ] test-walker +] unit-test + +[ { f } ] [ + [ "XYZ" "XuZ" = ] test-walker +] unit-test + +[ { 4 } ] [ + [ 2 2 + ] test-walker +] unit-test + +[ { 3 } ] [ + [ [ 3 "x" set "x" get ] with-scope ] test-walker +] unit-test + +[ { "hi\n" } ] [ + [ [ "hi" print ] with-string-writer ] test-walker +] unit-test + +[ { "4\n" } ] [ + [ [ 2 2 + number>string print ] with-string-writer ] test-walker +] unit-test + +[ { 1 2 3 } ] [ + [ { 1 2 3 } set-datastack ] test-walker +] unit-test + +[ { 6 } ] +[ [ 3 [ nip continue ] callcc0 2 * ] test-walker ] unit-test + +[ { 6 } ] +[ [ [ 3 swap continue-with ] callcc1 2 * ] test-walker ] unit-test + +[ { } ] +[ [ [ ] [ ] recover ] test-walker ] unit-test + +[ { 6 } ] +[ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test + +[ { } ] [ + [ "a" "b" set "c" "d" set [ ] test-walker ] with-scope +] unit-test diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor new file mode 100755 index 0000000000..e86cee0c47 --- /dev/null +++ b/extra/tools/walker/walker.factor @@ -0,0 +1,260 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: threads kernel namespaces continuations combinators +sequences math namespaces.private continuations.private +concurrency.messaging quotations kernel.private words +sequences.private assocs models ; +IN: tools.walker + +SYMBOL: new-walker-hook ! ( -- ) +SYMBOL: show-walker-hook ! ( thread -- ) + +! Thread local +SYMBOL: walker-thread +SYMBOL: walking-thread + +: get-walker-thread ( -- thread ) + walker-thread tget [ + dup show-walker-hook get call + ] [ + new-walker-hook get call + walker-thread tget + ] if* ; + +: break ( -- ) + continuation callstack over set-continuation-call + + get-walker-thread send-synchronous { + { [ dup continuation? ] [ (continue) ] } + { [ dup quotation? ] [ call ] } + { [ dup not ] [ "Single stepping abandoned" throw ] } + } cond ; + +\ break t "break?" set-word-prop + +: walk ( quot -- quot' ) + \ break add* [ break rethrow ] recover ; + +: add-breakpoint ( quot -- quot' ) + dup [ break ] head? [ \ break add* ] unless ; + +: (step-into-quot) ( quot -- ) add-breakpoint call ; + +: (step-into-if) ? (step-into-quot) ; + +: (step-into-dispatch) nth (step-into-quot) ; + +: (step-into-execute) ( word -- ) + dup "step-into" word-prop [ + call + ] [ + dup primitive? [ + execute break + ] [ + word-def (step-into-quot) + ] if + ] ?if ; + +\ (step-into-execute) t "step-into?" set-word-prop + +: (step-into-continuation) + continuation callstack over set-continuation-call break ; + +! Messages sent to walker thread +SYMBOL: step +SYMBOL: step-out +SYMBOL: step-into +SYMBOL: step-all +SYMBOL: step-into-all +SYMBOL: step-back +SYMBOL: detach +SYMBOL: abandon +SYMBOL: call-in + +! Thread locals +SYMBOL: walker-status +SYMBOL: walker-continuation +SYMBOL: walker-history + +SYMBOL: +running+ +SYMBOL: +suspended+ +SYMBOL: +stopped+ +SYMBOL: +detached+ + +: change-frame ( continuation quot -- continuation' ) + #! Applies quot to innermost call frame of the + #! continuation. + >r clone r> + over continuation-call clone + [ + dup innermost-frame-scan 1+ + swap innermost-frame-quot + rot call + ] keep + [ set-innermost-frame-quot ] keep + over set-continuation-call ; inline + +: step-msg ( continuation -- continuation' ) + [ + 2dup nth \ break = [ + nip + ] [ + swap 1+ cut [ break ] swap 3append + ] if + ] change-frame ; + +: step-out-msg ( continuation -- continuation' ) + [ nip \ break add ] change-frame ; + +{ + { call [ (step-into-quot) ] } + { (throw) [ drop (step-into-quot) ] } + { execute [ (step-into-execute) ] } + { if [ (step-into-if) ] } + { dispatch [ (step-into-dispatch) ] } + { continuation [ (step-into-continuation) ] } +} [ "step-into" set-word-prop ] assoc-each + +{ + >n ndrop >c c> + continue continue-with + stop yield suspend sleep (spawn) + suspend +} [ + dup [ execute break ] curry + "step-into" set-word-prop +] each + +\ break [ break ] "step-into" set-word-prop + +: step-into-msg ( continuation -- continuation' ) + [ + swap cut [ + swap % unclip { + { [ dup \ break eq? ] [ , ] } + { [ dup quotation? ] [ add-breakpoint , \ break , ] } + { [ dup word? ] [ literalize , \ (step-into-execute) , ] } + { [ t ] [ , \ break , ] } + } cond % + ] [ ] make + ] change-frame ; + +: status ( -- symbol ) + walker-status tget model-value ; + +: set-status ( symbol -- ) + walker-status tget set-model ; + +: unassociate-thread ( -- ) + walker-thread walking-thread tget thread-variables delete-at + [ ] walking-thread tget set-thread-exit-handler ; + +: detach-msg ( -- ) + +detached+ set-status + unassociate-thread ; + +: keep-running ( -- ) + +running+ set-status ; + +: walker-stopped ( -- ) + +stopped+ set-status + [ status +stopped+ eq? ] [ + [ + { + { detach [ detach-msg ] } + [ drop ] + } case f + ] handle-synchronous + ] [ ] while ; + +: step-into-all-loop ( -- ) + +running+ set-status + [ status +running+ eq? ] [ + [ + { + { detach [ detach-msg f ] } + { step [ f ] } + { step-out [ f ] } + { step-into [ f ] } + { step-all [ f ] } + { step-into-all [ f ] } + { step-back [ f ] } + { f [ +stopped+ set-status f ] } + [ + dup walker-continuation tget set-model + step-into-msg + ] + } case + ] handle-synchronous + ] [ ] while ; + +: step-back-msg ( continuation -- continuation' ) + walker-history tget dup pop* + empty? [ drop walker-history tget pop ] unless ; + +: walker-suspended ( continuation -- continuation' ) + +suspended+ set-status + [ status +suspended+ eq? ] [ + dup walker-history tget push + dup walker-continuation tget set-model + [ + { + ! These are sent by the walker tool. We reply + ! and keep cycling. + { detach [ detach-msg ] } + ! These change the state of the thread being + ! interpreted, so we modify the continuation and + ! output f. + { step [ step-msg keep-running ] } + { step-out [ step-out-msg keep-running ] } + { step-into [ step-into-msg keep-running ] } + { step-all [ keep-running ] } + { step-into-all [ step-into-all-loop ] } + { abandon [ drop f keep-running ] } + ! Pass quotation to debugged thread + { call-in [ nip keep-running ] } + ! Pass previous continuation to debugged thread + { step-back [ step-back-msg ] } + } case f + ] handle-synchronous + ] [ ] while ; + +: walker-loop ( -- ) + +running+ set-status + [ status +detached+ eq? not ] [ + [ + { + { detach [ detach-msg f ] } + ! ignore these commands while the thread is + ! running + { step [ f ] } + { step-out [ f ] } + { step-into [ f ] } + { step-all [ f ] } + { step-into-all [ step-into-all-loop f ] } + { step-back [ f ] } + { abandon [ f ] } + { f [ walker-stopped f ] } + ! thread hit a breakpoint and sent us the + ! continuation, so we modify it and send it + ! back. + [ walker-suspended ] + } case + ] handle-synchronous + ] [ ] while ; + +: associate-thread ( walker -- ) + walker-thread tset + [ f walker-thread tget send-synchronous drop ] + self set-thread-exit-handler ; + +: start-walker-thread ( status continuation -- thread' ) + self [ + walking-thread tset + walker-continuation tset + walker-status tset + V{ } clone walker-history tset + walker-loop + ] 3curry + "Walker on " self thread-name append spawn + [ associate-thread ] keep ; diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index 0964ea7e56..570125cb45 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test trees trees.avl math random sequences assocs ; -IN: temporary +IN: trees.avl.tests [ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor old mode 100644 new mode 100755 index a806dafdec..81628684bc --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -53,14 +53,14 @@ TUPLE: avl-node balance ; DEFER: avl-set : avl-insert ( value key node -- node taller? ) - 2dup node-key key< left right ? [ + 2dup node-key before? left right ? [ [ node-link avl-set ] keep swap >r tuck set-node-link r> [ dup current-side get change-balance balance-insert ] [ f ] if ] with-side ; : (avl-set) ( value key node -- node taller? ) - 2dup node-key key= [ + 2dup node-key = [ -rot pick set-node-key over set-node-value f ] [ avl-insert ] if ; diff --git a/extra/trees/splay/splay-docs.factor b/extra/trees/splay/splay-docs.factor index 1c49febe01..253d3f4aec 100644 --- a/extra/trees/splay/splay-docs.factor +++ b/extra/trees/splay/splay-docs.factor @@ -11,7 +11,7 @@ HELP: { $description "Creates an empty splay tree" } ; HELP: >splay -{ $values { "assoc" assoc } { "splay" splay } } +{ $values { "assoc" assoc } { "tree" splay } } { $description "Converts any " { $link assoc } " into an splay tree." } ; HELP: splay 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/splay/splay.factor b/extra/trees/splay/splay.factor index 2fca5eca95..7746db85d3 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -6,7 +6,7 @@ IN: trees.splay TUPLE: splay ; -: ( -- splay-tree ) +: ( -- tree ) \ splay construct-tree ; INSTANCE: splay tree-mixin @@ -130,7 +130,7 @@ M: splay delete-at ( key tree -- ) M: splay new-assoc 2drop ; -: >splay ( assoc -- splay-tree ) +: >splay ( assoc -- tree ) T{ splay T{ tree f f 0 } } assoc-clone-like ; : SPLAY{ 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/triggers/authors.txt b/extra/triggers/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/triggers/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/triggers/summary.txt b/extra/triggers/summary.txt new file mode 100644 index 0000000000..34353dc799 --- /dev/null +++ b/extra/triggers/summary.txt @@ -0,0 +1 @@ +triggers allow you to register code to be 'triggered' diff --git a/extra/triggers/triggers-tests.factor b/extra/triggers/triggers-tests.factor new file mode 100644 index 0000000000..744a4b13a7 --- /dev/null +++ b/extra/triggers/triggers-tests.factor @@ -0,0 +1,14 @@ +USING: triggers kernel tools.test ; +IN: triggers.tests + +SYMBOL: test-trigger +test-trigger reset-trigger +: add-test-trigger test-trigger add-trigger ; +[ ] [ test-trigger call-trigger ] unit-test +[ "op called" ] [ "op" [ "op called" ] add-test-trigger test-trigger call-trigger ] unit-test +[ "first called" "second called" ] [ + test-trigger reset-trigger + "second op" [ "second called" ] add-test-trigger + "first op" [ "first called" ] add-test-trigger + test-trigger call-trigger +] unit-test diff --git a/extra/triggers/triggers.factor b/extra/triggers/triggers.factor new file mode 100644 index 0000000000..ffdfe373cd --- /dev/null +++ b/extra/triggers/triggers.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: assocs digraphs kernel namespaces sequences ; +IN: triggers + +: triggers ( -- triggers ) + \ triggers global [ drop H{ } clone ] cache ; + +: trigger-graph ( trigger -- graph ) + triggers [ drop ] cache ; + +: reset-trigger ( trigger -- ) + swap triggers set-at ; + +: add-trigger ( key quot trigger -- ) + #! trigger should be a symbol. Note that symbols with the same name but + #! different vocab are not equal + trigger-graph add-vertex ; + +: before ( key1 key2 trigger -- ) + trigger-graph add-edge ; + +: after ( key1 key2 trigger -- ) + swapd before ; + +: call-trigger ( trigger -- ) + trigger-graph topological-sorted-values [ call ] each ; + diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index f71265e6f0..2936c39070 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -1,11 +1,11 @@ -USING: listener io.server ; +USING: listener io.server io.encodings.utf8 ; IN: tty-server : tty-server ( port -- ) local-server "tty-server" - [ listener ] with-server ; + utf8 [ listener ] with-server ; : default-tty-server 9999 tty-server ; -MAIN: default-tty-server \ No newline at end of file +MAIN: default-tty-server diff --git a/extra/tuple-arrays/tuple-arrays-tests.factor b/extra/tuple-arrays/tuple-arrays-tests.factor old mode 100644 new mode 100755 index dfe9002bb9..dd9510405f --- a/extra/tuple-arrays/tuple-arrays-tests.factor +++ b/extra/tuple-arrays/tuple-arrays-tests.factor @@ -1,4 +1,5 @@ USING: tuple-arrays sequences tools.test namespaces kernel math ; +IN: tuple-arrays.tests SYMBOL: mat TUPLE: foo bar ; 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-docs.factor b/extra/tuples/lib/lib-docs.factor index 0ab709a11f..75df1550f4 100644 --- a/extra/tuples/lib/lib-docs.factor +++ b/extra/tuples/lib/lib-docs.factor @@ -5,7 +5,7 @@ HELP: >tuple< { $values { "class" "a tuple class" } } { $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." } { $example - "USE: tuples.lib" + "USING: kernel prettyprint tuples.lib ;" "TUPLE: foo a b c ;" "1 2 3 \\ foo construct-boa \\ foo >tuple< .s" "1\n2\n3" @@ -17,7 +17,7 @@ HELP: >tuple*< { $values { "class" "a tuple class" } } { $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." } { $example - "USE: tuples.lib" + "USING: kernel prettyprint tuples.lib ;" "TUPLE: foo a bb* ccc dddd* ;" "1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s" "2\n4" diff --git a/extra/tuples/lib/lib-tests.factor b/extra/tuples/lib/lib-tests.factor index 88c09d81c4..5d90f25bd7 100644 --- a/extra/tuples/lib/lib-tests.factor +++ b/extra/tuples/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test tuples.lib ; -IN: temporary +IN: tuples.lib.tests TUPLE: foo a b* c d* e f* ; diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index 2334c7602b..d95cbd69ed 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -15,7 +15,7 @@ HOOK: (open-window) ui-backend ( world -- ) HOOK: (close-window) ui-backend ( handle -- ) -HOOK: raise-window ui-backend ( world -- ) +HOOK: raise-window* ui-backend ( world -- ) HOOK: select-gl-context ui-backend ( handle -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 06de1d81fb..572e798bd0 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window? : event-loop ( -- ) event-loop? [ [ - [ NSApp do-events ui-step 10 sleep ] ui-try + [ NSApp do-events ui-wait ] ui-try ] with-autorelease-pool event-loop ] when ; @@ -85,7 +85,7 @@ M: cocoa-ui-backend close-window ( gadget -- ) world-handle second f -> performClose: ] when* ; -M: cocoa-ui-backend raise-window ( world -- ) +M: cocoa-ui-backend raise-window* ( world -- ) world-handle [ second dup f -> orderFront: -> makeKeyWindow NSApp 1 -> activateIgnoringOtherApps: diff --git a/extra/ui/cocoa/tools/tools.factor b/extra/ui/cocoa/tools/tools.factor old mode 100644 new mode 100755 diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor old mode 100644 new mode 100755 index feac09ffc4..a965e8a30c --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -297,8 +297,7 @@ CLASS: { { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" } [ [ - 2drop dup view-dim swap window set-gadget-dim - ui-step + 2drop dup view-dim swap window set-gadget-dim yield ] ui-try ] } diff --git a/extra/ui/commands/commands-docs.factor b/extra/ui/commands/commands-docs.factor index af2df94ade..789d9b9e6a 100644 --- a/extra/ui/commands/commands-docs.factor +++ b/extra/ui/commands/commands-docs.factor @@ -46,10 +46,10 @@ HELP: command-name { $description "Outputs a human-readable name for the command." } { $examples { $example - "USE: ui.commands" + "USING: io ui.commands ;" ": com-my-command ;" "\\ com-my-command command-name write" - "My command" + "My Command" } } ; @@ -104,10 +104,10 @@ HELP: command-string { $description "Outputs a string containing the command name followed by the gesture." } { $examples { $example - "USING: ui.commands ui.gestures ;" + "USING: io ui.commands ui.gestures ;" ": com-my-command ;" "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write" - "My command (C+s)" + "My Command (C+s)" } } ; 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/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 2dade0f58e..8078ec4a33 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -73,7 +73,7 @@ M: freetype-renderer free-fonts ( world -- ) : open-face ( font style -- face ) ttf-name ttf-path - dup file-contents >byte-array malloc-byte-array + dup malloc-file-contents swap file-length (open-face) ; diff --git a/extra/ui/gadgets/books/books-tests.factor b/extra/ui/gadgets/books/books-tests.factor index 9e1b0aa985..dab9ef5acf 100755 --- a/extra/ui/gadgets/books/books-tests.factor +++ b/extra/ui/gadgets/books/books-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.books.tests USING: tools.test ui.gadgets.books ; \ must-infer diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index 224ef9e1ce..6c5d757dd4 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.buttons.tests USING: ui.commands ui.gadgets.buttons ui.gadgets.labels ui.gadgets tools.test namespaces sequences kernel models ; diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index a196173852..defd5aa38a 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 507dc932a4..def6b99b05 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -256,7 +256,7 @@ M: editor gadget-text* editor-string % ; } at T{ one-line-elt } or ; : drag-direction? ( loc editor -- ? ) - editor-mark* <=> 0 < ; + editor-mark* before? ; : drag-selection-caret ( loc editor element -- loc ) >r [ drag-direction? ] 2keep diff --git a/extra/ui/gadgets/frames/frames-tests.factor b/extra/ui/gadgets/frames/frames-tests.factor index 80cf70b960..e38e97c76c 100644 --- a/extra/ui/gadgets/frames/frames-tests.factor +++ b/extra/ui/gadgets/frames/frames-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.frames.tests USING: ui.gadgets.frames ui.gadgets tools.test ; [ ] [ layout ] unit-test diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index 54bae31f79..0a44e5e267 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.tests USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel dlists math math.parser ui sequences hashtables assocs io arrays diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 0ac43af756..ed3631bca5 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -1,10 +1,14 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables kernel models math namespaces sequences -timers quotations math.vectors combinators sorting vectors -dlists models ; +quotations math.vectors combinators sorting vectors dlists +models threads concurrency.flags ; IN: ui.gadgets +SYMBOL: ui-notify-flag + +: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; + TUPLE: rect loc dim ; C: rect @@ -184,7 +188,7 @@ M: array gadget-text* #! When unit testing gadgets without the UI running, the #! invalid queue is not initialized and we simply ignore #! invalidation requests. - layout-queue [ push-front ] [ drop ] if* ; + layout-queue [ push-front notify-ui-thread ] [ drop ] if* ; DEFER: relayout @@ -256,11 +260,11 @@ M: gadget layout* drop ; : queue-graft ( gadget -- ) { f t } over set-gadget-graft-state - graft-queue push-front ; + graft-queue push-front notify-ui-thread ; : queue-ungraft ( gadget -- ) { t f } over set-gadget-graft-state - graft-queue push-front ; + graft-queue push-front notify-ui-thread ; : graft-later ( gadget -- ) dup gadget-graft-state { diff --git a/extra/ui/gadgets/grids/grids-tests.factor b/extra/ui/gadgets/grids/grids-tests.factor index 6f08009da3..0792d55135 100644 --- a/extra/ui/gadgets/grids/grids-tests.factor +++ b/extra/ui/gadgets/grids/grids-tests.factor @@ -1,6 +1,6 @@ USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays namespaces ; -IN: temporary +IN: ui.gadgets.grids.tests [ { 0 0 } ] [ { } pref-dim ] unit-test diff --git a/extra/ui/gadgets/labelled/labelled-docs.factor b/extra/ui/gadgets/labelled/labelled-docs.factor index 285e470564..f09bcaa825 100755 --- a/extra/ui/gadgets/labelled/labelled-docs.factor +++ b/extra/ui/gadgets/labelled/labelled-docs.factor @@ -18,7 +18,7 @@ HELP: { $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ; HELP: -{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "title" string } { "gadget" "a new " { $link gadget } } } +{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } } { $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ; { } related-words diff --git a/extra/ui/gadgets/labelled/labelled-tests.factor b/extra/ui/gadgets/labelled/labelled-tests.factor index 87b2a45678..377f3ab787 100644 --- a/extra/ui/gadgets/labelled/labelled-tests.factor +++ b/extra/ui/gadgets/labelled/labelled-tests.factor @@ -1,7 +1,7 @@ USING: ui.gadgets ui.gadgets.labels ui.gadgets.labelled ui.gadgets.packs ui.gadgets.frames ui.gadgets.grids namespaces kernel tools.test ui.gadgets.buttons sequences ; -IN: temporary +IN: ui.gadgets.labelled.tests TUPLE: testing ; diff --git a/extra/ui/gadgets/labelled/labelled.factor b/extra/ui/gadgets/labelled/labelled.factor old mode 100644 new mode 100755 index 672d3d96d8..0231aef4d0 --- a/extra/ui/gadgets/labelled/labelled.factor +++ b/extra/ui/gadgets/labelled/labelled.factor @@ -21,8 +21,8 @@ M: labelled-gadget focusable-child* labelled-gadget-content ; : ( gadget title -- gadget ) >r r> ; -: ( model quot title -- gadget ) - >r t over set-pane-scrolls? r> +: ( model quot scrolls? title -- gadget ) + >r >r r> over set-pane-scrolls? r> ; : ( quot -- button/f ) diff --git a/extra/ui/gadgets/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor index 5e5801dd02..167aa26084 100755 --- a/extra/ui/gadgets/labels/labels.factor +++ b/extra/ui/gadgets/labels/labels.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel math namespaces -opengl sequences io.streams.lines strings splitting +opengl sequences strings splitting ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors models ; IN: ui.gadgets.labels diff --git a/extra/ui/gadgets/lists/lists-tests.factor b/extra/ui/gadgets/lists/lists-tests.factor index 44a89a7e60..bf2ad72d0e 100644 --- a/extra/ui/gadgets/lists/lists-tests.factor +++ b/extra/ui/gadgets/lists/lists-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.lists.tests USING: ui.gadgets.lists models prettyprint math tools.test kernel ; diff --git a/extra/ui/gadgets/packs/packs-tests.factor b/extra/ui/gadgets/packs/packs-tests.factor index ce6df74769..28a656e2ad 100644 --- a/extra/ui/gadgets/packs/packs-tests.factor +++ b/extra/ui/gadgets/packs/packs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.packs.tests USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render kernel namespaces tools.test math.parser sequences ; diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/extra/ui/gadgets/panes/panes-tests.factor index 848f7919d3..e3f6e36050 100755 --- a/extra/ui/gadgets/panes/panes-tests.factor +++ b/extra/ui/gadgets/panes/panes-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.panes.tests USING: alien ui.gadgets.panes ui.gadgets namespaces kernel sequences io io.streams.string tools.test prettyprint definitions help help.syntax help.markup splitting diff --git a/extra/ui/gadgets/presentations/presentations-tests.factor b/extra/ui/gadgets/presentations/presentations-tests.factor index c4f693c939..46f274d53a 100644 --- a/extra/ui/gadgets/presentations/presentations-tests.factor +++ b/extra/ui/gadgets/presentations/presentations-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.presentations.tests USING: math ui.gadgets.presentations ui.gadgets tools.test prettyprint ui.gadgets.buttons io io.streams.string kernel tuples ; diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index dd667fdfec..5ccd6c7cd8 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.scrollers.tests USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test kernel models ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames diff --git a/extra/ui/gadgets/slots/slots-tests.factor b/extra/ui/gadgets/slots/slots-tests.factor index 5388794624..b955a2604d 100644 --- a/extra/ui/gadgets/slots/slots-tests.factor +++ b/extra/ui/gadgets/slots/slots-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.slots.tests USING: assocs ui.gadgets.slots tools.test refs ; [ t ] [ { 1 2 3 } 2 slot-editor? ] unit-test diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/extra/ui/gadgets/status-bar/status-bar.factor old mode 100644 new mode 100755 index c5508e1891..b528d6739c --- a/extra/ui/gadgets/status-bar/status-bar.factor +++ b/extra/ui/gadgets/status-bar/status-bar.factor @@ -1,11 +1,12 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: models sequences ui.gadgets.labels ui.gadgets.theme -ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel ; +ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel +calendar ; IN: ui.gadgets.status-bar : ( model -- gadget ) - 100 [ "" like ] + 1/10 seconds [ "" like ] dup reverse-video-theme t over set-gadget-root? ; diff --git a/extra/ui/gadgets/tracks/tracks-tests.factor b/extra/ui/gadgets/tracks/tracks-tests.factor index 77c69bc8a8..e2db914089 100644 --- a/extra/ui/gadgets/tracks/tracks-tests.factor +++ b/extra/ui/gadgets/tracks/tracks-tests.factor @@ -1,5 +1,5 @@ USING: kernel ui.gadgets ui.gadgets.tracks tools.test ; -IN: temporary +IN: ui.gadgets.tracks.tests [ { 100 100 } ] [ [ diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/extra/ui/gadgets/worlds/worlds-docs.factor index a47717329d..c5c5c642f7 100755 --- a/extra/ui/gadgets/worlds/worlds-docs.factor +++ b/extra/ui/gadgets/worlds/worlds-docs.factor @@ -13,11 +13,6 @@ HELP: set-title { $description "Sets the title bar of the native window containing the world." } { $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ; -HELP: raise-window -{ $values { "world" world } } -{ $description "Makes the native window containing the given world the front-most window." } -{ $notes "To raise the window containing a specific gadget, use " { $link find-world } " to find the world containing the gadget first." } ; - HELP: select-gl-context { $values { "handle" "a backend-specific handle" } } { $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ; diff --git a/extra/ui/gadgets/worlds/worlds-tests.factor b/extra/ui/gadgets/worlds/worlds-tests.factor index 949ad49460..2e186d875d 100644 --- a/extra/ui/gadgets/worlds/worlds-tests.factor +++ b/extra/ui/gadgets/worlds/worlds-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.worlds.tests USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel ; diff --git a/extra/ui/gestures/gestures-docs.factor b/extra/ui/gestures/gestures-docs.factor index 95f2e5bf87..299498b1b8 100644 --- a/extra/ui/gestures/gestures-docs.factor +++ b/extra/ui/gestures/gestures-docs.factor @@ -194,7 +194,7 @@ HELP: gesture>string { $values { "gesture" "a gesture" } { "string/f" "a " { $link string } " or " { $link f } } } { $contract "Creates a human-readable string from a gesture object, returning " { $link f } " if the gesture does not have a human-readable form." } { $examples - { $example "USE: ui.gestures" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" } + { $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" } } ; ARTICLE: "ui-gestures" "UI gestures" diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 2a3e344a9e..574b71c44d 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser -math.vectors tuples classes ui.gadgets timers combinators.lib ; +math.vectors tuples classes ui.gadgets combinators.lib boxes +calendar alarms symbols ; IN: ui.gestures : set-gestures ( class hash -- ) "gestures" set-word-prop ; @@ -48,10 +49,7 @@ TUPLE: select-all-action ; C: select-all-action tuple>array 1 head* >tuple ; ! Modifiers -SYMBOL: C+ -SYMBOL: A+ -SYMBOL: M+ -SYMBOL: S+ +SYMBOLS: C+ A+ M+ S+ ; TUPLE: key-down mods sym ; @@ -107,20 +105,22 @@ SYMBOL: double-click-timeout : drag-gesture ( -- ) hand-buttons get-global first button-gesture ; -TUPLE: drag-timer ; +SYMBOL: drag-timer -M: drag-timer tick drop drag-gesture ; - -drag-timer construct-empty drag-timer set-global + drag-timer set-global : start-drag-timer ( -- ) hand-buttons get-global empty? [ - drag-timer get-global 100 300 add-timer + [ drag-gesture ] + 300 milliseconds from-now + 100 milliseconds + add-alarm drag-timer get-global >box ] when ; : stop-drag-timer ( -- ) hand-buttons get-global empty? [ - drag-timer get-global remove-timer + drag-timer get-global ?box + [ cancel-alarm ] [ drop ] if ] when ; : fire-motion ( -- ) diff --git a/extra/ui/operations/operations-tests.factor b/extra/ui/operations/operations-tests.factor index b7b2224cfa..1e3d08f164 100755 --- a/extra/ui/operations/operations-tests.factor +++ b/extra/ui/operations/operations-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.operations.tests USING: ui.operations ui.commands prettyprint kernel namespaces tools.test ui.gadgets ui.gadgets.editors parser io io.streams.string math help help.markup ; diff --git a/extra/ui/tools/browser/browser-tests.factor b/extra/ui/tools/browser/browser-tests.factor index 7262c72756..f56f5bcc4e 100755 --- a/extra/ui/tools/browser/browser-tests.factor +++ b/extra/ui/tools/browser/browser-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.tools.browser.tests USING: tools.test tools.test.ui ui.tools.browser ; \ must-infer diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index df87d57873..9aa763d7ec 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -34,9 +34,10 @@ TUPLE: deploy-gadget vocab settings ; "Advanced:"