diff --git a/Makefile b/Makefile index 60091d44ea..6f12633871 100755 --- a/Makefile +++ b/Makefile @@ -145,7 +145,8 @@ wince-arm: macosx.app: factor mkdir -p $(BUNDLE)/Contents/MacOS - cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor + mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor + ln -s Factor.app/Contents/MacOS/factor ./factor cp $(ENGINE) $(BUNDLE)/Contents/Frameworks install_name_tool \ diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 48e8d7e307..baab72036d 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -367,7 +367,7 @@ TUPLE: callback-context ; ] if ; : do-callback ( quot token -- ) - init-error-handler + init-catchstack dup 2 setenv slip wait-to-return ; inline diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6b85eb63e8..f3f233ea0b 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -30,7 +30,10 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set H{ } clone changed-words set -[ default-recompile-hook ] recompile-hook set + +! Trivial recompile hook. We don't want to touch the code heap +! during stage1 bootstrap, it would just waste time. +[ drop { } ] recompile-hook set call call diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 7c7a03f575..0e038d0a10 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: bootstrap.stage1 USING: arrays debugger generic hashtables io assocs kernel.private kernel math memory namespaces parser prettyprint sequences vectors words system splitting init io.files bootstrap.image bootstrap.image.private vocabs -vocabs.loader system ; +vocabs.loader system debugger continuations ; { "resource:core" } vocab-roots set @@ -40,7 +40,14 @@ vocabs.loader system ; [ "resource:core/bootstrap/stage2.factor" dup resource-exists? [ - run-file + [ run-file ] + [ + :c + dup print-error flush + "listener" vocab + [ restarts. vocab-main execute ] + [ die ] if* + ] recover ] [ "Cannot find " write write "." print "Please move " write image write " to the same directory as the Factor sources," print diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 3b5918a4f8..63b5726ad7 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -51,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/compiler/tests/curry.factor b/core/compiler/tests/curry.factor index 77ac01e101..982b3cfb75 100755 --- a/core/compiler/tests/curry.factor +++ b/core/compiler/tests/curry.factor @@ -1,5 +1,5 @@ -USING: tools.test compiler quotations math kernel sequences -assocs namespaces ; +USING: tools.test quotations math kernel sequences +assocs namespaces compiler.units ; IN: temporary [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test diff --git a/core/compiler/tests/float.factor b/core/compiler/tests/float.factor index 10d3baea9b..11470f7102 100755 --- a/core/compiler/tests/float.factor +++ b/core/compiler/tests/float.factor @@ -1,5 +1,5 @@ IN: temporary -USING: compiler kernel kernel.private memory math +USING: compiler.units kernel kernel.private memory math math.private tools.test math.floats.private ; [ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index 5dfe447443..d1e6f7abf4 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -1,10 +1,11 @@ IN: temporary -USING: arrays compiler kernel kernel.private math math.constants -math.private sequences strings tools.test words continuations -sequences.private hashtables.private byte-arrays strings.private -system random layouts vectors.private sbufs.private -strings.private slots.private alien alien.accessors -alien.c-types alien.syntax namespaces libc sequences.private ; +USING: arrays compiler.units kernel kernel.private math +math.constants math.private sequences strings tools.test words +continuations sequences.private hashtables.private byte-arrays +strings.private system random layouts vectors.private +sbufs.private strings.private slots.private alien +alien.accessors alien.c-types alien.syntax namespaces libc +sequences.private ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 6deed6c756..7f23e28bec 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -1,4 +1,4 @@ -USING: compiler tools.test kernel kernel.private +USING: compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien arrays memory ; IN: temporary diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index a23b6739ad..7acd599cb8 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -1,5 +1,5 @@ IN: temporary -USING: kernel tools.test compiler ; +USING: kernel tools.test compiler.units ; TUPLE: color red green blue ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 9f1976bec4..9849ddca7d 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations assocs namespaces sequences words -vocabs definitions hashtables ; +vocabs definitions hashtables init ; IN: compiler.units SYMBOL: old-definitions @@ -37,12 +37,13 @@ SYMBOL: recompile-hook SYMBOL: definition-observers -definition-observers global [ V{ } like ] change-at - GENERIC: definitions-changed ( assoc obj -- ) +[ V{ } clone definition-observers set-global ] +"compiler.units" add-init-hook + : add-definition-observer ( obj -- ) - definition-observers get push-new ; + definition-observers get push ; : remove-definition-observer ( obj -- ) definition-observers get delete ; diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index a1e2525c14..9a26dbc67e 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -23,9 +23,10 @@ $nl "Two words raise an error in the innermost error handler for the current dynamic extent:" { $subsection throw } { $subsection rethrow } -"Two words for establishing an error handler:" +"Words for establishing an error handler:" { $subsection cleanup } { $subsection recover } +{ $subsection ignore-errors } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "errors-post-mortem" } ; @@ -148,6 +149,10 @@ HELP: recover { $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } } { $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; +HELP: ignore-errors +{ $values { "try" quotation } } +{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ; + HELP: rethrow { $values { "error" object } } { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } @@ -188,6 +193,3 @@ HELP: save-error { $values { "error" "an error" } } { $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." } $low-level-note ; - -HELP: init-error-handler -{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index a0aa59332e..13b31cfde6 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -6,6 +6,7 @@ IN: continuations SYMBOL: error SYMBOL: error-continuation +SYMBOL: error-thread SYMBOL: restarts : catchstack ( -- catchstack ) catchstack* clone ; inline @@ -120,6 +123,9 @@ SYMBOL: thread-error-hook : recover ( try recovery -- ) >r [ swap >c call c> drop ] curry r> ifcc ; inline +: ignore-errors ( quot -- ) + [ drop ] recover ; inline + : cleanup ( try cleanup-always cleanup-error -- ) over >r compose [ dip rethrow ] curry recover r> call ; inline @@ -166,17 +172,3 @@ M: condition compute-restarts condition-continuation [ ] curry { } assoc>map append ; - - diff --git a/core/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.factor b/core/debugger/debugger.factor index 95470dcbcd..40bcbe78b1 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -5,7 +5,8 @@ math namespaces prettyprint sequences assocs sequences.private strings io.styles vectors words system splitting math.parser tuples continuations continuations.private combinators generic.math io.streams.duplex classes compiler.units -generic.standard vocabs ; +generic.standard vocabs threads threads.private init +kernel.private libc ; IN: debugger GENERIC: error. ( error -- ) @@ -57,19 +58,6 @@ M: string error. print ; dup length [ restart. ] 2each ] if ; -: debug-help ( -- ) - nl - "Debugger commands:" print - nl - ":help - documentation for this error" print - ":s - data stack at exception time" print - ":r - retain stack at exception time" print - ":c - call stack at exception time" print - ":edit - jump to source location (parse errors only)" print - - ":get ( var -- value ) accesses variables at time of the error" print - flush ; - : print-error ( error -- ) [ error. flush ] curry [ global [ "Error in print-error!" print drop ] bind ] @@ -77,7 +65,12 @@ M: string error. print ; SYMBOL: error-hook -[ print-error restarts. debug-help ] error-hook set-global +[ + print-error + restarts. + nl + "Type :help for debugging help." print flush +] error-hook set-global : try ( quot -- ) [ error-hook get call ] recover ; @@ -260,3 +253,49 @@ M: no-compilation-unit error. M: no-vocab summary drop "Vocabulary does not exist" ; + +M: check-ptr summary + drop "Memory allocation failed" ; + +M: double-free summary + drop "Free failed since memory is not allocated" ; + +M: realloc-error summary + drop "Memory reallocation failed" ; + +: error-in-thread. ( -- ) + error-thread get-global + "Error in thread " write + [ + dup thread-id # + " (" % dup thread-name % + ", " % dup thread-quot unparse-short % ")" % + ] "" make swap write-object ":" print nl ; + +! Hooks +M: thread error-in-thread ( error thread -- ) + initial-thread get-global eq? [ + die drop + ] [ + global [ + error-in-thread. print-error flush + ] bind + ] if ; + + + +[ init-debugger ] "debugger" add-init-hook diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor index e9c31171ed..02a3c4fde0 100644 --- a/core/inference/state/state-tests.factor +++ b/core/inference/state/state-tests.factor @@ -1,5 +1,5 @@ IN: temporary -USING: tools.test inference.state ; +USING: tools.test inference.state words ; SYMBOL: a SYMBOL: b diff --git a/core/init/init-tests.factor b/core/init/init-tests.factor new file mode 100644 index 0000000000..aa7cd0ea58 --- /dev/null +++ b/core/init/init-tests.factor @@ -0,0 +1,7 @@ +IN: temporary +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/io/encodings/authors.txt b/core/io/encodings/authors.txt index 1901f27a24..33616a2d6a 100755 --- a/core/io/encodings/authors.txt +++ b/core/io/encodings/authors.txt @@ -1 +1,2 @@ +Daniel Ehrenberg Slava Pestov diff --git a/core/io/encodings/tags.txt b/core/io/encodings/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/core/io/encodings/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 185fa1436b..c918641912 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -1,41 +1,116 @@ USING: help.markup help.syntax io io.styles strings -io.backend io.files.private ; +io.backend io.files.private quotations ; IN: io.files ARTICLE: "file-streams" "Reading and writing files" +"File streams:" { $subsection } { $subsection } { $subsection } +"Utility combinators:" +{ $subsection with-file-reader } +{ $subsection with-file-writer } +{ $subsection with-file-appender } ; + +ARTICLE: "pathnames" "Pathname manipulation" "Pathname manipulation:" { $subsection parent-directory } { $subsection file-name } { $subsection last-path-separator } { $subsection path+ } -"File system meta-data:" +"Pathnames relative to Factor's install directory:" +{ $subsection resource-path } +{ $subsection ?resource-path } +"Pathnames relative to Factor's temporary files directory:" +{ $subsection temp-directory } +{ $subsection temp-file } +"Pathname presentations:" +{ $subsection pathname } +{ $subsection } ; + +ARTICLE: "directories" "Directories" +"Current and home directories:" +{ $subsection cwd } +{ $subsection cd } +{ $subsection with-directory } +{ $subsection home } +"Directory listing:" +{ $subsection directory } +{ $subsection directory* } +"Creating directories:" +{ $subsection make-directory } +{ $subsection make-directories } ; + +ARTICLE: "fs-meta" "File meta-data" { $subsection exists? } { $subsection directory? } { $subsection file-length } { $subsection file-modified } -{ $subsection stat } -"Directory listing:" -{ $subsection directory } -"File management:" +{ $subsection stat } ; + +ARTICLE: "delete-move-copy" "Deleting, moving, copying files" +"Operations for deleting and copying files come in two forms:" +{ $list + { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." } + { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." } +} +"The operations for moving and copying files come in three flavors:" +{ $list + { "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." } + { "A word named " { $snippet { $emphasis "operation" } "-to" } " 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-to" } " 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-to } +{ $subsection move-files-to } +"Copying files:" +{ $subsection copy-file } +{ $subsection copy-file-to } +{ $subsection copy-files-to } +"Copying directory trees recursively:" +{ $subsection copy-tree } +{ $subsection copy-tree-to } +{ $subsection copy-trees-to } +"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 "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ; + +HELP: file-name +{ $values { "path" "a pathname string" } { "string" string } } +{ $description "Outputs the last component of a pathname string." } +{ $examples + { "\"/usr/bin/gcc\" file-name ." "\"gcc\"" } + { "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } +} ; HELP: { $values { "path" "a pathname string" } { "stream" "an input stream" } } @@ -77,7 +152,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 +188,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 +201,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 +240,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-to +{ $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-to +{ $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-to +{ $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-to +{ $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-to +{ $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-to +{ $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..92e148a854 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -6,63 +6,118 @@ USING: tools.test io.files io threads kernel continuations ; [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ ] [ - "test-foo.txt" resource-path [ + "test-foo.txt" temp-file [ "Hello world." print ] with-file-writer ] unit-test [ ] [ - "test-foo.txt" resource-path [ + "test-foo.txt" temp-file [ "Hello appender." print ] with-stream ] unit-test [ ] [ - "test-bar.txt" resource-path [ + "test-bar.txt" temp-file [ "Hello appender." print ] with-stream ] unit-test [ "Hello world.\nHello appender.\n" ] [ - "test-foo.txt" resource-path file-contents + "test-foo.txt" temp-file file-contents ] unit-test [ "Hello appender.\n" ] [ - "test-bar.txt" resource-path file-contents + "test-bar.txt" temp-file file-contents ] unit-test -[ ] [ "test-foo.txt" resource-path delete-file ] unit-test +[ ] [ "test-foo.txt" temp-file delete-file ] unit-test -[ ] [ "test-bar.txt" resource-path delete-file ] unit-test +[ ] [ "test-bar.txt" temp-file delete-file ] unit-test -[ f ] [ "test-foo.txt" resource-path exists? ] unit-test +[ f ] [ "test-foo.txt" temp-file exists? ] unit-test -[ f ] [ "test-bar.txt" resource-path exists? ] unit-test +[ f ] [ "test-bar.txt" temp-file exists? ] unit-test -[ ] [ "test-blah" resource-path make-directory ] unit-test +[ ] [ "test-blah" temp-file make-directory ] unit-test [ ] [ - "test-blah/fooz" resource-path dispose + "test-blah/fooz" temp-file dispose ] unit-test [ t ] [ - "test-blah/fooz" resource-path exists? + "test-blah/fooz" temp-file exists? ] unit-test -[ ] [ "test-blah/fooz" resource-path delete-file ] unit-test +[ ] [ "test-blah/fooz" temp-file delete-file ] unit-test -[ ] [ "test-blah" resource-path delete-directory ] unit-test +[ ] [ "test-blah" temp-file delete-directory ] unit-test -[ f ] [ "test-blah" resource-path exists? ] unit-test +[ f ] [ "test-blah" temp-file exists? ] unit-test -[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test +[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test -[ ] [ "test-quux.txt" resource-path delete-file ] unit-test +[ ] [ "test-quux.txt" temp-file delete-file ] unit-test -[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test +[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test -[ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test -[ t ] [ "quux-test.txt" resource-path exists? ] unit-test +[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test +[ t ] [ "quux-test.txt" temp-file exists? ] unit-test -[ ] [ "quux-test.txt" resource-path delete-file ] unit-test +[ ] [ "quux-test.txt" temp-file delete-file ] unit-test +[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test + +[ ] [ + "delete-tree-test/a/b/c/d" temp-file + [ "Hi" print ] with-file-writer +] unit-test + +[ ] [ + "delete-tree-test" temp-file delete-tree +] unit-test + +[ ] [ + "copy-tree-test/a/b/c" temp-file make-directories +] unit-test + +[ ] [ + "copy-tree-test/a/b/c/d" temp-file + [ "Foobar" write ] with-file-writer +] unit-test + +[ ] [ + "copy-tree-test" temp-file + "copy-destination" temp-file copy-tree +] unit-test + +[ "Foobar" ] [ + "copy-destination/a/b/c/d" temp-file file-contents +] unit-test + +[ ] [ + "copy-destination" temp-file delete-tree +] unit-test + +[ ] [ + "copy-tree-test" temp-file + "copy-destination" temp-file copy-tree-to +] unit-test + +[ "Foobar" ] [ + "copy-destination/copy-tree-test/a/b/c/d" temp-file file-contents +] unit-test + +[ ] [ + "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-to +] unit-test + +[ "Foobar" ] [ + "d" temp-file file-contents +] unit-test + +[ ] [ "d" temp-file delete-file ] unit-test + +[ ] [ "copy-destination" temp-file delete-tree ] unit-test + +[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 7dbe8c229e..85f0621443 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -5,30 +5,9 @@ USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs continuations ; -HOOK: cd io-backend ( path -- ) - -HOOK: cwd io-backend ( -- path ) - -HOOK: io-backend ( path -- stream ) - -HOOK: io-backend ( path -- stream ) - -HOOK: io-backend ( path -- stream ) - -HOOK: delete-file io-backend ( path -- ) - -HOOK: rename-file io-backend ( from to -- ) - -HOOK: make-directory io-backend ( path -- ) - -HOOK: delete-directory io-backend ( path -- ) - +! 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 +18,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 +50,30 @@ TUPLE: no-parent-directory path ; { [ t ] [ drop ] } } cond ; -: resource-path ( path -- newpath ) - \ resource-path get [ image parent-directory ] unless* - swap path+ ; +! File metadata +: stat ( path -- directory? permissions length modified ) + normalize-pathname (stat) ; -: ?resource-path ( path -- newpath ) - "resource:" ?head [ resource-path ] when ; +: file-length ( path -- n ) stat drop 2nip ; -: resource-exists? ( path -- ? ) - ?resource-path exists? ; +: 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 -- ) + swap cd cwd [ cd ] curry [ ] cleanup ; inline + +! Creating directories +HOOK: make-directory io-backend ( path -- ) : make-directories ( path -- ) normalize-pathname right-trim-separators { @@ -111,35 +87,107 @@ TUPLE: no-parent-directory path ; ] } } cond drop ; +! Directory listings +: fixup-directory ( path seq -- newseq ) + [ + dup string? + [ tuck path+ directory? 2array ] [ nip ] if + ] with map + [ first special-directory? not ] subset ; + +: directory ( path -- seq ) + normalize-directory dup (directory) fixup-directory ; + +: directory* ( path -- seq ) + dup directory [ first2 >r path+ r> 2array ] with map ; + +! Touching files +HOOK: touch-file io-backend ( path -- ) + +! Deleting files +HOOK: delete-file io-backend ( path -- ) + +HOOK: delete-directory io-backend ( path -- ) + +: (delete-tree) ( path dir? -- ) + [ + dup directory* [ (delete-tree) ] assoc-each + delete-directory + ] [ delete-file ] if ; + +: delete-tree ( path -- ) + dup directory? (delete-tree) ; + +: to-directory over file-name path+ ; + +! Moving and renaming files +HOOK: move-file io-backend ( from to -- ) + +: move-file-to ( from to -- ) + to-directory move-file ; + +: move-files-to ( files to -- ) + [ move-file-to ] curry each ; + +! Copying files HOOK: copy-file io-backend ( from to -- ) -M: object copy-file - dup parent-directory make-directories - [ - swap [ - swap stream-copy - ] with-disposal - ] with-disposal ; +: copy-file-to ( from to -- ) + to-directory copy-file ; -: copy-directory ( from to -- ) - dup make-directories - >r dup directory swap r> [ - >r >r first r> over path+ r> rot path+ copy-file - ] 2curry each ; +: copy-files-to ( files to -- ) + [ copy-file-to ] curry each ; -: home ( -- dir ) - { - { [ winnt? ] [ "USERPROFILE" os-env ] } - { [ wince? ] [ "" resource-path ] } - { [ unix? ] [ "HOME" os-env ] } - } cond ; +DEFER: copy-tree-to +: copy-tree ( from to -- ) + over directory? [ + >r dup directory swap r> [ + >r swap first path+ r> copy-tree-to + ] 2curry each + ] [ + copy-file + ] if ; + +: copy-tree-to ( from to -- ) + to-directory copy-tree ; + +: copy-trees-to ( files to -- ) + [ copy-tree-to ] curry each ; + +! Special paths +: resource-path ( path -- newpath ) + \ resource-path get [ image parent-directory ] unless* + swap path+ ; + +: ?resource-path ( path -- newpath ) + "resource:" ?head [ resource-path ] when ; + +: resource-exists? ( path -- ? ) + ?resource-path exists? ; + +: temp-directory ( -- path ) + "temp" resource-path + dup exists? not + [ dup make-directory ] + when ; + +: temp-file ( name -- path ) temp-directory swap path+ ; + +! Pathname presentations TUPLE: pathname string ; C: pathname M: pathname <=> [ pathname-string ] compare ; +! Streams +HOOK: io-backend ( path -- stream ) + +HOOK: io-backend ( path -- stream ) + +HOOK: io-backend ( path -- stream ) + : file-lines ( path -- seq ) lines ; : file-contents ( path -- str ) @@ -155,10 +203,10 @@ M: pathname <=> [ pathname-string ] compare ; : with-file-appender ( path quot -- ) >r r> with-stream ; inline -: temp-directory ( -- path ) - "temp" resource-path - dup exists? not - [ dup make-directory ] - when ; - -: temp-file ( name -- path ) temp-directory swap path+ ; \ No newline at end of file +! Home directory +: home ( -- dir ) + { + { [ winnt? ] [ "USERPROFILE" os-env ] } + { [ wince? ] [ "" resource-path ] } + { [ unix? ] [ "HOME" os-env ] } + } cond ; \ No newline at end of file diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 9c73a3b2b1..0986196e8d 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -5,6 +5,8 @@ IN: io ARTICLE: "stream-protocol" "Stream protocol" "The stream protocol consists of a large number of generic words, many of which are optional." $nl +"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in a " { $link with-stream } ". This leads more simpler, more reusable and more robust code." +$nl "All streams must implement the " { $link dispose } " word in addition to the stream protocol." $nl "Three words are required for input streams:" @@ -25,7 +27,35 @@ $nl { $see-also "io.timeouts" } ; ARTICLE: "stdio" "The default stream" -"Various words take an implicit stream parameter from a variable to reduce stack shuffling." +"Most I/O code only operates on one stream at a time. The " { $emphasis "default stream" } " is an implicit parameter used by many I/O words designed for this particular use-case. Using this idiom improves code in three ways:" +{ $list + { "Code becomes simpler because there is no need to keep a stream around on the stack." } + { "Code becomes more robust because " { $link with-stream } " automatically closes the stream if there is an error." } + { "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-stream } " to specify the source or destination for I/O operations." } +} +"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:" +{ $code + "USING: continuations kernel io io.files math.parser splitting ;" + "\"data.txt\" " + "dup stream-readln number>string over stream-read 16 group" + "swap dispose" +} +"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:" +{ $code + "USING: continuations kernel io io.files math.parser splitting ;" + "\"data.txt\" [" + " dup stream-readln number>string over stream-read" + " 16 group" + "] with-disposal" +} +"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:" +{ $code + "USING: continuations kernel io io.files math.parser splitting ;" + "\"data.txt\" [" + " readln number>string read 16 group" + "] with-stream" +} +"The default stream is stored in a dynamically-scoped variable:" { $subsection stdio } "Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user." { $subsection read1 } @@ -65,6 +95,8 @@ $nl ARTICLE: "streams" "Streams" "Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium." +$nl +"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "." { $subsection "stream-protocol" } { $subsection "stdio" } { $subsection "stream-utils" } @@ -75,42 +107,50 @@ ABOUT: "streams" HELP: stream-readln { $values { "stream" "an input stream" } { "str" string } } { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link readln } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read1 { $values { "stream" "an input stream" } { "ch/f" "a character or " { $link f } } } { $contract "Reads a character of input from the stream. Outputs " { $link f } " on stream exhaustion." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read { $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } } { $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read-until { $values { "seps" string } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } } { $contract "Reads characters from the stream, until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link read-until } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-write1 { $values { "ch" "a character" } { "stream" "an output stream" } } { $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link write1 } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-write { $values { "str" string } { "stream" "an output stream" } } { $contract "Writes a string of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link write } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-flush { $values { "stream" "an output stream" } } { $contract "Waits for any pending output to complete." } { $notes "With many output streams, written output is buffered and not sent to the underlying resource until either the buffer is full, or this word is called." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link flush } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-nl { $values { "stream" "an output stream" } } { $contract "Writes a line terminator. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link nl } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-format @@ -118,6 +158,7 @@ HELP: stream-format { $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." $nl "The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." } $io-error ; HELP: make-block-stream @@ -127,7 +168,7 @@ $nl "Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output." $nl "The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." } -{ $notes "Instead of calling this word directly, use " { $link with-nesting } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-write-table @@ -135,13 +176,13 @@ HELP: stream-write-table { $contract "Prints a table of cells produced by " { $link with-cell } "." $nl "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } -{ $notes "Instead of calling this word directly, use " { $link tabular-output } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." } $io-error ; HELP: make-cell-stream { $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } } { $contract "Creates an output stream which writes to a table cell object." } -{ $notes "Instead of calling this word directly, use " { $link tabular-output } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." } $io-error ; HELP: make-span-stream @@ -149,12 +190,13 @@ HELP: make-span-stream { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." $nl "Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." } -{ $notes "Instead of calling this word directly, use " { $link with-style } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-print { $values { "str" string } { "stream" "an output stream" } } { $description "Writes a newline-terminated string." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link print } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-copy @@ -167,17 +209,17 @@ HELP: stdio HELP: readln { $values { "str/f" "a string or " { $link f } } } -{ $contract "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } +{ $description "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } $io-error ; HELP: read1 { $values { "ch/f" "a character or " { $link f } } } -{ $contract "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } +{ $description "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } $io-error ; HELP: read { $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } } -{ $contract "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } +{ $description "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } $io-error ; HELP: read-until @@ -192,26 +234,26 @@ $io-error ; HELP: write { $values { "str" string } } -{ $contract "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $description "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } $io-error ; HELP: flush -{ $contract "Waits for any pending output to the " { $link stdio } " stream to complete." } +{ $description "Waits for any pending output to the " { $link stdio } " stream to complete." } $io-error ; HELP: nl -{ $contract "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $description "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } $io-error ; HELP: format { $values { "str" string } { "style" "a hashtable" } } -{ $contract "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $description "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } { $notes "Details are in the documentation for " { $link stream-format } "." } $io-error ; HELP: with-nesting { $values { "style" "a hashtable" } { "quot" "a quotation" } } -{ $contract "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." } +{ $description "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." } { $notes "Details are in the documentation for " { $link make-block-stream } "." } $io-error ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 456c3cc4ca..2f80e3c368 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -139,10 +139,6 @@ ARTICLE: "equality" "Equality and comparison testing" ! Defined in handbook.factor ABOUT: "dataflow" -HELP: version -{ $values { "str" string } } -{ $description "Outputs the version number of the current Factor instance." } ; - HELP: eq? ( obj1 obj2 -- ? ) { $values { "obj1" object } { "obj2" object } { "?" "a boolean" } } { $description "Tests if two references point at the same object." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d1f3af4779..61574e406f 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -3,8 +3,6 @@ USING: kernel.private ; IN: kernel -: version ( -- str ) "0.92" ; foldable - ! Stack stuff : spin ( x y z -- z y x ) swap rot ; inline diff --git a/core/libc/libc.factor b/core/libc/libc.factor old mode 100644 new mode 100755 index 2006850839..e82b244d6d --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -2,7 +2,7 @@ ! Copyright (C) 2007 Slava Pestov ! Copyright (C) 2007 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs continuations init inspector kernel namespaces ; +USING: alien assocs continuations init kernel namespaces ; IN: libc TUPLE: check-ptr ; -M: check-ptr summary drop "Memory allocation failed" ; - : check-ptr ( c-ptr -- c-ptr ) [ \ check-ptr construct-boa throw ] unless* ; TUPLE: double-free ; -M: double-free summary drop "Free failed since memory is not allocated" ; - : double-free ( -- * ) \ double-free construct-empty throw ; TUPLE: realloc-error ptr size ; -M: realloc-error summary drop "Memory reallocation failed" ; - : realloc-error ( alien size -- * ) \ realloc-error construct-boa throw ; ( 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/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 66d3956dba..c63787ad52 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -1,4 +1,4 @@ -USING: arrays compiler generic hashtables inference kernel +USING: arrays compiler.units generic hashtables inference kernel kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 3d2963fc85..d95e8258be 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -1,7 +1,7 @@ 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 ; +sorting tuples compiler.units debugger ; IN: temporary [ @@ -426,3 +426,7 @@ IN: temporary ] unit-test [ t ] [ "foo" "temporary" 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 bc129041e5..2f2d4a8c18 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -352,6 +352,8 @@ TUPLE: bad-number ; : parse-definition ( -- quot ) \ ; parse-until >quotation ; +: (:) CREATE dup reset-generic parse-definition ; + GENERIC: expected>string ( obj -- str ) M: f expected>string drop "end of input" ; @@ -468,7 +470,7 @@ SYMBOL: interactive-vocabs #! If a class word had a compound definition which was #! removed, it must go back to being a symbol. new-definitions get first2 diff - [ nip define-symbol ] assoc-each ; + [ nip dup reset-generic define-symbol ] assoc-each ; : forget-smudged ( -- ) smudged-usage forget-all @@ -507,7 +509,7 @@ SYMBOL: interactive-vocabs ] recover ; : run-file ( file -- ) - [ [ parse-file call ] keep ] assert-depth drop ; + [ dup parse-file call ] assert-depth drop ; : ?run-file ( path -- ) dup resource-exists? [ run-file ] [ drop ] if ; diff --git a/core/parser/test/assert-depth.factor b/core/parser/test/assert-depth.factor new file mode 100755 index 0000000000..3008dc05b6 --- /dev/null +++ b/core/parser/test/assert-depth.factor @@ -0,0 +1 @@ +1 2 3 diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index fbb879b01e..6e39bced07 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -429,7 +429,7 @@ HELP: collect HELP: each { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } -{ $description "Applies the quotation to each element of the sequence in turn." } ; +{ $description "Applies the quotation to each element of the sequence in order." } ; HELP: reduce { $values { "seq" sequence } { "identity" object } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "result" "the final result" } } @@ -447,7 +447,7 @@ HELP: accumulate HELP: map { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } } -{ $description "Applies the quotation to each element yielding a new element. The new elements are collected into a sequence of the same class as the input sequence." } ; +{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ; HELP: change-nth { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } } diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor old mode 100644 new mode 100755 index 8325832050..d9227b2d95 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -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/strings/strings-tests.factor b/core/strings/strings-tests.factor index 90e74275ff..1df4e1c477 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -28,8 +28,8 @@ IN: temporary [ "end" ] [ "Beginning and end" 14 tail ] unit-test -[ t ] [ "abc" "abd" <=> 0 < ] unit-test -[ t ] [ "z" "abd" <=> 0 > ] unit-test +[ t ] [ "abc" "abd" before? ] unit-test +[ t ] [ "z" "abd" after? ] unit-test [ 0 10 "hello" subseq ] must-fail diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 95a00f3801..eeb3f85962 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -163,7 +163,7 @@ ARTICLE: "syntax-byte-vectors" "Byte vector syntax" ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } -"Pathnames are documented in " { $link "file-streams" } "." ; +"Pathnames are documented in " { $link "pathnames" } "." ; ARTICLE: "syntax-literals" "Literals" "Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words." diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 601c05d8d9..79a5553228 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -107,7 +107,7 @@ IN: bootstrap.syntax ] define-syntax ":" [ - CREATE dup reset-generic parse-definition define + (:) define ] define-syntax "GENERIC:" [ diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index bdd04307df..c5c7791a35 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -1,5 +1,5 @@ USING: generic help.markup help.syntax kernel math memory -namespaces sequences kernel.private io.files strings ; +namespaces sequences kernel.private strings ; IN: system ARTICLE: "os" "System interface" @@ -29,7 +29,7 @@ ARTICLE: "os" "System interface" { $subsection millis } "Exiting the Factor VM:" { $subsection exit } -{ $see-also "file-streams" "network-streams" "io.launcher" "io.mmap" } ; +{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ; ABOUT: "os" diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 490c8dc740..b4fd6eee60 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -4,13 +4,12 @@ IN: threads USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private -dlists assocs system combinators debugger prettyprint io init -boxes ; +dlists assocs system combinators init boxes ; SYMBOL: initial-thread TUPLE: thread -name quot error-handler exit-handler +name quot exit-handler id continuation state mailbox variables sleep-entry ; @@ -60,11 +59,10 @@ threads global [ H{ } assoc-like ] change-at PRIVATE> -: ( quot name error-handler -- thread ) +: ( quot name -- thread ) \ thread counter [ ] { set-thread-quot set-thread-name - set-thread-error-handler set-thread-id set-thread-continuation set-thread-exit-handler @@ -86,6 +84,13 @@ PRIVATE> f over set-thread-state check-registered 2array run-queue push-front ; +: sleep-time ( -- ms/f ) + { + { [ run-queue dlist-empty? not ] [ 0 ] } + { [ sleep-queue heap-empty? ] [ f ] } + { [ t ] [ sleep-queue heap-peek nip millis [-] ] } + } cond ; + [ ] while drop ; -: next ( -- ) +: next ( -- * ) expire-sleep-loop - run-queue pop-back - dup array? [ first2 ] [ f swap ] if dup set-self - f over set-thread-state - thread-continuation box> - continue-with ; + run-queue dup dlist-empty? [ + ! We should never be in a state where the only threads + ! are sleeping; the I/O wait thread is always runnable. + ! However, if it dies, we handle this case + ! semi-gracefully. + ! + ! And if sleep-time outputs f, there are no sleeping + ! threads either... so WTF. + drop sleep-time [ die 0 ] unless* (sleep) next + ] [ + pop-back + dup array? [ first2 ] [ f swap ] if dup set-self + f over set-thread-state + thread-continuation box> + continue-with + ] if ; PRIVATE> -: sleep-time ( -- ms/f ) - { - { [ run-queue dlist-empty? not ] [ 0 ] } - { [ sleep-queue heap-empty? ] [ f ] } - { [ t ] [ sleep-queue heap-peek nip millis [-] ] } - } cond ; - : stop ( -- ) self dup thread-exit-handler call unregister-thread next ; @@ -168,20 +177,8 @@ M: real sleep ] 1 (throw) ] "spawn" suspend 2drop ; -: default-thread-error-handler ( error thread -- ) - global [ - "Error in thread " write - dup thread-id pprint - " (" write - dup thread-name pprint ")" print - "spawned to call " write - thread-quot short. - nl - print-error flush - ] bind ; - : spawn ( quot name -- thread ) - [ default-thread-error-handler ] [ (spawn) ] keep ; + [ (spawn) ] keep ; : spawn-server ( quot name -- thread ) >r [ [ ] [ ] while ] curry r> spawn ; @@ -191,6 +188,8 @@ M: real sleep [ >r set-namestack set-datastack r> call ] 3curry "Thread" spawn drop ; +GENERIC: error-in-thread ( error thread -- ) + 42 setenv 43 setenv initial-thread global - [ drop f "Initial" [ die ] ] cache + [ drop f "Initial" ] cache over set-thread-continuation f over set-thread-state dup register-thread set-self ; -[ self dup thread-error-handler call stop ] +[ self error-in-thread stop ] thread-error-hook set-global PRIVATE> diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 2d53ed82e2..8bdd9b902f 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -153,16 +153,18 @@ SYMBOL: load-help? [ load-error. nl ] each ; SYMBOL: blacklist +SYMBOL: failures : require-all ( vocabs -- failures ) [ V{ } clone blacklist set + V{ } clone failures set [ [ require ] - [ >r vocab-name r> 2array blacklist get push ] + [ swap vocab-name failures get set-at ] recover ] each - blacklist get + failures get ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) @@ -176,12 +178,17 @@ SYMBOL: blacklist : refresh-all ( -- ) "" refresh ; GENERIC: (load-vocab) ( name -- vocab ) -! + +: add-to-blacklist ( error vocab -- ) + vocab-name blacklist get dup [ set-at ] [ 3drop ] if ; + M: vocab (load-vocab) - dup vocab-root [ - dup vocab-source-loaded? [ dup load-source ] unless - dup vocab-docs-loaded? [ dup load-docs ] unless - ] when ; + [ + dup vocab-root [ + dup vocab-source-loaded? [ dup load-source ] unless + dup vocab-docs-loaded? [ dup load-docs ] unless + ] when + ] [ [ swap add-to-blacklist ] keep rethrow ] recover ; M: string (load-vocab) [ ".private" ?tail drop reload ] keep vocab ; @@ -189,24 +196,14 @@ M: string (load-vocab) M: vocab-link (load-vocab) vocab-name (load-vocab) ; -TUPLE: blacklisted-vocab name ; - -: blacklisted-vocab ( name -- * ) - \ blacklisted-vocab construct-boa throw ; - -M: blacklisted-vocab error. - "This vocabulary depends on the " write - blacklisted-vocab-name write - " vocabulary which failed to load" print ; - [ - dup vocab-name blacklist get key? [ - vocab-name blacklisted-vocab + dup vocab-name blacklist get at* [ + rethrow ] [ - [ - dup vocab [ ] [ ] ?if (load-vocab) - ] with-compiler-errors + drop + [ dup vocab swap or (load-vocab) ] with-compiler-errors ] if + ] load-vocab-hook set-global : vocab-where ( vocab -- loc ) diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index f29d21cd9f..63e30178f5 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -1,6 +1,6 @@ USING: arrays generic assocs kernel math namespaces sequences tools.test words definitions parser quotations -vocabs continuations tuples compiler.units ; +vocabs continuations tuples compiler.units io.streams.string ; IN: temporary [ 4 ] [ @@ -156,11 +156,13 @@ SYMBOL: quot-uses-b [ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test [ ] [ - "IN: temporary GENERIC: symbol-generic" eval + "IN: temporary GENERIC: symbol-generic" + "symbol-generic-test" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: symbol-generic ;" eval + "IN: temporary TUPLE: symbol-generic ;" + "symbol-generic-test" parse-stream drop ] unit-test [ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor index b609878c77..fcb2de8b6b 100755 --- a/extra/alarms/alarms-docs.factor +++ b/extra/alarms/alarms-docs.factor @@ -5,11 +5,11 @@ HELP: alarm { $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ; HELP: add-alarm -{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link dt } " or " { $link f } } { "alarm" alarm } } +{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } } { $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; HELP: later -{ $values { "quot" quotation } { "time" dt } { "alarm" alarm } } +{ $values { "quot" quotation } { "time" duration } { "alarm" alarm } } { $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ; HELP: cancel-alarm diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 7f43dbd612..a50e1817e1 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -16,7 +16,7 @@ SYMBOL: alarm-thread alarm-thread get-global interrupt ; : check-alarm - dup dt? over not or [ "Not a dt" throw ] unless + dup duration? over not or [ "Not a duration" throw ] unless over timestamp? [ "Not a timestamp" throw ] unless pick callable? [ "Not a quotation" throw ] unless ; inline @@ -29,10 +29,10 @@ SYMBOL: alarm-thread notify-alarm-thread ; : alarm-expired? ( alarm now -- ? ) - >r alarm-time r> <=> 0 <= ; + >r alarm-time r> before=? ; : reschedule-alarm ( alarm -- ) - dup alarm-time over alarm-interval +dt + dup alarm-time over alarm-interval time+ over set-alarm-time register-alarm ; diff --git a/extra/benchmark/crc32/crc32.factor b/extra/benchmark/crc32/crc32.factor new file mode 100644 index 0000000000..7dad272296 --- /dev/null +++ b/extra/benchmark/crc32/crc32.factor @@ -0,0 +1,10 @@ +USING: io.crc32 io.files kernel math ; +IN: benchmark.crc32 + +: crc32-primes-list ( -- ) + 10 [ + "extra/math/primes/list/list.factor" resource-path + file-contents crc32 drop + ] times ; + +MAIN: crc32-primes-list diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 75321def2d..1740bcb28e 100644 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -51,7 +51,7 @@ HINTS: random fixnum ; dup keys >byte-array swap values >float-array unclip [ + ] accumulate swap add ; -:: select-random | seed chars floats | +:: select-random ( seed chars floats -- elt ) floats seed random -rot [ >= ] curry find drop chars nth-unsafe ; inline @@ -62,7 +62,7 @@ HINTS: random fixnum ; : write-description ( desc id -- ) ">" write write bl print ; inline -:: split-lines | n quot | +:: split-lines ( n quot -- ) n line-length /mod [ [ line-length quot call ] times ] dip dup zero? [ drop ] quot if ; inline @@ -71,7 +71,7 @@ HINTS: random fixnum ; write-description [ make-random-fasta ] 2curry split-lines ; inline -:: make-repeat-fasta | k len alu | +:: make-repeat-fasta ( k len alu -- ) [let | kn [ alu length ] | len [ k + kn mod alu nth-unsafe ] B{ } map-as print k len + diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor new file mode 100644 index 0000000000..3043725acd --- /dev/null +++ b/extra/benchmark/md5/md5.factor @@ -0,0 +1,7 @@ +USING: crypto.md5 io.files kernel ; +IN: benchmark.md5 + +: md5-primes-list ( -- ) + "extra/math/primes/list/list.factor" resource-path file>md5 drop ; + +MAIN: md5-primes-list diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor new file mode 100644 index 0000000000..95c797cddd --- /dev/null +++ b/extra/benchmark/random/random.factor @@ -0,0 +1,14 @@ +USING: io.files random math.parser io math ; +IN: benchmark.random + +: random-numbers-path "random-numbers.txt" temp-file ; + +: write-random-numbers ( n -- ) + random-numbers-path [ + [ 200 random 100 - number>string print ] times + ] with-file-writer ; + +: random-main ( -- ) + 1000000 write-random-numbers ; + +MAIN: random-main diff --git a/extra/benchmark/sort/sort.factor b/extra/benchmark/sort/sort.factor index 0a31bf0ca4..a54480692a 100644 --- a/extra/benchmark/sort/sort.factor +++ b/extra/benchmark/sort/sort.factor @@ -1,7 +1,8 @@ -USING: kernel sequences sorting random ; +USING: kernel sequences sorting benchmark.random math.parser +io.files ; IN: benchmark.sort : sort-benchmark - 100000 [ drop 100000 random ] map natural-sort drop ; + random-numbers-path file-lines [ string>number ] map natural-sort drop ; MAIN: sort-benchmark diff --git a/extra/benchmark/sum-file/sum-file.factor b/extra/benchmark/sum-file/sum-file.factor index e17765d542..1d52beebfc 100644 --- a/extra/benchmark/sum-file/sum-file.factor +++ b/extra/benchmark/sum-file/sum-file.factor @@ -1,4 +1,5 @@ -USING: io io.files math math.parser kernel prettyprint ; +USING: io io.files math math.parser kernel prettyprint +benchmark.random ; IN: benchmark.sum-file : sum-file-loop ( n -- n' ) @@ -8,6 +9,6 @@ IN: benchmark.sum-file [ 0 sum-file-loop ] with-file-reader . ; : sum-file-main ( -- ) - home "sum-file-in.txt" path+ sum-file ; + random-numbers-path sum-file ; MAIN: sum-file-main diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 552e26ebf5..1fa8ee4f41 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -6,16 +6,20 @@ bootstrap.image sequences io namespaces io.launcher math ; : destination "slava@factorcode.org:www/images/latest/" ; +: checksums "checksums.txt" temp-file ; + : boot-image-names images [ boot-image-name ] map ; : compute-checksums ( -- ) - "checksums.txt" [ + checksums [ boot-image-names [ dup write bl file>md5str print ] each ] with-file-writer ; : upload-images ( -- ) [ - "scp" , boot-image-names % "checksums.txt" , destination , + "scp" , + boot-image-names % + "temp/checksums.txt" , destination , ] { } make try-process ; : new-images ( -- ) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index b123b9c428..2b51f8603e 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -65,15 +65,8 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: factor-binary ( -- name ) - os - { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } - { "winnt" [ "./factor-nt.exe" ] } - [ drop "./factor" ] } - case ; - : bootstrap-cmd ( -- cmd ) - { factor-binary { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; + { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; : bootstrap ( -- desc ) @@ -85,7 +78,7 @@ IN: builder >desc ; : builder-test-cmd ( -- cmd ) - { factor-binary "-run=builder.test" } to-strings ; + { "./factor" "-run=builder.test" } to-strings ; : builder-test ( -- desc ) @@ -147,7 +140,11 @@ SYMBOL: build-status show-benchmark-deltas - "../benchmarks" "../../benchmarks" copy-file + "../benchmarks" "../../benchmarks" copy-file + + ".." cd + + maybe-release ] with-file-writer @@ -168,7 +165,7 @@ SYMBOL: builder-recipients builder-from get >>from builder-recipients get >>to subject >>subject - "../report" file>string >>body + "./report" file>string >>body send ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,11 +174,11 @@ SYMBOL: builder-recipients { "bzip2" my-boot-image-name } to-strings run-process drop ; : build ( -- ) - [ (build) ] [ drop ] recover - maybe-release + [ (build) ] failsafe + builds cd stamp> cd [ send-builder-email ] [ drop "not sending mail" . ] recover - ".." cd { "rm" "-rf" "factor" } run-process drop - [ compress-image ] [ drop ] recover ; + { "rm" "-rf" "factor" } run-process drop + [ compress-image ] failsafe ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -216,8 +213,7 @@ USE: bootstrap.image.download [ build ] when ] - [ drop ] - recover + failsafe 5 minutes sleep build-loop ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index eb947ff14f..c65241d922 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -64,6 +64,8 @@ USING: system sequences splitting ; : linux-release ( -- ) + "factor" cd + { "rm" "-rf" "Factor.app" } run-process drop { "rm" "-rf" common-files } to-strings run-process drop @@ -78,6 +80,8 @@ USING: system sequences splitting ; : windows-release ( -- ) + "factor" cd + { "rm" "-rf" "Factor.app" } run-process drop { "rm" "-rf" common-files } to-strings run-process drop @@ -92,6 +96,8 @@ USING: system sequences splitting ; : macosx-release ( -- ) + "factor" cd + { "rm" "-rf" common-files } to-strings run-process drop ".." cd @@ -120,8 +126,8 @@ USING: system sequences splitting ; : release? ( -- ? ) { - "../load-everything-vocabs" - "../test-all-vocabs" + "./load-everything-vocabs" + "./test-all-vocabs" } [ eval-file empty? ] all? ; diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 3d699d4ba8..1081d3256d 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -4,7 +4,7 @@ USING: kernel words namespaces classes parser continuations math math.parser combinators sequences splitting quotations arrays strings tools.time parser-combinators new-slots accessors assocs.lib - combinators.cleave bake calendar ; + combinators.cleave bake calendar calendar.format ; IN: builder.util @@ -104,4 +104,8 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ; USE: prettyprint -: to-file ( object file -- ) [ . ] with-file-writer ; \ No newline at end of file +: to-file ( object file -- ) [ . ] with-file-writer ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: failsafe ( quot -- ) [ drop ] recover ; \ No newline at end of file diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 2d731dd830..49a0f9254a 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -39,12 +39,12 @@ IN: bunny.model [ normals ] 2keep 3array ] time ; -: model-path "bun_zipper.ply" ; +: model-path "bun_zipper.ply" temp-file ; : model-url "http://factorcode.org/bun_zipper.ply" ; : maybe-download ( -- path ) - model-path resource-path dup exists? [ + model-path dup exists? [ "Downloading bunny from " write model-url dup print flush over download-to diff --git a/extra/calendar/authors.txt b/extra/calendar/authors.txt index 1901f27a24..7c1b2f2279 100644 --- a/extra/calendar/authors.txt +++ b/extra/calendar/authors.txt @@ -1 +1 @@ -Slava Pestov +Doug Coleman diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index a3ae5f115a..f700d244f5 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,15 @@ USING: arrays calendar kernel math sequences tools.test -continuations system io.streams.string ; +continuations system ; -[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ f ] [ 2004 12 32 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 2 30 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2003 2 29 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 -2 9 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 0 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 24 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 60 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 59 60 0 valid-timestamp? ] unit-test +[ t ] [ now valid-timestamp? ] unit-test [ f ] [ 1900 leap-year? ] unit-test [ t ] [ 1904 leap-year? ] unit-test @@ -16,148 +17,144 @@ continuations system io.streams.string ; [ f ] [ 2001 leap-year? ] unit-test [ f ] [ 2006 leap-year? ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt - 2006 10 10 0 0 1 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 100 seconds +dt - 2006 10 10 0 1 40 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 seconds +dt - 2006 10 9 23 58 20 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 86400 seconds +dt - 2006 10 11 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 1 seconds time+ + 2006 10 10 0 0 1 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 100 seconds time+ + 2006 10 10 0 1 40 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -100 seconds time+ + 2006 10 9 23 58 20 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 86400 seconds time+ + 2006 10 11 0 0 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt - 2006 10 10 0 10 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10.5 minutes +dt - 2006 10 10 0 10 30 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 3/4 minutes +dt - 2006 10 10 0 0 45 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -3/4 minutes +dt - 2006 10 9 23 59 15 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 10 minutes time+ + 2006 10 10 0 10 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 10.5 minutes time+ + 2006 10 10 0 10 30 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 3/4 minutes time+ + 2006 10 10 0 0 45 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -3/4 minutes time+ + 2006 10 9 23 59 15 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt - 2006 10 15 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -10 minutes +dt - 2006 10 9 23 50 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 minutes +dt - 2006 10 9 22 20 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 7200 minutes time+ + 2006 10 15 0 0 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -10 minutes time+ + 2006 10 9 23 50 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -100 minutes time+ + 2006 10 9 22 20 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt - 2006 1 1 1 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 hours +dt - 2006 1 2 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 hours +dt - 2005 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 hours +dt - 2006 1 1 12 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 72 hours +dt - 2006 1 4 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 hours time+ + 2006 1 1 1 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 24 hours time+ + 2006 1 2 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -24 hours time+ + 2005 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 12 hours time+ + 2006 1 1 12 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 72 hours time+ + 2006 1 4 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt - 2006 1 2 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 days +dt - 2005 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 365 days +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -365 days +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 365 days +dt - 2004 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 366 days +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 days time+ + 2006 1 2 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 days time+ + 2005 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 365 days time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -365 days time+ + 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 365 days time+ + 2004 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 366 days time+ + 2005 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt - 2006 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 months +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 months +dt - 2008 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 13 months +dt - 2007 2 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 months +dt - 2006 2 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 months +dt - 2006 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 months +dt - 2005 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -2 months +dt - 2005 11 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -13 months +dt - 2004 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 months +dt - 2004 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 make-timestamp 12 months +dt - 2005 3 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 make-timestamp -12 months +dt - 2003 3 1 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 11 months time+ + 2006 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 12 months time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 24 months time+ + 2008 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 13 months time+ + 2007 2 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 months time+ + 2006 2 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 0 months time+ + 2006 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 months time+ + 2005 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -2 months time+ + 2005 11 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -13 months time+ + 2004 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -24 months time+ + 2004 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 2 29 0 0 0 0 12 months time+ + 2005 3 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 2 29 0 0 0 0 -12 months time+ + 2003 3 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt - 2006 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 years +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 years +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -100 years +dt - 1906 1 1 0 0 0 0 make-timestamp = ] unit-test -! [ t ] [ 2004 2 29 0 0 0 0 make-timestamp -1 years +dt - ! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 0 years time+ + 2006 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 years time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 years time+ + 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -100 years time+ + 1906 1 1 0 0 0 0 = ] unit-test +! [ t ] [ 2004 2 29 0 0 0 0 -1 years time+ +! 2003 2 28 0 0 0 0 = ] unit-test -[ 5 ] [ 2006 7 14 0 0 0 0 make-timestamp day-of-week ] unit-test +[ 5 ] [ 2006 7 14 0 0 0 0 day-of-week ] unit-test -[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 make-timestamp ] 3keep 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 ] 3keep 0 0 0 0 = ] unit-test -[ 1 ] [ 2006 1 1 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 60 ] [ 2004 2 29 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 61 ] [ 2004 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 366 ] [ 2004 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 365 ] [ 2003 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 60 ] [ 2003 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test +[ 1 ] [ 2006 1 1 0 0 0 0 day-of-year ] unit-test +[ 60 ] [ 2004 2 29 0 0 0 0 day-of-year ] unit-test +[ 61 ] [ 2004 3 1 0 0 0 0 day-of-year ] unit-test +[ 366 ] [ 2004 12 31 0 0 0 0 day-of-year ] unit-test +[ 365 ] [ 2003 12 31 0 0 0 0 day-of-year ] unit-test +[ 60 ] [ 2003 3 1 0 0 0 0 day-of-year ] unit-test -[ t ] [ 2004 12 31 0 0 0 0 make-timestamp dup = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 10 seconds 5 years +dts +dt - 2009 1 1 0 0 10 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp -10 seconds -5 years +dts +dt - 1998 12 31 23 59 50 0 make-timestamp = ] unit-test +[ t ] [ 2004 12 31 0 0 0 0 dup = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 10 seconds 5 years time+ time+ + 2009 1 1 0 0 10 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 -10 seconds -5 years time+ time+ + 1998 12 31 23 59 50 0 = ] unit-test -[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone - 2004 1 1 11 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 5 0 0 -11 make-timestamp 0 convert-timezone - 2004 1 1 16 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 23 0 0 9.5 make-timestamp 0 convert-timezone - 2004 1 1 13 30 0 0 make-timestamp = ] unit-test +[ t ] [ 2004 1 1 23 0 0 12 0 convert-timezone + 2004 1 1 11 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 5 0 0 -11 0 convert-timezone + 2004 1 1 16 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 23 0 0 9+1/2 0 convert-timezone + 2004 1 1 13 30 0 0 = ] unit-test -[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp - 2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test +[ 0 ] [ 2004 1 1 13 30 0 0 + 2004 1 1 12 30 0 -1 <=> ] unit-test -[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp - 2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test +[ 1 ] [ 2004 1 1 13 30 0 0 + 2004 1 1 12 30 0 0 <=> ] unit-test -[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp - 2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test +[ -1 ] [ 2004 1 1 12 30 0 0 + 2004 1 1 13 30 0 0 <=> ] unit-test -[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp - 2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test +[ 1 ] [ 2005 1 1 12 30 0 0 + 2004 1 1 13 30 0 0 <=> ] unit-test -[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test -[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test -[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test -[ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test +[ t ] [ now timestamp>millis millis - 1000 < ] unit-test +[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test +[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test +[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test -[ 0 ] [ - "Z" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +: checktime+ now dup clone [ rot time+ drop ] keep = ; -[ 1 ] [ - "+01" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 seconds checktime+ ] unit-test -[ -1 ] [ - "-01" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 minutes checktime+ ] unit-test -[ -1-1/2 ] [ - "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 hours checktime+ ] unit-test -[ 1+1/2 ] [ - "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 days checktime+ ] unit-test + +[ t ] [ 5 weeks checktime+ ] unit-test + +[ t ] [ 5 months checktime+ ] unit-test + +[ t ] [ 5 years checktime+ ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index d834698d08..2b80a8dce6 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -1,20 +1,21 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays hashtables io io.streams.string kernel math -math.vectors math.functions math.parser namespaces sequences -strings tuples system debugger combinators vocabs.loader -calendar.backend structs alien.c-types math.vectors -shuffle threads ; +USING: arrays kernel math math.functions namespaces sequences +strings tuples system vocabs.loader calendar.backend threads +new-slots accessors combinators ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; C: timestamp -TUPLE: dt year month day hour minute second ; +: ( year month day -- timestamp ) + 0 0 0 gmt-offset ; -C:
dt +TUPLE: duration year month day hour minute second ; + +C: duration : month-names { @@ -36,9 +37,14 @@ C:
dt : day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ; : day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ; -: average-month ( -- x ) - #! length of average month in days - 30.41666666666667 ; +: average-month 30+5/12 ; inline +: months-per-year 12 ; inline +: days-per-year 3652425/10000 ; inline +: hours-per-year 876582/100 ; inline +: minutes-per-year 5259492/10 ; inline +: seconds-per-year 31556952 ; inline + + + : julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 @@ -74,38 +82,31 @@ SYMBOL: m e get 153 m get * 2 + 5 /i - 1+ ] with-scope ; -: set-date ( year month day timestamp -- ) - [ set-timestamp-day ] keep - [ set-timestamp-month ] keep - set-timestamp-year ; - -: set-time ( hour minute second timestamp -- ) - [ set-timestamp-second ] keep - [ set-timestamp-minute ] keep - set-timestamp-hour ; - : >date< ( timestamp -- year month day ) - [ timestamp-year ] keep - [ timestamp-month ] keep - timestamp-day ; + { year>> month>> day>> } get-slots ; : >time< ( timestamp -- hour minute second ) - [ timestamp-hour ] keep - [ timestamp-minute ] keep - timestamp-second ; + { hour>> minute>> second>> } get-slots ; -: zero-dt ( --
) 0 0 0 0 0 0
; -: years ( n -- dt ) zero-dt [ set-dt-year ] keep ; -: months ( n -- dt ) zero-dt [ set-dt-month ] keep ; -: days ( n -- dt ) zero-dt [ set-dt-day ] keep ; +: instant ( -- dt ) 0 0 0 0 0 0 ; +: years ( n -- dt ) instant swap >>year ; +: months ( n -- dt ) instant swap >>month ; +: days ( n -- dt ) instant swap >>day ; : weeks ( n -- dt ) 7 * days ; -: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ; -: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ; -: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ; -: milliseconds ( n -- dt ) 1000 /f seconds ; +: hours ( n -- dt ) instant swap >>hour ; +: minutes ( n -- dt ) instant swap >>minute ; +: seconds ( n -- dt ) instant swap >>second ; +: milliseconds ( n -- dt ) 1000 / seconds ; -: julian-day-number>timestamp ( n -- timestamp ) - julian-day-number>date 0 0 0 0 ; +GENERIC: leap-year? ( obj -- ? ) + +M: integer leap-year? ( year -- ? ) + dup 100 mod zero? 400 4 ? mod zero? ; + +M: timestamp leap-year? ( timestamp -- ? ) + year>> leap-year? ; + +integer ] 2keep rem ; + [ / floor >integer ] 2keep rem ; : float>whole-part ( float -- int float ) [ floor >integer ] keep over - ; -GENERIC: leap-year? ( obj -- ? ) -M: integer leap-year? ( year -- ? ) - dup 100 mod zero? 400 4 ? mod zero? ; - -M: timestamp leap-year? ( timestamp -- ? ) - timestamp-year leap-year? ; - : adjust-leap-year ( timestamp -- timestamp ) - dup >date< 29 = swap 2 = and swap leap-year? not and [ - dup >r timestamp-year 3 1 r> [ set-date ] keep - ] when ; + dup day>> 29 = over month>> 2 = pick leap-year? not and and + [ 3 >>month 1 >>day ] when ; + +: unless-zero >r dup zero? [ drop ] r> if ; inline M: integer +year ( timestamp n -- timestamp ) - over timestamp-year + swap [ set-timestamp-year ] keep - adjust-leap-year ; + [ [ + ] curry change-year adjust-leap-year ] unless-zero ; + M: real +year ( timestamp n -- timestamp ) - float>whole-part rot swap 365.2425 * +day swap +year ; + [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ; + +: months/years ( n -- months years ) + 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline M: integer +month ( timestamp n -- timestamp ) - over timestamp-month + 12 /rem - dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month - +year ; + [ over month>> + months/years >r >>month r> +year ] unless-zero ; + M: real +month ( timestamp n -- timestamp ) - float>whole-part rot swap average-month * +day swap +month ; + [ float>whole-part swapd average-month * +day swap +month ] unless-zero ; M: integer +day ( timestamp n -- timestamp ) - swap [ - >date< julian-day-number + julian-day-number>timestamp - ] keep swap >r >time< r> [ set-time ] keep ; + [ + over >date< julian-day-number + julian-day-number>date + >r >r >>year r> >>month r> >>day + ] unless-zero ; + M: real +day ( timestamp n -- timestamp ) - float>whole-part rot swap 24 * +hour swap +day ; + [ float>whole-part swapd 24 * +hour swap +day ] unless-zero ; + +: hours/days ( n -- hours days ) + 24 /rem swap ; M: integer +hour ( timestamp n -- timestamp ) - over timestamp-hour + 24 /rem pick set-timestamp-hour - +day ; + [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ; + M: real +hour ( timestamp n -- timestamp ) - float>whole-part rot swap 60 * +minute swap +hour ; + float>whole-part swapd 60 * +minute swap +hour ; + +: minutes/hours ( n -- minutes hours ) + 60 /rem swap ; M: integer +minute ( timestamp n -- timestamp ) - over timestamp-minute + 60 /rem pick - set-timestamp-minute +hour ; + [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ; + M: real +minute ( timestamp n -- timestamp ) - float>whole-part rot swap 60 * +second swap +minute ; + [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ; + +: seconds/minutes ( n -- seconds minutes ) + 60 /rem swap >integer ; M: number +second ( timestamp n -- timestamp ) - over timestamp-second + 60 /rem >r >integer r> - pick set-timestamp-second +minute ; + [ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ; -: +dt ( timestamp dt -- timestamp ) - dupd - [ dt-second +second ] keep - [ dt-minute +minute ] keep - [ dt-hour +hour ] keep - [ dt-day +day ] keep - [ dt-month +month ] keep - dt-year +year - swap timestamp-gmt-offset over set-timestamp-gmt-offset ; +: (time+) + [ second>> +second ] keep + [ minute>> +minute ] keep + [ hour>> +hour ] keep + [ day>> +day ] keep + [ month>> +month ] keep + [ year>> +year ] keep ; inline -: make-timestamp ( year month day hour minute second gmt-offset -- timestamp ) - [ 0 seconds +dt ] keep - [ = [ "invalid timestamp" throw ] unless ] keep ; +: +slots [ 2apply + ] curry 2keep ; inline -: make-date ( year month day -- timestamp ) - 0 0 0 gmt-offset make-timestamp ; +PRIVATE> -: array>dt ( vec -- dt ) { dt f } swap append >tuple ; -: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ; +GENERIC# time+ 1 ( time dt -- time ) + +M: timestamp time+ + >r clone r> (time+) drop ; + +M: duration time+ + dup timestamp? [ + swap time+ + ] [ + [ year>> ] +slots + [ month>> ] +slots + [ day>> ] +slots + [ hour>> ] +slots + [ minute>> ] +slots + [ second>> ] +slots + 2drop + ] if ; : dt>years ( dt -- x ) #! Uses average month/year length since dt loses calendar #! data - tuple-slots - { 1 12 365.2425 8765.82 525949.2 31556952.0 } - v/ sum ; + 0 swap + [ year>> + ] keep + [ month>> months-per-year / + ] keep + [ day>> days-per-year / + ] keep + [ hour>> hours-per-year / + ] keep + [ minute>> minutes-per-year / + ] keep + second>> seconds-per-year / + ; -: dt>months ( dt -- x ) dt>years 12 * ; -: dt>days ( dt -- x ) dt>years 365.2425 * ; -: dt>hours ( dt -- x ) dt>years 8765.82 * ; -: dt>minutes ( dt -- x ) dt>years 525949.2 * ; -: dt>seconds ( dt -- x ) dt>years 31556952 * ; -: dt>milliseconds ( dt -- x ) dt>years 31556952000 * ; +M: duration <=> [ dt>years ] compare ; + +: dt>months ( dt -- x ) dt>years months-per-year * ; +: dt>days ( dt -- x ) dt>years days-per-year * ; +: dt>hours ( dt -- x ) dt>years hours-per-year * ; +: dt>minutes ( dt -- x ) dt>years minutes-per-year * ; +: dt>seconds ( dt -- x ) dt>years seconds-per-year * ; +: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ; : convert-timezone ( timestamp n -- timestamp ) - [ over timestamp-gmt-offset - hours +dt ] keep - over set-timestamp-gmt-offset ; + over gmt-offset>> over = [ drop ] [ + [ over gmt-offset>> - hours time+ ] keep >>gmt-offset + ] if ; : >local-time ( timestamp -- timestamp ) gmt-offset convert-timezone ; @@ -216,45 +240,54 @@ M: number +second ( timestamp n -- timestamp ) M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; -: timestamp- ( timestamp timestamp -- seconds ) - #! Exact calendar-time difference +: (time-) ( timestamp timestamp -- n ) [ >gmt ] 2apply [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; +GENERIC: time- ( time1 time2 -- time ) + +M: timestamp time- + #! Exact calendar-time difference + (time-) seconds ; + +: before ( dt -- -dt ) + [ year>> neg ] keep + [ month>> neg ] keep + [ day>> neg ] keep + [ hour>> neg ] keep + [ minute>> neg ] keep + second>> neg + ; + +M: duration time- + before time+ ; + +: 0 0 0 0 0 0 0 ; + +: valid-timestamp? ( timestamp -- ? ) + clone 0 >>gmt-offset + dup time- time+ = ; + : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; + 1970 1 1 0 0 0 0 ; foldable : millis>timestamp ( n -- timestamp ) - >r unix-1970 r> 1000 /f seconds +dt ; + >r unix-1970 r> milliseconds time+ ; : timestamp>millis ( timestamp -- n ) - unix-1970 timestamp- 1000 * >integer ; - -: unix-time>timestamp ( n -- timestamp ) - >r unix-1970 r> seconds +dt ; - -: timestamp>unix-time ( timestamp -- n ) - unix-1970 timestamp- >integer ; - -: timestamp>timeval ( timestamp -- timeval ) - timestamp>unix-time 1000 * make-timeval ; - -: timeval>timestamp ( timeval -- timestamp ) - [ timeval-sec ] keep - timeval-usec 1000000 / + unix-time>timestamp ; - + unix-1970 (time-) 1000 * >integer ; : gmt ( -- timestamp ) #! GMT time, right now - unix-1970 millis 1000 /f seconds +dt ; + unix-1970 millis milliseconds time+ ; : now ( -- timestamp ) gmt >local-time ; -: before ( dt -- -dt ) tuple-slots vneg array>dt ; -: from-now ( dt -- timestamp ) now swap +dt ; -: ago ( dt -- timestamp ) before from-now ; -: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; +: from-now ( dt -- timestamp ) now swap time+ ; +: ago ( dt -- timestamp ) now swap time- ; + +: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline : zeller-congruence ( year month day -- n ) #! Zeller Congruence @@ -268,7 +301,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) GENERIC: days-in-year ( obj -- n ) M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; -M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ; +M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; GENERIC: days-in-month ( obj -- n ) @@ -280,7 +313,7 @@ M: array days-in-month ( obj -- n ) ] if ; M: timestamp days-in-month ( timestamp -- n ) - { timestamp-year timestamp-month } get-slots 2array days-in-month ; + >date< drop 2array days-in-month ; GENERIC: day-of-week ( obj -- n ) @@ -297,156 +330,20 @@ M: array day-of-year ( array -- n ) 3dup day-counts rot head-slice sum + swap leap-year? [ -roll - pick 3 1 make-date >r make-date r> - <=> 0 >= [ 1+ ] when + pick 3 1 >r r> + after=? [ 1+ ] when ] [ - 3nip + >r 3drop r> ] if ; M: timestamp day-of-year ( timestamp -- n ) - { timestamp-year timestamp-month timestamp-day } get-slots - 3array day-of-year ; - -GENERIC: day. ( obj -- ) - -M: integer day. ( n -- ) - number>string dup length 2 < [ bl ] when write ; - -M: timestamp day. ( timestamp -- ) - timestamp-day day. ; - -GENERIC: month. ( obj -- ) - -M: array month. ( pair -- ) - first2 - [ month-names nth write bl number>string print ] 2keep - [ 1 zeller-congruence ] 2keep - 2array days-in-month day-abbreviations2 " " join print - over " " concat write - [ - [ 1+ day. ] keep - 1+ + 7 mod zero? [ nl ] [ bl ] if - ] with each nl ; - -M: timestamp month. ( timestamp -- ) - { timestamp-year timestamp-month } get-slots 2array month. ; - -GENERIC: year. ( obj -- ) - -M: integer year. ( n -- ) - 12 [ 1+ 2array month. nl ] with each ; - -M: timestamp year. ( timestamp -- ) - timestamp-year year. ; - -: pad-00 number>string 2 CHAR: 0 pad-left ; - -: write-00 pad-00 write ; - -: (timestamp>string) ( timestamp -- ) - dup day-of-week day-abbreviations3 nth write ", " write - dup timestamp-day number>string write bl - dup timestamp-month month-abbreviations nth write bl - dup timestamp-year number>string write bl - dup timestamp-hour write-00 ":" write - dup timestamp-minute write-00 ":" write - timestamp-second >fixnum write-00 ; - -: timestamp>string ( timestamp -- str ) - [ (timestamp>string) ] with-string-writer ; - -: (write-gmt-offset) ( ratio -- ) - 1 /mod swap write-00 60 * write-00 ; - -: write-gmt-offset ( gmt-offset -- ) - { - { [ dup zero? ] [ drop "GMT" write ] } - { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } - { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } - } cond ; - -: timestamp>rfc822-string ( timestamp -- str ) - #! RFC822 timestamp format - #! Example: Tue, 15 Nov 1994 08:12:31 +0200 - [ - dup (timestamp>string) - " " write - timestamp-gmt-offset write-gmt-offset - ] with-string-writer ; - -: timestamp>http-string ( timestamp -- str ) - #! http timestamp format - #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt timestamp>rfc822-string ; - -: write-rfc3339-gmt-offset ( n -- ) - dup zero? [ drop "Z" write ] [ - dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if - 60 * 60 /mod swap write-00 CHAR: : write1 write-00 - ] if ; - -: (timestamp>rfc3339) ( timestamp -- ) - dup timestamp-year number>string write CHAR: - write1 - dup timestamp-month write-00 CHAR: - write1 - dup timestamp-day write-00 CHAR: T write1 - dup timestamp-hour write-00 CHAR: : write1 - dup timestamp-minute write-00 CHAR: : write1 - dup timestamp-second >fixnum write-00 - timestamp-gmt-offset write-rfc3339-gmt-offset ; - -: timestamp>rfc3339 ( timestamp -- str ) - [ (timestamp>rfc3339) ] with-string-writer ; - -: expect ( str -- ) - read1 swap member? [ "Parse error" throw ] unless ; - -: read-00 2 read string>number ; - -: read-0000 4 read string>number ; - -: read-rfc3339-gmt-offset ( -- n ) - read1 dup CHAR: Z = [ drop 0 ] [ - { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case - read-00 - read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case - 60 / + * - ] if ; - -: (rfc3339>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day - "Tt" expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second - read-rfc3339-gmt-offset ! timezone - ; - -: rfc3339>timestamp ( str -- timestamp ) - [ (rfc3339>timestamp) ] with-string-reader ; - -: file-time-string ( timestamp -- string ) - [ - [ timestamp-month month-abbreviations nth write ] keep bl - [ timestamp-day number>string 2 32 pad-left write ] keep bl - dup now [ timestamp-year ] 2apply = [ - [ timestamp-hour write-00 ] keep ":" write - timestamp-minute write-00 - ] [ - timestamp-year number>string 5 32 pad-left write - ] if - ] with-string-writer ; + >date< 3array day-of-year ; : day-offset ( timestamp m -- timestamp n ) over day-of-week - ; inline : day-this-week ( timestamp n -- timestamp ) - day-offset days +dt ; + day-offset days time+ ; : sunday ( timestamp -- timestamp ) 0 day-this-week ; : monday ( timestamp -- timestamp ) 1 day-this-week ; @@ -457,25 +354,26 @@ M: timestamp year. ( timestamp -- ) : saturday ( timestamp -- timestamp ) 6 day-this-week ; : beginning-of-day ( timestamp -- new-timestamp ) - clone dup >r 0 0 0 r> - { set-timestamp-hour set-timestamp-minute set-timestamp-second } - set-slots ; inline + clone + 0 >>hour + 0 >>minute + 0 >>second ; inline : beginning-of-month ( timestamp -- new-timestamp ) - beginning-of-day 1 over set-timestamp-day ; + beginning-of-day 1 >>day ; : beginning-of-week ( timestamp -- new-timestamp ) beginning-of-day sunday ; : beginning-of-year ( timestamp -- new-timestamp ) - beginning-of-month 1 over set-timestamp-month ; + beginning-of-month 1 >>month ; -: seconds-since-midnight ( timestamp -- x ) - dup beginning-of-day timestamp- ; +: time-since-midnight ( timestamp -- duration ) + dup beginning-of-day time- ; M: timestamp sleep-until timestamp>millis sleep-until ; -M: dt sleep from-now 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..1f23d4f841 --- /dev/null +++ b/extra/calendar/format/format-tests.factor @@ -0,0 +1,22 @@ +IN: temporary +USING: calendar.format tools.test io.streams.string ; + +[ 0 ] [ + "Z" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ 1 ] [ + "+01" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ -1 ] [ + "-01" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ -1-1/2 ] [ + "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ 1+1/2 ] [ + "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor new file mode 100755 index 0000000000..75ceea8ea2 --- /dev/null +++ b/extra/calendar/format/format.factor @@ -0,0 +1,138 @@ +IN: calendar.format +USING: math math.parser kernel sequences io calendar +accessors arrays io.streams.string combinators accessors ; + +GENERIC: day. ( obj -- ) + +M: integer day. ( n -- ) + number>string dup length 2 < [ bl ] when write ; + +M: timestamp day. ( timestamp -- ) + day>> day. ; + +GENERIC: month. ( obj -- ) + +M: array month. ( pair -- ) + first2 + [ month-names nth write bl number>string print ] 2keep + [ 1 zeller-congruence ] 2keep + 2array days-in-month day-abbreviations2 " " join print + over " " concat write + [ + [ 1+ day. ] keep + 1+ + 7 mod zero? [ nl ] [ bl ] if + ] with each nl ; + +M: timestamp month. ( timestamp -- ) + { year>> month>> } get-slots 2array month. ; + +GENERIC: year. ( obj -- ) + +M: integer year. ( n -- ) + 12 [ 1+ 2array month. nl ] with each ; + +M: timestamp year. ( timestamp -- ) + year>> year. ; + +: pad-00 number>string 2 CHAR: 0 pad-left ; + +: write-00 pad-00 write ; + +: (timestamp>string) ( timestamp -- ) + dup day-of-week day-abbreviations3 nth write ", " write + dup day>> number>string write bl + dup month>> month-abbreviations nth write bl + dup year>> number>string write bl + dup hour>> write-00 ":" write + dup minute>> write-00 ":" write + second>> >integer write-00 ; + +: timestamp>string ( timestamp -- str ) + [ (timestamp>string) ] with-string-writer ; + +: (write-gmt-offset) ( ratio -- ) + 1 /mod swap write-00 60 * write-00 ; + +: write-gmt-offset ( gmt-offset -- ) + { + { [ dup zero? ] [ drop "GMT" write ] } + { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } + { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } + } cond ; + +: timestamp>rfc822-string ( timestamp -- str ) + #! RFC822 timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 +0200 + [ + dup (timestamp>string) + " " write + gmt-offset>> write-gmt-offset + ] with-string-writer ; + +: timestamp>http-string ( timestamp -- str ) + #! http timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 GMT + >gmt timestamp>rfc822-string ; + +: write-rfc3339-gmt-offset ( n -- ) + dup zero? [ drop "Z" write ] [ + dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if + 60 * 60 /mod swap write-00 CHAR: : write1 write-00 + ] if ; + +: (timestamp>rfc3339) ( timestamp -- ) + dup year>> number>string write CHAR: - write1 + dup month>> write-00 CHAR: - write1 + dup day>> write-00 CHAR: T write1 + dup hour>> write-00 CHAR: : write1 + dup minute>> write-00 CHAR: : write1 + dup second>> >fixnum write-00 + gmt-offset>> write-rfc3339-gmt-offset ; + +: timestamp>rfc3339 ( timestamp -- str ) + [ (timestamp>rfc3339) ] with-string-writer ; + +: expect ( str -- ) + read1 swap member? [ "Parse error" throw ] unless ; + +: read-00 2 read string>number ; + +: read-0000 4 read string>number ; + +: read-rfc3339-gmt-offset ( -- n ) + read1 dup CHAR: Z = [ drop 0 ] [ + { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case + read-00 + read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case + 60 / + * + ] if ; + +: (rfc3339>timestamp) ( -- timestamp ) + read-0000 ! year + "-" expect + read-00 ! month + "-" expect + read-00 ! day + "Tt" expect + read-00 ! hour + ":" expect + read-00 ! minute + ":" expect + read-00 ! second + read-rfc3339-gmt-offset ! timezone + ; + +: rfc3339>timestamp ( str -- timestamp ) + [ (rfc3339>timestamp) ] with-string-reader ; + +: file-time-string ( timestamp -- string ) + [ + [ month>> month-abbreviations nth write ] keep bl + [ day>> number>string 2 32 pad-left write ] keep bl + dup now [ year>> ] 2apply = [ + [ hour>> write-00 ] keep ":" write + minute>> write-00 + ] [ + year>> number>string 5 32 pad-left write + ] if + ] with-string-writer ; diff --git a/extra/calendar/format/summary.txt b/extra/calendar/format/summary.txt new file mode 100644 index 0000000000..b5360f7868 --- /dev/null +++ b/extra/calendar/format/summary.txt @@ -0,0 +1 @@ +Formatting dates and times diff --git a/extra/calendar/model/summary.txt b/extra/calendar/model/summary.txt new file mode 100644 index 0000000000..4cc85fd2b9 --- /dev/null +++ b/extra/calendar/model/summary.txt @@ -0,0 +1 @@ +Timestamp model updated every second diff --git a/extra/calendar/summary.txt b/extra/calendar/summary.txt index 4cc85fd2b9..63d1c3fec3 100644 --- a/extra/calendar/summary.txt +++ b/extra/calendar/summary.txt @@ -1 +1 @@ -Timestamp model updated every second +Operations on timestamps and durations diff --git a/extra/calendar/unix/unix-tests.factor b/extra/calendar/unix/unix-tests.factor deleted file mode 100644 index a35a60c6f3..0000000000 --- a/extra/calendar/unix/unix-tests.factor +++ /dev/null @@ -1,13 +0,0 @@ -USING: alien alien.c-types calendar calendar.unix -kernel math tools.test ; - -[ t ] [ 239293000 [ - unix-time>timestamp timestamp>timeval - timeval>timestamp timestamp>timeval *ulong -] keep = ] unit-test - - -[ t ] [ 23929000.3 [ - unix-time>timestamp timestamp>timeval - timeval>timestamp timestamp>timeval *ulong -] keep >bignum = ] unit-test diff --git a/extra/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/cocoa/cocoa-tests.factor b/extra/cocoa/cocoa-tests.factor index 1f94c051b7..44f0b50996 100644 --- a/extra/cocoa/cocoa-tests.factor +++ b/extra/cocoa/cocoa-tests.factor @@ -1,6 +1,7 @@ IN: temporary USING: cocoa cocoa.messages cocoa.subclassing cocoa.types -compiler kernel namespaces cocoa.classes tools.test memory ; +compiler kernel namespaces cocoa.classes tools.test memory +compiler.units ; CLASS: { { +superclass+ "NSObject" } diff --git a/extra/cocoa/plists/plists.factor b/extra/cocoa/plists/plists.factor index 32b35e9153..646a759c59 100644 --- a/extra/cocoa/plists/plists.factor +++ b/extra/cocoa/plists/plists.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: strings arrays hashtables assocs sequences xml.writer xml.utilities kernel namespaces ; +IN: cocoa.plists GENERIC: >plist ( obj -- tag ) diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index 831dad6b56..e06b97489b 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -11,7 +11,7 @@ concurrency.mailboxes threads sequences ; [ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test [ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ] -[ linked-error "Even" = ] must-fail-with +[ delegate "Even" = ] must-fail-with [ V{ 0 3 6 9 } ] [ 10 [ 3 mod zero? ] parallel-subset ] unit-test diff --git a/extra/concurrency/conditions/conditions.factor b/extra/concurrency/conditions/conditions.factor index 359ceaa9ae..b10aded671 100755 --- a/extra/concurrency/conditions/conditions.factor +++ b/extra/concurrency/conditions/conditions.factor @@ -8,7 +8,7 @@ IN: concurrency.conditions dup dlist-empty? [ drop ] [ pop-back resume-now ] if ; : notify-all ( dlist -- ) - [ resume-now ] dlist-slurp yield ; + [ resume-now ] dlist-slurp ; : queue-timeout ( queue timeout -- alarm ) #! Add an alarm which removes the current thread from the diff --git a/extra/concurrency/exchangers/exchangers-tests.factor b/extra/concurrency/exchangers/exchangers-tests.factor index 3e7f67b9f0..91338389d1 100755 --- a/extra/concurrency/exchangers/exchangers-tests.factor +++ b/extra/concurrency/exchangers/exchangers-tests.factor @@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers concurrency.count-downs concurrency.promises locals kernel threads ; -:: exchanger-test | | +:: exchanger-test ( -- ) [let | ex [ ] c [ 2 ] diff --git a/extra/concurrency/flags/flags-docs.factor b/extra/concurrency/flags/flags-docs.factor new file mode 100644 index 0000000000..1b2c1b754e --- /dev/null +++ b/extra/concurrency/flags/flags-docs.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: concurrency.flags + +HELP: flag +{ $class-description "A flag allows one thread to notify another when a condition is satisfied." } ; + +HELP: +{ $values { "flag" flag } } +{ $description "Creates a new flag." } ; + +HELP: raise-flag +{ $values { "flag" flag } } +{ $description "Raises a flag, notifying any threads waiting on it. Does nothing if the flag has already been raised." } ; + +HELP: wait-for-flag +{ $values { "flag" flag } } +{ $description "Waits for a flag to be raised. If the flag has already been raised, returns immediately." } ; + +HELP: lower-flag +{ $values { "flag" flag } } +{ $description "Attempts to lower a flag. If the flag has been raised previously, returns immediately, otherwise waits for it to be raised first." } ; + +ARTICLE: "concurrency.flags" "Flags" +"A " { $emphasis "flag" } " is a condition notification device which can be in one of two states: " { $emphasis "lowered" } " (the initial state) or " { $emphasis "raised" } "." +$nl +"The flag can be raised at any time; raising a raised flag does nothing. Lowering a flag if it has not been raised yet will wait for another thread to raise the flag." +$nl +"Essentially, a flag can be thought of as a counting semaphore where the count never goes above one." +{ $subsection flag } +{ $subsection flag? } +"Waiting for a flag to be raised:" +{ $subsection raise-flag } +{ $subsection wait-for-flag } +{ $subsection lower-flag } ; + +ABOUT: "concurrency.flags" diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor new file mode 100644 index 0000000000..888b617b85 --- /dev/null +++ b/extra/concurrency/flags/flags.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: boxes kernel threads ; +IN: concurrency.flags + +TUPLE: flag value? thread ; + +: ( -- flag ) f flag construct-boa ; + +: raise-flag ( flag -- ) + dup flag-value? [ + dup flag-thread ?box + [ resume ] [ drop t over set-flag-value? ] if + ] unless drop ; + +: wait-for-flag ( flag -- ) + dup flag-value? [ drop ] [ + [ flag-thread >box ] curry "flag" suspend drop + ] if ; + +: lower-flag ( flag -- ) + dup flag-value? [ + f swap set-flag-value? + ] [ + wait-for-flag + ] if ; diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor index 8ebf6856a9..92f1a9f103 100755 --- a/extra/concurrency/locks/locks-tests.factor +++ b/extra/concurrency/locks/locks-tests.factor @@ -3,7 +3,7 @@ USING: tools.test concurrency.locks concurrency.count-downs concurrency.messaging concurrency.mailboxes locals kernel threads sequences calendar ; -:: lock-test-0 | | +:: lock-test-0 ( -- ) [let | v [ V{ } clone ] c [ 2 ] | @@ -27,7 +27,7 @@ threads sequences calendar ; v ] ; -:: lock-test-1 | | +:: lock-test-1 ( -- ) [let | v [ V{ } clone ] l [ ] c [ 2 ] | @@ -79,7 +79,7 @@ threads sequences calendar ; [ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test -:: rw-lock-test-1 | | +:: rw-lock-test-1 ( -- ) [let | l [ ] c [ 1 ] c' [ 1 ] @@ -129,7 +129,7 @@ threads sequences calendar ; [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test -:: rw-lock-test-2 | | +:: rw-lock-test-2 ( -- ) [let | l [ ] c [ 1 ] c' [ 2 ] @@ -160,7 +160,7 @@ threads sequences calendar ; [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test ! Test lock timeouts -:: lock-timeout-test | | +:: lock-timeout-test ( -- ) [let | l [ ] | [ l [ 1 seconds sleep ] with-lock @@ -174,5 +174,5 @@ threads sequences calendar ; ] ; [ lock-timeout-test ] [ - linked-thread thread-name "Lock timeout-er" = + linked-error-thread thread-name "Lock timeout-er" = ] must-fail-with diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index e5f12d5507..28b2fb7221 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -15,7 +15,7 @@ TUPLE: mailbox threads data ; : mailbox-put ( obj mailbox -- ) [ mailbox-data push-front ] keep - mailbox-threads notify-all ; + mailbox-threads notify-all yield ; : block-unless-pred ( pred mailbox timeout -- ) 2over mailbox-data dlist-contains? [ @@ -65,12 +65,23 @@ TUPLE: mailbox threads data ; : mailbox-get? ( pred mailbox -- obj ) f mailbox-get-timeout? ; inline -TUPLE: linked error thread ; +TUPLE: linked-error thread ; -C: linked +: ( error thread -- linked ) + { set-delegate set-linked-error-thread } + linked-error construct ; -: ?linked dup linked? [ rethrow ] when ; +: ?linked dup linked-error? [ rethrow ] when ; + +TUPLE: linked-thread supervisor ; + +M: linked-thread error-in-thread + [ ] keep + linked-thread-supervisor mailbox-put ; + +: ( quot name mailbox -- thread' ) + >r linked-thread construct-delegate r> + over set-linked-thread-supervisor ; : spawn-linked-to ( quot name mailbox -- thread ) - [ >r r> mailbox-put ] curry - [ (spawn) ] keep ; + [ (spawn) ] keep ; diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 5f241b77e3..3f6e4e3ed8 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -29,7 +29,7 @@ IN: temporary "crash" throw ] "Linked test" spawn-linked drop receive -] [ linked-error "crash" = ] must-fail-with +] [ delegate "crash" = ] must-fail-with MATCH-VARS: ?from ?to ?value ; SYMBOL: increment diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index 97cd45190f..6915653eb4 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -32,7 +32,7 @@ M: thread send ( message thread -- ) my-mailbox swap mailbox-get-timeout? ?linked ; inline : rethrow-linked ( error process supervisor -- ) - >r r> send ; + >r r> send ; : spawn-linked ( quot name -- thread ) my-mailbox spawn-linked-to ; diff --git a/extra/concurrency/semaphores/semaphores-docs.factor b/extra/concurrency/semaphores/semaphores-docs.factor index 7f8b9b017a..76a87f2077 100755 --- a/extra/concurrency/semaphores/semaphores-docs.factor +++ b/extra/concurrency/semaphores/semaphores-docs.factor @@ -9,7 +9,7 @@ HELP: { $description "Creates a counting semaphore with the specified initial count." } ; HELP: acquire-timeout -{ $values { "semaphore" semaphore } { "timeout" "a " { $link dt } " or " { $link f } } { "value" object } } +{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "value" object } } { $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." } { $errors "Throws an error if the timeout expires before the semaphore is released." } ; @@ -22,7 +22,7 @@ HELP: release { $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ; HELP: with-semaphore-timeout -{ $values { "semaphore" semaphore } { "timeout" "a " { $link dt } " or " { $link f } } { "quot" quotation } } +{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } { $description "Calls the quotation with the semaphore held." } ; HELP: with-semaphore diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index fe215e32db..631a7a1020 100644 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -32,7 +32,7 @@ SYMBOL: old-d old-c c update-old-new old-d d update-old-new ; -:: (ABCD) | x s i k func a b c d | +:: (ABCD) ( x s i k func a b c d -- ) #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) a [ b get c get d get func call w+ diff --git a/extra/db/db.factor b/extra/db/db.factor index d88bbaee03..a577ff5fc5 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -1,16 +1,24 @@ ! 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 ; 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 ; @@ -23,18 +31,22 @@ HOOK: db-close db ( handle -- ) db-handle db-close ] with-variable ; -TUPLE: statement sql params handle bound? slot-names ; +TUPLE: statement handle sql in-params out-params bind-params bound? ; TUPLE: simple-statement ; TUPLE: prepared-statement ; - -HOOK: db ( str -- statement ) -HOOK: db ( str -- statement ) -GENERIC: prepare-statement ( statement -- ) -GENERIC: bind-statement* ( obj statement -- ) -GENERIC: reset-statement ( statement -- ) -GENERIC: insert-statement ( statement -- id ) - TUPLE: result-set sql params handle n max ; +: ( sql in out -- statement ) + { + set-statement-sql + set-statement-in-params + set-statement-out-params + } statement construct ; + +HOOK: db ( str in out -- statement ) +HOOK: db ( str in out -- statement ) +GENERIC: prepare-statement ( statement -- ) +GENERIC: bind-statement* ( statement -- ) +GENERIC: bind-tuple ( tuple statement -- ) GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) GENERIC: #columns ( result-set -- n ) @@ -42,12 +54,16 @@ GENERIC# row-column 1 ( result-set n -- obj ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) -: execute-statement ( statement -- ) query-results dispose ; +: execute-statement ( statement -- ) + dup sequence? [ + [ execute-statement ] each + ] [ + query-results dispose + ] if ; : bind-statement ( obj statement -- ) - dup statement-bound? [ dup reset-statement ] when - [ bind-statement* ] 2keep - [ set-statement-params ] keep + [ set-statement-bind-params ] keep + [ bind-statement* ] keep t swap set-statement-bound? ; : init-result-set ( result-set -- ) @@ -55,7 +71,7 @@ GENERIC: more-rows? ( result-set -- ? ) 0 swap set-result-set-n ; : ( query handle tuple -- result-set ) - >r >r { statement-sql statement-params } get-slots r> + >r >r { statement-sql statement-in-params } get-slots r> { set-result-set-sql set-result-set-params @@ -75,22 +91,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 +118,11 @@ HOOK: rollback-transaction db ( -- ) ] with-variable ; : sql-query ( sql -- rows ) - [ do-query ] with-disposal ; + f f [ default-query ] with-disposal ; : sql-command ( sql -- ) dup string? [ - [ execute-statement ] with-disposal + f f [ execute-statement ] with-disposal ] [ ! [ [ sql-command ] each diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor old mode 100644 new mode 100755 index c48eff964a..25b3a6d2cf --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -2,21 +2,25 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types -db.types ; +db.types tools.walker ascii splitting ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) dup zero? [ drop f ] [ - PQresultErrorMessage [ CHAR: \n = ] right-trim + PQresultErrorMessage [ blank? ] trim ] if ; : postgres-result-error ( res -- ) postgresql-result-error-message [ throw ] when* ; +: (postgresql-error-message) ( handle -- str ) + PQerrorMessage + "\n" split [ [ blank? ] trim ] map "\n" join ; + : postgresql-error-message ( -- str ) - db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ; + db get db-handle (postgresql-error-message) ; : postgresql-error ( res -- res ) dup [ postgresql-error-message throw ] unless ; @@ -27,7 +31,7 @@ IN: db.postgresql.lib : connect-postgres ( host port pgopts pgtty db user pass -- conn ) PQsetdbLogin - dup PQstatus zero? [ postgresql-error-message throw ] unless ; + dup PQstatus zero? [ (postgresql-error-message) throw ] unless ; : do-postgresql-statement ( statement -- res ) db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [ @@ -37,9 +41,9 @@ IN: db.postgresql.lib : do-postgresql-bound-statement ( statement -- res ) >r db get db-handle r> [ statement-sql ] keep - [ statement-params length f ] keep - statement-params - [ first number>string* malloc-char-string ] map >c-void*-array + [ statement-bind-params length f ] keep + statement-bind-params + [ number>string* malloc-char-string ] map >c-void*-array f f 0 PQexecParams dup postgresql-result-ok? [ dup postgresql-result-error-message swap PQclear throw diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor old mode 100644 new mode 100755 index 36b6fc829b..7ea2bb629a --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -1,13 +1,14 @@ ! 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 ; +USING: kernel db.postgresql alien continuations io classes +prettyprint sequences namespaces tools.test db +db.tuples db.types unicode.case ; IN: temporary IN: scratchpad : test-db ( -- postgresql-db ) - "localhost" "postgres" "" "factor-test" ; + { "localhost" "postgres" "" "factor-test" } postgresql-db ; IN: temporary [ ] [ test-db [ ] with-db ] unit-test @@ -39,7 +40,7 @@ IN: temporary ] [ test-db [ "select * from person where name = $1 and country = $2" - [ + f f [ { { "Jane" TEXT } { "New Zealand" TEXT } } over do-bound-query @@ -108,3 +109,248 @@ IN: temporary "select * from person" sql-query length ] with-db ] unit-test + + +: with-dummy-db ( quot -- ) + >r T{ postgresql-db } db r> with-variable ; + +! TEST TUPLE DB + +TUPLE: puppy id name age ; +: ( name age -- puppy ) + { set-puppy-name set-puppy-age } puppy construct ; + +puppy "PUPPY" { + { "id" "ID" +native-id+ +not-null+ } + { "name" "NAME" { VARCHAR 256 } } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: kitty id name age ; +: ( name age -- kitty ) + { set-kitty-name set-kitty-age } kitty construct ; + +kitty "KITTY" { + { "id" "ID" INTEGER +assigned-id+ } + { "name" "NAME" TEXT } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: basket id puppies kitties ; +basket "BASKET" +{ + { "id" "ID" +native-id+ +not-null+ } + { "location" "LOCATION" TEXT } + { "puppies" { +has-many+ puppy } } + { "kitties" { +has-many+ kitty } } +} define-persistent + +! Create table +[ + "create table puppy(id serial primary key not null, name varchar 256, age integer);" +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table create-table-sql >lower + ] with-variable +] unit-test + +[ + "create table kitty(id integer primary key, name text, age integer);" +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table create-table-sql >lower + ] with-variable +] unit-test + +[ + "create table basket(id serial primary key not null, location text);" +] [ + T{ postgresql-db } db [ + basket dup db-columns swap db-table create-table-sql >lower + ] with-variable +] unit-test + +! Create function +[ + "create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;" +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table create-function-sql >lower + ] with-variable +] unit-test + +! Drop table + +[ + "drop table puppy;" +] [ + T{ postgresql-db } db [ + puppy db-table drop-table-sql >lower + ] with-variable +] unit-test + +[ + "drop table kitty;" +] [ + T{ postgresql-db } db [ + kitty db-table drop-table-sql >lower + ] with-variable +] unit-test + +[ + "drop table basket;" +] [ + T{ postgresql-db } db [ + basket db-table drop-table-sql >lower + ] with-variable +] unit-test + + +! Drop function +[ + "drop function add_puppy(varchar, integer);" +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table drop-function-sql >lower + ] with-variable +] unit-test + +! Insert +[ +] [ + T{ postgresql-db } db [ + puppy + ] with-variable +] unit-test + +[ + "insert into kitty(id, name, age) values($1, $2, $3);" + { + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + T{ sql-spec f "name" "NAME" TEXT { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } + { } +] [ + T{ postgresql-db } db [ + kitty + ] with-variable +] unit-test + +! Update +[ + "update puppy set name = $1, age = $2 where id = $3" + { + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table >r >r >lower r> r> + ] with-variable +] unit-test + +[ + "update kitty set name = $1, age = $2 where id = $3" + { + T{ sql-spec f "name" "NAME" TEXT { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table >r >r >lower r> r> + ] with-variable +] unit-test + +! Delete +[ + "delete from puppy where id = $1" + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table >r >r >lower r> r> + ] with-variable +] unit-test + +[ + "delete from KITTY where ID = $1" + { + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table + ] with-variable +] unit-test + +! Select +[ + "select from PUPPY ID, NAME, AGE where NAME = $1;" + { T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } } + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } +] [ + T{ postgresql-db } db [ + T{ puppy f f "Mr. Clunkers" } + + ] with-variable +] unit-test diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 03746bcaa0..9383a9290c 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -4,25 +4,28 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges -combinators ; +combinators sequences.lib classes locals words tools.walker ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; TUPLE: postgresql-statement ; TUPLE: postgresql-result-set ; -: ( statement -- postgresql-statement ) +: ( statement in out -- postgresql-statement ) + postgresql-statement construct-delegate ; -: ( host user pass db -- obj ) - { - set-postgresql-db-host - set-postgresql-db-user - set-postgresql-db-pass - set-postgresql-db-db - } postgresql-db construct ; +M: postgresql-db make-db* ( seq tuple -- db ) + >r first4 r> [ + { + set-postgresql-db-host + set-postgresql-db-user + set-postgresql-db-pass + set-postgresql-db-db + } set-slots + ] keep ; M: postgresql-db db-open ( db -- ) - dup { + dup { postgresql-db-host postgresql-db-port postgresql-db-pgopts @@ -35,15 +38,15 @@ M: postgresql-db db-open ( db -- ) M: postgresql-db dispose ( db -- ) db-handle PQfinish ; -: with-postgresql ( host ust pass db quot -- ) - >r r> with-disposal ; - -M: postgresql-statement bind-statement* ( seq statement -- ) - set-statement-params ; - -M: postgresql-statement reset-statement ( statement -- ) +M: postgresql-statement bind-statement* ( statement -- ) drop ; +M: postgresql-statement bind-tuple ( tuple statement -- ) + [ + statement-in-params + [ sql-spec-slot-name swap get-slot-named ] with map + ] keep set-statement-bind-params ; + M: postgresql-result-set #rows ( result-set -- n ) result-set-handle PQntuples ; @@ -56,19 +59,8 @@ M: postgresql-result-set row-column ( result-set n -- obj ) M: postgresql-result-set row-column-typed ( result-set n type -- obj ) >r row-column r> sql-type>factor-type ; -M: postgresql-result-set sql-type>factor-type ( obj type -- newobj ) - { - { INTEGER [ string>number ] } - { BIG_INTEGER [ string>number ] } - { DOUBLE [ string>number ] } - [ drop ] - } case ; - -M: postgresql-statement insert-statement ( statement -- id ) - query-results [ 0 row-column ] with-disposal string>number ; - M: postgresql-statement query-results ( query -- result-set ) - dup statement-params [ + dup statement-bind-params [ over [ bind-statement ] keep do-postgresql-bound-statement ] [ @@ -96,17 +88,15 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) [ >r db get db-handle "" r> - dup statement-sql swap statement-params + dup statement-sql swap statement-in-params length f PQprepare postgresql-error ] keep set-statement-handle ; -M: postgresql-db ( sql -- statement ) - { set-statement-sql } statement construct +M: postgresql-db ( sql in out -- statement ) ; -M: postgresql-db ( sql -- statement ) - { set-statement-sql } statement construct - ; +M: postgresql-db ( sql in out -- statement ) + dup prepare-statement ; M: postgresql-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -117,139 +107,176 @@ M: postgresql-db commit-transaction ( -- ) M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -: postgresql-type-hash* ( -- assoc ) - H{ - { SERIAL "serial" } - } ; +SYMBOL: postgresql-counter +: bind-name% ( -- ) + CHAR: $ 0, + postgresql-counter [ inc ] keep get 0# ; -: postgresql-type-hash ( -- assoc ) +M: postgresql-db bind% ( spec -- ) + 1, bind-name% ; + +: postgresql-make ( class quot -- ) + >r sql-props r> + [ postgresql-counter off ] swap compose + { "" { } { } } nmake ; + +: create-table-sql ( class -- statement ) + [ + "create table " 0% 0% + "(" 0% + [ ", " 0% ] [ + dup sql-spec-column-name 0% + " " 0% + dup sql-spec-type t lookup-type 0% + modifiers 0% + ] interleave ");" 0% + ] postgresql-make ; + +: create-function-sql ( class -- statement ) + [ + >r remove-id r> + "create function add_" 0% dup 0% + "(" 0% + over [ "," 0% ] + [ + sql-spec-type f lookup-type 0% + ] interleave + ")" 0% + " returns bigint as '" 0% + + "insert into " 0% + dup 0% + "(" 0% + over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ") values(" 0% + swap [ ", " 0% ] [ drop bind-name% ] interleave + "); " 0% + "select currval(''" 0% 0% "_id_seq'');' language sql;" 0% + ] postgresql-make ; + +M: postgresql-db create-sql-statement ( class -- seq ) + [ + [ create-table-sql , ] keep + dup db-columns find-primary-key native-id? + [ create-function-sql , ] [ drop ] if + ] { } make ; + +: drop-function-sql ( class -- statement ) + [ + "drop function add_" 0% 0% + "(" 0% + remove-id + [ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave + ");" 0% + ] postgresql-make ; + +: drop-table-sql ( table -- statement ) + [ + "drop table " 0% 0% ";" 0% drop + ] postgresql-make ; + +M: postgresql-db drop-sql-statement ( class -- seq ) + [ + [ drop-table-sql , ] keep + dup db-columns find-primary-key native-id? + [ drop-function-sql , ] [ drop ] if + ] { } make ; + +M: postgresql-db ( class -- statement ) + [ + "select add_" 0% 0% + "(" 0% + dup find-primary-key 2, + remove-id + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] postgresql-make ; + +M: postgresql-db ( class -- statement ) + [ + "insert into " 0% 0% + "(" 0% + dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ")" 0% + + " values(" 0% + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] postgresql-make ; + +M: postgresql-db insert-tuple* ( tuple statement -- ) + query-modify-tuple ; + +M: postgresql-db ( class -- statement ) + [ + "update " 0% 0% + " set " 0% + dup remove-id + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + " where " 0% + find-primary-key + dup sql-spec-column-name 0% " = " 0% bind% + ] postgresql-make ; + +M: postgresql-db ( class -- statement ) + [ + "delete from " 0% 0% + " where " 0% + find-primary-key + dup sql-spec-column-name 0% " = " 0% bind% + ] postgresql-make ; + +M: postgresql-db ( tuple class -- statement ) + [ + ! tuple columns table + "select " 0% + over [ ", " 0% ] + [ dup sql-spec-column-name 0% 2, ] interleave + + " from " 0% 0% + [ sql-spec-slot-name swap get-slot-named ] with subset + " where " 0% + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ";" 0% + ] postgresql-make ; + +M: postgresql-db type-table ( -- hash ) H{ - { INTEGER "integer" } - { SERIAL "integer" } + { +native-id+ "integer" } { TEXT "text" } { VARCHAR "varchar" } + { INTEGER "integer" } { DOUBLE "real" } + { TIMESTAMP "timestamp" } } ; -: enquote ( str -- newstr ) "(" swap ")" 3append ; - -: postgresql-type ( str n/str -- newstr ) - " " swap number>string* enquote 3append ; - -: >sql-type* ( obj -- str ) - dup pair? [ - first2 >r >sql-type* r> postgresql-type - ] [ - dup postgresql-type-hash* at* [ - nip - ] [ - drop >sql-type - ] if - ] if ; - -M: postgresql-db >sql-type ( hash obj -- str ) - dup pair? [ - first2 >r >sql-type r> postgresql-type - ] [ - postgresql-type-hash at* [ - no-sql-type - ] unless - ] if ; - -: insert-function ( columns table -- sql ) - [ - >r remove-id r> - "create function add_" % dup % - "(" % - over [ "," % ] - [ third dup array? [ first ] when >sql-type % ] interleave - ")" % - " returns bigint as '" % - - 2dup "insert into " % - % - "(" % - dup [ ", " % ] [ second % ] interleave - ") " % - " values (" % - length [1,b] [ ", " % ] [ "$" % # ] interleave - "); " % - - "select currval(''" % % "_id_seq'');' language sql;" % - drop - ] "" make ; - -: drop-function ( columns table -- sql ) - [ - >r remove-id r> - "drop function add_" % % - "(" % - [ "," % ] [ third >sql-type % ] interleave - ")" % - ] "" make ; - -M: postgresql-db create-sql ( columns table -- seq ) - [ - [ - 2dup - "create table " % % - " (" % [ ", " % ] [ - dup second % " " % - dup third >sql-type* % " " % - sql-modifiers " " join % - ] interleave "); " % - ] "" make , - - over native-id? [ insert-function , ] [ 2drop ] if - ] { } make ; - -M: postgresql-db drop-sql ( columns table -- seq ) - [ - [ - dup "drop table " % % ";" % - ] "" make , - over native-id? [ drop-function , ] [ 2drop ] if - ] { } make ; - -M: postgresql-db insert-sql* ( columns table -- slot-names sql ) - [ - "select add_" % % - "(" % - length [1,b] [ ", " % ] [ "$" % # ] interleave - ")" % - ] "" make ; - -M: postgresql-db update-sql* ( columns table -- slot-names sql ) - [ - "update " % - % - " set " % - dup remove-id - dup length [1,b] swap 2array flip - [ ", " % ] [ first2 second % " = $" % # ] interleave - " where " % - [ primary-key? ] find nip second dup % " = $" % length 2 + # - ] "" make ; - -M: postgresql-db delete-sql* ( columns table -- slot-names sql ) - [ - "delete from " % - % - " where " % - first second % " = $1" % - ] "" make ; - -M: postgresql-db select-sql ( columns table -- slot-names sql ) - drop ; - -M: postgresql-db tuple>params ( columns tuple -- obj ) - [ >r dup third swap first r> get-slot-named swap ] - curry { } map>assoc ; - -: postgresql-db-modifiers ( -- hashtable ) +M: postgresql-db create-type-table ( -- hash ) H{ - { +native-id+ "not null primary key" } + { +native-id+ "serial primary key" } + } ; + +: postgresql-compound ( str n -- newstr ) + over { + { "default" [ first number>string join-space ] } + { "varchar" [ first number>string paren append ] } + { "references" [ + first2 >r [ unparse join-space ] keep db-columns r> + swap [ sql-spec-slot-name = ] with find nip + sql-spec-column-name paren append + ] } + [ "no compound found" 3array throw ] + } case ; + +M: postgresql-db compound-modifier ( str seq -- newstr ) + postgresql-compound ; + +M: postgresql-db modifier-table ( -- hashtable ) + H{ + { +native-id+ "primary key" } { +assigned-id+ "primary key" } + { +foreign-id+ "references" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } @@ -257,13 +284,5 @@ M: postgresql-db tuple>params ( columns tuple -- obj ) { +not-null+ "not null" } } ; -M: postgresql-db sql-modifiers* ( modifiers -- str ) - postgresql-db-modifiers swap [ - dup array? [ - first2 - >r swap at r> number>string* - " " swap 3append - ] [ - swap at - ] if - ] with map [ ] subset ; +M: postgresql-db compound-type ( str n -- newstr ) + postgresql-compound ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 85aa671d4d..648d8493dc 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -78,7 +78,8 @@ IN: db.sqlite.lib { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { SERIAL [ sqlite-bind-int-by-name ] } + { TIMESTAMP [ sqlite-bind-double-by-name ] } + { +native-id+ [ sqlite-bind-int-by-name ] } ! { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -102,6 +103,8 @@ IN: db.sqlite.lib { BIG_INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } + { TIMESTAMP [ sqlite3_column_double ] } + [ no-sql-type ] } case ; ! TODO diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor old mode 100644 new mode 100755 index d3388b4648..6c4b65ff9f --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,6 +1,6 @@ USING: io io.files io.launcher kernel namespaces prettyprint tools.test db.sqlite db sequences -continuations db.types ; +continuations db.types db.tuples unicode.case ; IN: temporary : test.db "extra/db/sqlite/test.db" resource-path ; @@ -89,3 +89,158 @@ IN: temporary "select * from person" sql-query length ] with-sqlite ] unit-test + +! TEST TUPLE DB + +TUPLE: puppy id name age ; +: ( name age -- puppy ) + { set-puppy-name set-puppy-age } puppy construct ; + +puppy "PUPPY" { + { "id" "ID" +native-id+ +not-null+ } + { "name" "NAME" { VARCHAR 256 } } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: kitty id name age ; +: ( name age -- kitty ) + { set-kitty-name set-kitty-age } kitty construct ; + +kitty "KITTY" { + { "id" "ID" INTEGER +assigned-id+ } + { "name" "NAME" TEXT } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: basket id puppies kitties ; +basket "BASKET" +{ + { "id" "ID" +native-id+ +not-null+ } + { "location" "LOCATION" TEXT } + { "puppies" { +has-many+ puppy } } + { "kitties" { +has-many+ kitty } } +} define-persistent + +! Create table +[ + "create table puppy(id integer primary key not null, name varchar, age integer);" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +[ + "create table kitty(id integer primary key, name text, age integer);" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +[ + "create table basket(id integer primary key not null, location text);" +] [ + T{ sqlite-db } db [ + basket dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +! Drop table +[ + "drop table puppy;" +] [ + T{ sqlite-db } db [ + puppy db-table drop-sql >lower + ] with-variable +] unit-test + +[ + "drop table kitty;" +] [ + T{ sqlite-db } db [ + kitty db-table drop-sql >lower + ] with-variable +] unit-test + +[ + "drop table basket;" +] [ + T{ sqlite-db } db [ + basket db-table drop-sql >lower + ] with-variable +] unit-test + +! Insert +[ + "insert into puppy(name, age) values(:name, :age);" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table insert-sql* >lower + ] with-variable +] unit-test + +[ + "insert into kitty(id, name, age) values(:id, :name, :age);" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table insert-sql* >lower + ] with-variable +] unit-test + +! Update +[ + "update puppy set name = :name, age = :age where id = :id" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table update-sql* >lower + ] with-variable +] unit-test + +[ + "update kitty set name = :name, age = :age where id = :id" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table update-sql* >lower + ] with-variable +] unit-test + +! Delete +[ + "delete from puppy where id = :id" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table delete-sql* >lower + ] with-variable +] unit-test + +[ + "delete from kitty where id = :id" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table delete-sql* >lower + ] with-variable +] unit-test + +! Select +[ + "select from puppy id, name, age where name = :name;" + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } +] [ + T{ sqlite-db } db [ + T{ puppy f f "Mr. Clunkers" } + select-sql >r >lower r> + ] with-variable +] unit-test diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 4eabfc2ecd..b980e99718 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -4,11 +4,14 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types ; +words combinators.lib db.types combinators tools.walker +combinators.cleave ; IN: db.sqlite TUPLE: sqlite-db path ; -C: sqlite-db + +M: sqlite-db make-db* ( path db -- db ) + [ set-sqlite-db-path ] keep ; M: sqlite-db db-open ( db -- ) dup sqlite-db-path sqlite-open @@ -19,11 +22,7 @@ M: sqlite-db db-close ( handle -- ) M: sqlite-db dispose ( db -- ) dispose-db ; -: with-sqlite ( path quot -- ) - >r r> with-db ; inline - TUPLE: sqlite-statement ; -C: sqlite-statement TUPLE: sqlite-result-set has-more? ; @@ -31,9 +30,14 @@ M: sqlite-db ( str -- obj ) ; M: sqlite-db ( str -- obj ) - db get db-handle over sqlite-prepare - { set-statement-sql set-statement-handle } statement construct - [ set-delegate ] keep ; + { + set-statement-sql + set-statement-in-params + set-statement-out-params + } statement construct + db get db-handle over statement-sql sqlite-prepare + over set-statement-handle + sqlite-statement construct-delegate ; M: sqlite-statement dispose ( statement -- ) statement-handle sqlite-finalize ; @@ -44,18 +48,30 @@ 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 + [ set-statement-bind-params ] keep bind-statement* ; + : last-insert-id ( -- id ) db get db-handle sqlite3_last_insert_rowid dup zero? [ "last-id failed" throw ] when ; -M: sqlite-statement insert-statement ( statement -- id ) - execute-statement last-insert-id ; +M: sqlite-db insert-tuple* ( tuple statement -- ) + execute-statement last-insert-id swap set-primary-key ; M: sqlite-result-set #columns ( result-set -- n ) result-set-handle sqlite-#columns ; @@ -86,78 +102,83 @@ M: sqlite-db commit-transaction ( -- ) M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -M: sqlite-db create-sql ( columns table -- sql ) - [ - "create table " % % - " (" % [ ", " % ] [ - dup second % " " % - dup third >sql-type % " " % - sql-modifiers " " join % - ] interleave ")" % - ] "" make ; +: sqlite-make ( class quot -- ) + >r sql-props r> + { "" { } { } } nmake ; -M: sqlite-db drop-sql ( columns table -- sql ) +M: sqlite-db create-sql-statement ( class -- statement ) [ - "drop table " % % - drop - ] "" make ; + "create table " 0% 0% + "(" 0% [ ", " 0% ] [ + dup sql-spec-column-name 0% + " " 0% + dup sql-spec-type t lookup-type 0% + modifiers 0% + ] interleave ");" 0% + ] sqlite-make ; -M: sqlite-db insert-sql* ( columns table -- sql ) +M: sqlite-db drop-sql-statement ( class -- statement ) [ - "insert into " % - % - "(" % - dup [ ", " % ] [ second % ] interleave - ") " % - " values (" % - [ ", " % ] [ ":" % second % ] interleave - ")" % - ] "" make ; + "drop table " 0% 0% ";" 0% drop + ] sqlite-make ; -: where-primary-key% ( columns -- ) - " where " % - [ primary-key? ] find nip second dup % " = :" % % ; - -M: sqlite-db update-sql* ( columns table -- sql ) +M: sqlite-db ( tuple -- statement ) [ - "update " % - % - " set " % + "insert into " 0% 0% + "(" 0% + maybe-remove-id + dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ") values(" 0% + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] sqlite-make ; + +M: sqlite-db ( tuple -- statement ) + ; + +: where-primary-key% ( specs -- ) + " where " 0% + find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ; + +M: sqlite-db ( class -- statement ) + [ + "update " 0% + 0% + " set " 0% dup remove-id - [ ", " % ] [ second dup % " = :" % % ] interleave + [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave where-primary-key% - ] "" make ; + ] sqlite-make ; -M: sqlite-db delete-sql* ( columns table -- sql ) +M: sqlite-db ( specs table -- sql ) [ - "delete from " % - % - " where " % - first second dup % " = :" % % - ] "" make ; + "delete from " 0% 0% + " where " 0% + find-primary-key + dup sql-spec-column-name 0% " = " 0% bind% + ] sqlite-make ; -: select-interval ( interval name -- ) - ; +! : select-interval ( interval name -- ) ; +! : select-sequence ( seq name -- ) ; -: select-sequence ( seq name -- ) - ; +M: sqlite-db bind% ( spec -- ) + dup 1, sql-spec-column-name ":" swap append 0% ; -M: sqlite-db select-sql ( columns table -- sql ) +M: sqlite-db ( tuple class -- statement ) [ - "select ROWID, " % - over [ ", " % ] [ second % ] interleave - " from " % % - " where " % - ] "" make ; + "select " 0% + over [ ", " 0% ] + [ dup sql-spec-column-name 0% 2, ] interleave -M: sqlite-db tuple>params ( columns tuple -- obj ) - [ - >r [ second ":" swap append ] keep r> - dupd >r first r> get-slot-named swap - third 3array - ] curry map ; + " from " 0% 0% + [ sql-spec-slot-name swap get-slot-named ] with subset + " where " 0% + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ";" 0% + ] sqlite-make ; -: sqlite-db-modifiers ( -- hashtable ) +M: sqlite-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } @@ -168,33 +189,24 @@ M: sqlite-db tuple>params ( columns tuple -- obj ) { +not-null+ "not null" } } ; -M: sqlite-db sql-modifiers* ( modifiers -- str ) - sqlite-db-modifiers swap [ - dup array? [ - first2 - >r swap at r> number>string* - " " swap 3append - ] [ - swap at - ] if - ] with map [ ] subset ; +M: sqlite-db compound-modifier ( str obj -- newstr ) + compound-type ; -: sqlite-type-hash ( -- assoc ) +M: sqlite-db compound-type ( str seq -- newstr ) + over { + { "default" [ first number>string join-space ] } + [ 2drop ] ! "no sqlite compound data type" 3array throw ] + } case ; + +M: sqlite-db type-table ( -- assoc ) H{ + { +native-id+ "integer primary key" } { INTEGER "integer" } - { SERIAL "integer" } { TEXT "text" } { VARCHAR "text" } + { TIMESTAMP "timestamp" } { DOUBLE "real" } } ; -M: sqlite-db >sql-type ( obj -- str ) - dup pair? [ - first >sql-type - ] [ - sqlite-type-hash at* [ T{ no-sql-type } throw ] unless - ] if ; - -! HOOK: get-column-value ( n result-set type -- ) -! M: sqlite get-column-value { { "TEXT" get-text-column } { -! "INTEGER" get-integer-column } ... } case ; +M: sqlite-db create-type-table + type-table ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index ea57193750..c9e6d302e0 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,70 +1,119 @@ ! 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 ; +USING: io.files kernel tools.test db db.tuples +db.types continuations namespaces db.postgresql math +prettyprint tools.walker db.sqlite ; IN: temporary -TUPLE: person the-id the-name the-number real ; +TUPLE: person the-id the-name the-number the-real ; : ( name age real -- person ) { set-person-the-name set-person-the-number - set-person-real + set-person-the-real } person construct ; -: ( id name number real -- obj ) +: ( id name number the-real -- obj ) [ set-person-the-id ] keep ; -SYMBOL: the-person +SYMBOL: the-person1 +SYMBOL: the-person2 : test-tuples ( -- ) [ person drop-table ] [ drop ] recover [ ] [ person create-table ] unit-test + [ person create-table ] must-fail - [ ] [ the-person get insert-tuple ] unit-test + [ ] [ the-person1 get insert-tuple ] unit-test - [ 1 ] [ the-person get person-the-id ] unit-test + [ 1 ] [ the-person1 get person-the-id ] unit-test - 200 the-person get set-person-the-number + 200 the-person1 get set-person-the-number - [ ] [ the-person get update-tuple ] unit-test + [ ] [ the-person1 get update-tuple ] unit-test - [ ] [ the-person get delete-tuple ] unit-test - ; ! 1 [ ] [ person drop-table ] unit-test ; + [ T{ person f 1 "billy" 200 3.14 } ] + [ T{ person f 1 } select-tuple ] unit-test + [ ] [ the-person2 get insert-tuple ] unit-test + [ + { + T{ person f 1 "billy" 200 3.14 } + T{ person f 2 "johnny" 10 3.14 } + } + ] [ T{ person f f f f 3.14 } select-tuples ] unit-test + + [ ] [ the-person1 get delete-tuple ] unit-test + [ f ] [ T{ person f 1 } select-tuple ] unit-test + [ ] [ person drop-table ] unit-test ; : test-sqlite ( -- ) - "tuples-test.db" resource-path [ + "tuples-test.db" resource-path sqlite-db [ test-tuples ] with-db ; : test-postgresql ( -- ) - "localhost" "postgres" "" "factor-test" [ + { "localhost" "postgres" "" "factor-test" } postgresql-db [ test-tuples ] with-db ; person "PERSON" { - { "the-id" "ID" SERIAL +native-id+ } + { "the-id" "ID" +native-id+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } - { "real" "REAL" DOUBLE { +default+ 0.3 } } + { "the-real" "REAL" DOUBLE { +default+ 0.3 } } } define-persistent -"billy" 10 3.14 the-person set +"billy" 10 3.14 the-person1 set +"johnny" 10 3.14 the-person2 set -! test-sqlite - test-postgresql - -! person "PERSON" -! { - ! { "the-id" "ID" INTEGER +assigned-id+ } - ! { "the-name" "NAME" { VARCHAR 256 } +not-null+ } - ! { "the-number" "AGE" INTEGER { +default+ 0 } } - ! { "real" "REAL" DOUBLE { +default+ 0.3 } } -! } define-persistent - -! 1 "billy" 20 6.28 the-person set - -! test-sqlite +test-sqlite ! test-postgresql + +person "PERSON" +{ + { "the-id" "ID" INTEGER +assigned-id+ } + { "the-name" "NAME" { VARCHAR 256 } +not-null+ } + { "the-number" "AGE" INTEGER { +default+ 0 } } + { "the-real" "REAL" DOUBLE { +default+ 0.3 } } +} define-persistent + +1 "billy" 10 3.14 the-person1 set +2 "johnny" 10 3.14 the-person2 set + +test-sqlite +! test-postgresql + +TUPLE: paste n summary author channel mode contents timestamp annotations ; +TUPLE: annotation n paste-id summary author mode contents ; + +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 diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 20cdd8a386..e7fe7e49c2 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -1,115 +1,111 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes db kernel namespaces -tuples words sequences slots slots.private math -math.parser io prettyprint db.types continuations ; +tuples words sequences slots math +math.parser io prettyprint db.types continuations +mirrors sequences.lib tools.walker combinators.lib ; IN: db.tuples -: db-columns ( class -- obj ) "db-columns" word-prop ; +: define-persistent ( class table columns -- ) + >r dupd "db-table" set-word-prop dup r> + [ relation? ] partition swapd + dupd [ spec>tuple ] with map + "db-columns" set-word-prop + "db-relations" set-word-prop ; + : db-table ( class -- obj ) "db-table" word-prop ; +: db-columns ( class -- obj ) "db-columns" word-prop ; +: db-relations ( class -- obj ) "db-relations" word-prop ; -TUPLE: no-slot-named ; -: no-slot-named ( -- * ) T{ no-slot-named } throw ; +: set-primary-key ( key tuple -- ) + [ + class db-columns find-primary-key sql-spec-slot-name + ] keep set-slot-named ; -: slot-spec-named ( str class -- slot-spec ) - "slots" word-prop [ slot-spec-name = ] with find nip - [ no-slot-named ] unless* ; +! returns a sequence of prepared-statements +HOOK: create-sql-statement db ( class -- obj ) +HOOK: drop-sql-statement db ( class -- obj ) -: offset-of-slot ( str obj -- n ) - class slot-spec-named slot-spec-offset ; +HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) -: get-slot-named ( str obj -- value ) - tuck offset-of-slot [ no-slot-named ] unless* slot ; +HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) -: set-slot-named ( value str obj -- ) - tuck offset-of-slot [ no-slot-named ] unless* set-slot ; +HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) -: primary-key-spec ( class -- spec ) - db-columns [ primary-key? ] find nip ; - -: primary-key ( tuple -- obj ) - dup class primary-key-spec get-slot-named ; - -: set-primary-key ( obj tuple -- ) - [ class primary-key-spec first ] keep - set-slot-named ; - -: cache-statement ( columns class assoc quot -- statement ) - [ db-table dupd ] swap - [ ] 3compose cache nip ; inline - -HOOK: create-sql db ( columns table -- seq ) -HOOK: drop-sql db ( columns table -- seq ) - -HOOK: insert-sql* db ( columns table -- slot-names sql ) -HOOK: update-sql* db ( columns table -- slot-names sql ) -HOOK: delete-sql* db ( columns table -- slot-names sql ) -HOOK: select-sql db ( tuple -- statement ) +HOOK: db ( tuple -- tuple ) HOOK: row-column-typed db ( result-set n type -- sql ) -HOOK: sql-type>factor-type db ( obj type -- obj ) -HOOK: tuple>params db ( columns tuple -- obj ) +HOOK: insert-tuple* db ( tuple statement -- ) +: resulting-tuple ( row out-params -- tuple ) + dup first sql-spec-class construct-empty [ + [ + >r [ sql-spec-type sql-type>factor-type ] keep + sql-spec-slot-name r> set-slot-named + ] curry 2each + ] keep ; -HOOK: make-slot-names* db ( quot -- seq ) -HOOK: column-slot-name% db ( spec -- ) -HOOK: column-bind-name% db ( spec -- ) +: query-tuples ( statement -- seq ) + [ statement-out-params ] keep query-results [ + [ sql-row swap resulting-tuple ] with query-map + ] with-disposal ; + +: query-modify-tuple ( tuple statement -- ) + [ query-results [ sql-row ] with-disposal ] keep + statement-out-params rot [ + >r [ sql-spec-type sql-type>factor-type ] keep + sql-spec-slot-name r> set-slot-named + ] curry 2each ; -: make-slots-names ( quot -- seq str ) - [ make-slot-names* ] "" make ; inline -: slot-name% ( seq -- ) first % ; -: column-name% ( seq -- ) second % ; -: column-type% ( seq -- ) third % ; +: sql-props ( class -- columns table ) + dup db-columns swap db-table ; -: insert-sql ( columns class -- statement ) - db get db-insert-statements [ insert-sql* ] cache-statement ; - -: update-sql ( columns class -- statement ) - db get db-update-statements [ update-sql* ] cache-statement ; - -: delete-sql ( columns class -- statement ) - db get db-delete-statements [ delete-sql* ] cache-statement ; - - -: tuple-statement ( columns tuple quot -- statement ) - >r [ tuple>params ] 2keep class r> call - 2dup . . - [ bind-statement ] keep ; - -: make-tuple-statement ( tuple columns-quot statement-quot -- statement ) - >r [ class db-columns ] swap compose keep - r> tuple-statement ; - -: do-tuple-statement ( tuple columns-quot statement-quot -- ) - make-tuple-statement execute-statement ; +: with-disposals ( seq quot -- ) + over sequence? [ + [ with-disposal ] curry each + ] [ + with-disposal + ] if ; : create-table ( class -- ) - dup db-columns swap db-table create-sql sql-command ; - + create-sql-statement [ execute-statement ] with-disposals ; + : drop-table ( class -- ) - dup db-columns swap db-table drop-sql sql-command ; + drop-sql-statement [ execute-statement ] with-disposals ; + +: insert-native ( tuple -- ) + dup class + db get db-insert-statements [ ] cache + [ bind-tuple ] 2keep insert-tuple* ; + +: insert-assigned ( tuple -- ) + dup class + db get db-insert-statements [ ] cache + [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - [ - [ maybe-remove-id ] [ insert-sql ] - make-tuple-statement insert-statement - ] keep set-primary-key ; + dup class db-columns find-primary-key assigned-id? [ + insert-assigned + ] [ + insert-native + ] if ; : update-tuple ( tuple -- ) - [ ] [ update-sql ] do-tuple-statement ; + dup class + db get db-update-statements [ ] cache + [ bind-tuple ] keep execute-statement ; : delete-tuple ( tuple -- ) - [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ; + dup class + db get db-delete-statements [ ] cache + [ bind-tuple ] keep execute-statement ; -: select-tuple ( tuple -- ) - [ select-sql ] keep do-query ; +: select-tuples ( tuple -- tuple ) + dup dup class [ + [ bind-tuple ] keep query-tuples + ] with-disposal ; -: persist ( tuple -- ) - dup primary-key [ update-tuple ] [ insert-tuple ] if ; - -: define-persistent ( class table columns -- ) - >r dupd "db-table" set-word-prop r> - "db-columns" set-word-prop ; - -: define-relation ( spec -- ) - drop ; +: select-tuple ( tuple -- tuple/f ) select-tuples ?first ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 7cacbcf861..c84b23c50f 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -1,21 +1,50 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser -sequences continuations ; +sequences continuations sequences.deep sequences.lib +words namespaces tools.walker slots slots.private classes +mirrors tuples combinators ; IN: db.types +HOOK: modifier-table db ( -- hash ) +HOOK: compound-modifier db ( str seq -- hash ) +HOOK: type-table db ( -- hash ) +HOOK: create-type-table db ( -- hash ) +HOOK: compound-type db ( str n -- hash ) + +TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; ! ID is the Primary key +! +native-id+ can be a columns type or a modifier SYMBOL: +native-id+ +! +assigned-id+ can only be a modifier SYMBOL: +assigned-id+ -: primary-key? ( spec -- ? ) - [ { +native-id+ +assigned-id+ } member? ] contains? ; +: (primary-key?) ( obj -- ? ) + { +native-id+ +assigned-id+ } member? ; -: contains-id? ( columns id -- ? ) - swap [ member? ] with contains? ; - -: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ; -: native-id? ( columns -- ? ) +native-id+ contains-id? ; +: primary-key? ( spec -- ? ) + sql-spec-primary-key (primary-key?) ; + +: normalize-spec ( spec -- ) + dup sql-spec-type dup (primary-key?) [ + swap set-sql-spec-primary-key + ] [ + drop dup sql-spec-modifiers [ + (primary-key?) + ] deep-find + [ swap set-sql-spec-primary-key ] [ drop ] if* + ] if ; + +: find-primary-key ( specs -- obj ) + [ sql-spec-primary-key ] find nip ; + +: native-id? ( spec -- ? ) + sql-spec-primary-key +native-id+ = ; + +: assigned-id? ( spec -- ? ) + sql-spec-primary-key +assigned-id+ = ; + +SYMBOL: +foreign-id+ ! Same concept, SQLite has autoincrement, PostgreSQL has serial SYMBOL: +autoincrement+ @@ -28,40 +57,168 @@ SYMBOL: +not-null+ SYMBOL: +has-many+ -SYMBOL: SERIAL -SYMBOL: INTEGER -SYMBOL: DOUBLE -SYMBOL: BOOLEAN +: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; +SYMBOL: INTEGER +SYMBOL: BIG_INTEGER +SYMBOL: DOUBLE +SYMBOL: REAL +SYMBOL: BOOLEAN SYMBOL: TEXT SYMBOL: VARCHAR - SYMBOL: TIMESTAMP SYMBOL: DATE -SYMBOL: BIG_INTEGER +: spec>tuple ( class spec -- tuple ) + [ ?first3 ] keep 3 ?tail* + { + set-sql-spec-class + set-sql-spec-slot-name + set-sql-spec-column-name + set-sql-spec-type + set-sql-spec-modifiers + } sql-spec construct + dup normalize-spec ; + +: sql-type-hash ( -- assoc ) + H{ + { INTEGER "integer" } + { TEXT "text" } + { VARCHAR "varchar" } + { DOUBLE "real" } + { TIMESTAMP "timestamp" } + } ; TUPLE: no-sql-type ; : no-sql-type ( -- * ) T{ no-sql-type } throw ; -HOOK: sql-modifiers* db ( modifiers -- str ) -HOOK: >sql-type db ( obj -- str ) - -! HOOK: >factor-type db ( obj -- obj ) +TUPLE: no-sql-modifier ; +: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ; : number>string* ( n/str -- str ) dup number? [ number>string ] when ; -: maybe-remove-id ( columns -- obj ) - [ +native-id+ swap member? not ] subset ; +: maybe-remove-id ( specs -- obj ) + [ native-id? not ] subset ; -: remove-id ( columns -- obj ) - [ primary-key? not ] subset ; +: remove-relations ( specs -- newcolumns ) + [ relation? not ] subset ; -: sql-modifiers ( spec -- seq ) - 3 tail sql-modifiers* ; +: remove-id ( specs -- obj ) + [ sql-spec-primary-key not ] subset ; ! SQLite Types: http://www.sqlite.org/datatype3.html ! NULL INTEGER REAL TEXT BLOB ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html + +: lookup-modifier ( obj -- str ) + dup array? [ + unclip lookup-modifier swap compound-modifier + ] [ + modifier-table at* + [ "unknown modifier" throw ] unless + ] if ; + +: lookup-type* ( obj -- str ) + dup array? [ + first lookup-type* + ] [ + type-table at* + [ no-sql-type ] unless + ] if ; + +: lookup-create-type ( obj -- str ) + dup array? [ + unclip lookup-create-type swap compound-type + ] [ + dup create-type-table at* + [ nip ] [ drop lookup-type* ] if + ] if ; + +: lookup-type ( obj create? -- str ) + [ lookup-create-type ] [ lookup-type* ] if ; + +: single-quote ( str -- newstr ) + "'" swap "'" 3append ; + +: double-quote ( str -- newstr ) + "\"" swap "\"" 3append ; + +: paren ( str -- newstr ) + "(" swap ")" 3append ; + +: join-space ( str1 str2 -- newstr ) + " " swap 3append ; + +: modifiers ( spec -- str ) + sql-spec-modifiers + [ lookup-modifier ] map " " join + dup empty? [ " " swap append ] unless ; + +SYMBOL: building-seq +: get-building-seq ( n -- seq ) + building-seq get nth ; + +: n, get-building-seq push ; +: n% get-building-seq push-all ; +: n# >r number>string r> n% ; + +: 0, 0 n, ; +: 0% 0 n% ; +: 0# 0 n# ; +: 1, 1 n, ; +: 1% 1 n% ; +: 1# 1 n# ; +: 2, 2 n, ; +: 2% 2 n% ; +: 2# 2 n# ; + +: nmake ( quot exemplars -- seqs ) + dup length dup zero? [ 1+ ] when + [ + [ + [ drop 1024 swap new-resizable ] 2map + [ building-seq set call ] keep + ] 2keep >r [ like ] 2map r> firstn + ] with-scope ; + +HOOK: bind% db ( spec -- ) + +TUPLE: no-slot-named ; +: no-slot-named ( -- * ) T{ no-slot-named } throw ; + +: slot-spec-named ( str class -- slot-spec ) + "slots" word-prop [ slot-spec-name = ] with find nip + [ no-slot-named ] unless* ; + +: offset-of-slot ( str obj -- n ) + class slot-spec-named slot-spec-offset ; + +: get-slot-named ( str obj -- value ) + tuck offset-of-slot [ no-slot-named ] unless* slot ; + +: set-slot-named ( value str obj -- ) + tuck offset-of-slot [ no-slot-named ] unless* set-slot ; + +: tuple>filled-slots ( tuple -- alist ) + dup mirror-slots [ slot-spec-name ] map + swap tuple-slots 2array flip [ nip ] assoc-subset ; + +: tuple>params ( specs tuple -- obj ) + [ + >r dup sql-spec-type swap sql-spec-slot-name r> + get-slot-named swap + ] curry { } map>assoc ; + +: sql-type>factor-type ( obj type -- obj ) + dup array? [ first ] when + { + { +native-id+ [ string>number ] } + { INTEGER [ string>number ] } + { DOUBLE [ string>number ] } + { REAL [ string>number ] } + { TEXT [ ] } + { VARCHAR [ ] } + [ "no conversion from sql type to factor type" throw ] + } case ; diff --git a/extra/farkup/authors.factor b/extra/farkup/authors.factor new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/extra/farkup/authors.factor @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/farkup/authors.txt b/extra/farkup/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/farkup/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/farkup/farkup-docs.factor b/extra/farkup/farkup-docs.factor new file mode 100644 index 0000000000..5d59a093af --- /dev/null +++ b/extra/farkup/farkup-docs.factor @@ -0,0 +1,6 @@ +USING: help.markup help.syntax ; +IN: farkup + +HELP: parse-farkup +{ $values { "string" "a string" } { "string'" "a string" } } +{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ; diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor new file mode 100644 index 0000000000..db11833cf1 --- /dev/null +++ b/extra/farkup/farkup-tests.factor @@ -0,0 +1,42 @@ +USING: farkup kernel tools.test ; +IN: temporary + +[ "
  • foo
" ] [ "-foo" parse-farkup ] unit-test +[ "
  • foo
\n" ] [ "-foo\n" parse-farkup ] unit-test +[ "
  • foo
  • bar
" ] [ "-foo\n-bar" parse-farkup ] unit-test +[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" parse-farkup ] unit-test + +[ "
  • foo
\n

bar\n

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

*foo\nbar\n

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

Wow!

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

Wow.

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

*

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

*

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

**

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

foo

bar

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

bar\n

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

foo

\n

bar

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

|a

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

|a|

" ] +[ "|a|" parse-farkup ] unit-test + +[ "
ab
" ] +[ "a|b" parse-farkup ] unit-test + +[ "
ab
\n
cd
" ] +[ "a|b\nc|d" parse-farkup ] unit-test + +[ "
ab
\n
cd
\n" ] +[ "a|b\nc|d\n" parse-farkup ] unit-test + diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor new file mode 100644 index 0000000000..718b8b3e28 --- /dev/null +++ b/extra/farkup/farkup.factor @@ -0,0 +1,148 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays io kernel memoize namespaces peg +peg.ebnf sequences strings html.elements xml.entities +xmode.code2html splitting io.streams.string html +html.elements sequences.deep ascii ; +! unicode.categories ; +USE: tools.walker +IN: farkup + +MEMO: any-char ( -- parser ) [ drop t ] satisfy ; + +: delimiters ( -- string ) + "*_^~%=[-|\\\n" ; inline + +MEMO: text ( -- parser ) + [ delimiters member? not ] satisfy repeat1 + [ >string escape-string ] action ; + +MEMO: delimiter ( -- parser ) + [ dup delimiters member? swap CHAR: \n = 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: h1 ( -- parser ) "=" "h1" delimited ; +MEMO: h2 ( -- parser ) "==" "h2" delimited ; +MEMO: h3 ( -- parser ) "===" "h3" delimited ; +MEMO: h4 ( -- parser ) "====" "h4" delimited ; +MEMO: nl ( -- parser ) "\n" token ; +MEMO: 2nl ( -- parser ) "\n\n" token hide ; + +: 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* , + ] seq* [ "tr" surround-with-foo ] action ; + +MEMO: table ( -- parser ) + table-row repeat1 [ "table" surround-with-foo ] action ; + +MEMO: code ( -- parser ) + [ + "[" token hide , + [ "{" member? not ] satisfy repeat1 optional [ >string ] action , + "{" token hide , + [ + [ any-char , "}]" token ensure-not , ] seq* + repeat1 [ concat >string ] action , + [ any-char , "}]" token hide , ] seq* optional [ >string ] action , + ] seq* [ concat ] action , + ] seq* [ first2 swap render-code ] action ; + +MEMO: line ( -- parser ) + [ + text , strong , emphasis , link , + superscript , subscript , inline-code , + escaped-char , delimiter , + ] choice* repeat1 ; + +MEMO: paragraph ( -- parser ) + line + "\n" token over 2seq repeat0 + "\n" token "\n" token ensure-not 2seq optional 3seq + [ + dup [ dup string? not swap [ blank? ] all? or ] deep-all? + [ "

" swap "

" 3array ] unless + ] action ; + +MEMO: farkup ( -- parser ) + [ + list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , + ] choice* repeat0 "\n" token optional 2seq ; + +: farkup. ( parse-result -- ) + parse-result-ast + [ dup string? [ write ] [ drop ] if ] deep-each ; + +: parse-farkup ( string -- string' ) + farkup parse [ farkup. ] with-string-writer ; + +! MEMO: table-column ( -- parser ) + ! text [ "td" surround-with-foo ] action ; +! +! MEMO: table-row ( -- parser ) + ! [ + ! "|" token hide , + ! table-column "|" token hide list-of , + ! "|" token "\n" token 2array choice hide , + ! ] seq* [ "tr" surround-with-foo ] action ; +! +! MEMO: table ( -- parser ) + ! table-row repeat1 + ! [ "table" surround-with-foo ] action ; 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/furnace/furnace.factor b/extra/furnace/furnace.factor index f10094f07b..3bbd2d03da 100755 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -215,4 +215,3 @@ SYMBOL: model ] [ drop ] if ; - diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 579e5a607e..cf03fee6b1 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -1,5 +1,5 @@ USING: assocs calendar init kernel math.parser -namespaces random boxes alarms ; +namespaces random boxes alarms combinators.lib ; IN: furnace.sessions SYMBOL: sessions @@ -11,9 +11,8 @@ SYMBOL: sessions ] "furnace.sessions" add-init-hook : new-session-id ( -- str ) - 4 big-random >hex - dup sessions get-global key? - [ drop new-session-id ] when ; + [ 4 big-random >hex ] + [ sessions get-global key? not ] generate ; TUPLE: session id namespace alarm user-agent ; diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 6dee7d4be3..45d19cb891 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,13 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-c-types? f } - { deploy-ui? f } - { deploy-reflection 1 } + { deploy-io 2 } { deploy-math? f } + { deploy-threads? f } + { deploy-compiler? f } { deploy-word-props? f } { deploy-word-defs? f } { deploy-name "Hello world (console)" } + { deploy-reflection 2 } + { deploy-c-types? f } + { deploy-ui? f } { "stop-after-last-window?" t } - { deploy-compiler? f } - { deploy-io 2 } } diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 5be69663f8..ebdbdeb37e 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -197,7 +197,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook" { $code "\"data.bin\" [ 1024 read ] with-file-reader" } -"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory:" +"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" { $code "\"mydata.dat\" dup file-length [" " 4 [ reverse-here ] change-each" diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index f12e0180b1..178b7a5d35 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -86,7 +86,8 @@ concurrency.futures concurrency.locks concurrency.semaphores concurrency.count-downs -concurrency.exchangers ; +concurrency.exchangers +concurrency.flags ; ARTICLE: "concurrency" "Concurrency" "Factor supports a variety of concurrency abstractions, however they are mostly used to multiplex input/output operations since the thread scheduling is co-operative and only one CPU is used at a time." @@ -106,6 +107,7 @@ $nl { $subsection "concurrency.semaphores" } { $subsection "concurrency.count-downs" } { $subsection "concurrency.exchangers" } +{ $subsection "concurrency.flags" } "Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ; ARTICLE: "objects" "Objects" @@ -169,23 +171,24 @@ ARTICLE: "collections" "Collections" USING: io.sockets io.launcher io.mmap io.monitors ; -ARTICLE: "io" "Input and output" +ARTICLE: "io" "Input and output" +{ $heading "Streams" } { $subsection "streams" } -"External streams:" -{ $subsection "file-streams" } -{ $subsection "network-streams" } "Wrapper streams:" { $subsection "io.streams.duplex" } { $subsection "io.streams.lines" } { $subsection "io.streams.plain" } { $subsection "io.streams.string" } -"Stream utilities:" +"Utilities:" { $subsection "stream-binary" } { $subsection "styles" } -"Advanced features:" -{ $subsection "io.launcher" } +{ $heading "Files" } +{ $subsection "io.files" } { $subsection "io.mmap" } { $subsection "io.monitors" } +{ $heading "Other features" } +{ $subsection "network-streams" } +{ $subsection "io.launcher" } { $subsection "io.timeouts" } ; ARTICLE: "tools" "Developer tools" @@ -196,6 +199,7 @@ ARTICLE: "tools" "Developer tools" "Debugging tools:" { $subsection "tools.annotations" } { $subsection "tools.test" } +{ $subsection "tools.threads" } "Performance tools:" { $subsection "tools.memory" } { $subsection "profiling" } diff --git a/extra/help/help.factor b/extra/help/help.factor index 77b9f699aa..490374a384 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -122,18 +122,31 @@ M: word set-article-parent swap "help-parent" set-word-prop ; : (:help-multi) "This error has multiple delegates:" print - ($index) nl ; + ($index) nl + "Use \\ ... help to get help about a specific delegate." print ; : (:help-none) drop "No help for this error. " print ; +: (:help-debugger) + nl + "Debugger commands:" print + nl + ":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 ; + : :help ( -- ) error get delegates [ error-help ] map [ ] subset { { [ dup empty? ] [ (:help-none) ] } { [ dup length 1 = ] [ first help ] } { [ t ] [ (:help-multi) ] } - } cond ; + } cond (:help-debugger) ; : remove-article ( name -- ) dup articles get key? [ diff --git a/extra/help/lint/lint-docs.factor b/extra/help/lint/lint-docs.factor index 2813391d07..6aa3310bf9 100644 --- a/extra/help/lint/lint-docs.factor +++ b/extra/help/lint/lint-docs.factor @@ -1,26 +1,26 @@ USING: help.markup help.syntax ; IN: help.lint -HELP: check-help -{ $description "Checks all word and article help." } ; +HELP: help-lint-all +{ $description "Checks all word help and articles in all loaded vocabularies." } ; -HELP: check-vocab-help +HELP: help-lint { $values { "vocab" "a vocabulary specifier" } } -{ $description "Checks all word help in the given vocabulary." } ; +{ $description "Checks all word help and articles in the given vocabulary and all child vocabularies." } ; ARTICLE: "help.lint" "Help lint tool" "The " { $vocab-link "help.lint" } " vocabulary implements a tool to check documentation in an automated fashion. You should use this tool to check any documentation that you write." $nl "To run help lint, use one of the following two words:" -{ $subsection check-help } -{ $subsection check-vocab-help } +{ $subsection help-lint } +{ $subsection help-lint-all } "Help lint performs the following checks:" { $list "ensures examples run and produce stated output" { "ensures " { $link $see-also } " elements don't contain duplicate entries" } { "ensures " { $link $vocab-link } " elements point to modules which actually exist" } { "ensures that " { $link $values } " match the stack effect declaration" } - { "ensures that word help articles actually render (this catches broken links, improper nesting, etc)" } + { "ensures that help topics actually render (this catches broken links, improper nesting, etc)" } } ; ABOUT: "help.lint" diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index 3c11a93509..4b97499a4c 100644 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -5,7 +5,7 @@ words strings classes tools.browser namespaces io io.streams.string prettyprint definitions arrays vectors combinators splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate -macros combinators.lib ; +macros combinators.lib sequences.lib ; IN: help.lint : check-example ( element -- ) @@ -84,7 +84,7 @@ M: help-error error. delegate error. ; : check-something ( obj quot -- ) - over . flush [ , ] recover ; inline + flush [ , ] recover ; inline : check-word ( word -- ) dup word-help [ @@ -106,22 +106,45 @@ M: help-error error. [ dup check-rendering ] assert-depth drop ] check-something ; -: check-articles ( -- ) - articles get keys [ check-article ] each ; +: group-articles ( -- assoc ) + articles get keys + vocabs [ dup vocab-docs-path swap ] H{ } map>assoc + H{ } clone [ + [ + >r >r dup >link where ?first r> at r> [ ?push ] change-at + ] 2curry each + ] keep ; -: with-help-lint ( quot -- ) +: check-vocab ( vocab -- seq ) + "Checking " write dup write "..." print + [ + dup words [ check-word ] each + "vocab-articles" get at [ check-article ] each + ] { } make ; + +: run-help-lint ( prefix -- alist ) [ all-vocabs-seq [ vocab-name ] map "all-vocabs" set - call - ] { } make [ nl error. ] each ; inline + articles get keys "group-articles" set + child-vocabs + [ dup check-vocab ] { } map>assoc + [ nip empty? not ] assoc-subset + ] with-scope ; -: check-help ( -- ) - [ all-words check-words check-articles ] with-help-lint ; +: typos. ( assoc -- ) + dup empty? [ + drop + "==== ALL CHECKS PASSED" print + ] [ + [ + swap vocab-heading. + [ error. nl ] each + ] assoc-each + ] if ; -: check-vocab-help ( vocab -- ) - [ - child-vocabs [ words check-words ] each - ] with-help-lint ; +: help-lint ( prefix -- ) run-help-lint typos. ; + +: help-lint-all ( -- ) "" help-lint ; : unlinked-words ( words -- seq ) all-word-help [ article-parent not ] subset ; @@ -132,4 +155,4 @@ M: help-error error. [ article-parent ] subset [ "predicating" word-prop not ] subset ; -MAIN: check-help +MAIN: help-lint diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 101bc423b5..4f9a052032 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -87,14 +87,14 @@ SYMBOL: html #! word. foo> [ ">" write-html ] empty-effect html-word ; -: [ "" % ] "" make ; +: "" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. dup [ write-html ] curry empty-effect html-word ; -: [ "<" % % "/>" % ] "" make ; +: "<" swap "/>" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned diff --git a/extra/http/basic-authentication/basic-authentication.factor b/extra/http/basic-authentication/basic-authentication.factor index e15ba9db16..dfe04dc4b5 100644 --- a/extra/http/basic-authentication/basic-authentication.factor +++ b/extra/http/basic-authentication/basic-authentication.factor @@ -61,5 +61,5 @@ SYMBOL: realms #! Check if the user is authenticated in the given realm #! to run the specified quotation. If not, use Basic #! Authentication to ask for authorization details. - over "Authorization" header-param authorization-ok? + over "authorization" header-param authorization-ok? [ nip call ] [ drop authentication-error ] if ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index f364b86524..3b0dcb8e5e 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -80,11 +80,10 @@ DEFER: <% delimiter "quiet" on parser-notes off templating-vocab use+ - dup source-file file set ! so that reload works properly - [ - ?resource-path file-contents - [ eval-template ] [ html-error. drop ] recover - ] keep + ! so that reload works properly + dup source-file file set + dup ?resource-path file-contents + [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs ] assert-depth drop ; diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 48b2a01b7d..96639dee87 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -78,7 +78,7 @@ $nl "This is used in situations where you want a spawn child process with some overridden environment variables." } ; HELP: +timeout+ -{ $description "Launch descriptor key. If set to a " { $link dt } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ; +{ $description "Launch descriptor key. If set to a " { $link duration } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ; HELP: default-descriptor { $description "Association storing default values for launch descriptor keys." } ; diff --git a/extra/io/launcher/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/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 8c2c9cb9d8..34065203f8 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) { @@ -47,9 +51,14 @@ TUPLE: simple-monitor handle callback ; : notify-callback ( simple-monitor -- ) simple-monitor-callback ?box [ resume ] [ drop ] if ; +M: simple-monitor timed-out + notify-callback ; + M: simple-monitor fill-queue ( monitor -- ) - [ swap simple-monitor-callback >box ] - "monitor" suspend drop + [ + [ swap simple-monitor-callback >box ] + "monitor" suspend drop + ] with-timeout check-monitor ; M: simple-monitor dispose ( monitor -- ) diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 8980eacc3d..4acfb9acad 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -1,5 +1,5 @@ USING: io.files kernel sequences new-slots accessors -dlists arrays ; +dlists arrays sequences.lib ; IN: io.paths TUPLE: directory-iterator path bfs queue ; @@ -34,19 +34,17 @@ TUPLE: directory-iterator path bfs queue ; drop r> r> r> 3drop f ] if ; inline -: prepare-find-file ( path bfs? quot -- iter quot' ) - >r r> [ keep and ] curry ; inline - : find-file ( path bfs? quot -- path/f ) - prepare-find-file iterate-directory ; + >r r> + [ keep and ] curry iterate-directory ; inline + +: each-file ( path bfs? quot -- ) + >r r> + [ f ] compose iterate-directory drop ; inline : find-all-files ( path bfs? quot -- paths ) - prepare-find-file V{ } clone [ - [ over [ push ] [ 2drop ] if f ] curry compose - iterate-directory - drop - ] keep ; inline + >r r> + pusher >r iterate-directory drop r> ; inline : recursive-directory ( path bfs? -- paths ) - - [ dup next-file dup ] [ ] [ drop ] unfold nip ; + [ ] accumulator >r each-file r> ; diff --git a/extra/io/server/summary.txt b/extra/io/server/summary.txt new file mode 100644 index 0000000000..e791b704eb --- /dev/null +++ b/extra/io/server/summary.txt @@ -0,0 +1 @@ +TCP/IP and UDP/IP servers diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor index 66336425a1..1c72a4780c 100644 --- a/extra/io/sniffer/bsd/bsd.factor +++ b/extra/io/sniffer/bsd/bsd.factor @@ -24,7 +24,7 @@ C: sniffer-spec : IOC_INOUT IOC_IN IOC_OUT bitor ; inline : IOC_DIRMASK HEX: e0000000 ; inline -:: ioc | inout group num len | +:: ioc ( inout group num len -- n ) group first 8 shift num bitor len IOCPARM_MASK bitand 16 shift bitor inout bitor ; diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index d7ac18ee20..77e8e098b1 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -53,7 +53,7 @@ M: inet4 make-sockaddr ( inet -- sockaddr ) SYMBOL: port-override -: (port) port-override get [ ] [ ] ?if ; +: (port) port-override get swap or ; M: inet4 parse-sockaddr >r dup sockaddr-in-addr r> inet-ntop diff --git a/extra/io/timeouts/summary.txt b/extra/io/timeouts/summary.txt new file mode 100644 index 0000000000..7a648d30bb --- /dev/null +++ b/extra/io/timeouts/summary.txt @@ -0,0 +1 @@ +Low-level support for setting timeouts on I/O operations diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor index 347c57a0d6..df7e1389cc 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/extra/io/timeouts/timeouts-docs.factor @@ -2,11 +2,11 @@ IN: io.timeouts USING: help.markup help.syntax math kernel calendar ; HELP: timeout -{ $values { "obj" object } { "dt/f" "a " { $link dt } " or " { $link f } } } +{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } } { $contract "Outputs an object's timeout." } ; HELP: set-timeout -{ $values { "dt/f" "a " { $link dt } " or " { $link f } } { "obj" object } } +{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } } { $contract "Sets an object's timeout." } ; HELP: timed-out diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 3bf0e3f897..6afbc33049 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -37,7 +37,15 @@ M: unix-io ( path -- stream ) M: unix-io ( path -- stream ) open-append ; -M: unix-io rename-file ( from to -- ) +: touch-mode + { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable + +M: unix-io touch-file ( path -- ) + touch-mode file-mode open + dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when + close ; + +M: unix-io move-file ( from to -- ) rename io-error ; M: unix-io delete-file ( path -- ) @@ -48,3 +56,14 @@ M: unix-io make-directory ( path -- ) M: unix-io delete-directory ( path -- ) rmdir io-error ; + +: (copy-file) ( from to -- ) + dup parent-directory make-directories + [ + swap [ + swap stream-copy + ] with-disposal + ] with-disposal ; + +M: unix-io copy-file ( from to -- ) + >r dup file-permissions over r> (copy-file) chmod io-error ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index c38d8c1283..7580e7bf6b 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -22,10 +22,12 @@ TUPLE: inotify watches ; : wd>monitor ( wd -- monitor ) watches at ; -: ( -- port ) +: ( -- port/f ) H{ } clone - inotify_init dup io-error inotify - { set-inotify-watches set-delegate } inotify construct ; + inotify_init dup 0 < [ 2drop f ] [ + inotify + { set-inotify-watches set-delegate } inotify construct + ] if ; : inotify-fd inotify get-global port-handle ; @@ -45,7 +47,13 @@ TUPLE: inotify watches ; dup simple-monitor-handle watches delete-at simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ; +: check-inotify + inotify get [ + "inotify is not supported by this Linux release" throw + ] unless ; + M: linux-io ( path recursive? -- monitor ) + check-inotify drop IN_CHANGE_EVENTS add-watch ; M: linux-monitor dispose ( monitor -- ) @@ -103,8 +111,7 @@ TUPLE: inotify-task ; f inotify-task ; : init-inotify ( mx -- ) - - dup inotify set-global + dup inotify set-global swap register-io-task ; M: inotify-task do-io-task ( task -- ) diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 6eb0b78955..af7417854e 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -4,12 +4,12 @@ sequences prettyprint system ; IN: temporary ! Unix domain stream sockets -[ - [ - "unix-domain-socket-test" resource-path delete-file - ] ignore-errors +: socket-server "unix-domain-socket-test" temp-file ; - "unix-domain-socket-test" resource-path +[ + [ socket-server delete-file ] ignore-errors + + socket-server [ stdio get accept [ "Hello world" print flush @@ -17,14 +17,14 @@ IN: temporary ] with-stream ] with-stream - "unix-domain-socket-test" resource-path delete-file + socket-server delete-file ] "Test" spawn drop yield [ { "Hello world" "FOO" } ] [ [ - "unix-domain-socket-test" resource-path + socket-server [ readln , "XYZ" print flush @@ -33,17 +33,16 @@ yield ] { } make ] unit-test -! Unix domain datagram sockets -[ - "unix-domain-datagram-test" resource-path delete-file -] ignore-errors +: datagram-server "unix-domain-datagram-test" temp-file ; +: datagram-client "unix-domain-datagram-test-2" temp-file ; -: server-addr "unix-domain-datagram-test" temp-file ; -: client-addr "unix-domain-datagram-test-2" temp-file ; +! Unix domain datagram sockets +[ datagram-server delete-file ] ignore-errors +[ datagram-client delete-file ] ignore-errors [ [ - server-addr "d" set + datagram-server "d" set "Receive 1" print @@ -67,58 +66,53 @@ yield "Done" print - "unix-domain-datagram-test" resource-path delete-file + datagram-server delete-file ] with-scope ] "Test" spawn drop yield -[ - "unix-domain-datagram-test-2" resource-path delete-file -] ignore-errors +[ datagram-client delete-file ] ignore-errors -client-addr +datagram-client "d" set [ ] [ "hello" >byte-array - server-addr + datagram-server "d" get send ] unit-test [ "olleh" t ] [ "d" get receive - server-addr = + datagram-server = >r >string r> ] unit-test [ ] [ "hello" >byte-array - server-addr + datagram-server "d" get send ] unit-test [ "hello world" t ] [ "d" get receive - server-addr = + datagram-server = >r >string r> ] unit-test [ ] [ "d" get dispose ] unit-test ! Test error behavior +: another-datagram "unix-domain-datagram-test-3" temp-file ; -[ - "unix-domain-datagram-test-3" resource-path delete-file -] ignore-errors +[ another-datagram delete-file ] ignore-errors -"unix-domain-datagram-test-2" temp-file delete-file +datagram-client delete-file -[ ] [ client-addr "d" set ] unit-test +[ ] [ datagram-client "d" set ] unit-test -[ - B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send -] must-fail +[ B{ 1 2 3 } another-datagram "d" get send ] must-fail [ ] [ "d" get dispose ] unit-test @@ -126,7 +120,7 @@ client-addr [ "d" get receive ] must-fail -[ B{ 1 2 } server-addr "d" get send ] must-fail +[ B{ 1 2 } datagram-server "d" get send ] must-fail ! Invalid parameter tests @@ -140,7 +134,7 @@ client-addr [ image [ - B{ 1 2 } server-addr + B{ 1 2 } datagram-server stdio get send ] with-file-reader ] must-fail diff --git a/extra/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/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index eff3c250dc..d14dff8c22 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32 windows.types libc assocs alien namespaces continuations io.monitors io.monitors.private io.nonblocking io.buffers io.files io.timeouts io sequences hashtables sorting arrays -combinators ; +combinators math.bitfields ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) @@ -13,7 +13,7 @@ IN: io.windows.nt.monitors share-mode f OPEN_EXISTING - FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED bitor + { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags f CreateFile dup invalid-handle? diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index ee3f744bb0..9f2f2db0a5 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -28,7 +28,7 @@ HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) M: windows-io normalize-directory ( string -- string ) - "\\" ?tail drop "\\*" append ; + normalize-pathname "\\" ?tail drop "\\*" append ; : share-mode ( -- fixnum ) { @@ -121,7 +121,7 @@ M: windows-io ( path -- stream ) M: windows-io ( path -- stream ) open-append ; -M: windows-io rename-file ( from to -- ) +M: windows-io move-file ( from to -- ) [ normalize-pathname ] 2apply MoveFile win32-error=0/f ; M: windows-io delete-file ( path -- ) diff --git a/extra/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/locals/locals-docs.factor b/extra/locals/locals-docs.factor index 97f9aa5c65..b8d836ecc1 100644 --- a/extra/locals/locals-docs.factor +++ b/extra/locals/locals-docs.factor @@ -16,7 +16,7 @@ HELP: [| { $examples { $example "USE: locals" - ":: adder | n | [| m | m n + ] ;" + ":: adder ( n -- quot ) [| m | m n + ] ;" "3 5 adder call ." "8" } @@ -29,7 +29,7 @@ HELP: [let { $examples { $example "USING: locals math.functions ;" - ":: frobnicate | n seq |" + ":: frobnicate ( n seq -- newseq )" " [let | n' [ n 6 * ] |" " seq [ n' gcd nip ] map ] ;" "6 { 36 14 } frobnicate ." @@ -44,7 +44,7 @@ HELP: [wlet { $examples { $example "USE: locals" - ":: quuxify | n seq |" + ":: quuxify ( n seq -- newseq )" " [wlet | add-n [| m | m n + ] |" " seq [ add-n ] map ] ;" "2 { 1 2 3 } quuxify ." @@ -57,13 +57,15 @@ HELP: with-locals { $description "Performs closure conversion of a lexically-scoped form. All nested sub-forms are converted. This word must be applied to a " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " used in an ordinary definition, however forms in " { $link POSTPONE: :: } " and " { $link POSTPONE: MACRO:: } " definitions are automatically closure-converted and there is no need to use this word." } ; HELP: :: -{ $syntax ":: word | bindings... | body... ;" } +{ $syntax ":: word ( bindings... -- outputs... ) body... ;" } { $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } +{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } { $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ; HELP: MACRO:: -{ $syntax "MACRO:: word | bindings... | body... ;" } -{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } ; +{ $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" } +{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } +{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ; { POSTPONE: MACRO: POSTPONE: MACRO:: } related-words @@ -72,7 +74,7 @@ ARTICLE: "locals-mutable" "Mutable locals" $nl "Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:" { $code - ":: counter | |" + ":: counter ( -- )" " [let | value! [ 0 ] |" " [ value 1+ dup value! ]" " [ value 1- dup value! ] ] ;" @@ -86,7 +88,7 @@ ARTICLE: "locals-limitations" "Limitations of locals" $nl "Another limitation is that closure conversion does not descend into arrays, hashtables or other types of literals. For example, the following does not work:" { $code - ":: bad-cond-usage | a |" + ":: bad-cond-usage ( a -- ... )" " { [ a 0 < ] [ ... ] }" " { [ a 0 > ] [ ... ] }" " { [ a 0 = ] [ ... ] } ;" diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index aa724c4aca..b290c25159 100644 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -1,52 +1,52 @@ USING: locals math sequences tools.test hashtables words kernel -namespaces arrays ; +namespaces arrays strings prettyprint ; IN: temporary -:: foo | a b | a a ; +:: foo ( a b -- a a ) a a ; [ 1 1 ] [ 1 2 foo ] unit-test -:: add-test | a b | a b + ; +:: add-test ( a b -- c ) a b + ; [ 3 ] [ 1 2 add-test ] unit-test -:: sub-test | a b | a b - ; +:: sub-test ( a b -- c ) a b - ; [ -1 ] [ 1 2 sub-test ] unit-test -:: map-test | a b | a [ b + ] map ; +:: map-test ( a b -- seq ) a [ b + ] map ; [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test -:: map-test-2 | seq inc | seq [| elt | elt inc + ] map ; +:: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ; [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test -:: let-test | c | +:: let-test ( c -- d ) [let | a [ 1 ] b [ 2 ] | a b + c + ] ; [ 7 ] [ 4 let-test ] unit-test -:: let-test-2 | | - [let | a [ ] | [let | b [ a ] | a ] ] ; +:: let-test-2 ( a -- a ) + a [let | a [ ] | [let | b [ a ] | a ] ] ; [ 3 ] [ 3 let-test-2 ] unit-test -:: let-test-3 | | - [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ; +:: let-test-3 ( a -- a ) + a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ; -:: let-test-4 | | - [let | a [ 1 ] b [ ] | a b 2array ] ; +:: let-test-4 ( a -- b ) + a [let | a [ 1 ] b [ ] | a b 2array ] ; [ { 1 2 } ] [ 2 let-test-4 ] unit-test -:: let-test-5 | | - [let | a [ ] b [ ] | a b 2array ] ; +:: let-test-5 ( a -- b ) + a [let | a [ ] b [ ] | a b 2array ] ; [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test -:: let-test-6 | | - [let | a [ ] b [ 1 ] | a b 2array ] ; +:: let-test-6 ( a -- b ) + a [let | a [ ] b [ 1 ] | a b 2array ] ; [ { 2 1 } ] [ 2 let-test-6 ] unit-test @@ -57,26 +57,26 @@ IN: temporary with-locals ] unit-test -:: wlet-test-2 | a b | +:: wlet-test-2 ( a b -- seq ) [wlet | add-b [ b + ] | a [ add-b ] map ] ; [ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test -:: wlet-test-3 | a | +:: wlet-test-3 ( a -- b ) [wlet | add-a [ a + ] | [ add-a ] ] [let | a [ 3 ] | a swap call ] ; [ 5 ] [ 2 wlet-test-3 ] unit-test -:: wlet-test-4 | a | +:: wlet-test-4 ( a -- b ) [wlet | sub-a [| b | b a - ] | 3 sub-a ] ; [ -7 ] [ 10 wlet-test-4 ] unit-test -:: write-test-1 | n! | +:: write-test-1 ( n! -- q ) [| i | n i + dup n! ] ; 0 write-test-1 "q" set @@ -89,7 +89,7 @@ IN: temporary [ 5 ] [ 2 "q" get call ] unit-test -:: write-test-2 | | +:: write-test-2 ( -- q ) [let | n! [ 0 ] | [| i | n i + dup n! ] ] ; @@ -108,21 +108,55 @@ write-test-2 "q" set 20 10 [| a! | [| b! | a b ] ] with-locals call call ] unit-test -:: write-test-3 | a! | [| b | b a! ] ; +:: write-test-3 ( a! -- q ) [| b | b a! ] ; [ ] [ 1 2 write-test-3 call ] unit-test -:: write-test-4 | x! | [ [let | y! [ 0 ] | f x! ] ] ; +:: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ; [ ] [ 5 write-test-4 drop ] unit-test SYMBOL: a -:: use-test | a b c | +:: use-test ( a b c -- a b c ) USE: kernel ; [ t ] [ a symbol? ] unit-test -:: let-let-test | n | [let | n [ n 3 + ] | n ] ; +:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ; [ 13 ] [ 10 let-let-test ] unit-test + +GENERIC: lambda-generic ( a b -- c ) + +GENERIC# lambda-generic-1 1 ( a b -- c ) + +M:: integer lambda-generic-1 ( a b -- c ) a b * ; + +M:: string lambda-generic-1 ( a b -- c ) + a b CHAR: x lambda-generic ; + +M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ; + +GENERIC# lambda-generic-2 1 ( a b -- c ) + +M:: integer lambda-generic-2 ( a b -- c ) + a CHAR: x b lambda-generic ; + +M:: string lambda-generic-2 ( a b -- c ) a b append ; + +M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; + +[ 10 ] [ 5 2 lambda-generic ] unit-test + +[ "abab" ] [ "aba" "b" lambda-generic ] unit-test + +[ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test + +[ "xaba" ] [ 1 "aba" lambda-generic ] unit-test + +[ ] [ \ lambda-generic-1 see ] unit-test + +[ ] [ \ lambda-generic-2 see ] unit-test + +[ ] [ \ lambda-generic see ] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 52ccb1bed3..2e6fd6485d 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math inference.transforms parser words quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables combinators.lib -prettyprint.sections sequences.private ; +prettyprint.sections sequences.private effects generic +compiler.units ; IN: locals ! Inspired by @@ -208,9 +209,6 @@ M: object local-rewrite* , ; : push-locals ( assoc -- ) use get push ; -: parse-locals ( -- words assoc ) - "|" parse-tokens make-locals ; - : pop-locals ( assoc -- ) use get delete ; @@ -218,7 +216,7 @@ M: object local-rewrite* , ; over push-locals parse-until >quotation swap pop-locals ; : parse-lambda ( -- lambda ) - parse-locals \ ] (parse-lambda) ; + "|" parse-tokens make-locals \ ] (parse-lambda) ; : (parse-bindings) ( -- ) scan dup "|" = [ @@ -246,11 +244,18 @@ M: wlet local-rewrite* dup wlet-bindings values over wlet-vars rot wlet-body [ call ] curry compose local-rewrite* \ call , ; -: (::) ( prop -- word quot n ) - >r CREATE dup reset-generic - scan "|" assert= parse-locals \ ; (parse-lambda) - 2dup r> set-word-prop - [ lambda-rewrite first ] keep lambda-vars length ; +: parse-locals + parse-effect + word [ over "declared-effect" set-word-prop ] when* + effect-in make-locals ; + +: ((::)) ( word -- word quot ) + scan "(" assert= parse-locals \ ; (parse-lambda) + 2dup "lambda" set-word-prop + lambda-rewrite first ; + +: (::) ( -- word quot ) + CREATE dup reset-generic ((::)) ; PRIVATE> @@ -268,9 +273,22 @@ PRIVATE> MACRO: with-locals ( form -- quot ) lambda-rewrite ; -: :: "lambda" (::) drop define ; parsing +: :: (::) define ; parsing -: MACRO:: "lambda-macro" (::) (MACRO:) ; parsing +! This will be cleaned up when method tuples and method words +! are unified +: create-method ( class generic -- method ) + 2dup method dup + [ 2nip method-word ] + [ drop 2dup [ ] -rot define-method create-method ] if ; + +: CREATE-METHOD ( -- class generic body ) + scan-word bootstrap-word scan-word 2dup + create-method f set-word dup save-location ; + +: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing + +: MACRO:: (::) define-macro ; parsing boolean ; + "lambda" word-prop >boolean ; M: lambda-macro definer drop \ MACRO:: \ ; ; M: lambda-macro definition - "lambda-macro" word-prop lambda-body ; + "lambda" word-prop lambda-body ; -M: lambda-macro synopsis* - "lambda-macro" lambda-word-synopsis ; +M: lambda-macro synopsis* lambda-word-synopsis ; + +PREDICATE: method-body lambda-method + "lambda" word-prop >boolean ; + +M: lambda-method definer drop \ M:: \ ; ; + +M: lambda-method definition + "lambda" word-prop lambda-body ; + +: method-stack-effect + dup "lambda" word-prop lambda-vars + swap "method" word-prop method-generic stack-effect dup [ effect-out ] when + ; + +M: lambda-method synopsis* + dup definer. + dup "method" word-prop dup + method-specializer pprint* + method-generic pprint* + method-stack-effect effect>string comment. ; PRIVATE> diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index b4c7e12772..015861501e 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -3,7 +3,7 @@ USING: parser-combinators memoize kernel sequences logging arrays words strings vectors io io.files namespaces combinators combinators.lib logging.server -calendar ; +calendar calendar.format ; IN: logging.parser : string-of satisfy [ >string ] <@ ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index e31391e5d5..99f637f4a0 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -3,7 +3,7 @@ USING: namespaces kernel io calendar sequences io.files io.sockets continuations prettyprint assocs math.parser words debugger math combinators concurrency.messaging -threads arrays init math.ranges strings ; +threads arrays init math.ranges strings calendar.format ; IN: logging.server : log-root ( -- string ) @@ -68,11 +68,11 @@ SYMBOL: log-files : delete-oldest keep-logs log# ?delete-file ; -: ?rename-file ( old new -- ) - over exists? [ rename-file ] [ 2drop ] if ; +: ?move-file ( old new -- ) + over exists? [ move-file ] [ 2drop ] if ; : advance-log ( path n -- ) - [ 1- log# ] 2keep log# ?rename-file ; + [ 1- log# ] 2keep log# ?move-file ; : rotate-log ( service -- ) dup close-log diff --git a/extra/macros/macros.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/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/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/models/models-docs.factor b/extra/models/models-docs.factor index ce86905b9f..d514a539aa 100755 --- a/extra/models/models-docs.factor +++ b/extra/models/models-docs.factor @@ -153,7 +153,7 @@ HELP: delay } ; HELP: -{ $values { "model" model } { "timeout" dt } { "delay" delay } } +{ $values { "model" model } { "timeout" duration } { "delay" delay } } { $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } { $examples "See the example in the documentation for " { $link delay } "." } ; diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor index 4edd4239fa..3273036b8b 100755 --- a/extra/new-slots/new-slots.factor +++ b/extra/new-slots/new-slots.factor @@ -34,7 +34,7 @@ IN: new-slots [ \ over , swap writer-word , ] [ ] make define-inline ] [ 2drop ] if ; -: changer-effect T{ effect f { "object" "quot" } } ; inline +: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline : changer-word ( name -- word ) "change-" swap append changer-effect create-accessor ; @@ -44,9 +44,9 @@ IN: new-slots [ [ over >r >r ] % over reader-word , - [ r> call r> ] % - swap writer-word , - ] [ ] make define + [ r> call r> swap ] % + swap setter-word , + ] [ ] make define-inline ] [ 2drop ] if ; : define-new-slot ( class slot name -- ) diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor index 3307e921b8..e24cee748e 100755 --- a/extra/ogg/player/player.factor +++ b/extra/ogg/player/player.factor @@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ; dup player-gadget [ dup { player-td player-yuv } get-slots theora_decode_YUVout drop dup player-rgb over player-yuv yuv>rgb - dup player-gadget relayout yield + dup player-gadget relayout-1 yield ] when ; : num-audio-buffers-processed ( player -- player n ) 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/peg/peg.factor b/extra/peg/peg.factor index 59a8b63c14..ed7012da45 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -306,9 +306,27 @@ 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 ; + +: 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 ; + +: choice* ( quot -- paser ) + { } make choice ; inline + MEMO: repeat0 ( parser -- parser ) repeat0-parser construct-boa init-parser ; @@ -336,8 +354,15 @@ MEMO: hide ( parser -- parser ) MEMO: delay ( parser -- parser ) delay-parser construct-boa init-parser ; +MEMO: (list-of) ( items separator repeat1? -- parser ) + >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq + [ unclip 1vector swap first append ] action ; + MEMO: list-of ( items separator -- parser ) - hide over 2array seq repeat0 [ concat ] action 2array seq [ unclip 1vector swap first append ] action ; + hide f (list-of) ; + +MEMO: list-of* ( items separator -- parser ) + hide t (list-of) ; MEMO: 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] action ; diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor index fd3ca02135..a2c3ebcd1f 100644 --- a/extra/project-euler/019/019.factor +++ b/extra/project-euler/019/019.factor @@ -45,25 +45,20 @@ IN: project-euler.019 ; : end-date ( -- timestamp ) - 2000 12 31 0 0 0 0 make-timestamp ; + 2000 12 31 ; -: (first-days) ( end-date start-date -- ) - 2dup timestamp- 0 >= [ - dup day-of-week , 1 +month (first-days) - ] [ - 2drop - ] if ; - -: first-days ( start-date end-date -- seq ) - [ swap (first-days) ] { } make ; +: first-days ( end-date start-date -- days ) + [ 2dup after=? ] + [ dup 1 months time+ swap day-of-week ] + [ ] unfold 2nip ; PRIVATE> : euler019a ( -- answer ) - start-date end-date first-days [ zero? ] count ; + end-date start-date first-days [ zero? ] count ; ! [ euler019a ] 100 ave-time ! 131 ms run / 3 ms GC ave time - 100 trials diff --git a/extra/random-tester/random-tester.factor b/extra/random-tester/random-tester.factor index 8704687e34..7fb1714860 100755 --- a/extra/random-tester/random-tester.factor +++ b/extra/random-tester/random-tester.factor @@ -1,5 +1,6 @@ USING: compiler continuations io kernel math namespaces -prettyprint quotations random sequences vectors ; +prettyprint quotations random sequences vectors +compiler.units ; USING: random-tester.databank random-tester.safe-words ; IN: random-tester diff --git a/extra/regexp/summary.txt b/extra/regexp/summary.txt new file mode 100644 index 0000000000..aa1e1c27a9 --- /dev/null +++ b/extra/regexp/summary.txt @@ -0,0 +1 @@ +Regular expressions diff --git a/extra/sequences/deep/deep.factor b/extra/sequences/deep/deep.factor index c55647bbcb..27b875bd8f 100644 --- a/extra/sequences/deep/deep.factor +++ b/extra/sequences/deep/deep.factor @@ -34,6 +34,9 @@ IN: sequences.deep : deep-contains? ( obj quot -- ? ) deep-find* nip ; inline +: deep-all? ( obj quot -- ? ) + [ not ] compose deep-contains? not ; inline + : deep-change-each ( obj quot -- ) over branch? [ [ [ call ] keep over >r deep-change-each r> diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 2f50ad1786..d4af66b72f 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -20,8 +20,6 @@ IN: temporary [ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test [ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test -[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test - [ -4 ] [ 1 -4 [ abs ] higher ] unit-test [ 1 ] [ 1 -4 [ abs ] lower ] unit-test @@ -80,4 +78,4 @@ IN: temporary { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test -[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test +[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 1beec90b75..c02932a020 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -18,8 +18,9 @@ IN: sequences.lib : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline -MACRO: nfirst ( n -- ) - [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ; +MACRO: firstn ( n -- ) + [ [ swap nth ] curry + [ keep ] curry ] map concat [ drop ] compose ; : prepare-index ( seq quot -- seq n quot ) >r dup length r> ; inline @@ -182,6 +183,14 @@ PRIVATE> : ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline : ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline +USE: continuations +: ?subseq ( from to seq -- subseq ) + >r >r 0 max r> r> + [ length tuck min >r min r> ] keep subseq ; + +: ?head* ( seq n -- seq/f ) (head) ?subseq ; +: ?tail* ( seq n -- seq/f ) (tail) ?subseq ; + : accumulator ( quot -- quot vec ) V{ } clone [ [ push ] curry compose ] keep ; diff --git a/extra/size-of/size-of.factor b/extra/size-of/size-of.factor new file mode 100644 index 0000000000..df43a9adb2 --- /dev/null +++ b/extra/size-of/size-of.factor @@ -0,0 +1,46 @@ + +USING: kernel namespaces sequences + io io.files io.launcher bake builder.util + accessors vars ; + +IN: size-of + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: headers + +: include-headers ( -- seq ) + headers> [ { "#include <" , ">" } bake to-string ] map ; + +: size-of-c-program ( type -- lines ) + { + "#include " + include-headers + { "main() { printf( \"%i\\n\" , sizeof( " , " ) ) ; }" } + } + bake to-strings ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: c-file ( -- path ) "size-of.c" temp-file ; + +: exe ( -- path ) "size-of" temp-file ; + +: answer ( -- path ) "size-of-answer" temp-file ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: size-of ( type -- n ) + c-file + [ size-of-c-program [ print ] each ] + with-file-writer + + { "gcc" c-file "-o" exe } to-strings + [ "Error compiling generated C program" print ] run-or-bail + + + { exe } to-strings >>arguments + answer >>stdout + >desc run-process drop + + answer eval-file ; \ No newline at end of file diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index c74a6e72fb..f3f90f68b9 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces io io.timeouts kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings -math.parser random system calendar ; +math.parser random system calendar calendar.format ; IN: smtp @@ -114,7 +114,7 @@ LOG: smtp-response DEBUG : extract-email ( recepient -- email ) #! This could be much smarter. - " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ; + " " last-split1 swap or "<" ?head drop ">" ?tail drop ; : message-id ( -- string ) [ diff --git a/extra/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..2f79669497 --- /dev/null +++ b/extra/tools/deploy/deploy-tests.factor @@ -0,0 +1,22 @@ +IN: temporary +USING: tools.test system io.files kernel tools.deploy.config +tools.deploy.backend math ; + +: shake-and-bake + "." resource-path [ + vm + "hello.image" temp-file + rot dup deploy-config make-deploy-image + ] with-directory ; + +[ ] [ "hello-world" shake-and-bake ] unit-test + +[ t ] [ + "hello.image" temp-file file-length 500000 <= +] unit-test + +[ ] [ "hello-ui" shake-and-bake ] unit-test + +[ t ] [ + "hello.image" temp-file file-length 2000000 <= +] unit-test diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index eb1a4af4a7..61d7b9eaed 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -1,36 +1,22 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files io.launcher kernel namespaces sequences -system tools.deploy.backend tools.deploy.config assocs -hashtables prettyprint io.unix.backend cocoa -cocoa.application cocoa.classes cocoa.plists qualified ; -QUALIFIED: unix +USING: io io.files kernel namespaces sequences system +tools.deploy.backend tools.deploy.config assocs hashtables +prettyprint cocoa cocoa.application cocoa.classes cocoa.plists ; IN: tools.deploy.macosx -: touch ( path -- ) - { "touch" } swap add try-process ; - -: rm ( path -- ) - { "rm" "-rf" } swap add try-process ; - : bundle-dir ( -- dir ) vm parent-directory parent-directory ; : copy-bundle-dir ( name dir -- ) - bundle-dir over path+ -rot - >r "Contents" path+ r> path+ copy-directory ; - -: chmod ( path perms -- ) - unix:chmod io-error ; + bundle-dir swap path+ swap "Contents" path+ copy-tree ; : copy-vm ( executable bundle-name -- vm ) - "Contents/MacOS/" path+ swap path+ vm swap - [ copy-file ] keep - [ OCT: 755 chmod ] keep ; + "Contents/MacOS/" path+ swap path+ vm over copy-file ; : copy-fonts ( name -- ) "fonts/" resource-path - swap "Contents/Resources/fonts/" path+ copy-directory ; + swap "Contents/Resources/" path+ copy-tree ; : print-app-plist ( executable bundle-name -- ) [ @@ -75,7 +61,7 @@ M: macosx-deploy-implementation deploy* ( vocab -- ) ".app deploy tool" assert.app "." resource-path cd dup deploy-config [ - bundle-name rm + bundle-name delete-tree [ bundle-name create-app-dir ] keep [ bundle-name deploy.app-image ] keep namespace make-deploy-image diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 16507232ae..0ddc2d5707 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -11,8 +11,16 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show "command-line" init-hooks get delete-at - "mallocs" init-hooks get delete-at - strip-io? [ "io.backend" init-hooks get delete-at ] when ; + "libc" init-hooks get delete-at + deploy-threads? get [ + "threads" init-hooks get delete-at + ] unless + native-io? [ + "io.thread" init-hooks get delete-at + ] unless + strip-io? [ + "io.backend" init-hooks get delete-at + ] when ; : strip-debugger ( -- ) strip-debugger? [ @@ -85,6 +93,7 @@ IN: tools.deploy.shaker { } set-retainstack V{ } set-namestack V{ } set-catchstack + "Saving final image" show [ save-image-and-exit ] call-clear ; diff --git a/extra/tools/deploy/shaker/strip-debugger.factor b/extra/tools/deploy/shaker/strip-debugger.factor index 38f5268c80..5caab02e69 100755 --- a/extra/tools/deploy/shaker/strip-debugger.factor +++ b/extra/tools/deploy/shaker/strip-debugger.factor @@ -1,6 +1,8 @@ -USING: kernel ; +USING: kernel threads threads.private ; IN: debugger : print-error die ; : error. die ; + +M: thread error-in-thread ( error thread -- ) die 2drop ; diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 00dbc2e4df..fb9e0f815a 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-to ; : 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-to ; : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dlls @@ -34,10 +30,11 @@ TUPLE: windows-deploy-implementation ; T{ windows-deploy-implementation } deploy-implementation set-global M: windows-deploy-implementation deploy* - "." resource-path cd - dup deploy-config [ - [ deploy-name get create-exe-dir ] keep - [ deploy-name get image-name ] keep - [ namespace make-deploy-image ] keep - open-in-explorer - ] bind ; + "." resource-path [ + dup deploy-config [ + [ deploy-name get create-exe-dir ] keep + [ deploy-name get image-name ] keep + [ namespace make-deploy-image ] keep + open-in-explorer + ] bind + ] with-directory ; diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 745e3b1842..8a0cd495cf 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -5,9 +5,9 @@ io.launcher system assocs arrays sequences namespaces qualified system math generator.fixup ; IN: tools.disassembler -: in-file "gdb-in.txt" resource-path ; +: in-file "gdb-in.txt" temp-file ; -: out-file "gdb-out.txt" resource-path ; +: out-file "gdb-out.txt" temp-file ; GENERIC: make-disassemble-cmd ( obj -- ) @@ -27,7 +27,7 @@ M: pair make-disassemble-cmd +closed+ +stdin+ set out-file +stdout+ set [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set - ] { } make-assoc run-process drop + ] { } make-assoc try-process out-file file-lines ; : tabs>spaces ( str -- str' ) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 69093f18a6..0ab68f502e 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -48,9 +48,6 @@ 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 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/walker/debug/debug.factor b/extra/tools/walker/debug/debug.factor index cfac9d8367..c8c0ff28a6 100755 --- a/extra/tools/walker/debug/debug.factor +++ b/extra/tools/walker/debug/debug.factor @@ -5,7 +5,7 @@ sequences concurrency.messaging locals continuations threads namespaces namespaces.private ; IN: tools.walker.debug -:: test-walker | quot | +:: test-walker ( quot -- data ) [let | p [ ] s [ f ] c [ f ] | diff --git a/extra/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/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/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index b719556cba..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 ui-wait ] ui-try + [ NSApp do-events ui-wait ] ui-try ] with-autorelease-pool event-loop ] when ; diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor old mode 100644 new mode 100755 index feac09ffc4..5ab3ec28f3 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -298,7 +298,6 @@ CLASS: { [ [ 2drop dup view-dim swap window set-gadget-dim - ui-step ] ui-try ] } diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index cf6d1a9ed9..defd5aa38a 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -88,7 +88,6 @@ TUPLE: repeat-button ; repeat-button H{ { T{ drag } [ button-clicked ] } - { T{ button-down } [ button-clicked ] } } set-gestures : ( label quot -- button ) diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 507dc932a4..def6b99b05 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -256,7 +256,7 @@ M: editor gadget-text* editor-string % ; } at T{ one-line-elt } or ; : drag-direction? ( loc editor -- ? ) - editor-mark* <=> 0 < ; + editor-mark* before? ; : drag-selection-caret ( loc editor element -- loc ) >r [ drag-direction? ] 2keep diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 3db3b9c270..ed3631bca5 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -2,9 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables kernel models math namespaces sequences quotations math.vectors combinators sorting vectors dlists -models threads ; +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 @@ -178,10 +182,6 @@ M: array gadget-text* : forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ; -SYMBOL: ui-thread - -: notify-ui-thread ( -- ) ui-thread get interrupt ; - : layout-queue ( -- queue ) \ layout-queue get ; : layout-later ( gadget -- ) 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:"